C4/Context.pm

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