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'], suppressempty => '');
 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         $stopwordlist->{$stopword} = uc($stopword);
 870     }
 871     $stopwordlist->{A} = "A" unless $stopwordlist;
 872     return $stopwordlist;
 873 }
 874
 875 =item userenv
 876
 877   C4::Context->userenv;
 878
 879 Retrieves a hash for user environment variables.
 880
 881 This hash shall be cached for future use: if you call
 882 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
 883
 884 =cut
 885
 886 #'
 887 sub userenv {
 888     my $var = $context->{"activeuser"};
 889     return $context->{"userenv"}->{$var} if (defined $var and defined $context->{"userenv"}->{$var});
 890     # insecure=1 management
 891     if ($context->{"dbh"} && $context->preference('insecure')) {
 892         my %insecure;
 893         $insecure{flags} = '16382';
 894         $insecure{branchname} ='Insecure';
 895         $insecure{number} ='0';
 896         $insecure{cardnumber} ='0';
 897         $insecure{id} = 'insecure';
 898         $insecure{branch} = 'INS';
 899         $insecure{emailaddress} = 'test@mode.insecure.com';
 900         return \%insecure;
 901     } else {
 902         return;
 903     }
 904 }
 905
 906 =item set_userenv
 907
 908   C4::Context->set_userenv($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $userflags, $emailaddress);
 909
 910 Establish a hash of user environment variables.
 911
 912 set_userenv is called in Auth.pm
 913
 914 =cut
 915
 916 #'
 917 sub set_userenv {
 918     my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter)= @_;
 919     my $var=$context->{"activeuser"};
 920     my $cell = {
 921         "number"     => $usernum,
 922         "id"         => $userid,
 923         "cardnumber" => $usercnum,
 924         "firstname"  => $userfirstname,
 925         "surname"    => $usersurname,
 926         #possibly a law problem
 927         "branch"     => $userbranch,
 928         "branchname" => $branchname,
 929         "flags"      => $userflags,
 930         "emailaddress"     => $emailaddress,
 931         "branchprinter"    => $branchprinter
 932     };
 933     $context->{userenv}->{$var} = $cell;
 934     return $cell;
 935 }
 936
 937 sub set_shelves_userenv ($$) {
 938         my ($type, $shelves) = @_ or return undef;
 939         my $activeuser = $context->{activeuser} or return undef;
 940         $context->{userenv}->{$activeuser}->{barshelves} = $shelves if $type eq 'bar';
 941         $context->{userenv}->{$activeuser}->{pubshelves} = $shelves if $type eq 'pub';
 942         $context->{userenv}->{$activeuser}->{totshelves} = $shelves if $type eq 'tot';
 943 }
 944
 945 sub get_shelves_userenv () {
 946         my $active;
 947         unless ($active = $context->{userenv}->{$context->{activeuser}}) {
 948                 $debug and warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}";
 949                 return undef;
 950         }
 951         my $totshelves = $active->{totshelves} or undef;
 952         my $pubshelves = $active->{pubshelves} or undef;
 953         my $barshelves = $active->{barshelves} or undef;
 954         return ($totshelves, $pubshelves, $barshelves);
 955 }
 956
 957 =item _new_userenv
 958
 959   C4::Context->_new_userenv($session);  # FIXME: This calling style is wrong for what looks like an _internal function
 960
 961 Builds a hash for user environment variables.
 962
 963 This hash shall be cached for future use: if you call
 964 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
 965
 966 _new_userenv is called in Auth.pm
 967
 968 =cut
 969
 970 #'
 971 sub _new_userenv
 972 {
 973     shift;  # Useless except it compensates for bad calling style
 974     my ($sessionID)= @_;
 975      $context->{"activeuser"}=$sessionID;
 976 }
 977
 978 =item _unset_userenv
 979
 980   C4::Context->_unset_userenv;
 981
 982 Destroys the hash for activeuser user environment variables.
 983
 984 =cut
 985
 986 #'
 987
 988 sub _unset_userenv
 989 {
 990     my ($sessionID)= @_;
 991     undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
 992 }
 993
 994
 995 =item get_versions
 996
 997   C4::Context->get_versions
 998
 999 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'.
