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