C4/Context.pm

   1 package C4::Context;
   2 # Copyright 2002 Katipo Communications
   3 #
   4 # This file is part of Koha.
   5 #
   6 # Koha is free software; you can redistribute it and/or modify it under the
   7 # terms of the GNU General Public License as published by the Free Software
   8 # Foundation; either version 2 of the License, or (at your option) any later
   9 # version.
  10 #
  11 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  12 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  13 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License along
  16 # with Koha; if not, write to the Free Software Foundation, Inc.,
  17 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  18
  19 use strict;
  20 use warnings;
  21 use vars qw($VERSION $AUTOLOAD $context @context_stack);
  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 =item set_preference
 511
 512   C4::Context->set_preference( $variable, $value );
 513
 514   This updates a preference's value both in the systempreferences table and in
 515   the sysprefs cache.
 516
 517 =cut
 518
 519 sub set_preference {
 520     my $self = shift;
 521     my $var = shift;
 522     my $value = shift;
 523
 524     my $dbh = C4::Context->dbh or return 0;
 525
 526     my $type = $dbh->selectrow_array( "SELECT type FROM systempreferences WHERE variable = ?", {}, $var );
 527
 528     $value = 0 if ( $type && $type eq 'YesNo' && $value eq '' );
 529
 530     my $sth = $dbh->prepare( "
 531       INSERT INTO systempreferences
 532         ( variable, value )
 533         VALUES( ?, ? )
 534         ON DUPLICATE KEY UPDATE value = VALUES(value)
 535     " );
 536
 537     $sth->execute( $var, $value );
 538     $sth->finish;
 539 }
 540
 541 # AUTOLOAD
 542 # This implements C4::Config->foo, and simply returns
 543 # C4::Context->config("foo"), as described in the documentation for
 544 # &config, above.
 545
 546 # FIXME - Perhaps this should be extended to check &config first, and
 547 # then &preference if that fails. OTOH, AUTOLOAD could lead to crappy
 548 # code, so it'd probably be best to delete it altogether so as not to
 549 # encourage people to use it.
 550 sub AUTOLOAD
 551 {
 552     my $self = shift;
 553
 554     $AUTOLOAD =~ s/.*:://;        # Chop off the package name,
 555                     # leaving only the function name.
 556     return $self->config($AUTOLOAD);
 557 }
 558
 559 =item Zconn
 560
 561 $Zconn = C4::Context->Zconn
 562
 563 Returns a connection to the Zebra database for the current
 564 context. If no connection has yet been made, this method
 565 creates one and connects.
 566
 567 C<$self>
 568
 569 C<$server> one of the servers defined in the koha-conf.xml file
 570
 571 C<$async> whether this is a asynchronous connection
 572
 573 C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
 574
 575
 576 =cut
 577
 578 sub Zconn {
 579     my $self=shift;
 580     my $server=shift;
 581     my $async=shift;
 582     my $auth=shift;
 583     my $piggyback=shift;
 584     my $syntax=shift;
 585     if ( defined($context->{"Zconn"}->{$server}) && (0 == $context->{"Zconn"}->{$server}->errcode()) ) {
 586         return $context->{"Zconn"}->{$server};
 587     # No connection object or it died. Create one.
 588     }else {
 589         # release resources if we're closing a connection and making a new one
 590         # FIXME: this needs to be smarter -- an error due to a malformed query or
 591         # a missing index does not necessarily require us to close the connection
 592         # and make a new one, particularly for a batch job.  However, at
 593         # first glance it does not look like there's a way to easily check
 594         # the basic health of a ZOOM::Connection
 595         $context->{"Zconn"}->{$server}->destroy() if defined($context->{"Zconn"}->{$server});
 596
 597         $context->{"Zconn"}->{$server} = &_new_Zconn($server,$async,$auth,$piggyback,$syntax);
 598         return $context->{"Zconn"}->{$server};
 599     }
 600 }
 601
 602 =item _new_Zconn
 603
 604 $context->{"Zconn"} = &_new_Zconn($server,$async);
 605
 606 Internal function. Creates a new database connection from the data given in the current context and returns it.
 607
 608 C<$server> one of the servers defined in the koha-conf.xml file
 609
 610 C<$async> whether this is a asynchronous connection
 611
 612 C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
 613
 614 =cut
 615
 616 sub _new_Zconn {
 617     my ($server,$async,$auth,$piggyback,$syntax) = @_;
 618
 619     my $tried=0; # first attempt
 620     my $Zconn; # connection object
 621     $server = "biblioserver" unless $server;
 622     $syntax = "usmarc" unless $syntax;
 623
 624     my $host = $context->{'listen'}->{$server}->{'content'};
 625     my $servername = $context->{"config"}->{$server};
 626     my $user = $context->{"serverinfo"}->{$server}->{"user"};
 627     my $password = $context->{"serverinfo"}->{$server}->{"password"};
 628  $auth = 1 if($user && $password);
 629     retry:
 630     eval {
 631         # set options
 632         my $o = new ZOOM::Options();
 633         $o->option(user=>$user) if $auth;
 634         $o->option(password=>$password) if $auth;
 635         $o->option(async => 1) if $async;
 636         $o->option(count => $piggyback) if $piggyback;
 637         $o->option(cqlfile=> $context->{"server"}->{$server}->{"cql2rpn"});
 638         $o->option(cclfile=> $context->{"serverinfo"}->{$server}->{"ccl2rpn"});
 639         $o->option(preferredRecordSyntax => $syntax);
 640         $o->option(elementSetName => "F"); # F for 'full' as opposed to B for 'brief'
 641         $o->option(databaseName => ($servername?$servername:"biblios"));
 642
 643         # create a new connection object
 644         $Zconn= create ZOOM::Connection($o);
 645
 646         # forge to server
 647         $Zconn->connect($host, 0);
 648
 649         # check for errors and warn
 650         if ($Zconn->errcode() !=0) {
 651             warn "something wrong with the connection: ". $Zconn->errmsg();
 652         }
 653
 654     };
 655 #     if ($@) {
 656 #         # Koha manages the Zebra server -- this doesn't work currently for me because of permissions issues
 657 #         # Also, I'm skeptical about whether it's the best approach
 658 #         warn "problem with Zebra";
 659 #         if ( C4::Context->preference("ManageZebra") ) {
 660 #             if ($@->code==10000 && $tried==0) { ##No connection try restarting Zebra
 661 #                 $tried=1;
 662 #                 warn "trying to restart Zebra";
 663 #                 my $res=system("zebrasrv -f $ENV{'KOHA_CONF'} >/koha/log/zebra-error.log");
 664 #                 goto "retry";
 665 #             } else {
 666 #                 warn "Error ", $@->code(), ": ", $@->message(), "\n";
 667 #                 $Zconn="error";
 668 #                 return $Zconn;
 669 #             }
 670 #         }
 671 #     }
 672     return $Zconn;
 673 }
 674
 675 # _new_dbh
 676 # Internal helper function (not a method!). This creates a new
 677 # database connection from the data given in the current context, and
 678 # returns it.
 679 sub _new_dbh
 680 {
 681
 682     ## $context
 683     ## correct name for db_schme
 684     my $db_driver;
 685     if ($context->config("db_scheme")){
 686         $db_driver=db_scheme2dbi($context->config("db_scheme"));
 687     }else{
 688         $db_driver="mysql";
 689     }
 690
 691     my $db_name   = $context->config("database");
 692     my $db_host   = $context->config("hostname");
 693     my $db_port   = $context->config("port") || '';
 694     my $db_user   = $context->config("user");
 695     my $db_passwd = $context->config("pass");
 696     # MJR added or die here, as we can't work without dbh
 697     my $dbh= DBI->connect("DBI:$db_driver:dbname=$db_name;host=$db_host;port=$db_port",
 698         $db_user, $db_passwd) or die $DBI::errstr;
 699         my $tz = $ENV{TZ};
 700     if ( $db_driver eq 'mysql' ) {
 701         # Koha 3.0 is utf-8, so force utf8 communication between mySQL and koha, whatever the mysql default config.
 702         # this is better than modifying my.cnf (and forcing all communications to be in utf8)
 703         $dbh->{'mysql_enable_utf8'}=1; #enable
 704         $dbh->do("set NAMES 'utf8'");
 705         ($tz) and $dbh->do(qq(SET time_zone = "$tz"));
 706     }
 707     elsif ( $db_driver eq 'Pg' ) {
 708             $dbh->do( "set client_encoding = 'UTF8';" );
 709         ($tz) and $dbh->do(qq(SET TIME ZONE = "$tz"));
 710     }
 711     return $dbh;
 712 }
 713
 714 =item dbh
 715
 716   $dbh = C4::Context->dbh;
 717
 718 Returns a database handle connected to the Koha database for the
 719 current context. If no connection has yet been made, this method
 720 creates one, and connects to the database.
 721
 722 This database handle is cached for future use: if you call
 723 C<C4::Context-E<gt>dbh> twice, you will get the same handle both
 724 times. If you need a second database handle, use C<&new_dbh> and
 725 possibly C<&set_dbh>.
 726
 727 =cut
 728
 729 #'
 730 sub dbh
 731 {
 732     my $self = shift;
 733     my $sth;
 734
 735     if (defined($context->{"dbh"}) && $context->{"dbh"}->ping()) {
 736         return $context->{"dbh"};
 737     }
 738
 739     # No database handle or it died . Create one.
 740     $context->{"dbh"} = &_new_dbh();
 741
 742     return $context->{"dbh"};
 743 }
 744
 745 =item new_dbh
 746
 747   $dbh = C4::Context->new_dbh;
 748
 749 Creates a new connection to the Koha database for the current context,
 750 and returns the database handle (a C<DBI::db> object).
 751
 752 The handle is not saved anywhere: this method is strictly a
 753 convenience function; the point is that it knows which database to
 754 connect to so that the caller doesn't have to know.
 755
 756 =cut
 757
 758 #'
 759 sub new_dbh
 760 {
 761     my $self = shift;
 762
 763     return &_new_dbh();
 764 }
 765
 766 =item set_dbh
 767
 768   $my_dbh = C4::Connect->new_dbh;
 769   C4::Connect->set_dbh($my_dbh);
 770   ...
 771   C4::Connect->restore_dbh;
 772
 773 C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
 774 C<&set_context> and C<&restore_context>.
 775
 776 C<&set_dbh> saves the current database handle on a stack, then sets
 777 the current database handle to C<$my_dbh>.
 778
 779 C<$my_dbh> is assumed to be a good database handle.
 780
 781 =cut
 782
 783 #'
 784 sub set_dbh
 785 {
 786     my $self = shift;
 787     my $new_dbh = shift;
 788
 789     # Save the current database handle on the handle stack.
 790     # We assume that $new_dbh is all good: if the caller wants to
 791     # screw himself by passing an invalid handle, that's fine by
 792     # us.
 793     push @{$context->{"dbh_stack"}}, $context->{"dbh"};
 794     $context->{"dbh"} = $new_dbh;
 795 }
 796
 797 =item restore_dbh
 798
 799   C4::Context->restore_dbh;
 800
 801 Restores the database handle saved by an earlier call to
 802 C<C4::Context-E<gt>set_dbh>.
 803
 804 =cut
 805
 806 #'
 807 sub restore_dbh
 808 {
 809     my $self = shift;
 810
 811     if ($#{$context->{"dbh_stack"}} < 0)
 812     {
 813         # Stack underflow
 814         die "DBH stack underflow";
 815     }
 816
 817     # Pop the old database handle and set it.
 818     $context->{"dbh"} = pop @{$context->{"dbh_stack"}};
 819
 820     # FIXME - If it is determined that restore_context should
 821     # return something, then this function should, too.
 822 }
 823
 824 =item marcfromkohafield
 825
 826   $dbh = C4::Context->marcfromkohafield;
 827
 828 Returns a hash with marcfromkohafield.
 829
 830 This hash is cached for future use: if you call
 831 C<C4::Context-E<gt>marcfromkohafield> twice, you will get the same hash without real DB access
 832
 833 =cut
 834
 835 #'
 836 sub marcfromkohafield
 837 {
 838     my $retval = {};
 839
 840     # If the hash already exists, return it.
 841     return $context->{"marcfromkohafield"} if defined($context->{"marcfromkohafield"});
 842
 843     # No hash. Create one.
 844     $context->{"marcfromkohafield"} = &_new_marcfromkohafield();
 845
 846     return $context->{"marcfromkohafield"};
 847 }
 848
 849 # _new_marcfromkohafield
 850 # Internal helper function (not a method!). This creates a new
 851 # hash with stopwords
 852 sub _new_marcfromkohafield
 853 {
 854     my $dbh = C4::Context->dbh;
 855     my $marcfromkohafield;
 856     my $sth = $dbh->prepare("select frameworkcode,kohafield,tagfield,tagsubfield from marc_subfield_structure where kohafield > ''");
 857     $sth->execute;
 858     while (my ($frameworkcode,$kohafield,$tagfield,$tagsubfield) = $sth->fetchrow) {
 859         my $retval = {};
 860         $marcfromkohafield->{$frameworkcode}->{$kohafield} = [$tagfield,$tagsubfield];
 861     }
 862     return $marcfromkohafield;
 863 }
 864
 865 =item stopwords
 866
 867   $dbh = C4::Context->stopwords;
 868
 869 Returns a hash with stopwords.
 870
 871 This hash is cached for future use: if you call
 872 C<C4::Context-E<gt>stopwords> twice, you will get the same hash without real DB access
 873
 874 =cut
 875
 876 #'
 877 sub stopwords
 878 {
 879     my $retval = {};
 880
 881     # If the hash already exists, return it.
 882     return $context->{"stopwords"} if defined($context->{"stopwords"});
 883
 884     # No hash. Create one.
 885     $context->{"stopwords"} = &_new_stopwords();
 886
 887     return $context->{"stopwords"};
 888 }
 889
 890 # _new_stopwords
 891 # Internal helper function (not a method!). This creates a new
 892 # hash with stopwords
 893 sub _new_stopwords
 894 {
 895     my $dbh = C4::Context->dbh;
 896     my $stopwordlist;
 897     my $sth = $dbh->prepare("select word from stopwords");
 898     $sth->execute;
 899     while (my $stopword = $sth->fetchrow_array) {
 900         $stopwordlist->{$stopword} = uc($stopword);
 901     }
 902     $stopwordlist->{A} = "A" unless $stopwordlist;
 903     return $stopwordlist;
 904 }
 905
 906 =item userenv
 907
 908   C4::Context->userenv;
 909
 910 Retrieves a hash for user environment variables.
 911
 912 This hash shall be cached for future use: if you call
 913 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
 914
 915 =cut
 916
 917 #'
 918 sub userenv {
 919     my $var = $context->{"activeuser"};
 920     return $context->{"userenv"}->{$var} if (defined $var and defined $context->{"userenv"}->{$var});
 921     # insecure=1 management
 922     if ($context->{"dbh"} && $context->preference('insecure')) {
 923         my %insecure;
 924         $insecure{flags} = '16382';
 925         $insecure{branchname} ='Insecure';
 926         $insecure{number} ='0';
 927         $insecure{cardnumber} ='0';
 928         $insecure{id} = 'insecure';
 929         $insecure{branch} = 'INS';
 930         $insecure{emailaddress} = 'test@mode.insecure.com';
 931         return \%insecure;
 932     } else {
 933         return;
 934     }
 935 }
 936
 937 =item set_userenv
 938
 939   C4::Context->set_userenv($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $userflags, $emailaddress);
 940
 941 Establish a hash of user environment variables.
 942
 943 set_userenv is called in Auth.pm
 944
 945 =cut
 946
 947 #'
 948 sub set_userenv {
 949     my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter)= @_;
 950     my $var=$context->{"activeuser"};
 951     my $cell = {
 952         "number"     => $usernum,
 953         "id"         => $userid,
 954         "cardnumber" => $usercnum,
 955         "firstname"  => $userfirstname,
 956         "surname"    => $usersurname,
 957         #possibly a law problem
 958         "branch"     => $userbranch,
 959         "branchname" => $branchname,
 960         "flags"      => $userflags,
 961         "emailaddress"     => $emailaddress,
 962         "branchprinter"    => $branchprinter
 963     };
 964     $context->{userenv}->{$var} = $cell;
 965     return $cell;
 966 }
 967
 968 sub set_shelves_userenv ($$) {
 969         my ($type, $shelves) = @_ or return undef;
 970         my $activeuser = $context->{activeuser} or return undef;
 971         $context->{userenv}->{$activeuser}->{barshelves} = $shelves if $type eq 'bar';
 972         $context->{userenv}->{$activeuser}->{pubshelves} = $shelves if $type eq 'pub';
 973         $context->{userenv}->{$activeuser}->{totshelves} = $shelves if $type eq 'tot';
 974 }
 975
 976 sub get_shelves_userenv () {
 977         my $active;
 978         unless ($active = $context->{userenv}->{$context->{activeuser}}) {
 979                 $debug and warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}";
 980                 return undef;
 981         }
 982         my $totshelves = $active->{totshelves} or undef;
 983         my $pubshelves = $active->{pubshelves} or undef;
 984         my $barshelves = $active->{barshelves} or undef;
 985         return ($totshelves, $pubshelves, $barshelves);
 986 }
 987
 988 =item _new_userenv
 989
 990   C4::Context->_new_userenv($session);  # FIXME: This calling style is wrong for what looks like an _internal function
 991
 992 Builds a hash for user environment variables.
 993
 994 This hash shall be cached for future use: if you call
 995 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
 996
 997 _new_userenv is called in Auth.pm
 998
 999 =cut
