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