]> git.koha-community.org Git - koha.git/blob - C4/Context.pm
Merge remote-tracking branch 'origin/new/bug_6875'
[koha.git] / 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