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);
48 use Koha::Config::SysPref;
49 use Koha::Config::SysPrefs;
55 C4::Context - Maintain and manipulate the context of a Koha script
61 use C4::Context("/path/to/koha-conf.xml");
63 $config_value = C4::Context->config("config_variable");
65 $koha_preference = C4::Context->preference("preference");
67 $db_handle = C4::Context->dbh;
69 $Zconn = C4::Context->Zconn;
73 When a Koha script runs, it makes use of a certain number of things:
74 configuration settings in F</etc/koha/koha-conf.xml>, a connection to the Koha
75 databases, and so forth. These things make up the I<context> in which
78 This module takes care of setting up the context for a script:
79 figuring out which configuration file to load, and loading it, opening
80 a connection to the right database, and so forth.
82 Most scripts will only use one context. They can simply have
88 Other scripts may need to use several contexts. For instance, if a
89 library has two databases, one for a certain collection, and the other
90 for everything else, it might be necessary for a script to use two
91 different contexts to search both databases. Such scripts should use
92 the C<&set_context> and C<&restore_context> functions, below.
94 By default, C4::Context reads the configuration from
95 F</etc/koha/koha-conf.xml>. This may be overridden by setting the C<$KOHA_CONF>
96 environment variable to the pathname of a configuration file to use.
103 # In addition to what is said in the POD above, a Context object is a
104 # reference-to-hash with the following fields:
107 # A reference-to-hash whose keys and values are the
108 # configuration variables and values specified in the config
109 # file (/etc/koha/koha-conf.xml).
111 # A handle to the appropriate database for this context.
113 # Used by &set_dbh and &restore_dbh to hold other database
114 # handles for this context.
116 # A connection object for the Zebra server
118 $context = undef; # Initially, no context is set
119 @context_stack = (); # Initially, no saved contexts
123 my $dbd_driver_name = C4::Context::db_schema2dbi($scheme);
125 This routines translates a database type to part of the name
126 of the appropriate DBD driver to use when establishing a new
127 database connection. It recognizes 'mysql' and 'Pg'; if any
128 other scheme is supplied it defaults to 'mysql'.
133 my $scheme = shift // '';
134 return $scheme eq 'Pg' ? $scheme : 'mysql';
138 # Create the default context ($C4::Context::Context)
139 # the first time the module is called
140 # (a config file can be optionaly passed)
142 # default context already exists?
146 my ($pkg,$config_file) = @_ ;
147 my $new_ctx = __PACKAGE__->new($config_file);
148 return unless $new_ctx;
150 # if successfully loaded, use it by default
151 $new_ctx->set_context;
157 $context = C4::Context->new;
158 $context = C4::Context->new("/path/to/koha-conf.xml");
160 Allocates a new context. Initializes the context from the specified
161 file, which defaults to either the file given by the C<$KOHA_CONF>
162 environment variable, or F</etc/koha/koha-conf.xml>.
164 It saves the koha-conf.xml values in the declared memcached server(s)
165 if currently available and uses those values until them expire and
168 C<&new> does not set this context as the new default context; for
169 that, use C<&set_context>.
175 # 2004-08-10 A. Tarallo: Added check if the conf file is not empty
178 my $conf_fname = shift; # Config file to load
180 # check that the specified config file exists and is not empty
181 undef $conf_fname unless
182 (defined $conf_fname && -s $conf_fname);
183 # Figure out a good config file to load if none was specified.
184 unless ( defined $conf_fname ) {
185 $conf_fname = Koha::Config->guess_koha_conf;
186 unless ( $conf_fname ) {
187 warn "unable to locate Koha configuration file koha-conf.xml";
192 my $self = Koha::Config->read_from_file($conf_fname);
193 unless ( exists $self->{config} or defined $self->{config} ) {
194 warn "The config file ($conf_fname) has not been parsed correctly";
198 $self->{"Zconn"} = undef; # Zebra Connections
199 $self->{"userenv"} = undef; # User env
200 $self->{"activeuser"} = undef; # current active user
201 $self->{"shelves"} = undef;
202 $self->{tz} = undef; # local timezone object
205 $self->{db_driver} = db_scheme2dbi($self->config('db_scheme')); # cache database driver
211 $context = new C4::Context;
212 $context->set_context();
214 set_context C4::Context $context;
217 restore_context C4::Context;
219 In some cases, it might be necessary for a script to use multiple
220 contexts. C<&set_context> saves the current context on a stack, then
221 sets the context to C<$context>, which will be used in future
222 operations. To restore the previous context, use C<&restore_context>.
230 my $new_context; # The context to set
232 # Figure out whether this is a class or instance method call.
234 # We're going to make the assumption that control got here
235 # through valid means, i.e., that the caller used an instance
236 # or class method call, and that control got here through the
237 # usual inheritance mechanisms. The caller can, of course,
238 # break this assumption by playing silly buggers, but that's
239 # harder to do than doing it properly, and harder to check
241 if (ref($self) eq "")
243 # Class method. The new context is the next argument.
244 $new_context = shift;
246 # Instance method. The new context is $self.
247 $new_context = $self;
250 # Save the old context, if any, on the stack
251 push @context_stack, $context if defined($context);
253 # Set the new context
254 $context = $new_context;
257 =head2 restore_context
261 Restores the context set by C<&set_context>.
270 if ($#context_stack < 0)
273 die "Context stack underflow";
276 # Pop the old context and set it.
277 $context = pop @context_stack;
279 # FIXME - Should this return something, like maybe the context
280 # that was current when this was called?
285 $value = C4::Context->config("config_variable");
287 $value = C4::Context->config_variable;
289 Returns the value of a variable specified in the configuration file
290 from which the current context was created.
292 The second form is more compact, but of course may conflict with
293 method names. If there is a configuration variable called "new", then
294 C<C4::Config-E<gt>new> will not return it.
301 return unless defined $context and defined $context->{$term};
302 # Presumably $self->{$term} might be
303 # undefined if the config file given to &new
304 # didn't exist, and the caller didn't bother
305 # to check the return value.
307 # Return the value of the requested config variable
308 return $context->{$term}->{$var};
312 return _common_config($_[1],'config');
315 return _common_config($_[1],'server');
320 $sys_preference = C4::Context->preference('some_variable');
322 Looks up the value of the given system preference in the
323 systempreferences table of the Koha database, and returns it. If the
324 variable is not set or does not exist, undef is returned.
326 In case of an error, this may return 0.
328 Note: It is impossible to tell the difference between system
329 preferences which do not exist, and those whose values are set to NULL
334 my $use_syspref_cache = 1;
337 my $var = shift; # The system preference to return
339 return Encode::decode_utf8($ENV{"OVERRIDE_SYSPREF_$var"})
340 if defined $ENV{"OVERRIDE_SYSPREF_$var"};
344 if ($use_syspref_cache) {
345 my $syspref_cache = Koha::Caches->get_instance('syspref');
346 my $cached_var = $syspref_cache->get_from_cache("syspref_$var");
347 return $cached_var if defined $cached_var;
351 eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) };
352 my $value = $syspref ? $syspref->value() : undef;
354 if ( $use_syspref_cache ) {
355 my $syspref_cache = Koha::Caches->get_instance('syspref');
356 $syspref_cache->set_in_cache("syspref_$var", $value);
361 =head2 yaml_preference
363 Retrieves the required system preference value, and converts it
364 from YAML into a Perl data structure. It throws an exception if
365 the value cannot be properly decoded as YAML.
369 sub yaml_preference {
370 my ( $self, $preference ) = @_;
372 my $yaml = eval { YAML::XS::Load( Encode::encode_utf8( $self->preference( $preference ) ) ); };
374 warn "Unable to parse $preference syspref : $@";
381 =head2 enable_syspref_cache
383 C4::Context->enable_syspref_cache();
385 Enable the in-memory syspref cache used by C4::Context. This is the
390 sub enable_syspref_cache {
392 $use_syspref_cache = 1;
393 # We need to clear the cache to have it up-to-date
394 $self->clear_syspref_cache();
397 =head2 disable_syspref_cache
399 C4::Context->disable_syspref_cache();
401 Disable the in-memory syspref cache used by C4::Context. This should be
402 used with Plack and other persistent environments.
406 sub disable_syspref_cache {
408 $use_syspref_cache = 0;
409 $self->clear_syspref_cache();
412 =head2 clear_syspref_cache
414 C4::Context->clear_syspref_cache();
416 cleans the internal cache of sysprefs. Please call this method if
417 you update the systempreferences table. Otherwise, your new changes
418 will not be seen by this process.
422 sub clear_syspref_cache {
423 return unless $use_syspref_cache;
424 my $syspref_cache = Koha::Caches->get_instance('syspref');
425 $syspref_cache->flush_all;
428 =head2 set_preference
430 C4::Context->set_preference( $variable, $value, [ $explanation, $type, $options ] );
432 This updates a preference's value both in the systempreferences table and in
433 the sysprefs cache. If the optional parameters are provided, then the query
434 becomes a create. It won't update the parameters (except value) for an existing
440 my ( $self, $variable, $value, $explanation, $type, $options ) = @_;
442 my $variable_case = $variable;
443 $variable = lc $variable;
445 my $syspref = Koha::Config::SysPrefs->find($variable);
448 : $syspref ? $syspref->type
451 $value = 0 if ( $type && $type eq 'YesNo' && $value eq '' );
453 # force explicit protocol on OPACBaseURL
454 if ( $variable eq 'opacbaseurl' && $value && substr( $value, 0, 4 ) !~ /http/ ) {
455 $value = 'http://' . $value;
460 { ( defined $value ? ( value => $value ) : () ),
461 ( $explanation ? ( explanation => $explanation ) : () ),
462 ( $type ? ( type => $type ) : () ),
463 ( $options ? ( options => $options ) : () ),
467 $syspref = Koha::Config::SysPref->new(
468 { variable => $variable_case,
470 explanation => $explanation || undef,
472 options => $options || undef,
477 if ( $use_syspref_cache ) {
478 my $syspref_cache = Koha::Caches->get_instance('syspref');
479 $syspref_cache->set_in_cache( "syspref_$variable", $value );
485 =head2 delete_preference
487 C4::Context->delete_preference( $variable );
489 This deletes a system preference from the database. Returns a true value on
490 success. Failure means there was an issue with the database, not that there
491 was no syspref of the name.
495 sub delete_preference {
496 my ( $self, $var ) = @_;
498 if ( Koha::Config::SysPrefs->find( $var )->delete ) {
499 if ( $use_syspref_cache ) {
500 my $syspref_cache = Koha::Caches->get_instance('syspref');
501 $syspref_cache->clear_from_cache("syspref_$var");
511 $Zconn = C4::Context->Zconn
513 Returns a connection to the Zebra database
517 C<$server> one of the servers defined in the koha-conf.xml file
519 C<$async> whether this is a asynchronous connection
524 my ($self, $server, $async ) = @_;
525 my $cache_key = join ('::', (map { $_ // '' } ($server, $async )));
526 if ( (!defined($ENV{GATEWAY_INTERFACE})) && defined($context->{"Zconn"}->{$cache_key}) && (0 == $context->{"Zconn"}->{$cache_key}->errcode()) ) {
527 # if we are running the script from the commandline, lets try to use the caching
528 return $context->{"Zconn"}->{$cache_key};
530 $context->{"Zconn"}->{$cache_key}->destroy() if defined($context->{"Zconn"}->{$cache_key}); #destroy old connection before making a new one
531 $context->{"Zconn"}->{$cache_key} = &_new_Zconn( $server, $async );
532 return $context->{"Zconn"}->{$cache_key};
537 $context->{"Zconn"} = &_new_Zconn($server,$async);
539 Internal function. Creates a new database connection from the data given in the current context and returns it.
541 C<$server> one of the servers defined in the koha-conf.xml file
543 C<$async> whether this is a asynchronous connection
545 C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
550 my ( $server, $async ) = @_;
552 my $tried=0; # first attempt
553 my $Zconn; # connection object
557 $server //= "biblioserver";
560 $elementSetName = 'marcxml';
562 my $host = $context->{'listen'}->{$server}->{'content'};
563 my $user = $context->{"serverinfo"}->{$server}->{"user"};
564 my $password = $context->{"serverinfo"}->{$server}->{"password"};
567 my $o = ZOOM::Options->new();
568 $o->option(user => $user) if $user && $password;
569 $o->option(password => $password) if $user && $password;
570 $o->option(async => 1) if $async;
571 $o->option(cqlfile=> $context->{"server"}->{$server}->{"cql2rpn"});
572 $o->option(cclfile=> $context->{"serverinfo"}->{$server}->{"ccl2rpn"});
573 $o->option(preferredRecordSyntax => $syntax);
574 $o->option(elementSetName => $elementSetName) if $elementSetName;
575 $o->option(databaseName => $context->{"config"}->{$server}||"biblios");
577 # create a new connection object
578 $Zconn= create ZOOM::Connection($o);
581 $Zconn->connect($host, 0);
583 # check for errors and warn
584 if ($Zconn->errcode() !=0) {
585 warn "something wrong with the connection: ". $Zconn->errmsg();
592 # Internal helper function (not a method!). This creates a new
593 # database connection from the data given in the current context, and
598 Koha::Database->schema({ new => 1 })->storage->dbh;
603 $dbh = C4::Context->dbh;
605 Returns a database handle connected to the Koha database for the
606 current context. If no connection has yet been made, this method
607 creates one, and connects to the database.
609 This database handle is cached for future use: if you call
610 C<C4::Context-E<gt>dbh> twice, you will get the same handle both
611 times. If you need a second database handle, use C<&new_dbh> and
612 possibly C<&set_dbh>.
622 unless ( $params->{new} ) {
623 return Koha::Database->schema->storage->dbh;
626 return Koha::Database->schema({ new => 1 })->storage->dbh;
631 $dbh = C4::Context->new_dbh;
633 Creates a new connection to the Koha database for the current context,
634 and returns the database handle (a C<DBI::db> object).
636 The handle is not saved anywhere: this method is strictly a
637 convenience function; the point is that it knows which database to
638 connect to so that the caller doesn't have to know.
647 return &dbh({ new => 1 });
652 $my_dbh = C4::Connect->new_dbh;
653 C4::Connect->set_dbh($my_dbh);
655 C4::Connect->restore_dbh;
657 C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
658 C<&set_context> and C<&restore_context>.
660 C<&set_dbh> saves the current database handle on a stack, then sets
661 the current database handle to C<$my_dbh>.
663 C<$my_dbh> is assumed to be a good database handle.
673 # Save the current database handle on the handle stack.
674 # We assume that $new_dbh is all good: if the caller wants to
675 # screw himself by passing an invalid handle, that's fine by
677 push @{$context->{"dbh_stack"}}, $context->{"dbh"};
678 $context->{"dbh"} = $new_dbh;
683 C4::Context->restore_dbh;
685 Restores the database handle saved by an earlier call to
686 C<C4::Context-E<gt>set_dbh>.
695 if ($#{$context->{"dbh_stack"}} < 0)
698 die "DBH stack underflow";
701 # Pop the old database handle and set it.
702 $context->{"dbh"} = pop @{$context->{"dbh_stack"}};
704 # FIXME - If it is determined that restore_context should
705 # return something, then this function should, too.
710 C4::Context->userenv;
712 Retrieves a hash for user environment variables.
714 This hash shall be cached for future use: if you call
715 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
721 my $var = $context->{"activeuser"};
722 if (defined $var and defined $context->{"userenv"}->{$var}) {
723 return $context->{"userenv"}->{$var};
731 C4::Context->set_userenv($usernum, $userid, $usercnum,
732 $userfirstname, $usersurname,
733 $userbranch, $branchname, $userflags,
734 $emailaddress, $shibboleth
735 $desk_id, $desk_name,
736 $register_id, $register_name);
738 Establish a hash of user environment variables.
740 set_userenv is called in Auth.pm
748 $usernum, $userid, $usercnum, $userfirstname,
749 $usersurname, $userbranch, $branchname, $userflags,
750 $emailaddress, $shibboleth, $desk_id, $desk_name,
751 $register_id, $register_name
754 my $var=$context->{"activeuser"} || '';
756 "number" => $usernum,
758 "cardnumber" => $usercnum,
759 "firstname" => $userfirstname,
760 "surname" => $usersurname,
762 #possibly a law problem
763 "branch" => $userbranch,
764 "branchname" => $branchname,
765 "flags" => $userflags,
766 "emailaddress" => $emailaddress,
767 "shibboleth" => $shibboleth,
768 "desk_id" => $desk_id,
769 "desk_name" => $desk_name,
770 "register_id" => $register_id,
771 "register_name" => $register_name
773 $context->{userenv}->{$var} = $cell;
779 C4::Context->_new_userenv($session); # FIXME: This calling style is wrong for what looks like an _internal function
781 Builds a hash for user environment variables.
783 This hash shall be cached for future use: if you call
784 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
786 _new_userenv is called in Auth.pm
793 shift; # Useless except it compensates for bad calling style
795 $context->{"activeuser"}=$sessionID;
798 =head2 _unset_userenv
800 C4::Context->_unset_userenv;
802 Destroys the hash for activeuser user environment variables.
811 undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
817 C4::Context->get_versions
819 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'.
825 # A little example sub to show more debugging info for CGI::Carp
828 $versions{kohaVersion} = Koha::version();
829 $versions{kohaDbVersion} = C4::Context->preference('version');
830 $versions{osVersion} = join(" ", POSIX::uname());
831 $versions{perlVersion} = $];
833 no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
834 $versions{mysqlVersion} = `mysql -V`;
835 $versions{apacheVersion} = (`apache2ctl -v`)[0];
836 $versions{apacheVersion} = `httpd -v` unless $versions{apacheVersion} ;
837 $versions{apacheVersion} = `httpd2 -v` unless $versions{apacheVersion} ;
838 $versions{apacheVersion} = `apache2 -v` unless $versions{apacheVersion} ;
839 $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless $versions{apacheVersion} ;
846 my $C4::Context->timzone
848 Returns a timezone code for the instance of Koha
855 my $timezone = C4::Context->config('timezone') || $ENV{TZ} || 'local';
856 if ( !DateTime::TimeZone->is_valid_name( $timezone ) ) {
857 warn "Invalid timezone in koha-conf.xml ($timezone)";
868 Returns a DateTime::TimeZone object for the system timezone
874 if (!defined $context->{tz}) {
875 my $timezone = $self->timezone;
876 $context->{tz} = DateTime::TimeZone->new(name => $timezone);
878 return $context->{tz};
882 =head2 IsSuperLibrarian
884 C4::Context->IsSuperLibrarian();
888 sub IsSuperLibrarian {
889 my $userenv = C4::Context->userenv;
891 unless ( $userenv and exists $userenv->{flags} ) {
892 # If we reach this without a user environment,
893 # assume that we're running from a command-line script,
894 # and act as a superlibrarian.
895 carp("C4::Context->userenv not defined!");
899 return ($userenv->{flags}//0) % 2;
904 Sets the current interface for later retrieval in any Perl module
906 C4::Context->interface('opac');
907 C4::Context->interface('intranet');
908 my $interface = C4::Context->interface;
913 my ($class, $interface) = @_;
915 if (defined $interface) {
916 $interface = lc $interface;
917 if ( $interface eq 'api'
918 || $interface eq 'opac'
919 || $interface eq 'intranet'
920 || $interface eq 'sip'
921 || $interface eq 'cron'
922 || $interface eq 'commandline' )
924 $context->{interface} = $interface;
926 warn "invalid interface : '$interface'";
930 return $context->{interface} // 'opac';
933 # always returns a string for OK comparison via "eq" or "ne"
935 C4::Context->userenv or return '';
936 return C4::Context->userenv->{branch} || '';
939 =head2 only_my_library
941 my $test = C4::Context->only_my_library;
943 Returns true if you enabled IndependentBranches and the current user
944 does not have superlibrarian permissions.
948 sub only_my_library {
950 C4::Context->preference('IndependentBranches')
951 && C4::Context->userenv
952 && !C4::Context->IsSuperLibrarian()
953 && C4::Context->userenv->{branch};
956 =head3 temporary_directory
958 Returns root directory for temporary storage
962 sub temporary_directory {
964 return C4::Context->config('tmp_path') || File::Spec->tmpdir;
967 =head3 set_remote_address
969 set_remote_address should be called at the beginning of every script
970 that is *not* running under plack in order to the REMOTE_ADDR environment
971 variable to be set correctly.
975 sub set_remote_address {
976 if ( C4::Context->config('koha_trusted_proxies') ) {
978 my $header = CGI->http('HTTP_X_FORWARDED_FOR');
981 require Koha::Middleware::RealIP;
982 $ENV{REMOTE_ADDR} = Koha::Middleware::RealIP::get_real_ip( $ENV{REMOTE_ADDR}, $header );
989 https_enabled should be called when checking if a HTTPS connection
992 Note that this depends on a HTTPS environmental variable being defined
993 by the web server. This function may not return the expected result,
994 if your web server or reverse proxies are not setting the correct
995 X-Forwarded-Proto headers and HTTPS environmental variable.
997 Note too that the HTTPS value can vary from web server to web server.
998 We are relying on the convention of the value being "on" or "ON" here.
1003 my $https_enabled = 0;
1004 my $env_https = $ENV{HTTPS};
1006 if ($env_https =~ /^ON$/i){
1010 return $https_enabled;
1015 =head3 needs_install
1017 if ( $context->needs_install ) { ... }
1019 This method returns a boolean representing the install status of the Koha instance.
1025 return ($self->preference('Version')) ? 0 : 1;
1034 Specifies the configuration file to read.
1038 Andrew Arensburger <arensb at ooblick dot com>
1040 Joshua Ferraro <jmf at liblime dot com>