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{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{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_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 = (
  encoding_after_encode => '*default',
  encoding_before_decode        => '*default',
  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,
  is_return_path        => -1,
  use_display_name      => 1,
  use_group     => 1,
);

sub _init_option ($$) {
  my $self = shift;
  my $field_name = shift;
  if ($field_name eq 'from' || $field_name eq 'resent-from') {
    $self->{option}->{is_mailbox} = 1;
  } elsif ($field_name eq 'return-path') {
    $self->{option}->{is_mailbox} = 1;
    $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>.

=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}};
}

=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};
  my @return;
  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) {
        my %s = &{$self->{option}->{hook_encode_string}} ($self, 
          $address->{display_name}, type => 'phrase');
      $return = $self->quote_unsafe_string ($s{value})
        .($address->{type} eq 'group' && $option{use_group}>0? ': ': ' ');
    }
    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 ($option{is_return_path}>0 && $#return == -1) {
    push @return, '<>';
  }
  join ', ', @return;
}

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);
  }
}

=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};
      }goex;
      push @{$r_addr{address}}, \%r_group;
    } else {
      my ($addr, $name, $route) = $self->parse_mailbox ($address);
      push @{$r_addr{address}}, {type => 'mailbox',
           display_name => $name, route => $route, addr_spec => $addr};
    }
  }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/03/20 09:56:26 $

