use strict;
use warnings;
use vars qw($VERSION $AUTOLOAD $context @context_stack $servers $memcached $ismemcached);
-$ENV{'DBIC_DONT_VALIDATE_RELS'} = 1; # FIXME once the DBIx schema has its schema adjusted we should remove this
BEGIN {
if ($ENV{'HTTP_USER_AGENT'}) {
require CGI::Carp;
}
use DBI;
-require Koha::Schema;
use ZOOM;
use XML::Simple;
use C4::Boolean;
use POSIX ();
use DateTime::TimeZone;
use Module::Load::Conditional qw(can_load);
+use Carp;
=head1 NAME
}
}
-# 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 {
$self->{tz} = undef; # local timezone object
bless $self, $class;
+ $self->{db_driver} = db_scheme2dbi($self->config('db_scheme')); # cache database driver
return $self;
}
=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
# 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);
- $context->{ Zconn }->{ $server }->option(
- preferredRecordSyntax => C4::Context->preference("marcflavour") );
- return $context->{"Zconn"}->{$server};
+ $context->{"Zconn"}->{$cache_key} = &_new_Zconn( $server, $async, $piggyback );
+ return $context->{"Zconn"}->{$cache_key};
}
}
=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);
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;
}
{
## $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");
$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.
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.
return;
}
-# _new_schema
-# 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_schema {
- 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");
- my $schema= Koha::Schema->connect("DBI:$db_driver:dbname=$db_name;host=$db_host;port=$db_port",
- $db_user, $db_passwd);
- return $schema;
-}
-
-=head2 schema
-
- $schema = C4::Context->schema;
-
-Returns a database handle connected to the Koha database for the
-current context. If no connection has yet been made, this method
-creates one, and connects to the database.
-
-This database handle is cached for future use: if you call
-C<C4::Context-E<gt>schema> twice, you will get the same handle both
-times. If you need a second database handle, use C<&new_schema> and
-possibly C<&set_schema>.
-
-=cut
-
-sub schema {
- my $self = shift;
- my $sth;
-
- if (defined($context->{"schema"}) && $context->{"schema"}->ping()) {
- return $context->{"schema"};
- }
-
- # No database handle or it died . Create one.
- $context->{"schema"} = &_new_schema();
-
- return $context->{"schema"};
-}
-
-=head2 new_schema
-
- $schema = C4::Context->new_schema;
-
-Creates a new connection to the Koha database for the current context,
-and returns the database handle (a C<DBI::db> object).
-
-The handle is not saved anywhere: this method is strictly a
-convenience function; the point is that it knows which database to
-connect to so that the caller doesn't have to know.
-
-=cut
-
-#'
-sub new_schema {
- my $self = shift;
-
- return &_new_schema();
-}
-
-=head2 set_schema
-
- $my_schema = C4::Connect->new_schema;
- C4::Connect->set_schema($my_schema);
- ...
- C4::Connect->restore_schema;
-
-C<&set_schema> and C<&restore_schema> work in a manner analogous to
-C<&set_context> and C<&restore_context>.
-
-C<&set_schema> saves the current database handle on a stack, then sets
-the current database handle to C<$my_schema>.
-
-C<$my_schema> is assumed to be a good database handle.
-
-=cut
-
-sub set_schema {
- my $self = shift;
- my $new_schema = shift;
-
- # Save the current database handle on the handle stack.
- # We assume that $new_schema is all good: if the caller wants to
- # screw himself by passing an invalid handle, that's fine by
- # us.
- push @{$context->{"schema_stack"}}, $context->{"schema"};
- $context->{"schema"} = $new_schema;
-}
-
-=head2 restore_schema
-
- C4::Context->restore_schema;
-
-Restores the database handle saved by an earlier call to
-C<C4::Context-E<gt>set_schema>.
-
-=cut
-
-sub restore_schema {
- my $self = shift;
-
- if ($#{$context->{"schema_stack"}} < 0) {
- # Stack underflow
- die "SCHEMA stack underflow";
- }
-
- # Pop the old database handle and set it.
- $context->{"schema"} = pop @{$context->{"schema_stack"}};
-
- # FIXME - If it is determined that restore_context should
- # return something, then this function should, too.
-}
-
=head2 marcfromkohafield
$dbh = C4::Context->marcfromkohafield;
}
+=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__
projects / koha_fer / blobdiff