cvsuser 04/02/27 06:19:25
Modified: App-Context/lib/App/Request CGI.pm
Log:
transitioning to a get_events() rather than a process() approach
Revision Changes Path
1.11 +130 -122 p5ee/App-Context/lib/App/Request/CGI.pm
Index: CGI.pm
===================================================================
RCS file: /cvs/public/p5ee/App-Context/lib/App/Request/CGI.pm,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -w -r1.10 -r1.11
--- CGI.pm 2 Feb 2004 21:24:03 -0000 1.10
+++ CGI.pm 27 Feb 2004 14:19:25 -0000 1.11
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: CGI.pm,v 1.10 2004/02/02 21:24:03 spadkins Exp $
+## $Id: CGI.pm,v 1.11 2004/02/27 14:19:25 spadkins Exp $
#############################################################################
package App::Request::CGI;
@@ -75,7 +75,7 @@
sub _init {
my ($self, $options) = @_;
- my ($cgi, $var, $value, $lang, $app, $file);
+ my ($cgi, $var, $value, $app, $file);
$options = {} if (!defined $options);
$app = $options->{app};
@@ -89,7 +89,7 @@
# read environment variables
#################################################################
- if (defined $options->{debugmode} && $options->{debugmode} eq "replay") {
+ if (defined $options->{debug_request} && $options->{debug_request} eq "replay")
{
$file = "$app.env";
if (open(App::FILE, "< $file")) {
foreach $var (keys %ENV) {
@@ -106,7 +106,7 @@
}
}
- if (defined $options->{debugmode} && $options->{debugmode} eq "record") {
+ if (defined $options->{debug_request} && $options->{debug_request} eq "record")
{
$file = "$app.env";
if (open(App::FILE, "> $file")) {
foreach $var (keys %ENV) {
@@ -116,21 +116,13 @@
}
}
- # include the environment variables in the configuration
- while (($var,$value) = each %ENV) {
- $var = lc($var); # make lower case
- if ($value ne "" && (!defined $options->{$var} || $options->{$var} eq "")) {
- $options->{$var} = $value;
- }
- }
-
#################################################################
# READ HTTP PARAMETERS (CGI VARIABLES)
#################################################################
- if (defined $options->{debugmode} && $options->{debugmode} eq "replay") {
- # when the "debugmode" is in "replay", the saved CGI environment from
- # a previous query (when "debugmode" was "record") is used
+ if (defined $options->{debug_request} && $options->{debug_request} eq "replay")
{
+ # when the "debug_request" is in "replay", the saved CGI environment from
+ # a previous query (when "debug_request" was "record") is used
$file = "$app.vars";
open(App::FILE, "< $file") || die "Unable to open $file: $!";
$cgi = new CGI(*App::FILE); # Get vars from debug file
@@ -150,8 +142,8 @@
}
}
- # when the "debugmode" is "record", save the CGI vars
- if (defined $options->{debugmode} && $options->{debugmode} eq "record") {
+ # when the "debug_request" is "record", save the CGI vars
+ if (defined $options->{debug_request} && $options->{debug_request} eq "record")
{
$file = "$app.vars";
if (open(App::FILE, "> $file")) {
$cgi->save(*App::FILE); # Save vars to debug file
@@ -163,13 +155,18 @@
# LANGUAGE
#################################################################
- # Hmmm... do I use $ENV{HTTP_ACCEPT_LANGUAGE} or
$options->{http_accept_language} ?
+ my $lang = "en_us"; # default
if (defined $ENV{HTTP_ACCEPT_LANGUAGE}) {
- $lang = $ENV{HTTP_ACCEPT_LANGUAGE};
+ $lang = lc($ENV{HTTP_ACCEPT_LANGUAGE});
$lang =~ s/ *,.*//;
$lang =~ s/-/_/g;
- # TODO: do something with the $lang ...
}
+ elsif ($options->{lang}) {
+ $lang = lc($options->{lang});
+ $lang =~ s/ *,.*//;
+ $lang =~ s/-/_/g;
+ }
+ $self->{lang} = $lang; # TODO: do something with the $lang ...
$self->{cgi} = $cgi;
}
@@ -183,22 +180,21 @@
=cut
#############################################################################
-# process()
+# get_events()
#############################################################################
-=head2 process()
+=head2 get_events()
-The process() method processes a request. i.e. It executes the events within
-a single CGI request.
+The get_events() method analyzes an HTTP request and returns the events
+within it which should be executed.
It is called primarily from the event loop handler, dispatch_events().
-However, it may be called from external software if that code manages
+However, it might also be called from external software if that code manages
the event loop itself. i.e. it instantiates the CGI object outside of
the Context and passes it in, never calling dispatch_events().
-Instead, it would call process().
- * Signature: $request->process()
- * Signature: $request->process($cgi)
+ * Signature: $request->get_events()
+ * Signature: $request->get_events($cgi)
* Param: $cgi (CGI)
* Return: void
* Throws: App::Exception
@@ -206,11 +202,11 @@
Sample Usage:
- $request->process();
+ $request->get_events();
=cut
-sub process {
+sub get_events {
my ($self, $cgi) = @_;
if (!defined $cgi) {
@@ -221,81 +217,93 @@
}
my $context = $self->{context};
- $context->dbgprint("Request::CGI->process() cgi=$cgi")
+ $context->dbgprint("Request::CGI->get_events() cgi=$cgi")
if ($App::DEBUG && $context->dbg(1));
- if (defined $cgi) {
- my $session_id = $cgi->param("session_id");
- $session_id = $context->new_session_id() if (!$session_id);
- my $session = $context->session($session_id, { cgi => $cgi });
- $context->set_current_session($session);
-
- my ($app_path_info, $curr_service, $curr_name, $curr_method, $curr_args,
$curr_returntype);
- my $options = $self->{context}->options();
-
- $curr_name = $context->so_get("default", "curr_name");
- $curr_service = $context->so_get("default", "curr_service");
- $curr_returntype = $context->so_get("default", "curr_returntype");
- # print "name=[$curr_name] service=[$curr_service]
returntype=[$curr_returntype]\n";
+ my (@events);
- if (!$curr_name) {
- if ($cgi->request_method() eq "POST") {
- $curr_service = $cgi->param("curr_service") || $options->{service}
|| "SessionObject";
- $curr_name = $cgi->param("curr_name") || $options->{name} ||
"default";
- $curr_method = $cgi->param("curr_method") || $options->{method}
|| "content";
- $curr_args = $cgi->param("curr_args") || $options->{args} ||
"";
- $curr_returntype = $cgi->param("curr_returntype") ||
$options->{returntype} || "default";
+ if (defined $cgi) {
+ my ($service, $name, $method, $args, $temp);
+ my $request_method = $cgi->request_method() || "GET";
+ if ($request_method eq "GET") {
+ # get PATH_INFO and see if an event is embedded there
+ my $path_info = $ENV{PATH_INFO};
+ $path_info =~ s!/$!!; # delete trailing "/"
+ my $options = $context->options();
+ my $app = $options->{app};
+ if ($path_info && $app && $app ne "app") {
+ # this is because App::Options uses the first leg of the PATH_INFO
+ # to set the {app} if the program name is the generic "app"
+ $path_info =~ s!/$app!!; # delete leading $app prefix
+ }
+ $path_info =~ s!:[a-zA-Z0-9_]+$!!; # delete trailing :<returntype>
+
+ if ($path_info =~ s!^/([A-Za-z0-9]+)!!) {
+ $service = $1;
+ }
+ else {
+ $service = "SessionObject";
+ }
+
+ if ($path_info =~ s!\.([a-zA-Z0-9_]+)\(([^\(\)]*)\)$!!) {
+ $method = $1;
+ $args = $2;
}
- else {
- # app_path_info = /Procedure/local.f2c(32):xml
- $app_path_info = $options->{app_path_info} || $ENV{PATH_INFO};
-
- if ($app_path_info =~ s!^/([A-Z][^/]*)!!) {
- $curr_service = $1;
+ elsif ($path_info =~ s!\.([a-zA-Z0-9_]+)$!!) {
+ $method = $1;
+ $args = "";
}
else {
- $curr_service = $options->{service} || "SessionObject";
+ $method = "";
+ $args = "";
}
- if ($app_path_info =~ s!:([a-zA-Z0-9_]+)$!!) {
- $curr_returntype = $1;
+ if ($path_info =~ m!^\.([a-zA-Z._-]+)$!) {
+ $name = $1;
}
- else {
- $curr_returntype = $cgi->param("curr_returntype") ||
$options->{returntype} || "default";
+ elsif ($path_info =~ m!^/([a-zA-Z._-]+)$!) {
+ $name = $1;
}
-
- if ($app_path_info =~ s!\.([a-zA-Z0-9_]+)\(([^\(\)]*)\)$!!) {
- $curr_method = $1;
- $curr_args = $2;
+ elsif ($path_info =~ m!^\(([a-zA-Z._-]+)\)$!) {
+ $name = $1;
}
else {
- $curr_method = $cgi->param("curr_method") ||
$options->{method} || "content";
- $curr_args = $cgi->param("curr_args") || $options->{args} ||
"";
+ $name = "default";
}
- if ($app_path_info =~ m!^/(.+)!) {
- $curr_name = $1;
+ # override PATH_INFO with CGI variables
+ $temp = $cgi->param("service");
+ $service = $temp if ($temp);
+ $temp = $cgi->param("name");
+ $name = $temp if ($temp);
+ $temp = $cgi->param("method");
+ $method = $temp if ($temp);
+ $temp = $cgi->param("args");
+ $args = $temp if ($temp);
+
+ if (defined $args) {
+ if ($args =~ /^\s*$/) {
+ $args = [];
}
else {
- $curr_name = $cgi->param("curr_name") || $options->{name} ||
$options->{app};
+ my $ser = $context->serializer("one_line", class =>
"App::Serializer::OneLine");
+ $args = $ser->deserialize($args);
}
}
- $context->so_set("default", "curr_service", $curr_service);
- $context->so_set("default", "curr_name", $curr_name);
- # $context->so_set("default", "curr_method", $curr_method);
- # $context->so_set("default", "curr_args", $curr_args);
- $context->so_set("default", "curr_returntype", $curr_returntype);
+ if ($service && $name && $method) {
+ push(@events, [ $service, $name, $method, $args ]);
+ }
}
##########################################################
# For each CGI variable, do the appropriate thing
# 1. "app.event.*" variable is an event and gets handled last
# 2. "app.*" variable is a "multi-level hash key" under $context
- # 3. "curr_name{m}[1]" variable is a "multi-level hash key" under
$context->{session_object}{$curr_name}
- # 4. "curr_name" variable is a "multi-level hash key"
+ # 3. "name{m}[1]" variable is a "multi-level hash key" under
$context->{session_object}{$name}
+ # 4. "name" variable is a "multi-level hash key"
##########################################################
- my (@eventvars, $var, @values, @tmp, $value, $mlhashkey, $name);
+ my (@eventvars, $var, @values, @tmp, $value, $mlhashkey);
@eventvars = ();
foreach $var ($cgi->param()) {
if ($var =~ /^app\.event\./) {
@@ -335,20 +343,20 @@
$value = join(",",@values);
}
- $context->dbgprint("Request::CGI->process() var=[$var]
value=[$value]")
+ $context->dbgprint("Request::CGI->get_events() var=[$var]
value=[$value]")
if ($App::DEBUG && $context->dbg(1));
if ($var =~ /[\[\]\{\}\.]/) {
$context->so_set($var, "", $value);
}
- elsif ($var eq "curr_name" || $var eq "curr_service" || $var eq
"curr_method" ||
- $var eq "curr_args" || $var eq "curr_returntype") {
+ elsif ($var eq "service" || $var eq "name" || $var eq "method" ||
+ $var eq "args" || $var eq "returntype") {
# this has already been done
# $context->so_set("default", $var, $value);
}
# Autoattribute vars: e.g. "width" (an attribute of session_object
named in request)
- elsif ($curr_name) {
- $context->so_set($curr_name, $var, $value);
+ elsif ($name) {
+ $context->so_set($name, $var, $value);
}
# Simple vars: e.g. "width" (gets dumped in the "default"
session_object)
else {
@@ -357,14 +365,14 @@
}
}
- my ($key, $fullkey, $args, $arg, @args, $event, %x, %y, $x, $y);
+ my ($key, $fullkey, $arg, @args, $event, %x, %y, $x, $y);
foreach $key (@eventvars) {
# These events come from <input type=submit> type controls
# The format is name="app.event.{session_objectName}.{event}(args)"
# Note: this format is important because the "value" is needed for
display purposes
- $context->dbgprint("Request::CGI->process() eventvar=[$key]")
+ $context->dbgprint("Request::CGI->get_events() eventvar=[$key]")
if ($App::DEBUG && $context->dbg(1));
if ($key =~ /^app\.event\./) {
@@ -415,7 +423,7 @@
$key =~ s/^app\.event\.//; # get rid of prefix
$key =~ s/\(.*//; # get rid of args
- $context->dbgprint("Request::CGI->process() key=[$key] [EMAIL
PROTECTED]")
+ $context->dbgprint("Request::CGI->get_events() key=[$key] [EMAIL
PROTECTED]")
if ($App::DEBUG && $context->dbg(1));
if ($key =~ /^([^()]+)\.([a-zA-Z0-9_-]+)$/) {
@@ -423,7 +431,7 @@
$event = $2;
if ($context->session_object_exists($name)) {
- $context->dbgprint("Request::CGI->process()
handle_event($name, $event, @args) [button]")
+ $context->dbgprint("Request::CGI->get_events()
handle_event($name, $event, @args) [button]")
if ($App::DEBUG && $context->dbg(1));
$context->session_object($name)->handle_event($name,
$event, @args);
}
@@ -431,21 +439,21 @@
my ($parent_name);
$parent_name = $name;
- $context->dbgprint("Request::CGI->process() $name doesn't
exist, trying parents...")
+ $context->dbgprint("Request::CGI->get_events() $name
doesn't exist, trying parents...")
if ($App::DEBUG && $context->dbg(1));
while ($parent_name =~ s/\.[^\.]+$//) {
if ($context->session_object_exists($parent_name)) {
- $context->dbgprint("Request::CGI->process()
handle_event($name, $event, @args) [button]")
+ $context->dbgprint("Request::CGI->get_events()
handle_event($name, $event, @args) [button]")
if ($App::DEBUG && $context->dbg(1));
$context->session_object($parent_name)->handle_event($name, $event, @args);
last;
}
- $context->dbgprint("Request::CGI->process()
$parent_name doesn't exist")
+ $context->dbgprint("Request::CGI->get_events()
$parent_name doesn't exist")
if ($App::DEBUG && $context->dbg(1));
}
}
@@ -469,7 +477,7 @@
}
@args = split(/ *, */,$args) if ($args ne "");
- $context->dbgprint("Request::CGI->process()
handle_event($name, $event, @args) [hidden/other]")
+ $context->dbgprint("Request::CGI->get_events()
handle_event($name, $event, @args) [hidden/other]")
if ($App::DEBUG && $context->dbg(1));
$context->session_object($name)->handle_event($name,
$event, @args);
@@ -478,34 +486,34 @@
}
}
- $context->dbgprint("Request->process():
$curr_service/$curr_name.$curr_method($curr_args)")
+ $context->dbgprint("Request->get_events(): $service($name).$method($args)")
if ($App::DEBUG && $context->dbg(1));
-
- if ($curr_service) {
- my $service = $context->service($curr_service, $curr_name);
- my $response = $context->response();
- if (!$service) {
- $response->content("Service not defined:
$curr_service($curr_name)\n");
}
- elsif (!$service->can($curr_method)) {
- $response->content("Method not defined on Service:
$curr_service($curr_name).$curr_method($curr_args)\n");
- }
- else {
- my @results = $service->$curr_method($curr_args);
- if ($#results == -1) {
- $response->content($service->internals());
+
+ return([EMAIL PROTECTED]);
}
- elsif ($#results == 0) {
- $response->content($results[0]);
- $response->content_type($service->content_type());
+
+sub get_returntype {
+ my ($self, $cgi) = @_;
+
+ if (!defined $cgi) {
+ $cgi = $self->{cgi};
}
- else {
- $response->content([EMAIL PROTECTED]);
+ elsif (!defined $self->{cgi}) {
+ $self->{cgi} = $cgi;
}
+ my ($returntype);
+ if ($cgi) {
+ $returntype = $cgi->param("returntype");
}
+ if (!$returntype) {
+ my $context = $self->{context};
+ my $path_info = $ENV{PATH_INFO};
+ if ($path_info =~ /:([a-zA-Z0-9_]+)$/) {
+ $returntype = $1;
}
- $context->restore_default_session();
}
+ return($returntype);
}
#############################################################################
