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