cvsuser 02/09/17 19:54:11
Modified: App-Context/lib App.pm
App-Context/lib/App Context.pm Response.pm Session.pm
App-Context/lib/App/Context CGI.pm HTML.pm HTTPHTML.pm
NetServer.pm SimpleServer.pm
App-Context/lib/App/Request CGI.pm
App-Context/lib/App/Session Cookie.pm HTMLHidden.pm
Added: App-Context/bin app
App-Context/lib/Apache App.pm
App-Context/lib/App UserAgent.pm
App-Context/lib/App/Context HTTP.pm
App-Context/lib/App/Response HTML.pm
App-Context/t Procedure.t
Log:
updated a good bit
Revision Changes Path
1.1 p5ee/App-Context/bin/app
Index: app
===================================================================
#!perl -wT
#############################################################################
# $Id: app,v 1.1 2002/09/18 02:54:10 spadkins Exp $
#############################################################################
BEGIN {
my ($var, $value, $open, $file, $path_part);
my ($app_path_info, $default_wname);
local(*FILE);
$app_path_info = "";
$app_path_info = $ENV{PATH_INFO} if (defined $ENV{PATH_INFO});
$file = "";
$path_part = "";
if ($app_path_info =~ s!^/([^/]+)!!) {
$path_part = $1;
$file = "$path_part.conf"; # initialization config file
}
$open = 0; # assume we cannot find an openable config file ...
$open = open(main::FILE, "< $file") if ($file && !$open);
if ($open) {
$default_wname = "";
if ($app_path_info =~ s!^/([^/]+)!!) {
$default_wname = $1; # default widget name
}
}
else {
$default_wname = $path_part;
}
$open = open(main::FILE, "< $0.conf") if (!$open);
$open = open(main::FILE, "< app.conf") if (!$open);
%main::conf = ();
if ($open) {
while (<main::FILE>) {
chomp;
s/#.*$//; # delete comments
s/^ +//; # delete leading spaces
s/ +$//; # delete trailing spaces
next if (/^$/); # skip blank lines
# look for "var = value" (ignore other lines)
if (/^([a-zA-Z_.-]+) *= *(.*)/) { # untainting also happens
$var = $1;
$value = $2;
$main::conf{$var} = $value; # save all in %main::conf
}
}
close(main::FILE);
if (defined $main::conf{perlinc}) { # add perlinc entries
unshift(@INC, split(/[ ,]+/,$main::conf{perlinc}));
}
}
$main::conf{defaultWname} = $default_wname if ($default_wname);
$main::conf{app_path_info} = $app_path_info if ($app_path_info);
}
#################################################################
# read command-line configuration variables
# (anything starting with one or two dashes is a config var, not a CGI var)
# i.e. --debugmode=record -debugmode=replay
# an option without an "=" (i.e. --help) acts as --help=1
#################################################################
while ($#ARGV >= 0 && $ARGV[0] =~ /^--?([^=-][^=]*)(=?)(.*)/) {
$var = $1;
$value = ($2 eq "") ? 1 : $3;
shift @ARGV;
$main::conf{$var} = $value;
}
use App;
#################################################################
# NOTE: some Context classes (e.g. Context::CGI) also read in
# the environment and store it in the %main::conf.
#################################################################
my $context = App->context(\%main::conf);
$context->dispatch_events();
1.2 +75 -19 p5ee/App-Context/lib/App.pm
Index: App.pm
===================================================================
RCS file: /cvs/public/p5ee/App-Context/lib/App.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- App.pm 9 Sep 2002 01:34:10 -0000 1.1
+++ App.pm 18 Sep 2002 02:54:10 -0000 1.2
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: App.pm,v 1.1 2002/09/09 01:34:10 spadkins Exp $
+## $Id: App.pm,v 1.2 2002/09/18 02:54:10 spadkins Exp $
#############################################################################
package App;
@@ -42,18 +42,53 @@
=head1 Distribution: App-Context
-The App-Context distribution is a set of files implementing the
-Perl 5 Enterprise Environment. See the following web pages for
-more information about this project.
+The App-Context distribution is the core set of modules implementing
+the core of an enterprise application development framework.
- http://p5ee.perl.org/
- http://www.officevision.com/pub/p5ee/
+ http://www.officevision.com/pub/App-Context
* Version: 0.01
+It provides the following services.
+
+ * Application Configuration (App::Conf::*)
+ * Session Management (App::Session::*)
+ * Remote Procedure Call (App::Procedure::*)
+ * Session Objects and Remote Method Invocation (App::SessionObject::*)
+ * Multiprocess-safe Name-Value Storage (App::SharedDatastore::*)
+ * Shared Resource Pooling and Locking (App::SharedResourceSet::*)
+
+One of App-Context's extended services (App::Repository::*)
+adds distributed transaction capabilities and access to data
+from a variety of sources through a uniform interface.
+
+In the same distribution (App-Repository), is a base class,
+App::RepositoryObject, which serves as the base class for
+implementing persistent business objects.
+
+ http://www.officevision.com/pub/App-Repository
+
+Another of App-Context's extended services (App::Widget::*)
+adds simple and complex active user interface widgets.
+These widgets can be used to supplement an existing application's
+user interface technology (template systems, hard-coded HTML, etc.)
+or the Widget system can be used as the central user interface paradigm.
+
+ http://www.officevision.com/pub/App-Widget
+
+App-Context and its extended service distributions were
+inspired by work on the Perl 5 Enterprise Environment project,
+and its goal is to satisfy the all of the requirements embodied in
+the Attributes of an Enterprise System.
+
+See the following web pages for more information about the P5EE project.
+
+ http://p5ee.perl.org/
+ http://www.officevision.com/pub/p5ee/
+
=head2 Distribution Requirements
-The following are enumerated requirements for the P5EE distribution.
+The following are enumerated requirements for the App-Context distribution.
It forms a high-level feature list.
The requirements which have been satisfied
(or features implemented) have an "x" by them, whereas the requirements
@@ -64,8 +99,8 @@
o a Software Architecture supporting many Platforms
http://www.officevision.com/pub/p5ee/platform.html
o a pluggable interface/implementation service architecture
- o support developers who wish to use portions of the P5EE
- without giving up their other styles of programming
+ o support developers who wish to use portions of the App-Context
+ framework without giving up their other styles of programming
(and support gradual migration)
=head2 Distribution Design
@@ -73,11 +108,12 @@
The distribution is designed in such a way that most of the functionality
is actually provided by modules outside the App namespace.
-The goal of the P5EE is to bring together many technologies to make a
+The goal of the App-Context framework
+is to bring together many technologies to make a
unified whole. In essence, it is collecting and unifying the good work
of a multitude of excellent projects which have already been developed.
This results in a Pluggable Service design which allows just about
-everything in P5EE to be customized. These Class Groups are described
+everything in App-Context to be customized. These Class Groups are described
in detail below.
Where a variety of excellent, overlapping or redundant, low-level modules
@@ -86,12 +122,13 @@
written to explain the pros and cons of each.
Where uniquely excellent modules exist on CPAN, they are named outright
-as the standard for the P5EE project. They are identified as dependencies
-in the P5EE CPAN Bundle file.
+as the standard for the App-Context framework.
+They are identified as dependencies
+in the App-Context CPAN Bundle file.
=head2 Class Groups
-The major Class Groups in the P5EE distribution fall into three categories:
+The major Class Groups in the App-Context distribution fall into three categories:
Core, Core Services, and Services.
=over
@@ -154,7 +191,7 @@
=item * Document: L<C<Podstyle, POD Documentation Guide>|App::podstyle>
-=item * Document: L<C<Datetime, Dates and Times in P5EE>|App::datetime>
+=item * Document: L<C<Datetime, Dates and Times in App-Context>|App::datetime>
=back
@@ -407,7 +444,7 @@
$context = App->context();
$context = App->context(
- contextClass => "App::Context::CGI",
+ contextClass => "App::Context::HTTP",
confFile => "app.xml",
);
@@ -464,10 +501,10 @@
else { # try autodetection ...
my $gateway = $ENV{GATEWAY_INTERFACE};
if (defined $gateway && $gateway =~ /CGI-Perl/) { # mod_perl?
- $args->{contextClass} = "App::Context::Modperl";
+ $args->{contextClass} = "App::Context::HTTP";
}
elsif ($ENV{HTTP_USER_AGENT}) { # running as CGI script?
- $args->{contextClass} = "App::Context::CGI";
+ $args->{contextClass} = "App::Context::HTTP";
}
# let's be real... these next two are not critical right now
#elsif ($ENV{DISPLAY}) { # running with an X DISPLAY var set?
@@ -477,7 +514,7 @@
# $args->{contextClass} = "App::Context::Curses";
#}
else { # fall back to CGI, because it works OK in command mode
- $args->{contextClass} = "App::Context::CGI";
+ $args->{contextClass} = "App::Context::HTTP";
}
}
}
@@ -526,6 +563,25 @@
}
$self->context($args)->conf();
+}
+
+#############################################################################
+# info()
+#############################################################################
+
+=head2 info()
+
+ * Signature: $ident = App->info();
+ * Param: void
+ * Return: $ident string
+ * Throws: App::Exception
+ * Since: 0.01
+
+=cut
+
+sub info {
+ my $self = shift;
+ "App-Context ($App::VERSION)";
}
=head1 ACKNOWLEDGEMENTS
1.1 p5ee/App-Context/lib/Apache/App.pm
Index: App.pm
===================================================================
package Apache::App;
use Apache ();
use App;
my %env = %ENV;
my $context;
sub handler {
my $r = shift;
if ($ENV{PATH_INFO} eq "/show") {
&show($r);
return;
}
my ($msg, $response);
# INITIALIZE THE CONTEXT THE FIRST TIME THIS APACHE CHILD PROCESS
# RECEIVES A REQUEST (should I do this sooner? at child init?)
# (so that the first request does not need to bear the extra burden)
# Also, the App class would cache the $context for me
# if I didn't want to cache it myself. But then I would have to
# prepare the %initconf every request. hmmm...
# I don't suppose the $r->dir_config() call is expensive.
if (!defined $context) {
my %initconf = %{$r->dir_config()};
if (!defined $initconf{contextClass}) {
$initconf{contextClass} = "App::Context::ModPerl";
}
eval {
$context = App->context(\%initconf);
};
$msg = $@ if ($@);
}
# this should always be true
if (defined $context) {
# the response will be emitted from within dispatch_events()
$context->dispatch_events();
}
else {
# we had an error (maybe App-Context not installed? Perl @INC not set?)
$response = <<EOF;
Content-type: text/plain
Unable to create an App::Context.
$msg
EOF
$r->print($response);
}
}
sub show {
my $r = shift;
my $header = <<EOF;
Content-type: text/plain
Welcome to Apache::App
EOF
$r->print($header);
print $r->as_string();
$r->print("\n");
$r->print("ENVIRONMENT VARIABLES\n");
$r->print("\n");
foreach my $var (sort keys %ENV) {
$r->print("$var=$ENV{$var}\n");
}
$r->print("\n");
$r->print("ENVIRONMENT VARIABLES (at startup)\n");
$r->print("\n");
foreach my $var (sort keys %env) {
$r->print("$var=$env{$var}\n");
}
$r->print("\n");
$r->print("DIRECTORY CONFIG\n");
$r->print("\n");
my %initconf = %{$r->dir_config()};
foreach my $var (sort keys %initconf) {
$r->print("$var=$initconf{$var}\n");
}
}
1;
1.2 +11 -10 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.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- Context.pm 9 Sep 2002 01:34:10 -0000 1.1
+++ Context.pm 18 Sep 2002 02:54:10 -0000 1.2
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: Context.pm,v 1.1 2002/09/09 01:34:10 spadkins Exp $
+## $Id: Context.pm,v 1.2 2002/09/18 02:54:10 spadkins Exp $
#############################################################################
package App::Context;
@@ -226,7 +226,7 @@
# -debug=1 (global debug)
# -debug=1,App::Context (debug class only)
# -debug=3,App::Context,App::Session (multiple classes)
- # -debug=6,App::Repository::DBI.select_rows (individual methods)
+ # -debug=6,App::Repository::DBI.select_rows (indiv. methods)
my ($debug, $pkg);
$debug = $args{debug};
if (defined $debug && $debug ne "") {
@@ -1318,15 +1318,16 @@
my ($file);
$file = "";
$file = $self->{initconf}{debugfile} if (ref($self));
- if (! $file) {
- print STDOUT "Debug: ", @_, "\n";
- }
- else {
+ if ($file) {
+ $file = ">> $file" if ($self->{initconf}{debugappend});
local(*FILE);
- if (open(main::FILE, ">> $file")) {
+ if (open(main::FILE, $file)) {
print main::FILE $$, ": ", @_, "\n";
close(main::FILE);
}
+ }
+ else {
+ print STDERR "Debug: ", @_, "\n";
}
}
1.2 +5 -17 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.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- Response.pm 9 Sep 2002 01:34:10 -0000 1.1
+++ Response.pm 18 Sep 2002 02:54:10 -0000 1.2
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: Response.pm,v 1.1 2002/09/09 01:34:10 spadkins Exp $
+## $Id: Response.pm,v 1.2 2002/09/18 02:54:10 spadkins Exp $
#############################################################################
package App::Response;
@@ -89,23 +89,11 @@
my $self = {};
bless $self, $class;
- my ($args, $i);
- if ($#_ > -1) {
- if (ref($_[0]) eq "HASH") {
- $args = shift;
- %$self = %$args;
- pop if ($#_ % 2 == 0); # throw away odd arg (probably should throw
exception)
- for ($i = 0; $i < $#_; $i++) {
- $self->{$_[$i]} = $_[$i+1];
- }
- }
- else {
- pop if ($#_ % 2 == 0); # throw away odd arg (probably should throw
exception)
- %$self = (@_) if ($#_ > -1);
- }
- }
+ my $context = shift;
+ $self->{context} = $context;
- $self->init(\%args);
+ my $args = shift || {};
+ $self->init($args);
return $self;
}
1.2 +2 -2 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.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- Session.pm 9 Sep 2002 01:34:10 -0000 1.1
+++ Session.pm 18 Sep 2002 02:54:10 -0000 1.2
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: Session.pm,v 1.1 2002/09/09 01:34:10 spadkins Exp $
+## $Id: Session.pm,v 1.2 2002/09/18 02:54:10 spadkins Exp $
#############################################################################
package App::Session;
@@ -183,7 +183,7 @@
my ($self, $options) = @_;
my ($session_id, $html);
$session_id = $self->get_session_id();
- $html = "<input type=\"hidden\" name=\"p5ee.session_id\"
value=\"$session_id\">";
+ $html = "<input type=\"hidden\" name=\"app.session_id\" value=\"$session_id\">";
$html;
}
1.1 p5ee/App-Context/lib/App/UserAgent.pm
Index: UserAgent.pm
===================================================================
#############################################################################
## $Id: UserAgent.pm,v 1.1 2002/09/18 02:54:10 spadkins Exp $
#############################################################################
package App::UserAgent;
use strict;
use App;
=head1 NAME
App::UserAgent - the browser this session is connected to
=head1 SYNOPSIS
# ... official way to get a UserAgent object ...
use App;
$context = App->context();
$user_agent = $context->user_agent(); # get the user_agent
if ($user_agent->supports("html.input.style")) {
# do something
}
=cut
#############################################################################
# CONSTANTS
#############################################################################
=head1 DESCRIPTION
A UserAgent class models the browser connected to this session.
It is used to determine what capabilities are supported by the user agent.
=cut
#############################################################################
# CONSTRUCTOR METHODS
#############################################################################
=head1 Constructor Methods:
=cut
#############################################################################
# new()
#############################################################################
=head2 new()
The App::UserAgent->new() method is rarely called directly.
That is because a $user_agent should always be instantiated by getting
it from the $context [ $context->user_agent() ].
* Signature: $user_agent = App::UserAgent->new($context);
* Signature: $user_agent = App::UserAgent->new();
* Param: $context App::Context
* Return: $user_agent App::UserAgent
* Throws: <none>
* Since: 0.01
Sample Usage:
[Common Use]
$context = App->context();
$user_agent = $context->user_agent();
[Internal Use Only]
$user_agent = App::UserAgent->new();
=cut
sub new {
my $this = shift;
my $class = ref($this) || $this;
my $self = {};
bless $self, $class;
my ($context) = @_;
$self->{context} = $context;
if (defined $context) {
$self->{http_user_agent} = $context->iget("http_user_agent");
}
else {
$self->{http_user_agent} =
(defined $ENV{HTTP_USER_AGENT}) ?
$ENV{HTTP_USER_AGENT} :
"unknown";
}
my ($uatype, $uaver, $ostype, $osver, $arch, $ualang, $lang);
($uatype, $uaver, $ostype, $osver, $arch, $ualang) =
$self->parse($self->{http_user_agent});
if (defined $context) {
$lang = $context->iget("http_user_agent");
}
elsif (defined $ENV{HTTP_ACCEPT_LANGUAGE}) {
$lang = lc($ENV{HTTP_ACCEPT_LANGUAGE});
$lang =~ s/[ ,].*//;
}
$self->{uatype} = $uatype;
$self->{uaver} = $uaver;
$self->{ostype} = $ostype;
$self->{osver} = $osver;
$self->{arch} = $arch;
$self->{lang} = $lang;
$self->{supports} = $self->get_support_matrix($uatype, $uaver,
$ostype, $osver, $arch, $lang);
return $self;
}
#############################################################################
# PUBLIC METHODS
#############################################################################
=head1 Public Methods
=cut
#############################################################################
# supports()
#############################################################################
=head2 supports()
The supports() method returns whether or not a "feature" or "capability" is
supported by a user agent (browser).
* Signature: $bool = $self->supports($capability);
* Param: $capability string
* Return: $bool boolean
* Throws: <none>
* Since: 0.01
Sample Usage:
if ($ua->supports("html.input.style")) {
# do something
}
The following are some of the types of capabilities that the
browser may or may not support.
The capability categorization scheme is derived from the O'Reilly book,
"Dynamic HTML: The Definitive Reference", which has sections on HTML,
DOM, CSS, and JavaScript. Java and HTTP capabilities are also
defined. Finally, hints are defined which simply tell the widgets what
to use on certain browsers.
html.<tag>
html.<tag>.<attrib>
html.input.style
html.input.style.border-width
dom
dom.<objectClass>
dom.<objectClass>.<attribute>
style
style.css1
style.css2
style.<attribute>
js
js.1.0
js.1.1
js.1.2
js.<class>.<method>
js.<class>.<attribute>
java.1.0.0
java.1.2.2
java.1.3.0
http.header.accept-encoding.x-gzip
http.header.accept-encoding.x-compress
widget.Stylizable.style
=cut
sub supports {
my ($self, $capability) = @_;
# return immediately if support for the capability is already determined
if (defined $self->{supports}{$capability}) {
return ($self->{supports}{$capability});
}
if ($capability eq "http.header.accept-encoding.x-gzip") {
my ($request, $accept_header, $support_status);
$request = $self->{context}->request();
$accept_header = $request->header("Accept-Encoding");
$support_status = ($accept_header =~ /gzip/) ? 1 : 0;
$self->{supports}{$capability} = $support_status;
return $support_status;
}
# see if this capability has a "parent" capability
if ($capability =~ /^(.*)\.([^\.]+)$/) {
# we support it if we support its parent capability
$self->{supports}{$capability} = $self->supports($1);
}
else {
# assume we support everything unless otherwise informed
$self->{supports}{$capability} = 1;
}
return $self->{supports}{$capability};
}
#############################################################################
# get()
#############################################################################
=head2 get()
The get() method retrieves attributes of the user agent.
* Signature: $bool = $self->parse($http_user_agent);
* Param: $http_user_agent string
* Return: $bool boolean
* Throws: <none>
* Since: 0.01
Sample Usage:
$http_user_agent = "Mozilla/4.0 (compatible; MSIE 5.5; Windows NT)";
@ua = $user_agent->parse($http_user_agent);
@ua = $App::UserAgent->parse($ENV{HTTP_USER_AGENT});
($uatype, $uaver, $ostype, $osver, $arch, $lang) = @ua;
The following attributes of the $user_agent are also defined.
The bracketed values ([value]) are the defaults if no other value can
be determined by the HTTP_USER_AGENT string and the other HTTP headers.
uatype - User Agent type (i.e. [unknown], NS, IE, Opera, Konqueror, Mozilla)
uaver - User Agent version (i.e. [1.0], 4.0, 4.7, 5.01) (always numeric)
ostype - Oper System type (i.e. [unknown], Windows, Macintosh, Linux,
FreeBSD, HP-UX, SunOS, AIX, IRIX, OSF1)
osver - Oper System version (i.e. [unknown], 16, 3.1, 95, 98, 2000, ME, NT 5.1)
arch - Hardware Architecture (i.e. [unknown], i386, i586, i686, ppc, sun4u,
9000/835)
lang - Preferred Language (i.e. [en], en-us, fr-ca, ja, de)
There is very little reason for any Widget code to call get() directly.
Widgets should rather use the supports() method to determine whether a
capability is supported by the browser. The supports method will
consult these attributes and its capability matrix to determine whether
the capability is supported or not.
sub get {
my ($self, $attribute) = @_;
$self->{$attribute};
}
#############################################################################
# parse()
#############################################################################
=head2 parse()
The parse() method parses an HTTP_USER_AGENT string and returns the
resulting attributes of the browser.
* Signature: $bool = $self->parse($http_user_agent);
* Param: $http_user_agent string
* Return: $bool boolean
* Throws: <none>
* Since: 0.01
Sample Usage:
$http_user_agent = "Mozilla/4.0 (compatible; MSIE 5.5; Windows NT)";
@ua = $user_agent->parse($http_user_agent);
@ua = $App::UserAgent->parse($ENV{HTTP_USER_AGENT});
($uatype, $uaver, $ostype, $osver, $arch, $lang) = @ua;
Note: Two additional attributes, $mozver and $iever are probably going to
be needed. They represent the Netscape/Mozilla version that the software
claims to operate like (IE has always included this) and the IE version
that the software claims to operate like (Opera includes this).
This will allow for a cascading of one type of compatibility matrix into
another.
=cut
sub parse {
my ($self, $http_user_agent) = @_;
my ($uatype, $uaver, $ostype, $osver, $arch, $lang);
my ($ua);
$uatype = "unknown"; # NS, IE, Opera, Konqueror, Mozilla, unknown
$uaver = 1.0; # 4.0, 4.7, 5.01
if ($http_user_agent =~ /MSIE[ \+\/]*([0-9][\.0-9]*)/) {
$uatype = "IE"; # MS Internet Explorer
$uaver = $1;
}
elsif ($http_user_agent =~ /Gecko[ \+\/]*([0-9][\.0-9]*)/) {
$uatype = "Mozilla"; # from www.mozilla.org
$uaver = $1;
}
# Opera should be first (unless we are OK to believe it is really MSIE)
elsif ($http_user_agent =~ /Opera[ \+\/]*([0-9][\.0-9]*)/) {
$uatype = "Opera";
$uaver = $1;
}
elsif ($http_user_agent =~ /Konqueror[ \+\/]*([0-9][\.0-9]*)/) {
$uatype = "Konqueror";
$uaver = $1;
}
elsif ($http_user_agent =~ /Mozilla[ \+\/]*([0-9][\.0-9]*)/) {
$uatype = "NS"; # the original Mozilla browser
$uaver = $1;
}
# ostype/osver
$ostype = "unknown"; # Windows, Macintosh, Linux, FreeBSD, HP-UX, SunOS
$osver = "unknown"; # 16, 3.1, 95, 98, 2000, ME, CE, NT 5.1
$arch = "unknown"; # i386, i586, i686, PPC
$lang = "en"; # en, en-US, ja, de
$ua = $http_user_agent;
$ua =~ s/\+/ /g;
$ua =~ s/Service Pack /SP/g;
if ($ua =~ /Win/) {
if ($ua =~ /Win16/) {
$ostype = "Windows";
$osver = "16";
}
elsif ($ua =~ /Win32/) {
$ostype = "Windows";
$osver = "32";
}
elsif ($ua =~ /Win(9[58x])/) {
$ostype = "Windows";
$osver = $1;
}
elsif ($ua =~ /Win(NT *[SP0-9. ]*)/) {
$ostype = "Windows";
$osver = $1;
$osver =~ s/ +$//;
}
elsif ($ua =~ /Windows *([239MCX][A-Z0-9. \/]*)/) {
$ostype = "Windows";
$osver = $1;
$osver =~ s/ +$//;
}
}
if ($ostype eq "unknown") { # haven't found it yet
if ($ua =~ /Linux/) {
$ostype = "Linux";
if ($ua =~ /Linux +([0-9][0-9\.a-z-]*) +([a-zA-Z0-9-]+)/) {
$osver = $1;
$arch = $2;
}
elsif ($ua =~ /Linux +([0-9][0-9\.a-z-]*)/) {
$osver = $1;
}
}
elsif ($ua =~ /X11/) {
$ostype = "X11";
}
}
# arch
if ($http_user_agent =~ /MSIE[ \+]?([0-9][\.0-9]*)/) {
$uatype = "IE";
$uaver = $1;
}
# lang
if ($http_user_agent =~ /\[([a-zA-Z]{2})\]/) {
$lang = $1;
}
elsif ($http_user_agent =~ /\[([a-zA-Z]{2}[-_][a-zA-Z]{2})\]/) {
$lang = $1;
}
return ($uatype, $uaver, $ostype, $osver, $arch, $lang);
}
#############################################################################
# PROTECTED METHODS
#############################################################################
=head1 Protected Methods
=cut
#############################################################################
# get_support_matrix()
#############################################################################
=head2 get_support_matrix()
The get_support_matrix() method returns whether or not a "feature" or "capability" is
supported by a user agent (browser).
* Signature: $support_matrix = $ua->get_support_matrix($uatype, $uaver, $ostype,
$osver, $arch, $lang);
* Param: $uatype string
* Param: $uaver float
* Param: $ostype string
* Param: $osver string
* Param: $arch string
* Param: $lang string
* Return: $support_matrix {}
* Throws: <none>
* Since: 0.01
Sample Usage:
$support_matrix = $self->get_support_matrix($uatype, $uaver, $ostype, $osver,
$arch, $lang);
The following are some of the types of capabilities that the
browser may or may not support.
=cut
sub get_support_matrix {
my ($self, $uatype, $uaver, $ostype, $osver, $arch, $lang) = @_;
my ($support_matrix);
# eventually, this will probably attach to an external DBM-style
# capabilities database. But for now, we just need a few features.
$support_matrix = {};
if ($uatype eq "NS" && $uaver <= 4.7) {
$support_matrix->{"widget.Stylizable.style"} = 0;
}
else {
$support_matrix->{"widget.Stylizable.style"} = 1;
}
return $support_matrix;
}
1;
1.2 +12 -12 p5ee/App-Context/lib/App/Context/CGI.pm
Index: CGI.pm
===================================================================
RCS file: /cvs/public/p5ee/App-Context/lib/App/Context/CGI.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- CGI.pm 9 Sep 2002 01:34:11 -0000 1.1
+++ CGI.pm 18 Sep 2002 02:54:11 -0000 1.2
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: CGI.pm,v 1.1 2002/09/09 01:34:11 spadkins Exp $
+## $Id: CGI.pm,v 1.2 2002/09/18 02:54:11 spadkins Exp $
#############################################################################
package App::Context::CGI;
@@ -149,11 +149,11 @@
else { # ... the normal path
if (defined $args && defined $args->{cgi}) {
# this allows for migration from old scripts where they already
- # read in the CGI object and they pass it in to P5EE as an arg
+ # read in the CGI object and they pass it in to App-Context as an arg
$cgi = $args->{cgi};
}
else {
- # this is the normal path for P5EE execution, where the Context::CGI
+ # this is the normal path for App-Context execution, where the
Context::CGI
# is responsible for reading its environment
$cgi = CGI->new();
$args->{cgi} = $cgi if (defined $args);
@@ -434,18 +434,18 @@
##########################################################
# For each CGI variable, do the appropriate thing
- # 1. "p5ee.event.*" variable is an event and gets handled last
- # 2. "p5ee.*" variable is a "multi-level hash key" under $self
+ # 1. "app.event.*" variable is an event and gets handled last
+ # 2. "app.*" variable is a "multi-level hash key" under $self
# 3. "wname{m}[1]" variable is a "multi-level hash key" under
$self->{widget}{$wname}
# 4. "wname" variable is a "multi-level hash key"
##########################################################
my (@eventvars, $var, @values, $value, $mlhashkey, $name);
@eventvars = ();
foreach $var ($cgi->param()) {
- if ($var =~ /^p5ee\.event/) {
+ if ($var =~ /^app\.event/) {
push(@eventvars, $var);
}
- elsif ($var =~ /^p5ee.session/) {
+ elsif ($var =~ /^app.session/) {
# do nothing.
# these vars are used in the Session restore() to restore state.
}
@@ -491,10 +491,10 @@
foreach $key (@eventvars) {
# These events come from <input type=submit> type controls
- # The format is name="p5ee.event.{widgetName}.{event}(args)"
+ # The format is name="app.event.{widgetName}.{event}(args)"
# Note: this format is important because the "value" is needed for
display purposes
- if ($key =~ /^p5ee\.event\./) {
+ if ($key =~ /^app\.event\./) {
$args = "";
@args = ();
@@ -524,7 +524,7 @@
push(@args, $cgi->param($key)); # tack the label on at
the end
}
- $key =~ s/^p5ee\.event\.//; # get rid of prefix
+ $key =~ s/^app\.event\.//; # get rid of prefix
$key =~ s/\(.*//; # get rid of args
if ($key =~ /^([^()]+)\.([a-zA-Z0-9_-]+)$/) {
@@ -550,11 +550,11 @@
}
}
}
- elsif ($key eq "p5ee.event") {
+ elsif ($key eq "app.event") {
# These events come from <input type=hidden> type controls
# They are basically call-backs so that the widget could clean
up something before being viewed
- # The format is name="p5ee.event" value="{widgetName}.{event}"
+ # The format is name="app.event" value="{widgetName}.{event}"
foreach $value ($cgi->param($key)) {
if ($value =~ /^([^()]+)\.([a-zA-Z0-9_-]+)/) {
1.2 +4 -4 p5ee/App-Context/lib/App/Context/HTML.pm
Index: HTML.pm
===================================================================
RCS file: /cvs/public/p5ee/App-Context/lib/App/Context/HTML.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- HTML.pm 9 Sep 2002 01:34:11 -0000 1.1
+++ HTML.pm 18 Sep 2002 02:54:11 -0000 1.2
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: HTML.pm,v 1.1 2002/09/09 01:34:11 spadkins Exp $
+## $Id: HTML.pm,v 1.2 2002/09/18 02:54:11 spadkins Exp $
#############################################################################
package App::Context::HTML;
@@ -95,9 +95,9 @@
$current_widget = $self->{cgi}->param("wname");
$self->wset("session","current_widget",$current_widget) if
($current_widget);
- # maybe we can find it in the {initconfig}
- if (!$current_widget && defined $self->{initconfig}{defaultWname}) {
- $current_widget = $self->{initconfig}{defaultWname};
+ # maybe we can find it in the {initconf}
+ if (!$current_widget && defined $self->{initconf}{defaultWname}) {
+ $current_widget = $self->{initconf}{defaultWname};
$self->wset("session","current_widget",$current_widget) if
($current_widget);
}
1.2 +6 -6 p5ee/App-Context/lib/App/Context/HTTPHTML.pm
Index: HTTPHTML.pm
===================================================================
RCS file: /cvs/public/p5ee/App-Context/lib/App/Context/HTTPHTML.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- HTTPHTML.pm 9 Sep 2002 01:34:11 -0000 1.1
+++ HTTPHTML.pm 18 Sep 2002 02:54:11 -0000 1.2
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: HTTPHTML.pm,v 1.1 2002/09/09 01:34:11 spadkins Exp $
+## $Id: HTTPHTML.pm,v 1.2 2002/09/18 02:54:11 spadkins Exp $
#############################################################################
package App::Context::HTTPHTML;
@@ -184,7 +184,7 @@
my $request_class = $self->iget("requestClass", "App::Request::CGI");
eval {
- $self->{request} = App->new($request_class, "new", $self,
$self->{initconfig});
+ $self->{request} = App->new($request_class, "new", $self,
$self->{initconf});
};
$self->add_message($@) if ($@);
@@ -223,7 +223,7 @@
my $response_class = $self->iget("responseClass", "App::Response::CGI");
eval {
- $self->{response} = App->new($response_class, "new", $self,
$self->{initconfig});
+ $self->{response} = App->new($response_class, "new", $self,
$self->{initconf});
};
$self->add_message($@) if ($@);
@@ -275,9 +275,9 @@
$current_widget = $self->request()->get_default_widget();
$self->wset("session","current_widget",$current_widget) if
($current_widget);
- # maybe we can find it in the {initconfig}
- if (!$current_widget && defined $self->{initconfig}{defaultWname}) {
- $current_widget = $self->{initconfig}{defaultWname};
+ # maybe we can find it in the {initconf}
+ if (!$current_widget && defined $self->{initconf}{defaultWname}) {
+ $current_widget = $self->{initconf}{defaultWname};
$self->wset("session","current_widget",$current_widget) if
($current_widget);
}
1.2 +6 -6 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.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- NetServer.pm 9 Sep 2002 01:34:11 -0000 1.1
+++ NetServer.pm 18 Sep 2002 02:54:11 -0000 1.2
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: NetServer.pm,v 1.1 2002/09/09 01:34:11 spadkins Exp $
+## $Id: NetServer.pm,v 1.2 2002/09/18 02:54:11 spadkins Exp $
#############################################################################
package App::Context::NetServer;
@@ -203,7 +203,7 @@
my $request_class = $self->iget("requestClass", "App::Request::CGI");
eval {
- $self->{request} = App->new($request_class, "new", $self,
$self->{initconfig});
+ $self->{request} = App->new($request_class, "new", $self,
$self->{initconf});
};
$self->add_message($@) if ($@);
@@ -242,7 +242,7 @@
my $response_class = $self->iget("responseClass", "App::Response::CGI");
eval {
- $self->{response} = App->new($response_class, "new", $self,
$self->{initconfig});
+ $self->{response} = App->new($response_class, "new", $self,
$self->{initconf});
};
$self->add_message($@) if ($@);
@@ -294,9 +294,9 @@
$current_widget = $self->request()->get_default_widget();
$self->wset("session","current_widget",$current_widget) if
($current_widget);
- # maybe we can find it in the {initconfig}
- if (!$current_widget && defined $self->{initconfig}{defaultWname}) {
- $current_widget = $self->{initconfig}{defaultWname};
+ # maybe we can find it in the {initconf}
+ if (!$current_widget && defined $self->{initconf}{defaultWname}) {
+ $current_widget = $self->{initconf}{defaultWname};
$self->wset("session","current_widget",$current_widget) if
($current_widget);
}
1.2 +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.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- SimpleServer.pm 9 Sep 2002 01:34:11 -0000 1.1
+++ SimpleServer.pm 18 Sep 2002 02:54:11 -0000 1.2
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: SimpleServer.pm,v 1.1 2002/09/09 01:34:11 spadkins Exp $
+## $Id: SimpleServer.pm,v 1.2 2002/09/18 02:54:11 spadkins Exp $
#############################################################################
package App::Context::SimpleServer;
@@ -162,7 +162,7 @@
my $request_class = $self->iget("requestClass", "App::Request");
eval {
- $self->{request} = App->new($request_class, "new", $self,
$self->{initconfig});
+ $self->{request} = App->new($request_class, "new", $self,
$self->{initconf});
};
$self->add_message($@) if ($@);
@@ -201,7 +201,7 @@
my $response_class = $self->iget("responseClass", "App::Response");
eval {
- $self->{response} = App->new($response_class, "new", $self,
$self->{initconfig});
+ $self->{response} = App->new($response_class, "new", $self,
$self->{initconf});
};
$self->add_message($@) if ($@);
1.1 p5ee/App-Context/lib/App/Context/HTTP.pm
Index: HTTP.pm
===================================================================
#############################################################################
## $Id: HTTP.pm,v 1.1 2002/09/18 02:54:11 spadkins Exp $
#############################################################################
package App::Context::HTTP;
use App;
use App::Context;
@ISA = ( "App::Context" );
use App::UserAgent;
use strict;
=head1 NAME
App::Context::HTTP - 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::HTTP;
$context = App::Context::HTTP->new();
=cut
#############################################################################
# DESCRIPTION
#############################################################################
=head1 DESCRIPTION
A Context class models the environment (aka "context)
in which the current process is running.
For the App::Context::HTTP class, this models any of the
web application runtime environments which employ the HTTP protocol
and produce HTML pages as output. This includes CGI, mod_perl, FastCGI,
etc. The difference between these environments is not in the Context
but in the implementation of the Request and Response objects.
=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 {
my ($self, $args) = @_;
$args = {} if (!defined $args);
eval {
$self->{user_agent} = App::UserAgent->new($self);
};
}
#############################################################################
# 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
#############################################################################
# dispatch_events()
#############################################################################
=head2 dispatch_events()
The dispatch_events() method is called by the CGI script
in order to get the Context object rolling. It causes the program to
process the CGI request, interpret and dispatch encoded events in the
request and exit.
In concept, the dispatch_events() method would not return until all
events for a Session were dispatched. However, the reality of the CGI
context is that events associated with a Session occur in many different
processes over different CGI requests. Therefore, the CGI Context
implements the dispatch_events() method to return after processing
all of the events of a single request, assuming that it will be called
again when the next CGI request is received.
* Signature: $context->dispatch_events()
* Param: void
* Return: void
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$context->dispatch_events();
=cut
sub dispatch_events {
my ($self) = @_;
my $request = $self->request();
$request->process();
$self->send_response();
$self->shutdown();
}
#############################################################################
# send_response()
#############################################################################
=head2 send_response()
* Signature: $context->send_response()
* Param: void
* Return: void
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$context->send_response();
=cut
sub send_response {
my $self = shift;
my $response = $self->response();
my $content_type = $response->content_type() || "text/plain";
my $content = $response->content();
my $headers = "Content-type: $content_type\n";
if (defined $self->{headers}) {
$headers .= $self->{headers};
delete $self->{headers}
}
if ($self->{initconf}{gzip}) {
my $user_agent = $self->user_agent();
my $gzip_ok = $user_agent->supports("http.header.accept-encoding.x-gzip");
if ($gzip_ok) {
$headers .= "Content-encoding: gzip\n";
use Compress::Zlib;
$content = Compress::Zlib::memGzip($content);
}
}
print $headers, "\n", $content;
}
#############################################################################
# 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
sub request {
my $self = shift;
return $self->{request} if (defined $self->{request});
#################################################################
# REQUEST
#################################################################
my $request_class = $self->iget("requestClass");
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?
$request_class = "App::Request::CGI";
}
elsif ($ENV{HTTP_USER_AGENT}) { # running as CGI script?
$request_class = "App::Request::CGI";
}
else {
$request_class = "App::Request::CGI";
}
}
eval {
$self->{request} = App->new($request_class, "new", $self, $self->{initconf});
};
$self->add_message($@) if ($@);
return $self->{request};
}
#############################################################################
# response()
#############################################################################
=head2 response()
* Signature: $context->response()
* Param: void
* Return: void
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$context->response();
The response() method gets the current Request being handled in the Context.
=cut
sub response {
my $self = shift;
return $self->{response} if (defined $self->{response});
#################################################################
# RESPONSE
#################################################################
my $response_class = $self->iget("responseClass", "App::Response::HTML");
eval {
$self->{response} = App->new($response_class, "new", $self,
$self->{initconf});
};
$self->add_message($@) if ($@);
return $self->{response};
}
#############################################################################
# user_agent()
#############################################################################
=head2 user_agent()
The user_agent() method returns a UserAgent objects which is primarily
useful to see what capabilities the user agent (browser) supports.
* Signature: $user_agent = $context->user_agent();
* Param: void
* Return: $user_agent App::UserAgent
* Throws: <none>
* Since: 0.01
Sample Usage:
$user_agent = $context->user_agent();
=cut
sub user_agent {
my $self = shift;
$self->{user_agent};
}
#############################################################################
# PUBLIC METHODS
#############################################################################
=head1 Public Methods:
=cut
#############################################################################
# user()
#############################################################################
=head2 user()
The user() method returns the username of the authenticated user.
The special name, "guest", refers to the unauthenticated (anonymous) user.
* Signature: $username = $self->user();
* Param: void
* Return: string
* Throws: <none>
* Since: 0.01
Sample Usage:
$username = $context->user();
In a request/response environment, this turns out to be a convenience
method which gets the authenticated user from the current Request object.
=cut
sub user {
my $self = shift;
return $self->request()->user();
}
1;
1.2 +34 -33 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.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- CGI.pm 9 Sep 2002 01:34:11 -0000 1.1
+++ CGI.pm 18 Sep 2002 02:54:11 -0000 1.2
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: CGI.pm,v 1.1 2002/09/09 01:34:11 spadkins Exp $
+## $Id: CGI.pm,v 1.2 2002/09/18 02:54:11 spadkins Exp $
#############################################################################
package App::Request::CGI;
@@ -8,6 +8,7 @@
use App;
use App::Request;
@ISA = ( "App::Request" );
+use CGI;
use strict;
@@ -73,9 +74,9 @@
=cut
sub init {
- my ($self, $args) = @_;
+ my ($self, $initconf) = @_;
my ($cgi, $var, $value, $lang, $prog, $file);
- $args = {} if (!defined $args);
+ $initconf = {} if (!defined $initconf);
# untaint the $prog
$0 =~ /(.*)/;
@@ -85,7 +86,7 @@
# read environment variables
#################################################################
- if (defined $args->{debugmode} && $args->{debugmode} eq "replay") {
+ if (defined $initconf->{debugmode} && $initconf->{debugmode} eq "replay") {
$file = "$prog.env";
if (open(main::FILE, "< $file")) {
foreach $var (keys %ENV) {
@@ -102,7 +103,7 @@
}
}
- if (defined $args->{debugmode} && $args->{debugmode} eq "record") {
+ if (defined $initconf->{debugmode} && $initconf->{debugmode} eq "record") {
$file = "$prog.env";
if (open(main::FILE, "> $file")) {
foreach $var (keys %ENV) {
@@ -115,8 +116,8 @@
# include the environment variables in the configuration
while (($var,$value) = each %ENV) {
$var = lc($var); # make lower case
- if ($value ne "" && (!defined $args->{$var} || $args->{$var} eq "")) {
- $args->{$var} = $value;
+ if ($value ne "" && (!defined $initconf->{$var} || $initconf->{$var} eq ""))
{
+ $initconf->{$var} = $value;
}
}
@@ -124,7 +125,7 @@
# READ CGI VARIABLES
#################################################################
- if (defined $args->{debugmode} && $args->{debugmode} eq "replay") {
+ if (defined $initconf->{debugmode} && $initconf->{debugmode} eq "replay") {
# when the "debugmode" is in "replay", the saved CGI environment from
# a previous query (when "debugmode" was "record") is used
$file = "$prog.vars";
@@ -134,21 +135,21 @@
}
}
else { # ... the normal path
- if (defined $args && defined $args->{cgi}) {
+ if (defined $initconf && defined $initconf->{cgi}) {
# this allows for migration from old scripts where they already
- # read in the CGI object and they pass it in to P5EE as an arg
- $cgi = $args->{cgi};
+ # read in the CGI object and they pass it in to App-Context as an arg
+ $cgi = $initconf->{cgi};
}
else {
- # this is the normal path for P5EE execution, where the Context::CGI
+ # this is the normal path for App-Context execution, where the
Context::CGI
# is responsible for reading its environment
$cgi = CGI->new();
- $args->{cgi} = $cgi if (defined $args);
+ $initconf->{cgi} = $cgi if (defined $initconf);
}
}
# when the "debugmode" is "record", save the CGI vars
- if (defined $args->{debugmode} && $args->{debugmode} eq "record") {
+ if (defined $initconf->{debugmode} && $initconf->{debugmode} eq "record") {
$file = "$prog.vars";
if (open(main::FILE, "> $file")) {
$cgi->save(*main::FILE); # Save vars to debug file
@@ -160,7 +161,7 @@
# LANGUAGE
#################################################################
- # Hmmm... do I use $ENV{HTTP_ACCEPT_LANGUAGE} or $args->{http_accept_language} ?
+ # Hmmm... do I use $ENV{HTTP_ACCEPT_LANGUAGE} or
$initconf->{http_accept_language} ?
if (defined $ENV{HTTP_ACCEPT_LANGUAGE}) {
$lang = $ENV{HTTP_ACCEPT_LANGUAGE};
$lang =~ s/ *,.*//;
@@ -180,22 +181,22 @@
=cut
#############################################################################
-# process_request()
+# process()
#############################################################################
-=head2 process_request()
+=head2 process()
-The process_request() method executes the events within a
+The process() method executes the events within a
single CGI request. It has no display functionality.
It is called primarily from the event loop handler, dispatch_events().
However, it may 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_request().
+Instead, it would call process().
- * Signature: $request->process_request()
- * Signature: $request->process_request($cgi)
+ * Signature: $request->process()
+ * Signature: $request->process($cgi)
* Param: $cgi (CGI)
* Return: void
* Throws: App::Exception
@@ -203,11 +204,11 @@
Sample Usage:
- $request->process_request();
+ $request->process();
=cut
-sub process_request {
+sub process {
my ($self, $cgi) = @_;
if (!defined $cgi) {
@@ -227,18 +228,18 @@
##########################################################
# For each CGI variable, do the appropriate thing
- # 1. "p5ee.event.*" variable is an event and gets handled last
- # 2. "p5ee.*" variable is a "multi-level hash key" under $context
+ # 1. "app.event.*" variable is an event and gets handled last
+ # 2. "app.*" variable is a "multi-level hash key" under $context
# 3. "wname{m}[1]" variable is a "multi-level hash key" under
$context->{widget}{$wname}
# 4. "wname" variable is a "multi-level hash key"
##########################################################
my (@eventvars, $var, @values, $value, $mlhashkey, $name);
@eventvars = ();
foreach $var ($cgi->param()) {
- if ($var =~ /^p5ee\.event/) {
+ if ($var =~ /^app\.event/) {
push(@eventvars, $var);
}
- elsif ($var =~ /^p5ee.session/) {
+ elsif ($var =~ /^app.session/) {
# do nothing.
# these vars are used in the Session restore() to restore state.
}
@@ -284,10 +285,10 @@
foreach $key (@eventvars) {
# These events come from <input type=submit> type controls
- # The format is name="p5ee.event.{widgetName}.{event}(args)"
+ # The format is name="app.event.{widgetName}.{event}(args)"
# Note: this format is important because the "value" is needed for
display purposes
- if ($key =~ /^p5ee\.event\./) {
+ if ($key =~ /^app\.event\./) {
$args = "";
@args = ();
@@ -317,7 +318,7 @@
push(@args, $cgi->param($key)); # tack the label on at the end
}
- $key =~ s/^p5ee\.event\.//; # get rid of prefix
+ $key =~ s/^app\.event\.//; # get rid of prefix
$key =~ s/\(.*//; # get rid of args
if ($key =~ /^([^()]+)\.([a-zA-Z0-9_-]+)$/) {
@@ -343,11 +344,11 @@
}
}
}
- elsif ($key eq "p5ee.event") {
+ elsif ($key eq "app.event") {
# These events come from <input type=hidden> type controls
# They are basically call-backs so that the widget could clean up
something before being viewed
- # The format is name="p5ee.event" value="{widgetName}.{event}"
+ # The format is name="app.event" value="{widgetName}.{event}"
foreach $value ($cgi->param($key)) {
if ($value =~ /^([^()]+)\.([a-zA-Z0-9_-]+)/) {
@@ -361,7 +362,7 @@
}
@args = split(/ *, */,$args) if ($args ne "");
- $context->dbgprint(ref($self), "->process_request[hidden]:
$name->$event(@args)")
+ $context->dbgprint(ref($self), "->process[hidden]:
$name->$event(@args)")
if ($App::DEBUG && $context->dbg(1));
$context->widget($name)->handle_event($name, $event, @args);
1.1 p5ee/App-Context/lib/App/Response/HTML.pm
Index: HTML.pm
===================================================================
#############################################################################
## $Id: HTML.pm,v 1.1 2002/09/18 02:54:11 spadkins Exp $
#############################################################################
package App::Response::HTML;
use App;
use App::Response;
@ISA = ( "App::Response" );
use strict;
=head1 NAME
App::Response::HTML - context in which we are currently running
=head1 SYNOPSIS
# ... official way to get a Response object ...
use App;
$context = App->context();
$response = $context->response();
# ... alternative way (used internally) ...
use App::Response::HTML;
$response = App::Response::HTML->new();
=cut
#############################################################################
# DESCRIPTION
#############################################################################
=head1 DESCRIPTION
A Response class ...
=cut
#############################################################################
# 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
#############################################################################
# dispatch_events()
#############################################################################
=head2 dispatch_events()
The dispatch_events() method is called by the CGI script
in order to get the Response object rolling. It causes the program to
process the CGI request, interpret and dispatch encoded events in the
request and exit.
In concept, the dispatch_events() method would not return until all
events for a Session were dispatched. However, the reality of the CGI
context is that events associated with a Session occur in many different
processes over different CGI requests. Therefore, the CGI Response
implements the dispatch_events() method to return after processing
all of the events of a single request, assuming that it will be called
again when the next CGI request is received.
* Signature: $response->dispatch_events()
* Param: void
* Return: void
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$response->dispatch_events();
=cut
sub dispatch_events {
my ($self) = @_;
$self->request()->process_request();
eval {
$self->display_current_widget();
};
if ($@) {
print <<EOF;
Content-type: text/plain
-----------------------------------------------------------------------------
AN ERROR OCCURRED in App::Response::CGI->display_current_widget()
-----------------------------------------------------------------------------
$@
-----------------------------------------------------------------------------
Additional messages from earlier stages may be relevant if they exist below.
-----------------------------------------------------------------------------
$self->{messages}
EOF
}
$self->shutdown();
}
#############################################################################
# request()
#############################################################################
=head2 request()
* Signature: $response->request()
* Param: void
* Return: void
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$response->request();
The request() method gets the current Request being handled in the Response.
=cut
sub request {
my $self = shift;
return $self->{request} if (defined $self->{request});
#################################################################
# REQUEST
#################################################################
my $request_class = $self->iget("requestClass", "App::Request::CGI");
eval {
$self->{request} = App->new($request_class, "new", $self, $self->{initconf});
};
$self->add_message($@) if ($@);
return $self->{request};
}
#############################################################################
# response()
#############################################################################
=head2 response()
* Signature: $response->response()
* Param: void
* Return: void
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$response->response();
The response() method gets the current Request being handled in the Response.
=cut
sub response {
my $self = shift;
return $self->{response} if (defined $self->{response});
#################################################################
# RESPONSE
#################################################################
my $response_class = $self->iget("responseClass", "App::Response::CGI");
eval {
$self->{response} = App->new($response_class, "new", $self,
$self->{initconf});
};
$self->add_message($@) if ($@);
return $self->{response};
}
#############################################################################
# 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
#############################################################################
# display_current_widget()
#############################################################################
=head2 display_current_widget()
* Signature: $response->display_current_widget()
* Param: void
* Return: void
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$response->display_current_widget();
The display_current_widget() method searches the "session widget" for an
attribute of "current_widget" and uses that as the name of the widget which should
be displayed in the browser.
=cut
sub display_current_widget {
my $self = shift;
my ($current_widget, $w);
$current_widget = $self->wget("session","current_widget");
if (!$current_widget) { # no current widget is defined
# see if the Request can suggest a default
$current_widget = $self->request()->get_default_widget();
$self->wset("session","current_widget",$current_widget) if ($current_widget);
# maybe we can find it in the {initconf}
if (!$current_widget && defined $self->{initconf}{defaultWname}) {
$current_widget = $self->{initconf}{defaultWname};
$self->wset("session","current_widget",$current_widget) if
($current_widget);
}
# oh well. just use "default".
if (!$current_widget) {
$current_widget = "default";
$self->wset("session","current_widget",$current_widget);
}
}
$w = $self->widget($current_widget);
$self->content($w);
}
#############################################################################
# content()
#############################################################################
=head2 content()
The content() method takes an array of arguments and puts them all
out to STDOUT with the appropriate headers.
* Signature: $response->content(@items)
* Param: @items @
* Return: void
* Throws: App::Exception
* Since: 0.01
Sample Usage:
$response->content("Hello world!");
=cut
sub content {
my $self = shift;
my $html = $self->html(@_);
my ($title, $bodyoptions, $w, $var, $value, $context_body, $context_head);
$title = "App-Context";
$bodyoptions = "";
$w = $_[0] if ($#_ > -1);
if ($w && ref($w) && $w->isa("App::Widget")) {
$title = $w->get("title");
$title = $w->get("name") if (!$title);
foreach $var ('bgcolor', 'text', 'link', 'vlink', 'alink',
'leftmargin', 'topmargin', 'rightmargin', 'bottommargin',
'class') {
$value = $w->get($var);
if (defined $value && $value ne "") {
$bodyoptions .= " $var=\"$value\"";
}
elsif ($var eq "bgcolor") {
$bodyoptions .= " $var=\"#ffffff\"";
}
}
}
$context_body = $self->body_html(\%main::conf);
$context_head = $self->head_html();
my $content = <<EOF;
<html>
<head>
<title>${title}</title>
$context_head</head>
<body${bodyoptions}>
<form method="POST">
$context_body
$html</form>
</body>
</html>
EOF
$content;
}
sub content_type {
"text/html";
}
sub html {
my $self = shift;
my ($item, $elem, $ref, @html, @elem);
@html = ();
foreach $item (@_) {
next if (!defined $item);
$ref = ref($item);
$self->dbgprint("Response->html() $item => ref=[$ref]") if ($App::DEBUG);
next if ($ref eq "CODE" || $ref eq "GLOB"); # TODO: are there others?
if ($ref eq "" || $ref eq "SCALAR") {
$elem = ($ref eq "") ? $item : $$item;
# borrowed from CGI::Util::simple_escape() ...
$elem =~ s{&}{&}gso;
$elem =~ s{<}{<}gso;
$elem =~ s{>}{>}gso;
$elem =~ s{\"}{"}gso;
push(@html, $elem);
}
elsif ($ref eq "ARRAY") {
push(@html, $self->html(@$item));
}
elsif ($ref eq "HASH") {
@elem = ();
foreach (sort keys %$item) {
push(@elem, $item->{$_});
}
push(@html, $self->html(@elem));
}
else {
push(@html, $item->html()); # assume if it's an object, that it has an
html() method
}
}
return join("",@html);
}
sub body_html {
my ($self, $conf) = @_;
my $session = $self->{context}->session();
return $session->html();
}
sub head_html {
my ($self) = @_;
my ($html, $key, $keys);
$keys = $self->{head}{keys};
$html = "";
if (defined $keys && ref($keys) eq "ARRAY") {
foreach $key (sort @$keys) {
$html .= $self->{head}{$key};
}
}
$html;
}
sub set_head_html {
my ($self, $key, $html) = @_;
my ($keys);
if (!defined $self->{head}{$key}) {
$self->dbgprint(ref($self), "->set_head_html(): $key=[$html]")
if ($App::DEBUG && $self->dbg(2));
$self->{head}{$key} = $html;
$keys = $self->{head}{keys};
if (defined $keys && ref($keys) eq "ARRAY") {
push(@$keys, $key);
}
else {
$self->{head}{keys} = [ $key ];
}
}
else {
$self->dbgprint(ref($self), "->set_head_html(): $key=[repeat]")
if ($App::DEBUG >= 3 && $self->dbg(3));
}
}
sub set_header {
my ($self, $header) = @_;
if (defined $self->{headers}) {
$self->{headers} .= $header;
}
else {
$self->{headers} = $header;
}
}
1;
1.2 +7 -7 p5ee/App-Context/lib/App/Session/Cookie.pm
Index: Cookie.pm
===================================================================
RCS file: /cvs/public/p5ee/App-Context/lib/App/Session/Cookie.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- Cookie.pm 9 Sep 2002 01:34:11 -0000 1.1
+++ Cookie.pm 18 Sep 2002 02:54:11 -0000 1.2
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: Cookie.pm,v 1.1 2002/09/09 01:34:11 spadkins Exp $
+## $Id: Cookie.pm,v 1.2 2002/09/18 02:54:11 spadkins Exp $
#############################################################################
package App::Session::Cookie;
@@ -183,7 +183,7 @@
if (length($sessiontext) <= $maxvarsize) {
$sessiontext =~ s/\n//g; # get rid of newlines (76 char lines)
- $headers = "Set-Cookie: p5ee_sessiondata=$sessiontext$cookieoptions\n";
+ $headers = "Set-Cookie: app_sessiondata=$sessiontext$cookieoptions\n";
$self->{context}->set_header($headers);
}
else {
@@ -193,14 +193,14 @@
$startidx = 0;
$endidx = $startidx+$maxvarlines-1;
$textchunk = join("",@sessiontext[$startidx .. $endidx]);
- $headers .= "Set-Cookie: p5ee_sessiondata=$textchunk$cookieoptions\n";
+ $headers .= "Set-Cookie: app_sessiondata=$textchunk$cookieoptions\n";
while ($endidx < $#sessiontext) {
$i++;
$startidx += $maxvarlines;
$endidx = $startidx+$maxvarlines-1;
$endidx = $#sessiontext if ($endidx > $#sessiontext-1);
$textchunk = join("",@sessiontext[$startidx .. $endidx]);
- $headers .= "Set-Cookie:
p5ee_sessiondata${i}=$textchunk$cookieoptions\n";
+ $headers .= "Set-Cookie:
app_sessiondata${i}=$textchunk$cookieoptions\n";
}
$self->{context}->set_header($headers);
}
@@ -277,7 +277,7 @@
The init() method looks at the cookies in the request
and restores the session state information from the cookies
-named "p5ee_sessiondata" (and "p5ee_sessiondata[2..n]").
+named "app_sessiondata" (and "app_sessiondata[2..n]").
When the values of these cookies are concatenated, they
form a Base64-encoded, gzipped, frozen multi-level hash of
@@ -295,12 +295,12 @@
$cgi = $args->{cgi} if (defined $args);
$store = {};
if (defined $cgi) {
- $sessiontext = $cgi->cookie("p5ee_sessiondata");
+ $sessiontext = $cgi->cookie("app_sessiondata");
if ($sessiontext) {
my ($i, $textchunk);
$i = 2;
while (1) {
- $textchunk = $cgi->cookie("p5ee_sessiondata${i}");
+ $textchunk = $cgi->cookie("app_sessiondata${i}");
last if (!$textchunk);
$sessiontext .= $textchunk;
$i++;
1.2 +10 -10 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.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- HTMLHidden.pm 9 Sep 2002 01:34:11 -0000 1.1
+++ HTMLHidden.pm 18 Sep 2002 02:54:11 -0000 1.2
@@ -1,6 +1,6 @@
#############################################################################
-## $Id: HTMLHidden.pm,v 1.1 2002/09/09 01:34:11 spadkins Exp $
+## $Id: HTMLHidden.pm,v 1.2 2002/09/18 02:54:11 spadkins Exp $
#############################################################################
package App::Session::HTMLHidden;
@@ -142,7 +142,7 @@
sub html {
my ($self) = @_;
- my ($sessiontext, $sessiondata, $html, $initconfig);
+ my ($sessiontext, $sessiondata, $html, $initconf);
$sessiondata = $self->{store};
$sessiontext = encode_base64(Compress::Zlib::memGzip(freeze($sessiondata)));
@@ -152,7 +152,7 @@
$maxvarsize = $maxvarlines*77; # length of a MIME/Base64 line is (76 chars +
newline)
if (length($sessiontext) <= $maxvarsize) {
- $html = "<input type=\"hidden\" name=\"p5ee.sessiondata\"
value=\"\n$sessiontext\">";
+ $html = "<input type=\"hidden\" name=\"app.sessiondata\"
value=\"\n$sessiontext\">";
}
else {
my (@sessiontext, $i, $startidx, $endidx, $textchunk);
@@ -161,20 +161,20 @@
$startidx = 0;
$endidx = $startidx+$maxvarlines-1;
$textchunk = join("\n",@sessiontext[$startidx .. $endidx]);
- $html = "<input type=\"hidden\" name=\"p5ee.sessiondata\"
value=\"\n$textchunk\n\">";
+ $html = "<input type=\"hidden\" name=\"app.sessiondata\"
value=\"\n$textchunk\n\">";
while ($endidx < $#sessiontext) {
$i++;
$startidx += $maxvarlines;
$endidx = $startidx+$maxvarlines-1;
$endidx = $#sessiontext if ($endidx > $#sessiontext-1);
$textchunk = join("\n",@sessiontext[$startidx .. $endidx]);
- $html .= "\n<input type=\"hidden\" name=\"p5ee.sessiondata${i}\"
value=\"\n$textchunk\n\">";
+ $html .= "\n<input type=\"hidden\" name=\"app.sessiondata${i}\"
value=\"\n$textchunk\n\">";
}
}
$html .= "\n";
- $initconfig = $self->{context}->initconfig();
- if ($initconfig && $initconfig->{showsession}) {
+ $initconf = $self->{context}->initconf();
+ if ($initconf && $initconf->{showsession}) {
# Debugging Only
my $d = Data::Dumper->new([ $sessiondata ], [ "session_store" ]);
$d->Indent(1);
@@ -246,7 +246,7 @@
The init() method looks at the CGI variables in the request
and restores the session state information from the variable
-named "p5ee.sessiondata" (and "p5ee.sessiondata[2..n]").
+named "app.sessiondata" (and "app.sessiondata[2..n]").
When the values of these variables are concatenated, they
form a Base64-encoded, gzipped, frozen multi-level hash of
@@ -264,12 +264,12 @@
$cgi = $args->{cgi} if (defined $args);
$store = {};
if (defined $cgi) {
- $sessiontext = $cgi->param("p5ee.sessiondata");
+ $sessiontext = $cgi->param("app.sessiondata");
if ($sessiontext) {
my ($i, $textchunk);
$i = 2;
while (1) {
- $textchunk = $cgi->param("p5ee.sessiondata${i}");
+ $textchunk = $cgi->param("app.sessiondata${i}");
last if (!$textchunk);
$sessiontext .= $textchunk;
$i++;
1.1 p5ee/App-Context/t/Procedure.t
Index: Procedure.t
===================================================================
#!/usr/local/bin/perl -wT
use Test::More qw(no_plan);
use lib "lib";
use lib "../lib";
BEGIN {
use_ok("App");
}
my ($context);
#$App::DEBUG = 1;
$context = App->context(
confFile => "",
conf => {
Procedure => {
f2c_local => {
serviceClass => "App::Procedure::Local",
module => "Temperature",
procedure => "f2c",
},
f2c_httprpc => {
serviceClass => "App::Procedure::HTTPRPC",
url => "http://localhost/cgi-bin/app/httprpc";,
procedure => "f2c",
},
f2c_xmlrpc => {
serviceClass => "App::Procedure::XMLRPC",
url => "http://localhost/cgi-bin/app/xmlrpc";,
procedure => "f2c",
},
f2c_soap => {
serviceClass => "App::Procedure::SOAP",
url => "http://localhost/cgi-bin/app/soaprpc";,
procedure => "f2c",
},
},
},
);
$service = $context->service("Procedure");
ok(defined $service, "constructor ok");
isa_ok($service, "App::Procedure", "right class");
is($service->service_type(), "Procedure", "right service type");
$f2c = $context->procedure("f2c_local");
$c = $f2c->execute(212);
is($c,100, "Boiling point in degrees C (local)");
$f2c = $context->procedure("f2c_httprpc");
$c = $f2c->execute(212);
is($c,100, "Boiling point in degrees C (httprpc)");
$f2c = $context->procedure("f2c_xmlrpc");
$c = $f2c->execute(212);
is($c,100, "Boiling point in degrees C (xmlrpc)");
$f2c = $context->procedure("f2c_soap");
$c = $f2c->execute(212);
is($c,100, "Boiling point in degrees C (soap)");
exit 0;
