CGI::ContactForm - Generate a web contact form

    use CGI::ContactForm;

    contactform (
        recname         => 'John Smith',
        recmail         => 'john.smith@example.com',
        styleurl        => '/style/ContactForm.css',
    );

                        Default value
                        =============
    Compulsory
    ----------
    recname             (none)
    recmail             (none)

    Optional
    --------
    smtp                'localhost'
    styleurl            (none)
    returnlinktext      'Main Page'
    returnlinkurl       '/'
    subject             (none)
    nocopy              0
    bouncetosender      0
    formtmplpath        (none)
    resulttmplpath      (none)
    maxsize             100 (KiB)
    maxperhour          5 (messages per hour per host)
    tempdir             (none)
    spamfilter          '(?is:</a>|\[/url]|https?:/(?:.+https?:/){3})' (Perl regex)

    Additional arguments, intended for forms at non-English sites
    -------------------------------------------------------------
    title               'Send email to'
    namelabel           'Your name:'
    emaillabel          'Your email:'
    subjectlabel        'Subject:'
    msglabel            'Message:'
    reset               'Reset'
    send                'Send'
    erroralert          'Fields with %s need to be filled or corrected.'
    marked              'marked labels'
    thanks              'Thanks for your message!'
    sent_to             'The message was sent to %s with a copy to %s.'
    sent_to_short       'The message was sent to %s.'
    encoding            'ISO-8859-1'

    perl Makefile.PL
    make
    make install

    http://my.execpc.com/~keithp/bdlogcgi.htm

    %Mail::Sender::default = (
        auth      => 'LOGIN',
        authid    => 'username',
        authpwd   => 'password',
    );

  Copyright (c) 2003-2009 Gunnar Hjalmarsson
  http://www.gunnar.cc/cgi-bin/contact.pl

package CGI::ContactForm;

$VERSION = '1.50';
# $Id: ContactForm.pm,v 1.76 2009/03/03 22:46:53 gunnarh Exp $

use strict;
use CGI 'escapeHTML';
use File::Basename;
use File::Spec;
use Fcntl qw(:DEFAULT :flock);
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use Exporter;
@ISA = 'Exporter';
@EXPORT = 'contactform';
@EXPORT_OK = 'CFdie';

BEGIN {
    sub CFdie($) {
        print "Status: 400 Bad Request\n";
        print "Content-type: text/html\n\n<h1>Error</h1>\n<tt>", shift;
        if ( $ENV{MOD_PERL} ) {
            if ( $] < 5.006 ) {
                require Apache;
                Apache::exit();
            }
        }
        exit 1;
    }

    eval "use Mail::Sender";
    CFdie($@) if $@;
}

sub contactform {
    local $^W = 1;  # enables warnings
    my ($error, $in) = {};
    my $time = time;
    my $host = $ENV{'REMOTE_ADDR'} or die "REMOTE_ADDR not set\n";
    umask 0;
    my $args = &arguments;
    if ($ENV{REQUEST_METHOD} eq 'POST') {
        checktimestamp( $args->{tempdir}, $time );
        $in = formdata( $args->{maxsize} );
        if (formcheck($in, $args->{subject}, $error) == 0) {
            checkspamfilter( $in->{message}, $args->{spamfilter} );
            checkmaxperhour($args, $time, $host);
            eval { mailsend($args, $in, $host) };
            CFdie( escapeHTML(my $msg = $@) ) if $@;
            return;
        }
    } else {
        settimestamp( $args->{tempdir}, $time );
    }
    formprint($args, $in, $error);
}

