X-Git-Url: http://koha-dev.rot13.org:8081/gitweb/?a=blobdiff_plain;f=C4%2FContext.pm;h=9a7b75da8fbd2259d12fb0fd4816b7155b789000;hb=5d6c092921919526ade501facb1220f8a108a08f;hp=85d1c1870a4b87e3f910c11fd12077cfa9d04539;hpb=16f1fffdd1f5d1c97db0bf664f83496864b7e24d;p=koha_fer diff --git a/C4/Context.pm b/C4/Context.pm index 85d1c1870a..9a7b75da8f 100644 --- a/C4/Context.pm +++ b/C4/Context.pm @@ -18,8 +18,7 @@ package C4::Context; use strict; use warnings; -use vars qw($VERSION $AUTOLOAD $context @context_stack); - +use vars qw($VERSION $AUTOLOAD $context @context_stack $servers $memcached $ismemcached); BEGIN { if ($ENV{'HTTP_USER_AGENT'}) { require CGI::Carp; @@ -78,7 +77,24 @@ BEGIN { $main::SIG{__DIE__} = \&CGI::Carp::confess; } } # else there is no browser to send fatals to! - $VERSION = '3.00.00.036'; + + # Check if there are memcached servers set + $servers = $ENV{'MEMCACHED_SERVERS'}; + if ($servers) { + # Load required libraries and create the memcached object + require Cache::Memcached; + $memcached = Cache::Memcached->new({ + servers => [ $servers ], + debug => 0, + compress_threshold => 10_000, + expire_time => 600, + namespace => $ENV{'MEMCACHED_NAMESPACE'} || 'koha' + }); + # Verify memcached available (set a variable and test the output) + $ismemcached = $memcached->set('ismemcached','1'); + } + + $VERSION = '3.07.00.049'; } use DBI; @@ -87,6 +103,9 @@ use XML::Simple; use C4::Boolean; use C4::Debug; use POSIX (); +use DateTime::TimeZone; +use Module::Load::Conditional qw(can_load); +use Carp; =head1 NAME @@ -202,6 +221,18 @@ sub KOHAVERSION { 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. @@ -229,22 +260,53 @@ Returns undef in case of error. sub read_config_file { # Pass argument naming config file to read my $koha = XMLin(shift, keyattr => ['id'], forcearray => ['listen', 'server', 'serverinfo'], suppressempty => ''); + + if ($ismemcached) { + $memcached->set('kohaconf',$koha); + } + 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; +=head2 ismemcached + +Returns the value of the $ismemcached variable (0/1) - for ($name) { -# FIXME - Should have other databases. - if (/mysql/i) { return("mysql"); } - if (/Postgres|Pg|PostgresSQL/) { return("Pg"); } - if (/oracle/i) { return("Oracle"); } +=cut + +sub ismemcached { + return $ismemcached; +} + +=head2 memcached + +If $ismemcached is true, returns the $memcache variable. +Returns undef otherwise + +=cut + +sub memcached { + if ($ismemcached) { + return $memcached; + } else { + return; } - return undef; # Just in case +} + +=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 $scheme = shift // ''; + return $scheme eq 'Pg' ? $scheme : 'mysql'; } sub import { @@ -274,6 +336,10 @@ 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. +It saves the koha-conf.xml values in the declared memcached server(s) +if currently available and uses those values until them expire and +re-reads them. + C<&new> does not set this context as the new default context; for that, use C<&set_context>. @@ -305,15 +371,25 @@ sub new { $conf_fname = CONFIG_FNAME; } else { warn "unable to locate Koha configuration file koha-conf.xml"; - return undef; + return; } } - # Load the desired config file. - $self = read_config_file($conf_fname); - $self->{"config_file"} = $conf_fname; + if ($ismemcached) { + # retreive from memcached + $self = $memcached->get('kohaconf'); + if (not defined $self) { + # not in memcached yet + $self = read_config_file($conf_fname); + } + } else { + # non-memcached env, read from 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"}); + return if !defined($self->{"config"}); $self->{"dbh"} = undef; # Database handle $self->{"Zconn"} = undef; # Zebra Connections @@ -322,8 +398,10 @@ sub new { $self->{"userenv"} = undef; # User env $self->{"activeuser"} = undef; # current active user $self->{"shelves"} = undef; + $self->{tz} = undef; # local timezone object bless $self, $class; + $self->{db_driver} = db_scheme2dbi($self->config('db_scheme')); # cache database driver return $self; } @@ -416,10 +494,10 @@ Cnew> will not return it. =cut -sub _common_config ($$) { +sub _common_config { my $var = shift; my $term = shift; - return undef if !defined($context->{$term}); + return 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 @@ -459,35 +537,72 @@ with this method. # flushing the caching mechanism. my %sysprefs; +my $use_syspref_cache = 1; sub preference { my $self = shift; - my $var = shift; # The system preference to return + my $var = shift; # The system preference to return - if (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 { + # Look up systempreferences.variable==$var + my $sql = q{ + SELECT value + FROM systempreferences + WHERE variable = ? + LIMIT 1 + }; + $value = $dbh->selectrow_array( $sql, {}, lc $var ); + } + + $sysprefs{lc $var} = $value; + return $value; } -sub boolean_preference ($) { +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; } +=head2 enable_syspref_cache + + C4::Context->enable_syspref_cache(); + +Enable the in-memory syspref cache used by C4::Context. This is the +default behavior. + +=cut + +sub enable_syspref_cache { + my ($self) = @_; + $use_syspref_cache = 1; +} + +=head2 disable_syspref_cache + + C4::Context->disable_syspref_cache(); + +Disable the in-memory syspref cache used by C4::Context. This should be +used with Plack and other persistent environments. + +=cut + +sub disable_syspref_cache { + my ($self) = @_; + $use_syspref_cache = 0; + $self->clear_syspref_cache(); +} + =head2 clear_syspref_cache C4::Context->clear_syspref_cache(); @@ -513,7 +628,7 @@ the sysprefs cache. sub set_preference { my $self = shift; - my $var = shift; + my $var = lc(shift); my $value = shift; my $dbh = C4::Context->dbh or return 0; @@ -529,7 +644,9 @@ sub set_preference { ON DUPLICATE KEY UPDATE value = VALUES(value) " ); - $sth->execute( $var, $value ); + if($sth->execute( $var, $value )) { + $sysprefs{$var} = $value; + } $sth->finish; } @@ -571,14 +688,13 @@ 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}; + my ($self, $server, $async, $auth, $piggyback, $syntax) = @_; + #TODO: We actually just ignore the auth and syntax parameter + #It also looks like we are not passing auth, piggyback, syntax anywhere + + my $cache_key = join ('::', (map { $_ // '' } ($server, $async, $auth, $piggyback, $syntax))); + if ( defined($context->{"Zconn"}->{$cache_key}) && (0 == $context->{"Zconn"}->{$cache_key}->errcode()) ) { + return $context->{"Zconn"}->{$cache_key}; # No connection object or it died. Create one. }else { # release resources if we're closing a connection and making a new one @@ -587,10 +703,10 @@ sub Zconn { # 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"}->{$cache_key}->destroy() if defined($context->{"Zconn"}->{$cache_key}); - $context->{"Zconn"}->{$server} = &_new_Zconn($server,$async,$auth,$piggyback,$syntax); - return $context->{"Zconn"}->{$server}; + $context->{"Zconn"}->{$cache_key} = &_new_Zconn( $server, $async, $piggyback ); + return $context->{"Zconn"}->{$cache_key}; } } @@ -609,31 +725,48 @@ 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, $piggyback ) = @_; 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'} // 'grs1'; + } 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); @@ -645,25 +778,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; } @@ -675,13 +790,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"); @@ -689,8 +799,27 @@ 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) or die $DBI::errstr; + 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; + + # 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 + # to run; installer will not run otherwise since we raise all db errors + + eval { + local $dbh->{PrintError} = 0; + local $dbh->{RaiseError} = 1; + $dbh->do(qq{SELECT * FROM systempreferences WHERE 1 = 0 }); + }; + + if ($@) { + $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. @@ -725,10 +854,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. @@ -816,6 +950,51 @@ sub restore_dbh # return something, then this function should, too. } +=head2 queryparser + + $queryparser = C4::Context->queryparser + +Returns a handle to an initialized Koha::QueryParser::Driver::PQF object. + +=cut + +sub queryparser { + my $self = shift; + unless (defined $context->{"queryparser"}) { + $context->{"queryparser"} = &_new_queryparser(); + } + + return + defined( $context->{"queryparser"} ) + ? $context->{"queryparser"}->new + : undef; +} + +=head2 _new_queryparser + +Internal helper function to create a new QueryParser object. QueryParser +is loaded dynamically so as to keep the lack of the QueryParser library from +getting in anyone's way. + +=cut + +sub _new_queryparser { + my $qpmodules = { + 'OpenILS::QueryParser' => undef, + 'Koha::QueryParser::Driver::PQF' => undef + }; + if ( can_load( 'modules' => $qpmodules ) ) { + my $QParser = Koha::QueryParser::Driver::PQF->new(); + my $config_file = $context->config('queryparser_config'); + $config_file ||= '/etc/koha/searchengine/queryparser.yaml'; + if ( $QParser->load_config($config_file) ) { + # TODO: allow indexes to be configured in the database + return $QParser; + } + } + return; +} + =head2 marcfromkohafield $dbh = C4::Context->marcfromkohafield; @@ -912,18 +1091,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; } @@ -932,7 +1101,8 @@ sub userenv { =head2 set_userenv C4::Context->set_userenv($usernum, $userid, $usercnum, $userfirstname, - $usersurname, $userbranch, $userflags, $emailaddress); + $usersurname, $userbranch, $userflags, $emailaddress, $branchprinter, + $persona); Establish a hash of user environment variables. @@ -942,8 +1112,8 @@ set_userenv is called in Auth.pm #' sub set_userenv { - my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter)= @_; - my $var=$context->{"activeuser"}; + my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter, $persona)= @_; + my $var=$context->{"activeuser"} || ''; my $cell = { "number" => $usernum, "id" => $userid, @@ -955,25 +1125,26 @@ sub set_userenv { "branchname" => $branchname, "flags" => $userflags, "emailaddress" => $emailaddress, - "branchprinter" => $branchprinter + "branchprinter" => $branchprinter, + "persona" => $persona, }; $context->{userenv}->{$var} = $cell; return $cell; } -sub set_shelves_userenv ($$) { - my ($type, $shelves) = @_ or return undef; - my $activeuser = $context->{activeuser} or return undef; +sub set_shelves_userenv { + my ($type, $shelves) = @_ or return; + my $activeuser = $context->{activeuser} or return; $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 () { +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; + return; } my $totshelves = $active->{totshelves} or undef; my $pubshelves = $active->{pubshelves} or undef; @@ -1048,6 +1219,68 @@ sub get_versions { } +=head2 tz + + C4::Context->tz + + Returns a DateTime::TimeZone object for the system timezone + +=cut + +sub tz { + my $self = shift; + if (!defined $context->{tz}) { + $context->{tz} = DateTime::TimeZone->new(name => 'local'); + } + return $context->{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__