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 $use_syspref_cache = 1;
 521 sub preference {
 522     my $self = shift;
 523     my $var  = shift;    # The system preference to return
 524
 525     $var = lc $var;
 526
 527     return $ENV{"OVERRIDE_SYSPREF_$var"}
 528         if defined $ENV{"OVERRIDE_SYSPREF_$var"};
 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 $syspref;
 536     eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) };
 537     my $value = $syspref ? $syspref->value() : undef;
 538
 539     if ( $use_syspref_cache ) {
 540         $syspref_cache->set_in_cache("syspref_$var", $value);
 541     }
 542     return $value;
 543 }
 544
 545 sub boolean_preference {
 546     my $self = shift;
 547     my $var = shift;        # The system preference to return
 548     my $it = preference($self, $var);
 549     return defined($it)? C4::Boolean::true_p($it): undef;
 550 }
 551
 552 =head2 enable_syspref_cache
 553
 554   C4::Context->enable_syspref_cache();
 555
 556 Enable the in-memory syspref cache used by C4::Context. This is the
 557 default behavior.
 558
 559 =cut
 560
 561 sub enable_syspref_cache {
 562     my ($self) = @_;
 563     $use_syspref_cache = 1;
 564     # We need to clear the cache to have it up-to-date
 565     $self->clear_syspref_cache();
 566 }
 567
 568 =head2 disable_syspref_cache
 569
 570   C4::Context->disable_syspref_cache();
 571
 572 Disable the in-memory syspref cache used by C4::Context. This should be
 573 used with Plack and other persistent environments.
 574
 575 =cut
 576
 577 sub disable_syspref_cache {
 578     my ($self) = @_;
 579     $use_syspref_cache = 0;
 580     $self->clear_syspref_cache();
 581 }
 582
 583 =head2 clear_syspref_cache
 584
 585   C4::Context->clear_syspref_cache();
 586
 587 cleans the internal cache of sysprefs. Please call this method if
 588 you update the systempreferences table. Otherwise, your new changes
 589 will not be seen by this process.
 590
 591 =cut
 592
 593 sub clear_syspref_cache {
 594     return unless $use_syspref_cache;
 595     $syspref_cache->flush_all;
 596 }
 597
 598 =head2 set_preference
 599
 600   C4::Context->set_preference( $variable, $value, [ $explanation, $type, $options ] );
 601
 602 This updates a preference's value both in the systempreferences table and in
 603 the sysprefs cache. If the optional parameters are provided, then the query
 604 becomes a create. It won't update the parameters (except value) for an existing
 605 preference.
 606
 607 =cut
 608
 609 sub set_preference {
 610     my ( $self, $variable, $value, $explanation, $type, $options ) = @_;
 611
 612     $variable = lc $variable;
 613
 614     my $syspref = Koha::Config::SysPrefs->find($variable);
 615     $type =
 616         $type    ? $type
 617       : $syspref ? $syspref->type
 618       :            undef;
 619
 620     $value = 0 if ( $type && $type eq 'YesNo' && $value eq '' );
 621
 622     # force explicit protocol on OPACBaseURL
 623     if ( $variable eq 'opacbaseurl' && $value && substr( $value, 0, 4 ) !~ /http/ ) {
 624         $value = 'http://' . $value;
 625     }
 626
 627     if ($syspref) {
 628         $syspref->set(
 629             {   ( defined $value ? ( value       => $value )       : () ),
 630                 ( $explanation   ? ( explanation => $explanation ) : () ),
 631                 ( $type          ? ( type        => $type )        : () ),
 632                 ( $options       ? ( options     => $options )     : () ),
 633             }
 634         )->store;
 635     } else {
 636         $syspref = Koha::Config::SysPref->new(
 637             {   variable    => $variable,
 638                 value       => $value,
 639                 explanation => $explanation || undef,
 640                 type        => $type,
 641                 options     => $options || undef,
 642             }
 643         )->store();
 644     }
 645
 646     if ( $use_syspref_cache ) {
 647         $syspref_cache->set_in_cache( "syspref_$variable", $value );
 648     }
 649
 650     return $syspref;
 651 }
 652
 653 =head2 delete_preference
 654
 655     C4::Context->delete_preference( $variable );
 656
 657 This deletes a system preference from the database. Returns a true value on
 658 success. Failure means there was an issue with the database, not that there
 659 was no syspref of the name.
 660
 661 =cut
 662
 663 sub delete_preference {
 664     my ( $self, $var ) = @_;
 665
 666     if ( Koha::Config::SysPrefs->find( $var )->delete ) {
 667         if ( $use_syspref_cache ) {
 668             $syspref_cache->clear_from_cache("syspref_$var");
 669         }
 670
 671         return 1;
 672     }
 673     return 0;
 674 }
 675
 676 =head2 Zconn
 677
 678   $Zconn = C4::Context->Zconn
 679
 680 Returns a connection to the Zebra database
 681
 682 C<$self>
 683
 684 C<$server> one of the servers defined in the koha-conf.xml file
 685
 686 C<$async> whether this is a asynchronous connection
 687
 688 =cut
 689
 690 sub Zconn {
 691     my ($self, $server, $async ) = @_;
 692     my $cache_key = join ('::', (map { $_ // '' } ($server, $async )));
 693     if ( (!defined($ENV{GATEWAY_INTERFACE})) && defined($context->{"Zconn"}->{$cache_key}) && (0 == $context->{"Zconn"}->{$cache_key}->errcode()) ) {
 694         # if we are running the script from the commandline, lets try to use the caching
 695         return $context->{"Zconn"}->{$cache_key};
 696     }
 697     $context->{"Zconn"}->{$cache_key}->destroy() if defined($context->{"Zconn"}->{$cache_key}); #destroy old connection before making a new one
 698     $context->{"Zconn"}->{$cache_key} = &_new_Zconn( $server, $async );
 699     return $context->{"Zconn"}->{$cache_key};
 700 }
 701
 702 =head2 _new_Zconn
 703
 704 $context->{"Zconn"} = &_new_Zconn($server,$async);
 705
 706 Internal function. Creates a new database connection from the data given in the current context and returns it.
 707
 708 C<$server> one of the servers defined in the koha-conf.xml file
 709
 710 C<$async> whether this is a asynchronous connection
 711
 712 C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
 713
 714 =cut
 715
 716 sub _new_Zconn {
 717     my ( $server, $async ) = @_;
 718
 719     my $tried=0; # first attempt
 720     my $Zconn; # connection object
 721     my $elementSetName;
 722     my $index_mode;
 723     my $syntax;
 724
 725     $server //= "biblioserver";
 726
 727     if ( $server eq 'biblioserver' ) {
 728         $index_mode = $context->{'config'}->{'zebra_bib_index_mode'} // 'dom';
 729     } elsif ( $server eq 'authorityserver' ) {
 730         $index_mode = $context->{'config'}->{'zebra_auth_index_mode'} // 'dom';
 731     }
 732
 733     if ( $index_mode eq 'grs1' ) {
 734         $elementSetName = 'F';
 735         $syntax = ( $context->preference("marcflavour") eq 'UNIMARC' )
 736                 ? 'unimarc'
 737                 : 'usmarc';
 738
 739     } else { # $index_mode eq 'dom'
 740         $syntax = 'xml';
 741         $elementSetName = 'marcxml';
 742     }
 743
 744     my $host = $context->{'listen'}->{$server}->{'content'};
 745     my $user = $context->{"serverinfo"}->{$server}->{"user"};
 746     my $password = $context->{"serverinfo"}->{$server}->{"password"};
 747     eval {
 748         # set options
 749         my $o = new ZOOM::Options();
 750         $o->option(user => $user) if $user && $password;
 751         $o->option(password => $password) if $user && $password;
 752         $o->option(async => 1) if $async;
 753         $o->option(cqlfile=> $context->{"server"}->{$server}->{"cql2rpn"});
 754         $o->option(cclfile=> $context->{"serverinfo"}->{$server}->{"ccl2rpn"});
 755         $o->option(preferredRecordSyntax => $syntax);
 756         $o->option(elementSetName => $elementSetName) if $elementSetName;
 757         $o->option(databaseName => $context->{"config"}->{$server}||"biblios");
 758
 759         # create a new connection object
 760         $Zconn= create ZOOM::Connection($o);
 761
 762         # forge to server
 763         $Zconn->connect($host, 0);
 764
 765         # check for errors and warn
 766         if ($Zconn->errcode() !=0) {
 767             warn "something wrong with the connection: ". $Zconn->errmsg();
 768         }
 769     };
 770     return $Zconn;
 771 }
 772
 773 # _new_dbh
 774 # Internal helper function (not a method!). This creates a new
 775 # database connection from the data given in the current context, and
 776 # returns it.
 777 sub _new_dbh
 778 {
 779
 780     Koha::Database->schema({ new => 1 })->storage->dbh;
 781 }
 782
 783 =head2 dbh
 784
 785   $dbh = C4::Context->dbh;
 786
 787 Returns a database handle connected to the Koha database for the
 788 current context. If no connection has yet been made, this method
 789 creates one, and connects to the database.
 790
 791 This database handle is cached for future use: if you call
 792 C<C4::Context-E<gt>dbh> twice, you will get the same handle both
 793 times. If you need a second database handle, use C<&new_dbh> and
 794 possibly C<&set_dbh>.
 795
 796 =cut
 797
 798 #'
 799 sub dbh
 800 {
 801     my $self = shift;
 802     my $params = shift;
 803     my $sth;
 804
 805     unless ( $params->{new} ) {
 806         return Koha::Database->schema->storage->dbh;
 807     }
 808
 809     return Koha::Database->schema({ new => 1 })->storage->dbh;
 810 }
 811
 812 =head2 new_dbh
 813
 814   $dbh = C4::Context->new_dbh;
 815
 816 Creates a new connection to the Koha database for the current context,
 817 and returns the database handle (a C<DBI::db> object).
 818
 819 The handle is not saved anywhere: this method is strictly a
 820 convenience function; the point is that it knows which database to
 821 connect to so that the caller doesn't have to know.
 822
 823 =cut
 824
 825 #'
 826 sub new_dbh
 827 {
 828     my $self = shift;
 829
 830     return &dbh({ new => 1 });
 831 }
 832
 833 =head2 set_dbh
 834
 835   $my_dbh = C4::Connect->new_dbh;
 836   C4::Connect->set_dbh($my_dbh);
 837   ...
 838   C4::Connect->restore_dbh;
 839
 840 C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
 841 C<&set_context> and C<&restore_context>.
 842
 843 C<&set_dbh> saves the current database handle on a stack, then sets
 844 the current database handle to C<$my_dbh>.
 845
 846 C<$my_dbh> is assumed to be a good database handle.
 847
 848 =cut
 849
 850 #'
 851 sub set_dbh
 852 {
 853     my $self = shift;
 854     my $new_dbh = shift;
 855
 856     # Save the current database handle on the handle stack.
 857     # We assume that $new_dbh is all good: if the caller wants to
 858     # screw himself by passing an invalid handle, that's fine by
 859     # us.
 860     push @{$context->{"dbh_stack"}}, $context->{"dbh"};
 861     $context->{"dbh"} = $new_dbh;
 862 }
 863
 864 =head2 restore_dbh
 865
 866   C4::Context->restore_dbh;
 867
 868 Restores the database handle saved by an earlier call to
 869 C<C4::Context-E<gt>set_dbh>.
 870
 871 =cut
 872
 873 #'
 874 sub restore_dbh
 875 {
 876     my $self = shift;
 877
 878     if ($#{$context->{"dbh_stack"}} < 0)
 879     {
 880         # Stack underflow
 881         die "DBH stack underflow";
 882     }
 883
 884     # Pop the old database handle and set it.
 885     $context->{"dbh"} = pop @{$context->{"dbh_stack"}};
 886
 887     # FIXME - If it is determined that restore_context should
 888     # return something, then this function should, too.
 889 }
 890
 891 =head2 queryparser
 892
 893   $queryparser = C4::Context->queryparser
 894
 895 Returns a handle to an initialized Koha::QueryParser::Driver::PQF object.
 896
 897 =cut
 898
 899 sub queryparser {
 900     my $self = shift;
 901     unless (defined $context->{"queryparser"}) {
 902         $context->{"queryparser"} = &_new_queryparser();
 903     }
 904
 905     return
 906       defined( $context->{"queryparser"} )
 907       ? $context->{"queryparser"}->new
 908       : undef;
 909 }
 910
 911 =head2 _new_queryparser
 912
 913 Internal helper function to create a new QueryParser object. QueryParser
 914 is loaded dynamically so as to keep the lack of the QueryParser library from
 915 getting in anyone's way.
 916
 917 =cut
 918
 919 sub _new_queryparser {
 920     my $qpmodules = {
 921         'OpenILS::QueryParser'           => undef,
 922         'Koha::QueryParser::Driver::PQF' => undef
 923     };
 924     if ( can_load( 'modules' => $qpmodules ) ) {
 925         my $QParser     = Koha::QueryParser::Driver::PQF->new();
 926         my $config_file = $context->config('queryparser_config');
 927         $config_file ||= '/etc/koha/searchengine/queryparser.yaml';
 928         if ( $QParser->load_config($config_file) ) {
 929             # Set 'keyword' as the default search class
 930             $QParser->default_search_class('keyword');
 931             # TODO: allow indexes to be configured in the database
 932             return $QParser;
 933         }
 934     }
 935     return;
 936 }
 937
 938 =head2 marcfromkohafield
 939
 940   $dbh = C4::Context->marcfromkohafield;
 941
 942 Returns a hash with marcfromkohafield.
 943
 944 This hash is cached for future use: if you call
 945 C<C4::Context-E<gt>marcfromkohafield> twice, you will get the same hash without real DB access
 946
 947 =cut
 948
 949 #'
 950 sub marcfromkohafield
 951 {
 952     my $retval = {};
 953
 954     # If the hash already exists, return it.
 955     return $context->{"marcfromkohafield"} if defined($context->{"marcfromkohafield"});
 956
 957     # No hash. Create one.
 958     $context->{"marcfromkohafield"} = &_new_marcfromkohafield();
 959
 960     return $context->{"marcfromkohafield"};
 961 }
 962
 963 # _new_marcfromkohafield
 964 # Internal helper function (not a method!). This creates a new
 965 # hash with stopwords
 966 sub _new_marcfromkohafield
 967 {
 968     my $dbh = C4::Context->dbh;
 969     my $marcfromkohafield;
 970     my $sth = $dbh->prepare("select frameworkcode,kohafield,tagfield,tagsubfield from marc_subfield_structure where kohafield > ''");
 971     $sth->execute;
 972     while (my ($frameworkcode,$kohafield,$tagfield,$tagsubfield) = $sth->fetchrow) {
 973         my $retval = {};
 974         $marcfromkohafield->{$frameworkcode}->{$kohafield} = [$tagfield,$tagsubfield];
 975     }
 976     return $marcfromkohafield;
 977 }
 978
 979 =head2 stopwords
 980
 981   $dbh = C4::Context->stopwords;
 982
 983 Returns a hash with stopwords.
 984
 985 This hash is cached for future use: if you call
 986 C<C4::Context-E<gt>stopwords> twice, you will get the same hash without real DB access
 987
 988 =cut
 989
 990 #'
 991 sub stopwords
 992 {
 993     my $retval = {};
 994
 995     # If the hash already exists, return it.
 996     return $context->{"stopwords"} if defined($context->{"stopwords"});
 997
 998     # No hash. Create one.
 999     $context->{"stopwords"} = &_new_stopwords();
1000
1001     return $context->{"stopwords"};
1002 }
1003
1004 # _new_stopwords
1005 # Internal helper function (not a method!). This creates a new
1006 # hash with stopwords
1007 sub _new_stopwords
1008 {
1009     my $dbh = C4::Context->dbh;
1010     my $stopwordlist;
1011     my $sth = $dbh->prepare("select word from stopwords");
1012     $sth->execute;
1013     while (my $stopword = $sth->fetchrow_array) {
1014         $stopwordlist->{$stopword} = uc($stopword);
1015     }
1016     $stopwordlist->{A} = "A" unless $stopwordlist;
1017     return $stopwordlist;
1018 }
1019
1020 =head2 userenv
1021
1022   C4::Context->userenv;
1023
1024 Retrieves a hash for user environment variables.
1025
1026 This hash shall be cached for future use: if you call
1027 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
1028
1029 =cut
1030
1031 #'
1032 sub userenv {
1033     my $var = $context->{"activeuser"};
1034     if (defined $var and defined $context->{"userenv"}->{$var}) {
1035         return $context->{"userenv"}->{$var};
1036     } else {
1037         return;
1038     }
1039 }
1040
1041 =head2 set_userenv
1042
1043   C4::Context->set_userenv($usernum, $userid, $usercnum,
1044                            $userfirstname, $usersurname,
1045                            $userbranch, $branchname, $userflags,
1046                            $emailaddress, $branchprinter, $persona);
1047
1048 Establish a hash of user environment variables.
1049
1050 set_userenv is called in Auth.pm
1051
1052 =cut
1053
1054 #'
1055 sub set_userenv {
1056     shift @_;
1057     my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter, $persona, $shibboleth)=
1058     map { Encode::is_utf8( $_ ) ? $_ : Encode::decode('UTF-8', $_) } # CGI::Session doesn't handle utf-8, so we decode it here
1059     @_;
1060     my $var=$context->{"activeuser"} || '';
1061     my $cell = {
1062         "number"     => $usernum,
1063         "id"         => $userid,
1064         "cardnumber" => $usercnum,
1065         "firstname"  => $userfirstname,
1066         "surname"    => $usersurname,
1067         #possibly a law problem
1068         "branch"     => $userbranch,
1069         "branchname" => $branchname,
1070         "flags"      => $userflags,
1071         "emailaddress"     => $emailaddress,
1072         "branchprinter"    => $branchprinter,
1073         "persona"    => $persona,
1074         "shibboleth" => $shibboleth,
1075     };
1076     $context->{userenv}->{$var} = $cell;
1077     return $cell;
1078 }
1079
1080 sub set_shelves_userenv {
1081         my ($type, $shelves) = @_ or return;
1082         my $activeuser = $context->{activeuser} or return;
1083         $context->{userenv}->{$activeuser}->{barshelves} = $shelves if $type eq 'bar';
1084         $context->{userenv}->{$activeuser}->{pubshelves} = $shelves if $type eq 'pub';
1085         $context->{userenv}->{$activeuser}->{totshelves} = $shelves if $type eq 'tot';
1086 }
1087
1088 sub get_shelves_userenv {
1089         my $active;
1090         unless ($active = $context->{userenv}->{$context->{activeuser}}) {
1091                 $debug and warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}";
1092                 return;
1093         }
1094         my $totshelves = $active->{totshelves} or undef;
1095         my $pubshelves = $active->{pubshelves} or undef;
1096         my $barshelves = $active->{barshelves} or undef;
1097         return ($totshelves, $pubshelves, $barshelves);
1098 }
1099
1100 =head2 _new_userenv
1101
1102   C4::Context->_new_userenv($session);  # FIXME: This calling style is wrong for what looks like an _internal function
1103
1104 Builds a hash for user environment variables.
1105
1106 This hash shall be cached for future use: if you call
1107 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
1108
1109 _new_userenv is called in Auth.pm
1110
1111 =cut
1112
1113 #'
1114 sub _new_userenv
1115 {
1116     shift;  # Useless except it compensates for bad calling style
1117     my ($sessionID)= @_;
1118      $context->{"activeuser"}=$sessionID;
1119 }
1120
1121 =head2 _unset_userenv
1122
1123   C4::Context->_unset_userenv;
1124
1125 Destroys the hash for activeuser user environment variables.
1126
1127 =cut
1128
1129 #'
1130
1131 sub _unset_userenv
1132 {
1133     my ($sessionID)= @_;
1134     undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
1135 }
1136
1137
1138 =head2 get_versions
1139
1140   C4::Context->get_versions
1141
1142 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'.
1143
1144 =cut
1145
1146 #'
1147
1148 # A little example sub to show more debugging info for CGI::Carp
1149 sub get_versions {
1150     my %versions;
1151     $versions{kohaVersion}  = Koha::version();
1152     $versions{kohaDbVersion} = C4::Context->preference('version');
1153     $versions{osVersion} = join(" ", POSIX::uname());
1154     $versions{perlVersion} = $];
1155     {
1156         no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
1157         $versions{mysqlVersion}  = `mysql -V`;
1158         $versions{apacheVersion} = (`apache2ctl -v`)[0];
1159         $versions{apacheVersion} = `httpd -v`             unless  $versions{apacheVersion} ;
1160         $versions{apacheVersion} = `httpd2 -v`            unless  $versions{apacheVersion} ;
1161         $versions{apacheVersion} = `apache2 -v`           unless  $versions{apacheVersion} ;
1162         $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless  $versions{apacheVersion} ;
1163     }
1164     return %versions;
1165 }
1166
1167
1168 =head2 tz
1169
1170   C4::Context->tz
1171
1172   Returns a DateTime::TimeZone object for the system timezone
1173
1174 =cut
1175
1176 sub tz {
1177     my $self = shift;
1178     if (!defined $context->{tz}) {
1179         $context->{tz} = DateTime::TimeZone->new(name => 'local');
1180     }
1181     return $context->{tz};
1182 }
1183
1184
1185 =head2 IsSuperLibrarian
1186
1187     C4::Context->IsSuperLibrarian();
1188
1189 =cut
1190
1191 sub IsSuperLibrarian {
1192     my $userenv = C4::Context->userenv;
1193
1194     unless ( $userenv and exists $userenv->{flags} ) {
1195         # If we reach this without a user environment,
1196         # assume that we're running from a command-line script,
1197         # and act as a superlibrarian.
1198         carp("C4::Context->userenv not defined!");
1199         return 1;
1200     }
1201
1202     return ($userenv->{flags}//0) % 2;
1203 }
1204
1205 =head2 interface
1206
1207 Sets the current interface for later retrieval in any Perl module
1208
1209     C4::Context->interface('opac');
1210     C4::Context->interface('intranet');
1211     my $interface = C4::Context->interface;
1212
1213 =cut
1214
1215 sub interface {
1216     my ($class, $interface) = @_;
1217
1218     if (defined $interface) {
1219         $interface = lc $interface;
1220         if ($interface eq 'opac' || $interface eq 'intranet') {
1221             $context->{interface} = $interface;
1222         } else {
1223             warn "invalid interface : '$interface'";
1224         }
1225     }
1226
1227     return $context->{interface} // 'opac';
1228 }
1229
1230 1;
1231 __END__
1232
1233 =head1 ENVIRONMENT
1234
1235 =head2 C<KOHA_CONF>
1236
1237 Specifies the configuration file to read.
1238
1239 =head1 SEE ALSO
1240
1241 XML::Simple
1242
1243 =head1 AUTHORS
1244
1245 Andrew Arensburger <arensb at ooblick dot com>
1246
1247 Joshua Ferraro <jmf at liblime dot com>
1248