1000
1001 #'
1002 sub _new_userenv
1003 {
1004     shift;  # Useless except it compensates for bad calling style
1005     my ($sessionID)= @_;
1006      $context->{"activeuser"}=$sessionID;
1007 }
1008
1009 =item _unset_userenv
1010
1011   C4::Context->_unset_userenv;
1012
1013 Destroys the hash for activeuser user environment variables.
1014
1015 =cut
1016
1017 #'
1018
1019 sub _unset_userenv
1020 {
1021     my ($sessionID)= @_;
1022     undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
1023 }
1024
1025
1026 =item get_versions
1027
1028   C4::Context->get_versions
1029
1030 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'.
1031
1032 =cut
1033
1034 #'
1035
1036 # A little example sub to show more debugging info for CGI::Carp
1037 sub get_versions {
1038     my %versions;
1039     $versions{kohaVersion}  = KOHAVERSION();
1040     $versions{kohaDbVersion} = C4::Context->preference('version');
1041     $versions{osVersion} = join(" ", POSIX::uname());
1042     $versions{perlVersion} = $];
1043     {
1044         no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
1045         $versions{mysqlVersion}  = `mysql -V`;
1046         $versions{apacheVersion} = `httpd -v`;
1047         $versions{apacheVersion} = `httpd2 -v`            unless  $versions{apacheVersion} ;
1048         $versions{apacheVersion} = `apache2 -v`           unless  $versions{apacheVersion} ;
1049         $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless  $versions{apacheVersion} ;
1050     }
1051     return %versions;
1052 }
1053
1054
1055 1;
1056 __END__
1057
1058 =back
1059
1060 =head1 ENVIRONMENT
1061
1062 =over 4
1063
1064 =item C<KOHA_CONF>
1065
1066 Specifies the configuration file to read.
1067
1068 =back
1069
1070 =head1 SEE ALSO
1071
1072 XML::Simple
1073
1074 =head1 AUTHORS
1075
1076 Andrew Arensburger <arensb at ooblick dot com>
1077
1078 Joshua Ferraro <jmf at liblime dot com>
1079
1080 =cut
1081
1082 # Revision 1.57  2007/05/22 09:13:55  tipaul
1083 # Bugfixes & improvements (various and minor) :
1084 # - updating templates to have tmpl_process3.pl running without any errors
1085 # - adding a drupal-like css for prog templates (with 3 small images)
1086 # - fixing some bugs in circulation & other scripts
1087 # - updating french translation
1088 # - fixing some typos in templates
1089 #
1090 # Revision 1.56  2007/04/23 15:21:17  tipaul
1091 # renaming currenttransfers to transferstoreceive
1092 #
1093 # Revision 1.55  2007/04/17 08:48:00  tipaul
1094 # circulation cleaning continued: bufixing
1095 #
1096 # Revision 1.54  2007/03/29 16:45:53  tipaul
1097 # Code cleaning of Biblio.pm (continued)
1098 #
1099 # All subs have be cleaned :
1100 # - removed useless
1101 # - merged some
1102 # - reordering Biblio.pm completly
1103 # - using only naming conventions
1104 #
1105 # Seems to have broken nothing, but it still has to be heavily tested.
1106 # Note that Biblio.pm is now much more efficient than previously & probably more reliable as well.
1107 #
1108 # Revision 1.53  2007/03/29 13:30:31  tipaul
1109 # Code cleaning :
1110 # == Biblio.pm cleaning (useless) ==
1111 # * some sub declaration dropped
1112 # * removed modbiblio sub
1113 # * removed moditem sub
1114 # * removed newitems. It was used only in finishrecieve. Replaced by a TransformKohaToMarc+AddItem, that is better.
1115 # * removed MARCkoha2marcItem
1116 # * removed MARCdelsubfield declaration
1117 # * removed MARCkoha2marcBiblio
1118 #
1119 # == Biblio.pm cleaning (naming conventions) ==
1120 # * MARCgettagslib renamed to GetMarcStructure
1121 # * MARCgetitems renamed to GetMarcItem
1122 # * MARCfind_frameworkcode renamed to GetFrameworkCode
1123 # * MARCmarc2koha renamed to TransformMarcToKoha
1124 # * MARChtml2marc renamed to TransformHtmlToMarc
1125 # * MARChtml2xml renamed to TranformeHtmlToXml
1126 # * zebraop renamed to ModZebra
1127 #
1128 # == MARC=OFF ==
1129 # * removing MARC=OFF related scripts (in cataloguing directory)
1130 # * removed checkitems (function related to MARC=off feature, that is completly broken in head. If someone want to reintroduce it, hard work coming...)
1131 # * removed getitemsbybiblioitem (used only by MARC=OFF scripts, that is removed as well)
1132 #
1133 # Revision 1.52  2007/03/16 01:25:08  kados
1134 # Using my precrash CVS copy I did the following:
1135 #
1136 # cvs -z3 -d:ext:kados@cvs.savannah.nongnu.org:/sources/koha co -P koha
1137 # find koha.precrash -type d -name "CVS" -exec rm -v {} \;
1138 # cp -r koha.precrash/* koha/
1139 # cd koha/
1140 # cvs commit
1141 #
1142 # This should in theory put us right back where we were before the crash
1143 #
1144 # Revision 1.52  2007/03/12 21:17:05  rych
1145 # add server, serverinfo as arrays from config
1146 #
1147 # Revision 1.51  2007/03/09 14:31:47  tipaul
1148 # rel_3_0 moved to HEAD
1149 #
1150 # Revision 1.43.2.10  2007/02/09 17:17:56  hdl
1151 # Managing a little better database absence.
1152 # (preventing from BIG 550)
1153 #
1154 # Revision 1.43.2.9  2006/12/20 16:50:48  tipaul
1155 # improving "insecure" management
1156 #
1157 # WARNING KADOS :
1158 # you told me that you had some libraries with insecure=ON (behind a firewall).
1159 # 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.
1160 #
1161 # Revision 1.43.2.8  2006/12/19 16:48:16  alaurin
1162 # reident programs, and adding branchcode value in reserves
1163 #
1164 # Revision 1.43.2.7  2006/12/06 21:55:38  hdl
1165 # Adding ModZebrations for servers to get serverinfos in Context.pm
1166 # Using this function in rebuild_zebra.pl
1167 #
1168 # Revision 1.43.2.6  2006/11/24 21:18:31  kados
1169 # very minor changes, no functional ones, just comments, etc.
1170 #
1171 # Revision 1.43.2.5  2006/10/30 13:24:16  toins
1172 # fix some minor POD error.
1173 #
1174 # Revision 1.43.2.4  2006/10/12 21:42:49  hdl
1175 # Managing multiple zebra connections
1176 #
1177 # Revision 1.43.2.3  2006/10/11 14:27:26  tipaul
1178 # removing a warning
1179 #
1180 # Revision 1.43.2.2  2006/10/10 15:28:16  hdl
1181 # BUG FIXING : using database name in Zconn if defined and not hard coded value
1182 #
1183 # Revision 1.43.2.1  2006/10/06 13:47:28  toins
1184 # Synch with dev_week.
1185 #  /!\ WARNING :: Please now use the new version of koha.xml.
1186 #
1187 # Revision 1.18.2.5.2.14  2006/09/24 15:24:06  kados
1188 # remove Zebraauth routine, fold the functionality into Zconn
1189 # Zconn can now take several arguments ... this will probably
1190 # change soon as I'm not completely happy with the readability
1191 # of the current format ... see the POD for details.
1192 #
1193 # cleaning up Biblio.pm, removing unnecessary routines.
1194 #
1195 # DeleteBiblio - used to delete a biblio from zebra and koha tables
1196 #     -- checks to make sure there are no existing issues
1197 #     -- saves backups of biblio,biblioitems,items in deleted* tables
1198 #     -- does commit operation
1199 #
1200 # getRecord - used to retrieve one record from zebra in piggyback mode using biblionumber
1201 # brought back z3950_extended_services routine
1202 #
1203 # Lots of modifications to Context.pm, you can now store user and pass info for
1204 # multiple servers (for federated searching) using the <serverinfo> element.
1205 # I'll commit my koha.xml to demonstrate this or you can refer to the POD in
1206 # Context.pm (which I also expanded on).
1207 #
1208 # Revision 1.18.2.5.2.13  2006/08/10 02:10:21  kados
1209 # Turned warnings on, and running a search turned up lots of warnings.
1210 # Cleaned up those ...
1211 #
1212 # removed getitemtypes from Koha.pm (one in Search.pm looks newer)
1213 # removed itemcount from Biblio.pm
1214 #
1215 # made some local subs local with a _ prefix (as they were redefined
1216 # elsewhere)
1217 #
1218 # Add two new search subs to Search.pm the start of a new search API
1219 # that's a bit more scalable
1220 #
1221 # Revision 1.18.2.5.2.10  2006/07/21 17:50:51  kados
1222 # moving the *.properties files to intranetdir/etc dir
1223 #
1224 # Revision 1.18.2.5.2.9  2006/07/17 08:05:20  tipaul
1225 # there was a hardcoded link to /koha/etc/ I replaced it with intranetdir config value
1226 #
1227 # Revision 1.18.2.5.2.8  2006/07/11 12:20:37  kados
1228 # adding ccl and cql files ... Tumer, if you want to fit these into the
1229 # config file by all means do.
1230 #
1231 # Revision 1.18.2.5.2.7  2006/06/04 22:50:33  tgarip1957
1232 # We do not hard code cql2rpn conversion file in context.pm our koha.xml configuration file already describes the path for this file.
1233 # At cql searching we use method CQL not CQL2RPN as the cql2rpn conversion file is defined at server level
1234 #
1235 # Revision 1.18.2.5.2.6  2006/06/02 23:11:24  kados
1236 # Committing my working dev_week. It's been tested only with
1237 # searching, and there's quite a lot of config stuff to set up
1238 # beforehand. As things get closer to a release, we'll be making
1239 # some scripts to do it for us
1240 #
1241 # Revision 1.18.2.5.2.5  2006/05/28 18:49:12  tgarip1957
1242 # This is an unusual commit. The main purpose is a working model of Zebra on a modified rel2_2.
1243 # Any questions regarding these commits should be asked to Joshua Ferraro unless you are Joshua whom I'll report to
1244 #
1245 # Revision 1.36  2006/05/09 13:28:08  tipaul
1246 # adding the branchname and the librarian name in every page :
1247 # - modified userenv to add branchname
1248 # - modifier menus.inc to have the librarian name & userenv displayed on every page. they are in a librarian_information div.
1249 #
1250 # Revision 1.35  2006/04/13 08:40:11  plg
1251 # bug fixed: typo on Zconnauth name
1252 #
1253 # Revision 1.34  2006/04/10 21:40:23  tgarip1957
1254 # 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:
1255 # zebradb=localhost
1256 # zebraport=<your port>
1257 # zebrauser=<username>
1258 # zebrapass=<password>
1259 #
1260 # The zebra.cfg file should read:
1261 # perm.anonymous:r
1262 # perm.username:rw
1263 # passw.c:<yourpasswordfile>
1264 #
1265 # Password file should be prepared with Apaches htpasswd utility in encrypted mode and should exist in a folder zebra.cfg can read
1266 #
1267 # Revision 1.33  2006/03/15 11:21:56  plg
1268 # bug fixed: utf-8 data where not displayed correctly in screens. Supposing
1269 # your data are truely utf-8 encoded in your database, they should be
1270 # correctly displayed. "set names 'UTF8'" on mysql connection (C4/Context.pm)
1271 # is mandatory and "binmode" to utf8 (C4/Interface/CGI/Output.pm) seemed to
1272 # converted data twice, so it was removed.
1273 #
1274 # Revision 1.32  2006/03/03 17:25:01  hdl
1275 # Bug fixing : a line missed a comment sign.
1276 #
1277 # Revision 1.31  2006/03/03 16:45:36  kados
1278 # Remove the search that tests the Zconn -- warning, still no fault
1279 # tollerance
1280 #
1281 # Revision 1.30  2006/02/22 00:56:59  kados
1282 # First go at a connection object for Zebra. You can now get a
1283 # connection object by doing:
1284 #
1285 # my $Zconn = C4::Context->Zconn;
1286 #
1287 # My initial tests indicate that as soon as your funcion ends
1288 # (ie, when you're done doing something) the connection will be
1289 # closed automatically. There may be some other way to make the
1290 # connection more stateful, I'm not sure...
1291 #
1292 # Local Variables:
1293 # tab-width: 4
1294 # End: