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