X-Git-Url: http://git.rot13.org/?a=blobdiff_plain;f=C4%2FContext.pm;h=2f2bc96c17635ecc584d6d0f9d8868bb3244dc0f;hb=b6e62489d8dc749db077ccb86ea29f4ae7b91fa6;hp=c9fe24918985f7a4adea32beb75c6c46a7abf063;hpb=cc9524a875d8b032a40fa943de3973d4c93854bf;p=koha.git diff --git a/C4/Context.pm b/C4/Context.pm index c9fe249189..2f2bc96c17 100644 --- a/C4/Context.pm +++ b/C4/Context.pm @@ -1,3 +1,4 @@ +package C4::Context; # Copyright 2002 Katipo Communications # # This file is part of Koha. @@ -15,18 +16,77 @@ # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place, # Suite 330, Boston, MA 02111-1307 USA -# $Id$ -package C4::Context; 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 C4::Boolean; +use ZOOM; use XML::Simple; -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::Boolean; +use C4::Debug; +use POSIX (); =head1 NAME @@ -36,17 +96,23 @@ 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"); + + $koha_preference = C4::Context->preference("preference"); + $db_handle = C4::Context->dbh; + + $Zconn = C4::Context->Zconn; + $stopwordhash = C4::Context->stopwords; =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 -database, and so forth. These things make up the I in which +configuration settings in F, a connection to the Koha +databases, and so forth. These things make up the I in which the script runs. This module takes care of setting up the context for a script: @@ -66,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 @@ -80,87 +146,138 @@ environment variable to the pathname of a configuration file to use. # reference-to-hash with the following fields: # # config -# A reference-to-hash whose keys and values are the -# configuration variables and values specified in the config -# file (/etc/koha.xml). +# A reference-to-hash whose keys and values are the +# configuration variables and values specified in the config +# file (/etc/koha/koha-conf.xml). # dbh -# A handle to the appropriate database for this context. +# A handle to the appropriate database for this context. # dbh_stack -# Used by &set_dbh and &restore_dbh to hold other database -# handles for this context. +# Used by &set_dbh and &restore_dbh to hold other database +# handles for this context. # Zconn -# A connection object for the Zebra server +# A connection object for the Zebra server -use constant CONFIG_FNAME => "/etc/koha.xml"; - # Default config file, if none is specified +# 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. -$context = undef; # Initially, no context is set -@context_stack = (); # Initially, no saved contexts +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 -# read_config_file -# Reads the specified Koha config file. Returns a reference-to-hash -# whose keys are the configuration variables, and whose values are the -# configuration values (duh). -# Returns undef in case of error. -# -# Revision History: -# 2004-08-10 A. Tarallo: Added code that checks if a variable is already -# assigned and prints a message, otherwise create a new entry in the hash to -# be returned. -# Also added code that complaints if finds a line that isn't a variable -# assignmet and skips the line. -# Added a quick hack that makes the translation between the db_schema -# and the DBI driver for that schema. -# -sub read_config_file -{ - my $fname = shift; # Config file to read +$context = undef; # Initially, no context is set +@context_stack = (); # Initially, no saved contexts - my $retval = {}; # Return value: ref-to-hash holding the - # configuration -my $koha = XMLin($fname, keyattr => ['id'],forcearray => ['listen']); +=item KOHAVERSION + returns the kohaversion stored in kohaversion.pl file - return $koha; +=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 + +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-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: + + my $pass = $koha->{'config'}->{'pass'}; + +The elements: + + my $listen = $koha->{'listen'}->{'biblioserver'}->{'content'}; + +The elements nested within the element: + + my $ccl2rpn = $koha->{'server'}->{'biblioserver'}->{'cql2rpn'}; + +Returns undef in case of error. + +=back + +=cut + +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 # Translates the full text name of a database into de appropiate dbi name # -sub db_scheme2dbi -{ - my $name = shift; +sub db_scheme2dbi { + my $name = shift; - for ($name) { + for ($name) { # FIXME - Should have other databases. - if (/mysql/i) { return("mysql"); } - if (/Postgres|Pg|PostgresSQL/) { return("Pg"); } - if (/oracle/i) { return("Oracle"); } - } - return undef; # Just in case + if (/mysql/i) { return("mysql"); } + if (/Postgres|Pg|PostgresSQL/) { return("Pg"); } + if (/oracle/i) { return("Oracle"); } + } + return undef; # Just in case } -sub import -{ - my $package = shift; - my $conf_fname = shift; # Config file name - my $context; +sub import { + # Create the default context ($C4::Context::Context) + # the first time the module is called + # (a config file can be optionaly passed) - # 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; + # 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.conf"); + $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>. @@ -170,41 +287,49 @@ that, use C<&set_context>. #' # Revision History: # 2004-08-10 A. Tarallo: Added check if the conf file is not empty -sub new -{ - my $class = shift; - my $conf_fname = shift; # Config file to load - my $self = {}; - - # check that the specified config file exists and is not empty - undef $conf_fname unless - (defined $conf_fname && -e $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; - } - # Load the desired config 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"}); - - $self->{"dbh"} = undef; # Database handle - $self->{"Zconn"} = undef; # Zebra Connection - $self->{"Zconnauth"} = undef; # Zebra Connection for updating - $self->{"stopwords"} = undef; # stopwords list - $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 - - bless $self, $class; - return $self; +sub new { + my $class = shift; + my $conf_fname = shift; # Config file to load + my $self = {}; + + # check that the specified config file exists and is not empty + undef $conf_fname unless + (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 -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); + $self->{"config_file"} = $conf_fname; + + warn "read_config_file($conf_fname) returned undef" if !defined($self->{"config"}); + return undef if !defined($self->{"config"}); + + $self->{"dbh"} = undef; # Database handle + $self->{"Zconn"} = undef; # Zebra Connections + $self->{"stopwords"} = undef; # stopwords list + $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 @@ -227,32 +352,32 @@ operations. To restore the previous context, use C<&restore_context>. #' sub set_context { - my $self = shift; - my $new_context; # The context to set - - # Figure out whether this is a class or instance method call. - # - # We're going to make the assumption that control got here - # through valid means, i.e., that the caller used an instance - # or class method call, and that control got here through the - # usual inheritance mechanisms. The caller can, of course, - # break this assumption by playing silly buggers, but that's - # harder to do than doing it properly, and harder to check - # for. - if (ref($self) eq "") - { - # Class method. The new context is the next argument. - $new_context = shift; - } else { - # Instance method. The new context is $self. - $new_context = $self; - } - - # Save the old context, if any, on the stack - push @context_stack, $context if defined($context); - - # Set the new context - $context = $new_context; + my $self = shift; + my $new_context; # The context to set + + # Figure out whether this is a class or instance method call. + # + # We're going to make the assumption that control got here + # through valid means, i.e., that the caller used an instance + # or class method call, and that control got here through the + # usual inheritance mechanisms. The caller can, of course, + # break this assumption by playing silly buggers, but that's + # harder to do than doing it properly, and harder to check + # for. + if (ref($self) eq "") + { + # Class method. The new context is the next argument. + $new_context = shift; + } else { + # Instance method. The new context is $self. + $new_context = $self; + } + + # Save the old context, if any, on the stack + push @context_stack, $context if defined($context); + + # Set the new context + $context = $new_context; } =item restore_context @@ -266,19 +391,19 @@ Restores the context set by C<&set_context>. #' sub restore_context { - my $self = shift; + my $self = shift; - if ($#context_stack < 0) - { - # Stack underflow. - die "Context stack underflow"; - } + if ($#context_stack < 0) + { + # Stack underflow. + die "Context stack underflow"; + } - # Pop the old context and set it. - $context = pop @context_stack; + # Pop the old context and set it. + $context = pop @context_stack; - # FIXME - Should this return something, like maybe the context - # that was current when this was called? + # FIXME - Should this return something, like maybe the context + # that was current when this was called? } =item config @@ -296,74 +421,90 @@ 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. - - # Return the value of the requested config variable - return $context->{"config"}->{$var}; +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->{$term}->{$var}; } -=item zebraconfig -$serverdir=C4::Context->zebraconfig("biblioserver")->{directory}; - -returns the zebra server specific details for different zebra servers -similar to C4:Context->config -=cut -sub zebraconfig -{ - my $self = shift; - my $var = shift; # The config variable to return - - return undef if !defined($context->{"server"}); - # Return the value of the requested config variable - return $context->{"server"}->{$var}; +sub config { + return _common_config($_[1],'config'); +} +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 -{ - my $self = shift; - my $var = shift; # The system preference to return - my $retval; # Return value - my $dbh = C4::Context->dbh; # Database handle - my $sth; # Database query handle - - # Look up systempreferences.variable==$var - $retval = $dbh->selectrow_array(<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 ); + return $sysprefs{$var}; } 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; + 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; +} + +=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 @@ -377,141 +518,166 @@ sub boolean_preference ($) { # encourage people to use it. sub AUTOLOAD { - my $self = shift; + my $self = shift; - $AUTOLOAD =~ s/.*:://; # Chop off the package name, - # leaving only the function name. - return $self->config($AUTOLOAD); + $AUTOLOAD =~ s/.*:://; # Chop off the package name, + # leaving only the function name. + return $self->config($AUTOLOAD); } =item Zconn $Zconn = C4::Context->Zconn -$Zconnauth = C4::Context->Zconnauth + Returns a connection to the Zebra database for the current context. If no connection has yet been made, this method creates one and connects. +C<$self> + +C<$server> one of the servers defined in the koha-conf.xml file + +C<$async> whether this is a asynchronous connection + +C<$auth> whether this connection has rw access (1) or just r access (0 or NULL) + + =cut sub Zconn { - my $self = shift; -my $server=shift; - my $Zconn; - if (defined($context->{"Zconn"})) { - $Zconn = $context->{"Zconn"}; - return $context->{"Zconn"}; - } else { - $context->{"Zconn"} = &new_Zconn($server); - return $context->{"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}; + # 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}; + } } -sub Zconnauth { - my $self = shift; -my $server=shift; - my $Zconnauth; - if (defined($context->{"Zconnauth"})) { - $Zconnauth = $context->{"Zconnauth"}; - return $context->{"Zconnauth"}; - } else { - $context->{"Zconnauth"} = &new_Zconnauth($server); - return $context->{"Zconnauth"}; - } -} +=item _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. -=item new_Zconn +C<$server> one of the servers defined in the koha-conf.xml file -Internal helper function. creates a new database connection from -the data given in the current context and returns it. +C<$async> whether this is a asynchronous connection + +C<$auth> whether this connection has rw access (1) or just r access (0 or NULL) =cut -sub new_Zconn { -use ZOOM; -my $server=shift; -my $tried=0; -my $Zconn; -my ($tcp,$host,$port)=split /:/,$context->{"listen"}->{$server}->{"content"}; - -retry: - eval { - $Zconn=new ZOOM::Connection($context->config("hostname"),$port,databaseName=>$context->{"config"}->{$server}, - preferredRecordSyntax => "USmarc",elementSetName=> "F"); - }; - if ($@){ -###Uncomment the lines below if you want to automatically restart your zebra if its stop -###The system call is for Windows it should be changed to unix deamon starting for Unix platforms -# if ($@->code==10000 && $tried==0){ ##No connection try restarting Zebra -# $tried==1; -# my $res=system('sc start "Z39.50 Server" >c:/zebraserver/error.log'); -# goto "retry"; -# }else{ - warn "Error ", $@->code(), ": ", $@->message(), "\n"; - $Zconn="error"; - return $Zconn; -# } - } - - return $Zconn; -} +sub _new_Zconn { + my ($server,$async,$auth,$piggyback,$syntax) = @_; + + my $tried=0; # first attempt + my $Zconn; # connection object + $server = "biblioserver" unless $server; + $syntax = "usmarc" unless $syntax; + + 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(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")); + + # create a new connection object + $Zconn= create ZOOM::Connection($o); + + # forge to server + $Zconn->connect($host, 0); + + # check for errors and warn + if ($Zconn->errcode() !=0) { + warn "something wrong with the connection: ". $Zconn->errmsg(); + } -## Zebra handler with write permission -sub new_Zconnauth { -use ZOOM; -my $server=shift; -my $tried=0; -my $Zconnauth; -my ($tcp,$host,$port)=split /:/,$context->{"listen"}->{$server}->{"content"}; -retry: -eval{ - $Zconnauth=new ZOOM::Connection($context->config("hostname"),$port,databaseName=>$context->{"config"}->{$server}, - user=>$context->{"config"}->{"zebrauser"}, - password=>$context->{"config"}->{"zebrapass"},preferredRecordSyntax => "USmarc",elementSetName=> "F"); -}; - if ($@){ -###Uncomment the lines below if you want to automatically restart your zebra if its stop -###The system call is for Windows it should be changed to unix deamon starting for Unix platforms -# if ($@->code==10000 && $tried==0){ ##No connection try restarting Zebra -# $tried==1; -# my $res=system('sc start "Z39.50 Server" >c:/zebraserver/error.log'); -# goto "retry"; -# }else{ - warn "Error ", $@->code(), ": ", $@->message(), "\n"; - $Zconnauth="error"; - return $Zconnauth; -# } - } - return $Zconnauth; + }; +# 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; } - # _new_dbh # Internal helper function (not a method!). This creates a new # database connection from the data given in the current context, and # returns it. sub _new_dbh { - ##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"; - } - my $db_name = $context->config("database"); - my $db_host = $context->config("hostname"); - 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'"); - return $dbh; + ## $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"; + } + + 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"); + # 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 @@ -532,18 +698,17 @@ possibly C<&set_dbh>. #' sub dbh { - my $self = shift; - my $sth; + 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. - $context->{"dbh"} = &_new_dbh(); + # No database handle or it died . Create one. + $context->{"dbh"} = &_new_dbh(); - return $context->{"dbh"}; + return $context->{"dbh"}; } =item new_dbh @@ -562,9 +727,9 @@ connect to so that the caller doesn't have to know. #' sub new_dbh { - my $self = shift; + my $self = shift; - return &_new_dbh(); + return &_new_dbh(); } =item set_dbh @@ -587,15 +752,15 @@ C<$my_dbh> is assumed to be a good database handle. #' sub set_dbh { - my $self = shift; - my $new_dbh = shift; - - # Save the current database handle on the handle stack. - # We assume that $new_dbh is all good: if the caller wants to - # screw himself by passing an invalid handle, that's fine by - # us. - push @{$context->{"dbh_stack"}}, $context->{"dbh"}; - $context->{"dbh"} = $new_dbh; + my $self = shift; + my $new_dbh = shift; + + # Save the current database handle on the handle stack. + # We assume that $new_dbh is all good: if the caller wants to + # screw himself by passing an invalid handle, that's fine by + # us. + push @{$context->{"dbh_stack"}}, $context->{"dbh"}; + $context->{"dbh"} = $new_dbh; } =item restore_dbh @@ -610,19 +775,19 @@ Cset_dbh>. #' sub restore_dbh { - my $self = shift; + my $self = shift; - if ($#{$context->{"dbh_stack"}} < 0) - { - # Stack underflow - die "DBH stack underflow"; - } + if ($#{$context->{"dbh_stack"}} < 0) + { + # Stack underflow + die "DBH stack underflow"; + } - # Pop the old database handle and set it. - $context->{"dbh"} = pop @{$context->{"dbh_stack"}}; + # Pop the old database handle and set it. + $context->{"dbh"} = pop @{$context->{"dbh_stack"}}; - # FIXME - If it is determined that restore_context should - # return something, then this function should, too. + # FIXME - If it is determined that restore_context should + # return something, then this function should, too. } =item marcfromkohafield @@ -639,15 +804,15 @@ Cmarcfromkohafield> twice, you will get the same hash without #' sub marcfromkohafield { - my $retval = {}; + my $retval = {}; - # If the hash already exists, return it. - return $context->{"marcfromkohafield"} if defined($context->{"marcfromkohafield"}); + # If the hash already exists, return it. + return $context->{"marcfromkohafield"} if defined($context->{"marcfromkohafield"}); - # No hash. Create one. - $context->{"marcfromkohafield"} = &_new_marcfromkohafield(); + # No hash. Create one. + $context->{"marcfromkohafield"} = &_new_marcfromkohafield(); - return $context->{"marcfromkohafield"}; + return $context->{"marcfromkohafield"}; } # _new_marcfromkohafield @@ -655,15 +820,15 @@ sub marcfromkohafield # hash with stopwords sub _new_marcfromkohafield { - my $dbh = C4::Context->dbh; - my $marcfromkohafield; - my $sth = $dbh->prepare("select frameworkcode,kohafield,tagfield,tagsubfield from marc_subfield_structure where kohafield > ''"); - $sth->execute; - while (my ($frameworkcode,$kohafield,$tagfield,$tagsubfield) = $sth->fetchrow) { - my $retval = {}; - $marcfromkohafield->{$frameworkcode}->{$kohafield} = [$tagfield,$tagsubfield]; - } - return $marcfromkohafield; + my $dbh = C4::Context->dbh; + my $marcfromkohafield; + my $sth = $dbh->prepare("select frameworkcode,kohafield,tagfield,tagsubfield from marc_subfield_structure where kohafield > ''"); + $sth->execute; + while (my ($frameworkcode,$kohafield,$tagfield,$tagsubfield) = $sth->fetchrow) { + my $retval = {}; + $marcfromkohafield->{$frameworkcode}->{$kohafield} = [$tagfield,$tagsubfield]; + } + return $marcfromkohafield; } =item stopwords @@ -680,15 +845,15 @@ Cstopwords> twice, you will get the same hash without real DB #' sub stopwords { - my $retval = {}; + my $retval = {}; - # If the hash already exists, return it. - return $context->{"stopwords"} if defined($context->{"stopwords"}); + # If the hash already exists, return it. + return $context->{"stopwords"} if defined($context->{"stopwords"}); - # No hash. Create one. - $context->{"stopwords"} = &_new_stopwords(); + # No hash. Create one. + $context->{"stopwords"} = &_new_stopwords(); - return $context->{"stopwords"}; + return $context->{"stopwords"}; } # _new_stopwords @@ -696,16 +861,16 @@ sub stopwords # hash with stopwords sub _new_stopwords { - my $dbh = C4::Context->dbh; - my $stopwordlist; - 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; + my $dbh = C4::Context->dbh; + my $stopwordlist; + 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 @@ -724,10 +889,22 @@ set_userenv is called in Auth.pm #' sub userenv { - my $var = $context->{"activeuser"}; - return $context->{"userenv"}->{$var} if (defined $context->{"userenv"}->{$var}); - return 0; - warn "NO CONTEXT for $var"; + 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')) { + 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; + } else { + return; + } } =item set_userenv @@ -742,25 +919,46 @@ Cuserenv> twice, you will get the same hash without real DB ac set_userenv is called in Auth.pm =cut + #' sub set_userenv{ - my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress,$branchprinter)= @_; - my $var=$context->{"activeuser"}; - my $cell = { - "number" => $usernum, - "id" => $userid, - "cardnumber" => $usercnum, -# "firstname" => $userfirstname, -# "surname" => $usersurname, -#possibly a law problem - "branch" => $userbranch, - "branchname" => $branchname, - "flags" => $userflags, - "emailaddress" => $emailaddress, - "branchprinter" => $branchprinter, - }; - $context->{userenv}->{$var} = $cell; - return $cell; + my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter)= @_; + my $var=$context->{"activeuser"}; + my $cell = { + "number" => $usernum, + "id" => $userid, + "cardnumber" => $usercnum, + "firstname" => $userfirstname, + "surname" => $usersurname, + #possibly a law problem + "branch" => $userbranch, + "branchname" => $branchname, + "flags" => $userflags, + "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 @@ -779,9 +977,9 @@ _new_userenv is called in Auth.pm #' sub _new_userenv { - shift; - my ($sessionID)= @_; - $context->{"activeuser"}=$sessionID; + shift; + my ($sessionID)= @_; + $context->{"activeuser"}=$sessionID; } =item _unset_userenv @@ -791,15 +989,44 @@ sub _new_userenv Destroys the hash for activeuser user environment variables. =cut + #' sub _unset_userenv { - my ($sessionID)= @_; - undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID); + my ($sessionID)= @_; + undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID); } +=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__ @@ -818,39 +1045,178 @@ Specifies the configuration file to read. =head1 SEE ALSO -DBI(3) +XML::Simple -=head1 AUTHOR +=head1 AUTHORS Andrew Arensburger +Joshua Ferraro + =cut -# $Log$ -# Revision 1.42 2006/07/04 14:36:51 toins -# Head & rel_2_2 merged + +# 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) # -# Revision 1.41 2006/05/20 14:36:09 tgarip1957 -# Typo error. Missing '>' +# Add two new search subs to Search.pm the start of a new search API +# that's a bit more scalable # -# Revision 1.40 2006/05/20 14:28:02 tgarip1957 -# Adding support to read zebra database name from config files +# Revision 1.18.2.5.2.10 2006/07/21 17:50:51 kados +# moving the *.properties files to intranetdir/etc dir # -# Revision 1.39 2006/05/19 09:52:54 alaurin -# committing new feature ip and printer management -# adding two fields in branches table (branchip,branchprinter) +# 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 # -# branchip : if the library enter an ip or ip range any librarian that connect from computer in this ip range will be temporarly affected to the corresponding branch . +# 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. # -# branchprinter : the library can select a default printer for a branch +# 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.38 2006/05/14 00:22:31 tgarip1957 -# Adding support for getting details of different zebra servers +# 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.37 2006/05/13 19:51:39 tgarip1957 -# Now reads koha.xml rather than koha.conf. -# koha.xml contains both the koha configuration and zebraserver configuration. -# Zebra connection is modified to allow connection to authority zebra as well. -# It will break head if koha.conf is not replaced with koha.xml +# 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 :