[PATCH 5/8] perl: update our copy of Mail::Address

From

Ævar Arnfjörð Bjarmason <avarab@gmail.com>

Date

Feb 14, 2018, 22:21 UTC

Message-ID

<20180214222146.10655-6-avarab@gmail.com>

In-Reply-To

<20180214222146.10655-1-avarab@gmail.com>

1. https://metacpan.org/diff/file?target=MARKOV/MailTools-2.20/lib%2FMail%2FAddress.pod&source=MARKOV%2FMailTools-2.19%2Flib%2FMail%2FAddress.pod

Signed-off-by: Ævar Arnfjörð Bjarmason <avarab@gmail.com>
---
 perl/Git/FromCPAN/Mail/.gitattributes |   1 +
 perl/Git/FromCPAN/Mail/Address.pm     | 436 +++++++++++++---------------------
 2 files changed, 163 insertions(+), 274 deletions(-)
 create mode 100644 perl/Git/FromCPAN/Mail/.gitattributes

diff --git a/perl/Git/FromCPAN/Mail/.gitattributes b/perl/Git/FromCPAN/Mail/.gitattributes
new file mode 100644
index 0000000000..94f3e5bb86
--- /dev/null
+++ b/perl/Git/FromCPAN/Mail/.gitattributes
@@ -0,0 +1 @@
+/Address.pm whitespace=-trailing-space
diff --git a/perl/Git/FromCPAN/Mail/Address.pm b/perl/Git/FromCPAN/Mail/Address.pm
index 13b2ff7d05..ee333e0f5a 100644
--- a/perl/Git/FromCPAN/Mail/Address.pm
+++ b/perl/Git/FromCPAN/Mail/Address.pm
@@ -1,276 +1,164 @@
-# 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 locale;   removed in version 1.78, because it causes taint problems
-
-sub Version { our $VERSION }
-
-
-
-# given a comment, attempt to extract a person's name
-sub _extract_name
-{   # 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+$//;
-    s/\s+/ /;
-
-    # Disregard numeric names (e.g. 123456.1234@compuserve.com)
-    return "" if /^[\d ]+$/;
-
-    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/,.*//;
-
-    # 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'
-    }
+=encoding utf8
 
