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