Perl Formail issue: $mailprog Flags change in NMS Formail

  • metalfury
  • Newbie
  • Newbie
  • User avatar
  • Posts: 6

Post 3+ Months Ago

Hello, hope someone can help as I've been tearing my hair out with this one.

I've been using Matts Script Archive Formail for many years without any problem and have always been able to make tweaks to code using the 'ReadMe' file and a bit of search engine work, however I'm drawing a blank on a particular issue and I have a very limited understanding of Perl!

A new site I'm producing is being hosted on a server that asks for the following:

Quote:
Within the script, the mail program used for sending mail is /usr/lib/sendmail . You should not use this with the -t argument (which find the From and To in the email) but use -f 'from-email-address' 'to-email-address' in place of the -t argument.


So I have upgraded to the NMS Formail script for the debugging and extra features and I have spent the evening trying to get it to work with the -f flag/argument

I've removed my previously trusted "-oi -t" and tweaked it as follows:

Code: [ Select ]
$mailprog = '/usr/lib/sendmail -f emailaddress1 emailaddress2';


I'm not able to include actual email addresses in my forum posts so I have replaced them with "emailaddress1/2"

This 'kind of' works, in that it sends a message from emailaddress1 to emailaddress2 (believe me this took me ages to work out!)

However I obviously need to replace the 'emailaddress1/2' for the actual sender and recipient, and this is where I get stuck!

My assumption is that I just need to replace the 'emailaddress' with variables defined in the formail script, but I'm afraid I don't understand enough to work this out and all my attempts so far have failed!

I'd hoped something like this would work:

Code: [ Select ]
$mailprog = '/usr/lib/sendmail -f $from $to';


..but nope :-(

If anyone can advise I would be *very* grateful.

Metalfury

PS I can paste in the code from the NMS Formail Script if you're not familiar with it?
  • Anonymous
  • Bot
  • No Avatar
  • Posts: ?
  • Loc: Ozzuland
  • Status: Online

Post 3+ Months Ago

  • metalfury
  • Newbie
  • Newbie
  • User avatar
  • Posts: 6

Post 3+ Months Ago

Here's the NMS Formail code (I've had to edit it quite a lot to remove any external links:

Code: [ Select ]
#!/usr/bin/perl -wT
##############################################################################
# nms Formmail             Version 3.14c1            #
# Copyright 2001 London Perl Mongers  All rights reserved          #
# Created 11/11/01           Last Modified 08/11/04        #
# Matt's Script Archive:           #
##############################################################################

##############################################################################
#
# NMS FormMail Version 3.14c1
#

use strict;
use vars qw(
 $DEBUGGING $emulate_matts_code $secure %more_config
 $allow_empty_ref $max_recipients $mailprog @referers
 @allow_mail_to @recipients %recipient_alias
 @valid_ENV $date_fmt $style $send_confirmation_mail
 $confirmation_text $locale $charset $no_content
 $double_spacing $wrap_text $wrap_style $postmaster
 $address_style
);

# PROGRAM INFORMATION
# -------------------
# FormMailVersion 3.14c1
#
# This program is licensed in the same way as Perl
# itself. You are free to choose between the GNU Public
# License  or
# the Artistic License
#
#
# For help on configuration or installation see the
# README file or the POD documentation at the end of
# this file.

# USER CONFIGURATION SECTION
# --------------------------
# Modify these to your own settings. You might have to
# contact your system administrator if you do not run
# your own web server. If the purpose of these
# parameters seems unclear, please see the README file.
#
BEGIN
{
 $DEBUGGING     = 1;
 $emulate_matts_code= 0;
 $secure      = 1;
 $allow_empty_ref  = 1;
 $max_recipients  = 5;
 $mailprog     = '/usr/lib/sendmail -oi -t';
 $postmaster    = '';
 @referers     = qw(dave dot org dot uk 209.207.222.64 localhost);
 @allow_mail_to   = qw(you@your.domain some.one.else@your.domain localhost);
 @recipients    = ();
 %recipient_alias  = ();
 @valid_ENV     = qw(REMOTE_HOST REMOTE_ADDR REMOTE_USER HTTP_USER_AGENT);
 $locale      = '';
 $charset      = 'iso-8859-1';
 $date_fmt     = '%A, %B %d, %Y at %H:%M:%S';
 $style       = '/css/nms.css';
 $no_content    = 0;
 $double_spacing  = 1;
 $wrap_text     = 0;
 $wrap_style    = 1;
 $address_style   = 0;
 $send_confirmation_mail = 0;
 $confirmation_text = <<'END_OF_CONFIRMATION';
From: you(at)your(dot)com
Subject: form submission

Thank you for your form submission.

END_OF_CONFIRMATION

# You may need to uncomment the line below and adjust the path.
# use lib './lib';

# USER CUSTOMISATION SECTION
# --------------------------
# Place any custom code here



# USER CUSTOMISATION << END >>
# ----------------------------
# (no user serviceable parts beyond here)
}

#
# The code below consists of module source inlined into this
# script to make it a standalone CGI.
#
#
BEGIN {


$CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer = <<'END_INLINED_CGI_NMS_Mailer';
package CGI::NMS::Mailer;
use strict;

use POSIX qw(strftime);

=head1 NAME

CGI::NMS::Mailer - email sender base class

=head1 SYNOPSYS

 use base qw(CGI::NMS::Mailer);

 ...

=head1 DESCRIPTION

This is a base class for classes implementing low-level email
sending objects for use within CGI scripts.

=head1 METHODS

=over

=item output_trace_headers ( TRACEINFO )

Uses the print() virtual method to output email abuse tracing headers
including whatever useful information can be gleaned from the CGI
environment variables.

The TRACEINFO parameter should be a short string giving the name and
version of the CGI script.

=cut

sub output_trace_headers {
 my ($self, $traceinfo) = @_;

 $ENV{REMOTE_ADDR} =~ /^\[?([\d\.\:a-f]{7,100})\]?$/i or die
   "failed to get remote address from [$ENV{REMOTE_ADDR}], so can't send traceable email";
 $self->print("Received: from [$1]\n");

 my $me = ($ENV{SERVER_NAME} =~ /^([\w\-\.]{1,100})$/ ? $1 : 'unknown');
 $self->print("\tby $me ($traceinfo)\n");

 my $date = strftime '%a, %e %b %Y %H:%M:%S GMT', gmtime;
 $self->print("\twith HTTP; $date\n");

 if ($ENV{SCRIPT_NAME} =~ /^([\w\-\.\/]{1,100})$/) {
  $self->print("\t(script-name $1)\n");
 }

 if (defined $ENV{HTTP_HOST} and $ENV{HTTP_HOST} =~ /^([\w\-\.]{1,100})$/) {
  $self->print("\t(http-host $1)\n");
 }

 my $ff = $ENV{HTTP_X_FORWARDED_FOR};
 if (defined $ff) {
  $ff =~ /^\s*([\w\-\.\[\] ,]{1,200})\s*/ or die
   "malformed X-Forwarded-For [$ff], suspect attack, aborting";

  $self->print("\t(http-x-forwarded-for $1)\n");
 }

 my $ref = $ENV{HTTP_REFERER};
 if (defined $ref and $ref =~ /^([\w\-\.\/\:\;\%\@\#\~\=\+\?]{1,100})$/) {
  $self->print("\t(http-referer $1)\n");
 }
}

=back

=head1 VIRTUAL METHODS

Subclasses must implement the following methods:

=over

=item newmail ( TRACEINFO, SENDER, @RECIPIENTS )

Starts a new email. TRACEINFO is the script name and version, SENDER is
the email address to use as the envelope sender and @RECIPIENTS is a list
of recipients. Dies on error.

=item print ( @ARGS )

Concatenates the arguments and appends them to the email. Both the
header and the body should be sent in this way, separated by a single
blank line. Dies on error.

=item endmail ()

Finishes the email, flushing buffers and sending it. Dies on error.

=back

=head1 SEE ALSO

L<CGI::NMS::Mailer::Sendmail>, L<CGI::NMS::Mailer::SMTP>,
L<CGI::NMS::Script>

=head1 MAINTAINERS

The NMS project, E<

To request support or report bugs, please email
E<lt>nms-cgi-support@lists.sourceforge dot netE<gt>

=head1 COPYRIGHT

Copyright 2003 London Perl Mongers, All rights reserved

=head1 LICENSE

This module is free software; you are free to redistribute it
and/or modify it under the same terms as Perl itself.

=cut

1;


END_INLINED_CGI_NMS_Mailer


$CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer_SMTP = <<'END_INLINED_CGI_NMS_Mailer_SMTP';
package CGI::NMS::Mailer::SMTP;
use strict;

use IO::Socket;
BEGIN {
do {
 unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Mailer}) {
  eval $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer or die $@;
  $INC{'CGI/NMS/Mailer.pm'} = 1;
 }
 undef $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer; # to save memory
};

import CGI::NMS::Mailer }
use base qw(CGI::NMS::Mailer);

=head1 NAME

CGI::NMS::Mailer::SMTP - mail sender using SMTP

=head1 SYNOPSYS

 my $mailer = CGI::NMS::Mailer::SMTP->new('mailhost.bigisp dot net');

 $mailer->newmail($from, $to);
 $mailer->print($email_header_and_body);
 $mailer->endmail;

=head1 DESCRIPTION

This implementation of the mailer object defined in L<CGI::NMS::Mailer>
uses an SMTP connection to a mail relay to send the email.

=head1 CONSTRUCTORS

=over

=item new ( MAILHOST )

MAILHOST must be the name or dotted decimal IP address of an SMTP
server that will relay mail for the web server.

=cut

sub new {
 my ($pkg, $mailhost) = @_;

 $mailhost .= ':25' unless $mailhost =~ /:/;
 return bless { Mailhost => $mailhost }, $pkg;
}

=back

=head1 METHODS

See L<CGI::NMS::Mailer> for the user interface to these methods.

=over

=item newmail ( SCRIPTNAME, SENDER, @RECIPIENTS )

Opens the SMTP connection and sends trace headers.

=cut

sub newmail {
 my ($self, $scriptname, $sender, @recipients) = @_;

 $self->{Sock} = IO::Socket::INET->new($self->{Mailhost});
 defined $self->{Sock} or die "connect to [$self->{Mailhost}]: $!";

 my $banner = $self->_smtp_response;
 $banner =~ /^2/ or die "bad SMTP banner [$banner] from [$self->{Mailhost}]";

 my $helohost = ($ENV{SERVER_NAME} =~ /^([\w\-\.]+)$/ ? $1 : '.');
 $self->_smtp_command("HELO $helohost");
 $self->_smtp_command("MAIL FROM:<$sender>");
 foreach my $r (@recipients) {
  $self->_smtp_command("RCPT TO:<$r>");
 }
 $self->_smtp_command("DATA", '3');

 $self->output_trace_headers($scriptname);
}

=item print ( @ARGS )

Writes some email body to the SMTP socket.

=cut

sub print {
 my ($self, @args) = @_;

 my $text = join '', @args;
 $text =~ s#\n#\015\012#g;
 $text =~ s#^\.#..#mg;

 $self->{Sock}->print($text) or die "write to SMTP socket: $!";
}

=item endmail ()

Finishes sending the mail and closes the SMTP connection.

=cut

sub endmail {
 my ($self) = @_;

 $self->_smtp_command(".");
 $self->_smtp_command("QUIT");
 delete $self->{Sock};
}

=back

=head1 PRIVATE METHODS

These methods should be called from within this module only.

=over

=item _smtp_getline ()

Reads a line from the SMTP socket, and returns it as a string,
including the terminating newline sequence.

=cut

sub _smtp_getline {
 my ($self) = @_;

 my $sock = $self->{Sock};
 my $line = <$sock>;
 defined $line or die "read from SMTP server: $!";

 return $line;
}

=item _smtp_response ()

Reads a command response from the SMTP socket, and returns it as
a single string. A multiline responses is returned as a multiline
string, and the terminating newline sequence is always included.

=cut

sub _smtp_response {
 my ($self) = @_;

 my $line = $self->_smtp_getline;
 my $resp = $line;
 while ($line =~ /^\d\d\d\-/) {
  $line = $self->_smtp_getline;
  $resp .= $line;
 }
 return $resp;
}

=item _smtp_command ( COMMAND [,EXPECT] )

Sends the SMTP command COMMAND to the SMTP server, and reads a line
in response. Dies unless the first character of the response is
the character EXPECT, which defaults to '2'.

=cut

sub _smtp_command {
 my ($self, $command, $expect) = @_;
 defined $expect or $expect = '2';

 $self->{Sock}->print("$command\015\012") or die
  "write [$command] to SMTP server: $!";
 
 my $resp = $self->_smtp_response;
 unless (substr($resp, 0, 1) eq $expect) {
  die "SMTP command [$command] gave response [$resp]";
 }
}

=back

=head1 MAINTAINERS

The NMS project, E<lt><gt>

To request support or report bugs, please email
E<lt>nms-cgi-support@lists.sourceforge(dot)netE<gt>

=head1 COPYRIGHT

Copyright 2003 London Perl Mongers, All rights reserved

=head1 LICENSE

This module is free software; you are free to redistribute it
and/or modify it under the same terms as Perl itself.

=cut

1;
 

END_INLINED_CGI_NMS_Mailer_SMTP


$CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer_Sendmail = <<'END_INLINED_CGI_NMS_Mailer_Sendmail';
package CGI::NMS::Mailer::Sendmail;
use strict;

use IO::File;
BEGIN {
do {
 unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Mailer}) {
  eval $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer or die $@;
  $INC{'CGI/NMS/Mailer.pm'} = 1;
 }
 undef $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer; # to save memory
};

import CGI::NMS::Mailer }
use base qw(CGI::NMS::Mailer);

=head1 NAME

CGI::NMS::Mailer::Sendmail - mail sender using sendmail

=head1 SYNOPSYS

 my $mailer = CGI::NMS::Mailer::Sendmail->new('/usr/lib/sendmail -oi -t');

 $mailer->newmail($from, $to);
 $mailer->print($email_header_and_body);
 $mailer->endmail;

=head1 DESCRIPTION

This implementation of the mailer object defined in L<CGI::NMS::Mailer>
uses a piped open to the UNIX sendmail program to send the email.

=head1 CONSTRUCTORS

=over

=item new ( MAILPROG )

MAILPROG must be the shell command to which a pipe is opened, including
all nessessary switches to cause the sendmail program to read the email
recipients from the header of the email.

=cut

sub new {
 my ($pkg, $mailprog) = @_;

 return bless { Mailprog => $mailprog }, $pkg;
}

=back

=head1 METHODS

See L<CGI::NMS::Mailer> for the user interface to these methods.

=over

=item newmail ( SCRIPTNAME, POSTMASTER, @RECIPIENTS )

Opens the sendmail pipe and outputs trace headers.

=cut

sub newmail {
 my ($self, $scriptname, $postmaster, @recipients) = @_;

 my $command = $self->{Mailprog};
 $command .= qq{ -f "$postmaster"} if $postmaster;
 my $pipe;
 eval { local $SIG{__DIE__};
     $pipe = IO::File->new("| $command");
    };
 if ($@) {
  die $@ unless $@ =~ /Insecure directory/;
  delete $ENV{PATH};
  $pipe = IO::File->new("| $command");
 }

 die "Can't open mailprog [$command]\n" unless $pipe;
 $self->{Pipe} = $pipe;

 $self->output_trace_headers($scriptname);
}

=item print ( @ARGS )

Writes some email body to the sendmail pipe.

=cut

sub print {
 my ($self, @args) = @_;

 $self->{Pipe}->print(@args) or die "write to sendmail pipe: $!";
}

=item endmail ()

Closes the sendmail pipe.

=cut

sub endmail {
 my ($self) = @_;

 $self->{Pipe}->close or die "close sendmail pipe failed, mailprog=[$self->{Mailprog}]";
 delete $self->{Pipe};
}

=back

=head1 MAINTAINERS

The NMS project, E<lt><gt>

To request support or report bugs, please email
E<lt>nms-cgi-support@lists.sourceforge(dot)netE<gt>

=head1 COPYRIGHT

Copyright 2003 London Perl Mongers, All rights reserved

=head1 LICENSE

This module is free software; you are free to redistribute it
and/or modify it under the same terms as Perl itself.

=cut

1;
 

END_INLINED_CGI_NMS_Mailer_Sendmail


unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Charset}) {
 eval <<'END_INLINED_CGI_NMS_Charset' or die $@;
package CGI::NMS::Charset;
use strict;

require 5.00404;

use vars qw($VERSION);
$VERSION = sprintf '%d.%.2d', (q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/);

=head1 NAME

CGI::NMS::Charset - a charset-aware object for handling text strings

=head1 SYNOPSIS

 my $cs = CGI::NMS::Charset->new('iso-8859-1');

 my $safe_to_put_in_html = $cs->escape($untrusted_user_input);

 my $printable = &{ $cs->strip_nonprint_coderef }( $input );
 my $escaped = &{ $cs->escape_html_coderef }( $printable );

=head1 DESCRIPTION

Each object of class C<CGI::NMS::Charset> is bound to a particular
character set when it is created. The object provides methods to
generate coderefs to perform a couple of character set dependent
operations on text strings.

=cut

=head1 CONSTRUCTORS

=over

=item new ( CHARSET )

Creates a new C<CGI::NMS::Charset> object, suitable for handing text
in the character set CHARSET. The CHARSET parameter must be a
character set string, such as C<us-ascii> or C<utf-8> for example.

=cut

sub new
{
  my ($pkg, $charset) = @_;

  my $self = { CHARSET => $charset };

  if ($charset =~ /^utf-8$/i)
  {
   $self->{SN} = \&_strip_nonprint_utf8;
   $self->{EH} = \&_escape_html_utf8;
  }
  elsif ($charset =~ /^iso-8859/i)
  {
   $self->{SN} = \&_strip_nonprint_8859;
   if ($charset =~ /^iso-8859-1$/i)
   {
     $self->{EH} = \&_escape_html_8859_1;
   }
   else
   {
     $self->{EH} = \&_escape_html_8859;
   }
  }
  elsif ($charset =~ /^us-ascii$/i)
  {
   $self->{SN} = \&_strip_nonprint_ascii;
   $self->{EH} = \&_escape_html_8859_1;
  }
  else
  {
   $self->{SN} = \&_strip_nonprint_weak;
   $self->{EH} = \&_escape_html_weak;
  }

  return bless $self, $pkg;
}

=back

=head1 METHODS

=over

=item charset ()

Returns the CHARSET string that was passed to the constructor.

=cut

sub charset
{
  my ($self) = @_;

  return $self->{CHARSET};
}

=item escape ( STRING )

Returns a copy of STRING with runs of non-printable characters
replaced with spaces and HTML metacharacters replaced with the
equivalent entities.

If STRING is undef then the empty string will be returned.

=cut

sub escape
{
  my ($self, $string) = @_;

  return &{ $self->{EH} }( &{ $self->{SN} }($string) );
}

=item strip_nonprint_coderef ()

Returns a reference to a sub to replace runs of non-printable
characters with spaces, in a manner suited to the charset in
use.

The returned coderef points to a sub that takes a single readonly
string argument and returns a modified version of the string. If
undef is passed to the function then the empty string will be
returned.

=cut

sub strip_nonprint_coderef
{
  my ($self) = @_;

  return $self->{SN};
}

=item escape_html_coderef ()

Returns a reference to a sub to escape HTML metacharacters in
a manner suited to the charset in use.

The returned coderef points to a sub that takes a single readonly
string argument and returns a modified version of the string.

=cut

sub escape_html_coderef
{
  my ($self) = @_;

  return $self->{EH};
}

=back

=head1 DATA TABLES

=over

=item C<%eschtml_map>

The C<%eschtml_map> hash maps C<iso-8859-1> characters to the
equivalent HTML entities.

=cut

use vars qw(%eschtml_map);
%eschtml_map = (
         ( map {chr($_) => "&#$_;"} (0..255) ),
         '<' => '&lt;',
         '>' => '&gt;',
         '&' => '&amp;',
         '"' => '&quot;',
        );

=back

=head1 PRIVATE FUNCTIONS

These functions are returned by the strip_nonprint_coderef() and
escape_html_coderef() methods and invoked by the escape() method.
The function most appropriate to the character set in use will be
chosen.

=over

=item _strip_nonprint_utf8

Returns a copy of STRING with everything but printable C<us-ascii>
characters and valid C<utf-8> multibyte sequences replaced with
space characters.

=cut

sub _strip_nonprint_utf8
{
  my ($string) = @_;
  return '' unless defined $string;

  $string =~
  s%
  ( [\t\n\040-\176]        # printable us-ascii
  | [\xC2-\xDF][\x80-\xBF]    # U+00000080 to U+000007FF
  | \xE0[\xA0-\xBF][\x80-\xBF]  # U+00000800 to U+00000FFF
  | [\xE1-\xEF][\x80-\xBF]{2}   # U+00001000 to U+0000FFFF
  | \xF0[\x90-\xBF][\x80-\xBF]{2} # U+00010000 to U+0003FFFF
  | [\xF1-\xF7][\x80-\xBF]{3}   # U+00040000 to U+001FFFFF
  | \xF8[\x88-\xBF][\x80-\xBF]{3} # U+00200000 to U+00FFFFFF
  | [\xF9-\xFB][\x80-\xBF]{4}   # U+01000000 to U+03FFFFFF
  | \xFC[\x84-\xBF][\x80-\xBF]{4} # U+04000000 to U+3FFFFFFF
  | \xFD[\x80-\xBF]{5}      # U+40000000 to U+7FFFFFFF
  ) | .
  %
  defined $1 ? $1 : ' '
  %gexs;

  #
  # U+FFFE, U+FFFF and U+D800 to U+DFFF are dangerous and
  # should be treated as invalid combinations, according to
  #
  #
  $string =~ s%\xEF\xBF[\xBE-\xBF]% %g;
  $string =~ s%\xED[\xA0-\xBF][\x80-\xBF]% %g;

  return $string;
}

=item _escape_html_utf8 ( STRING )

Returns a copy of STRING with any HTML metacharacters
escaped. Escapes all but the most commonly occurring C<us-ascii>
characters and bytes that might form part of valid C<utf-8>
multibyte sequences.

=cut

sub _escape_html_utf8
{
  my ($string) = @_;

  $string =~ s|([^\w \t\r\n\-\.\,\x80-\xFD])| $eschtml_map{$1} |ge;
  return $string;
}

=item _strip_nonprint_weak ( STRING )

Returns a copy of STRING with sequences of NULL characters
replaced with space characters.

=cut

sub _strip_nonprint_weak
{
  my ($string) = @_;
  return '' unless defined $string;

  $string =~ s/\0+/ /g;
  return $string;
}
 
=item _escape_html_weak ( STRING )

Returns a copy of STRING with any HTML metacharacters escaped.
In order to work in any charset, escapes only E<lt>, E<gt>, C<">
and C<&> characters.

=cut

sub _escape_html_weak
{
  my ($string) = @_;

  $string =~ s/[<>"&]/$eschtml_map{$1}/eg;
  return $string;
}

=item _escape_html_8859_1 ( STRING )

Returns a copy of STRING with all but the most commonly
occurring printable characters replaced with HTML entities.
Only suitable for C<us-ascii> or C<iso-8859-1> input.

=cut

sub _escape_html_8859_1
{
  my ($string) = @_;

  $string =~ s|([^\w \t\r\n\-\.\,\/\:])| $eschtml_map{$1} |ge;
  return $string;
}

=item _escape_html_8859 ( STRING )

Returns a copy of STRING with all but the most commonly
occurring printable C<us-ascii> characters and characters
that might be printable in some C<iso-8859-*> charset
replaced with HTML entities.

=cut

sub _escape_html_8859
{
  my ($string) = @_;

  $string =~ s|([^\w \t\r\n\-\.\,\/\:\240-\377])| $eschtml_map{$1} |ge;
  return $string;
}

=item _strip_nonprint_8859 ( STRING )

Returns a copy of STRING with runs of characters that are not
printable in any C<iso-8859-*> charset replaced with spaces.

=cut

sub _strip_nonprint_8859
{
  my ($string) = @_;
  return '' unless defined $string;

  $string =~ tr#\t\n\040-\176\240-\377# #cs;
  return $string;
}

=item _strip_nonprint_ascii ( STRING )

Returns a copy of STRING with runs of characters that are not
printable C<us-ascii> replaced with spaces.

=cut

sub _strip_nonprint_ascii
{
  my ($string) = @_;
  return '' unless defined $string;

  $string =~ tr#\t\n\040-\176# #cs;
  return $string;
}

=back

=head1 MAINTAINERS

The NMS project, E<lt>/E<gt>

To request support or report bugs, please email
E<lt>nms-cgi-support@lists.sourceforge(dot)netE<gt>

=head1 COPYRIGHT

Copyright 2002-2003 London Perl Mongers, All rights reserved

=head1 LICENSE

This module is free software; you are free to redistribute it
and/or modify it under the same terms as Perl itself.

=cut

1;


END_INLINED_CGI_NMS_Charset
 $INC{'CGI/NMS/Charset.pm'} = 1;
}


unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Mailer::ByScheme}) {
 eval <<'END_INLINED_CGI_NMS_Mailer_ByScheme' or die $@;
package CGI::NMS::Mailer::ByScheme;
use strict;

=head1 NAME

CGI::NMS::Mailer::ByScheme - mail sending engine switch

=head1 SYNOPSYS

 my $mailer = CGI::NMS::Mailer::ByScheme->new('/usr/lib/sendmail -oi -t');

 my $mailer = CGI::NMS::Mailer::ByScheme->new('SMTP:mailhost.bigisp(dot)net');

=head1 DESCRIPTION

This implementation of the mailer object defined in L<CGI::NMS::Mailer>
chooses between L<CGI::NMS::Mailer::SMTP> and L<CGI::NMS::Mailer::Sendmail>
based on the string passed to new().

=head1 CONSTRUCTORS

=over

=item new ( ARGUMENT )

ARGUMENT must either be the string C<SMTP:> followed by the name or
dotted decimal IP address of an SMTP server that will relay mail
for the web server, or the path to a sendmail compatible binary,
including switches.

=cut

sub new {
 my ($pkg, $argument) = @_;

 if ($argument =~ /^SMTP:([\w\-\.]+(:\d+)?)/i) {
  my $mailhost = $1;
  
do {
 unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Mailer::SMTP}) {
  eval $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer_SMTP or die $@;
  $INC{'CGI/NMS/Mailer/SMTP.pm'} = 1;
 }
 undef $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer_SMTP; # to save memory
};


  return CGI::NMS::Mailer::SMTP->new($mailhost);
 }
 else {
  
do {
 unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Mailer::Sendmail}) {
  eval $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer_Sendmail or die $@;
  $INC{'CGI/NMS/Mailer/Sendmail.pm'} = 1;
 }
 undef $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer_Sendmail; # to save memory
};


  return CGI::NMS::Mailer::Sendmail->new($argument);
 }
}

