Help with this error please...

raevans · Dec 5, 2002

CGI Error
The specified CGI application misbehaved by not returning a complete set of HTTP headers. The headers it did return are:

Too late for "-T" option at c:\inetpub\

http://wwwroot\cgi-bin\FormMail.pl

line 1.

Can anyone tell me where I went wrong?

tviman · Dec 5, 2002

Take out the -T in the shebang (/usr/bin/perl -w). But I also suspect that there are some syntax errors also. You'll have to take a good look at the formmail.pl code (notorious for errors) to find your problem.
There's always a better way...

raevans · Dec 5, 2002

Hmmm I took it out and i get the same errors. I have looked at this code all day with no progress. Here it is... maybe something will jumpm out at you??

Thanks for responding.

BEGIN
{
$DEBUGGING = 1;
$emulate_matts_code= 0;
$secure = 1;
$allow_empty_ref = 1;
$max_recipients = 5;

$mailprog = $^X =~ /(.+)/ or die;
$mailprog = "$1 -wT c:/nms_utils/nms_sendmail -oi";

@referers = (192.168.1.101);

@allow_mail_to = qw(rolandevans2000@yahoo.com cdalelio@yahoo.comsome.one.else@your.domain localhost);
@recipients = ();
%recipient_alias = ();
@valid_ENV = qw(REMOTE_HOST REMOTE_ADDR REMOTE_USER HTTP_USER_AGENT);
$locale = '';
$date_fmt = '%A, %B %d, %Y at %H:%M:%S';
$style = '/css/nms.css';
$send_confirmation_mail = 0;
$confirmation_text = <<'END_OF_CONFIRMATION';
From: you@your.com
Subject: form submission

Thank you for your form submission.

END_OF_CONFIRMATION
#
# USER CONFIGURATION << END >>
# ----------------------------
# (no user serviceable parts beyond here)

use vars qw($VERSION);
$VERSION = substr q$Revision: 1.87 $, 10, -1;

# Merge @allow_mail_to and @recipients into a single list of regexps,
# automatically adding any recipients in %recipient_alias.
push @allow_mail_to,
grep( /@/, split(/\s*,\s*/, join ',', values %recipient_alias) );
push @recipients, map { /\@/ ? "^\Q$_\E\$" : "\@\Q$_\E\$" } @allow_mail_to;

$secure = 0 if $emulate_matts_code;

use vars qw(%valid_ENV);
@valid_ENV{@valid_ENV} = (1) x @valid_ENV;

use vars qw($style_element);
$style_element = $style ?
qq%<link rel="stylesheet" type="text/css" href="$style" />%
: '';
}

use vars qw($done_headers $hide_recipient $debug_warnings);
$done_headers = 0;
$hide_recipient = 0;
$debug_warnings = '';

# We need finer control over what gets to the browser and the CGI::Carp
# set_message() is not available everywhere

# This is basically the same as what CGI::Carp does inside but simplified
# for our purposes here.

