cvs commit: p5ee/App-Context/lib/App/Session HTMLHidden.pm
[email protected] (Stephen Adkins)
| Newsgroups | perl.cvs.p5ee |
|---|---|
| Message-ID | <[email protected]> |
cvsuser 04/09/02 13:56:51
Modified: App-Context/lib/App Context.pm Request.pm Response.pm
Session.pm SessionObject.pm UserAgent.pm
App-Context/lib/App/Context HTTP.pm NetServer.pm
SimpleServer.pm
App-Context/lib/App/Request CGI.pm
App-Context/lib/App/Session HTMLHidden.pm
Log:
revamped
Revision Changes Path
1.16 +161 -97 p5ee/App-Context/lib/App/Context.pm
Index: Context.pm
===================================================================
RCS file: /cvs/public/p5ee/App-Context/lib/App/Context.pm,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -w -r1.15 -r1.16
--- Context.pm 27 Feb 2004 14:24:06 -0000 1.15
+++ Context.pm 2 Sep 2004 20:56:51 -0000 1.16
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: Context.pm,v 1.15 2004/02/27 14:24:06 spadkins Exp $
+## $Id: Context.pm,v 1.16 2004/09/02 20:56:51 spadkins Exp $
#############################################################################
package App::Context;
@@ -236,10 +236,17 @@
$self->dbgprint(join("",@str));
}
+ my $conf = {};
eval {
- $self->{conf} = App->new($conf_class, "new", \%options);
+ $conf = App->new($conf_class, "new", \%options);
+ foreach my $var (keys %options) {
+ if ($var =~ /^app\.(.+)/) {
+ $conf->set($1, $options{$var});
+ }
+ }
};
$self->add_message($@) if ($@);
+ $self->{conf} = $conf;
if ($options{debug_conf} >= 2) {
$self->dbgprint($self->{conf}->dump());
@@ -257,6 +264,8 @@
}
sub _default_session_class {
+ &App::sub_entry if ($App::trace);
+ &App::sub_exit("App::Session") if ($App::trace);
return("App::Session");
}
@@ -295,7 +304,9 @@
=cut
sub _init {
+ &App::sub_entry if ($App::trace);
my ($self, $options) = @_;
+ &App::sub_exit() if ($App::trace);
}
#############################################################################
@@ -404,7 +415,7 @@
$self->dbgprint("Context->service(" . join(", ",@_) . ")")
if ($App::DEBUG && $self->dbg(3));
- my ($args, $new_service, $override, $volatile, $attrib);
+ my ($args, $new_service, $override, $lightweight, $attrib);
my ($service, $conf, $class, $session);
my ($service_store, $service_conf, $service_type, $service_type_conf);
my ($default);
@@ -520,9 +531,9 @@
# take care of all %$args attributes next
################################################################
- # A "volatile" service is one which never stores its attributes in
+ # A "lightweight" service is one which never stores its attributes in
# the session store. It assumes that all necessary attributes will
- # be supplied by the conf or by the code. As a result, a "volatile"
+ # be supplied by the conf or by the code. As a result, a "lightweight"
# service can usually never handle events.
# 1. its attributes are only ever required when they are all supplied
# 2. its attributes will be OK by combining the %$args with the %$conf
@@ -532,11 +543,11 @@
# This is really handy when you have something like a huge spreadsheet
# of text entry cells (usually an indexed variable).
- if (defined $args->{volatile}) { # may be specified explicitly
- $volatile = $args->{volatile};
+ if (defined $args->{lightweight}) { # may be specified explicitly
+ $lightweight = $args->{lightweight};
}
else {
- $volatile = ($name =~ /[\{\}\[\]]/); # or implicitly for indexed variables
+ $lightweight = ($name =~ /[\{\}\[\]]/); # or implicitly for indexed variables
}
$override = $args->{override};
@@ -549,9 +560,9 @@
if (!defined $service->{$attrib} ||
($override && $service->{$attrib} ne $args->{$attrib})) {
$service->{$attrib} = $args->{$attrib};
- $session->{store}{$type}{$name}{$attrib} = $args->{$attrib} if (!$volatile);
+ $session->{store}{$type}{$name}{$attrib} = $args->{$attrib} if (!$lightweight);
}
- $self->dbgprint("Context->service() [arg=$attrib] name=$name vol=$volatile ovr=$override",
+ $self->dbgprint("Context->service() [arg=$attrib] name=$name lw=$lightweight ovr=$override",
" service=", $service->{$attrib},
" service_store=", $service_store->{$attrib},
" args=", $args->{$attrib})
@@ -694,7 +705,7 @@
must specify the session_object_class (at a minimum) and may not simply call it
with the $session_object_name.
-This is useful particularly for volatile session_objects which generate events
+This is useful particularly for lightweight session_objects which generate events
(such as image buttons). The $context->dispatch_events() method can check
that the session_object has not yet been defined and automatically passes the
event to the session_object's container (implied by the name) for handling.
@@ -702,6 +713,7 @@
=cut
sub session_object_exists {
+ &App::sub_entry if ($App::trace);
my ($self, $session_object_name) = @_;
my ($exists, $session_object_type, $session_object_class);
@@ -740,12 +752,12 @@
=cut
#############################################################################
-# iget()
+# get_option()
#############################################################################
-=head2 iget()
+=head2 get_option()
- * Signature: $value = $context->iget($var, $default);
+ * Signature: $value = $context->get_option($var, $default);
* Param: $var string
* Param: $attribute string
* Return: $value string
@@ -754,9 +766,9 @@
Sample Usage:
- $script_url_dir = $context->iget("scriptUrlDir", "/cgi-bin");
+ $script_url_dir = $context->get_option("scriptUrlDir", "/cgi-bin");
-The iget() returns the value of an Option variable
+The get_option() returns the value of an Option variable
(or the "default" value if not set).
This is an alternative to
@@ -765,7 +777,8 @@
=cut
-sub iget {
+sub get_option {
+ &App::sub_entry if ($App::trace);
my ($self, $var, $default) = @_;
my ($value, $var2, $value2);
$value = $self->{options}{$var};
@@ -774,8 +787,9 @@
$value2 = $self->{options}{$var2};
$value =~ s/\{$var2\}/$value2/g;
}
- $self->dbgprint("Context->iget($var) = [$value]")
+ $self->dbgprint("Context->get_option($var) = [$value]")
if ($App::DEBUG && $self->dbg(3));
+ &App::sub_exit((defined $value) ? $value : $default) if ($App::trace);
return (defined $value) ? $value : $default;
}
@@ -806,6 +820,7 @@
=cut
sub so_get {
+ &App::sub_entry if ($App::trace);
my ($self, $name, $var, $default, $setdefault) = @_;
my ($perl, $value);
@@ -825,20 +840,22 @@
}
if ($var !~ /[\[\]\{\}]/) { # no special chars, "foo.bar"
- $value = $self->{session}{cache}{SessionObject}{$name}{$var};
+ my $cached_service = $self->{session}{cache}{SessionObject}{$name};
+ if (!defined $cached_service || ref($cached_service) eq "HASH") {
+ $cached_service = $self->session_object($name);
+ }
+ $value = $cached_service->{$var};
if (!defined $value && defined $default) {
$value = $default;
if ($setdefault) {
$self->{session}{store}{SessionObject}{$name}{$var} = $value;
- $self->session_object($name) if (!defined $self->{session}{cache}{SessionObject}{$name});
$self->{session}{cache}{SessionObject}{$name}{$var} = $value;
}
}
$self->dbgprint("Context->so_get($name,$var) (value) = [$value]")
if ($App::DEBUG && $self->dbg(3));
- return $value;
- } # match {
- elsif ($var =~ /^\{([^\}]+)\}$/) { # a simple "{foo.bar}"
+ }
+ elsif ($var =~ /^\{([^\{\}]+)\}$/) { # a simple "{foo.bar}"
$var = $1;
$value = $self->{session}{cache}{SessionObject}{$name}{$var};
if (!defined $value && defined $default) {
@@ -851,13 +868,12 @@
}
$self->dbgprint("Context->so_get($name,$var) (attrib) = [$value]")
if ($App::DEBUG && $self->dbg(3));
- return $value;
- } # match {
+ }
elsif ($var =~ /^[\{\}\[\]].*$/) {
$self->session_object($name) if (!defined $self->{session}{cache}{SessionObject}{$name});
- $var =~ s/\{([^\}]+)\}/\{"$1"\}/g;
+ $var =~ s/\{([^\{\}]+)\}/\{"$1"\}/g;
$perl = "\$value = \$self->{session}{cache}{SessionObject}{\$name}$var;";
eval $perl;
$self->add_message("eval [$perl]: $@") if ($@);
@@ -867,6 +883,7 @@
if ($App::DEBUG && $self->dbg(3));
}
+ &App::sub_exit($value) if ($App::trace);
return $value;
}
@@ -896,13 +913,14 @@
=cut
sub so_set {
+ &App::sub_entry if ($App::trace);
my ($self, $name, $var, $value) = @_;
- my ($perl);
+ my ($perl, $retval);
if ($value eq "{:delete:}") {
- return $self->so_delete($name,$var);
+ $retval = $self->so_delete($name,$var);
}
-
+ else {
$self->dbgprint("Context->so_set($name,$var,$value)")
if ($App::DEBUG && $self->dbg(3));
@@ -927,14 +945,14 @@
# ... we used to only set the cache attribute when the
# object was already in the cache.
# if (defined $self->{session}{cache}{SessionObject}{$name});
- return;
+ $retval = 1;
} # match {
elsif ($var =~ /^\{([^\}]+)\}$/) { # a simple "{foo.bar}"
$var = $1;
$self->{session}{store}{SessionObject}{$name}{$var} = $value;
$self->{session}{cache}{SessionObject}{$name}{$var} = $value
if (defined $self->{session}{cache}{SessionObject}{$name});
- return;
+ $retval = 1;
}
elsif ($var =~ /^\{/) { # { i.e. "{columnSelected}{first_name}"
@@ -947,12 +965,20 @@
if (defined $self->{session}{cache}{SessionObject}{$name});
eval $perl;
- $self->add_message("eval [$perl]: $@") if ($@);
+ if ($@) {
+ $self->add_message("eval [$perl]: $@");
+ $retval = 0;
+ }
+ else {
+ $retval = 1;
+ }
#die "ERROR: Context->so_set($name,$var,$value): eval ($perl): $@" if ($@);
}
# } else we do nothing with it!
+ }
- return $value;
+ &App::sub_exit($retval) if ($App::trace);
+ return $retval;
}
#############################################################################
@@ -979,8 +1005,10 @@
=cut
sub so_default {
+ &App::sub_entry if ($App::trace);
my ($self, $name, $var, $default) = @_;
$self->so_get($name, $var, $default, 1);
+ &App::sub_exit() if ($App::trace);
}
#############################################################################
@@ -1008,6 +1036,7 @@
=cut
sub so_delete {
+ &App::sub_entry if ($App::trace);
my ($self, $name, $var) = @_;
my ($perl);
@@ -1033,14 +1062,12 @@
delete $self->{session}{store}{SessionObject}{$name}{$var};
delete $self->{session}{cache}{SessionObject}{$name}{$var}
if (defined $self->{session}{cache}{SessionObject}{$name});
- return;
} # match {
elsif ($var =~ /^\{([^\}]+)\}$/) { # a simple "{foo.bar}"
$var = $1;
delete $self->{session}{store}{SessionObject}{$name}{$var};
delete $self->{session}{cache}{SessionObject}{$name}{$var}
if (defined $self->{session}{cache}{SessionObject}{$name});
- return;
}
elsif ($var =~ /^\{/) { # { i.e. "{columnSelected}{first_name}"
@@ -1057,6 +1084,7 @@
#die "ERROR: Context->so_delete($name,$var): eval ($perl): $@" if ($@);
}
# } else we do nothing with it!
+ &App::sub_exit() if ($App::trace);
}
#############################################################################
@@ -1184,7 +1212,7 @@
my ($self, $msg) = @_;
if (defined $self->{messages}) {
- $self->{messages} .= "<br>\n" . $msg;
+ $self->{messages} .= "\n" . $msg;
}
else {
$self->{messages} = $msg;
@@ -1192,6 +1220,15 @@
&App::sub_exit() if ($App::trace);
}
+sub get_messages {
+ &App::sub_entry if ($App::trace);
+ my ($self) = @_;
+ my $msgs = $self->{messages};
+ delete $self->{messages} if ($msgs);
+ &App::sub_exit($msgs) if ($App::trace);
+ return($msgs);
+}
+
#############################################################################
# log()
#############################################################################
@@ -1242,7 +1279,9 @@
=cut
sub user {
+ &App::sub_entry if ($App::trace);
my $self = shift;
+ &App::sub_exit("guest") if ($App::trace);
"guest";
}
@@ -1268,8 +1307,11 @@
=cut
sub options {
+ &App::sub_entry if ($App::trace);
my $self = shift;
- return($self->{options} || {});
+ my $options = ($self->{options} || {});
+ &App::sub_exit($options) if ($App::trace);
+ return($options);
}
#############################################################################
@@ -1358,13 +1400,13 @@
return($session);
}
-sub new_session_id {
- &App::sub_entry if ($App::trace);
- my ($self) = @_;
- my $session_id = "user";
- &App::sub_exit($session_id) if ($App::trace);
- return($session_id);
-}
+#sub new_session_id {
+# &App::sub_entry if ($App::trace);
+# my ($self) = @_;
+# my $session_id = "user";
+# &App::sub_exit($session_id) if ($App::trace);
+# return($session_id);
+#}
sub set_current_session {
&App::sub_entry if ($App::trace);
@@ -1613,6 +1655,7 @@
=cut
sub dispatch_events {
+ &App::sub_entry if ($App::trace);
my ($self) = @_;
$self->dispatch_events_begin();
@@ -1620,13 +1663,26 @@
my $events = $self->{events};
my ($event, $service, $name, $method, $args);
my $results = "";
+ my $display_current_widget = 1;
eval {
while ($#$events > -1) {
$event = shift(@$events);
($service, $name, $method, $args) = @$event;
+ if ($service eq "SessionObject") {
+ $self->call($service, $name, $method, $args);
+ }
+ else {
$results = $self->call($service, $name, $method, $args);
+ $display_current_widget = 0;
+ }
+ }
+ if ($display_current_widget) {
+ my $type = $self->so_get("default","ctype","SessionObject");
+ my $name = $self->so_get("default","cname","default");
+ $results = $self->service($type, $name);
}
+
$self->send_results($results);
};
if ($@) {
@@ -1638,37 +1694,32 @@
}
$self->dispatch_events_finish();
+ &App::sub_exit() if ($App::trace);
}
sub dispatch_events_begin {
+ &App::sub_entry if ($App::trace);
my ($self) = @_;
+ &App::sub_exit() if ($App::trace);
}
sub dispatch_events_finish {
+ &App::sub_entry if ($App::trace);
my ($self) = @_;
$self->shutdown(); # assume we won't be doing anything else (this can be overridden)
+ &App::sub_exit() if ($App::trace);
}
sub call {
+ &App::sub_entry if ($App::trace);
my ($self, $service_type, $name, $method, $args) = @_;
my ($contents, $result);
- $self->dbgprint("Context->call(): ${service_type}\[$name].$method($args)")
- if ($App::DEBUG && $self->dbg(1));
-
my $service = $self->service($service_type, $name);
if (!$service) {
$result = "Service not defined: $service_type($name)\n";
}
- elsif (!$service->can($method)) {
- if ($method eq "contents") {
- $result = $service;
- }
- else {
- $result = "Method not defined on Service: $service($name).$method($args)\n";
- }
- }
- else {
+ elsif (!$service->isa("App::Widget") && $method && $service->can($method)) {
my @args = (ref($args) eq "ARRAY") ? (@$args) : $args;
my @results = $service->$method(@args);
if ($#results == -1) {
@@ -1681,6 +1732,19 @@
$result = \@results;
}
}
+ elsif ($service->can("handle_event")) {
+ my @args = (ref($args) eq "ARRAY") ? (@$args) : $args;
+ $result = $service->handle_event($name, $method, @args);
+ }
+ else {
+ if ($method eq "contents") {
+ $result = $service;
+ }
+ else {
+ $result = "Method not defined on Service: $service($name).$method($args)\n";
+ }
+ }
+ &App::sub_exit($result) if ($App::trace);
return($result);
}
1.3 +34 -1 p5ee/App-Context/lib/App/Request.pm
Index: Request.pm
===================================================================
RCS file: /cvs/public/p5ee/App-Context/lib/App/Request.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -w -r1.2 -r1.3
--- Request.pm 22 Mar 2003 04:04:34 -0000 1.2
+++ Request.pm 2 Sep 2004 20:56:51 -0000 1.3
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: Request.pm,v 1.2 2003/03/22 04:04:34 spadkins Exp $
+## $Id: Request.pm,v 1.3 2004/09/02 20:56:51 spadkins Exp $
#############################################################################
package App::Request;
@@ -84,6 +84,7 @@
=cut
sub new {
+ &App::sub_entry if ($App::trace);
my $this = shift;
my $class = ref($this) || $this;
my $self = {};
@@ -95,6 +96,7 @@
my $args = shift || {};
$self->_init($args);
+ &App::sub_exit($self) if ($App::trace);
return $self;
}
@@ -133,7 +135,9 @@
=cut
sub _init {
+ &App::sub_entry if ($App::trace);
my ($self, $args) = @_;
+ &App::sub_exit() if ($App::trace);
}
#############################################################################
@@ -166,9 +170,38 @@
=cut
sub user {
+ &App::sub_entry if ($App::trace);
my $self = shift;
+ &App::sub_exit("guest") if ($App::trace);
"guest";
}
+#############################################################################
+# get_session_id()
+#############################################################################
+
+=head2 get_session_id()
+
+The get_session_id() method returns the session_id in the request.
+
+ * Signature: $session_id = $request->get_session_id();
+ * Param: void
+ * Return: $session_id string
+ * Throws: <none>
+ * Since: 0.01
+
+ Sample Usage:
+
+ $session_id = $request->get_session_id();
+
+=cut
+
+sub get_session_id {
+ &App::sub_entry if ($App::trace);
+ my $self = shift;
+ &App::sub_exit("default") if ($App::trace);
+ "default";
+}
+
1;
1.5 +11 -7 p5ee/App-Context/lib/App/Response.pm
Index: Response.pm
===================================================================
RCS file: /cvs/public/p5ee/App-Context/lib/App/Response.pm,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -w -r1.4 -r1.5
--- Response.pm 22 Mar 2003 04:04:34 -0000 1.4
+++ Response.pm 2 Sep 2004 20:56:51 -0000 1.5
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: Response.pm,v 1.4 2003/03/22 04:04:34 spadkins Exp $
+## $Id: Response.pm,v 1.5 2004/09/02 20:56:51 spadkins Exp $
#############################################################################
package App::Response;
@@ -84,6 +84,7 @@
=cut
sub new {
+ &App::sub_entry if ($App::trace);
my $this = shift;
my $class = ref($this) || $this;
my $self = {};
@@ -95,6 +96,7 @@
my $args = shift || {};
$self->_init($args);
+ &App::sub_exit($self) if ($App::trace);
return $self;
}
@@ -133,7 +135,9 @@
=cut
sub _init {
+ &App::sub_entry if ($App::trace);
my ($self, $args) = @_;
+ &App::sub_exit() if ($App::trace);
}
#############################################################################
@@ -166,14 +170,14 @@
=cut
sub content_type {
+ &App::sub_entry if ($App::trace);
my ($self, $content_type) = @_;
if (defined $content_type) {
$self->{content_type} = $content_type;
}
- else {
+ &App::sub_exit($self->{content_type}) if ($App::trace);
return $self->{content_type};
}
-}
#############################################################################
# content()
@@ -197,14 +201,14 @@
=cut
sub content {
+ &App::sub_entry if ($App::trace);
my ($self, $content) = @_;
if (defined $content) {
$self->{content} = $content;
}
- else {
+ &App::sub_exit($self->{content}) if ($App::trace);
return $self->{content};
}
-}
1;
1.6 +39 -4 p5ee/App-Context/lib/App/Session.pm
Index: Session.pm
===================================================================
RCS file: /cvs/public/p5ee/App-Context/lib/App/Session.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -w -r1.5 -r1.6
--- Session.pm 27 Feb 2004 14:24:35 -0000 1.5
+++ Session.pm 2 Sep 2004 20:56:51 -0000 1.6
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: Session.pm,v 1.5 2004/02/27 14:24:35 spadkins Exp $
+## $Id: Session.pm,v 1.6 2004/09/02 20:56:51 spadkins Exp $
#############################################################################
package App::Session;
@@ -537,17 +537,47 @@
=cut
+sub get_session_id {
+ &App::sub_entry if ($App::trace);
+ my $self = shift;
+ my $session_id = $self->{session_id};
+ if (!$session_id) {
+ $session_id = $self->new_session_id();
+ $self->{session_id} = $session_id;
+ }
+ &App::sub_exit($session_id) if ($App::trace);
+ $session_id;
+}
+
+#############################################################################
+# new_session_id()
+#############################################################################
+
+=head2 new_session_id()
+
+The new_session_id() returns a new, unique session_id.
+
+ * Signature: $session_id = $session->new_session_id();
+ * Param: void
+ * Return: $session_id string
+ * Throws: <none>
+ * Since: 0.01
+
+ Sample Usage:
+
+ $session_id = $session->new_session_id();
+
+=cut
+
my $seq = 0;
-sub get_session_id {
+sub new_session_id {
&App::sub_entry if ($App::trace);
my $self = shift;
- return $self->{session_id} if (defined $self->{session_id});
my ($session_id);
$seq++;
$session_id = time() . ":" . $$;
$session_id .= ":$seq" if ($seq > 1);
- $self->{session_id} = $session_id;
&App::sub_exit($session_id) if ($App::trace);
$session_id;
}
@@ -624,5 +654,10 @@
return $d->Dump();
}
+sub print {
+ my $self = shift;
+ print $self->dump(@_);
+}
+
1;
1.4 +96 -41 p5ee/App-Context/lib/App/SessionObject.pm
Index: SessionObject.pm
===================================================================
RCS file: /cvs/public/p5ee/App-Context/lib/App/SessionObject.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -w -r1.3 -r1.4
--- SessionObject.pm 22 Mar 2003 04:04:34 -0000 1.3
+++ SessionObject.pm 2 Sep 2004 20:56:51 -0000 1.4
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: SessionObject.pm,v 1.3 2003/03/22 04:04:34 spadkins Exp $
+## $Id: SessionObject.pm,v 1.4 2004/09/02 20:56:51 spadkins Exp $
#############################################################################
package App::SessionObject;
@@ -160,6 +160,7 @@
=cut
sub _init {
+ &App::sub_entry if ($App::trace);
my ($self, $args) = @_;
my ($name, $absorbable_attribs, $container, $attrib);
@@ -185,6 +186,7 @@
}
}
}
+ &App::sub_exit() if ($App::trace);
}
#############################################################################
@@ -215,33 +217,42 @@
=cut
sub handle_event {
- my $self = shift;
- my ($name, $context, $container, $w);
- $name = $self->{name};
+ &App::sub_entry if ($App::trace);
+ my ($self, $wname, $event, @args) = @_;
- $self->{context}->dbgprint("SessionObject($name)->handle_event(@_)")
- if ($App::DEBUG && $self->{context}->dbg(1));
+ my $handled = 0;
- if ($_[0] eq "noop") { # handle all known events
- return 1;
+ if ($event eq "noop") { # handle all known events
+ $handled = 1;
}
else {
- $container = "default";
+ my $name = $self->{name};
+ my $context = $self->{context};
+ my $container = "default";
if ($name =~ /^(.+)\.[a-zA-Z][a-zA-Z0-9_]*$/) {
$container = $1;
}
- $context = $self->{context};
+ else {
+ my $cname = $context->so_get("default","cname");
+ if ($cname ne $name && $cname !~ /^$name\./) {
+ $container = $cname; # container is the current active widget
+ }
+ }
if ($container eq "default") {
- return 1;
- #$context = $self->{context};
- #$context->add_message("Event not handled: @_\n");
- #return 0;
+ $context->add_message("Event not handled: {$wname}.$event(@args)");
+ $handled = 1;
+ }
+ else {
+ my $w = $context->session_object($container);
+ $handled = $w->handle_event($wname, $event, @args); # bubble the event to container session_object
}
- $w = $context->session_object($container);
- return $w->handle_event(@_); # bubble the event to container session_object
}
+
+ &App::sub_exit($handled) if ($App::trace);
+ return($handled);
}
+
#############################################################################
# Method: set_value()
#############################################################################
@@ -260,6 +271,7 @@
=cut
sub set_value {
+ &App::sub_entry if ($App::trace);
my ($self, $value) = @_;
my $name = $self->{name};
if ($name =~ /^(.+)\.([a-zA-Z][a-zA-Z0-9_]*)$/) {
@@ -268,6 +280,7 @@
else {
$self->{context}->so_set("default", $name, $value);
}
+ &App::sub_exit() if ($App::trace);
}
#############################################################################
@@ -287,8 +300,11 @@
=cut
sub get_value {
+ &App::sub_entry if ($App::trace);
my ($self, $default, $setdefault) = @_;
- return $self->{context}->so_get($self->{name}, "", $default, $setdefault);
+ my $value = $self->{context}->so_get($self->{name}, "", $default, $setdefault);
+ &App::sub_exit($value) if ($App::trace);
+ return $value;
}
#############################################################################
@@ -310,20 +326,22 @@
=cut
sub fget_value {
+ &App::sub_entry if ($App::trace);
my ($self, $format) = @_;
$format = $self->get("format") if (!defined $format);
+ my ($value);
if (! defined $format) {
- return $self->get_value("");
+ $value = $self->get_value("");
}
else {
- my ($value, $type);
- $type = $self->get("validate");
+ my $type = $self->get("validate");
$value = $self->get_value("");
if ($type) {
$value = App::SessionObject->format($value, $type, $format);
}
- return $value;
}
+ &App::sub_exit($value) if ($App::trace);
+ return($value);
}
#############################################################################
@@ -346,9 +364,21 @@
=cut
sub get_values {
+ &App::sub_entry if ($App::trace);
my ($self, $default, $setdefault) = @_;
my $values = $self->get_value($default, $setdefault);
- return (ref($values) eq "ARRAY") ? @$values : ($values);
+ my (@values);
+ if (!defined $values) {
+ @values = ();
+ }
+ elsif (ref($values) eq "ARRAY") {
+ @values = @$values;
+ }
+ else {
+ @values = ($values);
+ }
+ &App::sub_exit(@values) if ($App::trace);
+ return (@values);
}
#############################################################################
@@ -369,8 +399,10 @@
=cut
sub set {
+ &App::sub_entry if ($App::trace);
my ($self, $var, $value) = @_;
$self->{context}->so_set($self->{name}, $var, $value);
+ &App::sub_exit() if ($App::trace);
}
#############################################################################
@@ -396,8 +428,11 @@
=cut
sub get {
+ &App::sub_entry if ($App::trace);
my ($self, $var, $default, $setdefault) = @_;
- $self->{context}->so_get($self->{name}, $var, $default, $setdefault);
+ my $value = $self->{context}->so_get($self->{name}, $var, $default, $setdefault);
+ &App::sub_exit($value) if ($App::trace);
+ $value;
}
#############################################################################
@@ -417,8 +452,11 @@
=cut
sub delete {
+ &App::sub_entry if ($App::trace);
my ($self, $var) = @_;
- $self->{context}->so_delete($self->{name}, $var);
+ my $result = $self->{context}->so_delete($self->{name}, $var);
+ &App::sub_exit($result) if ($App::trace);
+ $result;
}
#############################################################################
@@ -439,8 +477,11 @@
=cut
sub set_default {
+ &App::sub_entry if ($App::trace);
my ($self, $var, $default) = @_;
- $self->{context}->so_get($self->{name}, $var, $default, 1);
+ my $value = $self->{context}->so_get($self->{name}, $var, $default, 1);
+ &App::sub_exit($value) if ($App::trace);
+ $value;
}
#############################################################################
@@ -468,6 +509,7 @@
=cut
sub label {
+ &App::sub_entry if ($App::trace);
my ($self, $attrib, $lang) = @_;
my ($label);
#print "label($attrib, $lang) [$self]\n";
@@ -482,6 +524,7 @@
$label = $self->translate($label,$lang) if ($lang);
$self->{"${attrib}__${lang}"} = $label; # cache it for later use
#print "label($attrib, $lang) => $label\n";
+ &App::sub_exit($label) if ($App::trace);
return $label;
}
@@ -505,6 +548,7 @@
=cut
sub values_labels {
+ &App::sub_entry if ($App::trace);
my ($self) = @_;
my ($domain, $values, $labels);
@@ -521,10 +565,11 @@
$self->{context}->dbgprint("SessionObject->values_labels(): domain=$domain")
if ($App::DEBUG && $self->{context}->dbg(1));
- ($values, $labels) = $self->{context}->domain($domain);
+ ($values, $labels) = $self->{context}->value_domain($domain)->values_labels();
}
$values = [] if (! defined $values);
$labels = {} if (! defined $labels);
+ &App::sub_exit($values, $labels) if ($App::trace);
($values, $labels);
}
@@ -551,6 +596,7 @@
=cut
sub labels {
+ &App::sub_entry if ($App::trace);
my ($self, $attrib, $lang) = @_;
my ($labels, $langlabels, $key);
$attrib = "labels" if (!defined $attrib || $attrib eq ""); #"labels" is the default attribute to translate
@@ -569,6 +615,7 @@
}
$self->{"lang_${attrib}"} = $langlabels; # cache it for later use
}
+ &App::sub_exit($langlabels) if ($App::trace);
return $langlabels;
}
@@ -591,10 +638,12 @@
use Data::Dumper;
sub dump {
+ &App::sub_entry if ($App::trace);
my $self = shift;
my $d = Data::Dumper->new([ $self ], [ "session_object" ]);
$d->Indent(1);
$d->Dump();
+ &App::sub_exit() if ($App::trace);
}
#############################################################################
@@ -614,8 +663,10 @@
=cut
sub print {
+ &App::sub_entry if ($App::trace);
my $self = shift;
print $self->dump();
+ &App::sub_exit() if ($App::trace);
}
#############################################################################
@@ -689,24 +740,28 @@
my ($self, $label, $lang) = @_;
#print "translate($label, $lang)\n";
- return $label if (!$label); # can't translate a null label
- $label = $self->{lang} if (!$lang);
- return $label if (!$lang); # can't translate without a language
-
- my ($dict, $trans_label);
- $dict = $self->{dict};
- return $label if (!defined $dict); # can't translate without a dictionary
-
- $trans_label = $dict->{$lang}{$label};
- if (!defined $trans_label && $lang =~ s/_.*$//) { # trim the trailing modifier (en_us => en)
- $trans_label = $dict->{$lang}{$label};
+ my $trans_label = $label || "";
+ if (!$label) {
+ # do nothing (reply with blank)
}
+ else {
+ $lang = $self->{lang} if (!$lang);
+ my $dict = $self->{dict};
+ if (!$lang || !$dict) {
+ # do nothing (return $label without translation)
+ }
+ else {
+ $trans_label = $dict->{$lang}{$label};
if (!defined $trans_label) {
- $trans_label = $dict->{default}{$label};
+ my $base_lang = $lang;
+ $base_lang =~ s/_.*$//; # trim the trailing modifier (en_us => en)
+ $trans_label = $dict->{$base_lang}{$label} if ($base_lang ne $lang);
+ }
+ $trans_label = $dict->{default}{$label} if (!defined $trans_label);
+ $trans_label = $label if (!$trans_label);
+ }
}
- return $label if (!defined $trans_label);
- #print "translate($label, $lang) => $trans_label\n";
return $trans_label;
}
1.4 +3 -3 p5ee/App-Context/lib/App/UserAgent.pm
Index: UserAgent.pm
===================================================================
RCS file: /cvs/public/p5ee/App-Context/lib/App/UserAgent.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -w -r1.3 -r1.4
--- UserAgent.pm 22 Mar 2003 04:04:34 -0000 1.3
+++ UserAgent.pm 2 Sep 2004 20:56:51 -0000 1.4
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: UserAgent.pm,v 1.3 2003/03/22 04:04:34 spadkins Exp $
+## $Id: UserAgent.pm,v 1.4 2004/09/02 20:56:51 spadkins Exp $
#############################################################################
package App::UserAgent;
@@ -82,7 +82,7 @@
$self->{context} = $context;
if (defined $context) {
- $self->{http_user_agent} = $context->iget("http_user_agent");
+ $self->{http_user_agent} = $context->get_option("http_user_agent");
}
else {
$self->{http_user_agent} =
@@ -97,7 +97,7 @@
$self->parse($self->{http_user_agent});
if (defined $context) {
- $lang = $context->iget("http_user_agent");
+ $lang = $context->get_option("http_user_agent");
}
elsif (defined $ENV{HTTP_ACCEPT_LANGUAGE}) {
$lang = lc($ENV{HTTP_ACCEPT_LANGUAGE});
1.8 +174 -86 p5ee/App-Context/lib/App/Context/HTTP.pm
Index: HTTP.pm
===================================================================
RCS file: /cvs/public/p5ee/App-Context/lib/App/Context/HTTP.pm,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -w -r1.7 -r1.8
--- HTTP.pm 27 Feb 2004 14:23:55 -0000 1.7
+++ HTTP.pm 2 Sep 2004 20:56:51 -0000 1.8
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: HTTP.pm,v 1.7 2004/02/27 14:23:55 spadkins Exp $
+## $Id: HTTP.pm,v 1.8 2004/09/02 20:56:51 spadkins Exp $
#############################################################################
package App::Context::HTTP;
@@ -80,16 +80,21 @@
=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);
}
-sub _default_session {
- return("App::Session::HTMLHidden");
+sub _default_session_class {
+ &App::sub_entry if ($App::trace);
+ my $session_class = "App::Session::HTMLHidden";
+ &App::sub_exit($session_class) if ($App::trace);
+ return($session_class);
}
#############################################################################
@@ -104,16 +109,124 @@
=cut
sub dispatch_events_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);
}
+ &App::sub_exit() if ($App::trace);
+}
+
+sub dispatch_events {
+ &App::sub_entry if ($App::trace);
+ my ($self) = @_;
+
+ $self->dispatch_events_begin();
+
+ my $events = $self->{events};
+ my ($event, $service, $name, $method, $args);
+ my $results = "";
+ my $display_current_widget = 1;
+
+ eval {
+ while ($#$events > -1) {
+ $event = shift(@$events);
+ ($service, $name, $method, $args) = @$event;
+ if ($service eq "SessionObject") {
+ $self->call($service, $name, $method, $args);
+ }
+ else {
+ $results = $self->call($service, $name, $method, $args);
+ $display_current_widget = 0;
+ }
+ }
+ if ($display_current_widget) {
+ my $type = $self->so_get("default","ctype","SessionObject");
+ my $name = $self->so_get("default","cname","default");
+ $results = $self->service($type, $name);
+ }
+
+ my $response = $self->response();
+ my $ref = ref($results);
+ if (!$ref || $ref eq "ARRAY" || $ref eq "HASH") {
+ $response->content($results);
+ }
+ elsif ($results->isa("App::Service")) {
+ $response->content($results->content());
+ $response->content_type($results->content_type());
+ }
+ else {
+ $response->content($results->internals());
+ }
+
+ $self->send_response();
+ };
+ if ($@) {
+ $self->send_error($@);
+ }
+
+ if ($self->{options}{debug_context}) {
+ print STDERR $self->dump();
+ }
+
+ $self->dispatch_events_finish();
+ &App::sub_exit() if ($App::trace);
+}
+
+sub dispatch_events_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);
}
+# this code needs to be restored at the Context->dispatch_events() level
+# $name = $context->so_get("default", "name");
+# $service = $context->so_get("default", "service");
+# $returntype = $context->so_get("default", "returntype");
+# # print "name=[$curr_name] service=[$curr_service] returntype=[$curr_returntype]\n";
+# ...
+# $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) {
+# my $service = $context->service($service, $name);
+# my $response = $context->response();
+# if (!$service) {
+# $response->content("Service not defined: $service($name)\n");
+# }
+# elsif (!$service->can($method)) {
+# $response->content("Method not defined on Service: $service($name).$method($args)\n");
+# }
+# else {
+# my @results = $service->$method($args);
+# if ($#results == -1) {
+# $response->content($service->internals());
+# }
+# elsif ($#results == 0) {
+# $response->content($results[0]);
+# $response->content_type($service->content_type());
+# }
+# else {
+# $response->content(\@results);
+# }
+# }
+# }
+
sub send_error {
+ &App::sub_entry if ($App::trace);
my ($self, $errmsg) = @_;
print <<EOF;
Content-type: text/plain
@@ -128,6 +241,7 @@
-----------------------------------------------------------------------------
$self->{messages}
EOF
+ &App::sub_exit() if ($App::trace);
}
#############################################################################
@@ -151,15 +265,16 @@
=cut
sub request {
+ &App::sub_entry if ($App::trace);
my $self = shift;
- return $self->{request} if (defined $self->{request});
+ if (! defined $self->{request}) {
#################################################################
# REQUEST
#################################################################
- my $request_class = $self->iget("request_class");
+ my $request_class = $self->get_option("request_class");
if (!$request_class) {
my $gateway = $ENV{GATEWAY_INTERFACE};
# TODO: need to distinguish between PerlRun, Registry, libapreq, other
@@ -181,7 +296,9 @@
$self->add_message("Context::HTTP::request(): $@");
print STDERR "request=$self->{request} err=[$@]\n";
}
+ }
+ &App::sub_exit($self->{request}) if ($App::trace);
return $self->{request};
}
@@ -206,22 +323,27 @@
=cut
sub response {
+ &App::sub_entry if ($App::trace);
my $self = shift;
- return $self->{response} if (defined $self->{response});
+ my $response = $self->{response};
+ if (!defined $response) {
#################################################################
# RESPONSE
#################################################################
- my $response_class = $self->iget("response_class", "App::Response");
+ my $response_class = $self->get_option("response_class", "App::Response");
eval {
- $self->{response} = App->new($response_class, "new", $self, $self->{options});
+ $response = App->new($response_class, "new", $self, $self->{options});
};
+ $self->{response} = $response;
$self->add_message("Context::HTTP::response(): $@") if ($@);
+ }
- return $self->{response};
+ &App::sub_exit($response) if ($App::trace);
+ return($response);
}
#############################################################################
@@ -242,50 +364,6 @@
=cut
-# this code needs to be restored at the Context->dispatch_events() level
-#
-# 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);
-# ...
-# $context->restore_default_session();
-# ...
-# $name = $context->so_get("default", "name");
-# $service = $context->so_get("default", "service");
-# $returntype = $context->so_get("default", "returntype");
-# # print "name=[$curr_name] service=[$curr_service] returntype=[$curr_returntype]\n";
-# ...
-# $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) {
-# my $service = $context->service($service, $name);
-# my $response = $context->response();
-# if (!$service) {
-# $response->content("Service not defined: $service($name)\n");
-# }
-# elsif (!$service->can($method)) {
-# $response->content("Method not defined on Service: $service($name).$method($args)\n");
-# }
-# else {
-# my @results = $service->$method($args);
-# if ($#results == -1) {
-# $response->content($service->internals());
-# }
-# elsif ($#results == 0) {
-# $response->content($results[0]);
-# $response->content_type($service->content_type());
-# }
-# else {
-# $response->content(\@results);
-# }
-# }
-# }
-
#sub send_results {
# my ($self, $results) = @_;
#
@@ -323,7 +401,8 @@
#EOF
#}
-sub send_results {
+sub send_response {
+ &App::sub_entry if ($App::trace);
my $self = shift;
my ($serializer, $response, $ctype, $content, $content_type, $headers);
@@ -365,6 +444,7 @@
else {
print $headers, "\n", $content;
}
+ &App::sub_exit() if ($App::trace);
}
#############################################################################
@@ -386,6 +466,7 @@
=cut
sub set_header {
+ &App::sub_entry if ($App::trace);
my ($self, $header) = @_;
if ($self->{headers}) {
$self->{headers} .= $header;
@@ -393,6 +474,7 @@
else {
$self->{headers} = $header;
}
+ &App::sub_exit() if ($App::trace);
}
#############################################################################
@@ -417,8 +499,11 @@
=cut
sub user_agent {
+ &App::sub_entry if ($App::trace);
my $self = shift;
- $self->{user_agent};
+ my $user_agent = $self->{user_agent};
+ &App::sub_exit($user_agent) if ($App::trace);
+ return($user_agent);
}
#############################################################################
@@ -454,8 +539,11 @@
=cut
sub user {
+ &App::sub_entry if ($App::trace);
my $self = shift;
- return $self->request()->user();
+ my $user = $self->request()->user();
+ &App::sub_exit($user) if ($App::trace);
+ return $user;
}
1;
1.6 +76 -13 p5ee/App-Context/lib/App/Context/NetServer.pm
Index: NetServer.pm
===================================================================
RCS file: /cvs/public/p5ee/App-Context/lib/App/Context/NetServer.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -w -r1.5 -r1.6
--- NetServer.pm 3 Dec 2003 16:21:11 -0000 1.5
+++ NetServer.pm 2 Sep 2004 20:56:51 -0000 1.6
@@ -1,13 +1,14 @@
#############################################################################
-## $Id: NetServer.pm,v 1.5 2003/12/03 16:21:11 spadkins Exp $
+## $Id: NetServer.pm,v 1.6 2004/09/02 20:56:51 spadkins Exp $
#############################################################################
package App::Context::NetServer;
use App;
use App::Context;
-@ISA = ( "App::Context" );
+use Net::Server;
+@ISA = ( "Net::Server", "App::Context" );
use App::UserAgent;
use strict;
@@ -121,22 +122,84 @@
=cut
+# conf_file "filename" undef
+#
+# log_level 0-4 2
+# log_file (filename|Sys::Syslog) undef
+#
+# ## syslog parameters
+# syslog_logsock (unix|inet) unix
+# syslog_ident "identity" "net_server"
+# syslog_logopt (cons|ndelay|nowait|pid) pid
+# syslog_facility \w+ daemon
+#
+# port \d+ 20203
+# host "host" "*"
+# proto (tcp|udp|unix) "tcp"
+# listen \d+ SOMAXCONN
+#
+# reverse_lookups 1 undef
+# allow /regex/ none
+# deny /regex/ none
+#
+# ## daemonization parameters
+# pid_file "filename" undef
+# chroot "directory" undef
+# user (uid|username) "nobody"
+# group (gid|group) "nobody"
+# background 1 undef
+# setsid 1 undef
+#
+# no_close_by_child (1|undef) undef
+
sub dispatch_events {
my ($self) = @_;
- my ($request);
+ my $options = $self->options();
+ my @options = qw(
+ conf_file
+ log_level log_file
+ syslog_logsock syslog_ident syslog_logopt syslog_facility
+ port host proto listen
+ reverse_lookups allow deny
+ pid_file chroot user group background setsid
+ no_close_by_child
+ );
+
+ my (%options);
+ #foreach my $option (@options) {
+ # if (defined $options->{"netserver_$option"}) {
+ # $options{$option} = $options->{"netserver_$option"};
+ # }
+ #}
+
+ $self->run(%options); # this initiates the native event loop of Net::Server
+ $self->shutdown();
+}
+
+#############################################################################
+# process_request()
+# this is the interface that needs to be implemented for Net::Server
+#############################################################################
+sub process_request {
+ my $self = shift;
eval {
- $request = $self->request();
- $request->process();
- $self->send_response();
+ local $SIG{ALRM} = sub { die "Timed Out!\n" };
+ my $timeout = 10; # give the user 30 seconds to type a line
+
+ my $previous_alarm = alarm($timeout);
+ while( <STDIN> ){
+ s/\r?\n$//;
+ print "You said \"$_\"\r\n";
+ alarm($timeout);
+ }
+ alarm($previous_alarm);
};
- if ($@) {
- # TODO
- # log $@
+ if( $@=~/timed out/i ){
+ print STDOUT "Timed Out.\r\n";
+ return;
}
-
- $self->shutdown();
}
#############################################################################
@@ -247,7 +310,7 @@
# REQUEST
#################################################################
- my $request_class = $self->iget("request_class");
+ my $request_class = $self->get_option("request_class");
if (!$request_class) {
$request_class = "App::Request";
}
@@ -289,7 +352,7 @@
# RESPONSE
#################################################################
- my $response_class = $self->iget("response_class", "App::Response");
+ my $response_class = $self->get_option("response_class", "App::Response");
eval {
$self->{response} = App->new($response_class, "new", $self, $self->{options});
1.5 +3 -3 p5ee/App-Context/lib/App/Context/SimpleServer.pm
Index: SimpleServer.pm
===================================================================
RCS file: /cvs/public/p5ee/App-Context/lib/App/Context/SimpleServer.pm,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -w -r1.4 -r1.5
--- SimpleServer.pm 3 Dec 2003 16:21:11 -0000 1.4
+++ SimpleServer.pm 2 Sep 2004 20:56:51 -0000 1.5
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: SimpleServer.pm,v 1.4 2003/12/03 16:21:11 spadkins Exp $
+## $Id: SimpleServer.pm,v 1.5 2004/09/02 20:56:51 spadkins Exp $
#############################################################################
package App::Context::SimpleServer;
@@ -159,7 +159,7 @@
# REQUEST
#################################################################
- my $request_class = $self->iget("request_class", "App::Request");
+ my $request_class = $self->get_option("request_class", "App::Request");
eval {
$self->{request} = App->new($request_class, "new", $self, $self->{options});
@@ -198,7 +198,7 @@
# RESPONSE
#################################################################
- my $response_class = $self->iget("response_class", "App::Response");
+ my $response_class = $self->get_option("response_class", "App::Response");
eval {
$self->{response} = App->new($response_class, "new", $self, $self->{options});
1.12 +89 -52 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.11
retrieving revision 1.12
diff -u -w -r1.11 -r1.12
--- CGI.pm 27 Feb 2004 14:19:25 -0000 1.11
+++ CGI.pm 2 Sep 2004 20:56:51 -0000 1.12
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: CGI.pm,v 1.11 2004/02/27 14:19:25 spadkins Exp $
+## $Id: CGI.pm,v 1.12 2004/09/02 20:56:51 spadkins Exp $
#############################################################################
package App::Request::CGI;
@@ -74,6 +74,7 @@
=cut
sub _init {
+ &App::sub_entry if ($App::trace);
my ($self, $options) = @_;
my ($cgi, $var, $value, $app, $file);
$options = {} if (!defined $options);
@@ -85,11 +86,15 @@
$app = $1;
}
+ my $debug_request = $options->{debug_request} || "";
+ my $replay = ($debug_request eq "replay" || $options->{replay});
+ my $record = ($debug_request eq "record" && !$replay);
+
#################################################################
# read environment variables
#################################################################
- if (defined $options->{debug_request} && $options->{debug_request} eq "replay") {
+ if ($replay) {
$file = "$app.env";
if (open(App::FILE, "< $file")) {
foreach $var (keys %ENV) {
@@ -106,7 +111,7 @@
}
}
- if (defined $options->{debug_request} && $options->{debug_request} eq "record") {
+ if ($record) {
$file = "$app.env";
if (open(App::FILE, "> $file")) {
foreach $var (keys %ENV) {
@@ -120,7 +125,7 @@
# READ HTTP PARAMETERS (CGI VARIABLES)
#################################################################
- if (defined $options->{debug_request} && $options->{debug_request} eq "replay") {
+ if ($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";
@@ -143,7 +148,7 @@
}
# when the "debug_request" is "record", save the CGI vars
- if (defined $options->{debug_request} && $options->{debug_request} eq "record") {
+ if ($record) {
$file = "$app.vars";
if (open(App::FILE, "> $file")) {
$cgi->save(*App::FILE); # Save vars to debug file
@@ -169,6 +174,7 @@
$self->{lang} = $lang; # TODO: do something with the $lang ...
$self->{cgi} = $cgi;
+ &App::sub_exit() if ($App::trace);
}
#############################################################################
@@ -180,6 +186,34 @@
=cut
#############################################################################
+# get_session_id()
+#############################################################################
+
+=head2 get_session_id()
+
+The get_session_id() method returns the session_id in the request.
+
+ * Signature: $session_id = $request->get_session_id();
+ * Param: void
+ * Return: $session_id string
+ * Throws: <none>
+ * Since: 0.01
+
+ Sample Usage:
+
+ $session_id = $request->get_session_id();
+
+=cut
+
+sub get_session_id {
+ &App::sub_entry if ($App::trace);
+ my $self = shift;
+ my $session_id = $self->{cgi}->param("session_id");
+ &App::sub_exit($session_id) if ($App::trace);
+ return($session_id);
+}
+
+#############################################################################
# get_events()
#############################################################################
@@ -207,6 +241,7 @@
=cut
sub get_events {
+ &App::sub_entry if ($App::trace);
my ($self, $cgi) = @_;
if (!defined $cgi) {
@@ -231,14 +266,16 @@
$path_info =~ s!/$!!; # delete trailing "/"
my $options = $context->options();
my $app = $options->{app};
- if ($path_info && $app && $app ne "app") {
+ if ($path_info && $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>
+ $path_info =~ s!\.(html|xml|yaml|csv|pdf|perl)$!!; # delete trailing .<returntype>
- if ($path_info =~ s!^/([A-Za-z0-9]+)!!) {
+ if ($path_info =~ s!^/([A-Z][A-Za-z0-9]*)/!/!) {
$service = $1;
}
else {
@@ -249,26 +286,16 @@
$method = $1;
$args = $2;
}
- elsif ($path_info =~ s!\.([a-zA-Z0-9_]+)$!!) {
- $method = $1;
- $args = "";
- }
else {
$method = "";
$args = "";
}
- if ($path_info =~ m!^\.([a-zA-Z._-]+)$!) {
- $name = $1;
- }
- elsif ($path_info =~ m!^/([a-zA-Z._-]+)$!) {
- $name = $1;
- }
- elsif ($path_info =~ m!^\(([a-zA-Z._-]+)\)$!) {
+ if ($path_info =~ m!^/([a-zA-Z._-]+)$!) {
$name = $1;
}
else {
- $name = "default";
+ $name = $app;
}
# override PATH_INFO with CGI variables
@@ -294,6 +321,10 @@
if ($service && $name && $method) {
push(@events, [ $service, $name, $method, $args ]);
}
+ elsif ($service && $name) {
+ $context->so_set("default","ctype",$service);
+ $context->so_set("default","cname",$name);
+ }
}
##########################################################
@@ -306,10 +337,10 @@
my (@eventvars, $var, @values, @tmp, $value, $mlhashkey);
@eventvars = ();
foreach $var ($cgi->param()) {
- if ($var =~ /^app\.event\./) {
+ if ($var =~ /^app\.event/) {
push(@eventvars, $var);
}
- elsif ($var =~ /^app.session/) {
+ elsif ($var =~ /^app\.session/) {
# do nothing.
# these vars are used in the Session restore() to restore state.
}
@@ -430,33 +461,29 @@
$name = $1;
$event = $2;
- if ($context->session_object_exists($name)) {
- $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);
- }
- else {
- my ($parent_name);
- $parent_name = $name;
-
- $context->dbgprint("Request::CGI->get_events() $name doesn't exist, trying parents...")
- if ($App::DEBUG && $context->dbg(1));
+ push(@events, [ "SessionObject", $name, $event, [ @args ] ]);
- while ($parent_name =~ s/\.[^\.]+$//) {
-
- if ($context->session_object_exists($parent_name)) {
-
- $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->get_events() $parent_name doesn't exist")
- if ($App::DEBUG && $context->dbg(1));
- }
- }
+ #if ($context->session_object_exists($name)) {
+ # $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);
+ #}
+ #else {
+ # my ($parent_name);
+ # $parent_name = $name;
+ # $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->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->get_events() $parent_name doesn't exist")
+ # if ($App::DEBUG && $context->dbg(1));
+ # }
+ #}
}
}
elsif ($key eq "app.event") {
@@ -476,11 +503,12 @@
$args = $1;
}
@args = split(/ *, */,$args) if ($args ne "");
+ push(@events, [ "SessionObject", $name, $event, [ @args ] ]);
- $context->dbgprint("Request::CGI->get_events() handle_event($name, $event, @args) [hidden/other]")
- if ($App::DEBUG && $context->dbg(1));
+ #$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);
+ #$context->session_object($name)->handle_event($name, $event, @args);
}
}
}
@@ -490,10 +518,12 @@
if ($App::DEBUG && $context->dbg(1));
}
+ &App::sub_exit(\@events) if ($App::trace);
return(\@events);
}
sub get_returntype {
+ &App::sub_entry if ($App::trace);
my ($self, $cgi) = @_;
if (!defined $cgi) {
@@ -513,6 +543,7 @@
$returntype = $1;
}
}
+ &App::sub_exit($returntype) if ($App::trace);
return($returntype);
}
@@ -538,8 +569,11 @@
=cut
sub user {
+ &App::sub_entry if ($App::trace);
my $self = shift;
- return ($ENV{REMOTE_USER} || "guest");
+ my $user = $ENV{REMOTE_USER} || "guest";
+ &App::sub_exit($user) if ($App::trace);
+ return ($user);
}
#############################################################################
@@ -563,8 +597,11 @@
=cut
sub header {
+ &App::sub_entry if ($App::trace);
my ($self, $header_name) = @_;
- return $self->{cgi}->http($header_name);
+ my $header = $self->{cgi}->http($header_name);
+ &App::sub_exit($header) if ($App::trace);
+ return($header);
}
1;
1.6 +10 -32 p5ee/App-Context/lib/App/Session/HTMLHidden.pm
Index: HTMLHidden.pm
===================================================================
RCS file: /cvs/public/p5ee/App-Context/lib/App/Session/HTMLHidden.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -w -r1.5 -r1.6
--- HTMLHidden.pm 3 Dec 2003 16:18:50 -0000 1.5
+++ HTMLHidden.pm 2 Sep 2004 20:56:51 -0000 1.6
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: HTMLHidden.pm,v 1.5 2003/12/03 16:18:50 spadkins Exp $
+## $Id: HTMLHidden.pm,v 1.6 2004/09/02 20:56:51 spadkins Exp $
#############################################################################
package App::Session::HTMLHidden;
@@ -116,8 +116,11 @@
my $seq = 0;
sub get_session_id {
+ &App::sub_entry if ($App::trace);
my $self = shift;
- "embedded";
+ my $session_id = "embedded";
+ &App::sub_exit($session_id) if ($App::trace);
+ return($session_id);
}
#############################################################################
@@ -141,6 +144,7 @@
=cut
sub html {
+ &App::sub_entry if ($App::trace);
my ($self) = @_;
my ($sessiontext, $sessiondata, $html, $options);
@@ -174,7 +178,7 @@
$html .= "\n";
$options = $self->{context}->options();
- if ($options && $options->{showsession}) {
+ if ($options && $options->{show_session}) {
# Debugging Only
my $d = Data::Dumper->new([ $sessiondata ], [ "session_store" ]);
$d->Indent(1);
@@ -183,6 +187,7 @@
$html .= "-->\n";
}
+ &App::sub_exit($html) if ($App::trace);
$html;
}
@@ -198,35 +203,6 @@
=cut
#############################################################################
-# create()
-#############################################################################
-
-=head2 create()
-
-The create() method is used to create the Perl structure that will
-be blessed into the class and returned by the constructor.
-
- * Signature: $ref = App::Reference->create($hashref)
- * Param: $hashref {}
- * Return: $ref ref
- * Throws: App::Exception
- * Since: 0.01
-
- Sample Usage:
-
-=cut
-
-sub create {
- my ($self, $args) = @_;
- $args = {} if (!defined $args);
-
- my ($ref);
- $ref = {};
-
- $ref;
-}
-
-#############################################################################
# _init()
#############################################################################
@@ -258,6 +234,7 @@
=cut
sub _init {
+ &App::sub_entry if ($App::trace);
my ($self, $args) = @_;
my ($cgi, $sessiontext, $store);
@@ -282,6 +259,7 @@
$self->{context} = $args->{context} if (defined $args->{context});
$self->{store} = $store;
$self->{cache} = {};
+ &App::sub_exit() if ($App::trace);
}
1;