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

(-)a/C4/Auth.pm (-4 / +4 lines)
Lines 31-37 use C4::Templates; # to get the template Link Here
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
(-)a/C4/Auth_with_ldap.pm (-1 / +1 lines)
Lines 54-60 sub ldapserver_error { Link Here
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');
(-)a/C4/Biblio.pm (-3 / +3 lines)
Lines 38-45 use C4::Charset; Link Here
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;
(-)a/C4/Calendar.pm (-8 / +7 lines)
Lines 23-29 use Carp; Link Here
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
}
(-)a/C4/Context.pm (-152 / +158 lines)
Lines 32-38 BEGIN { Link Here
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
(-)a/C4/External/OverDrive.pm (-4 / +2 lines)
Lines 22-28 use warnings; Link Here
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;
(-)a/C4/Installer/PerlDependencies.pm (+5 lines)
Lines 362-367 our $PERL_DEPS = { Link Here
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',
(-)a/C4/Items.pm (-1 / +1 lines)
Lines 444-450 sub _build_default_values_for_mod_marc { Link Here
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;
(-)a/C4/Koha.pm (-2 / +1 lines)
Lines 24-30 use strict; Link Here
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
(-)a/C4/Utils/DataTables/ColumnsSettings.pm (-2 / +1 lines)
Lines 5-15 use List::Util qw( first ); Link Here
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) {
(-)a/Koha/Cache.pm (-16 / +17 lines)
Lines 64-97 Create a new Koha::Cache object. This is required for all cache-related function Link Here
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'
(-)a/Koha/Caches.pm (-5 / +8 lines)
Lines 46-56 persistent across multiple instances. Link Here
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
}
(-)a/Koha/Calendar.pm (-3 / +2 lines)
Lines 7-13 use DateTime; Link Here
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:
(-)a/Koha/Database.pm (-10 / +31 lines)
Lines 35-40 Koha::Database Link Here
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.
(-)a/Koha/Handler/Plack.pm (+200 lines)
Line 0 Link Here
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;
(-)a/Koha/Handler/Plack/CGI.pm (+228 lines)
Line 0 Link Here
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;
(-)a/Koha/MetaSearcher.pm (-2 / +2 lines)
Lines 25-31 use C4::Charset qw( MarcToUTF8Record ); Link Here
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 => {
(-)a/Koha/Template/Plugin/Cache.pm (-3 / +1 lines)
Lines 21-27 use strict; Link Here
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,
(-)a/about.pl (-3 / +2 lines)
Lines 43-49 use Koha::DateUtils qw(dt_from_string output_pref); Link Here
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, {
(-)a/admin/biblio_framework.pl (-2 / +1 lines)
Lines 26-37 use C4::Output; Link Here
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(
(-)a/admin/koha2marclinks.pl (-1 / +1 lines)
Lines 43-49 my ( $template, $borrowernumber, $cookie ) = get_template_and_user ( Link Here
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;
(-)a/admin/marc_subfields_structure.pl (-1 / +1 lines)
Lines 79-85 my ( $template, $borrowernumber, $cookie ) = get_template_and_user( Link Here
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;
(-)a/admin/marctagstructure.pl (-6 / +1 lines)
Lines 24-34 use C4::Auth; Link Here
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)
(-)a/admin/systempreferences.pl (-1 / +1 lines)
Lines 385-391 output_html_with_http_headers $input, $cookie, $template->output; Link Here
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
(-)a/installer/install.pl (-26 / +27 lines)
Lines 24-29 use diagnostics; Link Here
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
    }
(-)a/misc/cronjobs/check-url.pl (-1 / +1 lines)
Lines 190-196 sub check_all_url { Link Here
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 <> ''" );
(-)a/misc/plack/koha-multi.psgi (+34 lines)
Line 0 Link Here
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 );
(-)a/misc/translator/LangInstaller.pm (-2 / +2 lines)
Lines 56-62 sub new { Link Here
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;
(-)a/opac/svc/report (-3 / +2 lines)
Lines 23-34 Link Here
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) {
(-)a/reports/guided_reports.pl (-2 / +1 lines)
Lines 29-35 use C4::Auth qw/:DEFAULT get_session/; Link Here
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;
(-)a/svc/report (-2 / +2 lines)
Lines 25-31 use C4::Reports::Guided; Link Here
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) {
(-)a/t/Calendar.t (-2 / +2 lines)
Lines 22-28 use Test::MockModule; Link Here
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
(-)a/t/Context.t (-1 / +27 lines)
Lines 2-8 Link Here
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
}
(-)a/t/Koha_Handler_Plack.t (+136 lines)
Line 0 Link Here
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
    };
(-)a/t/Koha_Template_Plugin_Cache.t (-1 / +3 lines)
Lines 1-6 Link Here
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));
(-)a/t/conf/dummy/koha-conf.xml (+7 lines)
Line 0 Link Here
1
<yazgfs>
2
    <config>
3
        <kohasite>dummy</kohasite>
4
        <dummy>DUMMY</dummy>
5
        <intrahtdocs>.</intrahtdocs>
6
    </config>
7
</yazgfs>
(-)a/t/conf/koha1/koha-conf.xml (+7 lines)
Line 0 Link Here
1
<yazgfs>
2
    <config>
3
        <kohasite>koha1</kohasite>
4
        <dummy>KOHA1</dummy>
5
        <intrahtdocs>.</intrahtdocs>
6
    </config>
7
</yazgfs>
(-)a/t/conf/koha2/koha-conf.xml (+5 lines)
Line 0 Link Here
1
<yazgfs>
2
    <config>
3
        <dummy>KOHA2</dummy>
4
    </config>
5
</yazgfs>
(-)a/t/db_dependent/Amazon.t (-1 / +1 lines)
Lines 14-20 BEGIN { Link Here
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
(-)a/t/db_dependent/Context.t (-8 / +2 lines)
Lines 11-24 use Koha::Database; Link Here
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)) { 
(-)a/t/db_dependent/Filter_MARC_ViewPolicy.t (-3 / +2 lines)
Lines 30-36 use MARC::Record; Link Here
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(
(-)a/t/db_dependent/Items.t (-2 / +3 lines)
Lines 20-25 use Modern::Perl; Link Here
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
(-)a/t/db_dependent/Template/Plugin/KohaDates.t (-1 / +1 lines)
Lines 14-20 BEGIN { Link Here
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()");
(-)a/t/db_dependent/XISBN.t (-1 / +1 lines)
Lines 26-32 my $search_module = new Test::MockModule('C4::Search'); Link Here
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', '' );
(-)a/t/db_dependent/sysprefs.t (-1 / +12 lines)
Lines 19-25 Link Here
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;
(-)a/tools/newHolidays.pl (-2 / +2 lines)
Lines 24-30 use CGI qw ( -utf8 ); Link Here
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