#! /usr/bin/perl -s
# quarkshop.pl -- CGI script to accept an order from a caller, mail details
# to the site manager and an acknowledgement to the caller.
#
# $Id: quarkshop.perl,v 1.4 2007/12/05 23:03:27 webman Exp webman $
#
# $Log: quarkshop.perl,v $
# Revision 1.4 2007/12/05 23:03:27 webman
# Added mail handling.
#
# Revision 1.3 2007/12/05 21:13:22 webman
# Rearranged the code a bit and parametrised things properly.
#
# Revision 1.2 2007/12/05 20:52:42 webman
# Added some serious boilerplate for error handling.
# Logs the order to a local file.
#
# Revision 1.1 2007/12/05 17:52:39 webman
# Initial revision
#
#
#-------------------------------------------------------------------------------
use strict;
# use CGI qw(:standard);
# use Mail::Mailer;
# use DBI; ... when we have a database to talk to...
#-------------------------------------------------------------------------------
# global variables.
# headerGenerated - Set when the first header is returned to the browser.
# Used in error handling to prevent us generating another
# header before the error message.
# inError - Set in the error handler before generating the response
# to the browser. If it is already set when we get into the
# error handler, don't bother trying to tell the browser
# (since we've already tried once and failed).
my ($headerGenerated, $inError) = (), "", 0, 0;
#-------------------------------------------------------------------------------
# HTML-related stuff...
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
# sendHtmlHeader -- send the bit up to / including the body tag.
# Limits : It's a bit inflexible.
# Errors : None.
# Params : title - the title string to go into the header.
# Result : None.
sub sendHtmlHeader ()
{
if (@_ != 1) { &moan ("sendHtmlHeader has " . @_ . " parameters"); }
my ($title) = @_;
print (
"Content-Type: text/html\n" .
"\n" .
" " . $title . " \n" .
"\n");
$headerGenerated = 1;
}
#-------------------------------------------------------------------------------
# sendHtmlTrailer -- send the bit including and after the end body tag.
# Limits : It's a bit inflexible.
# Errors : None.
# Params : None.
# Result : None.
sub sendHtmlTrailer ()
{
print (" \n");
}
#-------------------------------------------------------------------------------
# sendHtmlBody -- send a string as it is.
# Limits : It's a bit inflexible.
# Errors : None.
# Params : The string that forms this bit of the body.
# Result : None.
sub sendHtmlBody ()
{
if (@_ != 1) { &moan ("sendHtmlBody has " . @_ . " parameters"); }
my ($body) = @_;
print ($body);
}
#-------------------------------------------------------------------------------
# makeHtmlPara -- put paragraph tags either end of a string.
# Limits : None.
# Errors : None.
# Params : The string forming the paragraph.
# Result : An HTML string that represents the paragraph.
sub makeHtmlPara ()
{
if (@_ != 1) { &moan ("makeHtmlPara has " . @_ . " parameters"); }
my ($string) = @_;
return "" . $string . "
\n";
}
#-------------------------------------------------------------------------------
# makeHtmlHeading -- put header tags round a string.
# Limits : None.
# Errors : None.
# Params : The numeric level of the heading.
# : The string forming the paragraph.
# Result : An HTML string that represents the heading.
sub makeHtmlHeading ()
{
if (@_ != 2) { &moan ("makeHHtmlHeading has " . @_ . " parameters"); }
my ($level, $text) = @_;
return " " . $text . "\n";
}
#-------------------------------------------------------------------------------
# makeHtmlCentred -- put 'center' tags round a string.
# Limits : None.
# Errors : None.
# Params : The string to be centred.
# Result : An HTML string that represents the centred text.
sub makeHtmlCentred ()
{
if (@_ != 1) { &moan ("makeHtmlCentred has " . @_ . " parameters"); }
my ($text) = @_;
return " " . $text . "\n";
}
#-------------------------------------------------------------------------------
# makeHtmLink -- put an anchor tag around some text and a URL.
# Limits : None.
# Errors : None.
# Params : The URL the link is to lead to.
# : The text to appear as the link.
# Result : An HTML string that represents the link.
sub makeHtmlLink ()
{
if (@_ != 2) { &moan ("makeHtmlLink has " . @_ . " parameters"); }
my ($url, $text) = @_;
return " " . $text . " \n";
}
#-------------------------------------------------------------------------------
# unmangleCgiString -- unmangle the form data parameter strings.
# Limits : None.
# Errors : None.
# Params : The string to translate.
# Result : The translated string.
# Effect : Replace '+' symbols by spaces, then translate %xx hex to characters.
sub unmangleCgiString ()
{
if (@_ != 1) { &moan ("unmangleCgiString has " . @_ . " parameters"); }
my ($str) = @_;
$str =~ tr/+/ /;
$str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack ("C", hex ($1))/eg;
return $str;
}
#-------------------------------------------------------------------------------
# readPostInput -- read the parameters supplied by the web page.
# Limits : The form must have generated a 'post' event.
# Errors : None. If this is not a "post" event, returns an empty dictionary.
# Params : None.
# Result : A dictionary (hash) containing the name/value pairs from the form.
sub readPostInput ()
{
my ($buffer, $pair, @pairs, $name, $value);
my (%myPostInputs) = ();
if ($ENV {'REQUEST_METHOD'} eq 'POST')
{
read (STDIN, $buffer, $ENV {'CONTENT_LENGTH'});
@pairs = split (/&/, $buffer);
foreach $pair (@pairs)
{
($name, $value) = split (/=/, $pair);
$name = &unmangleCgiString ($name);
$value = &unmangleCgiString ($value);
$myPostInputs {$name} = $value;
}
}
return %myPostInputs;
}
#-------------------------------------------------------------------------------
# Error handling.
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
# moan -- report an error.
# Limits : This is a bit ad-hoc if it is called after we have started
# generating the output page.
# We really need a stack of nested elements already generated...
# Errors : None. This is the error reporter!
# Params : An error message.
# Result : Never returns - kills the process.
# Effect : Log an error file in the private directory, make up
# a page to return to the browser, quit.
sub moan ()
{
my ($message) = @_;
# Remember this has happened...
# If we can't open the file there's not a lot we can do.
if (open (FILEHANDLE, ">>../private/html_error_log.txt"))
{
print (
FILEHANDLE
"Perl processing error " . $inError . " : " .
$message . " at " . gmtime () . "\n");
close (FILEHANDLE);
}
# If $inError is already set, we're already trying to generate an error
# response to the user and we've failed again - give up...
if ($inError) { exit (1); }
# Make sure we'll stop if the things we're doing next fail.
# Otherwise we're into infinite recursion...
++$inError;
# If we haven't already generated a header, put out something to keep
# the browser happy.
if (!$headerGenerated)
{
&sendHtmlHeader ("ERROR!");
}
# Add an error message to the page being generated.
&sendHtmlBody (
&makeHtmlPara (
"There has been an error which may prevent me completing this " .
"operation
" .
"The error has been recorded in the server log.
" .
"Please try again later.
" .
"If you contact the site administrators, it would be helpful to " .
"quote the message '" . $message . "'."));
# We just have to assume that there are no HTML structures open.
&sendHtmlTrailer ();
# That's all, folks...
exit (1);
}
#-------------------------------------------------------------------------------
# Mail handling.
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
# sendMail -- send a mail message to a specified recipient.
# Limits : Assumes we're running 'sendmail' (i.e. this is a Unix system).
# Errors : Silently does nothing if sendmail not running.
# Params : Address to send the mail to.
# : Address to use as sender.
# : Subject of the mail.
# : Text to be sent as the body of the mail.
# Result : true if all is OK, false (0) if anything went wrong.
sub sendMail ()
{
if (@_ != 4) { &moan ("sendMail has " . @_ . " parameters"); }
my ($toAddress, $fromAddress, $subject, $text) = @_;
open (MAILHANDLE, "|/usr/sbin/sendmail -t") || return 0;
# Ok, we have an output stream to the mail server.
print (MAILHANDLE
"To: " . $toAddress . "\n" .
"From: " . $fromAddress . "\n" .
"Subject: " . $subject . "\n\n" . $text . "\n\n");
close (MAILHANDLE);
return 1;
}
#-------------------------------------------------------------------------------
# Useful general subroutines.
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
# getNextCounterValue -- read last value, add one, rewrite, return value
# Limits : None. If there is no counter, starts at value of default parameter.
# Errors : None.
# Params : The name of the counter.
# : The default start value.
# Result : The next counter value in sequence.
# Notes : This version keeps a file in the private data of the web site.
# A later version should use a database and record the counter there.
sub getNextCounterValue ()
{
if (@_ != 2) { &moan ("getNextCounterValue has " . @_ . " parameters"); }
my ($myApplicationName, $counterValue) = @_;
my ($fileName) = "../private/" . $myApplicationName . "_counter.txt";
if (open (FILEHANDLE, "<" . $fileName))
{
$counterValue = ;
close (FILEHANDLE);
}
if (! $counterValue) { $counterValue = 0; }
++$counterValue;
open (FILEHANDLE, ">" . $fileName) ||
&moan ("Cannot rewrite order number file");
print FILEHANDLE $counterValue;
close (FILEHANDLE);
return $counterValue;
}
#-------------------------------------------------------------------------------
# The logic that applies specifically to quarkshop.
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
# recordOrder -- take a permanent record of the current order.
# Limits : None.
# Errors : moans if it can't write an order file.
# Params : The order number.
# : A dictionary (hash) containing the order details.
# Result : None.
# Effect : Creates an order file in the private directory.
sub recordOrder ()
{
my ($orderNumber, $orderDictionary) = @_;
my ($key);
open (FILEHANDLE, ">../private/quarkshop_order_" . $orderNumber . ".txt") ||
&moan ("Cannot open order file for writing");
foreach $key (sort keys %$orderDictionary)
{
print (FILEHANDLE "'$key' is set to '" . $$orderDictionary {$key} . "'\n");
}
close (FILEHANDLE);
}
#-------------------------------------------------------------------------------
# processOrder -- generate a text summary of the order to be used in replies.
# Limits : None.
# Errors : None.
# Params : Order number.
# : Date and time order placed.
# : Dictionary (hash) containing the details of the order.
# Result : A string describing the order..
sub processOrder ()
{
if (@_ != 3) { &moan ("processOrder has " . @_ . " parameters"); }
my ($orderNumber, $orderTime, $postInputs) = @_;
my ($order) = "";
my ($also) = "";
my ($plural);
my ($pqParam) = $$postInputs {'pquantity'};
my ($wqParam) = $$postInputs {'wquantity'};
my ($gqParam) = $$postInputs {'gquantity'};
my ($packParam) = $$postInputs {'pack'};
my ($colourParam) = $$postInputs {'colour'};
my ($gcolourParam) = $$postInputs {'gcolour'};
my ($flavourParam) = $$postInputs {'flavour'};
my ($wchargeParam) = $$postInputs {'wcharge'};
my ($weightParam) = $$postInputs {'weight'};
if ($pqParam > 0)
{
$plural = ($pqParam == 1) ? "" : "s";
$order = "You have ordered $pqParam $weightParam " . $packParam . $plural;
if ($packParam eq "meson")
{
$order .= " in a $colourParam/anti-$colourParam quark pair.";
}
else
{
$order .= " with a $colourParam $flavourParam singleton quark.";
}
$order .= "
";
$also = " also ";
}
if ($wqParam > 0)
{
$plural = ($wqParam == 1) ? "" : "s";
$order .= "You $also ordered $wqParam charge $wchargeParam ";
$order .= "anti-W-intermediate boson$plural.
";
$also = " also ";
}
if ($gqParam > 0)
{
$plural = ($gqParam == 1) ? "" : "s";
$order .= "You $also ordered $gqParam $gcolourParam gluon$plural.
";
$also = " also ";
}
$order .= "Your order was received at " . $orderTime;
return $order;
}
#-------------------------------------------------------------------------------
# sendReplyPage -- generate an HTML reply to be displayed in the callers browser.
# Limits : None.
# Errors : Reported on the page.
# Params : Order number that has been allocated to this order.
# : Name of the client.
# : E-mail address of the client.
# : Text string describing the order.
# Result : None.
sub sendReplyPage ()
{
if (@_ != 4) { &moan ("sendReplyPage has " . @_ . " parameters"); }
my ($myOrderNumber, $userName, $userEMail, $order) = @_;
my ($body) = "";
$body = &makeHtmlCentred (&makeHtmlHeading (1, "Quark Shop!"));
$body .=
&makeHtmlCentred (
&makeHtmlHeading (
3,
"Thank you for your order, " . $userName));
$body .=
&makeHtmlPara (
"Your order number is " . $myOrderNumber . ".
".
"We have sent an e-mail to " .
$userEMail . " confirming your order.
" .
"Remember, we haven't accepted your order until we contact " .
"you directly.");
$body .= &makeHtmlPara ($order);
$body .= &makeHtmlLink ("http://www.ecsel.co.uk/quarkshop.html", "Back to the shop");
&sendHtmlHeader ("Quark shop!");
&sendHtmlBody ($body);
&sendHtmlTrailer ();
}
#-------------------------------------------------------------------------------
# makeMailMessage -- create a mail message to send to the client and us.
# Limits : None.
# Errors : None.
# Params : Order number that has been allocated to this order.
# : Name of the client.
# : E-mail address of the client.
# : Text string describing the order.
# : Received time.
# Result : A string that can be used as the body of the message.
sub makeMailMessage ()
{
if (@_ != 5) { &moan ("sendReplyPage has " . @_ . " parameters"); }
my ($myOrderNumber, $userName, $userEMail, $order, $orderTime) = @_;
# Cheat - use the order string from the web page, just change
# to newline...
$order =~ s//\n/g;
return
"This e-mail acknowledges receipt of order " . $myOrderNumber .
" from " . $userName . " at e-mail '" .
$userEMail . ".\n\n" . $order . "\n" .
"Order received at " . $orderTime . "\n" .
"Remember, we have not yet accepted your order.\n" .
"A representative will contact you in due course.\n";
}
#-------------------------------------------------------------------------------
# Main program -- read and translate the input, then generate reply page.
# Main program local variables.
# %formInputs - Dictionary holding the supplied parameters from the form.
# $orderString - String holding humanly-readable description of the order.
# $orderNumber - Reference number given to client for this order.
# $orderTime - Date and time order was received.
# $name - The name field form the form.
# $email - The e-mail field from the form (actually 'email1' but they
# are the same).
# $mailMessage - The string to be mailed to client and to us.
my (%formInputs, $orderString, $orderNumber,
$orderTime, $name, $email, $mailMessage);
# Run the main program in an 'eval' block. If anything fails, the eval
# will stop, leaving a sensible message for 'moan'.
eval
{
$orderTime = gmtime ();
$orderNumber = &getNextCounterValue ("quarkshop_order_number", "1234");
%formInputs = &readPostInput ();
$name = $formInputs {'name'};
$email = $formInputs {'email1'};
&recordOrder ($orderNumber, \%formInputs);
$orderString = &processOrder ($orderNumber, $orderTime, \%formInputs);
$mailMessage =
&makeMailMessage ($orderNumber, $name, $email, $orderString, $orderTime);
# Send the message to him...
&sendMail (
$email,
"webmaster\@ecsel.co.uk",
"Thank you for ordering from Quark Shop!",
$mailMessage);
# ...and send it to us.
&sendMail (
"webmaster\@ecsel.co.uk",
$email,
"Another idiot put in an order!",
$mailMessage);
# Finally, send out a response page.
&sendReplyPage ($orderNumber, $name, $email, $orderString);
};
if ($@) { &moan ($@); }
#-------------------------------------------------------------------------------
# End of file quarkshop.pl
#-------------------------------------------------------------------------------