C4/Context.pm

   1 package C4::Context;
   2
   3 # Copyright 2002 Katipo Communications
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  19
  20 use Modern::Perl;
  21
  22 use vars qw($AUTOLOAD $context @context_stack);
  23 BEGIN {
  24         if ($ENV{'HTTP_USER_AGENT'})    {
  25                 require CGI::Carp;
  26         # FIXME for future reference, CGI::Carp doc says
  27         #  "Note that fatalsToBrowser does not work with mod_perl version 2.0 and higher."
  28                 import CGI::Carp qw(fatalsToBrowser);
  29                         sub handle_errors {
  30                             my $msg = shift;
  31                             my $debug_level;
  32                             eval {C4::Context->dbh();};
  33                             if ($@){
  34                                 $debug_level = 1;
  35                             }
  36                             else {
  37                                 $debug_level =  C4::Context->preference("DebugLevel");
  38                             }
  39
  40                 print q(<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
  41                             "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
  42                        <html lang="en" xml:lang="en"  xmlns="http://www.w3.org/1999/xhtml">
  43                        <head><title>Koha Error</title></head>
  44                        <body>
  45                 );
  46                                 if ($debug_level eq "2"){
  47                                         # debug 2 , print extra info too.
  48                                         my %versions = get_versions();
  49
  50                 # a little example table with various version info";
  51                                         print "
  52                                                 <h1>Koha error</h1>
  53                                                 <p>The following fatal error has occurred:</p>
  54                         <pre><code>$msg</code></pre>
  55                                                 <table>
  56                                                 <tr><th>Apache</th><td>  $versions{apacheVersion}</td></tr>
  57                                                 <tr><th>Koha</th><td>    $versions{kohaVersion}</td></tr>
  58                                                 <tr><th>Koha DB</th><td> $versions{kohaDbVersion}</td></tr>
  59                                                 <tr><th>MySQL</th><td>   $versions{mysqlVersion}</td></tr>
  60                                                 <tr><th>OS</th><td>      $versions{osVersion}</td></tr>
  61                                                 <tr><th>Perl</th><td>    $versions{perlVersion}</td></tr>
  62                                                 </table>";
  63
  64                                 } elsif ($debug_level eq "1"){
  65                                         print "
  66                                                 <h1>Koha error</h1>
  67                                                 <p>The following fatal error has occurred:</p>
  68                         <pre><code>$msg</code></pre>";
  69                                 } else {
  70                                         print "<p>production mode - trapped fatal error</p>";
  71                                 }
  72                 print "</body></html>";
  73                         }
  74                 #CGI::Carp::set_message(\&handle_errors);
  75                 ## give a stack backtrace if KOHA_BACKTRACES is set
  76                 ## can't rely on DebugLevel for this, as we're not yet connected
  77                 if ($ENV{KOHA_BACKTRACES}) {
  78                         $main::SIG{__DIE__} = \&CGI::Carp::confess;
  79                 }
  80
  81         # Redefine multi_param if cgi version is < 4.08
  82         # Remove the "CGI::param called in list context" warning in this case
  83         require CGI; # Can't check version without the require.
  84         if (!defined($CGI::VERSION) || $CGI::VERSION < 4.08) {
  85             no warnings 'redefine';
  86             *CGI::multi_param = \&CGI::param;
  87             use warnings 'redefine';
  88             $CGI::LIST_CONTEXT_WARN = 0;
  89         }
  90     }   # else there is no browser to send fatals to!
  91 }
  92
  93 use Carp;
  94 use DateTime::TimeZone;
  95 use Encode;
  96 use File::Spec;
  97 use Module::Load::Conditional qw(can_load);
  98 use POSIX ();
  99 use YAML qw/Load/;
 100 use ZOOM;
 101
 102 use C4::Boolean;
 103 use C4::Debug;
 104 use Koha::Caches;
 105 use Koha::Config::SysPref;
 106 use Koha::Config::SysPrefs;
 107 use Koha::Config;
 108 use Koha;
 109
 110 =head1 NAME
 111
 112 C4::Context - Maintain and manipulate the context of a Koha script
 113
 114 =head1 SYNOPSIS
 115
 116   use C4::Context;
 117
 118   use C4::Context("/path/to/koha-conf.xml");
 119
 120   $config_value = C4::Context->config("config_variable");
 121
 122   $koha_preference = C4::Context->preference("preference");
 123
 124   $db_handle = C4::Context->dbh;
 125
 126   $Zconn = C4::Context->Zconn;
 127
 128 =head1 DESCRIPTION
 129
 130 When a Koha script runs, it makes use of a certain number of things:
 131 configuration settings in F</etc/koha/koha-conf.xml>, a connection to the Koha
 132 databases, and so forth. These things make up the I<context> in which
 133 the script runs.
 134
 135 This module takes care of setting up the context for a script:
 136 figuring out which configuration file to load, and loading it, opening
 137 a connection to the right database, and so forth.
 138
 139 Most scripts will only use one context. They can simply have
 140
 141   use C4::Context;
 142
 143 at the top.
 144
 145 Other scripts may need to use several contexts. For instance, if a
 146 library has two databases, one for a certain collection, and the other
 147 for everything else, it might be necessary for a script to use two
 148 different contexts to search both databases. Such scripts should use
 149 the C<&set_context> and C<&restore_context> functions, below.
 150
 151 By default, C4::Context reads the configuration from
 152 F</etc/koha/koha-conf.xml>. This may be overridden by setting the C<$KOHA_CONF>
 153 environment variable to the pathname of a configuration file to use.
 154
 155 =head1 METHODS
 156
 157 =cut
 158
 159 #'
 160 # In addition to what is said in the POD above, a Context object is a
 161 # reference-to-hash with the following fields:
 162 #
 163 # config
 164 #    A reference-to-hash whose keys and values are the
 165 #    configuration variables and values specified in the config
 166 #    file (/etc/koha/koha-conf.xml).
 167 # dbh
 168 #    A handle to the appropriate database for this context.
 169 # dbh_stack
 170 #    Used by &set_dbh and &restore_dbh to hold other database
 171 #    handles for this context.
 172 # Zconn
 173 #     A connection object for the Zebra server
 174
 175 $context = undef;        # Initially, no context is set
 176 @context_stack = ();        # Initially, no saved contexts
 177
 178 =head2 db_scheme2dbi
 179
 180     my $dbd_driver_name = C4::Context::db_schema2dbi($scheme);
 181
 182 This routines translates a database type to part of the name
 183 of the appropriate DBD driver to use when establishing a new
 184 database connection.  It recognizes 'mysql' and 'Pg'; if any
 185 other scheme is supplied it defaults to 'mysql'.
 186
 187 =cut
 188
 189 sub db_scheme2dbi {
 190     my $scheme = shift // '';
 191     return $scheme eq 'Pg' ? $scheme : 'mysql';
 192 }
 193
 194 sub import {
 195     # Create the default context ($C4::Context::Context)
 196     # the first time the module is called
 197     # (a config file can be optionaly passed)
 198
 199     # default context already exists?
 200     return if $context;
 201
 202     # no ? so load it!
 203     my ($pkg,$config_file) = @_ ;
 204     my $new_ctx = __PACKAGE__->new($config_file);
 205     return unless $new_ctx;
 206
 207     # if successfully loaded, use it by default
 208     $new_ctx->set_context;
 209     1;
 210 }
 211
 212 =head2 new
 213
 214   $context = new C4::Context;
 215   $context = new C4::Context("/path/to/koha-conf.xml");
 216
 217 Allocates a new context. Initializes the context from the specified
 218 file, which defaults to either the file given by the C<$KOHA_CONF>
 219 environment variable, or F</etc/koha/koha-conf.xml>.
 220
 221 It saves the koha-conf.xml values in the declared memcached server(s)
 222 if currently available and uses those values until them expire and
 223 re-reads them.
 224
 225 C<&new> does not set this context as the new default context; for
 226 that, use C<&set_context>.
 227
 228 =cut
 229
 230 #'
 231 # Revision History:
 232 # 2004-08-10 A. Tarallo: Added check if the conf file is not empty
 233 sub new {
 234     my $class = shift;
 235     my $conf_fname = shift;        # Config file to load
 236     my $self = {};
 237
 238     # check that the specified config file exists and is not empty
 239     undef $conf_fname unless
 240         (defined $conf_fname && -s $conf_fname);
 241     # Figure out a good config file to load if none was specified.
 242     unless ( defined $conf_fname ) {
 243         $conf_fname = Koha::Config->guess_koha_conf;
 244         unless ( $conf_fname ) {
 245             warn "unable to locate Koha configuration file koha-conf.xml";
 246             return;
 247         }
 248     }
 249
 250     my $conf_cache = Koha::Caches->get_instance('config');
 251     if ( $conf_cache->cache ) {
 252         $self = $conf_cache->get_from_cache('koha_conf');
 253     }
 254     unless ( $self and %$self ) {
 255         $self = Koha::Config->read_from_file($conf_fname);
 256         if ( $conf_cache->memcached_cache ) {
 257             # FIXME it may be better to use the memcached servers from the config file
 258             # to cache it
 259             $conf_cache->set_in_cache('koha_conf', $self)
 260         }
 261     }
 262     unless ( exists $self->{config} or defined $self->{config} ) {
 263         warn "The config file ($conf_fname) has not been parsed correctly";
 264         return;
 265     }
 266
 267     $self->{"Zconn"} = undef;    # Zebra Connections
 268     $self->{"userenv"} = undef;        # User env
 269     $self->{"activeuser"} = undef;        # current active user
 270     $self->{"shelves"} = undef;
 271     $self->{tz} = undef; # local timezone object
 272
 273     bless $self, $class;
 274     $self->{db_driver} = db_scheme2dbi($self->config('db_scheme'));  # cache database driver
 275     return $self;
 276 }
 277
 278 =head2 set_context
 279
 280   $context = new C4::Context;
 281   $context->set_context();
 282 or
 283   set_context C4::Context $context;
 284
 285   ...
 286   restore_context C4::Context;
 287
 288 In some cases, it might be necessary for a script to use multiple
 289 contexts. C<&set_context> saves the current context on a stack, then
 290 sets the context to C<$context>, which will be used in future
 291 operations. To restore the previous context, use C<&restore_context>.
 292
 293 =cut
 294
 295 #'
 296 sub set_context
 297 {
 298     my $self = shift;
 299     my $new_context;    # The context to set
 300
 301     # Figure out whether this is a class or instance method call.
 302     #
 303     # We're going to make the assumption that control got here
 304     # through valid means, i.e., that the caller used an instance
 305     # or class method call, and that control got here through the
 306     # usual inheritance mechanisms. The caller can, of course,
 307     # break this assumption by playing silly buggers, but that's
 308     # harder to do than doing it properly, and harder to check
 309     # for.
 310     if (ref($self) eq "")
 311     {
 312         # Class method. The new context is the next argument.
 313         $new_context = shift;
 314     } else {
 315         # Instance method. The new context is $self.
 316         $new_context = $self;
 317     }
 318
 319     # Save the old context, if any, on the stack
 320     push @context_stack, $context if defined($context);
 321
 322     # Set the new context
 323     $context = $new_context;
 324 }
 325
 326 =head2 restore_context
 327
 328   &restore_context;
 329
 330 Restores the context set by C<&set_context>.
 331
 332 =cut
 333
 334 #'
 335 sub restore_context
 336 {
 337     my $self = shift;
 338
 339     if ($#context_stack < 0)
 340     {
 341         # Stack underflow.
 342         die "Context stack underflow";
 343     }
 344
 345     # Pop the old context and set it.
 346     $context = pop @context_stack;
 347
 348     # FIXME - Should this return something, like maybe the context
 349     # that was current when this was called?
 350 }
 351
 352 =head2 config
 353
 354   $value = C4::Context->config("config_variable");
 355
 356   $value = C4::Context->config_variable;
 357
 358 Returns the value of a variable specified in the configuration file
 359 from which the current context was created.
 360
 361 The second form is more compact, but of course may conflict with
 362 method names. If there is a configuration variable called "new", then
 363 C<C4::Config-E<gt>new> will not return it.
 364
 365 =cut
 366
 367 sub _common_config {
 368         my $var = shift;
 369         my $term = shift;
 370     return if !defined($context->{$term});
 371        # Presumably $self->{$term} might be
 372        # undefined if the config file given to &new
 373        # didn't exist, and the caller didn't bother
 374        # to check the return value.
 375
 376     # Return the value of the requested config variable
 377     return $context->{$term}->{$var};
 378 }
 379
 380 sub config {
 381         return _common_config($_[1],'config');
 382 }
 383 sub zebraconfig {
 384         return _common_config($_[1],'server');
 385 }
 386 sub ModZebrations {
 387         return _common_config($_[1],'serverinfo');
 388 }
 389
 390 =head2 preference
 391
 392   $sys_preference = C4::Context->preference('some_variable');
 393
 394 Looks up the value of the given system preference in the
 395 systempreferences table of the Koha database, and returns it. If the
 396 variable is not set or does not exist, undef is returned.
 397
 398 In case of an error, this may return 0.
 399
 400 Note: It is impossible to tell the difference between system
 401 preferences which do not exist, and those whose values are set to NULL
 402 with this method.
 403
 404 =cut
 405
 406 my $syspref_cache = Koha::Caches->get_instance('syspref');
 407 my $use_syspref_cache = 1;
 408 sub preference {
 409     my $self = shift;
 410     my $var  = shift;    # The system preference to return
 411
 412     return $ENV{"OVERRIDE_SYSPREF_$var"}
 413         if defined $ENV{"OVERRIDE_SYSPREF_$var"};
 414
 415     $var = lc $var;
 416
 417     if ($use_syspref_cache) {
 418         $syspref_cache = Koha::Caches->get_instance('syspref') unless $syspref_cache;
 419         my $cached_var = $syspref_cache->get_from_cache("syspref_$var");
 420         return $cached_var if defined $cached_var;
 421     }
 422
 423     my $syspref;
 424     eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) };
 425     my $value = $syspref ? $syspref->value() : undef;
 426
 427     if ( $use_syspref_cache ) {
 428         $syspref_cache->set_in_cache("syspref_$var", $value);
 429     }
 430     return $value;
 431 }
 432
 433 sub boolean_preference {
 434     my $self = shift;
 435     my $var = shift;        # The system preference to return
 436     my $it = preference($self, $var);
 437     return defined($it)? C4::Boolean::true_p($it): undef;
 438 }
 439
 440 =head2 yaml_preference
 441
 442 Retrieves the required system preference value, and converts it
 443 from YAML into a Perl data structure. It throws an exception if
 444 the value cannot be properly decoded as YAML.
 445
 446 =cut
 447
 448 sub yaml_preference {
 449     my ( $self, $preference ) = @_;
 450
 451     my $yaml = eval { YAML::Load( $self->preference( $preference ) ); };
 452     if ($@) {
 453         warn "Unable to parse $preference syspref : $@";
 454         return;
 455     }
 456
 457     return $yaml;
 458 }
 459
 460 =head2 enable_syspref_cache
 461
 462   C4::Context->enable_syspref_cache();
 463
 464 Enable the in-memory syspref cache used by C4::Context. This is the
 465 default behavior.
 466
 467 =cut
 468
 469 sub enable_syspref_cache {
 470     my ($self) = @_;
 471     $use_syspref_cache = 1;
 472     # We need to clear the cache to have it up-to-date
 473     $self->clear_syspref_cache();
 474 }
 475
 476 =head2 disable_syspref_cache
 477
 478   C4::Context->disable_syspref_cache();
 479
 480 Disable the in-memory syspref cache used by C4::Context. This should be
 481 used with Plack and other persistent environments.
 482
 483 =cut
 484
 485 sub disable_syspref_cache {
 486     my ($self) = @_;
 487     $use_syspref_cache = 0;
 488     $self->clear_syspref_cache();
 489 }
 490
 491 =head2 clear_syspref_cache
 492
 493   C4::Context->clear_syspref_cache();
 494
 495 cleans the internal cache of sysprefs. Please call this method if
 496 you update the systempreferences table. Otherwise, your new changes
 497 will not be seen by this process.
 498
 499 =cut
 500
 501 sub clear_syspref_cache {
 502     return unless $use_syspref_cache;
 503     $syspref_cache->flush_all;
 504 }
 505
 506 =head2 set_preference
 507
 508   C4::Context->set_preference( $variable, $value, [ $explanation, $type, $options ] );
 509
 510 This updates a preference's value both in the systempreferences table and in
 511 the sysprefs cache. If the optional parameters are provided, then the query
 512 becomes a create. It won't update the parameters (except value) for an existing
 513 preference.
 514
 515 =cut
 516
 517 sub set_preference {
 518     my ( $self, $variable, $value, $explanation, $type, $options ) = @_;
 519
 520     my $variable_case = $variable;
 521     $variable = lc $variable;
 522
 523     my $syspref = Koha::Config::SysPrefs->find($variable);
 524     $type =
 525         $type    ? $type
 526       : $syspref ? $syspref->type
 527       :            undef;
 528
 529     $value = 0 if ( $type && $type eq 'YesNo' && $value eq '' );
 530
 531     # force explicit protocol on OPACBaseURL
 532     if ( $variable eq 'opacbaseurl' && $value && substr( $value, 0, 4 ) !~ /http/ ) {
 533         $value = 'http://' . $value;
 534     }
 535
 536     if ($syspref) {
 537         $syspref->set(
 538             {   ( defined $value ? ( value       => $value )       : () ),
 539                 ( $explanation   ? ( explanation => $explanation ) : () ),
 540                 ( $type          ? ( type        => $type )        : () ),
 541                 ( $options       ? ( options     => $options )     : () ),
 542             }
 543         )->store;
 544     } else {
 545         $syspref = Koha::Config::SysPref->new(
 546             {   variable    => $variable_case,
 547                 value       => $value,
 548                 explanation => $explanation || undef,
 549                 type        => $type,
 550                 options     => $options || undef,
 551             }
 552         )->store();
 553     }
 554
 555     if ( $use_syspref_cache ) {
 556         $syspref_cache->set_in_cache( "syspref_$variable", $value );
 557     }
 558
 559     return $syspref;
 560 }
 561
 562 =head2 delete_preference
 563
 564     C4::Context->delete_preference( $variable );
 565
 566 This deletes a system preference from the database. Returns a true value on
 567 success. Failure means there was an issue with the database, not that there
 568 was no syspref of the name.
 569
 570 =cut
 571
 572 sub delete_preference {
 573     my ( $self, $var ) = @_;
 574
 575     if ( Koha::Config::SysPrefs->find( $var )->delete ) {
 576         if ( $use_syspref_cache ) {
 577             $syspref_cache->clear_from_cache("syspref_$var");
 578         }
 579
 580         return 1;
 581     }
 582     return 0;
 583 }
 584
 585 =head2 Zconn
 586
 587   $Zconn = C4::Context->Zconn
 588
 589 Returns a connection to the Zebra database
 590
 591 C<$self>
 592
 593 C<$server> one of the servers defined in the koha-conf.xml file
 594
 595 C<$async> whether this is a asynchronous connection
 596
 597 =cut
 598
 599 sub Zconn {
 600     my ($self, $server, $async ) = @_;
 601     my $cache_key = join ('::', (map { $_ // '' } ($server, $async )));
 602     if ( (!defined($ENV{GATEWAY_INTERFACE})) && defined($context->{"Zconn"}->{$cache_key}) && (0 == $context->{"Zconn"}->{$cache_key}->errcode()) ) {
 603         # if we are running the script from the commandline, lets try to use the caching
 604         return $context->{"Zconn"}->{$cache_key};
 605     }
 606     $context->{"Zconn"}->{$cache_key}->destroy() if defined($context->{"Zconn"}->{$cache_key}); #destroy old connection before making a new one
 607     $context->{"Zconn"}->{$cache_key} = &_new_Zconn( $server, $async );
 608     return $context->{"Zconn"}->{$cache_key};
 609 }
 610
 611 =head2 _new_Zconn
 612
 613 $context->{"Zconn"} = &_new_Zconn($server,$async);
 614
 615 Internal function. Creates a new database connection from the data given in the current context and returns it.
 616
 617 C<$server> one of the servers defined in the koha-conf.xml file
 618
 619 C<$async> whether this is a asynchronous connection
 620
 621 C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
 622
 623 =cut
 624
 625 sub _new_Zconn {
 626     my ( $server, $async ) = @_;
 627
 628     my $tried=0; # first attempt
 629     my $Zconn; # connection object
 630     my $elementSetName;
 631     my $syntax;
 632
 633     $server //= "biblioserver";
 634
 635     $syntax = 'xml';
 636     $elementSetName = 'marcxml';
 637
 638     my $host = $context->{'listen'}->{$server}->{'content'};
 639     my $user = $context->{"serverinfo"}->{$server}->{"user"};
 640     my $password = $context->{"serverinfo"}->{$server}->{"password"};
 641     eval {
 642         # set options
 643         my $o = new ZOOM::Options();
 644         $o->option(user => $user) if $user && $password;
 645         $o->option(password => $password) if $user && $password;
 646         $o->option(async => 1) if $async;
 647         $o->option(cqlfile=> $context->{"server"}->{$server}->{"cql2rpn"});
 648         $o->option(cclfile=> $context->{"serverinfo"}->{$server}->{"ccl2rpn"});
 649         $o->option(preferredRecordSyntax => $syntax);
 650         $o->option(elementSetName => $elementSetName) if $elementSetName;
 651         $o->option(databaseName => $context->{"config"}->{$server}||"biblios");
 652
 653         # create a new connection object
 654         $Zconn= create ZOOM::Connection($o);
 655
 656         # forge to server
 657         $Zconn->connect($host, 0);
 658
 659         # check for errors and warn
 660         if ($Zconn->errcode() !=0) {
 661             warn "something wrong with the connection: ". $Zconn->errmsg();
 662         }
 663     };
 664     return $Zconn;
 665 }
 666
 667 # _new_dbh
 668 # Internal helper function (not a method!). This creates a new
 669 # database connection from the data given in the current context, and
 670 # returns it.
 671 sub _new_dbh
 672 {
 673
 674     Koha::Database->schema({ new => 1 })->storage->dbh;
 675 }
 676
 677 =head2 dbh
 678
 679   $dbh = C4::Context->dbh;
 680
 681 Returns a database handle connected to the Koha database for the
 682 current context. If no connection has yet been made, this method
 683 creates one, and connects to the database.
 684
 685 This database handle is cached for future use: if you call
 686 C<C4::Context-E<gt>dbh> twice, you will get the same handle both
 687 times. If you need a second database handle, use C<&new_dbh> and
 688 possibly C<&set_dbh>.
 689
 690 =cut
 691
 692 #'
 693 sub dbh
 694 {
 695     my $self = shift;
 696     my $params = shift;
 697
 698     unless ( $params->{new} ) {
 699         return Koha::Database->schema->storage->dbh;
 700     }
 701
 702     return Koha::Database->schema({ new => 1 })->storage->dbh;
 703 }
 704
 705 =head2 new_dbh
 706
 707   $dbh = C4::Context->new_dbh;
 708
 709 Creates a new connection to the Koha database for the current context,
 710 and returns the database handle (a C<DBI::db> object).
 711
 712 The handle is not saved anywhere: this method is strictly a
 713 convenience function; the point is that it knows which database to
 714 connect to so that the caller doesn't have to know.
 715
 716 =cut
 717
 718 #'
 719 sub new_dbh
 720 {
 721     my $self = shift;
 722
 723     return &dbh({ new => 1 });
 724 }
 725
 726 =head2 set_dbh
 727
 728   $my_dbh = C4::Connect->new_dbh;
 729   C4::Connect->set_dbh($my_dbh);
 730   ...
 731   C4::Connect->restore_dbh;
 732
 733 C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
 734 C<&set_context> and C<&restore_context>.
 735
 736 C<&set_dbh> saves the current database handle on a stack, then sets
 737 the current database handle to C<$my_dbh>.
 738
 739 C<$my_dbh> is assumed to be a good database handle.
 740
 741 =cut
 742
 743 #'
 744 sub set_dbh
 745 {
 746     my $self = shift;
 747     my $new_dbh = shift;
 748
 749     # Save the current database handle on the handle stack.
 750     # We assume that $new_dbh is all good: if the caller wants to
 751     # screw himself by passing an invalid handle, that's fine by
 752     # us.
 753     push @{$context->{"dbh_stack"}}, $context->{"dbh"};
 754     $context->{"dbh"} = $new_dbh;
 755 }
 756
 757 =head2 restore_dbh
 758
 759   C4::Context->restore_dbh;
 760
 761 Restores the database handle saved by an earlier call to
 762 C<C4::Context-E<gt>set_dbh>.
 763
 764 =cut
 765
 766 #'
 767 sub restore_dbh
 768 {
 769     my $self = shift;
 770
 771     if ($#{$context->{"dbh_stack"}} < 0)
 772     {
 773         # Stack underflow
 774         die "DBH stack underflow";
 775     }
 776
 777     # Pop the old database handle and set it.
 778     $context->{"dbh"} = pop @{$context->{"dbh_stack"}};
 779
 780     # FIXME - If it is determined that restore_context should
 781     # return something, then this function should, too.
 782 }
 783
 784 =head2 userenv
 785
 786   C4::Context->userenv;
 787
 788 Retrieves a hash for user environment variables.
 789
 790 This hash shall be cached for future use: if you call
 791 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
 792
 793 =cut
 794
 795 #'
 796 sub userenv {
 797     my $var = $context->{"activeuser"};
 798     if (defined $var and defined $context->{"userenv"}->{$var}) {
 799         return $context->{"userenv"}->{$var};
 800     } else {
 801         return;
 802     }
 803 }
 804
 805 =head2 set_userenv
 806
 807   C4::Context->set_userenv($usernum, $userid, $usercnum,
 808                            $userfirstname, $usersurname,
 809                            $userbranch, $branchname, $userflags,
 810                            $emailaddress, $shibboleth);
 811
 812 Establish a hash of user environment variables.
 813
 814 set_userenv is called in Auth.pm
 815
 816 =cut
 817
 818 #'
 819 sub set_userenv {
 820     shift @_;
 821     my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $shibboleth)=
 822     map { Encode::is_utf8( $_ ) ? $_ : Encode::decode('UTF-8', $_) } # CGI::Session doesn't handle utf-8, so we decode it here
 823     @_;
 824     my $var=$context->{"activeuser"} || '';
 825     my $cell = {
 826         "number"     => $usernum,
 827         "id"         => $userid,
 828         "cardnumber" => $usercnum,
 829         "firstname"  => $userfirstname,
 830         "surname"    => $usersurname,
 831         #possibly a law problem
 832         "branch"     => $userbranch,
 833         "branchname" => $branchname,
 834         "flags"      => $userflags,
 835         "emailaddress"     => $emailaddress,
 836         "shibboleth" => $shibboleth,
 837     };
 838     $context->{userenv}->{$var} = $cell;
 839     return $cell;
 840 }
 841
 842 sub set_shelves_userenv {
 843         my ($type, $shelves) = @_ or return;
 844         my $activeuser = $context->{activeuser} or return;
 845         $context->{userenv}->{$activeuser}->{barshelves} = $shelves if $type eq 'bar';
 846         $context->{userenv}->{$activeuser}->{pubshelves} = $shelves if $type eq 'pub';
 847         $context->{userenv}->{$activeuser}->{totshelves} = $shelves if $type eq 'tot';
 848 }
 849
 850 sub get_shelves_userenv {
 851         my $active;
 852         unless ($active = $context->{userenv}->{$context->{activeuser}}) {
 853                 $debug and warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}";
 854                 return;
 855         }
 856         my $totshelves = $active->{totshelves} or undef;
 857         my $pubshelves = $active->{pubshelves} or undef;
 858         my $barshelves = $active->{barshelves} or undef;
 859         return ($totshelves, $pubshelves, $barshelves);
 860 }
 861
 862 =head2 _new_userenv
 863
 864   C4::Context->_new_userenv($session);  # FIXME: This calling style is wrong for what looks like an _internal function
 865
 866 Builds a hash for user environment variables.
 867
 868 This hash shall be cached for future use: if you call
 869 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
 870
 871 _new_userenv is called in Auth.pm
 872
 873 =cut
 874
 875 #'
 876 sub _new_userenv
 877 {
 878     shift;  # Useless except it compensates for bad calling style
 879     my ($sessionID)= @_;
 880      $context->{"activeuser"}=$sessionID;
 881 }
 882
 883 =head2 _unset_userenv
 884
 885   C4::Context->_unset_userenv;
 886
 887 Destroys the hash for activeuser user environment variables.
 888
 889 =cut
 890
 891 #'
 892
 893 sub _unset_userenv
 894 {
 895     my ($sessionID)= @_;
 896     undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
 897 }
 898
 899
 900 =head2 get_versions
 901
 902   C4::Context->get_versions
 903
 904 Gets various version info, for core Koha packages, Currently called from carp handle_errors() sub, to send to browser if 'DebugLevel' syspref is set to '2'.
 905
 906 =cut
 907
 908 #'
 909
 910 # A little example sub to show more debugging info for CGI::Carp
 911 sub get_versions {
 912     my %versions;
 913     $versions{kohaVersion}  = Koha::version();
 914     $versions{kohaDbVersion} = C4::Context->preference('version');
 915     $versions{osVersion} = join(" ", POSIX::uname());
 916     $versions{perlVersion} = $];
 917     {
 918         no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
 919         $versions{mysqlVersion}  = `mysql -V`;
 920         $versions{apacheVersion} = (`apache2ctl -v`)[0];
 921         $versions{apacheVersion} = `httpd -v`             unless  $versions{apacheVersion} ;
 922         $versions{apacheVersion} = `httpd2 -v`            unless  $versions{apacheVersion} ;
 923         $versions{apacheVersion} = `apache2 -v`           unless  $versions{apacheVersion} ;
 924         $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless  $versions{apacheVersion} ;
 925     }
 926     return %versions;
 927 }
 928
 929 =head2 timezone
 930
 931   my $C4::Context->timzone
 932
 933   Returns a timezone code for the instance of Koha
 934
 935 =cut
 936
 937 sub timezone {
 938     my $self = shift;
 939
 940     my $timezone = C4::Context->config('timezone') || $ENV{TZ} || 'local';
 941     if ( !DateTime::TimeZone->is_valid_name( $timezone ) ) {
 942         warn "Invalid timezone in koha-conf.xml ($timezone)";
 943         $timezone = 'local';
 944     }
 945
 946     return $timezone;
 947 }
 948
 949 =head2 tz
 950
 951   C4::Context->tz
 952
 953   Returns a DateTime::TimeZone object for the system timezone
 954
 955 =cut
 956
 957 sub tz {
 958     my $self = shift;
 959     if (!defined $context->{tz}) {
 960         my $timezone = $self->timezone;
 961         $context->{tz} = DateTime::TimeZone->new(name => $timezone);
 962     }
 963     return $context->{tz};
 964 }
 965
 966
 967 =head2 IsSuperLibrarian
 968
 969     C4::Context->IsSuperLibrarian();
 970
 971 =cut
 972
 973 sub IsSuperLibrarian {
 974     my $userenv = C4::Context->userenv;
 975
 976     unless ( $userenv and exists $userenv->{flags} ) {
 977         # If we reach this without a user environment,
 978         # assume that we're running from a command-line script,
 979         # and act as a superlibrarian.
 980         carp("C4::Context->userenv not defined!");
 981         return 1;
 982     }
 983
 984     return ($userenv->{flags}//0) % 2;
 985 }
 986
 987 =head2 interface
 988
 989 Sets the current interface for later retrieval in any Perl module
 990
 991     C4::Context->interface('opac');
 992     C4::Context->interface('intranet');
 993     my $interface = C4::Context->interface;
 994
 995 =cut
 996
 997 sub interface {
 998     my ($class, $interface) = @_;
 999
1000     if (defined $interface) {
1001         $interface = lc $interface;
1002         if (   $interface eq 'api'
1003             || $interface eq 'opac'
1004             || $interface eq 'intranet'
1005             || $interface eq 'sip'
1006             || $interface eq 'cron'
1007             || $interface eq 'commandline' )
1008         {
1009             $context->{interface} = $interface;
1010         } else {
1011             warn "invalid interface : '$interface'";
1012         }
1013     }
1014
1015     return $context->{interface} // 'opac';
1016 }
1017
1018 # always returns a string for OK comparison via "eq" or "ne"
1019 sub mybranch {
1020     C4::Context->userenv           or return '';
1021     return C4::Context->userenv->{branch} || '';
1022 }
1023
1024 =head2 only_my_library
1025
1026     my $test = C4::Context->only_my_library;
1027
1028     Returns true if you enabled IndependentBranches and the current user
1029     does not have superlibrarian permissions.
1030
1031 =cut
1032
1033 sub only_my_library {
1034     return
1035          C4::Context->preference('IndependentBranches')
1036       && C4::Context->userenv
1037       && !C4::Context->IsSuperLibrarian()
1038       && C4::Context->userenv->{branch};
1039 }
1040
1041 =head3 temporary_directory
1042
1043 Returns root directory for temporary storage
1044
1045 =cut
1046
1047 sub temporary_directory {
1048     my ( $class ) = @_;
1049     return C4::Context->config('tmp_path') || File::Spec->tmpdir;
1050 }
1051
1052 =head3 set_remote_address
1053
1054 set_remote_address should be called at the beginning of every script
1055 that is *not* running under plack in order to the REMOTE_ADDR environment
1056 variable to be set correctly.
1057
1058 =cut
1059
1060 sub set_remote_address {
1061     if ( C4::Context->config('koha_trusted_proxies') ) {
1062         require CGI;
1063         my $header = CGI->http('HTTP_X_FORWARDED_FOR');
1064
1065         if ($header) {
1066             require Koha::Middleware::RealIP;
1067             $ENV{REMOTE_ADDR} = Koha::Middleware::RealIP::get_real_ip( $ENV{REMOTE_ADDR}, $header );
1068         }
1069     }
1070 }
1071
1072 1;
1073
1074 =head3 needs_install
1075
1076     if ( $context->needs_install ) { ... }
1077
1078 This method returns a boolean representing the install status of the Koha instance.
1079
1080 =cut
1081
1082 sub needs_install {
1083     my ($self) = @_;
1084     return ($self->preference('Version')) ? 0 : 1;
1085 }
1086
1087 __END__
1088
1089 =head1 ENVIRONMENT
1090
1091 =head2 C<KOHA_CONF>
1092
1093 Specifies the configuration file to read.
1094
1095 =head1 SEE ALSO
1096
1097 XML::Simple
1098
1099 =head1 AUTHORS
1100
1101 Andrew Arensburger <arensb at ooblick dot com>
1102
1103 Joshua Ferraro <jmf at liblime dot com>
1104