cvsuser 02/02/01 11:09:41
Added: P5EEx/Blue/P5EEx/Blue/Context HTML.pm
Log:
added as a base class for Context::CGI to capture methods to be shared with classes
like Context::ModPerl
Revision Changes Path
1.1 p5ee/P5EEx/Blue/P5EEx/Blue/Context/HTML.pm
Index: HTML.pm
===================================================================
#############################################################################
## $Id: HTML.pm,v 1.1 2002/02/01 19:09:41 spadkins Exp $
#############################################################################
package P5EEx::Blue::Context::HTML;
use P5EEx::Blue::P5EE;
use P5EEx::Blue::Context;
@ISA = ( "P5EEx::Blue::Context" );
use strict;
use CGI;
=head1 NAME
P5EEx::Blue::Context::HTML - A base class for contexts that serve up HTML (CGI,
Modperl, etc.)
=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::CGI;
$context = P5EEx::Blue::Context::CGI->new();
=cut
#############################################################################
# DESCRIPTION
#############################################################################
=head1 DESCRIPTION
This is a base class for contexts that serve up HTML (CGI, Modperl, etc.).
It should never be instantiated for direct use.
A Context class models the environment (aka "context)
in which the current process is running.
There are many things in common between the various contexts that serve
web browsers via HTML.
This class provides those things.
The Context object is a singleton per process.
=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
#############################################################################
# display_current_widget()
#############################################################################
=head2 display_current_widget()
The display_current_widget() method searches the "default widget" for an
attribute of "wname" and uses that as the name of the widget which should
be displayed in the browser.
* Signature: $context->display_current_widget()
* Param: void
* Return: void
* Throws: P5EEx::Blue::Exception
* Since: 0.01
Sample Usage:
$context->display_current_widget();
=cut
sub display_current_widget {
my $self = shift;
$self->display_items("Hello world!"); # temporary
}
#############################################################################
# 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 ($cgi, $title, $bodyoptions, $w, $var, $value, $wc_body, $wc_head);
$cgi = $self->{cgi};
$bodyoptions = "";
if ($w) {
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\"";
}
}
}
$wc_body = $self->body_html(\%main::conf);
$wc_head = $self->head_html();
$self->shutdown();
my ($gzip, $accept_header, $header, $data);
$header = "Content-type: text/html\n";
$data = <<EOF;
<html>
<head>
<title>${title}</title>
$wc_head</head>
<body${bodyoptions}>
<form method="POST">
$wc_body
$html</form>
</body>
</html>
EOF
if ($main::target) {
$header .= "Window-target: $main::target\n";
}
if ($main::conf{gzip}) {
$accept_header = $cgi->http("Accept-Encoding");
$gzip = ($accept_header =~ /gzip/);
if ($gzip) {
$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::Context::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($conf);
"";
}
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::Context::DEBUG && $self->dbg(ref($self),
"set_head_html", 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::Context::DEBUG >= 3 && $self->dbg(ref($self),
"set_head_html", 3));
}
}
1;
