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
   9 # under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation; either version 3 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # Koha is distributed in the hope that it will be useful, but
  14 # WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16 # GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  20
  21 =head1 NAME
  22
  23 Koha::Database
  24
  25 =head1 SYNOPSIS
  26
  27   use Koha::Database;
  28   my $schema = Koha::Database->schema();
  29
  30 =head1 FUNCTIONS
  31
  32 =cut
  33
  34 use Modern::Perl;
  35 use DBI;
  36 use Koha::Config;
  37
  38 our $database;
  39
  40 # FIXME: It is useless to have a Koha::Database object since all methods
  41 # below act as class methods
  42 # Koha::Database->new->schema is exactly the same as Koha::Database->schema
  43 # We should use Koha::Database->schema everywhere and remove the `new` method
  44 sub new { bless {}, shift }
  45
  46 sub dbh {
  47     my $config = Koha::Config->get_instance;
  48     my $driver = db_scheme2dbi($config->get('db_scheme'));
  49     my $user = $config->get("user"),
  50     my $pass = $config->get("pass"),
  51     my $dsn = sprintf(
  52         'dbi:%s:database=%s;host=%s;port=%s',
  53         $driver,
  54         $config->get("database"),
  55         $config->get("hostname"),
  56         $config->get("port") || '',
  57     );
  58
  59     my $attr = {
  60         RaiseError => 1,
  61         PrintError => 1,
  62     };
  63
  64     if ($driver eq 'mysql') {
  65         my $tls = $config->get("tls");
  66         if ($tls && $tls eq 'yes') {
  67             $dsn .= sprintf(
  68                 ';mysql_ssl=1;mysql_ssl_client_key=%s;mysql_ssl_client_cert=%s;mysql_ssl_ca_file=%s',
  69                 $config->get('key'),
  70                 $config->get('cert'),
  71                 $config->get('ca'),
  72             );
  73         }
  74
  75         $attr->{mysql_enable_utf8} = 1;
  76     }
  77
  78     my $dbh = DBI->connect($dsn, $user, $pass, $attr);
  79
  80     if ($dbh) {
  81         my @queries;
  82         my $tz = $config->timezone;
  83         $tz = '' if $tz eq 'local';
  84
  85         if ($driver eq 'mysql') {
  86             push @queries, "SET NAMES 'utf8mb4'";
  87             push @queries, qq{SET time_zone = "$tz"} if $tz;
  88             if (   $config->get('strict_sql_modes')
  89                 || ( exists $ENV{_} && $ENV{_} =~ m|prove| )
  90                 || $ENV{KOHA_TESTING}
  91             ) {
  92                 push @queries, q{
  93                     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'
  94                 };
  95             } else {
  96                 push @queries, q{SET sql_mode = 'IGNORE_SPACE,NO_ZERO_IN_DATE,NO_ZERO_DATE,ERROR_FOR_DIVISION_BY_ZERO,NO_ENGINE_SUBSTITUTION'}
  97             }
  98         } elsif ($driver eq 'Pg') {
  99             push @queries, qq{SET TIME ZONE = "$tz"} if $tz;
 100             push @queries, q{set client_encoding = 'UTF8'};
 101         }
 102
 103         foreach my $query (@queries) {
 104             $dbh->do($query);
 105         }
 106     }
 107
 108     return $dbh;
 109 }
 110
 111
 112 # _new_schema
 113 # Internal helper function (not a method!). This creates a new
 114 # database connection from the data given in the current context, and
 115 # returns it.
 116 sub _new_schema {
 117
 118     require Koha::Schema;
 119
 120     my $schema = Koha::Schema->connect({
 121         dbh_maker => \&Koha::Database::dbh,
 122         quote_names => 1,
 123         auto_savepoint => 1,
 124     });
 125
 126     my $dbh = $schema->storage->dbh;
 127     eval {
 128         my $HandleError = $dbh->{HandleError};
 129         if ( $ENV{KOHA_DB_DO_NOT_RAISE_OR_PRINT_ERROR} ) {
 130             $dbh->{HandleError} = sub { return 1 };
 131         }
 132         $dbh->do(q|
 133             SELECT * FROM systempreferences WHERE 1 = 0 |
 134         );
 135         $dbh->{HandleError} = $HandleError;
 136     };
 137
 138     if ( $@ ) {
 139         $dbh->{HandleError} = sub { warn $_[0]; return 1 };
 140     }
 141
 142     return $schema;
 143 }
 144
 145 =head2 schema
 146
 147     $schema = Koha::Database->schema;
 148     $schema = Koha::Database->schema({ new => 1 });
 149
 150 Returns a database handle connected to the Koha database for the
 151 current context. If no connection has yet been made, this method
 152 creates one, and connects to the database.
 153
 154 This database handle is cached for future use: if you call
 155 C<$database-E<gt>schema> twice, you will get the same handle both
 156 times. If you need a second database handle, use C<&new_schema> and
 157 possibly C<&set_schema>.
 158
 159 =cut
 160
 161 sub schema {
 162     my ($class, $params) = @_;
 163
 164     unless ( $params->{new} ) {
 165         return $database->{schema} if defined $database->{schema};
 166     }
 167
 168     $database->{schema} = &_new_schema();
 169     return $database->{schema};
 170 }
 171
 172 =head2 new_schema
 173
 174   $schema = $database->new_schema;
 175
 176 Creates a new connection to the Koha database for the current context,
 177 and returns the database handle (a C<DBI::db> object).
 178
 179 The handle is not saved anywhere: this method is strictly a
 180 convenience function; the point is that it knows which database to
 181 connect to so that the caller doesn't have to know.
 182
 183 =cut
 184
 185 #'
 186 sub new_schema {
 187     my $self = shift;
 188
 189     return &_new_schema();
 190 }
 191
 192 =head2 set_schema
 193
 194   $my_schema = $database->new_schema;
 195   $database->set_schema($my_schema);
 196   ...
 197   $database->restore_schema;
 198
 199 C<&set_schema> and C<&restore_schema> work in a manner analogous to
 200 C<&set_context> and C<&restore_context>.
 201
 202 C<&set_schema> saves the current database handle on a stack, then sets
 203 the current database handle to C<$my_schema>.
 204
 205 C<$my_schema> is assumed to be a good database handle.
 206
 207 =cut
 208
 209 sub set_schema {
 210     my $self       = shift;
 211     my $new_schema = shift;
 212
 213     # Save the current database handle on the handle stack.
 214     # We assume that $new_schema is all good: if the caller wants to
 215     # screw himself by passing an invalid handle, that's fine by
 216     # us.
 217     push @{ $database->{schema_stack} }, $database->{schema};
 218     $database->{schema} = $new_schema;
 219 }
 220
 221 =head2 restore_schema
 222
 223   $database->restore_schema;
 224
 225 Restores the database handle saved by an earlier call to
 226 C<$database-E<gt>set_schema>.
 227
 228 =cut
 229
 230 sub restore_schema {
 231     my $self = shift;
 232
 233     if ( $#{ $database->{schema_stack} } < 0 ) {
 234
 235         # Stack underflow
 236         die "SCHEMA stack underflow";
 237     }
 238
 239     # Pop the old database handle and set it.
 240     $database->{schema} = pop @{ $database->{schema_stack} };
 241
 242     # FIXME - If it is determined that restore_context should
 243     # return something, then this function should, too.
 244 }
 245
 246 =head2 get_schema_cached
 247
 248 =cut
 249
 250 sub get_schema_cached {
 251     return $database->{schema};
 252 }
 253
 254 =head2 flush_schema_cache
 255
 256 =cut
 257
 258 sub flush_schema_cache {
 259     delete $database->{schema};
 260     return 1;
 261 }
 262
 263 =head2 db_scheme2dbi
 264
 265     my $dbd_driver_name = Koha::Database::db_scheme2dbi($scheme);
 266
 267 This routines translates a database type to part of the name
 268 of the appropriate DBD driver to use when establishing a new
 269 database connection.  It recognizes 'mysql' and 'Pg'; if any
 270 other scheme is supplied it defaults to 'mysql'.
 271
 272 =cut
 273
 274 sub db_scheme2dbi {
 275     my $scheme = shift // '';
 276     return $scheme eq 'Pg' ? $scheme : 'mysql';
 277 }
 278
 279 =head2 EXPORT
 280
 281 None by default.
 282
 283
 284 =head1 AUTHOR
 285
 286 Chris Cormack, E<lt>chrisc@catalyst.net.nzE<gt>
 287
 288 =cut
 289
 290 1;
 291
 292 __END__