diff options
Diffstat (limited to 'cpan/lib/Mail/Address.pm')
| -rw-r--r-- | cpan/lib/Mail/Address.pm | 536 |
1 files changed, 196 insertions, 340 deletions
diff --git a/cpan/lib/Mail/Address.pm b/cpan/lib/Mail/Address.pm index 6fa1f1c9..13b2ff7d 100644 --- a/cpan/lib/Mail/Address.pm +++ b/cpan/lib/Mail/Address.pm @@ -1,27 +1,32 @@ -# Mail::Address.pm -# -# Copyright (c) 1995-2001 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - +# Copyrights 1995-2017 by [Mark Overmeer <perl@overmeer.net>]. +# For other contributors see ChangeLog. +# See the manual pages for details on the licensing terms. +# Pod stripped from pm file by OODoc 2.02. package Mail::Address; +use vars '$VERSION'; +$VERSION = '2.19'; + use strict; use Carp; -use vars qw($VERSION); -use locale; -$VERSION = "1.52"; -sub Version { $VERSION } +# use locale; removed in version 1.78, because it causes taint problems -# -# given a comment, attempt to extract a person's name -# +sub Version { our $VERSION } + + +# given a comment, attempt to extract a person's name sub _extract_name -{ - local $_ = shift || ''; - +{ # This function can be called as method as well + my $self = @_ && ref $_[0] ? shift : undef; + + local $_ = shift + or return ''; + + # Using encodings, too hard. See Mail::Message::Field::Full. + return '' if m/\=\?.*?\?\=/; + # trim whitespace s/^\s+//; s/\s+$//; @@ -30,391 +35,242 @@ sub _extract_name # Disregard numeric names (e.g. 123456.1234@compuserve.com) return "" if /^[\d ]+$/; - # remove outermost parenthesis - s/^\(|\)$//g; - - # remove outer quotation marks - s/^"|"$//g; - - # remove embedded comments - s/\(.*\)//g; - - # reverse "Last, First M." if applicable - s/^([^\s]+) ?, ?(.*)$/$2 $1/; + s/^\((.*)\)$/$1/; # remove outermost parenthesis + s/^"(.*)"$/$1/; # remove outer quotation marks + s/\(.*?\)//g; # remove minimal embedded comments + s/\\//g; # remove all escapes + s/^"(.*)"$/$1/; # remove internal quotation marks + s/^([^\s]+) ?, ?(.*)$/$2 $1/; # reverse "Last, First M." if applicable s/,.*//; - # Set the case of the name to first char upper rest lower - # Upcase first letter on name - s/\b(\w+)/\L\u$1/igo; - - # Scottish names such as 'McLeod' - s/\bMc(\w)/Mc\u$1/igo; - - # Irish names such as 'O'Malley, O'Reilly' - s/\bo'(\w)/O'\u$1/igo; - - # Roman numerals, eg 'Level III Support' - s/\b(x*(ix)?v*(iv)?i*)\b/\U$1/igo; + # Change casing only when the name contains only upper or only + # lower cased characters. + unless( m/[A-Z]/ && m/[a-z]/ ) + { # Set the case of the name to first char upper rest lower + s/\b(\w+)/\L\u$1/igo; # Upcase first letter on name + s/\bMc(\w)/Mc\u$1/igo; # Scottish names such as 'McLeod' + s/\bo'(\w)/O'\u$1/igo; # Irish names such as 'O'Malley, O'Reilly' + s/\b(x*(ix)?v*(iv)?i*)\b/\U$1/igo; # Roman numerals, eg 'Level III Support' + } # some cleanup s/\[[^\]]*\]//g; s/(^[\s'"]+|[\s'"]+$)//g; s/\s{2,}/ /g; - return $_; + $_; } -sub _tokenise { - local($_) = join(',', @_); - my(@words,$snippet,$field); - - s/\A\s+//; - s/[\r\n]+/ /g; +sub _tokenise +{ local $_ = join ',', @_; + my (@words,$snippet,$field); - while ($_ ne '') - { - $field = ''; - if( s/^\s*\(/(/ ) # (...) - { - my $depth = 0; + s/\A\s+//; + s/[\r\n]+/ /g; + + while ($_ ne '') + { $field = ''; + if(s/^\s*\(/(/ ) # (...) + { my $depth = 0; PAREN: while(s/^(\(([^\(\)\\]|\\.)*)//) - { - $field .= $1; - $depth++; - while(s/^(([^\(\)\\]|\\.)*\)\s*)//) - { - $field .= $1; - last PAREN unless --$depth; - $field .= $1 if s/^(([^\(\)\\]|\\.)+)//; + { $field .= $1; + $depth++; + while(s/^(([^\(\)\\]|\\.)*\)\s*)//) + { $field .= $1; + last PAREN unless --$depth; + $field .= $1 if s/^(([^\(\)\\]|\\.)+)//; + } + } + + carp "Unmatched () '$field' '$_'" + if $depth; + + $field =~ s/\s+\Z//; + push @words, $field; + + next; } - } - - carp "Unmatched () '$field' '$_'" - if $depth; - $field =~ s/\s+\Z//; - push(@words, $field); + if( s/^("(?:[^"\\]+|\\.)*")\s*// # "..." + || s/^(\[(?:[^\]\\]+|\\.)*\])\s*// # [...] + || s/^([^\s()<>\@,;:\\".[\]]+)\s*// + || s/^([()<>\@,;:\\".[\]])\s*// + ) + { push @words, $1; + next; + } - next; + croak "Unrecognised line: $_"; } - s/^("([^"\\]|\\.)*")\s*// # "..." - || s/^(\[([^\]\\]|\\.)*\])\s*// # [...] - || s/^([^\s\Q()<>\@,;:\\".[]\E]+)\s*// - || s/^([\Q()<>\@,;:\\".[]\E])\s*// - and do { push(@words, $1); next; }; - - croak "Unrecognised line: $_"; - } - - push(@words, ","); - - \@words; -} - -sub _find_next { - my $idx = shift; - my $tokens = shift; - my $len = shift; - while($idx < $len) { - my $c = $tokens->[$idx]; - return $c if($c eq "," || $c eq "<"); - $idx++; - } - return ""; -} - -sub _complete { - my $pkg = shift; - my $phrase = shift; - my $address = shift; - my $comment = shift; - my $o = undef; - - if(@{$phrase} || @{$comment} || @{$address}) { - $o = $pkg->new(join(" ",@{$phrase}), - join("", @{$address}), - join(" ",@{$comment})); - @{$phrase} = (); - @{$address} = (); - @{$comment} = (); - } - - return $o; + push @words, ","; + \@words; } +sub _find_next +{ my ($idx, $tokens, $len) = @_; -sub new { - my $pkg = shift; - my $me = bless [@_], $pkg; - return $me; -} - + while($idx < $len) + { my $c = $tokens->[$idx]; + return $c if $c eq ',' || $c eq ';' || $c eq '<'; + $idx++; + } -sub parse { - my $pkg = shift; - my @line = grep { defined $_} @_; - my $line = join '', @line; - - local $_; - - my @phrase = (); - my @comment = (); - my @address = (); - my @objs = (); - my $depth = 0; - my $idx = 0; - my $tokens = _tokenise(@line); - my $len = @$tokens; - my $next = _find_next($idx,$tokens,$len); - - for( ; $idx < $len ; $idx++) { - $_ = $tokens->[$idx]; - - if(substr($_,0,1) eq "(") { - push(@comment,$_); - } - elsif($_ eq '<') { - $depth++; - } - elsif($_ eq '>') { - $depth-- if $depth; - } - elsif($_ eq ',') { - warn "Unmatched '<>' in $line" if($depth); - my $o = _complete($pkg,\@phrase, \@address, \@comment); - push(@objs, $o) if(defined $o); - $depth = 0; - $next = _find_next($idx+1,$tokens,$len); - } - elsif($depth) { - push(@address,$_); - } - elsif($next eq "<") { - push(@phrase,$_); - } - elsif( /\A[\Q.\@:;\E]\Z/ || !@address || $address[-1] =~ /\A[\Q.\@:;\E]\Z/) { - push(@address,$_); - } - else { - warn "Unmatched '<>' in $line" if($depth); - my $o = _complete($pkg,\@phrase, \@address, \@comment); - push(@objs, $o) if(defined $o); - $depth = 0; - push(@address,$_); - } - } - @objs; + ""; } -sub set_or_get { - my $me = shift; - my $i = shift; - my $val = $me->[$i]; +sub _complete +{ my ($class, $phrase, $address, $comment) = @_; - $me->[$i] = shift if(@_); + @$phrase || @$comment || @$address + or return undef; - $val; + my $o = $class->new(join(" ",@$phrase), join("",@$address), join(" ",@$comment)); + @$phrase = @$address = @$comment = (); + $o; } +#------------ -sub phrase { set_or_get(shift,0,@_) } -sub address { set_or_get(shift,1,@_) } -sub comment { set_or_get(shift,2,@_) } - - -sub format { - my @fmts = (); - my $me; - - foreach $me (@_) { - my($phrase,$addr,$comment) = @{$me}; - my @tmp = (); - - if(defined $phrase && length($phrase)) { - push(@tmp, $phrase); - push(@tmp, "<" . $addr . ">") if(defined $addr && length($addr)); - } - else { - push(@tmp, $addr) if(defined $addr && length($addr)); - } - if(defined($comment) && $comment =~ /\S/) { - $comment =~ s/^\s*\(?/(/; - $comment =~ s/\)?\s*$/)/; - } - push(@tmp, $comment) if(defined $comment && length($comment)); - push(@fmts, join(" ", @tmp)) if(scalar(@tmp)); - } - - return join(", ", @fmts); +sub new(@) +{ my $class = shift; + bless [@_], $class; } -sub name -{ - my $me = shift; - my $phrase = $me->phrase; - my $addr = $me->address; - - $phrase = $me->comment unless(defined($phrase) && length($phrase)); - - my $name = _extract_name($phrase); - - # first.last@domain address - if($name eq '' && $addr =~ /([^\%\.\@_]+([\._][^\%\.\@_]+)+)[\@\%]/o) - { - ($name = $1) =~ s/[\._]+/ /go; - $name = _extract_name($name); - } - - if($name eq '' && $addr =~ m#/g=#oi) - # X400 style address - { - my ($f) = $addr =~ m#g=([^/]*)#oi; - my ($l) = $addr =~ m#s=([^/]*)#io; - - $name = _extract_name($f . " " . $l); - } - - return length($name) ? $name : undef; -} +sub parse(@) +{ my $class = shift; + my @line = grep {defined} @_; + my $line = join '', @line; + my (@phrase, @comment, @address, @objs); + my ($depth, $idx) = (0, 0); -sub host { - my $me = shift; - my $addr = $me->address; - my $i = rindex($addr,'@'); + my $tokens = _tokenise @line; + my $len = @$tokens; + my $next = _find_next $idx, $tokens, $len; - my $host = ($i >= 0) ? substr($addr,$i+1) : undef; + local $_; + for(my $idx = 0; $idx < $len; $idx++) + { $_ = $tokens->[$idx]; - return $host; + if(substr($_,0,1) eq '(') { push @comment, $_ } + elsif($_ eq '<') { $depth++ } + elsif($_ eq '>') { $depth-- if $depth } + elsif($_ eq ',' || $_ eq ';') + { warn "Unmatched '<>' in $line" if $depth; + my $o = $class->_complete(\@phrase, \@address, \@comment); + push @objs, $o if defined $o; + $depth = 0; + $next = _find_next $idx+1, $tokens, $len; + } + elsif($depth) { push @address, $_ } + elsif($next eq '<') { push @phrase, $_ } + elsif( /^[.\@:;]$/ || !@address || $address[-1] =~ /^[.\@:;]$/ ) + { push @address, $_ } + else + { warn "Unmatched '<>' in $line" if $depth; + my $o = $class->_complete(\@phrase, \@address, \@comment); + push @objs, $o if defined $o; + $depth = 0; + push @address, $_; + } + } + @objs; } +#------------ -sub user { - my $me = shift; - my $addr = $me->address; - my $i = index($addr,'@'); +sub phrase { shift->set_or_get(0, @_) } +sub address { shift->set_or_get(1, @_) } +sub comment { shift->set_or_get(2, @_) } - my $user = ($i >= 0) ? substr($addr,0,$i) : $addr; +sub set_or_get($) +{ my ($self, $i) = (shift, shift); + @_ or return $self->[$i]; - return $user; + my $val = $self->[$i]; + $self->[$i] = shift if @_; + $val; } -sub path { - return (); -} +my $atext = '[\-\w !#$%&\'*+/=?^`{|}~]'; +sub format +{ my @addrs; + foreach (@_) + { my ($phrase, $email, $comment) = @$_; + my @addr; -sub canon { - my $me = shift; - return ($me->host, $me->user, $me->path); -} + if(defined $phrase && length $phrase) + { push @addr + , $phrase =~ /^(?:\s*$atext\s*)+$/o ? $phrase + : $phrase =~ /(?<!\\)"/ ? $phrase + : qq("$phrase"); -1; - - -__END__ - -=head1 NAME + push @addr, "<$email>" + if defined $email && length $email; + } + elsif(defined $email && length $email) + { push @addr, $email; + } -Mail::Address - Parse mail addresses + if(defined $comment && $comment =~ /\S/) + { $comment =~ s/^\s*\(?/(/; + $comment =~ s/\)?\s*$/)/; + } -=head1 SYNOPSIS + push @addr, $comment + if defined $comment && length $comment; - use Mail::Address; - - my @addrs = Mail::Address->parse($line); - - foreach $addr (@addrs) { - print $addr->format,"\n"; + push @addrs, join(" ", @addr) + if @addr; } -=head1 DESCRIPTION - -C<Mail::Address> extracts and manipulates RFC822 compilant email -addresses. As well as being able to create C<Mail::Address> objects -in the normal manner, C<Mail::Address> can extract addresses from -the To and Cc lines found in an email message. - -=head1 CONSTRUCTORS - -=over 4 - -=item new( PHRASE, ADDRESS, [ COMMENT ]) - - Mail::Address->new("Perl5 Porters", "perl5-porters@africa.nicoh.com"); - -Create a new C<Mail::Address> object which represents an address with the -elements given. In a message these 3 elements would be seen like: - - PHRASE <ADDRESS> (COMMENT) - ADDRESS (COMMENT) - -=item parse( LINE ) - - Mail::Address->parse($line); - -Parse the given line a return a list of extracted C<Mail::Address> objects. -The line would normally be one taken from a To,Cc or Bcc line in a message - -=back - -=head1 METHODS - -=over 4 - -=item phrase () - -Return the phrase part of the object. - -=item address () - -Return the address part of the object. - -=item comment () - -Return the comment part of the object - -=item format () - -Return a string representing the address in a suitable form to be placed -on a To,Cc or Bcc line of a message - -=item name () - -Using the information contained within the object attempt to identify what -the person or groups name is - -=item host () - -Return the address excluding the user id and '@' - -=item user () + join ", ", @addrs; +} -Return the address excluding the '@' and the mail domain +#------------ -=item path () +sub name +{ my $self = shift; + my $phrase = $self->phrase; + my $addr = $self->address; -Unimplemented yet but should return the UUCP path for the message + $phrase = $self->comment + unless defined $phrase && length $phrase; -=item canon () + my $name = $self->_extract_name($phrase); -Unimplemented yet but should return the UUCP canon for the message + # first.last@domain address + if($name eq '' && $addr =~ /([^\%\.\@_]+([\._][^\%\.\@_]+)+)[\@\%]/) + { ($name = $1) =~ s/[\._]+/ /g; + $name = _extract_name $name; + } -=back + if($name eq '' && $addr =~ m#/g=#i) # X400 style address + { my ($f) = $addr =~ m#g=([^/]*)#i; + my ($l) = $addr =~ m#s=([^/]*)#i; + $name = _extract_name "$f $l"; + } -=head1 AUTHOR + length $name ? $name : undef; +} -Graham Barr. Maintained by Mark Overmeer <mailtools@overmeer.net> -=head1 COPYRIGHT +sub host +{ my $addr = shift->address || ''; + my $i = rindex $addr, '@'; + $i >= 0 ? substr($addr, $i+1) : undef; +} -Copyright (c) 1995-2001 Graham Barr. All rights reserved. This program is free -software; you can redistribute it and/or modify it under the same terms -as Perl itself. -=cut +sub user +{ my $addr = shift->address || ''; + my $i = rindex $addr, '@'; + $i >= 0 ? substr($addr,0,$i) : $addr; +} +1; |