Perl State-Machine Guestbook

guestbook.cgi

#!/usr/bin/perl
# guestbook.cgi
# a state-machine guestbook for the Web

# constants
$CRLF = "\x0d\x0a";
$servername = $ENV{'SERVER_NAME'};  # this server
$scriptname = $ENV{'SCRIPT_NAME'};  # this program's URI
$callback = "http://$servername$scriptname";  # how to call back
$maxview = 50;       # maximum number of entries to view
$separator = "----- Guestbook Entry -----";

# data space
$datadir = "/path/to/the/guestbook/datafiles";
$dataname = "luna.dat";
$datafile = "$datadir/$dataname";
$tempfile = "$datadir/$dataname.$$";
$lockfile = "/tmp/$dataname.lock";

# create the datafile if nec
unless (-f $datafile) {
  open DATAFILE, ">$datafile";
  close DATAFILE;
  }

# need this at the top of all CGI progs
print "Content-type: text/html$CRLF$CRLF";

# get the query vars, if any
%query = getquery();

# if there's no data, assume this is the first iteration
$state = 'first' unless %query;

# prevent users from entering 
# arbitrary HTML in their entries
while(($qname, $qvalue) = each %query) {
  # convert any HTML entities
  $qvalue =~ s/</<\;/g;
  $qvalue =~ s/>/>\;/g;
  $qvalue =~ s/"/"\;/g; 
  $$qname = $qvalue; 
  }

# what now is
$date = localtime;

# the main jump table
if    ($state eq 'first'   ) { first()    }
elsif ($state eq 'create'  ) { edit()     }
elsif ($state eq 'view'    ) { view()     }
elsif ($state eq 'validate') { validate() }
elsif ($state eq 'edit'    ) { edit()     }
elsif ($state eq 'save'    ) { save()     }
else                         { unknown()  }

exit;

# STATE SCREENS
sub first{
htmlhead("My Guestbook!");
htmlp("initial.htmlp");
htmlfoot();
}

sub edit
{
htmlhead("My Guestbook: $state");
htmlp("form.htmlp");
htmlfoot();
}

sub validate
{
return error("Please provide at least a name and a message") 
  unless($name && $message);
htmlhead("My Guestbook: $state");
htmlp("validate.htmlp");
htmlfoot();
}

sub view
{
htmlhead("My Guestbook: $state");
htmlp("view.htmlp");
htmlfoot();
}

sub save{
guestwrite();
htmlhead("My Guestbook: $state");
htmlp("save.htmlp");
htmlfoot();
}

sub entries
{
my $count;
my $guestfh = "guestfh";

open($guestfh, "<$datafile");
for(<$guestfh>, # eat the first separator
    $count = 1; 
    guestread($guestfh) && $count < $maxview; 
    $count++) {
  htmlp("viewrec.htmlp");
  }
close($guestfh);
}

sub error
{
local $error = shift;

htmlhead("My Guestbook: $state");
htmlp("error.htmlp");
htmlfoot();
return 0;
}

sub unknown
{
htmlhead("My Guestbook: unknown state: $state");
print "<h1>Unknown state!</h1>\n";
printvars();
htmlfoot();
}

# COMMON HTML HEADER AND FOOTER
# htmlhead(title)
# print the top of the html file
sub htmlhead{
local $title = shift;

htmlp("header.htmlp");
}

# htmlfoot
# print the foot of the html file
#
sub htmlfoot{
my $title = shift;
htmlp("footer.htmlp");
}

# GUESTBOOK ROUTINES
# guestbook
# save an entry to the TOP of the guestbook
sub guestwrite
{
# put the message on one line
$message =~ s/[\n\r]/ /g;
# create the record
umask 0;
open(TEMPFILE, ">$tempfile");
print TEMPFILE <<RECORD;
$separator
date: $date
name: $name
wherefor: $wherefor
message: $message
RECORD

# using the main data file
lock();

# put the new record at the top of the datafile
# by reading the rest of the datafile into the 
# end of the new datafile . . . 
open(GUESTBOOK, "<$datafile");
while(<GUESTBOOK>) { print TEMPFILE; }
close(GUESTBOOK);
close(TEMPFILE);
# then put the new datafile in the place of the 
# old one. 
rename($tempfile, $datafile);

# done with the main datafile
unlock();
}

# guestread
# read the next entry from the guestbook
# stores the entry as global variables from 
# the 'name: value' lines in the guestbook file. 
#
sub guestread
{
my $fhguest = shift or die "guestread: no filehandle!\n";
my $record = 0;

while(<$fhguest>) {
  last if /^$separator/;
  $record = 1;
  ($gname, $gvalue) = split(/:/, $_, 2);
  $$gname = "$gvalue";
  }
return $record;
}
# UTILITY ROUTINES
# getquery
# returns hash of CGI query strings
sub getquery
{
my $method = $ENV{'REQUEST_METHOD'};
my ($query_string, $pair);
my %query_hash;

$query_string = $ENV{'QUERY_STRING'} if $method eq 'GET';
$query_string = <STDIN> if $method eq 'POST';
return undef unless $query_string;

foreach $pair (split(/&/, $query_string)) {
  $pair =~ s/\+/ /g;
  $pair =~ s/%([\da-f]{2})/pack('c',hex($1))/ieg;
  ($_qsname, $_qsvalue) = split(/=/, $pair);
  $query_hash{$_qsname} = $_qsvalue;
  }
return %query_hash;
}

# printvars
#
# diagnostic to print the environment and CGI variables
#
sub printvars{
print "<p>Environment:<br>\n";
foreach $e (sort keys %ENV) {
  print "<br><tt>$e => $ENV{$e}</tt>\n";
  }

print "<p>Form Vars:<br>\n";
foreach $name (sort keys %query) {
  print "<br><tt>$name => [$query{$name}]</tt>\n"; }
}
# htmlp
# generic print an html file routine
# file may also contain:
#   $variable    for a perl variable
#   $$filename   for a nested file
#         for arbitrary perl code

sub htmlp
{
local $filename = shift;
# this code has to be reentrant to make file includes work
# so we need a uniqe filehandle for each file opened (since 
# more than one may be open at once). 
# just strip all the nonalphas from the filename for the 
# filehandle
my $fhstring = $filename;
$fhstring =~ s/[^a-z]//i;
unless (-f $filename) {
  print qq(<h1>Error: </h1>\n);
  print qq(<p><em>htmlp</em> can't find "$filename"</p>\n);
  return "";
  }  
open($fhstring, "<$filename");
while(<$fhstring>) {
  # comment this out if you think it's too dangerous
  #  to execute perl code
  s/$\{(.*?)}/eval($1),""/eg;
  # $$filename to include another file
  s/$$([\S;]+;?)/htmlp($1)/eg;
  # $variable to include a variable
  s/$(\w+)//eg;
  print;
  }
close $fhstring;
return "";
}
# DOT-LOCKING ROUTINES
sub lock
{
my $oumask;
# create the lock file world-writable
$oumask = umask(0);
for($i = 0; !open(LOCK, ">$lockfile"); $i++) {
  # wait a sec and try again
  sleep 1;
  # after 30 seconds, just unlock it
  &unlock if ($i > 30);
  }
close(LOCK);
umask($oumask);
}
sub unlock{
# just delete the lockfile (unlink is unix-ese for delete)
unlink($lockfile);
}