source: project/release/3/formular/trunk/FormMail.pl @ 13317

Last change on this file since 13317 was 10243, checked in by Ivan Raikov, 13 years ago

Moved formmail to formular.

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