=back

=head1 MAINTAINERS

The NMS project, E<lt>/E<gt>

To request support or report bugs, please email
E<lt>nms-cgi-support@lists.sourceforge(dot)netE<gt>

=head1 COPYRIGHT

Copyright 2003 London Perl Mongers, All rights reserved

=head1 LICENSE

This module is free software; you are free to redistribute it
and/or modify it under the same terms as Perl itself.

=cut

1;
 

END_INLINED_CGI_NMS_Mailer_ByScheme
 $INC{'CGI/NMS/Mailer/ByScheme.pm'} = 1;
}


unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Script}) {
 eval <<'END_INLINED_CGI_NMS_Script' or die $@;
package CGI::NMS::Script;
use strict;

use CGI;
use POSIX qw(locale_h strftime);
use CGI::NMS::Charset;

=head1 NAME

CGI::NMS::Script - base class for NMS script modules

=head1 SYNOPSYS

 use base qw(CGI::NMS::Script);

 ...

=head1 DESCRIPTION

This module is a base class for the C<CGI::NMS::Script::*> modules,
which implement plugin replacements for Matt Wright's Perl CGI
scripts.

=head1 CONSTRUCTORS

=over

=item new ( CONFIG )

Creates a new C<CGI::NMS::Script> object and performs compile time
initialisation.

CONFIG is a key,value,key,value list, which will be stored as a hash
within the object, under the name C<CFG>.

=cut

sub new {
 my ($pkg, @cfg) = @_;

 my $self = bless {}, $pkg;

 $self->{CFG} = {
  DEBUGGING      => 0,
  emulate_matts_code => 0,
  secure       => 1,
  locale       => '',
  charset       => 'iso-8859-1',
  style        => '',
  cgi_post_max    => 1000000,
  cgi_disable_uploads => 1,

  $self->default_configuration,

  @cfg
 };

 $self->{Charset} = CGI::NMS::Charset->new( $self->{CFG}{charset} );

 $self->init;

 return $self;
}

=back

=item CONFIGURATION SETTINGS

Values for the following configuration settings can be passed to new().

Subclasses for different NMS scripts will define their own set of
configuration settings, but they all inherit these as well.

=over

=item C<DEBUGGING>

If this is set to a true value, then the error message will be displayed
in the browser if the script suffers a fatal error. This should be set
to 0 once the script is in service, since error messages may contain
sensitive information such as file paths which could be useful to
attackers.

Default: 0

=item C<name_and_version>

The name and version of the NMS script, as a single string.

=item C<emulate_matts_code>

When this variable is set to a true value (e.g. 1) the script will work
in exactly the same way as its counterpart at Matt's Script Archive. If
it is set to a false value (e.g. 0) then more advanced features and
security checks are switched on. We do not recommend changing this
variable to 1, as the resulting drop in security may leave your script
open to abuse.

Default: 0

=item C<secure>

When this variable is set to a true value (e.g. 1) many additional
security features are turned on. We do not recommend changing this
variable to 0, as the resulting drop in security may leave your script
open to abuse.

Default: 1

=item C<locale>

This determines the language that is used in the format_date() method -
by default this is blank and the language will probably be English.

Default: ''

=item C<charset>

The character set to use for output documents.

Default: 'iso-8859-1'

=item C<style>

This is the URL of a CSS stylesheet which will be used for script
generated messages. This should probably be the same as the one that
you use for all the other pages. This should be a local absolute URI
fragment. Set C<style> to 0 or the empty string if you don't want to
use style sheets.

Default: '';

=item C<cgi_post_max>

The variable C<$CGI::POST_MAX> is gets set to this value before the
request is handled.

Default: 1000000

=item C<cgi_disable_uploads>

The variable C<CGI::DISABLE_UPLOADS> gets set to this value before
the request is handled.

Default: 1

=item C<no_xml_doc_header>

If this is set to a true value then the output_cgi_html_header() method
will omit the XML document header that it would normally output. This
means that the output document will not be strictly valid XHTML, but it
may work better in some older browsers.

Default: not set

=item C<no_doctype_doc_header>

If this is set to a true value then the output_cgi_html_header() method
will omit the DOCTYPE document header that it would normally output.
This means that the output document will not be strictly valid XHTML, but
it may work better in some older browsers.

Default: not set

=item C<no_xmlns_doc_header>

If this is set to a true value then the output_cgi_html_header() method
will omit the C<xmlns> attribute from the opening C<html> tag that it
outputs.

=back

=head1 METHODS

=over

=item request ()

This is the method that the CGI script invokes once for each run of the
CGI. This implementation sets up some things that are common to all NMS
scripts and then invokes the virtual method handle_request() to do the
script specific processing.

=cut

sub request {
 my ($self) = @_;

 local ($CGI::POST_MAX, $CGI::DISABLE_UPLOADS);
 $CGI::POST_MAX    = $self->{CFG}{cgi_post_max};
 $CGI::DISABLE_UPLOADS = $self->{CFG}{cgi_disable_uploads};

 $ENV{PATH} =~ /(.*)/m or die;
 local $ENV{PATH} = $1;
 local $ENV{ENV} = '';

 $self->{CGI} = CGI->new;
 $self->{Done_Header} = 0;

 my $old_locale;
 if ($self->{CFG}{locale}) {
  $old_locale = POSIX::setlocale( LC_TIME );
  POSIX::setlocale( LC_TIME, $self->{CFG}{locale} );
 }

 eval { local $SIG{__DIE__} ; $self->handle_request };
 my $err = $@;

 if ($self->{CFG}{locale}) {
  POSIX::setlocale( LC_TIME, $old_locale );
 }

 if ($err) {
  my $message;
  if ($self->{CFG}{DEBUGGING}) {
   $message = $self->escape_html($err);
  }
  else {
   $message = "See the web server's error log for details";
  }

  $self->output_cgi_html_header;
  print <<END;
<head>
 <title>Error</title>
</head>
<body>
 <h1>Application Error</h1>
 <p>
  An error has occurred in the program
 </p>
 <p>
  $message
 </p>
</body>
</html>
END

  $self->warn($err);
 }
}

=item output_cgi_html_header ()

Prints the CGI content-type header and the standard header lines for
an XHTML document, unless the header has already been output.

=cut

sub output_cgi_html_header {
 my ($self) = @_;

 return if $self->{Done_Header};

 $self->output_cgi_header;

 unless ($self->{CFG}{no_xml_doc_header}) {
  print qq|<?xml version="1.0" encoding="$self->{CFG}{charset}"?>\n|;
 }

 unless ($self->{CFG}{no_doctype_doc_header}) {
  print <<END;
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
  "">
END
 }

 if ($self->{CFG}{no_xmlns_doc_header}) {
  print "<html>\n";
 }
 else {
  print qq|<html xmlns="">\n|;
 }

 $self->{Done_Header} = 1;
}

=item output_cgi_header ()

Outputs the CGI header for an HTML document.

=cut

sub output_cgi_header {
 my ($self) = @_;

 my $charset = $self->{CFG}{charset};
 my $cgi = $self->cgi_object;

 if ($CGI::VERSION >= 2.57) {
  # This is the correct way to set the charset
  print $cgi->header('-type'=>'text/html', '-charset'=>$charset);
 }
 else {
  # However CGI.pm older than version 2.57 doesn't have the
  # -charset option so we cheat:
  print $cgi->header('-type' => "text/html; charset=$charset");
 }
}

=item output_style_element ()

Outputs the C<link rel=stylesheet> header line, if a style sheet URL is
configured.

=cut

sub output_style_element {
 my ($self) = @_;

 if ($self->{CFG}{style}) {
  print qq|<link rel="stylesheet" type="text/css" href="$self->{CFG}{style}" />\n|;
 }
}

=item cgi_object ()

Returns a reference to the C<CGI.pm> object for this request.

=cut

sub cgi_object {
 my ($self) = @_;

  return $self->{CGI};
}

=item param ( ARGS )

Invokes the param() method of the C<CGI.pm> object for this request.

=cut

sub param {
  my $self = shift;

  $self->cgi_object->param(@_);
}

=item escape_html ( INPUT )

Returns a copy of the string INPUT with all HTML metacharacters escaped.

=cut

sub escape_html {
 my ($self, $input) = @_;

 return $self->{Charset}->escape($input);
}

=item strip_nonprint ( INPUT )

Returns a copy of the string INPUT with runs of nonprintable characters
replaced by spaces.

=cut

sub strip_nonprint {
 my ($self, $input) = @_;

 &{ $self->{Charset}->strip_nonprint_coderef }($input);
}

=item format_date ( FORMAT_STRING [,GMT_OFFSET] )

Returns the current time and date formated by C<strftime> according
to the format string FORMAT_STRING.

If GMT_OFFSET is undefined or the empty string then local time is
used. Otherwise GMT is used, with an offset of GMT_OFFSET hours.

=cut

sub format_date {
 my ($self, $format_string, $gmt_offset) = @_;

 if (defined $gmt_offset and length $gmt_offset) {
  return strftime $format_string, gmtime(time + 60*60*$gmt_offset);
 }
 else {
  return strftime $format_string, localtime;
 }
}

=item name_and_version ()

Returns the NMS script version string that was passed to the constructor.

=cut

sub name_and_version {
  my ($self) = @_;

  return $self->{CFG}{name_and_version};
}

=item warn ( MESSAGE )

Appends a message to the web server's error log.

=cut

sub warn {
  my ($self, $msg) = @_;

  if ($ENV{SCRIPT_NAME} =~ m#^([\w\-\/\.\:]{1,100})$#) {
    $msg = "$1: $msg";
  }

  if ($ENV{REMOTE_ADDR} =~ /^\[?([\d\.\:a-f]{7,100})\]?$/i) {
    $msg = "[$1] $msg";
  }

  warn "$msg\n";
}

=back

=head1 VIRTUAL METHODS

Subclasses for individual NMS scripts must provide the following
methods:

=over

=item default_configuration ()

Invoked from new(), this method must return the default script
configuration as a key,value,key,value list. Configuration options
passed to new() will override those set by this method.

=item init ()

Invoked from new(), this method can be used to do any script specific
object initialisation. There is a default implementation, which does
nothing.

=cut

sub init {}

=item handle_request ()

Invoked from request(), this method is responsible for performing the
bulk of the CGI processing. Any fatal errors raised here will be
trapped and treated according to the C<DEBUGGING> configuration setting.

=back

=head1 SEE ALSO

L<CGI::NMS::Charset>, L<CGI::NMS::Script::FormMail>

=head1 MAINTAINERS

The NMS project, E<lt>/E<gt>

To request support or report bugs, please email
E<lt>nms-cgi-support@lists.sourceforge(dot)netE<gt>

=head1 COPYRIGHT

Copyright 2003 London Perl Mongers, All rights reserved

=head1 LICENSE

This module is free software; you are free to redistribute it
and/or modify it under the same terms as Perl itself.

=cut

1;


END_INLINED_CGI_NMS_Script
 $INC{'CGI/NMS/Script.pm'} = 1;
}


unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Validator}) {
 eval <<'END_INLINED_CGI_NMS_Validator' or die $@;
package CGI::NMS::Validator;
use strict;

=head1 NAME

CGI::NMS::Validator - validation methods

=head1 SYNOPSYS

 use base qw(CGI::NMS::Validator);

 ...

 my $validurl = $self->validate_abs_url($url);

=head1 DESCRIPTION

This module provides methods to validate some of the types of
data the occur in CGI scripts, such as URLs and email addresses.

=head1 METHODS

These C<validate_*> methods all return undef if the item passed
in is invalid, otherwise they return the valid item.

Some of these methods attempt to transform invalid input into valid
input (for example, validate_abs_url() will prepend http if missing)
so the returned valid item may not be the same as that passed in.

The returned value is always detainted.

=over

=item validate_abs_url ( URL )

Validates an absolute URL.

=cut

sub validate_abs_url {
 my ($self, $url) = @_;

 $url = "http://$url" unless $url =~ /:/;
 $url =~ s#^(\w+://)# lc $1 #e;

 $url =~ m< ^ ( (?:ftp|http|https):// [\w\-\.]{1,100} (?:\:\d{1,5})? ) ( /* (?:[^\./].*)? ) $ >mx
  or return '';

 my ($prefix, $path) = ($1, $2);
 return $prefix unless length $path;

 $path = $self->validate_local_abs_uri_frag($path);
 return '' unless $path;
 
 return "$prefix$path";
}

=item validate_local_abs_uri_frag ( URIFRAG )

Validates a local absolute URI fragment, such as C</img/foo.png>. Allows
a query string. The empty string is considered to be a valid URI fragment.

=cut

sub validate_local_abs_uri_frag {
 my ($self, $frag) = @_;

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

=item validate_url ( URL )

Validates a URL, which can be either an absolute URL or a local absolute
URI fragment.

=cut

sub validate_url {
 my ($self, $url) = @_;

 if ($url =~ m#://#) {
  $self->validate_abs_url($url);
 }
 else {
  $self->validate_local_abs_uri_frag($url);
 }
}

=item validate_email ( EMAIL )

Validates an email address.

=cut

sub validate_email {
 my ($self, $email) = @_;

 $email =~ /^([a-z0-9_\-\.\*\+\=]{1,100})\@([^@]{2,100})$/i or return 0;
 my ($user, $host) = ($1, $2);

 return 0 if $host =~ m#^\.|\.$|\.\.#;

 if ($host =~ m#^\[\d+\.\d+\.\d+\.\d+\]$# or $host =~ /^[a-z0-9\-\.]+$/i ) {
   return "$user\@$host";
  }
  else {
   return 0;
 }
}

=item validate_realname ( REALNAME )

Validates a real name, i.e. an email address comment field.

=cut

sub validate_realname {
 my ($self, $realname) = @_;

 $realname =~ tr# a-zA-Z0-9_\-,./'\200-\377# #cs;
 $realname = substr $realname, 0, 128;

 $realname =~ m#^([ a-zA-Z0-9_\-,./'\200-\377]*)$# or die "failed on [$realname]";
 return $1;
}

=item validate_html_color ( COLOR )

Validates an HTML color, either as a named color or as RGB values in hex.

=cut

sub validate_html_color {
 my ($self, $color) = @_;

 $color =~ /^(#[0-9a-z]{6}|[\w\-]{2,50})$/i ? $1 : '';
}

=back

=head1 SEE ALSO

L<CGI::NMS::Script>

=head1 MAINTAINERS

The NMS project, E<lt>E<gt>

To request support or report bugs, please email
E<lt>nms-cgi-support@lists.sourceforge(dot)netE<gt>

=head1 COPYRIGHT

Copyright 2003 London Perl Mongers, All rights reserved

=head1 LICENSE

This module is free software; you are free to redistribute it
and/or modify it under the same terms as Perl itself.

=cut

1;


END_INLINED_CGI_NMS_Validator
 $INC{'CGI/NMS/Validator.pm'} = 1;
}


unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Script::FormMail}) {
 eval <<'END_INLINED_CGI_NMS_Script_FormMail' or die $@;
package CGI::NMS::Script::FormMail;
use strict;

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

use Socket; # for the inet_aton()

use CGI::NMS::Script;
use CGI::NMS::Validator;
use CGI::NMS::Mailer::ByScheme;
use base qw(CGI::NMS::Script CGI::NMS::Validator);

=head1 NAME

CGI::NMS::Script::FormMail - FormMail CGI script

=head1 SYNOPSIS

 #!/usr/bin/perl -wT
 use strict;

 use base qw(CGI::NMS::Script::FormMail);

 use vars qw($script);
 BEGIN {
  $script = __PACKAGE__->new(
   'DEBUGGING'   => 1,
   'postmaster'  => 'me@my.domain',
   'allow_mail_to' => 'me@my.domain',
  );
 }

 $script->request;

=head1 DESCRIPTION

This module implements the NMS plugin replacement for Matt Wright's
FormMail pl CGI script.

=head1 CONFIGURATION SETTINGS

As well as the generic NMS script configuration settings described in
L<CGI::NMS::Script>, the FormMail constructor recognizes the following
configuration settings:

=over

=item C<allow_empty_ref>

Some web proxies and office firewalls may strip certain headers from the
HTTP request that is sent by a browser. Among these is the HTTP_REFERER
that FormMail uses as an additional check of the requests validity - this
will cause the program to fail with a 'bad referer' message even though the
configuration seems fine.

In these cases, setting this configuration setting to 1 will stop the
program from complaining about requests where no referer header was sent
while leaving the rest of the security features intact.

Default: 1

=item C<max_recipients>

The maximum number of e-mail addresses that any single form should be
allowed to send copies of the e-mail to. If none of your forms send
e-mail to more than one recipient, then we recommend that you improve
the security of FormMail by reducing this value to 1. Setting this
configuration setting to 0 removes all limits on the number of recipients
of each e-mail.

Default: 5

=item C<mailprog>

The system command that the script should invoke to send an outgoing email.
This should be the full path to a program that will read a message from
STDIN and determine the list of message recipients from the message headers.
Any switches that the program requires should be provided here.

For example:

 'mailprog' => '/usr/lib/sendmail -oi -t',

An SMTP relay can be specified instead of a sendmail compatible mail program,
using the prefix C<SMTP:>, for example:

 'mailprog' => 'SMTP:mailhost.your.domain',

Default: C<'/usr/lib/sendmail -oi -t'>

=item C<postmaster>

The envelope sender address to use for all emails sent by the script.

Default: ''

=item C<referers>

This configuration setting must be an array reference, holding a list 
of names and/or IP address of systems that will host forms that refer
to this FormMail. An empty array here turns off all referer checking.

Default: []

=item C<allow_mail_to>

This configuration setting must be an array reference.

A list of the email addresses that FormMail can send email to. The
elements of this list can be either simple email addresses (like
'you@your.domain') or domain names (like 'your.domain'). If it's a
domain name then any address at that domain will be allowed.

Default: []

=item C<recipients>

This configuration setting must be an array reference.

A list of Perl regular expression patterns that determine who the
script will allow mail to be sent to in addition to those set in
C<allow_mail_to>. This is present only for compatibility with the
original FormMail script. We strongly advise against having anything
in C<recipients> as it's easy to make a mistake with the regular
expression syntax and turn your FormMail into an open SPAM relay.

Default: []

=item C<recipient_alias>

This configuration setting must be a hash reference.

A hash for predefining a list of recipients in the script, and then
choosing between them using the recipient form field, while keeping
all the email addresses out of the HTML so that they don't get
collected by address harvesters and sent junk email.

For example, suppose you have three forms on your site, and you want
each to submit to a different email address and you want to keep the
addresses hidden. You might set up C<recipient_alias> like this:

 %recipient_alias = (
  '1' => 'one@your.domain',
  '2' => 'two@your.domain',
  '3' => 'three@your.domain',
 );

In the HTML form that should submit to the recipient C<two@your.domain>,
you would then set the recipient with:

 <input type="hidden" name="recipient" value="2" />

Default: {}

=item C<valid_ENV>

This configuration setting must be an array reference.

A list of all the environment variables that you want to be able to
include in the email.

Default: ['REMOTE_HOST','REMOTE_ADDR','REMOTE_USER','HTTP_USER_AGENT']

=item C<date_fmt>

The format that the date will be displayed in, as a string suitable for
passing to strftime().

Default: '%A, %B %d, %Y at %H:%M:%S'

=item C<date_offset>

The empty string to use local time for the date, or an offset from GMT
in hours to fix the timezone independent of the server's locale settings.

Default: ''

=item C<no_content>

If this is set to 1 then rather than returning the HTML confirmation page
or doing a redirect the script will output a header that indicates that no
content will be returned and that the submitted form should not be
replaced. This should be used carefully as an unwitting visitor may click
the submit button several times thinking that nothing has happened.

Default: 0

=item C<double_spacing>

If this is set to 1 then a blank line is printed after each form value in
the e-mail. Change this value to 0 if you want the e-mail to be more
compact.

Default: 1

=item C<join_string>

If an input occurs multiple times, the values are joined to make a
single string value. The value of this configuration setting is
inserted between each value when they are joined.

Default: ' '

=item C<wrap_text>

If this is set to 1 then the content of any long text fields will be
wrapped at around 72 columns in the e-mail which is sent. The way that
this is done is controlled by the C<wrap_style> configuration setting.

Default: 0

=item C<wrap_style>

If C<wrap_text> is set to 1 then if this is set to 1 then the text will
be wrapped in such a way that the left margin of the text is lined up
with the beginning of the text after the description of the field -
that is to say it is indented by the length of the field name plus 2.

If it is set to 2 then the subsequent lines of the text will not be
indented at all and will be flush with the start of the lines. The
choice of style is really a matter of taste although you might find
that style 1 does not work particularly well if your e-mail client
uses a proportional font where the spaces of the indent might be
smaller than the characters in the field name.

Default: 1

=item C<address_style>

If C<address_style> is set to 0 then the full address for the user who filled
in the form will be used as "$email ($realname)" - this is also what the
format will be if C<emulate_matts_code> is true.

If it is set to 1 then the address format will be "$realname <$email>".

Default: 0

=item C<force_config_*>

Configuration settings of this form can be used to fix configuration
settings that would normally be set in hidden form fields. For
example, to force the email subject to be "Foo" irrespective of what's
in the C<subject> form field, you would set:

 'force_config_subject' => 'Foo',

Default: none set

=item C<include_config_*>

Configuration settings of this form can be used to treat particular
configuration inputs as normal data inputs as well as honoring their
special meaning. For example, a user might use C<include_config_email>
to include the email address as a regular input as well as using it in
the email header.

Default: none set

=back

=head1 COMPILE TIME METHODS

These methods are invoked at CGI script compile time only, so long as
the new() call is placed inside a BEGIN block as shown above.

=over

=item default_configuration ()

Returns the default values for the configuration passed to the new()
method, as a key,value,key,value list.

=cut

sub default_configuration {
 return (
  allow_empty_ref    => 1,
  max_recipients     => 5,
  mailprog        => '/usr/lib/sendmail -oi -t',
  postmaster       => '',
  referers        => [],
  allow_mail_to     => [],
  recipients       => [],
  recipient_alias    => {},
  valid_ENV       => [qw(REMOTE_HOST REMOTE_ADDR REMOTE_USER HTTP_USER_AGENT)],
  date_fmt        => '%A, %B %d, %Y at %H:%M:%S',
  date_offset      => '',
  no_content       => 0,
  double_spacing     => 1,
  join_string      => ' ',
  wrap_text       => 0,
  wrap_style       => 1,
  address_style     => 0,
 );
}

=item init ()

Invoked from the new() method inherited from L<CGI::NMS::Script>,
this method performs FormMail specific initialization of the script
object.

=cut

sub init {
 my ($self) = @_;

 if ($self->{CFG}{wrap_text}) {
  require Text::Wrap;
  import Text::Wrap;
 }

 $self->{Valid_Env} = { map {$_=>1} @{ $self->{CFG}{valid_ENV} } };

 $self->init_allowed_address_list;

 $self->{Mailer} = CGI::NMS::Mailer::ByScheme->new($self->{CFG}{mailprog});
}

=item init_allowed_address_list ()

Invoked from init(), this method sets up a hash with a key for each
allowed recipient email address as C<Allow_Mail> and a hash with a
key for each domain at which any address is allowed as C<Allow_Domain>.

=cut

sub init_allowed_address_list {
 my ($self) = @_;

 my @allow_mail = ();
 my @allow_domain = ();

 foreach my $m (@{ $self->{CFG}{allow_mail_to} }) {
  if ($m =~ /\@/) {
   push @allow_mail, $m;
  }
  else {
   push @allow_domain, $m;
  }
 }

 my @alias_targets = split /\s*,\s*/, join ',', values %{ $self->{CFG}{recipient_alias} };
 push @allow_mail, grep /\@/, @alias_targets;

 # The username part of email addresses should be case sensitive, but the
 # domain name part should not. Map all domain names to lower case for
 # comparison.
 my (%allow_mail, %allow_domain);
 foreach my $m (@allow_mail) {
  $m =~ /^([^@]+)\@([^@]+)$/ or die "internal failure [$m]";
  $m = $1 . '@' . lc $2;
  $allow_mail{$m} = 1;
 }
 foreach my $m (@allow_domain) {
  $m = lc $m;
  $allow_domain{$m} = 1;
 }

 $self->{Allow_Mail}  = \%allow_mail;
 $self->{Allow_Domain} = \%allow_domain;
}

=back

=head1 RUN TIME METHODS

These methods are invoked at script run time, as a result of the call
to the request() method inherited from L<CGI::NMS::Script>.

=over

=item handle_request ()

Handles the core of a single CGI request, outputting the HTML success
or error page or redirect header and sending emails.

Dies on error.

=cut

sub handle_request {
 my ($self) = @_;

 $self->{Hide_Recipient} = 0;

 my $referer = $self->cgi_object->referer;
 unless ($self->referer_is_ok($referer)) {
  $self->referer_error_page;
  return;
 }

 $self->check_method_is_post  or return;

 $self->parse_form;

 $self->check_recipients( $self->get_recipients ) or return;

 my @missing = $self->get_missing_fields;
 if (scalar @missing) {
  $self->missing_fields_output(@missing);
  return;
 }

 my $date   = $self->date_string;
 my $email  = $self->get_user_email;
 my $realname = $self->get_user_realname;

 $self->send_main_email($date, $email, $realname);
 $self->send_conf_email($date, $email, $realname);

 $self->success_page($date);
}

=item date_string ()

Returns a string giving the current date and time, in the configured
format.

=cut

sub date_string {
 my ($self) = @_;

 return $self->format_date( $self->{CFG}{date_fmt},
               $self->{CFG}{date_offset} );
}

=item referer_is_ok ( REFERER )

Returns true if the referer is OK, false otherwise.

=cut

sub referer_is_ok {
 my ($self, $referer) = @_;

 unless ($referer) {
  return ($self->{CFG}{allow_empty_ref} ? 1 : 0);
 }

 if ($referer =~ m!^https?://([^/]*\@)?([\w\-\.]+)!i) {
  my $refhost = $2;
  return $self->refering_host_is_ok($refhost);
 }
 else {
  return 0;
 }
}

=item refering_host_is_ok ( REFERING_HOST )

Returns true if the host name REFERING_HOST is on the list of allowed
referers, or resolves to an allowed IP address.

=cut

sub refering_host_is_ok {
 my ($self, $refhost) = @_;

 my @allow = @{ $self->{CFG}{referers} };
 return 1 unless scalar @allow;

 foreach my $test_ref (@allow) {
  if ($refhost =~ m|\Q$test_ref\E$|i) {
   return 1;
  }
 }

 my $ref_ip = inet_aton($refhost) or return 0;
 foreach my $test_ref (@allow) {
  next unless $test_ref =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/;

  my $test_ref_ip = inet_aton($test_ref) or next;
  if ($ref_ip eq $test_ref_ip) {
   return 1;
  }
 }
}

=item referer_error_page ()

Invoked if the referer is bad, this method outputs an error page
describing the problem with the referer.

=cut

sub referer_error_page {
 my ($self) = @_;

 my $referer = $self->cgi_object->referer || '';
 my $escaped_referer = $self->escape_html($referer);

 if ( $referer =~ m|^https?://([\w\.\-]+)|i) {
  my $host = $1;
  $self->error_page( 'Bad Referrer - Access Denied', <<END );
<p>
 The form attempting to use this script 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>
END
 }
 elsif (length $referer) {
  $self->error_page( 'Malformed Referrer - Access Denied', <<END );
<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>
END
 }
 else {
  $self->error_page( 'Missing Referrer - Access Denied', <<END );
<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>
END
 }
}

=item check_method_is_post ()

Unless the C<secure> configuration setting is false, this method checks
that the request method is POST. Returns true if OK, otherwise outputs
an error page and returns false.

=cut

sub check_method_is_post {
 my ($self) = @_;

 return 1 unless $self->{CFG}{secure};

 my $method = $self->cgi_object->request_method || '';
 if ($method ne 'POST') {
  $self->error_page( 'Error: GET request', <<END );
<p>
 The HTML form 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>&lt;form action=&quot;/cgi-bin/FormMail pl&quot; method=&quot;post&quot;&gt;</tt>
</p>
END
  return 0;
 }
 else {
  return 1;
 }
}

=item parse_form ()

Parses the HTML form, storing the results in various fields in the
C<FormMail> object, as follows:

=over

=item C<FormConfig>

A hash holding the values of the configuration inputs, such as
C<recipient> and C<subject>.

=item C<Form>

A hash holding the values of inputs other than configuration inputs.

=item C<Field_Order>

An array giving the set and order of fields to be included in the
email and on the success page.

=back

=cut

sub parse_form {
 my ($self) = @_;

 $self->{FormConfig} = { map {$_=>''} $self->configuration_form_fields };
 $self->{Field_Order} = [];
 $self->{Form} = {};

 foreach my $p ($self->cgi_object->param()) {
  if (exists $self->{FormConfig}{$p}) {
   $self->parse_config_form_input($p);
  }
  else {
   $self->parse_nonconfig_form_input($p);
  }
 }

 $self->substitute_forced_config_values;

 $self->expand_list_config_items;

 $self->sort_field_order;
 $self->remove_blank_fields;
}

=item configuration_form_fields ()

Returns a list of the names of the form fields which are used
to configure formmail rather than to provide user input, such
as C<subject> and C<recipient>. The specially treated C<email>
and C<realname> fields are included in this list.

=cut

sub configuration_form_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
 );
}

=item parse_config_form_input ( NAME )

Deals with the configuration form input NAME, incorporating it into
the C<FormConfig> field in the blessed hash.

=cut

sub parse_config_form_input {
 my ($self, $name) = @_;

 my $val = $self->strip_nonprint($self->cgi_object->param($name));
 if ($name =~ /return_link_url|redirect$/) {
  $val = $self->validate_url($val);
 }
 $self->{FormConfig}{$name} = $val;
 unless ($self->{CFG}{emulate_matts_code}) {
  $self->{Form}{$name} = $val;
  if ( $self->{CFG}{"include_config_$name"} ) {
   push @{ $self->{Field_Order} }, $name;
  }
 }
}

=item parse_nonconfig_form_input ( NAME )

Deals with the non-configuration form input NAME, incorporating it into
the C<Form> and C<Field_Order> fields in the blessed hash.

=cut

sub parse_nonconfig_form_input {
 my ($self, $name) = @_;

 my @vals = map {$self->strip_nonprint($_)} $self->cgi_object->param($name);
 my $key = $self->strip_nonprint($name);
 $self->{Form}{$key} = join $self->{CFG}{join_string}, @vals;
 push @{ $self->{Field_Order} }, $key;
}

=item expand_list_config_items ()

Converts the form configuration values C<required>, C<env_report> and
C<print_config> from strings of comma separated values to arrays, and
removes anything not in the C<valid_ENV> configuration setting from
C<env_report>.

=cut

sub expand_list_config_items {
 my ($self) = @_;

 foreach my $p (qw(required env_report print_config)) {
  if ($self->{FormConfig}{$p}) {
   $self->{FormConfig}{$p} = [split(/\s*,\s*/, $self->{FormConfig}{$p})];
  }
  else {
   $self->{FormConfig}{$p} = [];
  }
 }

 $self->{FormConfig}{env_report} =
   [ grep { $self->{Valid_Env}{$_} } @{ $self->{FormConfig}{env_report} } ];
}

=item substitute_forced_config_values ()

Replaces form configuration values for which there is a forced value
configuration setting with the forced value. Sets C<Hide_Recipient>
true if the recipient config value is forced.

=cut

sub substitute_forced_config_values {
 my ($self) = @_;

 foreach my $k (keys %{ $self->{FormConfig} }) {
  if (exists $self->{CFG}{"force_config_$k"}) {
   $self->{FormConfig}{$k} = $self->{CFG}{"force_config_$k"};
   $self->{Hide_Recipient} = 1 if $k eq 'recipient';
  }
 }
}

=item sort_field_order ()

Modifies the C<Field_Order> field in the blessed hash according to
the sorting scheme set in the C<sort> form configuration, if any.

=cut

sub sort_field_order {
 my ($self) = @_;

 my $sort = $self->{FormConfig}{'sort'};
 if (defined $sort) {
  if ($sort eq 'alphabetic') {
   $self->{Field_Order} = [ sort @{ $self->{Field_Order} } ];
  }
  elsif ($sort =~ /^\s*order:\s*(.*)$/s) {
   $self->{Field_Order} = [ split /\s*,\s*/, $1 ];
  }
 }
}

=item remove_blank_fields ()

Removes the names of blank or missing fields from the C<Field_Order> array
unless the C<print_blank_fields> form configuration value is true.

=cut

sub remove_blank_fields {
 my ($self) = @_;

 return if $self->{FormConfig}{print_blank_fields};

 $self->{Field_Order} = [
  grep { defined $self->{Form}{$_} and $self->{Form}{$_} !~ /^\s*$/ }
  @{ $self->{Field_Order} }
 ];
}

=item get_recipients ()

Determines the list of configured recipients from the form inputs and the
C<recipient_alias> configuration setting, and returns them as a list.

Sets the C<Hide_Recipient> field in the blessed hash to a true value if
one or more of the recipients were aliased and so should be hidden to
foil address harvesters.

=cut

sub get_recipients {
 my ($self) = @_;

 my $recipient = $self->{FormConfig}{recipient};
 my @recipients;

 if (length $recipient) {
  foreach my $r (split /\s*,\s*/, $recipient) {
   if (exists $self->{CFG}{recipient_alias}{$r}) {
    push @recipients, split /\s*,\s*/, $self->{CFG}{recipient_alias}{$r};
    $self->{Hide_Recipient} = 1;
   }
   else {
    push @recipients, $r;
   }
  }
 }
 else {
  return $self->default_recipients;
 }

 return @recipients;
}

=item default_recipients ()

Invoked from get_recipients if no C<recipient> input is found, this method
returns the default recipient list. The default recipient is the first email
address listed in the C<allow_mail_to> configuration setting, if any.

=cut

sub default_recipients {
 my ($self) = @_;

 my @allow = grep {/\@/} @{ $self->{CFG}{allow_mail_to} };
 if (scalar @allow > 0 and not $self->{CFG}{emulate_matts_code}) {
  $self->{Hide_Recipient} = 1;
  return ($allow[0]);
 }
 else {
  return ();
 }
}

=item check_recipients ( @RECIPIENTS )

Works through the array of recipients passed in and discards any the the script
is not configured to allow, storing the list of valid recipients in the
C<Recipients> field in the blessed hash.

Returns true if at least one (and not too many) valid recipients are found,
otherwise outputs an error page and returns false.

=cut

sub check_recipients {
 my ($self, @recipients) = @_;

 my @valid = grep { $self->recipient_is_ok($_) } @recipients;
 $self->{Recipients} = \@valid;

 if (scalar(@valid) == 0) {
  $self->bad_recipient_error_page;
  return 0;
 }
 elsif ($self->{CFG}{max_recipients} and scalar(@valid) > $self->{CFG}{max_recipients}) {
  $self->too_many_recipients_error_page;
  return 0;
 }
 else {
  return 1;
 }
}

=item recipient_is_ok ( RECIPIENT )

Returns true if the recipient RECIPIENT should be allowed, false otherwise.

=cut

sub recipient_is_ok {
 my ($self, $recipient) = @_;

 return 0 unless $self->validate_email($recipient);

 $recipient =~ /^(.+)\@([^@]+)$/m or die "regex failure [$recipient]";
 my ($user, $host) = ($1, lc $2);
 return 1 if exists $self->{Allow_Domain}{$host};
 return 1 if exists $self->{Allow_Mail}{"$user\@$host"};

 foreach my $r (@{ $self->{CFG}{recipients} }) {
  return 1 if $recipient =~ /(?:$r)$/;
  return 1 if $self->{CFG}{emulate_matts_code} and $recipient =~ /(?:$r)$/i;
 }

 return 0;
}

=item bad_recipient_error_page ()

Outputs the error page for a bad or missing recipient.

=cut

sub bad_recipient_error_page {
 my ($self) = @_;

 my $errhtml = <<END;
<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>
END

 unless ($self->{CFG}{force_config_recipient}) {
  my $esc_rec = $self->escape_html( $self->{FormConfig}{recipient} );
  $errhtml .= <<END;
<hr size="1" />
<p>
The recipient was: [ $esc_rec ]
</p>
END
 }

 $self->error_page( 'Error: Bad or Missing Recipient', $errhtml );
}

=item too_many_recipients_error_page ()

Outputs the error page for too many recipients configured.

=cut

sub too_many_recipients_error_page {
 my ($self) = @_;

 $self->error_page( 'Error: Too many Recipients', <<END );
<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>
END
}

=item get_missing_fields ()

Returns a list of the names of the required fields that have not been
filled in acceptably, each one possibly annotated with details of the
problem with the way the field was filled in.

=cut

sub get_missing_fields {
 my ($self) = @_;

 my @missing = ();

 foreach my $f (@{ $self->{FormConfig}{required} }) {
  if ($f eq 'email') {
   unless ( $self->get_user_email =~ /\@/ ) {
    push @missing, 'email (must be a valid email address)';
   }
  }
  elsif ($f eq 'realname') {
   unless ( length $self->get_user_realname ) {
    push @missing, 'realname';
   }
  }
  else {
   my $val = $self->{Form}{$f};
   if (! defined $val or $val =~ /^\s*$/) {
    push @missing, $f;
   }
  }
 }

 return @missing;
}

=item missing_fields_output ( @MISSING )

Produces the configured output (an error page or a redirect) for the
case when there are missing fields. Takes a list of the missing
fields as arguments.

=cut

sub missing_fields_output {
 my ($self, @missing) = @_;

 if ( $self->{FormConfig}{'missing_fields_redirect'} ) {
  print $self->cgi_object->redirect($self->{FormConfig}{'missing_fields_redirect'});
 }
 else {
  my $missing_field_list = join '',
               map { '<li>' . $self->escape_html($_) . "</li>\n" }
               @missing;
  $self->error_page( 'Error: Blank Fields', <<END );
<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>
END
 }
}

=item get_user_email ()

Returns the user's email address if they entered a valid one in the C<email>
form field, otherwise returns the string C<nobody>.

=cut

sub get_user_email {
 my ($self) = @_;

 my $email = $self->{FormConfig}{email};
 $email = $self->validate_email($email);
 $email = 'nobody' unless $email;

 return $email;
}

=item get_user_realname ()

Returns the user's real name, as entered in the C<realname> form field.

=cut

sub get_user_realname {
 my ($self) = @_;

 my $realname = $self->{FormConfig}{realname};
 if (defined $realname) {
  $realname = $self->validate_realname($realname);
 } else {
  $realname = '';
 }

 return $realname;
}

=item send_main_email ( DATE, EMAIL, REALNAME )

Sends the main email. DATE is a date string, EMAIL is the
user's email address if they entered a valid one and REALNAME
is the user's real name if entered.

=cut

sub send_main_email {
 my ($self, $date, $email, $realname) = @_;

 my $mailer = $self->mailer;
 $mailer->newmail($self->name_and_version, $self->{CFG}{postmaster}, @{ $self->{Recipients} });

 $self->send_main_email_header($email, $realname);
 $mailer->print("\n");

 $self->send_main_email_body_header($date);

 $self->send_main_email_print_config;

 $self->send_main_email_fields;

 $self->send_main_email_footer;

 $mailer->endmail;
}

=item build_from_address( EMAIL, REALNAME )

Creates the address that will be used for the user that filled in the form,
if the address_style configuration is 0 or emulate_matts_code is true then
the format will be "$email ($realname)" if it is set to a true value then
the format will be "$realname <$email>".

=cut

sub build_from_address
{
  my ( $self, $email, $realname ) = @_;

  my $from_address = $email;
  if ( length $realname )
  {
   if (!$self->{CFG}{emulates_matts_code} and $self->{CFG}{address_style})
   {
     $from_address = "$realname <$email>";
   }
   else
   {
     $from_address = "$email ($realname)";
   }
  }

  return $from_address;
}

=item send_main_email_header ( EMAIL, REALNAME )

Sends the email header for the main email, not including the terminating
blank line.

=cut

sub send_main_email_header {
 my ($self, $email, $realname) = @_;

 my $subject = $self->{FormConfig}{subject} || 'WWW Form Submission';
 if ($self->{CFG}{secure}) {
  $subject = substr($subject, 0, 256);
 }
 $subject =~ s#[\r\n\t]+# #g;

 my $to = join ',', @{ $self->{Recipients} };
 my $from = $self->build_from_address($email ,$realname);

 $self->mailer->print(<<END);
X-Mailer: ${\( $self->name_and_version )}
To: $to
From: $from
Subject: $subject
END
}

=item send_main_email_body_header ( DATE )

Invoked after the blank line to terminate the header is sent, this method
outputs the header of the email body.

=cut

sub send_main_email_body_header {
 my ($self, $date) = @_;

 my $dashes = '-' x 75;
 $dashes .= "\n\n" if $self->{CFG}{double_spacing};

 $self->mailer->print(<<END);
Below is the result of your feedback form. It was submitted by
$self->{FormConfig}{realname} ($self->{FormConfig}{email}) on $date
$dashes
END
}

=item send_main_email_print_config ()

