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>.
22 use vars qw($AUTOLOAD $context @context_stack);
24 if ( $ENV{'HTTP_USER_AGENT'} ) { # Only hit when plack is not enabled
26 # Redefine multi_param if cgi version is < 4.08
27 # Remove the "CGI::param called in list context" warning in this case
28 require CGI; # Can't check version without the require.
29 if ( !defined($CGI::VERSION) || $CGI::VERSION < 4.08 ) {
30 no warnings 'redefine';
31 *CGI::multi_param = \&CGI::param;
32 use warnings 'redefine';
33 $CGI::LIST_CONTEXT_WARN = 0;
39 use DateTime::TimeZone;
42 use Module::Load::Conditional qw(can_load);
49 use Koha::Config::SysPref;
50 use Koha::Config::SysPrefs;
56 C4::Context - Maintain and manipulate the context of a Koha script
62 use C4::Context("/path/to/koha-conf.xml");
64 $config_value = C4::Context->config("config_variable");
66 $koha_preference = C4::Context->preference("preference");
68 $db_handle = C4::Context->dbh;
70 $Zconn = C4::Context->Zconn;
74 When a Koha script runs, it makes use of a certain number of things:
75 configuration settings in F</etc/koha/koha-conf.xml>, a connection to the Koha
76 databases, and so forth. These things make up the I<context> in which
79 This module takes care of setting up the context for a script:
80 figuring out which configuration file to load, and loading it, opening
81 a connection to the right database, and so forth.
83 Most scripts will only use one context. They can simply have
89 Other scripts may need to use several contexts. For instance, if a
90 library has two databases, one for a certain collection, and the other
91 for everything else, it might be necessary for a script to use two
92 different contexts to search both databases. Such scripts should use
93 the C<&set_context> and C<&restore_context> functions, below.
95 By default, C4::Context reads the configuration from
96 F</etc/koha/koha-conf.xml>. This may be overridden by setting the C<$KOHA_CONF>
97 environment variable to the pathname of a configuration file to use.
104 # In addition to what is said in the POD above, a Context object is a
105 # reference-to-hash with the following fields:
108 # A reference-to-hash whose keys and values are the
109 # configuration variables and values specified in the config
110 # file (/etc/koha/koha-conf.xml).
112 # A handle to the appropriate database for this context.
114 # Used by &set_dbh and &restore_dbh to hold other database
115 # handles for this context.
117 # A connection object for the Zebra server
119 $context = undef; # Initially, no context is set
120 @context_stack = (); # Initially, no saved contexts
124 my $dbd_driver_name = C4::Context::db_schema2dbi($scheme);
126 This routines translates a database type to part of the name
127 of the appropriate DBD driver to use when establishing a new
128 database connection. It recognizes 'mysql' and 'Pg'; if any
129 other scheme is supplied it defaults to 'mysql'.
134 my $scheme = shift // '';
135 return $scheme eq 'Pg' ? $scheme : 'mysql';
139 # Create the default context ($C4::Context::Context)
140 # the first time the module is called
141 # (a config file can be optionaly passed)
143 # default context already exists?
147 my ($pkg,$config_file) = @_ ;
148 my $new_ctx = __PACKAGE__->new($config_file);
149 return unless $new_ctx;
151 # if successfully loaded, use it by default
152 $new_ctx->set_context;
158 $context = C4::Context->new;
159 $context = C4::Context->new("/path/to/koha-conf.xml");
161 Allocates a new context. Initializes the context from the specified
162 file, which defaults to either the file given by the C<$KOHA_CONF>
163 environment variable, or F</etc/koha/koha-conf.xml>.
165 It saves the koha-conf.xml values in the declared memcached server(s)
166 if currently available and uses those values until them expire and
169 C<&new> does not set this context as the new default context; for
170 that, use C<&set_context>.
176 # 2004-08-10 A. Tarallo: Added check if the conf file is not empty
179 my $conf_fname = shift; # Config file to load
181 # check that the specified config file exists and is not empty
182 undef $conf_fname unless
183 (defined $conf_fname && -s $conf_fname);
184 # Figure out a good config file to load if none was specified.
185 unless ( defined $conf_fname ) {
186 $conf_fname = Koha::Config->guess_koha_conf;
187 unless ( $conf_fname ) {
188 warn "unable to locate Koha configuration file koha-conf.xml";
193 my $self = Koha::Config->read_from_file($conf_fname);
194 unless ( exists $self->{config} or defined $self->{config} ) {
195 warn "The config file ($conf_fname) has not been parsed correctly";
199 $self->{"Zconn"} = undef; # Zebra Connections
200 $self->{"userenv"} = undef; # User env
201 $self->{"activeuser"} = undef; # current active user
202 $self->{"shelves"} = undef;
203 $self->{tz} = undef; # local timezone object
206 $self->{db_driver} = db_scheme2dbi($self->config('db_scheme')); # cache database driver
212 $context = new C4::Context;
213 $context->set_context();
215 set_context C4::Context $context;
218 restore_context C4::Context;
220 In some cases, it might be necessary for a script to use multiple
221 contexts. C<&set_context> saves the current context on a stack, then
222 sets the context to C<$context>, which will be used in future
223 operations. To restore the previous context, use C<&restore_context>.
231 my $new_context; # The context to set
233 # Figure out whether this is a class or instance method call.
235 # We're going to make the assumption that control got here
236 # through valid means, i.e., that the caller used an instance
237 # or class method call, and that control got here through the
238 # usual inheritance mechanisms. The caller can, of course,
239 # break this assumption by playing silly buggers, but that's
240 # harder to do than doing it properly, and harder to check
242 if (ref($self) eq "")
244 # Class method. The new context is the next argument.
245 $new_context = shift;
247 # Instance method. The new context is $self.
248 $new_context = $self;
251 # Save the old context, if any, on the stack
252 push @context_stack, $context if defined($context);
254 # Set the new context
255 $context = $new_context;
258 =head2 restore_context
262 Restores the context set by C<&set_context>.
271 if ($#context_stack < 0)
274 die "Context stack underflow";
277 # Pop the old context and set it.
278 $context = pop @context_stack;
280 # FIXME - Should this return something, like maybe the context
281 # that was current when this was called?
286 $value = C4::Context->config("config_variable");
288 $value = C4::Context->config_variable;
290 Returns the value of a variable specified in the configuration file
291 from which the current context was created.
293 The second form is more compact, but of course may conflict with
294 method names. If there is a configuration variable called "new", then
295 C<C4::Config-E<gt>new> will not return it.
302 return unless defined $context and defined $context->{$term};
303 # Presumably $self->{$term} might be
304 # undefined if the config file given to &new
305 # didn't exist, and the caller didn't bother
306 # to check the return value.
308 # Return the value of the requested config variable
309 return $context->{$term}->{$var};
313 return _common_config($_[1],'config');
316 return _common_config($_[1],'server');
321 $sys_preference = C4::Context->preference('some_variable');
323 Looks up the value of the given system preference in the
324 systempreferences table of the Koha database, and returns it. If the
325 variable is not set or does not exist, undef is returned.
327 In case of an error, this may return 0.
329 Note: It is impossible to tell the difference between system
330 preferences which do not exist, and those whose values are set to NULL
335 my $use_syspref_cache = 1;
338 my $var = shift; # The system preference to return
340 return Encode::decode_utf8($ENV{"OVERRIDE_SYSPREF_$var"})
341 if defined $ENV{"OVERRIDE_SYSPREF_$var"};
345 if ($use_syspref_cache) {
346 my $syspref_cache = Koha::Caches->get_instance('syspref');
347 my $cached_var = $syspref_cache->get_from_cache("syspref_$var");
348 return $cached_var if defined $cached_var;
352 eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) };
353 my $value = $syspref ? $syspref->value() : undef;
355 if ( $use_syspref_cache ) {
356 my $syspref_cache = Koha::Caches->get_instance('syspref');
357 $syspref_cache->set_in_cache("syspref_$var", $value);
362 =head2 yaml_preference
364 Retrieves the required system preference value, and converts it
365 from YAML into a Perl data structure. It throws an exception if
366 the value cannot be properly decoded as YAML.
370 sub yaml_preference {
371 my ( $self, $preference ) = @_;
373 my $yaml = eval { YAML::XS::Load( Encode::encode_utf8( $self->preference( $preference ) ) ); };
375 warn "Unable to parse $preference syspref : $@";
382 =head2 enable_syspref_cache
384 C4::Context->enable_syspref_cache();
386 Enable the in-memory syspref cache used by C4::Context. This is the
391 sub enable_syspref_cache {
393 $use_syspref_cache = 1;
394 # We need to clear the cache to have it up-to-date
395 $self->clear_syspref_cache();
398 =head2 disable_syspref_cache
400 C4::Context->disable_syspref_cache();
402 Disable the in-memory syspref cache used by C4::Context. This should be
403 used with Plack and other persistent environments.
407 sub disable_syspref_cache {
409 $use_syspref_cache = 0;
410 $self->clear_syspref_cache();
413 =head2 clear_syspref_cache
415 C4::Context->clear_syspref_cache();
417 cleans the internal cache of sysprefs. Please call this method if
418 you update the systempreferences table. Otherwise, your new changes
419 will not be seen by this process.
423 sub clear_syspref_cache {
424 return unless $use_syspref_cache;
425 my $syspref_cache = Koha::Caches->get_instance('syspref');
426 $syspref_cache->flush_all;
429 =head2 set_preference
431 C4::Context->set_preference( $variable, $value, [ $explanation, $type, $options ] );
433 This updates a preference's value both in the systempreferences table and in
434 the sysprefs cache. If the optional parameters are provided, then the query
435 becomes a create. It won't update the parameters (except value) for an existing
441 my ( $self, $variable, $value, $explanation, $type, $options ) = @_;
443 my $variable_case = $variable;
444 $variable = lc $variable;
446 my $syspref = Koha::Config::SysPrefs->find($variable);
449 : $syspref ? $syspref->type
452 $value = 0 if ( $type && $type eq 'YesNo' && $value eq '' );
454 # force explicit protocol on OPACBaseURL
455 if ( $variable eq 'opacbaseurl' && $value && substr( $value, 0, 4 ) !~ /http/ ) {
456 $value = 'http://' . $value;
461 { ( defined $value ? ( value => $value ) : () ),
462 ( $explanation ? ( explanation => $explanation ) : () ),
463 ( $type ? ( type => $type ) : () ),
464 ( $options ? ( options => $options ) : () ),
468 $syspref = Koha::Config::SysPref->new(
469 { variable => $variable_case,
471 explanation => $explanation || undef,
473 options => $options || undef,
478 if ( $use_syspref_cache ) {
479 my $syspref_cache = Koha::Caches->get_instance('syspref');
480 $syspref_cache->set_in_cache( "syspref_$variable", $value );
486 =head2 delete_preference
488 C4::Context->delete_preference( $variable );
490 This deletes a system preference from the database. Returns a true value on
491 success. Failure means there was an issue with the database, not that there
492 was no syspref of the name.
496 sub delete_preference {
497 my ( $self, $var ) = @_;
499 if ( Koha::Config::SysPrefs->find( $var )->delete ) {
500 if ( $use_syspref_cache ) {
501 my $syspref_cache = Koha::Caches->get_instance('syspref');
502 $syspref_cache->clear_from_cache("syspref_$var");
512 $Zconn = C4::Context->Zconn
514 Returns a connection to the Zebra database
518 C<$server> one of the servers defined in the koha-conf.xml file
520 C<$async> whether this is a asynchronous connection
525 my ($self, $server, $async ) = @_;
526 my $cache_key = join ('::', (map { $_ // '' } ($server, $async )));
527 if ( (!defined($ENV{GATEWAY_INTERFACE})) && defined($context->{"Zconn"}->{$cache_key}) && (0 == $context->{"Zconn"}->{$cache_key}->errcode()) ) {
528 # if we are running the script from the commandline, lets try to use the caching
529 return $context->{"Zconn"}->{$cache_key};
531 $context->{"Zconn"}->{$cache_key}->destroy() if defined($context->{"Zconn"}->{$cache_key}); #destroy old connection before making a new one
532 $context->{"Zconn"}->{$cache_key} = &_new_Zconn( $server, $async );
533 return $context->{"Zconn"}->{$cache_key};
538 $context->{"Zconn"} = &_new_Zconn($server,$async);
540 Internal function. Creates a new database connection from the data given in the current context and returns it.
542 C<$server> one of the servers defined in the koha-conf.xml file
544 C<$async> whether this is a asynchronous connection
546 C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
551 my ( $server, $async ) = @_;
553 my $tried=0; # first attempt
554 my $Zconn; # connection object
558 $server //= "biblioserver";
561 $elementSetName = 'marcxml';
563 my $host = $context->{'listen'}->{$server}->{'content'};
564 my $user = $context->{"serverinfo"}->{$server}->{"user"};
565 my $password = $context->{"serverinfo"}->{$server}->{"password"};
568 my $o = ZOOM::Options->new();
569 $o->option(user => $user) if $user && $password;
570 $o->option(password => $password) if $user && $password;
571 $o->option(async => 1) if $async;
572 $o->option(cqlfile=> $context->{"server"}->{$server}->{"cql2rpn"});
573 $o->option(cclfile=> $context->{"serverinfo"}->{$server}->{"ccl2rpn"});
574 $o->option(preferredRecordSyntax => $syntax);
575 $o->option(elementSetName => $elementSetName) if $elementSetName;
576 $o->option(databaseName => $context->{"config"}->{$server}||"biblios");
578 # create a new connection object
579 $Zconn= create ZOOM::Connection($o);
582 $Zconn->connect($host, 0);
584 # check for errors and warn
585 if ($Zconn->errcode() !=0) {
586 warn "something wrong with the connection: ". $Zconn->errmsg();
593 # Internal helper function (not a method!). This creates a new
594 # database connection from the data given in the current context, and
599 Koha::Database->schema({ new => 1 })->storage->dbh;
604 $dbh = C4::Context->dbh;
606 Returns a database handle connected to the Koha database for the
607 current context. If no connection has yet been made, this method
608 creates one, and connects to the database.
610 This database handle is cached for future use: if you call
611 C<C4::Context-E<gt>dbh> twice, you will get the same handle both
612 times. If you need a second database handle, use C<&new_dbh> and
613 possibly C<&set_dbh>.
623 unless ( $params->{new} ) {
624 return Koha::Database->schema->storage->dbh;
627 return Koha::Database->schema({ new => 1 })->storage->dbh;
632 $dbh = C4::Context->new_dbh;
634 Creates a new connection to the Koha database for the current context,
635 and returns the database handle (a C<DBI::db> object).
637 The handle is not saved anywhere: this method is strictly a
638 convenience function; the point is that it knows which database to
639 connect to so that the caller doesn't have to know.
648 return &dbh({ new => 1 });
653 $my_dbh = C4::Connect->new_dbh;
654 C4::Connect->set_dbh($my_dbh);
656 C4::Connect->restore_dbh;
658 C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
659 C<&set_context> and C<&restore_context>.
661 C<&set_dbh> saves the current database handle on a stack, then sets
662 the current database handle to C<$my_dbh>.
664 C<$my_dbh> is assumed to be a good database handle.
674 # Save the current database handle on the handle stack.
675 # We assume that $new_dbh is all good: if the caller wants to
676 # screw himself by passing an invalid handle, that's fine by
678 push @{$context->{"dbh_stack"}}, $context->{"dbh"};
679 $context->{"dbh"} = $new_dbh;
684 C4::Context->restore_dbh;
686 Restores the database handle saved by an earlier call to
687 C<C4::Context-E<gt>set_dbh>.
696 if ($#{$context->{"dbh_stack"}} < 0)
699 die "DBH stack underflow";
702 # Pop the old database handle and set it.
703 $context->{"dbh"} = pop @{$context->{"dbh_stack"}};
705 # FIXME - If it is determined that restore_context should
706 # return something, then this function should, too.
711 C4::Context->userenv;
713 Retrieves a hash for user environment variables.
715 This hash shall be cached for future use: if you call
716 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
722 my $var = $context->{"activeuser"};
723 if (defined $var and defined $context->{"userenv"}->{$var}) {
724 return $context->{"userenv"}->{$var};
732 C4::Context->set_userenv($usernum, $userid, $usercnum,
733 $userfirstname, $usersurname,
734 $userbranch, $branchname, $userflags,
735 $emailaddress, $shibboleth
736 $desk_id, $desk_name,
737 $register_id, $register_name);
739 Establish a hash of user environment variables.
741 set_userenv is called in Auth.pm
748 my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $shibboleth, $desk_id, $desk_name, $register_id, $register_name)=
749 map { Encode::is_utf8( $_ ) ? $_ : Encode::decode('UTF-8', $_) } # CGI::Session doesn't handle utf-8, so we decode it here
751 my $var=$context->{"activeuser"} || '';
753 "number" => $usernum,
755 "cardnumber" => $usercnum,
756 "firstname" => $userfirstname,
757 "surname" => $usersurname,
759 #possibly a law problem
760 "branch" => $userbranch,
761 "branchname" => $branchname,
762 "flags" => $userflags,
763 "emailaddress" => $emailaddress,
764 "shibboleth" => $shibboleth,
765 "desk_id" => $desk_id,
766 "desk_name" => $desk_name,
767 "register_id" => $register_id,
768 "register_name" => $register_name
770 $context->{userenv}->{$var} = $cell;
774 sub set_shelves_userenv {
775 my ($type, $shelves) = @_ or return;
776 my $activeuser = $context->{activeuser} or return;
777 $context->{userenv}->{$activeuser}->{barshelves} = $shelves if $type eq 'bar';
778 $context->{userenv}->{$activeuser}->{pubshelves} = $shelves if $type eq 'pub';
779 $context->{userenv}->{$activeuser}->{totshelves} = $shelves if $type eq 'tot';
782 sub get_shelves_userenv {
784 unless ($active = $context->{userenv}->{$context->{activeuser}}) {
785 $debug and warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}";
788 my $totshelves = $active->{totshelves} or undef;
789 my $pubshelves = $active->{pubshelves} or undef;
790 my $barshelves = $active->{barshelves} or undef;
791 return ($totshelves, $pubshelves, $barshelves);
796 C4::Context->_new_userenv($session); # FIXME: This calling style is wrong for what looks like an _internal function
798 Builds a hash for user environment variables.
800 This hash shall be cached for future use: if you call
801 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
803 _new_userenv is called in Auth.pm
810 shift; # Useless except it compensates for bad calling style
812 $context->{"activeuser"}=$sessionID;
815 =head2 _unset_userenv
817 C4::Context->_unset_userenv;
819 Destroys the hash for activeuser user environment variables.
828 undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
834 C4::Context->get_versions
836 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'.
842 # A little example sub to show more debugging info for CGI::Carp
845 $versions{kohaVersion} = Koha::version();
846 $versions{kohaDbVersion} = C4::Context->preference('version');
847 $versions{osVersion} = join(" ", POSIX::uname());
848 $versions{perlVersion} = $];
850 no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
851 $versions{mysqlVersion} = `mysql -V`;
852 $versions{apacheVersion} = (`apache2ctl -v`)[0];
853 $versions{apacheVersion} = `httpd -v` unless $versions{apacheVersion} ;
854 $versions{apacheVersion} = `httpd2 -v` unless $versions{apacheVersion} ;
855 $versions{apacheVersion} = `apache2 -v` unless $versions{apacheVersion} ;
856 $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless $versions{apacheVersion} ;
863 my $C4::Context->timzone
865 Returns a timezone code for the instance of Koha
872 my $timezone = C4::Context->config('timezone') || $ENV{TZ} || 'local';
873 if ( !DateTime::TimeZone->is_valid_name( $timezone ) ) {
874 warn "Invalid timezone in koha-conf.xml ($timezone)";
885 Returns a DateTime::TimeZone object for the system timezone
891 if (!defined $context->{tz}) {
892 my $timezone = $self->timezone;
893 $context->{tz} = DateTime::TimeZone->new(name => $timezone);
895 return $context->{tz};
899 =head2 IsSuperLibrarian
901 C4::Context->IsSuperLibrarian();
905 sub IsSuperLibrarian {
906 my $userenv = C4::Context->userenv;
908 unless ( $userenv and exists $userenv->{flags} ) {
909 # If we reach this without a user environment,
910 # assume that we're running from a command-line script,
911 # and act as a superlibrarian.
912 carp("C4::Context->userenv not defined!");
916 return ($userenv->{flags}//0) % 2;
921 Sets the current interface for later retrieval in any Perl module
923 C4::Context->interface('opac');
924 C4::Context->interface('intranet');
925 my $interface = C4::Context->interface;
930 my ($class, $interface) = @_;
932 if (defined $interface) {
933 $interface = lc $interface;
934 if ( $interface eq 'api'
935 || $interface eq 'opac'
936 || $interface eq 'intranet'
937 || $interface eq 'sip'
938 || $interface eq 'cron'
939 || $interface eq 'commandline' )
941 $context->{interface} = $interface;
943 warn "invalid interface : '$interface'";
947 return $context->{interface} // 'opac';
950 # always returns a string for OK comparison via "eq" or "ne"
952 C4::Context->userenv or return '';
953 return C4::Context->userenv->{branch} || '';
956 =head2 only_my_library
958 my $test = C4::Context->only_my_library;
960 Returns true if you enabled IndependentBranches and the current user
961 does not have superlibrarian permissions.
965 sub only_my_library {
967 C4::Context->preference('IndependentBranches')
968 && C4::Context->userenv
969 && !C4::Context->IsSuperLibrarian()
970 && C4::Context->userenv->{branch};
973 =head3 temporary_directory
975 Returns root directory for temporary storage
979 sub temporary_directory {
981 return C4::Context->config('tmp_path') || File::Spec->tmpdir;
984 =head3 set_remote_address
986 set_remote_address should be called at the beginning of every script
987 that is *not* running under plack in order to the REMOTE_ADDR environment
988 variable to be set correctly.
992 sub set_remote_address {
993 if ( C4::Context->config('koha_trusted_proxies') ) {
995 my $header = CGI->http('HTTP_X_FORWARDED_FOR');
998 require Koha::Middleware::RealIP;
999 $ENV{REMOTE_ADDR} = Koha::Middleware::RealIP::get_real_ip( $ENV{REMOTE_ADDR}, $header );
1004 =head3 https_enabled
1006 https_enabled should be called when checking if a HTTPS connection
1009 Note that this depends on a HTTPS environmental variable being defined
1010 by the web server. This function may not return the expected result,
1011 if your web server or reverse proxies are not setting the correct
1012 X-Forwarded-Proto headers and HTTPS environmental variable.
1014 Note too that the HTTPS value can vary from web server to web server.
1015 We are relying on the convention of the value being "on" or "ON" here.
1020 my $https_enabled = 0;
1021 my $env_https = $ENV{HTTPS};
1023 if ($env_https =~ /^ON$/i){
1027 return $https_enabled;
1032 =head3 needs_install
1034 if ( $context->needs_install ) { ... }
1036 This method returns a boolean representing the install status of the Koha instance.
1042 return ($self->preference('Version')) ? 0 : 1;
1051 Specifies the configuration file to read.
1059 Andrew Arensburger <arensb at ooblick dot com>
1061 Joshua Ferraro <jmf at liblime dot com>