#!/usr/bin/perl -w
use strict;
use CGI;
use Fcntl qw(:flock);
$|++;
$CGI::DISABLE_UPLOADS=1;
$CGI::POST_MAX=1*1024;

my $CGI=new CGI;
my $Name=$CGI->param("Name");
my $Email=$CGI->param("Email");
my $Desc=$CGI->param("Description");
my $Address="Thomas_J_Stanley\@msn.com";

#Untaint the parameters
$Name=~s/[ -\,\;\.]//;
if($Name=~/\d/){
  die"Tainted Data!\n";
}
# This script can be found in Mastering Regular Expressions by 
# Jeff Friedl or at this site:
# http://public.yahoo.com/~jfriedl/regex/email-unopt.txt

#Some things for avoiding backslashitis later on.
my $esc        = '\\\\';            my $Period      = '\.';
my $space      = '\040';            my $tab         = '\t';
my $OpenBR     = '\[';              my $CloseBR     = '\]';
my $OpenParen  = '\(';              my $CloseParen  = '\)';
my $NonASCII   = '\x80-\xff';       my $ctrl        = '\000-\037';
my $CRlist     = '\n\015';  # note: this should really be only \015.

# Items 19, 20, 21
my $qtext = qq/[^$esc$NonASCII$CRlist\"]/;               # for within 
+"..."
my $dtext = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/;  # for within 
+[...]
my $quoted_pair = qq< $esc [^$NonASCII] >; # an escaped character

# Item 10: atom
my $atom_char = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASC
+II]/;
my $atom = qq<
  $atom_char+    # some number of atom characters...
  (?!$atom_char) # ..not followed by something that could be part of a
+n atom
>;

# Items 22 and 23, comment.
# Impossible to do properly with a regex, I make do by allowing at mos
+t one level of nesting.
my $ctext   = qq< [^$esc$NonASCII$CRlist()] >;
my $Cnested = qq< $OpenParen (?: $ctext | $quoted_pair )* $CloseParen 
+>;
my $comment = qq< $OpenParen
                     (?: $ctext | $quoted_pair | $Cnested )*
               $CloseParen >;

my $X       = qq< (?: [$space$tab] | $comment )* >; # optional separat
+or

# Item 11: doublequoted string, with escaped items allowed
my $quoted_str = qq<
        \" (?:                      # opening quote...
              $qtext                #   Anything except backslash and 
+quote
              |                     #    or
              $quoted_pair          #   Escaped something (something !
+= CR)
                             )* \"  # closing quote
>;

# Item 7: word is an atom or quoted string
my $word = qq< (?: $atom | $quoted_str ) >;

# Item 12: domain-ref is just an atom
my $domain_ref = $atom;

# Item 13 domain-literal is like a quoted string, but [...] instead of
+ "..."
my $domain_lit = qq<  $OpenBR                         # [
                   (?: $dtext | $quoted_pair )*    #    stuff
                   $CloseBR                        #           ]
>;

# Item 9: sub-domain is a domain-ref or domain-literal
my $sub_domain = qq< (?: $domain_ref | $domain_lit ) >;

# Item 6: domain is a list of subdomains separated by dots.
my $domain = qq< $sub_domain                          # initial subdom
+ain
              (?:                                  #
                 $X $Period                        # if led by a perio
+d...
                 $X $sub_domain                    #   ...further okay
              )*
>;

# Item 8: a route. A bunch of "@ $domain" separated by commas, followe
+d by a colon
my $route = qq< \@ $X $domain
             (?: $X , $X \@ $X $domain )* # further okay, if led by co
+mma
         :                                # closing colon
>;

# Item 5: local-part is a bunch of $word separated by periods
my $local_part = qq< $word                   # initial word
        (?: $X $Period $X $word )*        # further okay, if led by a 
+period
>;

# Item 2: addr-spec is local@domain
my $addr_spec  = qq< $local_part $X \@ $X $domain >;

# Item 4: route-addr is  <route? addr-spec>
my $route_addr = qq[ < $X                    # leading <
                    (?: $route $X )?      #       optional route
                        $addr_spec        #       address spec
                                    $X >  #                  trailing 
+>
];


# Item 3: phrase
my $phrase_ctrl = '\000-\010\012-\037'; # like ctrl, but without tab

# Like atom-char, but without listing space, and uses phrase_ctrl.
# Since the class is negated, this matches the same as atom-char plus 
+space and tab
my $phrase_char =
   qq/[^()<>\@,;:\".$esc$OpenBR$CloseBR$NonASCII$phrase_ctrl]/;

my $phrase = qq< $word            # one word, optionally followed by..
+..
              (?:
                  $phrase_char  |  # atom and space parts, or...
                  $comment      |  # comments, or...
                  $quoted_str      # quoted strings
              )*
>;

# Item #1: mailbox is an addr_spec or a phrase/route_addr
my $mailbox = qq< $X                         # optional leading commen
+t
                (?: $addr_spec            # address
                    |                     #  or
                    $phrase  $route_addr  # name and address
                ) $X                      # optional trailing comment
>;


if($Email=~m/^$mailbox$/xo){}else{
  die"Tainted Data!\n";
}

$Desc=~s/[*,-,\,,\;,\.]//;
$Desc=$CGI->escape_html($Desc);

print $CGI->header();
print $CGI->start_html('Parameters');
print $CGI->h3(" Name = $Name");
print $CGI->end_html();
[download]