If the C<print_config> form configuration field is set, outputs the configured
config values to the email.

=cut

sub send_main_email_print_config {
 my ($self) = @_;

 if ($self->{FormConfig}{print_config}) {
  foreach my $cfg (@{ $self->{FormConfig}{print_config} }) {
   if ($self->{FormConfig}{$cfg}) {
    $self->mailer->print("$cfg: $self->{FormConfig}{$cfg}\n");
    $self->mailer->print("\n") if $self->{CFG}{double_spacing};
   }
  }
 }
}

=item send_main_email_fields ()

Outputs the form fields to the email body.

=cut

sub send_main_email_fields {
 my ($self) = @_;

 foreach my $f (@{ $self->{Field_Order} }) {
  my $val = (defined $self->{Form}{$f} ? $self->{Form}{$f} : '');

  $self->send_main_email_field($f, $val);
 }
}

=item send_main_email_field ( NAME, VALUE )

Outputs a single form field to the email body.

=cut

sub send_main_email_field {
 my ($self, $name, $value) = @_;
 
 my ($prefix, $line) = $self->build_main_email_field($name, $value);

 my $nl = ($self->{CFG}{double_spacing} ? "\n\n" : "\n");

 if ($self->{CFG}{wrap_text} and length("$prefix$line") > $self->email_wrap_columns) {
  $self->mailer->print( $self->wrap_field_for_email($prefix, $line) . $nl );
 }
 else {
  $self->mailer->print("$prefix$line$nl");
 }
}

=item build_main_email_field ( NAME, VALUE )

Generates the email body text for a single form input, and returns
it as a two element list of prefix and remainder of line. The return
value is split into a prefix and remainder of line because the text
wrapping code may need to indent the wrapped line to the length of the
prefix.

=cut

sub build_main_email_field {
 my ($self, $name, $value) = @_;

 return ("$name: ", $value);
}

=item wrap_field_for_email ( PREFIX, LINE )

Takes the prefix and rest of line of a field as arguments, and returns them
as a text wrapped paragraph suitable for inclusion in the main email.

=cut

sub wrap_field_for_email {
 my ($self, $prefix, $value) = @_;

 my $subs_indent = '';
 $subs_indent = ' ' x length($prefix) if $self->{CFG}{wrap_style} == 1;

 local $Text::Wrap::columns = $self->email_wrap_columns;

 # Some early versions of Text::Wrap will die on very long words, if that
 # happens we fall back to no wrapping.
 my $wrapped;
 eval { local $SIG{__DIE__} ; $wrapped = wrap($prefix,$subs_indent,$value) };
 return ($@ ? "$prefix$value" : $wrapped);
}

=item email_wrap_columns ()

Returns the number of columns to which the email should be wrapped if the
text wrapping option is in use.

=cut

sub email_wrap_columns { 72; }

=item send_main_email_footer ()

Sends the footer of the main email body, including any environment variables
listed in the C<env_report> configuration form field.

=cut

sub send_main_email_footer {
 my ($self) = @_;

 my $dashes = '-' x 75;
 $self->mailer->print("$dashes\n\n");

 foreach my $e (@{ $self->{FormConfig}{env_report}}) {
  if ($ENV{$e}) {
   $self->mailer->print("$e: " . $self->strip_nonprint($ENV{$e}) . "\n");
  }
 }
}

=item send_conf_email ( DATE, EMAIL, REALNAME )

Sends a confirmation email back to the user, if configured to do so and the
user entered a valid email addresses.

=cut

sub send_conf_email {
 my ($self, $date, $email, $realname) = @_;

 if ( $self->{CFG}{send_confirmation_mail} and $email =~ /\@/ ) {
  my $to = $self->build_from_address($email, $realname);
  $self->mailer->newmail("NMS FormMail.pm v$VERSION", $self->{CFG}{postmaster}, $email);
  $self->mailer->print("To: $to\n$self->{CFG}{confirmation_text}");
  $self->mailer->endmail;
 }
}

=item success_page ()

Outputs the HTML success page (or redirect if configured) after the email
has been successfully sent.

=cut

sub success_page {
 my ($self, $date) = @_;

 if ($self->{FormConfig}{'redirect'}) {
  print $self->cgi_object->redirect( $self->{FormConfig}{'redirect'} );
 }
 elsif ( $self->{CFG}{'no_content'}) {
  print $self->cgi_object->header(Status => 204);
 }
 else {
  $self->output_cgi_html_header;
  $self->success_page_html_preamble($date);
  $self->success_page_fields;
  $self->success_page_footer;
 }
}

=item success_page_html_preamble ( DATE )

Outputs the start of the HTML for the success page, not including the
standard HTML headers dealt with by output_cgi_html_header().

=cut

