#!/usr/bin/perl -T

require 5;

##
# params:
#     ctl:required        Fields that the user is required to enter.
#     ctl:required_mesg   Message to display if the user doesn't fill out 
#                         a required field.
# 
#     ctl:pretty_print    Nicely format the mail body.  (Default: true)
#                         Currently obsolete.
#     ctl:keep_empties    Mail an input and it's value, even if it wasn't 
#                         defined.  (Default: false)
# 
#     ctl:link...         There can be links appended to the end of the 
#                         follow-up document.  Each link directive is specified
#                         with ctl:link?_, where ? is the number of the link,
#                         starting with 1.
#     ctl:link?_url       A link to append at the end of the document.
#     ctl:link?_mesg      The text of the given link.
#     ctl:link?_img       The image associated with the given link.
# 
#     ctl:link_sepstr     String used to separate one link from another
#     ctl:link_sepimg     Image used to separate one link from another
# 
#     ctl:followup_url    URL to display after form submission, as a
#                         replacement for any output from this script.
#     ctl:followup_head   Absolute pathname of file to prepend the default 
#                         output from this script.
#     ctl:followup_tail   Absolute pathname of file to append the default 
#                         output from this script.
# 
#     hdr:to              Target address of mail.  Required.
#     hdr:*               Arbitrary mail header line.  Anything can be put 
#                         in place of the '*' -- it's up to sendmail to decide 
#                         what to do with it.
# 
#     anything_else       All other inputs will be sent as part of the mail 
#                         body.
##

##
# This script Copyright (c) 1997 O'Shaughnessy Evans, GST-Call America 
# Business Communications Corp.
##


sub init
{
    # Referer Pattern: the regular expression describing hosts that will
    # be allowed to call this script.  That is, what addresses will the
    # environmental variable HTTP_REFERER successfully match?
    $referer_pat = '^(207.114.188.170)$';

    # Sendmail: where is the local version of sendmail installed?
    $sendmail = "/usr/lib/sendmail";

    # Force Required: the list of parameters that MUST be included.
    # Should be a comma-separated list
    @force_reqd    = ( 'hdr:to' );

    # Input defaults
    $required_mesg = "Sorry, but you must fill out all of the required fields".
                     " as indicated on the form.";
    $Control{'link_sepstr'}   = '/';

    $Control{'pretty_print'}  = 1;
    $Control{'keep_empties'}  = 0;

    $ENV{'PATH'} = "/usr/bin:/usr/ucb:/usr/sbin:/usr/lib";
}


sub htstart
{
    $Cgi = new CGI;

    if ($Cgi->param('ctl:DEBUG')) {
        $DEBUG = 1;
        $| = 1;
        $Cgi->delete('ctl:DEBUG');
        print $Cgi->header, $Cgi->start_html(-'title'  => 'Mailserf Output');
    }
}


sub htend
{
    dprint("<hr>", $Cgi->dump);
    print $Cgi->end_html, "\n";
}


sub hterr
{
    my($title, @mesg) = @_;
    print $Cgi->header, "<h1>$title</h1>\n<p>@mesg<br>\n";
    exit(2);
}


sub dprint
{
    print @_ if $DEBUG;
}


sub name_to_addr
{
   my $name = shift;
   my($addr);

   $addr = inet_ntoa(inet_aton($name));
   if (!$addr) {
      dprint("Couldn't look up $name\n");
      return 0;
   }
   else {
      return $addr;
   }
}


sub hostallow
{
    $Cgi->referer =~ "^[a-zA-Z]+:\/\/([^:/]+)";
    $addr = name_to_addr($1);
    $addr =~ /$referer_pat/ or hterr("CGI-BIN access denied from referer $1",
     "Sorry, but only local hosts are allowed to access cgi-bin programs ".
     "on this server.");
}
 

# Recursively dereference a "val:key" input value.
# input  : an input value (as opposed to an input name)
# returns: value of the last-derefenced input
sub deref_val
{
    local($_) = shift;
    while ( /^val:(\S+)/ ) { $_ = $Cgi->param($1); }
    return $_;
}


