r2861 - in /packages/libemail-valid-perl/branches/upstream/current:
Changes
MANIFEST META.yml Makefile.PL Valid.pm lib/ lib/Email/ lib/Email/Valid.pm
t/valid.t
gregoa-guest at users.alioth.debian.org
gregoa-guest at users.alioth.debian.org
Sun Jun 4 20:20:18 UTC 2006
Author: gregoa-guest
Date: Sun Jun 4 20:20:16 2006
New Revision: 2861
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=2861
Log:
Load /tmp/tmp.kOhqs31782/libemail-valid-perl-0.16 into
packages/libemail-valid-perl/branches/upstream/current.
Added:
packages/libemail-valid-perl/branches/upstream/current/META.yml
packages/libemail-valid-perl/branches/upstream/current/lib/
packages/libemail-valid-perl/branches/upstream/current/lib/Email/
packages/libemail-valid-perl/branches/upstream/current/lib/Email/Valid.pm
Removed:
packages/libemail-valid-perl/branches/upstream/current/Valid.pm
Modified:
packages/libemail-valid-perl/branches/upstream/current/Changes
packages/libemail-valid-perl/branches/upstream/current/MANIFEST
packages/libemail-valid-perl/branches/upstream/current/Makefile.PL
packages/libemail-valid-perl/branches/upstream/current/t/valid.t
Modified: packages/libemail-valid-perl/branches/upstream/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libemail-valid-perl/branches/upstream/current/Changes?rev=2861&op=diff
==============================================================================
--- packages/libemail-valid-perl/branches/upstream/current/Changes (original)
+++ packages/libemail-valid-perl/branches/upstream/current/Changes Sun Jun 4 20:20:16 2006
@@ -1,4 +1,10 @@
Revision history for Perl extension Email::Valid.
+
+0.16 Fri Jun 2
+ - maintainership assumed by RJBS
+ - work with current, broken Net::Domain::TLD
+ - improve tests
+
0.15 Sun Sep 7 21:39:12 PDT 2003
- Support for top level domain validity check added by Elizabeth
Modified: packages/libemail-valid-perl/branches/upstream/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libemail-valid-perl/branches/upstream/current/MANIFEST?rev=2861&op=diff
==============================================================================
--- packages/libemail-valid-perl/branches/upstream/current/MANIFEST (original)
+++ packages/libemail-valid-perl/branches/upstream/current/MANIFEST Sun Jun 4 20:20:16 2006
@@ -1,6 +1,7 @@
Changes
-Valid.pm
+lib/Email/Valid.pm
README
MANIFEST
Makefile.PL
t/valid.t
+META.yml Module meta-data (added by MakeMaker)
Added: packages/libemail-valid-perl/branches/upstream/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libemail-valid-perl/branches/upstream/current/META.yml?rev=2861&op=file
==============================================================================
--- packages/libemail-valid-perl/branches/upstream/current/META.yml (added)
+++ packages/libemail-valid-perl/branches/upstream/current/META.yml Sun Jun 4 20:20:16 2006
@@ -1,0 +1,11 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: Email-Valid
+version: 0.16
+version_from: lib/Email/Valid.pm
+installdirs: site
+requires:
+ Mail::Address: 0
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.30
Modified: packages/libemail-valid-perl/branches/upstream/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libemail-valid-perl/branches/upstream/current/Makefile.PL?rev=2861&op=diff
==============================================================================
--- packages/libemail-valid-perl/branches/upstream/current/Makefile.PL (original)
+++ packages/libemail-valid-perl/branches/upstream/current/Makefile.PL Sun Jun 4 20:20:16 2006
@@ -2,7 +2,7 @@
WriteMakefile(
'NAME' => 'Email::Valid',
- 'VERSION_FROM' => 'Valid.pm',
+ 'VERSION_FROM' => 'lib/Email/Valid.pm',
'PREREQ_PM' => { 'Mail::Address' => 0 },
'dist' => { 'COMPRESS'=>'gzip -9f', 'SUFFIX' => 'gz',
'ZIP'=>'/usr/bin/zip', 'ZIPFLAGS'=>'-rl' }
Added: packages/libemail-valid-perl/branches/upstream/current/lib/Email/Valid.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libemail-valid-perl/branches/upstream/current/lib/Email/Valid.pm?rev=2861&op=file
==============================================================================
--- packages/libemail-valid-perl/branches/upstream/current/lib/Email/Valid.pm (added)
+++ packages/libemail-valid-perl/branches/upstream/current/lib/Email/Valid.pm Sun Jun 4 20:20:16 2006
@@ -1,0 +1,599 @@
+package Email::Valid;
+
+use strict;
+use vars qw( $VERSION $RFC822PAT %AUTOLOAD $AUTOLOAD $NSLOOKUP_PAT
+ @NSLOOKUP_PATHS $Details $Resolver $Nslookup_Path
+ $DNS_Method $TLD $Debug );
+use Carp;
+use IO::File;
+use Mail::Address;
+use File::Spec;
+
+$VERSION = '0.16';
+
+%AUTOLOAD = ( mxcheck => 1, tldcheck => 1, fudge => 1, fqdn => 1, local_rules => 1 );
+$NSLOOKUP_PAT = 'preference|serial|expire|mail\s+exchanger';
+ at NSLOOKUP_PATHS = File::Spec->path();
+
+# initialize if already loaded, better in prefork mod_perl environment
+$DNS_Method = defined $Net::DNS::VERSION ? 'Net::DNS' : '';
+
+sub new {
+ my $class = shift;
+
+ $class = ref $class || $class;
+ bless my $self = {}, $class;
+ $self->_initialize;
+ %$self = $self->_rearrange([qw( mxcheck tldcheck fudge fqdn local_rules )], \@_);
+ return $self;
+}
+
+sub _initialize {
+ my $self = shift;
+
+ $self->{mxcheck} = 0;
+ $self->{tldcheck} = 0;
+ $self->{fudge} = 0;
+ $self->{fqdn} = 1;
+ $self->{local_rules} = 0;
+ $self->{details} = $Details = undef;
+}
+
+# Pupose: handles named parameter calling style
+sub _rearrange {
+ my $self = shift;
+ my(@names) = @{ shift() };
+ my(@params) = @{ shift() };
+ my(%args);
+
+ ref $self ? %args = %$self : _initialize( \%args );
+ return %args unless @params;
+
+ unless ($params[0] =~ /^-/) {
+ while(@params) {
+ croak 'unexpected number of parameters' unless @names;
+ $args{ lc shift @names } = shift @params;
+ }
+ return %args;
+ }
+
+ while(@params) {
+ my $param = lc substr(shift @params, 1);
+ $args{ $param } = shift @params;
+ }
+
+ %args;
+}
+
+# Purpose: determine why an address failed a check
+sub details {
+ my $self = shift;
+
+ return (ref $self ? $self->{details} : $Details) unless @_;
+ $Details = shift;
+ $self->{details} = $Details if ref $self;
+ return undef;
+}
+
+# Purpose: Check whether address conforms to RFC 822 syntax.
+sub rfc822 {
+ my $self = shift;
+ my %args = $self->_rearrange([qw( address )], \@_);
+
+ my $addr = $args{address} or return $self->details('rfc822');
+ $addr = $addr->address if UNIVERSAL::isa($addr, 'Mail::Address');
+
+ return $self->details('rfc822') unless $addr =~ m/^$RFC822PAT$/o;
+
+ return 1;
+}
+
+# Purpose: attempt to locate the nslookup utility
+sub _find_nslookup {
+ my $self = shift;
+
+ my $ns = 'nslookup';
+ $ns .= '.exe' if $^O =~ /win32/i;
+ foreach my $path (@NSLOOKUP_PATHS) {
+ my $file = File::Spec->catfile($path, $ns);
+ return $file if -x $file and !-d _;
+ }
+ return undef;
+}
+
+sub _select_dns_method {
+ # Configure a global resolver object for DNS queries
+ # if Net::DNS is available
+ eval { require Net::DNS };
+ return $DNS_Method = 'Net::DNS' unless $@;
+
+ $DNS_Method = 'nslookup';
+}
+
+# Purpose: perform DNS query using the Net::DNS module
+sub _net_dns_query {
+ my $self = shift;
+ my $host = shift;
+
+ $Resolver = Net::DNS::Resolver->new unless defined $Resolver;
+
+ my $packet = $Resolver->send($host, 'A') or croak $Resolver->errorstring;
+ return 1 if $packet->header->ancount;
+
+ $packet = $Resolver->send($host, 'MX') or croak $Resolver->errorstring;
+ return 1 if $packet->header->ancount;
+
+ return $self->details('mx');
+}
+
+# Purpose: perform DNS query using the nslookup utility
+sub _nslookup_query {
+ my $self = shift;
+ my $host = shift;
+ local($/, *OLDERR);
+
+ unless ($Nslookup_Path) {
+ $Nslookup_Path = $self->_find_nslookup
+ or croak 'unable to locate nslookup';
+ }
+
+ # Check for an A record
+ return 1 if gethostbyname $host;
+
+ # Check for an MX record
+ if (my $fh = new IO::File '-|') {
+ my $response = <$fh>;
+ print STDERR $response if $Debug;
+ close $fh;
+ $response =~ /$NSLOOKUP_PAT/io or return $self->details('mx');
+ return 1;
+ } else {
+ open OLDERR, '>&STDERR' or croak "cannot dup stderr: $!";
+ open STDERR, '>&STDOUT' or croak "cannot redirect stderr to stdout: $!";
+ {
+ exec $Nslookup_Path, '-query=mx', $host;
+ }
+ open STDERR, ">&OLDERR";
+ croak "unable to execute nslookup '$Nslookup_Path': $!";
+ }
+}
+
+# Purpose: Check whether a top level domain is valid for a domain.
+sub tld {
+ my $self = shift;
+ my %args = $self->_rearrange([qw( address )], \@_);
+
+ unless (eval { require Net::Domain::TLD; 1 }) {
+ die "Net::Domain::TLD not available";
+ }
+
+ my $host = $self->_host( $args{address} or return $self->details('tld') );
+ my ($tld) = $host =~ m#\.(\w+)$#;
+ return Net::Domain::TLD::tld_exists($tld);
+}
+
+# Purpose: Check whether a DNS record (A or MX) exists for a domain.
+sub mx {
+ my $self = shift;
+ my %args = $self->_rearrange([qw( address )], \@_);
+
+ my $host = $self->_host($args{address}) or return $self->details('mx');
+
+ $self->_select_dns_method unless $DNS_Method;
+
+ if ($DNS_Method eq 'Net::DNS') {
+ print STDERR "using Net::DNS for dns query\n" if $Debug;
+ return $self->_net_dns_query( $host );
+ } elsif ($DNS_Method eq 'nslookup') {
+ print STDERR "using nslookup for dns query\n" if $Debug;
+ return $self->_nslookup_query( $host );
+ } else {
+ croak "unknown DNS method '$DNS_Method'";
+ }
+}
+
+# Purpose: convert address to host
+# Returns: host
+
+sub _host {
+ my $self = shift;
+ my $addr = shift;
+
+ $addr = $addr->address if UNIVERSAL::isa($addr, 'Mail::Address');
+
+ my $host = ($addr =~ /^.*@(.*)$/ ? $1 : $addr);
+ $host =~ s/\s+//g;
+
+ # REMOVE BRACKETS IF IT'S A DOMAIN-LITERAL
+ # RFC822 3.4.6
+ # Square brackets ("[" and "]") are used to indicate the
+ # presence of a domain-literal, which the appropriate
+ # name-domain is to use directly, bypassing normal
+ # name-resolution mechanisms.
+ $host =~ s/(^\[)|(\]$)//g;
+ $host;
+}
+
+# Purpose: Fix common addressing errors
+# Returns: Possibly modified address
+sub _fudge {
+ my $self = shift;
+ my $addr = shift;
+
+ $addr =~ s/\s+//g if $addr =~ /aol\.com$/i;
+ $addr =~ s/,/./g if $addr =~ /compuserve\.com$/i;
+ $addr;
+}
+
+# Purpose: Special address restrictions on a per-domain basis.
+# Caveats: These organizations may change their rules at any time.
+sub _local_rules {
+ my $self = shift;
+ my($user, $host) = @_;
+
+ # AOL addresses cannot:
+ # - Be shorter than 3 or longer than 16 characters
+ # - Begin with numerals
+ # - Contain periods, underscores, dashes or other punctuation characters
+ #
+ # http://postmaster.info.aol.com/faq.html
+ # Last updated: Aug 23, 2003
+ if ($host =~ /aol\.com/i) {
+ return undef unless $user =~ /^[a-zA-Z][a-zA-Z0-9]{2,15}$/;
+ }
+ 1;
+}
+
+# Purpose: Put an address through a series of checks to determine
+# whether it should be considered valid.
+sub address {
+ my $self = shift;
+ my %args = $self->_rearrange([qw( address fudge mxcheck tldcheck fqdn
+ local_rules )], \@_);
+
+ my $addr = $args{address} or return $self->details('rfc822');
+ $addr = $addr->address if UNIVERSAL::isa($addr, 'Mail::Address');
+
+ $addr = $self->_fudge( $addr ) if $args{fudge};
+ $self->rfc822( $addr ) or return undef;
+
+ ($addr) = Mail::Address->parse( $addr );
+ $addr or return $self->details('rfc822'); # This should never happen
+
+ if ($args{local_rules}) {
+ $self->_local_rules( $addr->user, $addr->host )
+ or return $self->details('local_rules');
+ }
+
+ if ($args{fqdn}) {
+ $addr->host =~ /^.+\..+$/ or return $self->details('fqdn');
+ }
+
+ if ($args{mxcheck}) {
+ $self->mx( $addr->host ) or return;
+ }
+
+ if ($args{tldcheck}) {
+ $self->tld( $addr->host ) or return;
+ }
+
+ return (wantarray ? ($addr->address, $addr) : $addr->address);
+}
+
+sub AUTOLOAD {
+ my $self = shift;
+ my $type = ref($self) || die "$self is not an object";
+ my $name = $AUTOLOAD;
+
+ $name =~ s/.*://;
+ return if $name eq 'DESTROY';
+ die "unknown autoload name '$name'" unless $AUTOLOAD{$name};
+
+ return (@_ ? $self->{$name} = shift : $self->{$name});
+}
+
+# Regular expression built using Jeffrey Friedl's example in
+# _Mastering Regular Expressions_ (http://www.ora.com/catalog/regexp/).
+
+$RFC822PAT = <<'EOF';
+[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\
+xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xf
+f\n\015()]*)*\)[\040\t]*)*(?:(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\x
+ff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff])|"[^\\\x80-\xff\n\015
+"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*")[\040\t]*(?:\([^\\\x80-\
+xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80
+-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*
+)*(?:\.[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\
+\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\
+x80-\xff\n\015()]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x8
+0-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff])|"[^\\\x80-\xff\n
+\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*")[\040\t]*(?:\([^\\\x
+80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^
+\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040
+\t]*)*)*@[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([
+^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\
+\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\
+x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-
+\xff\n\015\[\]]|\\[^\x80-\xff])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()
+]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\
+x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:\.[\04
+0\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\
+n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\
+015()]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?!
+[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\
+]]|\\[^\x80-\xff])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\
+x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\01
+5()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*)*|(?:[^(\040)<>@,;:".
+\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]
+)|"[^\\\x80-\xff\n\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*")[^
+()<>@,;:".\\\[\]\x80-\xff\000-\010\012-\037]*(?:(?:\([^\\\x80-\xff\n\0
+15()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][
+^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)|"[^\\\x80-\xff\
+n\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*")[^()<>@,;:".\\\[\]\
+x80-\xff\000-\010\012-\037]*)*<[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?
+:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-
+\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:@[\040\t]*
+(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015
+()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()
+]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\0
+40)<>@,;:".\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\
+[^\x80-\xff])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\
+xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*
+)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:\.[\040\t]*(?:\([^\\\x80
+-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x
+80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t
+]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\
+\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff])
+*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x
+80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80
+-\xff\n\015()]*)*\)[\040\t]*)*)*(?:,[\040\t]*(?:\([^\\\x80-\xff\n\015(
+)]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\
+\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*@[\040\t
+]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\0
+15()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015
+()]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(
+\040)<>@,;:".\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|
+\\[^\x80-\xff])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80
+-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()
+]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:\.[\040\t]*(?:\([^\\\x
+80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^
+\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040
+\t]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".
+\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff
+])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\
+\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x
+80-\xff\n\015()]*)*\)[\040\t]*)*)*)*:[\040\t]*(?:\([^\\\x80-\xff\n\015
+()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\
+\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*)?(?:[^
+(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-
+\037\x80-\xff])|"[^\\\x80-\xff\n\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\
+n\015"]*)*")[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|
+\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))
+[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:\.[\040\t]*(?:\([^\\\x80-\xff
+\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\x
+ff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(
+?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\
+000-\037\x80-\xff])|"[^\\\x80-\xff\n\015"]*(?:\\[^\x80-\xff][^\\\x80-\
+xff\n\015"]*)*")[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\x
+ff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)
+*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*)*@[\040\t]*(?:\([^\\\x80-\x
+ff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-
+\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)
+*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\
+]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff])*\]
+)[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-
+\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\x
+ff\n\015()]*)*\)[\040\t]*)*(?:\.[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(
+?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80
+-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:[^(\040)<
+>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x8
+0-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff])*\])[\040\t]*(?:
+\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]
+*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)
+*\)[\040\t]*)*)*>)
+EOF
+
+$RFC822PAT =~ s/\n//g;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Email::Valid - Check validity of Internet email addresses
+
+=head1 SYNOPSIS
+
+ use Email::Valid;
+ print (Email::Valid->address('maurice at hevanet.com') ? 'yes' : 'no');
+
+=head1 DESCRIPTION
+
+This module determines whether an email address is well-formed, and
+optionally, whether a mail host exists for the domain.
+
+Please note that there is no way to determine whether an
+address is deliverable without attempting delivery (for details, see
+perlfaq 9).
+
+=head1 PREREQUISITES
+
+This module requires perl 5.004 or later and the Mail::Address module.
+Either the Net::DNS module or the nslookup utility is required
+for DNS checks. The Net::Domain::TLD module is required to check the
+validity of top level domains.
+
+=head1 METHODS
+
+ Every method which accepts an <ADDRESS> parameter may
+ be passed either a string or an instance of the Mail::Address
+ class. All errors raise an exception.
+
+=over 4
+
+=item new ( [PARAMS] )
+
+This method is used to construct an Email::Valid object.
+It accepts an optional list of named parameters to
+control the behavior of the object at instantiation.
+
+The following named parameters are allowed. See the
+individual methods below of details.
+
+ -mxcheck
+ -tldcheck
+ -fudge
+ -fqdn
+ -local_rules
+
+=item mx ( <ADDRESS>|<DOMAIN> )
+
+This method accepts an email address or domain name and determines
+whether a DNS record (A or MX) exists for it.
+
+The method returns true if a record is found and undef if not.
+
+Either the Net::DNS module or the nslookup utility is required for
+DNS checks. Using Net::DNS is the preferred method since error
+handling is improved. If Net::DNS is available, you can modify
+the behavior of the resolver (e.g. change the default tcp_timeout
+value) by manipulating the global Net::DNS::Resolver instance stored in
+$Email::Valid::Resolver.
+
+=item rfc822 ( <ADDRESS> )
+
+This method determines whether an address conforms to the RFC822
+specification (except for nested comments). It returns true if it
+conforms and undef if not.
+
+=item fudge ( <TRUE>|<FALSE> )
+
+Specifies whether calls to address() should attempt to correct
+common addressing errors. Currently, this results in the removal of
+spaces in AOL addresses, and the conversion of commas to periods in
+Compuserve addresses. The default is false.
+
+=item fqdn ( <TRUE>|<FALSE> )
+
+Species whether addresses passed to address() must contain a fully
+qualified domain name (FQDN). The default is true.
+
+=item local_rules ( <TRUE>|<FALSE> )
+
+Specifies whether addresses passed to address() should be tested
+for domain specific restrictions. Currently, this is limited to
+certain AOL restrictions that I'm aware of. The default is false.
+
+=item mxcheck ( <TRUE>|<FALSE> )
+
+Specifies whether addresses passed to address() should be checked
+for a valid DNS entry. The default is false.
+
+=item tldcheck ( <TRUE>|<FALSE> )
+
+Specifies whether addresses passed to address() should be checked
+for a valid top level domains. The default is false.
+
+=item address ( <ADDRESS> )
+
+This is the primary method which determines whether an email
+address is valid. It's behavior is modified by the values of
+mxcheck(), tldcheck(), local_rules(), fqdn(), and fudge(). If the address
+passes all checks, the (possibly modified) address is returned as
+a string. Otherwise, the undefined value is returned.
+In a list context, the method also returns an instance of the
+Mail::Address class representing the email address.
+
+=item details ()
+
+If the last call to address() returned undef, you can call this
+method to determine why it failed. Possible values are:
+
+ rfc822
+ local_rules
+ fqdn
+ mxcheck
+ tldcheck
+
+If the class is not instantiated, you can get the same information
+from the global $Email::Valid::Details.
+
+=back
+
+=head1 EXAMPLES
+
+Let's see if the address 'maurice at hevanet.com' conforms to the
+RFC822 specification:
+
+ print (Email::Valid->address('maurice at hevanet.com') ? 'yes' : 'no');
+
+Additionally, let's make sure there's a mail host for it:
+
+ print (Email::Valid->address( -address => 'maurice at hevanet.com',
+ -mxcheck => 1 ) ? 'yes' : 'no');
+
+Let's see an example of how the address may be modified:
+
+ $addr = Email::Valid->address('Alfred Neuman <Neuman @ foo.bar>');
+ print "$addr\n"; # prints Neuman at foo.bar
+
+Now let's add the check for top level domains:
+
+ $addr = Email::Valid->address( -address => 'Neuman at foo.bar',
+ -tldcheck => 1 );
+ print "$addr\n"; # doesn't print anything
+
+Need to determine why an address failed?
+
+ unless(Email::Valid->address('maurice at hevanet')) {
+ print "address failed $Email::Valid::Details check.\n";
+ }
+
+If an error is encountered, an exception is raised. This is really
+only possible when performing DNS queries. Trap any exceptions by
+wrapping the call in an eval block:
+
+ eval {
+ $addr = Email::Valid->address( -address => 'maurice at hevanet.com',
+ -mxcheck => 1 );
+ };
+ warn "an error was encountered: $@" if $@;
+
+=head1 BUGS
+
+Email::Valid should work with Perl for Win32. In my experience,
+however, Net::DNS queries seem to take an extremely long time when
+a record cannot be found.
+
+=head1 AUTHOR
+
+Copyright 1998-2003, Maurice Aubrey E<lt>maurice at hevanet.comE<gt>.
+All rights reserved.
+
+This module is free software; you may redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 CREDITS
+
+Significant portions of this module are based on the ckaddr program
+written by Tom Christiansen and the RFC822 address pattern developed
+by Jeffrey Friedl. Neither were involved in the construction of this
+module; all errors are mine.
+
+Thanks very much to the following people for their suggestions and
+bug fixes:
+
+ Otis Gospodnetic <otis at DOMINIS.com>
+ Kim Ryan <kimaryan at ozemail.com.au>
+ Pete Ehlke <pde at listserv.music.sony.com>
+ Lupe Christoph
+ David Birnbaum
+ Achim
+ Elizabeth Mattijsen (liz at dijkmat.nl)
+
+=head1 SEE ALSO
+
+Mail::Address, Net::DNS, Net::Domain::TLD, perlfaq9
+
+=cut
Modified: packages/libemail-valid-perl/branches/upstream/current/t/valid.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libemail-valid-perl/branches/upstream/current/t/valid.t?rev=2861&op=diff
==============================================================================
--- packages/libemail-valid-perl/branches/upstream/current/t/valid.t (original)
+++ packages/libemail-valid-perl/branches/upstream/current/t/valid.t Sun Jun 4 20:20:16 2006
@@ -1,59 +1,75 @@
-# Before `make install' is performed this script should be runnable with
-# `make test'. After `make install' it should work as `perl test.pl'
+#!perl
+use strict;
-######################### We start with some black magic to print on failure.
+use Test::More tests => 12;
-# Change 1..1 below to 1..last_test_to_print .
-# (It may become useful if the test is moved to ./t subdirectory.)
+BEGIN {
+ use_ok('Email::Valid');
+}
-BEGIN { $| = 1; print "1..12\n"; }
-END {print "not ok 1\n" unless $loaded;}
-use Email::Valid;
-$loaded = 1;
-print "ok 1\n";
+my $v = Email::Valid->new;
-######################### End of black magic.
+ok(
+ ! $v->address('Alfred Neuman <Neuman at BBN-TENEXA>'),
+ 'Alfred Neuman <Neuman at BBN-TENEXA>',
+);
-# 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):
+ok(
+ $v->address( -address => 'Alfred Neuman <Neuman at BBN-TENEXA>', -fqdn => 0),
+ 'Alfred Neuman <Neuman at BBN-TENEXA> { -fqdn => 0 }',
+);
-$test = 2;
-my $v = new Email::Valid;
+is(
+ $v->address( -address => 'first last at aol.com', -fudge => 1),
+ 'firstlast at aol.com',
+ "spaces fudged out of an address local-part",
+);
-sub not_ok { print "not ok $test\n"; $test++ }
-sub ok { print "ok $test\n"; $test++ }
+ok(
+ ! $v->address( -address => 'first last at aol.com', -fudge => 0),
+ "spaces in localpart is not valid when not fudging",
+);
-$v->address('Alfred Neuman <Neuman at BBN-TENEXA>') ? not_ok : ok;
+is($v->details, 'rfc822', "details are rfc822");
-$v->address( -address => 'Alfred Neuman <Neuman at BBN-TENEXA>',
- -fqdn => 0) ? ok : not_ok;
+is(
+ $v->address('foo @ foo.com'),
+ 'foo at foo.com',
+ "spaced out address is squished"
+);
+
+is(
+ $v->address(q{fred&barney at stonehenge(yup, the rock place).(that's dot)com}),
+ 'fred&barney at stonehenge.com',
+ "comments nicely dropped from an address",
+);
-my $a = $v->address( -address => 'first last at aol.com',
- -fudge => 1);
-$a eq 'firstlast at aol.com' ? ok : not_ok;
+SKIP: {
+ skip "your dns appears missing or failing to resolve", 2
+ unless $v->address(-address=> 'devnull at pobox.com', -mxcheck => 1);
-$v->address( -address => 'first last at aol.com',
- -fudge => 0) ? not_ok : ok;
-$v->details eq 'rfc822' ? ok : not_ok;
+ ok(
+ $v->address(-address => 'blort at aol.com', -mxcheck => 1),
+ 'blort at aol.com, with mxcheck, is ok',
+ );
-$a = $v->address('foo @ foo.com');
-$a eq 'foo at foo.com' ? ok : not_ok;
-
-$a = $v->address("fred&barney\@stonehenge(yup, the rock place).(that's dot)com");
-$a eq 'fred&barney at stonehenge.com' ? ok : not_ok;
+ ok(
+ !$v->address(-address => 'blort at will-never-exist.pobox.com', -mxcheck => 1),
+ 'blort at will-never-exist.pobox.com, with mxcheck, is invalid',
+ );
+}
-$v->address( -address => 'blort at aol.com',
- -mxcheck => 1) ? ok : not_ok;
-$v->address( -address => 'blort at notarealdomainfoo.com',
- -mxcheck => 1) ? not_ok : ok;
+SKIP: {
+ skip "tests require Net::Domain::TLD", 2
+ unless eval { require Net::Domain::TLD; 1; };
-eval {require Net::Domain::TLD};
-if ($@) {
- ok; ok;
-} else {
- $v->address( -address => 'blort at notarealdomainfoo.com',
- -tldcheck => 1) ? ok : not_ok;
- $v->address( -address => 'blort at notarealdomainfoo.bla',
- -tldcheck => 1) ? not_ok : ok;
+ ok(
+ $v->address( -address => 'blort at notarealdomainfoo.com', -tldcheck => 1),
+ 'blort at notarealdomainfoo.com is ok with tldcheck',
+ );
+
+ ok(
+ ! $v->address( -address => 'blort at notarealdomainfoo.bla', -tldcheck => 1),
+ 'blort at notarealdomainfoo.bla is not ok with tldcheck',
+ );
}
More information about the Pkg-perl-cvs-commits
mailing list