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