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
492 if (exists $sysprefs{$var}) {
493 return $sysprefs{$var};
496 if (Koha::Cache->is_cache_active()) {
497 $cache = Koha::Cache->new();
498 if (defined $cache) {
499 $sysprefs{$var} = $cache->get_from_cache("syspref:$var");
500 return $sysprefs{$var} if (defined $sysprefs{$var});
504 my $dbh = C4::Context->dbh or return 0;
506 # Look up systempreferences.variable==$var
507 my $sql = <<'END_SQL';
509 FROM systempreferences
513 $sysprefs{$var} = $dbh->selectrow_array( $sql, {}, $var );
514 if (Koha::Cache->is_cache_active() && defined $cache) {
515 $cache->set_in_cache("syspref:$var");
517 return $sysprefs{$var};
520 sub boolean_preference ($) {
522 my $var = shift; # The system preference to return
523 my $it = preference($self, $var);
524 return defined($it)? C4::Boolean::true_p($it): undef;
527 =head2 clear_syspref_cache
529 C4::Context->clear_syspref_cache();
531 cleans the internal cache of sysprefs. Please call this method if
532 you update the systempreferences table. Otherwise, your new changes
533 will not be seen by this process.
537 sub clear_syspref_cache {
539 if (Koha::Cache->is_cache_active()) {
540 my $cache = Koha::Cache->new();
541 $cache->flush_all() if defined $cache; # Sorry, this is unpleasant
545 =head2 set_preference
547 C4::Context->set_preference( $variable, $value );
549 This updates a preference's value both in the systempreferences table and in
559 my $dbh = C4::Context->dbh or return 0;
561 my $type = $dbh->selectrow_array( "SELECT type FROM systempreferences WHERE variable = ?", {}, $var );
563 $value = 0 if ( $type && $type eq 'YesNo' && $value eq '' );
565 my $sth = $dbh->prepare( "
566 INSERT INTO systempreferences
569 ON DUPLICATE KEY UPDATE value = VALUES(value)
572 if($sth->execute( $var, $value )) {
573 if (Koha::Cache->is_cache_active()) {
574 my $cache = Koha::Cache->new();
575 $cache->set_in_cache("syspref:$var", $value) if defined $cache;
577 $sysprefs{$var} = $value;
583 # This implements C4::Config->foo, and simply returns
584 # C4::Context->config("foo"), as described in the documentation for
587 # FIXME - Perhaps this should be extended to check &config first, and
588 # then &preference if that fails. OTOH, AUTOLOAD could lead to crappy
589 # code, so it'd probably be best to delete it altogether so as not to
590 # encourage people to use it.
595 $AUTOLOAD =~ s/.*:://; # Chop off the package name,
596 # leaving only the function name.
597 return $self->config($AUTOLOAD);
602 $Zconn = C4::Context->Zconn
604 Returns a connection to the Zebra database for the current
605 context. If no connection has yet been made, this method
606 creates one and connects.
610 C<$server> one of the servers defined in the koha-conf.xml file
612 C<$async> whether this is a asynchronous connection
614 C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
626 if ( defined($context->{"Zconn"}->{$server}) && (0 == $context->{"Zconn"}->{$server}->errcode()) ) {
627 return $context->{"Zconn"}->{$server};
628 # No connection object or it died. Create one.
630 # release resources if we're closing a connection and making a new one
631 # FIXME: this needs to be smarter -- an error due to a malformed query or
632 # a missing index does not necessarily require us to close the connection
633 # and make a new one, particularly for a batch job. However, at
634 # first glance it does not look like there's a way to easily check
635 # the basic health of a ZOOM::Connection
636 $context->{"Zconn"}->{$server}->destroy() if defined($context->{"Zconn"}->{$server});
638 $context->{"Zconn"}->{$server} = &_new_Zconn($server,$async,$auth,$piggyback,$syntax);
639 return $context->{"Zconn"}->{$server};
645 $context->{"Zconn"} = &_new_Zconn($server,$async);
647 Internal function. Creates a new database connection from the data given in the current context and returns it.
649 C<$server> one of the servers defined in the koha-conf.xml file
651 C<$async> whether this is a asynchronous connection
653 C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
658 my ($server,$async,$auth,$piggyback,$syntax) = @_;
660 my $tried=0; # first attempt
661 my $Zconn; # connection object
662 $server = "biblioserver" unless $server;
663 $syntax = "usmarc" unless $syntax;
665 my $host = $context->{'listen'}->{$server}->{'content'};
666 my $servername = $context->{"config"}->{$server};
667 my $user = $context->{"serverinfo"}->{$server}->{"user"};
668 my $password = $context->{"serverinfo"}->{$server}->{"password"};
669 $auth = 1 if($user && $password);
673 my $o = new ZOOM::Options();
674 $o->option(user=>$user) if $auth;
675 $o->option(password=>$password) if $auth;
676 $o->option(async => 1) if $async;
677 $o->option(count => $piggyback) if $piggyback;
678 $o->option(cqlfile=> $context->{"server"}->{$server}->{"cql2rpn"});
679 $o->option(cclfile=> $context->{"serverinfo"}->{$server}->{"ccl2rpn"});
680 $o->option(preferredRecordSyntax => $syntax);
681 $o->option(elementSetName => "F"); # F for 'full' as opposed to B for 'brief'
682 $o->option(databaseName => ($servername?$servername:"biblios"));
684 # create a new connection object
685 $Zconn= create ZOOM::Connection($o);
688 $Zconn->connect($host, 0);
690 # check for errors and warn
691 if ($Zconn->errcode() !=0) {
692 warn "something wrong with the connection: ". $Zconn->errmsg();
697 # # Koha manages the Zebra server -- this doesn't work currently for me because of permissions issues
698 # # Also, I'm skeptical about whether it's the best approach
699 # warn "problem with Zebra";
700 # if ( C4::Context->preference("ManageZebra") ) {
701 # if ($@->code==10000 && $tried==0) { ##No connection try restarting Zebra
703 # warn "trying to restart Zebra";
704 # my $res=system("zebrasrv -f $ENV{'KOHA_CONF'} >/koha/log/zebra-error.log");
707 # warn "Error ", $@->code(), ": ", $@->message(), "\n";
717 # Internal helper function (not a method!). This creates a new
718 # database connection from the data given in the current context, and
724 ## correct name for db_schme
726 if ($context->config("db_scheme")){
727 $db_driver=db_scheme2dbi($context->config("db_scheme"));
732 my $db_name = $context->config("database");
733 my $db_host = $context->config("hostname");
734 my $db_port = $context->config("port") || '';
735 my $db_user = $context->config("user");
736 my $db_passwd = $context->config("pass");
737 # MJR added or die here, as we can't work without dbh
738 my $dbh= DBI->connect("DBI:$db_driver:dbname=$db_name;host=$db_host;port=$db_port",
739 $db_user, $db_passwd, {'RaiseError' => $ENV{DEBUG}?1:0 }) or die $DBI::errstr;
741 if ( $db_driver eq 'mysql' ) {
742 # Koha 3.0 is utf-8, so force utf8 communication between mySQL and koha, whatever the mysql default config.
743 # this is better than modifying my.cnf (and forcing all communications to be in utf8)
744 $dbh->{'mysql_enable_utf8'}=1; #enable
745 $dbh->do("set NAMES 'utf8'");
746 ($tz) and $dbh->do(qq(SET time_zone = "$tz"));
748 elsif ( $db_driver eq 'Pg' ) {
749 $dbh->do( "set client_encoding = 'UTF8';" );
750 ($tz) and $dbh->do(qq(SET TIME ZONE = "$tz"));
757 $dbh = C4::Context->dbh;
759 Returns a database handle connected to the Koha database for the
760 current context. If no connection has yet been made, this method
761 creates one, and connects to the database.
763 This database handle is cached for future use: if you call
764 C<C4::Context-E<gt>dbh> twice, you will get the same handle both
765 times. If you need a second database handle, use C<&new_dbh> and
766 possibly C<&set_dbh>.
776 if (defined($context->{"dbh"}) && $context->{"dbh"}->ping()) {
777 return $context->{"dbh"};
780 # No database handle or it died . Create one.
781 $context->{"dbh"} = &_new_dbh();
783 return $context->{"dbh"};
788 $dbh = C4::Context->new_dbh;
790 Creates a new connection to the Koha database for the current context,
791 and returns the database handle (a C<DBI::db> object).
793 The handle is not saved anywhere: this method is strictly a
794 convenience function; the point is that it knows which database to
795 connect to so that the caller doesn't have to know.
809 $my_dbh = C4::Connect->new_dbh;
810 C4::Connect->set_dbh($my_dbh);
812 C4::Connect->restore_dbh;
814 C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
815 C<&set_context> and C<&restore_context>.
817 C<&set_dbh> saves the current database handle on a stack, then sets
818 the current database handle to C<$my_dbh>.
820 C<$my_dbh> is assumed to be a good database handle.
830 # Save the current database handle on the handle stack.
831 # We assume that $new_dbh is all good: if the caller wants to
832 # screw himself by passing an invalid handle, that's fine by
834 push @{$context->{"dbh_stack"}}, $context->{"dbh"};
835 $context->{"dbh"} = $new_dbh;
840 C4::Context->restore_dbh;
842 Restores the database handle saved by an earlier call to
843 C<C4::Context-E<gt>set_dbh>.
852 if ($#{$context->{"dbh_stack"}} < 0)
855 die "DBH stack underflow";
858 # Pop the old database handle and set it.
859 $context->{"dbh"} = pop @{$context->{"dbh_stack"}};
861 # FIXME - If it is determined that restore_context should
862 # return something, then this function should, too.
865 =head2 marcfromkohafield
867 $dbh = C4::Context->marcfromkohafield;
869 Returns a hash with marcfromkohafield.
871 This hash is cached for future use: if you call
872 C<C4::Context-E<gt>marcfromkohafield> twice, you will get the same hash without real DB access
877 sub marcfromkohafield
881 # If the hash already exists, return it.
882 return $context->{"marcfromkohafield"} if defined($context->{"marcfromkohafield"});
884 # No hash. Create one.
885 $context->{"marcfromkohafield"} = &_new_marcfromkohafield();
887 return $context->{"marcfromkohafield"};
890 # _new_marcfromkohafield
891 # Internal helper function (not a method!). This creates a new
892 # hash with stopwords
893 sub _new_marcfromkohafield
895 my $dbh = C4::Context->dbh;
896 my $marcfromkohafield;
897 my $sth = $dbh->prepare("select frameworkcode,kohafield,tagfield,tagsubfield from marc_subfield_structure where kohafield > ''");
899 while (my ($frameworkcode,$kohafield,$tagfield,$tagsubfield) = $sth->fetchrow) {
901 $marcfromkohafield->{$frameworkcode}->{$kohafield} = [$tagfield,$tagsubfield];
903 return $marcfromkohafield;
908 $dbh = C4::Context->stopwords;
910 Returns a hash with stopwords.
912 This hash is cached for future use: if you call
913 C<C4::Context-E<gt>stopwords> twice, you will get the same hash without real DB access
922 # If the hash already exists, return it.
923 return $context->{"stopwords"} if defined($context->{"stopwords"});
925 # No hash. Create one.
926 $context->{"stopwords"} = &_new_stopwords();
928 return $context->{"stopwords"};
932 # Internal helper function (not a method!). This creates a new
933 # hash with stopwords
936 my $dbh = C4::Context->dbh;
938 my $sth = $dbh->prepare("select word from stopwords");
940 while (my $stopword = $sth->fetchrow_array) {
941 $stopwordlist->{$stopword} = uc($stopword);
943 $stopwordlist->{A} = "A" unless $stopwordlist;
944 return $stopwordlist;
949 C4::Context->userenv;
951 Retrieves a hash for user environment variables.
953 This hash shall be cached for future use: if you call
954 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
960 my $var = $context->{"activeuser"};
961 return $context->{"userenv"}->{$var} if (defined $var and defined $context->{"userenv"}->{$var});
962 # insecure=1 management
963 if ($context->{"dbh"} && $context->preference('insecure') eq 'yes') {
965 $insecure{flags} = '16382';
966 $insecure{branchname} ='Insecure';
967 $insecure{number} ='0';
968 $insecure{cardnumber} ='0';
969 $insecure{id} = 'insecure';
970 $insecure{branch} = 'INS';
971 $insecure{emailaddress} = 'test@mode.insecure.com';
980 C4::Context->set_userenv($usernum, $userid, $usercnum, $userfirstname,
981 $usersurname, $userbranch, $userflags, $emailaddress);
983 Establish a hash of user environment variables.
985 set_userenv is called in Auth.pm
991 my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter)= @_;
992 my $var=$context->{"activeuser"};
994 "number" => $usernum,
996 "cardnumber" => $usercnum,
997 "firstname" => $userfirstname,
998 "surname" => $usersurname,
999 #possibly a law problem
1000 "branch" => $userbranch,
1001 "branchname" => $branchname,
1002 "flags" => $userflags,
1003 "emailaddress" => $emailaddress,
1004 "branchprinter" => $branchprinter
1006 $context->{userenv}->{$var} = $cell;
1010 sub set_shelves_userenv ($$) {
1011 my ($type, $shelves) = @_ or return undef;
1012 my $activeuser = $context->{activeuser} or return undef;
1013 $context->{userenv}->{$activeuser}->{barshelves} = $shelves if $type eq 'bar';
1014 $context->{userenv}->{$activeuser}->{pubshelves} = $shelves if $type eq 'pub';
1015 $context->{userenv}->{$activeuser}->{totshelves} = $shelves if $type eq 'tot';
1018 sub get_shelves_userenv () {
1020 unless ($active = $context->{userenv}->{$context->{activeuser}}) {
1021 $debug and warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}";
1024 my $totshelves = $active->{totshelves} or undef;
1025 my $pubshelves = $active->{pubshelves} or undef;
1026 my $barshelves = $active->{barshelves} or undef;
1027 return ($totshelves, $pubshelves, $barshelves);
1032 C4::Context->_new_userenv($session); # FIXME: This calling style is wrong for what looks like an _internal function
1034 Builds a hash for user environment variables.
1036 This hash shall be cached for future use: if you call
1037 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
1039 _new_userenv is called in Auth.pm
1046 shift; # Useless except it compensates for bad calling style
1047 my ($sessionID)= @_;
1048 $context->{"activeuser"}=$sessionID;
1051 =head2 _unset_userenv
1053 C4::Context->_unset_userenv;
1055 Destroys the hash for activeuser user environment variables.
1063 my ($sessionID)= @_;
1064 undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
1070 C4::Context->get_versions
1072 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'.
1078 # A little example sub to show more debugging info for CGI::Carp
1081 $versions{kohaVersion} = KOHAVERSION();
1082 $versions{kohaDbVersion} = C4::Context->preference('version');
1083 $versions{osVersion} = join(" ", POSIX::uname());
1084 $versions{perlVersion} = $];
1086 no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
1087 $versions{mysqlVersion} = `mysql -V`;
1088 $versions{apacheVersion} = `httpd -v`;
1089 $versions{apacheVersion} = `httpd2 -v` unless $versions{apacheVersion} ;
1090 $versions{apacheVersion} = `apache2 -v` unless $versions{apacheVersion} ;
1091 $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless $versions{apacheVersion} ;
1101 Returns a DateTime::TimeZone object for the system timezone
1107 if (!defined $context->{tz}) {
1108 $context->{tz} = DateTime::TimeZone->new(name => 'local');
1110 return $context->{tz};
1122 Specifies the configuration file to read.
1130 Andrew Arensburger <arensb at ooblick dot com>
1132 Joshua Ferraro <jmf at liblime dot com>