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