-    # some cleanup
-    s/\[[^\]]*\]//g;
-    s/(^[\s'"]+|[\s'"]+$)//g;
-    s/\s{2,}/ /g;
-
-    $_;
-}
-
-sub _tokenise
-{   local $_ = join ',', @_;
-    my (@words,$snippet,$field);
-
-    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/^(([^\(\)\\]|\\.)+)//;
-                }
-            }
-
-            carp "Unmatched () '$field' '$_'"
-                if $depth;
-
-            $field =~ s/\s+\Z//;
-            push @words, $field;
-
-            next;
-        }
-
-        if( s/^("(?:[^"\\]+|\\.)*")\s*//       # "..."
-         || s/^(\[(?:[^\]\\]+|\\.)*\])\s*//    # [...]
-         || s/^([^\s()<>\@,;:\\".[\]]+)\s*//
-         || s/^([()<>\@,;:\\".[\]])\s*//
-          )
-        {   push @words, $1;
-            next;
-        }
-
-        croak "Unrecognised line: $_";
-    }
-
-    push @words, ",";
-    \@words;
-}
-
-sub _find_next
-{   my ($idx, $tokens, $len) = @_;
-
-    while($idx < $len)
-    {   my $c = $tokens->[$idx];
-        return $c if $c eq ',' || $c eq ';' || $c eq '<';
-        $idx++;
-    }
-
-    "";
-}
-
-sub _complete
-{   my ($class, $phrase, $address, $comment) = @_;
-
-    @$phrase || @$comment || @$address
-       or return undef;
-
-    my $o = $class->new(join(" ",@$phrase), join("",@$address), join(" ",@$comment));
-    @$phrase = @$address = @$comment = ();
-    $o;
-}
-
-#------------
-
-sub new(@)
-{   my $class = shift;
-    bless [@_], $class;
-}
-
-
-sub parse(@)
-{   my $class = shift;
-    my @line  = grep {defined} @_;
-    my $line  = join '', @line;
-
-    my (@phrase, @comment, @address, @objs);
-    my ($depth, $idx) = (0, 0);
-
-    my $tokens  = _tokenise @line;
-    my $len     = @$tokens;
-    my $next    = _find_next $idx, $tokens, $len;
-
-    local $_;
-    for(my $idx = 0; $idx < $len; $idx++)
-    {   $_ = $tokens->[$idx];
-
-        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 phrase  { shift->set_or_get(0, @_) }
-sub address { shift->set_or_get(1, @_) }
-sub comment { shift->set_or_get(2, @_) }
-
-sub set_or_get($)
-{   my ($self, $i) = (shift, shift);
-    @_ or return $self->[$i];
-
-    my $val = $self->[$i];
-    $self->[$i] = shift if @_;
-    $val;
-}
-
-
-my $atext = '[\-\w !#$%&\'*+/=?^`{|}~]';
-sub format
-{   my @addrs;
-
-    foreach (@_)
-    {   my ($phrase, $email, $comment) = @$_;
-        my @addr;
-
-        if(defined $phrase && length $phrase)
-        {   push @addr
-              , $phrase =~ /^(?:\s*$atext\s*)+$/o ? $phrase
-              : $phrase =~ /(?<!\\)"/             ? $phrase
-              :                                    qq("$phrase");
-
-            push @addr, "<$email>"
-                if defined $email && length $email;
-        }
-        elsif(defined $email && length $email)
-        {   push @addr, $email;
-        }
-
-        if(defined $comment && $comment =~ /\S/)
-        {   $comment =~ s/^\s*\(?/(/;
-            $comment =~ s/\)?\s*$/)/;
-        }
-
-        push @addr, $comment
-            if defined $comment && length $comment;
-
-        push @addrs, join(" ", @addr)
-            if @addr;
-    }
-
-    join ", ", @addrs;
-}
-
-#------------
-
-sub name
-{   my $self   = shift;
-    my $phrase = $self->phrase;
-    my $addr   = $self->address;
-
-    $phrase    = $self->comment
-        unless defined $phrase && length $phrase;
-
-    my $name   = $self->_extract_name($phrase);
-
-    # first.last@domain address
-    if($name eq '' && $addr =~ /([^\%\.\@_]+([\._][^\%\.\@_]+)+)[\@\%]/)
-    {   ($name  = $1) =~ s/[\._]+/ /g;
-	$name   = _extract_name $name;
-    }
-
-    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";
-    }
-
-    length $name ? $name : undef;
-}
-
-
-sub host
-{   my $addr = shift->address || '';
-    my $i    = rindex $addr, '@';
-    $i >= 0 ? substr($addr, $i+1) : undef;
-}
-
-
-sub user
-{   my $addr = shift->address || '';
-    my $i    = rindex $addr, '@';
-    $i >= 0 ? substr($addr,0,$i) : $addr;
-}
+=head1 NAME
+
+Mail::Address - parse mail addresses
+
+=head1 SYNOPSIS
+
+ use Mail::Address;
+ my @addrs = Mail::Address->parse($line);
+
+ foreach $addr (@addrs) {
+     print $addr->format,"\n";
+ }
+
+=head1 DESCRIPTION
+
+C<Mail::Address> extracts and manipulates email addresses from a message
+header.  It cannot be used to extract addresses from some random text.
+You can use this module to create RFC822 compliant fields.
+
+Although C<Mail::Address> is a very popular subject for books, and is
+used in many applications, it does a very poor job on the more complex
+message fields.  It does only handle simple address formats (which
+covers about 95% of what can be found). Problems are with
+
+=over 4
+
+=item *
+
+no support for address groups, even not with the semi-colon as
+separator between addresses;
+
+=item *
+
+limited support for escapes in phrases and comments.  There are
+cases where it can get wrong; and
+
+=item *
+
+you have to take care of most escaping when you create an address yourself:
+C<Mail::Address> does not do that for you.
+
+=back
+
+Often requests are made to the maintainers of this code improve this
+situation, but this is not a good idea, where it will break zillions
+of existing applications.  If you wish for a fully RFC2822 compliant
+implementation you may take a look at L<Mail::Message::Field::Full>,
+part of MailBox.
+
+B<. Example>
+
+  my $s = Mail::Message::Field::Full->new($from_header);
+  # ref $s isa Mail::Message::Field::Addresses;
+
+  my @g = $s->groups;          # all groups, at least one
+  # ref $g[0] isa Mail::Message::Field::AddrGroup;
+  my $ga = $g[0]->addresses;   # group addresses
+
+  my @a = $s->addresses;       # all addresses
+  # ref $a[0] isa Mail::Message::Field::Address;
+
+=head1 METHODS
+
+=head2 Constructors
+
+=over 4
+
+=item Mail::Address-E<gt>B<new>( $phrase, $address, [ $comment ] )
+
+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)
+
+example: 
+
+ Mail::Address->new("Perl5 Porters", "perl5-porters@africa.nicoh.com");
+
+=item $obj-E<gt>B<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
+
+example: 
+
+ my @addr = Mail::Address->parse($line);
+
+=back
+
+=head2 Accessors
+
+=over 4
+
+=item $obj-E<gt>B<address>()
+
+Return the address part of the object.
+
+=item $obj-E<gt>B<comment>()
+
+Return the comment part of the object
+
+=item $obj-E<gt>B<format>(@addresses)
+
+Return a string representing the address in a suitable form to be placed
+on a C<To>, C<Cc>, or C<Bcc> line of a message.  This method is called on
+the first address to be used; other specified addresses will be appended,
+separated by commas.
+
+=item $obj-E<gt>B<phrase>()
+
+Return the phrase part of the object.
+
+=back
+
+=head2 Smart accessors
+
+=over 4
+
+=item $obj-E<gt>B<host>()
+
+Return the address excluding the user id and '@'
+
+=item $obj-E<gt>B<name>()
+
+Using the information contained within the object attempt to identify what
+the person or groups name is.
+
+B<Note:> This function tries to be smart with the "phrase" of the
+email address, which is probably a very bad idea.  Consider to use
+L<phrase()|Mail::Address/"Accessors"> itself.
+
+=item $obj-E<gt>B<user>()
+
+Return the address excluding the '@' and the mail domain
+
+=back
+
+=head1 SEE ALSO
+
+This module is part of the MailTools distribution,
+F<http://perl.overmeer.net/mailtools/>.
+
+=head1 AUTHORS
+
+The MailTools bundle was developed by Graham Barr.  Later, Mark
+Overmeer took over maintenance without commitment to further development.
+
+Mail::Cap by Gisle Aas E<lt>aas@oslonett.noE<gt>.
+Mail::Field::AddrList by Peter Orbaek E<lt>poe@cit.dkE<gt>.
+Mail::Mailer and Mail::Send by Tim Bunce E<lt>Tim.Bunce@ig.co.ukE<gt>.
+For other contributors see ChangeLog.
+
+=head1 LICENSE
+
+Copyrights 1995-2000 Graham Barr E<lt>gbarr@pobox.comE<gt> and
+2001-2017 Mark Overmeer E<lt>perl@overmeer.netE<gt>.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+See F<http://www.perl.com/perl/misc/Artistic.html>
 
-1;

-- 
2.15.1.424.g9478a66081