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