Bug 18309: UNIMARC update from IFLA - authority (fr) (FAM)
[koha.git] / C4 / Context.pm
blob54341da5dce24605fa8bb048b693e357fa587540
1 package C4::Context;
3 # Copyright 2002 Katipo Communications
5 # This file is part of Koha.
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.
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.
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>.
20 use Modern::Perl;
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;
36 else {
37 $debug_level = C4::Context->preference("DebugLevel");
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>
46 if ($debug_level eq "2"){
47 # debug 2 , print extra info too.
48 my %versions = get_versions();
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>";
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>";
72 print "</body></html>";
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;
81 # Redefine multi_param if cgi version is < 4.08
82 # Remove the "CGI::param called in list context" warning in this case
83 require CGI; # Can't check version without the require.
84 if (!defined($CGI::VERSION) || $CGI::VERSION < 4.08) {
85 no warnings 'redefine';
86 *CGI::multi_param = \&CGI::param;
87 use warnings 'redefine';
88 $CGI::LIST_CONTEXT_WARN = 0;
90 } # else there is no browser to send fatals to!
93 use Carp;
94 use DateTime::TimeZone;
95 use Encode;
96 use File::Spec;
97 use Module::Load::Conditional qw(can_load);
98 use POSIX ();
99 use YAML qw/Load/;
100 use ZOOM;
102 use C4::Boolean;
103 use C4::Debug;
104 use Koha::Caches;
105 use Koha::Config::SysPref;
106 use Koha::Config::SysPrefs;
107 use Koha::Config;
108 use Koha;
110 =head1 NAME
112 C4::Context - Maintain and manipulate the context of a Koha script
114 =head1 SYNOPSIS
116 use C4::Context;
118 use C4::Context("/path/to/koha-conf.xml");
120 $config_value = C4::Context->config("config_variable");
122 $koha_preference = C4::Context->preference("preference");
124 $db_handle = C4::Context->dbh;
126 $Zconn = C4::Context->Zconn;
128 =head1 DESCRIPTION
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.
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.
139 Most scripts will only use one context. They can simply have
141 use C4::Context;
143 at the top.
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.
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.
155 =head1 METHODS
157 =cut
160 # In addition to what is said in the POD above, a Context object is a
161 # reference-to-hash with the following fields:
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
175 $context = undef; # Initially, no context is set
176 @context_stack = (); # Initially, no saved contexts
178 =head2 db_scheme2dbi
180 my $dbd_driver_name = C4::Context::db_schema2dbi($scheme);
182 This routines translates a database type to part of the name
183 of the appropriate DBD driver to use when establishing a new
184 database connection. It recognizes 'mysql' and 'Pg'; if any
185 other scheme is supplied it defaults to 'mysql'.
187 =cut
189 sub db_scheme2dbi {
190 my $scheme = shift // '';
191 return $scheme eq 'Pg' ? $scheme : 'mysql';
194 sub import {
195 # Create the default context ($C4::Context::Context)
196 # the first time the module is called
197 # (a config file can be optionaly passed)
199 # default context already exists?
200 return if $context;
202 # no ? so load it!
203 my ($pkg,$config_file) = @_ ;
204 my $new_ctx = __PACKAGE__->new($config_file);
205 return unless $new_ctx;
207 # if successfully loaded, use it by default
208 $new_ctx->set_context;
212 =head2 new
214 $context = new C4::Context;
215 $context = new C4::Context("/path/to/koha-conf.xml");
217 Allocates a new context. Initializes the context from the specified
218 file, which defaults to either the file given by the C<$KOHA_CONF>
219 environment variable, or F</etc/koha/koha-conf.xml>.
221 It saves the koha-conf.xml values in the declared memcached server(s)
222 if currently available and uses those values until them expire and
223 re-reads them.
225 C<&new> does not set this context as the new default context; for
226 that, use C<&set_context>.
228 =cut
231 # Revision History:
232 # 2004-08-10 A. Tarallo: Added check if the conf file is not empty
233 sub new {
234 my $class = shift;
235 my $conf_fname = shift; # Config file to load
236 my $self = {};
238 # check that the specified config file exists and is not empty
239 undef $conf_fname unless
240 (defined $conf_fname && -s $conf_fname);
241 # Figure out a good config file to load if none was specified.
242 unless ( defined $conf_fname ) {
243 $conf_fname = Koha::Config->guess_koha_conf;
244 unless ( $conf_fname ) {
245 warn "unable to locate Koha configuration file koha-conf.xml";
246 return;
250 my $conf_cache = Koha::Caches->get_instance('config');
251 my $config_from_cache;
252 if ( $conf_cache->cache ) {
253 $self = $conf_cache->get_from_cache('koha_conf');
255 unless ( $self and %$self ) {
256 $self = Koha::Config->read_from_file($conf_fname);
257 if ( $conf_cache->memcached_cache ) {
258 # FIXME it may be better to use the memcached servers from the config file
259 # to cache it
260 $conf_cache->set_in_cache('koha_conf', $self)
263 unless ( exists $self->{config} or defined $self->{config} ) {
264 warn "The config file ($conf_fname) has not been parsed correctly";
265 return;
268 $self->{"Zconn"} = undef; # Zebra Connections
269 $self->{"userenv"} = undef; # User env
270 $self->{"activeuser"} = undef; # current active user
271 $self->{"shelves"} = undef;
272 $self->{tz} = undef; # local timezone object
274 bless $self, $class;
275 $self->{db_driver} = db_scheme2dbi($self->config('db_scheme')); # cache database driver
276 return $self;
279 =head2 set_context
281 $context = new C4::Context;
282 $context->set_context();
284 set_context C4::Context $context;
287 restore_context C4::Context;
289 In some cases, it might be necessary for a script to use multiple
290 contexts. C<&set_context> saves the current context on a stack, then
291 sets the context to C<$context>, which will be used in future
292 operations. To restore the previous context, use C<&restore_context>.
294 =cut
297 sub set_context
299 my $self = shift;
300 my $new_context; # The context to set
302 # Figure out whether this is a class or instance method call.
304 # We're going to make the assumption that control got here
305 # through valid means, i.e., that the caller used an instance
306 # or class method call, and that control got here through the
307 # usual inheritance mechanisms. The caller can, of course,
308 # break this assumption by playing silly buggers, but that's
309 # harder to do than doing it properly, and harder to check
310 # for.
311 if (ref($self) eq "")
313 # Class method. The new context is the next argument.
314 $new_context = shift;
315 } else {
316 # Instance method. The new context is $self.
317 $new_context = $self;
320 # Save the old context, if any, on the stack
321 push @context_stack, $context if defined($context);
323 # Set the new context
324 $context = $new_context;
327 =head2 restore_context
329 &restore_context;
331 Restores the context set by C<&set_context>.
333 =cut
336 sub restore_context
338 my $self = shift;
340 if ($#context_stack < 0)
342 # Stack underflow.
343 die "Context stack underflow";
346 # Pop the old context and set it.
347 $context = pop @context_stack;
349 # FIXME - Should this return something, like maybe the context
350 # that was current when this was called?
353 =head2 config
355 $value = C4::Context->config("config_variable");
357 $value = C4::Context->config_variable;
359 Returns the value of a variable specified in the configuration file
360 from which the current context was created.
362 The second form is more compact, but of course may conflict with
363 method names. If there is a configuration variable called "new", then
364 C<C4::Config-E<gt>new> will not return it.
366 =cut
368 sub _common_config {
369 my $var = shift;
370 my $term = shift;
371 return if !defined($context->{$term});
372 # Presumably $self->{$term} might be
373 # undefined if the config file given to &new
374 # didn't exist, and the caller didn't bother
375 # to check the return value.
377 # Return the value of the requested config variable
378 return $context->{$term}->{$var};
381 sub config {
382 return _common_config($_[1],'config');
384 sub zebraconfig {
385 return _common_config($_[1],'server');
387 sub ModZebrations {
388 return _common_config($_[1],'serverinfo');
391 =head2 preference
393 $sys_preference = C4::Context->preference('some_variable');
395 Looks up the value of the given system preference in the
396 systempreferences table of the Koha database, and returns it. If the
397 variable is not set or does not exist, undef is returned.
399 In case of an error, this may return 0.
401 Note: It is impossible to tell the difference between system
402 preferences which do not exist, and those whose values are set to NULL
403 with this method.
405 =cut
407 my $syspref_cache = Koha::Caches->get_instance('syspref');
408 my $use_syspref_cache = 1;
409 sub preference {
410 my $self = shift;
411 my $var = shift; # The system preference to return
413 return $ENV{"OVERRIDE_SYSPREF_$var"}
414 if defined $ENV{"OVERRIDE_SYSPREF_$var"};
416 $var = lc $var;
418 if ($use_syspref_cache) {
419 $syspref_cache = Koha::Caches->get_instance('syspref') unless $syspref_cache;
420 my $cached_var = $syspref_cache->get_from_cache("syspref_$var");
421 return $cached_var if defined $cached_var;
424 my $syspref;
425 eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) };
426 my $value = $syspref ? $syspref->value() : undef;
428 if ( $use_syspref_cache ) {
429 $syspref_cache->set_in_cache("syspref_$var", $value);
431 return $value;
434 sub boolean_preference {
435 my $self = shift;
436 my $var = shift; # The system preference to return
437 my $it = preference($self, $var);
438 return defined($it)? C4::Boolean::true_p($it): undef;
441 =head2 yaml_preference
443 Retrieves the required system preference value, and converts it
444 from YAML into a Perl data structure. It throws an exception if
445 the value cannot be properly decoded as YAML.
447 =cut
449 sub yaml_preference {
450 my ( $self, $preference ) = @_;
452 my $yaml = eval { YAML::Load( $self->preference( $preference ) ); };
453 if ($@) {
454 warn "Unable to parse $preference syspref : $@";
455 return;
458 return $yaml;
461 =head2 enable_syspref_cache
463 C4::Context->enable_syspref_cache();
465 Enable the in-memory syspref cache used by C4::Context. This is the
466 default behavior.
468 =cut
470 sub enable_syspref_cache {
471 my ($self) = @_;
472 $use_syspref_cache = 1;
473 # We need to clear the cache to have it up-to-date
474 $self->clear_syspref_cache();
477 =head2 disable_syspref_cache
479 C4::Context->disable_syspref_cache();
481 Disable the in-memory syspref cache used by C4::Context. This should be
482 used with Plack and other persistent environments.
484 =cut
486 sub disable_syspref_cache {
487 my ($self) = @_;
488 $use_syspref_cache = 0;
489 $self->clear_syspref_cache();
492 =head2 clear_syspref_cache
494 C4::Context->clear_syspref_cache();
496 cleans the internal cache of sysprefs. Please call this method if
497 you update the systempreferences table. Otherwise, your new changes
498 will not be seen by this process.
500 =cut
502 sub clear_syspref_cache {
503 return unless $use_syspref_cache;
504 $syspref_cache->flush_all;
507 =head2 set_preference
509 C4::Context->set_preference( $variable, $value, [ $explanation, $type, $options ] );
511 This updates a preference's value both in the systempreferences table and in
512 the sysprefs cache. If the optional parameters are provided, then the query
513 becomes a create. It won't update the parameters (except value) for an existing
514 preference.
516 =cut
518 sub set_preference {
519 my ( $self, $variable, $value, $explanation, $type, $options ) = @_;
521 my $variable_case = $variable;
522 $variable = lc $variable;
524 my $syspref = Koha::Config::SysPrefs->find($variable);
525 $type =
526 $type ? $type
527 : $syspref ? $syspref->type
528 : undef;
530 $value = 0 if ( $type && $type eq 'YesNo' && $value eq '' );
532 # force explicit protocol on OPACBaseURL
533 if ( $variable eq 'opacbaseurl' && $value && substr( $value, 0, 4 ) !~ /http/ ) {
534 $value = 'http://' . $value;
537 if ($syspref) {
538 $syspref->set(
539 { ( defined $value ? ( value => $value ) : () ),
540 ( $explanation ? ( explanation => $explanation ) : () ),
541 ( $type ? ( type => $type ) : () ),
542 ( $options ? ( options => $options ) : () ),
544 )->store;
545 } else {
546 $syspref = Koha::Config::SysPref->new(
547 { variable => $variable_case,
548 value => $value,
549 explanation => $explanation || undef,
550 type => $type,
551 options => $options || undef,
553 )->store();
556 if ( $use_syspref_cache ) {
557 $syspref_cache->set_in_cache( "syspref_$variable", $value );
560 return $syspref;
563 =head2 delete_preference
565 C4::Context->delete_preference( $variable );
567 This deletes a system preference from the database. Returns a true value on
568 success. Failure means there was an issue with the database, not that there
569 was no syspref of the name.
571 =cut
573 sub delete_preference {
574 my ( $self, $var ) = @_;
576 if ( Koha::Config::SysPrefs->find( $var )->delete ) {
577 if ( $use_syspref_cache ) {
578 $syspref_cache->clear_from_cache("syspref_$var");
581 return 1;
583 return 0;
586 =head2 Zconn
588 $Zconn = C4::Context->Zconn
590 Returns a connection to the Zebra database
592 C<$self>
594 C<$server> one of the servers defined in the koha-conf.xml file
596 C<$async> whether this is a asynchronous connection
598 =cut
600 sub Zconn {
601 my ($self, $server, $async ) = @_;
602 my $cache_key = join ('::', (map { $_ // '' } ($server, $async )));
603 if ( (!defined($ENV{GATEWAY_INTERFACE})) && defined($context->{"Zconn"}->{$cache_key}) && (0 == $context->{"Zconn"}->{$cache_key}->errcode()) ) {
604 # if we are running the script from the commandline, lets try to use the caching
605 return $context->{"Zconn"}->{$cache_key};
607 $context->{"Zconn"}->{$cache_key}->destroy() if defined($context->{"Zconn"}->{$cache_key}); #destroy old connection before making a new one
608 $context->{"Zconn"}->{$cache_key} = &_new_Zconn( $server, $async );
609 return $context->{"Zconn"}->{$cache_key};
612 =head2 _new_Zconn
614 $context->{"Zconn"} = &_new_Zconn($server,$async);
616 Internal function. Creates a new database connection from the data given in the current context and returns it.
618 C<$server> one of the servers defined in the koha-conf.xml file
620 C<$async> whether this is a asynchronous connection
622 C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
624 =cut
626 sub _new_Zconn {
627 my ( $server, $async ) = @_;
629 my $tried=0; # first attempt
630 my $Zconn; # connection object
631 my $elementSetName;
632 my $syntax;
634 $server //= "biblioserver";
636 $syntax = 'xml';
637 $elementSetName = 'marcxml';
639 my $host = $context->{'listen'}->{$server}->{'content'};
640 my $user = $context->{"serverinfo"}->{$server}->{"user"};
641 my $password = $context->{"serverinfo"}->{$server}->{"password"};
642 eval {
643 # set options
644 my $o = new ZOOM::Options();
645 $o->option(user => $user) if $user && $password;
646 $o->option(password => $password) if $user && $password;
647 $o->option(async => 1) if $async;
648 $o->option(cqlfile=> $context->{"server"}->{$server}->{"cql2rpn"});
649 $o->option(cclfile=> $context->{"serverinfo"}->{$server}->{"ccl2rpn"});
650 $o->option(preferredRecordSyntax => $syntax);
651 $o->option(elementSetName => $elementSetName) if $elementSetName;
652 $o->option(databaseName => $context->{"config"}->{$server}||"biblios");
654 # create a new connection object
655 $Zconn= create ZOOM::Connection($o);
657 # forge to server
658 $Zconn->connect($host, 0);
660 # check for errors and warn
661 if ($Zconn->errcode() !=0) {
662 warn "something wrong with the connection: ". $Zconn->errmsg();
665 return $Zconn;
668 # _new_dbh
669 # Internal helper function (not a method!). This creates a new
670 # database connection from the data given in the current context, and
671 # returns it.
672 sub _new_dbh
675 Koha::Database->schema({ new => 1 })->storage->dbh;
678 =head2 dbh
680 $dbh = C4::Context->dbh;
682 Returns a database handle connected to the Koha database for the
683 current context. If no connection has yet been made, this method
684 creates one, and connects to the database.
686 This database handle is cached for future use: if you call
687 C<C4::Context-E<gt>dbh> twice, you will get the same handle both
688 times. If you need a second database handle, use C<&new_dbh> and
689 possibly C<&set_dbh>.
691 =cut
694 sub dbh
696 my $self = shift;
697 my $params = shift;
698 my $sth;
700 unless ( $params->{new} ) {
701 return Koha::Database->schema->storage->dbh;
704 return Koha::Database->schema({ new => 1 })->storage->dbh;
707 =head2 new_dbh
709 $dbh = C4::Context->new_dbh;
711 Creates a new connection to the Koha database for the current context,
712 and returns the database handle (a C<DBI::db> object).
714 The handle is not saved anywhere: this method is strictly a
715 convenience function; the point is that it knows which database to
716 connect to so that the caller doesn't have to know.
718 =cut
721 sub new_dbh
723 my $self = shift;
725 return &dbh({ new => 1 });
728 =head2 set_dbh
730 $my_dbh = C4::Connect->new_dbh;
731 C4::Connect->set_dbh($my_dbh);
733 C4::Connect->restore_dbh;
735 C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
736 C<&set_context> and C<&restore_context>.
738 C<&set_dbh> saves the current database handle on a stack, then sets
739 the current database handle to C<$my_dbh>.
741 C<$my_dbh> is assumed to be a good database handle.
743 =cut
746 sub set_dbh
748 my $self = shift;
749 my $new_dbh = shift;
751 # Save the current database handle on the handle stack.
752 # We assume that $new_dbh is all good: if the caller wants to
753 # screw himself by passing an invalid handle, that's fine by
754 # us.
755 push @{$context->{"dbh_stack"}}, $context->{"dbh"};
756 $context->{"dbh"} = $new_dbh;
759 =head2 restore_dbh
761 C4::Context->restore_dbh;
763 Restores the database handle saved by an earlier call to
764 C<C4::Context-E<gt>set_dbh>.
766 =cut
769 sub restore_dbh
771 my $self = shift;
773 if ($#{$context->{"dbh_stack"}} < 0)
775 # Stack underflow
776 die "DBH stack underflow";
779 # Pop the old database handle and set it.
780 $context->{"dbh"} = pop @{$context->{"dbh_stack"}};
782 # FIXME - If it is determined that restore_context should
783 # return something, then this function should, too.
786 =head2 queryparser
788 $queryparser = C4::Context->queryparser
790 Returns a handle to an initialized Koha::QueryParser::Driver::PQF object.
792 =cut
794 sub queryparser {
795 my $self = shift;
796 unless (defined $context->{"queryparser"}) {
797 $context->{"queryparser"} = &_new_queryparser();
800 return
801 defined( $context->{"queryparser"} )
802 ? $context->{"queryparser"}->new
803 : undef;
806 =head2 _new_queryparser
808 Internal helper function to create a new QueryParser object. QueryParser
809 is loaded dynamically so as to keep the lack of the QueryParser library from
810 getting in anyone's way.
812 =cut
814 sub _new_queryparser {
815 my $qpmodules = {
816 'OpenILS::QueryParser' => undef,
817 'Koha::QueryParser::Driver::PQF' => undef
819 if ( can_load( 'modules' => $qpmodules ) ) {
820 my $QParser = Koha::QueryParser::Driver::PQF->new();
821 my $config_file = $context->config('queryparser_config');
822 $config_file ||= '/etc/koha/searchengine/queryparser.yaml';
823 if ( $QParser->load_config($config_file) ) {
824 # Set 'keyword' as the default search class
825 $QParser->default_search_class('keyword');
826 # TODO: allow indexes to be configured in the database
827 return $QParser;
830 return;
833 =head2 userenv
835 C4::Context->userenv;
837 Retrieves a hash for user environment variables.
839 This hash shall be cached for future use: if you call
840 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
842 =cut
845 sub userenv {
846 my $var = $context->{"activeuser"};
847 if (defined $var and defined $context->{"userenv"}->{$var}) {
848 return $context->{"userenv"}->{$var};
849 } else {
850 return;
854 =head2 set_userenv
856 C4::Context->set_userenv($usernum, $userid, $usercnum,
857 $userfirstname, $usersurname,
858 $userbranch, $branchname, $userflags,
859 $emailaddress, $branchprinter, $shibboleth);
861 Establish a hash of user environment variables.
863 set_userenv is called in Auth.pm
865 =cut
868 sub set_userenv {
869 shift @_;
870 my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter, $shibboleth)=
871 map { Encode::is_utf8( $_ ) ? $_ : Encode::decode('UTF-8', $_) } # CGI::Session doesn't handle utf-8, so we decode it here
873 my $var=$context->{"activeuser"} || '';
874 my $cell = {
875 "number" => $usernum,
876 "id" => $userid,
877 "cardnumber" => $usercnum,
878 "firstname" => $userfirstname,
879 "surname" => $usersurname,
880 #possibly a law problem
881 "branch" => $userbranch,
882 "branchname" => $branchname,
883 "flags" => $userflags,
884 "emailaddress" => $emailaddress,
885 "branchprinter" => $branchprinter,
886 "shibboleth" => $shibboleth,
888 $context->{userenv}->{$var} = $cell;
889 return $cell;
892 sub set_shelves_userenv {
893 my ($type, $shelves) = @_ or return;
894 my $activeuser = $context->{activeuser} or return;
895 $context->{userenv}->{$activeuser}->{barshelves} = $shelves if $type eq 'bar';
896 $context->{userenv}->{$activeuser}->{pubshelves} = $shelves if $type eq 'pub';
897 $context->{userenv}->{$activeuser}->{totshelves} = $shelves if $type eq 'tot';
900 sub get_shelves_userenv {
901 my $active;
902 unless ($active = $context->{userenv}->{$context->{activeuser}}) {
903 $debug and warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}";
904 return;
906 my $totshelves = $active->{totshelves} or undef;
907 my $pubshelves = $active->{pubshelves} or undef;
908 my $barshelves = $active->{barshelves} or undef;
909 return ($totshelves, $pubshelves, $barshelves);
912 =head2 _new_userenv
914 C4::Context->_new_userenv($session); # FIXME: This calling style is wrong for what looks like an _internal function
916 Builds a hash for user environment variables.
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
921 _new_userenv is called in Auth.pm
923 =cut
926 sub _new_userenv
928 shift; # Useless except it compensates for bad calling style
929 my ($sessionID)= @_;
930 $context->{"activeuser"}=$sessionID;
933 =head2 _unset_userenv
935 C4::Context->_unset_userenv;
937 Destroys the hash for activeuser user environment variables.
939 =cut
943 sub _unset_userenv
945 my ($sessionID)= @_;
946 undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
950 =head2 get_versions
952 C4::Context->get_versions
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'.
956 =cut
960 # A little example sub to show more debugging info for CGI::Carp
961 sub get_versions {
962 my %versions;
963 $versions{kohaVersion} = Koha::version();
964 $versions{kohaDbVersion} = C4::Context->preference('version');
965 $versions{osVersion} = join(" ", POSIX::uname());
966 $versions{perlVersion} = $];
968 no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
969 $versions{mysqlVersion} = `mysql -V`;
970 $versions{apacheVersion} = (`apache2ctl -v`)[0];
971 $versions{apacheVersion} = `httpd -v` unless $versions{apacheVersion} ;
972 $versions{apacheVersion} = `httpd2 -v` unless $versions{apacheVersion} ;
973 $versions{apacheVersion} = `apache2 -v` unless $versions{apacheVersion} ;
974 $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless $versions{apacheVersion} ;
976 return %versions;
979 =head2 timezone
981 my $C4::Context->timzone
983 Returns a timezone code for the instance of Koha
985 =cut
987 sub timezone {
988 my $self = shift;
990 my $timezone = C4::Context->config('timezone') || $ENV{TZ} || 'local';
991 if ( !DateTime::TimeZone->is_valid_name( $timezone ) ) {
992 warn "Invalid timezone in koha-conf.xml ($timezone)";
993 $timezone = 'local';
996 return $timezone;
999 =head2 tz
1001 C4::Context->tz
1003 Returns a DateTime::TimeZone object for the system timezone
1005 =cut
1007 sub tz {
1008 my $self = shift;
1009 if (!defined $context->{tz}) {
1010 my $timezone = $self->timezone;
1011 $context->{tz} = DateTime::TimeZone->new(name => $timezone);
1013 return $context->{tz};
1017 =head2 IsSuperLibrarian
1019 C4::Context->IsSuperLibrarian();
1021 =cut
1023 sub IsSuperLibrarian {
1024 my $userenv = C4::Context->userenv;
1026 unless ( $userenv and exists $userenv->{flags} ) {
1027 # If we reach this without a user environment,
1028 # assume that we're running from a command-line script,
1029 # and act as a superlibrarian.
1030 carp("C4::Context->userenv not defined!");
1031 return 1;
1034 return ($userenv->{flags}//0) % 2;
1037 =head2 interface
1039 Sets the current interface for later retrieval in any Perl module
1041 C4::Context->interface('opac');
1042 C4::Context->interface('intranet');
1043 my $interface = C4::Context->interface;
1045 =cut
1047 sub interface {
1048 my ($class, $interface) = @_;
1050 if (defined $interface) {
1051 $interface = lc $interface;
1052 if ( $interface eq 'api'
1053 || $interface eq 'opac'
1054 || $interface eq 'intranet'
1055 || $interface eq 'sip'
1056 || $interface eq 'cron'
1057 || $interface eq 'commandline' )
1059 $context->{interface} = $interface;
1060 } else {
1061 warn "invalid interface : '$interface'";
1065 return $context->{interface} // 'opac';
1068 # always returns a string for OK comparison via "eq" or "ne"
1069 sub mybranch {
1070 C4::Context->userenv or return '';
1071 return C4::Context->userenv->{branch} || '';
1074 =head2 only_my_library
1076 my $test = C4::Context->only_my_library;
1078 Returns true if you enabled IndependentBranches and the current user
1079 does not have superlibrarian permissions.
1081 =cut
1083 sub only_my_library {
1084 return
1085 C4::Context->preference('IndependentBranches')
1086 && C4::Context->userenv
1087 && !C4::Context->IsSuperLibrarian()
1088 && C4::Context->userenv->{branch};
1091 =head3 temporary_directory
1093 Returns root directory for temporary storage
1095 =cut
1097 sub temporary_directory {
1098 my ( $class ) = @_;
1099 return C4::Context->config('tmp_path') || File::Spec->tmpdir;
1105 __END__
1107 =head1 ENVIRONMENT
1109 =head2 C<KOHA_CONF>
1111 Specifies the configuration file to read.
1113 =head1 SEE ALSO
1115 XML::Simple
1117 =head1 AUTHORS
1119 Andrew Arensburger <arensb at ooblick dot com>
1121 Joshua Ferraro <jmf at liblime dot com>