sub arguments {
    my %defaults = (
        recname        => '',
        recmail        => '',
        smtp           => 'localhost',
        styleurl       => '',
        returnlinktext => 'Main Page',
        returnlinkurl  => '/',
        subject        => '',
        nocopy         => 0,
        bouncetosender => 0,
        formtmplpath   => '',
        resulttmplpath => '',
        maxsize        => 100,
        maxperhour     => 5,
        tempdir        => '',
        spamfilter     => '(?is:</a>|\[/url]|https?:/(?:.+https?:/){3})',
        title          => 'Send email to',
        namelabel      => 'Your name:',
        emaillabel     => 'Your email:',
        subjectlabel   => 'Subject:',
        msglabel       => 'Message:',
        reset          => 'Reset',
        send           => 'Send',
        erroralert     => 'Fields with %s need to be filled or corrected.',
        marked         => 'marked labels',
        thanks         => 'Thanks for your message!',
        sent_to        => 'The message was sent to %s with a copy to %s.',
        sent_to_short  => 'The message was sent to %s.',
        encoding       => 'ISO-8859-1',
    );
    my $error;
    if ( @_ % 2 ) {
        $error .= "Odd number of elements in argument list:\n"
         . "  The contactform() function expects a number of key/value pairs.\n";
    }
    my %args = ( %defaults, @_ );
    for (qw/recname recmail/) {
        $error .= "The compulsory argument '$_' is missing.\n" unless $args{$_};
    }
    for (keys %args) {
        $error .= "Unknown argument: '$_'\n" unless defined $defaults{$_};
    }
    if ($args{recmail} and emailsyntax($args{recmail})) {
        $error .= "'$args{recmail}' is not a valid email address.\n";
    }
    unless ($args{tempdir}) {
        unless (-d $CGITempFile::TMPDIRECTORY and -w _ and -x _) {
            $error .= "You need to state a temporary directory via the 'tempdir' argument.\n";
        }
    } elsif (!(-d $args{tempdir} and -w _ and -x _)) {
        $error .= "'$args{tempdir}' is not a writable directory.\n";
    }
    for ('formtmplpath', 'resulttmplpath') {
        if ($args{$_} and !-f $args{$_}) {
            $error .= "Argument '$_': Can't find the file $args{$_}\n";
        }
    }
    {
        local $SIG{__WARN__} = sub { die $_[0] };
        eval { $args{spamfilter} = qr($args{spamfilter}) };
        if ( $@ ) {
            my $mod_path = $INC{'CGI/ContactForm.pm'};
            $@ =~ s/ at $mod_path.+//;
            $error .= "Argument 'spamfilter': " . escapeHTML(my $err = $@);
        }
    }

    CFdie("<pre>$error" . <<'EXAMPLE'

Example:

    contactform (
        recname => 'John Smith',
        recmail => 'john.smith@example.com',
    );
EXAMPLE

    ) if $error;

    \%args;
}

sub formdata {
    my $max = shift;
    if ($ENV{CONTENT_LENGTH} > 1024 * $max) {
        CFdie("The message size exceeds the $max KiB limit.\n"
              . '<p><a href="javascript:history.back(1)">Back</a>');
    }

    # create hash reference to the form data
    my $in = new CGI->Vars;

    # trim whitespace in message headers
    for (qw/name email subject/) {
        $in->{$_} =~ s/^\s+//;
        $in->{$_} =~ s/\s+$//;
        $in->{$_} =~ s/\s+/ /g;
    }

    $in;
}

sub formcheck {
    my ($in, $defaultsubject, $error) = @_;
    for (qw/name message/) { $error->{$_} = ' class="error"' unless $in->{$_} }
    $error->{subject} = ' class="error"' unless $in->{subject} or $defaultsubject;
    $error->{email} = ' class="error"' if emailsyntax( $in->{email} );
    %$error ? 1 : 0;
}

sub emailsyntax {
    return 1 unless my ($localpart, $domain) = shift =~ /^(.+)@(.+)/;
    my $atom = '[^[:cntrl:] "(),.:;<>@\[\\\\\]]+';
    my $qstring = '"(?:\\\\.|[^"\\\\\s]|[ \t])*"';
    my $word = qr($atom|$qstring);
    return 1 unless $localpart =~ /^$word(?:\.$word)*$/;
    $domain =~ /^$atom(?:\.$atom)+$/ ? 0 : 1;
}

