r28272 - in /branches/upstream/mail-rfc822-address: ./ current/ current/Address.pm current/Changes current/INSTALL current/MANIFEST current/Makefile.PL current/test.pl
gregoa at users.alioth.debian.org
gregoa at users.alioth.debian.org
Tue Dec 16 00:21:14 UTC 2008
Author: gregoa
Date: Tue Dec 16 00:21:11 2008
New Revision: 28272
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=28272
Log:
[svn-inject] Installing original source of mail-rfc822-address
Added:
branches/upstream/mail-rfc822-address/
branches/upstream/mail-rfc822-address/current/
branches/upstream/mail-rfc822-address/current/Address.pm
branches/upstream/mail-rfc822-address/current/Changes
branches/upstream/mail-rfc822-address/current/INSTALL
branches/upstream/mail-rfc822-address/current/MANIFEST
branches/upstream/mail-rfc822-address/current/Makefile.PL
branches/upstream/mail-rfc822-address/current/test.pl
Added: branches/upstream/mail-rfc822-address/current/Address.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/mail-rfc822-address/current/Address.pm?rev=28272&op=file
==============================================================================
--- branches/upstream/mail-rfc822-address/current/Address.pm (added)
+++ branches/upstream/mail-rfc822-address/current/Address.pm Tue Dec 16 00:21:11 2008
@@ -1,0 +1,200 @@
+package Mail::RFC822::Address;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
+
+require Exporter;
+
+ at 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.
+
+ at EXPORT_OK = qw( valid validlist );
+
+ at 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 at ex-parrot.com")) {
+ print "That's a valid address\n";
+ }
+
+ if (validlist("pdw at ex-parrot.com, other at 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 at ex-parrot.com
+
+=head1 CREDITS
+
+Most of the test suite in test.pl is taken from RFC::RFC822::Address, written
+by Abigail, abigail at 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
Added: branches/upstream/mail-rfc822-address/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/mail-rfc822-address/current/Changes?rev=28272&op=file
==============================================================================
--- branches/upstream/mail-rfc822-address/current/Changes (added)
+++ branches/upstream/mail-rfc822-address/current/Changes Tue Dec 16 00:21:11 2008
@@ -1,0 +1,15 @@
+Revision history for Perl extension Mail::RFC822::Address.
+
+0.3 Fri Apr 12 2002
+ - Changed behaviour of validlist when called in list context
+ Nick Cabatoff <ncabatoff at exodus.net>
+
+0.2 Sat Apr 14 2001
+ - now allows null items in list as per RFC822
+ Sam Roberts <sroberts at uniserve.com>
+ - other slight tweaks to the regexp
+ - added INSTALL file
+
+0.01 Sat Jan 20 2001
+ - original version
+
Added: branches/upstream/mail-rfc822-address/current/INSTALL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/mail-rfc822-address/current/INSTALL?rev=28272&op=file
==============================================================================
--- branches/upstream/mail-rfc822-address/current/INSTALL (added)
+++ branches/upstream/mail-rfc822-address/current/INSTALL Tue Dec 16 00:21:11 2008
@@ -1,0 +1,5 @@
+perl Makefile.PL
+make
+make test
+[ su ]
+make install
Added: branches/upstream/mail-rfc822-address/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/mail-rfc822-address/current/MANIFEST?rev=28272&op=file
==============================================================================
--- branches/upstream/mail-rfc822-address/current/MANIFEST (added)
+++ branches/upstream/mail-rfc822-address/current/MANIFEST Tue Dec 16 00:21:11 2008
@@ -1,0 +1,6 @@
+Address.pm
+Changes
+MANIFEST
+Makefile.PL
+test.pl
+INSTALL
Added: branches/upstream/mail-rfc822-address/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/mail-rfc822-address/current/Makefile.PL?rev=28272&op=file
==============================================================================
--- branches/upstream/mail-rfc822-address/current/Makefile.PL (added)
+++ branches/upstream/mail-rfc822-address/current/Makefile.PL Tue Dec 16 00:21:11 2008
@@ -1,0 +1,8 @@
+use 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
+);
Added: branches/upstream/mail-rfc822-address/current/test.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/mail-rfc822-address/current/test.pl?rev=28272&op=file
==============================================================================
--- branches/upstream/mail-rfc822-address/current/test.pl (added)
+++ branches/upstream/mail-rfc822-address/current/test.pl Tue Dec 16 00:21:11 2008
@@ -1,0 +1,182 @@
+# 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 at example.com
+abigail at example.com
+ abigail at example.com
+abigail @example.com
+*@example.net
+"\""@foo.bar
+fred&barny at example.com
+--- at example.com
+foo-bar at example.net
+"127.0.0.1"@[127.0.0.1]
+Abigail <abigail at example.com>
+Abigail<abigail at example.com>
+Abigail<@a, at b, at c:abigail at example.com>
+"This is a phrase"<abigail at example.com>
+"Abigail "<abigail at example.com>
+"Joe & J. Harvey" <example @Org>
+Abigail <abigail @ example.com>
+Abigail made this < abigail @ example . com >
+Abigail(the bitch)@example.com
+Abigail <abigail @ example . (bar) com >
+Abigail < (one) abigail (two) @(three)example . (bar) com (quz) >
+Abigail (foo) (((baz)(nested) (comment)) ! ) < (one) abigail (two) @(three)example . (bar) com (quz) >
+Abigail <abigail(fo\(o)@example.com>
+Abigail <abigail(fo\)o)@example.com>
+(foo) abigail at example.com
+abigail at example.com (foo)
+"Abi\"gail" <abigail at example.com>
+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 at this-domain
+sub-net.mailbox at sub-domain.domain
+name:;
+':;
+name: ;
+Alfred Neuman <Neuman at BBN-TENEXA>
+Neuman at BBN-TENEXA
+"George, Ted" <Shared at Group.Arpanet>
+Wilt . (the Stilt) Chamberlain at NBA.US
+Cruisers: Port at Portugal, Jones at SEA;
+$@[]
+*()@[]
+VALIDS
+
+push @valids =>
+ qq {"Joe & J. Harvey"\x0D\x0A <ddd\@ Org>},
+ qq {"Joe &\x0D\x0A J. Harvey" <ddd \@ Org>},
+ qq {Gourmets: Pompous Person <WhoZiWhatZit\@Cordon-Bleu>,\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 at example.com
+fred\ barny at example.com
+Abigail <abi gail @ example.com>
+Abigail <abigail(fo(o)@example.com>
+Abigail <abigail(fo)o)@example.com>
+"Abi"gail" <abigail at example.com>
+abigail@[exa]ple.com]
+abigail@[exa[ple.com]
+abigail@[exaple].com]
+abigail@
+ at example.com
+phrase: abigail at example.com abigail at example.com ;
+INVALIDS
+
+# ' Fix syntax highlighting.
+
+push @invalids =>
+ # Invalid, only a LF, no CR.
+ qq {"Joe & J. Harvey"\x0A <ddd\@ Org>},
+ # Invalid, CR LF not followed by a space.
+ qq {"Joe &\x0D\x0AJ. Harvey" <ddd \@ Org>},
+ # This appears in RFC 822, but ``Galloping Gourmet'' should be quoted.
+ qq {Gourmets: Pompous Person <WhoZiWhatZit\@Cordon-Bleu>,\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 <ddd\@ Org>},
+;
+
+my @validlists = split /\n/, <<'VALIDLISTS';
+pdw at ex-parrot.com, pdw at somewhere.else
+Paul Warren <pdw at ex-parrot.com>, foo.bar at blort.net
+And (with) Comments < (foo) bar at blort.net>, item2 at example.com, Person 3 <person3 at made.up>
+null at list.items,,are at valid.too
+pdw at ex-parrot.com,
+,i.think at 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 at foo.com, abc at blort.foo',1, (2, 'abc at foo.com', 'abc at blort.foo'));
+testlist('abc at 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";
+ }
+
+}
+
+
More information about the Pkg-perl-cvs-commits
mailing list