=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			$REG{mailbox} = qr/(?:(?:$REG{phrase})?<$REG{FWS}(?:$REG{obs_route})?$REG{FWS}$REG{addr_spec}$REG{FWS}>\|$REG{addr_spec})/;
35			$REG{mailbox_list} = qr/$REG{mailbox}(?:$REG{FWS},(?:$REG{FWS}$REG{mailbox})?)*/;
36			$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})/;
37			$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			$REG{M_quoted_string} = qr/\x22((?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*)\x22/;
41
42			$REG{NON_atom} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
43
44	wakaba	1.4	%DEFAULT = (
45			encoding_after_encode => '*default',
46			encoding_before_decode => '*default',
47			hook_encode_string => #sub {shift; (value => shift, @_)},
48			\&Message::Util::encode_header_string,
49			hook_decode_string => #sub {shift; (value => shift, @_)},
50			\&Message::Util::decode_header_string,
51	wakaba	1.3	is_mailbox => -1,
52			is_return_path => -1,
53			use_display_name => 1,
54			use_group => 1,
55			);
56
57			sub _init_option ($$) {
58			my $self = shift;
59			my $field_name = shift;
60			if ($field_name eq 'from' \|\| $field_name eq 'resent-from') {
61			$self->{option}->{is_mailbox} = 1;
62			} elsif ($field_name eq 'return-path') {
63			$self->{option}->{is_mailbox} = 1;
64			$self->{option}->{is_return_path} = 1;
65			$self->{option}->{use_display_name} = -1;
66			}
67			$self;
68			}
69
70	wakaba	1.2	=head2 Message::Field::Address->new ()
71	wakaba	1.1
72			Return empty address object.
73
74			=cut
75
76	wakaba	1.3	sub new ($;%) {
77			my $self = bless {type => '_ROOT'}, shift;
78			my %option = @_;
79	wakaba	1.4	for (%DEFAULT) {$option{$_} \|\|= $DEFAULT{$_}}
80	wakaba	1.3	$self->{option} = \%option;
81			$self->_init_option ($self->{option}->{field_name});
82			$self;
83	wakaba	1.1	}
84
85	wakaba	1.2	=head2 Message::Field::Address->parse ($unfolded_field_body)
86	wakaba	1.1
87			Parse structured C<field-body> contain of C<address-list>.
88
89			=cut
90
91	wakaba	1.3	sub parse ($$;%) {
92	wakaba	1.1	my $self = bless {}, shift;
93			my $field_body = shift;
94	wakaba	1.3	my %option = @_;
95	wakaba	1.4	for (%DEFAULT) {$option{$_} \|\|= $DEFAULT{$_}}
96	wakaba	1.3	$self->{option} = \%option;
97			$self->_init_option ($self->{option}->{field_name});
98	wakaba	1.1	$field_body = $self->delete_comment ($field_body);
99			my %addr = $self->parse_address_list ($field_body);
100			$self->{address} = $addr{address};
101			$self->{type} = $addr{type};
102			$self;
103			}
104
105			=head2 $self->address ()
106
107			Return address list in the format described in
108			L<$self-E<gt>parse_address_list ()>.
109
110			=cut
111
112			sub address ($) {@{shift->{address}}}
113
114	wakaba	1.4	=head2 $self->addr_spec ([$index])
115
116			Returns (C<$index>'th or all) C<addr-spec>.
117
118			=cut
119
120			sub addr_spec ($;$) {
121			my $self = shift;
122			my $i = shift;
123			return $self->{address}->[$i]->{addr_spec}
124			if defined $i && ref $self->{address}->[$i];
125			map {$_->{addr_spec}} @{$self->{address}};
126			}
127
128	wakaba	1.1	=head2 $self->add ($addr_spec, [%option])
129
130			Add an mail address to C<$self> (address object).
131			%option = (name => C<display-name>, route => C<route>,
132			group => C<display-name> of C<group>)
133
134			Note that this method (and other methods) does not check
135			$addr_spec and $option{route} is valid or not.
136
137			=cut
138
139			sub add ($$;%) {
140			my $self = shift;
141			my ($addr, %option) = @_;
142			my $name = $option{name} \|\| $option{display_name};
143			unless ($option{group}) {
144			push @{$self->{address}}, {type => 'mailbox',
145			addr_spec => $addr, display_name => $name, route => $option{route}};
146			} else {
147			for my $i (@{$self->{address}}) {
148			if ($i->{type} eq 'group' && $i->{display_name} eq $option{group}) {
149			push @{$i->{address}}, {type => 'mailbox',
150			addr_spec => $addr, display_name => $name, route => $option{route}};
151			return $self;
152			}
153			}
154			push @{$self->{address}}, {type => 'group', display_name => $option{group},
155			address => [
156			{type => 'mailbox',
157			addr_spec => $addr, display_name => $name, route => $option{route}}
158			]};
159			}
160			$self;
161			}
162
163	wakaba	1.3	sub stringify ($;%) {
164	wakaba	1.1	my $self = shift;
165	wakaba	1.3	my %option = @_;
166			$option{is_mailbox} \|\|= $self->{option}->{is_mailbox};
167			$option{is_return_path} \|\|= $self->{option}->{is_return_path};
168			$option{use_display_name} \|\|= $self->{option}->{use_display_name};
169			$option{use_group} \|\|= $self->{option}->{use_group};
170	wakaba	1.1	my @return;
171			for my $address (@{$self->{address}}) {
172			my $return = '';
173			next if !$address->{addr_spec} && $address->{type} ne 'group';
174	wakaba	1.3	if ($address->{display_name} && $option{use_display_name}>0) {
175	wakaba	1.4	my %s = &{$self->{option}->{hook_encode_string}} ($self,
176			$address->{display_name}, type => 'phrase');
177			$return = $self->quote_unsafe_string ($s{value})
178	wakaba	1.3	.($address->{type} eq 'group' && $option{use_group}>0? ': ': ' ');
179	wakaba	1.1	}
180			if ($address->{type} ne 'group') {
181			$return .= '<'.$address->{route}.$address->{addr_spec}.'>';
182			} else {
183			my (@g_return);
184			for my $mailbox (@{$address->{address}}) {
185			next unless $mailbox->{addr_spec};
186			my $g_return = '';
187	wakaba	1.4	if ($mailbox->{display_name} && $option{use_display_name}>0) {
188			my %s = &{$self->{option}->{hook_encode_string}} ($self,
189			$mailbox->{display_name}, type => 'phrase');
190			$g_return = $self->quote_unsafe_string ($s{value}) .' ';
191			}
192	wakaba	1.1	$g_return .= '<'.$mailbox->{route}.$mailbox->{addr_spec}.'>';
193			push @g_return, $g_return;
194	wakaba	1.3	last if $option{is_mailbox}>0;
195	wakaba	1.1	}
196			$return .= join ', ', @g_return;
197	wakaba	1.3	$return .= ';' if $address->{type} eq 'group' && $option{use_group}>0;
198	wakaba	1.1	}
199			push @return, $return;
200	wakaba	1.3	last if $option{is_mailbox}>0;
201			}
202			if ($option{is_return_path}>0 && $#return == -1) {
203			push @return, '<>';
204	wakaba	1.1	}
205			join ', ', @return;
206			}
207
208			sub quote_unsafe_string ($$) {
209			my $self = shift;
210			my $string = shift;
211			if ($string =~ /$REG{NON_atom}/ \|\| $string =~ /$REG{WSP}$REG{WSP}+/) {
212			$string =~ s/([\x22\x5C])/\x5C$1/g;
213			$string = '"'.$string.'"';
214			}
215			$string;
216			}
217
218			=head2 $self->unquote_quoted_string ($string)
219
220			Unquote C<quoted-string>. Get rid of C<DQUOTE>s and
221			C<REVERSED SOLIDUS> included in C<quoted-pair>.
222			This method is intended for internal use.
223
224			=cut
225
226			sub unquote_quoted_string ($$) {
227			my $self = shift;
228			my $quoted_string = shift;
229			$quoted_string =~ s{$REG{M_quoted_string}}{
230			my $qtext = $1;
231			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
232			$qtext;
233			}goex;
234			$quoted_string;
235			}
236
237	wakaba	1.4	sub _decode_quoted_string ($$) {
238			my $self = shift;
239			my $quoted_string = shift;
240			$quoted_string =~ s{$REG{M_quoted_string}\|([^\x22]+)}{
241			my ($qtext,$t) = ($1, $2);
242			if ($t) {
243			my %s = &{$self->{option}->{hook_decode_string}} ($self, $t,
244			type => 'value');
245			$s{value};
246			} else {
247			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
248			my %s = &{$self->{option}->{hook_decode_string}} ($self, $qtext,
249			type => 'value/quoted');
250			$s{value};
251			}
252			}goex;
253			$quoted_string;
254			}
255
256	wakaba	1.1	=head2 $self->parse_mailbox ($mailbox)
257
258			Parse C<mailbox> and return array of C<addr-spec>,
259			C<display-name> and C<route> (aka C<obs-route> of RFC 2822).
260			This method is intended for internal use.
261
262			=cut
263
264			sub parse_mailbox ($$) {
265			my $self = shift;
266			my $mailbox = shift;
267			if ($mailbox =~ /$REG{M_mailbox}/) {
268			my ($display_name, $route, $addr_spec) = ($1, $2, $3 \|\| $4);
269			$display_name =~ s/$REG{WSP}+$//;
270	wakaba	1.4	$display_name = $self->_decode_quoted_string ($display_name);
271	wakaba	1.1	$addr_spec =~ s{($REG{quoted_string}\|$REG{domain_literal})\|$REG{WSP}}{$1}go;
272			$route =~ s{($REG{quoted_string}\|$REG{domain_literal})\|$REG{WSP}}{$1}go;
273			return ($addr_spec, $display_name, $route);
274			}
275			}
276
277			=head2 $self->parse_address_list ($address_list)
278
279			Parse C<address-list> and return hash.
280			This method is intended for internal use.
281
282			=head3 Structure of hash returned by parse_address_list
283
284			%address = (
285
286			type => '_ROOT',
287			address => [
288
289			## mailbox
290			{
291			type => 'mailbox',
292			display_name => 'Foo H. Bar',
293			addr_spec => 'foo@bar.example',
294			route => '@hoge.example:',
295			},
296
297			## group
298			{
299			type => 'group',
300			display_name => 'The committee',
301			address => [
302
303			## mailbox
304			{
305			type => 'mailbox',
306			display_name => 'Tom (Director)',
307			addr_spec => 'tom@committee.example',
308			route => '',
309			}
310
311			],
312			},
313
314			],
315
316			);
317
318			=cut
319
320			sub parse_address_list ($$) {
321			my $self = shift;
322			my $address_list = shift;
323			my %r_addr = (type => '_ROOT');
324			$address_list =~ s{($REG{address})}{
325			my $address = $1;
326			if ($address =~ /^$REG{M_group}/) {
327			my %r_group = (type => 'group', display_name => $1);
328			$r_group{display_name} =~ s/$REG{WSP}+$//;
329			$r_group{display_name} = $self->unquote_quoted_string ($r_group{display_name});
330			$address =~ s{($REG{mailbox})}{
331			my ($addr, $name, $route) = $self->parse_mailbox ($1);
332			push @{$r_group{address}}, {type => 'mailbox',
333			display_name => $name, route => $route, addr_spec => $addr};
334			}goex;
335			push @{$r_addr{address}}, \%r_group;
336			} else {
337			my ($addr, $name, $route) = $self->parse_mailbox ($address);
338			push @{$r_addr{address}}, {type => 'mailbox',
339			display_name => $name, route => $route, addr_spec => $addr};
340			}
341			}goex;
342			%r_addr;
343			}
344
345			=head2 $self->delete_comment ($field_body)
346
347			Remove all C<comment> in given strictured C<field-body>.
348			This method is intended for internal use.
349
350			=cut
351
352			sub delete_comment ($$) {
353			my $self = shift;
354			my $body = shift;
355			$body =~ s{($REG{quoted_string}\|$REG{domain_literal})\|$REG{comment}}{
356			my $o = $1; $o? $o : ' ';
357			}gex;
358			$body;
359			}
360
361			=head1 EXAMPLE
362
363			## Compose field-body for To: field.
364
365	wakaba	1.2	use Message::Field::Address;
366	wakaba	1.1	my $addr = new Message::Field::Address;
367			$addr->add ('foo@example.org', name => 'Mr. foo bar');
368			$addr->add ('webmaster@example.org', group => 'administrators');
369			$addr->add ('postmaster@example.org', group => 'administrators');
370
371			my $field_body = $addr->stringify ();
372
373
374			## Output parsed address-list tree.
375
376			use Message::Field::Address;
377			my $addr = Message::Field::Address->parse ($field_body);
378
379			for my $i (@$addr) {
380			if ($i->{type} eq 'group') {
381			print "\x40 $i->{display_name}: \n";
382			for my $j (@{$i->{address}}) {
383			print "\t- $j->{display_name} <$j->{route}$j->{addr_spec}>\n";
384			}
385			} else {
386			print "- $i->{display_name} <$i->{route}$i->{addr_spec}>\n";
387			}
388			}
389
390			=head1 LICENSE
391
392			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
393
394			This program is free software; you can redistribute it and/or modify
395			it under the terms of the GNU General Public License as published by
396			the Free Software Foundation; either version 2 of the License, or
397			(at your option) any later version.
398
399			This program is distributed in the hope that it will be useful,
400			but WITHOUT ANY WARRANTY; without even the implied warranty of
401			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
402			GNU General Public License for more details.
403
404			You should have received a copy of the GNU General Public License
405			along with this program; see the file COPYING. If not, write to
406			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
407			Boston, MA 02111-1307, USA.
408
409			=head1 CHANGE
410
411			See F<ChangeLog>.
412	wakaba	1.4	$Date: 2002/03/20 09:56:26 $
413	wakaba	1.1
414			=cut
415
416			1;