Attachment #76062 for bug #15562

View | Details | Raw Unified | Return to bug 15562
Collapse All | Expand All




use C4::Languages;
use C4::Search::History;
use Koha;
use Koha::Caches;
use Koha::AuthUtils qw(get_script_name hash_password);
use Koha::DateUtils qw(dt_from_string);
use Koha::Library::Groups;

        my $dbh = C4::Context->dbh;
        return { dsn => "driver:PostgreSQL;serializer:yaml;id:md5", dsn_args => { Handle => $dbh } };
    }
    elsif ( $storage_method eq 'memcached' ) {
        if ( my $memcached = C4::Context->cache->memcached_cache ) {
            return { dsn => "driver:memcached;serializer:yaml;id:md5", dsn_args => { Memcached =>  $memcached } };
        }
    }
    else {
        # catch all defaults to tmp should work on all systems

Lines 54-60 sub ldapserver_error { Link Here

(-)a/C4/Auth_with_ldap.pm (-1 / +1 lines)
54	}	54	}
55		55
56	use vars qw($mapping @ldaphosts $base $ldapname $ldappassword);	56	use vars qw($mapping @ldaphosts $base $ldapname $ldappassword);
57	my $context = C4::Context->new() or die 'C4::Context->new failed';	57	my $context = C4::Context->current() or die 'No current context';
58	my $ldap = C4::Context->config("ldapserver") or die 'No "ldapserver" in server hash from KOHA_CONF: ' . $ENV{KOHA_CONF};	58	my $ldap = C4::Context->config("ldapserver") or die 'No "ldapserver" in server hash from KOHA_CONF: ' . $ENV{KOHA_CONF};
59	my $prefhost = $ldap->{hostname} or die ldapserver_error('hostname');	59	my $prefhost = $ldap->{hostname} or die ldapserver_error('hostname');
60	my $base = $ldap->{base} or die ldapserver_error('base');	60	my $base = $ldap->{base} or die ldapserver_error('base');




use C4::Linker;
use C4::OAI::Sets;
use C4::Debug;
use C4::Context;

use Koha::Caches;
use Koha::Authority::Types;
use Koha::Acquisition::Currencies;
use Koha::Biblio::Metadata;


    $forlibrarian = $forlibrarian ? 1 : 0;
    my $unsafe = ($params && $params->{unsafe})? 1: 0;
    my $cache = C4::Context->cache;
    my $cache_key = "MarcStructure-$forlibrarian-$frameworkcode";
    my $cached = $cache->get_from_cache($cache_key, { unsafe => $unsafe });
    return $cached if $cached;


    $frameworkcode //= '';

    my $cache     = C4::Context->cache;
    my $cache_key = "MarcSubfieldStructure-$frameworkcode";
    my $cached    = $cache->get_from_cache($cache_key);
    return $cached if $cached;




use Date::Calc qw( Date_to_Days Today);

use C4::Context;
use Koha::Caches;

use constant ISO_DATE_FORMAT => "%04d-%02d-%02d";




    # changed the 'single_holidays' table, lets force/reset its cache
    my $cache = C4::Context->cache;
    $cache->clear_from_cache( 'single_holidays') ;
    $cache->clear_from_cache( 'exception_holidays') ;


    $self->{'exception_holidays'}->{"$options{year}/$options{month}/$options{day}"}{description} = $options{description};

    # changed the 'single_holidays' table, lets force/reset its cache
    my $cache = C4::Context->cache;
    $cache->clear_from_cache( 'single_holidays') ;
    $cache->clear_from_cache( 'exception_holidays') ;


    $self->{'single_holidays'}->{"$options{year}/$options{month}/$options{day}"}{description} = $options{description};

    # changed the 'single_holidays' table, lets force/reset its cache
    my $cache = C4::Context->cache;
    $cache->clear_from_cache( 'single_holidays') ;
    $cache->clear_from_cache( 'exception_holidays') ;


    $self->{'exception_holidays'}->{"$options{year}/$options{month}/$options{day}"}{description} = $options{description};

    # changed the 'single_holidays' table, lets force/reset its cache
    my $cache = C4::Context->cache;
    $cache->clear_from_cache( 'single_holidays') ;
    $cache->clear_from_cache( 'exception_holidays') ;


    }

    # changed the 'single_holidays' table, lets force/reset its cache
    my $cache = C4::Context->cache;
    $cache->clear_from_cache( 'single_holidays') ;
    $cache->clear_from_cache( 'exception_holidays') ;


    $sth->execute($self->{branchcode}, $options{day}, $options{month}, $options{year});

    # changed the 'single_holidays' table, lets force/reset its cache
    my $cache = C4::Context->cache;
    $cache->clear_from_cache( 'single_holidays') ;
    $cache->clear_from_cache( 'exception_holidays') ;


    $sth->execute($self->{branchcode}, $options{day}, $options{month}, $options{year});

    # changed the 'single_holidays' table, lets force/reset its cache
    my $cache = C4::Context->cache;
    $cache->clear_from_cache( 'single_holidays') ;
    $cache->clear_from_cache( 'exception_holidays') ;
}




			    eval {C4::Context->dbh();};
			    if ($@){
				$debug_level = 1;
			    }
			    else {
				$debug_level =  C4::Context->preference("DebugLevel");
			    }

		# a little example table with various version info";
					print "
						<h1>Koha error</h1>
						<p>The following fatal error has occurred:</p>
                        <pre><code>$msg</code></pre>
						<table>
						<tr><th>Apache</th><td>  $versions{apacheVersion}</td></tr>

				} elsif ($debug_level eq "1"){
					print "
						<h1>Koha error</h1>
						<p>The following fatal error has occurred:</p>
                        <pre><code>$msg</code></pre>";
				} else {
					print "<p>production mode - trapped fatal error</p>";
				}
                print "</body></html>";
			}
		#CGI::Carp::set_message(\&handle_errors);

use POSIX ();
use DateTime::TimeZone;
use Module::Load::Conditional qw(can_load);
use Data::Dumper;
use Carp;
use DateTime::TimeZone;


#    file (/etc/koha/koha-conf.xml).
# dbh
#    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.
# Zconn
#     A connection object for the Zebra server

@context_stack = ();     # Initially, no saved contexts

=head2 current

Returns the current context

=cut

sub current {
    return $context;
}

=head2 cache

Returns the cache object or undef

=cut

sub cache {
    my $self = shift;
    $self = $context unless ref ($self);

    return Koha::Caches->get_instance($self->{namespace});
}

=head2 memcached

Returns the cache object if it is memcached or undef

=cut

sub memcached {
    my $self = shift;
    my $cache = $self->cache;
    return $cache if $cache->memcached_cache;

    return;
}

sub db_driver {
    my $self = shift;

    $self = $context unless ref ($self);
    return unless $self;

    return $self->{db_driver};
}

=head2 db_scheme2dbi


    # Create the default context ($C4::Context::Context)
    # the first time the module is called
    # (a config file can be optionaly passed)
    # If ":no_config" is passed, no config load will be attempted
    # It saves the context values in the declared memcached server(s)
    # if currently available and uses those values until them expire and
    # re-reads them.

    my ($pkg,$config_file) = @_;

    # default context already exists?
    return if $context;

    # multihost, we don't want/have one default config
    return if $config_file && $config_file eq ":no_config";
    my $new_ctx = __PACKAGE__->new($config_file);
    return unless $new_ctx;

    my $conf_cache = Koha::Caches->get_instance('config');
    if ( $conf_cache->cache ) {
        if ( $context = $conf_cache->get_from_cache('koha_conf') ) {
            return;
        }
    }

    undef $config_file if $config_file && !-s $config_file;
    $config_file ||= Koha::Config->guess_koha_conf();
    $context = __PACKAGE__->new($config_file);
    return unless $context;

    if ( $conf_cache->memcached_cache ) {
        # FIXME it may be better to use the memcached servers from the config file
        # to cache it
        $conf_cache->set_in_cache('koha_conf', $context)
    }
}

=head2 new

  $context = new C4::Context;
  $context = new C4::Context("/path/to/koha-conf.xml");

Allocates a new context. Initializes the context from the specified
file.
environment variable, or F</etc/koha/koha-conf.xml>.

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>.

# 2004-08-10 A. Tarallo: Added check if the conf file is not empty
sub new {
    my $class = shift;
    my $conf_fname = shift or croak "No conf";
    my $namespace = shift;

    # 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.
    unless ( defined $conf_fname ) {
        $conf_fname = Koha::Config->guess_koha_conf;
        unless ( $conf_fname ) {
            warn "unable to locate Koha configuration file koha-conf.xml";
            return;
        }
    }

    my $self = Koha::Config->read_from_file($conf_fname);
    die "Invalid config ".(ref($conf_fname) ? $$conf_fname : $conf_fname).": ".Dumper($self)
      unless ref($self) && $self->{"config"};

    $self->{config_file} = $conf_fname;
    $self->{namespace} = $namespace;
    $self->{use_syspref_cache} = 1;
    $self->{syspref_cache} = Koha::Caches->get_instance('syspref', $namespace);
            # FIXME it may be better to use the memcached servers from the config file
            # to cache it
            $conf_cache->set_in_cache('koha_conf', $self)
        }
    }
    unless ( exists $self->{config} or defined $self->{config} ) {
        warn "The config file ($conf_fname) has not been parsed correctly";
        return;
    }

    $self->{"Zconn"} = undef;    # Zebra Connections
    $self->{"userenv"} = undef;        # User env


=head2 set_context

  $context = new C4::Context;
  $context->set_context();
or
  set_context C4::Context $context;

    if (ref($self) eq "")
    {
        # Class method. The new context is the next argument.
        $new_context = shift or croak "No new context";
    } else {
        # Instance method. The new context is $self.
        $new_context = $self;
    }

    # undef $new_context->{schema} if $new_context->{schema} && !$new_context->{schema}->ping
    my $schema = $new_context->{schema} ||= Koha::Database->new_schema($new_context);

    # Save the old context on the stack
    push @context_stack, $context;

    # Set the new context
    $context = $new_context;
    Koha::Database->set_schema($schema);
}

=head2 restore_context

{
    my $self = shift;

    if ($#context_stack < 0)
    {
        # Stack underflow.
        die "Context stack underflow";
    }

    # Pop the old context and set it.
    $context = pop @context_stack;
    Koha::Database->restore_schema();

    # FIXME - Should this return something, like maybe the context
    # that was current when this was called?
}

=head2 run_within_context

  $context->run_within_context(sub {...});

Runs code within context

=cut

#'
sub run_within_context
{
    my $self = shift;
    my $code = shift or croak "No code";

    $self->set_context;

    local $@;
    my $ret = eval { $code->(@_) };
    my $died = $@;
    $self->restore_context;
    die $died if $died;
    return $ret;
}

=head2 config

  $value = C4::Context->config("config_variable");

=cut

sub _common_config {
    my $self = shift;
    my $var = shift;
    my $term = shift;

    $self = $context unless ref $self;
    return if !defined($self->{$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 $self->{$term}->{$var};
}

sub config {
    my $self = shift;
    return $self->_common_config($_[0],'config');
}
sub zebraconfig {
    my $self = shift;
    return $self->_common_config($_[0],'server');
}
sub ModZebrations {
    my $self = shift;
    return $self->_common_config($_[0],'serverinfo');
}

=head2 preference


=cut

my $syspref_cache = Koha::Caches->get_instance('syspref');
my $use_syspref_cache = 1;
sub preference {
    my $self = shift;
    $self = $context unless ref $self;
    my $var  = shift;    # The system preference to return

    $var = lc $var;

    return $ENV{"OVERRIDE_SYSPREF_$var"}
        if defined $ENV{"OVERRIDE_SYSPREF_$var"};

    my $cached_var = $self->{use_syspref_cache}
        ? $self->{syspref_cache}->get_from_cache("syspref_$var")
        : undef;
    return $cached_var if defined $cached_var;
        my $cached_var = $syspref_cache->get_from_cache("syspref_$var");
        return $cached_var if defined $cached_var;
    }

    my $syspref;
    eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) };
    my $value = $syspref ? $syspref->value() : undef;

    if ( $self->{use_syspref_cache} ) {
        $self->{syspref_cache}->set_in_cache("syspref_$var", $value);
    }
    return $value;
}


sub enable_syspref_cache {
    my ($self) = @_;
    $self = $context unless ref $self;
    $self->{use_syspref_cache} = 1;
    # We need to clear the cache to have it up-to-date
    $self->clear_syspref_cache();
}


sub disable_syspref_cache {
    my ($self) = @_;
    $self = $context unless ref $self;
    $self->clear_syspref_cache();
    $self->{use_syspref_cache} = 0;
}

=head2 clear_syspref_cache

=cut

sub clear_syspref_cache {
    my ($self) = @_;
    $self = $context unless ref $self;
    return unless $self->{use_syspref_cache};
    $self->{syspref_cache}->flush_all;
}

=head2 set_preference


sub set_preference {
    my ( $self, $variable, $value, $explanation, $type, $options ) = @_;
    $self = $context unless ref $self;

    my $variable_case = $variable;
    $variable = lc $variable;

        )->store();
    }

    if ( $self->{use_syspref_cache} ) {
        $self->{syspref_cache}->set_in_cache( "syspref_$variable", $value );
    }

    return $syspref;


sub delete_preference {
    my ( $self, $var ) = @_;
    $self = $context unless ref $self;

    if ( Koha::Config::SysPrefs->find( $var )->delete ) {
        if ( $self->{use_syspref_cache} ) {
            $self->{syspref_cache}->clear_from_cache("syspref_$var");
        }

        return 1;


Returns a connection to the Zebra database

C<$self>

C<$server> one of the servers defined in the koha-conf.xml file



This database handle is cached for future use: if you call
C<C4::Context-E<gt>dbh> twice, you will get the same handle both
times. If you need a second database handle, use C<&new_dbh>.
possibly C<&set_dbh>.

=cut


    return &dbh({ new => 1 });
}

=head2 set_dbh

  $my_dbh = C4::Connect->new_dbh;
  C4::Connect->set_dbh($my_dbh);
  ...
  C4::Connect->restore_dbh;

C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
C<&set_context> and C<&restore_context>.

C<&set_dbh> saves the current database handle on a stack, then sets
the current database handle to C<$my_dbh>.

C<$my_dbh> is assumed to be a good database handle.

=cut

#'
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;
}

=head2 restore_dbh

  C4::Context->restore_dbh;

Restores the database handle saved by an earlier call to
C<C4::Context-E<gt>set_dbh>.

=cut

#'
sub restore_dbh
{
    my $self = shift;

    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"}};

    # FIXME - If it is determined that restore_context should
    # return something, then this function should, too.
}

=head2 queryparser

  $queryparser = C4::Context->queryparser





use Koha;
use JSON;
use C4::Context;
use HTTP::Request;
use HTTP::Request::Common;
use LWP::Authen::Basic;


    return unless ( $key && $secret ) ;

    my $cache = C4::Context->cache;

    eval { $cache = Koha::Caches->get_instance() };

    my $token;
    $cache and $token = $cache->get_from_cache( "overdrive_token" ) and return $token;

Lines 362-367 our $PERL_DEPS = { Link Here

(-)a/C4/Installer/PerlDependencies.pm (+5 lines)
362	'required' => '1',	362	'required' => '1',
363	'min_ver' => '0.46'	363	'min_ver' => '0.46'
364	},	364	},
		365	'Capture::Tiny' => {
		366	'usage' => 'Core',
		367	'required' => '1',
		368	'min_ver' => '0.08'
		369	},
