X-Git-Url: http://git.rot13.org/?a=blobdiff_plain;f=C4%2FContext.pm;h=4dab9a98c52211587718fcc947ad96fab7f8b709;hb=f33e65499b0d00637dc7627c6ead4f6849cc2a96;hp=65f07596b9a58a32bd63ad048847b63cb676f2de;hpb=5ff7fcffa4b1e34c06cdb171503516b11c2350d4;p=koha.git diff --git a/C4/Context.pm b/C4/Context.pm index 65f07596b9..4dab9a98c5 100644 --- a/C4/Context.pm +++ b/C4/Context.pm @@ -16,20 +16,77 @@ package C4::Context; # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place, # Suite 330, Boston, MA 02111-1307 USA -# $Id$ 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; + 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 " +

Koha error

+

The following fatal error has occurred:

+
$msg
+ + + + + + + +
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 " +

Koha error

+

The following fatal error has occurred:

+
$msg
"; + } else { + print "

production mode - trapped fatal error

"; + } + 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), - qw($context), - qw(@context_stack); - -$VERSION = do { my @v = '$Revision$' =~ /\d+/g; - shift(@v) . "." . join("_", map {sprintf "%03d", $_ } @v); }; +use C4::Debug; +use POSIX (); =head1 NAME @@ -39,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"); @@ -54,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. @@ -75,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 @@ -91,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 @@ -100,12 +157,52 @@ 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 + +=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(); +} =item read_config_file =over 4 @@ -114,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: @@ -135,11 +232,9 @@ Returns undef in case of error. =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']); + return $koha; # Return value: ref-to-hash holding the configuration } # db_scheme2dbi @@ -158,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>. @@ -193,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); @@ -214,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; @@ -308,84 +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; # 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 ($) { @@ -395,6 +493,20 @@ 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 = (); +} + # AUTOLOAD # This implements C4::Config->foo, and simply returns # C4::Context->config("foo"), as described in the documentation for @@ -423,7 +535,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 @@ -439,11 +551,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}; } @@ -455,7 +574,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 @@ -472,21 +591,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 @@ -527,24 +647,36 @@ 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; } @@ -569,9 +701,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. @@ -735,7 +866,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; @@ -746,25 +876,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'; @@ -772,7 +899,7 @@ sub userenv $insecure{emailaddress} = 'test@mode.insecure.com'; return \%insecure; } else { - return 0; + return; } } @@ -780,18 +907,15 @@ 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{ - my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress)= @_; +sub set_userenv { + my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter)= @_; my $var=$context->{"activeuser"}; my $cell = { "number" => $usernum, @@ -799,19 +923,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, + "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. @@ -825,7 +970,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; } @@ -847,6 +992,34 @@ sub _unset_userenv } +=item get_versions + + C4::Context->get_versions + +Gets various version info, for core Koha packages, Currently called from carp handle_errors() sub, to send to browser if 'DebugLevel' syspref is set to '2'. + +=cut + +#' + +# A little example sub to show more debugging info for CGI::Carp +sub get_versions { + my %versions; + $versions{kohaVersion} = KOHAVERSION(); + $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} = `httpd2 -v` unless $versions{apacheVersion} ; + $versions{apacheVersion} = `apache2 -v` unless $versions{apacheVersion} ; + $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless $versions{apacheVersion} ; + } + return %versions; +} + 1; __END__ @@ -865,6 +1038,8 @@ Specifies the configuration file to read. =head1 SEE ALSO +XML::Simple + =head1 AUTHORS Andrew Arensburger @@ -873,7 +1048,6 @@ 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