use strict;
use warnings;
-use vars qw($VERSION $AUTOLOAD $context @context_stack);
-
-use Koha::Cache;
-
+use vars qw($VERSION $AUTOLOAD $context @context_stack $servers $memcached $ismemcached);
BEGIN {
if ($ENV{'HTTP_USER_AGENT'}) {
require CGI::Carp;
}
} # 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';
}
use C4::Debug;
use POSIX ();
use DateTime::TimeZone;
+use Module::Load::Conditional qw(can_load);
+use Carp;
=head1 NAME
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.
sub read_config_file { # Pass argument naming config file to read
my $koha = XMLin(shift, keyattr => ['id'], forcearray => ['listen', 'server', 'serverinfo'], suppressempty => '');
- if (Koha::Cache->is_cache_active()) {
- my $cache = Koha::Cache->new();
- $cache->set_in_cache('kohaconf', $koha) if defined $cache;
+ if ($ismemcached) {
+ $memcached->set('kohaconf',$koha);
}
return $koha; # Return value: ref-to-hash holding the configuration
}
-# 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"); }
+=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;
}
- return undef; # Just in case
+}
+
+=head2 db_scheme2dbi
+
+ my $dbd_driver_name = C4::Context::db_schema2dbi($scheme);
+
+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 db_scheme2dbi {
+ my $scheme = shift // '';
+ return $scheme eq 'Pg' ? $scheme : 'mysql';
}
sub import {
file, which defaults to either the file given by the C<$KOHA_CONF>
environment variable, or F</etc/koha/koha-conf.xml>.
-It saves the koha-conf.xml values in the cache (if configured) and uses
-those values until them expire and re-reads them.
+It saves the koha-conf.xml values in the declared memcached server(s)
+if currently available and uses those values until them expire and
+re-reads them.
C<&new> does not set this context as the new default context; for
that, use C<&set_context>.
$conf_fname = CONFIG_FNAME;
} else {
warn "unable to locate Koha configuration file koha-conf.xml";
- return undef;
+ return;
}
}
- if (Koha::Cache->is_cache_active()) {
- # retrieve from cache
- my $cache = Koha::Cache->new();
- $self = $cache->get_from_cache('kohaconf') if defined $cache;
- $self = { };
- }
- if (!keys %$self) {
- # not cached yet
+ 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 undef if !defined($self->{"config"});
+ return if !defined($self->{"config"});
$self->{"dbh"} = undef; # Database handle
$self->{"Zconn"} = undef; # Zebra Connections
$self->{tz} = undef; # local timezone object
bless $self, $class;
+ $self->{db_driver} = db_scheme2dbi($self->config('db_scheme')); # cache database driver
return $self;
}
=cut
-sub _common_config ($$) {
+sub _common_config {
my $var = shift;
my $term = shift;
- return undef if !defined($context->{$term});
+ return if !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
# flushing the caching mechanism.
my %sysprefs;
+my $use_syspref_cache = 1;
sub preference {
my $self = shift;
- my $var = lc(shift); # The system preference to return
- my $cache;
-
- if (exists $sysprefs{$var}) {
- return $sysprefs{$var};
- }
+ my $var = shift; # The system preference to return
- if (Koha::Cache->is_cache_active()) {
- $cache = Koha::Cache->new();
- if (defined $cache) {
- $sysprefs{$var} = $cache->get_from_cache("syspref:$var");
- return $sysprefs{$var} if (defined $sysprefs{$var});
- }
+ if ($use_syspref_cache && exists $sysprefs{lc $var}) {
+ return $sysprefs{lc $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 );
- if (Koha::Cache->is_cache_active() && defined $cache) {
- $cache->set_in_cache("syspref:$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 );
}
- return $sysprefs{$var};
+
+ $sysprefs{lc $var} = $value;
+ return $value;
}
-sub boolean_preference ($) {
+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 enable_syspref_cache
+
+ C4::Context->enable_syspref_cache();
+
+Enable the in-memory syspref cache used by C4::Context. This is the
+default behavior.
+
+=cut
+
+sub enable_syspref_cache {
+ my ($self) = @_;
+ $use_syspref_cache = 1;
+}
+
+=head2 disable_syspref_cache
+
+ C4::Context->disable_syspref_cache();
+
+Disable the in-memory syspref cache used by C4::Context. This should be
+used with Plack and other persistent environments.
+
+=cut
+
+sub disable_syspref_cache {
+ my ($self) = @_;
+ $use_syspref_cache = 0;
+ $self->clear_syspref_cache();
+}
+
=head2 clear_syspref_cache
C4::Context->clear_syspref_cache();
sub clear_syspref_cache {
%sysprefs = ();
- if (Koha::Cache->is_cache_active()) {
- my $cache = Koha::Cache->new();
- $cache->flush_all() if defined $cache; # Sorry, this is unpleasant
- }
}
=head2 set_preference
" );
if($sth->execute( $var, $value )) {
- if (Koha::Cache->is_cache_active()) {
- my $cache = Koha::Cache->new();
- $cache->set_in_cache("syspref:$var", $value) if defined $cache;
- }
$sysprefs{$var} = $value;
}
$sth->finish;
=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};
+ my ($self, $server, $async, $auth, $piggyback, $syntax) = @_;
+ #TODO: We actually just ignore the auth and syntax parameter
+ #It also looks like we are not passing auth, piggyback, syntax anywhere
+
+ my $cache_key = join ('::', (map { $_ // '' } ($server, $async, $auth, $piggyback, $syntax)));
+ if ( defined($context->{"Zconn"}->{$cache_key}) && (0 == $context->{"Zconn"}->{$cache_key}->errcode()) ) {
+ return $context->{"Zconn"}->{$cache_key};
# No connection object or it died. Create one.
}else {
# release resources if we're closing a connection and making a new one
# 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"}->{$cache_key}->destroy() if defined($context->{"Zconn"}->{$cache_key});
- $context->{"Zconn"}->{$server} = &_new_Zconn($server,$async,$auth,$piggyback,$syntax);
- return $context->{"Zconn"}->{$server};
+ $context->{"Zconn"}->{$cache_key} = &_new_Zconn( $server, $async, $piggyback );
+ return $context->{"Zconn"}->{$cache_key};
}
}
=cut
sub _new_Zconn {
- my ($server,$async,$auth,$piggyback,$syntax) = @_;
+ my ( $server, $async, $piggyback ) = @_;
my $tried=0; # first attempt
my $Zconn; # connection object
- $server = "biblioserver" unless $server;
- $syntax = "usmarc" unless $syntax;
+ my $elementSetName;
+ my $index_mode;
+ my $syntax;
+
+ $server //= "biblioserver";
+
+ if ( $server eq 'biblioserver' ) {
+ $index_mode = $context->{'config'}->{'zebra_bib_index_mode'} // 'grs1';
+ } 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';
+ }
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);
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;
}
{
## $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";
- }
+ ## 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_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",
+ 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;
+ }
+
+ 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.
sub dbh
{
my $self = shift;
+ my $params = shift;
my $sth;
- if (defined($context->{"dbh"}) && $context->{"dbh"}->ping()) {
- return $context->{"dbh"};
+ 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"};
+ }
}
# No database handle or it died . Create one.
# 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;
+}
+
=head2 marcfromkohafield
$dbh = C4::Context->marcfromkohafield;
#'
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;
}
=head2 set_userenv
C4::Context->set_userenv($usernum, $userid, $usercnum, $userfirstname,
- $usersurname, $userbranch, $userflags, $emailaddress);
+ $usersurname, $userbranch, $userflags, $emailaddress, $branchprinter,
+ $persona);
Establish a hash of user environment variables.
#'
sub set_userenv {
- my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter)= @_;
- my $var=$context->{"activeuser"};
+ my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter, $persona)= @_;
+ my $var=$context->{"activeuser"} || '';
my $cell = {
"number" => $usernum,
"id" => $userid,
"branchname" => $branchname,
"flags" => $userflags,
"emailaddress" => $emailaddress,
- "branchprinter" => $branchprinter
+ "branchprinter" => $branchprinter,
+ "persona" => $persona,
};
$context->{userenv}->{$var} = $cell;
return $cell;
}
-sub set_shelves_userenv ($$) {
- my ($type, $shelves) = @_ or return undef;
- my $activeuser = $context->{activeuser} or return undef;
+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 () {
+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 undef;
+ return;
}
my $totshelves = $active->{totshelves} or undef;
my $pubshelves = $active->{pubshelves} or undef;
}
+=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') {
+ $context->{interface} = $interface;
+ } else {
+ warn "invalid interface : '$interface'";
+ }
+ }
+
+ return $context->{interface} // 'opac';
+}
1;
__END__
projects / koha_fer / blobdiff