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