##
<!-- =perl $title -->page title<!-- /perl -->
Caption
1 foo
2 bar
####
#!/usr/bin/perl
package My::Special::View;
use Servlet qw(servlet);
my $s = servlet(
in => "example.html",
# nostrict => 1, # ah, no, never :-)
args => [ qw($title $header1 $arrayref) ],
);
$s->(
"sample servlet page",
"Servlet Heading for a table",
[[1,a],[2,b]]
);
####
#!/usr/bin/perl
package My::Special::View;
use Servlet;
my $s = Servlet->new(
in => "example.html",
args => [ qw($title $header1 $ref) ],
);
$s->render("page","heading",[['foo',1,2],[bar,3,4],[quux,5,6]]);
my @lines = $s->output;
# or
# @lines = $s->render->output;
# then postproess, whatever..
# and finally print them
print @lines;
# direkt render & print
$s->display("page","heading",[['foo',1,2],[bar,3,4],[quux,5,6]]);
####
#!/usr/bin/perl
package My::Special::View;
use Servlet qw(AUTOLOAD);
example("sample servlet page","Servlet Heading for a table",
[[1,a],[2,b]]);
####
#!/usr/bin/perl
package My::Special::View;
use strict;
# File generated by Servlet 0.01 at Sat Jun 17 13:55:02 2006
# from source: example.html
# WARNING: changes made here will be overwritten upon re-creation.
use File::Temp qw( tempfile ); # required once in My::Special::View
return sub {
my ($title, $header1, $ref) = @_;;
my ($___example_fh,$___example_fn,$___example_oldfh);
my $wantarray = wantarray();
if(wantarray) {
($___example_fh,$___example_fn) = tempfile() or die "can't tempfile: $!\n";
$___example_oldfh = select ($___example_fh); $| = 1;
}
print <<"E0000";
$title
$header1
E0000
unless($ref) {
print <<"E0001";
No data provided.
E0001
} else {
print <<"E0002";
E0002
foreach my $ary(@$ref) {
print <<"E0003";
E0003
map {
print <<"E0004";
$_
E0004
} @$ary;
}
print <<"E0005";
E0005
}
print <<"E0006";
E0006
if($wantarray) {
local *I;
open(I,"<",$___example_fn) or warn "My::Special::View::example: Can't open $___example_fn for reading: $!\n";
my @text = ;
close(I); unlink($___example_fn);
select($___example_oldfh);
return @text;
}
};
####
sample servlet page
Servlet Heading for a table
1
a
2
b
####
package Servlet;
use Carp;
use strict;
use 5.006_001;
our($VERSION, $AUTOLOAD, $exported,$debug);
my $is_dosish;
my $is_epoc;
my $is_vms;
my $is_macos;
BEGIN {
$is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare';
$is_epoc = $^O eq 'epoc';
$is_vms = $^O eq 'VMS';
$is_macos = $^O eq 'MacOS';
$VERSION = '0.01';
}
$Servlet::dir ||= '';
my @export_ok = qw(AUTOLOAD servlet);
my %T; # timestamps
my %S; # subs - our own %INC...
sub new {
my $class = shift;
my $caller = caller;
bless { 'sub' => servlet($caller,@_) }, $class;
}
# Output the servlet.
# At this point, the timestamps of the servlets source and its
# sub could be checked, and the sub recreated and reloaded.
sub display {
my $self = shift;
if($self->{'output'}) {
print @{$self->{'output'}};
} else {
$self->{'sub'}->(@_);
}
$self;
}
# get the output from the servlet.
sub output {
@{$_[0]->{'output'}};
}
# just render the servlet, store it's output.
# we use the value of wantarray() in the servlet function to
# determine if the output should be printed or returned.
sub render {
my $self = shift;
my @l = $self->{'sub'}->(@_);
$self->{'output'} = [@l];
$self;
}
# get the servlet's stored subroutine,
# require the servlet.al file
# or create it and require then
sub servlet {
my $callpkg = caller;
my $class = $callpkg eq __PACKAGE__ ? shift : $callpkg;
confess __PACKAGE__.' class wants no servlet! -'
if $class eq __PACKAGE__;
my %a = @_;
$a{'in'} or $a{'code'}
or confess __PACKAGE__.'::servlet: '
."provide at least one of argument for 'in' and 'code'\n";
-f $a{'in'} or confess "Can't find file '$a{in}' - $!\n" if defined($a{'in'});
# if we have 'in' and no 'code', process into standard path auto/__PACKAGE__
# if we have 'in' and 'code', name function & file after 'code'.
# if we have 'code' and no 'in', load that file, function is named after 'code'.
my ($sub, $function, $outfile);
if($a{'in'}) {
my $infile = $a{'code'} || $a{'in'};
($outfile = $infile ) =~ s/\.\w+$//;
(my $classpath = $class ) =~ s#::#/#g;
my $dir = "auto/$classpath";
substr($dir,0,0) = $servlet::dir .'/' if $Servlet::dir;
_mkdir_p($dir) unless -d $dir;
$outfile =~ s#.*/##;
substr($outfile,0,0) = $dir.'/';
$outfile .= '.al';
} else {
$outfile = $a{'code'};
}
($function = $outfile) =~ s#^.*/|\.\w+$##g;
if( ($function eq 'servlet') && $exported) {
carp "function for '$a{in}' resolves to servlet,\n"
."which is exported from ".__PACKAGE__."\n"
.'pointing gun at left foot. shooting...';
}
# check time of source & servlet.al
if(_time_ok($a{'in'},$outfile) || (!$a{'in'} && -f $outfile)) {
return $S{$outfile} if $S{$outfile}; # already known
# we use eval EXPR because we need to switch package
$S{$outfile} = $sub = eval "package $class; require '$outfile';";
} else {
# get rid of the old stuff, so we can require again.
delete $INC{$outfile};
local *O; # we could use Symbol and such, but what for?
local $/; # slurp
local *I;
open(I,"<$a{in}") or confess "can't read '$a{in}': $!";
open(O,">$outfile") or confess "Can't write $outfile: $!";
my $oldfh = select O;
local $\; # reset -l switch locally
my $text = ;
# first weed out sample content
$text =~ s/.*?//gs;
# then strip variables of enclosing tags
$text =~ s/<\!-- =perl\s*(.+?)\s*-->(.*?<\!--\s*\/perl\s*-->)?/$1/g;
# then, convert all into print <<"Exxxx" statements
# and leave perl code as is
my $t = "E0000"; # tag for here-document print statements
my $s = '';
$text =~ s/(.+?)?<\!-- perl\s*(.*?)?\s*-->|(.+)/
my $a = $1 if $1;
$a .= $3 if $3;
my $b = $2 || '';
$a =~ s#[\s*\n]*$#\n#;
($s = "\nprint <<\"$t\";\n".$a.$t++."\n".$b)=~s#\n+#\n#g;
$s
/ges;
# The output of the servlet is delivered straight to the
# selected filehandle or returned to the caller.
# We use wantarray() to determine the current context.
# If wantarray() returnes true, the output is captured into
# a temporary file which filehandle we select(). Thus all
# print() without explicit filehandle ends up in the tempfile
# and we can return its content as a list of lines.
#
# This mess is necessary because servlets may be chained, and
# we don't want output going unadverted into STDOUT or such.
my $strict = 'use strict;' unless $a{'nostrict'};
my $args;
$args = 'my ('.join(', ',@{$a{'args'}}).') = @_;' if ($a{'args'});
my $pkg = __PACKAGE__;
my $t = scalar(localtime(time));
print <<"EOH";
#!$^X
package $class;
$strict
# File generated by $pkg $VERSION at $t
# from source: $a{in}
# WARNING: changes made here will be overwritten upon re-creation.
use File::Temp qw( tempfile ); # required once in $class
return sub {
$args;
my (\$___${function}_fh,\$___${function}_fn,\$___${function}_oldfh);
my \$wantarray = wantarray();
if(wantarray) {
(\$___${function}_fh,\$___${function}_fn) = tempfile() or die "can't tempfile: \$!\\n";
\$___${function}_oldfh = select (\$___${function}_fh); \$| = 1;
}
$text
if(\$wantarray) {
local *I;
open(I,"<",\$___${function}_fn) or warn "$class\::$function: Can't open \$___${function}_fn for reading: \$!\\n";
my \@text = ;
close(I); unlink(\$___${function}_fn);
select(\$___${function}_oldfh);
return \@text;
}
};
EOH
close(O);
select $oldfh;
$sub = eval "package $class; require '$outfile';";
confess $@ if $@;
$S{$outfile} = $sub;
}
no strict 'refs';
if ($a{'import'}) {
*{$class.'::'.$function} = $sub;
}
$sub;
}
# ==============================================================================
# private subs
# ==============================================================================
# timestamp
sub _time_ok {
if ($_[0] and $_[1]) {
(stat($_[0]))[9] <= (stat($_[1]))[9] if -f $_[0] and -f $_[1];
}
}
# mkdir -p
sub _mkdir_p {
my @l = split(/\//,$_[0]);
my $dir = shift(@l);
mkdir($dir,0755) unless -d $dir;
foreach my $d(@l) {
$dir .= "/$d";
unless(-d $dir) {
mkdir($dir,0755) or confess "huh? - mkdir($dir,0755): $!\n";
}
}
}
1;
# From here on slightly modified AutoLoader.pm
AUTOLOAD {
my $sub = shift;
if ($sub =~ /.*::servlet$/) {
require Carp;
Carp::confess("servlet may not be autoloaded");
}
my $filename;
# Braces used to preserve $1 et al.
{
# [ AutoLoader comments deleted ]
my ($pkg,$func) = ($sub =~ /(.*)::([^:]+)$/);
$pkg =~ s#::#/#g;
if (defined($filename = $INC{"$pkg.pm"})) {
if ($is_macos) {
$pkg =~ tr#/#:#;
$filename =~ s#^(.*)$pkg\.pm\z#$1auto:$pkg:$func.al#s;
} else {
$filename =~ s#^(.*)$pkg\.pm\z#$1auto/$pkg/$func.al#s;
}
# # [ AutoLoader comments deleted ]
if (-r $filename) {
unless ($filename =~ m|^/|s) {
if ($is_dosish) {
unless ($filename =~ m{^([a-z]:)?[\\/]}is) {
if ($^O ne 'NetWare') {
$filename = "./$filename";
} else {
$filename = "$filename";
}
}
}
elsif ($is_epoc) {
unless ($filename =~ m{^([a-z?]:)?[\\/]}is) {
$filename = "./$filename";
}
}
elsif ($is_vms) {
# XXX todo by VMSmiths
$filename = "./$filename";
}
elsif (!$is_macos) {
$filename = "./$filename";
}
}
}
else {
$filename = undef;
}
}
unless (defined $filename) {
# let C do the searching
$filename = "auto/$sub.al";
$filename =~ s#::#/#g;
}
}
my $save = $@;
local $!; # Do not munge the value.
# BEGIN changes
my $ref;
$ref = eval { local $SIG{__DIE__}; require $filename };
# END changes
if ($@) {
if (substr($sub,-9) eq '::DESTROY') {
no strict 'refs';
*$sub = sub {};
$@ = undef;
} elsif ($@ =~ /^Can't locate/) {
# [ AutoLoader comments deleted ]
if ($filename =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){
$ref = eval { local $SIG{__DIE__}; require $filename };
}
}
if ($@){
# $@ =~ s/ at .*\n//; # why???
my $error = $@;
require Carp;
Carp::croak($error);
}
}
$@ = $save;
goto ref($ref) eq 'CODE' ? $ref : &$sub;
}
sub import {
my $pkg = shift;
my $callpkg = caller;
#
# Export symbols, but not by accident of inheritance.
#
my %a;
@a{@_} = @_;
if ($pkg eq 'Servlet') {
no strict 'refs';
foreach my $symbol(@export_ok){
*{ $callpkg . '::' . $symbol } = \&$symbol
if $a{$symbol};
$exported++ if $symbol eq 'servlet';
}
}
# I've left out the autosplit searching.
}
sub unimport {
my $callpkg = caller;
no strict 'refs';
my $symname = $callpkg . '::AUTOLOAD';
undef *{ $symname } if \&{ $symname } == \&AUTOLOAD;
*{ $symname } = \&{ $symname };
}
1;
__END__