sub mailsend {
    my ($args, $in, $host) = @_;

    # Extra headers
    my @extras = "X-Originating-IP: [$host]";
    if ( my $agent = $ENV{'HTTP_USER_AGENT'} ) {
        my @lines;
        while ( $agent =~ /(.{1,66})(?:\s+|$)/g ) {
            push @lines, $1;
        }
        push @extras, 'User-Agent: ' . join("\r\n\t", @lines);
    }
    push @extras, "Referer: $ENV{'HTTP_REFERER'}" if $ENV{'HTTP_REFERER'};
    push @extras, "X-Mailer: CGI::ContactForm $VERSION at $ENV{HTTP_HOST}";

    # Make message format=flowed (RFC 2646)
    eval "use Encode 2.23 ()";
    my $convert = $@ ? 0 : 1;
    $in->{message} = Encode::decode( $args->{encoding}, $in->{message} ) if $convert;
    $in->{message} = reformat( $in->{message}, { max_length => 66, opt_length => 66 } );
    $in->{message} = Encode::encode( $args->{encoding}, $in->{message} ) if $convert;
    push @extras, "Content-type: text/plain; charset=$args->{encoding}; format=flowed";

    # Send message
    $Mail::Sender::NO_X_MAILER = 1;
    $Mail::Sender::SITE_HEADERS = join "\r\n", @extras;
    ref (new Mail::Sender -> MailMsg( {
        smtp      => $args->{smtp},
        encoding  => ( $in->{message} =~ /[[:^ascii:]]/ ? 'quoted-printable' : '7bit' ),
        from      => ( $args->{bouncetosender} ? $in->{email} : $args->{recmail} ),
        fake_from => namefix( $in->{name}, $args->{encoding} ) . " <$in->{email}>",
        to        => namefix( $args->{recname}, $args->{encoding} ) . " <$args->{recmail}>",
        bcc       => ( $args->{nocopy} ? '' : $in->{email} ),
        subject   => mimeencode( $in->{subject}, $args->{encoding} ),
        msg       => $in->{message},
    } )) or die "Cannot send mail. $Mail::Sender::Error\n";

    # Print resulting page
    my @resultargs = qw/recname returnlinktext returnlinkurl title thanks/;
    $args->{$_} = escapeHTML( $args->{$_} ) for @resultargs;
    my $sent_to = sprintf escapeHTML( $args->{nocopy} ? $args->{sent_to_short} : $args->{sent_to} ),
      "<b>$args->{recname}</b>", '<b>' . escapeHTML( $in->{email} ) . '</b>';
    $args->{returnlinkurl} =~ s/ /%20/g;
    if ( $args->{resulttmplpath} ) {
        my %result_vars;
        $result_vars{style} = stylesheet( $args->{styleurl} );
        $result_vars{sent_to} = \$sent_to;
        $result_vars{$_} = \$args->{$_} for @resultargs;
        templateprint($args->{resulttmplpath}, $args->{encoding}, %result_vars);
    } else {
        headprint($args);

        print <<RESULT;
<h1>$args->{thanks}</h1>
<p>$sent_to</p>
<p class="returnlink"><a href="$args->{returnlinkurl}">$args->{returnlinktext}</a></p>
</body>
</html>
RESULT
    }
}

sub formprint {
    my ($args, $in, $error) = @_;
    my $scriptname = basename( $0 or $ENV{SCRIPT_FILENAME} );
    my $erroralert = %$error ? '<p class="erroralert">'
      . sprintf( escapeHTML( $args->{erroralert} ), '<span class="error">'
      . "\n" . escapeHTML( $args->{marked} ) . '</span>' ) . '</p>' : '';
    my @formargs = qw/recname returnlinktext returnlinkurl title namelabel
                      emaillabel subjectlabel msglabel reset send/;
    $args->{$_} = escapeHTML( $args->{$_} ) for @formargs;
    $args->{returnlinkurl} =~ s/ /%20/g;
    $in->{subject} ||= $args->{subject};
    for (qw/name email subject message/) {
        $in->{$_} = $in->{$_} ? escapeHTML( $in->{$_} ) : '';
        $error->{$_} ||= '';
    }

    # Prevent horizontal scrolling in NS4
    my $softwrap = ($ENV{HTTP_USER_AGENT} and $ENV{HTTP_USER_AGENT} =~ /Mozilla\/[34]/
      and $ENV{HTTP_USER_AGENT} !~ /MSIE|Opera/) ? ' wrap="soft"' : '';

    if ( $args->{formtmplpath} ) {
        my %form_vars;
        $form_vars{style} = stylesheet( $args->{styleurl} );
        $form_vars{scriptname} = \$scriptname;
        $form_vars{erroralert} = \$erroralert;
        $form_vars{$_} = \$args->{$_} for @formargs;
        for (qw/name email subject message/) {
            $form_vars{$_} = \$in->{$_};
            $form_vars{$_.'error'} = \$error->{$_};
        }
        $form_vars{softwrap} = \$softwrap;
        templateprint($args->{formtmplpath}, $args->{encoding}, %form_vars);
    } else {
        headprint($args);

        print <<FORM;
<form action="$scriptname" method="post">
<table cellpadding="3">
<tr>
<td colspan="4"><h1 class="halign">$args->{title} $args->{recname}</h1></td>
</tr><tr>
<td><p$error->{name}>$args->{namelabel}</p></td><td><input type="text" name="name"
 value="$in->{name}" size="20" />&nbsp;</td>
<td><p$error->{email}>$args->{emaillabel}</p></td><td><input type="text" name="email"
 value="$in->{email}" size="20" /></td>
</tr><tr>
<td><p$error->{subject}>$args->{subjectlabel}</p></td>
<td colspan="3"><input type="text" name="subject" value="$in->{subject}" size="55" /></td>
</tr><tr>
<td colspan="4"><p$error->{message}>$args->{msglabel}</p></td>
</tr><tr>
<td colspan="4">
<textarea name="message" rows="8" cols="65"$softwrap>$in->{message}</textarea>
</td>
</tr><tr>
<td colspan="4" class="halign">
$erroralert
<input class="button" type="reset" value="$args->{reset}" />&nbsp;&nbsp;
<input class="button" type="submit" value="$args->{send}" /></td>
</tr><tr>
<td colspan="4"><p class="returnlink"><a href="$args->{returnlinkurl}">
$args->{returnlinktext}</a></p></td>
</tr>
</table>
</form>
</body>
</html>
FORM
    }
}

