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