473,698 Members | 2,048 Online
Bytes | Software Development & Data Engineering Community
+ Post

Home Posts Topics Members FAQ

Can't make this page work

I can't make this script work properly. I've gone as far as I can with
it and the rest is out of my ability. I can do some html editing but
I'm lost in the Java world. The script at the bottom of the html page
controls the form fields that are required. It doesn't function like
it's supposed to and I can leave all the fields blank and it still
submits the form. Also I can't get it to transfer the file in the
upload section. The file name is emailed to me but not the file itself.
Any help would be greatly appreciated. We're hosting on Netsols web
server and I can't change that unfortunately so changing servers is out
of the question as someone else suggested. Does someone have a perl
script they can recommend that would solve the problem. I have the
"Form2Mail" script that I downloaded and that's not anywhere near as
complicated from what I saw but they say a script called "sendmail" has
to be on the server in order for it to work.

*************** *Beginning of page code*********** *****

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
"http://www.w3.org/TR/html4/loose.dtd">
<html>
<head>
<title>Order Form</title>
<meta http-equiv="Content-Type" content="text/html;
charset=iso-8859-1">
<style type="text/css">
<!--
body {
margin-top: 5px;
background-image: url();
background-color: #FFFFCC;
}
-->
</style>
<script language = "Javascript ">
/**
* DHTML textbox character counter (IE4+) script. Courtesy of
SmartWebby.com (http://www.smartwebby.com/dhtml/)
*/

function taLimit() {
var taObj=event.src Element;
if (taObj.value.le ngth==taObj.max Length*1) return false;
}

function taCount(visCnt) {
var taObj=event.src Element;
if (taObj.value.le ngth>taObj.maxL ength*1)
taObj.value=taO bj.value.substr ing(0,taObj.max Length*1);
if (visCnt) visCnt.innerTex t=taObj.maxLeng th-taObj.value.len gth;
}
</script>
<style type="text/css">
<!--
@import url("CSS/a_tag_effects.c ss");
..style3 {font-family: Georgia, "Times New Roman", Times, serif}
..style12 {font-size: 18px;
font-family: Georgia, "Times New Roman", Times, serif;
font-weight: bold;
}
-->
</style>
</head>

<body>
<div align="center">
<table width="1000" height="70" border="0" align="center"
cellpadding="0" cellspacing="0" >
<tr>
<td width="580" height="72"><di v align="center"> <img
src="LovenoteLe tters.jpg" width="580" height="70" border="0">
</div></td>
<td width="140"><di v align="center"> <img src="Special.jp g"
width="140" height="70"></div></td>
<td width="280"><di v align="center"> <img src="Ribbon.jpg "
width="280" height="70"><br >
</div></td>
</tr>
</table>
<table width="1000" border="0" align="center" cellpadding="0"
cellspacing="0" background="wor dbar.jpg">
<tr>
<td width="111" height="25"><di v align="center"> <span
class="style3"> </span></div></td>
<td width="111"><di v align="center"> <span
class="style3"> </span></div></td>
<td width="111" height="25">&nb sp;</td>
<td width="111" height="25">&nb sp;</td>
<td width="111" height="25">&nb sp;</td>
<td width="111" height="25">&nb sp;</td>
<td width="111" height="25"><di v align="center"> <span
class="style3"> </span></div></td>
<td width="111" height="25">&nb sp;</td>
<td width="111" height="25"><di v align="center"> <span
class="style3"> </span></div></td>
</tr>
</table>
<div align="center">
<table width="800" border="0" align="center" cellpadding="5"
cellspacing="0" background="cup idtile_50%25.pn g">
<tr>
<td valign="top"><d iv align="center"> <span
class="style12" ><u>Finalize your order...</u></span></div></td>
</tr>
<tr>
<td height="405" valign="top"><d iv align="left">
<form name="orderform " action="/cgi-bin/FormMail.order_ form.pl"
method="post" id="orderform" onsubmit="retur n validate(orderf orm)">
<table width="800" border="0" cellspacing="0"
cellpadding="0" >
<tr>
<td colspan="7"><in put type=hidden
name="formmail_ mail_email" value="sc****** *@comcast.net"> </td>
<td width="469">&nb sp;</td>
</tr>
<tr valign="top">
<td colspan="7">
<div align="center"> <font>
<font>
<TEXTAREA onkeypress="ret urn taLimit()"
onkeyup="return taCount(myCount er)"
name=Descriptio n rows=7 wrap=physical cols=40
maxLength="100" ></TEXTAREA>
<br>
You have <B><SPAN id=myCounter>10 0</SPAN></B> characters
remaining...</font>

<br>
</font></div></td>
<td><div align="left">
<p><strong>Th is is the pop-up when you click on the
image.<br>
Please type in your message.<br>
You are allowed a total of 100 characters for a 10x10
image.</strong></p>
</div></td>
</tr>
<tr valign="top">
<td colspan="7">&nb sp;</td>
<td>&nbsp;</td>
</tr>
<tr valign="top">
<td colspan="7">
<div align="center">
<input name="mouseover " type="text" id="mouseover"
value="Mouseove r Message" size="32" maxlength="25">
</div></td>
<td><strong>Thi s is the message that appears when you
mouse over the image.<br>
Please type in a brief statement so your loved ones will
recognize you. </strong></td>
</tr>
<tr valign="top">
<td colspan="7">&nb sp;</td>
<td>&nbsp;</td>
</tr>
<tr valign="top">
<td colspan="7"><di v align="center">
<input name="email" type="text" id="email"
value="so*****@ somewhere.com" size="32">
</div></td>
<td><strong>Ent er your email address here. Same as the
payment page! </strong></td>
</tr>
<tr valign="top">
<td colspan="7">&nb sp;</td>
<td>&nbsp;</td>
</tr>
<tr valign="top">
<td colspan="7">
<div align="center">
<input name="fileuploa d" type="file"
id="fileupload" >
</div></td>
<td><strong>U se this field to select and upload your
own pixel image.</strong></td>
</tr>
<tr valign="top">
<td colspan="7">&nb sp;</td>
<td>&nbsp;</td>
</tr>
<tr valign="top">
<td width="52"><div align="center">
<input name="radiobutt on" type="radio"
value="Dot_Blue _10x10">
</div></td>
<td width="45"><div align="center">
<input name="radiobutt on" type="radio"
value="Dot_Gree n_10x10">
</div></td>
<td width="44"><div align="center">
<input name="radiobutt on" type="radio"
value="Dot_Purp le_10x10">
</div></td>
<td width="43"><div align="center">
<input name="radiobutt on" type="radio"
value="Dot_Red_ 10x10">
</div></td>
<td width="45"><div align="center">
<input name="radiobutt on" type="radio"
value="Dot_Yell ow_10x10">
</div></td>
<td width="41"><div align="center">
<input name="radiobutt on" type="radio"
value="Boxes_10 x10">
</div></td>
<td width="61"><div align="center">
<input name="radiobutt on" type="radio"
value="Rainbow_ 10x10">
</div></td>
<td><strong>Sel ect one of ours if you don't have your
own pixel image.</strong></td>
</tr>
<tr valign="top">
<td height="22"><di v align="center"> <img
src="PixelImage s/Dot_Blue_10x10. png" width="10" height="10"></div></td>
<td><div align="center"> <img
src="PixelImage s/Dot_Green_10x10 .png" width="10"
height="10"></div></td>
<td><div align="center"> <img
src="PixelImage s/Dot_Purple_10x1 0.png" width="10"
height="10"></div></td>
<td><div align="center"> <img
src="PixelImage s/Dot_Red_10x10.p ng" width="10" height="10"></div></td>
<td><div align="center"> <img
src="PixelImage s/Dot_Yellow_10x1 0.png" width="10"
height="10"></div></td>
<td><div align="center"> <img
src="PixelImage s/Boxes_10x10.png " width="10" height="10"></div></td>
<td><div align="center"> <img
src="PixelImage s/Rainbow_10x10.p ng" width="10" height="10"></div></td>
<td>&nbsp;</td>
</tr>
<tr valign="top">
<td colspan="7">
<div align="center"> </div></td>
<td>&nbsp;</td>
</tr>
<tr valign="top">
<td height="26" colspan="7"><di v align="center">
<input type="reset" name="Reset" value="Reset">
<input name="Submit" type="submit" id="Submit2"
value="Submit">
</div></td>
<td>&nbsp;</td>
</tr>
</table>
</form>
<script language="javas cript">
function validate(frm) {
var inputFields = new Array("Lovenote ");
var counter;
var name;
var msg = "Please complete the following fields:\n";
var badFields = "lovenote,mouse over,email,radi obutton";
for (counter = 0; counter < inputFields.len gth; counter++) {
name = inputFields[counter];
if (frm.elements[name].value.length == 0) {
if (name == "formmail_mail_ email") {
badFields = badFields + " - \n";
} else {
badFields = badFields + " - " + name + "\n";
}
}
}
if (badFields.leng th != 0) {
alert(msg + badFields);
return false;
}
return true;
}
</script>
</div></td>
</tr>
<tr>
<td valign="top"><d iv align="left"><b r>
</div></td>
</tr>
</table>
</div>
<p>&nbsp;</p>
</div>
</body>
</html>
*************** *Beginning of Perl Script code*********** *****

