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