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
   9 # under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation; either version 3 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # Koha is distributed in the hope that it will be useful, but
  14 # WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16 # GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  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, $sql_mode_query );
  73     my $tz = C4::Context->timezone;
  74     $tz = q{} if ( $tz eq 'local' );
  75     if ( $db_driver eq 'mysql' ) {
  76         %encoding_attr = ( mysql_enable_utf8 => 1 );
  77         $encoding_query = "set NAMES 'utf8mb4'";
  78         $tz_query = qq(SET time_zone = "$tz") if $tz;
  79         if (   C4::Context->config('strict_sql_modes')
  80             || ( exists $ENV{_} && $ENV{_} =~ m|prove| )
  81             || $ENV{KOHA_TESTING}
  82         ) {
  83             $sql_mode_query = q{SET sql_mode = 'ONLY_FULL_GROUP_BY,STRICT_TRANS_TABLES,NO_ZERO_IN_DATE,NO_ZERO_DATE,ERROR_FOR_DIVISION_BY_ZERO,NO_ENGINE_SUBSTITUTION'};
  84         } else {
  85             $sql_mode_query = q{SET sql_mode = 'IGNORE_SPACE,NO_ZERO_IN_DATE,NO_ZERO_DATE,ERROR_FOR_DIVISION_BY_ZERO,NO_ENGINE_SUBSTITUTION'};
  86         }
  87     }
  88     elsif ( $db_driver eq 'Pg' ) {
  89         $encoding_query = "set client_encoding = 'UTF8';";
  90         $tz_query = qq(SET TIME ZONE = "$tz") if $tz;
  91     }
  92
  93     my $RaiseError = (
  94            $ENV{DEBUG}
  95         || $ENV{KOHA_TESTING}
  96         ||  exists $ENV{_} && $ENV{_} =~ m|prove|
  97     ) ? 1 : 0;
  98     my $schema = Koha::Schema->connect(
  99         {
 100             dsn => "dbi:$db_driver:database=$db_name;host=$db_host;port=$db_port".($tls_options? $tls_options : ""),
 101             user => $db_user,
 102             password => $db_passwd,
 103             %encoding_attr,
 104             RaiseError => $RaiseError,
 105             PrintError => 1,
 106             unsafe => !$RaiseError,
 107             quote_names => 1,
 108             auto_savepoint => 1,
 109             on_connect_do => [
 110                 $encoding_query || (),
 111                 $tz_query || (),
 112                 $sql_mode_query || (),
 113             ]
 114         }
 115     );
 116
 117     my $dbh = $schema->storage->dbh;
 118     eval {
 119         $dbh->{RaiseError} = 1;
 120         if ( $ENV{KOHA_DB_DO_NOT_RAISE_OR_PRINT_ERROR} ) {
 121             $dbh->{RaiseError} = 0;
 122             $dbh->{PrintError} = 0;
 123         }
 124         $dbh->do(q|
 125             SELECT * FROM systempreferences WHERE 1 = 0 |
 126         );
 127         $dbh->{RaiseError} = $RaiseError
 128     };
 129     $dbh->{RaiseError} = 0 if $@;
 130
 131     return $schema;
 132 }
 133
 134 =head2 schema
 135
 136     $schema = $database->schema;
 137
 138 Returns a database handle connected to the Koha database for the
 139 current context. If no connection has yet been made, this method
 140 creates one, and connects to the database.
 141
 142 This database handle is cached for future use: if you call
 143 C<$database-E<gt>schema> twice, you will get the same handle both
 144 times. If you need a second database handle, use C<&new_schema> and
 145 possibly C<&set_schema>.
 146
 147 =cut
 148
 149 sub schema {
 150     my $self = shift;
 151     my $params = shift;
 152
 153     unless ( $params->{new} ) {
 154         return $database->{schema} if defined $database->{schema};
 155     }
 156
 157     $database->{schema} = &_new_schema();
 158     return $database->{schema};
 159 }
 160
 161 =head2 new_schema
 162
 163   $schema = $database->new_schema;
 164
 165 Creates a new connection to the Koha database for the current context,
 166 and returns the database handle (a C<DBI::db> object).
 167
 168 The handle is not saved anywhere: this method is strictly a
 169 convenience function; the point is that it knows which database to
 170 connect to so that the caller doesn't have to know.
 171
 172 =cut
 173
 174 #'
 175 sub new_schema {
 176     my $self = shift;
 177
 178     return &_new_schema();
 179 }
 180
 181 =head2 set_schema
 182
 183   $my_schema = $database->new_schema;
 184   $database->set_schema($my_schema);
 185   ...
 186   $database->restore_schema;
 187
 188 C<&set_schema> and C<&restore_schema> work in a manner analogous to
 189 C<&set_context> and C<&restore_context>.
 190
 191 C<&set_schema> saves the current database handle on a stack, then sets
 192 the current database handle to C<$my_schema>.
 193
 194 C<$my_schema> is assumed to be a good database handle.
 195
 196 =cut
 197
 198 sub set_schema {
 199     my $self       = shift;
 200     my $new_schema = shift;
 201
 202     # Save the current database handle on the handle stack.
 203     # We assume that $new_schema is all good: if the caller wants to
 204     # screw himself by passing an invalid handle, that's fine by
 205     # us.
 206     push @{ $database->{schema_stack} }, $database->{schema};
 207     $database->{schema} = $new_schema;
 208 }
 209
 210 =head2 restore_schema
 211
 212   $database->restore_schema;
 213
 214 Restores the database handle saved by an earlier call to
 215 C<$database-E<gt>set_schema>.
 216
 217 =cut
 218
 219 sub restore_schema {
 220     my $self = shift;
 221
 222     if ( $#{ $database->{schema_stack} } < 0 ) {
 223
 224         # Stack underflow
 225         die "SCHEMA stack underflow";
 226     }
 227
 228     # Pop the old database handle and set it.
 229     $database->{schema} = pop @{ $database->{schema_stack} };
 230
 231     # FIXME - If it is determined that restore_context should
 232     # return something, then this function should, too.
 233 }
 234
 235 =head2 get_schema_cached
 236
 237 =cut
 238
 239 sub get_schema_cached {
 240     return $database->{schema};
 241 }
 242
 243 =head2 flush_schema_cache
 244
 245 =cut
 246
 247 sub flush_schema_cache {
 248     delete $database->{schema};
 249     return 1;
 250 }
 251
 252 =head2 EXPORT
 253
 254 None by default.
 255
 256
 257 =head1 AUTHOR
 258
 259 Chris Cormack, E<lt>chrisc@catalyst.net.nzE<gt>
 260
 261 =cut
 262
 263 1;
 264
 265 __END__