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