"Fossies" - the Fresh Open Source Software Archive

Member "formmail_compat-3.14c1/FormMail.pl" (11 Aug 2004, 76909 Bytes) of package /linux/www/old/formmail_compat-3.14c1.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "FormMail.pl" see the Fossies "Dox" file reference documentation.

    1 #!/usr/bin/perl -wT
    2 #
    3 # NMS FormMail Version 3.14c1
    4 #
    5 
    6 use strict;
    7 use vars qw(
    8   $DEBUGGING $emulate_matts_code $secure %more_config
    9   $allow_empty_ref $max_recipients $mailprog @referers
   10   @allow_mail_to @recipients %recipient_alias
   11   @valid_ENV $date_fmt $style $send_confirmation_mail
   12   $confirmation_text $locale $charset $no_content
   13   $double_spacing $wrap_text $wrap_style $postmaster 
   14   $address_style
   15 );
   16 
   17 # PROGRAM INFORMATION
   18 # -------------------
   19 # FormMail.pl Version 3.14c1
   20 #
   21 # This program is licensed in the same way as Perl
   22 # itself. You are free to choose between the GNU Public
   23 # License <http://www.gnu.org/licenses/gpl.html>  or
   24 # the Artistic License
   25 # <http://www.perl.com/pub/a/language/misc/Artistic.html>
   26 #
   27 # For help on configuration or installation see the
   28 # README file or the POD documentation at the end of
   29 # this file.
   30 
   31 # USER CONFIGURATION SECTION
   32 # --------------------------
   33 # Modify these to your own settings. You might have to
   34 # contact your system administrator if you do not run
   35 # your own web server. If the purpose of these
   36 # parameters seems unclear, please see the README file.
   37 #
   38 BEGIN
   39 {
   40   $DEBUGGING         = 1;
   41   $emulate_matts_code= 0;
   42   $secure            = 1;
   43   $allow_empty_ref   = 1;
   44   $max_recipients    = 5;
   45   $mailprog          = '/usr/lib/sendmail -oi -t';
   46   $postmaster        = '';
   47   @referers          = qw(dave.org.uk 209.207.222.64 localhost);
   48   @allow_mail_to     = qw(you@your.domain some.one.else@your.domain localhost);
   49   @recipients        = ();
   50   %recipient_alias   = ();
   51   @valid_ENV         = qw(REMOTE_HOST REMOTE_ADDR REMOTE_USER HTTP_USER_AGENT);
   52   $locale            = '';
   53   $charset           = 'iso-8859-1';
   54   $date_fmt          = '%A, %B %d, %Y at %H:%M:%S';
   55   $style             = '/css/nms.css';
   56   $no_content        = 0;
   57   $double_spacing    = 1;
   58   $wrap_text         = 0;
   59   $wrap_style        = 1;
   60   $address_style     = 0;
   61   $send_confirmation_mail = 0;
   62   $confirmation_text = <<'END_OF_CONFIRMATION';
   63 From: you@your.com
   64 Subject: form submission
   65 
   66 Thank you for your form submission.
   67 
   68 END_OF_CONFIRMATION
   69 
   70 # You may need to uncomment the line below and adjust the path.
   71 # use lib './lib';
   72 
   73 # USER CUSTOMISATION SECTION
   74 # --------------------------
   75 # Place any custom code here
   76 
   77 
   78 
   79 # USER CUSTOMISATION << END >>
   80 # ----------------------------
   81 # (no user serviceable parts beyond here)
   82 }
   83 
   84 #
   85 # The code below consists of module source inlined into this
   86 # script to make it a standalone CGI.
   87 #
   88 # Inlining performed by NMS inline - see /v2/buildtools/inline
   89 # in CVS at http://sourceforge.net/projects/nms-cgi for details.
   90 #
   91 BEGIN {
   92 
   93 
   94 $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer = <<'END_INLINED_CGI_NMS_Mailer';
   95 package CGI::NMS::Mailer;
   96 use strict;
   97 
   98 use POSIX qw(strftime);
   99 
  100 =head1 NAME
  101 
  102 CGI::NMS::Mailer - email sender base class
  103 
  104 =head1 SYNOPSYS
  105 
  106   use base qw(CGI::NMS::Mailer);
  107 
  108   ...
  109 
  110 =head1 DESCRIPTION
  111 
  112 This is a base class for classes implementing low-level email
  113 sending objects for use within CGI scripts.
  114 
  115 =head1 METHODS
  116 
  117 =over
  118 
  119 =item output_trace_headers ( TRACEINFO )
  120 
  121 Uses the print() virtual method to output email abuse tracing headers
  122 including whatever useful information can be gleaned from the CGI
  123 environment variables.
  124 
  125 The TRACEINFO parameter should be a short string giving the name and
  126 version of the CGI script.
  127 
  128 =cut
  129 
  130 sub output_trace_headers {
  131   my ($self, $traceinfo) = @_;
  132 
  133   $ENV{REMOTE_ADDR} =~ /^\[?([\d\.\:a-f]{7,100})\]?$/i or die
  134      "failed to get remote address from [$ENV{REMOTE_ADDR}], so can't send traceable email";
  135   $self->print("Received: from [$1]\n");
  136 
  137   my $me = ($ENV{SERVER_NAME} =~ /^([\w\-\.]{1,100})$/ ? $1 : 'unknown');
  138   $self->print("\tby $me ($traceinfo)\n");
  139 
  140   my $date = strftime '%a, %e %b %Y %H:%M:%S GMT', gmtime;
  141   $self->print("\twith HTTP; $date\n");
  142 
  143   if ($ENV{SCRIPT_NAME} =~ /^([\w\-\.\/]{1,100})$/) {
  144     $self->print("\t(script-name $1)\n");
  145   }
  146 
  147   if (defined $ENV{HTTP_HOST} and $ENV{HTTP_HOST} =~ /^([\w\-\.]{1,100})$/) {
  148     $self->print("\t(http-host $1)\n");
  149   }
  150 
  151   my $ff = $ENV{HTTP_X_FORWARDED_FOR};
  152   if (defined $ff) {
  153     $ff =~ /^\s*([\w\-\.\[\] ,]{1,200})\s*/ or die
  154       "malformed X-Forwarded-For [$ff], suspect attack, aborting";
  155 
  156     $self->print("\t(http-x-forwarded-for $1)\n");
  157   }
  158 
  159   my $ref = $ENV{HTTP_REFERER};
  160   if (defined $ref and $ref =~ /^([\w\-\.\/\:\;\%\@\#\~\=\+\?]{1,100})$/) {
  161     $self->print("\t(http-referer $1)\n");
  162   }
  163 }
  164 
  165 =back
  166 
  167 =head1 VIRTUAL METHODS
  168 
  169 Subclasses must implement the following methods:
  170 
  171 =over
  172 
  173 =item newmail ( TRACEINFO, SENDER, @RECIPIENTS )
  174 
  175 Starts a new email.  TRACEINFO is the script name and version, SENDER is
  176 the email address to use as the envelope sender and @RECIPIENTS is a list
  177 of recipients.  Dies on error.
  178 
  179 =item print ( @ARGS )
  180 
  181 Concatenates the arguments and appends them to the email.  Both the
  182 header and the body should be sent in this way, separated by a single
  183 blank line.  Dies on error.
  184 
  185 =item endmail ()
  186 
  187 Finishes the email, flushing buffers and sending it.  Dies on error.
  188 
  189 =back
  190 
  191 =head1 SEE ALSO
  192 
  193 L<CGI::NMS::Mailer::Sendmail>, L<CGI::NMS::Mailer::SMTP>,
  194 L<CGI::NMS::Script>
  195 
  196 =head1 MAINTAINERS
  197 
  198 The NMS project, E<lt>http://nms-cgi.sourceforge.net/E<gt>
  199 
  200 To request support or report bugs, please email
  201 E<lt>nms-cgi-support@lists.sourceforge.netE<gt>
  202 
  203 =head1 COPYRIGHT
  204 
  205 Copyright 2003 London Perl Mongers, All rights reserved
  206 
  207 =head1 LICENSE
  208 
  209 This module is free software; you are free to redistribute it
  210 and/or modify it under the same terms as Perl itself.
  211 
  212 =cut
  213 
  214 1;
  215 
  216 
  217 END_INLINED_CGI_NMS_Mailer
  218 
  219 
  220 $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer_SMTP = <<'END_INLINED_CGI_NMS_Mailer_SMTP';
  221 package CGI::NMS::Mailer::SMTP;
  222 use strict;
  223 
  224 use IO::Socket;
  225 BEGIN { 
  226 do {
  227   unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Mailer}) {
  228     eval $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer or die $@;
  229     $INC{'CGI/NMS/Mailer.pm'} = 1;
  230   }
  231   undef $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer; # to save memory
  232 };
  233 
  234  import CGI::NMS::Mailer }
  235 use base qw(CGI::NMS::Mailer);
  236 
  237 =head1 NAME
  238 
  239 CGI::NMS::Mailer::SMTP - mail sender using SMTP
  240 
  241 =head1 SYNOPSYS
  242 
  243   my $mailer = CGI::NMS::Mailer::SMTP->new('mailhost.bigisp.net');
  244 
  245   $mailer->newmail($from, $to);
  246   $mailer->print($email_header_and_body);
  247   $mailer->endmail;
  248 
  249 =head1 DESCRIPTION
  250 
  251 This implementation of the mailer object defined in L<CGI::NMS::Mailer>
  252 uses an SMTP connection to a mail relay to send the email.
  253 
  254 =head1 CONSTRUCTORS
  255 
  256 =over
  257 
  258 =item new ( MAILHOST )
  259 
  260 MAILHOST must be the name or dotted decimal IP address of an SMTP
  261 server that will relay mail for the web server.
  262 
  263 =cut
  264 
  265 sub new {
  266   my ($pkg, $mailhost) = @_;
  267 
  268   $mailhost .= ':25' unless $mailhost =~ /:/;
  269   return bless { Mailhost => $mailhost }, $pkg;
  270 }
  271 
  272 =back
  273 
  274 =head1 METHODS
  275 
  276 See L<CGI::NMS::Mailer> for the user interface to these methods.
  277 
  278 =over
  279 
  280 =item newmail ( SCRIPTNAME, SENDER, @RECIPIENTS )
  281 
  282 Opens the SMTP connection and sends trace headers.
  283 
  284 =cut
  285 
  286 sub newmail {
  287   my ($self, $scriptname, $sender, @recipients) = @_;
  288 
  289   $self->{Sock} = IO::Socket::INET->new($self->{Mailhost});
  290   defined $self->{Sock} or die "connect to [$self->{Mailhost}]: $!";
  291 
  292   my $banner = $self->_smtp_response;
  293   $banner =~ /^2/ or die "bad SMTP banner [$banner] from [$self->{Mailhost}]";
  294 
  295   my $helohost = ($ENV{SERVER_NAME} =~ /^([\w\-\.]+)$/ ? $1 : '.');
  296   $self->_smtp_command("HELO $helohost");
  297   $self->_smtp_command("MAIL FROM:<$sender>");
  298   foreach my $r (@recipients) {
  299     $self->_smtp_command("RCPT TO:<$r>");
  300   }
  301   $self->_smtp_command("DATA", '3');
  302 
  303   $self->output_trace_headers($scriptname);
  304 }
  305 
  306 =item print ( @ARGS )
  307 
  308 Writes some email body to the SMTP socket.
  309 
  310 =cut
  311 
  312 sub print {
  313   my ($self, @args) = @_;
  314 
  315   my $text = join '', @args;
  316   $text =~ s#\n#\015\012#g;
  317   $text =~ s#^\.#..#mg;
  318 
  319   $self->{Sock}->print($text) or die "write to SMTP socket: $!";
  320 }
  321 
  322 =item endmail ()
  323 
  324 Finishes sending the mail and closes the SMTP connection.
  325 
  326 =cut
  327 
  328 sub endmail {
  329   my ($self) = @_;
  330 
  331   $self->_smtp_command(".");
  332   $self->_smtp_command("QUIT");
  333   delete $self->{Sock};
  334 }
  335 
  336 =back
  337 
  338 =head1 PRIVATE METHODS
  339 
  340 These methods should be called from within this module only.
  341 
  342 =over
  343 
  344 =item _smtp_getline ()
  345 
  346 Reads a line from the SMTP socket, and returns it as a string,
  347 including the terminating newline sequence.
  348 
  349 =cut
  350 
  351 sub _smtp_getline {
  352   my ($self) = @_;
  353 
  354   my $sock = $self->{Sock};
  355   my $line = <$sock>;
  356   defined $line or die "read from SMTP server: $!";
  357 
  358   return $line;
  359 }
  360 
  361 =item _smtp_response ()
  362 
  363 Reads a command response from the SMTP socket, and returns it as
  364 a single string.  A multiline responses is returned as a multiline
  365 string, and the terminating newline sequence is always included.
  366 
  367 =cut
  368 
  369 sub _smtp_response {
  370   my ($self) = @_;
  371 
  372   my $line = $self->_smtp_getline;
  373   my $resp = $line;
  374   while ($line =~ /^\d\d\d\-/) {
  375     $line = $self->_smtp_getline;
  376     $resp .= $line;
  377   }
  378   return $resp;
  379 }
  380 
  381 =item _smtp_command ( COMMAND [,EXPECT] )
  382 
  383 Sends the SMTP command COMMAND to the SMTP server, and reads a line
  384 in response.  Dies unless the first character of the response is
  385 the character EXPECT, which defaults to '2'.
  386 
  387 =cut
  388 
  389 sub _smtp_command {
  390   my ($self, $command, $expect) = @_;
  391   defined $expect or $expect = '2';
  392 
  393   $self->{Sock}->print("$command\015\012") or die
  394     "write [$command] to SMTP server: $!";
  395   
  396   my $resp = $self->_smtp_response;
  397   unless (substr($resp, 0, 1) eq $expect) {
  398     die "SMTP command [$command] gave response [$resp]";
  399   }
  400 }
  401 
  402 =back
  403 
  404 =head1 MAINTAINERS
  405 
  406 The NMS project, E<lt>http://nms-cgi.sourceforge.net/E<gt>
  407 
  408 To request support or report bugs, please email
  409 E<lt>nms-cgi-support@lists.sourceforge.netE<gt>
  410 
  411 =head1 COPYRIGHT
  412 
  413 Copyright 2003 London Perl Mongers, All rights reserved
  414 
  415 =head1 LICENSE
  416 
  417 This module is free software; you are free to redistribute it
  418 and/or modify it under the same terms as Perl itself.
  419 
  420 =cut
  421 
  422 1;
  423   
  424 
  425 END_INLINED_CGI_NMS_Mailer_SMTP
  426 
  427 
  428 $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer_Sendmail = <<'END_INLINED_CGI_NMS_Mailer_Sendmail';
  429 package CGI::NMS::Mailer::Sendmail;
  430 use strict;
  431 
  432 use IO::File;
  433 BEGIN { 
  434 do {
  435   unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Mailer}) {
  436     eval $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer or die $@;
  437     $INC{'CGI/NMS/Mailer.pm'} = 1;
  438   }
  439   undef $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer; # to save memory
  440 };
  441 
  442  import CGI::NMS::Mailer }
  443 use base qw(CGI::NMS::Mailer);
  444 
  445 =head1 NAME
  446 
  447 CGI::NMS::Mailer::Sendmail - mail sender using sendmail
  448 
  449 =head1 SYNOPSYS
  450 
  451   my $mailer = CGI::NMS::Mailer::Sendmail->new('/usr/lib/sendmail -oi -t');
  452 
  453   $mailer->newmail($from, $to);
  454   $mailer->print($email_header_and_body);
  455   $mailer->endmail;
  456 
  457 =head1 DESCRIPTION
  458 
  459 This implementation of the mailer object defined in L<CGI::NMS::Mailer>
  460 uses a piped open to the UNIX sendmail program to send the email.
  461 
  462 =head1 CONSTRUCTORS
  463 
  464 =over
  465 
  466 =item new ( MAILPROG )
  467 
  468 MAILPROG must be the shell command to which a pipe is opened, including
  469 all nessessary switches to cause the sendmail program to read the email
  470 recipients from the header of the email.
  471 
  472 =cut
  473 
  474 sub new {
  475   my ($pkg, $mailprog) = @_;
  476 
  477   return bless { Mailprog => $mailprog }, $pkg;
  478 }
  479 
  480 =back
  481 
  482 =head1 METHODS
  483 
  484 See L<CGI::NMS::Mailer> for the user interface to these methods.
  485 
  486 =over
  487 
  488 =item newmail ( SCRIPTNAME, POSTMASTER, @RECIPIENTS )
  489 
  490 Opens the sendmail pipe and outputs trace headers.
  491 
  492 =cut
  493 
  494 sub newmail {
  495   my ($self, $scriptname, $postmaster, @recipients) = @_;
  496 
  497   my $command = $self->{Mailprog};
  498   $command .= qq{ -f "$postmaster"} if $postmaster;
  499   my $pipe;
  500   eval { local $SIG{__DIE__};
  501          $pipe = IO::File->new("| $command");
  502        };
  503   if ($@) {
  504     die $@ unless $@ =~ /Insecure directory/;
  505     delete $ENV{PATH};
  506     $pipe = IO::File->new("| $command");
  507   }
  508 
  509   die "Can't open mailprog [$command]\n" unless $pipe;
  510   $self->{Pipe} = $pipe;
  511 
  512   $self->output_trace_headers($scriptname);
  513 }
  514 
  515 =item print ( @ARGS )
  516 
  517 Writes some email body to the sendmail pipe.
  518 
  519 =cut
  520 
  521 sub print {
  522   my ($self, @args) = @_;
  523 
  524   $self->{Pipe}->print(@args) or die "write to sendmail pipe: $!";
  525 }
  526 
  527 =item endmail ()
  528 
  529 Closes the sendmail pipe.
  530 
  531 =cut
  532 
  533 sub endmail {
  534   my ($self) = @_;
  535 
  536   $self->{Pipe}->close or die "close sendmail pipe failed, mailprog=[$self->{Mailprog}]";
  537   delete $self->{Pipe};
  538 }
  539 
  540 =back
  541 
  542 =head1 MAINTAINERS
  543 
  544 The NMS project, E<lt>http://nms-cgi.sourceforge.net/E<gt>
  545 
  546 To request support or report bugs, please email
  547 E<lt>nms-cgi-support@lists.sourceforge.netE<gt>
  548 
  549 =head1 COPYRIGHT
  550 
  551 Copyright 2003 London Perl Mongers, All rights reserved
  552 
  553 =head1 LICENSE
  554 
  555 This module is free software; you are free to redistribute it
  556 and/or modify it under the same terms as Perl itself.
  557 
  558 =cut
  559 
  560 1;
  561   
  562 
  563 END_INLINED_CGI_NMS_Mailer_Sendmail
  564 
  565 
  566 unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Charset}) {
  567   eval <<'END_INLINED_CGI_NMS_Charset' or die $@;
  568 package CGI::NMS::Charset;
  569 use strict;
  570 
  571 require 5.00404;
  572 
  573 use vars qw($VERSION);
  574 $VERSION = sprintf '%d.%.2d', (q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/);
  575 
  576 =head1 NAME
  577 
  578 CGI::NMS::Charset - a charset-aware object for handling text strings
  579 
  580 =head1 SYNOPSIS
  581 
  582   my $cs = CGI::NMS::Charset->new('iso-8859-1');
  583 
  584   my $safe_to_put_in_html = $cs->escape($untrusted_user_input);
  585 
  586   my $printable = &{ $cs->strip_nonprint_coderef }( $input );
  587   my $escaped = &{ $cs->escape_html_coderef }( $printable );
  588 
  589 =head1 DESCRIPTION
  590 
  591 Each object of class C<CGI::NMS::Charset> is bound to a particular
  592 character set when it is created.  The object provides methods to
  593 generate coderefs to perform a couple of character set dependent
  594 operations on text strings.
  595 
  596 =cut
  597 
  598 =head1 CONSTRUCTORS
  599 
  600 =over
  601 
  602 =item new ( CHARSET )
  603 
  604 Creates a new C<CGI::NMS::Charset> object, suitable for handing text
  605 in the character set CHARSET.  The CHARSET parameter must be a
  606 character set string, such as C<us-ascii> or C<utf-8> for example.
  607 
  608 =cut
  609 
  610 sub new
  611 {
  612    my ($pkg, $charset) = @_;
  613 
  614    my $self = { CHARSET => $charset };
  615 
  616    if ($charset =~ /^utf-8$/i)
  617    {
  618       $self->{SN} = \&_strip_nonprint_utf8;
  619       $self->{EH} = \&_escape_html_utf8;
  620    }
  621    elsif ($charset =~ /^iso-8859/i)
  622    {
  623       $self->{SN} = \&_strip_nonprint_8859;
  624       if ($charset =~ /^iso-8859-1$/i)
  625       {
  626          $self->{EH} = \&_escape_html_8859_1;
  627       }
  628       else
  629       {
  630          $self->{EH} = \&_escape_html_8859;
  631       }
  632    }
  633    elsif ($charset =~ /^us-ascii$/i)
  634    {
  635       $self->{SN} = \&_strip_nonprint_ascii;
  636       $self->{EH} = \&_escape_html_8859_1;
  637    }
  638    else
  639    {
  640       $self->{SN} = \&_strip_nonprint_weak;
  641       $self->{EH} = \&_escape_html_weak;
  642    }
  643 
  644    return bless $self, $pkg;
  645 }
  646 
  647 =back
  648 
  649 =head1 METHODS
  650 
  651 =over
  652 
  653 =item charset ()
  654 
  655 Returns the CHARSET string that was passed to the constructor.
  656 
  657 =cut
  658 
  659 sub charset
  660 {
  661    my ($self) = @_;
  662 
  663    return $self->{CHARSET};
  664 }
  665 
  666 =item escape ( STRING )
  667 
  668 Returns a copy of STRING with runs of non-printable characters
  669 replaced with spaces and HTML metacharacters replaced with the
  670 equivalent entities.
  671 
  672 If STRING is undef then the empty string will be returned.
  673 
  674 =cut
  675 
  676 sub escape
  677 {
  678    my ($self, $string) = @_;
  679 
  680    return &{ $self->{EH} }(  &{ $self->{SN} }($string)  );
  681 }
  682 
  683 =item strip_nonprint_coderef ()
  684 
  685 Returns a reference to a sub to replace runs of non-printable
  686 characters with spaces, in a manner suited to the charset in
  687 use.
  688 
  689 The returned coderef points to a sub that takes a single readonly
  690 string argument and returns a modified version of the string.  If
  691 undef is passed to the function then the empty string will be
  692 returned.
  693 
  694 =cut
  695 
  696 sub strip_nonprint_coderef
  697 {
  698    my ($self) = @_;
  699 
  700    return $self->{SN};
  701 }
  702 
  703 =item escape_html_coderef ()
  704 
  705 Returns a reference to a sub to escape HTML metacharacters in
  706 a manner suited to the charset in use.
  707 
  708 The returned coderef points to a sub that takes a single readonly
  709 string argument and returns a modified version of the string.
  710 
  711 =cut
  712 
  713 sub escape_html_coderef
  714 {
  715    my ($self) = @_;
  716 
  717    return $self->{EH};
  718 }
  719 
  720 =back
  721 
  722 =head1 DATA TABLES
  723 
  724 =over
  725 
  726 =item C<%eschtml_map>
  727 
  728 The C<%eschtml_map> hash maps C<iso-8859-1> characters to the
  729 equivalent HTML entities.
  730 
  731 =cut
  732 
  733 use vars qw(%eschtml_map);
  734 %eschtml_map = ( 
  735                  ( map {chr($_) => "&#$_;"} (0..255) ),
  736                  '<' => '&lt;',
  737                  '>' => '&gt;',
  738                  '&' => '&amp;',
  739                  '"' => '&quot;',
  740                );
  741 
  742 =back
  743 
  744 =head1 PRIVATE FUNCTIONS
  745 
  746 These functions are returned by the strip_nonprint_coderef() and
  747 escape_html_coderef() methods and invoked by the escape() method.
  748 The function most appropriate to the character set in use will be
  749 chosen.
  750 
  751 =over
  752 
  753 =item _strip_nonprint_utf8
  754 
  755 Returns a copy of STRING with everything but printable C<us-ascii>
  756 characters and valid C<utf-8> multibyte sequences replaced with
  757 space characters.
  758 
  759 =cut
  760 
  761 sub _strip_nonprint_utf8
  762 {
  763    my ($string) = @_;
  764    return '' unless defined $string;
  765 
  766    $string =~
  767    s%
  768     ( [\t\n\040-\176]               # printable us-ascii
  769     | [\xC2-\xDF][\x80-\xBF]        # U+00000080 to U+000007FF
  770     | \xE0[\xA0-\xBF][\x80-\xBF]    # U+00000800 to U+00000FFF
  771     | [\xE1-\xEF][\x80-\xBF]{2}     # U+00001000 to U+0000FFFF
  772     | \xF0[\x90-\xBF][\x80-\xBF]{2} # U+00010000 to U+0003FFFF
  773     | [\xF1-\xF7][\x80-\xBF]{3}     # U+00040000 to U+001FFFFF
  774     | \xF8[\x88-\xBF][\x80-\xBF]{3} # U+00200000 to U+00FFFFFF
  775     | [\xF9-\xFB][\x80-\xBF]{4}     # U+01000000 to U+03FFFFFF
  776     | \xFC[\x84-\xBF][\x80-\xBF]{4} # U+04000000 to U+3FFFFFFF
  777     | \xFD[\x80-\xBF]{5}            # U+40000000 to U+7FFFFFFF
  778     ) | .
  779    %
  780     defined $1 ? $1 : ' '
  781    %gexs;
  782 
  783    #
  784    # U+FFFE, U+FFFF and U+D800 to U+DFFF are dangerous and
  785    # should be treated as invalid combinations, according to
  786    # http://www.cl.cam.ac.uk/~mgk25/unicode.html
  787    #
  788    $string =~ s%\xEF\xBF[\xBE-\xBF]% %g;
  789    $string =~ s%\xED[\xA0-\xBF][\x80-\xBF]% %g;
  790 
  791    return $string;
  792 }
  793 
  794 =item _escape_html_utf8 ( STRING )
  795 
  796 Returns a copy of STRING with any HTML metacharacters
  797 escaped.  Escapes all but the most commonly occurring C<us-ascii>
  798 characters and bytes that might form part of valid C<utf-8>
  799 multibyte sequences.
  800 
  801 =cut
  802 
  803 sub _escape_html_utf8
  804 {
  805    my ($string) = @_;
  806 
  807    $string =~ s|([^\w \t\r\n\-\.\,\x80-\xFD])| $eschtml_map{$1} |ge;
  808    return $string;
  809 }
  810 
  811 =item _strip_nonprint_weak ( STRING )
  812 
  813 Returns a copy of STRING with sequences of NULL characters
  814 replaced with space characters.
  815 
  816 =cut
  817 
  818 sub _strip_nonprint_weak
  819 {
  820    my ($string) = @_;
  821    return '' unless defined $string;
  822 
  823    $string =~ s/\0+/ /g;
  824    return $string;
  825 }
  826    
  827 =item _escape_html_weak ( STRING )
  828 
  829 Returns a copy of STRING with any HTML metacharacters escaped.
  830 In order to work in any charset, escapes only E<lt>, E<gt>, C<">
  831 and C<&> characters.
  832 
  833 =cut
  834 
  835 sub _escape_html_weak
  836 {
  837    my ($string) = @_;
  838 
  839    $string =~ s/[<>"&]/$eschtml_map{$1}/eg;
  840    return $string;
  841 }
  842 
  843 =item _escape_html_8859_1 ( STRING )
  844 
  845 Returns a copy of STRING with all but the most commonly
  846 occurring printable characters replaced with HTML entities.
  847 Only suitable for C<us-ascii> or C<iso-8859-1> input.
  848 
  849 =cut
  850 
  851 sub _escape_html_8859_1
  852 {
  853    my ($string) = @_;
  854 
  855    $string =~ s|([^\w \t\r\n\-\.\,\/\:])| $eschtml_map{$1} |ge;
  856    return $string;
  857 }
  858 
  859 =item _escape_html_8859 ( STRING )
  860 
  861 Returns a copy of STRING with all but the most commonly
  862 occurring printable C<us-ascii> characters and characters
  863 that might be printable in some C<iso-8859-*> charset
  864 replaced with HTML entities.
  865 
  866 =cut
  867 
  868 sub _escape_html_8859
  869 {
  870    my ($string) = @_;
  871 
  872    $string =~ s|([^\w \t\r\n\-\.\,\/\:\240-\377])| $eschtml_map{$1} |ge;
  873    return $string;
  874 }
  875 
  876 =item _strip_nonprint_8859 ( STRING )
  877 
  878 Returns a copy of STRING with runs of characters that are not
  879 printable in any C<iso-8859-*> charset replaced with spaces.
  880 
  881 =cut
  882 
  883 sub _strip_nonprint_8859
  884 {
  885    my ($string) = @_;
  886    return '' unless defined $string;
  887 
  888    $string =~ tr#\t\n\040-\176\240-\377# #cs;
  889    return $string;
  890 }
  891 
  892 =item _strip_nonprint_ascii ( STRING )
  893 
  894 Returns a copy of STRING with runs of characters that are not
  895 printable C<us-ascii> replaced with spaces.
  896 
  897 =cut
  898 
  899 sub _strip_nonprint_ascii
  900 {
  901    my ($string) = @_;
  902    return '' unless defined $string;
  903 
  904    $string =~ tr#\t\n\040-\176# #cs;
  905    return $string;
  906 }
  907 
  908 =back
  909 
  910 =head1 MAINTAINERS
  911 
  912 The NMS project, E<lt>http://nms-cgi.sourceforge.net/E<gt>
  913 
  914 To request support or report bugs, please email
  915 E<lt>nms-cgi-support@lists.sourceforge.netE<gt>
  916 
  917 =head1 COPYRIGHT
  918 
  919 Copyright 2002-2003 London Perl Mongers, All rights reserved
  920 
  921 =head1 LICENSE
  922 
  923 This module is free software; you are free to redistribute it
  924 and/or modify it under the same terms as Perl itself.
  925 
  926 =cut
  927 
  928 1;
  929 
  930 
  931 END_INLINED_CGI_NMS_Charset
  932   $INC{'CGI/NMS/Charset.pm'} = 1;
  933 }
  934 
  935 
  936 unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Mailer::ByScheme}) {
  937   eval <<'END_INLINED_CGI_NMS_Mailer_ByScheme' or die $@;
  938 package CGI::NMS::Mailer::ByScheme;
  939 use strict;
  940 
  941 =head1 NAME
  942 
  943 CGI::NMS::Mailer::ByScheme - mail sending engine switch
  944 
  945 =head1 SYNOPSYS
  946 
  947   my $mailer = CGI::NMS::Mailer::ByScheme->new('/usr/lib/sendmail -oi -t');
  948 
  949   my $mailer = CGI::NMS::Mailer::ByScheme->new('SMTP:mailhost.bigisp.net');
  950 
  951 =head1 DESCRIPTION
  952 
  953 This implementation of the mailer object defined in L<CGI::NMS::Mailer>
  954 chooses between L<CGI::NMS::Mailer::SMTP> and L<CGI::NMS::Mailer::Sendmail>
  955 based on the string passed to new().
  956 
  957 =head1 CONSTRUCTORS
  958 
  959 =over
  960 
  961 =item new ( ARGUMENT )
  962 
  963 ARGUMENT must either be the string C<SMTP:> followed by the name or
  964 dotted decimal IP address of an SMTP server that will relay mail
  965 for the web server, or the path to a sendmail compatible binary,
  966 including switches.
  967 
  968 =cut
  969 
  970 sub new {
  971   my ($pkg, $argument) = @_;
  972 
  973   if ($argument =~ /^SMTP:([\w\-\.]+(:\d+)?)/i) {
  974     my $mailhost = $1;
  975     
  976 do {
  977   unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Mailer::SMTP}) {
  978     eval $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer_SMTP or die $@;
  979     $INC{'CGI/NMS/Mailer/SMTP.pm'} = 1;
  980   }
  981   undef $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer_SMTP; # to save memory
  982 };
  983 
  984 
  985     return CGI::NMS::Mailer::SMTP->new($mailhost);
  986   }
  987   else {
  988     
  989 do {
  990   unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Mailer::Sendmail}) {
  991     eval $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer_Sendmail or die $@;
  992     $INC{'CGI/NMS/Mailer/Sendmail.pm'} = 1;
  993   }
  994   undef $CGI::NMS::INLINED_SOURCE::CGI_NMS_Mailer_Sendmail; # to save memory
  995 };
  996 
  997 
  998     return CGI::NMS::Mailer::Sendmail->new($argument);
  999   }
 1000 }
 1001 
 1002 =back
 1003 
 1004 =head1 MAINTAINERS
 1005 
 1006 The NMS project, E<lt>http://nms-cgi.sourceforge.net/E<gt>
 1007 
 1008 To request support or report bugs, please email
 1009 E<lt>nms-cgi-support@lists.sourceforge.netE<gt>
 1010 
 1011 =head1 COPYRIGHT
 1012 
 1013 Copyright 2003 London Perl Mongers, All rights reserved
 1014 
 1015 =head1 LICENSE
 1016 
 1017 This module is free software; you are free to redistribute it
 1018 and/or modify it under the same terms as Perl itself.
 1019 
 1020 =cut
 1021 
 1022 1;
 1023   
 1024 
 1025 END_INLINED_CGI_NMS_Mailer_ByScheme
 1026   $INC{'CGI/NMS/Mailer/ByScheme.pm'} = 1;
 1027 }
 1028 
 1029 
 1030 unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Script}) {
 1031   eval <<'END_INLINED_CGI_NMS_Script' or die $@;
 1032 package CGI::NMS::Script;
 1033 use strict;
 1034 
 1035 use CGI;
 1036 use POSIX qw(locale_h strftime);
 1037 use CGI::NMS::Charset;
 1038 
 1039 =head1 NAME
 1040 
 1041 CGI::NMS::Script - base class for NMS script modules
 1042 
 1043 =head1 SYNOPSYS
 1044 
 1045   use base qw(CGI::NMS::Script);
 1046 
 1047   ...
 1048  
 1049 =head1 DESCRIPTION
 1050 
 1051 This module is a base class for the C<CGI::NMS::Script::*> modules,
 1052 which implement plugin replacements for Matt Wright's Perl CGI
 1053 scripts.
 1054 
 1055 =head1 CONSTRUCTORS
 1056 
 1057 =over
 1058 
 1059 =item new ( CONFIG )
 1060 
 1061 Creates a new C<CGI::NMS::Script> object and performs compile time
 1062 initialisation.
 1063 
 1064 CONFIG is a key,value,key,value list, which will be stored as a hash
 1065 within the object, under the name C<CFG>.
 1066 
 1067 =cut
 1068 
 1069 sub new {
 1070   my ($pkg, @cfg) = @_;
 1071 
 1072   my $self = bless {}, $pkg;
 1073 
 1074   $self->{CFG} = {
 1075     DEBUGGING           => 0,
 1076     emulate_matts_code  => 0,
 1077     secure              => 1,
 1078     locale              => '',
 1079     charset             => 'iso-8859-1',
 1080     style               => '',
 1081     cgi_post_max        => 1000000,
 1082     cgi_disable_uploads => 1,
 1083 
 1084     $self->default_configuration,
 1085 
 1086     @cfg
 1087   };
 1088 
 1089   $self->{Charset} = CGI::NMS::Charset->new( $self->{CFG}{charset} );
 1090 
 1091   $self->init;
 1092 
 1093   return $self;
 1094 }
 1095 
 1096 =back
 1097 
 1098 =item CONFIGURATION SETTINGS
 1099 
 1100 Values for the following configuration settings can be passed to new().
 1101 
 1102 Subclasses for different NMS scripts will define their own set of
 1103 configuration settings, but they all inherit these as well.
 1104 
 1105 =over
 1106 
 1107 =item C<DEBUGGING>
 1108 
 1109 If this is set to a true value, then the error message will be displayed
 1110 in the browser if the script suffers a fatal error.  This should be set
 1111 to 0 once the script is in service, since error messages may contain
 1112 sensitive information such as file paths which could be useful to
 1113 attackers.
 1114 
 1115 Default: 0
 1116 
 1117 =item C<name_and_version>
 1118 
 1119 The name and version of the NMS script, as a single string.
 1120 
 1121 =item C<emulate_matts_code>
 1122 
 1123 When this variable is set to a true value (e.g. 1) the script will work
 1124 in exactly the same way as its counterpart at Matt's Script Archive. If
 1125 it is set to a false value (e.g. 0) then more advanced features and
 1126 security checks are switched on. We do not recommend changing this 
 1127 variable to 1, as the resulting drop in security may leave your script
 1128 open to abuse.
 1129 
 1130 Default: 0
 1131 
 1132 =item C<secure>
 1133 
 1134 When this variable is set to a true value (e.g. 1) many additional
 1135 security features are turned on.  We do not recommend changing this
 1136 variable to 0, as the resulting drop in security may leave your script
 1137 open to abuse.
 1138 
 1139 Default: 1
 1140 
 1141 =item C<locale>
 1142 
 1143 This determines the language that is used in the format_date() method -
 1144 by default this is blank and the language will probably be English.
 1145 
 1146 Default: ''
 1147 
 1148 =item C<charset>
 1149 
 1150 The character set to use for output documents.
 1151 
 1152 Default: 'iso-8859-1'
 1153 
 1154 =item C<style>
 1155 
 1156 This is the URL of a CSS stylesheet which will be used for script
 1157 generated messages.  This should probably be the same as the one that
 1158 you use for all the other pages.  This should be a local absolute URI
 1159 fragment.  Set C<style> to 0 or the empty string if you don't want to
 1160 use style sheets.
 1161 
 1162 Default: '';
 1163 
 1164 =item C<cgi_post_max>
 1165 
 1166 The variable C<$CGI::POST_MAX> is gets set to this value before the
 1167 request is handled.
 1168 
 1169 Default: 1000000
 1170 
 1171 =item C<cgi_disable_uploads>
 1172 
 1173 The variable C<CGI::DISABLE_UPLOADS> gets set to this value before
 1174 the request is handled.
 1175 
 1176 Default: 1
 1177 
 1178 =item C<no_xml_doc_header>
 1179 
 1180 If this is set to a true value then the output_cgi_html_header() method
 1181 will omit the XML document header that it would normally output.  This
 1182 means that the output document will not be strictly valid XHTML, but it
 1183 may work better in some older browsers.
 1184 
 1185 Default: not set
 1186 
 1187 =item C<no_doctype_doc_header>
 1188 
 1189 If this is set to a true value then the output_cgi_html_header() method
 1190 will omit the DOCTYPE document header that it would normally output.
 1191 This means that the output document will not be strictly valid XHTML, but
 1192 it may work better in some older browsers.
 1193 
 1194 Default: not set
 1195 
 1196 =item C<no_xmlns_doc_header>
 1197 
 1198 If this is set to a true value then the output_cgi_html_header() method
 1199 will omit the C<xmlns> attribute from the opening C<html> tag that it
 1200 outputs.
 1201 
 1202 =back
 1203 
 1204 =head1 METHODS
 1205 
 1206 =over
 1207 
 1208 =item request ()
 1209 
 1210 This is the method that the CGI script invokes once for each run of the
 1211 CGI.  This implementation sets up some things that are common to all NMS
 1212 scripts and then invokes the virtual method handle_request() to do the
 1213 script specific processing.
 1214 
 1215 =cut
 1216 
 1217 sub request {
 1218   my ($self) = @_;
 1219 
 1220   local ($CGI::POST_MAX, $CGI::DISABLE_UPLOADS);
 1221   $CGI::POST_MAX        = $self->{CFG}{cgi_post_max};
 1222   $CGI::DISABLE_UPLOADS = $self->{CFG}{cgi_disable_uploads};
 1223 
 1224   $ENV{PATH} =~ /(.*)/m or die;
 1225   local $ENV{PATH} = $1;
 1226   local $ENV{ENV}  = '';
 1227 
 1228   $self->{CGI} = CGI->new;
 1229   $self->{Done_Header} = 0;
 1230 
 1231   my $old_locale;
 1232   if ($self->{CFG}{locale}) {
 1233     $old_locale = POSIX::setlocale( LC_TIME );
 1234     POSIX::setlocale( LC_TIME, $self->{CFG}{locale} );
 1235   }
 1236 
 1237   eval { local $SIG{__DIE__} ; $self->handle_request };
 1238   my $err = $@;
 1239 
 1240   if ($self->{CFG}{locale}) {
 1241     POSIX::setlocale( LC_TIME, $old_locale );
 1242   }
 1243 
 1244   if ($err) {
 1245     my $message;
 1246     if ($self->{CFG}{DEBUGGING}) {
 1247       $message = $self->escape_html($err);
 1248     }
 1249     else {
 1250       $message = "See the web server's error log for details";
 1251     }
 1252 
 1253     $self->output_cgi_html_header;
 1254     print <<END;
 1255  <head>
 1256   <title>Error</title>
 1257  </head>
 1258  <body>
 1259   <h1>Application Error</h1>
 1260   <p>
 1261    An error has occurred in the program
 1262   </p>
 1263   <p>
 1264    $message
 1265   </p>
 1266  </body>
 1267 </html>
 1268 END
 1269 
 1270     $self->warn($err);
 1271   }
 1272 }
 1273 
 1274 =item output_cgi_html_header ()
 1275 
 1276 Prints the CGI content-type header and the standard header lines for
 1277 an XHTML document, unless the header has already been output.
 1278 
 1279 =cut
 1280 
 1281 sub output_cgi_html_header {
 1282   my ($self) = @_;
 1283 
 1284   return if $self->{Done_Header};
 1285 
 1286   $self->output_cgi_header;
 1287 
 1288   unless ($self->{CFG}{no_xml_doc_header}) {
 1289     print qq|<?xml version="1.0" encoding="$self->{CFG}{charset}"?>\n|;
 1290   }
 1291 
 1292   unless ($self->{CFG}{no_doctype_doc_header}) {
 1293     print <<END;
 1294 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 1295     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 1296 END
 1297   }
 1298 
 1299   if ($self->{CFG}{no_xmlns_doc_header}) {
 1300     print "<html>\n";
 1301   }
 1302   else {
 1303     print qq|<html xmlns="http://www.w3.org/1999/xhtml">\n|;
 1304   }
 1305 
 1306   $self->{Done_Header} = 1;
 1307 }
 1308 
 1309 =item output_cgi_header ()
 1310 
 1311 Outputs the CGI header for an HTML document.
 1312 
 1313 =cut
 1314 
 1315 sub output_cgi_header {
 1316   my ($self) = @_;
 1317 
 1318   my $charset = $self->{CFG}{charset};
 1319   my $cgi = $self->cgi_object;
 1320 
 1321   if ($CGI::VERSION >= 2.57) {
 1322     # This is the correct way to set the charset
 1323     print $cgi->header('-type'=>'text/html', '-charset'=>$charset);
 1324   }
 1325   else {
 1326     # However CGI.pm older than version 2.57 doesn't have the
 1327     # -charset option so we cheat:
 1328     print $cgi->header('-type' => "text/html; charset=$charset");
 1329   }
 1330 }
 1331 
 1332 =item output_style_element ()
 1333 
 1334 Outputs the C<link rel=stylesheet> header line, if a style sheet URL is
 1335 configured.
 1336 
 1337 =cut
 1338 
 1339 sub output_style_element {
 1340   my ($self) = @_;
 1341 
 1342   if ($self->{CFG}{style}) {
 1343     print qq|<link rel="stylesheet" type="text/css" href="$self->{CFG}{style}" />\n|;
 1344   }
 1345 }
 1346 
 1347 =item cgi_object ()
 1348 
 1349 Returns a reference to the C<CGI.pm> object for this request.
 1350 
 1351 =cut
 1352 
 1353 sub cgi_object {
 1354   my ($self) = @_;
 1355 
 1356    return $self->{CGI};
 1357 }
 1358 
 1359 =item param ( ARGS )
 1360 
 1361 Invokes the param() method of the C<CGI.pm> object for this request.
 1362 
 1363 =cut
 1364 
 1365 sub param {
 1366     my $self = shift;
 1367 
 1368     $self->cgi_object->param(@_);
 1369 }
 1370 
 1371 =item escape_html ( INPUT )
 1372 
 1373 Returns a copy of the string INPUT with all HTML metacharacters escaped.
 1374 
 1375 =cut
 1376 
 1377 sub escape_html {
 1378   my ($self, $input) = @_;
 1379 
 1380   return $self->{Charset}->escape($input);
 1381 }
 1382 
 1383 =item strip_nonprint ( INPUT )
 1384 
 1385 Returns a copy of the string INPUT with runs of nonprintable characters
 1386 replaced by spaces.
 1387 
 1388 =cut
 1389 
 1390 sub strip_nonprint {
 1391   my ($self, $input) = @_;
 1392 
 1393   &{ $self->{Charset}->strip_nonprint_coderef }($input);
 1394 }
 1395 
 1396 =item format_date ( FORMAT_STRING [,GMT_OFFSET] )
 1397 
 1398 Returns the current time and date formated by C<strftime> according
 1399 to the format string FORMAT_STRING.
 1400 
 1401 If GMT_OFFSET is undefined or the empty string then local time is
 1402 used.  Otherwise GMT is used, with an offset of GMT_OFFSET hours.
 1403 
 1404 =cut
 1405 
 1406 sub format_date {
 1407   my ($self, $format_string, $gmt_offset) = @_;
 1408 
 1409   if (defined $gmt_offset and length $gmt_offset) {
 1410     return strftime $format_string, gmtime(time + 60*60*$gmt_offset);
 1411   }
 1412   else {
 1413     return strftime $format_string, localtime;
 1414   }
 1415 }
 1416 
 1417 =item name_and_version ()
 1418 
 1419 Returns the NMS script version string that was passed to the constructor.
 1420 
 1421 =cut
 1422 
 1423 sub name_and_version {
 1424     my ($self) = @_;
 1425 
 1426     return $self->{CFG}{name_and_version};
 1427 }
 1428 
 1429 =item warn ( MESSAGE )
 1430 
 1431 Appends a message to the web server's error log.
 1432 
 1433 =cut
 1434 
 1435 sub warn {
 1436     my ($self, $msg) = @_;
 1437 
 1438     if ($ENV{SCRIPT_NAME} =~ m#^([\w\-\/\.\:]{1,100})$#) {
 1439         $msg = "$1: $msg";
 1440     }
 1441 
 1442     if ($ENV{REMOTE_ADDR} =~ /^\[?([\d\.\:a-f]{7,100})\]?$/i) {
 1443         $msg = "[$1] $msg";
 1444     }
 1445 
 1446     warn "$msg\n";
 1447 }
 1448 
 1449 =back
 1450 
 1451 =head1 VIRTUAL METHODS
 1452 
 1453 Subclasses for individual NMS scripts must provide the following
 1454 methods:
 1455 
 1456 =over
 1457 
 1458 =item default_configuration ()
 1459 
 1460 Invoked from new(), this method must return the default script
 1461 configuration as a key,value,key,value list.  Configuration options
 1462 passed to new() will override those set by this method.
 1463 
 1464 =item init ()
 1465 
 1466 Invoked from new(), this method can be used to do any script specific
 1467 object initialisation.  There is a default implementation, which does
 1468 nothing.
 1469 
 1470 =cut
 1471 
 1472 sub init {}
 1473 
 1474 =item handle_request ()
 1475 
 1476 Invoked from request(), this method is responsible for performing the
 1477 bulk of the CGI processing.  Any fatal errors raised here will be
 1478 trapped and treated according to the C<DEBUGGING> configuration setting.
 1479 
 1480 =back
 1481 
 1482 =head1 SEE ALSO
 1483 
 1484 L<CGI::NMS::Charset>, L<CGI::NMS::Script::FormMail>
 1485 
 1486 =head1 MAINTAINERS
 1487 
 1488 The NMS project, E<lt>http://nms-cgi.sourceforge.net/E<gt>
 1489 
 1490 To request support or report bugs, please email
 1491 E<lt>nms-cgi-support@lists.sourceforge.netE<gt>
 1492 
 1493 =head1 COPYRIGHT
 1494 
 1495 Copyright 2003 London Perl Mongers, All rights reserved
 1496 
 1497 =head1 LICENSE
 1498 
 1499 This module is free software; you are free to redistribute it
 1500 and/or modify it under the same terms as Perl itself.
 1501 
 1502 =cut
 1503 
 1504 1;
 1505 
 1506 
 1507 END_INLINED_CGI_NMS_Script
 1508   $INC{'CGI/NMS/Script.pm'} = 1;
 1509 }
 1510 
 1511 
 1512 unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Validator}) {
 1513   eval <<'END_INLINED_CGI_NMS_Validator' or die $@;
 1514 package CGI::NMS::Validator;
 1515 use strict;
 1516 
 1517 =head1 NAME
 1518 
 1519 CGI::NMS::Validator - validation methods
 1520 
 1521 =head1 SYNOPSYS
 1522 
 1523   use base qw(CGI::NMS::Validator);
 1524 
 1525   ...
 1526  
 1527   my $validurl = $self->validate_abs_url($url);
 1528 
 1529 =head1 DESCRIPTION
 1530 
 1531 This module provides methods to validate some of the types of
 1532 data the occur in CGI scripts, such as URLs and email addresses.
 1533 
 1534 =head1 METHODS
 1535 
 1536 These C<validate_*> methods all return undef if the item passed
 1537 in is invalid, otherwise they return the valid item.
 1538 
 1539 Some of these methods attempt to transform invalid input into valid
 1540 input (for example, validate_abs_url() will prepend http:// if missing)
 1541 so the returned valid item may not be the same as that passed in.
 1542 
 1543 The returned value is always detainted.
 1544 
 1545 =over
 1546 
 1547 =item validate_abs_url ( URL )
 1548 
 1549 Validates an absolute URL.
 1550 
 1551 =cut
 1552 
 1553 sub validate_abs_url {
 1554   my ($self, $url) = @_;
 1555 
 1556   $url = "http://$url" unless $url =~ /:/;
 1557   $url =~ s#^(\w+://)# lc $1 #e;
 1558 
 1559   $url =~ m< ^ ( (?:ftp|http|https):// [\w\-\.]{1,100} (?:\:\d{1,5})? ) ( /* (?:[^\./].*)? ) $ >mx
 1560     or return '';
 1561 
 1562   my ($prefix, $path) = ($1, $2);
 1563   return $prefix unless length $path;
 1564 
 1565   $path = $self->validate_local_abs_uri_frag($path);
 1566   return '' unless $path;
 1567   
 1568   return "$prefix$path";
 1569 }
 1570 
 1571 =item validate_local_abs_uri_frag ( URIFRAG )
 1572 
 1573 Validates a local absolute URI fragment, such as C</img/foo.png>.  Allows
 1574 a query string.  The empty string is considered to be a valid URI fragment.
 1575 
 1576 =cut
 1577 
 1578 sub validate_local_abs_uri_frag {
 1579   my ($self, $frag) = @_;
 1580 
 1581   $frag =~ m< ^ ( (?: \.* /  [\w\-.!~*'(|);/\@+\$,%#&=]* )?
 1582                   (?: \?     [\w\-.!~*'(|);/\@+\$,%#&=]* )?
 1583                 )
 1584               $
 1585            >x ? $1 : '';
 1586 }
 1587 
 1588 =item validate_url ( URL )
 1589 
 1590 Validates a URL, which can be either an absolute URL or a local absolute
 1591 URI fragment.
 1592 
 1593 =cut
 1594 
 1595 sub validate_url {
 1596   my ($self, $url) = @_;
 1597 
 1598   if ($url =~ m#://#) {
 1599     $self->validate_abs_url($url);
 1600   }
 1601   else {
 1602     $self->validate_local_abs_uri_frag($url);
 1603   }
 1604 }
 1605 
 1606 =item validate_email ( EMAIL )
 1607 
 1608 Validates an email address.
 1609 
 1610 =cut
 1611 
 1612 sub validate_email {
 1613   my ($self, $email) = @_;
 1614 
 1615   $email =~ /^([a-z0-9_\-\.\*\+\=]{1,100})\@([^@]{2,100})$/i or return 0;
 1616   my ($user, $host) = ($1, $2);
 1617 
 1618   return 0 if $host =~ m#^\.|\.$|\.\.#;
 1619 
 1620   if ($host =~ m#^\[\d+\.\d+\.\d+\.\d+\]$# or $host =~ /^[a-z0-9\-\.]+$/i ) {
 1621      return "$user\@$host";
 1622    }
 1623    else {
 1624      return 0;
 1625   }
 1626 }
 1627 
 1628 =item validate_realname ( REALNAME )
 1629 
 1630 Validates a real name, i.e. an email address comment field.
 1631 
 1632 =cut
 1633 
 1634 sub validate_realname {
 1635   my ($self, $realname) = @_;
 1636 
 1637   $realname =~ tr# a-zA-Z0-9_\-,./'\200-\377# #cs;
 1638   $realname = substr $realname, 0, 128;
 1639 
 1640   $realname =~ m#^([ a-zA-Z0-9_\-,./'\200-\377]*)$# or die "failed on [$realname]";
 1641   return $1;
 1642 }
 1643 
 1644 =item validate_html_color ( COLOR )
 1645 
 1646 Validates an HTML color, either as a named color or as RGB values in hex.
 1647 
 1648 =cut
 1649 
 1650 sub validate_html_color {
 1651   my ($self, $color) = @_;
 1652 
 1653   $color =~ /^(#[0-9a-z]{6}|[\w\-]{2,50})$/i ? $1 : '';
 1654 }
 1655 
 1656 =back
 1657 
 1658 =head1 SEE ALSO
 1659 
 1660 L<CGI::NMS::Script>
 1661 
 1662 =head1 MAINTAINERS
 1663 
 1664 The NMS project, E<lt>http://nms-cgi.sourceforge.net/E<gt>
 1665 
 1666 To request support or report bugs, please email
 1667 E<lt>nms-cgi-support@lists.sourceforge.netE<gt>
 1668 
 1669 =head1 COPYRIGHT
 1670 
 1671 Copyright 2003 London Perl Mongers, All rights reserved
 1672 
 1673 =head1 LICENSE
 1674 
 1675 This module is free software; you are free to redistribute it
 1676 and/or modify it under the same terms as Perl itself.
 1677 
 1678 =cut
 1679 
 1680 1;
 1681 
 1682 
 1683 END_INLINED_CGI_NMS_Validator
 1684   $INC{'CGI/NMS/Validator.pm'} = 1;
 1685 }
 1686 
 1687 
 1688 unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Script::FormMail}) {
 1689   eval <<'END_INLINED_CGI_NMS_Script_FormMail' or die $@;
 1690 package CGI::NMS::Script::FormMail;
 1691 use strict;
 1692 
 1693 use vars qw($VERSION);
 1694 $VERSION = substr q$Revision: 1.12 $, 10, -1;
 1695 
 1696 use Socket;  # for the inet_aton()
 1697 
 1698 use CGI::NMS::Script;
 1699 use CGI::NMS::Validator;
 1700 use CGI::NMS::Mailer::ByScheme;
 1701 use base qw(CGI::NMS::Script CGI::NMS::Validator);
 1702 
 1703 =head1 NAME
 1704 
 1705 CGI::NMS::Script::FormMail - FormMail CGI script
 1706 
 1707 =head1 SYNOPSIS
 1708 
 1709   #!/usr/bin/perl -wT
 1710   use strict;
 1711 
 1712   use base qw(CGI::NMS::Script::FormMail);
 1713 
 1714   use vars qw($script);
 1715   BEGIN {
 1716     $script = __PACKAGE__->new(
 1717       'DEBUGGING'     => 1,
 1718       'postmaster'    => 'me@my.domain',
 1719       'allow_mail_to' => 'me@my.domain',
 1720     );
 1721   }
 1722 
 1723   $script->request;
 1724 
 1725 =head1 DESCRIPTION
 1726 
 1727 This module implements the NMS plugin replacement for Matt Wright's
 1728 FormMail.pl CGI script.
 1729 
 1730 =head1 CONFIGURATION SETTINGS
 1731 
 1732 As well as the generic NMS script configuration settings described in
 1733 L<CGI::NMS::Script>, the FormMail constructor recognizes the following
 1734 configuration settings:
 1735 
 1736 =over
 1737 
 1738 =item C<allow_empty_ref>
 1739 
 1740 Some web proxies and office firewalls may strip certain headers from the
 1741 HTTP request that is sent by a browser.  Among these is the HTTP_REFERER
 1742 that FormMail uses as an additional check of the requests validity - this
 1743 will cause the program to fail with a 'bad referer' message even though the
 1744 configuration seems fine.
 1745 
 1746 In these cases, setting this configuration setting to 1 will stop the
 1747 program from complaining about requests where no referer header was sent
 1748 while leaving the rest of the security features intact.
 1749 
 1750 Default: 1
 1751 
 1752 =item C<max_recipients>
 1753 
 1754 The maximum number of e-mail addresses that any single form should be
 1755 allowed to send copies of the e-mail to.  If none of your forms send
 1756 e-mail to more than one recipient, then we recommend that you improve
 1757 the security of FormMail by reducing this value to 1.  Setting this
 1758 configuration setting to 0 removes all limits on the number of recipients
 1759 of each e-mail.
 1760 
 1761 Default: 5
 1762 
 1763 =item C<mailprog>
 1764 
 1765 The system command that the script should invoke to send an outgoing email.
 1766 This should be the full path to a program that will read a message from
 1767 STDIN and determine the list of message recipients from the message headers.
 1768 Any switches that the program requires should be provided here.
 1769 
 1770 For example:
 1771 
 1772   'mailprog' => '/usr/lib/sendmail -oi -t',
 1773 
 1774 An SMTP relay can be specified instead of a sendmail compatible mail program,
 1775 using the prefix C<SMTP:>, for example:
 1776 
 1777   'mailprog' => 'SMTP:mailhost.your.domain',
 1778 
 1779 Default: C<'/usr/lib/sendmail -oi -t'>
 1780 
 1781 =item C<postmaster>
 1782 
 1783 The envelope sender address to use for all emails sent by the script.
 1784 
 1785 Default: ''
 1786 
 1787 =item C<referers>
 1788 
 1789 This configuration setting must be an array reference, holding a list  
 1790 of names and/or IP address of systems that will host forms that refer
 1791 to this FormMail.  An empty array here turns off all referer checking.
 1792 
 1793 Default: [] 
 1794 
 1795 =item C<allow_mail_to>
 1796 
 1797 This configuration setting must be an array reference.
 1798 
 1799 A list of the email addresses that FormMail can send email to. The
 1800 elements of this list can be either simple email addresses (like
 1801 'you@your.domain') or domain names (like 'your.domain'). If it's a
 1802 domain name then any address at that domain will be allowed.
 1803 
 1804 Default: []
 1805 
 1806 =item C<recipients>
 1807 
 1808 This configuration setting must be an array reference.
 1809 
 1810 A list of Perl regular expression patterns that determine who the
 1811 script will allow mail to be sent to in addition to those set in
 1812 C<allow_mail_to>.  This is present only for compatibility with the
 1813 original FormMail script.  We strongly advise against having anything
 1814 in C<recipients> as it's easy to make a mistake with the regular
 1815 expression syntax and turn your FormMail into an open SPAM relay.
 1816 
 1817 Default: []
 1818 
 1819 =item C<recipient_alias>
 1820 
 1821 This configuration setting must be a hash reference.
 1822 
 1823 A hash for predefining a list of recipients in the script, and then
 1824 choosing between them using the recipient form field, while keeping
 1825 all the email addresses out of the HTML so that they don't get
 1826 collected by address harvesters and sent junk email.
 1827 
 1828 For example, suppose you have three forms on your site, and you want
 1829 each to submit to a different email address and you want to keep the
 1830 addresses hidden.  You might set up C<recipient_alias> like this:
 1831 
 1832   %recipient_alias = (
 1833     '1' => 'one@your.domain',
 1834     '2' => 'two@your.domain',
 1835     '3' => 'three@your.domain',
 1836   );
 1837 
 1838 In the HTML form that should submit to the recipient C<two@your.domain>,
 1839 you would then set the recipient with:
 1840 
 1841   <input type="hidden" name="recipient" value="2" />
 1842 
 1843 Default: {}
 1844 
 1845 =item C<valid_ENV>
 1846 
 1847 This configuration setting must be an array reference.
 1848 
 1849 A list of all the environment variables that you want to be able to
 1850 include in the email.
 1851 
 1852 Default: ['REMOTE_HOST','REMOTE_ADDR','REMOTE_USER','HTTP_USER_AGENT']
 1853 
 1854 =item C<date_fmt>
 1855 
 1856 The format that the date will be displayed in, as a string suitable for
 1857 passing to strftime().
 1858 
 1859 Default: '%A, %B %d, %Y at %H:%M:%S'
 1860 
 1861 =item C<date_offset>
 1862 
 1863 The empty string to use local time for the date, or an offset from GMT
 1864 in hours to fix the timezone independent of the server's locale settings.
 1865 
 1866 Default: ''
 1867 
 1868 =item C<no_content>
 1869 
 1870 If this is set to 1 then rather than returning the HTML confirmation page
 1871 or doing a redirect the script will output a header that indicates that no
 1872 content will be returned and that the submitted form should not be
 1873 replaced.  This should be used carefully as an unwitting visitor may click
 1874 the submit button several times thinking that nothing has happened.
 1875 
 1876 Default: 0
 1877 
 1878 =item C<double_spacing>
 1879 
 1880 If this is set to 1 then a blank line is printed after each form value in
 1881 the e-mail.  Change this value to 0 if you want the e-mail to be more
 1882 compact.
 1883 
 1884 Default: 1
 1885 
 1886 =item C<join_string>
 1887 
 1888 If an input occurs multiple times, the values are joined to make a
 1889 single string value.  The value of this configuration setting is
 1890 inserted between each value when they are joined.
 1891 
 1892 Default: ' '
 1893 
 1894 =item C<wrap_text>
 1895 
 1896 If this is set to 1 then the content of any long text fields will be
 1897 wrapped at around 72 columns in the e-mail which is sent.  The way that
 1898 this is done is controlled by the C<wrap_style> configuration setting.
 1899 
 1900 Default: 0
 1901 
 1902 =item C<wrap_style>
 1903 
 1904 If C<wrap_text> is set to 1 then if this is set to 1 then the text will
 1905 be wrapped in such a way that the left margin of the text is lined up
 1906 with the beginning of the text after the description of the field -
 1907 that is to say it is indented by the length of the field name plus 2.
 1908 
 1909 If it is set to 2 then the subsequent lines of the text will not be
 1910 indented at all and will be flush with the start of the lines.  The
 1911 choice of style is really a matter of taste although you might find
 1912 that style 1 does not work particularly well if your e-mail client
 1913 uses a proportional font where the spaces of the indent might be
 1914 smaller than the characters in the field name.
 1915 
 1916 Default: 1
 1917 
 1918 =item C<address_style>
 1919 
 1920 If C<address_style> is set to 0 then the full address for the user who filled
 1921 in the form will be used as "$email ($realname)" - this is also what the
 1922 format will be if C<emulate_matts_code> is true.
 1923 
 1924 If it is set to 1 then the address format will be "$realname <$email>".
 1925 
 1926 Default: 0
 1927 
 1928 =item C<force_config_*>
 1929 
 1930 Configuration settings of this form can be used to fix configuration
 1931 settings that would normally be set in hidden form fields.  For
 1932 example, to force the email subject to be "Foo" irrespective of what's
 1933 in the C<subject> form field, you would set:
 1934 
 1935   'force_config_subject' => 'Foo',
 1936 
 1937 Default: none set
 1938 
 1939 =item C<include_config_*>
 1940 
 1941 Configuration settings of this form can be used to treat particular
 1942 configuration inputs as normal data inputs as well as honoring their
 1943 special meaning.  For example, a user might use C<include_config_email>
 1944 to include the email address as a regular input as well as using it in
 1945 the email header.
 1946 
 1947 Default: none set
 1948 
 1949 =back
 1950 
 1951 =head1 COMPILE TIME METHODS
 1952 
 1953 These methods are invoked at CGI script compile time only, so long as
 1954 the new() call is placed inside a BEGIN block as shown above.
 1955 
 1956 =over
 1957 
 1958 =item default_configuration ()
 1959 
 1960 Returns the default values for the configuration passed to the new()
 1961 method, as a key,value,key,value list.
 1962 
 1963 =cut
 1964 
 1965 sub default_configuration {
 1966   return ( 
 1967     allow_empty_ref        => 1,
 1968     max_recipients         => 5,
 1969     mailprog               => '/usr/lib/sendmail -oi -t',
 1970     postmaster             => '',
 1971     referers               => [],
 1972     allow_mail_to          => [],
 1973     recipients             => [],
 1974     recipient_alias        => {},
 1975     valid_ENV              => [qw(REMOTE_HOST REMOTE_ADDR REMOTE_USER HTTP_USER_AGENT)],
 1976     date_fmt               => '%A, %B %d, %Y at %H:%M:%S',
 1977     date_offset            => '',
 1978     no_content             => 0,
 1979     double_spacing         => 1,
 1980     join_string            => ' ',
 1981     wrap_text              => 0,
 1982     wrap_style             => 1,
 1983     address_style          => 0,
 1984   );
 1985 }
 1986 
 1987 =item init ()
 1988 
 1989 Invoked from the new() method inherited from L<CGI::NMS::Script>,
 1990 this method performs FormMail specific initialization of the script
 1991 object.
 1992 
 1993 =cut
 1994 
 1995 sub init {
 1996   my ($self) = @_;
 1997 
 1998   if ($self->{CFG}{wrap_text}) {
 1999     require Text::Wrap;
 2000     import  Text::Wrap;
 2001   }
 2002 
 2003   $self->{Valid_Env} = {  map {$_=>1} @{ $self->{CFG}{valid_ENV} }  };
 2004 
 2005   $self->init_allowed_address_list;
 2006 
 2007   $self->{Mailer} = CGI::NMS::Mailer::ByScheme->new($self->{CFG}{mailprog});
 2008 }
 2009 
 2010 =item init_allowed_address_list ()
 2011 
 2012 Invoked from init(), this method sets up a hash with a key for each
 2013 allowed recipient email address as C<Allow_Mail> and a hash with a
 2014 key for each domain at which any address is allowed as C<Allow_Domain>.
 2015 
 2016 =cut
 2017 
 2018 sub init_allowed_address_list {
 2019   my ($self) = @_;
 2020 
 2021   my @allow_mail = ();
 2022   my @allow_domain = ();
 2023 
 2024   foreach my $m (@{ $self->{CFG}{allow_mail_to} }) {
 2025     if ($m =~ /\@/) {
 2026       push @allow_mail, $m;
 2027     }
 2028     else {
 2029       push @allow_domain, $m;
 2030     }
 2031   }
 2032 
 2033   my @alias_targets = split /\s*,\s*/, join ',', values %{ $self->{CFG}{recipient_alias} };
 2034   push @allow_mail, grep /\@/, @alias_targets;
 2035 
 2036   # The username part of email addresses should be case sensitive, but the
 2037   # domain name part should not.  Map all domain names to lower case for
 2038   # comparison.
 2039   my (%allow_mail, %allow_domain);
 2040   foreach my $m (@allow_mail) {
 2041     $m =~ /^([^@]+)\@([^@]+)$/ or die "internal failure [$m]";
 2042     $m = $1 . '@' . lc $2;
 2043     $allow_mail{$m} = 1;
 2044   }
 2045   foreach my $m (@allow_domain) {
 2046     $m = lc $m;
 2047     $allow_domain{$m} = 1;
 2048   }
 2049 
 2050   $self->{Allow_Mail}   = \%allow_mail;
 2051   $self->{Allow_Domain} = \%allow_domain;
 2052 }
 2053 
 2054 =back
 2055 
 2056 =head1 RUN TIME METHODS
 2057 
 2058 These methods are invoked at script run time, as a result of the call
 2059 to the request() method inherited from L<CGI::NMS::Script>.
 2060 
 2061 =over
 2062 
 2063 =item handle_request ()
 2064 
 2065 Handles the core of a single CGI request, outputting the HTML success
 2066 or error page or redirect header and sending emails.
 2067 
 2068 Dies on error.
 2069 
 2070 =cut
 2071 
 2072 sub handle_request {
 2073   my ($self) = @_;
 2074 
 2075   $self->{Hide_Recipient} = 0;
 2076 
 2077   my $referer = $self->cgi_object->referer;
 2078   unless ($self->referer_is_ok($referer)) {
 2079     $self->referer_error_page;
 2080     return;
 2081   }
 2082 
 2083   $self->check_method_is_post    or return;
 2084 
 2085   $self->parse_form;
 2086 
 2087   $self->check_recipients( $self->get_recipients ) or return;
 2088 
 2089   my @missing = $self->get_missing_fields;
 2090   if (scalar @missing) {
 2091     $self->missing_fields_output(@missing);
 2092     return;
 2093   }
 2094 
 2095   my $date     = $self->date_string;
 2096   my $email    = $self->get_user_email;
 2097   my $realname = $self->get_user_realname;
 2098 
 2099   $self->send_main_email($date, $email, $realname);
 2100   $self->send_conf_email($date, $email, $realname);
 2101 
 2102   $self->success_page($date);
 2103 }
 2104 
 2105 =item date_string ()
 2106 
 2107 Returns a string giving the current date and time, in the configured
 2108 format.
 2109 
 2110 =cut
 2111 
 2112 sub date_string {
 2113   my ($self) = @_;
 2114 
 2115   return $self->format_date( $self->{CFG}{date_fmt},
 2116                              $self->{CFG}{date_offset} );
 2117 }
 2118 
 2119 =item referer_is_ok ( REFERER )
 2120 
 2121 Returns true if the referer is OK, false otherwise.
 2122 
 2123 =cut
 2124 
 2125 sub referer_is_ok {
 2126   my ($self, $referer) = @_;
 2127 
 2128   unless ($referer) {
 2129     return ($self->{CFG}{allow_empty_ref} ? 1 : 0);
 2130   }
 2131 
 2132   if ($referer =~ m!^https?://([^/]*\@)?([\w\-\.]+)!i) {
 2133     my $refhost = $2;
 2134     return $self->refering_host_is_ok($refhost);
 2135   }
 2136   else {
 2137     return 0;
 2138   }
 2139 }
 2140 
 2141 =item refering_host_is_ok ( REFERING_HOST )
 2142 
 2143 Returns true if the host name REFERING_HOST is on the list of allowed
 2144 referers, or resolves to an allowed IP address.
 2145 
 2146 =cut
 2147 
 2148 sub refering_host_is_ok {
 2149   my ($self, $refhost) = @_;
 2150 
 2151   my @allow = @{ $self->{CFG}{referers} };
 2152   return 1 unless scalar @allow;
 2153 
 2154   foreach my $test_ref (@allow) {
 2155     if ($refhost =~ m|\Q$test_ref\E$|i) {
 2156       return 1;
 2157     }
 2158   }
 2159 
 2160   my $ref_ip = inet_aton($refhost) or return 0;
 2161   foreach my $test_ref (@allow) {
 2162     next unless $test_ref =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/;
 2163 
 2164     my $test_ref_ip = inet_aton($test_ref) or next;
 2165     if ($ref_ip eq $test_ref_ip) {
 2166       return 1;
 2167     }
 2168   }
 2169 }
 2170 
 2171 =item referer_error_page ()
 2172 
 2173 Invoked if the referer is bad, this method outputs an error page
 2174 describing the problem with the referer.
 2175 
 2176 =cut
 2177 
 2178 sub referer_error_page {
 2179   my ($self) = @_;
 2180 
 2181   my $referer = $self->cgi_object->referer || '';
 2182   my $escaped_referer = $self->escape_html($referer);
 2183 
 2184   if ( $referer =~ m|^https?://([\w\.\-]+)|i) {
 2185     my $host = $1;
 2186     $self->error_page( 'Bad Referrer - Access Denied', <<END );
 2187 <p>
 2188   The form attempting to use this script resides at <tt>$escaped_referer</tt>,
 2189   which is not allowed to access this program.
 2190 </p>
 2191 <p>
 2192   If you are attempting to configure FormMail to run with this form,
 2193   you need to add the following to \@referers, explained in detail in the
 2194   README file.
 2195 </p>
 2196 <p>
 2197   Add <tt>'$host'</tt> to your <tt><b>\@referers</b></tt> array.
 2198 </p>
 2199 END
 2200   }
 2201   elsif (length $referer) {
 2202     $self->error_page( 'Malformed Referrer - Access Denied', <<END );
 2203 <p>
 2204   The referrer value <tt>$escaped_referer</tt> cannot be parsed, so
 2205   it is not possible to check that the referring page is allowed to
 2206   access this program.
 2207 </p>
 2208 END
 2209   }
 2210   else {
 2211     $self->error_page( 'Missing Referrer - Access Denied', <<END );
 2212 <p>
 2213   Your browser did not send a <tt>Referer</tt> header with this
 2214   request, so it is not possible to check that the referring page
 2215   is allowed to access this program.
 2216 </p>
 2217 END
 2218   }
 2219 }
 2220 
 2221 =item check_method_is_post ()
 2222 
 2223 Unless the C<secure> configuration setting is false, this method checks
 2224 that the request method is POST.  Returns true if OK, otherwise outputs
 2225 an error page and returns false.
 2226 
 2227 =cut
 2228 
 2229 sub check_method_is_post {
 2230   my ($self) = @_;
 2231 
 2232   return 1 unless $self->{CFG}{secure};
 2233 
 2234   my $method = $self->cgi_object->request_method || '';
 2235   if ($method ne 'POST') {
 2236     $self->error_page( 'Error: GET request', <<END );
 2237 <p>
 2238   The HTML form fails to specify the POST method, so it would not
 2239   be correct for this script to take any action in response to
 2240   your request.
 2241 </p>
 2242 <p>
 2243   If you are attempting to configure this form to run with FormMail,
 2244   you need to set the request method to POST in the opening form tag,
 2245   like this:
 2246   <tt>&lt;form action=&quot;/cgi-bin/FormMail.pl&quot; method=&quot;post&quot;&gt;</tt>
 2247 </p>
 2248 END
 2249     return 0;
 2250   }
 2251   else {
 2252     return 1;
 2253   }
 2254 }
 2255 
 2256 =item parse_form ()
 2257 
 2258 Parses the HTML form, storing the results in various fields in the
 2259 C<FormMail> object, as follows:
 2260 
 2261 =over
 2262 
 2263 =item C<FormConfig>
 2264 
 2265 A hash holding the values of the configuration inputs, such as
 2266 C<recipient> and C<subject>.
 2267 
 2268 =item C<Form>
 2269 
 2270 A hash holding the values of inputs other than configuration inputs.
 2271 
 2272 =item C<Field_Order>
 2273 
 2274 An array giving the set and order of fields to be included in the
 2275 email and on the success page.
 2276 
 2277 =back
 2278 
 2279 =cut
 2280 
 2281 sub parse_form {
 2282   my ($self) = @_;
 2283 
 2284   $self->{FormConfig} = { map {$_=>''} $self->configuration_form_fields };
 2285   $self->{Field_Order} = [];
 2286   $self->{Form} = {};
 2287 
 2288   foreach my $p ($self->cgi_object->param()) {
 2289     if (exists $self->{FormConfig}{$p}) {
 2290       $self->parse_config_form_input($p);
 2291     }
 2292     else {
 2293       $self->parse_nonconfig_form_input($p);
 2294     }
 2295   }
 2296 
 2297   $self->substitute_forced_config_values;
 2298 
 2299   $self->expand_list_config_items;
 2300 
 2301   $self->sort_field_order;
 2302   $self->remove_blank_fields;
 2303 }
 2304 
 2305 =item configuration_form_fields ()
 2306 
 2307 Returns a list of the names of the form fields which are used
 2308 to configure formmail rather than to provide user input, such
 2309 as C<subject> and C<recipient>.  The specially treated C<email>
 2310 and C<realname> fields are included in this list.
 2311 
 2312 =cut
 2313 
 2314 sub configuration_form_fields {
 2315   qw(
 2316     recipient
 2317     subject
 2318     email
 2319     realname
 2320     redirect
 2321     bgcolor
 2322     background
 2323     link_color
 2324     vlink_color
 2325     text_color
 2326     alink_color
 2327     title
 2328     sort
 2329     print_config
 2330     required
 2331     env_report
 2332     return_link_title
 2333     return_link_url
 2334     print_blank_fields
 2335     missing_fields_redirect
 2336   );
 2337 }
 2338 
 2339 =item parse_config_form_input ( NAME )
 2340 
 2341 Deals with the configuration form input NAME, incorporating it into
 2342 the C<FormConfig> field in the blessed hash.
 2343 
 2344 =cut
 2345 
 2346 sub parse_config_form_input {
 2347   my ($self, $name) = @_;
 2348 
 2349   my $val = $self->strip_nonprint($self->cgi_object->param($name));
 2350   if ($name =~ /return_link_url|redirect$/) {
 2351     $val = $self->validate_url($val);
 2352   }
 2353   $self->{FormConfig}{$name} = $val;
 2354   unless ($self->{CFG}{emulate_matts_code}) {
 2355     $self->{Form}{$name} = $val;
 2356     if ( $self->{CFG}{"include_config_$name"} ) {
 2357       push @{ $self->{Field_Order} }, $name;
 2358     }
 2359   }
 2360 }
 2361 
 2362 =item parse_nonconfig_form_input ( NAME )
 2363 
 2364 Deals with the non-configuration form input NAME, incorporating it into
 2365 the C<Form> and C<Field_Order> fields in the blessed hash.
 2366 
 2367 =cut
 2368 
 2369 sub parse_nonconfig_form_input {
 2370   my ($self, $name) = @_;
 2371 
 2372   my @vals = map {$self->strip_nonprint($_)} $self->cgi_object->param($name);
 2373   my $key = $self->strip_nonprint($name);
 2374   $self->{Form}{$key} = join $self->{CFG}{join_string}, @vals;
 2375   push @{ $self->{Field_Order} }, $key;
 2376 }
 2377 
 2378 =item expand_list_config_items ()
 2379 
 2380 Converts the form configuration values C<required>, C<env_report> and
 2381 C<print_config> from strings of comma separated values to arrays, and
 2382 removes anything not in the C<valid_ENV> configuration setting from
 2383 C<env_report>.
 2384 
 2385 =cut
 2386 
 2387 sub expand_list_config_items {
 2388   my ($self) = @_;
 2389 
 2390   foreach my $p (qw(required env_report print_config)) {
 2391     if ($self->{FormConfig}{$p}) {
 2392       $self->{FormConfig}{$p} = [split(/\s*,\s*/, $self->{FormConfig}{$p})];
 2393     }
 2394     else {
 2395       $self->{FormConfig}{$p} = [];
 2396     }
 2397   }
 2398 
 2399   $self->{FormConfig}{env_report} =
 2400      [ grep { $self->{Valid_Env}{$_} } @{ $self->{FormConfig}{env_report} } ];
 2401 }
 2402 
 2403 =item substitute_forced_config_values ()
 2404 
 2405 Replaces form configuration values for which there is a forced value
 2406 configuration setting with the forced value.  Sets C<Hide_Recipient>
 2407 true if the recipient config value is forced.
 2408 
 2409 =cut
 2410 
 2411 sub substitute_forced_config_values {
 2412   my ($self) = @_;
 2413 
 2414   foreach my $k (keys %{ $self->{FormConfig} }) {
 2415     if (exists $self->{CFG}{"force_config_$k"}) {
 2416       $self->{FormConfig}{$k} = $self->{CFG}{"force_config_$k"};
 2417       $self->{Hide_Recipient} = 1 if $k eq 'recipient';
 2418     }
 2419   }
 2420 }
 2421 
 2422 =item sort_field_order ()
 2423 
 2424 Modifies the C<Field_Order> field in the blessed hash according to
 2425 the sorting scheme set in the C<sort> form configuration, if any.
 2426 
 2427 =cut
 2428 
 2429 sub sort_field_order {
 2430   my ($self) = @_;
 2431 
 2432   my $sort = $self->{FormConfig}{'sort'};
 2433   if (defined $sort) {
 2434     if ($sort eq 'alphabetic') {
 2435       $self->{Field_Order} = [ sort @{ $self->{Field_Order} } ];
 2436     }
 2437     elsif ($sort =~ /^\s*order:\s*(.*)$/s) {
 2438       $self->{Field_Order} = [ split /\s*,\s*/, $1 ];
 2439     }
 2440   }
 2441 }
 2442 
 2443 =item remove_blank_fields ()
 2444 
 2445 Removes the names of blank or missing fields from the C<Field_Order> array
 2446 unless the C<print_blank_fields> form configuration value is true.
 2447 
 2448 =cut
 2449 
 2450 sub remove_blank_fields {
 2451   my ($self) = @_;
 2452 
 2453   return if $self->{FormConfig}{print_blank_fields};
 2454 
 2455   $self->{Field_Order} = [
 2456     grep { defined $self->{Form}{$_} and $self->{Form}{$_} !~ /^\s*$/ } 
 2457     @{ $self->{Field_Order} }
 2458   ];
 2459 }
 2460 
 2461 =item get_recipients ()
 2462 
 2463 Determines the list of configured recipients from the form inputs and the
 2464 C<recipient_alias> configuration setting, and returns them as a list.
 2465 
 2466 Sets the C<Hide_Recipient> field in the blessed hash to a true value if
 2467 one or more of the recipients were aliased and so should be hidden to
 2468 foil address harvesters.
 2469 
 2470 =cut
 2471 
 2472 sub get_recipients {
 2473   my ($self) = @_;
 2474 
 2475   my $recipient = $self->{FormConfig}{recipient};
 2476   my @recipients;
 2477 
 2478   if (length $recipient) {
 2479     foreach my $r (split /\s*,\s*/, $recipient) {
 2480       if (exists $self->{CFG}{recipient_alias}{$r}) {
 2481         push @recipients, split /\s*,\s*/, $self->{CFG}{recipient_alias}{$r};
 2482         $self->{Hide_Recipient} = 1;
 2483       }
 2484       else {
 2485         push @recipients, $r;
 2486       }
 2487     }
 2488   }
 2489   else {
 2490     return $self->default_recipients;
 2491   }
 2492 
 2493   return @recipients;
 2494 }
 2495 
 2496 =item default_recipients ()
 2497 
 2498 Invoked from get_recipients if no C<recipient> input is found, this method
 2499 returns the default recipient list.  The default recipient is the first email
 2500 address listed in the C<allow_mail_to> configuration setting, if any.
 2501 
 2502 =cut
 2503 
 2504 sub default_recipients {
 2505   my ($self) = @_;
 2506 
 2507   my @allow = grep {/\@/} @{ $self->{CFG}{allow_mail_to} };
 2508   if (scalar @allow > 0 and not $self->{CFG}{emulate_matts_code}) {
 2509     $self->{Hide_Recipient} = 1;
 2510     return ($allow[0]);
 2511   }
 2512   else {
 2513     return ();
 2514   }
 2515 }
 2516 
 2517 =item check_recipients ( @RECIPIENTS )
 2518 
 2519 Works through the array of recipients passed in and discards any the the script
 2520 is not configured to allow, storing the list of valid recipients in the
 2521 C<Recipients> field in the blessed hash.
 2522 
 2523 Returns true if at least one (and not too many) valid recipients are found,
 2524 otherwise outputs an error page and returns false.
 2525 
 2526 =cut
 2527 
 2528 sub check_recipients {
 2529   my ($self, @recipients) = @_;
 2530 
 2531   my @valid = grep { $self->recipient_is_ok($_) } @recipients;
 2532   $self->{Recipients} = \@valid;
 2533 
 2534   if (scalar(@valid) == 0) {
 2535     $self->bad_recipient_error_page;
 2536     return 0;
 2537   }
 2538   elsif ($self->{CFG}{max_recipients} and scalar(@valid) > $self->{CFG}{max_recipients}) {
 2539     $self->too_many_recipients_error_page;
 2540     return 0;
 2541   }
 2542   else {
 2543     return 1;
 2544   }
 2545 }
 2546 
 2547 =item recipient_is_ok ( RECIPIENT )
 2548 
 2549 Returns true if the recipient RECIPIENT should be allowed, false otherwise.
 2550 
 2551 =cut
 2552 
 2553 sub recipient_is_ok {
 2554   my ($self, $recipient) = @_;
 2555 
 2556   return 0 unless $self->validate_email($recipient);
 2557 
 2558   $recipient =~ /^(.+)\@([^@]+)$/m or die "regex failure [$recipient]";
 2559   my ($user, $host) = ($1, lc $2);
 2560   return 1 if exists $self->{Allow_Domain}{$host};
 2561   return 1 if exists $self->{Allow_Mail}{"$user\@$host"};
 2562 
 2563   foreach my $r (@{ $self->{CFG}{recipients} }) {
 2564     return 1 if $recipient =~ /(?:$r)$/;
 2565     return 1 if $self->{CFG}{emulate_matts_code} and $recipient =~ /(?:$r)$/i;
 2566   }
 2567 
 2568   return 0;
 2569 }
 2570 
 2571 =item bad_recipient_error_page ()
 2572 
 2573 Outputs the error page for a bad or missing recipient.
 2574 
 2575 =cut
 2576 
 2577 sub bad_recipient_error_page {
 2578   my ($self) = @_;
 2579 
 2580   my $errhtml = <<END;
 2581 <p>
 2582   There was no recipient or an invalid recipient specified in the
 2583   data sent to FormMail. Please make sure you have filled in the
 2584   <tt>recipient</tt> form field with an e-mail address that has
 2585   been configured in <tt>\@recipients</tt> or <tt>\@allow_mail_to</tt>.
 2586   More information on filling in <tt>recipient/allow_mail_to</tt>
 2587   form fields and variables can be found in the README file.
 2588 </p>
 2589 END
 2590 
 2591   unless ($self->{CFG}{force_config_recipient}) {
 2592     my $esc_rec = $self->escape_html( $self->{FormConfig}{recipient} );
 2593     $errhtml .= <<END;
 2594 <hr size="1" />
 2595 <p>
 2596  The recipient was: [ $esc_rec ]
 2597 </p>
 2598 END
 2599   }
 2600 
 2601   $self->error_page( 'Error: Bad or Missing Recipient', $errhtml );
 2602 }
 2603 
 2604 =item too_many_recipients_error_page ()
 2605 
 2606 Outputs the error page for too many recipients configured.
 2607 
 2608 =cut
 2609 
 2610 sub too_many_recipients_error_page {
 2611   my ($self) = @_;
 2612 
 2613   $self->error_page( 'Error: Too many Recipients', <<END );
 2614 <p>
 2615   The number of recipients configured in the form exceeds the
 2616   maximum number of recipients configured in the script.  If
 2617   you are attempting to configure FormMail to run with this form
 2618   then you will need to increase the <tt>\$max_recipients</tt>
 2619   configuration setting in the script.
 2620 </p>
 2621 END
 2622 }
 2623 
 2624 =item get_missing_fields ()
 2625 
 2626 Returns a list of the names of the required fields that have not been
 2627 filled in acceptably, each one possibly annotated with details of the
 2628 problem with the way the field was filled in.
 2629 
 2630 =cut
 2631 
 2632 sub get_missing_fields {
 2633   my ($self) = @_;
 2634 
 2635   my @missing = ();
 2636 
 2637   foreach my $f (@{ $self->{FormConfig}{required} }) {
 2638     if ($f eq 'email') {
 2639       unless ( $self->get_user_email =~ /\@/ ) {
 2640         push @missing, 'email (must be a valid email address)';
 2641       }
 2642     }
 2643     elsif ($f eq 'realname') { 
 2644       unless ( length $self->get_user_realname ) {
 2645         push @missing, 'realname';
 2646       }
 2647     }
 2648     else {
 2649       my $val = $self->{Form}{$f};
 2650       if (! defined $val or $val =~ /^\s*$/) {
 2651         push @missing, $f;
 2652       }
 2653     }
 2654   }
 2655 
 2656   return @missing;
 2657 }
 2658 
 2659 =item missing_fields_output ( @MISSING )
 2660 
 2661 Produces the configured output (an error page or a redirect) for the
 2662 case when there are missing fields.  Takes a list of the missing
 2663 fields as arguments.
 2664 
 2665 =cut
 2666 
 2667 sub missing_fields_output {
 2668   my ($self, @missing) = @_;
 2669 
 2670   if ( $self->{FormConfig}{'missing_fields_redirect'} ) {
 2671     print $self->cgi_object->redirect($self->{FormConfig}{'missing_fields_redirect'});
 2672   }
 2673   else {
 2674     my $missing_field_list = join '',
 2675                              map { '<li>' . $self->escape_html($_) . "</li>\n" }
 2676                              @missing;
 2677     $self->error_page( 'Error: Blank Fields', <<END );
 2678 <p>
 2679     The following fields were left blank in your submission form:
 2680 </p>
 2681 <div class="c2">
 2682    <ul>
 2683      $missing_field_list
 2684    </ul>
 2685 </div>
 2686 <p>
 2687     These fields must be filled in before you can successfully
 2688     submit the form.
 2689 </p>
 2690 <p>
 2691     Please use your back button to return to the form and
 2692     try again.
 2693 </p>
 2694 END
 2695   }
 2696 }
 2697 
 2698 =item get_user_email ()
 2699 
 2700 Returns the user's email address if they entered a valid one in the C<email>
 2701 form field, otherwise returns the string C<nobody>.
 2702 
 2703 =cut
 2704 
 2705 sub get_user_email {
 2706   my ($self) = @_;
 2707 
 2708   my $email = $self->{FormConfig}{email};
 2709   $email = $self->validate_email($email);
 2710   $email = 'nobody' unless $email;
 2711 
 2712   return $email;
 2713 }
 2714 
 2715 =item get_user_realname ()
 2716 
 2717 Returns the user's real name, as entered in the C<realname> form field.
 2718 
 2719 =cut
 2720 
 2721 sub get_user_realname {
 2722   my ($self) = @_;
 2723 
 2724   my $realname = $self->{FormConfig}{realname};
 2725   if (defined $realname) {
 2726     $realname = $self->validate_realname($realname);
 2727   } else {
 2728     $realname = '';
 2729   }
 2730 
 2731   return $realname;
 2732 }
 2733 
 2734 =item send_main_email ( DATE, EMAIL, REALNAME )
 2735 
 2736 Sends the main email.  DATE is a date string, EMAIL is the
 2737 user's email address if they entered a valid one and REALNAME
 2738 is the user's real name if entered.
 2739 
 2740 =cut
 2741 
 2742 sub send_main_email {
 2743   my ($self, $date, $email, $realname) = @_;
 2744 
 2745   my $mailer = $self->mailer;
 2746   $mailer->newmail($self->name_and_version, $self->{CFG}{postmaster}, @{ $self->{Recipients} });
 2747 
 2748   $self->send_main_email_header($email, $realname);
 2749   $mailer->print("\n");
 2750 
 2751   $self->send_main_email_body_header($date);
 2752 
 2753   $self->send_main_email_print_config;
 2754 
 2755   $self->send_main_email_fields;
 2756 
 2757   $self->send_main_email_footer;
 2758 
 2759   $mailer->endmail;
 2760 }
 2761 
 2762 =item build_from_address( EMAIL, REALNAME )
 2763 
 2764 Creates the address that will be used for the user that filled in the form,
 2765 if the address_style configuration is 0 or emulate_matts_code is true then
 2766 the format will be "$email ($realname)" if it is set to a true value then 
 2767 the format will be "$realname <$email>".
 2768 
 2769 =cut
 2770 
 2771 sub build_from_address
 2772 {
 2773    my ( $self, $email, $realname ) = @_;
 2774 
 2775    my $from_address = $email;
 2776    if ( length $realname )
 2777    {
 2778       if (!$self->{CFG}{emulates_matts_code} and $self->{CFG}{address_style})
 2779       {
 2780          $from_address = "$realname <$email>";
 2781       }
 2782       else
 2783       {
 2784          $from_address = "$email ($realname)";
 2785       }
 2786    }
 2787 
 2788    return $from_address;
 2789 }
 2790 
 2791 =item send_main_email_header ( EMAIL, REALNAME )
 2792 
 2793 Sends the email header for the main email, not including the terminating
 2794 blank line.
 2795 
 2796 =cut
 2797 
 2798 sub send_main_email_header {
 2799   my ($self, $email, $realname) = @_;
 2800 
 2801   my $subject = $self->{FormConfig}{subject} || 'WWW Form Submission';
 2802   if ($self->{CFG}{secure}) {
 2803     $subject = substr($subject, 0, 256);
 2804   }
 2805   $subject =~ s#[\r\n\t]+# #g;
 2806 
 2807   my $to = join ',', @{ $self->{Recipients} };
 2808   my $from = $self->build_from_address($email ,$realname);
 2809 
 2810   $self->mailer->print(<<END);
 2811 X-Mailer: ${\( $self->name_and_version )}
 2812 To: $to
 2813 From: $from
 2814 Subject: $subject
 2815 END
 2816 }
 2817 
 2818 =item send_main_email_body_header ( DATE )
 2819 
 2820 Invoked after the blank line to terminate the header is sent, this method
 2821 outputs the header of the email body.
 2822 
 2823 =cut
 2824 
 2825 sub send_main_email_body_header {
 2826   my ($self, $date) = @_;
 2827 
 2828   my $dashes = '-' x 75;
 2829   $dashes .= "\n\n" if $self->{CFG}{double_spacing};
 2830 
 2831   $self->mailer->print(<<END);
 2832 Below is the result of your feedback form.  It was submitted by
 2833 $self->{FormConfig}{realname} ($self->{FormConfig}{email}) on $date
 2834 $dashes
 2835 END
 2836 }
 2837 
 2838 =item send_main_email_print_config ()
 2839 
 2840 If the C<print_config> form configuration field is set, outputs the configured
 2841 config values to the email.
 2842 
 2843 =cut
 2844 
 2845 sub send_main_email_print_config {
 2846   my ($self) = @_;
 2847 
 2848   if ($self->{FormConfig}{print_config}) {
 2849     foreach my $cfg (@{ $self->{FormConfig}{print_config} }) {
 2850       if ($self->{FormConfig}{$cfg}) {
 2851         $self->mailer->print("$cfg: $self->{FormConfig}{$cfg}\n");
 2852     $self->mailer->print("\n") if $self->{CFG}{double_spacing};
 2853       }
 2854     }
 2855   }
 2856 }
 2857 
 2858 =item send_main_email_fields ()
 2859 
 2860 Outputs the form fields to the email body.
 2861 
 2862 =cut
 2863 
 2864 sub send_main_email_fields {
 2865   my ($self) = @_;
 2866 
 2867   foreach my $f (@{ $self->{Field_Order} }) {
 2868     my $val = (defined $self->{Form}{$f} ? $self->{Form}{$f} : '');
 2869 
 2870     $self->send_main_email_field($f, $val);
 2871   }
 2872 }
 2873 
 2874 =item send_main_email_field ( NAME, VALUE )
 2875 
 2876 Outputs a single form field to the email body.
 2877 
 2878 =cut
 2879 
 2880 sub send_main_email_field {
 2881   my ($self, $name, $value) = @_;
 2882   
 2883   my ($prefix, $line) = $self->build_main_email_field($name, $value);
 2884 
 2885   my $nl = ($self->{CFG}{double_spacing} ? "\n\n" : "\n");
 2886 
 2887   if ($self->{CFG}{wrap_text} and length("$prefix$line") > $self->email_wrap_columns) {
 2888     $self->mailer->print( $self->wrap_field_for_email($prefix, $line) . $nl );
 2889   }
 2890   else {
 2891     $self->mailer->print("$prefix$line$nl");
 2892   }
 2893 }
 2894 
 2895 =item build_main_email_field ( NAME, VALUE )
 2896 
 2897 Generates the email body text for a single form input, and returns
 2898 it as a two element list of prefix and remainder of line.  The return
 2899 value is split into a prefix and remainder of line because the text
 2900 wrapping code may need to indent the wrapped line to the length of the
 2901 prefix.
 2902 
 2903 =cut
 2904 
 2905 sub build_main_email_field {
 2906   my ($self, $name, $value) = @_;
 2907 
 2908   return ("$name: ", $value);
 2909 }
 2910 
 2911 =item wrap_field_for_email ( PREFIX, LINE )
 2912 
 2913 Takes the prefix and rest of line of a field as arguments, and returns them
 2914 as a text wrapped paragraph suitable for inclusion in the main email.
 2915 
 2916 =cut
 2917 
 2918 sub wrap_field_for_email {
 2919   my ($self, $prefix, $value) = @_;
 2920 
 2921   my $subs_indent = '';
 2922   $subs_indent = ' ' x length($prefix) if $self->{CFG}{wrap_style} == 1;
 2923 
 2924   local $Text::Wrap::columns = $self->email_wrap_columns;
 2925 
 2926   # Some early versions of Text::Wrap will die on very long words, if that
 2927   # happens we fall back to no wrapping.
 2928   my $wrapped;
 2929   eval { local $SIG{__DIE__} ; $wrapped = wrap($prefix,$subs_indent,$value) };
 2930   return ($@ ? "$prefix$value" : $wrapped);
 2931 }
 2932 
 2933 =item email_wrap_columns ()
 2934 
 2935 Returns the number of columns to which the email should be wrapped if the
 2936 text wrapping option is in use.
 2937 
 2938 =cut
 2939 
 2940 sub email_wrap_columns { 72; }
 2941 
 2942 =item send_main_email_footer ()
 2943 
 2944 Sends the footer of the main email body, including any environment variables
 2945 listed in the C<env_report> configuration form field.
 2946 
 2947 =cut
 2948 
 2949 sub send_main_email_footer {
 2950   my ($self) = @_;
 2951 
 2952   my $dashes = '-' x 75;
 2953   $self->mailer->print("$dashes\n\n");
 2954 
 2955   foreach my $e (@{ $self->{FormConfig}{env_report}}) {
 2956     if ($ENV{$e}) {
 2957       $self->mailer->print("$e: " . $self->strip_nonprint($ENV{$e}) . "\n");
 2958     }
 2959   }
 2960 }
 2961 
 2962 =item send_conf_email ( DATE, EMAIL, REALNAME )
 2963 
 2964 Sends a confirmation email back to the user, if configured to do so and the
 2965 user entered a valid email addresses.
 2966 
 2967 =cut
 2968 
 2969 sub send_conf_email {
 2970   my ($self, $date, $email, $realname) = @_;
 2971 
 2972   if ( $self->{CFG}{send_confirmation_mail} and $email =~ /\@/ ) {
 2973     my $to = $self->build_from_address($email, $realname);
 2974     $self->mailer->newmail("NMS FormMail.pm v$VERSION", $self->{CFG}{postmaster}, $email);
 2975     $self->mailer->print("To: $to\n$self->{CFG}{confirmation_text}");
 2976     $self->mailer->endmail;
 2977   }
 2978 }
 2979 
 2980 =item success_page ()
 2981 
 2982 Outputs the HTML success page (or redirect if configured) after the email
 2983 has been successfully sent.
 2984 
 2985 =cut
 2986 
 2987 sub success_page {
 2988   my ($self, $date) = @_;
 2989 
 2990   if ($self->{FormConfig}{'redirect'}) {
 2991     print $self->cgi_object->redirect( $self->{FormConfig}{'redirect'} );
 2992   }
 2993   elsif ( $self->{CFG}{'no_content'}) {
 2994     print $self->cgi_object->header(Status => 204);
 2995   }
 2996   else {
 2997     $self->output_cgi_html_header;
 2998     $self->success_page_html_preamble($date);
 2999     $self->success_page_fields;
 3000     $self->success_page_footer;
 3001   }
 3002 }
 3003 
 3004 =item success_page_html_preamble ( DATE )
 3005 
 3006 Outputs the start of the HTML for the success page, not including the
 3007 standard HTML headers dealt with by output_cgi_html_header().
 3008 
 3009 =cut
 3010 
 3011 sub success_page_html_preamble {
 3012   my ($self, $date) = @_;
 3013 
 3014   my $title = $self->escape_html( $self->{FormConfig}{'title'} || 'Thank You' );
 3015   my $torecipient = 'to ' . $self->escape_html($self->{FormConfig}{'recipient'});
 3016   $torecipient = '' if $self->{Hide_Recipient};
 3017   my $attr = $self->body_attributes;
 3018 
 3019     print <<END;
 3020   <head>
 3021      <title>$title</title>
 3022 END
 3023 
 3024     $self->output_style_element;
 3025 
 3026     print <<END;
 3027      <style>
 3028        h1.title {
 3029                    text-align : center;
 3030                 }
 3031      </style>
 3032   </head>
 3033   <body $attr>
 3034     <h1 class="title">$title</h1>
 3035     <p>Below is what you submitted $torecipient on $date</p>
 3036     <p><hr size="1" width="75%" /></p>
 3037 END
 3038 }
 3039 
 3040 =item success_page_fields ()
 3041 
 3042 Outputs success page HTML output for each input field.
 3043 
 3044 =cut
 3045 
 3046 sub success_page_fields {
 3047   my ($self) = @_;
 3048 
 3049   foreach my $f (@{ $self->{Field_Order} }) {
 3050     my $val = (defined $self->{Form}{$f} ? $self->{Form}{$f} : '');
 3051     $self->success_page_field( $self->escape_html($f), $self->escape_html($val) );
 3052   }
 3053 }
 3054 
 3055 =item success_page_field ( NAME, VALUE ) {
 3056 
 3057 Outputs success page HTML for a single input field.  NAME and VALUE
 3058 are the HTML escaped field name and value.
 3059 
 3060 =cut
 3061 
 3062 sub success_page_field {
 3063   my ($self, $name, $value) = @_;
 3064 
 3065   print "<p><b>$name:</b> $value</p>\n";
 3066 }
 3067 
 3068 =item success_page_footer ()
 3069 
 3070 Outputs the footer of the success page, including the return link if
 3071 configured.
 3072 
 3073 =cut
 3074 
 3075 sub success_page_footer {
 3076   my ($self) = @_;
 3077 
 3078   print qq{<p><hr size="1" width="75%" /></p>\n};
 3079   $self->success_page_return_link;
 3080   print <<END;
 3081         <hr size="1" width="75%" />
 3082         <p align="center">
 3083            <font size="-1">
 3084              <a href="http://nms-cgi.sourceforge.net/">FormMail</a>
 3085              &copy; 2001  London Perl Mongers
 3086            </font>
 3087         </p>
 3088         </body>
 3089        </html>
 3090 END
 3091 }
 3092 
 3093 =item success_page_return_link ()
 3094 
 3095 Outputs the success page return link if any is configured.
 3096 
 3097 =cut
 3098 
 3099 sub success_page_return_link {
 3100   my ($self) = @_;
 3101 
 3102   if ($self->{FormConfig}{return_link_url} and $self->{FormConfig}{return_link_title}) {
 3103     print "<ul>\n";
 3104     print '<li><a href="', $self->escape_html($self->{FormConfig}{return_link_url}),
 3105        '">', $self->escape_html($self->{FormConfig}{return_link_title}), "</a>\n";
 3106     print "</li>\n</ul>\n";
 3107   }
 3108 }
 3109 
 3110 =item body_attributes ()
 3111 
 3112 Gets the body attributes for the success page from the form
 3113 configuration, and returns the string that should go inside
 3114 the C<body> tag.
 3115 
 3116 =cut
 3117 
 3118 sub body_attributes {
 3119   my ($self) = @_;
 3120 
 3121   my %attrs = (bgcolor     => 'bgcolor',
 3122                background  => 'background',
 3123                link_color  => 'link',
 3124                vlink_color => 'vlink',
 3125                alink_color => 'alink',
 3126                text_color  => 'text');
 3127 
 3128   my $attr = '';
 3129 
 3130   foreach my $at (keys %attrs) {
 3131     my $val = $self->{FormConfig}{$at};
 3132     next unless $val;
 3133     if ($at =~ /color$/) {
 3134       $val = $self->validate_html_color($val);
 3135     }
 3136     elsif ($at eq 'background') {
 3137       $val = $self->validate_url($val);
 3138     }
 3139     else {
 3140       die "no check defined for body attribute [$at]";
 3141     }
 3142     $attr .= qq( $attrs{$at}=") . $self->escape_html($val) . '"' if $val;
 3143   }
 3144 
 3145   return $attr;
 3146 }
 3147 
 3148 =item error_page( TITLE, ERROR_BODY )
 3149 
 3150 Outputs a FormMail error page, giving the HTML document the title
 3151 TITLE and displaying the HTML error message ERROR_BODY.
 3152 
 3153 =cut
 3154 
 3155 sub error_page {
 3156   my ($self, $title, $error_body) = @_;
 3157 
 3158   $self->output_cgi_html_header;
 3159 
 3160   my $etitle = $self->escape_html($title);
 3161   print <<END;
 3162   <head>
 3163     <title>$etitle</title>
 3164 END
 3165 
 3166 
 3167   print <<END;
 3168     <style type="text/css">
 3169     <!--
 3170        body {
 3171               background-color: #FFFFFF;
 3172               color: #000000;
 3173              }
 3174        table {
 3175                background-color: #9C9C9C;
 3176              }
 3177        p.c2 {
 3178               font-size: 80%;
 3179               text-align: center;
 3180             }
 3181        tr.title_row  {
 3182                         background-color: #9C9C9C;
 3183                       }
 3184        tr.body_row   {
 3185                          background-color: #CFCFCF;
 3186                       }
 3187 
 3188        th.c1 {
 3189                text-align: center;
 3190                font-size: 143%;
 3191              }
 3192        p.c3 {font-size: 80%; text-align: center}
 3193        div.c2 {margin-left: 2em}
 3194      -->
 3195     </style>
 3196 END
 3197 
 3198   $self->output_style_element;
 3199 
 3200 print <<END;
 3201   </head>
 3202   <body>
 3203     <table border="0" width="600" summary="">
 3204       <tr class="title_row">
 3205         <th class="c1">$etitle</th>
 3206       </tr>
 3207       <tr class="body_row">
 3208         <td>
 3209           $error_body
 3210           <hr size="1" />
 3211           <p class="c3">
 3212             <a href="http://nms-cgi.sourceforge.net/">FormMail</a>
 3213             &copy; 2001-2003 London Perl Mongers
 3214           </p>
 3215         </td>
 3216       </tr>
 3217     </table>
 3218   </body>
 3219 </html>
 3220 END
 3221 }
 3222 
 3223 =item mailer ()
 3224 
 3225 Returns an object satisfying the definition in L<CGI::NMS::Mailer>,
 3226 to be used for sending outgoing email.
 3227 
 3228 =cut
 3229 
 3230 sub mailer {
 3231   my ($self) = @_;
 3232 
 3233   return $self->{Mailer};
 3234 }
 3235 
 3236 =back
 3237 
 3238 =head1 SEE ALSO
 3239 
 3240 L<CGI::NMS::Script>
 3241 
 3242 =head1 MAINTAINERS
 3243 
 3244 The NMS project, E<lt>http://nms-cgi.sourceforge.net/E<gt>
 3245 
 3246 To request support or report bugs, please email
 3247 E<lt>nms-cgi-support@lists.sourceforge.netE<gt>
 3248 
 3249 =head1 COPYRIGHT
 3250 
 3251 Copyright 2003 London Perl Mongers, All rights reserved
 3252 
 3253 =head1 LICENSE
 3254 
 3255 This module is free software; you are free to redistribute it
 3256 and/or modify it under the same terms as Perl itself.
 3257 
 3258 =cut
 3259 
 3260 1;
 3261 
 3262 
 3263 END_INLINED_CGI_NMS_Script_FormMail
 3264   $INC{'CGI/NMS/Script/FormMail.pm'} = 1;
 3265 }
 3266 
 3267 }
 3268 #
 3269 # End of inlined modules
 3270 #
 3271 use CGI::NMS::Script::FormMail;
 3272 use base qw(CGI::NMS::Script::FormMail);
 3273 
 3274 use vars qw($script);
 3275 BEGIN {
 3276   $script = __PACKAGE__->new(
 3277      DEBUGGING              => $DEBUGGING,
 3278      name_and_version       => 'NMS FormMail 3.14c1',
 3279      emulate_matts_code     => $emulate_matts_code,
 3280      secure                 => $secure,
 3281      allow_empty_ref        => $allow_empty_ref,
 3282      max_recipients         => $max_recipients,
 3283      mailprog               => $mailprog,
 3284      postmaster             => $postmaster,
 3285      referers               => [@referers],
 3286      allow_mail_to          => [@allow_mail_to],
 3287      recipients             => [@recipients],
 3288      recipient_alias        => {%recipient_alias},
 3289      valid_ENV              => [@valid_ENV],
 3290      locale                 => $locale,
 3291      charset                => $charset,
 3292      date_fmt               => $date_fmt,
 3293      style                  => $style,
 3294      no_content             => $no_content,
 3295      double_spacing         => $double_spacing,
 3296      wrap_text              => $wrap_text,
 3297      wrap_style             => $wrap_style,
 3298      send_confirmation_mail => $send_confirmation_mail,
 3299      confirmation_text      => $confirmation_text,
 3300      address_style          => $address_style,
 3301      %more_config
 3302   );
 3303 }
 3304 
 3305 $script->request;
 3306