Bug 17486: [QA Follow-up] Changes as to set_userenv
[koha.git] / C4 / Context.pm
1 package C4::Context;
2
3 # Copyright 2002 Katipo Communications
4 #
5 # This file is part of Koha.
6 #
7 # Koha is free software; you can redistribute it and/or modify it
8 # under the terms of the GNU General Public License as published by
9 # the Free Software Foundation; either version 3 of the License, or
10 # (at your option) any later version.
11 #
12 # Koha is distributed in the hope that it will be useful, but
13 # WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
16 #
17 # You should have received a copy of the GNU General Public License
18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
19
20 use Modern::Perl;
21
22 use vars qw($AUTOLOAD $context @context_stack);
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
81         # Redefine multi_param if cgi version is < 4.08
82         # Remove the "CGI::param called in list context" warning in this case
83         if (!defined($CGI::VERSION) || $CGI::VERSION < 4.08) {
84             no warnings 'redefine';
85             *CGI::multi_param = \&CGI::param;
86             use warnings 'redefine';
87             $CGI::LIST_CONTEXT_WARN = 0;
88         }
89     }   # else there is no browser to send fatals to!
90 }
91
92 use Encode;
93 use ZOOM;
94 use Koha::Caches;
95 use POSIX ();
96 use DateTime::TimeZone;
97 use Module::Load::Conditional qw(can_load);
98 use Carp;
99
100 use C4::Boolean;
101 use C4::Debug;
102 use Koha;
103 use Koha::Config;
104 use Koha::Config::SysPref;
105 use Koha::Config::SysPrefs;
106
107 =head1 NAME
108
109 C4::Context - Maintain and manipulate the context of a Koha script
110
111 =head1 SYNOPSIS
112
113   use C4::Context;
114
115   use C4::Context("/path/to/koha-conf.xml");
116
117   $config_value = C4::Context->config("config_variable");
118
119   $koha_preference = C4::Context->preference("preference");
120
121   $db_handle = C4::Context->dbh;
122
123   $Zconn = C4::Context->Zconn;
124
125 =head1 DESCRIPTION
126
127 When a Koha script runs, it makes use of a certain number of things:
128 configuration settings in F</etc/koha/koha-conf.xml>, a connection to the Koha
129 databases, and so forth. These things make up the I<context> in which
130 the script runs.
131
132 This module takes care of setting up the context for a script:
133 figuring out which configuration file to load, and loading it, opening
134 a connection to the right database, and so forth.
135
136 Most scripts will only use one context. They can simply have
137
138   use C4::Context;
139
140 at the top.
141
142 Other scripts may need to use several contexts. For instance, if a
143 library has two databases, one for a certain collection, and the other
144 for everything else, it might be necessary for a script to use two
145 different contexts to search both databases. Such scripts should use
146 the C<&set_context> and C<&restore_context> functions, below.
147
148 By default, C4::Context reads the configuration from
149 F</etc/koha/koha-conf.xml>. This may be overridden by setting the C<$KOHA_CONF>
150 environment variable to the pathname of a configuration file to use.
151
152 =head1 METHODS
153
154 =cut
155
156 #'
157 # In addition to what is said in the POD above, a Context object is a
158 # reference-to-hash with the following fields:
159 #
160 # config
161 #    A reference-to-hash whose keys and values are the
162 #    configuration variables and values specified in the config
163 #    file (/etc/koha/koha-conf.xml).
164 # dbh
165 #    A handle to the appropriate database for this context.
166 # dbh_stack
167 #    Used by &set_dbh and &restore_dbh to hold other database
168 #    handles for this context.
169 # Zconn
170 #     A connection object for the Zebra server
171
172 $context = undef;        # Initially, no context is set
173 @context_stack = ();        # Initially, no saved contexts
174
175 =head2 db_scheme2dbi
176
177     my $dbd_driver_name = C4::Context::db_schema2dbi($scheme);
178
179 This routines translates a database type to part of the name
180 of the appropriate DBD driver to use when establishing a new
181 database connection.  It recognizes 'mysql' and 'Pg'; if any
182 other scheme is supplied it defaults to 'mysql'.
183
184 =cut
185
186 sub db_scheme2dbi {
187     my $scheme = shift // '';
188     return $scheme eq 'Pg' ? $scheme : 'mysql';
189 }
190
191 sub import {
192     # Create the default context ($C4::Context::Context)
193     # the first time the module is called
194     # (a config file can be optionaly passed)
195
196     # default context already exists?
197     return if $context;
198
199     # no ? so load it!
200     my ($pkg,$config_file) = @_ ;
201     my $new_ctx = __PACKAGE__->new($config_file);
202     return unless $new_ctx;
203
204     # if successfully loaded, use it by default
205     $new_ctx->set_context;
206     1;
207 }
208
209 =head2 new
210
211   $context = new C4::Context;
212   $context = new C4::Context("/path/to/koha-conf.xml");
213
214 Allocates a new context. Initializes the context from the specified
215 file, which defaults to either the file given by the C<$KOHA_CONF>
216 environment variable, or F</etc/koha/koha-conf.xml>.
217
218 It saves the koha-conf.xml values in the declared memcached server(s)
219 if currently available and uses those values until them expire and
220 re-reads them.
221
222 C<&new> does not set this context as the new default context; for
223 that, use C<&set_context>.
224
225 =cut
226
227 #'
228 # Revision History:
229 # 2004-08-10 A. Tarallo: Added check if the conf file is not empty
230 sub new {
231     my $class = shift;
232     my $conf_fname = shift;        # Config file to load
233     my $self = {};
234
235     # check that the specified config file exists and is not empty
236     undef $conf_fname unless 
237         (defined $conf_fname && -s $conf_fname);
238     # Figure out a good config file to load if none was specified.
239     unless ( defined $conf_fname ) {
240         $conf_fname = Koha::Config->guess_koha_conf;
241         unless ( $conf_fname ) {
242             warn "unable to locate Koha configuration file koha-conf.xml";
243             return;
244         }
245     }
246
247     my $conf_cache = Koha::Caches->get_instance('config');
248     my $config_from_cache;
249     if ( $conf_cache->cache ) {
250         $self = $conf_cache->get_from_cache('koha_conf');
251     }
252     unless ( $self and %$self ) {
253         $self = Koha::Config->read_from_file($conf_fname);
254         if ( $conf_cache->memcached_cache ) {
255             # FIXME it may be better to use the memcached servers from the config file
256             # to cache it
257             $conf_cache->set_in_cache('koha_conf', $self)
258         }
259     }
260     unless ( exists $self->{config} or defined $self->{config} ) {
261         warn "The config file ($conf_fname) has not been parsed correctly";
262         return;
263     }
264
265     $self->{"Zconn"} = undef;    # Zebra Connections
266     $self->{"userenv"} = undef;        # User env
267     $self->{"activeuser"} = undef;        # current active user
268     $self->{"shelves"} = undef;
269     $self->{tz} = undef; # local timezone object
270
271     bless $self, $class;
272     $self->{db_driver} = db_scheme2dbi($self->config('db_scheme'));  # cache database driver
273     return $self;
274 }
275
276 =head2 set_context
277
278   $context = new C4::Context;
279   $context->set_context();
280 or
281   set_context C4::Context $context;
282
283   ...
284   restore_context C4::Context;
285
286 In some cases, it might be necessary for a script to use multiple
287 contexts. C<&set_context> saves the current context on a stack, then
288 sets the context to C<$context>, which will be used in future
289 operations. To restore the previous context, use C<&restore_context>.
290
291 =cut
292
293 #'
294 sub set_context
295 {
296     my $self = shift;
297     my $new_context;    # The context to set
298
299     # Figure out whether this is a class or instance method call.
300     #
301     # We're going to make the assumption that control got here
302     # through valid means, i.e., that the caller used an instance
303     # or class method call, and that control got here through the
304     # usual inheritance mechanisms. The caller can, of course,
305     # break this assumption by playing silly buggers, but that's
306     # harder to do than doing it properly, and harder to check
307     # for.
308     if (ref($self) eq "")
309     {
310         # Class method. The new context is the next argument.
311         $new_context = shift;
312     } else {
313         # Instance method. The new context is $self.
314         $new_context = $self;
315     }
316
317     # Save the old context, if any, on the stack
318     push @context_stack, $context if defined($context);
319
320     # Set the new context
321     $context = $new_context;
322 }
323
324 =head2 restore_context
325
326   &restore_context;
327
328 Restores the context set by C<&set_context>.
329
330 =cut
331
332 #'
333 sub restore_context
334 {
335     my $self = shift;
336
337     if ($#context_stack < 0)
338     {
339         # Stack underflow.
340         die "Context stack underflow";
341     }
342
343     # Pop the old context and set it.
344     $context = pop @context_stack;
345
346     # FIXME - Should this return something, like maybe the context
347     # that was current when this was called?
348 }
349
350 =head2 config
351
352   $value = C4::Context->config("config_variable");
353
354   $value = C4::Context->config_variable;
355
356 Returns the value of a variable specified in the configuration file
357 from which the current context was created.
358
359 The second form is more compact, but of course may conflict with
360 method names. If there is a configuration variable called "new", then
361 C<C4::Config-E<gt>new> will not return it.
362
363 =cut
364
365 sub _common_config {
366         my $var = shift;
367         my $term = shift;
368     return if !defined($context->{$term});
369        # Presumably $self->{$term} might be
370        # undefined if the config file given to &new
371        # didn't exist, and the caller didn't bother
372        # to check the return value.
373
374     # Return the value of the requested config variable
375     return $context->{$term}->{$var};
376 }
377
378 sub config {
379         return _common_config($_[1],'config');
380 }
381 sub zebraconfig {
382         return _common_config($_[1],'server');
383 }
384 sub ModZebrations {
385         return _common_config($_[1],'serverinfo');
386 }
387
388 =head2 preference
389
390   $sys_preference = C4::Context->preference('some_variable');
391
392 Looks up the value of the given system preference in the
393 systempreferences table of the Koha database, and returns it. If the
394 variable is not set or does not exist, undef is returned.
395
396 In case of an error, this may return 0.
397
398 Note: It is impossible to tell the difference between system
399 preferences which do not exist, and those whose values are set to NULL
400 with this method.
401
402 =cut
403
404 my $syspref_cache = Koha::Caches->get_instance('syspref');
405 my $use_syspref_cache = 1;
406 sub preference {
407     my $self = shift;
408     my $var  = shift;    # The system preference to return
409
410     return $ENV{"OVERRIDE_SYSPREF_$var"}
411         if defined $ENV{"OVERRIDE_SYSPREF_$var"};
412
413     $var = lc $var;
414
415     if ($use_syspref_cache) {
416         $syspref_cache = Koha::Caches->get_instance('syspref') unless $syspref_cache;
417         my $cached_var = $syspref_cache->get_from_cache("syspref_$var");
418         return $cached_var if defined $cached_var;
419     }
420
421     my $syspref;
422     eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) };
423     my $value = $syspref ? $syspref->value() : undef;
424
425     if ( $use_syspref_cache ) {
426         $syspref_cache->set_in_cache("syspref_$var", $value);
427     }
428     return $value;
429 }
430
431 sub boolean_preference {
432     my $self = shift;
433     my $var = shift;        # The system preference to return
434     my $it = preference($self, $var);
435     return defined($it)? C4::Boolean::true_p($it): undef;
436 }
437
438 =head2 enable_syspref_cache
439
440   C4::Context->enable_syspref_cache();
441
442 Enable the in-memory syspref cache used by C4::Context. This is the
443 default behavior.
444
445 =cut
446
447 sub enable_syspref_cache {
448     my ($self) = @_;
449     $use_syspref_cache = 1;
450     # We need to clear the cache to have it up-to-date
451     $self->clear_syspref_cache();
452 }
453
454 =head2 disable_syspref_cache
455
456   C4::Context->disable_syspref_cache();
457
458 Disable the in-memory syspref cache used by C4::Context. This should be
459 used with Plack and other persistent environments.
460
461 =cut
462
463 sub disable_syspref_cache {
464     my ($self) = @_;
465     $use_syspref_cache = 0;
466     $self->clear_syspref_cache();
467 }
468
469 =head2 clear_syspref_cache
470
471   C4::Context->clear_syspref_cache();
472
473 cleans the internal cache of sysprefs. Please call this method if
474 you update the systempreferences table. Otherwise, your new changes
475 will not be seen by this process.
476
477 =cut
478
479 sub clear_syspref_cache {
480     return unless $use_syspref_cache;
481     $syspref_cache->flush_all;
482 }
483
484 =head2 set_preference
485
486   C4::Context->set_preference( $variable, $value, [ $explanation, $type, $options ] );
487
488 This updates a preference's value both in the systempreferences table and in
489 the sysprefs cache. If the optional parameters are provided, then the query
490 becomes a create. It won't update the parameters (except value) for an existing
491 preference.
492
493 =cut
494
495 sub set_preference {
496     my ( $self, $variable, $value, $explanation, $type, $options ) = @_;
497
498     $variable = lc $variable;
499
500     my $syspref = Koha::Config::SysPrefs->find($variable);
501     $type =
502         $type    ? $type
503       : $syspref ? $syspref->type
504       :            undef;
505
506     $value = 0 if ( $type && $type eq 'YesNo' && $value eq '' );
507
508     # force explicit protocol on OPACBaseURL
509     if ( $variable eq 'opacbaseurl' && $value && substr( $value, 0, 4 ) !~ /http/ ) {
510         $value = 'http://' . $value;
511     }
512
513     if ($syspref) {
514         $syspref->set(
515             {   ( defined $value ? ( value       => $value )       : () ),
516                 ( $explanation   ? ( explanation => $explanation ) : () ),
517                 ( $type          ? ( type        => $type )        : () ),
518                 ( $options       ? ( options     => $options )     : () ),
519             }
520         )->store;
521     } else {
522         $syspref = Koha::Config::SysPref->new(
523             {   variable    => $variable,
524                 value       => $value,
525                 explanation => $explanation || undef,
526                 type        => $type,
527                 options     => $options || undef,
528             }
529         )->store();
530     }
531
532     if ( $use_syspref_cache ) {
533         $syspref_cache->set_in_cache( "syspref_$variable", $value );
534     }
535
536     return $syspref;
537 }
538
539 =head2 delete_preference
540
541     C4::Context->delete_preference( $variable );
542
543 This deletes a system preference from the database. Returns a true value on
544 success. Failure means there was an issue with the database, not that there
545 was no syspref of the name.
546
547 =cut
548
549 sub delete_preference {
550     my ( $self, $var ) = @_;
551
552     if ( Koha::Config::SysPrefs->find( $var )->delete ) {
553         if ( $use_syspref_cache ) {
554             $syspref_cache->clear_from_cache("syspref_$var");
555         }
556
557         return 1;
558     }
559     return 0;
560 }
561
562 =head2 Zconn
563
564   $Zconn = C4::Context->Zconn
565
566 Returns a connection to the Zebra database
567
568 C<$self> 
569
570 C<$server> one of the servers defined in the koha-conf.xml file
571
572 C<$async> whether this is a asynchronous connection
573
574 =cut
575
576 sub Zconn {
577     my ($self, $server, $async ) = @_;
578     my $cache_key = join ('::', (map { $_ // '' } ($server, $async )));
579     if ( (!defined($ENV{GATEWAY_INTERFACE})) && defined($context->{"Zconn"}->{$cache_key}) && (0 == $context->{"Zconn"}->{$cache_key}->errcode()) ) {
580         # if we are running the script from the commandline, lets try to use the caching
581         return $context->{"Zconn"}->{$cache_key};
582     }
583     $context->{"Zconn"}->{$cache_key}->destroy() if defined($context->{"Zconn"}->{$cache_key}); #destroy old connection before making a new one
584     $context->{"Zconn"}->{$cache_key} = &_new_Zconn( $server, $async );
585     return $context->{"Zconn"}->{$cache_key};
586 }
587
588 =head2 _new_Zconn
589
590 $context->{"Zconn"} = &_new_Zconn($server,$async);
591
592 Internal function. Creates a new database connection from the data given in the current context and returns it.
593
594 C<$server> one of the servers defined in the koha-conf.xml file
595
596 C<$async> whether this is a asynchronous connection
597
598 C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
599
600 =cut
601
602 sub _new_Zconn {
603     my ( $server, $async ) = @_;
604
605     my $tried=0; # first attempt
606     my $Zconn; # connection object
607     my $elementSetName;
608     my $index_mode;
609     my $syntax;
610
611     $server //= "biblioserver";
612
613     if ( $server eq 'biblioserver' ) {
614         $index_mode = $context->{'config'}->{'zebra_bib_index_mode'} // 'dom';
615     } elsif ( $server eq 'authorityserver' ) {
616         $index_mode = $context->{'config'}->{'zebra_auth_index_mode'} // 'dom';
617     }
618
619     if ( $index_mode eq 'grs1' ) {
620         $elementSetName = 'F';
621         $syntax = ( $context->preference("marcflavour") eq 'UNIMARC' )
622                 ? 'unimarc'
623                 : 'usmarc';
624
625     } else { # $index_mode eq 'dom'
626         $syntax = 'xml';
627         $elementSetName = 'marcxml';
628     }
629
630     my $host = $context->{'listen'}->{$server}->{'content'};
631     my $user = $context->{"serverinfo"}->{$server}->{"user"};
632     my $password = $context->{"serverinfo"}->{$server}->{"password"};
633     eval {
634         # set options
635         my $o = new ZOOM::Options();
636         $o->option(user => $user) if $user && $password;
637         $o->option(password => $password) if $user && $password;
638         $o->option(async => 1) if $async;
639         $o->option(cqlfile=> $context->{"server"}->{$server}->{"cql2rpn"});
640         $o->option(cclfile=> $context->{"serverinfo"}->{$server}->{"ccl2rpn"});
641         $o->option(preferredRecordSyntax => $syntax);
642         $o->option(elementSetName => $elementSetName) if $elementSetName;
643         $o->option(databaseName => $context->{"config"}->{$server}||"biblios");
644
645         # create a new connection object
646         $Zconn= create ZOOM::Connection($o);
647
648         # forge to server
649         $Zconn->connect($host, 0);
650
651         # check for errors and warn
652         if ($Zconn->errcode() !=0) {
653             warn "something wrong with the connection: ". $Zconn->errmsg();
654         }
655     };
656     return $Zconn;
657 }
658
659 # _new_dbh
660 # Internal helper function (not a method!). This creates a new
661 # database connection from the data given in the current context, and
662 # returns it.
663 sub _new_dbh
664 {
665
666     Koha::Database->schema({ new => 1 })->storage->dbh;
667 }
668
669 =head2 dbh
670
671   $dbh = C4::Context->dbh;
672
673 Returns a database handle connected to the Koha database for the
674 current context. If no connection has yet been made, this method
675 creates one, and connects to the database.
676
677 This database handle is cached for future use: if you call
678 C<C4::Context-E<gt>dbh> twice, you will get the same handle both
679 times. If you need a second database handle, use C<&new_dbh> and
680 possibly C<&set_dbh>.
681
682 =cut
683
684 #'
685 sub dbh
686 {
687     my $self = shift;
688     my $params = shift;
689     my $sth;
690
691     unless ( $params->{new} ) {
692         return Koha::Database->schema->storage->dbh;
693     }
694
695     return Koha::Database->schema({ new => 1 })->storage->dbh;
696 }
697
698 =head2 new_dbh
699
700   $dbh = C4::Context->new_dbh;
701
702 Creates a new connection to the Koha database for the current context,
703 and returns the database handle (a C<DBI::db> object).
704
705 The handle is not saved anywhere: this method is strictly a
706 convenience function; the point is that it knows which database to
707 connect to so that the caller doesn't have to know.
708
709 =cut
710
711 #'
712 sub new_dbh
713 {
714     my $self = shift;
715
716     return &dbh({ new => 1 });
717 }
718
719 =head2 set_dbh
720
721   $my_dbh = C4::Connect->new_dbh;
722   C4::Connect->set_dbh($my_dbh);
723   ...
724   C4::Connect->restore_dbh;
725
726 C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
727 C<&set_context> and C<&restore_context>.
728
729 C<&set_dbh> saves the current database handle on a stack, then sets
730 the current database handle to C<$my_dbh>.
731
732 C<$my_dbh> is assumed to be a good database handle.
733
734 =cut
735
736 #'
737 sub set_dbh
738 {
739     my $self = shift;
740     my $new_dbh = shift;
741
742     # Save the current database handle on the handle stack.
743     # We assume that $new_dbh is all good: if the caller wants to
744     # screw himself by passing an invalid handle, that's fine by
745     # us.
746     push @{$context->{"dbh_stack"}}, $context->{"dbh"};
747     $context->{"dbh"} = $new_dbh;
748 }
749
750 =head2 restore_dbh
751
752   C4::Context->restore_dbh;
753
754 Restores the database handle saved by an earlier call to
755 C<C4::Context-E<gt>set_dbh>.
756
757 =cut
758
759 #'
760 sub restore_dbh
761 {
762     my $self = shift;
763
764     if ($#{$context->{"dbh_stack"}} < 0)
765     {
766         # Stack underflow
767         die "DBH stack underflow";
768     }
769
770     # Pop the old database handle and set it.
771     $context->{"dbh"} = pop @{$context->{"dbh_stack"}};
772
773     # FIXME - If it is determined that restore_context should
774     # return something, then this function should, too.
775 }
776
777 =head2 queryparser
778
779   $queryparser = C4::Context->queryparser
780
781 Returns a handle to an initialized Koha::QueryParser::Driver::PQF object.
782
783 =cut
784
785 sub queryparser {
786     my $self = shift;
787     unless (defined $context->{"queryparser"}) {
788         $context->{"queryparser"} = &_new_queryparser();
789     }
790
791     return
792       defined( $context->{"queryparser"} )
793       ? $context->{"queryparser"}->new
794       : undef;
795 }
796
797 =head2 _new_queryparser
798
799 Internal helper function to create a new QueryParser object. QueryParser
800 is loaded dynamically so as to keep the lack of the QueryParser library from
801 getting in anyone's way.
802
803 =cut
804
805 sub _new_queryparser {
806     my $qpmodules = {
807         'OpenILS::QueryParser'           => undef,
808         'Koha::QueryParser::Driver::PQF' => undef
809     };
810     if ( can_load( 'modules' => $qpmodules ) ) {
811         my $QParser     = Koha::QueryParser::Driver::PQF->new();
812         my $config_file = $context->config('queryparser_config');
813         $config_file ||= '/etc/koha/searchengine/queryparser.yaml';
814         if ( $QParser->load_config($config_file) ) {
815             # Set 'keyword' as the default search class
816             $QParser->default_search_class('keyword');
817             # TODO: allow indexes to be configured in the database
818             return $QParser;
819         }
820     }
821     return;
822 }
823
824 =head2 userenv
825
826   C4::Context->userenv;
827
828 Retrieves a hash for user environment variables.
829
830 This hash shall be cached for future use: if you call
831 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
832
833 =cut
834
835 #'
836 sub userenv {
837     my $var = $context->{"activeuser"};
838     if (defined $var and defined $context->{"userenv"}->{$var}) {
839         return $context->{"userenv"}->{$var};
840     } else {
841         return;
842     }
843 }
844
845 =head2 set_userenv
846
847   C4::Context->set_userenv($usernum, $userid, $usercnum,
848                            $userfirstname, $usersurname,
849                            $userbranch, $branchname, $userflags,
850                            $emailaddress, $branchprinter, $shibboleth);
851
852 Establish a hash of user environment variables.
853
854 set_userenv is called in Auth.pm
855
856 =cut
857
858 #'
859 sub set_userenv {
860     shift @_;
861     my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter, $shibboleth)=
862     map { Encode::is_utf8( $_ ) ? $_ : Encode::decode('UTF-8', $_) } # CGI::Session doesn't handle utf-8, so we decode it here
863     @_;
864     my $var=$context->{"activeuser"} || '';
865     my $cell = {
866         "number"     => $usernum,
867         "id"         => $userid,
868         "cardnumber" => $usercnum,
869         "firstname"  => $userfirstname,
870         "surname"    => $usersurname,
871         #possibly a law problem
872         "branch"     => $userbranch,
873         "branchname" => $branchname,
874         "flags"      => $userflags,
875         "emailaddress"     => $emailaddress,
876         "branchprinter"    => $branchprinter,
877         "shibboleth" => $shibboleth,
878     };
879     $context->{userenv}->{$var} = $cell;
880     return $cell;
881 }
882
883 sub set_shelves_userenv {
884         my ($type, $shelves) = @_ or return;
885         my $activeuser = $context->{activeuser} or return;
886         $context->{userenv}->{$activeuser}->{barshelves} = $shelves if $type eq 'bar';
887         $context->{userenv}->{$activeuser}->{pubshelves} = $shelves if $type eq 'pub';
888         $context->{userenv}->{$activeuser}->{totshelves} = $shelves if $type eq 'tot';
889 }
890
891 sub get_shelves_userenv {
892         my $active;
893         unless ($active = $context->{userenv}->{$context->{activeuser}}) {
894                 $debug and warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}";
895                 return;
896         }
897         my $totshelves = $active->{totshelves} or undef;
898         my $pubshelves = $active->{pubshelves} or undef;
899         my $barshelves = $active->{barshelves} or undef;
900         return ($totshelves, $pubshelves, $barshelves);
901 }
902
903 =head2 _new_userenv
904
905   C4::Context->_new_userenv($session);  # FIXME: This calling style is wrong for what looks like an _internal function
906
907 Builds a hash for user environment variables.
908
909 This hash shall be cached for future use: if you call
910 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
911
912 _new_userenv is called in Auth.pm
913
914 =cut
915
916 #'
917 sub _new_userenv
918 {
919     shift;  # Useless except it compensates for bad calling style
920     my ($sessionID)= @_;
921      $context->{"activeuser"}=$sessionID;
922 }
923
924 =head2 _unset_userenv
925
926   C4::Context->_unset_userenv;
927
928 Destroys the hash for activeuser user environment variables.
929
930 =cut
931
932 #'
933
934 sub _unset_userenv
935 {
936     my ($sessionID)= @_;
937     undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
938 }
939
940
941 =head2 get_versions
942
943   C4::Context->get_versions
944
945 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'.
946
947 =cut
948
949 #'
950
951 # A little example sub to show more debugging info for CGI::Carp
952 sub get_versions {
953     my %versions;
954     $versions{kohaVersion}  = Koha::version();
955     $versions{kohaDbVersion} = C4::Context->preference('version');
956     $versions{osVersion} = join(" ", POSIX::uname());
957     $versions{perlVersion} = $];
958     {
959         no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
960         $versions{mysqlVersion}  = `mysql -V`;
961         $versions{apacheVersion} = (`apache2ctl -v`)[0];
962         $versions{apacheVersion} = `httpd -v`             unless  $versions{apacheVersion} ;
963         $versions{apacheVersion} = `httpd2 -v`            unless  $versions{apacheVersion} ;
964         $versions{apacheVersion} = `apache2 -v`           unless  $versions{apacheVersion} ;
965         $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless  $versions{apacheVersion} ;
966     }
967     return %versions;
968 }
969
970
971 =head2 tz
972
973   C4::Context->tz
974
975   Returns a DateTime::TimeZone object for the system timezone
976
977 =cut
978
979 sub tz {
980     my $self = shift;
981     if (!defined $context->{tz}) {
982         $context->{tz} = DateTime::TimeZone->new(name => 'local');
983     }
984     return $context->{tz};
985 }
986
987
988 =head2 IsSuperLibrarian
989
990     C4::Context->IsSuperLibrarian();
991
992 =cut
993
994 sub IsSuperLibrarian {
995     my $userenv = C4::Context->userenv;
996
997     unless ( $userenv and exists $userenv->{flags} ) {
998         # If we reach this without a user environment,
999         # assume that we're running from a command-line script,
1000         # and act as a superlibrarian.
1001         carp("C4::Context->userenv not defined!");
1002         return 1;
1003     }
1004
1005     return ($userenv->{flags}//0) % 2;
1006 }
1007
1008 =head2 interface
1009
1010 Sets the current interface for later retrieval in any Perl module
1011
1012     C4::Context->interface('opac');
1013     C4::Context->interface('intranet');
1014     my $interface = C4::Context->interface;
1015
1016 =cut
1017
1018 sub interface {
1019     my ($class, $interface) = @_;
1020
1021     if (defined $interface) {
1022         $interface = lc $interface;
1023         if ($interface eq 'opac' || $interface eq 'intranet' || $interface eq 'sip' || $interface eq 'commandline') {
1024             $context->{interface} = $interface;
1025         } else {
1026             warn "invalid interface : '$interface'";
1027         }
1028     }
1029
1030     return $context->{interface} // 'opac';
1031 }
1032
1033 # always returns a string for OK comparison via "eq" or "ne"
1034 sub mybranch {
1035     C4::Context->userenv           or return '';
1036     return C4::Context->userenv->{branch} || '';
1037 }
1038
1039 =head2 only_my_library
1040
1041     my $test = C4::Context->only_my_library;
1042
1043     Returns true if you enabled IndependentBranches and the current user
1044     does not have superlibrarian permissions.
1045
1046 =cut
1047
1048 sub only_my_library {
1049     return
1050          C4::Context->preference('IndependentBranches')
1051       && C4::Context->userenv
1052       && !C4::Context->IsSuperLibrarian()
1053       && C4::Context->userenv->{branch};
1054 }
1055
1056 1;
1057
1058 __END__
1059
1060 =head1 ENVIRONMENT
1061
1062 =head2 C<KOHA_CONF>
1063
1064 Specifies the configuration file to read.
1065
1066 =head1 SEE ALSO
1067
1068 XML::Simple
1069
1070 =head1 AUTHORS
1071
1072 Andrew Arensburger <arensb at ooblick dot com>
1073
1074 Joshua Ferraro <jmf at liblime dot com>
1075