#!/usr/local/bin/perl
# CHANGE THE ABOVE PATH TO THE CORRECT PATH TO PERL VERSION 5.001 
# ON YOUR SYSTEM!
# Script: mailmerge.cgi

# Copyright 1995, Lincoln D. Stein.  You are free to use and
# redistribute this script so long as this copyright statement
# remains intact.

# This is the CGI.pm library, which must be installed in 
# /usr/local/lib/perl5 or equivalent.
use CGI;
sub lock($$);

# The path to the sendmail program may need to be set for
# your site.
$MAIL = '/usr/lib/sendmail';	
$ENV{'PATH'}='/bin:/usr/bin:/usr/lib';

# For logfile pathname translation, change this if your site
# uses something different for its user's home web directories.
$PUBLIC_HTML = 'public_html';

# See the material following the __END__ for more user-configurable
# options.

#####################################################
# From here to __END__ should not need to be changed
#####################################################
%VERBOTEN = ('ACTION'=>1,'DATE'=>1,'SCRIPT'=>1,'REFERER'=>1,
	     'REMOTE_USER'=>1,'USER_AGENT'=>1,'REMOTE_HOST'=>1,
	     'SERVER'=>1,'SERVER_HOST'=>1,'ADMINISTRATOR'=>1,
	     'ESCAPE_HTML'=>1);

# Create a new CGI object and print out the HTTP header
$query = new CGI;
print $query->header;

# Read our configuration files and store the token
# lookup table in "dictionary"
($dictionary,$forms) = &read_configuration($query);

# Print out the title and the top of the HTML document.
# Add information from the parsed form to the lookup table.
print $query->start_html($dictionary->{TITLE});
foreach ($query->param()) {
    next if $VERBOTEN{$_};	# certain parameters can't be set by the remote user
    $dictionary->{$_}=&process_user_input($dictionary,
					  $dictionary->{ESCAPE_HTML},
					  $query->param($_));
}

# Try to post mail if we're being called by a POST request
# and the lookup table contains the TO field.
if (($ENV{REQUEST_METHOD} eq 'POST') && $dictionary->{TO}) {

    if ($dictionary->{ACTION}=~/^mailto:\s*(.+)/i) {
	$dictionary->{TO} = $1;
	&send_mail($forms->{MAIL_HEADER},$forms->{OUTPUT_FORM},$dictionary);
    } elsif ($dictionary->{ACTION}=~/^mail/i) {
	&send_mail($forms->{MAIL_HEADER},$forms->{OUTPUT_FORM},$dictionary);
    } elsif ($dictionary->{ACTION}=~/^file:\s*(\S+)/i) {
	&save_file($1,$forms->{OUTPUT_FORM},$dictionary);
    }

    print "<P><A HREF=\"",$query->self_url,"\">Back to the form.</A>\n";
# Otherwise use the INPUT_FORM field to generate a new form
# for the use to fill out.
} else {
    &generate_form($forms->{INPUT_FORM},$dictionary);
}

# The rest of this is advertising.
print <<EOF;
<HR>
This form generated by 
<A HREF="http://stein.cshl.org/WWW/software/mailmerge/">
mailmerge</A>.
<HR><ADDRESS>
$dictionary->{AUTHOR}<BR>
$dictionary->{ADDRESS}
</ADDRESS>
EOF
    ;
print $query->end_html;

################### SUBROUTINES ###############
# ------------ Create the form -----------
sub generate_form {
    my($form,$dictionary) = @_;
    $form = &do_substitutions($form,$dictionary);
    print <<EOF;
<FORM METHOD="POST">
$form
</FORM>
EOF
}

# Join multivalued parameters according to the author's
# preference.
sub process_user_input {
    my($config,$escape_html,@values) = @_;
    @values = grep ($_,@values);
    
    # This is a convenient place to escape any HTML characters
    # in the user's input, if present.
    if ($escape_html) {
	foreach (@values) {
	    $_ = &CGI::escapeHTML({},$_);
	}
    }

    return $values[0] unless @values > 1;
    if ($config->{MULTIVALUE_FORMAT} eq 'BRACES') {
	return "{" . join(",",@values) . "}";
    } else {
	my $last = pop @values;
	return join(", ",@values) . " and $last";
    }
}

# ----------------- Write message to a file ------------------
sub save_file { 
    my($file,$body,$dictionary) = @_;
    $body = &do_substitutions($body,$dictionary);
    my $logfile = &find_logfile($query,$file);

    &croak("$0: Specified log file '$file' does not exist.  It must already be created and writable.")
	   unless $logfile;
    open(LOGFILE,">>$logfile") || 
	&croak("Failed opening log file $file: $!\n");
    lock(LOGFILE,1);
    select(LOGFILE);
    print '-'x50,"\n";
    &wordwrap($body,$dictionary->{WORDWRAP});
    lock(LOGFILE,undef);
    close(LOGFILE);

    # Print another copy to the screen so the user can see
    # what's going out:
    select STDOUT;
    print <<EOF;
<H1>$dictionary->{TITLE}</H1>
<STRONG>The following is a copy of the log entry that was submitted.</STRONG>
EOF
    ;
    &wordwrap($body,$dictionary->{WORDWRAP},$dictionary->{ESCAPE_HTML});
}

