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     my $variable_case = $variable;
 500     $variable = lc $variable;
 501
 502     my $syspref = Koha::Config::SysPrefs->find($variable);
 503     $type =
 504         $type    ? $type
 505       : $syspref ? $syspref->type
 506       :            undef;
 507
 508     $value = 0 if ( $type && $type eq 'YesNo' && $value eq '' );
 509
 510     # force explicit protocol on OPACBaseURL
 511     if ( $variable eq 'opacbaseurl' && $value && substr( $value, 0, 4 ) !~ /http/ ) {
 512         $value = 'http://' . $value;
 513     }
 514
 515     if ($syspref) {
 516         $syspref->set(
 517             {   ( defined $value ? ( value       => $value )       : () ),
 518                 ( $explanation   ? ( explanation => $explanation ) : () ),
 519                 ( $type          ? ( type        => $type )        : () ),
 520                 ( $options       ? ( options     => $options )     : () ),
 521             }
 522         )->store;
 523     } else {
 524         $syspref = Koha::Config::SysPref->new(
 525             {   variable    => $variable_case,
 526                 value       => $value,
 527                 explanation => $explanation || undef,
 528                 type        => $type,
 529                 options     => $options || undef,
 530             }
 531         )->store();
 532     }
 533
 534     if ( $use_syspref_cache ) {
 535         $syspref_cache->set_in_cache( "syspref_$variable", $value );
 536     }
 537
 538     return $syspref;
 539 }
 540
 541 =head2 delete_preference
 542
 543     C4::Context->delete_preference( $variable );
 544
 545 This deletes a system preference from the database. Returns a true value on
 546 success. Failure means there was an issue with the database, not that there
 547 was no syspref of the name.
 548
 549 =cut
 550
 551 sub delete_preference {
 552     my ( $self, $var ) = @_;
 553
 554     if ( Koha::Config::SysPrefs->find( $var )->delete ) {
 555         if ( $use_syspref_cache ) {
 556             $syspref_cache->clear_from_cache("syspref_$var");
 557         }
 558
 559         return 1;
 560     }
 561     return 0;
 562 }
 563
 564 =head2 Zconn
 565
 566   $Zconn = C4::Context->Zconn
 567
 568 Returns a connection to the Zebra database
 569
 570 C<$self>
 571
 572 C<$server> one of the servers defined in the koha-conf.xml file
 573
 574 C<$async> whether this is a asynchronous connection
 575
 576 =cut
 577
 578 sub Zconn {
 579     my ($self, $server, $async ) = @_;
 580     my $cache_key = join ('::', (map { $_ // '' } ($server, $async )));
 581     if ( (!defined($ENV{GATEWAY_INTERFACE})) && defined($context->{"Zconn"}->{$cache_key}) && (0 == $context->{"Zconn"}->{$cache_key}->errcode()) ) {
 582         # if we are running the script from the commandline, lets try to use the caching
 583         return $context->{"Zconn"}->{$cache_key};
 584     }
 585     $context->{"Zconn"}->{$cache_key}->destroy() if defined($context->{"Zconn"}->{$cache_key}); #destroy old connection before making a new one
 586     $context->{"Zconn"}->{$cache_key} = &_new_Zconn( $server, $async );
 587     return $context->{"Zconn"}->{$cache_key};
 588 }
 589
 590 =head2 _new_Zconn
 591
 592 $context->{"Zconn"} = &_new_Zconn($server,$async);
 593
 594 Internal function. Creates a new database connection from the data given in the current context and returns it.
 595
 596 C<$server> one of the servers defined in the koha-conf.xml file
 597
 598 C<$async> whether this is a asynchronous connection
 599
 600 C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
 601
 602 =cut
 603
 604 sub _new_Zconn {
 605     my ( $server, $async ) = @_;
 606
 607     my $tried=0; # first attempt
 608     my $Zconn; # connection object
 609     my $elementSetName;
 610     my $index_mode;
 611     my $syntax;
 612
 613     $server //= "biblioserver";
 614
 615     if ( $server eq 'biblioserver' ) {
 616         $index_mode = $context->{'config'}->{'zebra_bib_index_mode'} // 'dom';
 617     } elsif ( $server eq 'authorityserver' ) {
 618         $index_mode = $context->{'config'}->{'zebra_auth_index_mode'} // 'dom';
 619     }
 620
 621     if ( $index_mode eq 'grs1' ) {
 622         $elementSetName = 'F';
 623         $syntax = ( $context->preference("marcflavour") eq 'UNIMARC' )
 624                 ? 'unimarc'
 625                 : 'usmarc';
 626
 627     } else { # $index_mode eq 'dom'
 628         $syntax = 'xml';
 629         $elementSetName = 'marcxml';
 630     }
 631
 632     my $host = $context->{'listen'}->{$server}->{'content'};
 633     my $user = $context->{"serverinfo"}->{$server}->{"user"};
 634     my $password = $context->{"serverinfo"}->{$server}->{"password"};
 635     eval {
 636         # set options
 637         my $o = new ZOOM::Options();
 638         $o->option(user => $user) if $user && $password;
 639         $o->option(password => $password) if $user && $password;
 640         $o->option(async => 1) if $async;
 641         $o->option(cqlfile=> $context->{"server"}->{$server}->{"cql2rpn"});
 642         $o->option(cclfile=> $context->{"serverinfo"}->{$server}->{"ccl2rpn"});
 643         $o->option(preferredRecordSyntax => $syntax);
 644         $o->option(elementSetName => $elementSetName) if $elementSetName;
 645         $o->option(databaseName => $context->{"config"}->{$server}||"biblios");
 646
 647         # create a new connection object
 648         $Zconn= create ZOOM::Connection($o);
 649
 650         # forge to server
 651         $Zconn->connect($host, 0);
 652
 653         # check for errors and warn
 654         if ($Zconn->errcode() !=0) {
 655             warn "something wrong with the connection: ". $Zconn->errmsg();
 656         }
 657     };
 658     return $Zconn;
 659 }
 660
 661 # _new_dbh
 662 # Internal helper function (not a method!). This creates a new
 663 # database connection from the data given in the current context, and
 664 # returns it.
 665 sub _new_dbh
 666 {
 667
 668     Koha::Database->schema({ new => 1 })->storage->dbh;
 669 }
 670
 671 =head2 dbh
 672
 673   $dbh = C4::Context->dbh;
 674
 675 Returns a database handle connected to the Koha database for the
 676 current context. If no connection has yet been made, this method
 677 creates one, and connects to the database.
 678
 679 This database handle is cached for future use: if you call
 680 C<C4::Context-E<gt>dbh> twice, you will get the same handle both
 681 times. If you need a second database handle, use C<&new_dbh> and
 682 possibly C<&set_dbh>.
 683
 684 =cut
 685
 686 #'
 687 sub dbh
 688 {
 689     my $self = shift;
 690     my $params = shift;
 691     my $sth;
 692
 693     unless ( $params->{new} ) {
 694         return Koha::Database->schema->storage->dbh;
 695     }
 696
 697     return Koha::Database->schema({ new => 1 })->storage->dbh;
 698 }
 699
 700 =head2 new_dbh
 701
 702   $dbh = C4::Context->new_dbh;
 703
 704 Creates a new connection to the Koha database for the current context,
 705 and returns the database handle (a C<DBI::db> object).
 706
 707 The handle is not saved anywhere: this method is strictly a
 708 convenience function; the point is that it knows which database to
 709 connect to so that the caller doesn't have to know.
 710
 711 =cut
 712
 713 #'
 714 sub new_dbh
 715 {
 716     my $self = shift;
 717
 718     return &dbh({ new => 1 });
 719 }
 720
 721 =head2 set_dbh
 722
 723   $my_dbh = C4::Connect->new_dbh;
 724   C4::Connect->set_dbh($my_dbh);
 725   ...
 726   C4::Connect->restore_dbh;
 727
 728 C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
 729 C<&set_context> and C<&restore_context>.
 730
 731 C<&set_dbh> saves the current database handle on a stack, then sets
 732 the current database handle to C<$my_dbh>.
 733
 734 C<$my_dbh> is assumed to be a good database handle.
 735
 736 =cut
 737
 738 #'
 739 sub set_dbh
 740 {
 741     my $self = shift;
 742     my $new_dbh = shift;
 743
 744     # Save the current database handle on the handle stack.
 745     # We assume that $new_dbh is all good: if the caller wants to
 746     # screw himself by passing an invalid handle, that's fine by
 747     # us.
 748     push @{$context->{"dbh_stack"}}, $context->{"dbh"};
 749     $context->{"dbh"} = $new_dbh;
 750 }
 751
 752 =head2 restore_dbh
 753
 754   C4::Context->restore_dbh;
 755
 756 Restores the database handle saved by an earlier call to
 757 C<C4::Context-E<gt>set_dbh>.
 758
 759 =cut
 760
 761 #'
 762 sub restore_dbh
 763 {
 764     my $self = shift;
 765
 766     if ($#{$context->{"dbh_stack"}} < 0)
 767     {
 768         # Stack underflow
 769         die "DBH stack underflow";
 770     }
 771
 772     # Pop the old database handle and set it.
 773     $context->{"dbh"} = pop @{$context->{"dbh_stack"}};
 774
 775     # FIXME - If it is determined that restore_context should
 776     # return something, then this function should, too.
 777 }
 778
 779 =head2 queryparser
 780
 781   $queryparser = C4::Context->queryparser
 782
 783 Returns a handle to an initialized Koha::QueryParser::Driver::PQF object.
 784
 785 =cut
 786
 787 sub queryparser {
 788     my $self = shift;
 789     unless (defined $context->{"queryparser"}) {
 790         $context->{"queryparser"} = &_new_queryparser();
 791     }
 792
 793     return
 794       defined( $context->{"queryparser"} )
 795       ? $context->{"queryparser"}->new
 796       : undef;
 797 }
 798
 799 =head2 _new_queryparser
 800
 801 Internal helper function to create a new QueryParser object. QueryParser
 802 is loaded dynamically so as to keep the lack of the QueryParser library from
 803 getting in anyone's way.
 804
 805 =cut
 806
 807 sub _new_queryparser {
 808     my $qpmodules = {
 809         'OpenILS::QueryParser'           => undef,
 810         'Koha::QueryParser::Driver::PQF' => undef
 811     };
 812     if ( can_load( 'modules' => $qpmodules ) ) {
 813         my $QParser     = Koha::QueryParser::Driver::PQF->new();
 814         my $config_file = $context->config('queryparser_config');
 815         $config_file ||= '/etc/koha/searchengine/queryparser.yaml';
 816         if ( $QParser->load_config($config_file) ) {
 817             # Set 'keyword' as the default search class
 818             $QParser->default_search_class('keyword');
 819             # TODO: allow indexes to be configured in the database
 820             return $QParser;
 821         }
 822     }
 823     return;
 824 }
 825
 826 =head2 userenv
 827
 828   C4::Context->userenv;
 829
 830 Retrieves a hash for user environment variables.
 831
 832 This hash shall be cached for future use: if you call
 833 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
 834
 835 =cut
 836
 837 #'
 838 sub userenv {
 839     my $var = $context->{"activeuser"};
 840     if (defined $var and defined $context->{"userenv"}->{$var}) {
 841         return $context->{"userenv"}->{$var};
 842     } else {
 843         return;
 844     }
 845 }
 846
 847 =head2 set_userenv
 848
 849   C4::Context->set_userenv($usernum, $userid, $usercnum,
 850                            $userfirstname, $usersurname,
 851                            $userbranch, $branchname, $userflags,
 852                            $emailaddress, $branchprinter, $shibboleth);
 853
 854 Establish a hash of user environment variables.
 855
 856 set_userenv is called in Auth.pm
 857
 858 =cut
 859
 860 #'
 861 sub set_userenv {
 862     shift @_;
 863     my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter, $shibboleth)=
 864     map { Encode::is_utf8( $_ ) ? $_ : Encode::decode('UTF-8', $_) } # CGI::Session doesn't handle utf-8, so we decode it here
 865     @_;
 866     my $var=$context->{"activeuser"} || '';
 867     my $cell = {
 868         "number"     => $usernum,
 869         "id"         => $userid,
 870         "cardnumber" => $usercnum,
 871         "firstname"  => $userfirstname,
 872         "surname"    => $usersurname,
 873         #possibly a law problem
 874         "branch"     => $userbranch,
 875         "branchname" => $branchname,
 876         "flags"      => $userflags,
 877         "emailaddress"     => $emailaddress,
 878         "branchprinter"    => $branchprinter,
 879         "shibboleth" => $shibboleth,
 880     };
 881     $context->{userenv}->{$var} = $cell;
 882     return $cell;
 883 }
 884
 885 sub set_shelves_userenv {
 886         my ($type, $shelves) = @_ or return;
 887         my $activeuser = $context->{activeuser} or return;
 888         $context->{userenv}->{$activeuser}->{barshelves} = $shelves if $type eq 'bar';
 889         $context->{userenv}->{$activeuser}->{pubshelves} = $shelves if $type eq 'pub';
 890         $context->{userenv}->{$activeuser}->{totshelves} = $shelves if $type eq 'tot';
 891 }
 892
 893 sub get_shelves_userenv {
 894         my $active;
 895         unless ($active = $context->{userenv}->{$context->{activeuser}}) {
 896                 $debug and warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}";
 897                 return;
 898         }
 899         my $totshelves = $active->{totshelves} or undef;
 900         my $pubshelves = $active->{pubshelves} or undef;
 901         my $barshelves = $active->{barshelves} or undef;
 902         return ($totshelves, $pubshelves, $barshelves);
 903 }
 904
 905 =head2 _new_userenv
 906
 907   C4::Context->_new_userenv($session);  # FIXME: This calling style is wrong for what looks like an _internal function
 908
 909 Builds a hash for user environment variables.
 910
 911 This hash shall be cached for future use: if you call
 912 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
 913
 914 _new_userenv is called in Auth.pm
 915
 916 =cut
 917
 918 #'
 919 sub _new_userenv
 920 {
 921     shift;  # Useless except it compensates for bad calling style
 922     my ($sessionID)= @_;
 923      $context->{"activeuser"}=$sessionID;
 924 }
 925
 926 =head2 _unset_userenv
 927
 928   C4::Context->_unset_userenv;
 929
 930 Destroys the hash for activeuser user environment variables.
 931
 932 =cut
 933
 934 #'
 935
 936 sub _unset_userenv
 937 {
 938     my ($sessionID)= @_;
 939     undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
 940 }
 941
 942
 943 =head2 get_versions
 944
 945   C4::Context->get_versions
 946
 947 Gets various version info, for core Koha packages, Currently called from carp handle_errors() sub, to send to browser if 'DebugLevel' syspref is set to '2'.
 948
 949 =cut
 950
 951 #'
 952
 953 # A little example sub to show more debugging info for CGI::Carp
 954 sub get_versions {
 955     my %versions;
 956     $versions{kohaVersion}  = Koha::version();
 957     $versions{kohaDbVersion} = C4::Context->preference('version');
 958     $versions{osVersion} = join(" ", POSIX::uname());
 959     $versions{perlVersion} = $];
 960     {
 961         no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
 962         $versions{mysqlVersion}  = `mysql -V`;
 963         $versions{apacheVersion} = (`apache2ctl -v`)[0];
 964         $versions{apacheVersion} = `httpd -v`             unless  $versions{apacheVersion} ;
 965         $versions{apacheVersion} = `httpd2 -v`            unless  $versions{apacheVersion} ;
 966         $versions{apacheVersion} = `apache2 -v`           unless  $versions{apacheVersion} ;
 967         $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless  $versions{apacheVersion} ;
 968     }
 969     return %versions;
 970 }
 971
 972
 973 =head2 tz
 974
 975   C4::Context->tz
 976
 977   Returns a DateTime::TimeZone object for the system timezone
 978
 979 =cut
 980
 981 sub tz {
 982     my $self = shift;
 983     if (!defined $context->{tz}) {
 984         $context->{tz} = DateTime::TimeZone->new(name => 'local');
 985     }
 986     return $context->{tz};
 987 }
 988
 989
 990 =head2 IsSuperLibrarian
 991
 992     C4::Context->IsSuperLibrarian();
 993
 994 =cut
 995
 996 sub IsSuperLibrarian {
 997     my $userenv = C4::Context->userenv;
 998
 999     unless ( $userenv and exists $userenv->{flags} ) {
1000         # If we reach this without a user environment,
1001         # assume that we're running from a command-line script,
1002         # and act as a superlibrarian.
1003         carp("C4::Context->userenv not defined!");
1004         return 1;
1005     }
1006
1007     return ($userenv->{flags}//0) % 2;
1008 }
1009
1010 =head2 interface
1011
1012 Sets the current interface for later retrieval in any Perl module
1013
1014     C4::Context->interface('opac');
1015     C4::Context->interface('intranet');
1016     my $interface = C4::Context->interface;
1017
1018 =cut
1019
1020 sub interface {
1021     my ($class, $interface) = @_;
1022
1023     if (defined $interface) {
1024         $interface = lc $interface;
1025         if ($interface eq 'opac' || $interface eq 'intranet' || $interface eq 'sip' || $interface eq 'commandline') {
1026             $context->{interface} = $interface;
1027         } else {
1028             warn "invalid interface : '$interface'";
1029         }
1030     }
1031
1032     return $context->{interface} // 'opac';
1033 }
1034
1035 # always returns a string for OK comparison via "eq" or "ne"
1036 sub mybranch {
1037     C4::Context->userenv           or return '';
1038     return C4::Context->userenv->{branch} || '';
1039 }
1040
1041 =head2 only_my_library
1042
1043     my $test = C4::Context->only_my_library;
1044
1045     Returns true if you enabled IndependentBranches and the current user
1046     does not have superlibrarian permissions.
1047
1048 =cut
1049
1050 sub only_my_library {
1051     return
1052          C4::Context->preference('IndependentBranches')
1053       && C4::Context->userenv
1054       && !C4::Context->IsSuperLibrarian()
1055       && C4::Context->userenv->{branch};
1056 }
1057
1058 1;
1059
1060 __END__
1061
1062 =head1 ENVIRONMENT
1063
1064 =head2 C<KOHA_CONF>
1065
1066 Specifies the configuration file to read.
1067
1068 =head1 SEE ALSO
1069
1070 XML::Simple
1071
1072 =head1 AUTHORS
1073
1074 Andrew Arensburger <arensb at ooblick dot com>
1075
1076 Joshua Ferraro <jmf at liblime dot com>
1077