#!/usr/local/bin/perl
# ======================================================================
# soho.pl - order form information
#
# Original code by
# Carlos A. Pero (cpero@ncsa.uiuc.edu)
#
# Adapted for Soho Design by
# Marco Falcioni falcioni@npac.syr.edu Aug 1995
#
# ======================================================================
########################################################################
########## Configurable variables ######################################
$SENDMAIL = '/usr/lib/sendmail';
# The location of your sendmail binary
## Also, make sure the first line of this script points
## to your PERL binary
########## Nothing else to change ######################################
########################################################################
$SCRIPT = $ENV{'SCRIPT_NAME'};
#### Do standard HTTP stuff ####
&cgi_receive;
&cgi_decode;
&cgi_header;
#### Output confirmation message ####
print qq|Order Sent\n|;
print qq|Thank you for your Order!
\n|;
print qq|The following order has been sent.\n|;
print qq|Please check that the information is correct.\n|;
print qq|Contact us at
EMail: sohodes\@westnet.com - Fax: (714) 478 4938 - Tel: (714) 478 7953
\n|;
print qq|if you have any question (please allow time for us to receive the order).\n|;
print qq|You can now return to to the order form.\n| if ($FORM{'previous-url'});
print qq|
\n|;
print "\n";
&dump_values(FORM, STDOUT);
print "\n";
print "\n";
print "\n";
exit;
#####################################################################
#### SUBROUTINES ####################################################
sub error_blank_field {
local($variable) = @_;
print "\n" if ($FORM{'next-url'});
print "Server-Email Error\n";
print "Error!
\n";
print "You did not fill in $variable.\n";
print "Please go back to the form and do so.\n";
print "\n";
exit;
}
sub cgi_header {
print "Content-type: text/html\n";
print "\n" unless ($FORM{'next-url'});
}
sub cgi_receive {
if ($ENV{'REQUEST_METHOD'} eq "POST") {
read(STDIN, $incoming, $ENV{'CONTENT_LENGTH'});
}
else {
$incoming = $ENV{'QUERY_STRING'};
}
}
sub cgi_decode {
@pairs = split(/&/, $incoming);
foreach (@pairs) {
($name, $value) = split(/=/, $_);
$name =~ tr/+/ /;
$value =~ tr/+/ /;
$name =~ s/%([A-F0-9][A-F0-9])/pack("C", hex($1))/gie;
$value =~ s/%([A-F0-9][A-F0-9])/pack("C", hex($1))/gie;
#### Strip out semicolons unless for special character
$value =~ s/;/$$/g;
$value =~ s/&(\S{1,6})$$/&\1;/g;
$value =~ s/$$/ /g;
$value =~ s/\|/ /g;
$value =~ s/^!/ /g; ## Allow exclamation points in sentences
#### Skip blank text entry fields
next if ($value eq "");
#### Check for "assign-dynamic" field names
#### Mainly for on-the-fly input names, especially checkboxes
if ($name =~ /^assign-dynamic/) {
$name = $value;
$value = "on";
}
#### Allow for multiple values of a single name
$FORM{$name} .= ", " if ($FORM{$name});
$FORM{$name} .= $value;
}
}
sub dump_values {
local($env, $handle) = @_;
local(%PAIRS);
local($format);
local($value);
%months = (Jan,1,
Feb,2,
Mar,3,
Apr,4,
May,5,
Jun,6,
Jul,7,
Aug,8,
Sep,9,
Oct,10,
Nov,11,
Dec,12);
%format = ('Item #',"%7d- ",
'Color',"%10s- ",
'Size',"%4s- ",
'Qty',"%3d- ",
'Desc',"%20s- ",
'Price', "%6.2f-");
require "ctime.pl";
($day,$month,$num,$time,$year)= split(" ",&ctime(time));
($hour,$min,$sec)= split(":",$time);
$year =~ s/19//;
#
# Here I build a unique reference number for the order in question
# it is composed by the year - month - day - hours - mins - sec
# hence it has a very very small probability of not being unique
#
$refkey = "$year$months{$month}$num$hour$min$sec";
eval "\@keys = keys \%$env";
eval "\@values = values \%$env";
while ($#keys >= 0) {
$key = pop(@keys);
$value = pop(@values);
$PAIRS{$key}=$value;
}
($handle eq "STDOUT") && (print $handle "\n");
print $handle "Customer Order","\n";
print $handle "-" x 70,"\n";
print $handle "Reference Key: ",$refkey,"\n";
print $handle "-" x 70,"\n";
$printcommand = q|printf $handle "%s:\t%s\n",$_,$value;|;
foreach( sort keys(%PAIRS)){
$value = $PAIRS{$_};
if(/^[A,B,C]/){ # print only interesting fields
$_ =~ s/^.*-//; # strip the leading sort info
if($value eq "BEGINS"){ # switch to listing format
$printcommand = q|printf $handle $format{$_},$value;|;
printf $handle
"aaaItem \# Color Size Qty Description Price\n";
print $handle "-" x 70,"\n";
} elsif($value eq "ENDS") { # switch back to regular format
$printcommand = q|printf $handle "%s:\t%s\n",$_,$value;|;
print $handle "\n","-" x 70,"\n";
} else {
eval ($printcommand);
}
}
}
($handle eq "STDOUT") && (print $handle "\n");
}