Framework is a way to automate the upkeep and processing of CGI scripts through a well defined structure which implements pre- and post- CGI submission handling, business rule validation and templatization.
This is the project which I've commented on several times here, and I wish to submit it to brutal peer review.
First off, a revisit to the structure that drives the module. The primary datastore is %pages, which contains one or more page items, identified by their pagename. each page item contains several keys, as follows.
module : Optional, but highly recommended.
A page's perl code can be split out into
several modules, and whatever's in the
file specified by the module key will be
pushed into the MAIN namespace.
description : A string of questionable value
traverse_list : hash where the keys are pagenames, and the
values are true/ false to indicate if
post-submit processing is needed when
traversing to this page.
traverse_sub : reference to a sub used to determine which
member of traverse list to access.
validator : sub reference used to validate data on the
current page.
errorhandler : Not currently implemented.
template : String containing filepath to a TT2 template
Contains the HTML that will actually be displayed.
preprocess : Sub reference run before the page is displayed.
postsubmit : Sub reference run after the page is displayed.
params : Determines which CGI params are to be kept alive
between invocations.
OK.
Here is a small snippet from my proof of concept program (a small web journal) showing how to add pages to the collection, and then run the collection :
#!e:\perl\bin\perl.exe
use strict;
use Framework;
use CGI;
use DBI;
use Date::Manip;
use constant BASEPATH => 'c:/progra~1/apache~1/apache/cgi-bin/';
InsertPage_hashref ( {
pagename=> "Entry",
module => BASEPATH . 'entry.pl',
description => "Entrance to the journal",
traverse_list => {Entry=>0,
writejournal => 0,
readjournal => 0,
editjournal => 0},
traverse_sub => \&entry_trav,
validator => undef,
errorhandler => undef,
template => 'templates/JEntry.html',
preprocess => undef,
postsubmit => undef,
params => ["read.x","write.x","edit.x"]});
InsertPage_hashref ( {
pagename=> "writejournal",
module => BASEPATH . 'jwrite.pl',
description => "write a new journal entry",
traverse_list => {Entry=>0,
writejournal => 1,
readjournal => 0},
traverse_sub => \&entry_trav,
validator => \&write_valid,
errorhandler => undef,
template => 'templates/Jwrite.html',
preprocess => undef,
postsubmit => \&write_sub,
params => []});
RunPages;
The first two statements add two HTML pages and the subroutines and arrays required to automate the page's upkeep.
RunPages process the CGI parameters and runs the current page's subroutines to verify and process data.
Following is a sample of some of the subs that run behind the scenes. First up is a sub called write_sub, which takes the entry the user's working on, and saves it to a databse. Firstly, the Framework variables and errorcode are passed in. The get_errorlevel call performs the same function as shifting in $errorcode; this demonstrates 2 methods of doing the same thing, although I think the shiftiness is going to go away.
After checking to make sure all the data is valid -- e.g. that $errorcode is false, it prepares to insert the journal entry into a csv database. most of the code for dealing with the CSV, replicating an IDENTITY row...
sub write_sub {
my $vars = shift;
my $errorcode = shift;
if (&get_errorlevel) {return} # don't write anything to the
+database if something's errored out on us.
my $dbh = DBI->connect("DBI:CSV:f_dir=c:/journal/");
my $sth = $dbh->prepare ("SELECT id FROM entries") || die "$! and
+$DBI::errstr";
$sth->execute;
my $maxid;
while (my $thisrow = $sth->fetchrow_arrayref) {
if ($$thisrow[0] > $maxid) {$maxid = $$thisrow[0]}
};
$maxid++;
my $title = $dbh->quote ($$$vars{params}{title});
my $date = $dbh->quote (scalar localtime);
my $entry = $dbh->quote (unpack ("H*",$$$vars{params}{entry}));
+ # Hi, Tye!
$sth = $dbh->prepare ("INSERT INTO entries (id, date, title, entry
+) VALUES ($maxid, $date,$title, $entry)")|| die "$! and $DBI::errstr"
+;
$sth->execute;
}
More or less straightforward, I hope. But where does the errorcode come from, and what it tell us?
Before we get to the point of post submittal processing, the following sub is called to make sure the data on this HTML page meets whatever critera I choose. In this case, I want to make sure there's a title and and an entry. If there isn't, I set two flags in the sub's return code, $ret_code. This return value is then passed to write_sub.
sub write_valid {
my $vars = shift;
my $error = shift;
my $ret_code;
my @t = param ("title");
my @e = param ("entry");
unless ($t[-1]){$ret_code |= 1};
unless ($e[-1]){$ret_code |= 2};
return $ret_code;
}
This shows one particular segment of how the framework is used. It segments common tasks into automatable subroutines, and allows the programmer to decide how to build upon the framework.
Here is the code for Framework.PM.
package Framework;
#!/usr/bin/perl -w
# In nomine Ad Signo, et Percentus, et Dollar Signo Sancti. Amen.
use strict;
require Exporter;
use Template;
use DBI;
use CGI::Carp qw(fatalsToBrowser);
use CGI qw(:all);
use constant DEBUG => 0;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
use vars qw($defaultpage $Current_Page %pages);
my $vars;
my $errorlevel;
@ISA = qw(Exporter);
@EXPORT = qw(%pages &InsertPage_hashref &InsertPage_arrayref &Run
+Pages $defaultpage &dump_struct
&set_errorlevel &get_errorlevel &set_var &get_var);
#
# inserts a page into the hash via an array.
#
#
sub InsertPage_arrayref ($) {
my @_parms=@{@_[0]};
# Make sure there's the right # of keys to do the job.
if (scalar @_parms == 11) {
unless ($defaultpage) {$defaultpage = $_parms[0]};
if (defined $_parms[1]){ load_lib ($_parms[1],"main")};
$pages {$_parms[0]} = {
description => $_parms[1],
traverse_list => $_parms[3],
traverse_sub => $_parms[4],
validator => $_parms[5],
errorhandler => $_parms[6],
template => $_parms[7],
preprocess => $_parms[8],
postsubmit => $_parms[9],
params => $_parms[10],
}
} else {
die "wrong number of elements passed to InsertPage_arrayref. E
+xpected 11, got ". (scalar @_parms)
}
}
#
# inserts a page into the %pages hash via a hash.
#
#
sub InsertPage_hashref ($) {
my %_parms= %{@_[0]};
# Make sure there's the right keys to do the job.
if (CheckKeys (\%_parms,["pagename","description","traverse_list",
"traverse_sub","validator","errorhandler",
"template","preprocess","postsubmit","params"
+])) {
#
# ok, all the parameters are there, what about the default p
+age?
#
#
unless ($defaultpage) {$defaultpage = $_parms{pagename}};
#
# check to see if we should load a module for this page.
#
#
if (defined $_parms{module}){ load_lib ($_parms{module},"main"
+)};
#eval "require \"$_parms{module}\""|| die "no module";
$pages {$_parms{pagename}} = {
description => $_parms{description },
traverse_list => $_parms{traverse_list},
traverse_sub => $_parms{traverse_sub },
validator => $_parms{validator },
errorhandler => $_parms{errorhandler },
template => $_parms{template },
preprocess => $_parms{preprocess },
postsubmit => $_parms{postsubmit },
params => $_parms{params },
}
}
}
#
# Checks a hash to make sure a set of keys exist.
#
#
sub CheckKeys (\%\@) {
my %hash = %{$_[0]};
my @keys = @{$_[1]};
foreach (@keys) {
if (! exists ($hash{$_})) { return 0}
}
return 1;
}
#
# This sub is the meat of this module...
# it uses information to display HTML pages from
# %pages. Verifies parameters, and contains logic to
# perform pre and post display functions.
#
#
sub RunPages {
print header (-type=>'text/html');
print start_html;
print start_form; # remember that all hidden fields need to be w
+ithinthe form, they're input!
debugprint ( "checking Current_page ".br);
#
# separate into sub
#
#
#
# Current_Page is a parameter that will be set immediately befor
+e a page is displayed.
# Inside of the program, it is analogous to $Current_Page, and i
+s used to determine
# what set of subroutines should be run.
# If param ("Current_Page") exists, that means that the user's C
+GI script has run through at least once.
# We'll grab it's contents and stuff it into $Current_Page.
# But if param ("Current_Page") doesn't exist, then we set $Curr
+ent_Page to the
# contents of $defaultpage, which is typically the first page in
+serted.
# Note that $defaultpage is exported, so that users can set it t
+o whichever page they prefer.
# to display as their first.
#
if (param ("Current_Page")){
debugprint ("found Current_page set to ".param ("Current_Page"
+).br);
$Current_Page = param ("Current_Page");
debugprint ("Checking Current_Page for validator<BR>");
#
# Here, we are checking to see if the current page has a validat
+or defined.
# If it does, run it and store the result in $errorlevel.
# $errorlevel is then passed to all other subs as a way of deter
+mining state.
#
if (defined ($pages{$Current_Page}{validator})) {
$errorlevel =$pages{$Current_Page}{validator}->();
debugprint ("validator found, returned '$errorlevel'.<BR>"
+);
}
} else {
debugprint( "setting Current_Page to default page $defaultpage
+<BR>");
$Current_Page = $defaultpage;
}
debugprint ("printing parameters<BR>");
#
# Here we go through each page, and see what its params are.
# Note that I rarely use param lists, so I only write each
# parameter's last value.
# This prevents duplication of parameters when pages refer back
# to themselves.
# I consider this to be a problem, but I'm not sure how to fix i
+t :|
#
foreach my $thispage (keys %pages){
foreach (@{$pages{$thispage}{params}}) {
debugprint ("looking at param $_");
my @temp_param = param($_);
if ((param($_))){print hidden ($_, $temp_param[-1])}
$$vars{params}{$_}= $temp_param[-1];
debugprint ("Parameter '$_' set to '$temp_param[-1]'<B
+R>");
}
}
debugprint ("Done printing parameters<BR>");
debugprint ("Checking traversal list<BR>");
my $nextpage;
#
# Here we check the current page's traversal list.
# As a default, if it has no traverse_sub, it'll loop back to $C
+urrent_Page.
# Right now, the traverse_sub is called with references to $vars
+ and $errorlevel, but
# this should be unneeded with the introduction of (get|set)_(va
+r|errorlevel|param)
# I'm leaving it in right now.
#
# As a side effect of the order of processing things, it becomes
+ convenient to
# check for param("Current_Page") in the default page's validato
+r, and have it return itself
# if param("Current_Page") doesn't exist.
#
if ($pages{$Current_Page}{traverse_sub} ne "") {
debugprint ("Traversal list found... <BR>");
$nextpage = $pages{$Current_Page}{traverse_sub}->(\$vars,\$err
+orlevel);
} else {
debugprint ("No traverse_sub for page 'Current_Page'. Are you
+sure about that? Setting next_page to 'Current_Page'");
$nextpage = $Current_Page;
}
debugprint ("Traverse_sub returns '$nextpage'<BR>");
#
# Paranoia?
#
if (defined $nextpage) {
#
# make sure that $nextpage is in the current page's traverse
+ list.
#
unless (defined ($pages{$Current_Page}{traverse_list}{$nextpag
+e})){
debugprint ("tried to access undefined key in $Current_Pag
+e traverse_list : $nextpage");
#die;
}
#
# SO we survived that.
# Now we check the value of $nextpage 's entry in traverse_l
+ist.
# If it's true, we check for and execute $Current_Page's pos
+tsubmit.
#
debugprint ("Checking for '$Current_Page' traverse for post su
+bmit <BR>");
if ($pages{$Current_Page}{traverse_list}{$nextpage}){
if (defined $pages{$Current_Page}{postsubmit}) {
debugprint ("Executing '$Current_Page' post submit<BR>
+");
$pages{$Current_Page}{postsubmit}->(\$vars, \$errorlev
+el);
debugprint ("Done with '$Current_Page' post submit<BR>
+");
} else {
debugprint ("No post submit found, but traversal post
+submit set to 1!<BR>");
}
} else {
debugprint ("No post submit found, but traversal post subm
+it set to 1!<BR>");
};
#
# OK.
# At this point in the game, the previous page has been disp
+layed,
# or the default page has been queued up.
#
#
debugprint ("Setting Current_Page to '$nextpage'<BR>");
$Current_Page = $nextpage;
} else {
debugprint ("Nextpage is not defined... what happened here?<BR
+>");
}
#
# These are 4 special vars that will get loaded for any page.
# $$vars{pagetitle} is a reference to the description, I use
# it to define titles in my html templates.
# Will probably go away once I come to my sense.
#
# $$vars{current_page} is used to drive the RunPages subroutine.
# very much needed.
#
# $$vars{error_level} is a way to pass the errorlevel onto the
# HTML templates. This way you can have blocks like :
# [% IF error_level %] Don't do that again! [% END %]
# and so on.
#
# related to this is get_bit, which really should be unnecessary
+, but
# I can't seem to get tt2 to recognize bitwise ops.
# having get_bit available to the HTML Template will allow users
# to define bitflags in their errorcodes and check for them in
# templates.
#
debugprint ("Setting \$\$vars info<BR>");
$$vars{pagetitle} =$pages{$Current_Page}{description};
$$vars{current_page}= $Current_Page;
$$vars{error_level} = $errorlevel;
$$vars{get_bit}=sub {if ($_[0] && $_[1]){return ((scalar shift) &
+(scalar shift))}}; # why doesn't TT2 recognize bitwise ops? :(
debugprint ("Hiding current_page -- $Current_Page<BR>");
param('Current_Page',$Current_Page);
print hidden ("Current_Page", $Current_Page);
debugprint ("Setting Template<BR>");
debugprint ("Checking for preprocess sub<BR>\n");
#
# And now prepare to do any preprocessing for the real current p
+age.
#
if (defined $pages{$Current_Page}{preprocess}) {
$pages{$Current_Page}{preprocess}->(\$vars, \$errorlevel);
} else {
debugprint ("no preprocess sub found<BR>\n");
}
#
# show the template
#
my $template;
$template= Template->new() || die( "Can't create template $!");
$template->process($pages{$Current_Page}{template}, $vars)|| die (
+"Template process failed: ", $template->error(), "\n");
debugprint ("<BR>Done printing template<BR>\n");
debugprint ("Cleaning up<BR>");
print end_form;
print end_html;
}
sub set_errorlevel {
$errorlevel = $_[0];
}
sub get_errorlevel {
return $errorlevel;
}
sub set_var {
my $_key = shift;
my $_val = shift;
print "setting \$\$vars {$_key} to $_val";
$$vars {$_key} = $_val;
}
sub get_var {
if (exists $$vars{$_[0]})
{return \$$vars{$_[0]}}
else
{return undef}
}
sub get_param {
if (exists $$vars{params}{$_[0]})
{return \$$vars{params}{$_[0]}}
else
{return undef}
}
sub set_param {
$$vars{params}{$_[0]}
}
#
#this will print an html table showing
# the structure of the assembled %pages
# currently broken for pages that have
# recursive references. :(
#
#
sub dump_struct{
my $cp = $defaultpage;
print "<CENTER>";
print "<TABLE BORDER=1>";
print "<TH>Page Name</TH><TH>children</TH><TH>Verified?</TH>";
dump_line ($cp);
print "</TABLE>";
}
sub dump_line{
my $cp=shift;
if (keys %{$pages{$cp}{traverse_list}}){
foreach (sort keys %{$pages{$cp}{traverse_list}}) {
print "<TR><TD>$cp</TD><TD>", ($_ eq $cp)?"<I>self</I>
+":$_,"</TD><TD>",
$pages{$cp}{traverse_list}{$_}?"yes":"no","</TD>
+";
}
foreach (sort keys %{$pages{$cp}{traverse_list}}) {
unless ($_ eq $cp) {dump_line ($_)}
}
} else {
print "<TR><TD>$cp</TD><TD COLSPAN=3>no children</td>";
}
}
#
# Loads a file into a package.
#
# Courtesy Ben Tilly.
#
# node_id=52229
#
sub load_lib {
my $file = shift;
my $pkg = shift;
my $ret = eval "package $pkg; do '$file';";
if (not defined($ret)) {
$@ and confess("Cannot parse '$file': $@");
$! and confess("Cannot load '$file': $!");
$@ and debugprint ("Cannot parse '$file': $@");
$! and debugprint ("Cannot load '$file': $!");
warn("Loading '$file' did not return a defined value");
}
$ret;
}
sub debugprint {
if (DEBUG) {print scalar localtime , " : ", @_, "\n"};
}
I encourage you to post any comments you have. I want to develop this into a professional quality module -- I've come up with some changes I want to make just explaining this, and I'd appreciate suggestions from the community at large.
