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