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;
47 use Koha::Config::SysPref;
48 use Koha::Config::SysPrefs;
54 C4::Context - Maintain and manipulate the context of a Koha script
60 use C4::Context("/path/to/koha-conf.xml");
62 $config_value = C4::Context->config("config_variable");
64 $koha_preference = C4::Context->preference("preference");
66 $db_handle = C4::Context->dbh;
68 $Zconn = C4::Context->Zconn;
72 When a Koha script runs, it makes use of a certain number of things:
73 configuration settings in F</etc/koha/koha-conf.xml>, a connection to the Koha
74 databases, and so forth. These things make up the I<context> in which
77 This module takes care of setting up the context for a script:
78 figuring out which configuration file to load, and loading it, opening
79 a connection to the right database, and so forth.
81 Most scripts will only use one context. They can simply have
87 Other scripts may need to use several contexts. For instance, if a
88 library has two databases, one for a certain collection, and the other
89 for everything else, it might be necessary for a script to use two
90 different contexts to search both databases. Such scripts should use
91 the C<&set_context> and C<&restore_context> functions, below.
93 By default, C4::Context reads the configuration from
94 F</etc/koha/koha-conf.xml>. This may be overridden by setting the C<$KOHA_CONF>
95 environment variable to the pathname of a configuration file to use.
102 # In addition to what is said in the POD above, a Context object is a
103 # reference-to-hash with the following fields:
106 # A reference-to-hash whose keys and values are the
107 # configuration variables and values specified in the config
108 # file (/etc/koha/koha-conf.xml).
110 # A handle to the appropriate database for this context.
112 # Used by &set_dbh and &restore_dbh to hold other database
113 # handles for this context.
115 # A connection object for the Zebra server
117 $context = undef; # Initially, no context is set
118 @context_stack = (); # Initially, no saved contexts
122 my $dbd_driver_name = C4::Context::db_schema2dbi($scheme);
124 This routines translates a database type to part of the name
125 of the appropriate DBD driver to use when establishing a new
126 database connection. It recognizes 'mysql' and 'Pg'; if any
127 other scheme is supplied it defaults to 'mysql'.
132 my $scheme = shift // '';
133 return $scheme eq 'Pg' ? $scheme : 'mysql';
137 # Create the default context ($C4::Context::Context)
138 # the first time the module is called
139 # (a config file can be optionaly passed)
141 # default context already exists?
145 my ($pkg,$config_file) = @_ ;
146 my $new_ctx = __PACKAGE__->new($config_file);
147 return unless $new_ctx;
149 # if successfully loaded, use it by default
150 $new_ctx->set_context;
156 $context = C4::Context->new;
157 $context = C4::Context->new("/path/to/koha-conf.xml");
159 Allocates a new context. Initializes the context from the specified
160 file, which defaults to either the file given by the C<$KOHA_CONF>
161 environment variable, or F</etc/koha/koha-conf.xml>.
163 It saves the koha-conf.xml values in the declared memcached server(s)
164 if currently available and uses those values until them expire and
167 C<&new> does not set this context as the new default context; for
168 that, use C<&set_context>.
174 # 2004-08-10 A. Tarallo: Added check if the conf file is not empty
177 my $conf_fname = shift; # Config file to load
179 # check that the specified config file exists and is not empty
180 undef $conf_fname unless
181 (defined $conf_fname && -s $conf_fname);
182 # Figure out a good config file to load if none was specified.
183 unless ( defined $conf_fname ) {
184 $conf_fname = Koha::Config->guess_koha_conf;
185 unless ( $conf_fname ) {
186 warn "unable to locate Koha configuration file koha-conf.xml";
191 my $self = Koha::Config->read_from_file($conf_fname);
192 unless ( exists $self->{config} or defined $self->{config} ) {
193 warn "The config file ($conf_fname) has not been parsed correctly";
197 $self->{"Zconn"} = undef; # Zebra Connections
198 $self->{"userenv"} = undef; # User env
199 $self->{"activeuser"} = undef; # current active user
200 $self->{"shelves"} = undef;
201 $self->{tz} = undef; # local timezone object
204 $self->{db_driver} = db_scheme2dbi($self->config('db_scheme')); # cache database driver
210 $context = new C4::Context;
211 $context->set_context();
213 set_context C4::Context $context;
216 restore_context C4::Context;
218 In some cases, it might be necessary for a script to use multiple
219 contexts. C<&set_context> saves the current context on a stack, then
220 sets the context to C<$context>, which will be used in future
221 operations. To restore the previous context, use C<&restore_context>.
229 my $new_context; # The context to set
231 # Figure out whether this is a class or instance method call.
233 # We're going to make the assumption that control got here
234 # through valid means, i.e., that the caller used an instance
235 # or class method call, and that control got here through the
236 # usual inheritance mechanisms. The caller can, of course,
237 # break this assumption by playing silly buggers, but that's
238 # harder to do than doing it properly, and harder to check
240 if (ref($self) eq "")
242 # Class method. The new context is the next argument.
243 $new_context = shift;
245 # Instance method. The new context is $self.
246 $new_context = $self;
249 # Save the old context, if any, on the stack
250 push @context_stack, $context if defined($context);
252 # Set the new context
253 $context = $new_context;
256 =head2 restore_context
260 Restores the context set by C<&set_context>.
269 if ($#context_stack < 0)
272 die "Context stack underflow";
275 # Pop the old context and set it.
276 $context = pop @context_stack;
278 # FIXME - Should this return something, like maybe the context
279 # that was current when this was called?
284 $value = C4::Context->config("config_variable");
286 $value = C4::Context->config_variable;
288 Returns the value of a variable specified in the configuration file
289 from which the current context was created.
291 The second form is more compact, but of course may conflict with
292 method names. If there is a configuration variable called "new", then
293 C<C4::Config-E<gt>new> will not return it.
300 return unless defined $context and defined $context->{$term};
301 # Presumably $self->{$term} might be
302 # undefined if the config file given to &new
303 # didn't exist, and the caller didn't bother
304 # to check the return value.
306 # Return the value of the requested config variable
307 return $context->{$term}->{$var};
311 return _common_config($_[1],'config');
314 return _common_config($_[1],'server');
319 $sys_preference = C4::Context->preference('some_variable');
321 Looks up the value of the given system preference in the
322 systempreferences table of the Koha database, and returns it. If the
323 variable is not set or does not exist, undef is returned.
325 In case of an error, this may return 0.
327 Note: It is impossible to tell the difference between system
328 preferences which do not exist, and those whose values are set to NULL
333 my $use_syspref_cache = 1;
336 my $var = shift; # The system preference to return
338 return Encode::decode_utf8($ENV{"OVERRIDE_SYSPREF_$var"})
339 if defined $ENV{"OVERRIDE_SYSPREF_$var"};
343 if ($use_syspref_cache) {
344 my $syspref_cache = Koha::Caches->get_instance('syspref');
345 my $cached_var = $syspref_cache->get_from_cache("syspref_$var");
346 return $cached_var if defined $cached_var;
350 eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) };
351 my $value = $syspref ? $syspref->value() : undef;
353 if ( $use_syspref_cache ) {
354 my $syspref_cache = Koha::Caches->get_instance('syspref');
355 $syspref_cache->set_in_cache("syspref_$var", $value);
360 =head2 yaml_preference
362 Retrieves the required system preference value, and converts it
363 from YAML into a Perl data structure. It throws an exception if
364 the value cannot be properly decoded as YAML.
368 sub yaml_preference {
369 my ( $self, $preference ) = @_;
371 my $yaml = eval { YAML::XS::Load( Encode::encode_utf8( $self->preference( $preference ) ) ); };
373 warn "Unable to parse $preference syspref : $@";
380 =head2 enable_syspref_cache
382 C4::Context->enable_syspref_cache();
384 Enable the in-memory syspref cache used by C4::Context. This is the
389 sub enable_syspref_cache {
391 $use_syspref_cache = 1;
392 # We need to clear the cache to have it up-to-date
393 $self->clear_syspref_cache();
396 =head2 disable_syspref_cache
398 C4::Context->disable_syspref_cache();
400 Disable the in-memory syspref cache used by C4::Context. This should be
401 used with Plack and other persistent environments.
405 sub disable_syspref_cache {
407 $use_syspref_cache = 0;
408 $self->clear_syspref_cache();
411 =head2 clear_syspref_cache
413 C4::Context->clear_syspref_cache();
415 cleans the internal cache of sysprefs. Please call this method if
416 you update the systempreferences table. Otherwise, your new changes
417 will not be seen by this process.
421 sub clear_syspref_cache {
422 return unless $use_syspref_cache;
423 my $syspref_cache = Koha::Caches->get_instance('syspref');
424 $syspref_cache->flush_all;
427 =head2 set_preference
429 C4::Context->set_preference( $variable, $value, [ $explanation, $type, $options ] );
431 This updates a preference's value both in the systempreferences table and in
432 the sysprefs cache. If the optional parameters are provided, then the query
433 becomes a create. It won't update the parameters (except value) for an existing
439 my ( $self, $variable, $value, $explanation, $type, $options ) = @_;
441 my $variable_case = $variable;
442 $variable = lc $variable;
444 my $syspref = Koha::Config::SysPrefs->find($variable);
447 : $syspref ? $syspref->type
450 $value = 0 if ( $type && $type eq 'YesNo' && $value eq '' );
452 # force explicit protocol on OPACBaseURL
453 if ( $variable eq 'opacbaseurl' && $value && substr( $value, 0, 4 ) !~ /http/ ) {
454 $value = 'http://' . $value;
459 { ( defined $value ? ( value => $value ) : () ),
460 ( $explanation ? ( explanation => $explanation ) : () ),
461 ( $type ? ( type => $type ) : () ),
462 ( $options ? ( options => $options ) : () ),
466 $syspref = Koha::Config::SysPref->new(
467 { variable => $variable_case,
469 explanation => $explanation || undef,
471 options => $options || undef,
476 if ( $use_syspref_cache ) {
477 my $syspref_cache = Koha::Caches->get_instance('syspref');
478 $syspref_cache->set_in_cache( "syspref_$variable", $value );
484 =head2 delete_preference
486 C4::Context->delete_preference( $variable );
488 This deletes a system preference from the database. Returns a true value on
489 success. Failure means there was an issue with the database, not that there
490 was no syspref of the name.
494 sub delete_preference {
495 my ( $self, $var ) = @_;
497 if ( Koha::Config::SysPrefs->find( $var )->delete ) {
498 if ( $use_syspref_cache ) {
499 my $syspref_cache = Koha::Caches->get_instance('syspref');
500 $syspref_cache->clear_from_cache("syspref_$var");
510 $Zconn = C4::Context->Zconn
512 Returns a connection to the Zebra database
516 C<$server> one of the servers defined in the koha-conf.xml file
518 C<$async> whether this is a asynchronous connection
523 my ($self, $server, $async ) = @_;
524 my $cache_key = join ('::', (map { $_ // '' } ($server, $async )));
525 if ( (!defined($ENV{GATEWAY_INTERFACE})) && defined($context->{"Zconn"}->{$cache_key}) && (0 == $context->{"Zconn"}->{$cache_key}->errcode()) ) {
526 # if we are running the script from the commandline, lets try to use the caching
527 return $context->{"Zconn"}->{$cache_key};
529 $context->{"Zconn"}->{$cache_key}->destroy() if defined($context->{"Zconn"}->{$cache_key}); #destroy old connection before making a new one
530 $context->{"Zconn"}->{$cache_key} = &_new_Zconn( $server, $async );
531 return $context->{"Zconn"}->{$cache_key};
536 $context->{"Zconn"} = &_new_Zconn($server,$async);
538 Internal function. Creates a new database connection from the data given in the current context and returns it.
540 C<$server> one of the servers defined in the koha-conf.xml file
542 C<$async> whether this is a asynchronous connection
544 C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
549 my ( $server, $async ) = @_;
551 my $tried=0; # first attempt
552 my $Zconn; # connection object
556 $server //= "biblioserver";
559 $elementSetName = 'marcxml';
561 my $host = $context->{'listen'}->{$server}->{'content'};
562 my $user = $context->{"serverinfo"}->{$server}->{"user"};
563 my $password = $context->{"serverinfo"}->{$server}->{"password"};
566 my $o = ZOOM::Options->new();
567 $o->option(user => $user) if $user && $password;
568 $o->option(password => $password) if $user && $password;
569 $o->option(async => 1) if $async;
570 $o->option(cqlfile=> $context->{"server"}->{$server}->{"cql2rpn"});
571 $o->option(cclfile=> $context->{"serverinfo"}->{$server}->{"ccl2rpn"});
572 $o->option(preferredRecordSyntax => $syntax);
573 $o->option(elementSetName => $elementSetName) if $elementSetName;
574 $o->option(databaseName => $context->{"config"}->{$server}||"biblios");
576 # create a new connection object
577 $Zconn= create ZOOM::Connection($o);
580 $Zconn->connect($host, 0);
582 # check for errors and warn
583 if ($Zconn->errcode() !=0) {
584 warn "something wrong with the connection: ". $Zconn->errmsg();
591 # Internal helper function (not a method!). This creates a new
592 # database connection from the data given in the current context, and
597 Koha::Database->schema({ new => 1 })->storage->dbh;
602 $dbh = C4::Context->dbh;
604 Returns a database handle connected to the Koha database for the
605 current context. If no connection has yet been made, this method
606 creates one, and connects to the database.
608 This database handle is cached for future use: if you call
609 C<C4::Context-E<gt>dbh> twice, you will get the same handle both
610 times. If you need a second database handle, use C<&new_dbh> and
611 possibly C<&set_dbh>.
621 unless ( $params->{new} ) {
622 return Koha::Database->schema->storage->dbh;
625 return Koha::Database->schema({ new => 1 })->storage->dbh;
630 $dbh = C4::Context->new_dbh;
632 Creates a new connection to the Koha database for the current context,
633 and returns the database handle (a C<DBI::db> object).
635 The handle is not saved anywhere: this method is strictly a
636 convenience function; the point is that it knows which database to
637 connect to so that the caller doesn't have to know.
646 return &dbh({ new => 1 });
651 $my_dbh = C4::Connect->new_dbh;
652 C4::Connect->set_dbh($my_dbh);
654 C4::Connect->restore_dbh;
656 C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
657 C<&set_context> and C<&restore_context>.
659 C<&set_dbh> saves the current database handle on a stack, then sets
660 the current database handle to C<$my_dbh>.
662 C<$my_dbh> is assumed to be a good database handle.
672 # Save the current database handle on the handle stack.
673 # We assume that $new_dbh is all good: if the caller wants to
674 # screw himself by passing an invalid handle, that's fine by
676 push @{$context->{"dbh_stack"}}, $context->{"dbh"};
677 $context->{"dbh"} = $new_dbh;
682 C4::Context->restore_dbh;
684 Restores the database handle saved by an earlier call to
685 C<C4::Context-E<gt>set_dbh>.
694 if ($#{$context->{"dbh_stack"}} < 0)
697 die "DBH stack underflow";
700 # Pop the old database handle and set it.
701 $context->{"dbh"} = pop @{$context->{"dbh_stack"}};
703 # FIXME - If it is determined that restore_context should
704 # return something, then this function should, too.
709 C4::Context->userenv;
711 Retrieves a hash for user environment variables.
713 This hash shall be cached for future use: if you call
714 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
720 my $var = $context->{"activeuser"};
721 if (defined $var and defined $context->{"userenv"}->{$var}) {
722 return $context->{"userenv"}->{$var};
730 C4::Context->set_userenv($usernum, $userid, $usercnum,
731 $userfirstname, $usersurname,
732 $userbranch, $branchname, $userflags,
733 $emailaddress, $shibboleth
734 $desk_id, $desk_name,
735 $register_id, $register_name);
737 Establish a hash of user environment variables.
739 set_userenv is called in Auth.pm
747 $usernum, $userid, $usercnum, $userfirstname,
748 $usersurname, $userbranch, $branchname, $userflags,
749 $emailaddress, $shibboleth, $desk_id, $desk_name,
750 $register_id, $register_name
753 my $var=$context->{"activeuser"} || '';
755 "number" => $usernum,
757 "cardnumber" => $usercnum,
758 "firstname" => $userfirstname,
759 "surname" => $usersurname,
761 #possibly a law problem
762 "branch" => $userbranch,
763 "branchname" => $branchname,
764 "flags" => $userflags,
765 "emailaddress" => $emailaddress,
766 "shibboleth" => $shibboleth,
767 "desk_id" => $desk_id,
768 "desk_name" => $desk_name,
769 "register_id" => $register_id,
770 "register_name" => $register_name
772 $context->{userenv}->{$var} = $cell;
778 C4::Context->_new_userenv($session); # FIXME: This calling style is wrong for what looks like an _internal function
780 Builds a hash for user environment variables.
782 This hash shall be cached for future use: if you call
783 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
785 _new_userenv is called in Auth.pm
792 shift; # Useless except it compensates for bad calling style
794 $context->{"activeuser"}=$sessionID;
797 =head2 _unset_userenv
799 C4::Context->_unset_userenv;
801 Destroys the hash for activeuser user environment variables.
810 undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
816 C4::Context->get_versions
818 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'.
824 # A little example sub to show more debugging info for CGI::Carp
827 $versions{kohaVersion} = Koha::version();
828 $versions{kohaDbVersion} = C4::Context->preference('version');
829 $versions{osVersion} = join(" ", POSIX::uname());
830 $versions{perlVersion} = $];
832 no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
833 $versions{mysqlVersion} = `mysql -V`;
834 $versions{apacheVersion} = (`apache2ctl -v`)[0];
835 $versions{apacheVersion} = `httpd -v` unless $versions{apacheVersion} ;
836 $versions{apacheVersion} = `httpd2 -v` unless $versions{apacheVersion} ;
837 $versions{apacheVersion} = `apache2 -v` unless $versions{apacheVersion} ;
838 $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless $versions{apacheVersion} ;
845 my $C4::Context->timzone
847 Returns a timezone code for the instance of Koha
854 my $timezone = C4::Context->config('timezone') || $ENV{TZ} || 'local';
855 if ( !DateTime::TimeZone->is_valid_name( $timezone ) ) {
856 warn "Invalid timezone in koha-conf.xml ($timezone)";
867 Returns a DateTime::TimeZone object for the system timezone
873 if (!defined $context->{tz}) {
874 my $timezone = $self->timezone;
875 $context->{tz} = DateTime::TimeZone->new(name => $timezone);
877 return $context->{tz};
881 =head2 IsSuperLibrarian
883 C4::Context->IsSuperLibrarian();
887 sub IsSuperLibrarian {
888 my $userenv = C4::Context->userenv;
890 unless ( $userenv and exists $userenv->{flags} ) {
891 # If we reach this without a user environment,
892 # assume that we're running from a command-line script,
893 # and act as a superlibrarian.
894 carp("C4::Context->userenv not defined!");
898 return ($userenv->{flags}//0) % 2;
903 Sets the current interface for later retrieval in any Perl module
905 C4::Context->interface('opac');
906 C4::Context->interface('intranet');
907 my $interface = C4::Context->interface;
912 my ($class, $interface) = @_;
914 if (defined $interface) {
915 $interface = lc $interface;
916 if ( $interface eq 'api'
917 || $interface eq 'opac'
918 || $interface eq 'intranet'
919 || $interface eq 'sip'
920 || $interface eq 'cron'
921 || $interface eq 'commandline' )
923 $context->{interface} = $interface;
925 warn "invalid interface : '$interface'";
929 return $context->{interface} // 'opac';
932 # always returns a string for OK comparison via "eq" or "ne"
934 C4::Context->userenv or return '';
935 return C4::Context->userenv->{branch} || '';
938 =head2 only_my_library
940 my $test = C4::Context->only_my_library;
942 Returns true if you enabled IndependentBranches and the current user
943 does not have superlibrarian permissions.
947 sub only_my_library {
949 C4::Context->preference('IndependentBranches')
950 && C4::Context->userenv
951 && !C4::Context->IsSuperLibrarian()
952 && C4::Context->userenv->{branch};
955 =head3 temporary_directory
957 Returns root directory for temporary storage
961 sub temporary_directory {
963 return C4::Context->config('tmp_path') || File::Spec->tmpdir;
966 =head3 set_remote_address
968 set_remote_address should be called at the beginning of every script
969 that is *not* running under plack in order to the REMOTE_ADDR environment
970 variable to be set correctly.
974 sub set_remote_address {
975 if ( C4::Context->config('koha_trusted_proxies') ) {
977 my $header = CGI->http('HTTP_X_FORWARDED_FOR');
980 require Koha::Middleware::RealIP;
981 $ENV{REMOTE_ADDR} = Koha::Middleware::RealIP::get_real_ip( $ENV{REMOTE_ADDR}, $header );
988 https_enabled should be called when checking if a HTTPS connection
991 Note that this depends on a HTTPS environmental variable being defined
992 by the web server. This function may not return the expected result,
993 if your web server or reverse proxies are not setting the correct
994 X-Forwarded-Proto headers and HTTPS environmental variable.
996 Note too that the HTTPS value can vary from web server to web server.
997 We are relying on the convention of the value being "on" or "ON" here.
1002 my $https_enabled = 0;
1003 my $env_https = $ENV{HTTPS};
1005 if ($env_https =~ /^ON$/i){
1009 return $https_enabled;
1014 =head3 needs_install
1016 if ( $context->needs_install ) { ... }
1018 This method returns a boolean representing the install status of the Koha instance.
1024 return ($self->preference('Version')) ? 0 : 1;
1033 Specifies the configuration file to read.
1037 Andrew Arensburger <arensb at ooblick dot com>
1039 Joshua Ferraro <jmf at liblime dot com>