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