X-Git-Url: http://koha-dev.rot13.org:8081/gitweb/?a=blobdiff_plain;f=C4%2FContext.pm;h=484d4e10a8a061a0678157795314ef7008534601;hb=5bc49fe9ebada6642865175b83b9d299a11e8793;hp=98b63cb40af96bfdb0e757dfb0f367cddd9550fd;hpb=bd76a1fb0f9a07520f987646a3e1bf154d9861b1;p=koha_fer
diff --git a/C4/Context.pm b/C4/Context.pm
index 98b63cb40a..484d4e10a8 100644
--- a/C4/Context.pm
+++ b/C4/Context.pm
@@ -12,57 +12,81 @@ package C4::Context;
# 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., 59 Temple Place,
-# Suite 330, Boston, MA 02111-1307 USA
+# 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.
-# $Id$
use strict;
+use warnings;
+use vars qw($VERSION $AUTOLOAD $context @context_stack);
BEGIN {
- if ($ENV{'USER_AGENT'}) {
+ 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 = C4::Context->preference("DebugLevel");
-
+ 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 "
- debug level $debug_level
- Got an error: $msg
+ Koha error
+ The following fatal error has occurred:
+ $msg
- | Apache | $versions{apacheVersion} |
|---|
- | Koha | $versions{kohaVersion} |
|---|
- | MySQL | $versions{mysqlVersion} |
|---|
- | OS | $versions{osVersion} |
|---|
- | Perl | $versions{perlVersion} |
|---|
+ | 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 "debug level $debug_level
";
- print "Got an error: $msg
";
+ print "
+ Koha error
+ The following fatal error has occurred:
+ $msg
";
} else {
- print "production mode - trapped fatal";
+ print "production mode - trapped fatal error
";
}
- }
- CGI::Carp->set_message(\&handle_errors);
+ 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!
+ $VERSION = '3.00.00.036';
}
use DBI;
use ZOOM;
use XML::Simple;
-
use C4::Boolean;
-
-use vars qw($VERSION $AUTOLOAD $context @context_stack);
-
-$VERSION = '3.00.00.005';
+use C4::Debug;
+use POSIX ();
=head1 NAME
@@ -72,7 +96,7 @@ C4::Context - Maintain and manipulate the context of a Koha script
use C4::Context;
- use C4::Context("/path/to/koha.xml");
+ use C4::Context("/path/to/koha-conf.xml");
$config_value = C4::Context->config("config_variable");
@@ -87,7 +111,7 @@ C4::Context - Maintain and manipulate the context of a Koha script
=head1 DESCRIPTION
When a Koha script runs, it makes use of a certain number of things:
-configuration settings in F, a connection to the Koha
+configuration settings in F, a connection to the Koha
databases, and so forth. These things make up the I in which
the script runs.
@@ -108,13 +132,11 @@ different contexts to search both databases. Such scripts should use
the C<&set_context> and C<&restore_context> functions, below.
By default, C4::Context reads the configuration from
-F. This may be overridden by setting the C<$KOHA_CONF>
+F. This may be overridden by setting the C<$KOHA_CONF>
environment variable to the pathname of a configuration file to use.
=head1 METHODS
-=over 2
-
=cut
#'
@@ -124,7 +146,7 @@ environment variable to the pathname of a configuration file to use.
# config
# A reference-to-hash whose keys and values are the
# configuration variables and values specified in the config
-# file (/etc/koha.xml).
+# file (/etc/koha/koha-conf.xml).
# dbh
# A handle to the appropriate database for this context.
# dbh_stack
@@ -133,34 +155,60 @@ environment variable to the pathname of a configuration file to use.
# Zconn
# A connection object for the Zebra server
-use constant CONFIG_FNAME => "/etc/koha.xml";
+# 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
-=item KOHAVERSION
- returns the kohaversion stored in kohaversion.pl file
+=head2 KOHAVERSION
+
+returns the kohaversion stored in kohaversion.pl file
+
=cut
sub KOHAVERSION {
- my $cgidir = C4::Context->intranetdir ."/cgi-bin";
- unless (opendir(DIR, "$cgidir/cataloguing/value_builder")) {
- $cgidir = C4::Context->intranetdir;
+ 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();
}
-=item read_config_file
-
-=over 4
+=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.xml file as well as the XML::Simple documentation for details. Or,
+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:
@@ -177,15 +225,11 @@ The elements nested within the element:
Returns undef in case of error.
-=back
-
=cut
-sub read_config_file {
- my $fname = shift; # Config file to read
- my $retval = {}; # Return value: ref-to-hash holding the configuration
- my $koha = XMLin($fname, keyattr => ['id'],forcearray => ['listen', 'server', 'serverinfo']);
- return $koha;
+sub read_config_file { # Pass argument naming config file to read
+ my $koha = XMLin(shift, keyattr => ['id'], forcearray => ['listen', 'server', 'serverinfo'], suppressempty => '');
+ return $koha; # Return value: ref-to-hash holding the configuration
}
# db_scheme2dbi
@@ -204,25 +248,31 @@ sub db_scheme2dbi {
}
sub import {
- my $package = shift;
- my $conf_fname = shift; # Config file name
- my $context;
-
- # Create a new context from the given config file name, if
- # any, then set it as the current context.
- $context = new C4::Context($conf_fname);
- return undef if !defined($context);
- $context->set_context;
+ # Create the default context ($C4::Context::Context)
+ # the first time the module is called
+ # (a config file can be optionaly passed)
+
+ # default context allready exists?
+ return if $context;
+
+ # no ? so load it!
+ my ($pkg,$config_file) = @_ ;
+ my $new_ctx = __PACKAGE__->new($config_file);
+ return unless $new_ctx;
+
+ # if successfully loaded, use it by default
+ $new_ctx->set_context;
+ 1;
}
-=item new
+=head2 new
$context = new C4::Context;
- $context = new C4::Context("/path/to/koha.xml");
+ $context = new C4::Context("/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>
-environment variable, or F.
+environment variable, or F.
C<&new> does not set this context as the new default context; for
that, use C<&set_context>.
@@ -239,13 +289,24 @@ sub new {
# check that the specified config file exists and is not empty
undef $conf_fname unless
- (defined $conf_fname && -e $conf_fname && -s $conf_fname);
+ (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.
- $conf_fname = $ENV{"KOHA_CONF"} || CONFIG_FNAME;
+ 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 {
+ warn "unable to locate Koha configuration file koha-conf.xml";
+ return undef;
+ }
}
# Load the desired config file.
$self = read_config_file($conf_fname);
@@ -260,12 +321,13 @@ sub new {
$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;
bless $self, $class;
return $self;
}
-=item set_context
+=head2 set_context
$context = new C4::Context;
$context->set_context();
@@ -313,7 +375,7 @@ sub set_context
$context = $new_context;
}
-=item restore_context
+=head2 restore_context
&restore_context;
@@ -339,7 +401,7 @@ sub restore_context
# that was current when this was called?
}
-=item config
+=head2 config
$value = C4::Context->config("config_variable");
@@ -354,84 +416,69 @@ Cnew> will not return it.
=cut
-#'
-sub config
-{
- my $self = shift;
- my $var = shift; # The config variable to return
-
- return undef if !defined($context->{"config"});
- # Presumably $self->{config} might be
- # undefined if the config file given to &new
- # didn't exist, and the caller didn't bother
- # to check the return value.
+sub _common_config ($$) {
+ my $var = shift;
+ my $term = shift;
+ return undef 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
+ # to check the return value.
# Return the value of the requested config variable
- return $context->{"config"}->{$var};
+ return $context->{$term}->{$var};
}
-sub zebraconfig
-{
- my $self = shift;
- my $var = shift; # The config variable to return
-
- return undef if !defined($context->{"server"});
- # Presumably $self->{config} might be
- # undefined if the config file given to &new
- # didn't exist, and the caller didn't bother
- # to check the return value.
-
- # Return the value of the requested config variable
- return $context->{"server"}->{$var};
+sub config {
+ return _common_config($_[1],'config');
}
-sub ModZebrations
-{
- my $self = shift;
- my $var = shift; # The config variable to return
-
- return undef if !defined($context->{"serverinfo"});
- # Presumably $self->{config} might be
- # undefined if the config file given to &new
- # didn't exist, and the caller didn't bother
- # to check the return value.
-
- # Return the value of the requested config variable
- return $context->{"serverinfo"}->{$var};
+sub zebraconfig {
+ return _common_config($_[1],'server');
+}
+sub ModZebrations {
+ return _common_config($_[1],'serverinfo');
}
-=item preference
- $sys_preference = C4::Context->preference("some_variable");
+=head2 preference
+
+ $sys_preference = C4::Context->preference('some_variable');
Looks up the value of the given system preference in the
systempreferences table of the Koha database, and returns it. If the
-variable is not set, or in case of error, returns the undefined value.
+variable is not set or does not exist, undef is returned.
+
+In case of an error, this may return 0.
+
+Note: It is impossible to tell the difference between system
+preferences which do not exist, and those whose values are set to NULL
+with this method.
=cut
-#'
-# FIXME - The preferences aren't likely to change over the lifetime of
-# the script (and things might break if they did change), so perhaps
-# this function should cache the results it finds.
-sub preference
-{
+# FIXME: running this under mod_perl will require a means of
+# flushing the caching mechanism.
+
+my %sysprefs;
+
+sub preference {
my $self = shift;
- my $var = shift; # The system preference to return
- my $retval; # Return value
- my $dbh = C4::Context->dbh; # Database handle
- if ($dbh){
- my $sth; # Database query handle
+ my $var = shift; # The system preference to return
+
+ if (exists $sysprefs{$var}) {
+ return $sysprefs{$var};
+ }
+
+ my $dbh = C4::Context->dbh or return 0;
# Look up systempreferences.variable==$var
- $retval = $dbh->selectrow_array(<selectrow_array( $sql, {}, $var );
+ return $sysprefs{$var};
}
sub boolean_preference ($) {
@@ -441,6 +488,51 @@ sub boolean_preference ($) {
return defined($it)? C4::Boolean::true_p($it): undef;
}
+=head2 clear_syspref_cache
+
+ C4::Context->clear_syspref_cache();
+
+cleans the internal cache of sysprefs. Please call this method if
+you update the systempreferences table. Otherwise, your new changes
+will not be seen by this process.
+
+=cut
+
+sub clear_syspref_cache {
+ %sysprefs = ();
+}
+
+=head2 set_preference
+
+ C4::Context->set_preference( $variable, $value );
+
+This updates a preference's value both in the systempreferences table and in
+the sysprefs cache.
+
+=cut
+
+sub set_preference {
+ my $self = shift;
+ my $var = shift;
+ my $value = shift;
+
+ my $dbh = C4::Context->dbh or return 0;
+
+ my $type = $dbh->selectrow_array( "SELECT type FROM systempreferences WHERE variable = ?", {}, $var );
+
+ $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)
+ " );
+
+ $sth->execute( $var, $value );
+ $sth->finish;
+}
+
# AUTOLOAD
# This implements C4::Config->foo, and simply returns
# C4::Context->config("foo"), as described in the documentation for
@@ -459,9 +551,9 @@ sub AUTOLOAD
return $self->config($AUTOLOAD);
}
-=item Zconn
+=head2 Zconn
-$Zconn = C4::Context->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
@@ -469,7 +561,7 @@ creates one and connects.
C<$self>
-C<$server> one of the servers defined in the koha.xml file
+C<$server> one of the servers defined in the koha-conf.xml file
C<$async> whether this is a asynchronous connection
@@ -485,23 +577,30 @@ sub Zconn {
my $auth=shift;
my $piggyback=shift;
my $syntax=shift;
- if ( defined($context->{"Zconn"}->{$server}) ) {
+ 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);
return $context->{"Zconn"}->{$server};
}
}
-=item _new_Zconn
+=head2 _new_Zconn
$context->{"Zconn"} = &_new_Zconn($server,$async);
Internal function. Creates a new database connection from the data given in the current context and returns it.
-C<$server> one of the servers defined in the koha.xml file
+C<$server> one of the servers defined in the koha-conf.xml file
C<$async> whether this is a asynchronous connection
@@ -518,21 +617,22 @@ sub _new_Zconn {
$syntax = "usmarc" unless $syntax;
my $host = $context->{'listen'}->{$server}->{'content'};
- my $user = $context->{"serverinfo"}->{$server}->{"user"};
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(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(user=>$user) if $auth;
- $o->option(password=>$password) if $auth;
$o->option(databaseName => ($servername?$servername:"biblios"));
# create a new connection object
@@ -573,28 +673,40 @@ sub _new_Zconn {
# returns it.
sub _new_dbh
{
- ##correct name for db_schme
+
+ ## $context
+ ## correct name for db_schme
my $db_driver;
if ($context->config("db_scheme")){
- $db_driver=db_scheme2dbi($context->config("db_scheme"));
+ $db_driver=db_scheme2dbi($context->config("db_scheme"));
}else{
- $db_driver="mysql";
+ $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 $dbh= DBI->connect("DBI:$db_driver:$db_name:$db_host",
- $db_user, $db_passwd);
- # 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->do("set NAMES 'utf8'") if ($dbh);
- $dbh->{'mysql_enable_utf8'}=1; #enable
+ # 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) or die $DBI::errstr;
+ 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;
}
-=item dbh
+=head2 dbh
$dbh = C4::Context->dbh;
@@ -615,9 +727,8 @@ sub dbh
my $self = shift;
my $sth;
- if (defined($context->{"dbh"})) {
- $sth=$context->{"dbh"}->prepare("select 1");
- return $context->{"dbh"} if (defined($sth->execute));
+ if (defined($context->{"dbh"}) && $context->{"dbh"}->ping()) {
+ return $context->{"dbh"};
}
# No database handle or it died . Create one.
@@ -626,7 +737,7 @@ sub dbh
return $context->{"dbh"};
}
-=item new_dbh
+=head2 new_dbh
$dbh = C4::Context->new_dbh;
@@ -647,7 +758,7 @@ sub new_dbh
return &_new_dbh();
}
-=item set_dbh
+=head2 set_dbh
$my_dbh = C4::Connect->new_dbh;
C4::Connect->set_dbh($my_dbh);
@@ -678,7 +789,7 @@ sub set_dbh
$context->{"dbh"} = $new_dbh;
}
-=item restore_dbh
+=head2 restore_dbh
C4::Context->restore_dbh;
@@ -705,7 +816,7 @@ sub restore_dbh
# return something, then this function should, too.
}
-=item marcfromkohafield
+=head2 marcfromkohafield
$dbh = C4::Context->marcfromkohafield;
@@ -746,7 +857,7 @@ sub _new_marcfromkohafield
return $marcfromkohafield;
}
-=item stopwords
+=head2 stopwords
$dbh = C4::Context->stopwords;
@@ -781,36 +892,32 @@ sub _new_stopwords
my $sth = $dbh->prepare("select word from stopwords");
$sth->execute;
while (my $stopword = $sth->fetchrow_array) {
- my $retval = {};
$stopwordlist->{$stopword} = uc($stopword);
}
$stopwordlist->{A} = "A" unless $stopwordlist;
return $stopwordlist;
}
-=item userenv
+=head2 userenv
C4::Context->userenv;
-Builds a hash for user environment variables.
+Retrieves a hash for user environment variables.
This hash shall be cached for future use: if you call
Cuserenv> twice, you will get the same hash without real DB access
-set_userenv is called in Auth.pm
-
=cut
#'
-sub userenv
-{
+sub userenv {
my $var = $context->{"activeuser"};
- return $context->{"userenv"}->{$var} if (defined $context->{"userenv"}->{$var});
+ return $context->{"userenv"}->{$var} if (defined $var and defined $context->{"userenv"}->{$var});
# insecure=1 management
if ($context->{"dbh"} && $context->preference('insecure')) {
my %insecure;
$insecure{flags} = '16382';
- $insecure{branchname} ='Insecure',
+ $insecure{branchname} ='Insecure';
$insecure{number} ='0';
$insecure{cardnumber} ='0';
$insecure{id} = 'insecure';
@@ -818,25 +925,23 @@ sub userenv
$insecure{emailaddress} = 'test@mode.insecure.com';
return \%insecure;
} else {
- return 0;
+ return;
}
}
-=item set_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, $userflags, $emailaddress);
-Informs a hash for user environment variables.
-
-This hash shall be cached for future use: if you call
-Cuserenv> twice, you will get the same hash without real DB access
+Establish a hash of user environment variables.
set_userenv is called in Auth.pm
=cut
#'
-sub set_userenv{
+sub set_userenv {
my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter)= @_;
my $var=$context->{"activeuser"};
my $cell = {
@@ -845,20 +950,40 @@ sub set_userenv{
"cardnumber" => $usercnum,
"firstname" => $userfirstname,
"surname" => $usersurname,
-#possibly a law problem
+ #possibly a law problem
"branch" => $userbranch,
"branchname" => $branchname,
"flags" => $userflags,
- "emailaddress" => $emailaddress,
- "branchprinter" => $branchprinter
+ "emailaddress" => $emailaddress,
+ "branchprinter" => $branchprinter
};
$context->{userenv}->{$var} = $cell;
return $cell;
}
-=item _new_userenv
+sub set_shelves_userenv ($$) {
+ my ($type, $shelves) = @_ or return undef;
+ my $activeuser = $context->{activeuser} or return undef;
+ $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';
+}
- C4::Context->_new_userenv($session);
+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;
+ }
+ 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
Builds a hash for user environment variables.
@@ -872,12 +997,12 @@ _new_userenv is called in Auth.pm
#'
sub _new_userenv
{
- shift;
+ shift; # Useless except it compensates for bad calling style
my ($sessionID)= @_;
$context->{"activeuser"}=$sessionID;
}
-=item _unset_userenv
+=head2 _unset_userenv
C4::Context->_unset_userenv;
@@ -894,7 +1019,7 @@ sub _unset_userenv
}
-=item get_versions
+=head2 get_versions
C4::Context->get_versions
@@ -907,14 +1032,18 @@ 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} = C4::Context->config("kohaversion");
- $versions{osVersion} = `uname -a`;
+ $versions{kohaVersion} = KOHAVERSION();
+ $versions{kohaDbVersion} = C4::Context->preference('version');
+ $versions{osVersion} = join(" ", POSIX::uname());
$versions{perlVersion} = $];
- $versions{mysqlVersion} = `mysql -V`;
- $versions{apacheVersion} = `httpd -v`;
- $versions{apacheVersion} = `httpd2 -v` unless $versions{apacheVersion} ;
- $versions{apacheVersion} = `apache2 -v` unless $versions{apacheVersion} ;
- $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless $versions{apacheVersion} ;
+ {
+ no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
+ $versions{mysqlVersion} = `mysql -V`;
+ $versions{apacheVersion} = `httpd -v`;
+ $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;
}
@@ -922,20 +1051,16 @@ sub get_versions {
1;
__END__
-=back
-
=head1 ENVIRONMENT
-=over 4
-
-=item C
+=head2 C
Specifies the configuration file to read.
-=back
-
=head1 SEE ALSO
+XML::Simple
+
=head1 AUTHORS
Andrew Arensburger
@@ -943,218 +1068,3 @@ Andrew Arensburger
Joshua Ferraro
=cut
-
-# $Log$
-# Revision 1.57 2007/05/22 09:13:55 tipaul
-# Bugfixes & improvements (various and minor) :
-# - updating templates to have tmpl_process3.pl running without any errors
-# - adding a drupal-like css for prog templates (with 3 small images)
-# - fixing some bugs in circulation & other scripts
-# - updating french translation
-# - fixing some typos in templates
-#
-# Revision 1.56 2007/04/23 15:21:17 tipaul
-# renaming currenttransfers to transferstoreceive
-#
-# Revision 1.55 2007/04/17 08:48:00 tipaul
-# circulation cleaning continued: bufixing
-#
-# Revision 1.54 2007/03/29 16:45:53 tipaul
-# Code cleaning of Biblio.pm (continued)
-#
-# All subs have be cleaned :
-# - removed useless
-# - merged some
-# - reordering Biblio.pm completly
-# - using only naming conventions
-#
-# Seems to have broken nothing, but it still has to be heavily tested.
-# Note that Biblio.pm is now much more efficient than previously & probably more reliable as well.
-#
-# Revision 1.53 2007/03/29 13:30:31 tipaul
-# Code cleaning :
-# == Biblio.pm cleaning (useless) ==
-# * some sub declaration dropped
-# * removed modbiblio sub
-# * removed moditem sub
-# * removed newitems. It was used only in finishrecieve. Replaced by a TransformKohaToMarc+AddItem, that is better.
-# * removed MARCkoha2marcItem
-# * removed MARCdelsubfield declaration
-# * removed MARCkoha2marcBiblio
-#
-# == Biblio.pm cleaning (naming conventions) ==
-# * MARCgettagslib renamed to GetMarcStructure
-# * MARCgetitems renamed to GetMarcItem
-# * MARCfind_frameworkcode renamed to GetFrameworkCode
-# * MARCmarc2koha renamed to TransformMarcToKoha
-# * MARChtml2marc renamed to TransformHtmlToMarc
-# * MARChtml2xml renamed to TranformeHtmlToXml
-# * zebraop renamed to ModZebra
-#
-# == MARC=OFF ==
-# * removing MARC=OFF related scripts (in cataloguing directory)
-# * removed checkitems (function related to MARC=off feature, that is completly broken in head. If someone want to reintroduce it, hard work coming...)
-# * removed getitemsbybiblioitem (used only by MARC=OFF scripts, that is removed as well)
-#
-# Revision 1.52 2007/03/16 01:25:08 kados
-# Using my precrash CVS copy I did the following:
-#
-# cvs -z3 -d:ext:kados@cvs.savannah.nongnu.org:/sources/koha co -P koha
-# find koha.precrash -type d -name "CVS" -exec rm -v {} \;
-# cp -r koha.precrash/* koha/
-# cd koha/
-# cvs commit
-#
-# This should in theory put us right back where we were before the crash
-#
-# Revision 1.52 2007/03/12 21:17:05 rych
-# add server, serverinfo as arrays from config
-#
-# Revision 1.51 2007/03/09 14:31:47 tipaul
-# rel_3_0 moved to HEAD
-#
-# Revision 1.43.2.10 2007/02/09 17:17:56 hdl
-# Managing a little better database absence.
-# (preventing from BIG 550)
-#
-# Revision 1.43.2.9 2006/12/20 16:50:48 tipaul
-# improving "insecure" management
-#
-# WARNING KADOS :
-# you told me that you had some libraries with insecure=ON (behind a firewall).
-# In this commit, I created a "fake" user when insecure=ON. It has a fake branch. You may find better to have the 1st branch in branch table instead of a fake one.
-#
-# Revision 1.43.2.8 2006/12/19 16:48:16 alaurin
-# reident programs, and adding branchcode value in reserves
-#
-# Revision 1.43.2.7 2006/12/06 21:55:38 hdl
-# Adding ModZebrations for servers to get serverinfos in Context.pm
-# Using this function in rebuild_zebra.pl
-#
-# Revision 1.43.2.6 2006/11/24 21:18:31 kados
-# very minor changes, no functional ones, just comments, etc.
-#
-# Revision 1.43.2.5 2006/10/30 13:24:16 toins
-# fix some minor POD error.
-#
-# Revision 1.43.2.4 2006/10/12 21:42:49 hdl
-# Managing multiple zebra connections
-#
-# Revision 1.43.2.3 2006/10/11 14:27:26 tipaul
-# removing a warning
-#
-# Revision 1.43.2.2 2006/10/10 15:28:16 hdl
-# BUG FIXING : using database name in Zconn if defined and not hard coded value
-#
-# Revision 1.43.2.1 2006/10/06 13:47:28 toins
-# Synch with dev_week.
-# /!\ WARNING :: Please now use the new version of koha.xml.
-#
-# Revision 1.18.2.5.2.14 2006/09/24 15:24:06 kados
-# remove Zebraauth routine, fold the functionality into Zconn
-# Zconn can now take several arguments ... this will probably
-# change soon as I'm not completely happy with the readability
-# of the current format ... see the POD for details.
-#
-# cleaning up Biblio.pm, removing unnecessary routines.
-#
-# DeleteBiblio - used to delete a biblio from zebra and koha tables
-# -- checks to make sure there are no existing issues
-# -- saves backups of biblio,biblioitems,items in deleted* tables
-# -- does commit operation
-#
-# getRecord - used to retrieve one record from zebra in piggyback mode using biblionumber
-# brought back z3950_extended_services routine
-#
-# Lots of modifications to Context.pm, you can now store user and pass info for
-# multiple servers (for federated searching) using the element.
-# I'll commit my koha.xml to demonstrate this or you can refer to the POD in
-# Context.pm (which I also expanded on).
-#
-# Revision 1.18.2.5.2.13 2006/08/10 02:10:21 kados
-# Turned warnings on, and running a search turned up lots of warnings.
-# Cleaned up those ...
-#
-# removed getitemtypes from Koha.pm (one in Search.pm looks newer)
-# removed itemcount from Biblio.pm
-#
-# made some local subs local with a _ prefix (as they were redefined
-# elsewhere)
-#
-# Add two new search subs to Search.pm the start of a new search API
-# that's a bit more scalable
-#
-# Revision 1.18.2.5.2.10 2006/07/21 17:50:51 kados
-# moving the *.properties files to intranetdir/etc dir
-#
-# Revision 1.18.2.5.2.9 2006/07/17 08:05:20 tipaul
-# there was a hardcoded link to /koha/etc/ I replaced it with intranetdir config value
-#
-# Revision 1.18.2.5.2.8 2006/07/11 12:20:37 kados
-# adding ccl and cql files ... Tumer, if you want to fit these into the
-# config file by all means do.
-#
-# Revision 1.18.2.5.2.7 2006/06/04 22:50:33 tgarip1957
-# We do not hard code cql2rpn conversion file in context.pm our koha.xml configuration file already describes the path for this file.
-# At cql searching we use method CQL not CQL2RPN as the cql2rpn conversion file is defined at server level
-#
-# Revision 1.18.2.5.2.6 2006/06/02 23:11:24 kados
-# Committing my working dev_week. It's been tested only with
-# searching, and there's quite a lot of config stuff to set up
-# beforehand. As things get closer to a release, we'll be making
-# some scripts to do it for us
-#
-# Revision 1.18.2.5.2.5 2006/05/28 18:49:12 tgarip1957
-# This is an unusual commit. The main purpose is a working model of Zebra on a modified rel2_2.
-# Any questions regarding these commits should be asked to Joshua Ferraro unless you are Joshua whom I'll report to
-#
-# Revision 1.36 2006/05/09 13:28:08 tipaul
-# adding the branchname and the librarian name in every page :
-# - modified userenv to add branchname
-# - modifier menus.inc to have the librarian name & userenv displayed on every page. they are in a librarian_information div.
-#
-# Revision 1.35 2006/04/13 08:40:11 plg
-# bug fixed: typo on Zconnauth name
-#
-# Revision 1.34 2006/04/10 21:40:23 tgarip1957
-# A new handler defined for zebra Zconnauth with read/write permission. Zconnauth should only be called in biblio.pm where write operations are. Use of this handler will break things unless koha.conf contains new variables:
-# zebradb=localhost
-# zebraport=
-# zebrauser=
-# zebrapass=
-#
-# The zebra.cfg file should read:
-# perm.anonymous:r
-# perm.username:rw
-# passw.c:
-#
-# Password file should be prepared with Apaches htpasswd utility in encrypted mode and should exist in a folder zebra.cfg can read
-#
-# Revision 1.33 2006/03/15 11:21:56 plg
-# bug fixed: utf-8 data where not displayed correctly in screens. Supposing
-# your data are truely utf-8 encoded in your database, they should be
-# correctly displayed. "set names 'UTF8'" on mysql connection (C4/Context.pm)
-# is mandatory and "binmode" to utf8 (C4/Interface/CGI/Output.pm) seemed to
-# converted data twice, so it was removed.
-#
-# Revision 1.32 2006/03/03 17:25:01 hdl
-# Bug fixing : a line missed a comment sign.
-#
-# Revision 1.31 2006/03/03 16:45:36 kados
-# Remove the search that tests the Zconn -- warning, still no fault
-# tollerance
-#
-# Revision 1.30 2006/02/22 00:56:59 kados
-# First go at a connection object for Zebra. You can now get a
-# connection object by doing:
-#
-# my $Zconn = C4::Context->Zconn;
-#
-# My initial tests indicate that as soon as your funcion ends
-# (ie, when you're done doing something) the connection will be
-# closed automatically. There may be some other way to make the
-# connection more stateful, I'm not sure...
-#
-# Local Variables:
-# tab-width: 4
-# End: