X-Git-Url: http://git.rot13.org/?a=blobdiff_plain;f=C4%2FContext.pm;h=26eeb40885383795dbb025f1d7f0c07c5335a0d8;hb=c91b0d49a6375a2a7a3576d118700f4752ba03fb;hp=4385bff16cb5451c8429d08d55d193b59d8d50a8;hpb=84d8cce883afa2b3d2ca54354b221bfee1ca8153;p=koha.git diff --git a/C4/Context.pm b/C4/Context.pm index 4385bff16c..26eeb40885 100644 --- a/C4/Context.pm +++ b/C4/Context.pm @@ -3,23 +3,22 @@ package C4::Context; # # This file is part of Koha. # -# Koha is free software; you can redistribute it and/or modify it under the -# terms of the GNU General Public License as published by the Free Software -# Foundation; either version 2 of the License, or (at your option) any later -# version. +# Koha is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. # -# Koha is distributed in the hope that it will be useful, but WITHOUT ANY -# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR -# A PARTICULAR PURPOSE. See the GNU General Public License for more details. +# Koha is distributed in the hope that it will be useful, but +# WITHOUT ANY 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., -# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +# You should have received a copy of the GNU General Public License +# along with Koha; if not, see . use strict; use warnings; use vars qw($VERSION $AUTOLOAD $context @context_stack $servers $memcached $ismemcached); - BEGIN { if ($ENV{'HTTP_USER_AGENT'}) { require CGI::Carp; @@ -98,14 +97,19 @@ BEGIN { $VERSION = '3.07.00.049'; } -use DBI; +use DBIx::Connector; +use Encode; use ZOOM; use XML::Simple; -use C4::Boolean; -use C4::Debug; use POSIX (); use DateTime::TimeZone; use Module::Load::Conditional qw(can_load); +use Carp; + +use C4::Boolean; +use C4::Debug; +use Koha; +use Koha::Config::SysPrefs; =head1 NAME @@ -203,36 +207,6 @@ $context = undef; # Initially, no context is set @context_stack = (); # Initially, no saved contexts -=head2 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(); -} - -=head2 final_linear_version - -Returns the version number of the final update to run in updatedatabase.pl. -This number is equal to the version in kohaversion.pl - -=cut - -sub final_linear_version { - return KOHAVERSION; -} - =head2 read_config_file Reads the specified Koha config file. @@ -293,20 +267,20 @@ sub memcached { } } -# db_scheme2dbi -# Translates the full text name of a database into de appropiate dbi name -# +=head2 db_scheme2dbi + + my $dbd_driver_name = C4::Context::db_schema2dbi($scheme); + +This routines translates a database type to part of the name +of the appropriate DBD driver to use when establishing a new +database connection. It recognizes 'mysql' and 'Pg'; if any +other scheme is supplied it defaults to 'mysql'. + +=cut + sub db_scheme2dbi { - my $name = shift; - # for instance, we support only mysql, so don't care checking - return "mysql"; - for ($name) { -# FIXME - Should have other databases. - if (/mysql/) { return("mysql"); } - if (/Postgres|Pg|PostgresSQL/) { return("Pg"); } - if (/oracle/) { return("Oracle"); } - } - return; # Just in case + my $scheme = shift // ''; + return $scheme eq 'Pg' ? $scheme : 'mysql'; } sub import { @@ -314,7 +288,7 @@ sub import { # the first time the module is called # (a config file can be optionaly passed) - # default context allready exists? + # default context already exists? return if $context; # no ? so load it! @@ -376,7 +350,7 @@ sub new { } if ($ismemcached) { - # retreive from memcached + # retrieve from memcached $self = $memcached->get('kohaconf'); if (not defined $self) { # not in memcached yet @@ -401,6 +375,7 @@ sub new { $self->{tz} = undef; # local timezone object bless $self, $class; + $self->{db_driver} = db_scheme2dbi($self->config('db_scheme')); # cache database driver return $self; } @@ -540,23 +515,25 @@ my $use_syspref_cache = 1; sub preference { my $self = shift; - my $var = lc(shift); # The system preference to return + my $var = shift; # The system preference to return - if ($use_syspref_cache && exists $sysprefs{$var}) { - return $sysprefs{$var}; + if ($use_syspref_cache && exists $sysprefs{lc $var}) { + return $sysprefs{lc $var}; } my $dbh = C4::Context->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}; + my $value; + if ( defined $ENV{"OVERRIDE_SYSPREF_$var"} ) { + $value = $ENV{"OVERRIDE_SYSPREF_$var"}; + } else { + my $syspref; + eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) }; + $value = $syspref ? $syspref->value() : undef; + } + + $sysprefs{lc $var} = $value; + return $value; } sub boolean_preference { @@ -623,50 +600,33 @@ sub set_preference { my $var = lc(shift); my $value = shift; - my $dbh = C4::Context->dbh or return 0; - - my $type = $dbh->selectrow_array( "SELECT type FROM systempreferences WHERE variable = ?", {}, $var ); + my $syspref = Koha::Config::SysPrefs->find( $var ); + my $type = $syspref ? $syspref->type() : undef; $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) - " ); - - if($sth->execute( $var, $value )) { - $sysprefs{$var} = $value; + # force explicit protocol on OPACBaseURL + if ($var eq 'opacbaseurl' && substr($value,0,4) !~ /http/) { + $value = 'http://' . $value; } - $sth->finish; -} - -# AUTOLOAD -# This implements C4::Config->foo, and simply returns -# C4::Context->config("foo"), as described in the documentation for -# &config, above. -# FIXME - Perhaps this should be extended to check &config first, and -# then &preference if that fails. OTOH, AUTOLOAD could lead to crappy -# code, so it'd probably be best to delete it altogether so as not to -# encourage people to use it. -sub AUTOLOAD -{ - my $self = shift; + if ($syspref) { + $syspref = $syspref->set( { value => $value } )->store(); + } + else { + $syspref = Koha::Config::SysPref->new( { variable => $var, value => $value } )->store(); + } - $AUTOLOAD =~ s/.*:://; # Chop off the package name, - # leaving only the function name. - return $self->config($AUTOLOAD); + if ($syspref) { + $sysprefs{$var} = $value; + } } =head2 Zconn $Zconn = C4::Context->Zconn -Returns a connection to the Zebra database for the current -context. If no connection has yet been made, this method -creates one and connects. +Returns a connection to the Zebra database C<$self> @@ -674,35 +634,18 @@ 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 $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); - $context->{ Zconn }->{ $server }->option( - preferredRecordSyntax => C4::Context->preference("marcflavour") ); - return $context->{"Zconn"}->{$server}; + my ($self, $server, $async ) = @_; + my $cache_key = join ('::', (map { $_ // '' } ($server, $async ))); + if ( (!defined($ENV{GATEWAY_INTERFACE})) && defined($context->{"Zconn"}->{$cache_key}) && (0 == $context->{"Zconn"}->{$cache_key}->errcode()) ) { + # if we are running the script from the commandline, lets try to use the caching + return $context->{"Zconn"}->{$cache_key}; } + $context->{"Zconn"}->{$cache_key}->destroy() if defined($context->{"Zconn"}->{$cache_key}); #destroy old connection before making a new one + $context->{"Zconn"}->{$cache_key} = &_new_Zconn( $server, $async ); + return $context->{"Zconn"}->{$cache_key}; } =head2 _new_Zconn @@ -720,31 +663,47 @@ C<$auth> whether this connection has rw access (1) or just r access (0 or NULL) =cut sub _new_Zconn { - my ($server,$async,$auth,$piggyback,$syntax) = @_; + my ( $server, $async ) = @_; my $tried=0; # first attempt my $Zconn; # connection object - $server = "biblioserver" unless $server; - $syntax = "usmarc" unless $syntax; + my $elementSetName; + my $index_mode; + my $syntax; + + $server //= "biblioserver"; + + if ( $server eq 'biblioserver' ) { + $index_mode = $context->{'config'}->{'zebra_bib_index_mode'} // 'dom'; + } elsif ( $server eq 'authorityserver' ) { + $index_mode = $context->{'config'}->{'zebra_auth_index_mode'} // 'dom'; + } + + if ( $index_mode eq 'grs1' ) { + $elementSetName = 'F'; + $syntax = ( $context->preference("marcflavour") eq 'UNIMARC' ) + ? 'unimarc' + : 'usmarc'; + + } else { # $index_mode eq 'dom' + $syntax = 'xml'; + $elementSetName = 'marcxml'; + } 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(user => $user) if $user && $password; + $o->option(password => $password) if $user && $password; $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")); + $o->option(elementSetName => $elementSetName) if $elementSetName; + $o->option(databaseName => $context->{"config"}->{$server}||"biblios"); # create a new connection object $Zconn= create ZOOM::Connection($o); @@ -756,25 +715,7 @@ sub _new_Zconn { if ($Zconn->errcode() !=0) { warn "something wrong with the connection: ". $Zconn->errmsg(); } - }; -# 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; } @@ -786,13 +727,8 @@ sub _new_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"; - } + ## correct name for db_scheme + my $db_driver = $context->{db_driver}; my $db_name = $context->config("database"); my $db_host = $context->config("hostname"); @@ -800,8 +736,13 @@ sub _new_dbh 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, {'RaiseError' => $ENV{DEBUG}?1:0 }) or die $DBI::errstr; + my $dbh = DBIx::Connector->connect( + "dbi:$db_driver:dbname=$db_name;host=$db_host;port=$db_port", + $db_user, $db_passwd, + { + 'RaiseError' => $ENV{DEBUG} ? 1 : 0 + } + ); # Check for the existence of a systempreference table; if we don't have this, we don't # have a valid database and should not set RaiseError in order to allow the installer @@ -817,6 +758,10 @@ sub _new_dbh $dbh->{RaiseError} = 0; } + if ( $db_driver eq 'mysql' ) { + $dbh->{mysql_auto_reconnect} = 1; + } + 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. @@ -851,10 +796,15 @@ possibly C<&set_dbh>. sub dbh { my $self = shift; + my $params = shift; my $sth; - if (defined($context->{"dbh"}) && $context->{"dbh"}->ping()) { - return $context->{"dbh"}; + unless ( $params->{new} ) { + if ( defined($context->{db_driver}) && $context->{db_driver} eq 'mysql' && $context->{"dbh"} ) { + return $context->{"dbh"}; + } elsif ( defined($context->{"dbh"}) && $context->{"dbh"}->ping() ) { + return $context->{"dbh"}; + } } # No database handle or it died . Create one. @@ -980,6 +930,8 @@ sub _new_queryparser { my $config_file = $context->config('queryparser_config'); $config_file ||= '/etc/koha/searchengine/queryparser.yaml'; if ( $QParser->load_config($config_file) ) { + # Set 'keyword' as the default search class + $QParser->default_search_class('keyword'); # TODO: allow indexes to be configured in the database return $QParser; } @@ -1083,18 +1035,8 @@ Cuserenv> twice, you will get the same hash without real DB ac #' sub userenv { 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') eq 'yes') { - 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; + if (defined $var and defined $context->{"userenv"}->{$var}) { + return $context->{"userenv"}->{$var}; } else { return; } @@ -1102,9 +1044,10 @@ sub userenv { =head2 set_userenv - C4::Context->set_userenv($usernum, $userid, $usercnum, $userfirstname, - $usersurname, $userbranch, $userflags, $emailaddress, $branchprinter, - $persona); + C4::Context->set_userenv($usernum, $userid, $usercnum, + $userfirstname, $usersurname, + $userbranch, $branchname, $userflags, + $emailaddress, $branchprinter, $persona); Establish a hash of user environment variables. @@ -1114,7 +1057,10 @@ set_userenv is called in Auth.pm #' sub set_userenv { - my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter, $persona)= @_; + shift @_; + my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter, $persona, $shibboleth)= + map { Encode::is_utf8( $_ ) ? $_ : Encode::decode('UTF-8', $_) } # CGI::Session doesn't handle utf-8, so we decode it here + @_; my $var=$context->{"activeuser"} || ''; my $cell = { "number" => $usernum, @@ -1129,6 +1075,7 @@ sub set_userenv { "emailaddress" => $emailaddress, "branchprinter" => $branchprinter, "persona" => $persona, + "shibboleth" => $shibboleth, }; $context->{userenv}->{$var} = $cell; return $cell; @@ -1205,7 +1152,7 @@ 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} = KOHAVERSION(); + $versions{kohaVersion} = Koha::version(); $versions{kohaDbVersion} = C4::Context->preference('version'); $versions{osVersion} = join(" ", POSIX::uname()); $versions{perlVersion} = $]; @@ -1238,6 +1185,50 @@ sub tz { } +=head2 IsSuperLibrarian + + C4::Context->IsSuperLibrarian(); + +=cut + +sub IsSuperLibrarian { + my $userenv = C4::Context->userenv; + + unless ( $userenv and exists $userenv->{flags} ) { + # If we reach this without a user environment, + # assume that we're running from a command-line script, + # and act as a superlibrarian. + carp("C4::Context->userenv not defined!"); + return 1; + } + + return ($userenv->{flags}//0) % 2; +} + +=head2 interface + +Sets the current interface for later retrieval in any Perl module + + C4::Context->interface('opac'); + C4::Context->interface('intranet'); + my $interface = C4::Context->interface; + +=cut + +sub interface { + my ($class, $interface) = @_; + + if (defined $interface) { + $interface = lc $interface; + if ($interface eq 'opac' || $interface eq 'intranet') { + $context->{interface} = $interface; + } else { + warn "invalid interface : '$interface'"; + } + } + + return $context->{interface} // 'opac'; +} 1; __END__ @@ -1258,4 +1249,3 @@ Andrew Arensburger Joshua Ferraro -=cut