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