X-Git-Url: http://koha-dev.rot13.org:8081/gitweb/?a=blobdiff_plain;f=C4%2FContext.pm;h=926c1a5b8bb0386b4e22e3221f031310bace275b;hb=6843f5a346da3d0c0e55b7168750190c9194297b;hp=5ff2474a06c80279a8093f3727776be3ae8022d4;hpb=583baef555e2b8548598ce479957470b640b7ee9;p=srvgit diff --git a/C4/Context.pm b/C4/Context.pm index 5ff2474a06..926c1a5b8b 100644 --- a/C4/Context.pm +++ b/C4/Context.pm @@ -12,56 +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. use strict; +use warnings; +use vars qw($VERSION $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 = 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.032'; +use C4::Debug; +use POSIX (); =head1 NAME @@ -71,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"); @@ -86,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. @@ -107,7 +132,7 @@ 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 @@ -123,7 +148,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 @@ -132,8 +157,30 @@ 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 @@ -141,20 +188,18 @@ $context = undef; # Initially, no context is set =item KOHAVERSION returns the kohaversion stored in kohaversion.pl file + =cut sub KOHAVERSION { - my $cgidir = C4::Context->intranetdir ."/cgi-bin"; - - # 2 cases here : on CVS install, $cgidir does not need a /cgi-bin - # on a standard install, /cgi-bin need to be added. - # test one, then the other - # FIXME - is this all really necessary? - unless (opendir(DIR, "$cgidir/cataloguing/value_builder")) { - $cgidir = C4::Context->intranetdir; - closedir(DIR); - } + 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(); } @@ -166,7 +211,7 @@ 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: @@ -188,7 +233,7 @@ 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']); + my $koha = XMLin(shift, keyattr => ['id'], forcearray => ['listen', 'server', 'serverinfo'], suppressempty => ''); return $koha; # Return value: ref-to-hash holding the configuration } @@ -208,25 +253,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 $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>. @@ -243,13 +294,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); @@ -264,6 +326,7 @@ 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; @@ -358,78 +421,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"); + $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 or return 0; + 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 ($) { @@ -439,6 +493,51 @@ sub boolean_preference ($) { return defined($it)? C4::Boolean::true_p($it): undef; } +=item 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 = (); +} + +=item 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 @@ -467,7 +566,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 @@ -483,10 +582,18 @@ 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}; } @@ -498,7 +605,7 @@ $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 @@ -572,31 +679,34 @@ sub _new_Zconn { sub _new_dbh { -### $context - ##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"); - $db_port = "" unless defined $db_port; + 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); + $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->do("set NAMES 'utf8'") if ($dbh); $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; } @@ -622,9 +732,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. @@ -788,7 +897,6 @@ 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; @@ -799,25 +907,22 @@ sub _new_stopwords 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'; @@ -825,7 +930,7 @@ sub userenv $insecure{emailaddress} = 'test@mode.insecure.com'; return \%insecure; } else { - return 0; + return; } } @@ -833,17 +938,14 @@ sub userenv 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 = { @@ -852,20 +954,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; } +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'; +} + +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); +} + =item _new_userenv - C4::Context->_new_userenv($session); + 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. @@ -879,7 +1001,7 @@ _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; } @@ -914,14 +1036,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; } @@ -943,6 +1069,8 @@ Specifies the configuration file to read. =head1 SEE ALSO +XML::Simple + =head1 AUTHORS Andrew Arensburger