Attachment #66376 for bug #15562

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

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');




			    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 C4::Boolean;

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

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->{use_syspref_cache} = 0;
    $self->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;

    $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




=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, $subnamespace, $namespace) = @_;
    $namespace //= '';

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




# 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 $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,
      },
      {
          hostname => ['koha2.com', 'www.koha2.com'],
          app => $app2,
          context => $context2,
      },
      ...

  C<hostname> is mandatory.

  koha.psgi:

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

  use C4::Context;

  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

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

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

                return $context->run_within_context(sub { $app->($env) });
            });
        }
    }
    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;

=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 131-137 my $warnNoActiveCurrency = (! defined Koha::Acquisition::Currencies->get_active) Link Here

(-)a/about.pl (-1 / +1 lines)
131		131
132	my @xml_config_warnings;	132	my @xml_config_warnings;
133		133
134	my $context = new C4::Context;	134	my $context = C4::Context->current;
135		135
136	if ( ! defined C4::Context->config('zebra_bib_index_mode') ) {	136	if ( ! defined C4::Context->config('zebra_bib_index_mode') ) {
137	push @xml_config_warnings, {	137	push @xml_config_warnings, {

Lines 387-393 output_html_with_http_headers $input, $cookie, $template->output; Link Here

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

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;




#!/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);
            }
        }
    };

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

Lines 51-57 C4::Context->clear_syspref_cache(); Link Here

(-)a/t/db_dependent/Context.t (-1 / +1 lines)
51	C4::Context->enable_syspref_cache();	51	C4::Context->enable_syspref_cache();
52	$dbh->rollback;	52	$dbh->rollback;
53		53
54	ok($koha = C4::Context->new, 'C4::Context->new');	54	ok($koha = C4::Context->current, 'C4::Context->current');
55	my @keys = keys %$koha;	55	my @keys = keys %$koha;
56	my $width = 0;	56	my $width = 0;
57	if (ok(@keys)) {	57	if (ok(@keys)) {

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		28
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;
- 

Return to bug 15562

Lines 32-38 BEGIN { Link Here

(-)a/C4/Context.pm (-152 / +131 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		101
101	use C4::Boolean;	102	use C4::Boolean;
Lines 164-177 environment variable to the pathname of a configuration file to use. Link Here
164	# file (/etc/koha/koha-conf.xml).	165	# file (/etc/koha/koha-conf.xml).
165	# dbh	166	# dbh
166	# A handle to the appropriate database for this context.	167	# A handle to the appropriate database for this context.
167	# dbh_stack
168	# Used by &set_dbh and &restore_dbh to hold other database
169	# handles for this context.
170	# Zconn
171	# A connection object for the Zebra server	168	# A connection object for the Zebra server
172		169
173	$context = undef; # Initially, no context is set	170	@context_stack = (); # Initially, no saved contexts
174	@context_stack = (); # Initially, no saved contexts	171
		172	=head2 current
		173
		174	Returns the current context
		175
		176	=cut
		177
		178	sub current {
		179	return $context;
		180	}
		181
		182	sub db_driver {
		183	my $self = shift;
		184
		185	$self = $context unless ref ($self);
		186	return unless $self;
		187
		188	return $self->{db_driver};
		189	}
175		190
176	=head2 db_scheme2dbi	191	=head2 db_scheme2dbi
177		192
Lines 193-224 sub import { Link Here
193	# Create the default context ($C4::Context::Context)	208	# Create the default context ($C4::Context::Context)
194	# the first time the module is called	209	# the first time the module is called
195	# (a config file can be optionaly passed)	210	# (a config file can be optionaly passed)
		211	# If ":no_config" is passed, no config load will be attempted
		212	# It saves the context values in the declared memcached server(s)
		213	# if currently available and uses those values until them expire and
		214	# re-reads them.
		215
		216	my ($pkg,$config_file) = @_;
196		217
197	# default context already exists?	218	# default context already exists?
198	return if $context;	219	return if $context;
199		220
200	# no ? so load it!	221	# multihost, we don't want/have one default config
201	my ($pkg,$config_file) = @_ ;	222	return if $config_file && $config_file eq ":no_config";
202	my $new_ctx = __PACKAGE__->new($config_file);
203	return unless $new_ctx;
204		223
205	# if successfully loaded, use it by default	224	my $conf_cache = Koha::Caches->get_instance('config');
206	$new_ctx->set_context;	225	if ( $conf_cache->cache ) {
207	1;	226	if ( $context = $conf_cache->get_from_cache('koha_conf') ) {
		227	return;
		228	}
		229	}
		230
		231	undef $config_file if $config_file && !-s $config_file;
		232	$config_file \|\|= Koha::Config->guess_koha_conf();
		233	$context = __PACKAGE__->new($config_file);
		234	return unless $context;
		235
		236	if ( $conf_cache->memcached_cache ) {
		237	# FIXME it may be better to use the memcached servers from the config file
		238	# to cache it
		239	$conf_cache->set_in_cache('koha_conf', $context)
		240	}
208	}	241	}
209		242
210	=head2 new	243	=head2 new
211		244
212	$context = new C4::Context;
213	$context = new C4::Context("/path/to/koha-conf.xml");	245	$context = new C4::Context("/path/to/koha-conf.xml");
214		246
215	Allocates a new context. Initializes the context from the specified	247	Allocates a new context. Initializes the context from the specified
216	file, which defaults to either the file given by the C<$KOHA_CONF>	248	file.
217	environment variable, or F</etc/koha/koha-conf.xml>.
218
219	It saves the koha-conf.xml values in the declared memcached server(s)
220	if currently available and uses those values until them expire and
221	re-reads them.
222		249
223	C<&new> does not set this context as the new default context; for	250	C<&new> does not set this context as the new default context; for
224	that, use C<&set_context>.	251	that, use C<&set_context>.
Lines 230-267 that, use C<&set_context>. Link Here
230	# 2004-08-10 A. Tarallo: Added check if the conf file is not empty	257	# 2004-08-10 A. Tarallo: Added check if the conf file is not empty
231	sub new {	258	sub new {
232	my $class = shift;	259	my $class = shift;
233	my $conf_fname = shift; # Config file to load	260	my $conf_fname = shift or croak "No conf";
234	my $self = {};	261	my $namespace = shift;
235
236	# check that the specified config file exists and is not empty
237	undef $conf_fname unless
238	(defined $conf_fname && -s $conf_fname);
239	# Figure out a good config file to load if none was specified.
240	unless ( defined $conf_fname ) {
241	$conf_fname = Koha::Config->guess_koha_conf;
242	unless ( $conf_fname ) {
243	warn "unable to locate Koha configuration file koha-conf.xml";
244	return;
245	}
246	}
247		262
248	my $conf_cache = Koha::Caches->get_instance('config');	263	my $self = Koha::Config->read_from_file($conf_fname);
249	my $config_from_cache;	264	die "Invalid config ".(ref($conf_fname) ? $$conf_fname : $conf_fname).": ".Dumper($self)
250	if ( $conf_cache->cache ) {	265	unless ref($self) && $self->{"config"};
251	$self = $conf_cache->get_from_cache('koha_conf');	266
252	}	267	$self->{config_file} = $conf_fname;
253	unless ( $self and %$self ) {	268	$self->{namespace} = $namespace;
254	$self = Koha::Config->read_from_file($conf_fname);	269	$self->{use_syspref_cache} = 1;
255	if ( $conf_cache->memcached_cache ) {	270	$self->{syspref_cache} = Koha::Caches->get_instance('syspref', $namespace);
256	# FIXME it may be better to use the memcached servers from the config file
257	# to cache it
258	$conf_cache->set_in_cache('koha_conf', $self)
259	}
260	}
261	unless ( exists $self->{config} or defined $self->{config} ) {
262	warn "The config file ($conf_fname) has not been parsed correctly";
263	return;
264	}
265		271
266	$self->{"Zconn"} = undef; # Zebra Connections	272	$self->{"Zconn"} = undef; # Zebra Connections
267	$self->{"userenv"} = undef; # User env	273	$self->{"userenv"} = undef; # User env
Lines 276-282 sub new { Link Here
276		282
277	=head2 set_context	283	=head2 set_context
278		284
279	$context = new C4::Context;
280	$context->set_context();	285	$context->set_context();
281	or	286	or
282	set_context C4::Context $context;	287	set_context C4::Context $context;
Lines 309-325 sub set_context Link Here
309	if (ref($self) eq "")	314	if (ref($self) eq "")
310	{	315	{
311	# Class method. The new context is the next argument.	316	# Class method. The new context is the next argument.
312	$new_context = shift;	317	$new_context = shift or croak "No new context";
313	} else {	318	} else {
314	# Instance method. The new context is $self.	319	# Instance method. The new context is $self.
315	$new_context = $self;	320	$new_context = $self;
316	}	321	}
317		322
318	# Save the old context, if any, on the stack	323	# undef $new_context->{schema} if $new_context->{schema} && !$new_context->{schema}->ping
319	push @context_stack, $context if defined($context);	324	my $schema = $new_context->{schema} \|\|= Koha::Database->new_schema($new_context);
		325
		326	# Save the old context on the stack
		327	push @context_stack, $context;
320		328
321	# Set the new context	329	# Set the new context
322	$context = $new_context;	330	$context = $new_context;
		331	Koha::Database->set_schema($schema);
323	}	332	}
324		333
325	=head2 restore_context	334	=head2 restore_context
Lines 335-353 sub restore_context Link Here
335	{	344	{
336	my $self = shift;	345	my $self = shift;
337		346
338	if ($#context_stack < 0)
339	{
340	# Stack underflow.
341	die "Context stack underflow";
342	}
343
344	# Pop the old context and set it.	347	# Pop the old context and set it.
345	$context = pop @context_stack;	348	$context = pop @context_stack;
		349	Koha::Database->restore_schema();
346		350
347	# FIXME - Should this return something, like maybe the context	351	# FIXME - Should this return something, like maybe the context
348	# that was current when this was called?	352	# that was current when this was called?
349	}	353	}
350		354
		355	=head2 run_within_context
		356
		357	$context->run_within_context(sub {...});
		358
		359	Runs code within context
		360
		361	=cut
		362
		363	#'
		364	sub run_within_context
		365	{
		366	my $self = shift;
		367	my $code = shift or croak "No code";
		368
		369	$self->set_context;
		370
		371	local $@;
		372	my $ret = eval { $code->(@_) };
		373	my $died = $@;
		374	$self->restore_context;
		375	die $died if $died;
		376	return $ret;
		377	}
		378
351	=head2 config	379	=head2 config
352		380
353	$value = C4::Context->config("config_variable");	381	$value = C4::Context->config("config_variable");
Lines 364-389 C<C4::Config-E<gt>new> will not return it. Link Here
364	=cut	392	=cut
365		393
366	sub _common_config {	394	sub _common_config {
367	my $var = shift;	395	my $self = shift;
368	my $term = shift;	396	my $var = shift;
369	return if !defined($context->{$term});	397	my $term = shift;
		398
		399	$self = $context unless ref $self;
		400	return if !defined($self->{$term});
370	# Presumably $self->{$term} might be	401	# Presumably $self->{$term} might be
371	# undefined if the config file given to &new	402	# undefined if the config file given to &new
372	# didn't exist, and the caller didn't bother	403	# didn't exist, and the caller didn't bother
373	# to check the return value.	404	# to check the return value.
374		405
375	# Return the value of the requested config variable	406	# Return the value of the requested config variable
376	return $context->{$term}->{$var};	407	return $self->{$term}->{$var};
377	}	408	}
378		409
379	sub config {	410	sub config {
380	return _common_config($_[1],'config');	411	my $self = shift;
		412	return $self->_common_config($_[0],'config');
381	}	413	}
382	sub zebraconfig {	414	sub zebraconfig {
383	return _common_config($_[1],'server');	415	my $self = shift;
		416	return $self->_common_config($_[0],'server');
384	}	417	}
385	sub ModZebrations {	418	sub ModZebrations {
386	return _common_config($_[1],'serverinfo');	419	my $self = shift;
		420	return $self->_common_config($_[0],'serverinfo');
387	}	421	}
388		422
389	=head2 preference	423	=head2 preference
Lines 402-430 with this method. Link Here
402		436
403	=cut	437	=cut
404		438
405	my $syspref_cache = Koha::Caches->get_instance('syspref');
406	my $use_syspref_cache = 1;
407	sub preference {	439	sub preference {
408	my $self = shift;	440	my $self = shift;
		441	$self = $context unless ref $self;
409	my $var = shift; # The system preference to return	442	my $var = shift; # The system preference to return
410		443
		444	$var = lc $var;
		445
411	return $ENV{"OVERRIDE_SYSPREF_$var"}	446	return $ENV{"OVERRIDE_SYSPREF_$var"}
412	if defined $ENV{"OVERRIDE_SYSPREF_$var"};	447	if defined $ENV{"OVERRIDE_SYSPREF_$var"};
413		448
414	$var = lc $var;	449	my $cached_var = $self->{use_syspref_cache}
415		450	? $self->{syspref_cache}->get_from_cache("syspref_$var")
416	if ($use_syspref_cache) {	451	: undef;
417	$syspref_cache = Koha::Caches->get_instance('syspref') unless $syspref_cache;	452	return $cached_var if defined $cached_var;
418	my $cached_var = $syspref_cache->get_from_cache("syspref_$var");
419	return $cached_var if defined $cached_var;
420	}
421		453
422	my $syspref;	454	my $syspref;
423	eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) };	455	eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) };
424	my $value = $syspref ? $syspref->value() : undef;	456	my $value = $syspref ? $syspref->value() : undef;
425		457
426	if ( $use_syspref_cache ) {	458	if ( $self->{use_syspref_cache} ) {
427	$syspref_cache->set_in_cache("syspref_$var", $value);	459	$self->{syspref_cache}->set_in_cache("syspref_$var", $value);
428	}	460	}
429	return $value;	461	return $value;
430	}	462	}
Lines 447-453 default behavior. Link Here
447		479
448	sub enable_syspref_cache {	480	sub enable_syspref_cache {
449	my ($self) = @_;	481	my ($self) = @_;
450	$use_syspref_cache = 1;	482	$self = $context unless ref $self;
		483	$self->{use_syspref_cache} = 1;
451	# We need to clear the cache to have it up-to-date	484	# We need to clear the cache to have it up-to-date
452	$self->clear_syspref_cache();	485	$self->clear_syspref_cache();
453	}	486	}
Lines 463-469 used with Plack and other persistent environments. Link Here
463		496
464	sub disable_syspref_cache {	497	sub disable_syspref_cache {
465	my ($self) = @_;	498	my ($self) = @_;
466	$use_syspref_cache = 0;	499	$self = $context unless ref $self;
		500	$self->{use_syspref_cache} = 0;
467	$self->clear_syspref_cache();	501	$self->clear_syspref_cache();
468	}	502	}
469		503
Lines 478-485 will not be seen by this process. Link Here
478	=cut	512	=cut
479		513
480	sub clear_syspref_cache {	514	sub clear_syspref_cache {
481	return unless $use_syspref_cache;	515	my ($self) = @_;
482	$syspref_cache->flush_all;	516	$self = $context unless ref $self;
		517	return unless $self->{use_syspref_cache};
		518	$self->{syspref_cache}->flush_all;
483	}	519	}
484		520
485	=head2 set_preference	521	=head2 set_preference
Lines 495-500 preference. Link Here
495		531
496	sub set_preference {	532	sub set_preference {
497	my ( $self, $variable, $value, $explanation, $type, $options ) = @_;	533	my ( $self, $variable, $value, $explanation, $type, $options ) = @_;
		534	$self = $context unless ref $self;
498		535
499	$variable = lc $variable;	536	$variable = lc $variable;
500		537
Lines 530-537 sub set_preference { Link Here
530	)->store();	567	)->store();
531	}	568	}
532		569
533	if ( $use_syspref_cache ) {	570	if ( $self->{use_syspref_cache} ) {
534	$syspref_cache->set_in_cache( "syspref_$variable", $value );	571	$self->{syspref_cache}->set_in_cache( "syspref_$variable", $value );
535	}	572	}
536		573
537	return $syspref;	574	return $syspref;
Lines 549-558 was no syspref of the name. Link Here
549		586
550	sub delete_preference {	587	sub delete_preference {
551	my ( $self, $var ) = @_;	588	my ( $self, $var ) = @_;
		589	$self = $context unless ref $self;
552		590
553	if ( Koha::Config::SysPrefs->find( $var )->delete ) {	591	if ( Koha::Config::SysPrefs->find( $var )->delete ) {
554	if ( $use_syspref_cache ) {	592	if ( $self->{use_syspref_cache} ) {
555	$syspref_cache->clear_from_cache("syspref_$var");	593	$self->{syspref_cache}->clear_from_cache("syspref_$var");
556	}	594	}
557		595
558	return 1;	596	return 1;
Lines 566-572 sub delete_preference { Link Here
566		604
567	Returns a connection to the Zebra database	605	Returns a connection to the Zebra database
568		606
569	C<$self>	607	C<$self>
570		608
571	C<$server> one of the servers defined in the koha-conf.xml file	609	C<$server> one of the servers defined in the koha-conf.xml file
572		610
Lines 677-684 creates one, and connects to the database. Link Here
677		715
678	This database handle is cached for future use: if you call	716	This database handle is cached for future use: if you call
679	C<C4::Context-E<gt>dbh> twice, you will get the same handle both	717	C<C4::Context-E<gt>dbh> twice, you will get the same handle both
680	times. If you need a second database handle, use C<&new_dbh> and	718	times. If you need a second database handle, use C<&new_dbh>.
681	possibly C<&set_dbh>.
682		719
683	=cut	720	=cut
684		721
Lines 717-780 sub new_dbh Link Here
717	return &dbh({ new => 1 });	754	return &dbh({ new => 1 });
718	}	755	}
719		756
720	=head2 set_dbh
721
722	$my_dbh = C4::Connect->new_dbh;
723	C4::Connect->set_dbh($my_dbh);
724	...
725	C4::Connect->restore_dbh;
726
727	C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
728	C<&set_context> and C<&restore_context>.
729
730	C<&set_dbh> saves the current database handle on a stack, then sets
731	the current database handle to C<$my_dbh>.
732
733	C<$my_dbh> is assumed to be a good database handle.
734
735	=cut
736
737	#'
738	sub set_dbh
739	{
740	my $self = shift;
741	my $new_dbh = shift;
742
743	# Save the current database handle on the handle stack.
744	# We assume that $new_dbh is all good: if the caller wants to
745	# screw himself by passing an invalid handle, that's fine by
746	# us.
747	push @{$context->{"dbh_stack"}}, $context->{"dbh"};
748	$context->{"dbh"} = $new_dbh;
749	}
750
751	=head2 restore_dbh
752
753	C4::Context->restore_dbh;
754
755	Restores the database handle saved by an earlier call to
756	C<C4::Context-E<gt>set_dbh>.
757
758	=cut
759
760	#'
761	sub restore_dbh
762	{
763	my $self = shift;
764
765	if ($#{$context->{"dbh_stack"}} < 0)
766	{
767	# Stack underflow
768	die "DBH stack underflow";
769	}
770
771	# Pop the old database handle and set it.
772	$context->{"dbh"} = pop @{$context->{"dbh_stack"}};
773
774	# FIXME - If it is determined that restore_context should
775	# return something, then this function should, too.
776	}
777
778	=head2 queryparser	757	=head2 queryparser
779		758
780	$queryparser = C4::Context->queryparser	759	$queryparser = C4::Context->queryparser

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, $subnamespace, $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 47-56 __PACKAGE__->mk_accessors(qw( )); Link Here

(-)a/Koha/Database.pm (-8 / +30 lines)
47	# database connection from the data given in the current context, and	47	# database connection from the data given in the current context, and
48	# returns it.	48	# returns it.
49	sub _new_schema {	49	sub _new_schema {
		50	my $context = shift \|\| C4::Context->current();
50		51
51	my $context = C4::Context->new();	52	my $db_driver = $context->db_driver;
52
53	my $db_driver = $context->{db_driver};
54		53
55	my $db_name = $context->config("database");	54	my $db_name = $context->config("database");
56	my $db_host = $context->config("hostname");	55	my $db_host = $context->config("hostname");
Lines 136-151 sub schema { Link Here
136	return $database->{schema} if defined $database->{schema};	135	return $database->{schema} if defined $database->{schema};
137	}	136	}
138		137
139	$database->{schema} = &_new_schema();	138	$database->{schema} = &_new_schema($params->{context});
140	return $database->{schema};	139	return $database->{schema};
141	}	140	}
142		141
143	=head2 new_schema	142	=head2 new_schema
144		143
145	$schema = $database->new_schema;	144	$schema = $database->new_schema($context);
146		145
147	Creates a new connection to the Koha database for the current context,	146	Creates a new connection to the Koha database for the context
148	and returns the database handle (a C<DBI::db> object).	147	(current is default), and returns the database handle (a C<DBI::db> object).
149		148
150	The handle is not saved anywhere: this method is strictly a	149	The handle is not saved anywhere: this method is strictly a
151	convenience function; the point is that it knows which database to	150	convenience function; the point is that it knows which database to
Lines 157-163 connect to so that the caller doesn't have to know. Link Here
157	sub new_schema {	156	sub new_schema {
158	my $self = shift;	157	my $self = shift;
159		158
160	return &_new_schema();	159	return &_new_schema(@_);
161	}	160	}
162		161
163	=head2 set_schema	162	=head2 set_schema
Lines 231-236 sub flush_schema_cache { Link Here
231	return 1;	230	return 1;
232	}	231	}
233		232
		233	=head2 run_with_schema
		234
		235	$database->run_with_schema( $schema, sub {...} );
		236
		237	Restores the database handle saved by an earlier call to
		238	C<$database-E<gt>set_schema> C<$database-E<gt>restore_schema> wrapper.
		239
		240	=cut
		241
		242	sub run_with_schema {
		243	my $self = shift;
		244	my $schema = shift or croak "No schema";
		245	my $code = shift or croak "No sub";
		246
		247	$self->set_schema;
		248	local $@;
		249	my $ret = eval { $code->(@_) };
		250	my $died = $@;
		251	$self->restore_schema;
		252	die $died if $died;
		253	return $ret;
		254	}
		255
234	=head2 EXPORT	256	=head2 EXPORT
235		257
236	None by default.	258	None by default.

Line 0 Link Here

(-)a/Koha/Handler/Plack.pm (+163 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	},
73	{
74	hostname => ['koha2.com', 'www.koha2.com'],
75	app => $app2,
76	context => $context2,
77	},
78	...
79
80	C<hostname> is mandatory.
81
82	koha.psgi:
83
84	use Plack::Builder;
85	use Plack::App::CGIBin;
86
87	use C4::Context;
88
89	my $opac_app = builder {
90	enable "Plack::Middleware::Static",
91	path => qr{^/opac-tmpl/}, root => '/usr/share/koha/opac/htdocs/';
92
93	enable 'StackTrace';
94	mount "/cgi-bin/koha" => Plack::App::CGIBin->new(root => "/usr/share/koha/opac/cgi-bin/opac");
95	};
96	my $intranet_app = builder {
97	enable "Plack::Middleware::Static",
98	path => qr{^/intranet-tmpl/}, root => '/usr/share/koha/intranet/htdocs/';
99
100	enable 'StackTrace';
101	mount "/cgi-bin/koha" => Plack::App::CGIBin->new(root => "/usr/share/koha/cgi-bin");
102	};
103
104	my @host_def;
105
106	my $conf_file_1 = "/etc/koha/site-1/koha_conf.xml";
107	my $context_1 = C4::Context->new($conf_file_1);
108	push @host_def,
109	{
110	hostname => [ "public.host.for.site-1", "www.public.host.for.site-1" ],
111	app => $opac_app,
112	context => $context_1,
113	},
114	{
115	hostname => "intranet.host.for.site-1",
116	app => $intranet_app,
117	context => $context_1,
118	};
119
120	my $conf_file_2 = "/etc/koha/site-1/koha_conf.xml";
121	my $context_2 = C4::Context->new($conf_file_2);
122	push @host_def,
123	{
124	hostname => "public.host.for.site-2",
125	app => $opac_app,
126	context => $context_2,
127	},
128	{
129	hostname => "intranet.host.for.site-2",
130	app => $intranet_app,
131	context => $context_2,
132	};
133
134	...
135
136	Koha::Handler::Plack->app_per_host( \@host_def );
137
138	=cut
139
140	sub app_per_host {
141	my $class = shift;
142	my $sites = shift or die "No sites spec";
143
144	my $map = Plack::App::URLMap->new;
145	foreach my $site_params ( @$sites ) {
146	my $hosts = $site_params->{hostname} or croak "No hostname";
147	$hosts = [$hosts] unless ref $hosts;
148
149	my $app = $site_params->{app} or croak "No app";
150	my $context = $site_params->{context} or croak "No Koha Context";
151
152	foreach my $host (@$hosts) {
153	$map->map("http://$host/" => sub {
154	my $env = shift;
155
156	return $context->run_within_context(sub { $app->($env) });
157	});
158	}
159	}
160	return $map->to_app;
161	}
162
163	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;
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;

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 );

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 19-25 Link Here

(-)a/t/db_dependent/sysprefs.t (-2 / +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;
64	-