#!/usr/bin/perl -w
############### ############### ############### ############### ############### ###
# nms Formmail Version 3.14c1
#
# Copyright 2001 London Perl Mongers All rights reserved
#
# Created 11/11/01 Last Modified 08/11/04
#
# Matt's Script Archive: http://www.scriptarchive.com/
#
############### ############### ############### ############### ############### ###
# nms Formmail has been created as a drop in replacement for the
FormMail #
# found at Matt's Script Archive. Both the original and nms versions of
this #
# script can be found at the above URL. Support for nms Formmail is
#
# available through: nm************* @lists.sourcefo rge.net
#
############### ############### ############### ############### ############### ###
#
# NMS FormMail Version 3.14c1
#

use strict;
use vars qw(
$DEBUGGING $emulate_matts_ code $secure %more_config
$allow_empty_re f $max_recipients $mailprog @referers
@allow_mail_to @recipients %recipient_alia s
@valid_ENV $date_fmt $style $send_confirmat ion_mail
$confirmation_t ext $locale $charset $no_content
$double_spacing $wrap_text $wrap_style $postmaster
$address_style
);

# PROGRAM INFORMATION
# -------------------
# FormMail.pl Version 3.14c1
#
# This program is licensed in the same way as Perl
# itself. You are free to choose between the GNU Public
# License <http://www.gnu.org/licenses/gpl.html> or
# the Artistic License
# <http://www.perl.com/pub/a/language/misc/Artistic.html>
#
# For help on configuration or installation see the
# README file or the POD documentation at the end of
# this file.

# USER CONFIGURATION SECTION
# --------------------------
# Modify these to your own settings. You might have to
# contact your system administrator if you do not run
# your own web server. If the purpose of these
# parameters seems unclear, please see the README file.
#
BEGIN
{
$DEBUGGING = 1;
$emulate_matts_ code= 0;
$secure = 1;
$allow_empty_re f = 1;
$max_recipients = 5;
$mailprog = '/usr/lib/sendmail -oi -t';
$postmaster = 'f*******@comca st.net';
@referers = ();
@allow_mail_to = 'sc*******@comc ast.net';
@recipients = ();
%recipient_alia s = ();
@valid_ENV = qw(REMOTE_HOST REMOTE_ADDR REMOTE_USER
HTTP_USER_AGENT );
$locale = '';
$charset = 'iso-8859-1';
$date_fmt = '%A, %B %d, %Y at %H:%M:%S';
$style = 'order_form.css ';
$no_content = 0;
$double_spacing = 1;
$wrap_text = 1;
$wrap_style = 1;
$address_style = 0;
$send_confirmat ion_mail = 0;
$confirmation_t ext = <<'END_OF_CONFI RMATION';
From: yo*@your.com
Subject: form submission

Thank you for your form submission.

END_OF_CONFIRMA TION

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

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

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

#
# The code below consists of module source inlined into this
# script to make it a standalone CGI.
#
# Inlining performed by NMS inline - see /v2/buildtools/inline
# in CVS at http://sourceforge.net/projects/nms-cgi for details.
#
BEGIN {
$CGI::NMS::INLI NED_SOURCE::CGI _NMS_Mailer =
<<'END_INLINED_ CGI_NMS_Mailer' ;
package CGI::NMS::Maile r;
use strict;

use POSIX qw(strftime);

=head1 NAME

CGI::NMS::Maile r - email sender base class

=head1 SYNOPSYS

use base qw(CGI::NMS::Ma iler);

...

=head1 DESCRIPTION

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

=head1 METHODS

=over

=item output_trace_he aders ( TRACEINFO )

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

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

=cut

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

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

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

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

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

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

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

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

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

=back

=head1 VIRTUAL METHODS

Subclasses must implement the following methods:

=over

=item newmail ( TRACEINFO, SENDER, @RECIPIENTS )

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

=item print ( @ARGS )

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

=item endmail ()

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

=back

=head1 SEE ALSO

L<CGI::NMS::Mai ler::Sendmail>, L<CGI::NMS::Mai ler::SMTP>,
L<CGI::NMS::Scr ipt>

=head1 MAINTAINERS

The NMS project, E<lt>http://nms-cgi.sourceforge .net/E<gt>

To request support or report bugs, please email
E<lt>nm******** *****@lists.sou rceforge.netE<g t>

=head1 COPYRIGHT

Copyright 2003 London Perl Mongers, All rights reserved

=head1 LICENSE

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

=cut

1;
END_INLINED_CGI _NMS_Mailer
$CGI::NMS::INLI NED_SOURCE::CGI _NMS_Mailer_SMT P =
<<'END_INLINED_ CGI_NMS_Mailer_ SMTP';
package CGI::NMS::Maile r::SMTP;
use strict;

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

import CGI::NMS::Maile r }
use base qw(CGI::NMS::Ma iler);

=head1 NAME

CGI::NMS::Maile r::SMTP - mail sender using SMTP

=head1 SYNOPSYS

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

$mailer->newmail($fro m, $to);
$mailer->print($email_h eader_and_body) ;
$mailer->endmail;

=head1 DESCRIPTION

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

=head1 CONSTRUCTORS

=over

=item new ( MAILHOST )

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

=cut

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

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

=back

=head1 METHODS

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

=over

=item newmail ( SCRIPTNAME, SENDER, @RECIPIENTS )

Opens the SMTP connection and sends trace headers.

=cut

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

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

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

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

$self->output_trace_h eaders($scriptn ame);
}

