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