[12359] in Perl-Users-Digest
Perl-Users Digest, Issue: 5959 Volume: 8
daemon@ATHENA.MIT.EDU (Perl-Users Digest)
Fri Jun 11 10:07:29 1999
Date: Fri, 11 Jun 99 07:00:23 -0700
From: Perl-Users Digest <Perl-Users-Request@ruby.OCE.ORST.EDU>
To: Perl-Users@ruby.OCE.ORST.EDU (Perl-Users Digest)
Perl-Users Digest Fri, 11 Jun 1999 Volume: 8 Number: 5959
Today's topics:
Re: Alter name of an array? <frederic.descamps@origin-it.com>
Re: Calculating weekday given year, month and day <garethr@cre.canon.co.uk>
defined() and my variables cmertz@my-deja.com
expat XML parser <skerr@ryder.co.uk>
Re: File upload/download Web app. <paul.bunkham@synetica.com>
Re: File upload/download Web app. <gellyfish@gellyfish.com>
Re: fork for DNS lookup - help (Michael Fuhr)
Re: fork for DNS lookup - help <delete.the.nospam.kayec@gov.ns.ca>
Formmail with Credit Card Validation problems elklabone@my-deja.com
Special: Digest Administrivia (Last modified: 12 Dec 98 (Perl-Users-Digest Admin)
----------------------------------------------------------------------
Date: Fri, 11 Jun 1999 14:46:17 +0200
From: "Frederic Descamps" <frederic.descamps@origin-it.com>
Subject: Re: Alter name of an array?
Message-Id: <01beb408$4ce581c0$04d710ac@OINLAP316.zavint.be.origin-it.com>
Hi,
It's possible.
use the syntax like that :
$tab[$i]
Paul Batt <pbatt@pop.agri.ch> wrote in article
<7jqkr4$mhs$1@pollux.ip-plus.net>...
> Can you manipulate the name of an array? I'd need a way to continuously
add
> a number to the names of arrays while creating them. The name of the
first
> array should be @array_1, the next one should be called @array_2, etc. Is
> that possibly somehow or is there any alternate way?
>
> --
> Paul Batt - Kernstrasse 27 - CH-8004 Zurich - Switzerland
> Fachjournalist
> Phone +41 1 242 39 76 - Fax +41 1 242 20 94 - Mail pbatt@access.ch
>
>
>
------------------------------
Date: Fri, 11 Jun 1999 11:25:17 GMT
From: Gareth Rees <garethr@cre.canon.co.uk>
Subject: Re: Calculating weekday given year, month and day
Message-Id: <siaeu72d42.fsf@cre.canon.co.uk>
perl_beginner@my-deja.com wrote:
> what is the most efficient way to calculate the weekday (sunday=0,
> monday=1 ...) given the year, month, and day without using the module
> provided by perl?
What's wrong with "the module provided by Perl"? (I presume you mean
Time::Local, since
use Time::Local 'timegm';
$weekday = (gmtime(timegm(0,0,0,$day,$month-1,$year-1900)))[6];
does what you want). Is this a homework question?
--
Gareth Rees
------------------------------
Date: Fri, 11 Jun 1999 12:17:27 GMT
From: cmertz@my-deja.com
Subject: defined() and my variables
Message-Id: <7jquog$e4m$1@nnrp1.deja.com>
Following is a little code that outlines a
problem I'm encountering. The problem is that
defined() is responding differently to blank
input to a function based on whether or not any
valid input was ever passed to the function.
I expected %h to go completely out of scope when
func() returns. It appears that some symbol
reference is still remaining, because defined
acts differently between the first and third call.
I have read a bit about the perl and lexical
variables, but still don't follow why %h is
defined in the third call to func().
Thanks for any insight on this.
Craig
< running Perl 5.003 on HPUX >
< the script >
#!/usr/bin/perl
sub func
{
my %h = @_;
if (!defined(%h)) {
print "\thash not defined()\n";
} else {
print "\thash defined()\n";
}
}
my %test = ("one", 1);
print "\nPassing nothing\n";
func();
print "\nPassing Something\n";
func(%test);
print "\nPassing nothing Again\n";
func();
< the output >
Passing nothing
hash not defined()
Passing Something
hash defined()
Passing nothing Again
hash defined()
Sent via Deja.com http://www.deja.com/
Share what you know. Learn what you don't.
------------------------------
Date: Thu, 10 Jun 1999 18:12:30 +0100
From: "Simon Kerr" <skerr@ryder.co.uk>
Subject: expat XML parser
Message-Id: <375ff259.0@nnrp1.news.uk.psi.net>
Hi there, I'm trying to find a way to read the characters between the start
and end tags of an element.
I'm using Perl to do this. I think I may have to use
XML_SetCharacterDataHandler.
Can anyone help?
Thanks,
Simon
------------------------------
Date: Fri, 11 Jun 1999 13:07:31 +0100
From: Paul Bunkham <paul.bunkham@synetica.com>
Subject: Re: File upload/download Web app.
Message-Id: <3760FC03.B89A9DBB@synetica.com>
Why don't people actually help in this newsgroup? Jen here, may have
posted to the wrong place, but that is no reason to not pass on
information if you have it.
Why not try going to
http://cgi.resourceindex.com/Programs_and_Scripts/Perl/File_Uploading/
There's a whole host of example apps there, and if not something that
does exactly what you want I am sure one of them could be tailored to
your needs.
Hope it helps,
Paul.
Jen wrote:
>
> We have a situation at work where peopl want to send and receive
> e-mail messages with huge attachments. We really want to prevent
> people from doing this (so that the mail servers don't get stuffed),
> but we want to provide a good alternative. FTP is apparently too hard
> for people to use.
>
> What I was thinking of doing is creating a Web site (using Perl) where
> employees and customers could upload and download files from. However,
> if something like this is available somewhere, I'd rather get it than
> create something new from scratch. Does something like this exist?
>
> Thanks!
>
> Jen
> jenmei@my-dejanews.com
--
*****************************************
Paul Bunkham
Developer
Synetica Knowledge Technologies
*****************************************
------------------------------
Date: 11 Jun 1999 14:32:04 +0100
From: Jonathan Stowe <gellyfish@gellyfish.com>
Subject: Re: File upload/download Web app.
Message-Id: <37610fd4@newsread3.dircon.co.uk>
Paul Bunkham <paul.bunkham@synetica.com> wrote:
> Why don't people actually help in this newsgroup? Jen here, may have
> posted to the wrong place, but that is no reason to not pass on
> information if you have it.
>
I suppose you think we should pass on our recipes for doughnuts as well
if someone asks ?
/J\
--
"Tony Blair. Make it so" - Patrick Stewart
------------------------------
Date: 11 Jun 1999 06:47:20 -0600
From: mfuhr@dimensional.com (Michael Fuhr)
Subject: Re: fork for DNS lookup - help
Message-Id: <7jr0go$d7u@flatland.dimensional.com>
"kayec" <delete.the.nospam.kayec@gov.ns.ca> writes:
> >> When your script does the lookups it sometimes returns 3-4....10
> different
> >> names for one IP. Now i realize this isn't a problem as it does actually
> >> happen, but is their an easy way to modify the script to only give me
> one.
> >> I don't care about the rest.
> >>
> >But which one ?
> >
> Which IP gives different names?
> Here's a few, i have lots others:
> 193.4.138.1
> 209.176.19.50
> 207.14.58.254
> 207.109.33.231
> 205.205.229.1
>
> If you mean which name would i want.... Guess i don't care. If i do an
> NSLOOKUP (win nt)
> it only retuns one, usually the first one your perl script finds.
I think this is what the poster meant -- which name out of many should
be returned? If you want just the first one, you could do something
like this:
1. Add the following line near the top of the script:
my %seen;
2. Replace the two "$rr->print" lines with this:
$rr->print unless $seen{$rr->name}++;
You should also be aware that some records are CNAME records (aliases),
so you can end up with something like this:
1.99.168.192.in-addr.arpa. ... CNAME 1.0/25.99.168.192.in-addr.arpa.
1.0/25.99.168.192.in-addr.arpa. ... PTR host.example.com.
When I get time I'll add a way to show that 192.168.99.1 is
host.example.com.
> Question about the layout of each record:
> --------------
> -------------- --??-- -?- -?-- ----------- DNS ---------
> 1.229.205.205.in-addr.arpa. 3600 IN PTR www.mail.lesoleil.com.
Field 1: The IP addresses 1.2.3.4 is looked up in DNS as
4.3.2.1.in-addr.arpa.
Field 2: The time-to-live (TTL) of the record in seconds.
Field 3: The record class (usually "IN" for "Internet").
Field 4: The record type ("PTR" for "domain name pointer")
Field 5: The record data.
See RFC 1035 for all the gory details:
ftp://ftp.rfc-editor.org/in-notes/rfc1035.txt
> >You can change the line that says :
> > $rr->print;
> >To:
> > $rr->print unless $rr->type eq "CNAME";
> >
> In the above examples i just gave you, they all show up as PTR, not CNAME.
As I mentioned above, the CNAME records are aliases. If you don't
print them, then you won't be able to map the original IP address to
the answer. I'll work on the script to take care of this so you
don't have to see the CNAME records.
--
Michael Fuhr
http://www.fuhr.org/~mfuhr/
------------------------------
Date: Fri, 11 Jun 1999 10:18:52 -0300
From: "kayec" <delete.the.nospam.kayec@gov.ns.ca>
Subject: Re: fork for DNS lookup - help
Message-Id: <80883.1288$aP5.51823@sapphire.mtt.net>
Thanks for the info and possible fix... I'll give that a try asap !
Michael Fuhr wrote in message <7jr0go$d7u@flatland.dimensional.com>...
>
>1. Add the following line near the top of the script:
>
> my %seen;
>
>2. Replace the two "$rr->print" lines with this:
>
> $rr->print unless $seen{$rr->name}++;
>
>You should also be aware that some records are CNAME records (aliases),
>so you can end up with something like this:
------------------------------
Date: Fri, 11 Jun 1999 12:18:16 GMT
From: elklabone@my-deja.com
Subject: Formmail with Credit Card Validation problems
Message-Id: <7jquq0$e4u$1@nnrp1.deja.com>
I'm trying to combine formmail.cgi with a script
that does simple credit
card validation. It won't work if the card# is
valid - formmail hangs and
won't send mail. I'm sure this is simple to a
lot of you guys, but I'm
pretty new at this. I would greatly appreciate
any help. I've attached the
script. Please respond to
elklabone@terraworld.net
Thanks!
Begin Script ----
#!/usr/local/bin/perl
#
# CC-Verify script for Visa, MasterCard, Amex and
Novus Cards
# Written 29 June 1996 by Spider
(spider@servtech.com)
# http://w3works.com
# http://www.servtech.com/public/spider
#
# Loosely based on a re-post of original by
Melvyn Myers
# (initial author unknown) but this revision
covers all 13,
# 15 and 16 digit cards using the Mod 10
algorithm.
#########
# COPYRIGHT
NOTICE
#
# Copyright 1996 Dave Paris (aka Spider) All
Rights Reserved. #
#
#
# The Validator may be used and modified free of
charge by anyone so long as #
# this copyright notice and the comments above
remain intact. By using this #
# code you agree to indemnify Dave Paris from any
liability that might #
# arise from it's
use.
#
#
#
# Selling the code for this program without prior
written consent is #
# expressly forbidden. In other words, please
ask first before you try and #
# make money off of my
program.
#
#
#
# Obtain permission before redistributing this
software over the Internet or #
# in any other medium. In all cases copyright
and header must remain intact.#
# This Copyright is in full effect in any country
that has International #
# Trade Agreements with the United States of
America. #
#########
# Get the input
read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
# Split the name-value pairs
@pairs = split(/&/, $buffer);
foreach $pair (@pairs)
{
($name, $value) = split(/=/, $pair);
# Un-Webify plus signs and %-encoding
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack
("C", hex($1))/eg;
# Stop people from using subshells to execute
commands
# Not a big deal when using sendmail, but
very important
# when using UCB mail (aka mailx).
$value =~ s/~!/ ~!/g;
# Uncomment for debugging purposes
# print "Setting $name to $value<P>";
$FORM{$name} = $value;
if ($value =~ /\<\!--\#(.*)\s+(.*)\s?=\s?(.*)-
-\>/) { &kill_input; }
if ($value =~ /[;><\*`\|]/) {
&kill_input; }
}
print "Content-type: text/html\n\n";
if ($FORM{'payby'} eq "yes") {
&no_data unless $FORM{'cardholder'};
&no_data unless $FORM{'cardnumber'};
&no_data unless $FORM{'cardexp'};
&CC_Verify;
} else {
print "Thanks\n";
# You may choose to place something else here,
like calling a printable form subroutine
exit;
}
sub CC_Verify {
$cardnumber = $FORM{'cardnumber'};
# Remove any spaces or dashes in card number
$cardnumber =~ s/ //g;
$cardnumber =~ s/-//g;
$length = length($cardnumber);
# Make sure that only numbers exist
if (!($cardnumber =~ /^[0-9]*$/)) {
&invalid_cc;
}
# Verify correct length for each card type
if ($FORM{'cardtype'} eq "visa") { &vlen; }
if ($FORM{'cardtype'} eq "mastercard") { &mclen; }
if ($FORM{'cardtype'} eq "amex") { &alen; }
if ($FORM{'cardtype'} eq "novus") { &nlen; }
sub vlen {
&invalid_cc unless (($length ==13) ||
($length == 16));
}
sub mclen {
&invalid_cc unless ($length == 16);
}
sub alen {
&invalid_cc unless ($length == 15);
}
sub nlen {
&invalid_cc unless ($length == 16);
}
# Now Verify via Mod 10 for each one
if ($FORM{'cardtype'} eq "visa") { &vver; }
if ($FORM{'cardtype'} eq "mastercard") { &ver16; }
if ($FORM{'cardtype'} eq "amex") { &ver15; }
if ($FORM{'cardtype'} eq "novus") { &ver16; }
# pick one for Visa
sub vver {
if ($length == 13) { &ver13; }
if ($length == 16) { &ver16; }
}
# For 13 digit cards
sub ver13 {
$cc0 = substr($cardnumber,0,1);
$cc1 = substr($cardnumber,1,1);
$cc2 = substr($cardnumber,2,1);
$cc3 = substr($cardnumber,3,1);
$cc4 = substr($cardnumber,4,1);
$cc5 = substr($cardnumber,5,1);
$cc6 = substr($cardnumber,6,1);
$cc7 = substr($cardnumber,7,1);
$cc8 = substr($cardnumber,8,1);
$cc9 = substr($cardnumber,9,1);
$cc10 = substr($cardnumber,10,1);
$cc11 = substr($cardnumber,11,1);
$cc12 = substr($cardnumber,12,1);
$cc1a = $cc1 * 2;
$cc3a = $cc3 * 2;
$cc5a = $cc5 * 2;
$cc7a = $cc7 * 2;
$cc9a = $cc9 * 2;
$cc11a = $cc11 * 2;
if ($cc1a >= 10) {
$cc1b = substr($cc1a,0,1);
$cc1c = substr($cc1a,1,1);
$cc1 = $cc1b+$cc1c;
} else {
$cc1 = $cc1a;
}
if ($cc3a >= 10) {
$cc3b = substr($cc3a,0,1);
$cc3c = substr($cc3a,1,1);
$cc3 = $cc3b+$cc3c;
} else {
$cc3 = $cc3a;
}
if ($cc5a >= 10) {
$cc5b = substr($cc5a,0,1);
$cc5c = substr($cc5a,1,1);
$cc5 = $cc5b+$cc5c;
} else {
$cc5 = $cc5a;
}
if ($cc7a >= 10) {
$cc7b = substr($cc7a,0,1);
$cc7c = substr($cc7a,1,1);
$cc7 = $cc7b+$cc7c;
} else {
$cc7 = $cc7a;
}
if ($cc9a >= 10) {
$cc9b = substr($cc9a,0,1);
$cc9c = substr($cc9a,1,1);
$cc9 = $cc9b+$cc9c;
} else {
$cc9 = $cc9a;
}
if ($cc11a >= 10) {
$cc11b = substr($cc11a,0,1);
$cc11c = substr($cc11a,1,1);
$cc11 = $cc11b+$cc11c;
} else {
$cc11 = $cc11a;
}
$val =
$cc0+$cc1+$cc2+$cc3+$cc4+$cc5+$cc6+$cc7+$cc8+$cc9+
$cc10+$cc11+$cc12;
if (substr($val,1,1) !=0 ) {
&invalid_cc;
}
}
# For 16 digit cards
sub ver16 {
$cc0 = substr($cardnumber,0,1);
$cc1 = substr($cardnumber,1,1);
$cc2 = substr($cardnumber,2,1);
$cc3 = substr($cardnumber,3,1);
$cc4 = substr($cardnumber,4,1);
$cc5 = substr($cardnumber,5,1);
$cc6 = substr($cardnumber,6,1);
$cc7 = substr($cardnumber,7,1);
$cc8 = substr($cardnumber,8,1);
$cc9 = substr($cardnumber,9,1);
$cc10 = substr($cardnumber,10,1);
$cc11 = substr($cardnumber,11,1);
$cc12 = substr($cardnumber,12,1);
$cc13 = substr($cardnumber,13,1);
$cc14 = substr($cardnumber,14,1);
$cc15 = substr($cardnumber,15,1);
$cc0a = $cc0 * 2;
$cc2a = $cc2 * 2;
$cc4a = $cc4 * 2;
$cc6a = $cc6 * 2;
$cc8a = $cc8 * 2;
$cc10a = $cc10 * 2;
$cc12a = $cc12 * 2;
$cc14a = $cc14 * 2;
if ($cc0a >= 10) {
$cc0b = substr($cc0a,0,1);
$cc0c = substr($cc0a,1,1);
$cc0 = $cc0b+$cc0c;
} else {
$cc0 = $cc0a;
}
if ($cc2a >= 10) {
$cc2b = substr($cc2a,0,1);
$cc2c = substr($cc2a,1,1);
$cc2 = $cc2b+$cc2c;
} else {
$cc2 = $cc2a;
}
if ($cc4a >= 10) {
$cc4b = substr($cc4a,0,1);
$cc4c = substr($cc4a,1,1);
$cc4 = $cc4b+$cc4c;
} else {
$cc4 = $cc4a;
}
if ($cc6a >= 10) {
$cc6b = substr($cc6a,0,1);
$cc6c = substr($cc6a,1,1);
$cc6 = $cc6b+$cc6c;
} else {
$cc6 = $cc6a;
}
if ($cc8a >= 10) {
$cc8b = substr($cc8a,0,1);
$cc8c = substr($cc8a,1,1);
$cc8 = $cc8b+$cc8c;
} else {
$cc8 = $cc8a;
}
if ($cc10a >= 10) {
$cc10b = substr($cc10a,0,1);
$cc10c = substr($cc10a,1,1);
$cc10 = $cc10b+$cc10c;
} else {
$cc10 = $cc10a;
}
if ($cc12a >= 10) {
$cc12b = substr($cc12a,0,1);
$cc12c = substr($cc12a,1,1);
$cc12 = $cc12b+$cc12c;
} else {
$cc12 = $cc12a;
}
if ($cc14a >= 10) {
$cc14b = substr($cc14a,0,1);
$cc14c = substr($cc14a,1,1);
$cc14 = $cc14b+$cc14c;
} else {
$cc14 = $cc14a;
}
$val =
$cc0+$cc1+$cc2+$cc3+$cc4+$cc5+$cc6+$cc7+$cc8+$cc9+
$cc10+$cc11+$cc12+$cc13+$cc14+$cc15;
if (substr($val,1,1) !=0 ) {
&invalid_cc;
}
}
# For 15 digit (Amex) cards
sub ver15 {
$cc0 = substr($cardnumber,0,1);
$cc1 = substr($cardnumber,1,1);
$cc2 = substr($cardnumber,2,1);
$cc3 = substr($cardnumber,3,1);
$cc4 = substr($cardnumber,4,1);
$cc5 = substr($cardnumber,5,1);
$cc6 = substr($cardnumber,6,1);
$cc7 = substr($cardnumber,7,1);
$cc8 = substr($cardnumber,8,1);
$cc9 = substr($cardnumber,9,1);
$cc10 = substr($cardnumber,10,1);
$cc11 = substr($cardnumber,11,1);
$cc12 = substr($cardnumber,12,1);
$cc13 = substr($cardnumber,13,1);
$cc14 = substr($cardnumber,14,1);
$cc1a = $cc1 * 2;
$cc3a = $cc3 * 2;
$cc5a = $cc5 * 2;
$cc7a = $cc7 * 2;
$cc9a = $cc9 * 2;
$cc11a = $cc11 * 2;
$cc13a = $cc13 * 2;
if ($cc1a >= 10) {
$cc1b = substr($cc1a,0,1);
$cc1c = substr($cc1a,1,1);
$cc1 = $cc1b+$cc1c;
} else {
$cc1 = $cc1a;
}
if ($cc3a >= 10) {
$cc3b = substr($cc3a,0,1);
$cc3c = substr($cc3a,1,1);
$cc3 = $cc3b+$cc3c;
} else {
$cc3 = $cc3a;
}
if ($cc5a >= 10) {
$cc5b = substr($cc5a,0,1);
$cc5c = substr($cc5a,1,1);
$cc5 = $cc5b+$cc5c;
} else {
$cc5 = $cc5a;
}
if ($cc7a >= 10) {
$cc7b = substr($cc7a,0,1);
$cc7c = substr($cc7a,1,1);
$cc7 = $cc7b+$cc7c;
} else {
$cc7 = $cc7a;
}
if ($cc9a >= 10) {
$cc9b = substr($cc9a,0,1);
$cc9c = substr($cc9a,1,1);
$cc9 = $cc9b+$cc9c;
} else {
$cc9 = $cc9a;
}
if ($cc11a >= 10) {
$cc11b = substr($cc11a,0,1);
$cc11c = substr($cc11a,1,1);
$cc11 = $cc11b+$cc11c;
} else {
$cc11 = $cc11a;
}
if ($cc13a >= 10) {
$cc13b = substr($cc13a,0,1);
$cc13c = substr($cc13a,1,1);
$cc13 = $cc13b+$cc13c;
} else {
$cc13 = $cc13a;
}
$val =
$cc0+$cc1+$cc2+$cc3+$cc4+$cc5+$cc6+$cc7+$cc8+$cc9+
$cc10+$cc11+$cc12+$cc13+$cc14;
if (substr($val,1,1) !=0 ) {
&invalid_cc;
}
}
}
##
#
# This Section For Anything Past CC Validation
#
##
####this is where I inserted formmail.cgi
#!/usr/bin/perl
##################################################
############################
# FormMail Version
1.6 #
# Copyright 1995-1997 Matt Wright
mattw@worldwidemart.com #
# Created 06/09/95 Last Modified
05/02/97 #
# Matt's Script Archive, Inc.:
http://www.worldwidemart.com/scripts/ #
##################################################
############################
# COPYRIGHT
NOTICE
#
# Copyright 1995-1997 Matthew M. Wright All
Rights Reserved. #
#
#
# FormMail may be used and modified free of
charge by anyone so long as this #
# copyright notice and the comments above remain
intact. By using this #
# code you agree to indemnify Matthew M. Wright
from any liability that #
# might arise from its
use.
#
#
#
# Selling the code for this program without prior
written consent is #
# expressly forbidden. In other words, please
ask first before you try and #
# make money off of my
program.
#
#
#
# Obtain permission before redistributing this
software over the Internet or #
# in any other medium. In all cases copyright
and header must remain intact #
##################################################
############################
# Define
Variables
#
# Detailed Information Found In README
File. #
# $mailprog defines the location of your sendmail
program on your unix #
#
system.
#
$mailprog = '/usr/sbin/sendmail';
# @referers allows forms to be located only on
servers which are defined #
# in this field. This security fix from the last
version which allowed #
# anyone on any server to use your FormMail
script on their web site. #
@referers =
('herbalifedistributors.net','206.252.176.155','he
rbalifedealers.com','herbalife1.com','herbalifepro
ducts.net');
#
Done
#
##################################################
############################
# Check Referring URL
&check_url;
# Retrieve Date
&get_date;
# Parse Form Contents
&parse_form;
# Check Required Fields
&check_required;
# Return HTML Page or Redirect User
&return_html;
# Send E-Mail
&send_mail;
sub check_url {
# Localize the check_referer flag which
determines if user is valid. #
local($check_referer) = 0;
# If a referring URL was specified, for each
valid referer, make sure #
# that a valid referring URL was passed to
FormMail. #
if ($ENV{'HTTP_REFERER'}) {
foreach $referer (@referers) {
if ($ENV{'HTTP_REFERER'} =~
m|https?://([^/]*)$referer|i) {
$check_referer = 1;
last;
}
}
}
else {
$check_referer = 1;
}
# If the HTTP_REFERER was invalid, send back
an error. #
if ($check_referer != 1) { &error
('bad_referer') }
}
sub get_date {
# Define arrays for the day of the week and
month of the year. #
@days =
('Sunday','Monday','Tuesday','Wednesday',
'Thursday','Friday','Saturday');
@months =
('January','February','March','April','May','June'
,'July',
'August','September','October','N
ovember','December');
# Get the current time and format the hour,
minutes and seconds. Add #
# 1900 to the year to get the full 4 digit
year. #
($sec,$min,$hour,$mday,$mon,$year,$wday) =
(localtime(time))[0,1,2,3,4,5,6];
$time = sprintf("%02d:%02d:%
02d",$hour,$min,$sec);
$year += 1900;
# Format the
date.
#
$date = "$days[$wday], $months[$mon] $mday,
$year at $time";
}
sub parse_form {
# Define the configuration associative
array. #
%Config =
('recipient','', 'subject','',
'email','', 'realname'
,'',
'redirect','', 'bgcolor',
'',
'background','', 'link_colo
r','',
'vlink_color','', 'text_colo
r','',
'alink_color','', 'title',''
,
'sort','', 'print_con
fig','',
'required','', 'env_repor
t','',
'return_link_title','', 'return_li
nk_url','',
'print_blank_fields','', 'missing_f
ields_redirect','');
# Determine the form's REQUEST_METHOD (GET or
POST) and split the form #
# fields up into their name-value pairs. If
the REQUEST_METHOD was #
# not GET or POST, send an
error. #
if ($ENV{'REQUEST_METHOD'} eq 'GET') {
# Split the name-value pairs
@pairs = split(/&/, $ENV{'QUERY_STRING'});
}
elsif ($ENV{'REQUEST_METHOD'} eq 'POST') {
# Get the input
read(STDIN, $buffer, $ENV
{'CONTENT_LENGTH'});
# Split the name-value pairs
@pairs = split(/&/, $buffer);
}
else {
&error('request_method');
}
# For each name-value
pair:
#
foreach $pair (@pairs) {
# Split the pair up into individual
variables. #
local($name, $value) = split(/=/, $pair);
# Decode the form encoding on the name
and value variables. #
$name =~ tr/+/ /;
$name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack
("C", hex($1))/eg;
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack
("C", hex($1))/eg;
# If they try to include server side
includes, erase them, so they
# aren't a security risk if the html gets
returned. Another
# security hole plugged up.
$value =~ s/<!--(.|\n)*-->//g;
# If the field name has been specified in
the %Config array, it will #
# return a 1 for defined($Config{$name}})
and we should associate #
# this value with the appropriate
configuration variable. If this #
# is not a configuration form field, put
it into the associative #
# array %Form, appending the value with
a ', ' if there is already a #
# value present. We also save the order
of the form fields in the #
# @Field_Order array so we can use this
order for the generic sort. #
if (defined($Config{$name})) {
$Config{$name} = $value;
}
else {
if ($Form{$name} && $value) {
$Form{$name} = "$Form{$name},
$value";
}
elsif ($value) {
push(@Field_Order,$name);
$Form{$name} = $value;
}
}
}
# The next six lines remove any extra spaces
or new lines from the #
# configuration variables, which may have
been caused if your editor #
# wraps lines after a certain length or if
you used spaces between field #
# names or environment
variables.
#
$Config{'required'} =~ s/(\s+|\n)?,
(\s+|\n)?/,/g;
$Config{'required'} =~ s/(\s+)?\n+(\s+)?//g;
$Config{'env_report'} =~ s/(\s+|\n)?,
(\s+|\n)?/,/g;
$Config{'env_report'} =~ s/(\s+)?\n+(\s+)?//g;
$Config{'print_config'} =~ s/(\s+|\n)?,
(\s+|\n)?/,/g;
$Config{'print_config'} =~ s/(\s+)?\n+
(\s+)?//g;
# Split the configuration variables into
individual field names. #
@Required = split(/,/,$Config{'required'});
@Env_Report = split(/,/,$Config
{'env_report'});
@Print_Config = split(/,/,$Config
{'print_config'});
}
sub check_required {
# Localize the variables used in this
subroutine. #
local($require, @error);
if (!$Config{'recipient'}) {
if (!defined(%Form)) { &error
('bad_referer') }
else { &error
('no_recipient') }
}
# For each require field defined in the
form: #
foreach $require (@Required) {
# If the required field is the email
field, the syntax of the email #
# address if checked to make sure it
passes a valid syntax. #
if ($require eq 'email' && !&check_email
($Config{$require})) {
push(@error,$require);
}
# Otherwise, if the required field is a
configuration field and it #
# has no value or has been filled in with
a space, send an error. #
elsif (defined($Config{$require})) {
if (!$Config{$require}) {
push(@error,$require);
}
}
# If it is a regular form field which has
not been filled in or #
# filled in with a space, flag it as an
error field. #
elsif (!$Form{$require}) {
push(@error,$require);
}
}
# If any error fields have been found, send
error message to the user. #
if (@error) { &error('missing_fields',
@error) }
}
sub return_html {
# Local variables used in this subroutine
initialized. #
local($key,$sort_order,$sorted_field);
# If redirect option is used, print the
redirectional location header. #
if ($Config{'redirect'}) {
print "Location: $Config{'redirect'}\n\n";
}
# Otherwise, begin printing the response
page. #
else {
# Print HTTP header and opening HTML
tags. #
print "Content-type: text/html\n\n";
print "<html>\n <head>\n";
# Print out title of
page #
if ($Config{'title'}) { print "
<title>$Config{'title'}</title>\n" }
else { print "
<title>Thank You</title>\n" }
print " </head>\n <body";
# Get Body Tag
Attributes
#
&body_attributes;
# Close Body
Tag
#
print ">\n <center>\n";
# Print custom or generic
title. #
if ($Config{'title'}) { print "
<h1>$Config{'title'}</h1>\n" }
else { print " <h1>Thank You For Your
Order!</h1>\n" }
print "</center>\n";
print "Below is what you submitted to
$Config{'recipient'} on ";
print "$date<p><hr size=1 width=75\%
><p>\n";
# Sort alphabetically if
specified: #
if ($Config{'sort'} eq 'alphabetic') {
foreach $field (sort keys %Form) {
# If the field has a value or the
print blank fields option #
# is turned on, print out the
form field and value. #
if ($Config{'print_blank_fields'}
|| $Form{$field}) {
print "<b>$field:</b> $Form
{$field}<p>\n";
}
}
}
# If a sort order is specified, sort the
form fields based on that. #
elsif ($Config{'sort'} =~ /^order:.*,.*/)
{
# Set the temporary $sort_order
variable to the sorting order, #
# remove extraneous line breaks and
spaces, remove the order: #
# directive and split the sort fields
into an array. #
$sort_order = $Config{'sort'};
$sort_order =~ s/(\s+|\n)?,
(\s+|\n)?/,/g;
$sort_order =~ s/(\s+)?\n+(\s+)?//g;
$sort_order =~ s/order://;
@sorted_fields = split(/,/,
$sort_order);
# For each sorted field, if it has a
value or the print blank #
# fields option is turned on print
the form field and value. #
foreach $sorted_field
(@sorted_fields) {
if ($Config{'print_blank_fields'}
|| $Form{$sorted_field}) {
print "<b>$sorted_field:</b>
$Form{$sorted_field}<p>\n";
}
}
}
# Otherwise, default to the order in
which the fields were sent. #
else {
# For each form field, if it has a
value or the print blank #
# fields option is turned on print
the form field and value. #
foreach $field (@Field_Order) {
if ($Config{'print_blank_fields'}
|| $Form{$field}) {
print "<b>$field:</b> $Form
{$field}<p>\n";
}
}
}
print "<p><hr size=1 width=75%><p>\n";
# Check for a Return Link and print one
if found. #
if ($Config{'return_link_url'} && $Config
{'return_link_title'}) {
print "<ul>\n";
print "<li><a href=\"$Config
{'return_link_url'}\">$Config{'return_link_title'}
</a>\n";
print "</ul>\n";
}
# Print the page
footer.
#
print <<"(END HTML FOOTER)";
<hr size=1 width=75%><p>
<center></center>
</body>
</html>
(END HTML FOOTER)
}
}
sub send_mail {
# Localize variables used in this
subroutine. #
local
($print_config,$key,$sort_order,$sorted_field,$env
_report);
# Open The Mail Program
open(MAIL,"|$mailprog -t");
print MAIL "To: $Config{'recipient'}\n";
print MAIL "From: $Config{'email'} ($Config
{'realname'})\n";
# Check for Message Subject
if ($Config{'subject'}) { print
MAIL "Subject: $Config{'subject'}\n\n" }
else { print
MAIL "Subject: WWW Form Submission\n\n" }
print MAIL "Below is the result of your
feedback form. It was submitted by\n";
print MAIL "$Config{'realname'} ($Config
{'email'}) on $date\n";
print MAIL "-" x 75 . "\n\n";
if (@Print_Config) {
foreach $print_config (@Print_Config) {
if ($Config{$print_config}) {
print MAIL "$print_config: $Config
{$print_config}\n\n";
}
}
}
# Sort alphabetically if
specified: #
if ($Config{'sort'} eq 'alphabetic') {
foreach $field (sort keys %Form) {
# If the field has a value or the
print blank fields option #
# is turned on, print out the form
field and value. #
if ($Config{'print_blank_fields'} ||
$Form{$field} ||
$Form{$field} eq '0') {
print MAIL "$field: $Form{$field}
\n\n";
}
}
}
# If a sort order is specified, sort the form
fields based on that. #
elsif ($Config{'sort'} =~ /^order:.*,.*/) {
# Remove extraneous line breaks and
spaces, remove the order: #
# directive and split the sort fields
into an array. #
$Config{'sort'} =~ s/(\s+|\n)?,
(\s+|\n)?/,/g;
$Config{'sort'} =~ s/(\s+)?\n+(\s+)?//g;
$Config{'sort'} =~ s/order://;
@sorted_fields = split(/,/, $Config
{'sort'});
# For each sorted field, if it has a
value or the print blank #
# fields option is turned on print the
form field and value. #
foreach $sorted_field (@sorted_fields) {
if ($Config{'print_blank_fields'} ||
$Form{$sorted_field} ||
$Form{$sorted_field} eq '0') {
print MAIL "$sorted_field: $Form
{$sorted_field}\n\n";
}
}
}
# Otherwise, default to the order in which
the fields were sent. #
else {
# For each form field, if it has a value
or the print blank #
# fields option is turned on print the
form field and value. #
foreach $field (@Field_Order) {
if ($Config{'print_blank_fields'} ||
$Form{$field} ||
$Form{$field} eq '0') {
print MAIL "$field: $Form{$field}
\n\n";
}
}
}
print MAIL "-" x 75 . "\n\n";
# Send any specified Environment Variables to
recipient. #
foreach $env_report (@Env_Report) {
if ($ENV{$env_report}) {
print MAIL "$env_report: $ENV
{$env_report}\n";
}
}
close (MAIL);
}
sub check_email {
# Initialize local email variable with input
to subroutine. #
$email = $_[0];
# If the e-mail address
contains: #
if ($email =~ /(@.*@)|(\.\.)|(@\.)|(\.@)|
(^\.)/ ||
# the e-mail address contains an invalid
syntax. Or, if the #
# syntax does not match the following
regular expression pattern #
# it fails basic syntax
verification. #
$email !~ /^.+\@(\[?)[a-zA-Z0-9\-\.]+\.
([a-zA-Z]{2,3}|[0-9]{1,3})(\]?)$/) {
# Basic syntax requires: one or more
characters before the @ sign, #
# followed by an optional '[', then any
number of letters, numbers, #
# dashes or periods (valid domain/IP
characters) ending in a period #
# and then 2 or 3 letters (for domain
suffixes) or 1 to 3 numbers #
# (for IP addresses). An ending bracket
is also allowed as it is #
# valid syntax to have an email address
like: user@[255.255.255.0] #
# Return a false value, since the e-mail
address did not pass valid #
#
syntax.
#
return 0;
}
else {
# Return a true value, e-mail
verification passed. #
return 1;
}
}
sub body_attributes {
# Check for Background Color
if ($Config{'bgcolor'}) { print "
bgcolor=\"$Config{'bgcolor'}\"" }
# Check for Background Image
if ($Config{'background'}) { print "
background=\"$Config{'background'}\"" }
# Check for Link Color
if ($Config{'link_color'}) { print "
link=\"$Config{'link_color'}\"" }
# Check for Visited Link Color
if ($Config{'vlink_color'}) { print "
vlink=\"$Config{'vlink_color'}\"" }
# Check for Active Link Color
if ($Config{'alink_color'}) { print "
alink=\"$Config{'alink_color'}\"" }
# Check for Body Text Color
if ($Config{'text_color'}) { print "
text=\"$Config{'text_color'}\"" }
}
sub error {
# Localize variables and assign subroutine
input. #
local($error,@error_fields) = @_;
local
($host,$missing_field,$missing_field_list);
if ($error eq 'bad_referer') {
if ($ENV{'HTTP_REFERER'} =~ m|^https?://
([\w\.]+)|i) {
$host = $1;
print <<"(END ERROR HTML)";
Content-type: text/html
<html>
<head>
<title>Bad Referrer - Access Denied</title>
</head>
<body bgcolor=#FFFFFF text=#000000>
<center>
<table border=0 width=600 bgcolor=#9C9C9C>
<tr><th><font size=+2>Bad Referrer - Access
Denied</font></th></tr>
</table>
<table border=0 width=600 bgcolor=#CFCFCF>
<tr><td>The form attempting to use
<a
href="http://www.worldwidemart.com/scripts/formmai
l.shtml">FormMail</a>
resides at <tt>$ENV{'HTTP_REFERER'}</tt>,
which is not allowed to access
this cgi script.<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>
Add <tt>'$host'</tt> to your
<tt><b>\@referers</b></tt> array.<hr size=1>
<center>
</font></center>
</td></tr>
</table>
</center>
</body>
</html>
(END ERROR HTML)
}
else {
print <<"(END ERROR HTML)";
Content-type: text/html
<html>
<head>
<title>FormMail v1.6</title>
</head>
<body bgcolor=#FFFFFF text=#000000>
<center>
<table border=0 width=600 bgcolor=#9C9C9C>
<tr><th><font
size=+2>FormMail</font></th></tr>
</table>
<table border=0 width=600 bgcolor=#CFCFCF>
<tr><th><tt><font size=+1>Copyright 1995 -
1997 Matt Wright<br>
Version 1.6 - Released May 02, 1997<br>
</font></tt></th></tr>
</table>
</center>
</body>
</html>
(END ERROR HTML)
}
}
elsif ($error eq 'request_method') {
print <<"(END ERROR HTML)";
Content-type: text/html
<html>
<head>
<title>Error: Request Method</title>
</head>
<body bgcolor=#FFFFFF text=#000000>
<center>
<table border=0 width=600 bgcolor=#9C9C9C>
<tr><th><font size=+2>Error: Request
Method</font></th></tr>
</table>
<table border=0 width=600 bgcolor=#CFCFCF>
<tr><td>The Request Method of the Form you
submitted did not match
either <tt>GET</tt> or <tt>POST</tt>.
Please check the form and make sure the
<tt>method=</tt> statement is in upper case
and matches <tt>GET</tt> or <tt>POST</tt>.<p>
<center><font size=-1>
</font></center>
</td></tr>
</table>
</center>
</body>
</html>
(END ERROR HTML)
}
elsif ($error eq 'no_recipient') {
print <<"(END ERROR HTML)";
Content-type: text/html
<html>
<head>
<title>Error: No Recipient</title>
</head>
<body bgcolor=#FFFFFF text=#000000>
<center>
<table border=0 width=600 bgcolor=#9C9C9C>
<tr><th><font size=+2>Error: No
Recipient</font></th></tr>
</table>
<table border=0 width=600 bgcolor=#CFCFCF>
<tr><td>No Recipient was specified in the
data sent to FormMail. Please
make sure you have filled in the 'recipient'
form field with an e-mail
address. More information on filling in
recipient form fields can be
found in the README file.<hr size=1>
<center><font size=-1>
</font></center>
</td></tr>
</table>
</center>
</body>
</html>
(END ERROR HTML)
}
elsif ($error eq 'missing_fields') {
if ($Config{'missing_fields_redirect'}) {
print "Location: $Config
{'missing_fields_redirect'}\n\n";
}
else {
foreach $missing_field
(@error_fields) {
$missing_field_list .= "
<li>$missing_field\n";
}
print <<"(END ERROR HTML)";
Content-type: text/html
<html>
<head>
<title>Error: Blank Fields</title>
</head>
<center>
<table border=0 width=600 bgcolor=#9C9C9C>
<tr><th><font size=+2>Error: Blank
Fields</font></th></tr>
</table>
<table border=0 width=600 bgcolor=#CFCFCF>
<tr><td>The following fields were left blank
in your submission form:<p>
<ul>
$missing_field_list
</ul><br>
These fields must be filled in before you
can successfully submit the form.<p>
Please use your browser's back button to
return to the form and try again.<hr size=1>
<center><font size=-1>
</font></center>
</td></tr>
</table>
</center>
</body>
</html>
(END ERROR HTML)
}
}
exit;
}
# this is where formmail.cgi ends
# print "Thank You\! Your Card Has Passed
Validation. It will now be # submitted for
Charge Authorization.\n";
exit;
sub invalid_cc {
print "The Credit Card number you've supplied
does not pass verification. Please \n";
print "use your <B>Back</B> button and verify
that the number you've entered is correct \n";
print "and contains no additional characters
other than spaces or hyphens.\n";
exit;
}
sub kill_input {
print "Content-type: text/html\n\n";
$value = "";
print "<CENTER><H1><FONT COLOR=\"\#FF0000
\">CGI Alert</FONT></H1></CENTER>\n";
print "<CENTER><H3>It appears as though
you've tried to \n";
print "execute a system command via a SSI tag
or shell metacharacter. \n";
print "Please use your <B>Back</B> button,
remove the tags or characters and re-submit. \n";
print "Thanks\!</H3></CENTER>\n";
exit;
}
sub no_data {
print "It would seem that you've forgotten to
fill in one or more of \n";
print "the required fields. Please use your
<B>Back</B> button to \n";
print "do that now. Thanks\!\n";
exit;
}
Sent via Deja.com http://www.deja.com/
Share what you know. Learn what you don't.
------------------------------
Date: 12 Dec 98 21:33:47 GMT (Last modified)
From: Perl-Request@ruby.oce.orst.edu (Perl-Users-Digest Admin)
Subject: Special: Digest Administrivia (Last modified: 12 Dec 98)
Message-Id: <null>
Administrivia:
Well, after 6 months, here's the answer to the quiz: what do we do about
comp.lang.perl.moderated. Answer: nothing.
]From: Russ Allbery <rra@stanford.edu>
]Date: 21 Sep 1998 19:53:43 -0700
]Subject: comp.lang.perl.moderated available via e-mail
]
]It is possible to subscribe to comp.lang.perl.moderated as a mailing list.
]To do so, send mail to majordomo@eyrie.org with "subscribe clpm" in the
]body. Majordomo will then send you instructions on how to confirm your
]subscription. This is provided as a general service for those people who
]cannot receive the newsgroup for whatever reason or who just prefer to
]receive messages via e-mail.
The Perl-Users Digest is a retransmission of the USENET newsgroup
comp.lang.perl.misc. For subscription or unsubscription requests, send
the single line:
subscribe perl-users
or:
unsubscribe perl-users
to almanac@ruby.oce.orst.edu.
To submit articles to comp.lang.perl.misc (and this Digest), send your
article to perl-users@ruby.oce.orst.edu.
To submit articles to comp.lang.perl.announce, send your article to
clpa@perl.com.
To request back copies (available for a week or so), send your request
to almanac@ruby.oce.orst.edu with the command "send perl-users x.y",
where x is the volume number and y is the issue number.
The Meta-FAQ, an article containing information about the FAQ, is
available by requesting "send perl-users meta-faq". The real FAQ, as it
appeared last in the newsgroup, can be retrieved with the request "send
perl-users FAQ". Due to their sizes, neither the Meta-FAQ nor the FAQ
are included in the digest.
The "mini-FAQ", which is an updated version of the Meta-FAQ, is
available by requesting "send perl-users mini-faq". It appears twice
weekly in the group, but is not distributed in the digest.
For other requests pertaining to the digest, send mail to
perl-users-request@ruby.oce.orst.edu. Do not waste your time or mine
sending perl questions to the -request address, I don't have time to
answer them even if I did know the answer.
------------------------------
End of Perl-Users Digest V8 Issue 5959
**************************************
