Copyright © 1996-1999 Rex Swain
Email rex@rexswain.com,
Web
http://www.rexswain.com
Permission granted to distribute unmodified copies
Reports of errors or omissions appreciated
#!/usr/bin/perl -w
# MAILFORM.CGI
# Send an email message from an HTML <FORM>
# 15 Oct 1996 Rex Swain, Independent Consultant, rex@rexswain.com
# 26 Oct 1997 Switched from SENDMAIL to MAILX
# Key fields (probably hidden in the FORM):
# To = Primary addressee(s) [required] e.g., "Rex Swain <rex@rexswain.com>"
# Cc = Cc list [optional] e.g., "Polly Roberts <pollyr@snet.net>, another@somewhere.com"
# Bcc = Bcc list [optional] e.g., "Rex Swain <rhswain@pcnet.com>"
# Subj = Subject text [optional] e.g., "Request For Proposal"
# Key fields (probably hidden in the FORM):
# OkUrl = Next URL if okay [optional] e.g., "itworked.html"
# Title = HTML <TITLE> for OK page [optional] e.g., "OK"
# OkMsg = HTML for <BODY> of OK page [optional] e.g., "OK, message sent."
#
# (OkUrl is specified relative to the calling page.
# E.g., if "/dir/form.html" invokes mailform.cgi and OkUrl="ok.html",
# then the next page will be "/dir/ok.html".)
#
# (If OkUrl is not specified, a page is generated on the fly using
# Title and OkMsg. [But then the user will probably have to click BACK twice.])
# Key fields (generally visible; used for From and Reply-To):
# Name = Sender's name [optional] e.g., "Rex Swain"
# Email = Sender's email address [optional] e.g., "rex@rexswain.com"
#
# (Note that if the Email is missing, it will be impossible for the
# recipient to reply to the message.)
# All other fields are composed into the body of the message
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
require 5; # requires Perl 5 or better
### Define globals based on server
# mail program:
# $sendmail = '/bin/sendmail -t -n -oi';
# # SENDMAIL Options:
# # -t read message for recipients (To Cc Bcc)
# # -n do not do aliasing
# # -oi do not take dot on a line by itself as a message terminator
$sendmail = '/bin/mailx -t';
# MAILX Options:
# -t read message for recipients (To Cc Bcc)
### Make sure we don't wait forever...
$timeout = 30; # see &alarm_handler
$SIG{'ALRM'} = 'alarm_handler'; # see &alarm_handler
alarm($timeout); # turn on the alarm timer
### Make sure we got here from an HTML form and not directly
# unless (defined($ENV{'CONTENT_LENGTH'})) {
# &woops('Undefined CONTENT_LENGTH; please invoke from a FORM');
# }
### Get some environment information
$caller = &getenv('HTTP_REFERER' ,'Unknown HTTP_REFERER' );
$script = &getenv('SCRIPT_NAME' ,'Unknown SCRIPT_NAME' );
$browser = &getenv('HTTP_USER_AGENT','Unknown HTTP_USER_AGENT');
$method = &getenv('REQUEST_METHOD' ,'ARG' );
### Get data according to request method
if ('GET' eq $method) { # foo.cgi?a=1&b=2 arrives as a GET
$buffer = &getenv('QUERY_STRING','');
}
elsif ('POST' eq $method) { # an HTML form arrives as a POST
read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
}
elsif ('ARG' eq $method) { # invoked via TelNet
$buffer = join('&',@ARGV);
}
else {
&woops("Unanticipated REQUEST_METHOD: $method");
}
### Parse fields into %FORM
@pairs = split(/&/, $buffer); # split the name-value pairs
foreach (@pairs) {
($name, $value) = split(/=/, $_);
$name =~ tr/A-Za-z0-9//cd; # squeeze non-alphanumeric chars from name
if ($name eq '') { next; } # in case nothing remains
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$FORM{$name} = $value; # put in %FORM hash
}
### Default values for key fields
$Name = 'Unknown Sender';
$Email = '?';
$To = '';
$Cc = '';
$Bcc = '';
$Subj = "Form from $caller";
$OkUrl = '';
$Title = 'E-Mail Form';
$OkMsg = 'OK, your message has been sent. Thank you!';
### Use specified values for key fields passed from the form
### Remove key fields from %FORM so they are not included in body of message
if (defined $FORM{'To' }) { $To = $FORM{'To' }; delete $FORM{'To' }; }
if (defined $FORM{'Cc' }) { $Cc = $FORM{'Cc' }; delete $FORM{'Cc' }; }
if (defined $FORM{'Bcc' }) { $Bcc = $FORM{'Bcc' }; delete $FORM{'Bcc' }; }
if (defined $FORM{'Subj' }) { $Subj = $FORM{'Subj' }; delete $FORM{'Subj' }; }
if (defined $FORM{'OkUrl'}) { $OkUrl = $FORM{'OkUrl'}; delete $FORM{'OkUrl'}; }
if (defined $FORM{'Title'}) { $Title = $FORM{'Title'}; delete $FORM{'Title'}; }
if (defined $FORM{'OkMsg'}) { $OkMsg = $FORM{'OkMsg'}; delete $FORM{'OkMsg'}; }
# Keep Name and Email (so repeated in body of message)
if (defined $FORM{'Name' }) { $Name = $FORM{'Name' }; }
if (defined $FORM{'Email'}) { $Email = $FORM{'Email'}; }
### Fix OK URL (if specified)
unless ($OkUrl eq '') {
$i = rindex($caller,'/');
$i = substr($caller,0,1+$i); # http://dir/
$OkUrl = $i . $OkUrl;
}
### Clean up addressee fields
if ($Name eq '') { $Name = 'Unknown Sender'; }
if ($Email eq '') { $Email = '?'; }
$To = &cleanup($To );
$Cc = &cleanup($Cc );
$Bcc = &cleanup($Bcc );
$Name = &cleanup($Name );
$Email = &cleanup($Email);
$From = "$Name <$Email>";
### Make sure we have To field
if ($To eq '') {
&woops('Undefined "To" field');
}
### Compose the msssage
$msg = '';
$msg .= "From: $From\n";
$msg .= "Reply-To: $From\n";
$msg .= "To: $To\n";
$msg .= "Subject: $Subj\n";
unless ($Cc eq '') { $msg .= "Cc: $Cc\n" ; }
unless ($Bcc eq '') { $msg .= "Bcc: $Bcc\n" ; }
$msg .= "\nEnvironment Information:\n\n";
$msg .= "Form URL = $caller\n";
$msg .= "CGI Script = $script\n";
$msg .= "Browser = $browser\n";
$msg .= "\nForm Entries:\n\n";
# find the longest field name so we can right-justify them
$max = 0;
foreach (keys(%FORM)) {
$len = length($_);
$max = $len if $len > $max;
}
# first, display all one-line fields
$mask = '%' . $max . 's = %s' . "\n"; # to align field names
$ind = ' ' x (3+$max); # to indent before newlines
foreach (sort keys(%FORM)) { # alphabetical order (else random)
$k = $_; # name
$v = $FORM{$k}; # value
if (-1 == index($v,"\r\n")) { # one-liner?
$msg .= sprintf($mask,$k,$v); # append to message
delete $FORM{$k}; # and remove from hash
} # else postpone
}
# then, display all multi-line fields
foreach (sort keys(%FORM)) { # alphabetical order (else random)
$k = $_; # name
$v = $FORM{$k}; # value
$v =~ s/\r\n/\r\n$ind/gs; # indent before newlines
$msg .= sprintf($mask,$k,$v); # append to message
delete $FORM{$k}; # and remove from hash
}
### Send the msssage
open (MAIL,"|$sendmail") || &woops("Could not open mail program $@");
print MAIL $msg || &woops("Could not print to mail program $@");
close (MAIL) || &woops("Could not close mail program $@");
### OK: Forward to OkUrl, or generate HTML page
if ($OkUrl eq '') {
&start;
print "<H2>$OkMsg</H2>\n";
&stop;
}
else {
print "Status: 302 Moved Temporarily\n" ,
"URI: $OkUrl\n" ,
"Location: $OkUrl\n" ,
"Method: GET\n" ,
"\n";
}
exit; # Ttttthat's all, folks!
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub cleanup { # clean up email address(es)
my ($addr) = shift;
# I want to delete as few characters as possible, because I want to allow
# multiple emails/names, such as 'Rex <rex@rexswain.com>, Polly <pollyr@snet.net>'.
$addr =~ tr/[\x00-\x1F]//d; # delete control characters
# Remove semi-colon to prevent termination of Perl statements.
# Remove slash to prevent UNIX directory paths.
# Remove vert-bar to prevent UNIX pipe.
# Remove tilde to prevent MAILX shell commands.
# Remove back-quote to prevent UNIX shell commands.
$addr =~ tr/\;\/\|\~\`//d; # delete potentially dangerous chars `
return &deb($addr); # delete extraneous blanks
}
sub alarm_handler {
&woops("Maximum execution time of $timeout seconds exceeded!");
}
sub woops { # error
my ($msg) = shift;
&start;
print '<H2><FONT COLOR="#FF0000">E-Mail Failure</FONT></H2>' ,
"<H3>$msg</H3>\n";
&stop;
}
sub start { # start HTML
print "Content-type: text/html; charset=iso-8859-1\n\n";
unless (defined($Title)) {
$Title = "E-Mail Form";
}
print "<HTML><HEAD><TITLE>$Title</TITLE></HEAD>\n" ,
"<BODY BGCOLOR=\"#FFFFFF\" TEXT=\"#000000\">\n";
}
sub stop { # finish HTML and exit
print "</BODY></HTML>\n";
exit;
}
sub deb { # Delete Extraneous Blanks
my ($a) = shift;
$a =~ tr/ / /s; # squeeze multiple blanks
$a =~ s/^ //; # delete leading blank
$a =~ s/ $//; # delete trailing blank
return $a;
}
sub getenv { # Get from %ENV
my ($k,$d) = @_; # key, default value
if (exists $ENV{$k}) {
return $ENV{$k};
}
else {
return $d;
}
}