sub headprint {
    my $args = shift;
    print "Content-type: text/html; charset=$args->{encoding}\n\n";
    print <<HEAD;
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
                      "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<title>$args->{title} $args->{recname}</title>
<style type="text/css">
.error { font-weight: bold }
</style>
${ stylesheet( $args->{styleurl} ) }
</head>
<body>
HEAD
}

sub stylesheet {
    my $url = shift || return \'';
    $url =~ s/ /%20/g;
    \('<link rel="stylesheet" type="text/css" href="' . $url . '" />');
}

sub templateprint {
    my ($template, $encode, %tmpl_vars) = @_;
    my $error;
    open FH, "< $template" or die "Can't open $template\n$!";
    my $output = do { local $/; <FH> };
    close FH;
    $output =~ s[<(?:!--\s*)?tmpl_var\s*(?:name\s*=\s*)?
                                  (?:"([^">]*)"|'([^'>]*)'|([^\s=>]*))
                                  \s*(?:--)?>][
                if ( $tmpl_vars{lc $+} ) {
                        ${ $tmpl_vars{lc $+} };
                } else {
                        $error .= "Unknown template variable: '$+'\n";
                }
        ]egix;
    CFdie("<pre>$error") if $error;
    print "Content-type: text/html; charset=$encode\n\n";
    print $output;
}

sub namefix {
    my $name = $_[0];
    if ($name =~ /[[:^ascii:]]/) {
        return &mimeencode;
    }
    if ($name =~ /[^ \w]/) {
        $name =~ tr/"/'/;
        $name = qq{"$name"};
    }
    $name;
}

sub mimeencode {
    my ($str, $enc) = @_;
    return $str unless $str =~ /[[:^ascii:]]/;
    my @parts;
    while ( $str =~ /(.{1,40}.*?(?:\s|$))/g ) {
        my $part = $1;
        push @parts, MIME::QuotedPrint::encode($part, '');
    }
    join "\r\n\t", map { "=?$enc?Q?$_?=" } @parts;
}

