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