X-Git-Url: http://koha-dev.rot13.org:8081/gitweb/?a=blobdiff_plain;f=C4%2FContext.pm;h=63187bf4b7063d34e224725163920188fa9f021a;hb=9d6d641d1f8b77271800f43bc027b651f9aea52b;hp=e314f5a01ba8554c783fa1ea3c3284bba7729170;hpb=389ef2c6c79ce29d8834cea0fd62c93070f4a6dc;p=srvgit diff --git a/C4/Context.pm b/C4/Context.pm index e314f5a01b..63187bf4b7 100644 --- a/C4/Context.pm +++ b/C4/Context.pm @@ -1,4 +1,5 @@ package C4::Context; + # Copyright 2002 Katipo Communications # # This file is part of Koha. @@ -16,99 +17,37 @@ package C4::Context; # You should have received a copy of the GNU General Public License # along with Koha; if not, see . -use strict; -use warnings; -use vars qw($VERSION $AUTOLOAD $context @context_stack $servers $memcached $ismemcached); +use Modern::Perl; + +use vars qw($AUTOLOAD $context @context_stack); BEGIN { - if ($ENV{'HTTP_USER_AGENT'}) { - require CGI::Carp; - # FIXME for future reference, CGI::Carp doc says - # "Note that fatalsToBrowser does not work with mod_perl version 2.0 and higher." - import CGI::Carp qw(fatalsToBrowser); - sub handle_errors { - my $msg = shift; - my $debug_level; - eval {C4::Context->dbh();}; - if ($@){ - $debug_level = 1; - } - else { - $debug_level = C4::Context->preference("DebugLevel"); - } - - print q( - - Koha Error - - ); - if ($debug_level eq "2"){ - # debug 2 , print extra info too. - my %versions = get_versions(); - - # a little example table with various version info"; - print " -

Koha error

The following fatal error has occurred:

$msg

- - - - - - - -

Apache	$versions{apacheVersion}
Koha	$versions{kohaVersion}
Koha DB	$versions{kohaDbVersion}
MySQL	$versions{mysqlVersion}
OS	$versions{osVersion}
Perl	$versions{perlVersion}

"; - - } elsif ($debug_level eq "1"){ - print " -

Koha error

The following fatal error has occurred:

$msg

"; - } else { - print "

production mode - trapped fatal error