sub reformat {
# This subroutine was initially copied from Text::Flowed v0.14, written by
# Philip Mak. It has undergone a couple of changes since.

    # Help functions in Text::Flowed nested into this copy of reformat()
    sub _num_quotes { $_[0] =~ /^(>*)/; length $1 }
    sub _unquote { my $line = shift; $line =~ s/^(>+)//g; $line }
    sub _flowed {
        my $line = shift;
        # Lines with only spaces in them are not considered flowed
        # (heuristic to recover from sloppy user input)
        return 0 if $line =~ /^ *$/;
        $line =~ / $/;
    }
    sub _trim { local *_ = \shift; s/ +$//g; $_ }
    sub _stuff {
        my ($text, $num_quotes) = @_;
        if ($text =~ /^ / || $text =~ /^>/ || $text =~ /^From / || $num_quotes > 0) {
            return " $text";
        }
        $text;
    }
    sub _unstuff { local *_ = \shift; s/^ //; $_ }

    my @input = split "\n", $_[0];
    my $args = $_[1];
    $args->{max_length} ||= 79;
    $args->{opt_length} ||= 72;
    my @output = ();

    # Process message line by line
    while (@input) {
        # Count and strip quote levels
        my $line = shift @input;
        my $num_quotes = _num_quotes($line);
        $line = _unquote($line);

        # Should we interpret this line as flowed?
        if ( !$args->{fixed} || ( $args->{fixed} == 1 && $num_quotes ) ) {
            $line = _unstuff($line);
            # While line is flowed, and there is a next line, and the
            # next line has the same quote depth
            while (_flowed($line) && @input && _num_quotes($input[0]) == $num_quotes) {
                # Join the next line
                $line .= _unstuff(_unquote(shift @input));
            }
        }
        # Ensure line is fixed, since we joined all flowed lines
        $line = _trim($line);

        # Increment quote depth if we're quoting
        $num_quotes++ if $args->{quote};

        if ( !( defined $line and length $line ) ) {
            # Line is empty
            push @output, '>' x $num_quotes;
        } elsif (length($line) + $num_quotes <= $args->{max_length} - 1) {
            # Line does not require rewrapping
            push @output, '>' x $num_quotes . _stuff($line, $num_quotes);
        } else {
            # Rewrap this paragraph
            while ( defined $line and length $line ) {
                # Stuff and re-quote the line
                $line = '>' x $num_quotes . _stuff($line, $num_quotes);

                # Set variables used in regexps
                my $min = $num_quotes + 1;
                my $opt1 = $args->{opt_length} - 1;
                my $max1 = $args->{max_length} - 1;
                if ( length($line) <= $args->{opt_length} ) {
                    # Remaining section of line is short enough
                    push @output, $line;
                    last;
                } elsif ( $line =~ /^(.{$min,$opt1}) (.*)/ ||
                  $line =~ /^(.{$min,$max1}) (.*)/ || $line =~ /^(.{$min,}) (.*)/ ) {
                    # 1. Try to find a string as long as opt_length.
                    # 2. Try to find a string as long as max_length.
                    # 3. Take the first word.
                    push @output, "$1 ";
                    $line = $2;
                } else {
                    # One excessively long word left on line
                    push @output, $line;
                    last;
                }
            }
        }
    }

    join("\n", @output)."\n";
}

sub checktimestamp {
    my ($tempdir, $time) = @_;
    $tempdir ||= $CGITempFile::TMPDIRECTORY;
    my $cookie;
    unless ( $ENV{HTTP_COOKIE} and ($cookie) = $ENV{HTTP_COOKIE} =~ /\bContactForm_time=(\d+)/ ) {
        CFdie("Your browser is set to refuse cookies.<br>\n"
          . "Change that setting to accept at least session cookies, and try again.\n");
    }
    open FH, File::Spec->catfile( $tempdir, 'ContactForm_time' )
      or die "Couldn't open timestamp file: $!";
    chomp( my @timestamps = <FH> );
    close FH or die $!;
    if ( $cookie + 7200 < $time or ! grep $cookie eq $_, @timestamps ) {
        settimestamp($tempdir, $time);
        CFdie("Timeout due to more than an hour of inactivity.\n"
          . '<p><a href="javascript:history.back(1)">Go back one page</a> and try again.');
    }
}

sub settimestamp {
    my ($tempdir, $time) = @_;
    $tempdir ||= $CGITempFile::TMPDIRECTORY;

    sysopen FH, File::Spec->catfile( $tempdir, 'ContactForm_time' ), O_RDWR|O_CREAT
      or die "Couldn't open timestamp file: $!";
    flock FH, LOCK_EX or die $!;
    chomp( my @timestamps = <FH> );
    sysseek FH, 0, 0 or die $!;
    if ( @timestamps == 2 && $time > $timestamps[0] + 3600 or @timestamps == 1 ) {
        truncate FH, 0 or die $!;
        print FH join( "\n", $time, $timestamps[0] ), "\n";
        print "Set-cookie: ContactForm_time=$time\n";
    } elsif ( @timestamps == 0 ) {
        truncate FH, 0 or die $!;
        print FH "$time\n";
        print "Set-cookie: ContactForm_time=$time\n";
    } else {
        print "Set-cookie: ContactForm_time=$timestamps[0]\n";
    }
    close FH or die $!;
}

sub checkspamfilter {
    my ($msg, $filter) = @_;
    if ( $filter and $msg =~ /$filter/ ) {
        CFdie("The message was trapped in a spam filter and not sent.\n"
          . "You may want to try again with a modified message body.\n"
          . '<p><a href="javascript:history.back(1)">Back</a>');
    }
}

sub checkmaxperhour {
    my ($args, $time, $host) = @_;
    my $tempdir = $args->{tempdir} || $CGITempFile::TMPDIRECTORY;
    my (@senders, %senders);

    sysopen FH, File::Spec->catfile( $tempdir, 'ContactForm_sent' ), O_RDWR|O_CREAT
      or die "Couldn't open request file: $!";
    flock FH, LOCK_EX or die $!;
    while ( <FH> ) {
        my ($timestamp, $ip) = /^(\d+)\t(.+)/;
        next if $timestamp < $time - 3600;
        push @senders, $_;
        $senders{$ip}++;
    }
    push @senders, "$time\t$host\n";
    $senders{$host}++;
    seek FH, 0, 0 or die $!;
    truncate FH, 0 or die $!;
    print FH @senders;
    close FH or die $!;

    if ( $senders{$host} > $args->{maxperhour} ) {
        CFdie('Too many send attempts from the same host. You may want to try later.');
    }
}

1;