cvsuser 02/07/12 14:01:39
Added: P5EEx/Blue/P5EEx/Blue Request.pm
P5EEx/Blue/P5EEx/Blue/Request CGI.pm
Log:
new file - moves distinctions between CGI and mod_perl out of the Context into the
Request
Revision Changes Path
1.1 p5ee/P5EEx/Blue/P5EEx/Blue/Request.pm
Index: Request.pm
===================================================================
#############################################################################
## $Id: Request.pm,v 1.1 2002/07/12 21:01:39 spadkins Exp $
#############################################################################
package P5EEx::Blue::Request;
use strict;
use P5EEx::Blue::P5EE;
=head1 NAME
P5EEx::Blue::Request - the request
=head1 SYNOPSIS
# ... official way to get a Request object ...
use P5EEx::Blue::P5EE;
$context = P5EEx::Blue::P5EE->context();
$request = $context->request(); # get the request
# ... alternative way (used internally) ...
use P5EEx::Blue::Request;
$request = P5EEx::Blue::Request->new();
=cut
#############################################################################
# CONSTANTS
#############################################################################
=head1 DESCRIPTION
A Request class ...
=cut
#############################################################################
# CLASS GROUP
#############################################################################
=head1 Class Group: Request
The following classes might be a part of the Request Class Group.
=over
=item * Class: P5EEx::Blue::Request
=item * Class: P5EEx::Blue::Request::CGI
=back
=cut
#############################################################################
# CONSTRUCTOR METHODS
#############################################################################
=head1 Constructor Methods:
=cut
#############################################################################
# new()
#############################################################################
=head2 new()
The P5EEx::Blue::Request->new() method is rarely called directly.
That is because the current request is usually accessed through the
$context object.
* Signature: $request = P5EEx::Blue::Request->new($context, $named);
* Return: $request P5EEx::Blue::Request
* Throws: P5EEx::Blue::Exception
* Since: 0.01
Sample Usage:
$request = P5EEx::Blue::Request->new();
=cut
sub new {
my $this = shift;
my $class = ref($this) || $this;
my $self = {};
bless $self, $class;
my $context = shift;
$self->{context} = $context;
my $args = shift || {};
$self->init($args);
return $self;
}
#############################################################################
# PROTECTED METHODS
#############################################################################
=head1 Protected Methods:
The following methods are intended to be called by subclasses of the
current class (or environmental, "main" code).
=cut
#############################################################################
# init()
#############################################################################
=head2 init()
The init() method is called from within the standard Request constructor.
The init() method in this class does nothing.
It allows subclasses of the Request to customize the behavior of the
constructor by overriding the init() method.
* Signature: $request->init()
* Param: void
* Return: void
* Throws: P5EEx::Blue::Exception
* Since: 0.01
Sample Usage:
$request->init();
=cut
sub init {
my ($self, $args) = @_;
}
#############################################################################
# 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 = $request->user();
* Param: void
* Return: string
* Throws: <none>
* Since: 0.01
Sample Usage:
$username = $request->user();
=cut
sub user {
my $self = shift;
"guest";
}
1;
1.1 p5ee/P5EEx/Blue/P5EEx/Blue/Request/CGI.pm
Index: CGI.pm
===================================================================
#############################################################################
## $Id: CGI.pm,v 1.1 2002/07/12 21:01:39 spadkins Exp $
#############################################################################
package P5EEx::Blue::Request::CGI;
use P5EEx::Blue::P5EE;
use P5EEx::Blue::Request;
@ISA = ( "P5EEx::Blue::Request" );
use strict;
=head1 NAME
P5EEx::Blue::Request::CGI - the request
=head1 SYNOPSIS
# ... official way to get a Request object ...
use P5EEx::Blue::P5EE;
$context = P5EEx::Blue::P5EE->context();
$request = $context->request(); # get the request
# ... alternative way (used internally) ...
use P5EEx::Blue::Request::CGI;
$request = P5EEx::Blue::Request::CGI->new();
=cut
#############################################################################
# CONSTANTS
#############################################################################
=head1 DESCRIPTION
A Request class implemented using the CGI class.
=cut
#############################################################################
# PROTECTED METHODS
#############################################################################
=head1 Protected Methods:
The following methods are intended to be called by subclasses of the
current class (or environmental, "main" code).
=cut
#############################################################################
# init()
#############################################################################
=head2 init()
The init() method is called from within the standard Request constructor.
The init() method in this class does nothing.
It allows subclasses of the Request to customize the behavior of the
constructor by overriding the init() method.
* Signature: $request->init()
* Param: void
* Return: void
* Throws: P5EEx::Blue::Exception
* Since: 0.01
Sample Usage:
$request->init();
=cut
sub init {
my ($self, $args) = @_;
my ($cgi, $var, $value, $lang, $prog, $file);
$args = {} if (!defined $args);
# untaint the $prog
$0 =~ /(.*)/;
$prog = $1;
#################################################################
# read environment variables
#################################################################
if (defined $args->{debugmode} && $args->{debugmode} eq "replay") {
$file = "$prog.env";
if (open(main::FILE, "< $file")) {
foreach $var (keys %ENV) {
delete $ENV{$var}; # unset all environment variables
}
while (<main::FILE>) {
chop;
/^([^=]+)=(.*)/; # parse variable, value (and untaint)
$var = $1; # get variable name
$value = $2; # get variable value
$ENV{$var} = $value; # restore environment variable
}
close(main::FILE);
}
}
if (defined $args->{debugmode} && $args->{debugmode} eq "record") {
$file = "$prog.env";
if (open(main::FILE, "> $file")) {
foreach $var (keys %ENV) {
print main::FILE "$var=$ENV{$var}\n"; # save environment variables
}
close(main::FILE);
}
}
# 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;
}
}
#################################################################
# READ CGI VARIABLES
#################################################################
if (defined $args->{debugmode} && $args->{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";
if (open(main::FILE, "< $file")) {
$cgi = new CGI(*main::FILE); # Get vars from debug file
close(main::FILE);
}
}
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
$cgi = $args->{cgi};
}
else {
# this is the normal path for P5EE execution, where the Context::CGI
# is responsible for reading its environment
$cgi = CGI->new();
$args->{cgi} = $cgi if (defined $args);
}
}
# when the "debugmode" is "record", save the CGI vars
if (defined $args->{debugmode} && $args->{debugmode} eq "record") {
$file = "$prog.vars";
if (open(main::FILE, "> $file")) {
$cgi->save(*main::FILE); # Save vars to debug file
close(main::FILE);
}
}
#################################################################
# LANGUAGE
#################################################################
# Hmmm... do I use $ENV{HTTP_ACCEPT_LANGUAGE} or $args->{http_accept_language} ?
if (defined $ENV{HTTP_ACCEPT_LANGUAGE}) {
$lang = $ENV{HTTP_ACCEPT_LANGUAGE};
$lang =~ s/ *,.*//;
$lang =~ s/-/_/g;
# TODO: do something with the $lang ...
}
$self->{cgi} = $cgi;
}
#############################################################################
# PUBLIC METHODS
#############################################################################
=head1 Public Methods
=cut
#############################################################################
# process_request()
#############################################################################
=head2 process_request()
The process_request() 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().
* Signature: $request->process_request()
* Signature: $request->process_request($cgi)
* Param: $cgi (CGI)
* Return: void
* Throws: P5EEx::Blue::Exception
* Since: 0.01
Sample Usage:
$request->process_request();
=cut
sub process_request {
my ($self, $cgi) = @_;
if (!defined $cgi) {
$cgi = $self->{cgi};
}
elsif (!defined $self->{cgi}) {
$self->{cgi} = $cgi;
}
my $context = $self->{context};
if (defined $cgi) {
my ($session, $wname);
$session = $context->{session}; # get the Session
$wname = $cgi->param("wname"); # the "wname" variable is treated
specially
$wname = "" if (!defined $wname);
##########################################################
# 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
# 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/) {
push(@eventvars, $var);
}
elsif ($var =~ /^p5ee.session/) {
# do nothing.
# these vars are used in the Session restore() to restore state.
}
else {
@values = $cgi->param($var);
if ($var =~ s/\[\]$//) {
$value = [ @values ];
}
elsif ($#values == -1) {
$value = "";
}
elsif ($#values == 0) {
$value = $values[0];
}
else {
$value = join(",",@values);
}
if ($var =~ /^([^\[\]\{\}]+)([\[\]\{\}].*)/) {
$context->wset($1, $2, $value);
}
else {
if ($var eq "wname") {
# skip "wname" it is special. it is the way whereby the
# current_widget can be set from the browser
}
# Subwidget vars: e.g. "app.nav.toolbar"
elsif ($var =~ /^(.+)\.([^.]+)$/) {
$context->wset($1, $2, $value);
}
# Autoattribute vars: e.g. "width" (an attribute of widget named
in request)
elsif ($wname) {
$context->wset($wname, $var, $value);
}
# Simple vars: e.g. "width" (gets dumped in the "session" widget)
else {
$context->wset("session", $var, $value);
}
}
}
}
my ($key, $fullkey, $args, @args, $event, %x, %y, $x, $y);
foreach $key (@eventvars) {
# These events come from <input type=submit> type controls
# The format is name="p5ee.event.{widgetName}.{event}(args)"
# Note: this format is important because the "value" is needed for
display purposes
if ($key =~ /^p5ee\.event\./) {
$args = "";
@args = ();
if ($key =~ /\((.*)\)/) { # look for anything inside
parentheses
$args = $1;
}
@args = split(/ *, */,$args) if ($args ne "");
# <input type=image name=joe> returns e.g. joe.x=20 joe.y=35
# these two variables get turned into one event with $x, $y added to
the end of the @args
$fullkey = $key;
if ($key =~ /^(.*)\.x$/) {
$key = $1;
$x{$key} = $cgi->param($fullkey);
next if (!defined $y{$key});
push(@args, $x{$key}); # tack $x, $y coordinates on
at the end
push(@args, $y{$key});
}
elsif ($key =~ /^(.*)\.y$/) {
$key = $1;
$y{$key} = $cgi->param($fullkey);
next if (!defined $x{$key});
push(@args, $x{$key}); # tack $x, $y coordinates on
at the end
push(@args, $y{$key});
}
else {
push(@args, $cgi->param($key)); # tack the label on at the end
}
$key =~ s/^p5ee\.event\.//; # get rid of prefix
$key =~ s/\(.*//; # get rid of args
if ($key =~ /^([^()]+)\.([a-zA-Z0-9_-]+)$/) {
$name = $1;
$event = $2;
if ($context->widget_exists($name)) {
$context->dbgprint($context->widget($name),
"->handle_event($name, $event, @args) [Context/button]")
if ($P5EEx::Blue::DEBUG && $context->dbg(1));
$context->widget($name)->handle_event($name, $event, @args);
}
else {
my ($parent_name);
$parent_name = $name;
while ($parent_name =~ s/\.[^\.]+$//) {
if ($context->widget_exists($parent_name)) {
$context->dbgprint($context->widget($parent_name),
"->handle_event($name, $event, @args) [Context/button]")
if ($P5EEx::Blue::DEBUG && $context->dbg(1));
$context->widget($parent_name)->handle_event($name,
$event, @args);
last;
}
}
}
}
}
elsif ($key eq "p5ee.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}"
foreach $value ($cgi->param($key)) {
if ($value =~ /^([^()]+)\.([a-zA-Z0-9_-]+)/) {
$name = $1;
$event = $2;
$args = "";
@args = ();
if ($value =~ /\((.*)\)/) { # look for anything inside
parentheses
$args = $1;
}
@args = split(/ *, */,$args) if ($args ne "");
$context->dbgprint(ref($self), "->process_request[hidden]:
$name->$event(@args)")
if ($P5EEx::Blue::DEBUG && $context->dbg(1));
$context->widget($name)->handle_event($name, $event, @args);
}
}
}
}
}
#eval {
#};
#if ($@) {
# my ($msg);
# if (ref($@) eq "") { # i.e. a string thrown with "die"
# $msg = $@;
# }
# elsif ($@->isa("P5EEx::Blue::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);
#}
}
#############################################################################
# sync_to_native()
#############################################################################
#
#=head2 sync_to_native()
#
#The sync_to_native() method ...
#
# * Signature: $request->sync_to_native()
# * Param: void
# * Return: void
# * Throws: P5EEx::Blue::Exception
# * Since: 0.01
#
# Sample Usage:
#
# $request->sync_to_native();
#
#=cut
#
#sub sync_to_native {
# my ($self) = @_;
#
# my ($cgi, $context, $session_widget, $param, $value);
# $cgi = $self->{cgi};
# $context = $self->{context};
# $session_widget = $context->widget("session");
# foreach $param (keys %$session_widget) {
# $value = $session_widget->{$param};
# $cgi->param($param, $value);
# }
#}
#############################################################################
# get_default_widget()
#############################################################################
=head2 get_default_widget()
The get_default_widget() method returns the current widget of the authenticated user.
The special name, "guest", refers to the unauthenticated (anonymous) user.
* Signature: $current_widget = $request->get_default_widget();
* Param: void
* Return: $current_widget string
* Throws: <none>
* Since: 0.01
Sample Usage:
$current_widget = $request->get_default_widget();
=cut
sub get_default_widget {
my $self = shift;
my ($default_widget);
$default_widget = $self->{cgi}->param("wname");
# maybe we can infer it from the PATH_INFO
if (!$default_widget && defined $ENV{PATH_INFO}) {
$default_widget = $ENV{PATH_INFO};
$default_widget =~ s!^/!!; # remove leading "/"
# TODO: I may interpret PATH_INFO to include method(args) someday
$default_widget =~ s!/!.!g; # for now, convert "/" to "." (/app/toolbar =>
app.toolbar)
}
return $default_widget;
}
#############################################################################
# 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 = $request->user();
* Param: void
* Return: string
* Throws: <none>
* Since: 0.01
Sample Usage:
$username = $request->user();
=cut
sub user {
my $self = shift;
return ($ENV{REMOTE_USER} || "guest");
}
#############################################################################
# header()
#############################################################################
=head2 header()
The header() method returns the specified HTTP header from the request.
* Signature: $header_value = $request->header($header_name);
* Param: $header_name string
* Return: $header_value string
* Throws: <none>
* Since: 0.01
Sample Usage:
$header_value = $request->header("Accept-Encoding");
=cut
sub header {
my ($self, $header_name) = @_;
return $self->{cgi}->http($header_name);
}
1;