365	'HTTP::Cookies' => {	370	'HTTP::Cookies' => {
366	'usage' => 'Core',	371	'usage' => 'Core',
367	'required' => '1',	372	'required' => '1',

Lines 444-450 sub _build_default_values_for_mod_marc { Link Here

(-)a/C4/Items.pm (-1 / +1 lines)
444	# Has no framework parameter anymore, since Default is authoritative	444	# Has no framework parameter anymore, since Default is authoritative
445	# for Koha to MARC mappings.	445	# for Koha to MARC mappings.
446		446
447	my $cache = Koha::Caches->get_instance();	447	my $cache = C4::Context->cache;
448	my $cache_key = "default_value_for_mod_marc-";	448	my $cache_key = "default_value_for_mod_marc-";
449	my $cached = $cache->get_from_cache($cache_key);	449	my $cached = $cache->get_from_cache($cache_key);
450	return $cached if $cached;	450	return $cached if $cached;

Lines 24-30 use strict; Link Here

(-)a/C4/Koha.pm (-2 / +1 lines)
24	#use warnings; FIXME - Bug 2505	24	#use warnings; FIXME - Bug 2505
25		25
26	use C4::Context;	26	use C4::Context;
27	use Koha::Caches;
28	use Koha::DateUtils qw(dt_from_string);	27	use Koha::DateUtils qw(dt_from_string);
29	use Koha::AuthorisedValues;	28	use Koha::AuthorisedValues;
30	use Koha::Libraries;	29	use Koha::Libraries;
Lines 533-539 sub GetAuthorisedValues { Link Here
533	C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";	532	C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
534	my $cache_key =	533	my $cache_key =
535	"AuthorisedValues-$category-$opac-$branch_limit";	534	"AuthorisedValues-$category-$opac-$branch_limit";
536	my $cache = Koha::Caches->get_instance();	535	my $cache = C4::Context->cache;
537	my $result = $cache->get_from_cache($cache_key);	536	my $result = $cache->get_from_cache($cache_key);
538	return $result if $result;	537	return $result if $result;
539		538

Lines 5-15 use List::Util qw( first ); Link Here

(-)a/C4/Utils/DataTables/ColumnsSettings.pm (-2 / +1 lines)
5	use YAML;	5	use YAML;
6	use C4::Context;	6	use C4::Context;
7	use Koha::Database;	7	use Koha::Database;
8	use Koha::Caches;
9		8
10	sub get_yaml {	9	sub get_yaml {
11	my $yml_path = C4::Context->config('intranetdir') . '/admin/columns_settings.yml';	10	my $yml_path = C4::Context->config('intranetdir') . '/admin/columns_settings.yml';
12	my $cache = Koha::Caches->get_instance();	11	my $cache = C4::Context->cache;
13	my $yaml = $cache->get_from_cache('ColumnsSettingsYaml');	12	my $yaml = $cache->get_from_cache('ColumnsSettingsYaml');
14		13
15	unless ($yaml) {	14	unless ($yaml) {




=cut

sub new {
    my ( $class, $self ) = @_;
    $self->{'default_type'} =
         $self->{cache_type}
      || $ENV{CACHING_SYSTEM} # DELME What about this?
      || 'memcached';

    $self->{namespace} //= '';

    $ENV{DEBUG} && carp "Default caching system: $self->{'default_type'}";

    $self->{'timeout'}   ||= 0;
    # Should we continue to support MEMCACHED ENV vars?
    $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE};
    my @servers = split /,/, $ENV{MEMCACHED_SERVERS} || '';
    unless ( $self->{namespace} and @servers ) {
        my $koha_config = Koha::Config->read_from_file( Koha::Config->guess_koha_conf() );
        $self->{namespace} ||= $koha_config->{config}{memcached_namespace} || 'koha';
        @servers = split /,/, $koha_config->{config}{memcached_servers} // ''
            unless @servers;
    }
    $self->{namespace} .= ":$subnamespace:";

    if ( $self->{'default_type'} eq 'memcached'
        && can_load( modules => { 'Cache::Memcached::Fast' => undef } ) )
        && _initialize_memcached($self, @servers)
        && defined( $self->{'memcached_cache'} ) )
    {
        # Should we continue to support MEMCACHED ENV vars?
        $self->{'namespace'} ||= $ENV{MEMCACHED_NAMESPACE};
        my @servers = split /,/, $ENV{MEMCACHED_SERVERS} || '';
        unless ( $self->{namespace} && @servers ) {
            my $koha_config = Koha::Config->read_from_file( Koha::Config->guess_koha_conf() );
            $self->{namespace} ||= $koha_config->{config}{memcached_namespace} || 'koha';
            @servers = split /,/, $koha_config->{config}{memcached_servers} // ''
                unless @servers;
        }
        if ( _initialize_memcached($self, @servers)
            && defined( $self->{'memcached_cache'} ) )
        {
            $self->{'cache'} = $self->{'memcached_cache'};
        }
    }

    if ( $self->{'default_type'} eq 'fastmmap'




=cut

sub get_instance {
    my ($class, $subnamespace, $namespace) = @_;
    $subnamespace //= '';
    $namespace //= '';
    return $singleton_caches->{$namespace}{$subnamespace}
      ||= Koha::Cache->new({ namespace => $namespace }, { subnamespace => $subnamespace });
}

=head2 flush_L1_caches

=cut

sub flush_L1_caches {
    my ($class, $namespace) = @_;
    $namespace //= '';

    return unless $singleton_caches;
    for my $cache ( values %{$singleton_caches->{$namespace}} ) {
        $cache->flush_L1_cache;
    }
}




use DateTime::Set;
use DateTime::Duration;
use C4::Context;
use Koha::Caches;
use Carp;

sub new {

sub exception_holidays {
    my ( $self ) = @_;

    my $cache  = C4::Context->cache;
    my $cached = $cache->get_from_cache('exception_holidays');
    return $cached if $cached;


sub single_holidays {
    my ( $self, $date ) = @_;
    my $branchcode = $self->{branchcode};
    my $cache           = C4::Context->cache;
    my $single_holidays = $cache->get_from_cache('single_holidays');

    # $single_holidays looks like:




use Modern::Perl;
use Carp;
use C4::Context;
use Koha::Schema;
use base qw(Class::Accessor);

use vars qw($database);

# database connection from the data given in the current context, and
# returns it.
sub _new_schema {
    my $context = shift || C4::Context->current();

    my $db_driver = $context->db_driver;

    my $context = C4::Context->new();

    my $db_driver = $context->{db_driver};

    my $db_name   = $context->config("database");
    my $db_host   = $context->config("hostname");

        return $database->{schema} if defined $database->{schema};
    }

    $database->{schema} = &_new_schema($params->{context});
    return $database->{schema};
}

=head2 new_schema

  $schema = $database->new_schema($context);

Creates a new connection to the Koha database for the context
(current is default), 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

sub new_schema {
    my $self = shift;

    return &_new_schema(@_);
}

=head2 set_schema

    return 1;
}

=head2 run_with_schema

  $database->run_with_schema( $schema, sub {...} );

Restores the database handle saved by an earlier call to
C<$database-E<gt>set_schema> C<$database-E<gt>restore_schema> wrapper.

=cut

sub run_with_schema {
    my $self = shift;
    my $schema = shift or croak "No schema";
    my $code = shift or croak "No sub";

    $self->set_schema;
    local $@;
    my $ret = eval { $code->(@_) };
    my $died = $@;
    $self->restore_schema;
    die $died if $died;
    return $ret;
}

=head2 EXPORT

None by default.




package Koha::Handler::Plack;

# Copyright (c) 2016 Catalyst IT
#
# 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 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.

=head1 NAME

  Koha::Handler::Plack - Plack helper

=head1 SYNOPSIS

  koha.psgi:
  use Koha::Handler::Plack;

  my %HOST_CONF = (
      'koha1.com' => { ...  },
      'koha2.com' => { ...  },
      ...
  );
  # last line
  Koha::Handler::Plack->app_per_host(\%HOST_CONF);

  See C<app_per_host()> below

=head1 DESCRIPTION

  Some handy function to help with Koha/Plack in a multi-host situation.

  The problem:
  Koha app relies on env vars. This should be changed, ie C4::Context should
  be upgraded to Koha::App, but until then we need a gap filler. That's
  because once up, there's no way to pass on new env to a psgi container.
  In Apache, for instance, we can specify env vars per virtual host. Plack
  has no such concept.

  Solution:
  We need to modify the environment in situ, per virtual host - app_per_host().
  We specify env for each hostname, and apply.

=cut

use Modern::Perl;
use Carp;

use Plack::App::URLMap;

=head1 CLASS METHODS

=head2 app_per_host($host_apps)

  App wrapper for per virtual host scenario.

  C<$host_apps>:
      {
          hostname => 'koha1.com',
          app => $app1,
          context => $context1,
          shared_context => 1
      },
      {
          hostname => ['koha2.com', 'www.koha2.com'],
          app => $app2,
          context => $context2,
      },
      ...

  C<hostname> is mandatory.
  If C<shared_context> is set to true, some Context properties will be preserved across
  forked processes. Useful if both OPAC and Intranet apps are served here, so no restart
  is needed when Context cached properties cnamge values. Needs memcached.

  koha.psgi:

  use Plack::Builder;
  use Plack::App::CGIBin;

  use C4::Context ":no_config";

  my $opac_app = builder {
      enable "Plack::Middleware::Static",
              path => qr{^/opac-tmpl/}, root => '/usr/share/koha/opac/htdocs/';

      enable 'StackTrace';
      mount "/cgi-bin/koha" => Plack::App::CGIBin->new(root => "/usr/share/koha/opac/cgi-bin/opac");
  };
  my $intranet_app = builder {
      enable "Plack::Middleware::Static",
              path => qr{^/intranet-tmpl/}, root => '/usr/share/koha/intranet/htdocs/';

      enable 'StackTrace';
      mount "/cgi-bin/koha" => Plack::App::CGIBin->new(root => "/usr/share/koha/cgi-bin");
  };

  my @host_def;

  my $conf_file_1 = "/etc/koha/site-1/koha_conf.xml";
  my $context_1 = C4::Context->new($conf_file_1);
  push @host_def,
      {
          hostname => [ "public.host.for.site-1", "www.public.host.for.site-1" ],
          app => $opac_app,
          context => $context_1,
      },
      {
          hostname => "intranet.host.for.site-1",
          app => $intranet_app,
          context => $context_1,
      };

  my $conf_file_2 = "/etc/koha/site-1/koha_conf.xml";
  my $context_2 = C4::Context->new($conf_file_2);
  push @host_def,
      {
          hostname => "public.host.for.site-2",
          app => $opac_app,
          context => $context_2,
      },
      {
          hostname => "intranet.host.for.site-2",
          app => $intranet_app,
          context => $context_2,
      };

  ...

  Koha::Handler::Plack->app_per_host( \@host_def );

=cut

# We cannot store whole Context object, may contain non-serializable things
my @CONTEXT_UNSAFE_PROPERTIES = qw(sysprefs);
sub app_per_host {
    my $class = shift;
    my $sites = shift or die "No sites spec";

    my $map = Plack::App::URLMap->new;
    foreach my $site_params ( @$sites ) {
        my $hosts = $site_params->{hostname} or croak "No hostname";
        $hosts = [$hosts] unless ref $hosts;

        my $app = $site_params->{app} or croak "No app";
        my $context = $site_params->{context} or croak "No Koha Context";
        my $shared_context = $site_params->{shared_context};
        my $cache = $context->memcached;
        if ($shared_context) {
            if ($cache) {
                foreach (@CONTEXT_UNSAFE_PROPERTIES) {
                    # Clean slate
                    $cache->clear_from_cache($_);
                }
            }
            else {
                warn "shared_context works only with memcached";
            }
        }

        foreach my $host (@$hosts) {
            $map->map("http://$host/" => sub {
                my $env = shift;

                # may have stopped meanwhile or whatever
                my $cache = $context->memcached;
                if ($shared_context && $cache) {
                    foreach (@CONTEXT_UNSAFE_PROPERTIES) {
                        if (my $shared = $cache->get($_)) {
                            $context->{$_} = $shared;
                        }
                    }
                }

                my $ret = $context->run_within_context(sub { $app->($env) });

                if ($shared_context && $cache) {
                    foreach (@CONTEXT_UNSAFE_PROPERTIES) {
                        $cache->set($_, $context->{$_});
                    }
                }

                $ret;
            });
        }
    }
    return $map->to_app;
}

1;




package Koha::Handler::Plack::CGI;

# Copyright (c) 2016 Catalyst IT
#
# 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 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.

=head1 NAME

  Koha::Handler::Plack::CGI - Plack helper for CGI scripts

=head1 SYNOPSIS

  koha.psgi:
  use Koha::Handler::Plack::CGI;

  my %koha_env = (
      opac => {
          static_root => '/usr/share/koha/opac/htdocs',
          script_root => '/usr/share/koha/opac',
      },
      intranet => {
          static_root => '/usr/share/koha/intranet/htdocs',
          script_root => '/usr/share/koha/intranet'
      }
  );
  my @sites = (
      {
          opac_hostname => 'koha1-opac.com',
          intranet_hostname => 'koha1-intranet.com',
          config = '/etc/koha/koha1/koha-conf.xml'
      },
      {
          opac_hostname => ['opac.koha2.com', 'www.opackoha2.com'],
          intranet_hostname => ['intranet.koha2.com', 'www.intranetkoha2.com'],
          config = '/etc/koha/koha2/koha-conf.xml'
      },
  );

  # last line
  Koha::Handler::Plack::CGI->app_per_host(\%HOST_CONF);

  See C<app_per_host()> below

=head1 DESCRIPTION

  CGI script runner.

  One beautiful day wiwill move away from that and have proper App module
  with router and handlers</dream>

  See C<Koha::Handler::Plack>

=cut

use Modern::Perl;
use Carp;

use Plack::Builder;
use Plack::App::CGIBin;

use parent "Koha::Handler::Plack";

use C4::Context ":no_config";

=head1 CLASS METHODS

=head2 app($context, $env)

  Plack app builder fora CGI app

  C<$context>: "opac" or "intranet"
  C<$env>:
      {
          static_root => '...',
          script_root => '...',
          pugins => [
              [ 'StackTrace' ],
              ...
          ],
      }

  koha.psgi:

  Koha::Handler::Plack::CGI->app( "opac", \%opac_app_env );

=cut

sub app {
    my $class = shift;
    my $context = shift;
    croak "Invalid app context '$context' - must be 'opac' or 'intranet'"
      unless $context =~ m/^(opac|intranet)$/;
    my $env = shift or croak "No $context env details";

    my $static_root = $env->{static_root} or croak "No $context static_root";
    $static_root = "$static_root/" unless $static_root =~ m!/$!;
    my $script_root = $env->{script_root} or croak "No $context script_root";
    $script_root =~ s!/$!!;
    my $plugins = $env->{plugins} || [];
    my $is_intranet = $context eq "intranet";

    builder {
        enable "Plack::Middleware::Static",
                path => qr{^/$context-tmpl/}, root => $static_root;

        map enable(@$_), @$plugins;

        mount "/cgi-bin/koha" => Plack::App::CGIBin->new(root => $script_root)->to_app;
        mount "/" => sub {
            return [ 302, [ Location => '/cgi-bin/koha/' . ( $is_intranet ? 'mainpage.pl' : 'opac-main.pl' ) ], [] ];
        };
    };
}

=head2 multi_site($env, $sites)

  App wrapper for per virtual host scenario.

  C<$env>:
      {
          opac => {
              static_root => '/usr/share/koha/opac/htdocs',
              script_root => '/usr/share/koha/opac/cgi-bin/opac',
              pugins => [
                  [ 'StackTrace' ],
              ],
          },
          intranet => {
              static_root => '/usr/share/koha/intranet/htdocs',
              script_root => '/usr/share/koha/cgi-bin'
          }
      }
  C<$sites>:
      {
          namespace => 'koha1',
          opac_hostname => 'koha1-opac.com',
          intranet_hostname => 'koha1-intranet.com',
          config => '/etc/koha/sites/koha1/koha-conf.xml',
          shared_config => 1
      },
      {
          namespace => 'koha2',
          opac_hostname => ['opac.koha2.com', 'www.opackoha2.com'],
          intranet_hostname => ['intranet.koha2.com', 'www.intranetkoha2.com'],
          config => '/etc/koha/sites/koha2/koha-conf.xml'
      },
      ...

  koha.psgi:

  Koha::Handler::Plack::CGI->multi_site( \%koha_app_env, \@sites );

=cut

my $DUMMY_KOHA_CONF = "<yazgfs><config>DUMMY</config></yazgfs>";
sub multi_site {
    my $class = shift;
    my $env = shift or croak "No Koha env details";
    my $sites = shift or croak "No sites spec";

    my ($opac_app, $intranet_app);

    if (my $opac = $env->{opac}) {
        $opac_app = $class->app('opac', $opac);
    }

    if (my $intranet = $env->{intranet}) {
        $intranet_app = $class->app('intranet', $intranet);
    }

    my @host_def = map {
        my $namespace      = $_->{namespace} or croak "No namespace";
        my $config         = $_->{config}    or croak "Site without config";
        my $shared_context = $_->{shared_context};

        my $context = C4::Context->new($config, $namespace);

        my @hd;
        if (my $hostname = $_->{opac_hostname}) {
            croak "You have OPAC hosts without OPAC env details" unless $opac_app;
            push @hd, {
                hostname => $hostname,
                app => sub {
                    # XXX this may need some rethinking
                    local $ENV{KOHA_CONF} = \$DUMMY_KOHA_CONF;
                    local $ENV{MEMCACHED_NAMESPACE} = $namespace;

                    $opac_app->(@_);
                },
                context => $context,
                shared_context => $shared_context,
            };
        }
        if (my $hostname = $_->{intranet_hostname}) {
            croak "You have Intranet hosts without Intranet env details" unless $intranet_app;
            push @hd, {
                hostname => $hostname,
                app => sub {
                    # XXX this may need some rethinking
                    local $ENV{KOHA_CONF} = \$DUMMY_KOHA_CONF;
                    local $ENV{MEMCACHED_NAMESPACE} = $namespace;

                    $intranet_app->(@_);
                },
                context => $context,
                shared_context => $shared_context,
            };
        }
        @hd;
    } @$sites;

    return $class->app_per_host( \@host_def );
}

1;

Lines 25-31 use C4::Charset qw( MarcToUTF8Record ); Link Here

(-)a/Koha/MetaSearcher.pm (-2 / +2 lines)
25	use C4::Search qw(); # Purely for new_record_from_zebra	25	use C4::Search qw(); # Purely for new_record_from_zebra
26	use DBIx::Class::ResultClass::HashRefInflator;	26	use DBIx::Class::ResultClass::HashRefInflator;
27	use IO::Select;	27	use IO::Select;
28	use Koha::Caches;	28	use C4::Context;
29	use Koha::Database;	29	use Koha::Database;
30	use Koha::MetadataRecord;	30	use Koha::MetadataRecord;
31	use MARC::File::XML;	31	use MARC::File::XML;
Lines 91-97 sub search { Link Here
91		91
92	my $resultset_expiry = 300;	92	my $resultset_expiry = 300;
93		93
94	my $cache = Koha::Caches->get_instance();	94	my $cache = C4::Context->cache;
95	my $schema = Koha::Database->new->schema;	95	my $schema = Koha::Database->new->schema;
96	my $stats = {	96	my $stats = {
97	num_fetched => {	97	num_fetched => {

Lines 21-27 use strict; Link Here

(-)a/Koha/Template/Plugin/Cache.pm (-3 / +1 lines)
21	use warnings;	21	use warnings;
22	use base qw( Template::Plugin );	22	use base qw( Template::Plugin );
23	use Template::Plugin;	23	use Template::Plugin;
24	use C4::Context;
25		24
26	#------------------------------------------------------------------------	25	#------------------------------------------------------------------------
27	# new(\%options)	26	# new(\%options)
Lines 34-41 sub new { Link Here
34	$cache = delete $params->{cache};	33	$cache = delete $params->{cache};
35	}	34	}
36	else {	35	else {
37	require Koha::Cache;	36	$cache = $context->cache;
38	$cache = Koha::Caches->get_instance();
39	}	37	}
40	my $self = bless {	38	my $self = bless {
41	CACHE => $cache,	39	CACHE => $cache,




use Koha::Acquisition::Currencies;
use Koha::Patron::Categories;
use Koha::Patrons;
use Koha::Caches;
use Koha::Config::SysPrefs;
use Koha::Illrequest::Config;
use Koha::SearchEngine::Elasticsearch;

my $memcached_servers   = $ENV{MEMCACHED_SERVERS} || C4::Context->config('memcached_servers');
my $memcached_namespace = $ENV{MEMCACHED_NAMESPACE} || C4::Context->config('memcached_namespace') // 'koha';

my $cache = C4::Context->cache;
my $effective_caching_method = ref($cache->cache);
# Memcached may have been running when plack has been initialized but could have been stopped since
# FIXME What are the consequences of that??


my @xml_config_warnings;

my $context = C4::Context->current;

if ( ! defined C4::Context->config('zebra_bib_index_mode') ) {
    push @xml_config_warnings, {




use Koha::Biblios;
use Koha::BiblioFramework;
use Koha::BiblioFrameworks;
use Koha::Caches;

my $input         = new CGI;
my $frameworkcode = $input->param('frameworkcode') || q||;
my $op            = $input->param('op') || q|list|;
my $cache         = C4::Context->cache;
my @messages;

my ( $template, $borrowernumber, $cookie ) = get_template_and_user(

Lines 43-49 my ( $template, $borrowernumber, $cookie ) = get_template_and_user ( Link Here

(-)a/admin/koha2marclinks.pl (-1 / +1 lines)
43	);	43	);
44		44
45	my $schema = Koha::Database->new->schema;	45	my $schema = Koha::Database->new->schema;
46	my $cache = Koha::Caches->get_instance();	46	my $cache = C4::Context->cache;
47		47
48	# Update data before showing the form	48	# Update data before showing the form
49	my $no_upd;	49	my $no_upd;

Lines 79-85 my ( $template, $borrowernumber, $cookie ) = get_template_and_user( Link Here

(-)a/admin/marc_subfields_structure.pl (-1 / +1 lines)
79	debug => 1,	79	debug => 1,
80	}	80	}
81	);	81	);
82	my $cache = Koha::Caches->get_instance();	82	my $cache = C4::Context->cache;
83		83
84	my $op = $input->param('op') \|\| "";	84	my $op = $input->param('op') \|\| "";
85	$tagfield =~ s/\,//g;	85	$tagfield =~ s/\,//g;




use C4::Koha;
use C4::Context;
use C4::Output;
use C4::Context;

use Koha::Caches;
use Koha::AuthorisedValues;
use Koha::BiblioFrameworks;

# retrieve parameters
my $input = new CGI;

my $script_name = "/cgi-bin/koha/admin/marctagstructure.pl";

my $dbh = C4::Context->dbh;
my $cache = C4::Context->cache;

# open template
my ($template, $loggedinuser, $cookie)

Lines 385-391 output_html_with_http_headers $input, $cookie, $template->output; Link Here

(-)a/admin/systempreferences.pl (-1 / +1 lines)
385	# .pref files.	385	# .pref files.
386		386
387	sub get_prefs_from_files {	387	sub get_prefs_from_files {
388	my $context = C4::Context->new();	388	my $context = C4::Context->current();
389	my $path_pref_en = $context->config('intrahtdocs') .	389	my $path_pref_en = $context->config('intrahtdocs') .
390	'/prog/en/modules/admin/preferences';	390	'/prog/en/modules/admin/preferences';
391	# Get all .pref file names	391	# Get all .pref file names




use C4::InstallAuth;
use CGI qw ( -utf8 );
use POSIX qw(strftime);
use Capture::Tiny qw(capture);

use C4::Context;
use C4::Output;

            chk_log( $logdir, "updatedatabase-error_$filename_suffix" )
        );

        my $script = C4::Context->config("intranetdir") . "/installer/data/$info{dbms}/updatedatabase.pl";
        my ($stdout, $stderr, $exit) = capture { do( $script ) };
        warn "Cannot execute $script: ".($@ || $!) if $@ || $!;

        if ($stdout) {
            if ( open( my $fh, ">>", $logfilepath ) ) {
                print $fh $stdout;
                close $fh;
            }
            else {
                warn "Cannot open log file $logfilepath: $!";
            }
            $template->param( update_report => [ map { line => $_ }, split( /\n/, $stdout ) ] );
                  [ map { { line => $_ } } split( /\n/, join( '', @report ) ) ]
            );
            $template->param( has_update_succeeds => 1 );
        }
        else {
#           eval { `rm $logfilepath` };
        }
        if ($stderr) {
            if ( open( my $fh, ">>", $logfilepath_errors ) ) {
                print $fh $stderr;
                close $fh;
            }
            else {
                warn "Cannot open log file $logfilepath_errors: $!";
            }
            my @errors = split( /\n/, $stderr );
            $template->param( update_errors => [ map { line => $_ }, @errors ] );
            $template->param( has_update_errors => 1 );
            warn "The following errors were returned while attempting to run the updatedatabase.pl script:\n";
            warn $_ foreach @errors;
            foreach my $line (@report) { warn "$line\n"; }
        }
        else {
#           eval { `rm $logfilepath_errors` };
        }
        $template->param( $op => 1 );
    }

Lines 190-196 sub check_all_url { Link Here

(-)a/misc/cronjobs/check-url.pl (-1 / +1 lines)
190	my $checker = C4::URL::Checker->new($timeout,$agent);	190	my $checker = C4::URL::Checker->new($timeout,$agent);
191	$checker->{ host_default } = $host;	191	$checker->{ host_default } = $host;
192		192
193	my $context = new C4::Context( );	193	my $context = C4::Context->current();
194	my $dbh = $context->dbh;	194	my $dbh = $context->dbh;
195	my $sth = $dbh->prepare(	195	my $sth = $dbh->prepare(
196	"SELECT biblionumber FROM biblioitems WHERE url <> ''" );	196	"SELECT biblionumber FROM biblioitems WHERE url <> ''" );




#!/usr/bin/perl

use Koha::Handler::Plack::CGI;

# If modules are not in a standard location
# use lib '/usr/share/koha/lib' or set PERL5LIB or plackup -I

# This is a minimal example. You can include all frills from koha.psgi
# To try it:
# plackup --port 5010 koha-multi.psgi

my %KOHA_ENV = (
  opac => {
      static_root => '/usr/share/koha/opac/htdocs',
      script_root => '/usr/share/koha/opac/cgi-bin/opac',
      pugins => [
	# don't enable this plugin in production, since stack traces reveal too much information
	# about system to potential attackers!
          [ 'StackTrace' ],
      ],
  },
  intranet => {
      static_root => '/usr/share/koha/intranet/htdocs',
      script_root => '/usr/share/koha/intranet/cgi-bin',
  }
);
my @SITES = map {
    namespace => $_,
    opac_hostname => "opac.$_.my-koha-multisite.net",
    intranet_hostname => "intranet.$_.my-koha-multisite.net",
    config => "/etc/koha/sites/$_/koha-conf.xml"
}, qw(koha1 koha2 koha3);

Koha::Handler::Plack::CGI->multi_site( \%KOHA_ENV, \@SITES );

Lines 56-62 sub new { Link Here

(-)a/misc/translator/LangInstaller.pm (-2 / +2 lines)
56		56
57	my $self = { };	57	my $self = { };
58		58
59	my $context = C4::Context->new();	59	my $context = C4::Context->current();
60	$self->{context} = $context;	60	$self->{context} = $context;
61	$self->{path_pref_en} = $context->config('intrahtdocs') .	61	$self->{path_pref_en} = $context->config('intrahtdocs') .
62	'/prog/en/modules/admin/preferences';	62	'/prog/en/modules/admin/preferences';
Lines 140-146 sub new { Link Here
140	sub po_filename {	140	sub po_filename {
141	my $self = shift;	141	my $self = shift;
142		142
143	my $context = C4::Context->new;	143	my $context = C4::Context->current();
144	my $trans_path = $Bin . '/po';	144	my $trans_path = $Bin . '/po';
145	my $trans_file = "$trans_path/" . $self->{lang} . "-pref.po";	145	my $trans_file = "$trans_path/" . $self->{lang} . "-pref.po";
146	return $trans_file;	146	return $trans_file;





use Modern::Perl;

use C4::Context;
use C4::Reports::Guided;
use JSON;
use CGI qw ( -utf8 );

use Koha::Caches;

my $query       = CGI->new();
my $report_id   = $query->param('id');
my $report_name = $query->param('name');


my @sql_params  = $query->param('sql_params');

my $cache = C4::Context->cache;
my $cache_active = $cache->is_cache_active;
my ($cache_key, $json_text);
if ($cache_active) {

Lines 29-35 use C4::Auth qw/:DEFAULT get_session/; Link Here

(-)a/reports/guided_reports.pl (-2 / +1 lines)
29	use C4::Output;	29	use C4::Output;
30	use C4::Debug;	30	use C4::Debug;
31	use C4::Context;	31	use C4::Context;
32	use Koha::Caches;
33	use C4::Log;	32	use C4::Log;
34	use Koha::DateUtils qw/dt_from_string output_pref/;	33	use Koha::DateUtils qw/dt_from_string output_pref/;
35	use Koha::AuthorisedValue;	34	use Koha::AuthorisedValue;
Lines 49-55 Script to control the guided report creation Link Here
49	=cut	48	=cut
50		49
51	my $input = new CGI;	50	my $input = new CGI;
52	my $usecache = Koha::Caches->get_instance->memcached_cache;	51	my $usecache = C4::Context->cache->memcached_cache;
53		52
54	my $phase = $input->param('phase') // '';	53	my $phase = $input->param('phase') // '';
55	my $flagsrequired;	54	my $flagsrequired;

Lines 25-31 use C4::Reports::Guided; Link Here

(-)a/svc/report (-2 / +2 lines)
25	use JSON;	25	use JSON;
26	use CGI qw ( -utf8 );	26	use CGI qw ( -utf8 );
27		27
28	use Koha::Caches;	28	use C4::Context;
29		29
30		30
31	my $query = CGI->new();	31	my $query = CGI->new();
Lines 48-54 my ( $template, $loggedinuser, $cookie ) = get_template_and_user( Link Here
48	}	48	}
49	);	49	);
50		50
51	my $cache = Koha::Caches->get_instance();	51	my $cache = C4::Context->cache;
52	my $cache_active = $cache->is_cache_active;	52	my $cache_active = $cache->is_cache_active;
53	my ($cache_key, $json_text);	53	my ($cache_key, $json_text);
54	if ($cache_active) {	54	if ($cache_active) {

Lines 22-28 use Test::MockModule; Link Here

(-)a/t/Calendar.t (-2 / +2 lines)
22		22
23	use DateTime;	23	use DateTime;
24	use DateTime::Duration;	24	use DateTime::Duration;
25	use Koha::Caches;	25	use C4::Context;
26	use Koha::DateUtils;	26	use Koha::DateUtils;
27		27
28	use t::lib::Mocks;	28	use t::lib::Mocks;
Lines 76-82 fixtures_ok [ Link Here
76	],	76	],
77	], "add fixtures";	77	], "add fixtures";
78		78
79	my $cache = Koha::Caches->get_instance();	79	my $cache = C4::Context->cache;
80	$cache->clear_from_cache( 'single_holidays' ) ;	80	$cache->clear_from_cache( 'single_holidays' ) ;
81	$cache->clear_from_cache( 'exception_holidays' ) ;	81	$cache->clear_from_cache( 'exception_holidays' ) ;
82		82





use Modern::Perl;
use DBI;
use Test::More tests => 29;
use Test::MockModule;

BEGIN {

#Bug 14751
is( C4::Context->interface( 'SiP' ), 'sip', 'interface SiP' );
is( C4::Context->interface( 'COMMANDLINE' ), 'commandline', 'interface commandline uc' );

my $DUMMY_KOHA_CONF = "<yazgfs><config><kohasite>TEST</kohasite></config></yazgfs>";
my $ctx_a = C4::Context->new($DUMMY_KOHA_CONF, "a");
my $ctx_b = C4::Context->new($DUMMY_KOHA_CONF, "b");
my $cache_key = "test_C4::Context";

SKIP: {
    skip "No cache", 3 unless $ctx_a->cache->is_cache_active && $ctx_b->cache->is_cache_active;

    # Light warm up
    C4::Context->cache->set_in_cache($cache_key, 'c');
    $ctx_a->cache->set_in_cache($cache_key, 'a');
    $ctx_b->cache->set_in_cache($cache_key, 'b');
    is(C4::Context->cache->get_from_cache($cache_key), 'c', "Correct default cache value");
    is($ctx_a->cache->get_from_cache($cache_key), 'a', "Correct cache 'a' value");
    is($ctx_b->cache->get_from_cache($cache_key), 'b', "Correct cache 'b' value");

    # A bit more extravagant
    # Cannot run atm, fails due to no database in config
#   $ctx_a->run_within_context( sub {
#       $ctx_b->cache->set_in_cache($cache_key, 'bb');
#       C4::Context->cache->set_in_cache($cache_key, 'aa');
#   } );
#   is($ctx_a->cache->get_from_cache($cache_key), 'aa', "Correct cache 'a' value");
#   is($ctx_b->cache->get_from_cache($cache_key), 'bb', "Correct cache 'b' value");
}




#!/usr/bin/perl

use Test::More tests => 15;
use Plack::Test;
use Plack::Test::MockHTTP;
use Test::Mock::LWP::Dispatch;
use Test::MockModule;
use HTTP::Request::Common;
use FindBin qw($Bin);
use Data::Dumper;

use_ok("Koha::Handler::Plack");
use_ok("Koha::Handler::Plack::CGI");

use C4::Context;

my $db = Test::MockModule->new('Koha::Database');
$db->mock(
    _new_schema => sub {
        return $_[0];
    }
);

sub make_response {
    return join ";", map defined($_) ? $_ : "", @_;
}
sub dummy_val {
    return C4::Context->config("dummy");
}
sub check_context {
    my $dummy_val = dummy_val();
    is $dummy_val, undef, "context preserved"
      or diag("dummy val: $dummy_val");
}

my $app = sub {
    return [
        200,
        [ 'Content-Type' => 'text/plain' ],
        [ make_response(dummy_val()) ]
    ];
};
my $generic_url = "http://dummyhost.com/";

my $KOHA_CONF_XML = <<EOS;
<yazgfs>
    <config>
        <kohasite>test</kohasite>
        <dummy>XML</dummy>
        <intrahtdocs>.</intrahtdocs>
    </config>
</yazgfs>
EOS

my @HOST_CONF = (
    {
        hostname => ['koha-file.com', 'www.koha-file.com'],
        app => $app,
        context => C4::Context->new("$Bin/conf/koha1/koha-conf.xml"),
        _dummy => "KOHA1"
    },
    {
        hostname => ['koha-xml.com', 'www.koha-xml.com'],
        app => $app,
        context => C4::Context->new(\$KOHA_CONF_XML),
        _dummy => "XML"
    },
);
test_psgi
    app => Koha::Handler::Plack->app_per_host(\@HOST_CONF),
    client => sub {
        my $cb  = shift;

        foreach my $site_params ( @HOST_CONF ) {
            my $valid_response = make_response(
                $site_params->{_dummy}
            );
            foreach (@{$site_params->{hostname}}) {
                my $res = $cb->(GET "http://$_/");
                is $res->content, $valid_response, $_
                  or diag(Dumper($site_params, $_, $res->as_string));
                check_context();
            }
        }

        $res = $cb->(GET $generic_url);
        is $res->code, 404, "app_per_host unknown host"
          or diag($res->as_string);
    };

my %MULTI_HOST_ENV = (
    opac => {
        static_root => "$Bin/../koha-tmpl/opac-tmpl/bootstrap",
        script_root => "$Bin/../opac",
    },
    intranet => {
        static_root => "$Bin/../koha-tmpl/intranet-tmpl/bootstrap",
        script_root => "$Bin/.."
    }
);
my @MULTI_HOST_SITES = (
    {
        namespace => 'koha1',
        opac_hostname => ['opac.koha1.com', 'www.opac.koha1.com'],
        intranet_hostname => ['intranet.koha1.com', 'www.intranet.koha1.com'],
        config => "$Bin/conf/koha1/koha-conf.xml",
    },
    {
        namespace => 'koha2',
        opac_hostname => ['opac.koha2.com', 'www.opac.koha2.com'],
        intranet_hostname => ['intranet.koha2.com', 'www.intranet.koha2.com'],
        config => "$Bin/conf/koha2/koha-conf.xml",
        shared_context => 1,
    },
);
test_psgi
    app => Koha::Handler::Plack::CGI->multi_site(\%MULTI_HOST_ENV, \@MULTI_HOST_SITES),
    client => sub {
        my $cb  = shift;

        foreach my $site (@MULTI_HOST_SITES) {
            my $opac = $site->{opac_hostname};
            foreach my $host (@$opac) {
# this is not really a test, but cannot do any better atm
# TODO: a complex test involving two database connections
                my $res = $cb->(GET "http://$host/");
                # A future implementation may not redirect
                if ($res->is_redirect) {
                    my $loc = $res->header("Location");
                    $res = $cb->(GET "http://$host$loc");
                }
                is $res->code, 500, "multi_site() $host"
                  or diag($res->as_string);
            }
        }
    };

Lines 1-6 Link Here

(-)a/t/Koha_Template_Plugin_Cache.t (-1 / +3 lines)
1	use Modern::Perl;	1	use Modern::Perl;
2	use Test::More tests => 2;	2	use Test::More tests => 2;
3		3
		4	use C4::Context;
		5
4	use_ok('Koha::Template::Plugin::Cache');	6	use_ok('Koha::Template::Plugin::Cache');
5		7
6	ok(my $cache = Koha::Template::Plugin::Cache->new());	8	ok(my $cache = Koha::Template::Plugin::Cache->new(C4::Context->current));

Line 0 Link Here

(-)a/t/conf/dummy/koha-conf.xml (+7 lines)
	1	<yazgfs>
	2	<config>
	3	<kohasite>dummy</kohasite>
	4	<dummy>DUMMY</dummy>
	5	<intrahtdocs>.</intrahtdocs>
	6	</config>
	7	</yazgfs>

Line 0 Link Here

(-)a/t/conf/koha1/koha-conf.xml (+7 lines)
	1	<yazgfs>
	2	<config>
	3	<kohasite>koha1</kohasite>
	4	<dummy>KOHA1</dummy>
	5	<intrahtdocs>.</intrahtdocs>
	6	</config>
	7	</yazgfs>

Line 0 Link Here

(-)a/t/conf/koha2/koha-conf.xml (+5 lines)
	1	<yazgfs>
	2	<config>
	3	<dummy>KOHA2</dummy>
	4	</config>
	5	</yazgfs>

Lines 14-20 BEGIN { Link Here

(-)a/t/db_dependent/Amazon.t (-1 / +1 lines)
14	use_ok('C4::External::Amazon');	14	use_ok('C4::External::Amazon');
15	}	15	}
16		16
17	my $context = C4::Context->new();	17	my $context = C4::Context->current();
18		18
19	my $locale = $context->preference('AmazonLocale');	19	my $locale = $context->preference('AmazonLocale');
20		20





BEGIN {
    $debug = $ENV{DEBUG} || 0;

    # Note: The overall number of tests may vary by configuration.
    # First we need to check your environmental variables
    for (qw(KOHA_CONF PERL5LIB)) {
        ok( $ret = $ENV{$_}, "ENV{$_} = $ret" );
    }
    use_ok('C4::Context');
}
use_ok('C4::Context');

ok($dbh = C4::Context->dbh(), 'Getting dbh from C4::Context');


C4::Context->enable_syspref_cache();
$dbh->rollback;

ok($koha = C4::Context->current,  'C4::Context->current');
my @keys = keys %$koha;
my $width = 0;
if (ok(@keys)) { 




use MARC::Field;
use C4::Context;
use C4::Biblio;
use Koha::Caches;
use Koha::Database;

BEGIN {


        $sth->execute($hidden_value);

        my $cache = C4::Context->cache;
        $cache->flush_all();    # easy way to ensure DB is queried again.

        my $processor = Koha::RecordProcessor->new(


    $sth->execute(-1); # -1 is visible in opac and intranet.

    my $cache = C4::Context->cache;
    $cache->flush_all();    # easy way to ensure DB is queried again.

    my $shouldhidemarc = Koha::Filter::MARC::ViewPolicy->should_hide_marc(




use Data::Dumper;

use MARC::Record;
use C4::Context;
use C4::Biblio;
use Koha::Database;
use Koha::DateUtils qw( dt_from_string );

    $dbh->do('INSERT INTO marc_subfield_structure (tagfield, tagsubfield, frameworkcode) VALUES (?, "z", ?)', undef, $itemfield, $frameworkcode);

    # Clear cache
    my $cache = C4::Context->cache;
    $cache->clear_from_cache("MarcStructure-0-$frameworkcode");
    $cache->clear_from_cache("MarcStructure-1-$frameworkcode");
    $cache->clear_from_cache("default_value_for_mod_marc-");

    Koha::MarcSubfieldStructures->search({ frameworkcode => '', tagfield => '952', tagsubfield => 'p' })->delete;

    # And make sure the caches are cleared
    my $cache = C4::Context->cache;
    $cache->clear_from_cache("default_value_for_mod_marc-");
    $cache->clear_from_cache("MarcSubfieldStructure-");


Lines 14-20 BEGIN { Link Here

(-)a/t/db_dependent/Template/Plugin/KohaDates.t (-1 / +1 lines)
14	my $module_context = new Test::MockModule('C4::Context');	14	my $module_context = new Test::MockModule('C4::Context');
15		15
16	my $date = "1973-05-21";	16	my $date = "1973-05-21";
17	my $context = C4::Context->new();	17	my $context = C4::Context->current();
18		18
19	my $filter = Koha::Template::Plugin::KohaDates->new();	19	my $filter = Koha::Template::Plugin::KohaDates->new();
20	ok ($filter, "new()");	20	ok ($filter, "new()");

Lines 26-32 my $search_module = new Test::MockModule('C4::Search'); Link Here

(-)a/t/db_dependent/XISBN.t (-1 / +1 lines)
26		26
27	$search_module->mock('SimpleSearch', \&Mock_SimpleSearch );	27	$search_module->mock('SimpleSearch', \&Mock_SimpleSearch );
28	my $errors;	28	my $errors;
29	my $context = C4::Context->new;	29	my $context = C4::Context->current;
30		30
31	my ( $biblionumber_tag, $biblionumber_subfield ) =	31	my ( $biblionumber_tag, $biblionumber_subfield ) =
32	GetMarcFromKohaField( 'biblio.biblionumber', '' );	32	GetMarcFromKohaField( 'biblio.biblionumber', '' );




# along with Koha; if not, see <http://www.gnu.org/licenses>.

use Modern::Perl;
use Test::More tests => 11;
use C4::Context;

# Start transaction

C4::Context->clear_syspref_cache();
is(C4::Context->preference('testpreference'), undef, 'clearing preference cache');

delete $ENV{OVERRIDE_SYSPREF_opacheader};

my $DUMMY_KOHA_CONF = "<yazgfs><config><dummy>DUMMY</dummy></config></yazgfs>";
my $context1 = C4::Context->new($DUMMY_KOHA_CONF, "context1");
is( $context1->preference('opacheader'), $opacheader, 'context1 "opacheader"');

my $context2 = C4::Context->new($DUMMY_KOHA_CONF, "context2");
$context2->set_preference( 'opacheader', $newopacheader );
is( $context1->preference('opacheader'), $opacheader, 'context1 "opacheader"');
is( $context2->preference('opacheader'), $newopacheader, 'context2 "opacheader"');

$dbh->rollback;

Lines 24-30 use CGI qw ( -utf8 ); Link Here

(-)a/tools/newHolidays.pl (-2 / +2 lines)
24	use C4::Auth;	24	use C4::Auth;
25	use C4::Output;	25	use C4::Output;
26		26
27	use Koha::Caches;	27	use C4::Context;
28		28
29	use C4::Calendar;	29	use C4::Calendar;
30	use DateTime;	30	use DateTime;
Lines 142-147 sub add_holiday { Link Here
142	}	142	}
143	}	143	}
144	# we updated the single_holidays table, so wipe its cache	144	# we updated the single_holidays table, so wipe its cache
145	my $cache = Koha::Caches->get_instance();	145	my $cache = C4::Context->cache;
146	$cache->clear_from_cache( 'single_holidays') ;	146	$cache->clear_from_cache( 'single_holidays') ;
147	}	147	}

Return to bug 15562

Lines 24-29 use diagnostics; Link Here

(-)a/installer/install.pl (-26 / +27 lines)
24	use C4::InstallAuth;	24	use C4::InstallAuth;
25	use CGI qw ( -utf8 );	25	use CGI qw ( -utf8 );
26	use POSIX qw(strftime);	26	use POSIX qw(strftime);
		27	use Capture::Tiny qw(capture);
27		28
28	use C4::Context;	29	use C4::Context;
29	use C4::Output;	30	use C4::Output;
Lines 389-428 elsif ( $step && $step == 3 ) { Link Here
389	chk_log( $logdir, "updatedatabase-error_$filename_suffix" )	390	chk_log( $logdir, "updatedatabase-error_$filename_suffix" )
390	);	391	);
391		392
392	my $cmd = C4::Context->config("intranetdir")	393	my $script = C4::Context->config("intranetdir") . "/installer/data/$info{dbms}/updatedatabase.pl";
393	. "/installer/data/$info{dbms}/updatedatabase.pl >> $logfilepath 2>> $logfilepath_errors";	394	my ($stdout, $stderr, $exit) = capture { do( $script ) };
		395	warn "Cannot execute $script: ".($@ \|\| $!) if $@ \|\| $!;
394		396
395	system($cmd );	397	if ($stdout) {
396		398	if ( open( my $fh, ">>", $logfilepath ) ) {
397	my $fh;	399	print $fh $stdout;
398	open( $fh, "<:encoding(utf-8)", $logfilepath )	400	close $fh;
399	or die "Cannot open log file $logfilepath: $!";	401	}
400	my @report = <$fh>;	402	else {
401	close $fh;	403	warn "Cannot open log file $logfilepath: $!";
402	if (@report) {	404	}
403	$template->param( update_report =>	405	$template->param( update_report => [ map { line => $_ }, split( /\n/, $stdout ) ] );
404	[ map { { line => $_ } } split( /\n/, join( '', @report ) ) ]
405	);
406	$template->param( has_update_succeeds => 1 );	406	$template->param( has_update_succeeds => 1 );
407	}	407	}
408	else {	408	else {
409	eval { `rm $logfilepath` };	409	# eval { `rm $logfilepath` };
410	}	410	}
411	open( $fh, "<:encoding(utf-8)", $logfilepath_errors )	411	if ($stderr) {
412	or die "Cannot open log file $logfilepath_errors: $!";	412	if ( open( my $fh, ">>", $logfilepath_errors ) ) {
413	@report = <$fh>;	413	print $fh $stderr;
414	close $fh;	414	close $fh;
415	if (@report) {	415	}
416	$template->param( update_errors =>	416	else {
417	[ map { { line => $_ } } split( /\n/, join( '', @report ) ) ]	417	warn "Cannot open log file $logfilepath_errors: $!";
418	);	418	}
		419	my @errors = split( /\n/, $stderr );
		420	$template->param( update_errors => [ map { line => $_ }, @errors ] );
419	$template->param( has_update_errors => 1 );	421	$template->param( has_update_errors => 1 );
420	warn	422	warn "The following errors were returned while attempting to run the updatedatabase.pl script:\n";
421	"The following errors were returned while attempting to run the updatedatabase.pl script:\n";	423	warn $_ foreach @errors;
422	foreach my $line (@report) { warn "$line\n"; }
423	}	424	}
424	else {	425	else {
425	eval { `rm $logfilepath_errors` };	426	# eval { `rm $logfilepath_errors` };
426	}	427	}
427	$template->param( $op => 1 );	428	$template->param( $op => 1 );
428	}	429	}

Lines 31-37 use C4::Templates; # to get the template Link Here

(-)a/C4/Auth.pm (-4 / +4 lines)
31	use C4::Languages;	31	use C4::Languages;
32	use C4::Search::History;	32	use C4::Search::History;
33	use Koha;	33	use Koha;
34	use Koha::Caches;
35	use Koha::AuthUtils qw(get_script_name hash_password);	34	use Koha::AuthUtils qw(get_script_name hash_password);
36	use Koha::DateUtils qw(dt_from_string);	35	use Koha::DateUtils qw(dt_from_string);
37	use Koha::Library::Groups;	36	use Koha::Library::Groups;
Lines 1734-1742 sub _get_session_params { Link Here
1734	my $dbh = C4::Context->dbh;	1733	my $dbh = C4::Context->dbh;
1735	return { dsn => "driver:PostgreSQL;serializer:yaml;id:md5", dsn_args => { Handle => $dbh } };	1734	return { dsn => "driver:PostgreSQL;serializer:yaml;id:md5", dsn_args => { Handle => $dbh } };
1736	}	1735	}
1737	elsif ( $storage_method eq 'memcached' && Koha::Caches->get_instance->memcached_cache ) {	1736	elsif ( $storage_method eq 'memcached' ) {
1738	my $memcached = Koha::Caches->get_instance()->memcached_cache;	1737	if ( my $memcached = C4::Context->cache->memcached_cache ) {
1739	return { dsn => "driver:memcached;serializer:yaml;id:md5", dsn_args => { Memcached => $memcached } };	1738	return { dsn => "driver:memcached;serializer:yaml;id:md5", dsn_args => { Memcached => $memcached } };
		1739	}
1740	}	1740	}
1741	else {	1741	else {
1742	# catch all defaults to tmp should work on all systems	1742	# catch all defaults to tmp should work on all systems

Lines 38-45 use C4::Charset; Link Here

(-)a/C4/Biblio.pm (-3 / +3 lines)
38	use C4::Linker;	38	use C4::Linker;
39	use C4::OAI::Sets;	39	use C4::OAI::Sets;
40	use C4::Debug;	40	use C4::Debug;
		41	use C4::Context;
41		42
42	use Koha::Caches;
43	use Koha::Authority::Types;	43	use Koha::Authority::Types;
44	use Koha::Acquisition::Currencies;	44	use Koha::Acquisition::Currencies;
45	use Koha::Biblio::Metadata;	45	use Koha::Biblio::Metadata;
Lines 899-905 sub GetMarcStructure { Link Here
899		899
900	$forlibrarian = $forlibrarian ? 1 : 0;	900	$forlibrarian = $forlibrarian ? 1 : 0;
901	my $unsafe = ($params && $params->{unsafe})? 1: 0;	901	my $unsafe = ($params && $params->{unsafe})? 1: 0;
902	my $cache = Koha::Caches->get_instance();	902	my $cache = C4::Context->cache;
903	my $cache_key = "MarcStructure-$forlibrarian-$frameworkcode";	903	my $cache_key = "MarcStructure-$forlibrarian-$frameworkcode";
904	my $cached = $cache->get_from_cache($cache_key, { unsafe => $unsafe });	904	my $cached = $cache->get_from_cache($cache_key, { unsafe => $unsafe });
905	return $cached if $cached;	905	return $cached if $cached;
Lines 1009-1015 sub GetMarcSubfieldStructure { Link Here
1009		1009
1010	$frameworkcode //= '';	1010	$frameworkcode //= '';
1011		1011
1012	my $cache = Koha::Caches->get_instance();	1012	my $cache = C4::Context->cache;
1013	my $cache_key = "MarcSubfieldStructure-$frameworkcode";	1013	my $cache_key = "MarcSubfieldStructure-$frameworkcode";
1014	my $cached = $cache->get_from_cache($cache_key);	1014	my $cached = $cache->get_from_cache($cache_key);
1015	return $cached if $cached;	1015	return $cached if $cached;

Lines 23-29 use Carp; Link Here

(-)a/C4/Calendar.pm (-8 / +7 lines)
23	use Date::Calc qw( Date_to_Days Today);	23	use Date::Calc qw( Date_to_Days Today);
24		24
25	use C4::Context;	25	use C4::Context;
26	use Koha::Caches;
27		26
28	use constant ISO_DATE_FORMAT => "%04d-%02d-%02d";	27	use constant ISO_DATE_FORMAT => "%04d-%02d-%02d";
29		28
Lines 276-282 sub insert_single_holiday { Link Here
276		275
277		276
278	# changed the 'single_holidays' table, lets force/reset its cache	277	# changed the 'single_holidays' table, lets force/reset its cache
279	my $cache = Koha::Caches->get_instance();	278	my $cache = C4::Context->cache;
280	$cache->clear_from_cache( 'single_holidays') ;	279	$cache->clear_from_cache( 'single_holidays') ;
281	$cache->clear_from_cache( 'exception_holidays') ;	280	$cache->clear_from_cache( 'exception_holidays') ;
282		281
Lines 321-327 sub insert_exception_holiday { Link Here
321	$self->{'exception_holidays'}->{"$options{year}/$options{month}/$options{day}"}{description} = $options{description};	320	$self->{'exception_holidays'}->{"$options{year}/$options{month}/$options{day}"}{description} = $options{description};
322		321
323	# changed the 'single_holidays' table, lets force/reset its cache	322	# changed the 'single_holidays' table, lets force/reset its cache
324	my $cache = Koha::Caches->get_instance();	323	my $cache = C4::Context->cache;
325	$cache->clear_from_cache( 'single_holidays') ;	324	$cache->clear_from_cache( 'single_holidays') ;
326	$cache->clear_from_cache( 'exception_holidays') ;	325	$cache->clear_from_cache( 'exception_holidays') ;
327		326
Lines 422-428 UPDATE special_holidays SET title = ?, description = ? Link Here
422	$self->{'single_holidays'}->{"$options{year}/$options{month}/$options{day}"}{description} = $options{description};	421	$self->{'single_holidays'}->{"$options{year}/$options{month}/$options{day}"}{description} = $options{description};
423		422
424	# changed the 'single_holidays' table, lets force/reset its cache	423	# changed the 'single_holidays' table, lets force/reset its cache
425	my $cache = Koha::Caches->get_instance();	424	my $cache = C4::Context->cache;
426	$cache->clear_from_cache( 'single_holidays') ;	425	$cache->clear_from_cache( 'single_holidays') ;
427	$cache->clear_from_cache( 'exception_holidays') ;	426	$cache->clear_from_cache( 'exception_holidays') ;
428		427
Lines 465-471 UPDATE special_holidays SET title = ?, description = ? Link Here
465	$self->{'exception_holidays'}->{"$options{year}/$options{month}/$options{day}"}{description} = $options{description};	464	$self->{'exception_holidays'}->{"$options{year}/$options{month}/$options{day}"}{description} = $options{description};
466		465
467	# changed the 'single_holidays' table, lets force/reset its cache	466	# changed the 'single_holidays' table, lets force/reset its cache
468	my $cache = Koha::Caches->get_instance();	467	my $cache = C4::Context->cache;
469	$cache->clear_from_cache( 'single_holidays') ;	468	$cache->clear_from_cache( 'single_holidays') ;
470	$cache->clear_from_cache( 'exception_holidays') ;	469	$cache->clear_from_cache( 'exception_holidays') ;
471		470
Lines 546-552 sub delete_holiday { Link Here
546	}	545	}
547		546
548	# changed the 'single_holidays' table, lets force/reset its cache	547	# changed the 'single_holidays' table, lets force/reset its cache
549	my $cache = Koha::Caches->get_instance();	548	my $cache = C4::Context->cache;
550	$cache->clear_from_cache( 'single_holidays') ;	549	$cache->clear_from_cache( 'single_holidays') ;
551	$cache->clear_from_cache( 'exception_holidays') ;	550	$cache->clear_from_cache( 'exception_holidays') ;
552		551
Lines 577-583 sub delete_holiday_range { Link Here
577	$sth->execute($self->{branchcode}, $options{day}, $options{month}, $options{year});	576	$sth->execute($self->{branchcode}, $options{day}, $options{month}, $options{year});
578		577
579	# changed the 'single_holidays' table, lets force/reset its cache	578	# changed the 'single_holidays' table, lets force/reset its cache
580	my $cache = Koha::Caches->get_instance();	579	my $cache = C4::Context->cache;
581	$cache->clear_from_cache( 'single_holidays') ;	580	$cache->clear_from_cache( 'single_holidays') ;
582	$cache->clear_from_cache( 'exception_holidays') ;	581	$cache->clear_from_cache( 'exception_holidays') ;
583		582
Lines 631-637 sub delete_exception_holiday_range { Link Here
631	$sth->execute($self->{branchcode}, $options{day}, $options{month}, $options{year});	630	$sth->execute($self->{branchcode}, $options{day}, $options{month}, $options{year});
632		631
633	# changed the 'single_holidays' table, lets force/reset its cache	632	# changed the 'single_holidays' table, lets force/reset its cache
634	my $cache = Koha::Caches->get_instance();	633	my $cache = C4::Context->cache;
635	$cache->clear_from_cache( 'single_holidays') ;	634	$cache->clear_from_cache( 'single_holidays') ;
636	$cache->clear_from_cache( 'exception_holidays') ;	635	$cache->clear_from_cache( 'exception_holidays') ;
637	}	636	}

Lines 32-38 BEGIN { Link Here

(-)a/C4/Context.pm (-152 / +158 lines)
32	eval {C4::Context->dbh();};	32	eval {C4::Context->dbh();};
33	if ($@){	33	if ($@){
34	$debug_level = 1;	34	$debug_level = 1;
35	}	35	}
36	else {	36	else {
37	$debug_level = C4::Context->preference("DebugLevel");	37	$debug_level = C4::Context->preference("DebugLevel");
38	}	38	}
Lines 50-56 BEGIN { Link Here
50	# a little example table with various version info";	50	# a little example table with various version info";
51	print "	51	print "
52	<h1>Koha error</h1>	52	<h1>Koha error</h1>
53	<p>The following fatal error has occurred:</p>	53	<p>The following fatal error has occurred:</p>
54	<pre><code>$msg</code></pre>	54	<pre><code>$msg</code></pre>
55	<table>	55	<table>
56	<tr><th>Apache</th><td> $versions{apacheVersion}</td></tr>	56	<tr><th>Apache</th><td> $versions{apacheVersion}</td></tr>
Lines 64-74 BEGIN { Link Here
64	} elsif ($debug_level eq "1"){	64	} elsif ($debug_level eq "1"){
65	print "	65	print "
66	<h1>Koha error</h1>	66	<h1>Koha error</h1>
67	<p>The following fatal error has occurred:</p>	67	<p>The following fatal error has occurred:</p>
68	<pre><code>$msg</code></pre>";	68	<pre><code>$msg</code></pre>";
69	} else {	69	} else {
70	print "<p>production mode - trapped fatal error</p>";	70	print "<p>production mode - trapped fatal error</p>";
71	}	71	}
72	print "</body></html>";	72	print "</body></html>";
73	}	73	}
74	#CGI::Carp::set_message(\&handle_errors);	74	#CGI::Carp::set_message(\&handle_errors);
Lines 96-101 use Koha::Caches; Link Here
96	use POSIX ();	96	use POSIX ();
97	use DateTime::TimeZone;	97	use DateTime::TimeZone;
98	use Module::Load::Conditional qw(can_load);	98	use Module::Load::Conditional qw(can_load);
		99	use Data::Dumper;
99	use Carp;	100	use Carp;
100	use DateTime::TimeZone;	101	use DateTime::TimeZone;
101		102
Lines 165-178 environment variable to the pathname of a configuration file to use. Link Here
165	# file (/etc/koha/koha-conf.xml).	166	# file (/etc/koha/koha-conf.xml).
166	# dbh	167	# dbh
167	# A handle to the appropriate database for this context.	168	# A handle to the appropriate database for this context.
168	# dbh_stack
169	# Used by &set_dbh and &restore_dbh to hold other database
170	# handles for this context.
171	# Zconn
172	# A connection object for the Zebra server	169	# A connection object for the Zebra server
173		170
174	$context = undef; # Initially, no context is set	171	@context_stack = (); # Initially, no saved contexts
175	@context_stack = (); # Initially, no saved contexts	172
		173	=head2 current
		174
		175	Returns the current context
		176
		177	=cut
		178
		179	sub current {
		180	return $context;
		181	}
		182
		183	=head2 cache
		184
		185	Returns the cache object or undef
		186
		187	=cut
		188
		189	sub cache {
		190	my $self = shift;
		191	$self = $context unless ref ($self);
		192
		193	return Koha::Caches->get_instance($self->{namespace});
		194	}
		195
		196	=head2 memcached
		197
		198	Returns the cache object if it is memcached or undef
		199
		200	=cut
		201
		202	sub memcached {
		203	my $self = shift;
		204	my $cache = $self->cache;
		205	return $cache if $cache->memcached_cache;
		206
		207	return;
		208	}
		209
		210	sub db_driver {
		211	my $self = shift;
		212
		213	$self = $context unless ref ($self);
		214	return unless $self;
		215
		216	return $self->{db_driver};
		217	}
176		218
177	=head2 db_scheme2dbi	219	=head2 db_scheme2dbi
178		220
Lines 194-225 sub import { Link Here
194	# Create the default context ($C4::Context::Context)	236	# Create the default context ($C4::Context::Context)
195	# the first time the module is called	237	# the first time the module is called
196	# (a config file can be optionaly passed)	238	# (a config file can be optionaly passed)
		239	# If ":no_config" is passed, no config load will be attempted
		240	# It saves the context values in the declared memcached server(s)
		241	# if currently available and uses those values until them expire and
		242	# re-reads them.
		243
		244	my ($pkg,$config_file) = @_;
197		245
198	# default context already exists?	246	# default context already exists?
199	return if $context;	247	return if $context;
200		248
201	# no ? so load it!	249	# multihost, we don't want/have one default config
202	my ($pkg,$config_file) = @_ ;	250	return if $config_file && $config_file eq ":no_config";
203	my $new_ctx = __PACKAGE__->new($config_file);
204	return unless $new_ctx;
205		251
206	# if successfully loaded, use it by default	252	my $conf_cache = Koha::Caches->get_instance('config');
207	$new_ctx->set_context;	253	if ( $conf_cache->cache ) {
208	1;	254	if ( $context = $conf_cache->get_from_cache('koha_conf') ) {
		255	return;
		256	}
		257	}
		258
		259	undef $config_file if $config_file && !-s $config_file;
		260	$config_file \|\|= Koha::Config->guess_koha_conf();
		261	$context = __PACKAGE__->new($config_file);
		262	return unless $context;
		263
		264	if ( $conf_cache->memcached_cache ) {
		265	# FIXME it may be better to use the memcached servers from the config file
		266	# to cache it
		267	$conf_cache->set_in_cache('koha_conf', $context)
		268	}
209	}	269	}
210		270
211	=head2 new	271	=head2 new
212		272
213	$context = new C4::Context;
214	$context = new C4::Context("/path/to/koha-conf.xml");	273	$context = new C4::Context("/path/to/koha-conf.xml");
215		274
216	Allocates a new context. Initializes the context from the specified	275	Allocates a new context. Initializes the context from the specified
217	file, which defaults to either the file given by the C<$KOHA_CONF>	276	file.
218	environment variable, or F</etc/koha/koha-conf.xml>.
219
220	It saves the koha-conf.xml values in the declared memcached server(s)
221	if currently available and uses those values until them expire and
222	re-reads them.
223		277
224	C<&new> does not set this context as the new default context; for	278	C<&new> does not set this context as the new default context; for
225	that, use C<&set_context>.	279	that, use C<&set_context>.
Lines 231-268 that, use C<&set_context>. Link Here
231	# 2004-08-10 A. Tarallo: Added check if the conf file is not empty	285	# 2004-08-10 A. Tarallo: Added check if the conf file is not empty
232	sub new {	286	sub new {
233	my $class = shift;	287	my $class = shift;
234	my $conf_fname = shift; # Config file to load	288	my $conf_fname = shift or croak "No conf";
235	my $self = {};	289	my $namespace = shift;
236
237	# check that the specified config file exists and is not empty
238	undef $conf_fname unless
239	(defined $conf_fname && -s $conf_fname);
240	# Figure out a good config file to load if none was specified.
241	unless ( defined $conf_fname ) {
242	$conf_fname = Koha::Config->guess_koha_conf;
243	unless ( $conf_fname ) {
244	warn "unable to locate Koha configuration file koha-conf.xml";
245	return;
246	}
247	}
248		290
249	my $conf_cache = Koha::Caches->get_instance('config');	291	my $self = Koha::Config->read_from_file($conf_fname);
250	my $config_from_cache;	292	die "Invalid config ".(ref($conf_fname) ? $$conf_fname : $conf_fname).": ".Dumper($self)
251	if ( $conf_cache->cache ) {	293	unless ref($self) && $self->{"config"};
252	$self = $conf_cache->get_from_cache('koha_conf');	294
253	}	295	$self->{config_file} = $conf_fname;
254	unless ( $self and %$self ) {	296	$self->{namespace} = $namespace;
255	$self = Koha::Config->read_from_file($conf_fname);	297	$self->{use_syspref_cache} = 1;
256	if ( $conf_cache->memcached_cache ) {	298	$self->{syspref_cache} = Koha::Caches->get_instance('syspref', $namespace);
257	# FIXME it may be better to use the memcached servers from the config file
258	# to cache it
259	$conf_cache->set_in_cache('koha_conf', $self)
260	}
261	}
262	unless ( exists $self->{config} or defined $self->{config} ) {
263	warn "The config file ($conf_fname) has not been parsed correctly";
264	return;
265	}
266		299
267	$self->{"Zconn"} = undef; # Zebra Connections	300	$self->{"Zconn"} = undef; # Zebra Connections
268	$self->{"userenv"} = undef; # User env	301	$self->{"userenv"} = undef; # User env
Lines 277-283 sub new { Link Here
277		310
278	=head2 set_context	311	=head2 set_context
279		312
280	$context = new C4::Context;
281	$context->set_context();	313	$context->set_context();
282	or	314	or
283	set_context C4::Context $context;	315	set_context C4::Context $context;
Lines 310-326 sub set_context Link Here
310	if (ref($self) eq "")	342	if (ref($self) eq "")
311	{	343	{
312	# Class method. The new context is the next argument.	344	# Class method. The new context is the next argument.
313	$new_context = shift;	345	$new_context = shift or croak "No new context";
314	} else {	346	} else {
315	# Instance method. The new context is $self.	347	# Instance method. The new context is $self.
316	$new_context = $self;	348	$new_context = $self;
317	}	349	}
318		350
319	# Save the old context, if any, on the stack	351	# undef $new_context->{schema} if $new_context->{schema} && !$new_context->{schema}->ping
320	push @context_stack, $context if defined($context);	352	my $schema = $new_context->{schema} \|\|= Koha::Database->new_schema($new_context);
		353
		354	# Save the old context on the stack
		355	push @context_stack, $context;
321		356
322	# Set the new context	357	# Set the new context
323	$context = $new_context;	358	$context = $new_context;
		359	Koha::Database->set_schema($schema);
324	}	360	}
325		361
326	=head2 restore_context	362	=head2 restore_context
Lines 336-354 sub restore_context Link Here
336	{	372	{
337	my $self = shift;	373	my $self = shift;
338		374
339	if ($#context_stack < 0)
340	{
341	# Stack underflow.
342	die "Context stack underflow";
343	}
344
345	# Pop the old context and set it.	375	# Pop the old context and set it.
346	$context = pop @context_stack;	376	$context = pop @context_stack;
		377	Koha::Database->restore_schema();
347		378
348	# FIXME - Should this return something, like maybe the context	379	# FIXME - Should this return something, like maybe the context
349	# that was current when this was called?	380	# that was current when this was called?
350	}	381	}
351		382
		383	=head2 run_within_context
		384
		385	$context->run_within_context(sub {...});
		386
		387	Runs code within context
		388
		389	=cut
		390
		391	#'
		392	sub run_within_context
		393	{
		394	my $self = shift;
		395	my $code = shift or croak "No code";
		396
		397	$self->set_context;
		398
		399	local $@;
		400	my $ret = eval { $code->(@_) };
		401	my $died = $@;
		402	$self->restore_context;
		403	die $died if $died;
		404	return $ret;
		405	}
		406
352	=head2 config	407	=head2 config
353		408
354	$value = C4::Context->config("config_variable");	409	$value = C4::Context->config("config_variable");
Lines 365-390 C<C4::Config-E<gt>new> will not return it. Link Here
365	=cut	420	=cut
366		421
367	sub _common_config {	422	sub _common_config {
368	my $var = shift;	423	my $self = shift;
369	my $term = shift;	424	my $var = shift;
370	return if !defined($context->{$term});	425	my $term = shift;
		426
		427	$self = $context unless ref $self;
		428	return if !defined($self->{$term});
371	# Presumably $self->{$term} might be	429	# Presumably $self->{$term} might be
372	# undefined if the config file given to &new	430	# undefined if the config file given to &new
373	# didn't exist, and the caller didn't bother	431	# didn't exist, and the caller didn't bother
374	# to check the return value.	432	# to check the return value.
375		433
376	# Return the value of the requested config variable	434	# Return the value of the requested config variable
377	return $context->{$term}->{$var};	435	return $self->{$term}->{$var};
378	}	436	}
379		437
380	sub config {	438	sub config {
381	return _common_config($_[1],'config');	439	my $self = shift;
		440	return $self->_common_config($_[0],'config');
382	}	441	}
383	sub zebraconfig {	442	sub zebraconfig {
384	return _common_config($_[1],'server');	443	my $self = shift;
		444	return $self->_common_config($_[0],'server');
385	}	445	}
386	sub ModZebrations {	446	sub ModZebrations {
387	return _common_config($_[1],'serverinfo');	447	my $self = shift;
		448	return $self->_common_config($_[0],'serverinfo');
388	}	449	}
389		450
390	=head2 preference	451	=head2 preference
Lines 403-431 with this method. Link Here
403		464
404	=cut	465	=cut
405		466
406	my $syspref_cache = Koha::Caches->get_instance('syspref');
407	my $use_syspref_cache = 1;
408	sub preference {	467	sub preference {
409	my $self = shift;	468	my $self = shift;
		469	$self = $context unless ref $self;
410	my $var = shift; # The system preference to return	470	my $var = shift; # The system preference to return
411		471
		472	$var = lc $var;
		473
412	return $ENV{"OVERRIDE_SYSPREF_$var"}	474	return $ENV{"OVERRIDE_SYSPREF_$var"}
413	if defined $ENV{"OVERRIDE_SYSPREF_$var"};	475	if defined $ENV{"OVERRIDE_SYSPREF_$var"};
414		476
415	$var = lc $var;	477	my $cached_var = $self->{use_syspref_cache}
416		478	? $self->{syspref_cache}->get_from_cache("syspref_$var")
417	if ($use_syspref_cache) {	479	: undef;
418	$syspref_cache = Koha::Caches->get_instance('syspref') unless $syspref_cache;	480	return $cached_var if defined $cached_var;
419	my $cached_var = $syspref_cache->get_from_cache("syspref_$var");
420	return $cached_var if defined $cached_var;
421	}
422		481
423	my $syspref;	482	my $syspref;
424	eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) };	483	eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) };
425	my $value = $syspref ? $syspref->value() : undef;	484	my $value = $syspref ? $syspref->value() : undef;
426		485
427	if ( $use_syspref_cache ) {	486	if ( $self->{use_syspref_cache} ) {
428	$syspref_cache->set_in_cache("syspref_$var", $value);	487	$self->{syspref_cache}->set_in_cache("syspref_$var", $value);
429	}	488	}
430	return $value;	489	return $value;
431	}	490	}
Lines 448-454 default behavior. Link Here
448		507
449	sub enable_syspref_cache {	508	sub enable_syspref_cache {
450	my ($self) = @_;	509	my ($self) = @_;
451	$use_syspref_cache = 1;	510	$self = $context unless ref $self;
		511	$self->{use_syspref_cache} = 1;
452	# We need to clear the cache to have it up-to-date	512	# We need to clear the cache to have it up-to-date
453	$self->clear_syspref_cache();	513	$self->clear_syspref_cache();
454	}	514	}
Lines 464-471 used with Plack and other persistent environments. Link Here
464		524
465	sub disable_syspref_cache {	525	sub disable_syspref_cache {
466	my ($self) = @_;	526	my ($self) = @_;
467	$use_syspref_cache = 0;	527	$self = $context unless ref $self;
468	$self->clear_syspref_cache();	528	$self->clear_syspref_cache();
		529	$self->{use_syspref_cache} = 0;
469	}	530	}
470		531
471	=head2 clear_syspref_cache	532	=head2 clear_syspref_cache
Lines 479-486 will not be seen by this process. Link Here
479	=cut	540	=cut
480		541
481	sub clear_syspref_cache {	542	sub clear_syspref_cache {
482	return unless $use_syspref_cache;	543	my ($self) = @_;
483	$syspref_cache->flush_all;	544	$self = $context unless ref $self;
		545	return unless $self->{use_syspref_cache};
		546	$self->{syspref_cache}->flush_all;
484	}	547	}
485		548
486	=head2 set_preference	549	=head2 set_preference
Lines 496-501 preference. Link Here
496		559
497	sub set_preference {	560	sub set_preference {
498	my ( $self, $variable, $value, $explanation, $type, $options ) = @_;	561	my ( $self, $variable, $value, $explanation, $type, $options ) = @_;
		562	$self = $context unless ref $self;
499		563
500	my $variable_case = $variable;	564	my $variable_case = $variable;
501	$variable = lc $variable;	565	$variable = lc $variable;
Lines 532-539 sub set_preference { Link Here
532	)->store();	596	)->store();
533	}	597	}
534		598
535	if ( $use_syspref_cache ) {	599	if ( $self->{use_syspref_cache} ) {
536	$syspref_cache->set_in_cache( "syspref_$variable", $value );	600	$self->{syspref_cache}->set_in_cache( "syspref_$variable", $value );
537	}	601	}
538		602
539	return $syspref;	603	return $syspref;
Lines 551-560 was no syspref of the name. Link Here
551		615
552	sub delete_preference {	616	sub delete_preference {
553	my ( $self, $var ) = @_;	617	my ( $self, $var ) = @_;
		618	$self = $context unless ref $self;
554		619
555	if ( Koha::Config::SysPrefs->find( $var )->delete ) {	620	if ( Koha::Config::SysPrefs->find( $var )->delete ) {
556	if ( $use_syspref_cache ) {	621	if ( $self->{use_syspref_cache} ) {
557	$syspref_cache->clear_from_cache("syspref_$var");	622	$self->{syspref_cache}->clear_from_cache("syspref_$var");
558	}	623	}
559		624
560	return 1;	625	return 1;
Lines 568-574 sub delete_preference { Link Here
568		633
569	Returns a connection to the Zebra database	634	Returns a connection to the Zebra database
570		635
571	C<$self>	636	C<$self>
572		637
573	C<$server> one of the servers defined in the koha-conf.xml file	638	C<$server> one of the servers defined in the koha-conf.xml file
574		639
Lines 679-686 creates one, and connects to the database. Link Here
679		744
680	This database handle is cached for future use: if you call	745	This database handle is cached for future use: if you call
681	C<C4::Context-E<gt>dbh> twice, you will get the same handle both	746	C<C4::Context-E<gt>dbh> twice, you will get the same handle both
682	times. If you need a second database handle, use C<&new_dbh> and	747	times. If you need a second database handle, use C<&new_dbh>.
683	possibly C<&set_dbh>.
684		748
685	=cut	749	=cut
686		750
Lines 719-782 sub new_dbh Link Here
719	return &dbh({ new => 1 });	783	return &dbh({ new => 1 });
720	}	784	}
721		785
722	=head2 set_dbh
723
724	$my_dbh = C4::Connect->new_dbh;
725	C4::Connect->set_dbh($my_dbh);
726	...
727	C4::Connect->restore_dbh;
728
729	C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
730	C<&set_context> and C<&restore_context>.
731
732	C<&set_dbh> saves the current database handle on a stack, then sets
733	the current database handle to C<$my_dbh>.
734
735	C<$my_dbh> is assumed to be a good database handle.
736
737	=cut
738
739	#'
740	sub set_dbh
741	{
742	my $self = shift;
743	my $new_dbh = shift;
744
745	# Save the current database handle on the handle stack.
746	# We assume that $new_dbh is all good: if the caller wants to
747	# screw himself by passing an invalid handle, that's fine by
748	# us.
749	push @{$context->{"dbh_stack"}}, $context->{"dbh"};
750	$context->{"dbh"} = $new_dbh;
751	}
752
753	=head2 restore_dbh
754
755	C4::Context->restore_dbh;
756
757	Restores the database handle saved by an earlier call to
758	C<C4::Context-E<gt>set_dbh>.
759
760	=cut
761
762	#'
763	sub restore_dbh
764	{
765	my $self = shift;
766
767	if ($#{$context->{"dbh_stack"}} < 0)
768	{
769	# Stack underflow
770	die "DBH stack underflow";
771	}
772
773	# Pop the old database handle and set it.
774	$context->{"dbh"} = pop @{$context->{"dbh_stack"}};
775
776	# FIXME - If it is determined that restore_context should
777	# return something, then this function should, too.
778	}
779
780	=head2 queryparser	786	=head2 queryparser
781		787
782	$queryparser = C4::Context->queryparser	788	$queryparser = C4::Context->queryparser

Lines 22-28 use warnings; Link Here

(-)a/C4/External/OverDrive.pm (-4 / +2 lines)
22		22
23	use Koha;	23	use Koha;
24	use JSON;	24	use JSON;
25	use Koha::Caches;	25	use C4::Context;
26	use HTTP::Request;	26	use HTTP::Request;
27	use HTTP::Request::Common;	27	use HTTP::Request::Common;
28	use LWP::Authen::Basic;	28	use LWP::Authen::Basic;
Lines 97-105 sub GetOverDriveToken { Link Here
97		97
98	return unless ( $key && $secret ) ;	98	return unless ( $key && $secret ) ;
99		99
100	my $cache;	100	my $cache = C4::Context->cache;
101
102	eval { $cache = Koha::Caches->get_instance() };
103		101
104	my $token;	102	my $token;
105	$cache and $token = $cache->get_from_cache( "overdrive_token" ) and return $token;	103	$cache and $token = $cache->get_from_cache( "overdrive_token" ) and return $token;

Lines 64-97 Create a new Koha::Cache object. This is required for all cache-related function Link Here

(-)a/Koha/Cache.pm (-16 / +17 lines)
64	=cut	64	=cut
65		65
66	sub new {	66	sub new {
67	my ( $class, $self, $params ) = @_;	67	my ( $class, $self ) = @_;
68	$self->{'default_type'} =	68	$self->{'default_type'} =
69	$self->{cache_type}	69	$self->{cache_type}
70	\|\| $ENV{CACHING_SYSTEM} # DELME What about this?	70	\|\| $ENV{CACHING_SYSTEM} # DELME What about this?
71	\|\| 'memcached';	71	\|\| 'memcached';
72		72
73	my $subnamespace = $params->{subnamespace} // '';	73	$self->{namespace} //= '';
74		74
75	$ENV{DEBUG} && carp "Default caching system: $self->{'default_type'}";	75	$ENV{DEBUG} && carp "Default caching system: $self->{'default_type'}";
76		76
77	$self->{'timeout'} \|\|= 0;	77	$self->{'timeout'} \|\|= 0;
78	# Should we continue to support MEMCACHED ENV vars?
79	$self->{'namespace'} \|\|= $ENV{MEMCACHED_NAMESPACE};
80	my @servers = split /,/, $ENV{MEMCACHED_SERVERS} \|\| '';
81	unless ( $self->{namespace} and @servers ) {
82	my $koha_config = Koha::Config->read_from_file( Koha::Config->guess_koha_conf() );
83	$self->{namespace} \|\|= $koha_config->{config}{memcached_namespace} \|\| 'koha';
84	@servers = split /,/, $koha_config->{config}{memcached_servers} // ''
85	unless @servers;
86	}
87	$self->{namespace} .= ":$subnamespace:";
88		78
89	if ( $self->{'default_type'} eq 'memcached'	79	if ( $self->{'default_type'} eq 'memcached'
90	&& can_load( modules => { 'Cache::Memcached::Fast' => undef } )	80	&& can_load( modules => { 'Cache::Memcached::Fast' => undef } ) )
91	&& _initialize_memcached($self, @servers)
92	&& defined( $self->{'memcached_cache'} ) )
93	{	81	{
94	$self->{'cache'} = $self->{'memcached_cache'};	82	# Should we continue to support MEMCACHED ENV vars?
		83	$self->{'namespace'} \|\|= $ENV{MEMCACHED_NAMESPACE};
		84	my @servers = split /,/, $ENV{MEMCACHED_SERVERS} \|\| '';
		85	unless ( $self->{namespace} && @servers ) {
		86	my $koha_config = Koha::Config->read_from_file( Koha::Config->guess_koha_conf() );
		87	$self->{namespace} \|\|= $koha_config->{config}{memcached_namespace} \|\| 'koha';
		88	@servers = split /,/, $koha_config->{config}{memcached_servers} // ''
		89	unless @servers;
		90	}
		91	if ( _initialize_memcached($self, @servers)
		92	&& defined( $self->{'memcached_cache'} ) )
		93	{
		94	$self->{'cache'} = $self->{'memcached_cache'};
		95	}
95	}	96	}
96		97
97	if ( $self->{'default_type'} eq 'fastmmap'	98	if ( $self->{'default_type'} eq 'fastmmap'

Lines 46-56 persistent across multiple instances. Link Here

(-)a/Koha/Caches.pm (-5 / +8 lines)
46	=cut	46	=cut
47		47
48	sub get_instance {	48	sub get_instance {
49	my ($class, $subnamespace) = @_;	49	my ($class, $subnamespace, $namespace) = @_;
50	$subnamespace //= '';	50	$subnamespace //= '';
51	$singleton_caches->{$subnamespace} = Koha::Cache->new({}, { subnamespace => $subnamespace } )	51	$namespace //= '';
52	unless $singleton_caches->{$subnamespace};	52	return $singleton_caches->{$namespace}{$subnamespace}
53	return $singleton_caches->{$subnamespace};	53	\|\|= Koha::Cache->new({ namespace => $namespace }, { subnamespace => $subnamespace });
54	}	54	}
55		55
56	=head2 flush_L1_caches	56	=head2 flush_L1_caches
Lines 58-65 sub get_instance { Link Here
58	=cut	58	=cut
59		59
60	sub flush_L1_caches {	60	sub flush_L1_caches {
		61	my ($class, $namespace) = @_;
		62	$namespace //= '';
		63
61	return unless $singleton_caches;	64	return unless $singleton_caches;
62	for my $cache ( values %$singleton_caches ) {	65	for my $cache ( values %{$singleton_caches->{$namespace}} ) {
63	$cache->flush_L1_cache;	66	$cache->flush_L1_cache;
64	}	67	}
65	}	68	}

Lines 7-13 use DateTime; Link Here

(-)a/Koha/Calendar.pm (-3 / +2 lines)
7	use DateTime::Set;	7	use DateTime::Set;
8	use DateTime::Duration;	8	use DateTime::Duration;
9	use C4::Context;	9	use C4::Context;
10	use Koha::Caches;
11	use Carp;	10	use Carp;
12		11
13	sub new {	12	sub new {
Lines 55-61 sub _init { Link Here
55	sub exception_holidays {	54	sub exception_holidays {
56	my ( $self ) = @_;	55	my ( $self ) = @_;
57		56
58	my $cache = Koha::Caches->get_instance();	57	my $cache = C4::Context->cache;
59	my $cached = $cache->get_from_cache('exception_holidays');	58	my $cached = $cache->get_from_cache('exception_holidays');
60	return $cached if $cached;	59	return $cached if $cached;
61		60
Lines 84-90 sub exception_holidays { Link Here
84	sub single_holidays {	83	sub single_holidays {
85	my ( $self, $date ) = @_;	84	my ( $self, $date ) = @_;
86	my $branchcode = $self->{branchcode};	85	my $branchcode = $self->{branchcode};
87	my $cache = Koha::Caches->get_instance();	86	my $cache = C4::Context->cache;
88	my $single_holidays = $cache->get_from_cache('single_holidays');	87	my $single_holidays = $cache->get_from_cache('single_holidays');
89		88
90	# $single_holidays looks like:	89	# $single_holidays looks like:

Lines 35-40 Koha::Database Link Here

(-)a/Koha/Database.pm (-10 / +31 lines)
35	use Modern::Perl;	35	use Modern::Perl;
36	use Carp;	36	use Carp;
37	use C4::Context;	37	use C4::Context;
		38	use Koha::Schema;
38	use base qw(Class::Accessor);	39	use base qw(Class::Accessor);
39		40
40	use vars qw($database);	41	use vars qw($database);
Lines 46-57 __PACKAGE__->mk_accessors(qw( )); Link Here
46	# database connection from the data given in the current context, and	47	# database connection from the data given in the current context, and
47	# returns it.	48	# returns it.
48	sub _new_schema {	49	sub _new_schema {
		50	my $context = shift \|\| C4::Context->current();
49		51
50	require Koha::Schema;	52	my $db_driver = $context->db_driver;
51
52	my $context = C4::Context->new();
53
54	my $db_driver = $context->{db_driver};
55		53
56	my $db_name = $context->config("database");	54	my $db_name = $context->config("database");
57	my $db_host = $context->config("hostname");	55	my $db_host = $context->config("hostname");
Lines 140-155 sub schema { Link Here
140	return $database->{schema} if defined $database->{schema};	138	return $database->{schema} if defined $database->{schema};
141	}	139	}
142		140
143	$database->{schema} = &_new_schema();	141	$database->{schema} = &_new_schema($params->{context});
144	return $database->{schema};	142	return $database->{schema};
145	}	143	}
146		144
147	=head2 new_schema	145	=head2 new_schema
148		146
149	$schema = $database->new_schema;	147	$schema = $database->new_schema($context);
150		148
151	Creates a new connection to the Koha database for the current context,	149	Creates a new connection to the Koha database for the context
152	and returns the database handle (a C<DBI::db> object).	150	(current is default), and returns the database handle (a C<DBI::db> object).
153		151
154	The handle is not saved anywhere: this method is strictly a	152	The handle is not saved anywhere: this method is strictly a
155	convenience function; the point is that it knows which database to	153	convenience function; the point is that it knows which database to
Lines 161-167 connect to so that the caller doesn't have to know. Link Here
161	sub new_schema {	159	sub new_schema {
162	my $self = shift;	160	my $self = shift;
163		161
164	return &_new_schema();	162	return &_new_schema(@_);
165	}	163	}
166		164
167	=head2 set_schema	165	=head2 set_schema
Lines 235-240 sub flush_schema_cache { Link Here
235	return 1;	233	return 1;
236	}	234	}
237		235
		236	=head2 run_with_schema
		237
		238	$database->run_with_schema( $schema, sub {...} );
		239
		240	Restores the database handle saved by an earlier call to
		241	C<$database-E<gt>set_schema> C<$database-E<gt>restore_schema> wrapper.
		242
		243	=cut
		244
		245	sub run_with_schema {
		246	my $self = shift;
		247	my $schema = shift or croak "No schema";
		248	my $code = shift or croak "No sub";
		249
		250	$self->set_schema;
		251	local $@;
		252	my $ret = eval { $code->(@_) };
		253	my $died = $@;
		254	$self->restore_schema;
		255	die $died if $died;
		256	return $ret;
		257	}
		258
238	=head2 EXPORT	259	=head2 EXPORT
239		260
240	None by default.	261	None by default.

Line 0 Link Here

(-)a/Koha/Handler/Plack.pm (+200 lines)
		1	package Koha::Handler::Plack;
		2
		3	# Copyright (c) 2016 Catalyst IT
		4	#
		5	# This file is part of Koha.
		6	#
		7	# Koha is free software; you can redistribute it and/or modify it under the
		8	# terms of the GNU General Public License as published by the Free Software
		9	# Foundation; either version 2 of the License, or (at your option) any later
		10	# version.
		11	#
		12	# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
		13	# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
		14	# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
		15	#
		16	# You should have received a copy of the GNU General Public License along with
		17	# Koha; if not, write to the Free Software Foundation, Inc.,
		18	# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
		19
		20	=head1 NAME
		21
		22	Koha::Handler::Plack - Plack helper
		23
		24	=head1 SYNOPSIS
		25
		26	koha.psgi:
		27	use Koha::Handler::Plack;
		28
		29	my %HOST_CONF = (
		30	'koha1.com' => { ... },
		31	'koha2.com' => { ... },
		32	...
		33	);
		34	# last line
		35	Koha::Handler::Plack->app_per_host(\%HOST_CONF);
		36
		37	See C<app_per_host()> below
		38
		39	=head1 DESCRIPTION
		40
		41	Some handy function to help with Koha/Plack in a multi-host situation.
		42
		43	The problem:
		44	Koha app relies on env vars. This should be changed, ie C4::Context should
		45	be upgraded to Koha::App, but until then we need a gap filler. That's
		46	because once up, there's no way to pass on new env to a psgi container.
		47	In Apache, for instance, we can specify env vars per virtual host. Plack
		48	has no such concept.
		49
		50	Solution:
		51	We need to modify the environment in situ, per virtual host - app_per_host().
		52	We specify env for each hostname, and apply.
		53
		54	=cut
		55
		56	use Modern::Perl;
		57	use Carp;
		58
		59	use Plack::App::URLMap;
		60
		61	=head1 CLASS METHODS
		62
		63	=head2 app_per_host($host_apps)
		64
65	App wrapper for per virtual host scenario.
66
67	C<$host_apps>:
68	{
69	hostname => 'koha1.com',
70	app => $app1,
71	context => $context1,
72	shared_context => 1
73	},
74	{
75	hostname => ['koha2.com', 'www.koha2.com'],
76	app => $app2,
77	context => $context2,
78	},
79	...
80
81	C<hostname> is mandatory.
82	If C<shared_context> is set to true, some Context properties will be preserved across
83	forked processes. Useful if both OPAC and Intranet apps are served here, so no restart
84	is needed when Context cached properties cnamge values. Needs memcached.
85
86	koha.psgi:
87
88	use Plack::Builder;
89	use Plack::App::CGIBin;
90
91	use C4::Context ":no_config";
92
93	my $opac_app = builder {
94	enable "Plack::Middleware::Static",
95	path => qr{^/opac-tmpl/}, root => '/usr/share/koha/opac/htdocs/';
96
97	enable 'StackTrace';
98	mount "/cgi-bin/koha" => Plack::App::CGIBin->new(root => "/usr/share/koha/opac/cgi-bin/opac");
99	};
100	my $intranet_app = builder {
101	enable "Plack::Middleware::Static",
102	path => qr{^/intranet-tmpl/}, root => '/usr/share/koha/intranet/htdocs/';
103
104	enable 'StackTrace';
105	mount "/cgi-bin/koha" => Plack::App::CGIBin->new(root => "/usr/share/koha/cgi-bin");
106	};
107
108	my @host_def;
109
110	my $conf_file_1 = "/etc/koha/site-1/koha_conf.xml";
111	my $context_1 = C4::Context->new($conf_file_1);
112	push @host_def,
113	{
114	hostname => [ "public.host.for.site-1", "www.public.host.for.site-1" ],
115	app => $opac_app,
116	context => $context_1,
117	},
118	{
119	hostname => "intranet.host.for.site-1",
120	app => $intranet_app,
121	context => $context_1,
122	};
123
124	my $conf_file_2 = "/etc/koha/site-1/koha_conf.xml";
125	my $context_2 = C4::Context->new($conf_file_2);
126	push @host_def,
127	{
128	hostname => "public.host.for.site-2",
129	app => $opac_app,
130	context => $context_2,
131	},
132	{
133	hostname => "intranet.host.for.site-2",
134	app => $intranet_app,
135	context => $context_2,
136	};
137
138	...
139
140	Koha::Handler::Plack->app_per_host( \@host_def );
141
142	=cut
143
144	# We cannot store whole Context object, may contain non-serializable things
145	my @CONTEXT_UNSAFE_PROPERTIES = qw(sysprefs);
146	sub app_per_host {
147	my $class = shift;
148	my $sites = shift or die "No sites spec";
149
150	my $map = Plack::App::URLMap->new;
151	foreach my $site_params ( @$sites ) {
152	my $hosts = $site_params->{hostname} or croak "No hostname";
153	$hosts = [$hosts] unless ref $hosts;
154
155	my $app = $site_params->{app} or croak "No app";
156	my $context = $site_params->{context} or croak "No Koha Context";
157	my $shared_context = $site_params->{shared_context};
158	my $cache = $context->memcached;
159	if ($shared_context) {
160	if ($cache) {
161	foreach (@CONTEXT_UNSAFE_PROPERTIES) {
162	# Clean slate
163	$cache->clear_from_cache($_);
164	}
165	}
166	else {
167	warn "shared_context works only with memcached";
168	}
169	}
170
171	foreach my $host (@$hosts) {
172	$map->map("http://$host/" => sub {
173	my $env = shift;
174
175	# may have stopped meanwhile or whatever
176	my $cache = $context->memcached;
177	if ($shared_context && $cache) {
178	foreach (@CONTEXT_UNSAFE_PROPERTIES) {
179	if (my $shared = $cache->get($_)) {
180	$context->{$_} = $shared;
181	}
182	}
183	}
184
185	my $ret = $context->run_within_context(sub { $app->($env) });
186
187	if ($shared_context && $cache) {
188	foreach (@CONTEXT_UNSAFE_PROPERTIES) {
189	$cache->set($_, $context->{$_});
190	}
191	}
192
193	$ret;
194	});
195	}
196	}
197	return $map->to_app;
198	}
199
200	1;

Line 0 Link Here

(-)a/Koha/Handler/Plack/CGI.pm (+228 lines)
		1	package Koha::Handler::Plack::CGI;
		2
		3	# Copyright (c) 2016 Catalyst IT
		4	#
		5	# This file is part of Koha.
		6	#
		7	# Koha is free software; you can redistribute it and/or modify it under the
		8	# terms of the GNU General Public License as published by the Free Software
		9	# Foundation; either version 2 of the License, or (at your option) any later
		10	# version.
		11	#
		12	# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
		13	# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
		14	# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
		15	#
		16	# You should have received a copy of the GNU General Public License along with
		17	# Koha; if not, write to the Free Software Foundation, Inc.,
		18	# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
		19
		20	=head1 NAME
		21
		22	Koha::Handler::Plack::CGI - Plack helper for CGI scripts
		23
		24	=head1 SYNOPSIS
		25
		26	koha.psgi:
		27	use Koha::Handler::Plack::CGI;
		28
		29	my %koha_env = (
		30	opac => {
		31	static_root => '/usr/share/koha/opac/htdocs',
		32	script_root => '/usr/share/koha/opac',
		33	},
		34	intranet => {
		35	static_root => '/usr/share/koha/intranet/htdocs',
		36	script_root => '/usr/share/koha/intranet'
		37	}
		38	);
		39	my @sites = (
		40	{
		41	opac_hostname => 'koha1-opac.com',
		42	intranet_hostname => 'koha1-intranet.com',
		43	config = '/etc/koha/koha1/koha-conf.xml'
		44	},
		45	{
		46	opac_hostname => ['opac.koha2.com', 'www.opackoha2.com'],
		47	intranet_hostname => ['intranet.koha2.com', 'www.intranetkoha2.com'],
		48	config = '/etc/koha/koha2/koha-conf.xml'
		49	},
		50	);
		51
		52	# last line
		53	Koha::Handler::Plack::CGI->app_per_host(\%HOST_CONF);
		54
		55	See C<app_per_host()> below
		56
		57	=head1 DESCRIPTION
		58
		59	CGI script runner.
		60
		61	One beautiful day wiwill move away from that and have proper App module
		62	with router and handlers</dream>
		63
		64	See C<Koha::Handler::Plack>
65
66	=cut
67
68	use Modern::Perl;
69	use Carp;
70
71	use Plack::Builder;
72	use Plack::App::CGIBin;
73
74	use parent "Koha::Handler::Plack";
75
76	use C4::Context ":no_config";
77
78	=head1 CLASS METHODS
79
80	=head2 app($context, $env)
81
82	Plack app builder fora CGI app
83
84	C<$context>: "opac" or "intranet"
85	C<$env>:
86	{
87	static_root => '...',
88	script_root => '...',
89	pugins => [
90	[ 'StackTrace' ],
91	...
92	],
93	}
94
95	koha.psgi:
96
97	Koha::Handler::Plack::CGI->app( "opac", \%opac_app_env );
98
99	=cut
100
101	sub app {
102	my $class = shift;
103	my $context = shift;
104	croak "Invalid app context '$context' - must be 'opac' or 'intranet'"
105	unless $context =~ m/^(opac\|intranet)$/;
106	my $env = shift or croak "No $context env details";
107
108	my $static_root = $env->{static_root} or croak "No $context static_root";
109	$static_root = "$static_root/" unless $static_root =~ m!/$!;
110	my $script_root = $env->{script_root} or croak "No $context script_root";
111	$script_root =~ s!/$!!;
112	my $plugins = $env->{plugins} \|\| [];
113	my $is_intranet = $context eq "intranet";
114
115	builder {
116	enable "Plack::Middleware::Static",
117	path => qr{^/$context-tmpl/}, root => $static_root;
118
119	map enable(@$_), @$plugins;
120
121	mount "/cgi-bin/koha" => Plack::App::CGIBin->new(root => $script_root)->to_app;
122	mount "/" => sub {
123	return [ 302, [ Location => '/cgi-bin/koha/' . ( $is_intranet ? 'mainpage.pl' : 'opac-main.pl' ) ], [] ];
124	};
125	};
126	}
127
128	=head2 multi_site($env, $sites)
129
130	App wrapper for per virtual host scenario.
131
132	C<$env>:
133	{
134	opac => {
135	static_root => '/usr/share/koha/opac/htdocs',
136	script_root => '/usr/share/koha/opac/cgi-bin/opac',
137	pugins => [
138	[ 'StackTrace' ],
139	],
140	},
141	intranet => {
142	static_root => '/usr/share/koha/intranet/htdocs',
143	script_root => '/usr/share/koha/cgi-bin'
144	}
145	}
146	C<$sites>:
147	{
148	namespace => 'koha1',
149	opac_hostname => 'koha1-opac.com',
150	intranet_hostname => 'koha1-intranet.com',
151	config => '/etc/koha/sites/koha1/koha-conf.xml',
152	shared_config => 1
153	},
154	{
155	namespace => 'koha2',
156	opac_hostname => ['opac.koha2.com', 'www.opackoha2.com'],
157	intranet_hostname => ['intranet.koha2.com', 'www.intranetkoha2.com'],
158	config => '/etc/koha/sites/koha2/koha-conf.xml'
159	},
160	...
161
162	koha.psgi:
163
164	Koha::Handler::Plack::CGI->multi_site( \%koha_app_env, \@sites );
165
166	=cut
167
168	my $DUMMY_KOHA_CONF = "<yazgfs><config>DUMMY</config></yazgfs>";
169	sub multi_site {
170	my $class = shift;
171	my $env = shift or croak "No Koha env details";
172	my $sites = shift or croak "No sites spec";
173
174	my ($opac_app, $intranet_app);
175
176	if (my $opac = $env->{opac}) {
177	$opac_app = $class->app('opac', $opac);
178	}
179
180	if (my $intranet = $env->{intranet}) {
181	$intranet_app = $class->app('intranet', $intranet);
182	}
183
184	my @host_def = map {
185	my $namespace = $_->{namespace} or croak "No namespace";
186	my $config = $_->{config} or croak "Site without config";
187	my $shared_context = $_->{shared_context};
188
189	my $context = C4::Context->new($config, $namespace);
190
191	my @hd;
192	if (my $hostname = $_->{opac_hostname}) {
193	croak "You have OPAC hosts without OPAC env details" unless $opac_app;
194	push @hd, {
195	hostname => $hostname,
196	app => sub {
197	# XXX this may need some rethinking
198	local $ENV{KOHA_CONF} = \$DUMMY_KOHA_CONF;
199	local $ENV{MEMCACHED_NAMESPACE} = $namespace;
200
201	$opac_app->(@_);
202	},
203	context => $context,
204	shared_context => $shared_context,
205	};
206	}
207	if (my $hostname = $_->{intranet_hostname}) {
208	croak "You have Intranet hosts without Intranet env details" unless $intranet_app;
209	push @hd, {
210	hostname => $hostname,
211	app => sub {
212	# XXX this may need some rethinking
213	local $ENV{KOHA_CONF} = \$DUMMY_KOHA_CONF;
214	local $ENV{MEMCACHED_NAMESPACE} = $namespace;
215
216	$intranet_app->(@_);
217	},
218	context => $context,
219	shared_context => $shared_context,
220	};
221	}
222	@hd;
223	} @$sites;
224
225	return $class->app_per_host( \@host_def );
226	}
227
228	1;

Lines 43-49 use Koha::DateUtils qw(dt_from_string output_pref); Link Here

(-)a/about.pl (-3 / +2 lines)
43	use Koha::Acquisition::Currencies;	43	use Koha::Acquisition::Currencies;
44	use Koha::Patron::Categories;	44	use Koha::Patron::Categories;
45	use Koha::Patrons;	45	use Koha::Patrons;
46	use Koha::Caches;
47	use Koha::Config::SysPrefs;	46	use Koha::Config::SysPrefs;
48	use Koha::Illrequest::Config;	47	use Koha::Illrequest::Config;
49	use Koha::SearchEngine::Elasticsearch;	48	use Koha::SearchEngine::Elasticsearch;
Lines 119-125 if ( any { /(^psgi\.\|^plack\.)/i } keys %ENV ) { Link Here
119	my $memcached_servers = $ENV{MEMCACHED_SERVERS} \|\| C4::Context->config('memcached_servers');	118	my $memcached_servers = $ENV{MEMCACHED_SERVERS} \|\| C4::Context->config('memcached_servers');
120	my $memcached_namespace = $ENV{MEMCACHED_NAMESPACE} \|\| C4::Context->config('memcached_namespace') // 'koha';	119	my $memcached_namespace = $ENV{MEMCACHED_NAMESPACE} \|\| C4::Context->config('memcached_namespace') // 'koha';
121		120
122	my $cache = Koha::Caches->get_instance;	121	my $cache = C4::Context->cache;
123	my $effective_caching_method = ref($cache->cache);	122	my $effective_caching_method = ref($cache->cache);
124	# Memcached may have been running when plack has been initialized but could have been stopped since	123	# Memcached may have been running when plack has been initialized but could have been stopped since
125	# FIXME What are the consequences of that??	124	# FIXME What are the consequences of that??
Lines 175-181 my $warnNoActiveCurrency = (! defined Koha::Acquisition::Currencies->get_active) Link Here
175		174
176	my @xml_config_warnings;	175	my @xml_config_warnings;
177		176
178	my $context = new C4::Context;	177	my $context = C4::Context->current;
179		178
180	if ( ! defined C4::Context->config('zebra_bib_index_mode') ) {	179	if ( ! defined C4::Context->config('zebra_bib_index_mode') ) {
181	push @xml_config_warnings, {	180	push @xml_config_warnings, {

Lines 26-37 use C4::Output; Link Here

(-)a/admin/biblio_framework.pl (-2 / +1 lines)
26	use Koha::Biblios;	26	use Koha::Biblios;
27	use Koha::BiblioFramework;	27	use Koha::BiblioFramework;
28	use Koha::BiblioFrameworks;	28	use Koha::BiblioFrameworks;
29	use Koha::Caches;
30		29
31	my $input = new CGI;	30	my $input = new CGI;
32	my $frameworkcode = $input->param('frameworkcode') \|\| q\|\|;	31	my $frameworkcode = $input->param('frameworkcode') \|\| q\|\|;
33	my $op = $input->param('op') \|\| q\|list\|;	32	my $op = $input->param('op') \|\| q\|list\|;
34	my $cache = Koha::Caches->get_instance();	33	my $cache = C4::Context->cache;
35	my @messages;	34	my @messages;
36		35
37	my ( $template, $borrowernumber, $cookie ) = get_template_and_user(	36	my ( $template, $borrowernumber, $cookie ) = get_template_and_user(

Lines 24-34 use C4::Auth; Link Here

(-)a/admin/marctagstructure.pl (-6 / +1 lines)
24	use C4::Koha;	24	use C4::Koha;
25	use C4::Context;	25	use C4::Context;
26	use C4::Output;	26	use C4::Output;
27	use C4::Context;
28
29	use Koha::Caches;
30	use Koha::AuthorisedValues;
31	use Koha::BiblioFrameworks;
32		27
33	# retrieve parameters	28	# retrieve parameters
34	my $input = new CGI;	29	my $input = new CGI;
Lines 45-51 my $pagesize = 20; Link Here
45	my $script_name = "/cgi-bin/koha/admin/marctagstructure.pl";	40	my $script_name = "/cgi-bin/koha/admin/marctagstructure.pl";
46		41
47	my $dbh = C4::Context->dbh;	42	my $dbh = C4::Context->dbh;
48	my $cache = Koha::Caches->get_instance();	43	my $cache = C4::Context->cache;
49		44
50	# open template	45	# open template
51	my ($template, $loggedinuser, $cookie)	46	my ($template, $loggedinuser, $cookie)

Line 0 Link Here

(-)a/misc/plack/koha-multi.psgi (+34 lines)
	1	#!/usr/bin/perl
	2
	3	use Koha::Handler::Plack::CGI;
	4
	5	# If modules are not in a standard location
	6	# use lib '/usr/share/koha/lib' or set PERL5LIB or plackup -I
	7
	8	# This is a minimal example. You can include all frills from koha.psgi
	9	# To try it:
	10	# plackup --port 5010 koha-multi.psgi
	11
	12	my %KOHA_ENV = (
	13	opac => {
	14	static_root => '/usr/share/koha/opac/htdocs',
	15	script_root => '/usr/share/koha/opac/cgi-bin/opac',
	16	pugins => [
	17	# don't enable this plugin in production, since stack traces reveal too much information
	18	# about system to potential attackers!
	19	[ 'StackTrace' ],
	20	],
	21	},
	22	intranet => {
	23	static_root => '/usr/share/koha/intranet/htdocs',
	24	script_root => '/usr/share/koha/intranet/cgi-bin',
	25	}
	26	);
	27	my @SITES = map {
	28	namespace => $_,
	29	opac_hostname => "opac.$_.my-koha-multisite.net",
	30	intranet_hostname => "intranet.$_.my-koha-multisite.net",
	31	config => "/etc/koha/sites/$_/koha-conf.xml"
	32	}, qw(koha1 koha2 koha3);
	33
	34	Koha::Handler::Plack::CGI->multi_site( \%KOHA_ENV, \@SITES );

Lines 23-34 Link Here

(-)a/opac/svc/report (-3 / +2 lines)
23		23
24	use Modern::Perl;	24	use Modern::Perl;
25		25
		26	use C4::Context;
26	use C4::Reports::Guided;	27	use C4::Reports::Guided;
27	use JSON;	28	use JSON;
28	use CGI qw ( -utf8 );	29	use CGI qw ( -utf8 );
29		30
30	use Koha::Caches;
31
32	my $query = CGI->new();	31	my $query = CGI->new();
33	my $report_id = $query->param('id');	32	my $report_id = $query->param('id');
34	my $report_name = $query->param('name');	33	my $report_name = $query->param('name');
Lines 41-47 die "Sorry this report is not public\n" unless $report_rec->{public}; Link Here
41		40
42	my @sql_params = $query->param('sql_params');	41	my @sql_params = $query->param('sql_params');
43		42
44	my $cache = Koha::Caches->get_instance();	43	my $cache = C4::Context->cache;
45	my $cache_active = $cache->is_cache_active;	44	my $cache_active = $cache->is_cache_active;
46	my ($cache_key, $json_text);	45	my ($cache_key, $json_text);
47	if ($cache_active) {	46	if ($cache_active) {

Lines 2-8 Link Here

(-)a/t/Context.t (-1 / +27 lines)
2		2
3	use Modern::Perl;	3	use Modern::Perl;
4	use DBI;	4	use DBI;
5	use Test::More tests => 26;	5	use Test::More tests => 29;
6	use Test::MockModule;	6	use Test::MockModule;
7		7
8	BEGIN {	8	BEGIN {
Lines 62-64 is(C4::Context->interface, 'opac', 'interface still opac'); Link Here
62	#Bug 14751	62	#Bug 14751
63	is( C4::Context->interface( 'SiP' ), 'sip', 'interface SiP' );	63	is( C4::Context->interface( 'SiP' ), 'sip', 'interface SiP' );
64	is( C4::Context->interface( 'COMMANDLINE' ), 'commandline', 'interface commandline uc' );	64	is( C4::Context->interface( 'COMMANDLINE' ), 'commandline', 'interface commandline uc' );
		65
		66	my $DUMMY_KOHA_CONF = "<yazgfs><config><kohasite>TEST</kohasite></config></yazgfs>";
		67	my $ctx_a = C4::Context->new($DUMMY_KOHA_CONF, "a");
		68	my $ctx_b = C4::Context->new($DUMMY_KOHA_CONF, "b");
		69	my $cache_key = "test_C4::Context";
		70
		71	SKIP: {
		72	skip "No cache", 3 unless $ctx_a->cache->is_cache_active && $ctx_b->cache->is_cache_active;
		73
		74	# Light warm up
		75	C4::Context->cache->set_in_cache($cache_key, 'c');
		76	$ctx_a->cache->set_in_cache($cache_key, 'a');
		77	$ctx_b->cache->set_in_cache($cache_key, 'b');
		78	is(C4::Context->cache->get_from_cache($cache_key), 'c', "Correct default cache value");
		79	is($ctx_a->cache->get_from_cache($cache_key), 'a', "Correct cache 'a' value");
		80	is($ctx_b->cache->get_from_cache($cache_key), 'b', "Correct cache 'b' value");
		81
		82	# A bit more extravagant
		83	# Cannot run atm, fails due to no database in config
		84	# $ctx_a->run_within_context( sub {
		85	# $ctx_b->cache->set_in_cache($cache_key, 'bb');
		86	# C4::Context->cache->set_in_cache($cache_key, 'aa');
		87	# } );
		88	# is($ctx_a->cache->get_from_cache($cache_key), 'aa', "Correct cache 'a' value");
		89	# is($ctx_b->cache->get_from_cache($cache_key), 'bb', "Correct cache 'b' value");
		90	}

Line 0 Link Here

(-)a/t/Koha_Handler_Plack.t (+136 lines)
		1	#!/usr/bin/perl
		2
		3	use Test::More tests => 15;
		4	use Plack::Test;
		5	use Plack::Test::MockHTTP;
		6	use Test::Mock::LWP::Dispatch;
		7	use Test::MockModule;
		8	use HTTP::Request::Common;
		9	use FindBin qw($Bin);
		10	use Data::Dumper;
		11
		12	use_ok("Koha::Handler::Plack");
		13	use_ok("Koha::Handler::Plack::CGI");
		14
		15	use C4::Context;
		16
		17	my $db = Test::MockModule->new('Koha::Database');
		18	$db->mock(
		19	_new_schema => sub {
		20	return $_[0];
		21	}
		22	);
		23
		24	sub make_response {
		25	return join ";", map defined($_) ? $_ : "", @_;
		26	}
		27	sub dummy_val {
		28	return C4::Context->config("dummy");
		29	}
		30	sub check_context {
		31	my $dummy_val = dummy_val();
		32	is $dummy_val, undef, "context preserved"
		33	or diag("dummy val: $dummy_val");
		34	}
		35
		36	my $app = sub {
		37	return [
		38	200,
		39	[ 'Content-Type' => 'text/plain' ],
		40	[ make_response(dummy_val()) ]
		41	];
		42	};
		43	my $generic_url = "http://dummyhost.com/";
		44
		45	my $KOHA_CONF_XML = <<EOS;
		46	<yazgfs>
		47	<config>
		48	<kohasite>test</kohasite>
		49	<dummy>XML</dummy>
		50	<intrahtdocs>.</intrahtdocs>
		51	</config>
		52	</yazgfs>
		53	EOS
		54
		55	my @HOST_CONF = (
		56	{
		57	hostname => ['koha-file.com', 'www.koha-file.com'],
		58	app => $app,
		59	context => C4::Context->new("$Bin/conf/koha1/koha-conf.xml"),
		60	_dummy => "KOHA1"
		61	},
		62	{
		63	hostname => ['koha-xml.com', 'www.koha-xml.com'],
		64	app => $app,
65	context => C4::Context->new(\$KOHA_CONF_XML),
66	_dummy => "XML"
67	},
68	);
69	test_psgi
70	app => Koha::Handler::Plack->app_per_host(\@HOST_CONF),
71	client => sub {
72	my $cb = shift;
73
74	foreach my $site_params ( @HOST_CONF ) {
75	my $valid_response = make_response(
76	$site_params->{_dummy}
77	);
78	foreach (@{$site_params->{hostname}}) {
79	my $res = $cb->(GET "http://$_/");
80	is $res->content, $valid_response, $_
81	or diag(Dumper($site_params, $_, $res->as_string));
82	check_context();
83	}
84	}
85
86	$res = $cb->(GET $generic_url);
87	is $res->code, 404, "app_per_host unknown host"
88	or diag($res->as_string);
89	};
90
91	my %MULTI_HOST_ENV = (
92	opac => {
93	static_root => "$Bin/../koha-tmpl/opac-tmpl/bootstrap",
94	script_root => "$Bin/../opac",
95	},
96	intranet => {
97	static_root => "$Bin/../koha-tmpl/intranet-tmpl/bootstrap",
98	script_root => "$Bin/.."
99	}
100	);
101	my @MULTI_HOST_SITES = (
102	{
103	namespace => 'koha1',
104	opac_hostname => ['opac.koha1.com', 'www.opac.koha1.com'],
105	intranet_hostname => ['intranet.koha1.com', 'www.intranet.koha1.com'],
106	config => "$Bin/conf/koha1/koha-conf.xml",
107	},
108	{
109	namespace => 'koha2',
110	opac_hostname => ['opac.koha2.com', 'www.opac.koha2.com'],
111	intranet_hostname => ['intranet.koha2.com', 'www.intranet.koha2.com'],
112	config => "$Bin/conf/koha2/koha-conf.xml",
113	shared_context => 1,
114	},
115	);
116	test_psgi
117	app => Koha::Handler::Plack::CGI->multi_site(\%MULTI_HOST_ENV, \@MULTI_HOST_SITES),
118	client => sub {
119	my $cb = shift;
120
121	foreach my $site (@MULTI_HOST_SITES) {
122	my $opac = $site->{opac_hostname};
123	foreach my $host (@$opac) {
124	# this is not really a test, but cannot do any better atm
125	# TODO: a complex test involving two database connections
126	my $res = $cb->(GET "http://$host/");
127	# A future implementation may not redirect
128	if ($res->is_redirect) {
129	my $loc = $res->header("Location");
130	$res = $cb->(GET "http://$host$loc");
131	}
132	is $res->code, 500, "multi_site() $host"
133	or diag($res->as_string);
134	}
135	}
136	};

Lines 11-24 use Koha::Database; Link Here

(-)a/t/db_dependent/Context.t (-8 / +2 lines)
11		11
12	BEGIN {	12	BEGIN {
13	$debug = $ENV{DEBUG} \|\| 0;	13	$debug = $ENV{DEBUG} \|\| 0;
14
15	# Note: The overall number of tests may vary by configuration.
16	# First we need to check your environmental variables
17	for (qw(KOHA_CONF PERL5LIB)) {
18	ok( $ret = $ENV{$_}, "ENV{$_} = $ret" );
19	}
20	use_ok('C4::Context');
21	}	14	}
		15	use_ok('C4::Context');
22		16
23	ok($dbh = C4::Context->dbh(), 'Getting dbh from C4::Context');	17	ok($dbh = C4::Context->dbh(), 'Getting dbh from C4::Context');
24		18
Lines 50-56 C4::Context->clear_syspref_cache(); Link Here
50	C4::Context->enable_syspref_cache();	44	C4::Context->enable_syspref_cache();
51	$dbh->rollback;	45	$dbh->rollback;
52		46
53	ok($koha = C4::Context->new, 'C4::Context->new');	47	ok($koha = C4::Context->current, 'C4::Context->current');
54	my @keys = keys %$koha;	48	my @keys = keys %$koha;
55	my $width = 0;	49	my $width = 0;
56	if (ok(@keys)) {	50	if (ok(@keys)) {

Lines 30-36 use MARC::Record; Link Here

(-)a/t/db_dependent/Filter_MARC_ViewPolicy.t (-3 / +2 lines)
30	use MARC::Field;	30	use MARC::Field;
31	use C4::Context;	31	use C4::Context;
32	use C4::Biblio;	32	use C4::Biblio;
33	use Koha::Caches;
34	use Koha::Database;	33	use Koha::Database;
35		34
36	BEGIN {	35	BEGIN {
Lines 66-72 sub run_hiding_tests { Link Here
66		65
67	$sth->execute($hidden_value);	66	$sth->execute($hidden_value);
68		67
69	my $cache = Koha::Caches->get_instance();	68	my $cache = C4::Context->cache;
70	$cache->flush_all(); # easy way to ensure DB is queried again.	69	$cache->flush_all(); # easy way to ensure DB is queried again.
71		70
72	my $processor = Koha::RecordProcessor->new(	71	my $processor = Koha::RecordProcessor->new(
Lines 138-144 sub run_hiding_tests { Link Here
138		137
139	$sth->execute(-1); # -1 is visible in opac and intranet.	138	$sth->execute(-1); # -1 is visible in opac and intranet.
140		139
141	my $cache = Koha::Caches->get_instance();	140	my $cache = C4::Context->cache;
142	$cache->flush_all(); # easy way to ensure DB is queried again.	141	$cache->flush_all(); # easy way to ensure DB is queried again.
143		142
144	my $shouldhidemarc = Koha::Filter::MARC::ViewPolicy->should_hide_marc(	143	my $shouldhidemarc = Koha::Filter::MARC::ViewPolicy->should_hide_marc(

Lines 20-25 use Modern::Perl; Link Here

(-)a/t/db_dependent/Items.t (-2 / +3 lines)
20	use Data::Dumper;	20	use Data::Dumper;
21		21
22	use MARC::Record;	22	use MARC::Record;
		23	use C4::Context;
23	use C4::Biblio;	24	use C4::Biblio;
24	use Koha::Database;	25	use Koha::Database;
25	use Koha::DateUtils qw( dt_from_string );	26	use Koha::DateUtils qw( dt_from_string );
Lines 451-457 subtest 'SearchItems test' => sub { Link Here
451	$dbh->do('INSERT INTO marc_subfield_structure (tagfield, tagsubfield, frameworkcode) VALUES (?, "z", ?)', undef, $itemfield, $frameworkcode);	452	$dbh->do('INSERT INTO marc_subfield_structure (tagfield, tagsubfield, frameworkcode) VALUES (?, "z", ?)', undef, $itemfield, $frameworkcode);
452		453
453	# Clear cache	454	# Clear cache
454	my $cache = Koha::Caches->get_instance();	455	my $cache = C4::Context->cache;
455	$cache->clear_from_cache("MarcStructure-0-$frameworkcode");	456	$cache->clear_from_cache("MarcStructure-0-$frameworkcode");
456	$cache->clear_from_cache("MarcStructure-1-$frameworkcode");	457	$cache->clear_from_cache("MarcStructure-1-$frameworkcode");
457	$cache->clear_from_cache("default_value_for_mod_marc-");	458	$cache->clear_from_cache("default_value_for_mod_marc-");
Lines 708-714 subtest 'C4::Items::_build_default_values_for_mod_marc' => sub { Link Here
708	Koha::MarcSubfieldStructures->search({ frameworkcode => '', tagfield => '952', tagsubfield => 'p' })->delete;	709	Koha::MarcSubfieldStructures->search({ frameworkcode => '', tagfield => '952', tagsubfield => 'p' })->delete;
709		710
710	# And make sure the caches are cleared	711	# And make sure the caches are cleared
711	my $cache = Koha::Caches->get_instance();	712	my $cache = C4::Context->cache;
712	$cache->clear_from_cache("default_value_for_mod_marc-");	713	$cache->clear_from_cache("default_value_for_mod_marc-");
713	$cache->clear_from_cache("MarcSubfieldStructure-");	714	$cache->clear_from_cache("MarcSubfieldStructure-");
714		715

Lines 19-25 Link Here

(-)a/t/db_dependent/sysprefs.t (-1 / +12 lines)
19	# along with Koha; if not, see <http://www.gnu.org/licenses>.	19	# along with Koha; if not, see <http://www.gnu.org/licenses>.
20		20
21	use Modern::Perl;	21	use Modern::Perl;
22	use Test::More tests => 8;	22	use Test::More tests => 11;
23	use C4::Context;	23	use C4::Context;
24		24
25	# Start transaction	25	# Start transaction
Lines 60-63 is(C4::Context->preference('testpreference'), 'def', 'caching preferences'); Link Here
60	C4::Context->clear_syspref_cache();	60	C4::Context->clear_syspref_cache();
61	is(C4::Context->preference('testpreference'), undef, 'clearing preference cache');	61	is(C4::Context->preference('testpreference'), undef, 'clearing preference cache');
62		62
		63	delete $ENV{OVERRIDE_SYSPREF_opacheader};
		64
		65	my $DUMMY_KOHA_CONF = "<yazgfs><config><dummy>DUMMY</dummy></config></yazgfs>";
		66	my $context1 = C4::Context->new($DUMMY_KOHA_CONF, "context1");
		67	is( $context1->preference('opacheader'), $opacheader, 'context1 "opacheader"');
		68
		69	my $context2 = C4::Context->new($DUMMY_KOHA_CONF, "context2");
		70	$context2->set_preference( 'opacheader', $newopacheader );
		71	is( $context1->preference('opacheader'), $opacheader, 'context1 "opacheader"');
		72	is( $context2->preference('opacheader'), $newopacheader, 'context2 "opacheader"');
		73
63	$dbh->rollback;	74	$dbh->rollback;