X-Git-Url: http://koha-dev.rot13.org:8081/gitweb/?a=blobdiff_plain;f=C4%2FContext.pm;h=63187bf4b7063d34e224725163920188fa9f021a;hb=9d6d641d1f8b77271800f43bc027b651f9aea52b;hp=452b764c2ea7d5fe0cac07309c4a763768d657f0;hpb=1651cf70d10101739e3a7ff943fb709cedf6dccf;p=srvgit diff --git a/C4/Context.pm b/C4/Context.pm index 452b764c2e..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,98 +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 DBIx::Connector; +use Carp qw( carp ); +use DateTime::TimeZone; use Encode; +use File::Spec; +use POSIX; +use YAML::XS; use ZOOM; -use XML::Simple; -use C4::Boolean; -use C4::Debug; + +use Koha::Caches; +use Koha::Config::SysPref; +use Koha::Config::SysPrefs; +use Koha::Config; use Koha; -use POSIX (); -use DateTime::TimeZone; -use Module::Load::Conditional qw(can_load); -use Carp; =head1 NAME @@ -127,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: @@ -176,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); @@ -286,7 +138,7 @@ sub import { # the first time the module is called # (a config file can be optionaly passed) - # default context allready exists? + # default context already exists? return if $context; # no ? so load it! @@ -301,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> @@ -323,50 +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) { - # retreive 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->{"dbh"} = undef; # Database handle $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,45 +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 { - # Look up systempreferences.variable==$var - my $sql = q{ - SELECT value - FROM systempreferences - WHERE variable = ? - LIMIT 1 - }; - $value = $dbh->selectrow_array( $sql, {}, lc $var ); + 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 @@ -558,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 @@ -586,63 +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 $dbh = C4::Context->dbh or return 0; + my $variable_case = $variable; + $variable = lc $variable; - my $type = $dbh->selectrow_array( "SELECT type FROM systempreferences WHERE variable = ?", {}, $var ); + 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; } - my $sth = $dbh->prepare( " - INSERT INTO systempreferences - ( variable, value ) - VALUES( ?, ? ) - ON DUPLICATE KEY UPDATE value = VALUES(value) - " ); + if ($syspref) { + $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(); + } - if($sth->execute( $var, $value )) { - $sysprefs{$var} = $value; + if ( $use_syspref_cache ) { + my $syspref_cache = Koha::Caches->get_instance('syspref'); + $syspref_cache->set_in_cache( "syspref_$variable", $value ); } - $sth->finish; + + return $syspref; } -# AUTOLOAD -# This implements C4::Config->foo, and simply returns -# C4::Context->config("foo"), as described in the documentation for -# &config, above. +=head2 delete_preference -# FIXME - Perhaps this should be extended to check &config first, and -# then &preference if that fails. OTOH, AUTOLOAD could lead to crappy -# code, so it'd probably be best to delete it altogether so as not to -# encourage people to use it. -sub AUTOLOAD -{ - my $self = shift; + 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. - $AUTOLOAD =~ s/.*:://; # Chop off the package name, - # leaving only the function name. - return $self->config($AUTOLOAD); +=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 @@ -691,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; @@ -749,55 +594,7 @@ sub _new_Zconn { sub _new_dbh { - ## $context - ## correct name for db_scheme - my $db_driver = $context->{db_driver}; - - my $db_name = $context->config("database"); - my $db_host = $context->config("hostname"); - my $db_port = $context->config("port") || ''; - my $db_user = $context->config("user"); - my $db_passwd = $context->config("pass"); - # MJR added or die here, as we can't work without dbh - my $dbh = DBIx::Connector->connect( - "dbi:$db_driver:dbname=$db_name;host=$db_host;port=$db_port", - $db_user, $db_passwd, - { - 'RaiseError' => $ENV{DEBUG} ? 1 : 0 - } - ); - - # Check for the existence of a systempreference table; if we don't have this, we don't - # have a valid database and should not set RaiseError in order to allow the installer - # to run; installer will not run otherwise since we raise all db errors - - eval { - local $dbh->{PrintError} = 0; - local $dbh->{RaiseError} = 1; - $dbh->do(qq{SELECT * FROM systempreferences WHERE 1 = 0 }); - }; - - if ($@) { - $dbh->{RaiseError} = 0; - } - - if ( $db_driver eq 'mysql' ) { - $dbh->{mysql_auto_reconnect} = 1; - } - - my $tz = $ENV{TZ}; - if ( $db_driver eq 'mysql' ) { - # Koha 3.0 is utf-8, so force utf8 communication between mySQL and koha, whatever the mysql default config. - # this is better than modifying my.cnf (and forcing all communications to be in utf8) - $dbh->{'mysql_enable_utf8'}=1; #enable - $dbh->do("set NAMES 'utf8'"); - ($tz) and $dbh->do(qq(SET time_zone = "$tz")); - } - elsif ( $db_driver eq 'Pg' ) { - $dbh->do( "set client_encoding = 'UTF8';" ); - ($tz) and $dbh->do(qq(SET TIME ZONE = "$tz")); - } - return $dbh; + Koha::Database->schema({ new => 1 })->storage->dbh; } =head2 dbh @@ -820,20 +617,12 @@ sub dbh { my $self = shift; my $params = shift; - my $sth; unless ( $params->{new} ) { - if ( defined($context->{db_driver}) && $context->{db_driver} eq 'mysql' && $context->{"dbh"} ) { - return $context->{"dbh"}; - } elsif ( defined($context->{"dbh"}) && $context->{"dbh"}->ping() ) { - return $context->{"dbh"}; - } + return Koha::Database->schema->storage->dbh; } - # No database handle or it died . Create one. - $context->{"dbh"} = &_new_dbh(); - - return $context->{"dbh"}; + return Koha::Database->schema({ new => 1 })->storage->dbh; } =head2 new_dbh @@ -854,7 +643,7 @@ sub new_dbh { my $self = shift; - return &_new_dbh(); + return &dbh({ new => 1 }); } =head2 set_dbh @@ -915,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; @@ -1070,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. @@ -1081,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, @@ -1091,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 @@ -1182,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} ; @@ -1190,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 @@ -1202,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}; } @@ -1210,7 +880,7 @@ sub tz { =head2 IsSuperLibrarian - C4::Context->IsSuperlibrarian(); + C4::Context->IsSuperLibrarian(); =cut @@ -1243,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'"; @@ -1253,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 @@ -1262,10 +1032,6 @@ __END__ Specifies the configuration file to read. -=head1 SEE ALSO - -XML::Simple - =head1 AUTHORS Andrew Arensburger