cvsuser 02/11/01 11:56:08
Modified: App-Context/lib/App/Request CGI.pm
App-Context/lib/App Context.pm
Log:
extensive changes to get the new App-Context framework on its feet
Revision Changes Path
1.5 +41 -40 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.4
retrieving revision 1.5
diff -u -w -r1.4 -r1.5
--- CGI.pm 15 Oct 2002 21:58:49 -0000 1.4
+++ CGI.pm 1 Nov 2002 19:56:08 -0000 1.5
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: CGI.pm,v 1.4 2002/10/15 21:58:49 spadkins Exp $
+## $Id: CGI.pm,v 1.5 2002/11/01 19:56:08 spadkins Exp $
#############################################################################
package App::Request::CGI;
@@ -122,7 +122,7 @@
}
#################################################################
- # READ CGI VARIABLES
+ # READ HTTP PARAMETERS (CGI VARIABLES)
#################################################################
if (defined $initconf->{debugmode} && $initconf->{debugmode} eq "replay") {
@@ -219,19 +219,23 @@
}
my $context = $self->{context};
+ $context->dbgprint("Request::CGI->process() cgi=$cgi")
+ if ($App::DEBUG && $context->dbg(1));
+
if (defined $cgi) {
my ($session);
$session = $context->{session}; # get the Session
my ($app_path_info, $cservice, $cname, $cmethod, $cargs, $ctype);
+ my $initconf = $self->{context}->initconf();
my $cname_new = 0;
if ($cgi->request_method() eq "POST") {
- $cservice = $cgi->param("cservice") || "SessionObject";
- $cname = $cgi->param("cname") || "default";
- $cmethod = $cgi->param("cmethod") || "content";
- $cargs = $cgi->param("cargs") || "";
- $ctype = $cgi->param("ctype") || "default";
+ $cservice = $cgi->param("cservice") || $initconf->{default_cservice} ||
"SessionObject";
+ $cname = $cgi->param("cname") || $initconf->{default_cname} ||
"default";
+ $cmethod = $cgi->param("cmethod") || $initconf->{default_cmethod} ||
"content";
+ $cargs = $cgi->param("cargs") || $initconf->{default_cargs} || "";
+ $ctype = $cgi->param("ctype") || $initconf->{default_ctype} ||
"default";
}
else {
# app_path_info = /Procedure/local.f2c(32):xml
@@ -241,14 +245,14 @@
$cservice = $1;
}
else {
- $cservice = "SessionObject";
+ $cservice = $initconf->{default_cservice} || "SessionObject";
}
if ($app_path_info =~ s!:([a-zA-Z0-9_]+)$!!) {
$ctype = $1;
}
else {
- $ctype = $cgi->param("ctype") || "default";
+ $ctype = $cgi->param("ctype") || $initconf->{default_ctype} ||
"default";
}
if ($app_path_info =~ s!\.([a-zA-Z0-9_]+)\(([^\(\)]*)\)$!!) {
@@ -256,15 +260,15 @@
$cargs = $2;
}
else {
- $cmethod = $cgi->param("cmethod") || "content";
- $cargs = $cgi->param("cargs") || "";
+ $cmethod = $cgi->param("cmethod") || $initconf->{default_cmethod}
|| "content";
+ $cargs = $cgi->param("cargs") || $initconf->{default_cargs} ||
"";
}
if ($app_path_info =~ m!^/(.+)!) {
$cname = $1;
}
else {
- $cname = $cgi->param("cname") || "default";
+ $cname = $cgi->param("cname") || $initconf->{default_cname} ||
"default";
}
}
@@ -284,7 +288,7 @@
my (@eventvars, $var, @values, @tmp, $value, $mlhashkey, $name);
@eventvars = ();
foreach $var ($cgi->param()) {
- if ($var =~ /^app\.event/) {
+ if ($var =~ /^app\.event\./) {
push(@eventvars, $var);
}
elsif ($var =~ /^app.session/) {
@@ -321,6 +325,9 @@
$value = join(",",@values);
}
+ $context->dbgprint("Request::CGI->process() var=[$var]
value=[$value]")
+ if ($App::DEBUG && $context->dbg(1));
+
if ($var =~ /[\[\]\{\}\.]/) {
$context->so_set($var, "", $value);
}
@@ -347,6 +354,9 @@
# 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]")
+ if ($App::DEBUG && $context->dbg(1));
+
if ($key =~ /^app\.event\./) {
$args = "";
@@ -395,27 +405,38 @@
$key =~ s/^app\.event\.//; # get rid of prefix
$key =~ s/\(.*//; # get rid of args
+ $context->dbgprint("Request::CGI->process() key=[$key]
args=[@args]")
+ if ($App::DEBUG && $context->dbg(1));
+
if ($key =~ /^([^()]+)\.([a-zA-Z0-9_-]+)$/) {
$name = $1;
$event = $2;
if ($context->session_object_exists($name)) {
- $context->dbgprint($context->session_object($name),
- "->handle_event($name, $event, @args)
[Context/button]")
+ $context->dbgprint("Request::CGI->process()
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->process() $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($context->session_object($parent_name),
- "->handle_event($name, $event, @args)
[Context/button]")
+
+ $context->dbgprint("Request::CGI->process()
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")
+ if ($App::DEBUG && $context->dbg(1));
}
}
}
@@ -438,7 +459,7 @@
}
@args = split(/ *, */,$args) if ($args ne "");
- $context->dbgprint(ref($self), "->process[hidden]:
$name->$event(@args)")
+ $context->dbgprint("Request::CGI->process()
handle_event($name, $event, @args) [hidden/other]")
if ($App::DEBUG && $context->dbg(1));
$context->session_object($name)->handle_event($name,
$event, @args);
@@ -447,7 +468,7 @@
}
}
- $context->dbgprint("Request->process(): $cservice/$cname.$cmethod($cargs)
=> $ctype")
+ $context->dbgprint("Request->process(): $cservice/$cname.$cmethod($cargs)")
if ($App::DEBUG && $context->dbg(1));
if ($cservice) {
@@ -466,6 +487,7 @@
}
elsif ($#results == 0) {
$response->content($results[0]);
+ $response->content_type($service->content_type());
}
else {
$response->content(\@results);
@@ -473,27 +495,6 @@
}
}
}
-
- #eval {
- #};
- #if ($@) {
- # my ($msg);
- # if (ref($@) eq "") { # i.e. a string thrown with "die"
- # $msg = $@;
- # }
- # elsif ($@->isa("App::Exception")) {
- # $msg = $@->error . "\n" . $@->trace->as_string . "\n";
- # }
- # else {
- # $@->rethrow();
- # }
- # $msg =~ s{&}{&}gso;
- # $msg =~ s{<}{<}gso;
- # $msg =~ s{>}{>}gso;
- # $msg =~ s{\"}{"}gso;
- # $msg =~ s{\n}{<br>\n}gso;
- # $context->add_message($msg);
- #}
}
#############################################################################
1.6 +179 -66 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.5
retrieving revision 1.6
diff -u -w -r1.5 -r1.6
--- Context.pm 25 Oct 2002 13:05:17 -0000 1.5
+++ Context.pm 1 Nov 2002 19:56:08 -0000 1.6
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: Context.pm,v 1.5 2002/10/25 13:05:17 spadkins Exp $
+## $Id: Context.pm,v 1.6 2002/11/01 19:56:08 spadkins Exp $
#############################################################################
package App::Context;
@@ -122,7 +122,6 @@
$context->{debugscope}{$class.$method} Debugging a single method
$context->{initconf} Args that Context was created with
$context->{used}{$class} Similar to %INC, keeps track of what classes used
- $context->{cgi} (Context::CGI only) the CGI object
$context->{Conf}{$user} Info from conf file
[$context->{conf}]
$conf->{$type}{$name} Read-only service conf
@@ -191,6 +190,7 @@
$args = ($#_ > -1) ? { @_ } : {};
}
}
+ %args = %$args;
#################################################################
# DEBUGGING
@@ -214,23 +214,7 @@
}
}
- my ($debugfile);
- $debugfile = "";
- $debugfile = $self->{initconf}{debugfile} if (ref($self));
- if ($debugfile) {
- if ($debugfile !~ /^[>|]/) {
- $debugfile = ">> $debugfile";
- }
- if (open(main::DEBUGFILE, $debugfile)) {
- close(main::DEBUGFILE);
- }
- }
- else {
- print STDERR "Debug: ", @_, "\n";
- }
-
my ($conf_class, $session_class);
- %args = %$args;
$self->{initconf} = \%args;
$args{context} = $self;
@@ -276,6 +260,12 @@
};
$self->add_message($@) if ($@);
+ foreach my $key (keys %args) {
+ if ($key =~ /^set_(.+)$/) {
+ $self->so_default($1, "", $args{$key});
+ }
+ }
+
return $self;
}
@@ -645,6 +635,7 @@
=cut
+# Standard Services: provided in the App-Context distribution
sub serializer { my $self = shift; return $self->service("Serializer",@_);
}
sub call_dispatcher { my $self = shift; return
$self->service("CallDispatcher",@_); }
sub message_dispatcher { my $self = shift; return
$self->service("MessageDispatcher",@_); }
@@ -654,6 +645,12 @@
sub authorization { my $self = shift; return
$self->service("Authorization",@_); }
sub session_object { my $self = shift; return
$self->service("SessionObject",@_); }
+# Extended Services: provided in the App-Widget and App-Repository distributions
+# this is kind of cheating for the core to know about the extensions, but OK
+sub widget { my $self = shift; return
$self->service("SessionObject",@_); }
+sub template_engine { my $self = shift; return
$self->service("TemplateEngine",@_); }
+sub repository { my $self = shift; return $self->service("Repository",@_);
}
+
#############################################################################
# session_object_exists()
#############################################################################
@@ -697,19 +694,19 @@
my ($exists, $session_object_type, $session_object_class);
$session_object_class =
-
$self->{session}{cache}{SessionObject}{$session_object_name}{session_objectClass} ||
-
$self->{session}{store}{SessionObject}{$session_object_name}{session_objectClass} ||
- $self->{conf}{SessionObject}{$session_object_name}{session_objectClass};
+
$self->{session}{cache}{SessionObject}{$session_object_name}{sessionObjectClass} ||
+
$self->{session}{store}{SessionObject}{$session_object_name}{sessionObjectClass} ||
+ $self->{conf}{SessionObject}{$session_object_name}{sessionObjectClass};
if (!$session_object_class) {
$session_object_type =
-
$self->{session}{cache}{SessionObject}{$session_object_name}{session_objectType} ||
-
$self->{session}{store}{SessionObject}{$session_object_name}{session_objectType} ||
- $self->{conf}{SessionObject}{$session_object_name}{session_objectType};
+
$self->{session}{cache}{SessionObject}{$session_object_name}{sessionObjectType} ||
+
$self->{session}{store}{SessionObject}{$session_object_name}{sessionObjectType} ||
+ $self->{conf}{SessionObject}{$session_object_name}{sessionObjectType};
if ($session_object_type) {
- $session_object_class =
$self->{conf}{SessionObjectType}{$session_object_type}{session_objectClass};
+ $session_object_class =
$self->{conf}{SessionObjectType}{$session_object_type}{sessionObjectClass};
}
}
@@ -757,7 +754,13 @@
sub iget {
my ($self, $var, $default) = @_;
- my $value = $self->{initconf}{$var};
+ my ($value, $var2, $value2);
+ $value = $self->{initconf}{$var};
+ while ($value =~ /\{([^\{\}]+)\}/) {
+ $var2 = $1;
+ $value2 = $self->{initconf}{$var2};
+ $value =~ s/\{$var2\}/$value2/g;
+ }
$self->dbgprint("Context->iget($var) = [$value]")
if ($App::DEBUG && $self->dbg(3));
return (defined $value) ? $value : $default;
@@ -772,8 +775,12 @@
The so_get() returns the attribute of a session_object.
* Signature: $value = $context->so_get($session_objectname, $attribute);
+ * Signature: $value = $context->so_get($session_objectname, $attribute,
$default);
+ * Signature: $value = $context->so_get($session_objectname, $attribute,
$default, $setdefault);
* Param: $session_objectname string
* Param: $attribute string
+ * Param: $default any
+ * Param: $setdefault boolean
* Return: $value string,ref
* Throws: <none>
* Since: 0.01
@@ -934,6 +941,34 @@
}
#############################################################################
+# so_default()
+#############################################################################
+
+=head2 so_default()
+
+The so_default() sets the value of a SessionObject's attribute
+only if it is currently undefined.
+
+ * Signature: $value = $context->so_default($session_objectname, $attribute);
+ * Param: $session_objectname string
+ * Param: $attribute string
+ * Return: $value string,ref
+ * Throws: <none>
+ * Since: 0.01
+
+ Sample Usage:
+
+ $cname = $context->so_default("default", "cname");
+ $width = $context->so_default("main.app.toolbar.calc", "width");
+
+=cut
+
+sub so_default {
+ my ($self, $name, $var, $default) = @_;
+ $self->so_get($name, $var, $default, 1);
+}
+
+#############################################################################
# so_delete()
#############################################################################
@@ -1010,6 +1045,95 @@
}
#############################################################################
+# substitute()
+#############################################################################
+
+=head2 substitute()
+
+The substitute() method substitutes values of SessionObjects into target strings.
+
+ * Signature: $context->substitute($session_objectname, $attribute);
+ * Param: $session_objectname string
+ * Param: $attribute string
+ * Return: void
+ * Throws: <none>
+ * Since: 0.01
+
+ Sample Usage:
+
+ $context->substitute("default", "cname");
+ $context->substitute("main.app.toolbar.calc", "width");
+ $context->substitute("xyz", "{arr}[1][2]");
+ $context->substitute("xyz", "{arr.totals}");
+
+=cut
+
+sub substitute {
+ my ($self, $text, $values) = @_;
+ $self->dbgprint("Context->substitute()")
+ if ($App::DEBUG && $self->dbg(1));
+ my ($phrase, $var, $value);
+ $values = {} if (! defined $values);
+
+ if (ref($text) eq "HASH") {
+ my ($hash, $newhash);
+ $hash = $text; # oops, not text, but a hash of text values
+ $newhash = {}; # prepare a new hash for the substituted values
+ foreach $var (keys %$hash) {
+ $newhash->{$var} = $self->substitute($hash->{$var}, $values);
+ }
+ return($newhash); # short-circuit this whole process
+ }
+
+ while ( $text =~ /\[([^\[\]]+)\]/ ) {
+ $phrase = $1;
+ while ( $phrase =~ /\{([^\{\}]+)\}/ ) {
+ $var = $1;
+ if (defined $values->{$var}) {
+ $value = $values->{$var};
+ $phrase =~ s/\{$var\}/$value/g;
+ }
+ else {
+ if ($var =~ /^(.+)\.([^.]+)$/) {
+ $value = $self->so_get($1, $2);
+ if (defined $value) {
+ $phrase =~ s/\{$var\}/$value/g;
+ }
+ else {
+ $phrase = "";
+ }
+ }
+ else {
+ $phrase = "";
+ }
+ }
+ }
+ if ($phrase eq "") {
+ $text =~ s/\[[^\[\]]+\]\n?//; # zap it including (optional) ending
newline
+ }
+ else {
+ $text =~ s/\[[^\[\]]+\]/$phrase/;
+ }
+ }
+ while ( $text =~ /\{([^\{\}]+)\}/ ) { # vars of the form {var}
+ $var = $1;
+ if (defined $values->{$var}) {
+ $value = $values->{$var};
+ $text =~ s/\{$var\}/$value/g;
+ }
+ else {
+ $value = "";
+ if ($var =~ /^(.+)\.([^.]+)$/) {
+ $value = $self->so_get($1, $2);
+ }
+ }
+ $value = "" if (!defined $value);
+ $text =~ s/\{$var\}/$value/g;
+ }
+ $text;
+}
+
+#############################################################################
# PUBLIC METHODS
#############################################################################
@@ -1210,25 +1334,19 @@
my ($self, $domain) = @_;
my ($domain_conf, $domain_session, $repository, $rep);
my ($values, $labels, $needs_loading, $time_to_live, $time);
- my ($class, $method, $args, $rows, $row);
+ my ($method, $args, $rows, $row);
$self->dbgprint("Context->domain($domain)")
if ($App::DEBUG && $self->dbg(1));
- $domain_conf = $self->{conf}{Domain}{$domain};
- $domain_session = $self->{session}{Domain}{$domain};
- $domain_conf = {} if (!defined $domain_conf);
- $domain_session = {} if (!defined $domain_session);
+ $domain_conf = $self->{conf}{Domain}{$domain} || {};
+ $domain_session = $self->{session}{Domain}{$domain} || {};
- $values = $domain_session->{values};
- $values = $domain_conf->{values} if (!$values);
-
- $labels = $domain_session->{labels};
- $labels = $domain_conf->{labels} if (!$labels);
+ $values = $domain_session->{values} || $domain_conf->{values};
+ $labels = $domain_session->{labels} || $domain_conf->{labels};
$needs_loading = 0;
- $repository = $domain_session->{repository};
- $repository = $domain_conf->{repository} if (!$repository);
+ $repository = $domain_conf->{repository};
if (defined $repository && $repository ne "") {
if (!defined $values || !defined $labels) {
@@ -1253,31 +1371,26 @@
if ($App::DEBUG && $self->dbg(1));
if ($needs_loading) {
+
$rep = $self->repository($repository);
- if (defined $rep) {
- #$method = $domain_session->{getmethod};
- #$method = "get" if (!defined $method);
- #$args = $domain_session->{getmethod_args};
- #$args = [ $domain ] if (!defined $args);
-
- #$self->dbgprint("Context->domain($domain): $rep->$method(@$args)")
- # if ($App::DEBUG && $self->dbg(1));
-
- #$rows = ${rep}->${method}(@$args);
- #$values = [];
- #$labels = {};
- #foreach $row (@$rows) {
- # push(@$values, $row->[0]);
- # $labels->{$row->[0]} = $row->[1];
- #}
- #$domain_session->{values} = $values;
- #$domain_session->{labels} = $labels;
- #$time = time();
- #$domain_session->{time} = $time;
+ $table = $domain_conf->{table};
+ $keycolumn = $domain_conf->{keycolumn};
+ $valuecolumn = $domain_conf->{valuecolumn};
+ $paramvalues = $domain_conf->{paramvalues};
+
+ if ($rep && $table && $keycolumn && $valuecolumn && $paramvalues) {
+ $rows = $rep->select_rows($table, [ $keycolumn, $valuecolumn ],
undef, $paramvalues);
+ $values = [];
+ $labels = {};
+ foreach $row (@$rows) {
+ push(@$values, $row->[0]);
+ $labels->{$row->[0]} = $row->[1];
+ }
+ $domain_session->{values} = $values;
+ $domain_session->{labels} = $labels;
+ $time = time();
+ $domain_session->{time} = $time;
}
-
- $values = $domain_session->{values};
- $labels = $domain_session->{labels};
}
$values = [] if (! defined $values);
@@ -1378,8 +1491,8 @@
sub dbgprint {
my $self = shift;
- if (defined main::DEBUGFILE) {
- print main::DEBUGFILE $$, ": ", @_, "\n";
+ if (defined $main::conf{debugfile}) {
+ print App::DEBUGFILE $$, ": ", @_, "\n";
}
else {
print STDERR "Debug: ", @_, "\n";