=item print ( @ARGS )

Writes some email body to the SMTP socket.

=cut

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

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

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

=item endmail ()

Finishes sending the mail and closes the SMTP connection.

=cut

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

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

=back

=head1 PRIVATE METHODS

These methods should be called from within this module only.

=over

=item _smtp_getline ()

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

=cut

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

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

return $line;
}

=item _smtp_response ()

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

=cut

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

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

=item _smtp_command ( COMMAND [,EXPECT] )

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

=cut

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

$self->{Sock}->print("$comman d\015\012") or die
"write [$command] to SMTP server: $!";

my $resp = $self->_smtp_response ;
unless (substr($resp, 0, 1) eq $expect) {
die "SMTP command [$command] gave response [$resp]";
}
}

=back

=head1 MAINTAINERS

The NMS project, E<lt>http://nms-cgi.sourceforge .net/E<gt>

To request support or report bugs, please email
E<lt>nm******** *****@lists.sou rceforge.netE<g t>

=head1 COPYRIGHT

Copyright 2003 London Perl Mongers, All rights reserved

=head1 LICENSE

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

=cut

1;
END_INLINED_CGI _NMS_Mailer_SMT P
$CGI::NMS::INLI NED_SOURCE::CGI _NMS_Mailer_Sen dmail =
<<'END_INLINED_ CGI_NMS_Mailer_ Sendmail';
package CGI::NMS::Maile r::Sendmail;
use strict;

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

import CGI::NMS::Maile r }
use base qw(CGI::NMS::Ma iler);

=head1 NAME

CGI::NMS::Maile r::Sendmail - mail sender using sendmail

=head1 SYNOPSYS

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

$mailer->newmail($fro m, $to);
$mailer->print($email_h eader_and_body) ;
$mailer->endmail;

=head1 DESCRIPTION

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

=head1 CONSTRUCTORS

=over

=item new ( MAILPROG )

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

=cut

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

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

=back

=head1 METHODS

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

=over

=item newmail ( SCRIPTNAME, POSTMASTER, @RECIPIENTS )

Opens the sendmail pipe and outputs trace headers.

=cut

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

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

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

$self->output_trace_h eaders($scriptn ame);
}

=item print ( @ARGS )

Writes some email body to the sendmail pipe.

=cut

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

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

=item endmail ()

Closes the sendmail pipe.

=cut

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

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

=back

=head1 MAINTAINERS

The NMS project, E<lt>http://nms-cgi.sourceforge .net/E<gt>

To request support or report bugs, please email
E<lt>nm******** *****@lists.sou rceforge.netE<g t>

=head1 COPYRIGHT

Copyright 2003 London Perl Mongers, All rights reserved

=head1 LICENSE

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

=cut

1;
END_INLINED_CGI _NMS_Mailer_Sen dmail
unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Chars et}) {
eval <<'END_INLINED_ CGI_NMS_Charset ' or die $@;
package CGI::NMS::Chars et;
use strict;

require 5.00404;

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

=head1 NAME

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

=head1 SYNOPSIS

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

my $safe_to_put_in _html = $cs->escape($untrus ted_user_input) ;

my $printable = &{ $cs->strip_nonprint _coderef }( $input );
my $escaped = &{ $cs->escape_html_co deref }( $printable );

=head1 DESCRIPTION

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

=cut

=head1 CONSTRUCTORS

=over

=item new ( CHARSET )

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

=cut

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

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

if ($charset =~ /^utf-8$/i)
{
$self->{SN} = \&_strip_nonpri nt_utf8;
$self->{EH} = \&_escape_html_ utf8;
}
elsif ($charset =~ /^iso-8859/i)
{
$self->{SN} = \&_strip_nonpri nt_8859;
if ($charset =~ /^iso-8859-1$/i)
{
$self->{EH} = \&_escape_html_ 8859_1;
}
else
{
$self->{EH} = \&_escape_html_ 8859;
}
}
elsif ($charset =~ /^us-ascii$/i)
{
$self->{SN} = \&_strip_nonpri nt_ascii;
$self->{EH} = \&_escape_html_ 8859_1;
}
else
{
$self->{SN} = \&_strip_nonpri nt_weak;
$self->{EH} = \&_escape_html_ weak;
}

return bless $self, $pkg;
}

=back

=head1 METHODS

=over

=item charset ()

Returns the CHARSET string that was passed to the constructor.

=cut

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

return $self->{CHARSET};
}

=item escape ( STRING )

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

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

=cut

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

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

=item strip_nonprint_ coderef ()

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

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

=cut

sub strip_nonprint_ coderef
{
my ($self) = @_;

return $self->{SN};
}

=item escape_html_cod eref ()

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

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

=cut

sub escape_html_cod eref
{
my ($self) = @_;

return $self->{EH};
}

=back

=head1 DATA TABLES

=over

=item C<%eschtml_map >

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

=cut

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

=back

=head1 PRIVATE FUNCTIONS

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

=over

=item _strip_nonprint _utf8

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

=cut

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

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

#
# U+FFFE, U+FFFF and U+D800 to U+DFFF are dangerous and
# should be treated as invalid combinations, according to
# http://www.cl.cam.ac.uk/~mgk25/unicode.html
#
$string =~ s%\xEF\xBF[\xBE-\xBF]% %g;
$string =~ s%\xED[\xA0-\xBF][\x80-\xBF]% %g;

return $string;
}

=item _escape_html_ut f8 ( STRING )

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

=cut

sub _escape_html_ut f8
{
my ($string) = @_;

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

=item _strip_nonprint _weak ( STRING )

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

=cut

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

$string =~ s/\0+/ /g;
return $string;
}

=item _escape_html_we ak ( STRING )

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

=cut

