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