BEGIN
{
sub fatalsToBrowser
{
my ( $message ) = @_;

if ( $DEBUGGING )
{
$message =~ s/</</g;
$message =~ s/>/>/g;
}
else
{
$message = '';
}

my ( $pack, $file, $line, $sub ) = caller(1);
my ($id ) = $file =~ m%([^/]+)$%;

return undef if $file =~ /^\(eval/;

print "Content-Type: text/html; charset=iso-8859-1\n\n" unless $done_headers;

print <<EOERR;
<?xml version="1.0" encoding="iso-8859-1"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
"

http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">

<html xmlns="

http://www.w3.org/1999/xhtml">

<head>
<title>Error</title>
</head>
<body>
<h1>Application Error</h1>
<p>
An error has occurred in the program
</p>
<p>
$message
</p>
</body>
</html>
EOERR
die @_;
};

# Don't stomp on global SIG{__DIE__} if we're sharing an
# interpreter under Apache::Registry
unless (exists $ENV{MOD_PERL}) {
$SIG{__DIE__} = \&fatalsToBrowser;
}
}
local $SIG{__DIE__} = \&fatalsToBrowser;

# We don't need file uploads or very large POST requests.
# Annoying locution to shut up 'used only once' warning in
# older perl. Localize these to avoid stomping on other
# scripts that need file uploads under Apache::Registry.

local ($CGI:

ISABLE_UPLOADS, $CGI:

OST_MAX);
$CGI:

ISABLE_UPLOADS = 1;
$CGI:

OST_MAX = 1000000;

# Empty the environment of potentially harmful variables,
# and detaint the path. We accept anything in the path
# because $ENV{PATH} is trusted for a CGI script, and in
# general we have no way to tell what should be there.

delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
$ENV{PATH} =~ /(.*)/ and $ENV{PATH} = $1;

use vars qw(%Config %Form);
%Config = ();
%Form = ();

check_url();

eval
{
setlocale(LC_TIME, $locale) if $locale;
};

my $date = strftime($date_fmt, localtime);

my @Field_Order = parse_form();

check_required();

send_mail($date, [@Field_Order]);

return_html($date, [@Field_Order]);

sub check_url {
my $check_referer = check_referer(referer());

error('bad_referer') unless $check_referer;
}

sub check_referer
{
my $check_referer;
my ($referer) = @_;

unless ($referer) {
return 1 if $allow_empty_ref or !$secure;
}

if ($referer && ($referer =~ m!^https?://([^/]*\@)?([\w\-\.]+)!i)) {
my $refHost;

$refHost = $2;

foreach my $test_ref (@referers) {
if ($refHost =~ m|\Q$test_ref\E$|i) {
$check_referer = 1;
last;
}
elsif ( $secure && $test_ref =~ /\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}/ ) {
if ( my $ref_host = inet_aton($refHost) ) {
$ref_host = unpack "l", $ref_host;
if ( my $test_ref_ip = inet_aton($test_ref) ) {
$test_ref_ip = unpack "l", $test_ref_ip;
if ( $test_ref_ip == $ref_host ) {
$check_referer = 1;
last;
}
}
}
}
}
} else {
return 0;
}

return $check_referer;
};

sub parse_form {

my @fields = qw(
recipient
subject
email
realname
redirect
bgcolor
background
link_color
vlink_color
text_color
alink_color
title
sort
print_config
required
env_report
return_link_title
return_link_url
print_blank_fields
missing_fields_redirect
);

@Config{@fields} = (undef) x @fields; # make it undef rather than empty string

my @field_order;

foreach (param()) {
if (exists $Config{$_}) {
my $val = strip_nonprintable(param($_));
next if /redirect$/ and not check_url_valid($val);
next if /^return_link_url$/ and $secure and not check_url_valid($val);
$Config{$_} = $val;
} else {
my @vals = map {strip_nonprintable($_)} param($_);
my $key = strip_nonprintable($_);
$Form{$key} = join ' ', @vals;
push @field_order, $key;
}
}

foreach (qw(required env_report print_config)) {
if ($Config{$_}) {
$Config{$_} =~ s/(\s+|\n)?,(\s+|\n)?/,/g;
$Config{$_} =~ s/(\s+)?\n+(\s+)?//g;
$Config{$_} = [split(/,/, $Config{$_})];
} else {
$Config{$_} = [];
}
}

$Config{env_report} = [ grep { $valid_ENV{$_} } @{$Config{env_report}} ];

if (defined $Config{'sort'}) {
if ($Config{'sort'} eq 'alphabetic') {
@field_order = sort @field_order;
} elsif ($Config{'sort'} =~ /^\s*order:\s*(.*)$/s) {
@field_order = split /\s*,\s*/, $1;
}
}

return @field_order;
}

sub check_required {
my ($require, @error);

defined $Config{subject} or $Config{subject} = '';
defined $Config{recipient} or $Config{recipient} = '';
$Config{subject} =~ s/[\r\n]+/ /g;
$Config{recipient} =~ s/[\r\n]+/ /g;

if (length $Config{recipient}) {
my @valid;

if (exists $recipient_alias{$Config{recipient}}) {
$Config{recipient} = $recipient_alias{$Config{recipient}};
$hide_recipient = 1;
}

foreach (split /,/, $Config{recipient}) {
next unless check_email($_);

if (check_recipient($_)) {
push @valid, $_;
}
}

error('no_recipient') unless scalar @valid;
if ($max_recipients > 0 and not $emulate_matts_code) {
error('too_many_recipients') if scalar @valid > $max_recipients;
}
$Config{recipient} = join ',', @valid;

} else {
my @allow = grep {/\@/} @allow_mail_to;
if (scalar @allow > 0 and not $emulate_matts_code) {
$Config{recipient} = $allow[0];
$hide_recipient = 1;
} else {
error('no_recipient')
}
}

if ($secure and request_method() ne 'POST') {
error('bad_method');
}

foreach (@{$Config{required}}) {
if ($_ eq 'email' && !check_email($Config{$_})) {
push(@error, $_);
} elsif (defined($Config{$_})) {
push(@error, $_) unless length $Config{$_};
} else {
push(@error,$_) unless defined $Form{$_} and length $Form{$_};
}
}

error('missing_fields', @error) if @error;
}

sub check_recipient {
my ($recip) = @_;

foreach my $r (@recipients) {
if ( ($recip =~ /(?:$r)$/) or $emulate_matts_code and ($recip =~ /$r/i) ) {
return(1);
}
}

warn_bad_email($recip, "script not configured to allow this address&quot

;
return(0);
}

sub return_html {
my ($date, $Field_Order) = @_;

if ($Config{'redirect'}) {
print redirect $Config{'redirect'};
} else {
print "Content-Type: text/html; charset=iso-8859-1\n\n";
$done_headers++;

my $title = escape_html( $Config{'title'} || 'Thank You' );
my $torecipient = 'to ' . escape_html($Config{'recipient'});
$torecipient = '' if $hide_recipient;
my $attr = body_attributes(); # surely this should be done with CSS

print <<EOHTML;
<?xml version="1.0" encoding="iso-8859-1"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
"

http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">

<html xmlns="

http://www.w3.org/1999/xhtml">

<head>
<title>$title</title>
$style_element
<style>
h1.title {
text-align : center;
}
</style>
</head>
<body $attr>$debug_warnings
<h1 class="title">$title</h1>
<p>Below is what you submitted $torecipient on $date</p>
<p><hr size="1" width="75%" /></p>
EOHTML

foreach (@$Field_Order) {
my $val = (defined $Form{$_} ? $Form{$_} : '');
if ($Config{print_blank_fields} || $val !~ /^\s*$/) {
print '<p><b>', escape_html($_), ':</b> ',
escape_html($val), "</p>\n";
}
}

print qq{<p><hr size="1" width="75%" /></p>\n};

if ($Config{return_link_url} && $Config{return_link_title}) {
print "<ul>\n";
print '<li><a href="', escape_html($Config{return_link_url}),
'">', escape_html($Config{return_link_title}), "</a>\n";
print "</li>\n</ul>\n";
}

print <<END_HTML_FOOTER;
<hr size="1" width="75%" />
<p align="center">
<font size="-1">
<a href="

http://www.scriptarchive.com/nms.html">nms

FormMail</a>
© 2001 London Perl Mongers<br>
Written as drop-in replacement for
<a href="

http://www.scriptarchive.com/formmail.html">FormMail</a>

at
<a href="

http://www.scriptarchive.com/">Matt's

Script Archive</a>.
</font>
</p>
</body>
</html>
END_HTML_FOOTER
}
}

sub send_mail {
my ($date, $Field_Order) = @_;

my $dashes = '-' x 75;

my $realname = $Config{realname};
if (defined $realname) {
$realname = ' (' . cleanup_realname($realname) . ')';
} else {
$realname = $Config{realname} = '';
}

my $subject = $Config{subject} || '

http://WWW Form

Submission';
if ($secure) {
$subject = substr($subject, 0, 256);
}

my $email = $Config{email};
unless (defined $email and check_email($email)) {
$email = 'nobody';
}

if ("$Config{recipient}$email$realname$subject" =~ /\r|\n/) {
die 'multiline variable in mail header, unsafe to continue';
}

my $xheader = '';

# This is more lenient than that in check_referer() because we
# want to know how people got this far if they are faking it
# however it is probably prudent to restrict to the characters
# valid in a URL - or what ?

if ( $secure and defined (my $referer = referer()) ) {
if ( $referer =~ /([\d\w.

&%\/;?,-]{1,128})/ ) {
$xheader .= "X-HTTP-Referer: [$1]\n";
}
}

# however if remote_addr() is not pukka then something
# really bad is going on here.

if ( $secure and defined (my $addr = remote_addr()) ) {
$addr =~ /^\[?([\d\.]+)\]?$/ or die "bad remote addr [$addr]";
$xheader .= "X-HTTP-Client: [$1]\n"
. "X-Generated-By: NMS FormMail.pl v$VERSION\n";
}

if ( $send_confirmation_mail ) {
open_sendmail_pipe(\*CMAIL, $mailprog);
print CMAIL $xheader, "To: $email$realname\n$confirmation_text";
close CMAIL;
}

open_sendmail_pipe(\*MAIL, $mailprog);

print MAIL $xheader, <<EOMAIL;
To: $Config{recipient}
From: $email$realname
Subject: $subject

Below is the result of your feedback form. It was submitted by
$Config{realname} (${\( $Config{email}||'' )}) on $date
$dashes

EOMAIL

if ($Config{print_config}) {
foreach (@{$Config{print_config}}) {
print MAIL "$_: $Config{$_}\n\n" if $Config{$_};
}
}

foreach (@$Field_Order) {
my $val = (defined $Form{$_} ? $Form{$_} : '');
if ($Config{'print_blank_fields'} || $val !~ /^\s*$/) {
print MAIL "$_: $val\n\n";
}
}

print MAIL "$dashes\n\n";

foreach (@{$Config{env_report}}) {
print MAIL "$_: ", strip_nonprintable($ENV{$_}), "\n" if $ENV{$_};
}

close (MAIL) || die "close mailprog: \$?=$?,\$!=$!";
}

sub open_sendmail_pipe {
my ($fh, $mailprog) = @_;

my $result;
eval { local $SIG{__DIE__};
$result = open $fh, "| $mailprog"
};
if ($@) {
die $@ unless $@ =~ /Insecure directory/;
delete $ENV{PATH};
$result = open $fh, "| $mailprog";
}

die "Can't open $mailprog\n" unless $result;
}

sub cleanup_realname {
my ($realname) = @_;

return '' unless defined $realname;

$realname =~ s#\s+# #g;

if ($secure) {
# Allow no unusual characters and impose a length limit. We
# need to allow extended ASCII characters because they can
# occur in non-English names.
$realname =~ tr# a-zA-Z0-9_\-,./'\200-377##dc;
$realname = substr $realname, 0, 128;
} else {
# Be as generous as possible without opening any known or
# strongly suspected relaying holes.
$realname =~ tr#()\\#{}/#;
}

return $realname;
}

sub check_email {
my ($email) = @_;

return 0 if $email =~ /^\s*$/;

unless ($email =~ /^(.+)\@([a-z0-9_\.\-\[\]]+)$/is) {
warn_bad_email($email, "malformed email address&quot

;
return 0;
}
my ($user, $host) = ($1, $2);

if ($host =~ /\.\./) {
warn_bad_email($email, "hostname $host contains '..'&quot

;
return 0;
} elsif ($host =~ /^\./) {
warn_bad_email($email, "hostname $host starts with '.'&quot

;
return 0;
} elsif ($host =~ /\.$/) {
warn_bad_email($email, "hostname $host ends with '.'&quot

;
return 0;
}

if ($emulate_matts_code and not $secure) {
# Be as generous as possible without opening any known or strongly
# suspected relaying holes.
if ($user =~ /([^a-z0-9_\-\.\#\$\&\'\*\+\/\=\?\^\`\{\|\}\~\200-\377])/i) {
my $c = sprintf '%s (ASCII 0x%.2X)', $1, unpack('C',$1);
warn_bad_email($email, "bad character $c&quot

;
return 0;
} else {
return 1;
}
} else {
# Only allow reasonable email addresses.

if ($user =~ /([^a-z0-9_\-\.\*\+\=])/i) {
my $c = sprintf '%s (ASCII 0x%.2X)', $1, unpack('C',$1);
warn_bad_email($email, "bad character $c&quot

;
return 0;
} elsif (length $user > 100) {
warn_bad_email($email, "username part too long&quot

;
return 0;
}

if (length $host > 100) {
warn_bad_email($email, "hostname too long&quot

;
return 0;
}
return 1 if $host =~ /^\[\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}\]$/;
return 1 if $host =~ /^[a-z0-9\-\.]+$/i;

warn_bad_email($email, "invalid hostname $host&quot

;
return 0;
}

# not reached
return 0;
}

sub warn_bad_email {
my ($email, $whybad) = @_;

$debug_warnings .= <<END if $DEBUGGING;
<p>
<font color="red">Warning:</font>
The email address <tt>${\( escape_html($email) )}</tt> was rejected
for the following reason: ${\( escape_html($whybad) )}
</p>
END
}

# check the validity of a URL.

sub check_url_valid {
my $url = shift;

# allow relative URLs with sane values
return 1 if $url =~ m#^[a-z0-9_\-\.\,\+\/]+$#i;

$url =~ m< ^ (?:ftp|http|https):// [\w\-\.]+ (?:\:\d+)?
(?: / [\w\-.!~*'(|);/\@+\$,%#]* )?
(?: \? [\w\-.!~*'(|);/\@&=+\$,%#]* )?
$
>x ? 1 : 0;
}

sub strip_nonprintable {
my $text = shift;
return '' unless defined $text;
$text=~ tr#\t\n\040-\176\241-\377# #cs;
return $text;
}

sub body_attributes {
my %attrs = (bgcolor => 'bgcolor',
background => 'background',
link_color => 'link',
vlink_color => 'vlink',
alink_color => 'alink',
text_color => 'text');

my $attr = '';

foreach (keys %attrs) {
next unless $Config{$_};
if (/color$/) {
next unless $Config{$_} =~ /^(?:#[0-9a-z]{6}|[\w\-]{2,50})$/i;
} elsif ($_ eq 'background') {
next unless check_url_valid($Config{$_});
} else {
die "no check defined for body attribute [$_]";
}
$attr .= qq( $attrs{$_}=&quot

. escape_html($Config{$_}) . '"' if $Config{$_};
}

return $attr;
}

sub error {
my ($error, @error_fields) = @_;
my ($host, $missing_field, $missing_field_list);

my ($title, $error_body);

if ($error eq 'bad_referer') {
my $referer = referer();
$referer = '' if ! defined( $referer );
my $escaped_referer = escape_html($referer);

if ( $referer =~ m|^https?://([\w\.\-]+)|i) {
$host = $1;
$title = 'Bad Referrer - Access Denied';
$error_body =<<EOBODY;
<p>
The form attempting to use FormMail resides at <tt>$escaped_referer</tt>,
which is not allowed to access this program.
</p>
<p>
If you are attempting to configure FormMail to run with this form,
you need to add the following to \@referers, explained in detail in the
README file.
</p>
<p>
Add <tt>'$host'</tt> to your <tt><b>\@referers</b></tt> array.
</p>
EOBODY
} elsif (length $referer) {
$title = 'Malformed Referrer - Access Denied';
$error_body =<<EOBODY;
<p>
The referrer value <tt>$escaped_referer</tt> cannot be parsed, so
it is not possible to check that the referring page is allowed to
access this program.
</p>
EOBODY
} else {
$title = 'Missing Referrer - Access Denied';
$error_body =<<EOBODY;
<p>
Your browser did not send a <tt>Referer</tt> header with this
request, so it is not possible to check that the referring page
is allowed to access this program.
</p>
EOBODY
}
}
elsif ($error eq 'bad_method') {
my $ref = referer();
if (defined $ref and $ref =~ m#^https?://#) {
$ref = 'at <tt>' . escape_html($ref) . '</tt>';
} else {
$ref = 'that you just filled in';
}
$title = 'Error: GET request';
$error_body =<<EOBODY;
<p>
The form $ref fails to specify the POST method, so it would not
be correct for this script to take any action in response to
your request.
</p>
<p>
If you are attempting to configure this form to run with FormMail,
you need to set the request method to POST in the opening form tag,
like this:
<tt><form action="/cgi-bin/FormMail.pl" method="post"></tt>
</p>
EOBODY
} elsif ($error eq 'no_recipient') {

my $recipient = escape_html($Config{recipient});
$title = 'Error: Bad or Missing Recipient';
$error_body =<<EOBODY;
<p>
There was no recipient or an invalid recipient specified in the
data sent to FormMail. Please make sure you have filled in the
<tt>recipient</tt> form field with an e-mail address that has
been configured in <tt>\@recipients</tt> or <tt>\@allow_mail_to</tt>.
More information on filling in <tt>recipient/allow_mail_to</tt>
form fields and variables can be found in the README file.
</p>
<hr size="1" />
<p>
The recipient was: [ $recipient ]
</p>
EOBODY
}
elsif ( $error eq 'too_many_recipients' ) {
$title = 'Error: Too many Recipients';
$error_body =<<EOBODY;
<p>
The number of recipients configured in the form exceeds the
maximum number of recipients configured in the script. If
you are attempting to configure FormMail to run with this form
then you will need to increase the <tt>\$max_recipients</tt>
configuration setting in the script.
</p>
EOBODY
}
elsif ( $error eq 'missing_fields' ) {
if ( $Config{'missing_fields_redirect'} ) {
print redirect($Config{'missing_fields_redirect'});
exit;
}
else {
my $missing_field_list = join '',
map { '<li>' . escape_html($_) . "</li>\n" }
@error_fields;
$title = 'Error: Blank Fields';
$error_body =<<EOBODY;
<p>
The following fields were left blank in your submission form:
</p>
<div class="c2">
<ul>
$missing_field_list
</ul>
</div>
<p>
These fields must be filled in before you can successfully
submit the form.
</p>

<p>
Please use your back button to return to the form and
try again.
</p>
EOBODY
}
}

print header();
$done_headers++;
print <<END_ERROR_HTML;
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
"

http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">

<html xmlns="

http://www.w3.org/1999/xhtml">

<head>
<title>$title</title>
$style_element
<style type="text/css">

</style>
</head>
<body>$debug_warnings
<table border="0" width="600" bgcolor="#9C9C9C" align="center" summary="">
<tr>
<th class="c1">$title</th>
</tr>
</table>
<table border="0" width="600" bgcolor="#CFCFCF">
<tr>
<td>
$error_body
<hr size="1" />
<p class="c3">
<a href="

http://www.scriptarchive.com/nms.html">nms

http://www.scriptarchive.com/formmail.html">FormMail</a>

at
<a href="

http://www.scriptarchive.com/">Matt's

Script Archive</a>.
</p>
</td>
</tr>
</table>
</body>
</html>
END_ERROR_HTML
exit;
}

use vars qw(%escape_html_map);

BEGIN
{
%escape_html_map = ( '&' => '&',
'<' => '<',
'>' => '>',
'"' => '"',
"'" => ''',
);
}

sub escape_html {
my $str = shift;

my $chars = join '', keys %escape_html_map;

if (defined($str))
{
$str =~ s/([\Q$chars\E])/$escape_html_map{$1}/g;
}

return $str;
}

# No __END__ here because that breaks under Apache::Registry

=head1 COPYRIGHT

FormMail $Revision: 1.87 $
Copyright 2001 London Perl Mongers, All rights reserved

Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Help with this error please...

raevans

Programmer

tviman

Programmer

raevans

Programmer

Similar threads

Part and Inventory Search

Sponsor