Author: spadkins
Date: Mon Aug 30 14:40:44 2010
New Revision: 14365
Modified:
p5ee/trunk/App-Context/lib/Apache/App.pm
p5ee/trunk/App-Context/lib/App.pm
Log:
added necessary support for mod_perl
Modified: p5ee/trunk/App-Context/lib/Apache/App.pm
==============================================================================
--- p5ee/trunk/App-Context/lib/Apache/App.pm (original)
+++ p5ee/trunk/App-Context/lib/Apache/App.pm Mon Aug 30 14:40:44 2010
@@ -1,16 +1,18 @@
-#############################################################################
+######################################################################################
## $Id: App.pm 3666 2006-03-11 20:34:10Z spadkins $
-#############################################################################
+######################################################################################
## Note: Much of this code is borrowed from Apache::DBI
## In doing so, I have made a half-hearted attempt to make this mod_perl
1.X compatible.
## However, I have never run it on mod_perl 1.X, only on mod_perl 2.X.
## When someone debugs this on mod_perl 1.X, please let me know what you
had to do to make it work.
-#############################################################################
+######################################################################################
package Apache::App;
-$VERSION = (q$Revision: 3666 $ =~ /(\d[\d\.]*)/)[0];
use strict;
+our $VERSION = (q$Revision: 3666 $ =~ /(\d[\d\.]*)/)[0];
+
+use base qw(ModPerl::RegistryCooker);
use constant MP2 => (exists $ENV{MOD_PERL_API_VERSION} &&
$ENV{MOD_PERL_API_VERSION} == 2) ? 1 : 0;
@@ -27,6 +29,7 @@
my $s = Apache2::ServerUtil->server;
$s->push_handlers(PerlChildInitHandler => \&child_init_handler);
$s->push_handlers(PerlChildExitHandler => \&child_exit_handler);
+ $s->push_handlers(PerlResponseHandler => \&request_handler);
$s->push_handlers(PerlCleanupHandler => \&request_cleanup_handler);
}
elsif (defined $modperl::VERSION && $modperl::VERSION > 1 &&
$modperl::VERSION < 1.99) {
@@ -35,33 +38,184 @@
Carp::carp("Apache.pm was not loaded\n")
and return unless $INC{'Apache.pm'};
+
if (Apache->can('push_handlers')) {
Apache->push_handlers(PerlChildInitHandler =>
\&child_init_handler);
Apache->push_handlers(PerlChildExitHandler =>
\&child_exit_handler);
+ Apache->push_handlers(PerlResponseHandler => \&request_handler);
Apache->push_handlers(PerlCleanupHandler =>
\&request_cleanup_handler);
}
}
}
use Carp ();
+use App::Options;
use App;
+##-BEGIN-OF-Apache::Registry-CODE-####################################################
+# The following section of code is lifted from ModPerl::Registry and modified.
+
+sub request_handler : method {
+ warn("$$ Apache::App::request_handler(@_)\n");
+ my $class = (@_ >= 2) ? shift : __PACKAGE__;
+ my $r = shift;
+
+ my $app_apache = $class->new($r);
+
+ my $prog = $app_apache->{FILENAME}; # (same as $r->filename())
+ $prog =~ s/\\/\//g;
+ my $prog_dir = $prog;
+ $prog_dir =~ s!/[^/]+$!!;
+ my $prog_file = $prog;
+ $prog_file =~ s!.*/!!;
+
+ my $app = App::Options->determine_app($ENV{PREFIX}, $prog_dir,
$prog_file, $r->path_info());
+ $app_apache->prepare_context($app, $app_apache->{FILENAME});
+
+ # Then we run the request and return the result (Apache2::Const::OK)
+ my $request_result = $app_apache->default_handler();
+
+ warn("$$ Apache::App app =[$app]\n");
+ warn("$$ Apache::App.REQ =[$app_apache->{REQ}]\n");
+ warn("$$ Apache::App.URI =[$app_apache->{URI}]\n");
+ warn("$$ Apache::App.FILENAME=[$app_apache->{FILENAME}]\n");
+
+ return $request_result;
+}
+
+my $parent_class = "ModPerl::RegistryCooker";
+my $self_class = __PACKAGE__;
+
+# the following code:
+# - specifies package's behavior different from default of $parent class
+# - speeds things up by shortcutting @ISA search, so even if the
+# default is used we still use the alias
+my %aliases = (
+ new => "${parent_class}::new",
+ init => "${parent_class}::init",
+ default_handler => "${parent_class}::default_handler",
+ run => "${parent_class}::run",
+ can_compile => "${parent_class}::can_compile",
+ make_namespace => "${parent_class}::make_namespace",
+ namespace_root => "${parent_class}::namespace_root",
+ namespace_from => "${parent_class}::namespace_from_filename",
+ is_cached => "${parent_class}::is_cached",
+ should_compile => "${parent_class}::should_compile_if_modified",
+ flush_namespace => "${parent_class}::NOP",
+ cache_table => "${parent_class}::cache_table_common",
+ cache_it => "${parent_class}::cache_it",
+ read_script => "${parent_class}::read_script",
+ shebang_to_perl => "${parent_class}::shebang_to_perl",
+ get_script_name => "${parent_class}::get_script_name",
+ chdir_file => "${parent_class}::NOP",
+ get_mark_line => "${parent_class}::get_mark_line",
+ compile => "${parent_class}::compile",
+ error_check => "${parent_class}::error_check",
+ strip_end_data_segment =>
"${parent_class}::strip_end_data_segment",
+ convert_script_to_compiled_handler =>
"${parent_class}::convert_script_to_compiled_handler",
+);
+
+$self_class->install_aliases(\%aliases);
+
+##-END-OF-Apache::Registry-CODE-######################################################
+
+######################################################################################
+# Variables
+######################################################################################
+
my (@service_on_init); # services to be initialized when a new
httpd child is created
-my %env = %ENV;
-my ($context);
+#my %env = %ENV;
+my (%options, %context);
+
+######################################################################################
+# This is supposed to be called in a startup script or in httpd.conf (<Perl>
section).
+######################################################################################
+
+sub import {
+ # save global values initialized up until now
+ App->context() if (!$App::context);
+ Apache::App->save_context("main");
+}
-#############################################################################
-# This is supposed to be called in a startup script.
-# stores the data_source of all connections, which are supposed to be created
-# upon server startup, and creates a PerlChildInitHandler, which initiates
-# the connections. Provide a handler which creates all connections during
-# server startup
-#############################################################################
+sub save_context {
+ my ($self, $app) = @_;
+ $options{$app} = { %App::options };
+ $context{$app} = $App::context;
+}
+
+sub restore_context {
+ my ($self, $app) = @_;
+
+ if ($options{$app}) {
+ %App::options = %{$options{$app}};
+ }
+ else {
+ %App::options = ();
+ }
+
+ if ($context{$app}) {
+ $App::context = $context{$app};
+ }
+ else {
+ $App::context = undef;
+ }
+}
+
+sub clear_context {
+ my ($self) = @_;
+ %App::options = ();
+ $App::context = undef;
+}
+
+#sub determine_app_from_request {
+# my ($self, $r) = @_;
+#}
+
+######################################################################################
+# This is supposed to be called in a startup script or in httpd.conf (<Perl>
section).
+######################################################################################
+
+sub prepare_context {
+ warn("$$ Apache::App::prepare_context(@_)\n");
+ my ($self, $app, $program) = @_;
+ if (!$context{$app} || !$options{$app}) {
+ $self->clear_context() if ($context{$app} || $options{$app});
+ my $prefix = $ENV{PREFIX} || $options{main}{prefix} ||
"/usr/local/app";
+ %App::options = (
+ app => $app,
+ prefix => $prefix,
+ context_class => "App::Context::ModPerl",
+ );
+ my $option_processor = App::Options->new({
+ init_args => {
+ no_cmd_args => 1,
+ no_env_vars => 1,
+ option => {
+ session_class => { default => "App::Session::HTMLHidden",
},
+ request_class => { default => "App::Request::CGI", },
+ },
+ },
+ });
+ local($0) = $program;
+ $option_processor->read_options(\%App::options);
+ my $context = App->context();
+ $self->save_context($app);
+ }
+ elsif ($context{$app} ne $App::context) {
+ $self->restore_context($app);
+ }
+}
+
+######################################################################################
+# Upon child server startup (PerlChildInitHandler), services should be
initialized
+# which may include repositories and hence possible connections to databases.
+######################################################################################
sub init_service_on_child_init {
- my (@args) = @_;
- shift(@args); # get rid of class name
- push(@service_on_init, [...@args]);
+ warn("$$ Apache::App::init_service_on_child_init(@_)\n");
+ my ($self, $app, @args) = @_;
+ push(@service_on_init, [$app, @args]);
+ warn("$$ Apache::App::init_service_on_child_init() : \$#service_on_init =
[$#service_on_init]\n");
}
######################################################################################
@@ -72,16 +226,21 @@
sub child_init_handler {
my ($child_pool, $s) = @_;
- warn("$$ Apache::App child_init\n");
+ warn("$$ Apache::App::child_init_handler(@_) : \$#service_on_init =
[$#service_on_init]\n");
- #my $context = App->context();
- #if (@service_on_init) {
- # for my $service_init_args (@service_on_init) {
- # $context->service(@$service_init_args);
- # }
- #}
+ my ($app, $service);
+ if ($#service_on_init > -1) {
+ foreach my $service_init_args (@service_on_init) {
+ warn("$$ Apache::App::child_init_handler() :
service_init_arg...@$service_init_args]\n");
+ $app = shift(@$service_init_args);
+ warn("$$ Apache::App::child_init_handler() :
context($app).service(@$service_init_args)\n");
+ App::Apache->prepare_context($app);
+ $service = $App::context->service(@$service_init_args);
+ warn("$$ Apache::App::child_init_handler() :
context($app).service(@$service_init_args) = [$service]\n");
+ }
+ }
- return 1; # (MP2 ? Apache2::Const::OK : Apache::OK);
+ return 1;
}
######################################################################################
@@ -90,8 +249,8 @@
sub child_exit_handler {
my ($child_pool, $s) = @_;
- warn("$$ Apache::App child_exit\n");
- return 1; # (MP2 ? Apache2::Const::OK : Apache::OK);
+ warn("$$ Apache::App::child_exit_handler(@_)\n");
+ return 1;
}
######################################################################################
@@ -99,7 +258,7 @@
######################################################################################
sub request_cleanup_handler {
- warn("$$ Apache::App request_cleanup\n");
+ warn("$$ Apache::App::request_cleanup_handler(@_)\n");
# my $Idx = shift;
#
# my $prefix = "$$ Apache::DBI ";
@@ -123,134 +282,134 @@
# Response Handler
######################################################################################
-sub handler {
- my $r = shift;
-
- if ($ENV{PATH_INFO} eq "/_info") {
- &info($r);
- return;
- }
-
- my ($msg, $response);
-
- # INITIALIZE THE CONTEXT THE FIRST TIME THIS APACHE CHILD PROCESS
- # RECEIVES A REQUEST (should I do this sooner? at child init?)
- # (so that the first request does not need to bear the extra burden)
-
- # Also, the App class would cache the $context for me
- # if I didn't want to cache it myself. But then I would have to
- # prepare the %options every request. hmmm...
- # I don't suppose the $r->dir_config() call is expensive.
-
- if (!defined $context) {
- my %options = %{$r->dir_config()};
- $options{context_class} = "App::Context::ModPerl" if (!defined
$options{context_class});
- eval {
- $context = App->context(\%options);
- };
- $msg = $@ if ($@);
- }
-
- if ($ENV{PATH_INFO} eq "/_context") {
- my $header = <<EOF;
-Content-type: text/plain
-
-App::Context::ModPerl - Context
-
-EOF
- $r->print($header);
- $r->print($context->dump());
- return;
- }
- elsif ($ENV{PATH_INFO} eq "/_session") {
- my $header = <<EOF;
-Content-type: text/plain
-
-App::Context::ModPerl - Session
-
-EOF
- $r->print($header);
- $r->print($context->{session}->dump());
- return;
- }
- elsif ($ENV{PATH_INFO} eq "/_conf") {
- my $header = <<EOF;
-Content-type: text/plain
-
-App::Context::ModPerl - Conf
-
-EOF
- $r->print($header);
- $r->print($context->{conf}->dump());
- return;
- }
- elsif ($ENV{PATH_INFO} eq "/_options") {
- my $header = <<EOF;
-Content-type: text/plain
-
-App::Context::ModPerl - Options
-
-EOF
- $r->print($header);
- my $options = $context->{options} || {};
- foreach my $key (sort keys %$options) {
- $r->print("$key = $options->{$key}\n");
- }
- return;
- }
-
- # this should always be true
- if (defined $context) {
- # the response will be emitted from within dispatch_events()
- $context->dispatch_events();
- }
- else {
- # we had an error (maybe App-Context not installed? Perl @INC not set?)
- $response = <<EOF;
-Content-type: text/plain
-
-Unable to create an App::Context.
-$msg
-
-EOF
- $r->print($response);
- }
-}
+#sub handler {
+# my $r = shift;
+#
+# if ($ENV{PATH_INFO} eq "/_info") {
+# &info($r);
+# return;
+# }
+#
+# my ($msg, $response);
+#
+# # INITIALIZE THE CONTEXT THE FIRST TIME THIS APACHE CHILD PROCESS
+# # RECEIVES A REQUEST (should I do this sooner? at child init?)
+# # (so that the first request does not need to bear the extra burden)
+#
+# # Also, the App class would cache the $context for me
+# # if I didn't want to cache it myself. But then I would have to
+# # prepare the %options every request. hmmm...
+# # I don't suppose the $r->dir_config() call is expensive.
+#
+# if (!defined $context) {
+# my %options = %{$r->dir_config()};
+# $options{context_class} = "App::Context::ModPerl" if (!defined
$options{context_class});
+# eval {
+# $context = App->context(\%options);
+# };
+# $msg = $@ if ($@);
+# }
+#
+# if ($ENV{PATH_INFO} eq "/_context") {
+# my $header = <<EOF;
+#Content-type: text/plain
+#
+#App::Context::ModPerl - Context
+#
+#EOF
+# $r->print($header);
+# $r->print($context->dump());
+# return;
+# }
+# elsif ($ENV{PATH_INFO} eq "/_session") {
+# my $header = <<EOF;
+#Content-type: text/plain
+#
+#App::Context::ModPerl - Session
+#
+#EOF
+# $r->print($header);
+# $r->print($context->{session}->dump());
+# return;
+# }
+# elsif ($ENV{PATH_INFO} eq "/_conf") {
+# my $header = <<EOF;
+#Content-type: text/plain
+#
+#App::Context::ModPerl - Conf
+#
+#EOF
+# $r->print($header);
+# $r->print($context->{conf}->dump());
+# return;
+# }
+# elsif ($ENV{PATH_INFO} eq "/_options") {
+# my $header = <<EOF;
+#Content-type: text/plain
+#
+#App::Context::ModPerl - Options
+#
+#EOF
+# $r->print($header);
+# my $options = $context->{options} || {};
+# foreach my $key (sort keys %$options) {
+# $r->print("$key = $options->{$key}\n");
+# }
+# return;
+# }
+#
+# # this should always be true
+# if (defined $context) {
+# # the response will be emitted from within dispatch_events()
+# $context->dispatch_events();
+# }
+# else {
+# # we had an error (maybe App-Context not installed? Perl @INC not
set?)
+# $response = <<EOF;
+#Content-type: text/plain
+#
+#Unable to create an App::Context.
+#$msg
+#
+#EOF
+# $r->print($response);
+# }
+#}
######################################################################################
# Special URL-driven Responses
######################################################################################
-sub info {
- my $r = shift;
- my $header = <<EOF;
-Content-type: text/plain
-
-Welcome to Apache::App
-
-EOF
- $r->print($header);
- print $r->as_string();
- $r->print("\n");
- $r->print("ENVIRONMENT VARIABLES\n");
- $r->print("\n");
- foreach my $var (sort keys %ENV) {
- $r->print("$var=$ENV{$var}\n");
- }
- $r->print("\n");
- $r->print("ENVIRONMENT VARIABLES (at startup)\n");
- $r->print("\n");
- foreach my $var (sort keys %env) {
- $r->print("$var=$env{$var}\n");
- }
- $r->print("\n");
- $r->print("DIRECTORY CONFIG\n");
- $r->print("\n");
- my %options = %{$r->dir_config()};
- foreach my $var (sort keys %options) {
- $r->print("$var=$options{$var}\n");
- }
-}
+#sub info {
+# my $r = shift;
+# my $header = <<EOF;
+#Content-type: text/plain
+#
+#Welcome to Apache::App
+#
+#EOF
+# $r->print($header);
+# print $r->as_string();
+# $r->print("\n");
+# $r->print("ENVIRONMENT VARIABLES\n");
+# $r->print("\n");
+# foreach my $var (sort keys %ENV) {
+# $r->print("$var=$ENV{$var}\n");
+# }
+# $r->print("\n");
+# $r->print("ENVIRONMENT VARIABLES (at startup)\n");
+# $r->print("\n");
+# foreach my $var (sort keys %env) {
+# $r->print("$var=$env{$var}\n");
+# }
+# $r->print("\n");
+# $r->print("DIRECTORY CONFIG\n");
+# $r->print("\n");
+# my %options = %{$r->dir_config()};
+# foreach my $var (sort keys %options) {
+# $r->print("$var=$options{$var}\n");
+# }
+#}
# prepare menu item for Apache::Status
#sub status_function {
Modified: p5ee/trunk/App-Context/lib/App.pm
==============================================================================
--- p5ee/trunk/App-Context/lib/App.pm (original)
+++ p5ee/trunk/App-Context/lib/App.pm Mon Aug 30 14:40:44 2010
@@ -633,8 +633,8 @@
=cut
-my (%context); # usually a singleton per process (under "default" name)
- # multiple named contexts are allowed for debugging purposes
+our (%options); # the default global location for conf options (%App::options)
+our ($context); # a singleton per process (for exception see Apache::App)
sub context {
&App::sub_entry if ($App::trace);
@@ -660,7 +660,7 @@
$name = "default" if (!$name); # use "default" as name
}
- if (!defined $context{$name}) {
+ if (!defined $context) {
if (! $options->{context_class}) {
if (defined $ENV{APP_CONTEXT_CLASS}) { # env variable set?
@@ -685,19 +685,20 @@
}
# instantiate Context and cache it (it's reference) for future use
- $context{$name} = $self->new($options->{context_class}, "new",
$options);
+ $context = $self->new($options->{context_class}, "new", $options);
}
- &App::sub_exit($context{$name}) if ($App::trace);
- return($context{$name});
+ &App::sub_exit($context) if ($App::trace);
+ return($context);
}
sub shutdown {
&App::sub_entry if ($App::trace);
- my ($self, $name) = @_;
- $name = "default" if (!defined $name);
- $context{$name}->shutdown() if (defined $context{$name});
- delete $context{$name};
+ my ($self) = @_;
+ if ($context) {
+ $context->shutdown();
+ $context = undef;
+ }
&App::sub_exit() if ($App::trace);
}
