Mail-RFC822-Address-0.3/0040755000076400007640000000000007455770645012672 5ustar pdwpdwMail-RFC822-Address-0.3/INSTALL0100644000076400007640000000006407455640107013705 0ustar pdwpdwperl Makefile.PL make make test [ su ] make install Mail-RFC822-Address-0.3/Makefile.PL0100644000076400007640000000045407455640107014631 0ustar pdwpdwuse ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'Mail::RFC822::Address', 'VERSION_FROM' => 'Address.pm', # finds $VERSION 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1 ); Mail-RFC822-Address-0.3/Changes0100644000076400007640000000065307455656465014171 0ustar pdwpdwRevision history for Perl extension Mail::RFC822::Address. 0.3 Fri Apr 12 2002 - Changed behaviour of validlist when called in list context Nick Cabatoff 0.2 Sat Apr 14 2001 - now allows null items in list as per RFC822 Sam Roberts - other slight tweaks to the regexp - added INSTALL file 0.01 Sat Jan 20 2001 - original version Mail-RFC822-Address-0.3/Address.pm0100644000076400007640000001454307455770624014616 0ustar pdwpdwpackage Mail::RFC822::Address; use strict; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); require Exporter; @ISA = qw(Exporter); # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. @EXPORT_OK = qw( valid validlist ); @EXPORT = qw( ); $VERSION = '0.3'; my $rfc822re; # Preloaded methods go here. my $lwsp = "(?:(?:\\r\\n)?[ \\t])"; sub make_rfc822re { # Basic lexical tokens are specials, domain_literal, quoted_string, atom, and # comment. We must allow for lwsp (or comments) after each of these. # This regexp will only work on addresses which have had comments stripped # and replaced with lwsp. my $specials = '()<>@,;:\\\\".\\[\\]'; my $controls = '\\000-\\031'; my $dtext = "[^\\[\\]\\r\\\\]"; my $domain_literal = "\\[(?:$dtext|\\\\.)*\\]$lwsp*"; my $quoted_string = "\"(?:[^\\\"\\r\\\\]|\\\\.|$lwsp)*\"$lwsp*"; # Use zero-width assertion to spot the limit of an atom. A simple # $lwsp* causes the regexp engine to hang occasionally. my $atom = "[^$specials $controls]+(?:$lwsp+|\\Z|(?=[\\[\"$specials]))"; my $word = "(?:$atom|$quoted_string)"; my $localpart = "$word(?:\\.$lwsp*$word)*"; my $sub_domain = "(?:$atom|$domain_literal)"; my $domain = "$sub_domain(?:\\.$lwsp*$sub_domain)*"; my $addr_spec = "$localpart\@$lwsp*$domain"; my $phrase = "$word*"; my $route = "(?:\@$domain(?:,\@$lwsp*$domain)*:$lwsp*)"; my $route_addr = "\\<$lwsp*$route?$addr_spec\\>$lwsp*"; my $mailbox = "(?:$addr_spec|$phrase$route_addr)"; my $group = "$phrase:$lwsp*(?:$mailbox(?:,\\s*$mailbox)*)?;\\s*"; my $address = "(?:$mailbox|$group)"; return "$lwsp*$address"; } sub strip_comments { my $s = shift; # Recursively remove comments, and replace with a single space. The simpler # regexps in the Email Addressing FAQ are imperfect - they will miss escaped # chars in atoms, for example. while ($s =~ s/^((?:[^"\\]|\\.)* (?:"(?:[^"\\]|\\.)*"(?:[^"\\]|\\.)*)*) \((?:[^()\\]|\\.)*\)/$1 /osx) {} return $s; } # valid: returns true if the parameter is an RFC822 valid address # sub valid ($) { my $s = strip_comments(shift); if (!$rfc822re) { $rfc822re = make_rfc822re(); } return $s =~ m/^$rfc822re$/so; } # validlist: In scalar context, returns true if the parameter is an RFC822 # valid list of addresses. # # In list context, returns an empty list on failure (an invalid # address was found); otherwise a list whose first element is the # number of addresses found and whose remaining elements are the # addresses. This is needed to disambiguate failure (invalid) # from success with no addresses found, because an empty string is # a valid list. sub validlist ($) { my $s = strip_comments(shift); if (!$rfc822re) { $rfc822re = make_rfc822re(); } # * null list items are valid according to the RFC # * the '1' business is to aid in distinguishing failure from no results my @r; if($s =~ m/^(?:$rfc822re)?(?:,(?:$rfc822re)?)*$/so) { while($s =~ m/(?:^|,$lwsp*)($rfc822re)/gos) { push @r, $1; } return wantarray ? (scalar(@r), @r) : 1; } else { return wantarray ? () : 0; } } 1; __END__ =head1 NAME Mail::RFC822::Address - Perl extension for validating email addresses according to RFC822 =head1 SYNOPSIS use Mail::RFC822::Address qw(valid validlist); if (valid("pdw@ex-parrot.com")) { print "That's a valid address\n"; } if (validlist("pdw@ex-parrot.com, other@elsewhere.com")) { print "That's a valid list of addresses\n"; } =head1 DESCRIPTION Mail::RFC822::Address validates email addresses against the grammar described in RFC 822 using regular expressions. How to validate a user supplied email address is a FAQ (see perlfaq9): the only sure way to see if a supplied email address is genuine is to send an email to it and see if the user recieves it. The one useful check that can be performed on an address is to check that the email address is syntactically valid. That is what this module does. This module is functionally equivalent to RFC::RFC822::Address, but uses regular expressions rather than the Parse::RecDescent parser. This means that startup time is greatly reduced making it suitable for use in transient scripts such as CGI scripts. =head2 valid ( address ) Returns true or false to indicate if address is an RFC822 valid address. =head2 validlist ( addresslist ) In scalar context, returns true if the parameter is an RFC822 valid list of addresses. In list context, returns an empty list on failure (an invalid address was found); otherwise a list whose first element is the number of addresses found and whose remaining elements are the addresses. This is needed to disambiguate failure (invalid) from success with no addresses found, because an empty string is a valid list. =head1 AUTHOR Paul Warren, pdw@ex-parrot.com =head1 CREDITS Most of the test suite in test.pl is taken from RFC::RFC822::Address, written by Abigail, abigail@foad.org =head1 COPYRIGHT and LICENSE This program is copyright 2001-2002 by Paul Warren. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO RFC::RFC822::Address, Mail::Address =cut Mail-RFC822-Address-0.3/MANIFEST0100644000076400007640000000007007455640107014002 0ustar pdwpdwAddress.pm Changes MANIFEST Makefile.PL test.pl INSTALL Mail-RFC822-Address-0.3/test.pl0100644000076400007640000001211507455654214014174 0ustar pdwpdw# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..80\n"; } END {print "not ok 1\n" unless $loaded;} use Mail::RFC822::Address qw(valid validlist); use Data::Dumper; $loaded = 1; print "ok 1\n"; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): # # These test cases are taken from RFC::RFC822::Address # my @valids = split /\n/ => <<'VALIDS'; abigail@example.com abigail@example.com abigail@example.com abigail @example.com *@example.net "\""@foo.bar fred&barny@example.com ---@example.com foo-bar@example.net "127.0.0.1"@[127.0.0.1] Abigail Abigail Abigail<@a,@b,@c:abigail@example.com> "This is a phrase" "Abigail " "Joe & J. Harvey" Abigail Abigail made this < abigail @ example . com > Abigail(the bitch)@example.com Abigail Abigail < (one) abigail (two) @(three)example . (bar) com (quz) > Abigail (foo) (((baz)(nested) (comment)) ! ) < (one) abigail (two) @(three)example . (bar) com (quz) > Abigail Abigail (foo) abigail@example.com abigail@example.com (foo) "Abi\"gail" abigail@[example.com] abigail@[exa\[ple.com] abigail@[exa\]ple.com] ":sysmail"@ Some-Group. Some-Org Muhammed.(I am the greatest) Ali @(the)Vegas.WBA mailbox.sub1.sub2@this-domain sub-net.mailbox@sub-domain.domain name:; ':; name: ; Alfred Neuman Neuman@BBN-TENEXA "George, Ted" Wilt . (the Stilt) Chamberlain@NBA.US Cruisers: Port@Portugal, Jones@SEA; $@[] *()@[] VALIDS push @valids => qq {"Joe & J. Harvey"\x0D\x0A }, qq {"Joe &\x0D\x0A J. Harvey" }, qq {Gourmets: Pompous Person ,\x0D\x0A} . qq { Childs\@WGBH.Boston, "Galloping Gourmet"\@\x0D\x0A} . qq { ANT.Down-Under (Australian National Television),\x0D\x0A} . qq { Cheapie\@Discount-Liquors;}, ; my @invalids = split /\n/ => <<'INVALIDS'; Just a string string (comment) ()@example.com fred(&)barny@example.com fred\ barny@example.com Abigail Abigail Abigail "Abi"gail" abigail@[exa]ple.com] abigail@[exa[ple.com] abigail@[exaple].com] abigail@ @example.com phrase: abigail@example.com abigail@example.com ; INVALIDS # ' Fix syntax highlighting. push @invalids => # Invalid, only a LF, no CR. qq {"Joe & J. Harvey"\x0A }, # Invalid, CR LF not followed by a space. qq {"Joe &\x0D\x0AJ. Harvey" }, # This appears in RFC 822, but ``Galloping Gourmet'' should be quoted. qq {Gourmets: Pompous Person ,\x0D\x0A} . qq { Childs\@WGBH.Boston, Galloping Gourmet\@\x0D\x0A} . qq { ANT.Down-Under (Australian National Television),\x0D\x0A} . qq { Cheapie\@Discount-Liquors;}, # Invalid, only a CR, no LF. qq {"Joe & J. Harvey"\x0D }, ; my @validlists = split /\n/, <<'VALIDLISTS'; pdw@ex-parrot.com, pdw@somewhere.else Paul Warren , foo.bar@blort.net And (with) Comments < (foo) bar@blort.net>, item2@example.com, Person 3 null@list.items,,are@valid.too pdw@ex-parrot.com, ,i.think@this.is.valid.too VALIDLISTS my $c = 1; foreach my $test (@valids) { my $d = sprintf "%3d" => ++ $c; my $valid = valid ($test); print $valid ? "ok $d" : "not ok $d"; print "# [VALID: $test] " unless $valid; print "\n"; } foreach my $test (@invalids) { my $d = sprintf "%3d" => ++ $c; my $valid = valid ($test); print $valid ? "not ok $d" : "ok $d"; print "# [INVALID: $test] " if $valid; print "\n"; } foreach my $test (@validlists) { my $d = sprintf "%3d" => ++ $c; my $valid = validlist ($test); print $valid ? "ok $d" : "not ok $d"; print "# [VALID: $test] " unless $valid; print "\n"; } my $d; testlist('abc@foo.com, abc@blort.foo',1, (2, 'abc@foo.com', 'abc@blort.foo')); testlist('abc@foo.com, abcblort.foo',0, ()); testlist('',1, (0)); sub testlist { my($in, $scalar, @listctl) = @_; my $d = sprintf "%3d" => ++ $c; @res = validlist($in); # Is there a better way to compare two lists? if(Dumper(\@res) == Dumper(\@ctl)) { print "ok $d\n"; } else { print "not ok $d\n"; print "[validlist (list): $in]\n"; } $d = sprintf "%3d" => ++ $c; if($scalar == validlist($in)) { print "ok $d\n"; } else { print "not ok $d\n"; print "[validlist (scalar): $in]\n"; } }