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
7 # under the terms of the GNU General Public License as published by
8 # the Free Software Foundation; either version 3 of the License, or
9 # (at your option) any later version.
11 # Koha is distributed in the hope that it will be useful, but
12 # WITHOUT ANY WARRANTY; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 # GNU General Public License for more details.
16 # You should have received a copy of the GNU General Public License
17 # along with Koha; if not, see <http://www.gnu.org/licenses>.
21 use vars qw($VERSION $AUTOLOAD $context @context_stack $servers $memcached $ismemcached);
23 if ($ENV{'HTTP_USER_AGENT'}) {
25 # FIXME for future reference, CGI::Carp doc says
26 # "Note that fatalsToBrowser does not work with mod_perl version 2.0 and higher."
27 import CGI::Carp qw(fatalsToBrowser);
31 eval {C4::Context->dbh();};
36 $debug_level = C4::Context->preference("DebugLevel");
39 print q(<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
40 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
41 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
42 <head><title>Koha Error</title></head>
45 if ($debug_level eq "2"){
46 # debug 2 , print extra info too.
47 my %versions = get_versions();
49 # a little example table with various version info";
52 <p>The following fatal error has occurred:</p>
53 <pre><code>$msg</code></pre>
55 <tr><th>Apache</th><td> $versions{apacheVersion}</td></tr>
56 <tr><th>Koha</th><td> $versions{kohaVersion}</td></tr>
57 <tr><th>Koha DB</th><td> $versions{kohaDbVersion}</td></tr>
58 <tr><th>MySQL</th><td> $versions{mysqlVersion}</td></tr>
59 <tr><th>OS</th><td> $versions{osVersion}</td></tr>
60 <tr><th>Perl</th><td> $versions{perlVersion}</td></tr>
63 } elsif ($debug_level eq "1"){
66 <p>The following fatal error has occurred:</p>
67 <pre><code>$msg</code></pre>";
69 print "<p>production mode - trapped fatal error</p>";
71 print "</body></html>";
73 #CGI::Carp::set_message(\&handle_errors);
74 ## give a stack backtrace if KOHA_BACKTRACES is set
75 ## can't rely on DebugLevel for this, as we're not yet connected
76 if ($ENV{KOHA_BACKTRACES}) {
77 $main::SIG{__DIE__} = \&CGI::Carp::confess;
80 # Redefine multi_param if cgi version is < 4.08
81 # Remove the "CGI::param called in list context" warning in this case
82 if (!defined($CGI::VERSION) || $CGI::VERSION < 4.08) {
83 no warnings 'redefine';
84 *CGI::multi_param = \&CGI::param;
85 use warnings 'redefine';
86 $CGI::LIST_CONTEXT_WARN = 0;
88 } # else there is no browser to send fatals to!
90 # Check if there are memcached servers set
91 $servers = $ENV{'MEMCACHED_SERVERS'};
93 # Load required libraries and create the memcached object
94 require Cache::Memcached;
95 $memcached = Cache::Memcached->new({
96 servers => [ $servers ],
98 compress_threshold => 10_000,
100 namespace => $ENV{'MEMCACHED_NAMESPACE'} || 'koha'
102 # Verify memcached available (set a variable and test the output)
103 $ismemcached = $memcached->set('ismemcached','1');
106 $VERSION = '3.07.00.049';
114 use DateTime::TimeZone;
115 use Module::Load::Conditional qw(can_load);
121 use Koha::Config::SysPref;
122 use Koha::Config::SysPrefs;
126 C4::Context - Maintain and manipulate the context of a Koha script
132 use C4::Context("/path/to/koha-conf.xml");
134 $config_value = C4::Context->config("config_variable");
136 $koha_preference = C4::Context->preference("preference");
138 $db_handle = C4::Context->dbh;
140 $Zconn = C4::Context->Zconn;
142 $stopwordhash = C4::Context->stopwords;
146 When a Koha script runs, it makes use of a certain number of things:
147 configuration settings in F</etc/koha/koha-conf.xml>, a connection to the Koha
148 databases, and so forth. These things make up the I<context> in which
151 This module takes care of setting up the context for a script:
152 figuring out which configuration file to load, and loading it, opening
153 a connection to the right database, and so forth.
155 Most scripts will only use one context. They can simply have
161 Other scripts may need to use several contexts. For instance, if a
162 library has two databases, one for a certain collection, and the other
163 for everything else, it might be necessary for a script to use two
164 different contexts to search both databases. Such scripts should use
165 the C<&set_context> and C<&restore_context> functions, below.
167 By default, C4::Context reads the configuration from
168 F</etc/koha/koha-conf.xml>. This may be overridden by setting the C<$KOHA_CONF>
169 environment variable to the pathname of a configuration file to use.
176 # In addition to what is said in the POD above, a Context object is a
177 # reference-to-hash with the following fields:
180 # A reference-to-hash whose keys and values are the
181 # configuration variables and values specified in the config
182 # file (/etc/koha/koha-conf.xml).
184 # A handle to the appropriate database for this context.
186 # Used by &set_dbh and &restore_dbh to hold other database
187 # handles for this context.
189 # A connection object for the Zebra server
191 # Koha's main configuration file koha-conf.xml
192 # is searched for according to this priority list:
194 # 1. Path supplied via use C4::Context '/path/to/koha-conf.xml'
195 # 2. Path supplied in KOHA_CONF environment variable.
196 # 3. Path supplied in INSTALLED_CONFIG_FNAME, as long
197 # as value has changed from its default of
198 # '__KOHA_CONF_DIR__/koha-conf.xml', as happens
199 # when Koha is installed in 'standard' or 'single'
201 # 4. Path supplied in CONFIG_FNAME.
203 # The first entry that refers to a readable file is used.
205 use constant CONFIG_FNAME => "/etc/koha/koha-conf.xml";
206 # Default config file, if none is specified
208 my $INSTALLED_CONFIG_FNAME = '__KOHA_CONF_DIR__/koha-conf.xml';
209 # path to config file set by installer
210 # __KOHA_CONF_DIR__ is set by rewrite-confg.PL
211 # when Koha is installed in 'standard' or 'single'
212 # mode. If Koha was installed in 'dev' mode,
213 # __KOHA_CONF_DIR__ is *not* rewritten; instead
214 # developers should set the KOHA_CONF environment variable
216 $context = undef; # Initially, no context is set
217 @context_stack = (); # Initially, no saved contexts
220 =head2 read_config_file
222 Reads the specified Koha config file.
224 Returns an object containing the configuration variables. The object's
225 structure is a bit complex to the uninitiated ... take a look at the
226 koha-conf.xml file as well as the XML::Simple documentation for details. Or,
227 here are a few examples that may give you what you need:
229 The simple elements nested within the <config> element:
231 my $pass = $koha->{'config'}->{'pass'};
233 The <listen> elements:
235 my $listen = $koha->{'listen'}->{'biblioserver'}->{'content'};
237 The elements nested within the <server> element:
239 my $ccl2rpn = $koha->{'server'}->{'biblioserver'}->{'cql2rpn'};
241 Returns undef in case of error.
245 sub read_config_file { # Pass argument naming config file to read
246 my $koha = XMLin(shift, keyattr => ['id'], forcearray => ['listen', 'server', 'serverinfo'], suppressempty => '');
249 $memcached->set('kohaconf',$koha);
252 return $koha; # Return value: ref-to-hash holding the configuration
257 Returns the value of the $ismemcached variable (0/1)
267 If $ismemcached is true, returns the $memcache variable.
268 Returns undef otherwise
282 my $dbd_driver_name = C4::Context::db_schema2dbi($scheme);
284 This routines translates a database type to part of the name
285 of the appropriate DBD driver to use when establishing a new
286 database connection. It recognizes 'mysql' and 'Pg'; if any
287 other scheme is supplied it defaults to 'mysql'.
292 my $scheme = shift // '';
293 return $scheme eq 'Pg' ? $scheme : 'mysql';
297 # Create the default context ($C4::Context::Context)
298 # the first time the module is called
299 # (a config file can be optionaly passed)
301 # default context already exists?
305 my ($pkg,$config_file) = @_ ;
306 my $new_ctx = __PACKAGE__->new($config_file);
307 return unless $new_ctx;
309 # if successfully loaded, use it by default
310 $new_ctx->set_context;
316 $context = new C4::Context;
317 $context = new C4::Context("/path/to/koha-conf.xml");
319 Allocates a new context. Initializes the context from the specified
320 file, which defaults to either the file given by the C<$KOHA_CONF>
321 environment variable, or F</etc/koha/koha-conf.xml>.
323 It saves the koha-conf.xml values in the declared memcached server(s)
324 if currently available and uses those values until them expire and
327 C<&new> does not set this context as the new default context; for
328 that, use C<&set_context>.
334 # 2004-08-10 A. Tarallo: Added check if the conf file is not empty
337 my $conf_fname = shift; # Config file to load
340 # check that the specified config file exists and is not empty
341 undef $conf_fname unless
342 (defined $conf_fname && -s $conf_fname);
343 # Figure out a good config file to load if none was specified.
344 if (!defined($conf_fname))
346 # If the $KOHA_CONF environment variable is set, use
347 # that. Otherwise, use the built-in default.
348 if (exists $ENV{"KOHA_CONF"} and $ENV{'KOHA_CONF'} and -s $ENV{"KOHA_CONF"}) {
349 $conf_fname = $ENV{"KOHA_CONF"};
350 } elsif ($INSTALLED_CONFIG_FNAME !~ /__KOHA_CONF_DIR/ and -s $INSTALLED_CONFIG_FNAME) {
351 # NOTE: be careful -- don't change __KOHA_CONF_DIR in the above
352 # regex to anything else -- don't want installer to rewrite it
353 $conf_fname = $INSTALLED_CONFIG_FNAME;
354 } elsif (-s CONFIG_FNAME) {
355 $conf_fname = CONFIG_FNAME;
357 warn "unable to locate Koha configuration file koha-conf.xml";
363 # retrieve from memcached
364 $self = $memcached->get('kohaconf');
365 if (not defined $self) {
366 # not in memcached yet
367 $self = read_config_file($conf_fname);
370 # non-memcached env, read from file
371 $self = read_config_file($conf_fname);
374 $self->{"config_file"} = $conf_fname;
375 warn "read_config_file($conf_fname) returned undef" if !defined($self->{"config"});
376 return if !defined($self->{"config"});
378 $self->{"Zconn"} = undef; # Zebra Connections
379 $self->{"stopwords"} = undef; # stopwords list
380 $self->{"marcfromkohafield"} = undef; # the hash with relations between koha table fields and MARC field/subfield
381 $self->{"userenv"} = undef; # User env
382 $self->{"activeuser"} = undef; # current active user
383 $self->{"shelves"} = undef;
384 $self->{tz} = undef; # local timezone object
387 $self->{db_driver} = db_scheme2dbi($self->config('db_scheme')); # cache database driver
393 $context = new C4::Context;
394 $context->set_context();
396 set_context C4::Context $context;
399 restore_context C4::Context;
401 In some cases, it might be necessary for a script to use multiple
402 contexts. C<&set_context> saves the current context on a stack, then
403 sets the context to C<$context>, which will be used in future
404 operations. To restore the previous context, use C<&restore_context>.
412 my $new_context; # The context to set
414 # Figure out whether this is a class or instance method call.
416 # We're going to make the assumption that control got here
417 # through valid means, i.e., that the caller used an instance
418 # or class method call, and that control got here through the
419 # usual inheritance mechanisms. The caller can, of course,
420 # break this assumption by playing silly buggers, but that's
421 # harder to do than doing it properly, and harder to check
423 if (ref($self) eq "")
425 # Class method. The new context is the next argument.
426 $new_context = shift;
428 # Instance method. The new context is $self.
429 $new_context = $self;
432 # Save the old context, if any, on the stack
433 push @context_stack, $context if defined($context);
435 # Set the new context
436 $context = $new_context;
439 =head2 restore_context
443 Restores the context set by C<&set_context>.
452 if ($#context_stack < 0)
455 die "Context stack underflow";
458 # Pop the old context and set it.
459 $context = pop @context_stack;
461 # FIXME - Should this return something, like maybe the context
462 # that was current when this was called?
467 $value = C4::Context->config("config_variable");
469 $value = C4::Context->config_variable;
471 Returns the value of a variable specified in the configuration file
472 from which the current context was created.
474 The second form is more compact, but of course may conflict with
475 method names. If there is a configuration variable called "new", then
476 C<C4::Config-E<gt>new> will not return it.
483 return if !defined($context->{$term});
484 # Presumably $self->{$term} might be
485 # undefined if the config file given to &new
486 # didn't exist, and the caller didn't bother
487 # to check the return value.
489 # Return the value of the requested config variable
490 return $context->{$term}->{$var};
494 return _common_config($_[1],'config');
497 return _common_config($_[1],'server');
500 return _common_config($_[1],'serverinfo');
505 $sys_preference = C4::Context->preference('some_variable');
507 Looks up the value of the given system preference in the
508 systempreferences table of the Koha database, and returns it. If the
509 variable is not set or does not exist, undef is returned.
511 In case of an error, this may return 0.
513 Note: It is impossible to tell the difference between system
514 preferences which do not exist, and those whose values are set to NULL
519 my $syspref_cache = Koha::Cache->get_instance();
520 my $use_syspref_cache = 1;
523 my $var = shift; # The system preference to return
527 return $ENV{"OVERRIDE_SYSPREF_$var"}
528 if defined $ENV{"OVERRIDE_SYSPREF_$var"};
530 my $cached_var = $use_syspref_cache
531 ? $syspref_cache->get_from_cache("syspref_$var")
533 return $cached_var if defined $cached_var;
536 eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) };
537 my $value = $syspref ? $syspref->value() : undef;
539 if ( $use_syspref_cache ) {
540 $syspref_cache->set_in_cache("syspref_$var", $value);
545 sub boolean_preference {
547 my $var = shift; # The system preference to return
548 my $it = preference($self, $var);
549 return defined($it)? C4::Boolean::true_p($it): undef;
552 =head2 enable_syspref_cache
554 C4::Context->enable_syspref_cache();
556 Enable the in-memory syspref cache used by C4::Context. This is the
561 sub enable_syspref_cache {
563 $use_syspref_cache = 1;
564 # We need to clear the cache to have it up-to-date
565 $self->clear_syspref_cache();
568 =head2 disable_syspref_cache
570 C4::Context->disable_syspref_cache();
572 Disable the in-memory syspref cache used by C4::Context. This should be
573 used with Plack and other persistent environments.
577 sub disable_syspref_cache {
579 $use_syspref_cache = 0;
580 $self->clear_syspref_cache();
583 =head2 clear_syspref_cache
585 C4::Context->clear_syspref_cache();
587 cleans the internal cache of sysprefs. Please call this method if
588 you update the systempreferences table. Otherwise, your new changes
589 will not be seen by this process.
593 sub clear_syspref_cache {
594 return unless $use_syspref_cache;
595 $syspref_cache->flush_all;
598 =head2 set_preference
600 C4::Context->set_preference( $variable, $value, [ $explanation, $type, $options ] );
602 This updates a preference's value both in the systempreferences table and in
603 the sysprefs cache. If the optional parameters are provided, then the query
604 becomes a create. It won't update the parameters (except value) for an existing
610 my ( $self, $variable, $value, $explanation, $type, $options ) = @_;
612 $variable = lc $variable;
614 my $syspref = Koha::Config::SysPrefs->find($variable);
617 : $syspref ? $syspref->type
620 $value = 0 if ( $type && $type eq 'YesNo' && $value eq '' );
622 # force explicit protocol on OPACBaseURL
623 if ( $variable eq 'opacbaseurl' && $value && substr( $value, 0, 4 ) !~ /http/ ) {
624 $value = 'http://' . $value;
629 { ( defined $value ? ( value => $value ) : () ),
630 ( $explanation ? ( explanation => $explanation ) : () ),
631 ( $type ? ( type => $type ) : () ),
632 ( $options ? ( options => $options ) : () ),
636 $syspref = Koha::Config::SysPref->new(
637 { variable => $variable,
639 explanation => $explanation || undef,
641 options => $options || undef,
646 if ( $use_syspref_cache ) {
647 $syspref_cache->set_in_cache( "syspref_$variable", $value );
653 =head2 delete_preference
655 C4::Context->delete_preference( $variable );
657 This deletes a system preference from the database. Returns a true value on
658 success. Failure means there was an issue with the database, not that there
659 was no syspref of the name.
663 sub delete_preference {
664 my ( $self, $var ) = @_;
666 if ( Koha::Config::SysPrefs->find( $var )->delete ) {
667 if ( $use_syspref_cache ) {
668 $syspref_cache->clear_from_cache("syspref_$var");
678 $Zconn = C4::Context->Zconn
680 Returns a connection to the Zebra database
684 C<$server> one of the servers defined in the koha-conf.xml file
686 C<$async> whether this is a asynchronous connection
691 my ($self, $server, $async ) = @_;
692 my $cache_key = join ('::', (map { $_ // '' } ($server, $async )));
693 if ( (!defined($ENV{GATEWAY_INTERFACE})) && defined($context->{"Zconn"}->{$cache_key}) && (0 == $context->{"Zconn"}->{$cache_key}->errcode()) ) {
694 # if we are running the script from the commandline, lets try to use the caching
695 return $context->{"Zconn"}->{$cache_key};
697 $context->{"Zconn"}->{$cache_key}->destroy() if defined($context->{"Zconn"}->{$cache_key}); #destroy old connection before making a new one
698 $context->{"Zconn"}->{$cache_key} = &_new_Zconn( $server, $async );
699 return $context->{"Zconn"}->{$cache_key};
704 $context->{"Zconn"} = &_new_Zconn($server,$async);
706 Internal function. Creates a new database connection from the data given in the current context and returns it.
708 C<$server> one of the servers defined in the koha-conf.xml file
710 C<$async> whether this is a asynchronous connection
712 C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
717 my ( $server, $async ) = @_;
719 my $tried=0; # first attempt
720 my $Zconn; # connection object
725 $server //= "biblioserver";
727 if ( $server eq 'biblioserver' ) {
728 $index_mode = $context->{'config'}->{'zebra_bib_index_mode'} // 'dom';
729 } elsif ( $server eq 'authorityserver' ) {
730 $index_mode = $context->{'config'}->{'zebra_auth_index_mode'} // 'dom';
733 if ( $index_mode eq 'grs1' ) {
734 $elementSetName = 'F';
735 $syntax = ( $context->preference("marcflavour") eq 'UNIMARC' )
739 } else { # $index_mode eq 'dom'
741 $elementSetName = 'marcxml';
744 my $host = $context->{'listen'}->{$server}->{'content'};
745 my $user = $context->{"serverinfo"}->{$server}->{"user"};
746 my $password = $context->{"serverinfo"}->{$server}->{"password"};
749 my $o = new ZOOM::Options();
750 $o->option(user => $user) if $user && $password;
751 $o->option(password => $password) if $user && $password;
752 $o->option(async => 1) if $async;
753 $o->option(cqlfile=> $context->{"server"}->{$server}->{"cql2rpn"});
754 $o->option(cclfile=> $context->{"serverinfo"}->{$server}->{"ccl2rpn"});
755 $o->option(preferredRecordSyntax => $syntax);
756 $o->option(elementSetName => $elementSetName) if $elementSetName;
757 $o->option(databaseName => $context->{"config"}->{$server}||"biblios");
759 # create a new connection object
760 $Zconn= create ZOOM::Connection($o);
763 $Zconn->connect($host, 0);
765 # check for errors and warn
766 if ($Zconn->errcode() !=0) {
767 warn "something wrong with the connection: ". $Zconn->errmsg();
774 # Internal helper function (not a method!). This creates a new
775 # database connection from the data given in the current context, and
780 Koha::Database->schema({ new => 1 })->storage->dbh;
785 $dbh = C4::Context->dbh;
787 Returns a database handle connected to the Koha database for the
788 current context. If no connection has yet been made, this method
789 creates one, and connects to the database.
791 This database handle is cached for future use: if you call
792 C<C4::Context-E<gt>dbh> twice, you will get the same handle both
793 times. If you need a second database handle, use C<&new_dbh> and
794 possibly C<&set_dbh>.
805 unless ( $params->{new} ) {
806 return Koha::Database->schema->storage->dbh;
809 return Koha::Database->schema({ new => 1 })->storage->dbh;
814 $dbh = C4::Context->new_dbh;
816 Creates a new connection to the Koha database for the current context,
817 and returns the database handle (a C<DBI::db> object).
819 The handle is not saved anywhere: this method is strictly a
820 convenience function; the point is that it knows which database to
821 connect to so that the caller doesn't have to know.
830 return &dbh({ new => 1 });
835 $my_dbh = C4::Connect->new_dbh;
836 C4::Connect->set_dbh($my_dbh);
838 C4::Connect->restore_dbh;
840 C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
841 C<&set_context> and C<&restore_context>.
843 C<&set_dbh> saves the current database handle on a stack, then sets
844 the current database handle to C<$my_dbh>.
846 C<$my_dbh> is assumed to be a good database handle.
856 # Save the current database handle on the handle stack.
857 # We assume that $new_dbh is all good: if the caller wants to
858 # screw himself by passing an invalid handle, that's fine by
860 push @{$context->{"dbh_stack"}}, $context->{"dbh"};
861 $context->{"dbh"} = $new_dbh;
866 C4::Context->restore_dbh;
868 Restores the database handle saved by an earlier call to
869 C<C4::Context-E<gt>set_dbh>.
878 if ($#{$context->{"dbh_stack"}} < 0)
881 die "DBH stack underflow";
884 # Pop the old database handle and set it.
885 $context->{"dbh"} = pop @{$context->{"dbh_stack"}};
887 # FIXME - If it is determined that restore_context should
888 # return something, then this function should, too.
893 $queryparser = C4::Context->queryparser
895 Returns a handle to an initialized Koha::QueryParser::Driver::PQF object.
901 unless (defined $context->{"queryparser"}) {
902 $context->{"queryparser"} = &_new_queryparser();
906 defined( $context->{"queryparser"} )
907 ? $context->{"queryparser"}->new
911 =head2 _new_queryparser
913 Internal helper function to create a new QueryParser object. QueryParser
914 is loaded dynamically so as to keep the lack of the QueryParser library from
915 getting in anyone's way.
919 sub _new_queryparser {
921 'OpenILS::QueryParser' => undef,
922 'Koha::QueryParser::Driver::PQF' => undef
924 if ( can_load( 'modules' => $qpmodules ) ) {
925 my $QParser = Koha::QueryParser::Driver::PQF->new();
926 my $config_file = $context->config('queryparser_config');
927 $config_file ||= '/etc/koha/searchengine/queryparser.yaml';
928 if ( $QParser->load_config($config_file) ) {
929 # Set 'keyword' as the default search class
930 $QParser->default_search_class('keyword');
931 # TODO: allow indexes to be configured in the database
938 =head2 marcfromkohafield
940 $dbh = C4::Context->marcfromkohafield;
942 Returns a hash with marcfromkohafield.
944 This hash is cached for future use: if you call
945 C<C4::Context-E<gt>marcfromkohafield> twice, you will get the same hash without real DB access
950 sub marcfromkohafield
954 # If the hash already exists, return it.
955 return $context->{"marcfromkohafield"} if defined($context->{"marcfromkohafield"});
957 # No hash. Create one.
958 $context->{"marcfromkohafield"} = &_new_marcfromkohafield();
960 return $context->{"marcfromkohafield"};
963 # _new_marcfromkohafield
964 # Internal helper function (not a method!). This creates a new
965 # hash with stopwords
966 sub _new_marcfromkohafield
968 my $dbh = C4::Context->dbh;
969 my $marcfromkohafield;
970 my $sth = $dbh->prepare("select frameworkcode,kohafield,tagfield,tagsubfield from marc_subfield_structure where kohafield > ''");
972 while (my ($frameworkcode,$kohafield,$tagfield,$tagsubfield) = $sth->fetchrow) {
974 $marcfromkohafield->{$frameworkcode}->{$kohafield} = [$tagfield,$tagsubfield];
976 return $marcfromkohafield;
981 $dbh = C4::Context->stopwords;
983 Returns a hash with stopwords.
985 This hash is cached for future use: if you call
986 C<C4::Context-E<gt>stopwords> twice, you will get the same hash without real DB access
995 # If the hash already exists, return it.
996 return $context->{"stopwords"} if defined($context->{"stopwords"});
998 # No hash. Create one.
999 $context->{"stopwords"} = &_new_stopwords();
1001 return $context->{"stopwords"};
1005 # Internal helper function (not a method!). This creates a new
1006 # hash with stopwords
1009 my $dbh = C4::Context->dbh;
1011 my $sth = $dbh->prepare("select word from stopwords");
1013 while (my $stopword = $sth->fetchrow_array) {
1014 $stopwordlist->{$stopword} = uc($stopword);
1016 $stopwordlist->{A} = "A" unless $stopwordlist;
1017 return $stopwordlist;
1022 C4::Context->userenv;
1024 Retrieves a hash for user environment variables.
1026 This hash shall be cached for future use: if you call
1027 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
1033 my $var = $context->{"activeuser"};
1034 if (defined $var and defined $context->{"userenv"}->{$var}) {
1035 return $context->{"userenv"}->{$var};
1043 C4::Context->set_userenv($usernum, $userid, $usercnum,
1044 $userfirstname, $usersurname,
1045 $userbranch, $branchname, $userflags,
1046 $emailaddress, $branchprinter, $persona);
1048 Establish a hash of user environment variables.
1050 set_userenv is called in Auth.pm
1057 my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter, $persona, $shibboleth)=
1058 map { Encode::is_utf8( $_ ) ? $_ : Encode::decode('UTF-8', $_) } # CGI::Session doesn't handle utf-8, so we decode it here
1060 my $var=$context->{"activeuser"} || '';
1062 "number" => $usernum,
1064 "cardnumber" => $usercnum,
1065 "firstname" => $userfirstname,
1066 "surname" => $usersurname,
1067 #possibly a law problem
1068 "branch" => $userbranch,
1069 "branchname" => $branchname,
1070 "flags" => $userflags,
1071 "emailaddress" => $emailaddress,
1072 "branchprinter" => $branchprinter,
1073 "persona" => $persona,
1074 "shibboleth" => $shibboleth,
1076 $context->{userenv}->{$var} = $cell;
1080 sub set_shelves_userenv {
1081 my ($type, $shelves) = @_ or return;
1082 my $activeuser = $context->{activeuser} or return;
1083 $context->{userenv}->{$activeuser}->{barshelves} = $shelves if $type eq 'bar';
1084 $context->{userenv}->{$activeuser}->{pubshelves} = $shelves if $type eq 'pub';
1085 $context->{userenv}->{$activeuser}->{totshelves} = $shelves if $type eq 'tot';
1088 sub get_shelves_userenv {
1090 unless ($active = $context->{userenv}->{$context->{activeuser}}) {
1091 $debug and warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}";
1094 my $totshelves = $active->{totshelves} or undef;
1095 my $pubshelves = $active->{pubshelves} or undef;
1096 my $barshelves = $active->{barshelves} or undef;
1097 return ($totshelves, $pubshelves, $barshelves);
1102 C4::Context->_new_userenv($session); # FIXME: This calling style is wrong for what looks like an _internal function
1104 Builds a hash for user environment variables.
1106 This hash shall be cached for future use: if you call
1107 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
1109 _new_userenv is called in Auth.pm
1116 shift; # Useless except it compensates for bad calling style
1117 my ($sessionID)= @_;
1118 $context->{"activeuser"}=$sessionID;
1121 =head2 _unset_userenv
1123 C4::Context->_unset_userenv;
1125 Destroys the hash for activeuser user environment variables.
1133 my ($sessionID)= @_;
1134 undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
1140 C4::Context->get_versions
1142 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'.
1148 # A little example sub to show more debugging info for CGI::Carp
1151 $versions{kohaVersion} = Koha::version();
1152 $versions{kohaDbVersion} = C4::Context->preference('version');
1153 $versions{osVersion} = join(" ", POSIX::uname());
1154 $versions{perlVersion} = $];
1156 no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
1157 $versions{mysqlVersion} = `mysql -V`;
1158 $versions{apacheVersion} = (`apache2ctl -v`)[0];
1159 $versions{apacheVersion} = `httpd -v` unless $versions{apacheVersion} ;
1160 $versions{apacheVersion} = `httpd2 -v` unless $versions{apacheVersion} ;
1161 $versions{apacheVersion} = `apache2 -v` unless $versions{apacheVersion} ;
1162 $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless $versions{apacheVersion} ;
1172 Returns a DateTime::TimeZone object for the system timezone
1178 if (!defined $context->{tz}) {
1179 $context->{tz} = DateTime::TimeZone->new(name => 'local');
1181 return $context->{tz};
1185 =head2 IsSuperLibrarian
1187 C4::Context->IsSuperLibrarian();
1191 sub IsSuperLibrarian {
1192 my $userenv = C4::Context->userenv;
1194 unless ( $userenv and exists $userenv->{flags} ) {
1195 # If we reach this without a user environment,
1196 # assume that we're running from a command-line script,
1197 # and act as a superlibrarian.
1198 carp("C4::Context->userenv not defined!");
1202 return ($userenv->{flags}//0) % 2;
1207 Sets the current interface for later retrieval in any Perl module
1209 C4::Context->interface('opac');
1210 C4::Context->interface('intranet');
1211 my $interface = C4::Context->interface;
1216 my ($class, $interface) = @_;
1218 if (defined $interface) {
1219 $interface = lc $interface;
1220 if ($interface eq 'opac' || $interface eq 'intranet') {
1221 $context->{interface} = $interface;
1223 warn "invalid interface : '$interface'";
1227 return $context->{interface} // 'opac';
1237 Specifies the configuration file to read.
1245 Andrew Arensburger <arensb at ooblick dot com>
1247 Joshua Ferraro <jmf at liblime dot com>