sub _escape_html_we ak
{
my ($string) = @_;

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

=item _escape_html_88 59_1 ( STRING )

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

=cut

sub _escape_html_88 59_1
{
my ($string) = @_;

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

=item _escape_html_88 59 ( STRING )

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

=cut

sub _escape_html_88 59
{
my ($string) = @_;

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

=item _strip_nonprint _8859 ( STRING )

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

=cut

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

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

=item _strip_nonprint _ascii ( STRING )

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

=cut

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

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

=back

=head1 MAINTAINERS

The NMS project, E<lt>http://nms-cgi.sourceforge .net/E<gt>

To request support or report bugs, please email
E<lt>nm******** *****@lists.sou rceforge.netE<g t>

=head1 COPYRIGHT

Copyright 2002-2003 London Perl Mongers, All rights reserved

=head1 LICENSE

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

=cut

1;
END_INLINED_CGI _NMS_Charset
$INC{'CGI/NMS/Charset.pm'} = 1;
}
unless (eval {local $SIG{__DIE__} ; require
CGI::NMS::Maile r::ByScheme}) {
eval <<'END_INLINED_ CGI_NMS_Mailer_ ByScheme' or die $@;
package CGI::NMS::Maile r::ByScheme;
use strict;

=head1 NAME

CGI::NMS::Maile r::ByScheme - mail sending engine switch

=head1 SYNOPSYS

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

my $mailer =
CGI::NMS::Maile r::ByScheme->new('SMTP:mail host.bigisp.net ');

=head1 DESCRIPTION

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

=head1 CONSTRUCTORS

=over

=item new ( ARGUMENT )

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

=cut

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

if ($argument =~ /^SMTP:([\w\-\.]+(:\d+)?)/i) {
my $mailhost = $1;

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

do {
unless (eval {local $SIG{__DIE__} ; require
CGI::NMS::Maile r::Sendmail}) {
eval $CGI::NMS::INLI NED_SOURCE::CGI _NMS_Mailer_Sen dmail or die $@;
$INC{'CGI/NMS/Mailer/Sendmail.pm'} = 1;
}
undef $CGI::NMS::INLI NED_SOURCE::CGI _NMS_Mailer_Sen dmail; # to save
memory
};
return CGI::NMS::Maile r::Sendmail->new($argument) ;
}
}

=back

=head1 MAINTAINERS

The NMS project, E<lt>http://nms-cgi.sourceforge .net/E<gt>

To request support or report bugs, please email
E<lt>nm******** *****@lists.sou rceforge.netE<g t>

=head1 COPYRIGHT

Copyright 2003 London Perl Mongers, All rights reserved

=head1 LICENSE

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

=cut

1;
END_INLINED_CGI _NMS_Mailer_ByS cheme
$INC{'CGI/NMS/Mailer/ByScheme.pm'} = 1;
}
unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Scrip t}) {
eval <<'END_INLINED_ CGI_NMS_Script' or die $@;
package CGI::NMS::Scrip t;
use strict;

use CGI;
use POSIX qw(locale_h strftime);
use CGI::NMS::Chars et;

=head1 NAME

CGI::NMS::Scrip t - base class for NMS script modules

=head1 SYNOPSYS

use base qw(CGI::NMS::Sc ript);

...

=head1 DESCRIPTION

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

=head1 CONSTRUCTORS

=over

=item new ( CONFIG )

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

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

=cut

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

my $self = bless {}, $pkg;

$self->{CFG} = {
DEBUGGING => 0,
emulate_matts_c ode => 0,
secure => 1,
locale => '',
charset => 'iso-8859-1',
style => '',
cgi_post_max => 1000000,
cgi_disable_upl oads => 1,

$self->default_config uration,

@cfg
};

$self->{Charset} = CGI::NMS::Chars et->new( $self->{CFG}{charse t} );

$self->init;

return $self;
}

=back

=item CONFIGURATION SETTINGS

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

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

=over

=item C<DEBUGGING>

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

Default: 0

=item C<name_and_vers ion>

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

=item C<emulate_matts _code>

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

Default: 0

=item C<secure>

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

Default: 1

=item C<locale>

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

Default: ''

=item C<charset>

The character set to use for output documents.

Default: 'iso-8859-1'

=item C<style>

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

Default: '';

=item C<cgi_post_max >

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

Default: 1000000

=item C<cgi_disable_u ploads>

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

Default: 1

=item C<no_xml_doc_he ader>

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

Default: not set

=item C<no_doctype_do c_header>

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

Default: not set

=item C<no_xmlns_doc_ header>

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

=back

=head1 METHODS

=over

=item request ()

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

=cut

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

local ($CGI::POST_MAX , $CGI::DISABLE_U PLOADS);
$CGI::POST_MAX = $self->{CFG}{cgi_post _max};
$CGI::DISABLE_U PLOADS = $self->{CFG}{cgi_disa ble_uploads};

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

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

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

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

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

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

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

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

=item output_cgi_html _header ()

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

=cut

sub output_cgi_html _header {
my ($self) = @_;

return if $self->{Done_Header };

$self->output_cgi_hea der;

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

unless ($self->{CFG}{no_docty pe_doc_header}) {
print <<END;
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dt d">
END
}

if ($self->{CFG}{no_xmlns _doc_header}) {
print "<html>\n";
}
else {
print qq|<html xmlns="http://www.w3.org/1999/xhtml">\n|;
}

$self->{Done_Header } = 1;
}

=item output_cgi_head er ()

Outputs the CGI header for an HTML document.

=cut

sub output_cgi_head er {
my ($self) = @_;

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

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

=item output_style_el ement ()

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

=cut

sub output_style_el ement {
my ($self) = @_;

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

=item cgi_object ()

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

=cut

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

return $self->{CGI};
}

=item param ( ARGS )

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

=cut

sub param {
my $self = shift;

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

=item escape_html ( INPUT )

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

=cut

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

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

=item strip_nonprint ( INPUT )

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

=cut

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

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

=item format_date ( FORMAT_STRING [,GMT_OFFSET] )

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

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

=cut

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

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

=item name_and_versio n ()

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

=cut

sub name_and_versio n {
my ($self) = @_;

return $self->{CFG}{name_and _version};
}

=item warn ( MESSAGE )

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

=cut

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

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

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

warn "$msg\n";
}

=back

=head1 VIRTUAL METHODS

Subclasses for individual NMS scripts must provide the following
methods:

=over

=item default_configu ration ()

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

=item init ()

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

=cut

sub init {}

=item handle_request ()

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

=back

=head1 SEE ALSO

L<CGI::NMS::Cha rset>, L<CGI::NMS::Scr ipt::FormMail>

=head1 MAINTAINERS

The NMS project, E<lt>http://nms-cgi.sourceforge .net/E<gt>

To request support or report bugs, please email
E<lt>nm******** *****@lists.sou rceforge.netE<g t>

=head1 COPYRIGHT

Copyright 2003 London Perl Mongers, All rights reserved

=head1 LICENSE

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

=cut

1;
END_INLINED_CGI _NMS_Script
$INC{'CGI/NMS/Script.pm'} = 1;
}
unless (eval {local $SIG{__DIE__} ; require CGI::NMS::Valid ator}) {
eval <<'END_INLINED_ CGI_NMS_Validat or' or die $@;
package CGI::NMS::Valid ator;
use strict;

=head1 NAME

CGI::NMS::Valid ator - validation methods

=head1 SYNOPSYS

use base qw(CGI::NMS::Va lidator);

...

my $validurl = $self->validate_abs_u rl($url);

=head1 DESCRIPTION

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

=head1 METHODS

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

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

The returned value is always detainted.

=over

=item validate_abs_ur l ( URL )

Validates an absolute URL.

=cut

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

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

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

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

$path = $self->validate_local _abs_uri_frag($ path);
return '' unless $path;

return "$prefix$pa th";
}

=item validate_local_ abs_uri_frag ( URIFRAG )

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

=cut

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

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

}

