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.
-
-use strict;
-use warnings;
-use vars qw($VERSION $AUTOLOAD $context @context_stack $servers $memcached $ismemcached);
-$ENV{'DBIC_DONT_VALIDATE_RELS'} = 1; # FIXME once the DBIx schema has its schema adjusted we should remove this
+# You should have received a copy of the GNU General Public License
+# along with Koha; if not, see <http://www.gnu.org/licenses>.
+
+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(<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
- <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
- <head><title>Koha Error</title></head>
- <body>
- );
- if ($debug_level eq "2"){
- # debug 2 , print extra info too.
- my %versions = get_versions();
-
- # a little example table with various version info";
- print "
- <h1>Koha error</h1>
- <p>The following fatal error has occurred:</p>
- <pre><code>$msg</code></pre>
- <table>
- <tr><th>Apache</th><td> $versions{apacheVersion}</td></tr>
- <tr><th>Koha</th><td> $versions{kohaVersion}</td></tr>
- <tr><th>Koha DB</th><td> $versions{kohaDbVersion}</td></tr>
- <tr><th>MySQL</th><td> $versions{mysqlVersion}</td></tr>
- <tr><th>OS</th><td> $versions{osVersion}</td></tr>
- <tr><th>Perl</th><td> $versions{perlVersion}</td></tr>
- </table>";
-
- } elsif ($debug_level eq "1"){
- print "
- <h1>Koha error</h1>
- <p>The following fatal error has occurred:</p>
- <pre><code>$msg</code></pre>";
- } else {
- print "<p>production mode - trapped fatal error</p>";
- }
- print "</body></html>";
- }
- #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 DBI;
-require Koha::Schema;
-use ZOOM;
-use XML::Simple;
-use C4::Boolean;
-use C4::Debug;
-use POSIX ();
+use Carp qw( carp );
use DateTime::TimeZone;
-use Module::Load::Conditional qw(can_load);
+use Encode;
+use File::Spec;
+use POSIX;
+use YAML::XS;
+use ZOOM;
+
+use Koha::Caches;
+use Koha::Config::SysPref;
+use Koha::Config::SysPrefs;
+use Koha::Config;
+use Koha;
=head1 NAME
$Zconn = C4::Context->Zconn;
- $stopwordhash = C4::Context->stopwords;
-
=head1 DESCRIPTION
When a Koha script runs, it makes use of a certain number of things:
# 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 final_linear_version
-
-Returns the version number of the final update to run in updatedatabase.pl.
-This number is equal to the version in kohaversion.pl
-
-=cut
-
-sub final_linear_version {
- 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 <config> element:
-
- my $pass = $koha->{'config'}->{'pass'};
-
-The <listen> elements:
-
- my $listen = $koha->{'listen'}->{'biblioserver'}->{'content'};
-
-The elements nested within the <server> 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
+ my $dbd_driver_name = C4::Context::db_schema2dbi($scheme);
-Returns the value of the $ismemcached variable (0/1)
+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 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;
- }
-}
-
-# 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 {
# 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!
=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>
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;
$self->{tz} = undef; # local timezone object
bless $self, $class;
+ $self->{db_driver} = db_scheme2dbi($self->config('db_scheme')); # cache database driver
return $self;
}
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
sub zebraconfig {
return _common_config($_[1],'server');
}
-sub ModZebrations {
- return _common_config($_[1],'serverinfo');
-}
=head2 preference
=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
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
=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 '' );
- 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 ) {
+ 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.
+
+=cut
+
+sub delete_preference {
+ my ( $self, $var ) = @_;
- $AUTOLOAD =~ s/.*:://; # Chop off the package name,
- # leaving only the function name.
- return $self->config($AUTOLOAD);
+ 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
$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>
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
=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;
+ 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;
- $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);
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;
}
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
sub dbh
{
my $self = shift;
- my $sth;
+ my $params = shift;
- 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
{
my $self = shift;
- return &_new_dbh();
+ return &dbh({ new => 1 });
}
=head2 set_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) ) {
- # TODO: allow indexes to be configured in the database
- return $QParser;
- }
- }
- return;
-}
-
-# _new_schema
-# Internal helper function (not a method!). This creates a new
-# database connection from the data given in the current context, and
-# returns it.
-sub _new_schema {
- 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");
- my $schema= Koha::Schema->connect("DBI:$db_driver:dbname=$db_name;host=$db_host;port=$db_port",
- $db_user, $db_passwd);
- return $schema;
-}
-
-=head2 schema
-
- $schema = C4::Context->schema;
-
-Returns a database handle connected to the Koha database for the
-current context. If no connection has yet been made, this method
-creates one, and connects to the database.
-
-This database handle is cached for future use: if you call
-C<C4::Context-E<gt>schema> twice, you will get the same handle both
-times. If you need a second database handle, use C<&new_schema> and
-possibly C<&set_schema>.
-
-=cut
-
-sub schema {
- my $self = shift;
- my $sth;
-
- if (defined($context->{"schema"}) && $context->{"schema"}->ping()) {
- return $context->{"schema"};
- }
-
- # No database handle or it died . Create one.
- $context->{"schema"} = &_new_schema();
-
- return $context->{"schema"};
-}
-
-=head2 new_schema
-
- $schema = C4::Context->new_schema;
-
-Creates a new connection to the Koha database for the current context,
-and returns the database handle (a C<DBI::db> object).
-
-The handle is not saved anywhere: this method is strictly a
-convenience function; the point is that it knows which database to
-connect to so that the caller doesn't have to know.
-
-=cut
-
-#'
-sub new_schema {
- my $self = shift;
-
- return &_new_schema();
-}
-
-=head2 set_schema
-
- $my_schema = C4::Connect->new_schema;
- C4::Connect->set_schema($my_schema);
- ...
- C4::Connect->restore_schema;
-
-C<&set_schema> and C<&restore_schema> work in a manner analogous to
-C<&set_context> and C<&restore_context>.
-
-C<&set_schema> saves the current database handle on a stack, then sets
-the current database handle to C<$my_schema>.
-
-C<$my_schema> is assumed to be a good database handle.
-
-=cut
-
-sub set_schema {
- my $self = shift;
- my $new_schema = shift;
-
- # Save the current database handle on the handle stack.
- # We assume that $new_schema is all good: if the caller wants to
- # screw himself by passing an invalid handle, that's fine by
- # us.
- push @{$context->{"schema_stack"}}, $context->{"schema"};
- $context->{"schema"} = $new_schema;
-}
-
-=head2 restore_schema
-
- C4::Context->restore_schema;
-
-Restores the database handle saved by an earlier call to
-C<C4::Context-E<gt>set_schema>.
-
-=cut
-
-sub restore_schema {
- my $self = shift;
-
- if ($#{$context->{"schema_stack"}} < 0) {
- # Stack underflow
- die "SCHEMA stack underflow";
- }
-
- # Pop the old database handle and set it.
- $context->{"schema"} = pop @{$context->{"schema_stack"}};
-
- # FIXME - If it is determined that restore_context should
- # return something, then this function should, too.
-}
-
-=head2 marcfromkohafield
-
- $dbh = C4::Context->marcfromkohafield;
-
-Returns a hash with marcfromkohafield.
-
-This hash is cached for future use: if you call
-C<C4::Context-E<gt>marcfromkohafield> 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
-C<C4::Context-E<gt>stopwords> 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;
=head2 set_userenv
- C4::Context->set_userenv($usernum, $userid, $usercnum, $userfirstname,
- $usersurname, $userbranch, $userflags, $emailaddress, $branchprinter,
- $persona);
+ C4::Context->set_userenv($usernum, $userid, $usercnum,
+ $userfirstname, $usersurname,
+ $userbranch, $branchname, $userflags,
+ $emailaddress, $shibboleth
+ $desk_id, $desk_name,
+ $register_id, $register_name);
Establish a hash of user environment variables.
#'
sub set_userenv {
- my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter, $persona)= @_;
+ shift @_;
+ 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,
"cardnumber" => $usercnum,
"firstname" => $userfirstname,
"surname" => $usersurname,
+
#possibly a law problem
- "branch" => $userbranch,
- "branchname" => $branchname,
- "flags" => $userflags,
- "emailaddress" => $emailaddress,
- "branchprinter" => $branchprinter,
- "persona" => $persona,
+ "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
# 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} ;
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
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 'api'
+ || $interface eq 'opac'
+ || $interface eq 'intranet'
+ || $interface eq 'sip'
+ || $interface eq 'cron'
+ || $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;
+}
+
+=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
Specifies the configuration file to read.
-=head1 SEE ALSO
-
-XML::Simple
-
=head1 AUTHORS
Andrew Arensburger <arensb at ooblick dot com>
Joshua Ferraro <jmf at liblime dot com>
-=cut
projects / srvgit / blobdiff