C4/Context.pm

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