# Find and expand the '+' and 'val:' tokens in an input value.
# input  : the name of the input to expand
# returns: Changes the CGI object's definition of the given input's value.
#          Returns nothing.
sub expand_input
{
    shift;
    my($val);

    $val = $Cgi->param($_);
    if ($val =~ /\+/) {
        my(@line);
        foreach ( split(/\s*\+\s*/, $val) ) {
            push(@line, /^val:/ ? deref_val($_) : $_);
        }
        $Cgi->param($_, "@line");
        dprint("Expanded <b>$val</b> to <b>", $Cgi->param($_), "</b><br>\n");
    }
    elsif ($val =~ /^val:/) { 
        $Cgi->param($_, deref_val($val));
        dprint("Expanded <b>$val</b> to <b>", $Cgi->param($_), "</b><br>\n");
    }
}


sub abs_path
{
    my($path) = @_;

    return $ENV{'DOCUMENT_ROOT'}.'/'.$path;
}

sub parse_params
{
    my(@reqd, $tmp);

    # check for required params
    push @reqd, @force_reqd;
    if ($Cgi->param('ctl:required')) {
        push @reqd, ( split(/\s*,\s*/, $Cgi->param('ctl:required')) );
    }
    if ($Cgi->param('ctl:required_mesg')) {
        $required_mesg = $Cgi->param('ctl:required_mesg');
    }

    dprint("Required: <b>@reqd</b><br>\n");
    grep { $tmp = $Cgi->param($_);
           dprint("looking for <b>$_</b>...");
           $tmp =~ /\S/ or hterr("Missing Arguments", $required_mesg);
           dprint("found.<br>\n");
    } @reqd;

    $Cgi->delete('ctl:required');
    $Cgi->delete('ctl:required_mesg');

    foreach ($Cgi->param) {
        expand_input($_);

        if (/^ctl:(\S+)/) {
            $tmp = lc $1;
            if ($Cgi->param($_) =~ /^(false|0)$/) {
                $Control{$tmp} = 0;
            }
            elsif ($Cgi->param($_) =~ /^(true|1)$/) {
                $Control{$tmp} = 1;
            }
            else {
                $Control{$tmp} = $Cgi->param($_);
            }
            dprint("Found control line: <b><i>$tmp = </i>", 
             $Control{$tmp}, "</b><br>\n");

        }
        elsif (/^hdr:(\S+)/) {
            $Headers{$1} = $Cgi->param($_);
            dprint("Found header line: <b><i>$1 = </i>", $Headers{$1}, 
             "</b><br>\n");
        }
        else {
            $Body{$_} = $Cgi->param($_);
            dprint("Found body line: <b><i>$_ = </i>", $Body{$_}, "</b><br>\n");
        }   
    }
    $Cgi->delete_all() unless $DEBUG;
}


sub send_mail
{
    my($hdr);

    # Build message header
    $hdr = "To: $Headers{'to'}\n";
    delete $Headers{'to'};
    foreach (keys %Headers) {
        $hdr .= "$_: $Headers{$_}\n";
    }

    # Send message
    if ($DEBUG) {
        open(MTA, ">&STDOUT") || croak("I couldn't dup STDOUT");
        print MTA "The following message was generated, but not sent:<br>\n",
              "<hr width=\"30%\" align=\"left\"><pre>\n";
    }
    else {
        open(MTA, "|$sendmail -t -oi") || croak("I couldn't open $sendmail!");
    }

    print MTA "$hdr\n";
    print MTA "The following data was submitted from ", 
     $Cgi->remote_host(), "\non ", scalar localtime(), ":\n\n";
    foreach (sort keys %Body) {
        next if (!$Control{'keep_empties'} && !$Body{$_});
        if ($Body{$_} =~ /\n/) {
            print MTA "  o $_ = \n";
            foreach (split /\n/, $Body{$_}) {
                print MTA "       $_\n";
            }
        }
        else {
            print MTA "  o $_ = $Body{$_}\n";
        }
    }

    close(MTA) || croak("Weird error: I couldn't close $sendmail!");
    dprint("</pre><hr width=\"30%\" align=\"left\">\n");
}


