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