Author: spadkins
Date: Tue Apr 6 06:36:42 2010
New Revision: 13887
Added:
p5ee/trunk/App-Context/lib/App/Context/ModPerl.pm
Modified:
p5ee/trunk/App-Context/lib/Apache/App.pm
p5ee/trunk/App-Context/lib/App.pm
p5ee/trunk/App-Context/lib/App/Context/HTTP.pm
p5ee/trunk/App-Context/lib/App/Session/HTMLHidden.pm
Log:
Early development snapshot for mod_perl support. Not tested well for backward
compatibility.
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 Tue Apr 6 06:36:42 2010
@@ -2,15 +2,126 @@
#############################################################################
## $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]; # VERSION numbers
generated by svn
+$VERSION = (q$Revision: 3666 $ =~ /(\d[\d\.]*)/)[0];
+use strict;
+
+use constant MP2 => (exists $ENV{MOD_PERL_API_VERSION} &&
+ $ENV{MOD_PERL_API_VERSION} == 2) ? 1 : 0;
+
+BEGIN {
+ if (MP2) {
+ require mod_perl2;
+ require Apache2::Module;
+ require Apache2::RequestUtil;
+ require Apache2::ServerUtil;
+ require Apache2::Const;
+ require Apache::DBI;
+
+ my $s = Apache2::ServerUtil->server;
+ $s->push_handlers(PerlChildInitHandler => \&child_init_handler);
+ $s->push_handlers(PerlChildExitHandler => \&child_exit_handler);
+ $s->push_handlers(PerlCleanupHandler => \&request_cleanup_handler);
+ }
+ elsif (defined $modperl::VERSION && $modperl::VERSION > 1 &&
$modperl::VERSION < 1.99) {
+ require Apache;
+ require Apache::DBI;
+
+ 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(PerlCleanupHandler =>
\&request_cleanup_handler);
+ }
+ }
+}
-use Apache ();
+use Carp ();
use App;
+my (@service_on_init); # services to be initialized when a new
httpd child is created
my %env = %ENV;
-my $context;
+my ($context);
+
+#############################################################################
+# 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 init_service_on_child_init {
+ my (@args) = @_;
+ shift(@args); # get rid of class name
+ push(@service_on_init, [...@args]);
+}
+
+######################################################################################
+# PerlChildInitHandler : runs during child server startup.
+######################################################################################
+# Note: this handler runs in every child server, but not in the main server.
+######################################################################################
+
+sub child_init_handler {
+ my ($child_pool, $s) = @_;
+ warn("$$ Apache::App child_init\n");
+
+ #my $context = App->context();
+ #if (@service_on_init) {
+ # for my $service_init_args (@service_on_init) {
+ # $context->service(@$service_init_args);
+ # }
+ #}
+
+ return 1; # (MP2 ? Apache2::Const::OK : Apache::OK);
+}
+
+######################################################################################
+# PerlChildExitHandler : runs during child server shutdown.
+######################################################################################
+
+sub child_exit_handler {
+ my ($child_pool, $s) = @_;
+ warn("$$ Apache::App child_exit\n");
+ return 1; # (MP2 ? Apache2::Const::OK : Apache::OK);
+}
+
+######################################################################################
+# PerlCleanupHandler : runs after the response has been sent to the client
+######################################################################################
+
+sub request_cleanup_handler {
+ warn("$$ Apache::App request_cleanup\n");
+# my $Idx = shift;
+#
+# my $prefix = "$$ Apache::DBI ";
+# debug(2, "$prefix PerlCleanupHandler");
+#
+# my $dbh = $Connected{$Idx};
+# if ($Rollback{$Idx}
+# and $dbh
+# and $dbh->{Active}
+# and !$dbh->{AutoCommit}
+# and eval {$dbh->rollback}) {
+# debug (2, "$prefix PerlCleanupHandler rollback for '$Idx'");
+# }
+#
+# delete $Rollback{$Idx};
+#
+ 1;
+}
+
+######################################################################################
+# Response Handler
+######################################################################################
sub handler {
my $r = shift;
@@ -82,7 +193,7 @@
EOF
$r->print($header);
my $options = $context->{options} || {};
- foreach (sort keys %$options) {
+ foreach my $key (sort keys %$options) {
$r->print("$key = $options->{$key}\n");
}
return;
@@ -106,6 +217,10 @@
}
}
+######################################################################################
+# Special URL-driven Responses
+######################################################################################
+
sub info {
my $r = shift;
my $header = <<EOF;
@@ -137,5 +252,39 @@
}
}
+# prepare menu item for Apache::Status
+#sub status_function {
+# my($r, $q) = @_;
+#
+# my(@s) = qw(<TABLE><TR><TD>Datasource</TD><TD>Username</TD></TR>);
+# for (1 .. 5) {
+# push @s, '<TR><TD>',
+# join('</TD><TD>',
+# ($_, "tbd"), "</TD></TR>\n";
+# }
+# push @s, '</TABLE>';
+#
+# \...@s;
+#}
+
+#if (MP2) {
+# if (Apache2::Module::loaded('Apache2::Status')) {
+# Apache2::Status->menu_item(
+# 'DBI' => 'DBI connections',
+# \&status_function
+# );
+# }
+#}
+#else {
+# if ($INC{'Apache.pm'} # is Apache.pm loaded?
+# and Apache->can('module') # really?
+# and Apache->module('Apache::Status')) { # Apache::Status too?
+# Apache::Status->menu_item(
+# 'DBI' => 'DBI connections',
+# \&status_function
+# );
+# }
+#}
+
1;
Modified: p5ee/trunk/App-Context/lib/App.pm
==============================================================================
--- p5ee/trunk/App-Context/lib/App.pm (original)
+++ p5ee/trunk/App-Context/lib/App.pm Tue Apr 6 06:36:42 2010
@@ -667,8 +667,7 @@
$options->{context_class} = $ENV{APP_CONTEXT_CLASS};
}
else { # try autodetection ...
- my $gateway = $ENV{GATEWAY_INTERFACE};
- if (defined $gateway && $gateway =~ /CGI-Perl/) { # mod_perl?
+ if ($ENV{MOD_PERL}) {
$options->{context_class} = "App::Context::ModPerl";
}
elsif ($ENV{HTTP_USER_AGENT}) { # running as CGI script?
Modified: p5ee/trunk/App-Context/lib/App/Context/HTTP.pm
==============================================================================
--- p5ee/trunk/App-Context/lib/App/Context/HTTP.pm (original)
+++ p5ee/trunk/App-Context/lib/App/Context/HTTP.pm Tue Apr 6 06:36:42 2010
@@ -311,7 +311,7 @@
if (!$request_class) {
my $gateway = $ENV{GATEWAY_INTERFACE};
# TODO: need to distinguish between PerlRun, Registry, libapreq,
other
- if (defined $gateway && $gateway =~ /CGI-Perl/) { # mod_perl?
+ if ($ENV{MOD_PERL}) { # mod_perl: Registry
$request_class = "App::Request::CGI";
}
elsif ($ENV{HTTP_USER_AGENT}) { # running as CGI script?
@@ -325,10 +325,7 @@
eval {
$self->{request} = App->new($request_class, "new", $self,
$self->{options});
};
- if ($@) {
- $self->add_message("Context::HTTP::request(): $@");
- print STDERR "request=$self->{request} err...@]\n";
- }
+ # ignore the failure to find a request. no request is currently
available. method will return undef.
}
&App::sub_exit($self->{request}) if ($App::trace);
Added: p5ee/trunk/App-Context/lib/App/Context/ModPerl.pm
==============================================================================
--- (empty file)
+++ p5ee/trunk/App-Context/lib/App/Context/ModPerl.pm Tue Apr 6 06:36:42 2010
@@ -0,0 +1,278 @@
+
+#############################################################################
+## $Id: ModPerl.pm 13649 2009-12-07 21:02:32Z spadkins $
+#############################################################################
+
+package App::Context::ModPerl;
+$VERSION = (q$Revision: 13649 $ =~ /(\d[\d\.]*)/)[0]; # VERSION numbers
generated by svn
+
+use App;
+use App::Context::HTTP;
+
+...@isa = ( "App::Context::HTTP" );
+
+#use App::UserAgent;
+#use Time::HiRes qw(gettimeofday tv_interval);
+#use Date::Format;
+
+use strict;
+
+=head1 NAME
+
+App::Context::ModPerl - context in which we are currently running
+
+=head1 SYNOPSIS
+
+ # ... official way to get a Context object ...
+ use App;
+ $context = App->context();
+ $config = $context->config(); # get the configuration
+ $config->dispatch_events(); # dispatch events
+
+ # ... alternative way (used internally) ...
+ use App::Context::ModPerl;
+ $context = App::Context::ModPerl->new();
+
+=cut
+
+#############################################################################
+# DESCRIPTION
+#############################################################################
+
+=head1 DESCRIPTION
+
+A Context class models the environment (aka "context)
+in which the current process is running.
+For the App::Context::ModPerl class, this models the
+web application runtime environments which is mod_perl (perl embedded in the
Apache server).
+It gets events from HTTP user agents via the HTTP protocol
+and produces (mostly) HTML pages as output.
+
+=cut
+
+#############################################################################
+# PROTECTED METHODS
+#############################################################################
+
+=head1 Protected Methods:
+
+The following methods are intended to be called by subclasses of the
+current class.
+
+=cut
+
+#############################################################################
+# _init()
+#############################################################################
+
+#=head2 _init()
+#
+#The _init() method is called from within the standard Context constructor.
+#
+#The _init() method sets debug flags.
+#
+# * Signature: $context->_init($args)
+# * Param: $args hash{string} [in]
+# * Return: void
+# * Throws: App::Exception
+# * Since: 0.01
+#
+# Sample Usage:
+#
+# $context->_init($args);
+#
+#=cut
+#
+#sub _init {
+# &App::sub_entry if ($App::trace);
+# my ($self, $args) = @_;
+# $args = {} if (!defined $args);
+#
+# eval {
+# $self->{user_agent} = App::UserAgent->new($self);
+# };
+# $self->add_message("Context::HTTP::_init(): $@") if ($@);
+#
+# &App::sub_exit() if ($App::trace);
+#}
+
+#############################################################################
+# PROTECTED METHODS
+#############################################################################
+
+=head1 Protected Methods
+
+These methods are considered protected because no class is ever supposed
+to call them. They may however be called by the context-specific drivers.
+
+=cut
+
+sub dispatch_events {
+ &App::sub_entry if ($App::trace);
+ my ($self) = @_;
+ # do nothing
+ &App::sub_exit() if ($App::trace);
+}
+
+sub dispatch_events_from_request_begin {
+ &App::sub_entry if ($App::trace);
+ my ($self) = @_;
+ my $events = $self->{events};
+ my $request = $self->request();
+
+ my $session_id = $request->get_session_id();
+ my $session = $self->session($session_id);
+ $self->set_current_session($session);
+
+ my $request_events = $request->get_events();
+ if ($request_events && $#$request_events > -1) {
+ push(@$events, @$request_events);
+ }
+ $self->init_profiler_log();
+
+ &App::sub_exit() if ($App::trace);
+}
+
+sub dispatch_events_from_request {
+ &App::sub_entry if ($App::trace);
+ my ($self) = @_;
+
+ my ($content_length);
+ my $content_description = "Unknown";
+
+ $self->dispatch_events_from_request_begin();
+ my $events = $self->{events};
+
+ my $options = $self->{options};
+ my $app = $options->{app} || "app";
+ my $profiler = $options->{"app.Context.profiler"};
+ my ($app_scope, $app_scope_id_type, $app_scope_id, $content_name);
+
+ eval {
+ my $user = $self->user();
+ my $authorization = $self->authorization();
+ my ($event, $service_type, $service_name, $method, $args,
$return_results, $return_event_results, $event_results);
+ my $results = "";
+ # my $display_current_widget = 1;
+
+ if ($#$events > -1) {
+ if ($profiler) {
+ $self->profile_start("event");
+ }
+ while ($#$events > -1) {
+ $event = shift(@$events);
+ ($service_type, $service_name, $method, $args,
$return_event_results) = @$event;
+ if
($authorization->is_authorized("/App/$service_type/$service_name/$method",
$user)) {
+ $event_results = $self->call($service_type, $service_name,
$method, $args);
+ if ($return_event_results) {
+ $results = $event_results;
+ $return_results = 1;
+ }
+ $user = $self->user();
+ }
+ }
+ if ($profiler) {
+ my $args_str = (ref($args) eq "ARRAY") ? join(",", @$args) :
$args;
+ $app_scope =
"$service_type($service_name).$method($args_str)";
+ $self->profile_stop("event");
+ }
+ }
+ $service_type = $self->so_get("default","ctype","SessionObject");
+ $service_name = $self->so_get("default","cname");
+
+ if ($authorization->is_authorized("/App/$service_type/$service_name",
$user)) {
+ # do nothing
+ }
+ else {
+ if ($self->session_object_exists("login_${app}")) {
+ $service_name = "login_${app}";
+ }
+ else {
+ $service_name = "login";
+ }
+ }
+
+ $results = $self->service($service_type, $service_name) if
(!$return_results);
+
+ my $response = $self->response();
+ my $ref = ref($results);
+ if (!$ref || $ref eq "ARRAY" || $ref eq "HASH") {
+ $app_scope = "results [$ref]";
+ if ($profiler) {
+ $self->update_profiler_log($app_scope, $service_name,
$app_scope_id_type, $app_scope_id);
+ }
+ $response->content($results);
+ }
+ elsif ($results->isa("App::Service")) {
+ ($app_scope, $app_scope_id_type, $app_scope_id, $content_name) =
$results->content_description();
+ $content_name ||= $service_name;
+ if ($profiler) {
+ $self->update_profiler_log($app_scope, $content_name,
$app_scope_id_type, $app_scope_id);
+ }
+ $response->content($results->content());
+ $response->content_type($results->content_type());
+ }
+ else {
+ $app_scope = "$service_type($service_name).internals()";
+ if ($profiler) {
+ $self->update_profiler_log($app_scope, $service_name,
$app_scope_id_type, $app_scope_id);
+ }
+ $response->content($results->internals());
+ }
+
+ if ($profiler) {
+ $self->profile_start("xfer", 1);
+ }
+ $content_length = $self->send_response();
+
+ if ($profiler) {
+ $self->{profile_state}{app_scope} = $app_scope;
+ $self->{profile_state}{content_length} = $content_length;
+ }
+ };
+ if ($@) {
+ $content_length = $self->send_error($@);
+ if ($profiler) {
+ $self->{profile_state}{app_scope} = "ERROR [$app_scope]: $@";
+ $self->{profile_state}{content_length} = $content_length;
+ }
+ }
+
+ if ($self->{options}{debug_context}) {
+ print STDERR $self->dump();
+ }
+
+ $self->dispatch_events_from_request_finish();
+ &App::sub_exit() if ($App::trace);
+}
+
+sub dispatch_events_from_request_finish {
+ &App::sub_entry if ($App::trace);
+ my ($self) = @_;
+ $self->restore_default_session();
+ $self->shutdown(); # assume we won't be doing anything else (this can be
overridden)
+ &App::sub_exit() if ($App::trace);
+}
+
+#############################################################################
+# request()
+#############################################################################
+
+=head2 request()
+
+ * Signature: $context->request()
+ * Param: void
+ * Return: void
+ * Throws: App::Exception
+ * Since: 0.01
+
+ Sample Usage:
+
+ $context->request();
+
+The request() method gets the current Request being handled in the Context.
+
+=cut
+
+1;
+
Modified: p5ee/trunk/App-Context/lib/App/Session/HTMLHidden.pm
==============================================================================
--- p5ee/trunk/App-Context/lib/App/Session/HTMLHidden.pm (original)
+++ p5ee/trunk/App-Context/lib/App/Session/HTMLHidden.pm Tue Apr 6
06:36:42 2010
@@ -261,12 +261,20 @@
sub _init {
&App::sub_entry if ($App::trace);
my ($self, $args) = @_;
- my ($cgi, $sessiontext, $store);
+ my ($cgi, $sessiontext, $store, $request);
$self->{context} = $args->{context};
$store = {};
$cgi = $args->{cgi} if (defined $args);
- $cgi = $self->{context}->request()->{cgi} if (!defined $cgi);
+
+ eval {
+ $request = $self->{context}->request();
+ };
+ # ignore it if it fails
+
+ if (!defined $cgi) {
+ $cgi = $request->{cgi} if ($request);
+ }
if (defined $cgi) {
$sessiontext = $cgi->param("app.sessiondata");
@@ -283,32 +291,34 @@
}
}
- my $options = $self->{context}{options};
- my $cookie_attribs = $options->{"app.Session.cookie_attribs"};
- if ($cookie_attribs) {
- my $cookiedata = {};
-
- my $app = $options->{"app"};
- my $cookietext = $cgi->cookie("app_session_${app}_persist");
- if ($cookietext) {
- $cookietext =~ s/ /\+/g;
- my $length = length($cookietext);
- my $pad = 4 - ($length % 4);
- $pad = 0 if ($pad == 4);
- $cookietext .= ("=" x $pad) if ($pad);
- $cookietext =~ s/(.{76})/$1\n/g;
- $cookietext .= "\n";
-#print "Session::Cookie->_init(): sessiontext = [\n$sessiontext\n]\n";
- $cookiedata =
thaw(Compress::Zlib::memGunzip(MIME::Base64::decode($cookietext)));
- }
-
- foreach my $cookie_attrib (split(/[ ,;]+/, $cookie_attribs)) {
- if ($cookie_attrib =~ /^([^-]+)-(.+)$/) {
- $store->{SessionObject}{$1}{$2} = $cookiedata->{$1}{$2};
+ if ($request) {
+ my $options = $self->{context}{options};
+ my $cookie_attribs = $options->{"app.Session.cookie_attribs"};
+ if ($cookie_attribs) {
+ my $cookiedata = {};
+
+ my $app = $options->{"app"};
+ my $cookietext = $cgi->cookie("app_session_${app}_persist");
+ if ($cookietext) {
+ $cookietext =~ s/ /\+/g;
+ my $length = length($cookietext);
+ my $pad = 4 - ($length % 4);
+ $pad = 0 if ($pad == 4);
+ $cookietext .= ("=" x $pad) if ($pad);
+ $cookietext =~ s/(.{76})/$1\n/g;
+ $cookietext .= "\n";
+ #print "Session::Cookie->_init(): sessiontext =
[\n$sessiontext\n]\n";
+ $cookiedata =
thaw(Compress::Zlib::memGunzip(MIME::Base64::decode($cookietext)));
}
- elsif ($cookie_attrib) {
- $store->{SessionObject}{default}{$cookie_attrib} =
- $cookiedata->{default}{$cookie_attrib};
+
+ foreach my $cookie_attrib (split(/[ ,;]+/, $cookie_attribs)) {
+ if ($cookie_attrib =~ /^([^-]+)-(.+)$/) {
+ $store->{SessionObject}{$1}{$2} = $cookiedata->{$1}{$2};
+ }
+ elsif ($cookie_attrib) {
+ $store->{SessionObject}{default}{$cookie_attrib} =
+ $cookiedata->{default}{$cookie_attrib};
+ }
}
}
}