=item validate_url ( URL )

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

=cut

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

if ($url =~ m#://#) {
$self->validate_abs_u rl($url);
}
else {
$self->validate_local _abs_uri_frag($ url);
}
}

=item validate_email ( EMAIL )

Validates an email address.

=cut

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

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

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

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

=item validate_realna me ( REALNAME )

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

=cut

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

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

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

=item validate_html_c olor ( COLOR )

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

=cut

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

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

=back

=head1 SEE ALSO

L<CGI::NMS::Scr ipt>

=head1 MAINTAINERS

The NMS project, E<lt>http://nms-cgi.sourceforge .net/E<gt>

To request support or report bugs, please email
E<lt>nm******** *****@lists.sou rceforge.netE<g t>

=head1 COPYRIGHT

Copyright 2003 London Perl Mongers, All rights reserved

=head1 LICENSE

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

=cut

1;
END_INLINED_CGI _NMS_Validator
$INC{'CGI/NMS/Validator.pm'} = 1;
}
unless (eval {local $SIG{__DIE__} ; require
CGI::NMS::Scrip t::FormMail}) {
eval <<'END_INLINED_ CGI_NMS_Script_ FormMail' or die $@;
package CGI::NMS::Scrip t::FormMail;
use strict;

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

use Socket; # for the inet_aton()

use CGI::NMS::Scrip t;
use CGI::NMS::Valid ator;
use CGI::NMS::Maile r::ByScheme;
use base qw(CGI::NMS::Sc ript CGI::NMS::Valid ator);

=head1 NAME

CGI::NMS::Scrip t::FormMail - FormMail CGI script

=head1 SYNOPSIS

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

use base qw(CGI::NMS::Sc ript::FormMail) ;

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

$script->request;

=head1 DESCRIPTION

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

=head1 CONFIGURATION SETTINGS

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

=over

=item C<allow_empty_r ef>

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

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

Default: 1

=item C<max_recipient s>

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

Default: 5

=item C<mailprog>

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

For example:

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

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

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

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

=item C<postmaster>

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

Default: ''

=item C<referers>

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

Default: []

=item C<allow_mail_to >

This configuration setting must be an array reference.

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

Default: []

=item C<recipients>

This configuration setting must be an array reference.

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

Default: []

=item C<recipient_ali as>

This configuration setting must be a hash reference.

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

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

%recipient_alia s = (
'1' => 'o**@your.domai n',
'2' => 't**@your.domai n',
'3' => 't****@your.dom ain',
);

In the HTML form that should submit to the recipient
C<tw*@your.doma in>,
you would then set the recipient with:

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

Default: {}

=item C<valid_ENV>

This configuration setting must be an array reference.

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

Default: ['REMOTE_HOST',' REMOTE_ADDR','R EMOTE_USER','HT TP_USER_AGENT']

=item C<date_fmt>

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

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

=item C<date_offset>

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

Default: ''

=item C<no_content>

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

Default: 0

=item C<double_spacin g>

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

Default: 1

=item C<join_string>

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

Default: ' '

=item C<wrap_text>

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

Default: 0

=item C<wrap_style>

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

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

Default: 1

=item C<address_style >

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

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

Default: 0

=item C<force_config_ *>

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

'force_config_s ubject' => 'Foo',

Default: none set

=item C<include_confi g_*>

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

Default: none set

=back

=head1 COMPILE TIME METHODS

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

=over

=item default_configu ration ()

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

=cut

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

=item init ()

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

=cut

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

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

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

$self->init_allowed_a ddress_list;

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

=item init_allowed_ad dress_list ()

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

=cut

sub init_allowed_ad dress_list {
my ($self) = @_;

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

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

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

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

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

=back

=head1 RUN TIME METHODS

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

=over

=item handle_request ()

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

Dies on error.

=cut

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

$self->{Hide_Recipien t} = 0;

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

$self->check_method_i s_post or return;

$self->parse_form;

$self->check_recipien ts( $self->get_recipien ts ) or return;

my @missing = $self->get_missing_fi elds;
if (scalar @missing) {
$self->missing_fields _output(@missin g);
return;
}

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

$self->send_main_emai l($date, $email, $realname);
$self->send_conf_emai l($date, $email, $realname);

$self->success_page($ date);
}

=item date_string ()

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

=cut

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

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

=item referer_is_ok ( REFERER )

Returns true if the referer is OK, false otherwise.

=cut

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

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

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

=item refering_host_i s_ok ( REFERING_HOST )

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

=cut

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

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

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

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

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

=item referer_error_p age ()

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

=cut

sub referer_error_p age {
my ($self) = @_;

my $referer = $self->cgi_object->referer || '';
my $escaped_refere r = $self->escape_html($r eferer);

if ( $referer =~ m|^https?://([\w\.\-]+)|i) {
my $host = $1;
$self->error_page( 'Bad Referrer - Access Denied', <<END );
<p>
The form attempting to use this script resides at
<tt>$escaped_re ferer</tt>,
which is not allowed to access this program.
</p>
<p>
If you are attempting to configure FormMail to run with this form,
you need to add the following to \@referers, explained in detail in
the
README file.
</p>
<p>
Add <tt>'$host'</tt> to your <tt><b>\@refere rs</b></tt> array.
</p>
END
}
elsif (length $referer) {
$self->error_page( 'Malformed Referrer - Access Denied', <<END );
<p>
The referrer value <tt>$escaped_re ferer</tt> cannot be parsed, so
it is not possible to check that the referring page is allowed to
access this program.
</p>
END
}
else {
$self->error_page( 'Missing Referrer - Access Denied', <<END );
<p>
Your browser did not send a <tt>Referer</tt> header with this
request, so it is not possible to check that the referring page
is allowed to access this program.
</p>
END
}
}

=item check_method_is _post ()

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

=cut

sub check_method_is _post {
my ($self) = @_;

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

my $method = $self->cgi_object->request_meth od || '';
if ($method ne 'POST') {
$self->error_page( 'Error: GET request', <<END );
<p>
The HTML form fails to specify the POST method, so it would not
be correct for this script to take any action in response to
your request.
</p>
<p>
If you are attempting to configure this form to run with FormMail,
you need to set the request method to POST in the opening form tag,
like this:
<tt>&lt;form action=&quot;/cgi-bin/FormMail.order_ form.pl&quot;
method=&quot;po st&quot;&gt;</tt>
</p>
END
return 0;
}
else {
return 1;
}
}

=item parse_form ()

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

=over

=item C<FormConfig>

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

=item C<Form>

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

=item C<Field_Order>

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

=back

=cut

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

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

foreach my $p ($self->cgi_object->param()) {
if (exists $self->{FormConfig}{$ p}) {
$self->parse_config_f orm_input($p);
}
else {
$self->parse_nonconfi g_form_input($p );
}
}

$self->substitute_for ced_config_valu es;

$self->expand_list_co nfig_items;

$self->sort_field_ord er;
$self->remove_blank_f ields;
}

=item configuration_f orm_fields ()

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

=cut

