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 Encode;
  94 use ZOOM;
  95 use Koha::Caches;
  96 use POSIX ();
  97 use DateTime::TimeZone;
  98 use Module::Load::Conditional qw(can_load);
  99 use Carp;
 100
 101 use C4::Boolean;
 102 use C4::Debug;
 103 use Koha;
 104 use Koha::Config;
 105 use Koha::Config::SysPref;
 106 use Koha::Config::SysPrefs;
 107
 108 =head1 NAME
 109
 110 C4::Context - Maintain and manipulate the context of a Koha script
 111
 112 =head1 SYNOPSIS
 113
 114   use C4::Context;
 115
 116   use C4::Context("/path/to/koha-conf.xml");
 117
 118   $config_value = C4::Context->config("config_variable");
 119
 120   $koha_preference = C4::Context->preference("preference");
 121
 122   $db_handle = C4::Context->dbh;
 123
 124   $Zconn = C4::Context->Zconn;
 125
 126 =head1 DESCRIPTION
 127
 128 When a Koha script runs, it makes use of a certain number of things:
 129 configuration settings in F</etc/koha/koha-conf.xml>, a connection to the Koha
 130 databases, and so forth. These things make up the I<context> in which
 131 the script runs.
 132
 133 This module takes care of setting up the context for a script:
 134 figuring out which configuration file to load, and loading it, opening
 135 a connection to the right database, and so forth.
 136
 137 Most scripts will only use one context. They can simply have
 138
 139   use C4::Context;
 140
 141 at the top.
 142
 143 Other scripts may need to use several contexts. For instance, if a
 144 library has two databases, one for a certain collection, and the other
 145 for everything else, it might be necessary for a script to use two
 146 different contexts to search both databases. Such scripts should use
 147 the C<&set_context> and C<&restore_context> functions, below.
 148
 149 By default, C4::Context reads the configuration from
 150 F</etc/koha/koha-conf.xml>. This may be overridden by setting the C<$KOHA_CONF>
 151 environment variable to the pathname of a configuration file to use.
 152
 153 =head1 METHODS
 154
 155 =cut
 156
 157 #'
 158 # In addition to what is said in the POD above, a Context object is a
 159 # reference-to-hash with the following fields:
 160 #
 161 # config
 162 #    A reference-to-hash whose keys and values are the
 163 #    configuration variables and values specified in the config
 164 #    file (/etc/koha/koha-conf.xml).
 165 # dbh
 166 #    A handle to the appropriate database for this context.
 167 # dbh_stack
 168 #    Used by &set_dbh and &restore_dbh to hold other database
 169 #    handles for this context.
 170 # Zconn
 171 #     A connection object for the Zebra server
 172
 173 $context = undef;        # Initially, no context is set
 174 @context_stack = ();        # Initially, no saved contexts
 175
 176 =head2 db_scheme2dbi
 177
 178     my $dbd_driver_name = C4::Context::db_schema2dbi($scheme);
 179
 180 This routines translates a database type to part of the name
 181 of the appropriate DBD driver to use when establishing a new
 182 database connection.  It recognizes 'mysql' and 'Pg'; if any
 183 other scheme is supplied it defaults to 'mysql'.
 184
 185 =cut
 186
 187 sub db_scheme2dbi {
 188     my $scheme = shift // '';
 189     return $scheme eq 'Pg' ? $scheme : 'mysql';
 190 }
 191
 192 sub import {
 193     # Create the default context ($C4::Context::Context)
 194     # the first time the module is called
 195     # (a config file can be optionaly passed)
 196
 197     # default context already exists?
 198     return if $context;
 199
 200     # no ? so load it!
 201     my ($pkg,$config_file) = @_ ;
 202     my $new_ctx = __PACKAGE__->new($config_file);
 203     return unless $new_ctx;
 204
 205     # if successfully loaded, use it by default
 206     $new_ctx->set_context;
 207     1;
 208 }
 209
 210 =head2 new
 211
 212   $context = new C4::Context;
 213   $context = new C4::Context("/path/to/koha-conf.xml");
 214
 215 Allocates a new context. Initializes the context from the specified
 216 file, which defaults to either the file given by the C<$KOHA_CONF>
 217 environment variable, or F</etc/koha/koha-conf.xml>.
 218
 219 It saves the koha-conf.xml values in the declared memcached server(s)
 220 if currently available and uses those values until them expire and
 221 re-reads them.
 222
 223 C<&new> does not set this context as the new default context; for
 224 that, use C<&set_context>.
 225
 226 =cut
 227
 228 #'
 229 # Revision History:
 230 # 2004-08-10 A. Tarallo: Added check if the conf file is not empty
 231 sub new {
 232     my $class = shift;
 233     my $conf_fname = shift;        # Config file to load
 234     my $self = {};
 235
 236     # check that the specified config file exists and is not empty
 237     undef $conf_fname unless
 238         (defined $conf_fname && -s $conf_fname);
 239     # Figure out a good config file to load if none was specified.
 240     unless ( defined $conf_fname ) {
 241         $conf_fname = Koha::Config->guess_koha_conf;
 242         unless ( $conf_fname ) {
 243             warn "unable to locate Koha configuration file koha-conf.xml";
 244             return;
 245         }
 246     }
 247
 248     my $conf_cache = Koha::Caches->get_instance('config');
 249     my $config_from_cache;
 250     if ( $conf_cache->cache ) {
 251         $self = $conf_cache->get_from_cache('koha_conf');
 252     }
 253     unless ( $self and %$self ) {
 254         $self = Koha::Config->read_from_file($conf_fname);
 255         if ( $conf_cache->memcached_cache ) {
 256             # FIXME it may be better to use the memcached servers from the config file
 257             # to cache it
 258             $conf_cache->set_in_cache('koha_conf', $self)
 259         }
 260     }
 261     unless ( exists $self->{config} or defined $self->{config} ) {
 262         warn "The config file ($conf_fname) has not been parsed correctly";
 263         return;
 264     }
 265
 266     $self->{"Zconn"} = undef;    # Zebra Connections
 267     $self->{"userenv"} = undef;        # User env
 268     $self->{"activeuser"} = undef;        # current active user
 269     $self->{"shelves"} = undef;
 270     $self->{tz} = undef; # local timezone object
 271
 272     bless $self, $class;
 273     $self->{db_driver} = db_scheme2dbi($self->config('db_scheme'));  # cache database driver
 274     return $self;
 275 }
 276
 277 =head2 set_context
 278
 279   $context = new C4::Context;
 280   $context->set_context();
 281 or
 282   set_context C4::Context $context;
 283
 284   ...
 285   restore_context C4::Context;
 286
 287 In some cases, it might be necessary for a script to use multiple
 288 contexts. C<&set_context> saves the current context on a stack, then
 289 sets the context to C<$context>, which will be used in future
 290 operations. To restore the previous context, use C<&restore_context>.
 291
 292 =cut
 293
 294 #'
 295 sub set_context
 296 {
 297     my $self = shift;
 298     my $new_context;    # The context to set
 299
 300     # Figure out whether this is a class or instance method call.
 301     #
 302     # We're going to make the assumption that control got here
 303     # through valid means, i.e., that the caller used an instance
 304     # or class method call, and that control got here through the
 305     # usual inheritance mechanisms. The caller can, of course,
 306     # break this assumption by playing silly buggers, but that's
 307     # harder to do than doing it properly, and harder to check
 308     # for.
 309     if (ref($self) eq "")
 310     {
 311         # Class method. The new context is the next argument.
 312         $new_context = shift;
 313     } else {
 314         # Instance method. The new context is $self.
 315         $new_context = $self;
 316     }
 317
 318     # Save the old context, if any, on the stack
 319     push @context_stack, $context if defined($context);
 320
 321     # Set the new context
 322     $context = $new_context;
 323 }
 324
 325 =head2 restore_context
 326
 327   &restore_context;
 328
 329 Restores the context set by C<&set_context>.
 330
 331 =cut
 332
 333 #'
 334 sub restore_context
 335 {
 336     my $self = shift;
 337
 338     if ($#context_stack < 0)
 339     {
 340         # Stack underflow.
 341         die "Context stack underflow";
 342     }
 343
 344     # Pop the old context and set it.
 345     $context = pop @context_stack;
 346
 347     # FIXME - Should this return something, like maybe the context
 348     # that was current when this was called?
 349 }
 350
 351 =head2 config
 352
 353   $value = C4::Context->config("config_variable");
 354
 355   $value = C4::Context->config_variable;
 356
 357 Returns the value of a variable specified in the configuration file
 358 from which the current context was created.
 359
 360 The second form is more compact, but of course may conflict with
 361 method names. If there is a configuration variable called "new", then
 362 C<C4::Config-E<gt>new> will not return it.
 363
 364 =cut
 365
 366 sub _common_config {
 367         my $var = shift;
 368         my $term = shift;
 369     return if !defined($context->{$term});
 370        # Presumably $self->{$term} might be
 371        # undefined if the config file given to &new
 372        # didn't exist, and the caller didn't bother
 373        # to check the return value.
 374
 375     # Return the value of the requested config variable
 376     return $context->{$term}->{$var};
 377 }
 378
 379 sub config {
 380         return _common_config($_[1],'config');
 381 }
 382 sub zebraconfig {
 383         return _common_config($_[1],'server');
 384 }
 385 sub ModZebrations {
 386         return _common_config($_[1],'serverinfo');
 387 }
 388
 389 =head2 preference
 390
 391   $sys_preference = C4::Context->preference('some_variable');
 392
 393 Looks up the value of the given system preference in the
 394 systempreferences table of the Koha database, and returns it. If the
 395 variable is not set or does not exist, undef is returned.
 396
 397 In case of an error, this may return 0.
 398
 399 Note: It is impossible to tell the difference between system
 400 preferences which do not exist, and those whose values are set to NULL
 401 with this method.
 402
 403 =cut
 404
 405 my $syspref_cache = Koha::Caches->get_instance('syspref');
 406 my $use_syspref_cache = 1;
 407 sub preference {
 408     my $self = shift;
 409     my $var  = shift;    # The system preference to return
 410
 411     return $ENV{"OVERRIDE_SYSPREF_$var"}
 412         if defined $ENV{"OVERRIDE_SYSPREF_$var"};
 413
 414     $var = lc $var;
 415
 416     if ($use_syspref_cache) {
 417         $syspref_cache = Koha::Caches->get_instance('syspref') unless $syspref_cache;
 418         my $cached_var = $syspref_cache->get_from_cache("syspref_$var");
 419         return $cached_var if defined $cached_var;
 420     }
 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, $shibboleth);
 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, $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         "shibboleth" => $shibboleth,
 879     };
 880     $context->{userenv}->{$var} = $cell;
 881     return $cell;
 882 }
 883
 884 sub set_shelves_userenv {
 885         my ($type, $shelves) = @_ or return;
 886         my $activeuser = $context->{activeuser} or return;
 887         $context->{userenv}->{$activeuser}->{barshelves} = $shelves if $type eq 'bar';
 888         $context->{userenv}->{$activeuser}->{pubshelves} = $shelves if $type eq 'pub';
 889         $context->{userenv}->{$activeuser}->{totshelves} = $shelves if $type eq 'tot';
 890 }
 891
 892 sub get_shelves_userenv {
 893         my $active;
 894         unless ($active = $context->{userenv}->{$context->{activeuser}}) {
 895                 $debug and warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}";
 896                 return;
 897         }
 898         my $totshelves = $active->{totshelves} or undef;
 899         my $pubshelves = $active->{pubshelves} or undef;
 900         my $barshelves = $active->{barshelves} or undef;
 901         return ($totshelves, $pubshelves, $barshelves);
 902 }
 903
 904 =head2 _new_userenv
 905
 906   C4::Context->_new_userenv($session);  # FIXME: This calling style is wrong for what looks like an _internal function
 907
 908 Builds a hash for user environment variables.
 909
 910 This hash shall be cached for future use: if you call
 911 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
 912
 913 _new_userenv is called in Auth.pm
 914
 915 =cut
 916
 917 #'
 918 sub _new_userenv
 919 {
 920     shift;  # Useless except it compensates for bad calling style
 921     my ($sessionID)= @_;
 922      $context->{"activeuser"}=$sessionID;
 923 }
 924
 925 =head2 _unset_userenv
 926
 927   C4::Context->_unset_userenv;
 928
 929 Destroys the hash for activeuser user environment variables.
 930
 931 =cut
 932
 933 #'
 934
 935 sub _unset_userenv
 936 {
 937     my ($sessionID)= @_;
 938     undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
 939 }
 940
 941
 942 =head2 get_versions
 943
 944   C4::Context->get_versions
 945
 946 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'.
 947
 948 =cut
 949
 950 #'
 951
 952 # A little example sub to show more debugging info for CGI::Carp
 953 sub get_versions {
 954     my %versions;
 955     $versions{kohaVersion}  = Koha::version();
 956     $versions{kohaDbVersion} = C4::Context->preference('version');
 957     $versions{osVersion} = join(" ", POSIX::uname());
 958     $versions{perlVersion} = $];
 959     {
 960         no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
 961         $versions{mysqlVersion}  = `mysql -V`;
 962         $versions{apacheVersion} = (`apache2ctl -v`)[0];
 963         $versions{apacheVersion} = `httpd -v`             unless  $versions{apacheVersion} ;
 964         $versions{apacheVersion} = `httpd2 -v`            unless  $versions{apacheVersion} ;
 965         $versions{apacheVersion} = `apache2 -v`           unless  $versions{apacheVersion} ;
 966         $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless  $versions{apacheVersion} ;
 967     }
 968     return %versions;
 969 }
 970
 971
 972 =head2 tz
 973
 974   C4::Context->tz
 975
 976   Returns a DateTime::TimeZone object for the system timezone
 977
 978 =cut
 979
 980 sub tz {
 981     my $self = shift;
 982     if (!defined $context->{tz}) {
 983         $context->{tz} = DateTime::TimeZone->new(name => 'local');
 984     }
 985     return $context->{tz};
 986 }
 987
 988
 989 =head2 IsSuperLibrarian
 990
 991     C4::Context->IsSuperLibrarian();
 992
 993 =cut
 994
 995 sub IsSuperLibrarian {
 996     my $userenv = C4::Context->userenv;
 997
 998     unless ( $userenv and exists $userenv->{flags} ) {
 999         # If we reach this without a user environment,
1000         # assume that we're running from a command-line script,
1001         # and act as a superlibrarian.
1002         carp("C4::Context->userenv not defined!");
1003         return 1;
1004     }
1005
1006     return ($userenv->{flags}//0) % 2;
1007 }
1008
1009 =head2 interface
1010
1011 Sets the current interface for later retrieval in any Perl module
1012
1013     C4::Context->interface('opac');
1014     C4::Context->interface('intranet');
1015     my $interface = C4::Context->interface;
1016
1017 =cut
1018
1019 sub interface {
1020     my ($class, $interface) = @_;
1021
1022     if (defined $interface) {
1023         $interface = lc $interface;
1024         if ($interface eq 'opac' || $interface eq 'intranet' || $interface eq 'sip' || $interface eq 'commandline') {
1025             $context->{interface} = $interface;
1026         } else {
1027             warn "invalid interface : '$interface'";
1028         }
1029     }
1030
1031     return $context->{interface} // 'opac';
1032 }
1033
1034 # always returns a string for OK comparison via "eq" or "ne"
1035 sub mybranch {
1036     C4::Context->userenv           or return '';
1037     return C4::Context->userenv->{branch} || '';
1038 }
1039
1040 =head2 only_my_library
1041
1042     my $test = C4::Context->only_my_library;
1043
1044     Returns true if you enabled IndependentBranches and the current user
1045     does not have superlibrarian permissions.
1046
1047 =cut
1048
1049 sub only_my_library {
1050     return
1051          C4::Context->preference('IndependentBranches')
1052       && C4::Context->userenv
1053       && !C4::Context->IsSuperLibrarian()
1054       && C4::Context->userenv->{branch};
1055 }
1056
1057 1;
1058
1059 __END__
1060
1061 =head1 ENVIRONMENT
1062
1063 =head2 C<KOHA_CONF>
1064
1065 Specifies the configuration file to read.
1066
1067 =head1 SEE ALSO
1068
1069 XML::Simple
1070
1071 =head1 AUTHORS
1072
1073 Andrew Arensburger <arensb at ooblick dot com>
1074
1075 Joshua Ferraro <jmf at liblime dot com>
1076