cvsuser 02/07/12 14:01:13
Added: P5EEx/Blue/P5EEx/Blue/Context HTTPHTML.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/Context/HTTPHTML.pm
Index: HTTPHTML.pm
===================================================================
#############################################################################
## $Id: HTTPHTML.pm,v 1.1 2002/07/12 21:01:13 spadkins Exp $
#############################################################################
package P5EEx::Blue::Context::HTTPHTML;
use P5EEx::Blue::P5EE;
use P5EEx::Blue::Context;
@ISA = ( "P5EEx::Blue::Context" );
use strict;
=head1 NAME
P5EEx::Blue::Context::HTTPHTML - context in which we are currently running
=head1 SYNOPSIS
# ... official way to get a Context object ...
use P5EEx::Blue::P5EE;
$context = P5EEx::Blue::P5EE->context();
$config = $context->config(); # get the configuration
$config->dispatch_events(); # dispatch events
# ... alternative way (used internally) ...
use P5EEx::Blue::Context::HTTPHTML;
$context = P5EEx::Blue::Context::HTTPHTML->new();
=cut
#############################################################################
# DESCRIPTION
#############################################################################
=head1 DESCRIPTION
A Context class models the environment (aka "context)
in which the current process is running.
For the P5EEx::Blue::Context::HTTPHTML 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: P5EEx::Blue::Exception
* Since: 0.01
Sample Usage:
$context->init($args);
=cut
sub init {
my ($self, $args) = @_;
$args = {} if (!defined $args);
#################################################################
# DEBUGGING
#################################################################
# Supports the following command-line usage:
# -debug=1 (global debug)
# -debug=1,P5EEx::Blue::Context (debug class only)
# -debug=3,P5EEx::Blue::Context,P5EEx::Blue::Session (multiple classes)
# -debug=6,P5EEx::Blue::Repository::DBI.select_rows (individual methods)
my ($debug, $pkg);
$debug = $args->{debug};
if (defined $debug && $debug ne "") {
if ($debug =~ s/^([0-9]+),?//) {
$P5EEx::Blue::DEBUG = $1;
}
if ($debug) {
foreach $pkg (split(/,/,$debug)) {
$self->{debugscope}{$pkg} = 1;
}
}
}
}
#############################################################################
# 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: P5EEx::Blue::Exception
* Since: 0.01
Sample Usage:
$context->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 P5EEx::Blue::Context::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: $context->request()
* Param: void
* Return: void
* Throws: P5EEx::Blue::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", "P5EEx::Blue::Request::CGI");
eval {
$self->{request} = P5EEx::Blue::P5EE->new($request_class, "new", $self,
$self->{initconfig});
};
$self->add_message($@) if ($@);
return $self->{request};
}
#############################################################################
# response()
#############################################################################
=head2 response()
* Signature: $context->response()
* Param: void
* Return: void
* Throws: P5EEx::Blue::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", "P5EEx::Blue::Response::CGI");
eval {
$self->{response} = P5EEx::Blue::P5EE->new($response_class, "new", $self,
$self->{initconfig});
};
$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: $context->display_current_widget()
* Param: void
* Return: void
* Throws: P5EEx::Blue::Exception
* Since: 0.01
Sample Usage:
$context->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 {initconfig}
if (!$current_widget && defined $self->{initconfig}{defaultWname}) {
$current_widget = $self->{initconfig}{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->display_items($w);
}
#############################################################################
# display_items()
#############################################################################
=head2 display_items()
The display_items() method takes an array of arguments and puts them all
out to STDOUT with the appropriate headers.
* Signature: $context->display_items(@items)
* Param: @items @
* Return: void
* Throws: P5EEx::Blue::Exception
* Since: 0.01
Sample Usage:
$context->display_items("Hello world!");
=cut
sub display_items {
my $self = shift;
my $html = $self->html(@_);
my ($title, $bodyoptions, $w, $var, $value, $context_body, $context_head);
$title = "Perl 5 Enterprise Environment";
$bodyoptions = "";
$w = $_[0] if ($#_ > -1);
if ($w && ref($w) && $w->isa("P5EEx::Blue::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 ($user_agent, $gzip_ok, $header, $data);
$header = "Content-type: text/html\n";
$data = <<EOF;
<html>
<head>
<title>${title}</title>
$context_head</head>
<body${bodyoptions}>
<form method="POST">
$context_body
$html</form>
</body>
</html>
EOF
if (defined $self->{headers}) {
$header .= $self->{headers};
delete $self->{headers}
}
if ($main::conf{gzip}) {
$user_agent = $self->user_agent();
$gzip_ok = $user_agent->supports("http.header.accept-encoding.x-gzip");
if ($gzip_ok) {
$header .= "Content-encoding: gzip\n";
use Compress::Zlib;
$data = Compress::Zlib::memGzip($data);
}
}
print $header, "\n", $data;
}
sub html {
my $self = shift;
my ($item, $elem, $ref, @html, @elem);
@html = ();
foreach $item (@_) {
next if (!defined $item);
$ref = ref($item);
$self->dbgprint("Context->html() $item => ref=[$ref]") if
($P5EEx::Blue::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) = @_;
$self->{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 ($P5EEx::Blue::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 ($P5EEx::Blue::DEBUG >= 3 && $self->dbg(3));
}
}
sub set_header {
my ($self, $header) = @_;
if (defined $self->{headers}) {
$self->{headers} .= $header;
}
else {
$self->{headers} = $header;
}
}
#############################################################################
# PUBLIC METHODS
#############################################################################
=head1 Public Methods:
=cut
#############################################################################
# log()
#############################################################################
=head2 log()
This method is inherited from
L<C<P5EEx::Blue::Context>|P5EEx::Blue::Context/"log()">.
=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();
}
#############################################################################
# config()
#############################################################################
=head2 config()
This method is inherited from
L<C<P5EEx::Blue::Context>|P5EEx::Blue::Context/"config()">.
=cut
#############################################################################
# PUBLIC METHODS
#############################################################################
=head1 Public Methods: Debugging
=cut
#############################################################################
# dbg()
#############################################################################
=head2 dbg()
This method is inherited from
L<C<P5EEx::Blue::Context>|P5EEx::Blue::Context/"dbg()">.
=cut
#############################################################################
# dbgprint()
#############################################################################
=head2 dbgprint()
This method is inherited from
L<C<P5EEx::Blue::Context>|P5EEx::Blue::Context/"dbgprint()">.
=cut
#############################################################################
# dbglevel()
#############################################################################
=head2 dbglevel()
This method is inherited from
L<C<P5EEx::Blue::Context>|P5EEx::Blue::Context/"dbglevel()">.
=cut
#############################################################################
# dbgscope()
#############################################################################
=head2 dbgscope()
This method is inherited from
L<C<P5EEx::Blue::Context>|P5EEx::Blue::Context/"dbgscope()">.
=cut
1;