sub configuration_f orm_fields {
qw(
recipient
subject
formmail_mail_e mail
realname
redirect
bgcolor
background
link_color
vlink_color
text_color
alink_color
title
sort
print_config
required
env_report
return_link_tit le
return_link_url
print_blank_fie lds
missing_fields_ redirect
);
}

=item parse_config_fo rm_input ( NAME )

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

=cut

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

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

=item parse_nonconfig _form_input ( NAME )

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

=cut

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

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

=item expand_list_con fig_items ()

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

=cut

sub expand_list_con fig_items {
my ($self) = @_;

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

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

=item substitute_forc ed_config_value s ()

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

=cut

sub substitute_forc ed_config_value s {
my ($self) = @_;

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

=item sort_field_orde r ()

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

=cut

sub sort_field_orde r {
my ($self) = @_;

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

=item remove_blank_fi elds ()

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

=cut

sub remove_blank_fi elds {
my ($self) = @_;

return if $self->{FormConfig}{p rint_blank_fiel ds};

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

=item get_recipients ()

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

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

=cut

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

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

if (length $recipient) {
foreach my $r (split /\s*,\s*/, $recipient) {
if (exists $self->{CFG}{recipien t_alias}{$r}) {
push @recipients, split /\s*,\s*/,
$self->{CFG}{recipien t_alias}{$r};
$self->{Hide_Recipien t} = 1;
}
else {
push @recipients, $r;
}
}
}
else {
return $self->default_recipi ents;
}

return @recipients;
}

=item default_recipie nts ()

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

=cut

sub default_recipie nts {
my ($self) = @_;

my @allow = grep {/\@/} @{ $self->{CFG}{allow_ma il_to} };
if (scalar @allow > 0 and not $self->{CFG}{emulate_ matts_code}) {
$self->{Hide_Recipien t} = 1;
return ($allow[0]);
}
else {
return ();
}
}

=item check_recipient s ( @RECIPIENTS )

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

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

=cut

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

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

if (scalar(@valid) == 0) {
$self->bad_recipient_ error_page;
return 0;
}
elsif ($self->{CFG}{max_reci pients} and scalar(@valid) >
$self->{CFG}{max_reci pients}) {
$self->too_many_recip ients_error_pag e;
return 0;
}
else {
return 1;
}
}

=item recipient_is_ok ( RECIPIENT )

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

=cut

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

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

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

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

return 0;
}

=item bad_recipient_e rror_page ()

Outputs the error page for a bad or missing recipient.

=cut

sub bad_recipient_e rror_page {
my ($self) = @_;

my $errhtml = <<END;
<p>
There was no recipient or an invalid recipient specified in the
data sent to FormMail. Please make sure you have filled in the
<tt>recipient </tt> form field with an e-mail address that has
been configured in <tt>\@recipient s</tt> or <tt>\@allow_mai l_to</tt>.
More information on filling in <tt>recipient/allow_mail_to</tt>
form fields and variables can be found in the README file.
</p>
END

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

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

=item too_many_recipi ents_error_page ()

Outputs the error page for too many recipients configured.

=cut

sub too_many_recipi ents_error_page {
my ($self) = @_;

$self->error_page( 'Error: Too many Recipients', <<END );
<p>
The number of recipients configured in the form exceeds the
maximum number of recipients configured in the script. If
you are attempting to configure FormMail to run with this form
then you will need to increase the <tt>\$max_recip ients</tt>
configuration setting in the script.
</p>
END
}

=item get_missing_fie lds ()

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

=cut

sub get_missing_fie lds {
my ($self) = @_;

my @missing = ();

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

return @missing;
}

=item missing_fields_ output ( @MISSING )

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

=cut

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

if ( $self->{FormConfig}{' missing_fields_ redirect'} ) {
print
$self->cgi_object->redirect($se lf->{FormConfig}{' missing_fields_ redirect'});
}
else {
my $missing_field_ list = join '',
map { '<li>' . $self->escape_html($_ ) .
"</li>\n" }
@missing;
$self->error_page( 'Error: Blank Fields', <<END );
<p>
The following fields were left blank in your submission form:
</p>
<div class="c2">
<ul>
$missing_field_ list
</ul>
</div>
<p>
These fields must be filled in before you can successfully
submit the form.
</p>
<p>
Please use your back button to return to the form and
try again.
</p>
END
}
}

=item get_user_email ()

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

=cut

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

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

return $email;
}

=item get_user_realna me ()

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

=cut

sub get_user_realna me {
my ($self) = @_;

my $realname = $self->{FormConfig}{r ealname};
if (defined $realname) {
$realname = $self->validate_realn ame($realname);
} else {
$realname = '';
}

return $realname;
}

=item send_main_email ( DATE, EMAIL, REALNAME )

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

=cut

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

my $mailer = $self->mailer;
$mailer->newmail($sel f->name_and_versi on, $self->{CFG}{postmast er},
@{ $self->{Recipients} });

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

$self->send_main_emai l_body_header($ date);

$self->send_main_emai l_print_config;

$self->send_main_emai l_fields;

$self->send_main_emai l_footer;

$mailer->endmail;
}

=item build_from_addr ess( EMAIL, REALNAME )

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

=cut

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

my $from_address = $email;
if ( length $realname )
{
if (!$self->{CFG}{emulates _matts_code} and
$self->{CFG}{address_ style})
{
$from_address = "$realname <$email>";
}
else
{
$from_address = "$email ($realname)";
}
}

return $from_address;
}

=item send_main_email _header ( EMAIL, REALNAME )

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

=cut

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

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

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

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

=item send_main_email _body_header ( DATE )

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

=cut

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

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

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

=item send_main_email _print_config ()

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

=cut

sub send_main_email _print_config {
my ($self) = @_;

if ($self->{FormConfig}{p rint_config}) {
foreach my $cfg (@{ $self->{FormConfig}{p rint_config} }) {
if ($self->{FormConfig}{$ cfg}) {
$self->mailer->print("$cfg: $self->{FormConfig}{$ cfg}\n");
$self->mailer->print("\n") if $self->{CFG}{double_s pacing};
}
}
}
}

=item send_main_email _fields ()

Outputs the form fields to the email body.

=cut

sub send_main_email _fields {
my ($self) = @_;

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

$self->send_main_emai l_field($f, $val);
}
}

=item send_main_email _field ( NAME, VALUE )

Outputs a single form field to the email body.

=cut

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

my ($prefix, $line) = $self->build_main_ema il_field($name, $value);

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

if ($self->{CFG}{wrap_tex t} and length("$prefix $line") >
$self->email_wrap_col umns) {
$self->mailer->print( $self->wrap_field_for _email($prefix, $line) .
$nl );
}
else {
$self->mailer->print("$prefix $line$nl");
}
}

=item build_main_emai l_field ( NAME, VALUE )

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

=cut

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

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

=item wrap_field_for_ email ( PREFIX, LINE )

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

=cut

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

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

local $Text::Wrap::co lumns = $self->email_wrap_col umns;

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

=item email_wrap_colu mns ()

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

=cut

sub email_wrap_colu mns { 72; }

=item send_main_email _footer ()

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

=cut

