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