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