sub send_main_email _footer {
my ($self) = @_;

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

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

=item send_conf_email ( DATE, EMAIL, REALNAME )

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

=cut

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

if ( $self->{CFG}{send_con firmation_mail} and $email =~ /\@/ ) {
my $to = $self->build_from_add ress($email, $realname);
$self->mailer->newmail("NMS FormMail.pm v$VERSION",
$self->{CFG}{postmast er}, $email);
$self->mailer->print("To: $to\n$self->{CFG}{confirma tion_text}");
$self->mailer->endmail;
}
}

=item success_page ()

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

=cut

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

if ($self->{FormConfig}{' redirect'}) {
print $self->cgi_object->redirect( $self->{FormConfig}{' redirect'}
);
}
elsif ( $self->{CFG}{'no_cont ent'}) {
print $self->cgi_object->header(Statu s => 204);
}
else {
$self->output_cgi_htm l_header;
$self->success_page_h tml_preamble($d ate);
$self->success_page_f ields;
$self->success_page_f ooter;
}
}

=item success_page_ht ml_preamble ( DATE )

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

=cut

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

my $title = $self->escape_html( $self->{FormConfig}{' title'} ||
'Thanks for submitting your order!' );
my $torecipient = 'to ' .
$self->escape_html($s elf->{FormConfig}{' recipient'});
$torecipient = '' if $self->{Hide_Recipien t};
my $attr = $self->body_attribute s;

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

$self->output_style_e lement;

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

=item success_page_fi elds ()

Outputs success page HTML output for each input field.

=cut

sub success_page_fi elds {
my ($self) = @_;

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

=item success_page_fi eld ( NAME, VALUE ) {

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

=cut

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

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

=item success_page_fo oter ()

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

=cut

sub success_page_fo oter {
my ($self) = @_;

print qq{<p><hr size="1" width="75%" /></p>\n};
$self->success_page_r eturn_link;
print <<END;
<hr size="1" width="75%" />
Click <a href="http://www.lovenotepag e.com">here</a> to return
to the site.
</body>
</html>
END
}

=item success_page_re turn_link ()

Outputs the success page return link if any is configured.

=cut

sub success_page_re turn_link {
my ($self) = @_;

if ($self->{FormConfig}{r eturn_link_url} and
$self->{FormConfig}{r eturn_link_titl e}) {
print "<ul>\n";
print '<li><a href="',
$self->escape_html($s elf->{FormConfig}{r eturn_link_url} ),
'">',
$self->escape_html($s elf->{FormConfig}{r eturn_link_titl e}), "</a>\n";
print "</li>\n</ul>\n";
}
}

=item body_attributes ()

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

=cut

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

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

my $attr = '';

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

return $attr;
}

=item error_page( TITLE, ERROR_BODY )

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

=cut

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

$self->output_cgi_htm l_header;

my $etitle = $self->escape_html($t itle);
print <<END;
<head>
<title>$etitl e</title>
END
print <<END;
<style type="text/css">
<!--
body {
background-color: #FFFFFF;
color: #000000;
}
table {
background-color: #9C9C9C;
}
p.c2 {
font-size: 80%;
text-align: center;
}
tr.title_row {
background-color: #9C9C9C;
}
tr.body_row {
background-color: #CFCFCF;
}

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

$self->output_style_e lement;

print <<END;
</head>
<body>
<table border="0" width="600" summary="">
<tr class="title_ro w">
<th class="c1">$eti tle</th>
</tr>
<tr class="body_row ">
<td>
$error_body
<hr size="1" />
<p class="3">
<a href="http://www.scriptarchi ve.com/nms.html">nms
FormMail</a> &copy; 2001 London Perl Mongers<br />Written as drop-in
replacement for <a
href="http://www.scriptarchi ve.com/formmail.html"> FormMail</a> at <a
href="http://www.scriptarchi ve.com/">Matt's Script Archive</a>
</p>
</td>
</tr>
</table>
</body>
</html>
END
}

=item mailer ()

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

=cut

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

return $self->{Mailer};
}

=back

=head1 SEE ALSO

L<CGI::NMS::Scr ipt>

=head1 MAINTAINERS

The NMS project, E<lt>http://nms-cgi.sourceforge .net/E<gt>

To request support or report bugs, please email
E<lt>nm******** *****@lists.sou rceforge.netE<g t>

=head1 COPYRIGHT

Copyright 2003 London Perl Mongers, All rights reserved

=head1 LICENSE

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

=cut

1;
END_INLINED_CGI _NMS_Script_For mMail
$INC{'CGI/NMS/Script/FormMail.pm'} = 1;
}

}
#
# End of inlined modules
#
use CGI::NMS::Scrip t::FormMail;
use base qw(CGI::NMS::Sc ript::FormMail) ;

use vars qw($script);
BEGIN {
$script = __PACKAGE__->new(
DEBUGGING => $DEBUGGING,
name_and_versio n => 'NMS FormMail 3.14c1',
emulate_matts_c ode => $emulate_matts_ code,
secure => $secure,
allow_empty_ref => $allow_empty_re f,
max_recipients => $max_recipients ,
mailprog => $mailprog,
postmaster => $postmaster,
referers => [@referers],
allow_mail_to => [@allow_mail_to],
recipients => [@recipients],
recipient_alias => {%recipient_ali as},
valid_ENV => [@valid_ENV],
locale => $locale,
charset => $charset,
date_fmt => $date_fmt,
style => $style,
no_content => $no_content,
double_spacing => $double_spacing ,
wrap_text => $wrap_text,
wrap_style => $wrap_style,
send_confirmati on_mail => $send_confirmat ion_mail,
confirmation_te xt => $confirmation_t ext,
address_style => $address_style,
%more_config
);
}

$script->request;

Mar 8 '06 #1
6 4881

sc*******@comca st.net wrote:
I can't make this script work properly. var inputFields = new Array("Lovenote "); From your code, this 'array' is intended presumably to contain the

names of the fields to be tested, however the single name it contains
isn't used in the form.
Before asking for help - check the error console, that's why it's
there.

--
S.C.

Mar 9 '06 #2
Stephen,
I'm completely new to this and that's why I'm seeking help, so please
pardon my ignorance. I am trying to learn though and I appreciate any
help. This is going to sound like a stupid question to you, but what
exactly is the "error console" and how do I access and use it?
Scott

Mar 9 '06 #3
sc*******@comca st.net wrote:
Stephen,
I'm completely new to this and that's why I'm seeking help,
so please pardon my ignorance. I am trying to learn though
and I appreciate any help. This is going to sound like a
stupid question to you, but what exactly is the "error
console" and how do I access and use it?


The 'error console' is one of a number of browser-specific methods of
reporting javascript errors:-

<URL: http://www.jibering.com/faq/#FAQ4_43 >

(Also, read the entire FAQ as it will enable you to anticipate and avoid
many potential problems when posting to this group)

If your problems are client-side javascript related you are unlikely to
be able to identify them while looking at server-side code. You (and
indeed we) would be better off looking at the combination of client-side
HTML and javascript that is sent to the browser, as that is where the
error (or faulty/ineffective code) will actually be found. You can
usually access the client-side code that is actually sent to the browser
by using a browser's view-source facility (or looking in the cache).
Viewing the source sent to the browser is a common and normal part of
debugging client-side aspects of server scripts.

