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             on_connect_do => [
 109                 $encoding_query || (),
 110                 $tz_query || (),
 111                 $sql_mode_query || (),
 112             ]
 113         }
 114     );
 115
 116     my $dbh = $schema->storage->dbh;
 117     eval {
 118         $dbh->{RaiseError} = 1;
 119         if ( $ENV{KOHA_DB_DO_NOT_RAISE_OR_PRINT_ERROR} ) {
 120             $dbh->{RaiseError} = 0;
 121             $dbh->{PrintError} = 0;
 122         }
 123         $dbh->do(q|
 124             SELECT * FROM systempreferences WHERE 1 = 0 |
 125         );
 126         $dbh->{RaiseError} = $RaiseError
 127     };
 128     $dbh->{RaiseError} = 0 if $@;
 129
 130     return $schema;
 131 }
 132
 133 =head2 schema
 134
 135     $schema = $database->schema;
 136
 137 Returns a database handle connected to the Koha database for the
 138 current context. If no connection has yet been made, this method
 139 creates one, and connects to the database.
 140
 141 This database handle is cached for future use: if you call
 142 C<$database-E<gt>schema> twice, you will get the same handle both
 143 times. If you need a second database handle, use C<&new_schema> and
 144 possibly C<&set_schema>.
 145
 146 =cut
 147
 148 sub schema {
 149     my $self = shift;
 150     my $params = shift;
 151
 152     unless ( $params->{new} ) {
 153         return $database->{schema} if defined $database->{schema};
 154     }
 155
 156     $database->{schema} = &_new_schema();
 157     return $database->{schema};
 158 }
 159
 160 =head2 new_schema
 161
 162   $schema = $database->new_schema;
 163
 164 Creates a new connection to the Koha database for the current context,
 165 and returns the database handle (a C<DBI::db> object).
 166
 167 The handle is not saved anywhere: this method is strictly a
 168 convenience function; the point is that it knows which database to
 169 connect to so that the caller doesn't have to know.
 170
 171 =cut
 172
 173 #'
 174 sub new_schema {
 175     my $self = shift;
 176
 177     return &_new_schema();
 178 }
 179
 180 =head2 set_schema
 181
 182   $my_schema = $database->new_schema;
 183   $database->set_schema($my_schema);
 184   ...
 185   $database->restore_schema;
 186
 187 C<&set_schema> and C<&restore_schema> work in a manner analogous to
 188 C<&set_context> and C<&restore_context>.
 189
 190 C<&set_schema> saves the current database handle on a stack, then sets
 191 the current database handle to C<$my_schema>.
 192
 193 C<$my_schema> is assumed to be a good database handle.
 194
 195 =cut
 196
 197 sub set_schema {
 198     my $self       = shift;
 199     my $new_schema = shift;
 200
 201     # Save the current database handle on the handle stack.
 202     # We assume that $new_schema is all good: if the caller wants to
 203     # screw himself by passing an invalid handle, that's fine by
 204     # us.
 205     push @{ $database->{schema_stack} }, $database->{schema};
 206     $database->{schema} = $new_schema;
 207 }
 208
 209 =head2 restore_schema
 210
 211   $database->restore_schema;
 212
 213 Restores the database handle saved by an earlier call to
 214 C<$database-E<gt>set_schema>.
 215
 216 =cut
 217
 218 sub restore_schema {
 219     my $self = shift;
 220
 221     if ( $#{ $database->{schema_stack} } < 0 ) {
 222
 223         # Stack underflow
 224         die "SCHEMA stack underflow";
 225     }
 226
 227     # Pop the old database handle and set it.
 228     $database->{schema} = pop @{ $database->{schema_stack} };
 229
 230     # FIXME - If it is determined that restore_context should
 231     # return something, then this function should, too.
 232 }
 233
 234 =head2 get_schema_cached
 235
 236 =cut
 237
 238 sub get_schema_cached {
 239     return $database->{schema};
 240 }
 241
 242 =head2 flush_schema_cache
 243
 244 =cut
 245
 246 sub flush_schema_cache {
 247     delete $database->{schema};
 248     return 1;
 249 }
 250
 251 =head2 EXPORT
 252
 253 None by default.
 254
 255
 256 =head1 AUTHOR
 257
 258 Chris Cormack, E<lt>chrisc@catalyst.net.nzE<gt>
 259
 260 =cut
 261
 262 1;
 263
 264 __END__