# ---------- 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,$dictionary) = @_;
    $header = &do_substitutions($header,$dictionary);
    $header = &remove_empty_fields($header);
    $body = &do_substitutions($body,$dictionary);
    
    # Check the TO address for shell meta-characters
    if ($dictionary->{TO}=~/[;|\`\/]/) {
	print <<EOF;
<STRONG>The To: address "$dictionary->{TO}" contains
illegal shell metacharacters.  If this was unintentional,
please try again.</STRONG>	
EOF
    ;
	return;
    }

    # We fork ourselves in order to avoid passing characters
    # through a shell.
    open (MAIL, "|-") || exec($MAIL,'-t','-oi');
    select MAIL;
    print $header,"\n";
    &wordwrap($body,$dictionary->{WORDWRAP});
    close MAIL;

    # Print another copy to the screen so the user can see
    # what's going out:
    select STDOUT;
    print <<EOF;
<H1>$dictionary->{TITLE}</H1>
<STRONG>The following is a copy of the mail that was submitted.</STRONG>
<LISTING>
$header

EOF
    ;
    &wordwrap($body,$dictionary->{WORDWRAP});
    print <<EOF;
</LISTING>
EOF
    ;
}

# -------- 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);

    &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;
    } 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*(.*)/;
	if ($tag=~/MAIL_HEADER|OUTPUT_FORM|INPUT_FORM/) {
	    ($old,$/)=($/,"\n.\n"); # look for a lonely dot
	    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) = @_;
    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) {
	$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=<<EOF;
format OUT=
^$linepat~~
\$xText

.
EOF
    ;
    eval($FMT);
}

# -------------- error reporting utility ---------------
sub croak {
    my($msg) = @_;
    print "<P><STRONG>An error occurred while processing this form:</STRONG>\n";
    print "<P>$msg</BODY></HTML>\n";
    die $msg;
}

# -------------- file locking utilities -----------
sub lock ($$) {
    my ($lockfh,$lockit) = @_;
    my($LOCK_SH,$LOCK_EX,$LOCK_UN) = (1,2,8);
    if ($lockit) {
	flock($lockfh,$LOCK_EX) || croak "Couldn't get lock in lock()\n";
	seek($lockfh,0,2);
    } else {
	flock($lockfh,$LOCK_UN);
    }
}

####
# Figure out the file to write to
# for log entries.  Look first for a
# absolute URL, then a relative URL, then a physical
# path name.  File must already be created.
###
sub find_logfile {
    my($query,$filename) = @_;
    my $document_root = &document_root($query);
    $filename=~s@~([^/]+)@&getlogin($1)@e;

    return "$document_root$filename" if -e "$document_root/$filename";
    return $filename if -e $filename;

    return undef;
}

####
# Get login account for ~name substitution
#
####
sub getlogin {
    return (getpwnam($_[0]))[7] . "/$PUBLIC_HTML";
}

####
# Utility routine determines the
# document root by comparing path_info to path_translated
####
sub document_root {
    my $query = shift;
    my $partial_path = $query->path_info();
    my $full_path = $query->path_translated();
    # find the partial path in the full path
    return undef unless $full_path=~/$partial_path$/o;
    return $`;			# everything before the match is good
}


__END__

###########################################################
# More user-configurable defaults.  These can (and are
# intended to) be overridden by values provided in a
# configuration file whose address is passed to mailmerge
# at the end of its URL:
#         /cgi-bin/mailmerge.cgi/path/to/config/file
###########################################################

###
# You'll want to adjust these for your site
###
# The title for the mailmerge page
TITLE=Mail Merge Gateway

# Author and address are printed at the bottom of the page
AUTHOR=Lincoln D. Stein
ADDRESS=<A HREF="/">Whitehead Institute for Biomedical Research</A>

############
# The default action is to mail the message to whoever is defined in
# the TO field
ACTION=mail

############
# If you're going to display the user's input in an HTML file, you
# might want to set the ESCAPE_HTML variable to a non-zero value
ESCAPE_HTML=0

############
# Default values for some e-mail fields.  You may
# want to change the default TO field.

TO=webmaster
FROM=@REMOTE_USER@@@REMOTE_HOST@
REPLY_TO=@ADMINISTRATOR@
SUBJECT=Web mail via the mailmerge gateway
CC=
BCC=
BODY=

############
# Values that determine how the e-mail message will
# be formatted.

# Wordwrap width.  Leave the value blank to disable automatic
# word wrapping of long lines.
WORDWRAP=72

# Set this field to BRACES to show multivalued parameters as "{a,b,c}".
# Set to COMMAS to show multivalued parameters as "a, b and c".
MULTIVALUE_FORMAT=BRACES

############
# This defines the default e-mail header.
# You probably won't need to change it.

MAIL_HEADER=
To: @TO@
From: @FROM@
Reply-to: @REPLY_TO@
Cc: @CC@
Bcc: @BCC@
Subject: @SUBJECT@
X-mail-agent: mailmerge v1.1
.

############
# This defines the input form.  Everything from the
# line INPUT_FORM= to the dot (.) at the very bottom
# is the form.

INPUT_FORM=
<H1>@TITLE@</H1>

    <INPUT TYPE="hidden" NAME="TO" VALUE="@TO@">
    <INPUT TYPE="text" NAME="NAME" SIZE=50> Your Name<BR>
    <INPUT TYPE="text" NAME="FROM" 
           VALUE="@FROM@" SIZE=50> Your E-mail address<BR>
    <INPUT TYPE="text" NAME="SUBJECT" VALUE="@SUBJECT@" SIZE=50> Subject<BR>
    <TEXTAREA NAME="BODY" ROWS=12 COLS=60>@BODY@</TEXTAREA><BR>

    <INPUT TYPE="reset"><INPUT TYPE="submit">
.

############
# This defines the output form -- the way the
# various input fields are formatted into the body text of
# the e-mail message.  Everything from OUTPUT_FORM=
# to the dot (.) at the very bottom is the form.

OUTPUT_FORM=
On @DATE@, the following message was submitted via the mailmerge server
running on @SERVER@:

NAME:    @NAME@
ADDRESS: @FROM@

MESSAGE TEXT:

@BODY@
.