Richard.
Mar 9 '06 #4
Richard,
That link doesn't work. Can you repost it with a valid link?
Thanks

Mar 9 '06 #5
sc*******@comca st.net wrote:
Richard,
That link doesn't work. Can you repost it with a valid link?


Which link? This one I guess (there's two b's in 'jibbering'):

<URL: http://www.jibbering.com/faq/#FAQ4_43 >

--
Rob
Mar 9 '06 #6
sc*******@comca st.net wrote:
That link doesn't work. Can you repost it with a valid link?


You could have searched this group for "FAQ", and would have found not only
numerous pointers with the correct URL for the FAQ, but also the text
version of the FAQ as it is posted here regularly. FWIW, here you are:

<URL:http://jibbering.com/faq/#FAQ4_43>

(Richard just forgot one "b", however the `www.' is unnecessary here.)

Please quote what you are replying to next time. This is described in the
FAQ Notes as well. See
<URL:http://www.safalra.com/special/googlegroupsrep ly/> for Google Groups
specific advice.
PointedEars
Mar 9 '06 #7

This thread has been closed and replies have been disabled. Please start a new discussion.

Similar topics

1
3946
by: Sugapablo | last post by:
In the following file below, I want it to return itself as a Rich Text Format file that populates the variables with data from the database. I set up the mime types and the filename accordingly. Now, when I call this page on a Linux system, using the Mozilla browser, it opens a dialog, asks me whether I want to save it or open it, and if I open it, opens it as test.rtf, just like I tell it to in the Content-Disposition header.
20
5762
by: O Ransen | last post by:
Hello all, I hope you can help me. Given graphical idea for a page: http://www.ransen.com/temp/temp.htm (Large image, please be patient!) What is the best way of constructing this page so that it does not require Flash or frames or active-x? It has to work on Mac (for
10
2050
by: delerious | last post by:
Please take a look at the following page: If you are using IE: http://home.comcast.net/~delerious1/index2.html If you are using Mozilla: http://home.comcast.net/~delerious1/index2_moz.html I'm trying to have a navigation menu on the left, and content on the right. With my default browser setups, there is a little bit of whitespace between the navigation menu and the content area, which is what I want. But I would also like the user to...
9
1939
by: Nicole | last post by:
Okay, so I was working primarily in dreamweaver and the site looks very good in both IE (our customers primarily use this) and Firefox (my new 'thing'), but I ran it through the validator and noticed some startling things-- I have eight errors keeping me from being valid html 4.01 transitional. Please help! What would a style sheet look like for this page, as it is one of about 30. I want this site to be fully compliant, but I've never...
2
4245
by: Nicolas LeBlanc | last post by:
I've seen several message on newsgroup, but none helped me fixed this damned problem. I am not on a load balancing, and the copy in the server is there for ages, and yet I receive 10 to 20 times a day an email with the same error happening in various places of my website.. ------------- System.Web.HttpUnhandledException: Exception of type System.Web.HttpUnhandledException was thrown. ---> System.Web.HttpException:
2
1449
by: Bob | last post by:
Hi, In the aspx file, i create a table: <asp:Table ID="table1" runat="server"> </asp:Table></p> In the code-behind, i defined a lot of cells with each an unique ID and some of them a background color (red): Dim r As TableRow Dim c(x,y) As TableCell
4
4888
by: chaz | last post by:
here is the html : <br> <table width="100%" border="0" cellspacing="0" cellpadding="0"> <tr> <td width="<%=LABEL_WIDTH%>" class="formtext"><%= HTEXT("Connection type:")%></td> <td class="formtext"> <input type="radio" class="inputRadio" id="dbStatus" name="dbStatus" value="1" onclick="changeDbStatus(1)" <%if dbStatus=1 then%checked
3
8701
by: Nathan Sokalski | last post by:
I am recieving the following error on the second postback of a page I have written: The state information is invalid for this page and might be corrupted Stack Trace: System.Convert.FromBase64String(String s) +0
0
9148
Oralloy
by: Oralloy | last post by:
Hello folks, I am unable to find appropriate documentation on the type promotion of bit-fields when using the generalised comparison operator "<=>". The problem is that using the GNU compilers, it seems that the internal comparison operator "<=>" tries to promote arguments from unsigned to signed. This is as boiled down as I can make it. Here is my compilation command: g++-12 -std=c++20 -Wnarrowing bit_field.cpp Here is the code in...
0
9012
jinu1996
by: jinu1996 | last post by:
In today's digital age, having a compelling online presence is paramount for businesses aiming to thrive in a competitive landscape. At the heart of this digital strategy lies an intricately woven tapestry of website design and digital marketing. It's not merely about having a website; it's about crafting an immersive digital experience that captivates audiences and drives business growth. The Art of Business Website Design Your website is...
1
6515
isladogs
by: isladogs | last post by:
The next Access Europe User Group meeting will be on Wednesday 1 May 2024 starting at 18:00 UK time (6PM UTC+1) and finishing by 19:30 (7.30PM). In this session, we are pleased to welcome a new presenter, Adolph Dupré who will be discussing some powerful techniques for using class modules. He will explain when you may want to use classes instead of User Defined Types (UDT). For example, to manage the data in unbound forms. Adolph will...
0
5857
by: conductexam | last post by:
I have .net C# application in which I am extracting data from word file and save it in database particularly. To store word all data as it is I am converting the whole word file firstly in HTML and then checking html paragraph one by one. At the time of converting from word file to html my equations which are in the word document file was convert into image. Globals.ThisAddIn.Application.ActiveDocument.Select();...
0
4358
by: TSSRALBI | last post by:
Hello I'm a network technician in training and I need your help. I am currently learning how to create and manage the different types of VPNs and I have a question about LAN-to-LAN VPNs. The last exercise I practiced was to create a LAN-to-LAN VPN between two Pfsense firewalls, by using IPSEC protocols. I succeeded, with both firewalls in the same network. But I'm wondering if it's possible to do the same thing, with 2 Pfsense firewalls...
0
4611
by: adsilva | last post by:
A Windows Forms form does not have the event Unload, like VB6. What one acts like?
1
3034
by: 6302768590 | last post by:
Hai team i want code for transfer the data from one system to another through IP address by using C# our system has to for every 5mins then we have to update the data what the data is updated we have to send another system
2
2319
muto222
by: muto222 | last post by:
How can i add a mobile payment intergratation into php mysql website.
3
1992
bsmnconsultancy
by: bsmnconsultancy | last post by:
In today's digital era, a well-designed website is crucial for businesses looking to succeed. Whether you're a small business owner or a large corporation in Toronto, having a strong online presence can significantly impact your brand's success. BSMN Consultancy, a leader in Website Development in Toronto offers valuable insights into creating effective websites that not only look great but also perform exceptionally well. In this comprehensive...

By using Bytes.com and it's services, you agree to our Privacy Policy and Terms of Use.

To disable or enable advertisements and analytics tracking please visit the manage ads & tracking page.