sub success_page_html_preamble {
 my ($self, $date) = @_;

 my $title = $self->escape_html( $self->{FormConfig}{'title'} || 'Thank You' );
 my $torecipient = 'to ' . $self->escape_html($self->{FormConfig}{'recipient'});
 $torecipient = '' if $self->{Hide_Recipient};
 my $attr = $self->body_attributes;

  print <<END;
 <head>
   <title>$title</title>
END

  $self->output_style_element;

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

=item success_page_fields ()

Outputs success page HTML output for each input field.

=cut

sub success_page_fields {
 my ($self) = @_;

 foreach my $f (@{ $self->{Field_Order} }) {
  my $val = (defined $self->{Form}{$f} ? $self->{Form}{$f} : '');
  $self->success_page_field( $self->escape_html($f), $self->escape_html($val) );
 }
}

=item success_page_field ( NAME, VALUE ) {

Outputs success page HTML for a single input field. NAME and VALUE
are the HTML escaped field name and value.

=cut

sub success_page_field {
 my ($self, $name, $value) = @_;

 print "<p><b>$name:</b> $value</p>\n";
}

=item success_page_footer ()

Outputs the footer of the success page, including the return link if
configured.

=cut

sub success_page_footer {
 my ($self) = @_;

 print qq{<p><hr size="1" width="75%" /></p>\n};
 $self->success_page_return_link;
 print <<END;
    <hr size="1" width="75%" />
    <p align="center">
      <font size="-1">
       <a href="">nms FormMail</a> &copy; 2001 London Perl Mongers<br />Written as drop-in replacement for <a href="/formmail.html">FormMail</a> at <a href="">Matt's Script Archive</a>
      </font>
    </p>
    </body>
    </html>
END
}

=item success_page_return_link ()

Outputs the success page return link if any is configured.

=cut

sub success_page_return_link {
 my ($self) = @_;

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

=item body_attributes ()

Gets the body attributes for the success page from the form
configuration, and returns the string that should go inside
the C<body> tag.

=cut

sub body_attributes {
 my ($self) = @_;

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

 my $attr = '';

 foreach my $at (keys %attrs) {
  my $val = $self->{FormConfig}{$at};
  next unless $val;
  if ($at =~ /color$/) {
   $val = $self->validate_html_color($val);
  }
  elsif ($at eq 'background') {
   $val = $self->validate_url($val);
  }
  else {
   die "no check defined for body attribute [$at]";
  }
  $attr .= qq( $attrs{$at}=") . $self->escape_html($val) . '"' if $val;
 }

 return $attr;
}

=item error_page( TITLE, ERROR_BODY )

Outputs a FormMail error page, giving the HTML document the title
TITLE and displaying the HTML error message ERROR_BODY.

=cut

sub error_page {
 my ($self, $title, $error_body) = @_;

 $self->output_cgi_html_header;

 my $etitle = $self->escape_html($title);
 print <<END;
 <head>
  <title>$etitle</title>
END


 print <<END;
  <style type="text/css">
  <!--
    body {
       background-color: #FFFFFF;
       color: #000000;
       }
    table {
        background-color: #9C9C9C;
       }
    p.c2 {
       font-size: 80%;
       text-align: center;
      }
    tr.title_row {
            background-color: #9C9C9C;
           }
    tr.body_row  {
             background-color: #CFCFCF;
           }

    th.c1 {
        text-align: center;
        font-size: 143%;
       }
    p.c3 {font-size: 80%; text-align: center}
    div.c2 {margin-left: 2em}
   -->
  </style>
END

 $self->output_style_element;

print <<END;
 </head>
 <body>
  <table border="0" width="600" summary="">
   <tr class="title_row">
    <th class="c1">$etitle</th>
   </tr>
   <tr class="body_row">
    <td>
     $error_body
     <hr size="1" />
     <p class="3">
       <a href="">nms FormMail</a> &copy; 2001 London Perl Mongers<br />Written as drop-in replacement for <a href="">FormMail</a> at <a href="">Matt's Script Archive</a>
     </p>
    </td>
   </tr>
  </table>
 </body>
</html>
END
}

=item mailer ()

Returns an object satisfying the definition in L<CGI::NMS::Mailer>,
to be used for sending outgoing email.

=cut

sub mailer {
 my ($self) = @_;

 return $self->{Mailer};
}

=back

=head1 SEE ALSO

L<CGI::NMS::Script>

=head1 MAINTAINERS

The NMS project, E<lt>E<gt>

To request support or report bugs, please email
E<lt>nms-cgi-support@lists.sourceforge(dot)netE<gt>

=head1 COPYRIGHT

Copyright 2003 London Perl Mongers, All rights reserved

=head1 LICENSE

This module is free software; you are free to redistribute it
and/or modify it under the same terms as Perl itself.

=cut

1;


END_INLINED_CGI_NMS_Script_FormMail
 $INC{'CGI/NMS/Script/FormMail.pm'} = 1;
}

}
#
# End of inlined modules
#
use CGI::NMS::Script::FormMail;
use base qw(CGI::NMS::Script::FormMail);

use vars qw($script);
BEGIN {
 $script = __PACKAGE__->new(
   DEBUGGING       => $DEBUGGING,
   name_and_version    => 'NMS FormMail 3.14c1',
   emulate_matts_code   => $emulate_matts_code,
   secure         => $secure,
   allow_empty_ref    => $allow_empty_ref,
   max_recipients     => $max_recipients,
   mailprog        => $mailprog,
   postmaster       => $postmaster,
   referers        => [@referers],
   allow_mail_to     => [@allow_mail_to],
   recipients       => [@recipients],
   recipient_alias    => {%recipient_alias},
   valid_ENV       => [@valid_ENV],
   locale         => $locale,
   charset        => $charset,
   date_fmt        => $date_fmt,
   style         => $style,
   no_content       => $no_content,
   double_spacing     => $double_spacing,
   wrap_text       => $wrap_text,
   wrap_style       => $wrap_style,
   send_confirmation_mail => $send_confirmation_mail,
   confirmation_text   => $confirmation_text,
   address_style     => $address_style,
   %more_config
 );
}

$script->request;
  1. #!/usr/bin/perl -wT
  2. ##############################################################################
  3. # nms Formmail             Version 3.14c1            #
  4. # Copyright 2001 London Perl Mongers  All rights reserved          #
  5. # Created 11/11/01           Last Modified 08/11/04        #
  6. # Matt's Script Archive:           #
  7. ##############################################################################
  8. ##############################################################################
  9. #
  10. # NMS FormMail Version 3.14c1
  11. #
  12. use strict;
  13. use vars qw(
  14.  $DEBUGGING $emulate_matts_code $secure %more_config
  15.  $allow_empty_ref $max_recipients $mailprog @referers
  16.  @allow_mail_to @recipients %recipient_alias
  17.  @valid_ENV $date_fmt $style $send_confirmation_mail
  18.  $confirmation_text $locale $charset $no_content
  19.  $double_spacing $wrap_text $wrap_style $postmaster
  20.  $address_style
  21. );
  22. # PROGRAM INFORMATION
  23. # -------------------
  24. # FormMailVersion 3.14c1
  25. #
  26. # This program is licensed in the same way as Perl
  27. # itself. You are free to choose between the GNU Public
  28. # License  or
  29. # the Artistic License
  30. #
  31. #
  32. # For help on configuration or installation see the
  33. # README file or the POD documentation at the end of
  34. # this file.
  35. # USER CONFIGURATION SECTION
  36. # --------------------------
  37. # Modify these to your own settings. You might have to
  38. # contact your system administrator if you do not run
  39. # your own web server. If the purpose of these
  40. # parameters seems unclear, please see the README file.
  41. #
  42. BEGIN
  43. {
  44.  $DEBUGGING     = 1;
  45.  $emulate_matts_code= 0;
  46.  $secure      = 1;
  47.  $allow_empty_ref  = 1;
  48.  $max_recipients  = 5;
  49.  $mailprog     = '/usr/lib/sendmail -oi -t';
  50.  $postmaster    = '';
  51.  @referers     = qw(dave dot org dot uk 209.207.222.64 localhost);
  52.  @allow_mail_to   = qw(you@your.domain some.one.else@your.domain localhost);
  53.  @recipients    = ();
  54.  %recipient_alias  = ();
  55.  @valid_ENV     = qw(REMOTE_HOST REMOTE_ADDR REMOTE_USER HTTP_USER_AGENT);
  56.  $locale      = '';
  57.  $charset      = 'iso-8859-1';
  58.  $date_fmt     = '%A, %B %d, %Y at %H:%M:%S';
  59.  $style       = '/css/nms.css';
  60.  $no_content    = 0;
  61.  $double_spacing  = 1;
  62.  $wrap_text     = 0;
  63.  $wrap_style    = 1;
  64.  $address_style   = 0;
  65.  $send_confirmation_mail = 0;
  66.  $confirmation_text = <<'END_OF_CONFIRMATION';
  67. From: you(at)your(dot)com
  68. Subject: form submission
  69. Thank you for your form submission.
  70. END_OF_CONFIRMATION
  71. # You may need to uncomment the line below and adjust the path.
  72. # use lib './lib';
  73. # USER CUSTOMISATION SECTION
  74. # --------------------------
  75. # Place any custom code here
  76. # USER CUSTOMISATION << END >>
  77. # ----------------------------
  78. # (no user serviceable parts beyond here)
  79. }
  80. #
  81. # The code below consists of module source inlined into this
  82. # script to make it a standalone CGI.
  83. #
  84. #
  85. BEGIN {
  86. $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer = <<'END_INLINED_CGI_NMS_Mailer';
  87. package CGI::NMS::Mailer;
  88. use strict;
  89. use POSIX qw(strftime);
  90. =head1 NAME
  91. CGI::NMS::Mailer - email sender base class
  92. =head1 SYNOPSYS
  93.  use base qw(CGI::NMS::Mailer);
  94.  ...
  95. =head1 DESCRIPTION
  96. This is a base class for classes implementing low-level email
  97. sending objects for use within CGI scripts.
  98. =head1 METHODS
  99. =over
  100. =item output_trace_headers ( TRACEINFO )
  101. Uses the print() virtual method to output email abuse tracing headers
  102. including whatever useful information can be gleaned from the CGI
  103. environment variables.
  104. The TRACEINFO parameter should be a short string giving the name and
  105. version of the CGI script.
  106. =cut
  107. sub output_trace_headers {
  108.  my ($self, $traceinfo) = @_;
  109.  $ENV{REMOTE_ADDR} =~ /^\[?([\d\.\:a-f]{7,100})\]?$/i or die
  110.    "failed to get remote address from [$ENV{REMOTE_ADDR}], so can't send traceable email";
  111.  $self->print("Received: from [$1]\n");
  112.  my $me = ($ENV{SERVER_NAME} =~ /^([\w\-\.]{1,100})$/ ? $1 : 'unknown');
  113.  $self->print("\tby $me ($traceinfo)\n");
  114.  my $date = strftime '%a, %e %b %Y %H:%M:%S GMT', gmtime;
  115.  $self->print("\twith HTTP; $date\n");
  116.  if ($ENV{SCRIPT_NAME} =~ /^([\w\-\.\/]{1,100})$/) {
  117.   $self->print("\t(script-name $1)\n");
  118.  }
  119.  if (defined $ENV{HTTP_HOST} and $ENV{HTTP_HOST} =~ /^([\w\-\.]{1,100})$/) {
  120.   $self->print("\t(http-host $1)\n");
  121.  }
  122.  my $ff = $ENV{HTTP_X_FORWARDED_FOR};
  123.  if (defined $ff) {
  124.   $ff =~ /^\s*([\w\-\.\[\] ,]{1,200})\s*/ or die
  125.    "malformed X-Forwarded-For [$ff], suspect attack, aborting";
  126.   $self->print("\t(http-x-forwarded-for $1)\n");
  127.  }
  128.  my $ref = $ENV{HTTP_REFERER};
  129.  if (defined $ref and $ref =~ /^([\w\-\.\/\:\;\%\@\#\~\=\+\?]{1,100})$/) {
  130.   $self->print("\t(http-referer $1)\n");
  131.  }
  132. }
  133. =back
  134. =head1 VIRTUAL METHODS
  135. Subclasses must implement the following methods:
  136. =over
  137. =item newmail ( TRACEINFO, SENDER, @RECIPIENTS )
  138. Starts a new email. TRACEINFO is the script name and version, SENDER is
  139. the email address to use as the envelope sender and @RECIPIENTS is a list
  140. of recipients. Dies on error.
  141. =item print ( @ARGS )
  142. Concatenates the arguments and appends them to the email. Both the
  143. header and the body should be sent in this way, separated by a single
  144. blank line. Dies on error.
  145. =item endmail ()
  146. Finishes the email, flushing buffers and sending it. Dies on error.
  147. =back
  148. =head1 SEE ALSO
  149. L<CGI::NMS::Mailer::Sendmail>, L<CGI::NMS::Mailer::SMTP>,
  150. L<CGI::NMS::Script>
  151. =head1 MAINTAINERS
  152. The NMS project, E<
  153. To request support or report bugs, please email
  154. E<lt>nms-cgi-support@lists.sourceforge dot netE<gt>
  155. =head1 COPYRIGHT
  156. Copyright 2003 London Perl Mongers, All rights reserved
  157. =head1 LICENSE
  158. This module is free software; you are free to redistribute it
  159. and/or modify it under the same terms as Perl itself.
  160. =cut
  161. 1;
  162. END_INLINED_CGI_NMS_Mailer
  163. $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer_SMTP = <<'END_INLINED_CGI_NMS_Mailer_SMTP';
  164. package CGI::NMS::Mailer::SMTP;
  165. use strict;
  166. use IO::Socket;
  167. BEGIN {
  168. do {
  169.  unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Mailer}) {
  170.   eval $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer or die $@;
  171.   $INC{'CGI/NMS/Mailer.pm'} = 1;
  172.  }
  173.  undef $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer; # to save memory
  174. };
  175. import CGI::NMS::Mailer }
  176. use base qw(CGI::NMS::Mailer);
  177. =head1 NAME
  178. CGI::NMS::Mailer::SMTP - mail sender using SMTP
  179. =head1 SYNOPSYS
  180.  my $mailer = CGI::NMS::Mailer::SMTP->new('mailhost.bigisp dot net');
  181.  $mailer->newmail($from, $to);
  182.  $mailer->print($email_header_and_body);
  183.  $mailer->endmail;
  184. =head1 DESCRIPTION
  185. This implementation of the mailer object defined in L<CGI::NMS::Mailer>
  186. uses an SMTP connection to a mail relay to send the email.
  187. =head1 CONSTRUCTORS
  188. =over
  189. =item new ( MAILHOST )
  190. MAILHOST must be the name or dotted decimal IP address of an SMTP
  191. server that will relay mail for the web server.
  192. =cut
  193. sub new {
  194.  my ($pkg, $mailhost) = @_;
  195.  $mailhost .= ':25' unless $mailhost =~ /:/;
  196.  return bless { Mailhost => $mailhost }, $pkg;
  197. }
  198. =back
  199. =head1 METHODS
  200. See L<CGI::NMS::Mailer> for the user interface to these methods.
  201. =over
  202. =item newmail ( SCRIPTNAME, SENDER, @RECIPIENTS )
  203. Opens the SMTP connection and sends trace headers.
  204. =cut
  205. sub newmail {
  206.  my ($self, $scriptname, $sender, @recipients) = @_;
  207.  $self->{Sock} = IO::Socket::INET->new($self->{Mailhost});
  208.  defined $self->{Sock} or die "connect to [$self->{Mailhost}]: $!";
  209.  my $banner = $self->_smtp_response;
  210.  $banner =~ /^2/ or die "bad SMTP banner [$banner] from [$self->{Mailhost}]";
  211.  my $helohost = ($ENV{SERVER_NAME} =~ /^([\w\-\.]+)$/ ? $1 : '.');
  212.  $self->_smtp_command("HELO $helohost");
  213.  $self->_smtp_command("MAIL FROM:<$sender>");
  214.  foreach my $r (@recipients) {
  215.   $self->_smtp_command("RCPT TO:<$r>");
  216.  }
  217.  $self->_smtp_command("DATA", '3');
  218.  $self->output_trace_headers($scriptname);
  219. }
  220. =item print ( @ARGS )
  221. Writes some email body to the SMTP socket.
  222. =cut
  223. sub print {
  224.  my ($self, @args) = @_;
  225.  my $text = join '', @args;
  226.  $text =~ s#\n#\015\012#g;
  227.  $text =~ s#^\.#..#mg;
  228.  $self->{Sock}->print($text) or die "write to SMTP socket: $!";
  229. }
  230. =item endmail ()
  231. Finishes sending the mail and closes the SMTP connection.
  232. =cut
  233. sub endmail {
  234.  my ($self) = @_;
  235.  $self->_smtp_command(".");
  236.  $self->_smtp_command("QUIT");
  237.  delete $self->{Sock};
  238. }
  239. =back
  240. =head1 PRIVATE METHODS
  241. These methods should be called from within this module only.
  242. =over
  243. =item _smtp_getline ()
  244. Reads a line from the SMTP socket, and returns it as a string,
  245. including the terminating newline sequence.
  246. =cut
  247. sub _smtp_getline {
  248.  my ($self) = @_;
  249.  my $sock = $self->{Sock};
  250.  my $line = <$sock>;
  251.  defined $line or die "read from SMTP server: $!";
  252.  return $line;
  253. }
  254. =item _smtp_response ()
  255. Reads a command response from the SMTP socket, and returns it as
  256. a single string. A multiline responses is returned as a multiline
  257. string, and the terminating newline sequence is always included.
  258. =cut
  259. sub _smtp_response {
  260.  my ($self) = @_;
  261.  my $line = $self->_smtp_getline;
  262.  my $resp = $line;
  263.  while ($line =~ /^\d\d\d\-/) {
  264.   $line = $self->_smtp_getline;
  265.   $resp .= $line;
  266.  }
  267.  return $resp;
  268. }
  269. =item _smtp_command ( COMMAND [,EXPECT] )
  270. Sends the SMTP command COMMAND to the SMTP server, and reads a line
  271. in response. Dies unless the first character of the response is
  272. the character EXPECT, which defaults to '2'.
  273. =cut
  274. sub _smtp_command {
  275.  my ($self, $command, $expect) = @_;
  276.  defined $expect or $expect = '2';
  277.  $self->{Sock}->print("$command\015\012") or die
  278.   "write [$command] to SMTP server: $!";
  279.  
  280.  my $resp = $self->_smtp_response;
  281.  unless (substr($resp, 0, 1) eq $expect) {
  282.   die "SMTP command [$command] gave response [$resp]";
  283.  }
  284. }
  285. =back
  286. =head1 MAINTAINERS
  287. The NMS project, E<lt><gt>
  288. To request support or report bugs, please email
  289. E<lt>nms-cgi-support@lists.sourceforge(dot)netE<gt>
  290. =head1 COPYRIGHT
  291. Copyright 2003 London Perl Mongers, All rights reserved
  292. =head1 LICENSE
  293. This module is free software; you are free to redistribute it
  294. and/or modify it under the same terms as Perl itself.
  295. =cut
  296. 1;
  297.  
  298. END_INLINED_CGI_NMS_Mailer_SMTP
  299. $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer_Sendmail = <<'END_INLINED_CGI_NMS_Mailer_Sendmail';
  300. package CGI::NMS::Mailer::Sendmail;
  301. use strict;
  302. use IO::File;
  303. BEGIN {
  304. do {
  305.  unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Mailer}) {
  306.   eval $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer or die $@;
  307.   $INC{'CGI/NMS/Mailer.pm'} = 1;
  308.  }
  309.  undef $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer; # to save memory
  310. };
  311. import CGI::NMS::Mailer }
  312. use base qw(CGI::NMS::Mailer);
  313. =head1 NAME
  314. CGI::NMS::Mailer::Sendmail - mail sender using sendmail
  315. =head1 SYNOPSYS
  316.  my $mailer = CGI::NMS::Mailer::Sendmail->new('/usr/lib/sendmail -oi -t');
  317.  $mailer->newmail($from, $to);
  318.  $mailer->print($email_header_and_body);
  319.  $mailer->endmail;
  320. =head1 DESCRIPTION
  321. This implementation of the mailer object defined in L<CGI::NMS::Mailer>
  322. uses a piped open to the UNIX sendmail program to send the email.
  323. =head1 CONSTRUCTORS
  324. =over
  325. =item new ( MAILPROG )
  326. MAILPROG must be the shell command to which a pipe is opened, including
  327. all nessessary switches to cause the sendmail program to read the email
  328. recipients from the header of the email.
  329. =cut
  330. sub new {
  331.  my ($pkg, $mailprog) = @_;
  332.  return bless { Mailprog => $mailprog }, $pkg;
  333. }
  334. =back
  335. =head1 METHODS
  336. See L<CGI::NMS::Mailer> for the user interface to these methods.
  337. =over
  338. =item newmail ( SCRIPTNAME, POSTMASTER, @RECIPIENTS )
  339. Opens the sendmail pipe and outputs trace headers.
  340. =cut
  341. sub newmail {
  342.  my ($self, $scriptname, $postmaster, @recipients) = @_;
  343.  my $command = $self->{Mailprog};
  344.  $command .= qq{ -f "$postmaster"} if $postmaster;
  345.  my $pipe;
  346.  eval { local $SIG{__DIE__};
  347.      $pipe = IO::File->new("| $command");
  348.     };
  349.  if ($@) {
  350.   die $@ unless $@ =~ /Insecure directory/;
  351.   delete $ENV{PATH};
  352.   $pipe = IO::File->new("| $command");
  353.  }
  354.  die "Can't open mailprog [$command]\n" unless $pipe;
  355.  $self->{Pipe} = $pipe;
  356.  $self->output_trace_headers($scriptname);
  357. }
  358. =item print ( @ARGS )
  359. Writes some email body to the sendmail pipe.
  360. =cut
  361. sub print {
  362.  my ($self, @args) = @_;
  363.  $self->{Pipe}->print(@args) or die "write to sendmail pipe: $!";
  364. }
  365. =item endmail ()
  366. Closes the sendmail pipe.
  367. =cut
  368. sub endmail {
  369.  my ($self) = @_;
  370.  $self->{Pipe}->close or die "close sendmail pipe failed, mailprog=[$self->{Mailprog}]";
  371.  delete $self->{Pipe};
  372. }
  373. =back
  374. =head1 MAINTAINERS
  375. The NMS project, E<lt><gt>
  376. To request support or report bugs, please email
  377. E<lt>nms-cgi-support@lists.sourceforge(dot)netE<gt>
  378. =head1 COPYRIGHT
  379. Copyright 2003 London Perl Mongers, All rights reserved
  380. =head1 LICENSE
  381. This module is free software; you are free to redistribute it
  382. and/or modify it under the same terms as Perl itself.
  383. =cut
  384. 1;
  385.  
  386. END_INLINED_CGI_NMS_Mailer_Sendmail
  387. unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Charset}) {
  388.  eval <<'END_INLINED_CGI_NMS_Charset' or die $@;
  389. package CGI::NMS::Charset;
  390. use strict;
  391. require 5.00404;
  392. use vars qw($VERSION);
  393. $VERSION = sprintf '%d.%.2d', (q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/);
  394. =head1 NAME
  395. CGI::NMS::Charset - a charset-aware object for handling text strings
  396. =head1 SYNOPSIS
  397.  my $cs = CGI::NMS::Charset->new('iso-8859-1');
  398.  my $safe_to_put_in_html = $cs->escape($untrusted_user_input);
  399.  my $printable = &{ $cs->strip_nonprint_coderef }( $input );
  400.  my $escaped = &{ $cs->escape_html_coderef }( $printable );
  401. =head1 DESCRIPTION
  402. Each object of class C<CGI::NMS::Charset> is bound to a particular
  403. character set when it is created. The object provides methods to
  404. generate coderefs to perform a couple of character set dependent
  405. operations on text strings.
  406. =cut
  407. =head1 CONSTRUCTORS
  408. =over
  409. =item new ( CHARSET )
  410. Creates a new C<CGI::NMS::Charset> object, suitable for handing text
  411. in the character set CHARSET. The CHARSET parameter must be a
  412. character set string, such as C<us-ascii> or C<utf-8> for example.
  413. =cut
  414. sub new
  415. {
  416.   my ($pkg, $charset) = @_;
  417.   my $self = { CHARSET => $charset };
  418.   if ($charset =~ /^utf-8$/i)
  419.   {
  420.    $self->{SN} = \&_strip_nonprint_utf8;
  421.    $self->{EH} = \&_escape_html_utf8;
  422.   }
  423.   elsif ($charset =~ /^iso-8859/i)
  424.   {
  425.    $self->{SN} = \&_strip_nonprint_8859;
  426.    if ($charset =~ /^iso-8859-1$/i)
  427.    {
  428.      $self->{EH} = \&_escape_html_8859_1;
  429.    }
  430.    else
  431.    {
  432.      $self->{EH} = \&_escape_html_8859;
  433.    }
  434.   }
  435.   elsif ($charset =~ /^us-ascii$/i)
  436.   {
  437.    $self->{SN} = \&_strip_nonprint_ascii;
  438.    $self->{EH} = \&_escape_html_8859_1;
  439.   }
  440.   else
  441.   {
  442.    $self->{SN} = \&_strip_nonprint_weak;
  443.    $self->{EH} = \&_escape_html_weak;
  444.   }
  445.   return bless $self, $pkg;
  446. }
  447. =back
  448. =head1 METHODS
  449. =over
  450. =item charset ()
  451. Returns the CHARSET string that was passed to the constructor.
  452. =cut
  453. sub charset
  454. {
  455.   my ($self) = @_;
  456.   return $self->{CHARSET};
  457. }
  458. =item escape ( STRING )
  459. Returns a copy of STRING with runs of non-printable characters
  460. replaced with spaces and HTML metacharacters replaced with the
  461. equivalent entities.
  462. If STRING is undef then the empty string will be returned.
  463. =cut
  464. sub escape
  465. {
  466.   my ($self, $string) = @_;
  467.   return &{ $self->{EH} }( &{ $self->{SN} }($string) );
  468. }
  469. =item strip_nonprint_coderef ()
  470. Returns a reference to a sub to replace runs of non-printable
  471. characters with spaces, in a manner suited to the charset in
  472. use.
  473. The returned coderef points to a sub that takes a single readonly
  474. string argument and returns a modified version of the string. If
  475. undef is passed to the function then the empty string will be
  476. returned.
  477. =cut
  478. sub strip_nonprint_coderef
  479. {
  480.   my ($self) = @_;
  481.   return $self->{SN};
  482. }
  483. =item escape_html_coderef ()
  484. Returns a reference to a sub to escape HTML metacharacters in
  485. a manner suited to the charset in use.
  486. The returned coderef points to a sub that takes a single readonly
  487. string argument and returns a modified version of the string.
  488. =cut
  489. sub escape_html_coderef
  490. {
  491.   my ($self) = @_;
  492.   return $self->{EH};
  493. }
  494. =back
  495. =head1 DATA TABLES
  496. =over
  497. =item C<%eschtml_map>
  498. The C<%eschtml_map> hash maps C<iso-8859-1> characters to the
  499. equivalent HTML entities.
  500. =cut
  501. use vars qw(%eschtml_map);
  502. %eschtml_map = (
  503.          ( map {chr($_) => "&#$_;"} (0..255) ),
  504.          '<' => '&lt;',
  505.          '>' => '&gt;',
  506.          '&' => '&amp;',
  507.          '"' => '&quot;',
  508.         );
  509. =back
  510. =head1 PRIVATE FUNCTIONS
  511. These functions are returned by the strip_nonprint_coderef() and
  512. escape_html_coderef() methods and invoked by the escape() method.
  513. The function most appropriate to the character set in use will be
  514. chosen.
  515. =over
  516. =item _strip_nonprint_utf8
  517. Returns a copy of STRING with everything but printable C<us-ascii>
  518. characters and valid C<utf-8> multibyte sequences replaced with
  519. space characters.
  520. =cut
  521. sub _strip_nonprint_utf8
  522. {
  523.   my ($string) = @_;
  524.   return '' unless defined $string;
  525.   $string =~
  526.   s%
  527.   ( [\t\n\040-\176]        # printable us-ascii
  528.   | [\xC2-\xDF][\x80-\xBF]    # U+00000080 to U+000007FF
  529.   | \xE0[\xA0-\xBF][\x80-\xBF]  # U+00000800 to U+00000FFF
  530.   | [\xE1-\xEF][\x80-\xBF]{2}   # U+00001000 to U+0000FFFF
  531.   | \xF0[\x90-\xBF][\x80-\xBF]{2} # U+00010000 to U+0003FFFF
  532.   | [\xF1-\xF7][\x80-\xBF]{3}   # U+00040000 to U+001FFFFF
  533.   | \xF8[\x88-\xBF][\x80-\xBF]{3} # U+00200000 to U+00FFFFFF
  534.   | [\xF9-\xFB][\x80-\xBF]{4}   # U+01000000 to U+03FFFFFF
  535.   | \xFC[\x84-\xBF][\x80-\xBF]{4} # U+04000000 to U+3FFFFFFF
  536.   | \xFD[\x80-\xBF]{5}      # U+40000000 to U+7FFFFFFF
  537.   ) | .
  538.   %
  539.   defined $1 ? $1 : ' '
  540.   %gexs;
  541.   #
  542.   # U+FFFE, U+FFFF and U+D800 to U+DFFF are dangerous and
  543.   # should be treated as invalid combinations, according to
  544.   #
  545.   #
  546.   $string =~ s%\xEF\xBF[\xBE-\xBF]% %g;
  547.   $string =~ s%\xED[\xA0-\xBF][\x80-\xBF]% %g;
  548.   return $string;
  549. }
  550. =item _escape_html_utf8 ( STRING )
  551. Returns a copy of STRING with any HTML metacharacters
  552. escaped. Escapes all but the most commonly occurring C<us-ascii>
  553. characters and bytes that might form part of valid C<utf-8>
  554. multibyte sequences.
  555. =cut
  556. sub _escape_html_utf8
  557. {
  558.   my ($string) = @_;
  559.   $string =~ s|([^\w \t\r\n\-\.\,\x80-\xFD])| $eschtml_map{$1} |ge;
  560.   return $string;
  561. }
  562. =item _strip_nonprint_weak ( STRING )
  563. Returns a copy of STRING with sequences of NULL characters
  564. replaced with space characters.
  565. =cut
  566. sub _strip_nonprint_weak
  567. {
  568.   my ($string) = @_;
  569.   return '' unless defined $string;
  570.   $string =~ s/\0+/ /g;
  571.   return $string;
  572. }
  573.  
  574. =item _escape_html_weak ( STRING )
  575. Returns a copy of STRING with any HTML metacharacters escaped.
  576. In order to work in any charset, escapes only E<lt>, E<gt>, C<">
  577. and C<&> characters.
  578. =cut
  579. sub _escape_html_weak
  580. {
  581.   my ($string) = @_;
  582.   $string =~ s/[<>"&]/$eschtml_map{$1}/eg;
  583.   return $string;
  584. }
  585. =item _escape_html_8859_1 ( STRING )
  586. Returns a copy of STRING with all but the most commonly
  587. occurring printable characters replaced with HTML entities.
  588. Only suitable for C<us-ascii> or C<iso-8859-1> input.
  589. =cut
  590. sub _escape_html_8859_1
  591. {
  592.   my ($string) = @_;
  593.   $string =~ s|([^\w \t\r\n\-\.\,\/\:])| $eschtml_map{$1} |ge;
  594.   return $string;
  595. }
  596. =item _escape_html_8859 ( STRING )
  597. Returns a copy of STRING with all but the most commonly
  598. occurring printable C<us-ascii> characters and characters
  599. that might be printable in some C<iso-8859-*> charset
  600. replaced with HTML entities.
  601. =cut
  602. sub _escape_html_8859
  603. {
  604.   my ($string) = @_;
  605.   $string =~ s|([^\w \t\r\n\-\.\,\/\:\240-\377])| $eschtml_map{$1} |ge;
  606.   return $string;
  607. }
  608. =item _strip_nonprint_8859 ( STRING )
  609. Returns a copy of STRING with runs of characters that are not
  610. printable in any C<iso-8859-*> charset replaced with spaces.
  611. =cut
  612. sub _strip_nonprint_8859
  613. {
  614.   my ($string) = @_;
  615.   return '' unless defined $string;
  616.   $string =~ tr#\t\n\040-\176\240-\377# #cs;
  617.   return $string;
  618. }
  619. =item _strip_nonprint_ascii ( STRING )
  620. Returns a copy of STRING with runs of characters that are not
  621. printable C<us-ascii> replaced with spaces.
  622. =cut
  623. sub _strip_nonprint_ascii
  624. {
  625.   my ($string) = @_;
  626.   return '' unless defined $string;
  627.   $string =~ tr#\t\n\040-\176# #cs;
  628.   return $string;
  629. }
  630. =back
  631. =head1 MAINTAINERS
  632. The NMS project, E<lt>/E<gt>
  633. To request support or report bugs, please email
  634. E<lt>nms-cgi-support@lists.sourceforge(dot)netE<gt>
  635. =head1 COPYRIGHT
  636. Copyright 2002-2003 London Perl Mongers, All rights reserved
  637. =head1 LICENSE
  638. This module is free software; you are free to redistribute it
  639. and/or modify it under the same terms as Perl itself.
  640. =cut
  641. 1;
  642. END_INLINED_CGI_NMS_Charset
  643.  $INC{'CGI/NMS/Charset.pm'} = 1;
  644. }
  645. unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Mailer::ByScheme}) {
  646.  eval <<'END_INLINED_CGI_NMS_Mailer_ByScheme' or die $@;
  647. package CGI::NMS::Mailer::ByScheme;
  648. use strict;
  649. =head1 NAME
  650. CGI::NMS::Mailer::ByScheme - mail sending engine switch
  651. =head1 SYNOPSYS
  652.  my $mailer = CGI::NMS::Mailer::ByScheme->new('/usr/lib/sendmail -oi -t');
  653.  my $mailer = CGI::NMS::Mailer::ByScheme->new('SMTP:mailhost.bigisp(dot)net');
  654. =head1 DESCRIPTION
  655. This implementation of the mailer object defined in L<CGI::NMS::Mailer>
  656. chooses between L<CGI::NMS::Mailer::SMTP> and L<CGI::NMS::Mailer::Sendmail>
  657. based on the string passed to new().
  658. =head1 CONSTRUCTORS
  659. =over
  660. =item new ( ARGUMENT )
  661. ARGUMENT must either be the string C<SMTP:> followed by the name or
  662. dotted decimal IP address of an SMTP server that will relay mail
  663. for the web server, or the path to a sendmail compatible binary,
  664. including switches.
  665. =cut
  666. sub new {
  667.  my ($pkg, $argument) = @_;
  668.  if ($argument =~ /^SMTP:([\w\-\.]+(:\d+)?)/i) {
  669.   my $mailhost = $1;
  670.   
  671. do {
  672.  unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Mailer::SMTP}) {
  673.   eval $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer_SMTP or die $@;
  674.   $INC{'CGI/NMS/Mailer/SMTP.pm'} = 1;
  675.  }
  676.  undef $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer_SMTP; # to save memory
  677. };
  678.   return CGI::NMS::Mailer::SMTP->new($mailhost);
  679.  }
  680.  else {
  681.   
  682. do {
  683.  unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Mailer::Sendmail}) {
  684.   eval $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer_Sendmail or die $@;
  685.   $INC{'CGI/NMS/Mailer/Sendmail.pm'} = 1;
  686.  }
  687.  undef $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer_Sendmail; # to save memory
  688. };
  689.   return CGI::NMS::Mailer::Sendmail->new($argument);
  690.  }
  691. }
  692. =back
  693. =head1 MAINTAINERS
  694. The NMS project, E<lt>/E<gt>
  695. To request support or report bugs, please email
  696. E<lt>nms-cgi-support@lists.sourceforge(dot)netE<gt>
  697. =head1 COPYRIGHT
  698. Copyright 2003 London Perl Mongers, All rights reserved
  699. =head1 LICENSE
  700. This module is free software; you are free to redistribute it
  701. and/or modify it under the same terms as Perl itself.
  702. =cut
  703. 1;
  704.  
  705. END_INLINED_CGI_NMS_Mailer_ByScheme
  706.  $INC{'CGI/NMS/Mailer/ByScheme.pm'} = 1;
  707. }
  708. unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Script}) {
  709.  eval <<'END_INLINED_CGI_NMS_Script' or die $@;
  710. package CGI::NMS::Script;
  711. use strict;
  712. use CGI;
  713. use POSIX qw(locale_h strftime);
  714. use CGI::NMS::Charset;
  715. =head1 NAME
  716. CGI::NMS::Script - base class for NMS script modules
  717. =head1 SYNOPSYS
  718.  use base qw(CGI::NMS::Script);
  719.  ...
  720. =head1 DESCRIPTION
  721. This module is a base class for the C<CGI::NMS::Script::*> modules,
  722. which implement plugin replacements for Matt Wright's Perl CGI
  723. scripts.
  724. =head1 CONSTRUCTORS
  725. =over
  726. =item new ( CONFIG )
  727. Creates a new C<CGI::NMS::Script> object and performs compile time
  728. initialisation.
  729. CONFIG is a key,value,key,value list, which will be stored as a hash
  730. within the object, under the name C<CFG>.
  731. =cut
  732. sub new {
  733.  my ($pkg, @cfg) = @_;
  734.  my $self = bless {}, $pkg;
  735.  $self->{CFG} = {
  736.   DEBUGGING      => 0,
  737.   emulate_matts_code => 0,
  738.   secure       => 1,
  739.   locale       => '',
  740.   charset       => 'iso-8859-1',
  741.   style        => '',
  742.   cgi_post_max    => 1000000,
  743.   cgi_disable_uploads => 1,
  744.   $self->default_configuration,
  745.   @cfg
  746.  };
  747.  $self->{Charset} = CGI::NMS::Charset->new( $self->{CFG}{charset} );
  748.  $self->init;
  749.  return $self;
  750. }
  751. =back
  752. =item CONFIGURATION SETTINGS
  753. Values for the following configuration settings can be passed to new().
  754. Subclasses for different NMS scripts will define their own set of
  755. configuration settings, but they all inherit these as well.
  756. =over
  757. =item C<DEBUGGING>
  758. If this is set to a true value, then the error message will be displayed
  759. in the browser if the script suffers a fatal error. This should be set
  760. to 0 once the script is in service, since error messages may contain
  761. sensitive information such as file paths which could be useful to
  762. attackers.
  763. Default: 0
  764. =item C<name_and_version>
  765. The name and version of the NMS script, as a single string.
  766. =item C<emulate_matts_code>
  767. When this variable is set to a true value (e.g. 1) the script will work
  768. in exactly the same way as its counterpart at Matt's Script Archive. If
  769. it is set to a false value (e.g. 0) then more advanced features and
  770. security checks are switched on. We do not recommend changing this
  771. variable to 1, as the resulting drop in security may leave your script
  772. open to abuse.
  773. Default: 0
  774. =item C<secure>
  775. When this variable is set to a true value (e.g. 1) many additional
  776. security features are turned on. We do not recommend changing this
  777. variable to 0, as the resulting drop in security may leave your script
  778. open to abuse.
  779. Default: 1
  780. =item C<locale>
  781. This determines the language that is used in the format_date() method -
  782. by default this is blank and the language will probably be English.
  783. Default: ''
  784. =item C<charset>
  785. The character set to use for output documents.
  786. Default: 'iso-8859-1'
  787. =item C<style>
  788. This is the URL of a CSS stylesheet which will be used for script
  789. generated messages. This should probably be the same as the one that
  790. you use for all the other pages. This should be a local absolute URI
  791. fragment. Set C<style> to 0 or the empty string if you don't want to
  792. use style sheets.
  793. Default: '';
  794. =item C<cgi_post_max>
  795. The variable C<$CGI::POST_MAX> is gets set to this value before the
  796. request is handled.
  797. Default: 1000000
  798. =item C<cgi_disable_uploads>
  799. The variable C<CGI::DISABLE_UPLOADS> gets set to this value before
  800. the request is handled.
  801. Default: 1
  802. =item C<no_xml_doc_header>
  803. If this is set to a true value then the output_cgi_html_header() method
  804. will omit the XML document header that it would normally output. This
  805. means that the output document will not be strictly valid XHTML, but it
  806. may work better in some older browsers.
  807. Default: not set
  808. =item C<no_doctype_doc_header>
  809. If this is set to a true value then the output_cgi_html_header() method
  810. will omit the DOCTYPE document header that it would normally output.
  811. This means that the output document will not be strictly valid XHTML, but
  812. it may work better in some older browsers.
  813. Default: not set
  814. =item C<no_xmlns_doc_header>
  815. If this is set to a true value then the output_cgi_html_header() method
  816. will omit the C<xmlns> attribute from the opening C<html> tag that it
  817. outputs.
  818. =back
  819. =head1 METHODS
  820. =over
  821. =item request ()
  822. This is the method that the CGI script invokes once for each run of the
  823. CGI. This implementation sets up some things that are common to all NMS
  824. scripts and then invokes the virtual method handle_request() to do the
  825. script specific processing.
  826. =cut
  827. sub request {
  828.  my ($self) = @_;
  829.  local ($CGI::POST_MAX, $CGI::DISABLE_UPLOADS);
  830.  $CGI::POST_MAX    = $self->{CFG}{cgi_post_max};
  831.  $CGI::DISABLE_UPLOADS = $self->{CFG}{cgi_disable_uploads};
  832.  $ENV{PATH} =~ /(.*)/m or die;
  833.  local $ENV{PATH} = $1;
  834.  local $ENV{ENV} = '';
  835.  $self->{CGI} = CGI->new;
  836.  $self->{Done_Header} = 0;
  837.  my $old_locale;
  838.  if ($self->{CFG}{locale}) {
  839.   $old_locale = POSIX::setlocale( LC_TIME );
  840.   POSIX::setlocale( LC_TIME, $self->{CFG}{locale} );
  841.  }
  842.  eval { local $SIG{__DIE__} ; $self->handle_request };
  843.  my $err = $@;
  844.  if ($self->{CFG}{locale}) {
  845.   POSIX::setlocale( LC_TIME, $old_locale );
  846.  }
  847.  if ($err) {
  848.   my $message;
  849.   if ($self->{CFG}{DEBUGGING}) {
  850.    $message = $self->escape_html($err);
  851.   }
  852.   else {
  853.    $message = "See the web server's error log for details";
  854.   }
  855.   $self->output_cgi_html_header;
  856.   print <<END;
  857. <head>
  858.  <title>Error</title>
  859. </head>
  860. <body>
  861.  <h1>Application Error</h1>
  862.  <p>
  863.   An error has occurred in the program
  864.  </p>
  865.  <p>
  866.   $message
  867.  </p>
  868. </body>
  869. </html>
  870. END
  871.   $self->warn($err);
  872.  }
  873. }
  874. =item output_cgi_html_header ()
  875. Prints the CGI content-type header and the standard header lines for
  876. an XHTML document, unless the header has already been output.
  877. =cut
  878. sub output_cgi_html_header {
  879.  my ($self) = @_;
  880.  return if $self->{Done_Header};
  881.  $self->output_cgi_header;
  882.  unless ($self->{CFG}{no_xml_doc_header}) {
  883.   print qq|<?xml version="1.0" encoding="$self->{CFG}{charset}"?>\n|;
  884.  }
  885.  unless ($self->{CFG}{no_doctype_doc_header}) {
  886.   print <<END;
  887. <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
  888.   "">
  889. END
  890.  }
  891.  if ($self->{CFG}{no_xmlns_doc_header}) {
  892.   print "<html>\n";
  893.  }
  894.  else {
  895.   print qq|<html xmlns="">\n|;
  896.  }
  897.  $self->{Done_Header} = 1;
  898. }
  899. =item output_cgi_header ()
  900. Outputs the CGI header for an HTML document.
  901. =cut
  902. sub output_cgi_header {
  903.  my ($self) = @_;
  904.  my $charset = $self->{CFG}{charset};
  905.  my $cgi = $self->cgi_object;
  906.  if ($CGI::VERSION >= 2.57) {
  907.   # This is the correct way to set the charset
  908.   print $cgi->header('-type'=>'text/html', '-charset'=>$charset);
  909.  }
  910.  else {
  911.   # However CGI.pm older than version 2.57 doesn't have the
  912.   # -charset option so we cheat:
  913.   print $cgi->header('-type' => "text/html; charset=$charset");
  914.  }
  915. }
  916. =item output_style_element ()
  917. Outputs the C<link rel=stylesheet> header line, if a style sheet URL is
  918. configured.
  919. =cut
  920. sub output_style_element {
  921.  my ($self) = @_;
  922.  if ($self->{CFG}{style}) {
  923.   print qq|<link rel="stylesheet" type="text/css" href="$self->{CFG}{style}" />\n|;
  924.  }
  925. }
  926. =item cgi_object ()
  927. Returns a reference to the C<CGI.pm> object for this request.
  928. =cut
  929. sub cgi_object {
  930.  my ($self) = @_;
  931.   return $self->{CGI};
  932. }
  933. =item param ( ARGS )
  934. Invokes the param() method of the C<CGI.pm> object for this request.
  935. =cut
  936. sub param {
  937.   my $self = shift;
  938.   $self->cgi_object->param(@_);
  939. }
  940. =item escape_html ( INPUT )
  941. Returns a copy of the string INPUT with all HTML metacharacters escaped.
  942. =cut
  943. sub escape_html {
  944.  my ($self, $input) = @_;
  945.  return $self->{Charset}->escape($input);
  946. }
  947. =item strip_nonprint ( INPUT )
  948. Returns a copy of the string INPUT with runs of nonprintable characters
  949. replaced by spaces.
  950. =cut
  951. sub strip_nonprint {
  952.  my ($self, $input) = @_;
  953.  &{ $self->{Charset}->strip_nonprint_coderef }($input);
  954. }
  955. =item format_date ( FORMAT_STRING [,GMT_OFFSET] )
  956. Returns the current time and date formated by C<strftime> according
  957. to the format string FORMAT_STRING.
  958. If GMT_OFFSET is undefined or the empty string then local time is
  959. used. Otherwise GMT is used, with an offset of GMT_OFFSET hours.
  960. =cut
  961. sub format_date {
  962.  my ($self, $format_string, $gmt_offset) = @_;
  963.  if (defined $gmt_offset and length $gmt_offset) {
  964.   return strftime $format_string, gmtime(time + 60*60*$gmt_offset);
  965.  }
  966.  else {
  967.   return strftime $format_string, localtime;
  968.  }
  969. }
  970. =item name_and_version ()
  971. Returns the NMS script version string that was passed to the constructor.
  972. =cut
  973. sub name_and_version {
  974.   my ($self) = @_;
  975.   return $self->{CFG}{name_and_version};
  976. }
  977. =item warn ( MESSAGE )
  978. Appends a message to the web server's error log.
  979. =cut
  980. sub warn {
  981.   my ($self, $msg) = @_;
  982.   if ($ENV{SCRIPT_NAME} =~ m#^([\w\-\/\.\:]{1,100})$#) {
  983.     $msg = "$1: $msg";
  984.   }
  985.   if ($ENV{REMOTE_ADDR} =~ /^\[?([\d\.\:a-f]{7,100})\]?$/i) {
  986.     $msg = "[$1] $msg";
  987.   }
  988.   warn "$msg\n";
  989. }
  990. =back
  991. =head1 VIRTUAL METHODS
  992. Subclasses for individual NMS scripts must provide the following
  993. methods:
  994. =over
  995. =item default_configuration ()
  996. Invoked from new(), this method must return the default script
  997. configuration as a key,value,key,value list. Configuration options
  998. passed to new() will override those set by this method.
  999. =item init ()
  1000. Invoked from new(), this method can be used to do any script specific
  1001. object initialisation. There is a default implementation, which does
  1002. nothing.
  1003. =cut
  1004. sub init {}
  1005. =item handle_request ()
  1006. Invoked from request(), this method is responsible for performing the
  1007. bulk of the CGI processing. Any fatal errors raised here will be
  1008. trapped and treated according to the C<DEBUGGING> configuration setting.
  1009. =back
  1010. =head1 SEE ALSO
  1011. L<CGI::NMS::Charset>, L<CGI::NMS::Script::FormMail>
  1012. =head1 MAINTAINERS
  1013. The NMS project, E<lt>/E<gt>
  1014. To request support or report bugs, please email
  1015. E<lt>nms-cgi-support@lists.sourceforge(dot)netE<gt>
  1016. =head1 COPYRIGHT
  1017. Copyright 2003 London Perl Mongers, All rights reserved
  1018. =head1 LICENSE
  1019. This module is free software; you are free to redistribute it
  1020. and/or modify it under the same terms as Perl itself.
  1021. =cut
  1022. 1;
  1023. END_INLINED_CGI_NMS_Script
  1024.  $INC{'CGI/NMS/Script.pm'} = 1;
  1025. }
  1026. unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Validator}) {
  1027.  eval <<'END_INLINED_CGI_NMS_Validator' or die $@;
  1028. package CGI::NMS::Validator;
  1029. use strict;
  1030. =head1 NAME
  1031. CGI::NMS::Validator - validation methods
  1032. =head1 SYNOPSYS
  1033.  use base qw(CGI::NMS::Validator);
  1034.  ...
  1035.  my $validurl = $self->validate_abs_url($url);
  1036. =head1 DESCRIPTION
  1037. This module provides methods to validate some of the types of
  1038. data the occur in CGI scripts, such as URLs and email addresses.
  1039. =head1 METHODS
  1040. These C<validate_*> methods all return undef if the item passed
  1041. in is invalid, otherwise they return the valid item.
  1042. Some of these methods attempt to transform invalid input into valid
  1043. input (for example, validate_abs_url() will prepend http if missing)
  1044. so the returned valid item may not be the same as that passed in.
  1045. The returned value is always detainted.
  1046. =over
  1047. =item validate_abs_url ( URL )
  1048. Validates an absolute URL.
  1049. =cut
  1050. sub validate_abs_url {
  1051.  my ($self, $url) = @_;
  1052.  $url = "http://$url" unless $url =~ /:/;
  1053.  $url =~ s#^(\w+://)# lc $1 #e;
  1054.  $url =~ m< ^ ( (?:ftp|http|https):// [\w\-\.]{1,100} (?:\:\d{1,5})? ) ( /* (?:[^\./].*)? ) $ >mx
  1055.   or return '';
  1056.  my ($prefix, $path) = ($1, $2);
  1057.  return $prefix unless length $path;
  1058.  $path = $self->validate_local_abs_uri_frag($path);
  1059.  return '' unless $path;
  1060.  
  1061.  return "$prefix$path";
  1062. }
  1063. =item validate_local_abs_uri_frag ( URIFRAG )
  1064. Validates a local absolute URI fragment, such as C</img/foo.png>. Allows
  1065. a query string. The empty string is considered to be a valid URI fragment.
  1066. =cut
  1067. sub validate_local_abs_uri_frag {
  1068.  my ($self, $frag) = @_;
  1069.  $frag =~ m< ^ ( (?: \.* / [\w\-.!~*'(|);/\@+\$,%#&=]* )?
  1070.          (?: \?   [\w\-.!~*'(|);/\@+\$,%#&=]* )?
  1071.         )
  1072.        $
  1073.       >x ? $1 : '';
  1074. }
  1075. =item validate_url ( URL )
  1076. Validates a URL, which can be either an absolute URL or a local absolute
  1077. URI fragment.
  1078. =cut
  1079. sub validate_url {
  1080.  my ($self, $url) = @_;
  1081.  if ($url =~ m#://#) {
  1082.   $self->validate_abs_url($url);
  1083.  }
  1084.  else {
  1085.   $self->validate_local_abs_uri_frag($url);
  1086.  }
  1087. }
  1088. =item validate_email ( EMAIL )
  1089. Validates an email address.
  1090. =cut
  1091. sub validate_email {
  1092.  my ($self, $email) = @_;
  1093.  $email =~ /^([a-z0-9_\-\.\*\+\=]{1,100})\@([^@]{2,100})$/i or return 0;
  1094.  my ($user, $host) = ($1, $2);
  1095.  return 0 if $host =~ m#^\.|\.$|\.\.#;
  1096.  if ($host =~ m#^\[\d+\.\d+\.\d+\.\d+\]$# or $host =~ /^[a-z0-9\-\.]+$/i ) {
  1097.    return "$user\@$host";
  1098.   }
  1099.   else {
  1100.    return 0;
  1101.  }
  1102. }
  1103. =item validate_realname ( REALNAME )
  1104. Validates a real name, i.e. an email address comment field.
  1105. =cut
  1106. sub validate_realname {
  1107.  my ($self, $realname) = @_;
  1108.  $realname =~ tr# a-zA-Z0-9_\-,./'\200-\377# #cs;
  1109.  $realname = substr $realname, 0, 128;
  1110.  $realname =~ m#^([ a-zA-Z0-9_\-,./'\200-\377]*)$# or die "failed on [$realname]";
  1111.  return $1;
  1112. }
  1113. =item validate_html_color ( COLOR )
  1114. Validates an HTML color, either as a named color or as RGB values in hex.
  1115. =cut
  1116. sub validate_html_color {
  1117.  my ($self, $color) = @_;
  1118.  $color =~ /^(#[0-9a-z]{6}|[\w\-]{2,50})$/i ? $1 : '';
  1119. }
  1120. =back
  1121. =head1 SEE ALSO
  1122. L<CGI::NMS::Script>
  1123. =head1 MAINTAINERS
  1124. The NMS project, E<lt>E<gt>
  1125. To request support or report bugs, please email
  1126. E<lt>nms-cgi-support@lists.sourceforge(dot)netE<gt>
  1127. =head1 COPYRIGHT
  1128. Copyright 2003 London Perl Mongers, All rights reserved
  1129. =head1 LICENSE
  1130. This module is free software; you are free to redistribute it
  1131. and/or modify it under the same terms as Perl itself.
  1132. =cut
  1133. 1;
  1134. END_INLINED_CGI_NMS_Validator
  1135.  $INC{'CGI/NMS/Validator.pm'} = 1;
  1136. }
  1137. unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Script::FormMail}) {
  1138.  eval <<'END_INLINED_CGI_NMS_Script_FormMail' or die $@;
  1139. package CGI::NMS::Script::FormMail;
  1140. use strict;
  1141. use vars qw($VERSION);
  1142. $VERSION = substr q$Revision: 1.12 $, 10, -1;
  1143. use Socket; # for the inet_aton()
  1144. use CGI::NMS::Script;
  1145. use CGI::NMS::Validator;
  1146. use CGI::NMS::Mailer::ByScheme;
  1147. use base qw(CGI::NMS::Script CGI::NMS::Validator);
  1148. =head1 NAME
  1149. CGI::NMS::Script::FormMail - FormMail CGI script
  1150. =head1 SYNOPSIS
  1151.  #!/usr/bin/perl -wT
  1152.  use strict;
  1153.  use base qw(CGI::NMS::Script::FormMail);
  1154.  use vars qw($script);
  1155.  BEGIN {
  1156.   $script = __PACKAGE__->new(
  1157.    'DEBUGGING'   => 1,
  1158.    'postmaster'  => 'me@my.domain',
  1159.    'allow_mail_to' => 'me@my.domain',
  1160.   );
  1161.  }
  1162.  $script->request;
  1163. =head1 DESCRIPTION
  1164. This module implements the NMS plugin replacement for Matt Wright's
  1165. FormMail pl CGI script.
  1166. =head1 CONFIGURATION SETTINGS
  1167. As well as the generic NMS script configuration settings described in
  1168. L<CGI::NMS::Script>, the FormMail constructor recognizes the following
  1169. configuration settings:
  1170. =over
  1171. =item C<allow_empty_ref>
  1172. Some web proxies and office firewalls may strip certain headers from the
  1173. HTTP request that is sent by a browser. Among these is the HTTP_REFERER
  1174. that FormMail uses as an additional check of the requests validity - this
  1175. will cause the program to fail with a 'bad referer' message even though the
  1176. configuration seems fine.
  1177. In these cases, setting this configuration setting to 1 will stop the
  1178. program from complaining about requests where no referer header was sent
  1179. while leaving the rest of the security features intact.
  1180. Default: 1
  1181. =item C<max_recipients>
  1182. The maximum number of e-mail addresses that any single form should be
  1183. allowed to send copies of the e-mail to. If none of your forms send
  1184. e-mail to more than one recipient, then we recommend that you improve
  1185. the security of FormMail by reducing this value to 1. Setting this
  1186. configuration setting to 0 removes all limits on the number of recipients
  1187. of each e-mail.
  1188. Default: 5
  1189. =item C<mailprog>
  1190. The system command that the script should invoke to send an outgoing email.
  1191. This should be the full path to a program that will read a message from
  1192. STDIN and determine the list of message recipients from the message headers.
  1193. Any switches that the program requires should be provided here.
  1194. For example:
  1195.  'mailprog' => '/usr/lib/sendmail -oi -t',
  1196. An SMTP relay can be specified instead of a sendmail compatible mail program,
  1197. using the prefix C<SMTP:>, for example:
  1198.  'mailprog' => 'SMTP:mailhost.your.domain',
  1199. Default: C<'/usr/lib/sendmail -oi -t'>
  1200. =item C<postmaster>
  1201. The envelope sender address to use for all emails sent by the script.
  1202. Default: ''
  1203. =item C<referers>
  1204. This configuration setting must be an array reference, holding a list 
  1205. of names and/or IP address of systems that will host forms that refer
  1206. to this FormMail. An empty array here turns off all referer checking.
  1207. Default: []
  1208. =item C<allow_mail_to>
  1209. This configuration setting must be an array reference.
  1210. A list of the email addresses that FormMail can send email to. The
  1211. elements of this list can be either simple email addresses (like
  1212. 'you@your.domain') or domain names (like 'your.domain'). If it's a
  1213. domain name then any address at that domain will be allowed.
  1214. Default: []
  1215. =item C<recipients>
  1216. This configuration setting must be an array reference.
  1217. A list of Perl regular expression patterns that determine who the
  1218. script will allow mail to be sent to in addition to those set in
  1219. C<allow_mail_to>. This is present only for compatibility with the
  1220. original FormMail script. We strongly advise against having anything
  1221. in C<recipients> as it's easy to make a mistake with the regular
  1222. expression syntax and turn your FormMail into an open SPAM relay.
  1223. Default: []
  1224. =item C<recipient_alias>
  1225. This configuration setting must be a hash reference.
  1226. A hash for predefining a list of recipients in the script, and then
  1227. choosing between them using the recipient form field, while keeping
  1228. all the email addresses out of the HTML so that they don't get
  1229. collected by address harvesters and sent junk email.
  1230. For example, suppose you have three forms on your site, and you want
  1231. each to submit to a different email address and you want to keep the
  1232. addresses hidden. You might set up C<recipient_alias> like this:
  1233.  %recipient_alias = (
  1234.   '1' => 'one@your.domain',
  1235.   '2' => 'two@your.domain',
  1236.   '3' => 'three@your.domain',
  1237.  );
  1238. In the HTML form that should submit to the recipient C<two@your.domain>,
  1239. you would then set the recipient with:
  1240.  <input type="hidden" name="recipient" value="2" />
  1241. Default: {}
  1242. =item C<valid_ENV>
  1243. This configuration setting must be an array reference.
  1244. A list of all the environment variables that you want to be able to
  1245. include in the email.
  1246. Default: ['REMOTE_HOST','REMOTE_ADDR','REMOTE_USER','HTTP_USER_AGENT']
  1247. =item C<date_fmt>
  1248. The format that the date will be displayed in, as a string suitable for
  1249. passing to strftime().
  1250. Default: '%A, %B %d, %Y at %H:%M:%S'
  1251. =item C<date_offset>
  1252. The empty string to use local time for the date, or an offset from GMT
  1253. in hours to fix the timezone independent of the server's locale settings.
  1254. Default: ''
  1255. =item C<no_content>
  1256. If this is set to 1 then rather than returning the HTML confirmation page
  1257. or doing a redirect the script will output a header that indicates that no
  1258. content will be returned and that the submitted form should not be
  1259. replaced. This should be used carefully as an unwitting visitor may click
  1260. the submit button several times thinking that nothing has happened.
  1261. Default: 0
  1262. =item C<double_spacing>
  1263. If this is set to 1 then a blank line is printed after each form value in
  1264. the e-mail. Change this value to 0 if you want the e-mail to be more
  1265. compact.
  1266. Default: 1
  1267. =item C<join_string>
  1268. If an input occurs multiple times, the values are joined to make a
  1269. single string value. The value of this configuration setting is
  1270. inserted between each value when they are joined.
  1271. Default: ' '
  1272. =item C<wrap_text>
  1273. If this is set to 1 then the content of any long text fields will be
  1274. wrapped at around 72 columns in the e-mail which is sent. The way that
  1275. this is done is controlled by the C<wrap_style> configuration setting.
  1276. Default: 0
  1277. =item C<wrap_style>
  1278. If C<wrap_text> is set to 1 then if this is set to 1 then the text will
  1279. be wrapped in such a way that the left margin of the text is lined up
  1280. with the beginning of the text after the description of the field -
  1281. that is to say it is indented by the length of the field name plus 2.
  1282. If it is set to 2 then the subsequent lines of the text will not be
  1283. indented at all and will be flush with the start of the lines. The
  1284. choice of style is really a matter of taste although you might find
  1285. that style 1 does not work particularly well if your e-mail client
  1286. uses a proportional font where the spaces of the indent might be
  1287. smaller than the characters in the field name.
  1288. Default: 1
  1289. =item C<address_style>
  1290. If C<address_style> is set to 0 then the full address for the user who filled
  1291. in the form will be used as "$email ($realname)" - this is also what the
  1292. format will be if C<emulate_matts_code> is true.
  1293. If it is set to 1 then the address format will be "$realname <$email>".
  1294. Default: 0
  1295. =item C<force_config_*>
  1296. Configuration settings of this form can be used to fix configuration
  1297. settings that would normally be set in hidden form fields. For
  1298. example, to force the email subject to be "Foo" irrespective of what's
  1299. in the C<subject> form field, you would set:
  1300.  'force_config_subject' => 'Foo',
  1301. Default: none set
  1302. =item C<include_config_*>
  1303. Configuration settings of this form can be used to treat particular
  1304. configuration inputs as normal data inputs as well as honoring their
  1305. special meaning. For example, a user might use C<include_config_email>
  1306. to include the email address as a regular input as well as using it in
  1307. the email header.
  1308. Default: none set
  1309. =back
  1310. =head1 COMPILE TIME METHODS
  1311. These methods are invoked at CGI script compile time only, so long as
  1312. the new() call is placed inside a BEGIN block as shown above.
  1313. =over
  1314. =item default_configuration ()
  1315. Returns the default values for the configuration passed to the new()
  1316. method, as a key,value,key,value list.
  1317. =cut
  1318. sub default_configuration {
  1319.  return (
  1320.   allow_empty_ref    => 1,
  1321.   max_recipients     => 5,
  1322.   mailprog        => '/usr/lib/sendmail -oi -t',
  1323.   postmaster       => '',
  1324.   referers        => [],
  1325.   allow_mail_to     => [],
  1326.   recipients       => [],
  1327.   recipient_alias    => {},
  1328.   valid_ENV       => [qw(REMOTE_HOST REMOTE_ADDR REMOTE_USER HTTP_USER_AGENT)],
  1329.   date_fmt        => '%A, %B %d, %Y at %H:%M:%S',
  1330.   date_offset      => '',
  1331.   no_content       => 0,
  1332.   double_spacing     => 1,
  1333.   join_string      => ' ',
  1334.   wrap_text       => 0,
  1335.   wrap_style       => 1,
  1336.   address_style     => 0,
  1337.  );
  1338. }
  1339. =item init ()
  1340. Invoked from the new() method inherited from L<CGI::NMS::Script>,
  1341. this method performs FormMail specific initialization of the script
  1342. object.
  1343. =cut
  1344. sub init {
  1345.  my ($self) = @_;
  1346.  if ($self->{CFG}{wrap_text}) {
  1347.   require Text::Wrap;
  1348.   import Text::Wrap;
  1349.  }
  1350.  $self->{Valid_Env} = { map {$_=>1} @{ $self->{CFG}{valid_ENV} } };
  1351.  $self->init_allowed_address_list;
  1352.  $self->{Mailer} = CGI::NMS::Mailer::ByScheme->new($self->{CFG}{mailprog});
  1353. }
  1354. =item init_allowed_address_list ()
  1355. Invoked from init(), this method sets up a hash with a key for each
  1356. allowed recipient email address as C<Allow_Mail> and a hash with a
  1357. key for each domain at which any address is allowed as C<Allow_Domain>.
  1358. =cut
  1359. sub init_allowed_address_list {
  1360.  my ($self) = @_;
  1361.  my @allow_mail = ();
  1362.  my @allow_domain = ();
  1363.  foreach my $m (@{ $self->{CFG}{allow_mail_to} }) {
  1364.   if ($m =~ /\@/) {
  1365.    push @allow_mail, $m;
  1366.   }
  1367.   else {
  1368.    push @allow_domain, $m;
  1369.   }
  1370.  }
  1371.  my @alias_targets = split /\s*,\s*/, join ',', values %{ $self->{CFG}{recipient_alias} };
  1372.  push @allow_mail, grep /\@/, @alias_targets;
  1373.  # The username part of email addresses should be case sensitive, but the
  1374.  # domain name part should not. Map all domain names to lower case for
  1375.  # comparison.
  1376.  my (%allow_mail, %allow_domain);
  1377.  foreach my $m (@allow_mail) {
  1378.   $m =~ /^([^@]+)\@([^@]+)$/ or die "internal failure [$m]";
  1379.   $m = $1 . '@' . lc $2;
  1380.   $allow_mail{$m} = 1;
  1381.  }
  1382.  foreach my $m (@allow_domain) {
  1383.   $m = lc $m;
  1384.   $allow_domain{$m} = 1;
  1385.  }
  1386.  $self->{Allow_Mail}  = \%allow_mail;
  1387.  $self->{Allow_Domain} = \%allow_domain;
  1388. }
  1389. =back
  1390. =head1 RUN TIME METHODS
  1391. These methods are invoked at script run time, as a result of the call
  1392. to the request() method inherited from L<CGI::NMS::Script>.
  1393. =over
  1394. =item handle_request ()
  1395. Handles the core of a single CGI request, outputting the HTML success
  1396. or error page or redirect header and sending emails.
  1397. Dies on error.
  1398. =cut
  1399. sub handle_request {
  1400.  my ($self) = @_;
  1401.  $self->{Hide_Recipient} = 0;
  1402.  my $referer = $self->cgi_object->referer;
  1403.  unless ($self->referer_is_ok($referer)) {
  1404.   $self->referer_error_page;
  1405.   return;
  1406.  }
  1407.  $self->check_method_is_post  or return;
  1408.  $self->parse_form;
  1409.  $self->check_recipients( $self->get_recipients ) or return;
  1410.  my @missing = $self->get_missing_fields;
  1411.  if (scalar @missing) {
  1412.   $self->missing_fields_output(@missing);
  1413.   return;
  1414.  }
  1415.  my $date   = $self->date_string;
  1416.  my $email  = $self->get_user_email;
  1417.  my $realname = $self->get_user_realname;
  1418.  $self->send_main_email($date, $email, $realname);
  1419.  $self->send_conf_email($date, $email, $realname);
  1420.  $self->success_page($date);
  1421. }
  1422. =item date_string ()
  1423. Returns a string giving the current date and time, in the configured
  1424. format.
  1425. =cut
  1426. sub date_string {
  1427.  my ($self) = @_;
  1428.  return $self->format_date( $self->{CFG}{date_fmt},
  1429.                $self->{CFG}{date_offset} );
  1430. }
  1431. =item referer_is_ok ( REFERER )
  1432. Returns true if the referer is OK, false otherwise.
  1433. =cut
  1434. sub referer_is_ok {
  1435.  my ($self, $referer) = @_;
  1436.  unless ($referer) {
  1437.   return ($self->{CFG}{allow_empty_ref} ? 1 : 0);
  1438.  }
  1439.  if ($referer =~ m!^https?://([^/]*\@)?([\w\-\.]+)!i) {
  1440.   my $refhost = $2;
  1441.   return $self->refering_host_is_ok($refhost);
  1442.  }
  1443.  else {
  1444.   return 0;
  1445.  }
  1446. }
  1447. =item refering_host_is_ok ( REFERING_HOST )
  1448. Returns true if the host name REFERING_HOST is on the list of allowed
  1449. referers, or resolves to an allowed IP address.
  1450. =cut
  1451. sub refering_host_is_ok {
  1452.  my ($self, $refhost) = @_;
  1453.  my @allow = @{ $self->{CFG}{referers} };
  1454.  return 1 unless scalar @allow;
  1455.  foreach my $test_ref (@allow) {
  1456.   if ($refhost =~ m|\Q$test_ref\E$|i) {
  1457.    return 1;
  1458.   }
  1459.  }
  1460.  my $ref_ip = inet_aton($refhost) or return 0;
  1461.  foreach my $test_ref (@allow) {
  1462.   next unless $test_ref =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/;
  1463.   my $test_ref_ip = inet_aton($test_ref) or next;
  1464.   if ($ref_ip eq $test_ref_ip) {
  1465.    return 1;
  1466.   }
  1467.  }
  1468. }
  1469. =item referer_error_page ()
  1470. Invoked if the referer is bad, this method outputs an error page
  1471. describing the problem with the referer.
  1472. =cut
  1473. sub referer_error_page {
  1474.  my ($self) = @_;
  1475.  my $referer = $self->cgi_object->referer || '';
  1476.  my $escaped_referer = $self->escape_html($referer);
  1477.  if ( $referer =~ m|^https?://([\w\.\-]+)|i) {
  1478.   my $host = $1;
  1479.   $self->error_page( 'Bad Referrer - Access Denied', <<END );
  1480. <p>
  1481.  The form attempting to use this script resides at <tt>$escaped_referer</tt>,
  1482.  which is not allowed to access this program.
  1483. </p>
  1484. <p>
  1485.  If you are attempting to configure FormMail to run with this form,
  1486.  you need to add the following to \@referers, explained in detail in the
  1487.  README file.
  1488. </p>
  1489. <p>
  1490.  Add <tt>'$host'</tt> to your <tt><b>\@referers</b></tt> array.
  1491. </p>
  1492. END
  1493.  }
  1494.  elsif (length $referer) {
  1495.   $self->error_page( 'Malformed Referrer - Access Denied', <<END );
  1496. <p>
  1497.  The referrer value <tt>$escaped_referer</tt> cannot be parsed, so
  1498.  it is not possible to check that the referring page is allowed to
  1499.  access this program.
  1500. </p>
  1501. END
  1502.  }
  1503.  else {
  1504.   $self->error_page( 'Missing Referrer - Access Denied', <<END );
  1505. <p>
  1506.  Your browser did not send a <tt>Referer</tt> header with this
  1507.  request, so it is not possible to check that the referring page
  1508.  is allowed to access this program.
  1509. </p>
  1510. END
  1511.  }
  1512. }
  1513. =item check_method_is_post ()
  1514. Unless the C<secure> configuration setting is false, this method checks
  1515. that the request method is POST. Returns true if OK, otherwise outputs
  1516. an error page and returns false.
  1517. =cut
  1518. sub check_method_is_post {
  1519.  my ($self) = @_;
  1520.  return 1 unless $self->{CFG}{secure};
  1521.  my $method = $self->cgi_object->request_method || '';
  1522.  if ($method ne 'POST') {
  1523.   $self->error_page( 'Error: GET request', <<END );
  1524. <p>
  1525.  The HTML form fails to specify the POST method, so it would not
  1526.  be correct for this script to take any action in response to
  1527.  your request.
  1528. </p>
  1529. <p>
  1530.  If you are attempting to configure this form to run with FormMail,
  1531.  you need to set the request method to POST in the opening form tag,
  1532.  like this:
  1533.  <tt>&lt;form action=&quot;/cgi-bin/FormMail pl&quot; method=&quot;post&quot;&gt;</tt>
  1534. </p>
  1535. END
  1536.   return 0;
  1537.  }
  1538.  else {
  1539.   return 1;
  1540.  }
  1541. }
  1542. =item parse_form ()
  1543. Parses the HTML form, storing the results in various fields in the
  1544. C<FormMail> object, as follows:
  1545. =over
  1546. =item C<FormConfig>
  1547. A hash holding the values of the configuration inputs, such as
  1548. C<recipient> and C<subject>.
  1549. =item C<Form>
  1550. A hash holding the values of inputs other than configuration inputs.
  1551. =item C<Field_Order>
  1552. An array giving the set and order of fields to be included in the
  1553. email and on the success page.
  1554. =back
  1555. =cut
  1556. sub parse_form {
  1557.  my ($self) = @_;
  1558.  $self->{FormConfig} = { map {$_=>''} $self->configuration_form_fields };
  1559.  $self->{Field_Order} = [];
  1560.  $self->{Form} = {};
  1561.  foreach my $p ($self->cgi_object->param()) {
  1562.   if (exists $self->{FormConfig}{$p}) {
  1563.    $self->parse_config_form_input($p);
  1564.   }
  1565.   else {
  1566.    $self->parse_nonconfig_form_input($p);
  1567.   }
  1568.  }
  1569.  $self->substitute_forced_config_values;
  1570.  $self->expand_list_config_items;
  1571.  $self->sort_field_order;
  1572.  $self->remove_blank_fields;
  1573. }
  1574. =item configuration_form_fields ()
  1575. Returns a list of the names of the form fields which are used
  1576. to configure formmail rather than to provide user input, such
  1577. as C<subject> and C<recipient>. The specially treated C<email>
  1578. and C<realname> fields are included in this list.
  1579. =cut
  1580. sub configuration_form_fields {
  1581.  qw(
  1582.   recipient
  1583.   subject
  1584.   email
  1585.   realname
  1586.   redirect
  1587.   bgcolor
  1588.   background
  1589.   link_color
  1590.   vlink_color
  1591.   text_color
  1592.   alink_color
  1593.   title
  1594.   sort
  1595.   print_config
  1596.   required
  1597.   env_report
  1598.   return_link_title
  1599.   return_link_url
  1600.   print_blank_fields
  1601.   missing_fields_redirect
  1602.  );
  1603. }
  1604. =item parse_config_form_input ( NAME )
  1605. Deals with the configuration form input NAME, incorporating it into
  1606. the C<FormConfig> field in the blessed hash.
  1607. =cut
  1608. sub parse_config_form_input {
  1609.  my ($self, $name) = @_;
  1610.  my $val = $self->strip_nonprint($self->cgi_object->param($name));
  1611.  if ($name =~ /return_link_url|redirect$/) {
  1612.   $val = $self->validate_url($val);
  1613.  }
  1614.  $self->{FormConfig}{$name} = $val;
  1615.  unless ($self->{CFG}{emulate_matts_code}) {
  1616.   $self->{Form}{$name} = $val;
  1617.   if ( $self->{CFG}{"include_config_$name"} ) {
  1618.    push @{ $self->{Field_Order} }, $name;
  1619.   }
  1620.  }
  1621. }
  1622. =item parse_nonconfig_form_input ( NAME )
  1623. Deals with the non-configuration form input NAME, incorporating it into
  1624. the C<Form> and C<Field_Order> fields in the blessed hash.
  1625. =cut
  1626. sub parse_nonconfig_form_input {
  1627.  my ($self, $name) = @_;
  1628.  my @vals = map {$self->strip_nonprint($_)} $self->cgi_object->param($name);
  1629.  my $key = $self->strip_nonprint($name);
  1630.  $self->{Form}{$key} = join $self->{CFG}{join_string}, @vals;
  1631.  push @{ $self->{Field_Order} }, $key;
  1632. }
  1633. =item expand_list_config_items ()
  1634. Converts the form configuration values C<required>, C<env_report> and
  1635. C<print_config> from strings of comma separated values to arrays, and
  1636. removes anything not in the C<valid_ENV> configuration setting from
  1637. C<env_report>.
  1638. =cut
  1639. sub expand_list_config_items {
  1640.  my ($self) = @_;
  1641.  foreach my $p (qw(required env_report print_config)) {
  1642.   if ($self->{FormConfig}{$p}) {
  1643.    $self->{FormConfig}{$p} = [split(/\s*,\s*/, $self->{FormConfig}{$p})];
  1644.   }
  1645.   else {
  1646.    $self->{FormConfig}{$p} = [];
  1647.   }
  1648.  }
  1649.  $self->{FormConfig}{env_report} =
  1650.    [ grep { $self->{Valid_Env}{$_} } @{ $self->{FormConfig}{env_report} } ];
  1651. }
  1652. =item substitute_forced_config_values ()
  1653. Replaces form configuration values for which there is a forced value
  1654. configuration setting with the forced value. Sets C<Hide_Recipient>
  1655. true if the recipient config value is forced.
  1656. =cut
  1657. sub substitute_forced_config_values {
  1658.  my ($self) = @_;
  1659.  foreach my $k (keys %{ $self->{FormConfig} }) {
  1660.   if (exists $self->{CFG}{"force_config_$k"}) {
  1661.    $self->{FormConfig}{$k} = $self->{CFG}{"force_config_$k"};
  1662.    $self->{Hide_Recipient} = 1 if $k eq 'recipient';
  1663.   }
  1664.  }
  1665. }
  1666. =item sort_field_order ()
  1667. Modifies the C<Field_Order> field in the blessed hash according to
  1668. the sorting scheme set in the C<sort> form configuration, if any.
  1669. =cut
  1670. sub sort_field_order {
  1671.  my ($self) = @_;
  1672.  my $sort = $self->{FormConfig}{'sort'};
  1673.  if (defined $sort) {
  1674.   if ($sort eq 'alphabetic') {
  1675.    $self->{Field_Order} = [ sort @{ $self->{Field_Order} } ];
  1676.   }
  1677.   elsif ($sort =~ /^\s*order:\s*(.*)$/s) {
  1678.    $self->{Field_Order} = [ split /\s*,\s*/, $1 ];
  1679.   }
  1680.  }
  1681. }
  1682. =item remove_blank_fields ()
  1683. Removes the names of blank or missing fields from the C<Field_Order> array
  1684. unless the C<print_blank_fields> form configuration value is true.
  1685. =cut
  1686. sub remove_blank_fields {
  1687.  my ($self) = @_;
  1688.  return if $self->{FormConfig}{print_blank_fields};
  1689.  $self->{Field_Order} = [
  1690.   grep { defined $self->{Form}{$_} and $self->{Form}{$_} !~ /^\s*$/ }
  1691.   @{ $self->{Field_Order} }
  1692.  ];
  1693. }
  1694. =item get_recipients ()
  1695. Determines the list of configured recipients from the form inputs and the
  1696. C<recipient_alias> configuration setting, and returns them as a list.
  1697. Sets the C<Hide_Recipient> field in the blessed hash to a true value if
  1698. one or more of the recipients were aliased and so should be hidden to
  1699. foil address harvesters.
  1700. =cut
  1701. sub get_recipients {
  1702.  my ($self) = @_;
  1703.  my $recipient = $self->{FormConfig}{recipient};
  1704.  my @recipients;
  1705.  if (length $recipient) {
  1706.   foreach my $r (split /\s*,\s*/, $recipient) {
  1707.    if (exists $self->{CFG}{recipient_alias}{$r}) {
  1708.     push @recipients, split /\s*,\s*/, $self->{CFG}{recipient_alias}{$r};
  1709.     $self->{Hide_Recipient} = 1;
  1710.    }
  1711.    else {
  1712.     push @recipients, $r;
  1713.    }
  1714.   }
  1715.  }
  1716.  else {
  1717.   return $self->default_recipients;
  1718.  }
  1719.  return @recipients;
  1720. }
  1721. =item default_recipients ()
  1722. Invoked from get_recipients if no C<recipient> input is found, this method
  1723. returns the default recipient list. The default recipient is the first email
  1724. address listed in the C<allow_mail_to> configuration setting, if any.
  1725. =cut
  1726. sub default_recipients {
  1727.  my ($self) = @_;
  1728.  my @allow = grep {/\@/} @{ $self->{CFG}{allow_mail_to} };
  1729.  if (scalar @allow > 0 and not $self->{CFG}{emulate_matts_code}) {
  1730.   $self->{Hide_Recipient} = 1;
  1731.   return ($allow[0]);
  1732.  }
  1733.  else {
  1734.   return ();
  1735.  }
  1736. }
  1737. =item check_recipients ( @RECIPIENTS )
  1738. Works through the array of recipients passed in and discards any the the script
  1739. is not configured to allow, storing the list of valid recipients in the
  1740. C<Recipients> field in the blessed hash.
  1741. Returns true if at least one (and not too many) valid recipients are found,
  1742. otherwise outputs an error page and returns false.
  1743. =cut
  1744. sub check_recipients {
  1745.  my ($self, @recipients) = @_;
  1746.  my @valid = grep { $self->recipient_is_ok($_) } @recipients;
  1747.  $self->{Recipients} = \@valid;
  1748.  if (scalar(@valid) == 0) {
  1749.   $self->bad_recipient_error_page;
  1750.   return 0;
  1751.  }
  1752.  elsif ($self->{CFG}{max_recipients} and scalar(@valid) > $self->{CFG}{max_recipients}) {
  1753.   $self->too_many_recipients_error_page;
  1754.   return 0;
  1755.  }
  1756.  else {
  1757.   return 1;
  1758.  }
  1759. }
  1760. =item recipient_is_ok ( RECIPIENT )
  1761. Returns true if the recipient RECIPIENT should be allowed, false otherwise.
  1762. =cut
  1763. sub recipient_is_ok {
  1764.  my ($self, $recipient) = @_;
  1765.  return 0 unless $self->validate_email($recipient);
  1766.  $recipient =~ /^(.+)\@([^@]+)$/m or die "regex failure [$recipient]";
  1767.  my ($user, $host) = ($1, lc $2);
  1768.  return 1 if exists $self->{Allow_Domain}{$host};
  1769.  return 1 if exists $self->{Allow_Mail}{"$user\@$host"};
  1770.  foreach my $r (@{ $self->{CFG}{recipients} }) {
  1771.   return 1 if $recipient =~ /(?:$r)$/;
  1772.   return 1 if $self->{CFG}{emulate_matts_code} and $recipient =~ /(?:$r)$/i;
  1773.  }
  1774.  return 0;
  1775. }
  1776. =item bad_recipient_error_page ()
  1777. Outputs the error page for a bad or missing recipient.
  1778. =cut
  1779. sub bad_recipient_error_page {
  1780.  my ($self) = @_;
  1781.  my $errhtml = <<END;
  1782. <p>
  1783.  There was no recipient or an invalid recipient specified in the
  1784.  data sent to FormMail. Please make sure you have filled in the
  1785.  <tt>recipient</tt> form field with an e-mail address that has
  1786.  been configured in <tt>\@recipients</tt> or <tt>\@allow_mail_to</tt>.
  1787.  More information on filling in <tt>recipient/allow_mail_to</tt>
  1788.  form fields and variables can be found in the README file.
  1789. </p>
  1790. END
  1791.  unless ($self->{CFG}{force_config_recipient}) {
  1792.   my $esc_rec = $self->escape_html( $self->{FormConfig}{recipient} );
  1793.   $errhtml .= <<END;
  1794. <hr size="1" />
  1795. <p>
  1796. The recipient was: [ $esc_rec ]
  1797. </p>
  1798. END
  1799.  }
  1800.  $self->error_page( 'Error: Bad or Missing Recipient', $errhtml );
  1801. }
  1802. =item too_many_recipients_error_page ()
  1803. Outputs the error page for too many recipients configured.
  1804. =cut
  1805. sub too_many_recipients_error_page {
  1806.  my ($self) = @_;
  1807.  $self->error_page( 'Error: Too many Recipients', <<END );
  1808. <p>
  1809.  The number of recipients configured in the form exceeds the
  1810.  maximum number of recipients configured in the script. If
  1811.  you are attempting to configure FormMail to run with this form
  1812.  then you will need to increase the <tt>\$max_recipients</tt>
  1813.  configuration setting in the script.
  1814. </p>
  1815. END
  1816. }
  1817. =item get_missing_fields ()
  1818. Returns a list of the names of the required fields that have not been
  1819. filled in acceptably, each one possibly annotated with details of the
  1820. problem with the way the field was filled in.
  1821. =cut
  1822. sub get_missing_fields {
  1823.  my ($self) = @_;
  1824.  my @missing = ();
  1825.  foreach my $f (@{ $self->{FormConfig}{required} }) {
  1826.   if ($f eq 'email') {
  1827.    unless ( $self->get_user_email =~ /\@/ ) {
  1828.     push @missing, 'email (must be a valid email address)';
  1829.    }
  1830.   }
  1831.   elsif ($f eq 'realname') {
  1832.    unless ( length $self->get_user_realname ) {
  1833.     push @missing, 'realname';
  1834.    }
  1835.   }
  1836.   else {
  1837.    my $val = $self->{Form}{$f};
  1838.    if (! defined $val or $val =~ /^\s*$/) {
  1839.     push @missing, $f;
  1840.    }
  1841.   }
  1842.  }
  1843.  return @missing;
  1844. }
  1845. =item missing_fields_output ( @MISSING )
  1846. Produces the configured output (an error page or a redirect) for the
  1847. case when there are missing fields. Takes a list of the missing
  1848. fields as arguments.
  1849. =cut
  1850. sub missing_fields_output {
  1851.  my ($self, @missing) = @_;
  1852.  if ( $self->{FormConfig}{'missing_fields_redirect'} ) {
  1853.   print $self->cgi_object->redirect($self->{FormConfig}{'missing_fields_redirect'});
  1854.  }
  1855.  else {
  1856.   my $missing_field_list = join '',
  1857.                map { '<li>' . $self->escape_html($_) . "</li>\n" }
  1858.                @missing;
  1859.   $self->error_page( 'Error: Blank Fields', <<END );
  1860. <p>
  1861.   The following fields were left blank in your submission form:
  1862. </p>
  1863. <div class="c2">
  1864.   <ul>
  1865.    $missing_field_list
  1866.   </ul>
  1867. </div>
  1868. <p>
  1869.   These fields must be filled in before you can successfully
  1870.   submit the form.
  1871. </p>
  1872. <p>
  1873.   Please use your back button to return to the form and
  1874.   try again.
  1875. </p>
  1876. END
  1877.  }
  1878. }
  1879. =item get_user_email ()
  1880. Returns the user's email address if they entered a valid one in the C<email>
  1881. form field, otherwise returns the string C<nobody>.
  1882. =cut
  1883. sub get_user_email {
  1884.  my ($self) = @_;
  1885.  my $email = $self->{FormConfig}{email};
  1886.  $email = $self->validate_email($email);
  1887.  $email = 'nobody' unless $email;
  1888.  return $email;
  1889. }
  1890. =item get_user_realname ()
  1891. Returns the user's real name, as entered in the C<realname> form field.
  1892. =cut
  1893. sub get_user_realname {
  1894.  my ($self) = @_;
  1895.  my $realname = $self->{FormConfig}{realname};
  1896.  if (defined $realname) {
  1897.   $realname = $self->validate_realname($realname);
  1898.  } else {
  1899.   $realname = '';
  1900.  }
  1901.  return $realname;
  1902. }
  1903. =item send_main_email ( DATE, EMAIL, REALNAME )
  1904. Sends the main email. DATE is a date string, EMAIL is the
  1905. user's email address if they entered a valid one and REALNAME
  1906. is the user's real name if entered.
  1907. =cut
  1908. sub send_main_email {
  1909.  my ($self, $date, $email, $realname) = @_;
  1910.  my $mailer = $self->mailer;
  1911.  $mailer->newmail($self->name_and_version, $self->{CFG}{postmaster}, @{ $self->{Recipients} });
  1912.  $self->send_main_email_header($email, $realname);
  1913.  $mailer->print("\n");
  1914.  $self->send_main_email_body_header($date);
  1915.  $self->send_main_email_print_config;
  1916.  $self->send_main_email_fields;
  1917.  $self->send_main_email_footer;
  1918.  $mailer->endmail;
  1919. }
  1920. =item build_from_address( EMAIL, REALNAME )
  1921. Creates the address that will be used for the user that filled in the form,
  1922. if the address_style configuration is 0 or emulate_matts_code is true then
  1923. the format will be "$email ($realname)" if it is set to a true value then
  1924. the format will be "$realname <$email>".
  1925. =cut
  1926. sub build_from_address
  1927. {
  1928.   my ( $self, $email, $realname ) = @_;
  1929.   my $from_address = $email;
  1930.   if ( length $realname )
  1931.   {
  1932.    if (!$self->{CFG}{emulates_matts_code} and $self->{CFG}{address_style})
  1933.    {
  1934.      $from_address = "$realname <$email>";
  1935.    }
  1936.    else
  1937.    {
  1938.      $from_address = "$email ($realname)";
  1939.    }
  1940.   }
  1941.   return $from_address;
  1942. }
  1943. =item send_main_email_header ( EMAIL, REALNAME )
  1944. Sends the email header for the main email, not including the terminating
  1945. blank line.
  1946. =cut
  1947. sub send_main_email_header {
  1948.  my ($self, $email, $realname) = @_;
  1949.  my $subject = $self->{FormConfig}{subject} || 'WWW Form Submission';
  1950.  if ($self->{CFG}{secure}) {
  1951.   $subject = substr($subject, 0, 256);
  1952.  }
  1953.  $subject =~ s#[\r\n\t]+# #g;
  1954.  my $to = join ',', @{ $self->{Recipients} };
  1955.  my $from = $self->build_from_address($email ,$realname);
  1956.  $self->mailer->print(<<END);
  1957. X-Mailer: ${\( $self->name_and_version )}
  1958. To: $to
  1959. From: $from
  1960. Subject: $subject
  1961. END
  1962. }
  1963. =item send_main_email_body_header ( DATE )
  1964. Invoked after the blank line to terminate the header is sent, this method
  1965. outputs the header of the email body.
  1966. =cut
  1967. sub send_main_email_body_header {
  1968.  my ($self, $date) = @_;
  1969.  my $dashes = '-' x 75;
  1970.  $dashes .= "\n\n" if $self->{CFG}{double_spacing};
  1971.  $self->mailer->print(<<END);
  1972. Below is the result of your feedback form. It was submitted by
  1973. $self->{FormConfig}{realname} ($self->{FormConfig}{email}) on $date
  1974. $dashes
  1975. END
  1976. }
  1977. =item send_main_email_print_config ()
  1978. If the C<print_config> form configuration field is set, outputs the configured
  1979. config values to the email.
  1980. =cut
  1981. sub send_main_email_print_config {
  1982.  my ($self) = @_;
  1983.  if ($self->{FormConfig}{print_config}) {
  1984.   foreach my $cfg (@{ $self->{FormConfig}{print_config} }) {
  1985.    if ($self->{FormConfig}{$cfg}) {
  1986.     $self->mailer->print("$cfg: $self->{FormConfig}{$cfg}\n");
  1987.     $self->mailer->print("\n") if $self->{CFG}{double_spacing};
  1988.    }
  1989.   }
  1990.  }
  1991. }
  1992. =item send_main_email_fields ()
  1993. Outputs the form fields to the email body.
  1994. =cut
  1995. sub send_main_email_fields {
  1996.  my ($self) = @_;
  1997.  foreach my $f (@{ $self->{Field_Order} }) {
  1998.   my $val = (defined $self->{Form}{$f} ? $self->{Form}{$f} : '');
  1999.   $self->send_main_email_field($f, $val);
  2000.  }
  2001. }
  2002. =item send_main_email_field ( NAME, VALUE )
  2003. Outputs a single form field to the email body.
  2004. =cut
  2005. sub send_main_email_field {
  2006.  my ($self, $name, $value) = @_;
  2007.  
  2008.  my ($prefix, $line) = $self->build_main_email_field($name, $value);
  2009.  my $nl = ($self->{CFG}{double_spacing} ? "\n\n" : "\n");
  2010.  if ($self->{CFG}{wrap_text} and length("$prefix$line") > $self->email_wrap_columns) {
  2011.   $self->mailer->print( $self->wrap_field_for_email($prefix, $line) . $nl );
  2012.  }
  2013.  else {
  2014.   $self->mailer->print("$prefix$line$nl");
  2015.  }
  2016. }
  2017. =item build_main_email_field ( NAME, VALUE )
  2018. Generates the email body text for a single form input, and returns
  2019. it as a two element list of prefix and remainder of line. The return
  2020. value is split into a prefix and remainder of line because the text
  2021. wrapping code may need to indent the wrapped line to the length of the
  2022. prefix.
  2023. =cut
  2024. sub build_main_email_field {
  2025.  my ($self, $name, $value) = @_;
  2026.  return ("$name: ", $value);
  2027. }
  2028. =item wrap_field_for_email ( PREFIX, LINE )
  2029. Takes the prefix and rest of line of a field as arguments, and returns them
  2030. as a text wrapped paragraph suitable for inclusion in the main email.
  2031. =cut
  2032. sub wrap_field_for_email {
  2033.  my ($self, $prefix, $value) = @_;
  2034.  my $subs_indent = '';
  2035.  $subs_indent = ' ' x length($prefix) if $self->{CFG}{wrap_style} == 1;
  2036.  local $Text::Wrap::columns = $self->email_wrap_columns;
  2037.  # Some early versions of Text::Wrap will die on very long words, if that
  2038.  # happens we fall back to no wrapping.
  2039.  my $wrapped;
  2040.  eval { local $SIG{__DIE__} ; $wrapped = wrap($prefix,$subs_indent,$value) };
  2041.  return ($@ ? "$prefix$value" : $wrapped);
  2042. }
  2043. =item email_wrap_columns ()
  2044. Returns the number of columns to which the email should be wrapped if the
  2045. text wrapping option is in use.
  2046. =cut
  2047. sub email_wrap_columns { 72; }
  2048. =item send_main_email_footer ()
  2049. Sends the footer of the main email body, including any environment variables
  2050. listed in the C<env_report> configuration form field.
  2051. =cut
  2052. sub send_main_email_footer {
  2053.  my ($self) = @_;
  2054.  my $dashes = '-' x 75;
  2055.  $self->mailer->print("$dashes\n\n");
  2056.  foreach my $e (@{ $self->{FormConfig}{env_report}}) {
  2057.   if ($ENV{$e}) {
  2058.    $self->mailer->print("$e: " . $self->strip_nonprint($ENV{$e}) . "\n");
  2059.   }
  2060.  }
  2061. }
  2062. =item send_conf_email ( DATE, EMAIL, REALNAME )
  2063. Sends a confirmation email back to the user, if configured to do so and the
  2064. user entered a valid email addresses.
  2065. =cut
  2066. sub send_conf_email {
  2067.  my ($self, $date, $email, $realname) = @_;
  2068.  if ( $self->{CFG}{send_confirmation_mail} and $email =~ /\@/ ) {
  2069.   my $to = $self->build_from_address($email, $realname);
  2070.   $self->mailer->newmail("NMS FormMail.pm v$VERSION", $self->{CFG}{postmaster}, $email);
  2071.   $self->mailer->print("To: $to\n$self->{CFG}{confirmation_text}");
  2072.   $self->mailer->endmail;
  2073.  }
  2074. }
  2075. =item success_page ()
  2076. Outputs the HTML success page (or redirect if configured) after the email
  2077. has been successfully sent.
  2078. =cut
  2079. sub success_page {
  2080.  my ($self, $date) = @_;
  2081.  if ($self->{FormConfig}{'redirect'}) {
  2082.   print $self->cgi_object->redirect( $self->{FormConfig}{'redirect'} );
  2083.  }
  2084.  elsif ( $self->{CFG}{'no_content'}) {
  2085.   print $self->cgi_object->header(Status => 204);
  2086.  }
  2087.  else {
  2088.   $self->output_cgi_html_header;
  2089.   $self->success_page_html_preamble($date);
  2090.   $self->success_page_fields;
  2091.   $self->success_page_footer;
  2092.  }
  2093. }
  2094. =item success_page_html_preamble ( DATE )
  2095. Outputs the start of the HTML for the success page, not including the
  2096. standard HTML headers dealt with by output_cgi_html_header().
  2097. =cut
  2098. sub success_page_html_preamble {
  2099.  my ($self, $date) = @_;
  2100.  my $title = $self->escape_html( $self->{FormConfig}{'title'} || 'Thank You' );
  2101.  my $torecipient = 'to ' . $self->escape_html($self->{FormConfig}{'recipient'});
  2102.  $torecipient = '' if $self->{Hide_Recipient};
  2103.  my $attr = $self->body_attributes;
  2104.   print <<END;
  2105.  <head>
  2106.    <title>$title</title>
  2107. END
  2108.   $self->output_style_element;
  2109.   print <<END;
  2110.    <style>
  2111.     h1.title {
  2112.           text-align : center;
  2113.         }
  2114.    </style>
  2115.  </head>
  2116.  <body $attr>
  2117.   <h1 class="title">$title</h1>
  2118.   <p>Below is what you submitted $torecipient on $date</p>
  2119.   <p><hr size="1" width="75%" /></p>
  2120. END
  2121. }
  2122. =item success_page_fields ()
  2123. Outputs success page HTML output for each input field.
  2124. =cut
  2125. sub success_page_fields {
  2126.  my ($self) = @_;
  2127.  foreach my $f (@{ $self->{Field_Order} }) {
  2128.   my $val = (defined $self->{Form}{$f} ? $self->{Form}{$f} : '');
  2129.   $self->success_page_field( $self->escape_html($f), $self->escape_html($val) );
  2130.  }
  2131. }
  2132. =item success_page_field ( NAME, VALUE ) {
  2133. Outputs success page HTML for a single input field. NAME and VALUE
  2134. are the HTML escaped field name and value.
  2135. =cut
  2136. sub success_page_field {
  2137.  my ($self, $name, $value) = @_;
  2138.  print "<p><b>$name:</b> $value</p>\n";
  2139. }
  2140. =item success_page_footer ()
  2141. Outputs the footer of the success page, including the return link if
  2142. configured.
  2143. =cut
  2144. sub success_page_footer {
  2145.  my ($self) = @_;
  2146.  print qq{<p><hr size="1" width="75%" /></p>\n};
  2147.  $self->success_page_return_link;
  2148.  print <<END;
  2149.     <hr size="1" width="75%" />
  2150.     <p align="center">
  2151.       <font size="-1">
  2152.        <a href="">nms FormMail</a> &copy; 2001 London Perl Mongers<br />Written as drop-in replacement for <a href="/formmail.html">FormMail</a> at <a href="">Matt's Script Archive</a>
  2153.       </font>
  2154.     </p>
  2155.     </body>
  2156.     </html>
  2157. END
  2158. }
  2159. =item success_page_return_link ()
  2160. Outputs the success page return link if any is configured.
  2161. =cut
  2162. sub success_page_return_link {
  2163.  my ($self) = @_;
  2164.  if ($self->{FormConfig}{return_link_url} and $self->{FormConfig}{return_link_title}) {
  2165.   print "<ul>\n";
  2166.   print '<li><a href="', $self->escape_html($self->{FormConfig}{return_link_url}),
  2167.     '">', $self->escape_html($self->{FormConfig}{return_link_title}), "</a>\n";
  2168.   print "</li>\n</ul>\n";
  2169.  }
  2170. }
  2171. =item body_attributes ()
  2172. Gets the body attributes for the success page from the form
  2173. configuration, and returns the string that should go inside
  2174. the C<body> tag.
  2175. =cut
  2176. sub body_attributes {
  2177.  my ($self) = @_;
  2178.  my %attrs = (bgcolor   => 'bgcolor',
  2179.         background => 'background',
  2180.         link_color => 'link',
  2181.         vlink_color => 'vlink',
  2182.         alink_color => 'alink',
  2183.         text_color => 'text');
  2184.  my $attr = '';
  2185.  foreach my $at (keys %attrs) {
  2186.   my $val = $self->{FormConfig}{$at};
  2187.   next unless $val;
  2188.   if ($at =~ /color$/) {
  2189.    $val = $self->validate_html_color($val);
  2190.   }
  2191.   elsif ($at eq 'background') {
  2192.    $val = $self->validate_url($val);
  2193.   }
  2194.   else {
  2195.    die "no check defined for body attribute [$at]";
  2196.   }
  2197.   $attr .= qq( $attrs{$at}=") . $self->escape_html($val) . '"' if $val;
  2198.  }
  2199.  return $attr;
  2200. }
  2201. =item error_page( TITLE, ERROR_BODY )
  2202. Outputs a FormMail error page, giving the HTML document the title
  2203. TITLE and displaying the HTML error message ERROR_BODY.
  2204. =cut
  2205. sub error_page {
  2206.  my ($self, $title, $error_body) = @_;
  2207.  $self->output_cgi_html_header;
  2208.  my $etitle = $self->escape_html($title);
  2209.  print <<END;
  2210.  <head>
  2211.   <title>$etitle</title>
  2212. END
  2213.  print <<END;
  2214.   <style type="text/css">
  2215.   <!--
  2216.     body {
  2217.        background-color: #FFFFFF;
  2218.        color: #000000;
  2219.        }
  2220.     table {
  2221.         background-color: #9C9C9C;
  2222.        }
  2223.     p.c2 {
  2224.        font-size: 80%;
  2225.        text-align: center;
  2226.       }
  2227.     tr.title_row {
  2228.             background-color: #9C9C9C;
  2229.            }
  2230.     tr.body_row  {
  2231.              background-color: #CFCFCF;
  2232.            }
  2233.     th.c1 {
  2234.         text-align: center;
  2235.         font-size: 143%;
  2236.        }
  2237.     p.c3 {font-size: 80%; text-align: center}
  2238.     div.c2 {margin-left: 2em}
  2239.    -->
  2240.   </style>
  2241. END
  2242.  $self->output_style_element;
  2243. print <<END;
  2244.  </head>
  2245.  <body>
  2246.   <table border="0" width="600" summary="">
  2247.    <tr class="title_row">
  2248.     <th class="c1">$etitle</th>
  2249.    </tr>
  2250.    <tr class="body_row">
  2251.     <td>
  2252.      $error_body
  2253.      <hr size="1" />
  2254.      <p class="3">
  2255.        <a href="">nms FormMail</a> &copy; 2001 London Perl Mongers<br />Written as drop-in replacement for <a href="">FormMail</a> at <a href="">Matt's Script Archive</a>
  2256.      </p>
  2257.     </td>
  2258.    </tr>
  2259.   </table>
  2260.  </body>
  2261. </html>
  2262. END
  2263. }
  2264. =item mailer ()
  2265. Returns an object satisfying the definition in L<CGI::NMS::Mailer>,
  2266. to be used for sending outgoing email.
  2267. =cut
  2268. sub mailer {
  2269.  my ($self) = @_;
  2270.  return $self->{Mailer};
  2271. }
  2272. =back
  2273. =head1 SEE ALSO
  2274. L<CGI::NMS::Script>
  2275. =head1 MAINTAINERS
  2276. The NMS project, E<lt>E<gt>
  2277. To request support or report bugs, please email
  2278. E<lt>nms-cgi-support@lists.sourceforge(dot)netE<gt>
  2279. =head1 COPYRIGHT
  2280. Copyright 2003 London Perl Mongers, All rights reserved
  2281. =head1 LICENSE
  2282. This module is free software; you are free to redistribute it
  2283. and/or modify it under the same terms as Perl itself.
  2284. =cut
  2285. 1;
  2286. END_INLINED_CGI_NMS_Script_FormMail
  2287.  $INC{'CGI/NMS/Script/FormMail.pm'} = 1;
  2288. }
  2289. }
  2290. #
  2291. # End of inlined modules
  2292. #
  2293. use CGI::NMS::Script::FormMail;
  2294. use base qw(CGI::NMS::Script::FormMail);
  2295. use vars qw($script);
  2296. BEGIN {
  2297.  $script = __PACKAGE__->new(
  2298.    DEBUGGING       => $DEBUGGING,
  2299.    name_and_version    => 'NMS FormMail 3.14c1',
  2300.    emulate_matts_code   => $emulate_matts_code,
  2301.    secure         => $secure,
  2302.    allow_empty_ref    => $allow_empty_ref,
  2303.    max_recipients     => $max_recipients,
  2304.    mailprog        => $mailprog,
  2305.    postmaster       => $postmaster,
  2306.    referers        => [@referers],
  2307.    allow_mail_to     => [@allow_mail_to],
  2308.    recipients       => [@recipients],
  2309.    recipient_alias    => {%recipient_alias},
  2310.    valid_ENV       => [@valid_ENV],
  2311.    locale         => $locale,
  2312.    charset        => $charset,
  2313.    date_fmt        => $date_fmt,
  2314.    style         => $style,
  2315.    no_content       => $no_content,
  2316.    double_spacing     => $double_spacing,
  2317.    wrap_text       => $wrap_text,
  2318.    wrap_style       => $wrap_style,
  2319.    send_confirmation_mail => $send_confirmation_mail,
  2320.    confirmation_text   => $confirmation_text,
  2321.    address_style     => $address_style,
  2322.    %more_config
  2323.  );
  2324. }
  2325. $script->request;
  • Bigwebmaster
  • Site Admin
  • Site Admin
  • User avatar
  • Posts: 9090
  • Loc: Seattle, WA & Phoenix, AZ

Post 3+ Months Ago

According to the DOCS:

Quote:
$postmaster - The envelope sender address to use for all emails
sent by the script. This address will recieve bounce
messages if any of the emails cannot be delivered. If
in doubt, put your own email address here.


Seems like the variable you need to change/modify/use is $postmaster.
  • metalfury
  • Newbie
  • Newbie
  • User avatar
  • Posts: 6

Post 3+ Months Ago

Thanks Bigwebmaster I thought I'd tried that one, but will give it another go - may of got lost in the forest with all the changes and tests I'd tried!

I'll report back if it works :-)
  • this213
  • Guru
  • Guru
  • User avatar
  • Posts: 1260
  • Loc: ./

Post 3+ Months Ago

Code: [ Select ]
$mailprog = '/usr/lib/sendmail -f $from $to';

This can't parse $from and $to because they're in single quotes. Try something more like:
Code: [ Select ]
$mailprog = '/usr/lib/sendmail -f '.$from.' '.$to;
  • metalfury
  • Newbie
  • Newbie
  • User avatar
  • Posts: 6

Post 3+ Months Ago

Thanks @this123, I've a few things to try now. I'll report back when I've got it working. :-)

I've got a workaround that helped with the immediate deadline, but I want to do it properly, so will be giving these ideas a try.

Thanks again
  • metalfury
  • Newbie
  • Newbie
  • User avatar
  • Posts: 6

Post 3+ Months Ago

Hi Guys,

Thanks for the replies, I tried all the suggestions on the forums but unfortunately I didn't get anywhere with them. It's not to say any were wrong, but it turns out that the issue went a little further than just the $mailprog line.

After some fantastic assistance from Dave Cross at NMS the solution with the -f flag is:

  
Code: [ Select ]
$mailprog              =     '/usr/lib/sendmail -f @recipients';


However it also needed a tweak to the code further along. I've pasted below Dave's email in case anyone else needs to make the same change in the future.

Quote:
Looks to me like you're on the right lines. But you have a couple of problems.

Firstly, the recipients aren't known when we are setting the $mailprog variable, so you can't make your changes there.

You need to make the change in the email_start() function that actually makes the connection to sendmail. That starts on line 591 of the version I'm looking at - but you might be looking at a different version with different line numbers.

In there we create an variable, $command, which contains the sendmail command line we are going to use. And the function knows the list of recipients - they are in an array called @recipients.

There's a line that adds the postmaster address to the command. It looks like this:

 
Code: [ Select ]
$command = qq{ -f "$postmaster"} if $postmaster;


If think that all we need to do is to add the recipients on the line after that.

Code: [ Select ]
 $command = ' ' . join ' ', @recipients;



Thanks again

Rob

Post Information

  • Total Posts in this topic: 7 posts
  • Users browsing this forum: No registered users and 55 guests
  • You cannot post new topics in this forum
  • You cannot reply to topics in this forum
  • You cannot edit your posts in this forum
  • You cannot delete your posts in this forum
  • You cannot post attachments in this forum
 
cron
 

© 1998-2014. Ozzu® is a registered trademark of Unmelted, LLC.