"; - } - print ""; - } - #CGI::Carp::set_message(\&handle_errors); - ## give a stack backtrace if KOHA_BACKTRACES is set - ## can't rely on DebugLevel for this, as we're not yet connected - if ($ENV{KOHA_BACKTRACES}) { - $main::SIG{__DIE__} = \&CGI::Carp::confess; - } - } # else there is no browser to send fatals to! - - # Check if there are memcached servers set - $servers = $ENV{'MEMCACHED_SERVERS'}; - if ($servers) { - # Load required libraries and create the memcached object - require Cache::Memcached; - $memcached = Cache::Memcached->new({ - servers => [ $servers ], - debug => 0, - compress_threshold => 10_000, - expire_time => 600, - namespace => $ENV{'MEMCACHED_NAMESPACE'} || 'koha' - }); - # Verify memcached available (set a variable and test the output) - $ismemcached = $memcached->set('ismemcached','1'); + if ( $ENV{'HTTP_USER_AGENT'} ) { # Only hit when plack is not enabled + + # Redefine multi_param if cgi version is < 4.08 + # Remove the "CGI::param called in list context" warning in this case + require CGI; # Can't check version without the require. + if ( !defined($CGI::VERSION) || $CGI::VERSION < 4.08 ) { + no warnings 'redefine'; + *CGI::multi_param = \&CGI::param; + use warnings 'redefine'; + $CGI::LIST_CONTEXT_WARN = 0; + } } +}; - $VERSION = '3.07.00.049'; -} - +use Carp qw( carp ); +use DateTime::TimeZone; use Encode; +use File::Spec; +use POSIX; +use YAML::XS; use ZOOM; -use XML::Simple; -use POSIX (); -use DateTime::TimeZone; -use Module::Load::Conditional qw(can_load); -use Carp; -use C4::Boolean; -use C4::Debug; -use Koha; +use Koha::Caches; +use Koha::Config::SysPref; use Koha::Config::SysPrefs; +use Koha::Config; +use Koha; =head1 NAME @@ -128,8 +67,6 @@ C4::Context - Maintain and manipulate the context of a Koha script $Zconn = C4::Context->Zconn; - $stopwordhash = C4::Context->stopwords; - =head1 DESCRIPTION When a Koha script runs, it makes use of a certain number of things: @@ -177,95 +114,9 @@ environment variable to the pathname of a configuration file to use. # Zconn # A connection object for the Zebra server -# Koha's main configuration file koha-conf.xml -# is searched for according to this priority list: -# -# 1. Path supplied via use C4::Context '/path/to/koha-conf.xml' -# 2. Path supplied in KOHA_CONF environment variable. -# 3. Path supplied in INSTALLED_CONFIG_FNAME, as long -# as value has changed from its default of -# '__KOHA_CONF_DIR__/koha-conf.xml', as happens -# when Koha is installed in 'standard' or 'single' -# mode. -# 4. Path supplied in CONFIG_FNAME. -# -# The first entry that refers to a readable file is used. - -use constant CONFIG_FNAME => "/etc/koha/koha-conf.xml"; - # Default config file, if none is specified - -my $INSTALLED_CONFIG_FNAME = '__KOHA_CONF_DIR__/koha-conf.xml'; - # path to config file set by installer - # __KOHA_CONF_DIR__ is set by rewrite-confg.PL - # when Koha is installed in 'standard' or 'single' - # mode. If Koha was installed in 'dev' mode, - # __KOHA_CONF_DIR__ is *not* rewritten; instead - # developers should set the KOHA_CONF environment variable - $context = undef; # Initially, no context is set @context_stack = (); # Initially, no saved contexts - -=head2 read_config_file - -Reads the specified Koha config file. - -Returns an object containing the configuration variables. The object's -structure is a bit complex to the uninitiated ... take a look at the -koha-conf.xml file as well as the XML::Simple documentation for details. Or, -here are a few examples that may give you what you need: - -The simple elements nested within the element: - - my $pass = $koha->{'config'}->{'pass'}; - -The elements: - - my $listen = $koha->{'listen'}->{'biblioserver'}->{'content'}; - -The elements nested within the element: - - my $ccl2rpn = $koha->{'server'}->{'biblioserver'}->{'cql2rpn'}; - -Returns undef in case of error. - -=cut - -sub read_config_file { # Pass argument naming config file to read - my $koha = XMLin(shift, keyattr => ['id'], forcearray => ['listen', 'server', 'serverinfo'], suppressempty => ''); - - if ($ismemcached) { - $memcached->set('kohaconf',$koha); - } - - return $koha; # Return value: ref-to-hash holding the configuration -} - -=head2 ismemcached - -Returns the value of the $ismemcached variable (0/1) - -=cut - -sub ismemcached { - return $ismemcached; -} - -=head2 memcached - -If $ismemcached is true, returns the $memcache variable. -Returns undef otherwise - -=cut - -sub memcached { - if ($ismemcached) { - return $memcached; - } else { - return; - } -} - =head2 db_scheme2dbi my $dbd_driver_name = C4::Context::db_schema2dbi($scheme); @@ -302,8 +153,8 @@ sub import { =head2 new - $context = new C4::Context; - $context = new C4::Context("/path/to/koha-conf.xml"); + $context = C4::Context->new; + $context = C4::Context->new("/path/to/koha-conf.xml"); Allocates a new context. Initializes the context from the specified file, which defaults to either the file given by the C<$KOHA_CONF> @@ -324,49 +175,26 @@ that, use C<&set_context>. sub new { my $class = shift; my $conf_fname = shift; # Config file to load - my $self = {}; # check that the specified config file exists and is not empty undef $conf_fname unless (defined $conf_fname && -s $conf_fname); # Figure out a good config file to load if none was specified. - if (!defined($conf_fname)) - { - # If the $KOHA_CONF environment variable is set, use - # that. Otherwise, use the built-in default. - if (exists $ENV{"KOHA_CONF"} and $ENV{'KOHA_CONF'} and -s $ENV{"KOHA_CONF"}) { - $conf_fname = $ENV{"KOHA_CONF"}; - } elsif ($INSTALLED_CONFIG_FNAME !~ /__KOHA_CONF_DIR/ and -s $INSTALLED_CONFIG_FNAME) { - # NOTE: be careful -- don't change __KOHA_CONF_DIR in the above - # regex to anything else -- don't want installer to rewrite it - $conf_fname = $INSTALLED_CONFIG_FNAME; - } elsif (-s CONFIG_FNAME) { - $conf_fname = CONFIG_FNAME; - } else { + unless ( defined $conf_fname ) { + $conf_fname = Koha::Config->guess_koha_conf; + unless ( $conf_fname ) { warn "unable to locate Koha configuration file koha-conf.xml"; return; } } - - if ($ismemcached) { - # retrieve from memcached - $self = $memcached->get('kohaconf'); - if (not defined $self) { - # not in memcached yet - $self = read_config_file($conf_fname); - } - } else { - # non-memcached env, read from file - $self = read_config_file($conf_fname); - } - $self->{"config_file"} = $conf_fname; - warn "read_config_file($conf_fname) returned undef" if !defined($self->{"config"}); - return if !defined($self->{"config"}); + my $self = Koha::Config->read_from_file($conf_fname); + unless ( exists $self->{config} or defined $self->{config} ) { + warn "The config file ($conf_fname) has not been parsed correctly"; + return; + } $self->{"Zconn"} = undef; # Zebra Connections - $self->{"stopwords"} = undef; # stopwords list - $self->{"marcfromkohafield"} = undef; # the hash with relations between koha table fields and MARC field/subfield $self->{"userenv"} = undef; # User env $self->{"activeuser"} = undef; # current active user $self->{"shelves"} = undef; @@ -469,7 +297,7 @@ Cnew> will not return it. sub _common_config { my $var = shift; my $term = shift; - return if !defined($context->{$term}); + return unless defined $context and defined $context->{$term}; # Presumably $self->{$term} might be # undefined if the config file given to &new # didn't exist, and the caller didn't bother @@ -485,9 +313,6 @@ sub config { sub zebraconfig { return _common_config($_[1],'server'); } -sub ModZebrations { - return _common_config($_[1],'serverinfo'); -} =head2 preference @@ -505,40 +330,51 @@ with this method. =cut -# FIXME: running this under mod_perl will require a means of -# flushing the caching mechanism. - -my %sysprefs; my $use_syspref_cache = 1; - sub preference { my $self = shift; my $var = shift; # The system preference to return - if ($use_syspref_cache && exists $sysprefs{lc $var}) { - return $sysprefs{lc $var}; - } + return Encode::decode_utf8($ENV{"OVERRIDE_SYSPREF_$var"}) + if defined $ENV{"OVERRIDE_SYSPREF_$var"}; - my $dbh = C4::Context->dbh or return 0; + $var = lc $var; - my $value; - if ( defined $ENV{"OVERRIDE_SYSPREF_$var"} ) { - $value = $ENV{"OVERRIDE_SYSPREF_$var"}; - } else { - my $syspref; - eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) }; - $value = $syspref ? $syspref->value() : undef; + if ($use_syspref_cache) { + my $syspref_cache = Koha::Caches->get_instance('syspref'); + my $cached_var = $syspref_cache->get_from_cache("syspref_$var"); + return $cached_var if defined $cached_var; } - $sysprefs{lc $var} = $value; + my $syspref; + eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) }; + my $value = $syspref ? $syspref->value() : undef; + + if ( $use_syspref_cache ) { + my $syspref_cache = Koha::Caches->get_instance('syspref'); + $syspref_cache->set_in_cache("syspref_$var", $value); + } return $value; } -sub boolean_preference { - my $self = shift; - my $var = shift; # The system preference to return - my $it = preference($self, $var); - return defined($it)? C4::Boolean::true_p($it): undef; +=head2 yaml_preference + +Retrieves the required system preference value, and converts it +from YAML into a Perl data structure. It throws an exception if +the value cannot be properly decoded as YAML. + +=cut + +sub yaml_preference { + my ( $self, $preference ) = @_; + + my $yaml = eval { YAML::XS::Load( Encode::encode_utf8( $self->preference( $preference ) ) ); }; + if ($@) { + warn "Unable to parse $preference syspref : $@"; + return; + } + + return $yaml; } =head2 enable_syspref_cache @@ -553,6 +389,8 @@ default behavior. sub enable_syspref_cache { my ($self) = @_; $use_syspref_cache = 1; + # We need to clear the cache to have it up-to-date + $self->clear_syspref_cache(); } =head2 disable_syspref_cache @@ -581,43 +419,90 @@ will not be seen by this process. =cut sub clear_syspref_cache { - %sysprefs = (); + return unless $use_syspref_cache; + my $syspref_cache = Koha::Caches->get_instance('syspref'); + $syspref_cache->flush_all; } =head2 set_preference - C4::Context->set_preference( $variable, $value ); + C4::Context->set_preference( $variable, $value, [ $explanation, $type, $options ] ); This updates a preference's value both in the systempreferences table and in -the sysprefs cache. +the sysprefs cache. If the optional parameters are provided, then the query +becomes a create. It won't update the parameters (except value) for an existing +preference. =cut sub set_preference { - my $self = shift; - my $var = lc(shift); - my $value = shift; + my ( $self, $variable, $value, $explanation, $type, $options ) = @_; + + my $variable_case = $variable; + $variable = lc $variable; - my $syspref = Koha::Config::SysPrefs->find( $var ); - my $type = $syspref ? $syspref->type() : undef; + my $syspref = Koha::Config::SysPrefs->find($variable); + $type = + $type ? $type + : $syspref ? $syspref->type + : undef; $value = 0 if ( $type && $type eq 'YesNo' && $value eq '' ); # force explicit protocol on OPACBaseURL - if ($var eq 'opacbaseurl' && substr($value,0,4) !~ /http/) { + if ( $variable eq 'opacbaseurl' && $value && substr( $value, 0, 4 ) !~ /http/ ) { $value = 'http://' . $value; } if ($syspref) { - $syspref = $syspref->set( { value => $value } )->store(); + $syspref->set( + { ( defined $value ? ( value => $value ) : () ), + ( $explanation ? ( explanation => $explanation ) : () ), + ( $type ? ( type => $type ) : () ), + ( $options ? ( options => $options ) : () ), + } + )->store; + } else { + $syspref = Koha::Config::SysPref->new( + { variable => $variable_case, + value => $value, + explanation => $explanation || undef, + type => $type, + options => $options || undef, + } + )->store(); } - else { - $syspref = Koha::Config::SysPref->new( { variable => $var, value => $value } )->store(); + + if ( $use_syspref_cache ) { + my $syspref_cache = Koha::Caches->get_instance('syspref'); + $syspref_cache->set_in_cache( "syspref_$variable", $value ); } - if ($syspref) { - $sysprefs{$var} = $value; + return $syspref; +} + +=head2 delete_preference + + C4::Context->delete_preference( $variable ); + +This deletes a system preference from the database. Returns a true value on +success. Failure means there was an issue with the database, not that there +was no syspref of the name. + +=cut + +sub delete_preference { + my ( $self, $var ) = @_; + + if ( Koha::Config::SysPrefs->find( $var )->delete ) { + if ( $use_syspref_cache ) { + my $syspref_cache = Koha::Caches->get_instance('syspref'); + $syspref_cache->clear_from_cache("syspref_$var"); + } + + return 1; } + return 0; } =head2 Zconn @@ -666,34 +551,19 @@ sub _new_Zconn { my $tried=0; # first attempt my $Zconn; # connection object my $elementSetName; - my $index_mode; my $syntax; $server //= "biblioserver"; - if ( $server eq 'biblioserver' ) { - $index_mode = $context->{'config'}->{'zebra_bib_index_mode'} // 'dom'; - } elsif ( $server eq 'authorityserver' ) { - $index_mode = $context->{'config'}->{'zebra_auth_index_mode'} // 'dom'; - } - - if ( $index_mode eq 'grs1' ) { - $elementSetName = 'F'; - $syntax = ( $context->preference("marcflavour") eq 'UNIMARC' ) - ? 'unimarc' - : 'usmarc'; - - } else { # $index_mode eq 'dom' - $syntax = 'xml'; - $elementSetName = 'marcxml'; - } + $syntax = 'xml'; + $elementSetName = 'marcxml'; my $host = $context->{'listen'}->{$server}->{'content'}; my $user = $context->{"serverinfo"}->{$server}->{"user"}; my $password = $context->{"serverinfo"}->{$server}->{"password"}; eval { # set options - my $o = new ZOOM::Options(); + my $o = ZOOM::Options->new(); $o->option(user => $user) if $user && $password; $o->option(password => $password) if $user && $password; $o->option(async => 1) if $async; @@ -747,7 +617,6 @@ sub dbh { my $self = shift; my $params = shift; - my $sth; unless ( $params->{new} ) { return Koha::Database->schema->storage->dbh; @@ -835,135 +704,6 @@ sub restore_dbh # return something, then this function should, too. } -=head2 queryparser - - $queryparser = C4::Context->queryparser - -Returns a handle to an initialized Koha::QueryParser::Driver::PQF object. - -=cut - -sub queryparser { - my $self = shift; - unless (defined $context->{"queryparser"}) { - $context->{"queryparser"} = &_new_queryparser(); - } - - return - defined( $context->{"queryparser"} ) - ? $context->{"queryparser"}->new - : undef; -} - -=head2 _new_queryparser - -Internal helper function to create a new QueryParser object. QueryParser -is loaded dynamically so as to keep the lack of the QueryParser library from -getting in anyone's way. - -=cut - -sub _new_queryparser { - my $qpmodules = { - 'OpenILS::QueryParser' => undef, - 'Koha::QueryParser::Driver::PQF' => undef - }; - if ( can_load( 'modules' => $qpmodules ) ) { - my $QParser = Koha::QueryParser::Driver::PQF->new(); - my $config_file = $context->config('queryparser_config'); - $config_file ||= '/etc/koha/searchengine/queryparser.yaml'; - if ( $QParser->load_config($config_file) ) { - # Set 'keyword' as the default search class - $QParser->default_search_class('keyword'); - # TODO: allow indexes to be configured in the database - return $QParser; - } - } - return; -} - -=head2 marcfromkohafield - - $dbh = C4::Context->marcfromkohafield; - -Returns a hash with marcfromkohafield. - -This hash is cached for future use: if you call -Cmarcfromkohafield> twice, you will get the same hash without real DB access - -=cut - -#' -sub marcfromkohafield -{ - my $retval = {}; - - # If the hash already exists, return it. - return $context->{"marcfromkohafield"} if defined($context->{"marcfromkohafield"}); - - # No hash. Create one. - $context->{"marcfromkohafield"} = &_new_marcfromkohafield(); - - return $context->{"marcfromkohafield"}; -} - -# _new_marcfromkohafield -# Internal helper function (not a method!). This creates a new -# hash with stopwords -sub _new_marcfromkohafield -{ - my $dbh = C4::Context->dbh; - my $marcfromkohafield; - my $sth = $dbh->prepare("select frameworkcode,kohafield,tagfield,tagsubfield from marc_subfield_structure where kohafield > ''"); - $sth->execute; - while (my ($frameworkcode,$kohafield,$tagfield,$tagsubfield) = $sth->fetchrow) { - my $retval = {}; - $marcfromkohafield->{$frameworkcode}->{$kohafield} = [$tagfield,$tagsubfield]; - } - return $marcfromkohafield; -} - -=head2 stopwords - - $dbh = C4::Context->stopwords; - -Returns a hash with stopwords. - -This hash is cached for future use: if you call -Cstopwords> twice, you will get the same hash without real DB access - -=cut - -#' -sub stopwords -{ - my $retval = {}; - - # If the hash already exists, return it. - return $context->{"stopwords"} if defined($context->{"stopwords"}); - - # No hash. Create one. - $context->{"stopwords"} = &_new_stopwords(); - - return $context->{"stopwords"}; -} - -# _new_stopwords -# Internal helper function (not a method!). This creates a new -# hash with stopwords -sub _new_stopwords -{ - my $dbh = C4::Context->dbh; - my $stopwordlist; - my $sth = $dbh->prepare("select word from stopwords"); - $sth->execute; - while (my $stopword = $sth->fetchrow_array) { - $stopwordlist->{$stopword} = uc($stopword); - } - $stopwordlist->{A} = "A" unless $stopwordlist; - return $stopwordlist; -} - =head2 userenv C4::Context->userenv; @@ -990,7 +730,9 @@ sub userenv { C4::Context->set_userenv($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, - $emailaddress, $branchprinter, $persona); + $emailaddress, $shibboleth + $desk_id, $desk_name, + $register_id, $register_name); Establish a hash of user environment variables. @@ -1001,9 +743,13 @@ set_userenv is called in Auth.pm #' sub set_userenv { shift @_; - my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter, $persona, $shibboleth)= - map { Encode::is_utf8( $_ ) ? $_ : Encode::decode('UTF-8', $_) } # CGI::Session doesn't handle utf-8, so we decode it here - @_; + my ( + $usernum, $userid, $usercnum, $userfirstname, + $usersurname, $userbranch, $branchname, $userflags, + $emailaddress, $shibboleth, $desk_id, $desk_name, + $register_id, $register_name + ) = @_; + my $var=$context->{"activeuser"} || ''; my $cell = { "number" => $usernum, @@ -1011,39 +757,22 @@ sub set_userenv { "cardnumber" => $usercnum, "firstname" => $userfirstname, "surname" => $usersurname, + #possibly a law problem - "branch" => $userbranch, - "branchname" => $branchname, - "flags" => $userflags, - "emailaddress" => $emailaddress, - "branchprinter" => $branchprinter, - "persona" => $persona, - "shibboleth" => $shibboleth, + "branch" => $userbranch, + "branchname" => $branchname, + "flags" => $userflags, + "emailaddress" => $emailaddress, + "shibboleth" => $shibboleth, + "desk_id" => $desk_id, + "desk_name" => $desk_name, + "register_id" => $register_id, + "register_name" => $register_name }; $context->{userenv}->{$var} = $cell; return $cell; } -sub set_shelves_userenv { - my ($type, $shelves) = @_ or return; - my $activeuser = $context->{activeuser} or return; - $context->{userenv}->{$activeuser}->{barshelves} = $shelves if $type eq 'bar'; - $context->{userenv}->{$activeuser}->{pubshelves} = $shelves if $type eq 'pub'; - $context->{userenv}->{$activeuser}->{totshelves} = $shelves if $type eq 'tot'; -} - -sub get_shelves_userenv { - my $active; - unless ($active = $context->{userenv}->{$context->{activeuser}}) { - $debug and warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}"; - return; - } - my $totshelves = $active->{totshelves} or undef; - my $pubshelves = $active->{pubshelves} or undef; - my $barshelves = $active->{barshelves} or undef; - return ($totshelves, $pubshelves, $barshelves); -} - =head2 _new_userenv C4::Context->_new_userenv($session); # FIXME: This calling style is wrong for what looks like an _internal function @@ -1102,7 +831,8 @@ sub get_versions { { no warnings qw(exec); # suppress warnings if unable to find a program in $PATH $versions{mysqlVersion} = `mysql -V`; - $versions{apacheVersion} = `httpd -v`; + $versions{apacheVersion} = (`apache2ctl -v`)[0]; + $versions{apacheVersion} = `httpd -v` unless $versions{apacheVersion} ; $versions{apacheVersion} = `httpd2 -v` unless $versions{apacheVersion} ; $versions{apacheVersion} = `apache2 -v` unless $versions{apacheVersion} ; $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless $versions{apacheVersion} ; @@ -1110,6 +840,25 @@ sub get_versions { return %versions; } +=head2 timezone + + my $C4::Context->timzone + + Returns a timezone code for the instance of Koha + +=cut + +sub timezone { + my $self = shift; + + my $timezone = C4::Context->config('timezone') || $ENV{TZ} || 'local'; + if ( !DateTime::TimeZone->is_valid_name( $timezone ) ) { + warn "Invalid timezone in koha-conf.xml ($timezone)"; + $timezone = 'local'; + } + + return $timezone; +} =head2 tz @@ -1122,7 +871,8 @@ sub get_versions { sub tz { my $self = shift; if (!defined $context->{tz}) { - $context->{tz} = DateTime::TimeZone->new(name => 'local'); + my $timezone = $self->timezone; + $context->{tz} = DateTime::TimeZone->new(name => $timezone); } return $context->{tz}; } @@ -1163,7 +913,13 @@ sub interface { if (defined $interface) { $interface = lc $interface; - if ($interface eq 'opac' || $interface eq 'intranet') { + if ( $interface eq 'api' + || $interface eq 'opac' + || $interface eq 'intranet' + || $interface eq 'sip' + || $interface eq 'cron' + || $interface eq 'commandline' ) + { $context->{interface} = $interface; } else { warn "invalid interface : '$interface'"; @@ -1173,7 +929,101 @@ sub interface { return $context->{interface} // 'opac'; } +# always returns a string for OK comparison via "eq" or "ne" +sub mybranch { + C4::Context->userenv or return ''; + return C4::Context->userenv->{branch} || ''; +} + +=head2 only_my_library + + my $test = C4::Context->only_my_library; + + Returns true if you enabled IndependentBranches and the current user + does not have superlibrarian permissions. + +=cut + +sub only_my_library { + return + C4::Context->preference('IndependentBranches') + && C4::Context->userenv + && !C4::Context->IsSuperLibrarian() + && C4::Context->userenv->{branch}; +} + +=head3 temporary_directory + +Returns root directory for temporary storage + +=cut + +sub temporary_directory { + my ( $class ) = @_; + return C4::Context->config('tmp_path') || File::Spec->tmpdir; +} + +=head3 set_remote_address + +set_remote_address should be called at the beginning of every script +that is *not* running under plack in order to the REMOTE_ADDR environment +variable to be set correctly. + +=cut + +sub set_remote_address { + if ( C4::Context->config('koha_trusted_proxies') ) { + require CGI; + my $header = CGI->http('HTTP_X_FORWARDED_FOR'); + + if ($header) { + require Koha::Middleware::RealIP; + $ENV{REMOTE_ADDR} = Koha::Middleware::RealIP::get_real_ip( $ENV{REMOTE_ADDR}, $header ); + } + } +} + +=head3 https_enabled + +https_enabled should be called when checking if a HTTPS connection +is used. + +Note that this depends on a HTTPS environmental variable being defined +by the web server. This function may not return the expected result, +if your web server or reverse proxies are not setting the correct +X-Forwarded-Proto headers and HTTPS environmental variable. + +Note too that the HTTPS value can vary from web server to web server. +We are relying on the convention of the value being "on" or "ON" here. + +=cut + +sub https_enabled { + my $https_enabled = 0; + my $env_https = $ENV{HTTPS}; + if ($env_https){ + if ($env_https =~ /^ON$/i){ + $https_enabled = 1; + } + } + return $https_enabled; +} + 1; + +=head3 needs_install + + if ( $context->needs_install ) { ... } + +This method returns a boolean representing the install status of the Koha instance. + +=cut + +sub needs_install { + my ($self) = @_; + return ($self->preference('Version')) ? 0 : 1; +} + __END__ =head1 ENVIRONMENT @@ -1182,10 +1032,6 @@ __END__ Specifies the configuration file to read. -=head1 SEE ALSO - -XML::Simple - =head1 AUTHORS Andrew Arensburger