C4/Context.pm

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