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