X-Git-Url: http://git.rot13.org/?a=blobdiff_plain;f=C4%2FContext.pm;h=9b3f74dbb21134dc0745a72b984744dd3f9c437e;hb=4ccbae8879a386a1846bb48c18b3722f936dc983;hp=bd1f2351d937600915b78748cacb9d8fe5c40aa6;hpb=d44b552b3f22c7423038f831d622bfe67a543936;p=koha.git diff --git a/C4/Context.pm b/C4/Context.pm index bd1f2351d9..9b3f74dbb2 100644 --- a/C4/Context.pm +++ b/C4/Context.pm @@ -1,25 +1,25 @@ package C4::Context; + # Copyright 2002 Katipo Communications # # This file is part of Koha. # -# Koha is free software; you can redistribute it and/or modify it under the -# terms of the GNU General Public License as published by the Free Software -# Foundation; either version 2 of the License, or (at your option) any later -# version. +# Koha is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. # -# Koha is distributed in the hope that it will be useful, but WITHOUT ANY -# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR -# A PARTICULAR PURPOSE. See the GNU General Public License for more details. +# Koha is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. # -# You should have received a copy of the GNU General Public License along -# with Koha; if not, write to the Free Software Foundation, Inc., -# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +# 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; @@ -77,34 +77,34 @@ BEGIN { 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'); - } - $VERSION = '3.07.00.049'; + # 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; + } + } # else there is no browser to send fatals to! } -use DBI; +use Carp; +use DateTime::TimeZone; +use Encode; +use File::Spec; +use Module::Load::Conditional qw(can_load); +use POSIX (); use ZOOM; -use XML::Simple; + use C4::Boolean; use C4::Debug; -use POSIX (); -use DateTime::TimeZone; +use Koha::Caches; +use Koha::Config::SysPref; +use Koha::Config::SysPrefs; +use Koha::Config; +use Koha; =head1 NAME @@ -124,8 +124,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: @@ -173,127 +171,23 @@ 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 db_scheme2dbi -=head2 KOHAVERSION - -returns the kohaversion stored in kohaversion.pl file - -=cut - -sub KOHAVERSION { - my $cgidir = C4::Context->intranetdir; - - # Apparently the GIT code does not run out of a CGI-BIN subdirectory - # but distribution code does? (Stan, 1jan08) - if(-d $cgidir . "/cgi-bin"){ - my $cgidir .= "/cgi-bin"; - } - - do $cgidir."/kohaversion.pl" || die "NO $cgidir/kohaversion.pl"; - return kohaversion(); -} -=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 + my $dbd_driver_name = C4::Context::db_schema2dbi($scheme); -If $ismemcached is true, returns the $memcache variable. -Returns undef otherwise +This routines translates a database type to part of the name +of the appropriate DBD driver to use when establishing a new +database connection. It recognizes 'mysql' and 'Pg'; if any +other scheme is supplied it defaults to 'mysql'. =cut -sub memcached { - if ($ismemcached) { - return $memcached; - } else { - return; - } -} - -# db_scheme2dbi -# Translates the full text name of a database into de appropiate dbi name -# sub db_scheme2dbi { - my $name = shift; - # for instance, we support only mysql, so don't care checking - return "mysql"; - for ($name) { -# FIXME - Should have other databases. - if (/mysql/) { return("mysql"); } - if (/Postgres|Pg|PostgresSQL/) { return("Pg"); } - if (/oracle/) { return("Oracle"); } - } - return; # Just in case + my $scheme = shift // ''; + return $scheme eq 'Pg' ? $scheme : 'mysql'; } sub import { @@ -301,7 +195,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! @@ -344,50 +238,40 @@ sub new { 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); + + my $conf_cache = Koha::Caches->get_instance('config'); + my $config_from_cache; + if ( $conf_cache->cache ) { + $self = $conf_cache->get_from_cache('koha_conf'); + } + unless ( $self and %$self ) { + $self = Koha::Config->read_from_file($conf_fname); + if ( $conf_cache->memcached_cache ) { + # FIXME it may be better to use the memcached servers from the config file + # to cache it + $conf_cache->set_in_cache('koha_conf', $self) } - } else { - # non-memcached env, read from file - $self = read_config_file($conf_fname); + } + unless ( exists $self->{config} or defined $self->{config} ) { + warn "The config file ($conf_fname) has not been parsed correctly"; + return; } - $self->{"config_file"} = $conf_fname; - warn "read_config_file($conf_fname) returned undef" if !defined($self->{"config"}); - return if !defined($self->{"config"}); - - $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; $self->{tz} = undef; # local timezone object bless $self, $class; + $self->{db_driver} = db_scheme2dbi($self->config('db_scheme')); # cache database driver return $self; } @@ -519,31 +403,31 @@ with this method. =cut -# FIXME: running this under mod_perl will require a means of -# flushing the caching mechanism. - -my %sysprefs; +my $syspref_cache = Koha::Caches->get_instance('syspref'); my $use_syspref_cache = 1; - sub preference { my $self = shift; - my $var = lc(shift); # The system preference to return + my $var = shift; # The system preference to return - if ($use_syspref_cache && exists $sysprefs{$var}) { - return $sysprefs{$var}; + return $ENV{"OVERRIDE_SYSPREF_$var"} + if defined $ENV{"OVERRIDE_SYSPREF_$var"}; + + $var = lc $var; + + if ($use_syspref_cache) { + $syspref_cache = Koha::Caches->get_instance('syspref') unless $syspref_cache; + my $cached_var = $syspref_cache->get_from_cache("syspref_$var"); + return $cached_var if defined $cached_var; } - my $dbh = C4::Context->dbh or return 0; - - # Look up systempreferences.variable==$var - my $sql = <<'END_SQL'; - SELECT value - FROM systempreferences - WHERE variable=? - LIMIT 1 -END_SQL - $sysprefs{$var} = $dbh->selectrow_array( $sql, {}, $var ); - return $sysprefs{$var}; + my $syspref; + eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) }; + my $value = $syspref ? $syspref->value() : undef; + + if ( $use_syspref_cache ) { + $syspref_cache->set_in_cache("syspref_$var", $value); + } + return $value; } sub boolean_preference { @@ -565,6 +449,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 @@ -593,67 +479,94 @@ will not be seen by this process. =cut sub clear_syspref_cache { - %sysprefs = (); + return unless $use_syspref_cache; + $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 '' ); - my $sth = $dbh->prepare( " - INSERT INTO systempreferences - ( variable, value ) - VALUES( ?, ? ) - ON DUPLICATE KEY UPDATE value = VALUES(value) - " ); + # force explicit protocol on OPACBaseURL + if ( $variable eq 'opacbaseurl' && $value && substr( $value, 0, 4 ) !~ /http/ ) { + $value = 'http://' . $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 ) { + $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. + +=cut - $AUTOLOAD =~ s/.*:://; # Chop off the package name, - # leaving only the function name. - return $self->config($AUTOLOAD); +sub delete_preference { + my ( $self, $var ) = @_; + + if ( Koha::Config::SysPrefs->find( $var )->delete ) { + if ( $use_syspref_cache ) { + $syspref_cache->clear_from_cache("syspref_$var"); + } + + return 1; + } + return 0; } =head2 Zconn $Zconn = C4::Context->Zconn -Returns a connection to the Zebra database for the current -context. If no connection has yet been made, this method -creates one and connects. +Returns a connection to the Zebra database C<$self> @@ -661,35 +574,18 @@ C<$server> one of the servers defined in the koha-conf.xml file C<$async> whether this is a asynchronous connection -C<$auth> whether this connection has rw access (1) or just r access (0 or NULL) - - =cut sub Zconn { - my $self=shift; - my $server=shift; - my $async=shift; - my $auth=shift; - my $piggyback=shift; - my $syntax=shift; - if ( defined($context->{"Zconn"}->{$server}) && (0 == $context->{"Zconn"}->{$server}->errcode()) ) { - return $context->{"Zconn"}->{$server}; - # No connection object or it died. Create one. - }else { - # release resources if we're closing a connection and making a new one - # FIXME: this needs to be smarter -- an error due to a malformed query or - # a missing index does not necessarily require us to close the connection - # and make a new one, particularly for a batch job. However, at - # first glance it does not look like there's a way to easily check - # the basic health of a ZOOM::Connection - $context->{"Zconn"}->{$server}->destroy() if defined($context->{"Zconn"}->{$server}); - - $context->{"Zconn"}->{$server} = &_new_Zconn($server,$async,$auth,$piggyback,$syntax); - $context->{ Zconn }->{ $server }->option( - preferredRecordSyntax => C4::Context->preference("marcflavour") ); - return $context->{"Zconn"}->{$server}; + my ($self, $server, $async ) = @_; + my $cache_key = join ('::', (map { $_ // '' } ($server, $async ))); + if ( (!defined($ENV{GATEWAY_INTERFACE})) && defined($context->{"Zconn"}->{$cache_key}) && (0 == $context->{"Zconn"}->{$cache_key}->errcode()) ) { + # if we are running the script from the commandline, lets try to use the caching + return $context->{"Zconn"}->{$cache_key}; } + $context->{"Zconn"}->{$cache_key}->destroy() if defined($context->{"Zconn"}->{$cache_key}); #destroy old connection before making a new one + $context->{"Zconn"}->{$cache_key} = &_new_Zconn( $server, $async ); + return $context->{"Zconn"}->{$cache_key}; } =head2 _new_Zconn @@ -707,31 +603,32 @@ C<$auth> whether this connection has rw access (1) or just r access (0 or NULL) =cut sub _new_Zconn { - my ($server,$async,$auth,$piggyback,$syntax) = @_; + my ( $server, $async ) = @_; my $tried=0; # first attempt my $Zconn; # connection object - $server = "biblioserver" unless $server; - $syntax = "usmarc" unless $syntax; + my $elementSetName; + my $syntax; + + $server //= "biblioserver"; + + $syntax = 'xml'; + $elementSetName = 'marcxml'; my $host = $context->{'listen'}->{$server}->{'content'}; - my $servername = $context->{"config"}->{$server}; my $user = $context->{"serverinfo"}->{$server}->{"user"}; my $password = $context->{"serverinfo"}->{$server}->{"password"}; - $auth = 1 if($user && $password); - retry: eval { # set options my $o = new ZOOM::Options(); - $o->option(user=>$user) if $auth; - $o->option(password=>$password) if $auth; + $o->option(user => $user) if $user && $password; + $o->option(password => $password) if $user && $password; $o->option(async => 1) if $async; - $o->option(count => $piggyback) if $piggyback; $o->option(cqlfile=> $context->{"server"}->{$server}->{"cql2rpn"}); $o->option(cclfile=> $context->{"serverinfo"}->{$server}->{"ccl2rpn"}); $o->option(preferredRecordSyntax => $syntax); - $o->option(elementSetName => "F"); # F for 'full' as opposed to B for 'brief' - $o->option(databaseName => ($servername?$servername:"biblios")); + $o->option(elementSetName => $elementSetName) if $elementSetName; + $o->option(databaseName => $context->{"config"}->{$server}||"biblios"); # create a new connection object $Zconn= create ZOOM::Connection($o); @@ -743,25 +640,7 @@ sub _new_Zconn { if ($Zconn->errcode() !=0) { warn "something wrong with the connection: ". $Zconn->errmsg(); } - }; -# if ($@) { -# # Koha manages the Zebra server -- this doesn't work currently for me because of permissions issues -# # Also, I'm skeptical about whether it's the best approach -# warn "problem with Zebra"; -# if ( C4::Context->preference("ManageZebra") ) { -# if ($@->code==10000 && $tried==0) { ##No connection try restarting Zebra -# $tried=1; -# warn "trying to restart Zebra"; -# my $res=system("zebrasrv -f $ENV{'KOHA_CONF'} >/koha/log/zebra-error.log"); -# goto "retry"; -# } else { -# warn "Error ", $@->code(), ": ", $@->message(), "\n"; -# $Zconn="error"; -# return $Zconn; -# } -# } -# } return $Zconn; } @@ -772,51 +651,7 @@ sub _new_Zconn { sub _new_dbh { - ## $context - ## correct name for db_schme - my $db_driver; - if ($context->config("db_scheme")){ - $db_driver=db_scheme2dbi($context->config("db_scheme")); - }else{ - $db_driver="mysql"; - } - - 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 = DBI->connect("DBI:$db_driver:dbname=$db_name;host=$db_host;port=$db_port", - $db_user, $db_passwd, {'RaiseError' => $ENV{DEBUG}?1:0 }) or die $DBI::errstr; - - # 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; - } - - 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 @@ -838,16 +673,14 @@ possibly C<&set_dbh>. sub dbh { my $self = shift; + my $params = shift; my $sth; - if (defined($context->{"dbh"}) && $context->{"dbh"}->ping()) { - return $context->{"dbh"}; + unless ( $params->{new} ) { + 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 @@ -868,7 +701,7 @@ sub new_dbh { my $self = shift; - return &_new_dbh(); + return &dbh({ new => 1 }); } =head2 set_dbh @@ -929,86 +762,51 @@ sub restore_dbh # return something, then this function should, too. } -=head2 marcfromkohafield - - $dbh = C4::Context->marcfromkohafield; +=head2 queryparser -Returns a hash with marcfromkohafield. + $queryparser = C4::Context->queryparser -This hash is cached for future use: if you call -Cmarcfromkohafield> twice, you will get the same hash without real DB access +Returns a handle to an initialized Koha::QueryParser::Driver::PQF object. =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]; +sub queryparser { + my $self = shift; + unless (defined $context->{"queryparser"}) { + $context->{"queryparser"} = &_new_queryparser(); } - return $marcfromkohafield; -} - -=head2 stopwords - $dbh = C4::Context->stopwords; + return + defined( $context->{"queryparser"} ) + ? $context->{"queryparser"}->new + : undef; +} -Returns a hash with stopwords. +=head2 _new_queryparser -This hash is cached for future use: if you call -Cstopwords> twice, you will get the same hash without real DB access +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 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); +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; + } } - $stopwordlist->{A} = "A" unless $stopwordlist; - return $stopwordlist; + return; } =head2 userenv @@ -1025,18 +823,8 @@ Cuserenv> twice, you will get the same hash without real DB ac #' sub userenv { my $var = $context->{"activeuser"}; - return $context->{"userenv"}->{$var} if (defined $var and defined $context->{"userenv"}->{$var}); - # insecure=1 management - if ($context->{"dbh"} && $context->preference('insecure') eq 'yes') { - my %insecure; - $insecure{flags} = '16382'; - $insecure{branchname} ='Insecure'; - $insecure{number} ='0'; - $insecure{cardnumber} ='0'; - $insecure{id} = 'insecure'; - $insecure{branch} = 'INS'; - $insecure{emailaddress} = 'test@mode.insecure.com'; - return \%insecure; + if (defined $var and defined $context->{"userenv"}->{$var}) { + return $context->{"userenv"}->{$var}; } else { return; } @@ -1044,8 +832,10 @@ sub userenv { =head2 set_userenv - C4::Context->set_userenv($usernum, $userid, $usercnum, $userfirstname, - $usersurname, $userbranch, $userflags, $emailaddress); + C4::Context->set_userenv($usernum, $userid, $usercnum, + $userfirstname, $usersurname, + $userbranch, $branchname, $userflags, + $emailaddress, $branchprinter, $shibboleth); Establish a hash of user environment variables. @@ -1055,7 +845,10 @@ set_userenv is called in Auth.pm #' sub set_userenv { - my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter)= @_; + shift @_; + my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter, $shibboleth)= + map { Encode::is_utf8( $_ ) ? $_ : Encode::decode('UTF-8', $_) } # CGI::Session doesn't handle utf-8, so we decode it here + @_; my $var=$context->{"activeuser"} || ''; my $cell = { "number" => $usernum, @@ -1068,7 +861,8 @@ sub set_userenv { "branchname" => $branchname, "flags" => $userflags, "emailaddress" => $emailaddress, - "branchprinter" => $branchprinter + "branchprinter" => $branchprinter, + "shibboleth" => $shibboleth, }; $context->{userenv}->{$var} = $cell; return $cell; @@ -1145,14 +939,15 @@ Gets various version info, for core Koha packages, Currently called from carp ha # A little example sub to show more debugging info for CGI::Carp sub get_versions { my %versions; - $versions{kohaVersion} = KOHAVERSION(); + $versions{kohaVersion} = Koha::version(); $versions{kohaDbVersion} = C4::Context->preference('version'); $versions{osVersion} = join(" ", POSIX::uname()); $versions{perlVersion} = $]; { 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} ; @@ -1160,6 +955,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 @@ -1172,14 +986,95 @@ 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}; } +=head2 IsSuperLibrarian + + C4::Context->IsSuperLibrarian(); + +=cut + +sub IsSuperLibrarian { + my $userenv = C4::Context->userenv; + + unless ( $userenv and exists $userenv->{flags} ) { + # If we reach this without a user environment, + # assume that we're running from a command-line script, + # and act as a superlibrarian. + carp("C4::Context->userenv not defined!"); + return 1; + } + + return ($userenv->{flags}//0) % 2; +} + +=head2 interface + +Sets the current interface for later retrieval in any Perl module + + C4::Context->interface('opac'); + C4::Context->interface('intranet'); + my $interface = C4::Context->interface; + +=cut + +sub interface { + my ($class, $interface) = @_; + + if (defined $interface) { + $interface = lc $interface; + if ($interface eq 'opac' || $interface eq 'intranet' || $interface eq 'sip' || $interface eq 'commandline') { + $context->{interface} = $interface; + } else { + warn "invalid interface : '$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; +} + 1; + __END__ =head1 ENVIRONMENT @@ -1198,4 +1093,3 @@ Andrew Arensburger Joshua Ferraro -=cut