1000
1001 =cut
1002
1003 #'
1004
1005 # A little example sub to show more debugging info for CGI::Carp
1006 sub get_versions {
1007     my %versions;
1008     $versions{kohaVersion}  = KOHAVERSION();
1009     $versions{kohaDbVersion} = C4::Context->preference('version');
1010     $versions{osVersion} = join(" ", POSIX::uname());
1011     $versions{perlVersion} = $];
1012     {
1013         no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
1014         $versions{mysqlVersion}  = `mysql -V`;
1015         $versions{apacheVersion} = `httpd -v`;
1016         $versions{apacheVersion} = `httpd2 -v`            unless  $versions{apacheVersion} ;
1017         $versions{apacheVersion} = `apache2 -v`           unless  $versions{apacheVersion} ;
1018         $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless  $versions{apacheVersion} ;
1019     }
1020     return %versions;
1021 }
1022
1023
1024 1;
1025 __END__
1026
1027 =back
1028
1029 =head1 ENVIRONMENT
1030
1031 =over 4
1032
1033 =item C<KOHA_CONF>
1034
1035 Specifies the configuration file to read.
1036
1037 =back
1038
1039 =head1 SEE ALSO
1040
1041 XML::Simple
1042
1043 =head1 AUTHORS
1044
1045 Andrew Arensburger <arensb at ooblick dot com>
1046
1047 Joshua Ferraro <jmf at liblime dot com>
1048
1049 =cut
1050
1051 # Revision 1.57  2007/05/22 09:13:55  tipaul
1052 # Bugfixes & improvements (various and minor) :
1053 # - updating templates to have tmpl_process3.pl running without any errors
1054 # - adding a drupal-like css for prog templates (with 3 small images)
1055 # - fixing some bugs in circulation & other scripts
1056 # - updating french translation
1057 # - fixing some typos in templates
1058 #
1059 # Revision 1.56  2007/04/23 15:21:17  tipaul
1060 # renaming currenttransfers to transferstoreceive
1061 #
1062 # Revision 1.55  2007/04/17 08:48:00  tipaul
1063 # circulation cleaning continued: bufixing
1064 #
1065 # Revision 1.54  2007/03/29 16:45:53  tipaul
1066 # Code cleaning of Biblio.pm (continued)
1067 #
1068 # All subs have be cleaned :
1069 # - removed useless
1070 # - merged some
1071 # - reordering Biblio.pm completly
1072 # - using only naming conventions
1073 #
1074 # Seems to have broken nothing, but it still has to be heavily tested.
1075 # Note that Biblio.pm is now much more efficient than previously & probably more reliable as well.
1076 #
1077 # Revision 1.53  2007/03/29 13:30:31  tipaul
1078 # Code cleaning :
1079 # == Biblio.pm cleaning (useless) ==
1080 # * some sub declaration dropped
1081 # * removed modbiblio sub
1082 # * removed moditem sub
1083 # * removed newitems. It was used only in finishrecieve. Replaced by a TransformKohaToMarc+AddItem, that is better.
1084 # * removed MARCkoha2marcItem
1085 # * removed MARCdelsubfield declaration
1086 # * removed MARCkoha2marcBiblio
1087 #
1088 # == Biblio.pm cleaning (naming conventions) ==
1089 # * MARCgettagslib renamed to GetMarcStructure
1090 # * MARCgetitems renamed to GetMarcItem
1091 # * MARCfind_frameworkcode renamed to GetFrameworkCode
1092 # * MARCmarc2koha renamed to TransformMarcToKoha
1093 # * MARChtml2marc renamed to TransformHtmlToMarc
1094 # * MARChtml2xml renamed to TranformeHtmlToXml
1095 # * zebraop renamed to ModZebra
1096 #
1097 # == MARC=OFF ==
1098 # * removing MARC=OFF related scripts (in cataloguing directory)
1099 # * removed checkitems (function related to MARC=off feature, that is completly broken in head. If someone want to reintroduce it, hard work coming...)
1100 # * removed getitemsbybiblioitem (used only by MARC=OFF scripts, that is removed as well)
1101 #
1102 # Revision 1.52  2007/03/16 01:25:08  kados
1103 # Using my precrash CVS copy I did the following:
1104 #
1105 # cvs -z3 -d:ext:kados@cvs.savannah.nongnu.org:/sources/koha co -P koha
1106 # find koha.precrash -type d -name "CVS" -exec rm -v {} \;
1107 # cp -r koha.precrash/* koha/
1108 # cd koha/
1109 # cvs commit
1110 #
1111 # This should in theory put us right back where we were before the crash
1112 #
1113 # Revision 1.52  2007/03/12 21:17:05  rych
1114 # add server, serverinfo as arrays from config
1115 #
1116 # Revision 1.51  2007/03/09 14:31:47  tipaul
1117 # rel_3_0 moved to HEAD
1118 #
1119 # Revision 1.43.2.10  2007/02/09 17:17:56  hdl
1120 # Managing a little better database absence.
1121 # (preventing from BIG 550)
1122 #
1123 # Revision 1.43.2.9  2006/12/20 16:50:48  tipaul
1124 # improving "insecure" management
1125 #
1126 # WARNING KADOS :
1127 # you told me that you had some libraries with insecure=ON (behind a firewall).
1128 # 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.
1129 #
1130 # Revision 1.43.2.8  2006/12/19 16:48:16  alaurin
1131 # reident programs, and adding branchcode value in reserves
1132 #
1133 # Revision 1.43.2.7  2006/12/06 21:55:38  hdl
1134 # Adding ModZebrations for servers to get serverinfos in Context.pm
1135 # Using this function in rebuild_zebra.pl
1136 #
1137 # Revision 1.43.2.6  2006/11/24 21:18:31  kados
1138 # very minor changes, no functional ones, just comments, etc.
1139 #
1140 # Revision 1.43.2.5  2006/10/30 13:24:16  toins
1141 # fix some minor POD error.
1142 #
1143 # Revision 1.43.2.4  2006/10/12 21:42:49  hdl
1144 # Managing multiple zebra connections
1145 #
1146 # Revision 1.43.2.3  2006/10/11 14:27:26  tipaul
1147 # removing a warning
1148 #
1149 # Revision 1.43.2.2  2006/10/10 15:28:16  hdl
1150 # BUG FIXING : using database name in Zconn if defined and not hard coded value
1151 #
1152 # Revision 1.43.2.1  2006/10/06 13:47:28  toins
1153 # Synch with dev_week.
1154 #  /!\ WARNING :: Please now use the new version of koha.xml.
1155 #
1156 # Revision 1.18.2.5.2.14  2006/09/24 15:24:06  kados
1157 # remove Zebraauth routine, fold the functionality into Zconn
1158 # Zconn can now take several arguments ... this will probably
1159 # change soon as I'm not completely happy with the readability
1160 # of the current format ... see the POD for details.
1161 #
1162 # cleaning up Biblio.pm, removing unnecessary routines.
1163 #
1164 # DeleteBiblio - used to delete a biblio from zebra and koha tables
1165 #     -- checks to make sure there are no existing issues
1166 #     -- saves backups of biblio,biblioitems,items in deleted* tables
1167 #     -- does commit operation
1168 #
1169 # getRecord - used to retrieve one record from zebra in piggyback mode using biblionumber
1170 # brought back z3950_extended_services routine
1171 #
1172 # Lots of modifications to Context.pm, you can now store user and pass info for
1173 # multiple servers (for federated searching) using the <serverinfo> element.
1174 # I'll commit my koha.xml to demonstrate this or you can refer to the POD in
1175 # Context.pm (which I also expanded on).
1176 #
1177 # Revision 1.18.2.5.2.13  2006/08/10 02:10:21  kados
1178 # Turned warnings on, and running a search turned up lots of warnings.
1179 # Cleaned up those ...
1180 #
1181 # removed getitemtypes from Koha.pm (one in Search.pm looks newer)
1182 # removed itemcount from Biblio.pm
1183 #
1184 # made some local subs local with a _ prefix (as they were redefined
1185 # elsewhere)
1186 #
1187 # Add two new search subs to Search.pm the start of a new search API
1188 # that's a bit more scalable
1189 #
1190 # Revision 1.18.2.5.2.10  2006/07/21 17:50:51  kados
1191 # moving the *.properties files to intranetdir/etc dir
1192 #
1193 # Revision 1.18.2.5.2.9  2006/07/17 08:05:20  tipaul
1194 # there was a hardcoded link to /koha/etc/ I replaced it with intranetdir config value
1195 #
1196 # Revision 1.18.2.5.2.8  2006/07/11 12:20:37  kados
1197 # adding ccl and cql files ... Tumer, if you want to fit these into the
1198 # config file by all means do.
1199 #
1200 # Revision 1.18.2.5.2.7  2006/06/04 22:50:33  tgarip1957
1201 # We do not hard code cql2rpn conversion file in context.pm our koha.xml configuration file already describes the path for this file.
1202 # At cql searching we use method CQL not CQL2RPN as the cql2rpn conversion file is defined at server level
1203 #
1204 # Revision 1.18.2.5.2.6  2006/06/02 23:11:24  kados
1205 # Committing my working dev_week. It's been tested only with
1206 # searching, and there's quite a lot of config stuff to set up
1207 # beforehand. As things get closer to a release, we'll be making
1208 # some scripts to do it for us
1209 #
1210 # Revision 1.18.2.5.2.5  2006/05/28 18:49:12  tgarip1957
1211 # This is an unusual commit. The main purpose is a working model of Zebra on a modified rel2_2.
1212 # Any questions regarding these commits should be asked to Joshua Ferraro unless you are Joshua whom I'll report to
1213 #
1214 # Revision 1.36  2006/05/09 13:28:08  tipaul
1215 # adding the branchname and the librarian name in every page :
1216 # - modified userenv to add branchname
1217 # - modifier menus.inc to have the librarian name & userenv displayed on every page. they are in a librarian_information div.
1218 #
1219 # Revision 1.35  2006/04/13 08:40:11  plg
1220 # bug fixed: typo on Zconnauth name
1221 #
1222 # Revision 1.34  2006/04/10 21:40:23  tgarip1957
1223 # 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:
1224 # zebradb=localhost
1225 # zebraport=<your port>
1226 # zebrauser=<username>
1227 # zebrapass=<password>
1228 #
1229 # The zebra.cfg file should read:
1230 # perm.anonymous:r
1231 # perm.username:rw
1232 # passw.c:<yourpasswordfile>
1233 #
1234 # Password file should be prepared with Apaches htpasswd utility in encrypted mode and should exist in a folder zebra.cfg can read
1235 #
1236 # Revision 1.33  2006/03/15 11:21:56  plg
1237 # bug fixed: utf-8 data where not displayed correctly in screens. Supposing
1238 # your data are truely utf-8 encoded in your database, they should be
1239 # correctly displayed. "set names 'UTF8'" on mysql connection (C4/Context.pm)
1240 # is mandatory and "binmode" to utf8 (C4/Interface/CGI/Output.pm) seemed to
1241 # converted data twice, so it was removed.
1242 #
1243 # Revision 1.32  2006/03/03 17:25:01  hdl
1244 # Bug fixing : a line missed a comment sign.
1245 #
1246 # Revision 1.31  2006/03/03 16:45:36  kados
1247 # Remove the search that tests the Zconn -- warning, still no fault
1248 # tollerance
1249 #
1250 # Revision 1.30  2006/02/22 00:56:59  kados
1251 # First go at a connection object for Zebra. You can now get a
1252 # connection object by doing:
1253 #
1254 # my $Zconn = C4::Context->Zconn;
1255 #
1256 # My initial tests indicate that as soon as your funcion ends
1257 # (ie, when you're done doing something) the connection will be
1258 # closed automatically. There may be some other way to make the
1259 # connection more stateful, I'm not sure...
1260 #
1261 # Local Variables:
1262 # tab-width: 4
1263 # End: