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