Apache-XPP
view release on metacpan or search on metacpan
lib/Apache/XPP.pm view on Meta::CPAN
HTTP::Request
LWP::UserAgent
=cut
use Carp;
use strict;
use vars qw( $AUTOLOAD $debug $debuglines );
BEGIN {
$Apache::XPP::REVISION = (qw$Revision: 1.32 $)[-1];
$Apache::XPP::VERSION = '2.02';
}
use Apache::XPP::Cache;
use Apache::XPP::PreParse;
if ($INC{ 'Apache.pm' }) {
eval q{
use Apache();
use Apache::Constants qw(:response);
};
}
use Carp;
use File::stat;
use FileHandle;
use HTTP::Request;
use LWP::UserAgent;
=head1 EXPORTS
Nothing
=head1 DESCRIPTION
Apache::XPP is an HTML parser which on run time compiles and runs embedded perl code.
=head1 CLASS VARIABLES
=over
=item C<$Apache::XPP::main_class>
XPP sub-classes must set $Apache::XPP::main_class to the name of the
sub-class. This will allow xinclude/include to work properly.
=cut
$Apache::XPP::main_class = 'Apache::XPP';
=item C<$debug>
Activates debugging output. All debugging output is sent to STDERR.
At present there are only 4 levels of debugging :
0 - no debugging (default)
1 - some debugging
2 - verbose debugging
3 - adds some Data::Dumper calls
=item C<$debuglines>
Optionally, you can activate the $debuglines, which will cause all
debugging output to include the line numbers (in this file) of the debugging.
=back
=cut
$debug = 0;
$debuglines = 0;
=head1 METHODS
=over
=item C<handler> ( $r )
The Apache handler hook. This is the entry point for the Apache module. It
takes the Apache request object ($r) as its parameter and builds a new XPP
object to handle the request. In order to support the procedural nature
of include() and xinclude() a global is defined. If you subclass Apache::XPP
replace the value of the global L<"$Apache::XPP::main_class"> with your class name.
=cut
sub handler ($$) {
my $class = shift;
my $r = shift;
# handle things other than GET or POST gracefully here
unless ($r->method eq 'GET' || $r->method eq 'POST') {
return NOT_IMPLEMENTED();
}
# Prevent browser caching
$r->no_cache(1);
# Get the file and build a new XPP object
warn "\nxpp: handler called" . ($debuglines ? '' : "\n") if ($debug);
my $xpp = $class->new( {
filename => $r->filename,
r => $r,
is_main => 1,
server_name => $r->get_server_name,
XPMLHeaders => $r->dir_config( 'XPMLHeaders' ),
XPMLFooters => $r->dir_config( 'XPMLFooters' ),
XPPIncludeDir => $r->dir_config( 'XPPIncludeDir' ),
XPPVHostIncludeDir => $r->dir_config( 'XPPVHostIncludeDir' )
} );
if (ref($xpp)) {
eval {
$xpp->run;
};
if ($@) {
warn "Bad things happened. XPP page didn't compile: $@";
return SERVER_ERROR();
lib/Apache/XPP.pm view on Meta::CPAN
} else {
warn "xpp: using cached header object"
. ($debuglines ? '' : "\n") if ($debug);
$$headorfoot .= $hfcache;
}
} else {
warn "xpp: caching new header object"
. ($debuglines ? '' : "\n") if ($debug);
$hfxpp = bless($params, $class);
$$headorfoot .= $hfxpp->load( $filename );
}
}
}
$source = $header . $source . $footer;
$self->parse( $self->preparse( $source ) );
$self->compiletime( time );
$cache{ $specifier } = $self;
} # END constructor new
} # END private codeblock
=item C<preparse> ( )
Pre-Parses the object's code, converting TAGS to text and xpp code. This method passes a
reference to the xpp source to each preparser returned by the preparse class's C<parses>
method. (The preparse class is returned by the C<preparseclass> method).
=cut
sub preparse {
my $self = shift;
my $class = ref($self) || return undef;
my $source = shift;
warn "xpp: preparsing source" . ($debuglines ? '' : "\n") if ($debug);
foreach my $pparser (@{ $class->preparseclass->parsers() }) {
warn "xpp: \t$pparser" . ($debuglines ? '' : "\n") if ($debug);
$class->preparseclass->$pparser( \$source );
}
return $self->source( $source );
} # END method preparse
=item C<parse> ( )
Parses the object's xpp source code, populating the object's C<code> attribute
with a subroutine reference which when run (with the C<run> method), will result
in the printing of the xpp page.
=cut
sub parse {
my $self = shift;
my $class = ref($self) || return undef;
my $string = $self->source;
warn "xpp: parsing source" . ($debuglines ? '' : "\n") if ($debug);
my @codesrc;
{
if ($debug >= 3) {
eval "use Data::Dumper;";
local($Data::Dumper::Indent) = 0;
}
warn "xpp: parsing source:\n<<\n$string\n>>" . ($debuglines ? '' : "\n") if ($debug);
# The regex in the while() statement below is somewhat complex. It was placed in one line for efficiency,
# but this is how it came to be:
# my $re_b = q{<\?(?:xpp)?(=)?((?:(?!<\?|\?>).)*}; # only q{} and not qr{} because there is an imbalanced paren matched in the next line
# my $re_e = q{(?:(?!\?>).)*)\?>}; # only q{} and not qr{} because there is an imbalanced paren matched in the previous line
# my $double_xpp = qr{${re_b}(?:${re_b}${re_e})?${re_e}}so;
# my $regex = qr(^((?:(?!<\?).)*)$double_xpp)s;
# # this was the old xpp parsing regex (which didn't handle embedded tags).
# while (($string =~ s/^(.*?)\<\?(?:xpp)?(=)?(.*?\s*)\?\>//so) || ($string =~ s/^(.+)$//so)) {
while (($string =~ s/^((?:(?!<\?).)*)<\?(?:xpp)?(=)?((?:(?!<\?|\?>).)*(?:<\?(?:xpp)?(?:=)?(?:(?!<\?|\?>).)*(?:(?!\?>).)*\?>)?(?:(?!\?>).)*)\?>//so) || ($string =~ s/^(.+)$//so)) {
my $text = $1;
my $print = $2 ? 1 : 0;
my $code = $3;
warn Data::Dumper->Dump([$text,$code], [qw(text code)]) if ($debug >= 3);
$text =~ s#\\#\\\\#gso;
$text =~ s#\'#\\\'#gso;
if ($text) {
if ($self->is_main() && !$self->r()->notes('headersaway')) {
push(@codesrc, "\$xpp->r()->send_http_header();\n");
$self->r()->notes(headersaway => 1);
}
my $textsrc = 'print ' . join(qq{ . "\\n"\n\t. }, map { qq{'$_'} } (split(/\n/, $text,-1))) . ";";
push(@codesrc, $textsrc); }
if (defined $code) {
if ($print) {
push(@codesrc, qq{print ($code);});
} else {
push(@codesrc, $code);
}
}
}
}
my $type = (ref($self->r()) ? $self->r()->content_type() : '');
my $filename = defined($self->filename()) ? $self->filename() : '';
my $joined = join('', (@codesrc));
my $codesrc = qq{
sub {
package Apache::XPP::Page;
my \$xpp = shift;
if (ref(\$xpp->r())) {
\$xpp->r()->content_type( "${type}" );
}
#line 0 ${filename}
${joined}
}
};
warn "xpp: source:\n" . $codesrc . ($debuglines ? '' : "\n") if ($debug >= 2);
my $code = eval $codesrc;
if ($@) {
warn "*** XPP COMPILE ERROR: $@";
return undef;
} else {
return $self->code( $code );
}
} # END method parse
=item C<run> ( @arguments )
Runs the XPP code (set by the C<parse> method), passing any arguments supplied to the code.
This should have the effect of printing the xpp page to STDOUT.
=cut
sub run {
my $self = shift;
my $class = ref($self) || return undef;
warn "xpp: running xpp code" . ($debuglines ? '' : "\n") if ($debug);
if (ref($self->code)) {
lib/Apache/XPP.pm view on Meta::CPAN
my $proto = shift;
my $class = ref($proto) || $proto;
my $content = '';
my $self = bless(\$content, $class);
}
sub PRINT {
my $self = shift;
warn "tie: caught print" . ($$debuglines ? '' : "\n") if ($$debug);
warn "tie:\t@_" . ($$debuglines ? '' : "\n") if ($$debug >= 2);
${ $self } .= join($,, @_) . (defined($\) ? $\ : '');
}
sub PRINTF {
my $self = shift;
warn "tie: caught printf" . ($$debuglines ? '' : "\n") if ($$debug);
warn "tie:\t" . sprintf( @_ ) . ($$debuglines ? '' : "\n") if ($$debug >= 2);
${ $self } .= sprintf( @_ );
}
sub content {
my $self = shift;
return ${ $self };
}
1;
__END__
=back
=head1 REVISION HISTORY
$Log: XPP.pm,v $
Revision 1.32 2002/02/15 05:00:01 kasei
- fixed bugs introduced by adding Apache::XPP::Inline
Revision 1.31 2002/02/15 02:39:31 kasei
- merged 1.30 and 1.28 conflicts
Revision 1.30 2002/02/15 02:17:06 kasei
- Fixed quoting bug with $r->content_type
- Changed use constant to use subs for Apache constants when in a non m_p environment
Revision 1.29 2002/02/01 08:22:12 kasei
Reduced dependance on Apache (still waiting on testing to confirm nothing broke)
Revision 1.28 2002/01/16 22:06:46 kasei
- Updated README to mention version 2.01
- POD typo fix in XPP.pm
Revision 1.27 2002/01/16 21:06:01 kasei
Updated VERSION variables to 2.01
Revision 1.26 2002/01/16 21:00:02 kasei
- Added PREREQ_PM arguments to Makefile.PL
- XPP.pm now only uses Data::Dumper if $debug >= 3 (not listed as a prereq)
Revision 1.25 2000/09/23 01:22:06 dweimer
Fixed VHostIncludeDir's, thanks david.
Revision 1.24 2000/09/20 00:33:18 zhobson
Fixed a warning in docroot(), misplaced "-" made it look like an invalid range
Revision 1.23 2000/09/08 22:26:44 david
added, changed, revised, and otherwise cleaned up a lot of POD
cleaned up new()
- removed dependence on MD5 (uses conventional checksum)
- folded nearly duplicate header and footer code into a loop
incdir()
- now uses Apache->server_root_relative() instead of $ENV{SERVER_ROOT}
debug()
- new method to manipulate $debug and $debuglines globals
Apache::XPP::Tie class now uses $debug settings of Apache::XPP class
"This would go great with gwack-a-mole!" - Z.B.
Revision 1.22 2000/09/08 00:42:45 dougw
Took out rscope stuff.
Revision 1.21 2000/09/07 23:42:23 greg
fixed POD
Revision 1.20 2000/09/07 23:30:40 dougw
Fixed over.
Revision 1.19 2000/09/07 20:15:54 david
new(), r() - makes previous bug fix less agressive, yet more thorough.
Revision 1.18 2000/09/07 19:49:01 david
r() - fixed peculiar (and elusive) bug where DirectoryIndex accessed pages
(and potentially any page using a subrequest) caused a segmentation fault
with cached pages.
Revision 1.17 2000/09/07 18:48:11 dougw
Small update
Revision 1.16 2000/09/07 18:45:14 dougw
Version update
Revision 1.15 2000/09/06 23:42:50 dougw
Modified POD to be consistent with BingoX
=head1 SEE ALSO
perl(1).
=head1 KNOWN BUGS
None
=head1 TODO
precompile
=head1 COPYRIGHT
( run in 1.181 second using v1.01-cache-2.11-cpan-0bb4e1dffa6 )