C4/Context.pm

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