Sort of an apocalypse * C4::Context->new() must be called with at least config file param. If you want current context, call C4::Context->current(). C4::Context->some_method() will still work as is. * Koha::Database->new_schema() now takes optional context param. * C4::Context->set_context() and restore_context() are synched with database set_schema() and restore_schema(). Created run_within_context() that wraps set_context() and restore_context() around code. * Created Koha::Handler::Plack* to facilitate running same code within different (database) contexts. * This initial version does not run with memcached turned on. Next patch will correct that.
https://bugs.koha-community.org/show_bug.cgi?id=15562 --- C4/Auth_with_cas.pm | 2 +- C4/Auth_with_ldap.pm | 2 +- C4/Context.pm | 352 +++++++++++------------- Koha/Cache.pm | 14 +- Koha/Database.pm | 38 ++- Koha/Handler/Plack.pm | 163 +++++++++++ Koha/Handler/Plack/CGI.pm | 228 +++++++++++++++ about.pl | 2 +- admin/systempreferences.pl | 2 +- misc/cronjobs/check-url.pl | 2 +- misc/plack/koha-multi.psgi | 29 ++ misc/translator/LangInstaller.pm | 4 +- t/Koha_Handler_Plack.t | 136 +++++++++ t/conf/dummy/koha-conf.xml | 7 + t/conf/koha1/koha-conf.xml | 7 + t/conf/koha2/koha-conf.xml | 5 + t/db_dependent/Amazon.t | 2 +- t/db_dependent/Context.t | 2 +- t/db_dependent/Koha_template_plugin_KohaDates.t | 2 +- t/db_dependent/XISBN.t | 2 +- t/db_dependent/sysprefs.t | 13 +- 21 files changed, 802 insertions(+), 212 deletions(-) create mode 100644 Koha/Handler/Plack.pm create mode 100644 Koha/Handler/Plack/CGI.pm create mode 100644 misc/plack/koha-multi.psgi create mode 100644 t/Koha_Handler_Plack.t create mode 100644 t/conf/dummy/koha-conf.xml create mode 100644 t/conf/koha1/koha-conf.xml create mode 100644 t/conf/koha2/koha-conf.xml diff --git a/C4/Auth_with_cas.pm b/C4/Auth_with_cas.pm index c9174da..f78e3b5 100644 --- a/C4/Auth_with_cas.pm +++ b/C4/Auth_with_cas.pm @@ -36,7 +36,7 @@ BEGIN { @ISA = qw(Exporter); @EXPORT = qw(check_api_auth_cas checkpw_cas login_cas logout_cas login_cas_url); } -my $context = C4::Context->new() or die 'C4::Context->new failed'; +my $context = C4::Context->current() or die 'No current context'; my $defaultcasserver; my $casservers; my $yamlauthfile = C4::Context->config('intranetdir') . "/C4/Auth_cas_servers.yaml"; diff --git a/C4/Auth_with_ldap.pm b/C4/Auth_with_ldap.pm index 4a9c302..0e7e6b0 100644 --- a/C4/Auth_with_ldap.pm +++ b/C4/Auth_with_ldap.pm @@ -53,7 +53,7 @@ sub ldapserver_error { } use vars qw($mapping @ldaphosts $base $ldapname $ldappassword); -my $context = C4::Context->new() or die 'C4::Context->new failed'; +my $context = C4::Context->current() or die 'No current context'; my $ldap = C4::Context->config("ldapserver") or die 'No "ldapserver" in server hash from KOHA_CONF: ' . $ENV{KOHA_CONF}; my $prefhost = $ldap->{hostname} or die ldapserver_error('hostname'); my $base = $ldap->{base} or die ldapserver_error('base'); diff --git a/C4/Context.pm b/C4/Context.pm index 6b70b60..189b07d 100644 --- a/C4/Context.pm +++ b/C4/Context.pm @@ -31,7 +31,7 @@ BEGIN { eval {C4::Context->dbh();}; if ($@){ $debug_level = 1; - } + } else { $debug_level = C4::Context->preference("DebugLevel"); } @@ -49,7 +49,7 @@ BEGIN { # a little example table with various version info"; print " <h1>Koha error</h1> - <p>The following fatal error has occurred:</p> + <p>The following fatal error has occurred:</p> <pre><code>$msg</code></pre> <table> <tr><th>Apache</th><td> $versions{apacheVersion}</td></tr> @@ -63,11 +63,11 @@ BEGIN { } elsif ($debug_level eq "1"){ print " <h1>Koha error</h1> - <p>The following fatal error has occurred:</p> + <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); @@ -112,6 +112,7 @@ use Koha::Cache; use POSIX (); use DateTime::TimeZone; use Module::Load::Conditional qw(can_load); +use Data::Dumper; use Carp; use C4::Boolean; @@ -179,10 +180,6 @@ environment variable to the pathname of a configuration file to use. # 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 # Koha's main configuration file koha-conf.xml @@ -191,7 +188,7 @@ environment variable to the pathname of a configuration file to use. # 1. Path supplied via use C4::Context '/path/to/koha-conf.xml' # 2. Path supplied in KOHA_CONF environment variable. # 3. Path supplied in INSTALLED_CONFIG_FNAME, as long -# as value has changed from its default of +# as value has changed from its default of # '__KOHA_CONF_DIR__/koha-conf.xml', as happens # when Koha is installed in 'standard' or 'single' # mode. @@ -201,52 +198,25 @@ environment variable to the pathname of a configuration file to use. use constant CONFIG_FNAME => "/etc/koha/koha-conf.xml"; # Default config file, if none is specified - + my $INSTALLED_CONFIG_FNAME = '__KOHA_CONF_DIR__/koha-conf.xml'; # path to config file set by installer # __KOHA_CONF_DIR__ is set by rewrite-confg.PL # when Koha is installed in 'standard' or 'single' - # mode. If Koha was installed in 'dev' mode, + # mode. If Koha was installed in 'dev' mode, # __KOHA_CONF_DIR__ is *not* rewritten; instead - # developers should set the KOHA_CONF environment variable - -$context = undef; # Initially, no context is set -@context_stack = (); # Initially, no saved contexts - - -=head2 read_config_file - -Reads the specified Koha config file. - -Returns an object containing the configuration variables. The object's -structure is a bit complex to the uninitiated ... take a look at the -koha-conf.xml file as well as the XML::Simple documentation for details. Or, -here are a few examples that may give you what you need: + # developers should set the KOHA_CONF environment variable -The simple elements nested within the <config> element: +@context_stack = (); # Initially, no saved contexts - my $pass = $koha->{'config'}->{'pass'}; +=head2 current -The <listen> elements: - - my $listen = $koha->{'listen'}->{'biblioserver'}->{'content'}; - -The elements nested within the <server> element: - - my $ccl2rpn = $koha->{'server'}->{'biblioserver'}->{'cql2rpn'}; - -Returns undef in case of error. +Returns the current context =cut -sub read_config_file { # Pass argument naming config file to read - my $koha = XMLin(shift, keyattr => ['id'], forcearray => ['listen', 'server', 'serverinfo'], suppressempty => ''); - - if ($ismemcached) { - $memcached->set('kohaconf',$koha); - } - - return $koha; # Return value: ref-to-hash holding the configuration +sub current { + return $context; } =head2 ismemcached @@ -274,6 +244,15 @@ sub memcached { } } +sub db_driver { + my $self = shift; + + $self = $context unless ref ($self); + return unless $self; + + return $self->{db_driver}; +} + =head2 db_scheme2dbi my $dbd_driver_name = C4::Context::db_schema2dbi($scheme); @@ -294,32 +273,85 @@ sub import { # 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 + # Config file defaults to either the file given by the $KOHA_CONF + # environment variable, or /etc/koha/koha-conf.xml. + # 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; + if ($ismemcached) { + # retrieve from memcached + if (my $self = $memcached->get('kohaconf')) { + $context = $self; + return; + } + } + + # check that the specified config file exists and is not empty + undef $config_file if defined $config_file && + !( ref($config_file) || openhandle($config_file) || -s $config_file ); + # Figure out a good config file to load if none was specified. + if (!defined($config_file)) + { + # If the $KOHA_CONF environment variable is set, use + # that. Otherwise, use the built-in default. + if ($ENV{'KOHA_CONF'} and ref($ENV{'KOHA_CONF'}) || -s $ENV{"KOHA_CONF"}) { + $config_file = $ENV{"KOHA_CONF"}; + } elsif ($INSTALLED_CONFIG_FNAME !~ /__KOHA_CONF_DIR/ and -s $INSTALLED_CONFIG_FNAME) { + # NOTE: be careful -- don't change __KOHA_CONF_DIR in the above + # regex to anything else -- don't want installer to rewrite it + $config_file = $INSTALLED_CONFIG_FNAME; + } elsif (-s CONFIG_FNAME) { + $config_file = CONFIG_FNAME; + } else { + die "unable to locate Koha configuration file koha-conf.xml"; + } + } + # no ? so load it! - my ($pkg,$config_file) = @_ ; + return if $config_file && $config_file eq ":no_config"; my $new_ctx = __PACKAGE__->new($config_file); return unless $new_ctx; # if successfully loaded, use it by default - $new_ctx->set_context; - 1; + $context = $new_ctx; + + if ($ismemcached) { + $memcached->set('kohaconf',$new_ctx); + } } +use Scalar::Util qw(openhandle); =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, which defaults to either the file given by the C<$KOHA_CONF> -environment variable, or F</etc/koha/koha-conf.xml>. +file. -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. +XML structure is a bit complex to the uninitiated ... take a look at the +koha-conf.xml file as well as the XML::Simple documentation for details. Or, +here are a few examples that may give you what you need: + +The simple elements nested within the <config> element: + + my $pass = $koha->{'config'}->{'pass'}; + +The <listen> elements: + + my $listen = $koha->{'listen'}->{'biblioserver'}->{'content'}; + +The elements nested within the <server> element: + + my $ccl2rpn = $koha->{'server'}->{'biblioserver'}->{'cql2rpn'}; + +Returns undef in case of error. C<&new> does not set this context as the new default context; for that, use C<&set_context>. @@ -331,46 +363,22 @@ 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; # Config file to load - my $self = {}; - - # 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. - if (!defined($conf_fname)) - { - # If the $KOHA_CONF environment variable is set, use - # that. Otherwise, use the built-in default. - if (exists $ENV{"KOHA_CONF"} and $ENV{'KOHA_CONF'} and -s $ENV{"KOHA_CONF"}) { - $conf_fname = $ENV{"KOHA_CONF"}; - } elsif ($INSTALLED_CONFIG_FNAME !~ /__KOHA_CONF_DIR/ and -s $INSTALLED_CONFIG_FNAME) { - # NOTE: be careful -- don't change __KOHA_CONF_DIR in the above - # regex to anything else -- don't want installer to rewrite it - $conf_fname = $INSTALLED_CONFIG_FNAME; - } elsif (-s CONFIG_FNAME) { - $conf_fname = CONFIG_FNAME; - } else { - warn "unable to locate Koha configuration file koha-conf.xml"; - return; - } - } - - if ($ismemcached) { - # retrieve from memcached - $self = $memcached->get('kohaconf'); - if (not defined $self) { - # not in memcached yet - $self = read_config_file($conf_fname); - } - } else { - # non-memcached env, read from file - $self = read_config_file($conf_fname); - } - - $self->{"config_file"} = $conf_fname; - warn "read_config_file($conf_fname) returned undef" if !defined($self->{"config"}); - return if !defined($self->{"config"}); + my $conf_fname = shift or croak "No conf"; + my $namespace = shift; + + my $self = XMLin( + $conf_fname, + keyattr => ['id'], + forcearray => ['listen', 'server', 'serverinfo'], + suppressempty => '', + ); + 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::Cache->new({namespace => $namespace}); $self->{"Zconn"} = undef; # Zebra Connections $self->{"marcfromkohafield"} = undef; # the hash with relations between koha table fields and MARC field/subfield @@ -386,7 +394,6 @@ sub new { =head2 set_context - $context = new C4::Context; $context->set_context(); or set_context C4::Context $context; @@ -419,17 +426,21 @@ sub set_context if (ref($self) eq "") { # Class method. The new context is the next argument. - $new_context = shift; + $new_context = shift or croak "No new context"; } else { # Instance method. The new context is $self. $new_context = $self; } - # Save the old context, if any, on the stack - push @context_stack, $context if defined($context); + # 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 @@ -445,19 +456,38 @@ sub 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"); @@ -474,26 +504,32 @@ C<C4::Config-E<gt>new> will not return it. =cut sub _common_config { - my $var = shift; - my $term = shift; - return if !defined($context->{$term}); + 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 $context->{$term}->{$var}; + return $self->{$term}->{$var}; } sub config { - return _common_config($_[1],'config'); + my $self = shift; + return $self->_common_config($_[0],'config'); } sub zebraconfig { - return _common_config($_[1],'server'); + my $self = shift; + return $self->_common_config($_[0],'server'); } sub ModZebrations { - return _common_config($_[1],'serverinfo'); + my $self = shift; + return $self->_common_config($_[0],'serverinfo'); } =head2 preference @@ -512,16 +548,15 @@ with this method. =cut -my $syspref_cache = Koha::Cache->get_instance(); -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; - my $cached_var = $use_syspref_cache - ? $syspref_cache->get_from_cache("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; @@ -534,8 +569,8 @@ sub preference { $value = $syspref ? $syspref->value() : undef; } - if ( $use_syspref_cache ) { - $syspref_cache->set_in_cache("syspref_$var", $value); + if ( $self->{use_syspref_cache} ) { + $self->{syspref_cache}->set_in_cache("syspref_$var", $value); } return $value; } @@ -558,7 +593,8 @@ default behavior. sub enable_syspref_cache { my ($self) = @_; - $use_syspref_cache = 1; + $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(); } @@ -574,7 +610,8 @@ used with Plack and other persistent environments. sub disable_syspref_cache { my ($self) = @_; - $use_syspref_cache = 0; + $self = $context unless ref $self; + $self->{use_syspref_cache} = 0; $self->clear_syspref_cache(); } @@ -589,8 +626,10 @@ will not be seen by this process. =cut sub clear_syspref_cache { - return unless $use_syspref_cache; - $syspref_cache->flush_all; + my ($self) = @_; + $self = $context unless ref $self; + return unless $self->{use_syspref_cache}; + $self->{syspref_cache}->flush_all; } =head2 set_preference @@ -606,6 +645,7 @@ preference. sub set_preference { my ( $self, $variable, $value, $explanation, $type, $options ) = @_; + $self = $context unless ref $self; $variable = lc $variable; @@ -641,8 +681,8 @@ sub set_preference { )->store(); } - if ( $use_syspref_cache ) { - $syspref_cache->set_in_cache( "syspref_$variable", $value ); + if ( $self->{use_syspref_cache} ) { + $self->{syspref_cache}->set_in_cache( "syspref_$variable", $value ); } return $syspref; @@ -660,10 +700,11 @@ was no syspref of the name. sub delete_preference { my ( $self, $var ) = @_; + $self = $context unless ref $self; if ( Koha::Config::SysPrefs->find( $var )->delete ) { - if ( $use_syspref_cache ) { - $syspref_cache->clear_from_cache("syspref_$var"); + if ( $self->{use_syspref_cache} ) { + $self->{syspref_cache}->clear_from_cache("syspref_$var"); } return 1; @@ -677,7 +718,7 @@ sub delete_preference { Returns a connection to the Zebra database -C<$self> +C<$self> C<$server> one of the servers defined in the koha-conf.xml file @@ -788,8 +829,7 @@ creates one, and connects to the database. 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> and -possibly C<&set_dbh>. +times. If you need a second database handle, use C<&new_dbh>. =cut @@ -828,64 +868,6 @@ sub new_dbh 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 diff --git a/Koha/Cache.pm b/Koha/Cache.pm index 8370d3e..44b07e9 100644 --- a/Koha/Cache.pm +++ b/Koha/Cache.pm @@ -282,7 +282,7 @@ sub set_in_cache { my $set_sub = $self->{ref($self->{$cache}) . "_set"}; # Set in L1 cache - $L1_cache{ $key } = $value; + $L1_cache{ $self->{namespace} }{ $key } = $value; # We consider an expiry of 0 to be inifinite if ( $expiry ) { @@ -320,12 +320,12 @@ sub get_from_cache { return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); # Return L1 cache value if exists - if ( exists $L1_cache{$key} ) { + if ( exists $L1_cache{ $self->{namespace} }{ $key } ) { # No need to deep copy if it's a scalar # Or if we do not need to deep copy - return $L1_cache{$key} - if not ref $L1_cache{$key} or $unsafe; - return clone $L1_cache{$key}; + return $L1_cache{ $self->{namespace} }{ $key } + if not ref $L1_cache{ $self->{namespace} }{ $key } or $unsafe; + return clone $L1_cache{ $self->{namespace} }{ $key }; } my $get_sub = $self->{ref($self->{$cache}) . "_get"}; @@ -354,7 +354,7 @@ sub clear_from_cache { return unless ( $self->{$cache} && ref( $self->{$cache} ) =~ m/^Cache::/ ); # Clear from L1 cache - delete $L1_cache{$key}; + delete $L1_cache{ $self->{namespace} }{ $key }; return $self->{$cache}->delete($key) if ( ref( $self->{$cache} ) =~ m'^Cache::Memcached' ); @@ -383,7 +383,7 @@ sub flush_all { sub flush_L1_cache { my( $self ) = @_; - %L1_cache = (); + delete $L1_cache{ $self->{namespace} }; } =head1 TIED INTERFACE diff --git a/Koha/Database.pm b/Koha/Database.pm index d40eb52..959c00d 100644 --- a/Koha/Database.pm +++ b/Koha/Database.pm @@ -47,10 +47,9 @@ __PACKAGE__->mk_accessors(qw( )); # database connection from the data given in the current context, and # returns it. sub _new_schema { + my $context = shift || C4::Context->current(); - my $context = C4::Context->new(); - - my $db_driver = $context->{db_driver}; + my $db_driver = $context->db_driver; my $db_name = $context->config("database"); my $db_host = $context->config("hostname"); @@ -122,16 +121,16 @@ sub schema { return $database->{schema} if defined $database->{schema}; } - $database->{schema} = &_new_schema(); + $database->{schema} = &_new_schema($params->{context}); return $database->{schema}; } =head2 new_schema - $schema = $database->new_schema; + $schema = $database->new_schema($context); -Creates a new connection to the Koha database for the current context, -and returns the database handle (a C<DBI::db> object). +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 @@ -143,7 +142,7 @@ connect to so that the caller doesn't have to know. sub new_schema { my $self = shift; - return &_new_schema(); + return &_new_schema(@_); } =head2 set_schema @@ -200,6 +199,29 @@ sub restore_schema { # return something, then this function should, too. } +=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. diff --git a/Koha/Handler/Plack.pm b/Koha/Handler/Plack.pm new file mode 100644 index 0000000..af3f6cb --- /dev/null +++ b/Koha/Handler/Plack.pm @@ -0,0 +1,163 @@ +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; diff --git a/Koha/Handler/Plack/CGI.pm b/Koha/Handler/Plack/CGI.pm new file mode 100644 index 0000000..36c6907 --- /dev/null +++ b/Koha/Handler/Plack/CGI.pm @@ -0,0 +1,228 @@ +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; diff --git a/about.pl b/about.pl index 6b77677..a1469c1 100755 --- a/about.pl +++ b/about.pl @@ -92,7 +92,7 @@ my $warnIsRootUser = (! $loggedinuser); my $warnNoActiveCurrency = (! defined Koha::Acquisition::Currencies->get_active); my @xml_config_warnings; -my $context = new C4::Context; +my $context = C4::Context->current; if ( ! defined C4::Context->config('zebra_bib_index_mode') ) { push @xml_config_warnings, { diff --git a/admin/systempreferences.pl b/admin/systempreferences.pl index 67e0638..861508f 100755 --- a/admin/systempreferences.pl +++ b/admin/systempreferences.pl @@ -387,7 +387,7 @@ output_html_with_http_headers $input, $cookie, $template->output; # .pref files. sub get_prefs_from_files { - my $context = C4::Context->new(); + my $context = C4::Context->current(); my $path_pref_en = $context->config('intrahtdocs') . '/prog/en/modules/admin/preferences'; # Get all .pref file names diff --git a/misc/cronjobs/check-url.pl b/misc/cronjobs/check-url.pl index 71885ab..2869446 100755 --- a/misc/cronjobs/check-url.pl +++ b/misc/cronjobs/check-url.pl @@ -190,7 +190,7 @@ sub check_all_url { my $checker = C4::URL::Checker->new($timeout,$agent); $checker->{ host_default } = $host; - my $context = new C4::Context( ); + my $context = C4::Context->current(); my $dbh = $context->dbh; my $sth = $dbh->prepare( "SELECT biblionumber FROM biblioitems WHERE url <> ''" ); diff --git a/misc/plack/koha-multi.psgi b/misc/plack/koha-multi.psgi new file mode 100644 index 0000000..e897f02 --- /dev/null +++ b/misc/plack/koha-multi.psgi @@ -0,0 +1,29 @@ +#!/usr/bin/perl + +# This is a minimal example. You can include all frills from koha.psgi +# To try it: +# plackup -I /usr/share/koha/lib --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 ); diff --git a/misc/translator/LangInstaller.pm b/misc/translator/LangInstaller.pm index 5244945..1b8d63a 100644 --- a/misc/translator/LangInstaller.pm +++ b/misc/translator/LangInstaller.pm @@ -56,7 +56,7 @@ sub new { my $self = { }; - my $context = C4::Context->new(); + my $context = C4::Context->current(); $self->{context} = $context; $self->{path_pref_en} = $context->config('intrahtdocs') . '/prog/en/modules/admin/preferences'; @@ -140,7 +140,7 @@ sub new { sub po_filename { my $self = shift; - my $context = C4::Context->new; + my $context = C4::Context->current(); my $trans_path = $Bin . '/po'; my $trans_file = "$trans_path/" . $self->{lang} . "-pref.po"; return $trans_file; diff --git a/t/Koha_Handler_Plack.t b/t/Koha_Handler_Plack.t new file mode 100644 index 0000000..8172940 --- /dev/null +++ b/t/Koha_Handler_Plack.t @@ -0,0 +1,136 @@ +#!/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); + } + } + }; diff --git a/t/conf/dummy/koha-conf.xml b/t/conf/dummy/koha-conf.xml new file mode 100644 index 0000000..d4c96b0 --- /dev/null +++ b/t/conf/dummy/koha-conf.xml @@ -0,0 +1,7 @@ +<yazgfs> + <config> + <kohasite>dummy</kohasite> + <dummy>DUMMY</dummy> + <intrahtdocs>.</intrahtdocs> + </config> +</yazgfs> diff --git a/t/conf/koha1/koha-conf.xml b/t/conf/koha1/koha-conf.xml new file mode 100644 index 0000000..371d039 --- /dev/null +++ b/t/conf/koha1/koha-conf.xml @@ -0,0 +1,7 @@ +<yazgfs> + <config> + <kohasite>koha1</kohasite> + <dummy>KOHA1</dummy> + <intrahtdocs>.</intrahtdocs> + </config> +</yazgfs> diff --git a/t/conf/koha2/koha-conf.xml b/t/conf/koha2/koha-conf.xml new file mode 100644 index 0000000..437e772 --- /dev/null +++ b/t/conf/koha2/koha-conf.xml @@ -0,0 +1,5 @@ +<yazgfs> + <config> + <dummy>KOHA2</dummy> + </config> +</yazgfs> diff --git a/t/db_dependent/Amazon.t b/t/db_dependent/Amazon.t index 2304073..a5b316f 100755 --- a/t/db_dependent/Amazon.t +++ b/t/db_dependent/Amazon.t @@ -14,7 +14,7 @@ BEGIN { use_ok('C4::External::Amazon'); } -my $context = C4::Context->new(); +my $context = C4::Context->current(); my $locale = $context->preference('AmazonLocale'); diff --git a/t/db_dependent/Context.t b/t/db_dependent/Context.t index b5a050f..c3f6066 100755 --- a/t/db_dependent/Context.t +++ b/t/db_dependent/Context.t @@ -47,7 +47,7 @@ C4::Context->clear_syspref_cache(); C4::Context->enable_syspref_cache(); $dbh->rollback; -ok($koha = C4::Context->new, 'C4::Context->new'); +ok($koha = C4::Context->current, 'C4::Context->current'); my @keys = keys %$koha; my $width = 0; if (ok(@keys)) { diff --git a/t/db_dependent/Koha_template_plugin_KohaDates.t b/t/db_dependent/Koha_template_plugin_KohaDates.t index fe18836..2088347 100644 --- a/t/db_dependent/Koha_template_plugin_KohaDates.t +++ b/t/db_dependent/Koha_template_plugin_KohaDates.t @@ -14,7 +14,7 @@ BEGIN { my $module_context = new Test::MockModule('C4::Context'); my $date = "1973-05-21"; -my $context = C4::Context->new(); +my $context = C4::Context->current(); my $filter = Koha::Template::Plugin::KohaDates->new(); ok ($filter, "new()"); diff --git a/t/db_dependent/XISBN.t b/t/db_dependent/XISBN.t index 2f6d63b..45e01dd 100755 --- a/t/db_dependent/XISBN.t +++ b/t/db_dependent/XISBN.t @@ -26,7 +26,7 @@ my $search_module = new Test::MockModule('C4::Search'); $search_module->mock('SimpleSearch', \&Mock_SimpleSearch ); -my $context = C4::Context->new; +my $context = C4::Context->current; my ( $biblionumber_tag, $biblionumber_subfield ) = GetMarcFromKohaField( 'biblio.biblionumber', '' ); diff --git a/t/db_dependent/sysprefs.t b/t/db_dependent/sysprefs.t index 340e89a..07552f1 100755 --- a/t/db_dependent/sysprefs.t +++ b/t/db_dependent/sysprefs.t @@ -19,7 +19,7 @@ # along with Koha; if not, see <http://www.gnu.org/licenses>. use Modern::Perl; -use Test::More tests => 8; +use Test::More tests => 11; use C4::Context; # Start transaction @@ -60,4 +60,15 @@ is(C4::Context->preference('testpreference'), 'def', 'caching preferences'); 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; -- 2.5.0 _______________________________________________ Koha-patches mailing list Koha-patches@lists.koha-community.org http://lists.koha-community.org/cgi-bin/mailman/listinfo/koha-patches website : http://www.koha-community.org/ git : http://git.koha-community.org/ bugs : http://bugs.koha-community.org/
