Koha/Database.pm

   1 package Koha::Database;
   2
   3 # Copyright 2013 Catalyst IT
   4 # chrisc@catalyst.net.nz
   5 #
   6 # This file is part of Koha.
   7 #
   8 # Koha is free software; you can redistribute it and/or modify it under the
   9 # terms of the GNU General Public License as published by the Free Software
  10 # Foundation; either version 3 of the License, or (at your option) any later
  11 # version.
  12 #
  13 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  14 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  15 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License along
  18 # with Koha; if not, write to the Free Software Foundation, Inc.,
  19 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  20
  21 =head1 NAME
  22
  23 Koha::Database
  24
  25 =head1 SYNOPSIS
  26
  27   use Koha::Database;
  28   my $database = Koha::Database->new();
  29   my $schema = $database->schema();
  30
  31 =head1 FUNCTIONS
  32
  33 =cut
  34
  35 use Modern::Perl;
  36 use Carp;
  37 use C4::Context;
  38 use base qw(Class::Accessor);
  39
  40 use vars qw($database);
  41
  42 __PACKAGE__->mk_accessors(qw( ));
  43
  44 # _new_schema
  45 # Internal helper function (not a method!). This creates a new
  46 # database connection from the data given in the current context, and
  47 # returns it.
  48 sub _new_schema {
  49
  50     require Koha::Schema;
  51
  52     my $context = C4::Context->new();
  53
  54     my $db_driver = $context->{db_driver};
  55
  56     my $db_name   = $context->config("database");
  57     my $db_host   = $context->config("hostname");
  58     my $db_port   = $context->config("port") || '';
  59     my $db_user   = $context->config("user");
  60     my $db_passwd = $context->config("pass");
  61     my $tls = $context->config("tls");
  62     my $tls_options;
  63     if( $tls && $tls eq 'yes' ) {
  64         my $ca = $context->config('ca');
  65         my $cert = $context->config('cert');
  66         my $key = $context->config('key');
  67         $tls_options = ";mysql_ssl=1;mysql_ssl_client_key=".$key.";mysql_ssl_client_cert=".$cert.";mysql_ssl_ca_file=".$ca;
  68     }
  69
  70
  71
  72     my ( %encoding_attr, $encoding_query, $tz_query );
  73     my $tz = $ENV{TZ};
  74     if ( $db_driver eq 'mysql' ) {
  75         %encoding_attr = ( mysql_enable_utf8 => 1 );
  76         $encoding_query = "set NAMES 'utf8'";
  77         $tz_query = qq(SET time_zone = "$tz") if $tz;
  78     }
  79     elsif ( $db_driver eq 'Pg' ) {
  80         $encoding_query = "set client_encoding = 'UTF8';";
  81         $tz_query = qq(SET TIME ZONE = "$tz") if $tz;
  82     }
  83     my $schema = Koha::Schema->connect(
  84         {
  85             dsn => "dbi:$db_driver:database=$db_name;host=$db_host;port=$db_port".($tls_options? $tls_options : ""),
  86             user => $db_user,
  87             password => $db_passwd,
  88             %encoding_attr,
  89             RaiseError => $ENV{DEBUG} ? 1 : 0,
  90             PrintError => 1,
  91             unsafe => 1,
  92             quote_names => 1,
  93             on_connect_do => [
  94                 $encoding_query || (),
  95                 $tz_query || (),
  96             ]
  97         }
  98     );
  99
 100     my $dbh = $schema->storage->dbh;
 101     eval {
 102         $dbh->{RaiseError} = 1;
 103         if ( $ENV{KOHA_DB_DO_NOT_RAISE_OR_PRINT_ERROR} ) {
 104             $dbh->{RaiseError} = 0;
 105             $dbh->{PrintError} = 0;
 106         }
 107         $dbh->do(q|
 108             SELECT * FROM systempreferences WHERE 1 = 0 |
 109         );
 110         $dbh->{RaiseError} = $ENV{DEBUG} ? 1 : 0;
 111     };
 112     $dbh->{RaiseError} = 0 if $@;
 113
 114     return $schema;
 115 }
 116
 117 =head2 schema
 118
 119     $schema = $database->schema;
 120
 121 Returns a database handle connected to the Koha database for the
 122 current context. If no connection has yet been made, this method
 123 creates one, and connects to the database.
 124
 125 This database handle is cached for future use: if you call
 126 C<$database-E<gt>schema> twice, you will get the same handle both
 127 times. If you need a second database handle, use C<&new_schema> and
 128 possibly C<&set_schema>.
 129
 130 =cut
 131
 132 sub schema {
 133     my $self = shift;
 134     my $params = shift;
 135
 136     unless ( $params->{new} ) {
 137         return $database->{schema} if defined $database->{schema};
 138     }
 139
 140     $database->{schema} = &_new_schema();
 141     return $database->{schema};
 142 }
 143
 144 =head2 new_schema
 145
 146   $schema = $database->new_schema;
 147
 148 Creates a new connection to the Koha database for the current context,
 149 and returns the database handle (a C<DBI::db> object).
 150
 151 The handle is not saved anywhere: this method is strictly a
 152 convenience function; the point is that it knows which database to
 153 connect to so that the caller doesn't have to know.
 154
 155 =cut
 156
 157 #'
 158 sub new_schema {
 159     my $self = shift;
 160
 161     return &_new_schema();
 162 }
 163
 164 =head2 set_schema
 165
 166   $my_schema = $database->new_schema;
 167   $database->set_schema($my_schema);
 168   ...
 169   $database->restore_schema;
 170
 171 C<&set_schema> and C<&restore_schema> work in a manner analogous to
 172 C<&set_context> and C<&restore_context>.
 173
 174 C<&set_schema> saves the current database handle on a stack, then sets
 175 the current database handle to C<$my_schema>.
 176
 177 C<$my_schema> is assumed to be a good database handle.
 178
 179 =cut
 180
 181 sub set_schema {
 182     my $self       = shift;
 183     my $new_schema = shift;
 184
 185     # Save the current database handle on the handle stack.
 186     # We assume that $new_schema is all good: if the caller wants to
 187     # screw himself by passing an invalid handle, that's fine by
 188     # us.
 189     push @{ $database->{schema_stack} }, $database->{schema};
 190     $database->{schema} = $new_schema;
 191 }
 192
 193 =head2 restore_schema
 194
 195   $database->restore_schema;
 196
 197 Restores the database handle saved by an earlier call to
 198 C<$database-E<gt>set_schema>.
 199
 200 =cut
 201
 202 sub restore_schema {
 203     my $self = shift;
 204
 205     if ( $#{ $database->{schema_stack} } < 0 ) {
 206
 207         # Stack underflow
 208         die "SCHEMA stack underflow";
 209     }
 210
 211     # Pop the old database handle and set it.
 212     $database->{schema} = pop @{ $database->{schema_stack} };
 213
 214     # FIXME - If it is determined that restore_context should
 215     # return something, then this function should, too.
 216 }
 217
 218 =head2 get_schema_cached
 219
 220 =cut
 221
 222 sub get_schema_cached {
 223     return $database->{schema};
 224 }
 225
 226 =head2 flush_schema_cache
 227
 228 =cut
 229
 230 sub flush_schema_cache {
 231     delete $database->{schema};
 232     return 1;
 233 }
 234
 235 =head2 EXPORT
 236
 237 None by default.
 238
 239
 240 =head1 AUTHOR
 241
 242 Chris Cormack, E<lt>chrisc@catalyst.net.nzE<gt>
 243
 244 =cut
 245
 246 1;
 247
 248 __END__