git.oblomov.eu Git - git/blob - perl/Git/FromCPAN/Mail/Address.pm

   1 # Copyrights 1995-2017 by [Mark Overmeer <perl@overmeer.net>].
   2 #  For other contributors see ChangeLog.
   3 # See the manual pages for details on the licensing terms.
   4 # Pod stripped from pm file by OODoc 2.02.
   5 package Mail::Address;
   6 use vars '$VERSION';
   7 $VERSION = '2.19';
   8
   9 use strict;
  10
  11 use Carp;
  12
  13 # use locale;   removed in version 1.78, because it causes taint problems
  14
  15 sub Version { our $VERSION }
  16
  17
  18
  19 # given a comment, attempt to extract a person's name
  20 sub _extract_name
  21 {   # This function can be called as method as well
  22     my $self = @_ && ref $_[0] ? shift : undef;
  23
  24     local $_ = shift
  25         or return '';
  26
  27     # Using encodings, too hard. See Mail::Message::Field::Full.
  28     return '' if m/\=\?.*?\?\=/;
  29
  30     # trim whitespace
  31     s/^\s+//;
  32     s/\s+$//;
  33     s/\s+/ /;
  34
  35     # Disregard numeric names (e.g. 123456.1234@compuserve.com)
  36     return "" if /^[\d ]+$/;
  37
  38     s/^\((.*)\)$/$1/; # remove outermost parenthesis
  39     s/^"(.*)"$/$1/;   # remove outer quotation marks
  40     s/\(.*?\)//g;     # remove minimal embedded comments
  41     s/\\//g;          # remove all escapes
  42     s/^"(.*)"$/$1/;   # remove internal quotation marks
  43     s/^([^\s]+) ?, ?(.*)$/$2 $1/; # reverse "Last, First M." if applicable
  44     s/,.*//;
  45
  46     # Change casing only when the name contains only upper or only
  47     # lower cased characters.
  48     unless( m/[A-Z]/ && m/[a-z]/ )
  49     {   # Set the case of the name to first char upper rest lower
  50         s/\b(\w+)/\L\u$1/igo;  # Upcase first letter on name
  51         s/\bMc(\w)/Mc\u$1/igo; # Scottish names such as 'McLeod'
  52         s/\bo'(\w)/O'\u$1/igo; # Irish names such as 'O'Malley, O'Reilly'
  53         s/\b(x*(ix)?v*(iv)?i*)\b/\U$1/igo; # Roman numerals, eg 'Level III Support'
  54     }
  55
  56     # some cleanup
  57     s/\[[^\]]*\]//g;
  58     s/(^[\s'"]+|[\s'"]+$)//g;
  59     s/\s{2,}/ /g;
  60
  61     $_;
  62 }
  63
  64 sub _tokenise
  65 {   local $_ = join ',', @_;
  66     my (@words,$snippet,$field);
  67
  68     s/\A\s+//;
  69     s/[\r\n]+/ /g;
  70
  71     while ($_ ne '')
  72     {   $field = '';
  73         if(s/^\s*\(/(/ )    # (...)
  74         {   my $depth = 0;
  75
  76      PAREN: while(s/^(\(([^\(\)\\]|\\.)*)//)
  77             {   $field .= $1;
  78                 $depth++;
  79                 while(s/^(([^\(\)\\]|\\.)*\)\s*)//)
  80                 {   $field .= $1;
  81                     last PAREN unless --$depth;
  82                     $field .= $1 if s/^(([^\(\)\\]|\\.)+)//;
  83                 }
  84             }
  85
  86             carp "Unmatched () '$field' '$_'"
  87                 if $depth;
  88
  89             $field =~ s/\s+\Z//;
  90             push @words, $field;
  91
  92             next;
  93         }
  94
  95         if( s/^("(?:[^"\\]+|\\.)*")\s*//       # "..."
  96          || s/^(\[(?:[^\]\\]+|\\.)*\])\s*//    # [...]
  97          || s/^([^\s()<>\@,;:\\".[\]]+)\s*//
  98          || s/^([()<>\@,;:\\".[\]])\s*//
  99           )
 100         {   push @words, $1;
 101             next;
 102         }
 103
 104         croak "Unrecognised line: $_";
 105     }
 106
 107     push @words, ",";
 108     \@words;
 109 }
 110
 111 sub _find_next
 112 {   my ($idx, $tokens, $len) = @_;
 113
 114     while($idx < $len)
 115     {   my $c = $tokens->[$idx];
 116         return $c if $c eq ',' || $c eq ';' || $c eq '<';
 117         $idx++;
 118     }
 119
 120     "";
 121 }
 122
 123 sub _complete
 124 {   my ($class, $phrase, $address, $comment) = @_;
 125
 126     @$phrase || @$comment || @$address
 127        or return undef;
 128
 129     my $o = $class->new(join(" ",@$phrase), join("",@$address), join(" ",@$comment));
 130     @$phrase = @$address = @$comment = ();
 131     $o;
 132 }
 133
 134 #------------
 135
 136 sub new(@)
 137 {   my $class = shift;
 138     bless [@_], $class;
 139 }
 140
 141
 142 sub parse(@)
 143 {   my $class = shift;
 144     my @line  = grep {defined} @_;
 145     my $line  = join '', @line;
 146
 147     my (@phrase, @comment, @address, @objs);
 148     my ($depth, $idx) = (0, 0);
 149
 150     my $tokens  = _tokenise @line;
 151     my $len     = @$tokens;
 152     my $next    = _find_next $idx, $tokens, $len;
 153
 154     local $_;
 155     for(my $idx = 0; $idx < $len; $idx++)
 156     {   $_ = $tokens->[$idx];
 157
 158         if(substr($_,0,1) eq '(') { push @comment, $_ }
 159         elsif($_ eq '<')    { $depth++ }
 160         elsif($_ eq '>')    { $depth-- if $depth }
 161         elsif($_ eq ',' || $_ eq ';')
 162         {   warn "Unmatched '<>' in $line" if $depth;
 163             my $o = $class->_complete(\@phrase, \@address, \@comment);
 164             push @objs, $o if defined $o;
 165             $depth = 0;
 166             $next = _find_next $idx+1, $tokens, $len;
 167         }
 168         elsif($depth)       { push @address, $_ }
 169         elsif($next eq '<') { push @phrase,  $_ }
 170         elsif( /^[.\@:;]$/ || !@address || $address[-1] =~ /^[.\@:;]$/ )
 171         {   push @address, $_ }
 172         else
 173         {   warn "Unmatched '<>' in $line" if $depth;
 174             my $o = $class->_complete(\@phrase, \@address, \@comment);
 175             push @objs, $o if defined $o;
 176             $depth = 0;
 177             push @address, $_;
 178         }
 179     }
 180     @objs;
 181 }
 182
 183 #------------
 184
 185 sub phrase  { shift->set_or_get(0, @_) }
 186 sub address { shift->set_or_get(1, @_) }
 187 sub comment { shift->set_or_get(2, @_) }
 188
 189 sub set_or_get($)
 190 {   my ($self, $i) = (shift, shift);
 191     @_ or return $self->[$i];
 192
 193     my $val = $self->[$i];
 194     $self->[$i] = shift if @_;
 195     $val;
 196 }
 197
 198
 199 my $atext = '[\-\w !#$%&\'*+/=?^`{|}~]';
 200 sub format
 201 {   my @addrs;
 202
 203     foreach (@_)
 204     {   my ($phrase, $email, $comment) = @$_;
 205         my @addr;
 206
 207         if(defined $phrase && length $phrase)
 208         {   push @addr
 209               , $phrase =~ /^(?:\s*$atext\s*)+$/o ? $phrase
 210               : $phrase =~ /(?<!\\)"/             ? $phrase
 211               :                                    qq("$phrase");
 212
 213             push @addr, "<$email>"
 214                 if defined $email && length $email;
 215         }
 216         elsif(defined $email && length $email)
 217         {   push @addr, $email;
 218         }
 219
 220         if(defined $comment && $comment =~ /\S/)
 221         {   $comment =~ s/^\s*\(?/(/;
 222             $comment =~ s/\)?\s*$/)/;
 223         }
 224
 225         push @addr, $comment
 226             if defined $comment && length $comment;
 227
 228         push @addrs, join(" ", @addr)
 229             if @addr;
 230     }
 231
 232     join ", ", @addrs;
 233 }
 234
 235 #------------
 236
 237 sub name
 238 {   my $self   = shift;
 239     my $phrase = $self->phrase;
 240     my $addr   = $self->address;
 241
 242     $phrase    = $self->comment
 243         unless defined $phrase && length $phrase;
 244
 245     my $name   = $self->_extract_name($phrase);
 246
 247     # first.last@domain address
 248     if($name eq '' && $addr =~ /([^\%\.\@_]+([\._][^\%\.\@_]+)+)[\@\%]/)
 249     {   ($name  = $1) =~ s/[\._]+/ /g;
 250         $name   = _extract_name $name;
 251     }
 252
 253     if($name eq '' && $addr =~ m#/g=#i)    # X400 style address
 254     {   my ($f) = $addr =~ m#g=([^/]*)#i;
 255         my ($l) = $addr =~ m#s=([^/]*)#i;
 256         $name   = _extract_name "$f $l";
 257     }
 258
 259     length $name ? $name : undef;
 260 }
 261
 262
 263 sub host
 264 {   my $addr = shift->address || '';
 265     my $i    = rindex $addr, '@';
 266     $i >= 0 ? substr($addr, $i+1) : undef;
 267 }
 268
 269
 270 sub user
 271 {   my $addr = shift->address || '';
 272     my $i    = rindex $addr, '@';
 273     $i >= 0 ? substr($addr,0,$i) : $addr;
 274 }
 275
 276 1;