2 # Copyright 2002 Katipo Communications
4 # This file is part of Koha.
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
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.
15 # You should have received a copy of the GNU General Public License along
16 # with Koha; if not, write to the Free Software Foundation, Inc.,
17 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
21 use vars qw($VERSION $AUTOLOAD $context @context_stack);
26 if ($ENV{'HTTP_USER_AGENT'}) {
28 # FIXME for future reference, CGI::Carp doc says
29 # "Note that fatalsToBrowser does not work with mod_perl version 2.0 and higher."
30 import CGI::Carp qw(fatalsToBrowser);
34 eval {C4::Context->dbh();};
39 $debug_level = C4::Context->preference("DebugLevel");
42 print q(<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
43 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
44 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
45 <head><title>Koha Error</title></head>
48 if ($debug_level eq "2"){
49 # debug 2 , print extra info too.
50 my %versions = get_versions();
52 # a little example table with various version info";
55 <p>The following fatal error has occurred:</p>
56 <pre><code>$msg</code></pre>
58 <tr><th>Apache</th><td> $versions{apacheVersion}</td></tr>
59 <tr><th>Koha</th><td> $versions{kohaVersion}</td></tr>
60 <tr><th>Koha DB</th><td> $versions{kohaDbVersion}</td></tr>
61 <tr><th>MySQL</th><td> $versions{mysqlVersion}</td></tr>
62 <tr><th>OS</th><td> $versions{osVersion}</td></tr>
63 <tr><th>Perl</th><td> $versions{perlVersion}</td></tr>
66 } elsif ($debug_level eq "1"){
69 <p>The following fatal error has occurred:</p>
70 <pre><code>$msg</code></pre>";
72 print "<p>production mode - trapped fatal error</p>";
74 print "</body></html>";
76 #CGI::Carp::set_message(\&handle_errors);
77 ## give a stack backtrace if KOHA_BACKTRACES is set
78 ## can't rely on DebugLevel for this, as we're not yet connected
79 if ($ENV{KOHA_BACKTRACES}) {
80 $main::SIG{__DIE__} = \&CGI::Carp::confess;
82 } # else there is no browser to send fatals to!
84 $VERSION = '3.07.00.049';
93 use DateTime::TimeZone;
97 C4::Context - Maintain and manipulate the context of a Koha script
103 use C4::Context("/path/to/koha-conf.xml");
105 $config_value = C4::Context->config("config_variable");
107 $koha_preference = C4::Context->preference("preference");
109 $db_handle = C4::Context->dbh;
111 $Zconn = C4::Context->Zconn;
113 $stopwordhash = C4::Context->stopwords;
117 When a Koha script runs, it makes use of a certain number of things:
118 configuration settings in F</etc/koha/koha-conf.xml>, a connection to the Koha
119 databases, and so forth. These things make up the I<context> in which
122 This module takes care of setting up the context for a script:
123 figuring out which configuration file to load, and loading it, opening
124 a connection to the right database, and so forth.
126 Most scripts will only use one context. They can simply have
132 Other scripts may need to use several contexts. For instance, if a
133 library has two databases, one for a certain collection, and the other
134 for everything else, it might be necessary for a script to use two
135 different contexts to search both databases. Such scripts should use
136 the C<&set_context> and C<&restore_context> functions, below.
138 By default, C4::Context reads the configuration from
139 F</etc/koha/koha-conf.xml>. This may be overridden by setting the C<$KOHA_CONF>
140 environment variable to the pathname of a configuration file to use.
147 # In addition to what is said in the POD above, a Context object is a
148 # reference-to-hash with the following fields:
151 # A reference-to-hash whose keys and values are the
152 # configuration variables and values specified in the config
153 # file (/etc/koha/koha-conf.xml).
155 # A handle to the appropriate database for this context.
157 # Used by &set_dbh and &restore_dbh to hold other database
158 # handles for this context.
160 # A connection object for the Zebra server
162 # Koha's main configuration file koha-conf.xml
163 # is searched for according to this priority list:
165 # 1. Path supplied via use C4::Context '/path/to/koha-conf.xml'
166 # 2. Path supplied in KOHA_CONF environment variable.
167 # 3. Path supplied in INSTALLED_CONFIG_FNAME, as long
168 # as value has changed from its default of
169 # '__KOHA_CONF_DIR__/koha-conf.xml', as happens
170 # when Koha is installed in 'standard' or 'single'
172 # 4. Path supplied in CONFIG_FNAME.
174 # The first entry that refers to a readable file is used.
176 use constant CONFIG_FNAME => "/etc/koha/koha-conf.xml";
177 # Default config file, if none is specified
179 my $INSTALLED_CONFIG_FNAME = '__KOHA_CONF_DIR__/koha-conf.xml';
180 # path to config file set by installer
181 # __KOHA_CONF_DIR__ is set by rewrite-confg.PL
182 # when Koha is installed in 'standard' or 'single'
183 # mode. If Koha was installed in 'dev' mode,
184 # __KOHA_CONF_DIR__ is *not* rewritten; instead
185 # developers should set the KOHA_CONF environment variable
187 $context = undef; # Initially, no context is set
188 @context_stack = (); # Initially, no saved contexts
193 returns the kohaversion stored in kohaversion.pl file
198 my $cgidir = C4::Context->intranetdir;
200 # Apparently the GIT code does not run out of a CGI-BIN subdirectory
201 # but distribution code does? (Stan, 1jan08)
202 if(-d $cgidir . "/cgi-bin"){
203 my $cgidir .= "/cgi-bin";
206 do $cgidir."/kohaversion.pl" || die "NO $cgidir/kohaversion.pl";
207 return kohaversion();
209 =head2 read_config_file
211 Reads the specified Koha config file.
213 Returns an object containing the configuration variables. The object's
214 structure is a bit complex to the uninitiated ... take a look at the
215 koha-conf.xml file as well as the XML::Simple documentation for details. Or,
216 here are a few examples that may give you what you need:
218 The simple elements nested within the <config> element:
220 my $pass = $koha->{'config'}->{'pass'};
222 The <listen> elements:
224 my $listen = $koha->{'listen'}->{'biblioserver'}->{'content'};
226 The elements nested within the <server> element:
228 my $ccl2rpn = $koha->{'server'}->{'biblioserver'}->{'cql2rpn'};
230 Returns undef in case of error.
234 sub read_config_file { # Pass argument naming config file to read
235 my $koha = XMLin(shift, keyattr => ['id'], forcearray => ['listen', 'server', 'serverinfo'], suppressempty => '');
237 if (Koha::Cache->is_cache_active()) {
238 my $cache = Koha::Cache->new();
239 $cache->set_in_cache('kohaconf', $koha) if defined $cache;
242 return $koha; # Return value: ref-to-hash holding the configuration
246 # Translates the full text name of a database into de appropiate dbi name
250 # for instance, we support only mysql, so don't care checking
253 # FIXME - Should have other databases.
254 if (/mysql/) { return("mysql"); }
255 if (/Postgres|Pg|PostgresSQL/) { return("Pg"); }
256 if (/oracle/) { return("Oracle"); }
258 return undef; # Just in case
262 # Create the default context ($C4::Context::Context)
263 # the first time the module is called
264 # (a config file can be optionaly passed)
266 # default context allready exists?
270 my ($pkg,$config_file) = @_ ;
271 my $new_ctx = __PACKAGE__->new($config_file);
272 return unless $new_ctx;
274 # if successfully loaded, use it by default
275 $new_ctx->set_context;
281 $context = new C4::Context;
282 $context = new C4::Context("/path/to/koha-conf.xml");
284 Allocates a new context. Initializes the context from the specified
285 file, which defaults to either the file given by the C<$KOHA_CONF>
286 environment variable, or F</etc/koha/koha-conf.xml>.
288 It saves the koha-conf.xml values in the cache (if configured) and uses
289 those values until them expire and re-reads them.
291 C<&new> does not set this context as the new default context; for
292 that, use C<&set_context>.
298 # 2004-08-10 A. Tarallo: Added check if the conf file is not empty
301 my $conf_fname = shift; # Config file to load
304 # check that the specified config file exists and is not empty
305 undef $conf_fname unless
306 (defined $conf_fname && -s $conf_fname);
307 # Figure out a good config file to load if none was specified.
308 if (!defined($conf_fname))
310 # If the $KOHA_CONF environment variable is set, use
311 # that. Otherwise, use the built-in default.
312 if (exists $ENV{"KOHA_CONF"} and $ENV{'KOHA_CONF'} and -s $ENV{"KOHA_CONF"}) {
313 $conf_fname = $ENV{"KOHA_CONF"};
314 } elsif ($INSTALLED_CONFIG_FNAME !~ /__KOHA_CONF_DIR/ and -s $INSTALLED_CONFIG_FNAME) {
315 # NOTE: be careful -- don't change __KOHA_CONF_DIR in the above
316 # regex to anything else -- don't want installer to rewrite it
317 $conf_fname = $INSTALLED_CONFIG_FNAME;
318 } elsif (-s CONFIG_FNAME) {
319 $conf_fname = CONFIG_FNAME;
321 warn "unable to locate Koha configuration file koha-conf.xml";
326 if (Koha::Cache->is_cache_active()) {
327 # retrieve from cache
328 my $cache = Koha::Cache->new();
329 $self = $cache->get_from_cache('kohaconf') if defined $cache;
334 $self = read_config_file($conf_fname);
337 $self->{"config_file"} = $conf_fname;
338 warn "read_config_file($conf_fname) returned undef" if !defined($self->{"config"});
339 return undef if !defined($self->{"config"});
341 $self->{"dbh"} = undef; # Database handle
342 $self->{"Zconn"} = undef; # Zebra Connections
343 $self->{"stopwords"} = undef; # stopwords list
344 $self->{"marcfromkohafield"} = undef; # the hash with relations between koha table fields and MARC field/subfield
345 $self->{"userenv"} = undef; # User env
346 $self->{"activeuser"} = undef; # current active user
347 $self->{"shelves"} = undef;
348 $self->{tz} = undef; # local timezone object
356 $context = new C4::Context;
357 $context->set_context();
359 set_context C4::Context $context;
362 restore_context C4::Context;
364 In some cases, it might be necessary for a script to use multiple
365 contexts. C<&set_context> saves the current context on a stack, then
366 sets the context to C<$context>, which will be used in future
367 operations. To restore the previous context, use C<&restore_context>.
375 my $new_context; # The context to set
377 # Figure out whether this is a class or instance method call.
379 # We're going to make the assumption that control got here
380 # through valid means, i.e., that the caller used an instance
381 # or class method call, and that control got here through the
382 # usual inheritance mechanisms. The caller can, of course,
383 # break this assumption by playing silly buggers, but that's
384 # harder to do than doing it properly, and harder to check
386 if (ref($self) eq "")
388 # Class method. The new context is the next argument.
389 $new_context = shift;
391 # Instance method. The new context is $self.
392 $new_context = $self;
395 # Save the old context, if any, on the stack
396 push @context_stack, $context if defined($context);
398 # Set the new context
399 $context = $new_context;
402 =head2 restore_context
406 Restores the context set by C<&set_context>.
415 if ($#context_stack < 0)
418 die "Context stack underflow";
421 # Pop the old context and set it.
422 $context = pop @context_stack;
424 # FIXME - Should this return something, like maybe the context
425 # that was current when this was called?
430 $value = C4::Context->config("config_variable");
432 $value = C4::Context->config_variable;
434 Returns the value of a variable specified in the configuration file
435 from which the current context was created.
437 The second form is more compact, but of course may conflict with
438 method names. If there is a configuration variable called "new", then
439 C<C4::Config-E<gt>new> will not return it.
443 sub _common_config ($$) {
446 return undef if !defined($context->{$term});
447 # Presumably $self->{$term} might be
448 # undefined if the config file given to &new
449 # didn't exist, and the caller didn't bother
450 # to check the return value.
452 # Return the value of the requested config variable
453 return $context->{$term}->{$var};
457 return _common_config($_[1],'config');
460 return _common_config($_[1],'server');
463 return _common_config($_[1],'serverinfo');
468 $sys_preference = C4::Context->preference('some_variable');
470 Looks up the value of the given system preference in the
471 systempreferences table of the Koha database, and returns it. If the
472 variable is not set or does not exist, undef is returned.
474 In case of an error, this may return 0.
476 Note: It is impossible to tell the difference between system
477 preferences which do not exist, and those whose values are set to NULL
482 # FIXME: running this under mod_perl will require a means of
483 # flushing the caching mechanism.
489 my $var = lc(shift); # The system preference to return
491 if (exists $sysprefs{$var}) {
492 return $sysprefs{$var};
495 my $dbh = C4::Context->dbh or return 0;
497 # Look up systempreferences.variable==$var
498 my $sql = <<'END_SQL';
500 FROM systempreferences
504 $sysprefs{$var} = $dbh->selectrow_array( $sql, {}, $var );
505 return $sysprefs{$var};
508 sub boolean_preference ($) {
510 my $var = shift; # The system preference to return
511 my $it = preference($self, $var);
512 return defined($it)? C4::Boolean::true_p($it): undef;
515 =head2 clear_syspref_cache
517 C4::Context->clear_syspref_cache();
519 cleans the internal cache of sysprefs. Please call this method if
520 you update the systempreferences table. Otherwise, your new changes
521 will not be seen by this process.
525 sub clear_syspref_cache {
529 =head2 set_preference
531 C4::Context->set_preference( $variable, $value );
533 This updates a preference's value both in the systempreferences table and in
543 my $dbh = C4::Context->dbh or return 0;
545 my $type = $dbh->selectrow_array( "SELECT type FROM systempreferences WHERE variable = ?", {}, $var );
547 $value = 0 if ( $type && $type eq 'YesNo' && $value eq '' );
549 my $sth = $dbh->prepare( "
550 INSERT INTO systempreferences
553 ON DUPLICATE KEY UPDATE value = VALUES(value)
556 if($sth->execute( $var, $value )) {
557 $sysprefs{$var} = $value;
563 # This implements C4::Config->foo, and simply returns
564 # C4::Context->config("foo"), as described in the documentation for
567 # FIXME - Perhaps this should be extended to check &config first, and
568 # then &preference if that fails. OTOH, AUTOLOAD could lead to crappy
569 # code, so it'd probably be best to delete it altogether so as not to
570 # encourage people to use it.
575 $AUTOLOAD =~ s/.*:://; # Chop off the package name,
576 # leaving only the function name.
577 return $self->config($AUTOLOAD);
582 $Zconn = C4::Context->Zconn
584 Returns a connection to the Zebra database for the current
585 context. If no connection has yet been made, this method
586 creates one and connects.
590 C<$server> one of the servers defined in the koha-conf.xml file
592 C<$async> whether this is a asynchronous connection
594 C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
606 if ( defined($context->{"Zconn"}->{$server}) && (0 == $context->{"Zconn"}->{$server}->errcode()) ) {
607 return $context->{"Zconn"}->{$server};
608 # No connection object or it died. Create one.
610 # release resources if we're closing a connection and making a new one
611 # FIXME: this needs to be smarter -- an error due to a malformed query or
612 # a missing index does not necessarily require us to close the connection
613 # and make a new one, particularly for a batch job. However, at
614 # first glance it does not look like there's a way to easily check
615 # the basic health of a ZOOM::Connection
616 $context->{"Zconn"}->{$server}->destroy() if defined($context->{"Zconn"}->{$server});
618 $context->{"Zconn"}->{$server} = &_new_Zconn($server,$async,$auth,$piggyback,$syntax);
619 return $context->{"Zconn"}->{$server};
625 $context->{"Zconn"} = &_new_Zconn($server,$async);
627 Internal function. Creates a new database connection from the data given in the current context and returns it.
629 C<$server> one of the servers defined in the koha-conf.xml file
631 C<$async> whether this is a asynchronous connection
633 C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
638 my ($server,$async,$auth,$piggyback,$syntax) = @_;
640 my $tried=0; # first attempt
641 my $Zconn; # connection object
642 $server = "biblioserver" unless $server;
643 $syntax = "usmarc" unless $syntax;
645 my $host = $context->{'listen'}->{$server}->{'content'};
646 my $servername = $context->{"config"}->{$server};
647 my $user = $context->{"serverinfo"}->{$server}->{"user"};
648 my $password = $context->{"serverinfo"}->{$server}->{"password"};
649 $auth = 1 if($user && $password);
653 my $o = new ZOOM::Options();
654 $o->option(user=>$user) if $auth;
655 $o->option(password=>$password) if $auth;
656 $o->option(async => 1) if $async;
657 $o->option(count => $piggyback) if $piggyback;
658 $o->option(cqlfile=> $context->{"server"}->{$server}->{"cql2rpn"});
659 $o->option(cclfile=> $context->{"serverinfo"}->{$server}->{"ccl2rpn"});
660 $o->option(preferredRecordSyntax => $syntax);
661 $o->option(elementSetName => "F"); # F for 'full' as opposed to B for 'brief'
662 $o->option(databaseName => ($servername?$servername:"biblios"));
664 # create a new connection object
665 $Zconn= create ZOOM::Connection($o);
668 $Zconn->connect($host, 0);
670 # check for errors and warn
671 if ($Zconn->errcode() !=0) {
672 warn "something wrong with the connection: ". $Zconn->errmsg();
677 # # Koha manages the Zebra server -- this doesn't work currently for me because of permissions issues
678 # # Also, I'm skeptical about whether it's the best approach
679 # warn "problem with Zebra";
680 # if ( C4::Context->preference("ManageZebra") ) {
681 # if ($@->code==10000 && $tried==0) { ##No connection try restarting Zebra
683 # warn "trying to restart Zebra";
684 # my $res=system("zebrasrv -f $ENV{'KOHA_CONF'} >/koha/log/zebra-error.log");
687 # warn "Error ", $@->code(), ": ", $@->message(), "\n";
697 # Internal helper function (not a method!). This creates a new
698 # database connection from the data given in the current context, and
704 ## correct name for db_schme
706 if ($context->config("db_scheme")){
707 $db_driver=db_scheme2dbi($context->config("db_scheme"));
712 my $db_name = $context->config("database");
713 my $db_host = $context->config("hostname");
714 my $db_port = $context->config("port") || '';
715 my $db_user = $context->config("user");
716 my $db_passwd = $context->config("pass");
717 # MJR added or die here, as we can't work without dbh
718 my $dbh= DBI->connect("DBI:$db_driver:dbname=$db_name;host=$db_host;port=$db_port",
719 $db_user, $db_passwd, {'RaiseError' => $ENV{DEBUG}?1:0 }) or die $DBI::errstr;
721 if ( $db_driver eq 'mysql' ) {
722 # Koha 3.0 is utf-8, so force utf8 communication between mySQL and koha, whatever the mysql default config.
723 # this is better than modifying my.cnf (and forcing all communications to be in utf8)
724 $dbh->{'mysql_enable_utf8'}=1; #enable
725 $dbh->do("set NAMES 'utf8'");
726 ($tz) and $dbh->do(qq(SET time_zone = "$tz"));
728 elsif ( $db_driver eq 'Pg' ) {
729 $dbh->do( "set client_encoding = 'UTF8';" );
730 ($tz) and $dbh->do(qq(SET TIME ZONE = "$tz"));
737 $dbh = C4::Context->dbh;
739 Returns a database handle connected to the Koha database for the
740 current context. If no connection has yet been made, this method
741 creates one, and connects to the database.
743 This database handle is cached for future use: if you call
744 C<C4::Context-E<gt>dbh> twice, you will get the same handle both
745 times. If you need a second database handle, use C<&new_dbh> and
746 possibly C<&set_dbh>.
756 if (defined($context->{"dbh"}) && $context->{"dbh"}->ping()) {
757 return $context->{"dbh"};
760 # No database handle or it died . Create one.
761 $context->{"dbh"} = &_new_dbh();
763 return $context->{"dbh"};
768 $dbh = C4::Context->new_dbh;
770 Creates a new connection to the Koha database for the current context,
771 and returns the database handle (a C<DBI::db> object).
773 The handle is not saved anywhere: this method is strictly a
774 convenience function; the point is that it knows which database to
775 connect to so that the caller doesn't have to know.
789 $my_dbh = C4::Connect->new_dbh;
790 C4::Connect->set_dbh($my_dbh);
792 C4::Connect->restore_dbh;
794 C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
795 C<&set_context> and C<&restore_context>.
797 C<&set_dbh> saves the current database handle on a stack, then sets
798 the current database handle to C<$my_dbh>.
800 C<$my_dbh> is assumed to be a good database handle.
810 # Save the current database handle on the handle stack.
811 # We assume that $new_dbh is all good: if the caller wants to
812 # screw himself by passing an invalid handle, that's fine by
814 push @{$context->{"dbh_stack"}}, $context->{"dbh"};
815 $context->{"dbh"} = $new_dbh;
820 C4::Context->restore_dbh;
822 Restores the database handle saved by an earlier call to
823 C<C4::Context-E<gt>set_dbh>.
832 if ($#{$context->{"dbh_stack"}} < 0)
835 die "DBH stack underflow";
838 # Pop the old database handle and set it.
839 $context->{"dbh"} = pop @{$context->{"dbh_stack"}};
841 # FIXME - If it is determined that restore_context should
842 # return something, then this function should, too.
845 =head2 marcfromkohafield
847 $dbh = C4::Context->marcfromkohafield;
849 Returns a hash with marcfromkohafield.
851 This hash is cached for future use: if you call
852 C<C4::Context-E<gt>marcfromkohafield> twice, you will get the same hash without real DB access
857 sub marcfromkohafield
861 # If the hash already exists, return it.
862 return $context->{"marcfromkohafield"} if defined($context->{"marcfromkohafield"});
864 # No hash. Create one.
865 $context->{"marcfromkohafield"} = &_new_marcfromkohafield();
867 return $context->{"marcfromkohafield"};
870 # _new_marcfromkohafield
871 # Internal helper function (not a method!). This creates a new
872 # hash with stopwords
873 sub _new_marcfromkohafield
875 my $dbh = C4::Context->dbh;
876 my $marcfromkohafield;
877 my $sth = $dbh->prepare("select frameworkcode,kohafield,tagfield,tagsubfield from marc_subfield_structure where kohafield > ''");
879 while (my ($frameworkcode,$kohafield,$tagfield,$tagsubfield) = $sth->fetchrow) {
881 $marcfromkohafield->{$frameworkcode}->{$kohafield} = [$tagfield,$tagsubfield];
883 return $marcfromkohafield;
888 $dbh = C4::Context->stopwords;
890 Returns a hash with stopwords.
892 This hash is cached for future use: if you call
893 C<C4::Context-E<gt>stopwords> twice, you will get the same hash without real DB access
902 # If the hash already exists, return it.
903 return $context->{"stopwords"} if defined($context->{"stopwords"});
905 # No hash. Create one.
906 $context->{"stopwords"} = &_new_stopwords();
908 return $context->{"stopwords"};
912 # Internal helper function (not a method!). This creates a new
913 # hash with stopwords
916 my $dbh = C4::Context->dbh;
918 my $sth = $dbh->prepare("select word from stopwords");
920 while (my $stopword = $sth->fetchrow_array) {
921 $stopwordlist->{$stopword} = uc($stopword);
923 $stopwordlist->{A} = "A" unless $stopwordlist;
924 return $stopwordlist;
929 C4::Context->userenv;
931 Retrieves a hash for user environment variables.
933 This hash shall be cached for future use: if you call
934 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
940 my $var = $context->{"activeuser"};
941 return $context->{"userenv"}->{$var} if (defined $var and defined $context->{"userenv"}->{$var});
942 # insecure=1 management
943 if ($context->{"dbh"} && $context->preference('insecure') eq 'yes') {
945 $insecure{flags} = '16382';
946 $insecure{branchname} ='Insecure';
947 $insecure{number} ='0';
948 $insecure{cardnumber} ='0';
949 $insecure{id} = 'insecure';
950 $insecure{branch} = 'INS';
951 $insecure{emailaddress} = 'test@mode.insecure.com';
960 C4::Context->set_userenv($usernum, $userid, $usercnum, $userfirstname,
961 $usersurname, $userbranch, $userflags, $emailaddress);
963 Establish a hash of user environment variables.
965 set_userenv is called in Auth.pm
971 my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter)= @_;
972 my $var=$context->{"activeuser"};
974 "number" => $usernum,
976 "cardnumber" => $usercnum,
977 "firstname" => $userfirstname,
978 "surname" => $usersurname,
979 #possibly a law problem
980 "branch" => $userbranch,
981 "branchname" => $branchname,
982 "flags" => $userflags,
983 "emailaddress" => $emailaddress,
984 "branchprinter" => $branchprinter
986 $context->{userenv}->{$var} = $cell;
990 sub set_shelves_userenv ($$) {
991 my ($type, $shelves) = @_ or return undef;
992 my $activeuser = $context->{activeuser} or return undef;
993 $context->{userenv}->{$activeuser}->{barshelves} = $shelves if $type eq 'bar';
994 $context->{userenv}->{$activeuser}->{pubshelves} = $shelves if $type eq 'pub';
995 $context->{userenv}->{$activeuser}->{totshelves} = $shelves if $type eq 'tot';
998 sub get_shelves_userenv () {
1000 unless ($active = $context->{userenv}->{$context->{activeuser}}) {
1001 $debug and warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}";
1004 my $totshelves = $active->{totshelves} or undef;
1005 my $pubshelves = $active->{pubshelves} or undef;
1006 my $barshelves = $active->{barshelves} or undef;
1007 return ($totshelves, $pubshelves, $barshelves);
1012 C4::Context->_new_userenv($session); # FIXME: This calling style is wrong for what looks like an _internal function
1014 Builds a hash for user environment variables.
1016 This hash shall be cached for future use: if you call
1017 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
1019 _new_userenv is called in Auth.pm
1026 shift; # Useless except it compensates for bad calling style
1027 my ($sessionID)= @_;
1028 $context->{"activeuser"}=$sessionID;
1031 =head2 _unset_userenv
1033 C4::Context->_unset_userenv;
1035 Destroys the hash for activeuser user environment variables.
1043 my ($sessionID)= @_;
1044 undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
1050 C4::Context->get_versions
1052 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'.
1058 # A little example sub to show more debugging info for CGI::Carp
1061 $versions{kohaVersion} = KOHAVERSION();
1062 $versions{kohaDbVersion} = C4::Context->preference('version');
1063 $versions{osVersion} = join(" ", POSIX::uname());
1064 $versions{perlVersion} = $];
1066 no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
1067 $versions{mysqlVersion} = `mysql -V`;
1068 $versions{apacheVersion} = `httpd -v`;
1069 $versions{apacheVersion} = `httpd2 -v` unless $versions{apacheVersion} ;
1070 $versions{apacheVersion} = `apache2 -v` unless $versions{apacheVersion} ;
1071 $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless $versions{apacheVersion} ;
1081 Returns a DateTime::TimeZone object for the system timezone
1087 if (!defined $context->{tz}) {
1088 $context->{tz} = DateTime::TimeZone->new(name => 'local');
1090 return $context->{tz};
1102 Specifies the configuration file to read.
1110 Andrew Arensburger <arensb at ooblick dot com>
1112 Joshua Ferraro <jmf at liblime dot com>