{REFERER},"\">Back to the form.\n";
}
}
}
# ---------- Send out the form via E-mail ---------
# One copy gets e-mailed. The other gets displayed
# on the screen so that the remote user knows something happened.
sub send_mail {
my($header,$body,$html,$dictionary) = @_; # RHK - added parameter
$header = &do_substitutions($header,$dictionary);
$header = &remove_empty_fields($header);
$html = &do_substitutions($html,$dictionary,2); # RHK - added function call
$body = &do_substitutions($body,$dictionary,1);
# Check the TO address for shell meta-characters
if ($dictionary->{TO}=~/[;|\`\/]/) {
print < {REFERER},"\">Back to the form.\n";
}
}
# -------- Parse configuration form -------
# Pass the routine a filehandle open to the configuration
# file
sub read_configuration {
my($query) = @_;
my($dictionary) = {};
my($forms) = {};
my($user_config_file, $new_path);
&config(DATA,$dictionary,$forms); # read our built-in defaults
if (-e $query->path_info) {
$user_config_file = $query->path_info;
} elsif (-e $query->path_translated) {
$user_config_file = $query->path_translated;
##### CFK - the user config file may have moved...
} elsif (-e ($new_path = &site_moved($query->path_info))) {
$user_config_file = $new_path;
} else { # still can't find it, so try a rel. path
my($path) = $query->path_info=~m#^/(\S+)#;
$user_config_file = "./$path" if -e "./$path";
}
if ($user_config_file) {
open (USER_CONFIG,"$user_config_file") || &croak("$user_config_file: $!");
&config(USER_CONFIG,$dictionary,$forms);
close(USER_CONFIG);
}
return ($dictionary,$forms);
}
# Read an individual configuration file.
sub config {
my($filehandle,$dictionary,$forms)=@_;
my($tag,$value,$old);
&fill_in_predefines($dictionary);
while (<$filehandle>) {
chomp;
next if /^#/;
next unless ($tag,$value) = /(^\w+)\s*=\s*(.*)/;
# Eliminate case-sensitivity by converting to upper case
$tag =~ tr/a-z/A-Z/;
# RHK - added NEXT_HTML, FILE_OUTPUT_FORM, and MAIL_OUTPUT_FORM to tag list
if ($tag=~/MAIL_HEADER|NEXT_HTML|OUTPUT_FORM|FILE_OUTPUT_FORM|INPUT_FORM/) {
($old,$/)=($/,"\n.\n");
chomp($forms->{$tag}=<$filehandle>);
$forms->{$tag} .= "\n"; # add back a newline
$/=$old;
} else {
$dictionary->{$tag} = &do_substitutions($value,$dictionary);
}
}
}
# Fill in a few of the special predefined tags.
sub fill_in_predefines {
my $dictionary = shift;
$dictionary->{DATE}=localtime;
$dictionary->{SCRIPT}=$query->script_name;
$dictionary->{REFERER}=$query->referer;
$dictionary->{REMOTE_USER}=$ENV{HTTP_FROM} ||
$query->remote_ident || $query->remote_user;
$dictionary->{USER_AGENT}=$query->user_agent;
$dictionary->{REMOTE_HOST}=$query->remote_host;
my($name,$junk,$junk,$junk,$junk,$junk,$gcos) = getpwuid($<);
$dictionary->{SERVER} = "$name\@" . $query->server_name . " ($gcos)";
$dictionary->{SERVER_HOST} = $query->server_name;
$dictionary->{ADMINISTRATOR} = $ENV{SERVER_ADMIN};
}
# Do the variable substitutions.
sub do_substitutions {
my($scalar,$dictionary,$tag) = @_;
my($key);
my(@keys) = $scalar=~/\@(\w+)\@/g;
# Note that we use the unoptimized s/// form here for
# security reasons -- check the performance!
foreach $key (@keys) {
# RHK - if processing OUTPUT_FORM, use \n instead of An error occurred while processing this form:\n";
print " $msg\n
if ($dictionary->{MULTIVALUE_FORMAT} eq "LIST" && $tag == 1) {
$dictionary->{$key} =~ s/
/\n/g;
}
$scalar=~s/\@$key\@/$dictionary->{$key}/g;
}
return $scalar;
}
# A bit of aesthetic silliness -- remove empty
# fields in the e-mail header
sub remove_empty_fields {
my $header = shift;
do {} while $header=~s/\n[\w-]+:\s*\n/\n/mg;
return $header;
}
# Wordwrap paragraphs
sub wordwrap {
my ($text,$wordwraplength) = @_;
unless ($wordwraplength) {
print $text;
return;
}
my (@paragraphs) = split("\n\n",$text);
my $para;
foreach $para (@paragraphs) {
my (@lines) = split("\n",$para);
if (grep(length($_) > $wordwraplength,@lines)) {
&compile_format($wordwraplength);
($xText=$para)=~tr/\n//; # get rid of the newlines
$-=9999; # no page breaks
write;
} else {
print "$para\n\n";
}
}
}
# Compile the report format used to wordwrap lines
sub compile_format {
my $length = shift;
$~=OUT;
return if $FMT;
my ($linepat) = '<' x $length;
$FMT=<