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