Apache-Wyrd
view release on metacpan or search on metacpan
use strict;
use warnings;
no warnings qw(uninitialized);
package Apache::Wyrd;
our $VERSION = '0.98';
use Apache::Wyrd::Services::SAK qw (token_parse slurp_file);
use Apache::Wyrd::Services::Tree;
use Apache::Util;
use Apache::Constants qw(:common);
###############################################################################
#Globals
###############################################################################
my $_dbl = undef;
my %_loglevel = (
'fatal' => 0,
'error' => 1,
'warn' => 2,
'info' => 3,
'debug' => 4,
'verbose' => 5,
);
###############################################################################
#Error Handling Anonymous Subroutines
###############################################################################
my %_error_handler = ();
my $_disabled_error_handler = sub {
return undef
};
my $_enabled_error_handler = sub {
my ($self, $value) = @_;
my @caller = caller();
$caller[0] =~ s/.+://;
$caller[2] =~ s/.+://;
my $id = "($caller[0]:$caller[2])";
$value = join(':', $id, $value);
$_dbl->log_event($value) if ($_dbl);
print STDERR "$value\n";
};
my $_fatal_error_handler = sub {
my ($self, $value) = @_;
die "_raise_exception called without object. Always call _raise_exception as a method, not a subroutine."
unless UNIVERSAL::isa($self, 'Apache::Wyrd');
my @caller = caller();
$caller[0] =~ s/.+://;
$caller[2] =~ s/.+://;
my $processing = undef;
$processing = $self->dbl->self_path if ($_dbl);
$processing ||= "{COULD NOT PROCESS PATH TO PERL OBJECT}";#assume self_path could be erroneously null
my $id = "($processing -- $caller[0]:$caller[2])";
$value = join(':', $id, $value , "\n". $self->{'_as_html'} . "\n");
if ($_dbl) {
my $htmlvalue = join(':', $id, $value , "<BR>\n". Apache::Util::escape_html($self->{'_as_html'}) . "<BR>\n");
$_dbl->log_event($htmlvalue);
}
die $value;
};
sub _verbose {
goto $_error_handler{$_loglevel{'verbose'}};
}
sub _debug {
goto $_error_handler{$_loglevel{'debug'}};
}
sub _info {
goto $_error_handler{$_loglevel{'info'}};
}
sub _warn {
goto $_error_handler{$_loglevel{'warn'}};
}
sub _error {
goto $_error_handler{$_loglevel{'error'}};
}
sub _fatal {
goto $_error_handler{$_loglevel{'fatal'}};
}
sub _raise_exception {
goto $_fatal_error_handler;
}
=pod
=head1 NAME
Apache::Wyrd - HTML embeddable perl objects under mod_perl
=head1 SYNOPSIS
NONE
=head1 DESCRIPTION
Apache::Wyrd is the core module in a collection of interoperating
modules that allow the rapid object-oriented development of web sites in
Apache's mod_perl environment (LAMP). This collection includes a very
flexible, HTML-friendly method of defining dynamic items on a web page,
and interfacing directly to perl objects with them. It comes with many
pre-built objects to support a web site such as an authentication
module, an reverse-lookup database, granular debugging, and smart
forms/inputs and their interfaces to a DBI-compliant SQL application.
The collection is not meant to be a drop-in replacement for PHP,
ColdFusion, or other server-side parsed content creation systems, but to
provide a more flexible framework for organic custom perl development
for an experienced perl programmer who favors an object-oriented
approach. It has been designed to simplify the transition from static
to dynamic web content by allowing the design of objects that can be
the abstract class for this purpose.
The modules in this distribution are not meant to be used directly.
Instead, instances of the objects are created in another namespace (in
all POD synopses called BASENAME, but it can be any string acceptable as
a single namespace of a perl class) where the Handler object has been
configured to use that namespace in interpreting HTML pages (see
C<Apache::Wyrd::Handler>).
=head2 SETUP
At the minimum, BASENAME::Wyrd needs to be defined, C<BASENAME::Handler>
needs to be defined and properly configured and able to properly invoke
an instance of C<BASENAME::DBL>. [N.B: A sample minimal installation,
C<TESTCLIENT> can be found in the t/lib directory of this package].
When a BASENAME::FOO Wyrd is invoked, and no BASENAME::FOO perl object can
be found, the object Apache::Wyrd::FOO will be tried. This allows the use
of any Apache::Wyrd::FOO objects derived from this module to be used in a
web page as BASENAME::FOO objects without explicitly subclassing them. If
neither a BASENAME::FOO nor an Apache::Wyrd::FOO object exists, a generic
(do-nothing) Apache::Wyrd object will be used rather than an error occur.
As one would expect, one namespace can also instantiate another namespace's
objects as long as the other namespace can be found in the local perl
installation's @INC array.
=head2 SYNTAX IN HTML
Wyrds are embedded in HTML documents as if they were specialized tags.
These tags are assigned attributes in a manner very similar to HTML
tags, in that they are formed like HTML tags with named attributes and
(optionally) with enclosed text, i.e.:
<NAME ATTRIBUTENAME="ATTRIBUTE VALUE">ENCLOSED TEXT</NAME>
They follow the XHTML syntax somewhat in that they require a terminating
whitespace followed by a forward-slash (/) before the enclosing brace
when they are embedded as "stand-alone" tags, and require quotes around
all attributes. Therefore:
<BASENAME::WyrdName name=imasample>
must either be written:
<BASENAME::WyrdName name="imasample"></BASENAME::WyrdName>
or as:
<BASENAME::WyrdName name="imasample" />
to be valid. Invalid Wyrds are ignored and do not get processed, but
may cause errors in other Wyrds if malformed, so it often pays to "view
source" on your browser while debugging.
Unlike (X)HTML, however, Wyrds are named like perl modules with the double-colon
syntax (BASENAME::SUBNAME::SUBSUBNAME) and these names are B<case-sensitive>.
Furthermore, either single or double quotes MUST be used around attributes, and
these quotes must match on either side of the enclosed attribute value. Single
quotes may be used, however, to enclose double quotes and vice-versa unless the
entire attribute value is quoted. When in doubt, escape quotes by preceding
them with a backslash (\). B<HTML tags should not appear inside attributes.>
See C<Apache::Wyrd::Template> and C<Apache::Wyrd::Attribute> for common ways
around this limitation.
Also unlike (X)HTML, one Wyrd of one type cannot be embedded in another of the
same type. We believe this is a feature(TM).
=head2 LIFE CYCLE
The "normal" behavior of a Wyrd is simply to disappear, leaving its enclosed
text behind after interpreting all the Wyrds within that text. It is through
"hook" methods that manipulation and output of perl-generated material is
accomplished.
Just as nested HTML elements produce different outcomes on a web page depending
on the order which they are nested in, Wyrds are processed relative to their
nesting. The outermost Wyrd is created (with the C<new> method) first from a
requested page and processes its enclosed text, spawning the next enclosing tag
within it, and so on. When the final nested Wyrd is reached, that Wyrd's
C<output> method is called and the resulting text replaces it on the page. The
C<output> method of each superclosing tag is called in turn, repeating the
process. Between C<new> and C<output> are several stages. In these stages,
"hooks" for Wyrd specialization are called:
=over
=item 1.
C<new> calls C<_setup> which allows initialization of the Wyrd B<before> it
processes itself, spawning enclosed Wyrds.
=item 2.
C<_setup> returns the object, which waits for the C<output> call to be
performed on it by it's parent or by the Handler.
=item 3.
When the C<output> method is called, it processes itself, meaning that
it goes through the enclosed text (if any), finding embedded Wyrds.
When such a Wyrd is found, it spawns a new object based on itself,
inheriting the same C<Apache::Wyrd::DBL>, the same C<Apache> request
object, the same loglevel (see attributes, below), and so on. Prior to
spawning, the hook method C<_pre_spawn> is called to allow changes to
the new Wyrd before it is created.
=item 4.
C<output> then calls the two hooks, C<_format_output> which is meant to handle
changes to the enclosing text and C<_generate_output> which returns the actual
text to replace the Wyrd at that point in the HTML page.
=back
In most cases, there will not be any need to override non-hook methods. For minor variations on Wyrd behavior, most
of the built-in Wyrds can be quickly extended by overriding the method with a method that calls the SUPER class:
sub _setup {
my $self = shift;
#allow user-defined filters on all Wyrds
($class, $init) = $self->_pre_spawn($class, $init);
#loglevel/dielevel will be inherited if it exists, but not if the object explicitly has it defined
$init->{'loglevel'} = $self->{'loglevel'} unless(exists($init->{'loglevel'}));
$init->{'dielevel'} = $self->{'dielevel'} unless(exists($init->{'dielevel'}));
#Temporarily "hide" the global so that loglevel changes in children do not
#propagate back up into their parents.
my %_error_handler_temp = %_error_handler;
my ($child) = ();
#first attempt to find a perl class which is in the base_class hierarchy
eval('require ' . $self->base_class . '::' . $class);
eval('$child = ' . $self->base_class . '::' . $class . '->new($self->dbl, $init)');
if ($@) {
if ($@ =~ /^Can't locate object method "new"/) {
$self->_info("No direct implementation of $class in " . $self->base_class . " Looking in core class...");
} else {
$self->_raise_exception("Compilation Error in " . $self->base_class . "::" . $class . ":" . $@);
}
} else {
$self->_info("Using $class from " . $self->base_class);
}
#if that doesn't work, go into the Apache::Wyrd class
unless (ref($child)) {
eval('require Apache::Wyrd::' . $class);
eval('$child = Apache::Wyrd::' . $class . '->new($self->dbl, $init)');
if ($@) {
if ($@ =~ /^Can't locate object method "new"/) {
$self->_error("No direct or indirect implementation of $class...");
} else {
$self->_raise_exception("Compilation Error while spawning a new Wyrd: " . $@);
}
}
unless (ref($child)) {
$self->_raise_exception("Giving up! Don't know how to make a $child") if ($self->dbl->strict);
$child = Apache::Wyrd->new($self->dbl, $init);
$child->{'_attempted'} = $self->base_class . '::' . $class;
}
}
#Restore the loglevel of this parent so that it's child's changes to the
#global variable do not affect it.
%_error_handler = %_error_handler_temp;
return (undef, $self->base_class . "$class could not be generated.") unless ref($child);
return $child, undef;
}
sub _invoke_html_wyrd {
my ($self, $class, $params, $data, $original) = @_;
my $base_class = $self->base_class;
$self->_debug("$original is the original\n");
$self->_debug("$base_class is the base class\n");
$self->_debug("$class is the class\n");
$self->_debug("$params is the params\n");
$self->_debug("$data is the data\n");
my $match = 0;
my (%init, $init_ref, $unescape) = ();
$self->_error("Attempted recursion of $class") if ($data =~ /<$base_class\:\:$class[\s>]/);
#drop the nest identifier
$class =~ s/([^:]):([^:]+)$/$1/ && $self->_info("dropped the nest identifier $2");
#encode the escaped-out " and '
$params =~ s/\\'/<!apostrophe!>/g;
$params =~ s/\\"/<!quote!>/g;
#escape-out special characters when they are the only attribute
$params =~ s/\$/<!dollar!>/g;
$params =~ s/\@/<!at!>/g;
$params =~ s/\%/<!percent!>/g;
$params =~ s/\&/<!ampersand!>/g;
#nullify the blank attributes
$params =~ s/""/"<!null!>"/g;
$params =~ s/''/'<!null!>'/g;
#zerofy the numerical zero attributes
$params =~ s/"0"/"<!zero!>"/g;
$params =~ s/'0'/'<!zero!>'/g;
#Process Params:
do {
$match = 0;
$match = ($params =~ m/
\G #last search match
[^\w-]* #any amount of non-word space
(?: #non-capturing cluster 1
([^=]+) #non-equals
\s*=\s* #an equals with or without whitespace around it
(?: #non-capturing cluster 2
"([^"]+)" #non-double-quotes surrounded by double-quotes
| #or
'([^']+)' #non-single-quotes surrounded by single quotes
) #end of non-capturing cluster 2
| #or
([\w-]+) #plain word
) #end of non-matching cluster 1
\W* #and any amount of non-word space
/xmsg);
if ($match) {
#warn "1: $1 2: $2 3: $3 4: $4";
if ($1) {
$init{lc($1)} = ($2 || $3);
$self->_debug(lc($1) . " is '" . $init{$1} . "'\n");
} else {
$init{lc($4)} = 1;
$self->_debug(lc($4) . " is '1'\n");
}
}
} while $match;
foreach my $i (keys(%init)) {
$init{$i} =~ s/<!apostrophe!>/'/g;
$init{$i} =~ s/<!quote!>/"/g;
$init{$i} =~ s/<!null!>//g;
$init{$i} =~ s/<!zero!>/0/g;
$init{$i} =~ s/<!dollar!>/\$/g;
$init{$i} =~ s/<!at!>/\@/g;
$init{$i} =~ s/<!percent!>/\%/g;
$init{$i} =~ s/<!ampersand!>/\&/g;
}
#store the HTML of the wyrd
$init{'_as_html'} = $original;
$init{'_data'} = $data || '';
#spawn the new object
my ($wyrd, $err) = $self->_spawn($class, \%init);
#Either call output on the object or give up
if ($err) {
( run in 1.426 second using v1.01-cache-2.11-cpan-98e64b0badf )