Message/Field/Address.pm


=head1 NAME

Message::Field::Address Perl module

=head1 DESCRIPTION

Perl module for RFC 822/2822 address related C<field>s.

=cut

package Message::Field::Address;
require 5.6.0;
use strict;
use re 'eval';
use vars qw(%DEFAULT %REG $VERSION);
$VERSION = '1.00';
use Message::Util;
use overload '@{}' => sub {shift->{address}},
             '""' => sub {shift->stringify};

$REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]+|(??{$REG{comment}}))*\x29/;
$REG{quoted_string} = qr/\x22(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*\x22/;
$REG{domain_literal} = qr/\x5B(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x5A\x5E-\xFF])*\x5D/;

$REG{WSP} = qr/[\x20\x09]+/;
$REG{FWS} = qr/[\x20\x09]*/;
$REG{atext} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
$REG{dot_atom} = qr/$REG{atext}(?:$REG{FWS}\x2E$REG{FWS}$REG{atext})*/;
$REG{dot_word} = qr/(?:$REG{atext}|$REG{quoted_string})(?:$REG{FWS}\x2E$REG{FWS}(?:$REG{atext}|$REG{quoted_string}))*/;
$REG{phrase} = qr/(?:$REG{atext}|$REG{quoted_string})(?:$REG{atext}|$REG{quoted_string}|\.|$REG{FWS})*/;
$REG{obs_route} = qr/(?:\x40$REG{FWS}(?:$REG{dot_word}|$REG{domain_literal})(?:$REG{FWS},?$REG{FWS}\x40$REG{FWS}(?:$REG{dot_word}|$REG{domain_literal}))*):/;
$REG{addr_spec} = qr/$REG{dot_word}$REG{FWS}\x40$REG{FWS}(?:$REG{dot_atom}|$REG{domain_literal})/;
$REG{mailbox} = qr/(?:(?:$REG{phrase})?<$REG{FWS}(?:(?:$REG{obs_route})?$REG{FWS}$REG{addr_spec}$REG{FWS})?>|$REG{addr_spec}|$REG{atext})/;
$REG{mailbox_list} = qr/$REG{mailbox}(?:$REG{FWS},(?:$REG{FWS}$REG{mailbox})?)*/;
$REG{address} = qr/(?:(?:$REG{phrase})?(?:<$REG{FWS}(?:(?:$REG{obs_route})?$REG{FWS}$REG{addr_spec}$REG{FWS})?>|:$REG{FWS}(?:$REG{mailbox_list}$REG{FWS})?;)|$REG{addr_spec}|$REG{atext})/;
$REG{address_list} = qr/$REG{address}(?:$REG{FWS},(?:$REG{FWS}$REG{address})?)*/;
$REG{M_group} = qr/($REG{phrase}):/;
$REG{M_mailbox} = qr/(?:($REG{phrase})?<$REG{FWS}($REG{obs_route})?$REG{FWS}($REG{addr_spec})$REG{FWS}>|($REG{addr_spec}))/;
$REG{M_mailbox_empty} = qr/(?:($REG{phrase})?<$REG{FWS}>)/;
$REG{M_quoted_string} = qr/\x22((?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*)\x22/;

$REG{NON_atom} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;

%DEFAULT = (
  dont_reply    => -1,  ## See C<$self->dont_reply>
  dont_reply_display_name       => '',
  encoding_after_encode => '*default',
  encoding_before_decode        => '*default',
  format        => 'rfc2822',
  hook_encode_string    => #sub {shift; (value => shift, @_)},
        \&Message::Util::encode_header_string,
  hook_decode_string    => #sub {shift; (value => shift, @_)},
        \&Message::Util::decode_header_string,
  is_mailbox    => -1,  ## Allow multiple mail addresses?
  is_return_path        => -1,
  use_display_name      => 1,
  use_dont_reply        => -1,  ## See C<$self->dont_reply>
  use_group     => 1,
  use_keyword   => -1,  ## See C<$self->keyword>
  use_keyword_multiple  => -1,
);
## RFC 2822 C<mailbox>  => is_mailbox = +1, (use_group = -1)
## RFC 2822 C<mailbox-list>     => is_mailbox = -1, use_group = -1
## RFC 2822 C<address-list>     => is_mailbox = -1, use_group = +1

## Initialization of option value by C<field-name> and 
## version of specification(s).
sub _init_option ($$) {
  my $self = shift;
  my $name = shift;
  my $spec = $self->{option}->{format};
  my %is_mailbox_name   = (     ## C<is_mailbox>
    'complaints-to'     => 1,
    'mail-copies-to'    => 1, 'resent-sender'   => 1,
    'return-path'       => 1, sender    => 1, 
    'x-complaints-to'   => 1,
  );
  my %use_group_name    = (     ## C<use_group>
    'approved'  => -1,
    'from'      => -1, 'resent-from'    => -1,
  );
  if ($is_mailbox_name{$name}) {
    $self->{option}->{is_mailbox} = $is_mailbox_name{$name};
  } elsif ($use_group_name{$name}) {
    $self->{option}->{use_group} = $use_group_name{$name};
  }
  if ($spec eq 'usefor') {
    if ($name eq 'reply-to') {
      $self->{option}->{use_group} = -1;
      $self->{option}->{use_dont_reply} = 1;
    }
  }
  if ($name eq 'mail-copies-to') {
    $self->{option}->{use_keyword} = 1;
  }
  if ($name eq 'return-path') {
    $self->{option}->{is_return_path} = 1;
    $self->{option}->{use_display_name} = -1;
  }
  $self;
}

=head2 Message::Field::Address->new ()

Return empty address object.

=cut

sub new ($;%) {
  my $self = bless {type => '_ROOT'}, shift;
  my %option = @_;
  for (%DEFAULT) {$option{$_} ||= $DEFAULT{$_}}
  $self->{option} = \%option;
  $self->_init_option ($self->{option}->{field_name});
  $self;
}

=head2 Message::Field::Address->parse ($unfolded_field_body)

Parse structured C<field-body> contain of C<address-list>.

=cut

sub parse ($$;%) {
  my $self = bless {}, shift;
  my $field_body = shift;
  my %option = @_;
  for (%DEFAULT) {$option{$_} ||= $DEFAULT{$_}}
  $self->{option} = \%option;
  $self->_init_option ($self->{option}->{field_name});
  $field_body = $self->delete_comment ($field_body);
  my %addr = $self->parse_address_list ($field_body);
  $self->{address} = $addr{address};
  $self->{type}    = $addr{type};
  $self;
}

=head2 $self->address ()

Return address list in the format described in
L<$self-E<gt>parse_address_list ()>.

=cut

sub address ($) {@{shift->{address}}}

=head2 $self->addr_spec ([$index])

Returns (C<$index>'th or all) C<addr-spec>.
(First C<addr-spec>'s C<$index> is C<1>, not C<0>.)

=cut

sub addr_spec ($;$) {
  my $self = shift;
  my $i = shift;
  #return $self->{address}->[$i]->{addr_spec}
  #  if defined $i && ref $self->{address}->[$i];
  #map {$_->{addr_spec}} @{$self->{address}};
  my @r = ();  my $j = 0;
  for my $m (@{$self->{address}}) {
    if ($m->{type} eq 'group') {
      for my $n (@{$m->{address}}) {
        $j++;
        return $n->{addr_spec} if $j == $i;
        push @r, $m->{addr_spec};
      }
    } else {
      $j++;
      return $m->{addr_spec} if $j == $i;
      push @r, $m->{addr_spec};
    }
  }
  @r;
}

sub have_group ($) {
  my $self = shift;
  for (@{$self->{address}}) {
    return 1 if $_->{type} eq 'group';
  }
  0;
}

=head2 $self->add ($addr_spec, [%option])

Add an mail address to C<$self> (address object).
%option = (name => C<display-name>, route => C<route>, 
           group => C<display-name> of C<group>)

Note that this method (and other methods) does not check
$addr_spec and $option{route} is valid or not.

=cut

sub add ($$;%) {
  my $self = shift;
  my ($addr, %option) = @_;
  my $name = $option{name} || $option{display_name};
  unless ($option{group}) {
    push @{$self->{address}}, {type => 'mailbox',
         addr_spec => $addr, display_name => $name, route => $option{route}};
  } else {
    for my $i (@{$self->{address}}) {
      if ($i->{type} eq 'group' && $i->{display_name} eq $option{group}) {
        push @{$i->{address}}, {type => 'mailbox',
             addr_spec => $addr, display_name => $name, route => $option{route}};
        return $self;
      }
    }
    push @{$self->{address}}, {type => 'group', display_name => $option{group},
         address => [
           {type => 'mailbox',
            addr_spec => $addr, display_name => $name, route => $option{route}}
         ]};
  }
  $self;
}

sub stringify ($;%) {
  my $self = shift;
  my %option = @_;  
  $option{is_mailbox} ||= $self->{option}->{is_mailbox};
  $option{is_return_path} ||= $self->{option}->{is_return_path};
  $option{use_display_name} ||= $self->{option}->{use_display_name};
  $option{use_group} ||= $self->{option}->{use_group};
  $option{use_keyword} ||= $self->{option}->{use_keyword};
  $option{use_keyword_multiple} ||= $self->{option}->{use_keyword_multiple};
  $option{use_dont_reply} ||= $self->{option}->{use_dont_reply};
  $option{dont_reply} ||= $self->{option}->{dont_reply};
  $option{dont_reply_display_name} = $self->{option}->{dont_reply_display_name}
    unless defined $option{dont_reply_display_name};
  if ($option{use_dont_reply}>0 && $option{dont_reply}>0) {
  ## usefor-article Reply-To:
        my $g_return = '';
        if ($option{dont_reply_display_name} && $option{use_display_name}>0) {
          my %s = &{$self->{option}->{hook_encode_string}} ($self, 
            $option{dont_reply_display_name}, type => 'phrase');
          $g_return = $self->quote_unsafe_string ($s{value}) .' ';
        }
        $g_return .= '<>';
    return $g_return;
  }
  my @return;
  if ($option{use_keyword}>0) {
    my @kw = grep {$self->{keyword}->{$_}>0} keys %{$self->{keyword}};
    return $kw[0] if $kw[0] && $option{use_keyword_multiple}<0;
    push @return, @kw;
  }
  for my $address (@{$self->{address}}) {
    my $return = '';
    next if !$address->{addr_spec} && $address->{type} ne 'group';
    if ($address->{display_name} && $option{use_display_name}>0) {
      if ($address->{type} eq 'group' && $option{use_group}>0) {
        my %s = &{$self->{option}->{hook_encode_string}} ($self, 
          $address->{display_name}, type => 'phrase');
        $return = $self->quote_unsafe_string ($s{value}).': ';
      #} else {
      #  my %s = &{$self->{option}->{hook_encode_string}} ($self, 
      #    $address->{display_name}, type => 'comment');
      #  $s{value} =~ s/[\x28\x29\x5C]/\\$&/g;
      #  $return = '('.$s{value}.') ';
      } elsif ($address->{type} ne 'group') {
        my %s = &{$self->{option}->{hook_encode_string}} ($self, 
          $address->{display_name}, type => 'phrase');
        $return = $self->quote_unsafe_string ($s{value}).' ';
      }
    }
    if ($address->{type} ne 'group') {
      $return .= '<'.$address->{route}.$address->{addr_spec}.'>';
    } else {
      my (@g_return);
      for my $mailbox (@{$address->{address}}) {
        next unless $mailbox->{addr_spec};
        my $g_return = '';
        if ($mailbox->{display_name} && $option{use_display_name}>0) {
          my %s = &{$self->{option}->{hook_encode_string}} ($self, 
            $mailbox->{display_name}, type => 'phrase');
          $g_return = $self->quote_unsafe_string ($s{value}) .' ';
        }
        $g_return .= '<'.$mailbox->{route}.$mailbox->{addr_spec}.'>';
        push @g_return, $g_return;
        last if $option{is_mailbox}>0;
      }
      $return .= join ', ', @g_return;
      $return .= ';' if $address->{type} eq 'group' && $option{use_group}>0;
    }
    push @return, $return;
    last if $option{is_mailbox}>0;
  }
  if ($#return == -1) {
    if ($option{is_return_path}>0) {
      push @return, '<>';
    #} elsif ($option{use_dont_reply}>0) {      ## usefor-article Reply-To:
    #    my $g_return = '';
    #    if ($option{dont_reply_display_name} && $option{use_display_name}>0) {
    #      my %s = &{$self->{option}->{hook_encode_string}} ($self, 
    #        $option{dont_reply_display_name}, type => 'phrase');
    #      $g_return = $self->quote_unsafe_string ($s{value}) .' ';
    #    }
    #    $g_return .= '<>';
    #  push @return, $g_return;
    }
  }
  join ', ', @return;
}

=head2 $self->dont_reply ([$don't_reply?, [$display_name]])

Set/gets whether C<field-body> content is "don't reply!"
or not.  Second argument is short string used as C<display-name>.

This function returns an array of C<($don't_reply?, $display_name)>.
<$don't_reply> takes value C<1> (true) or C<-1> (false).

Note: This don't reply convention is defined by draft-usefor-article.
You should not use this in RFC 2822 mail message.

Enable this, set C<use_dont_reply> option to C<1>.  (Default is C<-1>.

Note: Set this value does not mean clear address list that
current C<Message::Field::Address> has.  You can get it
as well as before setting new value.  But C<stringify> method
does not output any of addresses if <$don't_reply> is C<1>.

=head3 example

  my $a = Message::Field::Address->new (use_reply => 1);
  $a->dont_reply (1, 'Please do not reply');
  print $a;     # "Please do not reply <>"

=cut

sub dont_reply ($;$$) {
  my $self = shift;
  my $dr = shift;
  my $dname = shift;
  $self->{option}->{dont_reply} = $dr if $dr;
  $self->{option}->{dont_reply_display_name} = $dname if defined $dname;
  ($self->{dont_reply}, $self->{dont_reply_display_name});
}

=head2 $self->keyword ($keyword, [$true_of_false])

Set/gets whether keyword is specified.  C<$true_or_false>
takes values C<1> and C<-1>.

This function is intended to be used for keyword(s) allowed
mail addresses field, such as C<Mail-Copies-To:> defined by
draft-usefor-article.

There are two related options, C<use_keyword> and C<use_keyword_multiple>.
Former is on/off switch of this function.  Later allows
multiple options/addresses, such as C<keyworda, E<lt>foo@bar.exampleE<gt>>.

=cut

sub keyword ($$;$) {
  my $self = shift;
  my $key = shift;
  my $tf = shift;
  $self->{keyword}->{$key} = $tf if $tf;
  $self->{keyword}->{$key} || -1;
}

sub quote_unsafe_string ($$) {
  my $self = shift;
  my $string = shift;
  if ($string =~ /$REG{NON_atom}/ || $string =~ /$REG{WSP}$REG{WSP}+/) {
    $string =~ s/([\x22\x5C])/\x5C$1/g;
    $string = '"'.$string.'"';
  }
  $string;
}

=head2 $self->unquote_quoted_string ($string)

Unquote C<quoted-string>.  Get rid of C<DQUOTE>s and
C<REVERSED SOLIDUS> included in C<quoted-pair>.
This method is intended for internal use.

=cut

sub unquote_quoted_string ($$) {
  my $self = shift;
  my $quoted_string = shift;
  $quoted_string =~ s{$REG{M_quoted_string}}{
    my $qtext = $1;
    $qtext =~ s/\x5C([\x00-\xFF])/$1/g;
    $qtext;
  }goex;
  $quoted_string;
}

sub _decode_quoted_string ($$) {
  my $self = shift;
  my $quoted_string = shift;
  $quoted_string =~ s{$REG{M_quoted_string}|([^\x22]+)}{
    my ($qtext,$t) = ($1, $2);
    if ($t) {
      my %s = &{$self->{option}->{hook_decode_string}} ($self, $t,
                type => 'value');
      $s{value};
    } else {
      $qtext =~ s/\x5C([\x00-\xFF])/$1/g;
      my %s = &{$self->{option}->{hook_decode_string}} ($self, $qtext,
                type => 'value/quoted');
      $s{value};
    }
  }goex;
  $quoted_string;
}

=head2 $self->parse_mailbox ($mailbox)

Parse C<mailbox> and return array of C<addr-spec>,
C<display-name> and C<route> (aka C<obs-route> of RFC 2822).
This method is intended for internal use.

=cut

sub parse_mailbox ($$) {
  my $self = shift;
  my $mailbox = shift;
  if ($mailbox =~ /$REG{M_mailbox}/) {
    my ($display_name, $route, $addr_spec) = ($1, $2, $3 || $4);
    $display_name =~ s/$REG{WSP}+$//;
    $display_name = $self->_decode_quoted_string ($display_name);
    $addr_spec =~ s{($REG{quoted_string}|$REG{domain_literal})|$REG{WSP}}{$1}go;
    $route =~ s{($REG{quoted_string}|$REG{domain_literal})|$REG{WSP}}{$1}go;
    return ($addr_spec, $display_name, $route);
  } elsif ($mailbox =~ /$REG{M_mailbox_empty}/) {
    my ($display_name) = ($1);
    $display_name =~ s/$REG{WSP}+$//;
    $display_name = $self->_decode_quoted_string ($display_name);
    return ('', $display_name, 'dummy');
  } elsif ($mailbox =~ /^$REG{atext}$/) {
    $self->{keyword}->{$mailbox} = 1;
  }
  (undef, undef, undef);
}

=head2 $self->parse_address_list ($address_list)

Parse C<address-list> and return hash.
This method is intended for internal use.

=head3 Structure of hash returned by parse_address_list

%address = (

  type  => '_ROOT',
  address       => [
  
    ## mailbox
    {
      type      => 'mailbox',
      display_name      => 'Foo H. Bar',
      addr_spec => 'foo@bar.example',
      route     => '@hoge.example:',
    },
    
    ## group
    {
      type      => 'group',
      display_name      => 'The committee',
      address   => [
        
        ## mailbox
        {
          type  => 'mailbox',
          display_name  => 'Tom (Director)',
          addr_spec     => 'tom@committee.example',
          route => '',
        }
        
      ],
    },
  
  ],

);

=cut

sub parse_address_list ($$) {
  my $self = shift;
  my $address_list = shift;
  my %r_addr = (type => '_ROOT');
  $address_list =~ s{($REG{address})}{
    my $address = $1;
    if ($address =~ /^$REG{M_group}/) {
      my %r_group = (type => 'group', display_name => $1);
      $r_group{display_name} =~ s/$REG{WSP}+$//;
      $r_group{display_name} = $self->unquote_quoted_string ($r_group{display_name});
      $address =~ s{($REG{mailbox})}{
        my ($addr, $name, $route) = $self->parse_mailbox ($1);
        push @{$r_group{address}}, {type => 'mailbox',
           display_name => $name, route => $route, addr_spec => $addr}
           if $addr;
      }goex;
      push @{$r_addr{address}}, \%r_group;
    } else {
      my ($addr, $name, $route) = $self->parse_mailbox ($address);
      if ($addr) {
        push @{$r_addr{address}}, {type => 'mailbox',
             display_name => $name, route => $route, addr_spec => $addr};
      } elsif ($route) {        # dummy
        $self->{option}->{dont_reply} = 1;
        $self->{option}->{dont_reply_display_name} = $name;
      }
    }
  }goex;
  %r_addr;
}

=head2 $self->delete_comment ($field_body)

Remove all C<comment> in given strictured C<field-body>.
This method is intended for internal use.

=cut

sub delete_comment ($$) {
  my $self = shift;
  my $body = shift;
  $body =~ s{($REG{quoted_string}|$REG{domain_literal})|$REG{comment}}{
    my $o = $1;  $o? $o : ' ';
  }gex;
  $body;
}

=head1 EXAMPLE

  ## Compose field-body for To: field.
  
  use Message::Field::Address;
  my $addr = new Message::Field::Address;
  $addr->add ('foo@example.org', name => 'Mr. foo bar');
  $addr->add ('webmaster@example.org', group => 'administrators');
  $addr->add ('postmaster@example.org', group => 'administrators');
  
  my $field_body = $addr->stringify ();


  ## Output parsed address-list tree.
  
  use Message::Field::Address;
  my $addr = Message::Field::Address->parse ($field_body);
  
  for my $i (@$addr) {
    if ($i->{type} eq 'group') {
      print "\x40 $i->{display_name}: \n";
      for my $j (@{$i->{address}}) {
        print "\t- $j->{display_name} <$j->{route}$j->{addr_spec}>\n";
      }
    } else {
      print "- $i->{display_name} <$i->{route}$i->{addr_spec}>\n";
    }
  }

=head1 LICENSE

Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.

=head1 CHANGE

See F<ChangeLog>.
$Date: 2002/04/05 14:55:28 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Field::Address Perl module
5
6			=head1 DESCRIPTION
7
8			Perl module for RFC 822/2822 address related C<field>s.
9
10			=cut
11
12			package Message::Field::Address;
13			require 5.6.0;
14			use strict;
15			use re 'eval';
16	wakaba	1.4	use vars qw(%DEFAULT %REG $VERSION);
17	wakaba	1.1	$VERSION = '1.00';
18	wakaba	1.4	use Message::Util;
19	wakaba	1.2	use overload '@{}' => sub {shift->{address}},
20			'""' => sub {shift->stringify};
21	wakaba	1.1
22			$REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]+\|(??{$REG{comment}}))*\x29/;
23			$REG{quoted_string} = qr/\x22(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*\x22/;
24			$REG{domain_literal} = qr/\x5B(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x5A\x5E-\xFF])*\x5D/;
25
26			$REG{WSP} = qr/[\x20\x09]+/;
27			$REG{FWS} = qr/[\x20\x09]*/;
28			$REG{atext} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
29			$REG{dot_atom} = qr/$REG{atext}(?:$REG{FWS}\x2E$REG{FWS}$REG{atext})*/;
30			$REG{dot_word} = qr/(?:$REG{atext}\|$REG{quoted_string})(?:$REG{FWS}\x2E$REG{FWS}(?:$REG{atext}\|$REG{quoted_string}))*/;
31			$REG{phrase} = qr/(?:$REG{atext}\|$REG{quoted_string})(?:$REG{atext}\|$REG{quoted_string}\|\.\|$REG{FWS})*/;
32			$REG{obs_route} = qr/(?:\x40$REG{FWS}(?:$REG{dot_word}\|$REG{domain_literal})(?:$REG{FWS},?$REG{FWS}\x40$REG{FWS}(?:$REG{dot_word}\|$REG{domain_literal}))*):/;
33			$REG{addr_spec} = qr/$REG{dot_word}$REG{FWS}\x40$REG{FWS}(?:$REG{dot_atom}\|$REG{domain_literal})/;
34	wakaba	1.5	$REG{mailbox} = qr/(?:(?:$REG{phrase})?<$REG{FWS}(?:(?:$REG{obs_route})?$REG{FWS}$REG{addr_spec}$REG{FWS})?>\|$REG{addr_spec}\|$REG{atext})/;
35	wakaba	1.1	$REG{mailbox_list} = qr/$REG{mailbox}(?:$REG{FWS},(?:$REG{FWS}$REG{mailbox})?)*/;
36	wakaba	1.5	$REG{address} = qr/(?:(?:$REG{phrase})?(?:<$REG{FWS}(?:(?:$REG{obs_route})?$REG{FWS}$REG{addr_spec}$REG{FWS})?>\|:$REG{FWS}(?:$REG{mailbox_list}$REG{FWS})?;)\|$REG{addr_spec}\|$REG{atext})/;
37	wakaba	1.1	$REG{address_list} = qr/$REG{address}(?:$REG{FWS},(?:$REG{FWS}$REG{address})?)*/;
38			$REG{M_group} = qr/($REG{phrase}):/;
39			$REG{M_mailbox} = qr/(?:($REG{phrase})?<$REG{FWS}($REG{obs_route})?$REG{FWS}($REG{addr_spec})$REG{FWS}>\|($REG{addr_spec}))/;
40	wakaba	1.5	$REG{M_mailbox_empty} = qr/(?:($REG{phrase})?<$REG{FWS}>)/;
41	wakaba	1.1	$REG{M_quoted_string} = qr/\x22((?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*)\x22/;
42
43			$REG{NON_atom} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
44
45	wakaba	1.4	%DEFAULT = (
46	wakaba	1.5	dont_reply => -1, ## See C<$self->dont_reply>
47			dont_reply_display_name => '',
48	wakaba	1.4	encoding_after_encode => '*default',
49			encoding_before_decode => '*default',
50	wakaba	1.6	format => 'rfc2822',
51	wakaba	1.4	hook_encode_string => #sub {shift; (value => shift, @_)},
52			\&Message::Util::encode_header_string,
53			hook_decode_string => #sub {shift; (value => shift, @_)},
54			\&Message::Util::decode_header_string,
55	wakaba	1.5	is_mailbox => -1, ## Allow multiple mail addresses?
56	wakaba	1.3	is_return_path => -1,
57			use_display_name => 1,
58	wakaba	1.5	use_dont_reply => -1, ## See C<$self->dont_reply>
59	wakaba	1.3	use_group => 1,
60	wakaba	1.5	use_keyword => -1, ## See C<$self->keyword>
61			use_keyword_multiple => -1,
62	wakaba	1.3	);
63	wakaba	1.5	## RFC 2822 C<mailbox> => is_mailbox = +1, (use_group = -1)
64			## RFC 2822 C<mailbox-list> => is_mailbox = -1, use_group = -1
65			## RFC 2822 C<address-list> => is_mailbox = -1, use_group = +1
66	wakaba	1.3
67	wakaba	1.5	## Initialization of option value by C<field-name> and
68			## version of specification(s).
69	wakaba	1.3	sub _init_option ($$) {
70			my $self = shift;
71	wakaba	1.5	my $name = shift;
72			my $spec = $self->{option}->{format};
73	wakaba	1.6	my %is_mailbox_name = ( ## C<is_mailbox>
74			'complaints-to' => 1,
75			'mail-copies-to' => 1, 'resent-sender' => 1,
76			'return-path' => 1, sender => 1,
77			'x-complaints-to' => 1,
78			);
79			my %use_group_name = ( ## C<use_group>
80			'approved' => -1,
81			'from' => -1, 'resent-from' => -1,
82			);
83			if ($is_mailbox_name{$name}) {
84			$self->{option}->{is_mailbox} = $is_mailbox_name{$name};
85			} elsif ($use_group_name{$name}) {
86			$self->{option}->{use_group} = $use_group_name{$name};
87	wakaba	1.5	}
88			if ($spec eq 'usefor') {
89			if ($name eq 'reply-to') {
90			$self->{option}->{use_group} = -1;
91			$self->{option}->{use_dont_reply} = 1;
92			}
93			}
94			if ($name eq 'mail-copies-to') {
95			$self->{option}->{use_keyword} = 1;
96			}
97			if ($name eq 'return-path') {
98	wakaba	1.3	$self->{option}->{is_return_path} = 1;
99			$self->{option}->{use_display_name} = -1;
100			}
101			$self;
102			}
103
104	wakaba	1.2	=head2 Message::Field::Address->new ()
105	wakaba	1.1
106			Return empty address object.
107
108			=cut
109
110	wakaba	1.3	sub new ($;%) {
111			my $self = bless {type => '_ROOT'}, shift;
112			my %option = @_;
113	wakaba	1.4	for (%DEFAULT) {$option{$_} \|\|= $DEFAULT{$_}}
114	wakaba	1.3	$self->{option} = \%option;
115			$self->_init_option ($self->{option}->{field_name});
116			$self;
117	wakaba	1.1	}
118
119	wakaba	1.2	=head2 Message::Field::Address->parse ($unfolded_field_body)
120	wakaba	1.1
121			Parse structured C<field-body> contain of C<address-list>.
122
123			=cut
124
125	wakaba	1.3	sub parse ($$;%) {
126	wakaba	1.1	my $self = bless {}, shift;
127			my $field_body = shift;
128	wakaba	1.3	my %option = @_;
129	wakaba	1.4	for (%DEFAULT) {$option{$_} \|\|= $DEFAULT{$_}}
130	wakaba	1.3	$self->{option} = \%option;
131			$self->_init_option ($self->{option}->{field_name});
132	wakaba	1.1	$field_body = $self->delete_comment ($field_body);
133			my %addr = $self->parse_address_list ($field_body);
134			$self->{address} = $addr{address};
135			$self->{type} = $addr{type};
136			$self;
137			}
138
139			=head2 $self->address ()
140
141			Return address list in the format described in
142			L<$self-E<gt>parse_address_list ()>.
143
144			=cut
145
146			sub address ($) {@{shift->{address}}}
147
148	wakaba	1.4	=head2 $self->addr_spec ([$index])
149
150			Returns (C<$index>'th or all) C<addr-spec>.
151	wakaba	1.5	(First C<addr-spec>'s C<$index> is C<1>, not C<0>.)
152	wakaba	1.4
153			=cut
154
155			sub addr_spec ($;$) {
156			my $self = shift;
157			my $i = shift;
158	wakaba	1.5	#return $self->{address}->[$i]->{addr_spec}
159			# if defined $i && ref $self->{address}->[$i];
160			#map {$_->{addr_spec}} @{$self->{address}};
161			my @r = (); my $j = 0;
162			for my $m (@{$self->{address}}) {
163			if ($m->{type} eq 'group') {
164			for my $n (@{$m->{address}}) {
165			$j++;
166			return $n->{addr_spec} if $j == $i;
167			push @r, $m->{addr_spec};
168			}
169			} else {
170			$j++;
171			return $m->{addr_spec} if $j == $i;
172			push @r, $m->{addr_spec};
173			}
174			}
175			@r;
176	wakaba	1.4	}
177
178	wakaba	1.7	sub have_group ($) {
179			my $self = shift;
180			for (@{$self->{address}}) {
181			return 1 if $_->{type} eq 'group';
182			}
183			0;
184			}
185
186	wakaba	1.1	=head2 $self->add ($addr_spec, [%option])
187
188			Add an mail address to C<$self> (address object).
189			%option = (name => C<display-name>, route => C<route>,
190			group => C<display-name> of C<group>)
191
192			Note that this method (and other methods) does not check
193			$addr_spec and $option{route} is valid or not.
194
195			=cut
196
197			sub add ($$;%) {
198			my $self = shift;
199			my ($addr, %option) = @_;
200			my $name = $option{name} \|\| $option{display_name};
201			unless ($option{group}) {
202			push @{$self->{address}}, {type => 'mailbox',
203			addr_spec => $addr, display_name => $name, route => $option{route}};
204			} else {
205			for my $i (@{$self->{address}}) {
206			if ($i->{type} eq 'group' && $i->{display_name} eq $option{group}) {
207			push @{$i->{address}}, {type => 'mailbox',
208			addr_spec => $addr, display_name => $name, route => $option{route}};
209			return $self;
210			}
211			}
212			push @{$self->{address}}, {type => 'group', display_name => $option{group},
213			address => [
214			{type => 'mailbox',
215			addr_spec => $addr, display_name => $name, route => $option{route}}
216			]};
217			}
218			$self;
219			}
220
221	wakaba	1.3	sub stringify ($;%) {
222	wakaba	1.1	my $self = shift;
223	wakaba	1.3	my %option = @_;
224			$option{is_mailbox} \|\|= $self->{option}->{is_mailbox};
225			$option{is_return_path} \|\|= $self->{option}->{is_return_path};
226			$option{use_display_name} \|\|= $self->{option}->{use_display_name};
227			$option{use_group} \|\|= $self->{option}->{use_group};
228	wakaba	1.5	$option{use_keyword} \|\|= $self->{option}->{use_keyword};
229			$option{use_keyword_multiple} \|\|= $self->{option}->{use_keyword_multiple};
230			$option{use_dont_reply} \|\|= $self->{option}->{use_dont_reply};
231			$option{dont_reply} \|\|= $self->{option}->{dont_reply};
232			$option{dont_reply_display_name} = $self->{option}->{dont_reply_display_name}
233			unless defined $option{dont_reply_display_name};
234			if ($option{use_dont_reply}>0 && $option{dont_reply}>0) {
235			## usefor-article Reply-To:
236			my $g_return = '';
237			if ($option{dont_reply_display_name} && $option{use_display_name}>0) {
238			my %s = &{$self->{option}->{hook_encode_string}} ($self,
239			$option{dont_reply_display_name}, type => 'phrase');
240			$g_return = $self->quote_unsafe_string ($s{value}) .' ';
241			}
242			$g_return .= '<>';
243			return $g_return;
244			}
245	wakaba	1.1	my @return;
246	wakaba	1.5	if ($option{use_keyword}>0) {
247			my @kw = grep {$self->{keyword}->{$_}>0} keys %{$self->{keyword}};
248			return $kw[0] if $kw[0] && $option{use_keyword_multiple}<0;
249			push @return, @kw;
250			}
251	wakaba	1.1	for my $address (@{$self->{address}}) {
252			my $return = '';
253			next if !$address->{addr_spec} && $address->{type} ne 'group';
254	wakaba	1.3	if ($address->{display_name} && $option{use_display_name}>0) {
255	wakaba	1.5	if ($address->{type} eq 'group' && $option{use_group}>0) {
256			my %s = &{$self->{option}->{hook_encode_string}} ($self,
257			$address->{display_name}, type => 'phrase');
258			$return = $self->quote_unsafe_string ($s{value}).': ';
259			#} else {
260			# my %s = &{$self->{option}->{hook_encode_string}} ($self,
261			# $address->{display_name}, type => 'comment');
262			# $s{value} =~ s/[\x28\x29\x5C]/\\$&/g;
263			# $return = '('.$s{value}.') ';
264			} elsif ($address->{type} ne 'group') {
265	wakaba	1.4	my %s = &{$self->{option}->{hook_encode_string}} ($self,
266			$address->{display_name}, type => 'phrase');
267	wakaba	1.5	$return = $self->quote_unsafe_string ($s{value}).' ';
268			}
269	wakaba	1.1	}
270			if ($address->{type} ne 'group') {
271			$return .= '<'.$address->{route}.$address->{addr_spec}.'>';
272			} else {
273			my (@g_return);
274			for my $mailbox (@{$address->{address}}) {
275			next unless $mailbox->{addr_spec};
276			my $g_return = '';
277	wakaba	1.4	if ($mailbox->{display_name} && $option{use_display_name}>0) {
278			my %s = &{$self->{option}->{hook_encode_string}} ($self,
279			$mailbox->{display_name}, type => 'phrase');
280			$g_return = $self->quote_unsafe_string ($s{value}) .' ';
281			}
282	wakaba	1.1	$g_return .= '<'.$mailbox->{route}.$mailbox->{addr_spec}.'>';
283			push @g_return, $g_return;
284	wakaba	1.3	last if $option{is_mailbox}>0;
285	wakaba	1.1	}
286			$return .= join ', ', @g_return;
287	wakaba	1.3	$return .= ';' if $address->{type} eq 'group' && $option{use_group}>0;
288	wakaba	1.1	}
289			push @return, $return;
290	wakaba	1.3	last if $option{is_mailbox}>0;
291			}
292	wakaba	1.5	if ($#return == -1) {
293			if ($option{is_return_path}>0) {
294			push @return, '<>';
295			#} elsif ($option{use_dont_reply}>0) { ## usefor-article Reply-To:
296			# my $g_return = '';
297			# if ($option{dont_reply_display_name} && $option{use_display_name}>0) {
298			# my %s = &{$self->{option}->{hook_encode_string}} ($self,
299			# $option{dont_reply_display_name}, type => 'phrase');
300			# $g_return = $self->quote_unsafe_string ($s{value}) .' ';
301			# }
302			# $g_return .= '<>';
303			# push @return, $g_return;
304			}
305	wakaba	1.1	}
306			join ', ', @return;
307			}
308
309	wakaba	1.5	=head2 $self->dont_reply ([$don't_reply?, [$display_name]])
310
311			Set/gets whether C<field-body> content is "don't reply!"
312			or not. Second argument is short string used as C<display-name>.
313
314			This function returns an array of C<($don't_reply?, $display_name)>.
315			<$don't_reply> takes value C<1> (true) or C<-1> (false).
316
317			Note: This don't reply convention is defined by draft-usefor-article.
318			You should not use this in RFC 2822 mail message.
319
320			Enable this, set C<use_dont_reply> option to C<1>. (Default is C<-1>.
321
322			Note: Set this value does not mean clear address list that
323			current C<Message::Field::Address> has. You can get it
324			as well as before setting new value. But C<stringify> method
325			does not output any of addresses if <$don't_reply> is C<1>.
326
327			=head3 example
328
329			my $a = Message::Field::Address->new (use_reply => 1);
330			$a->dont_reply (1, 'Please do not reply');
331			print $a; # "Please do not reply <>"
332
333			=cut
334
335			sub dont_reply ($;$$) {
336			my $self = shift;
337			my $dr = shift;
338			my $dname = shift;
339			$self->{option}->{dont_reply} = $dr if $dr;
340			$self->{option}->{dont_reply_display_name} = $dname if defined $dname;
341			($self->{dont_reply}, $self->{dont_reply_display_name});
342			}
343
344			=head2 $self->keyword ($keyword, [$true_of_false])
345
346			Set/gets whether keyword is specified. C<$true_or_false>
347			takes values C<1> and C<-1>.
348
349			This function is intended to be used for keyword(s) allowed
350			mail addresses field, such as C<Mail-Copies-To:> defined by
351			draft-usefor-article.
352
353			There are two related options, C<use_keyword> and C<use_keyword_multiple>.
354			Former is on/off switch of this function. Later allows
355			multiple options/addresses, such as C<keyworda, E<lt>foo@bar.exampleE<gt>>.
356
357			=cut
358
359			sub keyword ($$;$) {
360			my $self = shift;
361			my $key = shift;
362			my $tf = shift;
363			$self->{keyword}->{$key} = $tf if $tf;
364			$self->{keyword}->{$key} \|\| -1;
365			}
366
367	wakaba	1.1	sub quote_unsafe_string ($$) {
368			my $self = shift;
369			my $string = shift;
370			if ($string =~ /$REG{NON_atom}/ \|\| $string =~ /$REG{WSP}$REG{WSP}+/) {
371			$string =~ s/([\x22\x5C])/\x5C$1/g;
372			$string = '"'.$string.'"';
373			}
374			$string;
375			}
376
377			=head2 $self->unquote_quoted_string ($string)
378
379			Unquote C<quoted-string>. Get rid of C<DQUOTE>s and
380			C<REVERSED SOLIDUS> included in C<quoted-pair>.
381			This method is intended for internal use.
382
383			=cut
384
385			sub unquote_quoted_string ($$) {
386			my $self = shift;
387			my $quoted_string = shift;
388			$quoted_string =~ s{$REG{M_quoted_string}}{
389			my $qtext = $1;
390			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
391			$qtext;
392			}goex;
393			$quoted_string;
394			}
395
396	wakaba	1.4	sub _decode_quoted_string ($$) {
397			my $self = shift;
398			my $quoted_string = shift;
399			$quoted_string =~ s{$REG{M_quoted_string}\|([^\x22]+)}{
400			my ($qtext,$t) = ($1, $2);
401			if ($t) {
402			my %s = &{$self->{option}->{hook_decode_string}} ($self, $t,
403			type => 'value');
404			$s{value};
405			} else {
406			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
407			my %s = &{$self->{option}->{hook_decode_string}} ($self, $qtext,
408			type => 'value/quoted');
409			$s{value};
410			}
411			}goex;
412			$quoted_string;
413			}
414
415	wakaba	1.1	=head2 $self->parse_mailbox ($mailbox)
416
417			Parse C<mailbox> and return array of C<addr-spec>,
418			C<display-name> and C<route> (aka C<obs-route> of RFC 2822).
419			This method is intended for internal use.
420
421			=cut
422
423			sub parse_mailbox ($$) {
424			my $self = shift;
425			my $mailbox = shift;
426			if ($mailbox =~ /$REG{M_mailbox}/) {
427			my ($display_name, $route, $addr_spec) = ($1, $2, $3 \|\| $4);
428			$display_name =~ s/$REG{WSP}+$//;
429	wakaba	1.4	$display_name = $self->_decode_quoted_string ($display_name);
430	wakaba	1.1	$addr_spec =~ s{($REG{quoted_string}\|$REG{domain_literal})\|$REG{WSP}}{$1}go;
431			$route =~ s{($REG{quoted_string}\|$REG{domain_literal})\|$REG{WSP}}{$1}go;
432			return ($addr_spec, $display_name, $route);
433	wakaba	1.5	} elsif ($mailbox =~ /$REG{M_mailbox_empty}/) {
434			my ($display_name) = ($1);
435			$display_name =~ s/$REG{WSP}+$//;
436			$display_name = $self->_decode_quoted_string ($display_name);
437			return ('', $display_name, 'dummy');
438			} elsif ($mailbox =~ /^$REG{atext}$/) {
439			$self->{keyword}->{$mailbox} = 1;
440	wakaba	1.1	}
441	wakaba	1.5	(undef, undef, undef);
442	wakaba	1.1	}
443
444			=head2 $self->parse_address_list ($address_list)
445
446			Parse C<address-list> and return hash.
447			This method is intended for internal use.
448
449			=head3 Structure of hash returned by parse_address_list
450
451			%address = (
452
453			type => '_ROOT',
454			address => [
455
456			## mailbox
457			{
458			type => 'mailbox',
459			display_name => 'Foo H. Bar',
460			addr_spec => 'foo@bar.example',
461			route => '@hoge.example:',
462			},
463
464			## group
465			{
466			type => 'group',
467			display_name => 'The committee',
468			address => [
469
470			## mailbox
471			{
472			type => 'mailbox',
473			display_name => 'Tom (Director)',
474			addr_spec => 'tom@committee.example',
475			route => '',
476			}
477
478			],
479			},
480
481			],
482
483			);
484
485			=cut
486
487			sub parse_address_list ($$) {
488			my $self = shift;
489			my $address_list = shift;
490			my %r_addr = (type => '_ROOT');
491			$address_list =~ s{($REG{address})}{
492			my $address = $1;
493			if ($address =~ /^$REG{M_group}/) {
494			my %r_group = (type => 'group', display_name => $1);
495			$r_group{display_name} =~ s/$REG{WSP}+$//;
496			$r_group{display_name} = $self->unquote_quoted_string ($r_group{display_name});
497			$address =~ s{($REG{mailbox})}{
498			my ($addr, $name, $route) = $self->parse_mailbox ($1);
499			push @{$r_group{address}}, {type => 'mailbox',
500	wakaba	1.5	display_name => $name, route => $route, addr_spec => $addr}
501			if $addr;
502	wakaba	1.1	}goex;
503			push @{$r_addr{address}}, \%r_group;
504			} else {
505			my ($addr, $name, $route) = $self->parse_mailbox ($address);
506	wakaba	1.5	if ($addr) {
507			push @{$r_addr{address}}, {type => 'mailbox',
508			display_name => $name, route => $route, addr_spec => $addr};
509			} elsif ($route) { # dummy
510			$self->{option}->{dont_reply} = 1;
511			$self->{option}->{dont_reply_display_name} = $name;
512			}
513	wakaba	1.1	}
514			}goex;
515			%r_addr;
516			}
517
518			=head2 $self->delete_comment ($field_body)
519
520			Remove all C<comment> in given strictured C<field-body>.
521			This method is intended for internal use.
522
523			=cut
524
525			sub delete_comment ($$) {
526			my $self = shift;
527			my $body = shift;
528			$body =~ s{($REG{quoted_string}\|$REG{domain_literal})\|$REG{comment}}{
529			my $o = $1; $o? $o : ' ';
530			}gex;
531			$body;
532			}
533
534			=head1 EXAMPLE
535
536			## Compose field-body for To: field.
537
538	wakaba	1.2	use Message::Field::Address;
539	wakaba	1.1	my $addr = new Message::Field::Address;
540			$addr->add ('foo@example.org', name => 'Mr. foo bar');
541			$addr->add ('webmaster@example.org', group => 'administrators');
542			$addr->add ('postmaster@example.org', group => 'administrators');
543
544			my $field_body = $addr->stringify ();
545
546
547			## Output parsed address-list tree.
548
549			use Message::Field::Address;
550			my $addr = Message::Field::Address->parse ($field_body);
551
552			for my $i (@$addr) {
553			if ($i->{type} eq 'group') {
554			print "\x40 $i->{display_name}: \n";
555			for my $j (@{$i->{address}}) {
556			print "\t- $j->{display_name} <$j->{route}$j->{addr_spec}>\n";
557			}
558			} else {
559			print "- $i->{display_name} <$i->{route}$i->{addr_spec}>\n";
560			}
561			}
562
563			=head1 LICENSE
564
565			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
566
567			This program is free software; you can redistribute it and/or modify
568			it under the terms of the GNU General Public License as published by
569			the Free Software Foundation; either version 2 of the License, or
570			(at your option) any later version.
571
572			This program is distributed in the hope that it will be useful,
573			but WITHOUT ANY WARRANTY; without even the implied warranty of
574			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
575			GNU General Public License for more details.
576
577			You should have received a copy of the GNU General Public License
578			along with this program; see the file COPYING. If not, write to
579			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
580			Boston, MA 02111-1307, USA.
581
582			=head1 CHANGE
583
584			See F<ChangeLog>.
585	wakaba	1.7	$Date: 2002/04/05 14:55:28 $
586	wakaba	1.1
587			=cut
588
589			1;