sub follow_up
{
    my($url, $img, $mesg);
    local(*FILE);

    if ($Control{'followup_url'}) {
        print "Location: ", $Control{'followup_url'}, "\n\n";
        dprint("<p>\n");
        dprint("No follow up text; Browser redirected to ".
         "<b>$Control{'followup_url'}</b><br>\n");
        return;
    }
    else {
        print $Cgi->header,
              $Cgi->start_html(
              -'title'  => 'Mailserf Output',
              -'author' => 'shaug@callamer.com',
              -'meta'   => { 'copyright' => "copyright (c) 1997 O'Shaughnessy ".
                             "Evans, GST-Call America" });
    }

    if ($Control{'followup_head'}) {
        dprint("<p>Opening up followup header file <b>", 
         abs_path($Control{'followup_head'}), "</b><br>\n");
        open(FILE, abs_path($Control{'followup_head'}))
         || carp("Couldn't read in followup header file ".
            $Control{'followup_head'}.": $!");

        while(<FILE>) { print; }

        close(FILE)
         || carp("mailserf: Couldn't close followup header file ".
            $Control{'followup_head'}.": $!");
        dprint("<p>End of followup header file<br>\n");
    }

    # Display the submitted information
    print "<h3>Thank you!  Your form was submitted with the following ".
     "information:</h3>\n";
    print "<ul compact>\n";
    foreach (sort keys %Body) {
        next if (!$Control{'keep_empties'} && !$Body{$_});
        print "<li><strong>$_</strong>\n",
              "<pre>".$Body{$_}."</pre>\n";
    }
    print "</ul><p>\n";

    if ($Control{'followup_tail'}) {
        dprint("<p>Opening up followup tail file <b>", 
         abs_path($Control{'followup_tail'}), "</b><br>\n");
        open(FILE, abs_path($Control{'followup_tail'}))
         || carp("mailserf: Couldn't read in followup tail file ".
            $Control{'followup_tail'}.": $!");

        while(<FILE>) { print; }

        close(FILE)
         || carp("mailserf: Couldn't close followup tail file ".
            $Control{'followup_tail'}.": $!");
        dprint("<p>End of followup tail file<br>\n");
    }

    # Provide options (i.e. links) for continuing
    print qq/<hr width="50%">\n/;
    $url = $Control{'link1_url'};    
    if ($url) {
        $img  = $Control{'link1_img'};    
        $mesg = $Control{'link1_mesg'};    
        print qq/<a href="$url">\n/;
        print qq/\t<img src="$img" border="0">\n/ if $img;
        print $mesg if $mesg;
        print "</a>\n";
    }
    $i = 1;
    $link_sep = $Control{'link_sepimg'} 
                ? qq/\t<img src="$Control{'link_sepimg'}">\n/
                : qq/\t$Control{'link_sepstr'}\n/;
    while ($url = $Control{'link'.++$i.'_url'}) {
        dprint("<br>{$i} Building link for <b>$url</b><br>\n");
        $mesg = $Control{'link'.$i.'_mesg'};    
        $img  = $Control{'link'.$i.'_img'};    
        dprint("-> found link message <b>$mesg</b><br>\n");
        dprint("-> found link image <b>$img</b><br>\n");
        print $link_sep;
        print qq/<a href="$url">\n/;
        print qq/\t<img src="$img" border="0">\n/ if $img;
        print "\t$mesg" if $mesg;
        print "</a>\n";
    }
}


BEGIN { 
    use Socket;
    use CGI;
    use CGI::Carp;

    init();
    htstart(); 
}

hostallow();
parse_params();
send_mail();
follow_up();

END { htend(); }