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(<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
+ <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
+ <head><title>Koha Error</title></head>
+ <body>
+ );
if ($debug_level eq "2"){
# debug 2 , print extra info too.
my %versions = get_versions();
# a little example table with various version info";
print "
- <h1>debug level $debug_level </h1>
- <p>Got an error: $msg</p>
+ <h1>Koha error</h1>
+ <p>The following fatal error has occurred:</p>
+ <pre><code>$msg</code></pre>
<table>
- <tr><th>Apache<td> $versions{apacheVersion}</tr>
- <tr><th>Koha<td> $versions{kohaVersion}</tr>
- <tr><th>MySQL<td> $versions{mysqlVersion}</tr>
- <tr><th>OS<td> $versions{osVersion}</tr>
- <tr><th>Perl<td> $versions{perlVersion}</tr>
+ <tr><th>Apache</th><td> $versions{apacheVersion}</td></tr>
+ <tr><th>Koha</th><td> $versions{kohaVersion}</td></tr>
+ <tr><th>Koha DB</th><td> $versions{kohaDbVersion}</td></tr>
+ <tr><th>MySQL</th><td> $versions{mysqlVersion}</td></tr>
+ <tr><th>OS</th><td> $versions{osVersion}</td></tr>
+ <tr><th>Perl</th><td> $versions{perlVersion}</td></tr>
</table>";
} elsif ($debug_level eq "1"){
- print "<h1>debug level $debug_level </h1>";
- print "<p>Got an error: $msg</p>";
+ print "
+ <h1>Koha error</h1>
+ <p>The following fatal error has occurred:</p>
+ <pre><code>$msg</code></pre>";
} else {
- print "production mode - trapped fatal";
+ print "<p>production mode - trapped fatal error</p>";
}
- }
- CGI::Carp->set_message(\&handle_errors);
+ print "</body></html>";
+ }
+ CGI::Carp::set_message(\&handle_errors);
+ ## give a stack backtrace if KOHA_BACKTRACES is set
+ ## can't rely on DebugLevel for this, as we're not yet connected
+ if ($ENV{KOHA_BACKTRACES}) {
+ $main::SIG{__DIE__} = \&CGI::Carp::confess;
+ }
} # else there is no browser to send fatals to!
$VERSION = '3.00.00.036';
}
use ZOOM;
use XML::Simple;
use C4::Boolean;
+use C4::Debug;
=head1 NAME
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);
+ $context = new C4::Context($conf_fname) unless $context;
return undef if !defined($context);
$context->set_context;
}
# 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.
- if (exists $ENV{"KOHA_CONF"} and $ENV{'KOHA_CONF'} and -e $ENV{"KOHA_CONF"} and -s $ENV{"KOHA_CONF"}) {
+ 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 -e $INSTALLED_CONFIG_FNAME and -s $INSTALLED_CONFIG_FNAME) {
+ } 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 (-e CONFIG_FNAME and -s CONFIG_FNAME) {
+ } elsif (-s CONFIG_FNAME) {
$conf_fname = CONFIG_FNAME;
} else {
warn "unable to locate Koha configuration file koha-conf.xml";
=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
-{
+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
+ my $dbh = C4::Context->dbh or return 0;
+
# Look up systempreferences.variable==$var
- $retval = $dbh->selectrow_array(<<EOT);
+ my $sql = <<'END_SQL';
SELECT value
FROM systempreferences
- WHERE variable='$var'
+ WHERE variable=?
LIMIT 1
-EOT
+END_SQL
+ my $retval = $dbh->selectrow_array( $sql, {}, $var );
return $retval;
}
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};
}
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) or die $DBI::errstr;
+ $db_user, $db_passwd) or die $DBI::errstr;
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)
return $cell;
}
-sub set_shelves_userenv ($) {
- my $lists = shift or return undef;
+sub set_shelves_userenv ($$) {
+ my ($type, $shelves) = @_ or return undef;
my $activeuser = $context->{activeuser} or return undef;
- $context->{userenv}->{$activeuser}->{shelves} = $lists;
- # die "set_shelves_userenv: $lists";
+ $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}}) {
- warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}";
+ $debug and warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}";
return undef;
}
- my $lists = $active->{shelves} or return undef;# die "get_shelves_userenv: activeenv has no ->{shelves}";
- return $lists;
+ 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
# A little example sub to show more debugging info for CGI::Carp
sub get_versions {
my %versions;
- $versions{kohaVersion} = C4::Context->config("kohaversion");
+ $versions{kohaVersion} = KOHAVERSION();
+ $versions{kohaDbVersion} = C4::Context->preference('version');
$versions{osVersion} = `uname -a`;
$versions{perlVersion} = $];
$versions{mysqlVersion} = `mysql -V`;
projects / koha_fer / blobdiff