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->{"dbh"} = undef;        # Database handle
 368     $self->{"Zconn"} = undef;    # Zebra Connections
 369     $self->{"stopwords"} = undef; # stopwords list
 370     $self->{"marcfromkohafield"} = undef; # the hash with relations between koha table fields and MARC field/subfield
 371     $self->{"userenv"} = undef;        # User env
 372     $self->{"activeuser"} = undef;        # current active user
 373     $self->{"shelves"} = undef;
 374     $self->{tz} = undef; # local timezone object
 375
 376     bless $self, $class;
 377     $self->{db_driver} = db_scheme2dbi($self->config('db_scheme'));  # cache database driver
 378     return $self;
 379 }
 380
 381 =head2 set_context
 382
 383   $context = new C4::Context;
 384   $context->set_context();
 385 or
 386   set_context C4::Context $context;
 387
 388   ...
 389   restore_context C4::Context;
 390
 391 In some cases, it might be necessary for a script to use multiple
 392 contexts. C<&set_context> saves the current context on a stack, then
 393 sets the context to C<$context>, which will be used in future
 394 operations. To restore the previous context, use C<&restore_context>.
 395
 396 =cut
 397
 398 #'
 399 sub set_context
 400 {
 401     my $self = shift;
 402     my $new_context;    # The context to set
 403
 404     # Figure out whether this is a class or instance method call.
 405     #
 406     # We're going to make the assumption that control got here
 407     # through valid means, i.e., that the caller used an instance
 408     # or class method call, and that control got here through the
 409     # usual inheritance mechanisms. The caller can, of course,
 410     # break this assumption by playing silly buggers, but that's
 411     # harder to do than doing it properly, and harder to check
 412     # for.
 413     if (ref($self) eq "")
 414     {
 415         # Class method. The new context is the next argument.
 416         $new_context = shift;
 417     } else {
 418         # Instance method. The new context is $self.
 419         $new_context = $self;
 420     }
 421
 422     # Save the old context, if any, on the stack
 423     push @context_stack, $context if defined($context);
 424
 425     # Set the new context
 426     $context = $new_context;
 427 }
 428
 429 =head2 restore_context
 430
 431   &restore_context;
 432
 433 Restores the context set by C<&set_context>.
 434
 435 =cut
 436
 437 #'
 438 sub restore_context
 439 {
 440     my $self = shift;
 441
 442     if ($#context_stack < 0)
 443     {
 444         # Stack underflow.
 445         die "Context stack underflow";
 446     }
 447
 448     # Pop the old context and set it.
 449     $context = pop @context_stack;
 450
 451     # FIXME - Should this return something, like maybe the context
 452     # that was current when this was called?
 453 }
 454
 455 =head2 config
 456
 457   $value = C4::Context->config("config_variable");
 458
 459   $value = C4::Context->config_variable;
 460
 461 Returns the value of a variable specified in the configuration file
 462 from which the current context was created.
 463
 464 The second form is more compact, but of course may conflict with
 465 method names. If there is a configuration variable called "new", then
 466 C<C4::Config-E<gt>new> will not return it.
 467
 468 =cut
 469
 470 sub _common_config {
 471         my $var = shift;
 472         my $term = shift;
 473     return if !defined($context->{$term});
 474        # Presumably $self->{$term} might be
 475        # undefined if the config file given to &new
 476        # didn't exist, and the caller didn't bother
 477        # to check the return value.
 478
 479     # Return the value of the requested config variable
 480     return $context->{$term}->{$var};
 481 }
 482
 483 sub config {
 484         return _common_config($_[1],'config');
 485 }
 486 sub zebraconfig {
 487         return _common_config($_[1],'server');
 488 }
 489 sub ModZebrations {
 490         return _common_config($_[1],'serverinfo');
 491 }
 492
 493 =head2 preference
 494
 495   $sys_preference = C4::Context->preference('some_variable');
 496
 497 Looks up the value of the given system preference in the
 498 systempreferences table of the Koha database, and returns it. If the
 499 variable is not set or does not exist, undef is returned.
 500
 501 In case of an error, this may return 0.
 502
 503 Note: It is impossible to tell the difference between system
 504 preferences which do not exist, and those whose values are set to NULL
 505 with this method.
 506
 507 =cut
 508
 509 # FIXME: running this under mod_perl will require a means of
 510 # flushing the caching mechanism.
 511
 512 my %sysprefs;
 513 my $use_syspref_cache = 1;
 514
 515 sub preference {
 516     my $self = shift;
 517     my $var  = shift;    # The system preference to return
 518
 519     if ($use_syspref_cache && exists $sysprefs{lc $var}) {
 520         return $sysprefs{lc $var};
 521     }
 522
 523     my $dbh  = C4::Context->dbh or return 0;
 524
 525     my $value;
 526     if ( defined $ENV{"OVERRIDE_SYSPREF_$var"} ) {
 527         $value = $ENV{"OVERRIDE_SYSPREF_$var"};
 528     } else {
 529         my $syspref;
 530         eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) };
 531         $value = $syspref ? $syspref->value() : undef;
 532     }
 533
 534     $sysprefs{lc $var} = $value;
 535     return $value;
 536 }
 537
 538 sub boolean_preference {
 539     my $self = shift;
 540     my $var = shift;        # The system preference to return
 541     my $it = preference($self, $var);
 542     return defined($it)? C4::Boolean::true_p($it): undef;
 543 }
 544
 545 =head2 enable_syspref_cache
 546
 547   C4::Context->enable_syspref_cache();
 548
 549 Enable the in-memory syspref cache used by C4::Context. This is the
 550 default behavior.
 551
 552 =cut
 553
 554 sub enable_syspref_cache {
 555     my ($self) = @_;
 556     $use_syspref_cache = 1;
 557 }
 558
 559 =head2 disable_syspref_cache
 560
 561   C4::Context->disable_syspref_cache();
 562
 563 Disable the in-memory syspref cache used by C4::Context. This should be
 564 used with Plack and other persistent environments.
 565
 566 =cut
 567
 568 sub disable_syspref_cache {
 569     my ($self) = @_;
 570     $use_syspref_cache = 0;
 571     $self->clear_syspref_cache();
 572 }
 573
 574 =head2 clear_syspref_cache
 575
 576   C4::Context->clear_syspref_cache();
 577
 578 cleans the internal cache of sysprefs. Please call this method if
 579 you update the systempreferences table. Otherwise, your new changes
 580 will not be seen by this process.
 581
 582 =cut
 583
 584 sub clear_syspref_cache {
 585     %sysprefs = ();
 586 }
 587
 588 =head2 set_preference
 589
 590   C4::Context->set_preference( $variable, $value );
 591
 592 This updates a preference's value both in the systempreferences table and in
 593 the sysprefs cache.
 594
 595 =cut
 596
 597 sub set_preference {
 598     my $self = shift;
 599     my $var = lc(shift);
 600     my $value = shift;
 601
 602     my $syspref = Koha::Config::SysPrefs->find( $var );
 603     my $type = $syspref ? $syspref->type() : undef;
 604
 605     $value = 0 if ( $type && $type eq 'YesNo' && $value eq '' );
 606
 607     # force explicit protocol on OPACBaseURL
 608     if ($var eq 'opacbaseurl' && substr($value,0,4) !~ /http/) {
 609         $value = 'http://' . $value;
 610     }
 611
 612     if ($syspref) {
 613         $syspref = $syspref->set( { value => $value } )->store();
 614     }
 615     else {
 616         $syspref = Koha::Config::SysPref->new( { variable => $var, value => $value } )->store();
 617     }
 618
 619     if ($syspref) {
 620         $sysprefs{$var} = $value;
 621     }
 622 }
 623
 624 =head2 Zconn
 625
 626   $Zconn = C4::Context->Zconn
 627
 628 Returns a connection to the Zebra database
 629
 630 C<$self>
 631
 632 C<$server> one of the servers defined in the koha-conf.xml file
 633
 634 C<$async> whether this is a asynchronous connection
 635
 636 =cut
 637
 638 sub Zconn {
 639     my ($self, $server, $async ) = @_;
 640     my $cache_key = join ('::', (map { $_ // '' } ($server, $async )));
 641     if ( (!defined($ENV{GATEWAY_INTERFACE})) && defined($context->{"Zconn"}->{$cache_key}) && (0 == $context->{"Zconn"}->{$cache_key}->errcode()) ) {
 642         # if we are running the script from the commandline, lets try to use the caching
 643         return $context->{"Zconn"}->{$cache_key};
 644     }
 645     $context->{"Zconn"}->{$cache_key}->destroy() if defined($context->{"Zconn"}->{$cache_key}); #destroy old connection before making a new one
 646     $context->{"Zconn"}->{$cache_key} = &_new_Zconn( $server, $async );
 647     return $context->{"Zconn"}->{$cache_key};
 648 }
 649
 650 =head2 _new_Zconn
 651
 652 $context->{"Zconn"} = &_new_Zconn($server,$async);
 653
 654 Internal function. Creates a new database connection from the data given in the current context and returns it.
 655
 656 C<$server> one of the servers defined in the koha-conf.xml file
 657
 658 C<$async> whether this is a asynchronous connection
 659
 660 C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
 661
 662 =cut
 663
 664 sub _new_Zconn {
 665     my ( $server, $async ) = @_;
 666
 667     my $tried=0; # first attempt
 668     my $Zconn; # connection object
 669     my $elementSetName;
 670     my $index_mode;
 671     my $syntax;
 672
 673     $server //= "biblioserver";
 674
 675     if ( $server eq 'biblioserver' ) {
 676         $index_mode = $context->{'config'}->{'zebra_bib_index_mode'} // 'dom';
 677     } elsif ( $server eq 'authorityserver' ) {
 678         $index_mode = $context->{'config'}->{'zebra_auth_index_mode'} // 'dom';
 679     }
 680
 681     if ( $index_mode eq 'grs1' ) {
 682         $elementSetName = 'F';
 683         $syntax = ( $context->preference("marcflavour") eq 'UNIMARC' )
 684                 ? 'unimarc'
 685                 : 'usmarc';
 686
 687     } else { # $index_mode eq 'dom'
 688         $syntax = 'xml';
 689         $elementSetName = 'marcxml';
 690     }
 691
 692     my $host = $context->{'listen'}->{$server}->{'content'};
 693     my $user = $context->{"serverinfo"}->{$server}->{"user"};
 694     my $password = $context->{"serverinfo"}->{$server}->{"password"};
 695     eval {
 696         # set options
 697         my $o = new ZOOM::Options();
 698         $o->option(user => $user) if $user && $password;
 699         $o->option(password => $password) if $user && $password;
 700         $o->option(async => 1) if $async;
 701         $o->option(cqlfile=> $context->{"server"}->{$server}->{"cql2rpn"});
 702         $o->option(cclfile=> $context->{"serverinfo"}->{$server}->{"ccl2rpn"});
 703         $o->option(preferredRecordSyntax => $syntax);
 704         $o->option(elementSetName => $elementSetName) if $elementSetName;
 705         $o->option(databaseName => $context->{"config"}->{$server}||"biblios");
 706
 707         # create a new connection object
 708         $Zconn= create ZOOM::Connection($o);
 709
 710         # forge to server
 711         $Zconn->connect($host, 0);
 712
 713         # check for errors and warn
 714         if ($Zconn->errcode() !=0) {
 715             warn "something wrong with the connection: ". $Zconn->errmsg();
 716         }
 717     };
 718     return $Zconn;
 719 }
 720
 721 # _new_dbh
 722 # Internal helper function (not a method!). This creates a new
 723 # database connection from the data given in the current context, and
 724 # returns it.
 725 sub _new_dbh
 726 {
 727
 728     Koha::Database->schema->storage->dbh;
 729 }
 730
 731 =head2 dbh
 732
 733   $dbh = C4::Context->dbh;
 734
 735 Returns a database handle connected to the Koha database for the
 736 current context. If no connection has yet been made, this method
 737 creates one, and connects to the database.
 738
 739 This database handle is cached for future use: if you call
 740 C<C4::Context-E<gt>dbh> twice, you will get the same handle both
 741 times. If you need a second database handle, use C<&new_dbh> and
 742 possibly C<&set_dbh>.
 743
 744 =cut
 745
 746 #'
 747 sub dbh
 748 {
 749     my $self = shift;
 750     my $params = shift;
 751     my $sth;
 752
 753     unless ( $params->{new} ) {
 754         if ( defined($context->{db_driver}) && $context->{db_driver} eq 'mysql' && $context->{"dbh"} ) {
 755             return $context->{"dbh"};
 756         } elsif ( defined($context->{"dbh"}) && $context->{"dbh"}->ping() ) {
 757             return $context->{"dbh"};
 758         }
 759     }
 760
 761     # No database handle or it died . Create one.
 762     $context->{"dbh"} = &_new_dbh();
 763
 764     return $context->{"dbh"};
 765 }
 766
 767 =head2 new_dbh
 768
 769   $dbh = C4::Context->new_dbh;
 770
 771 Creates a new connection to the Koha database for the current context,
 772 and returns the database handle (a C<DBI::db> object).
 773
 774 The handle is not saved anywhere: this method is strictly a
 775 convenience function; the point is that it knows which database to
 776 connect to so that the caller doesn't have to know.
 777
 778 =cut
 779
 780 #'
 781 sub new_dbh
 782 {
 783     my $self = shift;
 784
 785     return &_new_dbh();
 786 }
 787
 788 =head2 set_dbh
 789
 790   $my_dbh = C4::Connect->new_dbh;
 791   C4::Connect->set_dbh($my_dbh);
 792   ...
 793   C4::Connect->restore_dbh;
 794
 795 C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
 796 C<&set_context> and C<&restore_context>.
 797
 798 C<&set_dbh> saves the current database handle on a stack, then sets
 799 the current database handle to C<$my_dbh>.
 800
 801 C<$my_dbh> is assumed to be a good database handle.
 802
 803 =cut
 804
 805 #'
 806 sub set_dbh
 807 {
 808     my $self = shift;
 809     my $new_dbh = shift;
 810
 811     # Save the current database handle on the handle stack.
 812     # We assume that $new_dbh is all good: if the caller wants to
 813     # screw himself by passing an invalid handle, that's fine by
 814     # us.
 815     push @{$context->{"dbh_stack"}}, $context->{"dbh"};
 816     $context->{"dbh"} = $new_dbh;
 817 }
 818
 819 =head2 restore_dbh
 820
 821   C4::Context->restore_dbh;
 822
 823 Restores the database handle saved by an earlier call to
 824 C<C4::Context-E<gt>set_dbh>.
 825
 826 =cut
 827
 828 #'
 829 sub restore_dbh
 830 {
 831     my $self = shift;
 832
 833     if ($#{$context->{"dbh_stack"}} < 0)
 834     {
 835         # Stack underflow
 836         die "DBH stack underflow";
 837     }
 838
 839     # Pop the old database handle and set it.
 840     $context->{"dbh"} = pop @{$context->{"dbh_stack"}};
 841
 842     # FIXME - If it is determined that restore_context should
 843     # return something, then this function should, too.
 844 }
 845
 846 =head2 queryparser
 847
 848   $queryparser = C4::Context->queryparser
 849
 850 Returns a handle to an initialized Koha::QueryParser::Driver::PQF object.
 851
 852 =cut
 853
 854 sub queryparser {
 855     my $self = shift;
 856     unless (defined $context->{"queryparser"}) {
 857         $context->{"queryparser"} = &_new_queryparser();
 858     }
 859
 860     return
 861       defined( $context->{"queryparser"} )
 862       ? $context->{"queryparser"}->new
 863       : undef;
 864 }
 865
 866 =head2 _new_queryparser
 867
 868 Internal helper function to create a new QueryParser object. QueryParser
 869 is loaded dynamically so as to keep the lack of the QueryParser library from
 870 getting in anyone's way.
 871
 872 =cut
 873
 874 sub _new_queryparser {
 875     my $qpmodules = {
 876         'OpenILS::QueryParser'           => undef,
 877         'Koha::QueryParser::Driver::PQF' => undef
 878     };
 879     if ( can_load( 'modules' => $qpmodules ) ) {
 880         my $QParser     = Koha::QueryParser::Driver::PQF->new();
 881         my $config_file = $context->config('queryparser_config');
 882         $config_file ||= '/etc/koha/searchengine/queryparser.yaml';
 883         if ( $QParser->load_config($config_file) ) {
 884             # Set 'keyword' as the default search class
 885             $QParser->default_search_class('keyword');
 886             # TODO: allow indexes to be configured in the database
 887             return $QParser;
 888         }
 889     }
 890     return;
 891 }
 892
 893 =head2 marcfromkohafield
 894
 895   $dbh = C4::Context->marcfromkohafield;
 896
 897 Returns a hash with marcfromkohafield.
 898
 899 This hash is cached for future use: if you call
 900 C<C4::Context-E<gt>marcfromkohafield> twice, you will get the same hash without real DB access
 901
 902 =cut
 903
 904 #'
 905 sub marcfromkohafield
 906 {
 907     my $retval = {};
 908
 909     # If the hash already exists, return it.
 910     return $context->{"marcfromkohafield"} if defined($context->{"marcfromkohafield"});
 911
 912     # No hash. Create one.
 913     $context->{"marcfromkohafield"} = &_new_marcfromkohafield();
 914
 915     return $context->{"marcfromkohafield"};
 916 }
 917
 918 # _new_marcfromkohafield
 919 # Internal helper function (not a method!). This creates a new
 920 # hash with stopwords
 921 sub _new_marcfromkohafield
 922 {
 923     my $dbh = C4::Context->dbh;
 924     my $marcfromkohafield;
 925     my $sth = $dbh->prepare("select frameworkcode,kohafield,tagfield,tagsubfield from marc_subfield_structure where kohafield > ''");
 926     $sth->execute;
 927     while (my ($frameworkcode,$kohafield,$tagfield,$tagsubfield) = $sth->fetchrow) {
 928         my $retval = {};
 929         $marcfromkohafield->{$frameworkcode}->{$kohafield} = [$tagfield,$tagsubfield];
 930     }
 931     return $marcfromkohafield;
 932 }
 933
 934 =head2 stopwords
 935
 936   $dbh = C4::Context->stopwords;
 937
 938 Returns a hash with stopwords.
 939
 940 This hash is cached for future use: if you call
 941 C<C4::Context-E<gt>stopwords> twice, you will get the same hash without real DB access
 942
 943 =cut
 944
 945 #'
 946 sub stopwords
 947 {
 948     my $retval = {};
 949
 950     # If the hash already exists, return it.
 951     return $context->{"stopwords"} if defined($context->{"stopwords"});
 952
 953     # No hash. Create one.
 954     $context->{"stopwords"} = &_new_stopwords();
 955
 956     return $context->{"stopwords"};
 957 }
 958
 959 # _new_stopwords
 960 # Internal helper function (not a method!). This creates a new
 961 # hash with stopwords
 962 sub _new_stopwords
 963 {
 964     my $dbh = C4::Context->dbh;
 965     my $stopwordlist;
 966     my $sth = $dbh->prepare("select word from stopwords");
 967     $sth->execute;
 968     while (my $stopword = $sth->fetchrow_array) {
 969         $stopwordlist->{$stopword} = uc($stopword);
 970     }
 971     $stopwordlist->{A} = "A" unless $stopwordlist;
 972     return $stopwordlist;
 973 }
 974
 975 =head2 userenv
 976
 977   C4::Context->userenv;
 978
 979 Retrieves a hash for user environment variables.
 980
 981 This hash shall be cached for future use: if you call
 982 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
 983
 984 =cut
 985
 986 #'
 987 sub userenv {
 988     my $var = $context->{"activeuser"};
 989     if (defined $var and defined $context->{"userenv"}->{$var}) {
 990         return $context->{"userenv"}->{$var};
 991     } else {
 992         return;
 993     }
 994 }
 995
 996 =head2 set_userenv
 997
 998   C4::Context->set_userenv($usernum, $userid, $usercnum,
 999                            $userfirstname, $usersurname,
1000                            $userbranch, $branchname, $userflags,
1001                            $emailaddress, $branchprinter, $persona);
1002
1003 Establish a hash of user environment variables.
1004
1005 set_userenv is called in Auth.pm
1006
1007 =cut
1008
1009 #'
1010 sub set_userenv {
1011     shift @_;
1012     my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter, $persona, $shibboleth)=
1013     map { Encode::is_utf8( $_ ) ? $_ : Encode::decode('UTF-8', $_) } # CGI::Session doesn't handle utf-8, so we decode it here
1014     @_;
1015     my $var=$context->{"activeuser"} || '';
1016     my $cell = {
1017         "number"     => $usernum,
1018         "id"         => $userid,
1019         "cardnumber" => $usercnum,
1020         "firstname"  => $userfirstname,
1021         "surname"    => $usersurname,
1022         #possibly a law problem
1023         "branch"     => $userbranch,
1024         "branchname" => $branchname,
1025         "flags"      => $userflags,
1026         "emailaddress"     => $emailaddress,
1027         "branchprinter"    => $branchprinter,
1028         "persona"    => $persona,
1029         "shibboleth" => $shibboleth,
1030     };
1031     $context->{userenv}->{$var} = $cell;
1032     return $cell;
1033 }
1034
1035 sub set_shelves_userenv {
1036         my ($type, $shelves) = @_ or return;
1037         my $activeuser = $context->{activeuser} or return;
1038         $context->{userenv}->{$activeuser}->{barshelves} = $shelves if $type eq 'bar';
1039         $context->{userenv}->{$activeuser}->{pubshelves} = $shelves if $type eq 'pub';
1040         $context->{userenv}->{$activeuser}->{totshelves} = $shelves if $type eq 'tot';
1041 }
1042
1043 sub get_shelves_userenv {
1044         my $active;
1045         unless ($active = $context->{userenv}->{$context->{activeuser}}) {
1046                 $debug and warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}";
1047                 return;
1048         }
1049         my $totshelves = $active->{totshelves} or undef;
1050         my $pubshelves = $active->{pubshelves} or undef;
1051         my $barshelves = $active->{barshelves} or undef;
1052         return ($totshelves, $pubshelves, $barshelves);
1053 }
1054
1055 =head2 _new_userenv
1056
1057   C4::Context->_new_userenv($session);  # FIXME: This calling style is wrong for what looks like an _internal function
1058
1059 Builds a hash for user environment variables.
1060
1061 This hash shall be cached for future use: if you call
1062 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
1063
1064 _new_userenv is called in Auth.pm
1065
1066 =cut
1067
1068 #'
1069 sub _new_userenv
1070 {
1071     shift;  # Useless except it compensates for bad calling style
1072     my ($sessionID)= @_;
1073      $context->{"activeuser"}=$sessionID;
1074 }
1075
1076 =head2 _unset_userenv
1077
1078   C4::Context->_unset_userenv;
1079
1080 Destroys the hash for activeuser user environment variables.
1081
1082 =cut
1083
1084 #'
1085
1086 sub _unset_userenv
1087 {
1088     my ($sessionID)= @_;
1089     undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
1090 }
1091
1092
1093 =head2 get_versions
1094
1095   C4::Context->get_versions
1096
1097 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'.
1098
1099 =cut
1100
1101 #'
1102
1103 # A little example sub to show more debugging info for CGI::Carp
1104 sub get_versions {
1105     my %versions;
1106     $versions{kohaVersion}  = Koha::version();
1107     $versions{kohaDbVersion} = C4::Context->preference('version');
1108     $versions{osVersion} = join(" ", POSIX::uname());
1109     $versions{perlVersion} = $];
1110     {
1111         no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
1112         $versions{mysqlVersion}  = `mysql -V`;
1113         $versions{apacheVersion} = `httpd -v`;
1114         $versions{apacheVersion} = `httpd2 -v`            unless  $versions{apacheVersion} ;
1115         $versions{apacheVersion} = `apache2 -v`           unless  $versions{apacheVersion} ;
1116         $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless  $versions{apacheVersion} ;
1117     }
1118     return %versions;
1119 }
1120
1121
1122 =head2 tz
1123
1124   C4::Context->tz
1125
1126   Returns a DateTime::TimeZone object for the system timezone
1127
1128 =cut
1129
1130 sub tz {
1131     my $self = shift;
1132     if (!defined $context->{tz}) {
1133         $context->{tz} = DateTime::TimeZone->new(name => 'local');
1134     }
1135     return $context->{tz};
1136 }
1137
1138
1139 =head2 IsSuperLibrarian
1140
1141     C4::Context->IsSuperLibrarian();
1142
1143 =cut
1144
1145 sub IsSuperLibrarian {
1146     my $userenv = C4::Context->userenv;
1147
1148     unless ( $userenv and exists $userenv->{flags} ) {
1149         # If we reach this without a user environment,
1150         # assume that we're running from a command-line script,
1151         # and act as a superlibrarian.
1152         carp("C4::Context->userenv not defined!");
1153         return 1;
1154     }
1155
1156     return ($userenv->{flags}//0) % 2;
1157 }
1158
1159 =head2 interface
1160
1161 Sets the current interface for later retrieval in any Perl module
1162
1163     C4::Context->interface('opac');
1164     C4::Context->interface('intranet');
1165     my $interface = C4::Context->interface;
1166
1167 =cut
1168
1169 sub interface {
1170     my ($class, $interface) = @_;
1171
1172     if (defined $interface) {
1173         $interface = lc $interface;
1174         if ($interface eq 'opac' || $interface eq 'intranet') {
1175             $context->{interface} = $interface;
1176         } else {
1177             warn "invalid interface : '$interface'";
1178         }
1179     }
1180
1181     return $context->{interface} // 'opac';
1182 }
1183
1184 1;
1185 __END__
1186
1187 =head1 ENVIRONMENT
1188
1189 =head2 C<KOHA_CONF>
1190
1191 Specifies the configuration file to read.
1192
1193 =head1 SEE ALSO
1194
1195 XML::Simple
1196
1197 =head1 AUTHORS
1198
1199 Andrew Arensburger <arensb at ooblick dot com>
1200
1201 Joshua Ferraro <jmf at liblime dot com>
1202