Message/Field/Mailbox.pm


=head1 NAME

Message::Field::Mailbox --- A perl module for an Internet
mail address (mailbox) which is part of Internet Messages

=cut

package Message::Field::Mailbox;
use strict;
use vars qw(%DEFAULT @ISA %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.5 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Field::AngleQuoted;
push @ISA, qw(Message::Field::AngleQuoted);

%REG = %Message::Util::REG;
        $REG{sub_domain} = qr/$REG{atext}|$REG{domain_literal}/;
        $REG{domain} = qr/$REG{sub_domain}(?:$REG{FWS}\.$REG{FWS}$REG{sub_domain})*/;
        $REG{route} = qr/\x40$REG{FWS}$REG{domain}(?:[\x09\x20,]*\x40$REG{FWS}$REG{domain})*$REG{FWS}:/;

%DEFAULT = (
    -_ARRAY_NAME        => 'route',
    -_ARRAY_VALTYPE     => 'domain',
    -_MEMBERS   => [qw|display_name route local_part domain keyword|],
    -_METHODS   => [qw|addr_spec display_name local_part domain keyword
                       have_group comment_add comment_delete comment_item
                       comment_count route_add route_count route_delete
                       route_item|],
    -allow_empty        => 0,
    -by => 'domain',
    -comment_to_display_name    => 1,
    -default_domain     => 'localhost',
    #encoding_after_encode
    #encoding_before_decode
    #-encoding_after_encode_domain      => 'unknown-8bit',
    #-encoding_before_decode_domain     => 'unknown-8bit',
    -encoding_after_encode_local_part   => 'unknown-8bit',
    -encoding_before_decode_local_part  => 'unknown-8bit',
    #field_param_name
    #field_name
    -fill_domain        => 1,
    #format
    #hook_encode_string
    #hook_decode_string
    -must_have_addr_spec        => 1,
    #output_angle_bracket       => 1,
    #output_comment     => 1,
    #output_display_name        => 1,
    #output_keyword     => 0,
    -output_route       => 0,
    #parse_all  => 0,   ## = parse_domain + parse_local_part
    -parse_domain       => 0,
    -parse_local_part   => 0,   ## not implemented.
    #unsafe_rule_of_display_name        => 'NON_http_attribute_char_wsp',
    -unsafe_rule_of_local_part  => 'NON_http_attribute_char_wsp',
    #unsafe_rule_of_keyword     => 'NON_atext',
    -use_comment_in_angle       => 1,
    #use_keyword        => 0,
);

=head1 CONSTRUCTORS

The following methods construct new objects:

=over 4

=cut

## $self->_init (%options); Initialize of this class -- called by constructors
sub _init ($;%) {
  my $self = shift;
  my %options = @_;
  my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
  $self->SUPER::_init (%$DEFAULT, %options);
  $self->{option}->{value_type}->{domain} = ['Message::Field::Domain', {
      #-encoding_after_encode => $self->{option}->{encoding_after_encode_domain},
      #-encoding_before_decode => $self->{option}->{encoding_before_decode_domain},
  },];
  
  my $format = $self->{option}->{format};
  my $field = $self->{option}->{field_name};
  if ($format =~ /mail-rfc822/) {
    $self->{option}->{output_route} = 1
      if $field eq 'from' || $field eq 'resent-from'
      || $field eq 'sender' || $field eq 'resent-sender'
      || $field eq 'to' || $field eq 'cc' || $field eq 'bcc'
      || $field eq 'resent-to' || $field eq 'resent-cc'
      || $field eq 'resent-bcc' || $field eq 'reply-to'
      || $field eq 'resent-reply-to' || $field eq 'return-path';
  }
  if ($field eq 'mail-copies-to') {
    $self->{option}->{use_keyword} = 1;
    $self->{option}->{output_keyword} = 1;
  }
  if ($field eq 'return-path') {
    $self->{option}->{allow_empty} = 1;
    $self->{option}->{allow_empty} = 0
      if $format =~ /rfc822/ && $format !~ /rfc1123/;
    $self->{option}->{output_display_name} = 0;
    $self->{option}->{output_comment} = 0
      if $format =~ /smtp/;
        ## RFC [2]822 allows CFWS, but [2]821 does NOT.
  }
  #if ($format =~ /http/) {
  #  $self->{option}->{unsafe_rule_local_part} = 'NON_http_attribute_char_wsp';
  #}
}

=item $m = Message::Field::Mailbox->new ([%options])

Constructs a new object.  You might pass some options as parameters 
to the constructor.

=cut

## Inherited

=item $m = Message::Field::Mailbox->parse ($field-body, [%options])

Constructs a new object with given field body.  You might pass 
some options as parameters to the constructor.

=cut

## $self->_save_value ($value, $display_name, \@comment)
sub _save_value ($$\@%) {
  my $self = shift;
  my ($v, $dn, $comment, %misc) = @_;
  my $parse_lp = $self->{option}->{parse_local_part}
              || $self->{option}->{parse_all};
  my $parse_dm = $self->{option}->{parse_domain}
              || $self->{option}->{parse_all};
  $v = Message::Util::remove_meaningless_wsp ($v);
  if ($v =~ /^($REG{route})?((?:$REG{quoted_string}|[^\x22])+?)\x40((?:$REG{domain_literal}|[^\x5B\x40])+)$/) {
    my $route = $1;
    $self->{local_part} = $2; $self->{domain} = $3;
    $self->{domain} = $self->_parse_value ('domain' => $self->{domain})
      if $parse_dm;
    $route =~ s{\x40$REG{FWS}($REG{domain})}{
      my $d = $1;
      $d = $self->_parse_value (domain => $d) if $parse_dm;
      push @{$self->{route}}, $d;
    }gex;
  } elsif (length $v) {
    $self->{local_part} = $v;
  }
  $self->{local_part}
    = $self->Message::Util::decode_quoted_string ($self->{local_part}, 
      type => 'word',
      charset => $self->{option}->{encoding_before_decode_local_part});
  $self->{comment} = $comment;
  $self->{display_name} = $dn;
  $self->{keyword} = $misc{keyword};
}

## display_name: Inherited

sub local_part ($;$) {
  my $self = shift;
  my $newlp = shift;
  $self->{local_part} = $newlp if defined $newlp;
  $self->{local_part};
}

sub domain ($;$) {
  my $self = shift;
  my $newdomain = shift;
  if (defined $newdomain) {
    $newdomain = $self->_parse_value (domain => $newdomain)
      if $self->{option}->{parse_domain} || $self->{option}->{parse_all};
    $self->{domain} = $newdomain;
  }
  $self->{domain};
}

sub keyword ($;$) {
  my $self = shift;
  return unless $self->{option}->{use_keyword};
  my $newkey = shift;
  $self->{keyword} = $newkey if defined $newkey;
  $self->{keyword};
}

sub route_add ($@) { shift->SUPER::add (@_) }
sub route_count ($@) { shift->SUPER::count (@_) }
sub route_delete ($@) { shift->SUPER::delete (@_) }
sub route_item ($@) { shift->SUPER::item (@_) }

sub _delete_match ($$$\%\%) {
  my $self = shift;
  my ($by, $i, $list, $option) = @_;
  return 0 unless ref $$i;      ## Already removed
  return 0 if $$option{type} && $$i->{type} ne $$option{type};
  if ($by eq 'domain') {
    $$i = $self->_parse_value (domain => $$i);
    return 1 if $list->{$$i};
  }
  0;
}
*_item_match = \&_delete_match;

## Returns returned item value    \$item-value, \%option
sub _item_return_value ($\$\%) {
  if (ref ${$_[1]}) {
    ${$_[1]};
  } else {
    ${$_[1]} = $_[0]->_parse_value (domain => ${$_[1]});
    ${$_[1]};
  }
}
sub _item_new_value ($$\%) {
  $_[0]->_parse_value (domain => ($_[2]->{by} eq 'domain'? $_[1]: ''));
}

sub have_group ($) { 0 }

sub addr_spec ($;%) {
  my $self = shift;
  my %o = (
    -output_angle_bracket       => 0,
    -output_comment     => 0,
    -output_display_name        => 0,
    -output_keyword     => 0,
    -output_route       => 0,
  );
  $self->stringify (%o, @_);
}
*value = \&addr_spec;

## $self->_stringify_value (\%option)
sub _stringify_value ($\%) {
  my $self = shift;
  my $option = shift;
  my %r;
    my %s = &{$option->{hook_encode_string}} ($self, 
          $self->{local_part}, type => 'word',
          charset => $option->{encoding_after_encode_local_part});
    my $as = Message::Util::quote_unsafe_string ($s{value}, 
            unsafe => $option->{unsafe_rule_local_part});
    my $d = '' . $self->{domain};
    $d ||= $option->{default_domain} if $option->{fill_domain};
    $as .= '@' . $d if length $d && length $as;
      if ($option->{output_angle_bracket}) {
        if ($option->{output_route}) {
          my $route = join ',', grep {$_ ne '@'}
            map {'@'.$_} @{$self->{route}};
          $as = $route . ':' . $as if $route;
        }
      }
  $r{value} = $as;
  $r{display_name} = $self->{display_name};
  $r{comment} = $self->{comment};
  $r{keyword} = $self->{keyword};
  %r;
}

## $self->_option_recursive (\%argv)
sub _option_recursive ($\%) {
  my $self = shift;
  my $o = shift;
  for (@{$self->{route}}) {
    $_->option (%$o) if ref $_;
  }
  $self->{local_part}->option (%$o) if ref $self->{local_part};
  $self->{domain}->option (%$o) if ref $self->{domain};
}

=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/06/15 07:15:59 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Field::Mailbox --- A perl module for an Internet
5			mail address (mailbox) which is part of Internet Messages
6
7			=cut
8
9			package Message::Field::Mailbox;
10			use strict;
11			use vars qw(%DEFAULT @ISA %REG $VERSION);
12	wakaba	1.6	$VERSION=do{my @r=(q$Revision: 1.5 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13	wakaba	1.5	require Message::Field::AngleQuoted;
14			push @ISA, qw(Message::Field::AngleQuoted);
15	wakaba	1.1
16			%REG = %Message::Util::REG;
17			$REG{sub_domain} = qr/$REG{atext}\|$REG{domain_literal}/;
18			$REG{domain} = qr/$REG{sub_domain}(?:$REG{FWS}\.$REG{FWS}$REG{sub_domain})*/;
19			$REG{route} = qr/\x40$REG{FWS}$REG{domain}(?:[\x09\x20,]\x40$REG{FWS}$REG{domain})$REG{FWS}:/;
20
21	wakaba	1.6	%DEFAULT = (
22	wakaba	1.1	-_ARRAY_NAME => 'route',
23			-_ARRAY_VALTYPE => 'domain',
24	wakaba	1.2	-_MEMBERS => [qw\|display_name route local_part domain keyword\|],
25			-_METHODS => [qw\|addr_spec display_name local_part domain keyword
26			have_group comment_add comment_delete comment_item
27			comment_count route_add route_count route_delete
28			route_item\|],
29	wakaba	1.5	-allow_empty => 0,
30	wakaba	1.1	-by => 'domain',
31			-comment_to_display_name => 1,
32			-default_domain => 'localhost',
33			#encoding_after_encode
34			#encoding_before_decode
35			#-encoding_after_encode_domain => 'unknown-8bit',
36			#-encoding_before_decode_domain => 'unknown-8bit',
37			-encoding_after_encode_local_part => 'unknown-8bit',
38			-encoding_before_decode_local_part => 'unknown-8bit',
39			#field_param_name
40			#field_name
41			-fill_domain => 1,
42			#format
43			#hook_encode_string
44			#hook_decode_string
45			-must_have_addr_spec => 1,
46	wakaba	1.5	#output_angle_bracket => 1,
47			#output_comment => 1,
48			#output_display_name => 1,
49			#output_keyword => 0,
50	wakaba	1.1	-output_route => 0,
51	wakaba	1.5	#parse_all => 0, ## = parse_domain + parse_local_part
52			-parse_domain => 0,
53			-parse_local_part => 0, ## not implemented.
54			#unsafe_rule_of_display_name => 'NON_http_attribute_char_wsp',
55			-unsafe_rule_of_local_part => 'NON_http_attribute_char_wsp',
56			#unsafe_rule_of_keyword => 'NON_atext',
57			-use_comment_in_angle => 1,
58			#use_keyword => 0,
59	wakaba	1.6	);
60
61			=head1 CONSTRUCTORS
62
63			The following methods construct new objects:
64
65			=over 4
66
67			=cut
68	wakaba	1.5
69	wakaba	1.6	## $self->_init (%options); Initialize of this class -- called by constructors
70	wakaba	1.1	sub _init ($;%) {
71			my $self = shift;
72			my %options = @_;
73			my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
74			$self->SUPER::_init (%$DEFAULT, %options);
75	wakaba	1.3	$self->{option}->{value_type}->{domain} = ['Message::Field::Domain', {
76	wakaba	1.1	#-encoding_after_encode => $self->{option}->{encoding_after_encode_domain},
77			#-encoding_before_decode => $self->{option}->{encoding_before_decode_domain},
78			},];
79
80			my $format = $self->{option}->{format};
81	wakaba	1.3	my $field = $self->{option}->{field_name};
82	wakaba	1.1	if ($format =~ /mail-rfc822/) {
83	wakaba	1.2	$self->{option}->{output_route} = 1
84	wakaba	1.1	if $field eq 'from' \|\| $field eq 'resent-from'
85			\|\| $field eq 'sender' \|\| $field eq 'resent-sender'
86			\|\| $field eq 'to' \|\| $field eq 'cc' \|\| $field eq 'bcc'
87			\|\| $field eq 'resent-to' \|\| $field eq 'resent-cc'
88			\|\| $field eq 'resent-bcc' \|\| $field eq 'reply-to'
89			\|\| $field eq 'resent-reply-to' \|\| $field eq 'return-path';
90			}
91	wakaba	1.3	if ($field eq 'mail-copies-to') {
92	wakaba	1.1	$self->{option}->{use_keyword} = 1;
93	wakaba	1.2	$self->{option}->{output_keyword} = 1;
94	wakaba	1.1	}
95	wakaba	1.3	if ($field eq 'return-path') {
96	wakaba	1.5	$self->{option}->{allow_empty} = 1;
97			$self->{option}->{allow_empty} = 0
98			if $format =~ /rfc822/ && $format !~ /rfc1123/;
99	wakaba	1.1	$self->{option}->{output_display_name} = 0;
100	wakaba	1.5	$self->{option}->{output_comment} = 0
101			if $format =~ /smtp/;
102	wakaba	1.1	## RFC [2]822 allows CFWS, but [2]821 does NOT.
103			}
104	wakaba	1.5	#if ($format =~ /http/) {
105			# $self->{option}->{unsafe_rule_local_part} = 'NON_http_attribute_char_wsp';
106			#}
107	wakaba	1.1	}
108
109	wakaba	1.3	=item $m = Message::Field::Mailbox->new ([%options])
110	wakaba	1.1
111			Constructs a new object. You might pass some options as parameters
112			to the constructor.
113
114			=cut
115
116			## Inherited
117
118	wakaba	1.3	=item $m = Message::Field::Mailbox->parse ($field-body, [%options])
119	wakaba	1.1
120			Constructs a new object with given field body. You might pass
121			some options as parameters to the constructor.
122
123			=cut
124
125	wakaba	1.5	## $self->_save_value ($value, $display_name, \@comment)
126			sub _save_value ($$\@%) {
127			my $self = shift;
128			my ($v, $dn, $comment, %misc) = @_;
129	wakaba	1.1	my $parse_lp = $self->{option}->{parse_local_part}
130			\|\| $self->{option}->{parse_all};
131			my $parse_dm = $self->{option}->{parse_domain}
132			\|\| $self->{option}->{parse_all};
133	wakaba	1.5	$v = Message::Util::remove_meaningless_wsp ($v);
134			if ($v =~ /^($REG{route})?((?:$REG{quoted_string}\|[^\x22])+?)\x40((?:$REG{domain_literal}\|[^\x5B\x40])+)$/) {
135	wakaba	1.1	my $route = $1;
136			$self->{local_part} = $2; $self->{domain} = $3;
137			$self->{domain} = $self->_parse_value ('domain' => $self->{domain})
138			if $parse_dm;
139			$route =~ s{\x40$REG{FWS}($REG{domain})}{
140			my $d = $1;
141	wakaba	1.5	$d = $self->_parse_value (domain => $d) if $parse_dm;
142	wakaba	1.1	push @{$self->{route}}, $d;
143			}gex;
144	wakaba	1.5	} elsif (length $v) {
145			$self->{local_part} = $v;
146	wakaba	1.1	}
147			$self->{local_part}
148			= $self->Message::Util::decode_quoted_string ($self->{local_part},
149			type => 'word',
150			charset => $self->{option}->{encoding_before_decode_local_part});
151	wakaba	1.5	$self->{comment} = $comment;
152			$self->{display_name} = $dn;
153			$self->{keyword} = $misc{keyword};
154	wakaba	1.1	}
155
156	wakaba	1.5	## display_name: Inherited
157	wakaba	1.4
158	wakaba	1.1	sub local_part ($;$) {
159			my $self = shift;
160			my $newlp = shift;
161			$self->{local_part} = $newlp if defined $newlp;
162			$self->{local_part};
163			}
164
165			sub domain ($;$) {
166			my $self = shift;
167			my $newdomain = shift;
168			if (defined $newdomain) {
169	wakaba	1.5	$newdomain = $self->_parse_value (domain => $newdomain)
170	wakaba	1.1	if $self->{option}->{parse_domain} \|\| $self->{option}->{parse_all};
171			$self->{domain} = $newdomain;
172			}
173			$self->{domain};
174			}
175
176			sub keyword ($;$) {
177			my $self = shift;
178			return unless $self->{option}->{use_keyword};
179			my $newkey = shift;
180			$self->{keyword} = $newkey if defined $newkey;
181			$self->{keyword};
182			}
183
184	wakaba	1.5	sub route_add ($@) { shift->SUPER::add (@_) }
185			sub route_count ($@) { shift->SUPER::count (@_) }
186			sub route_delete ($@) { shift->SUPER::delete (@_) }
187			sub route_item ($@) { shift->SUPER::item (@_) }
188	wakaba	1.1
189			sub _delete_match ($$$\%\%) {
190			my $self = shift;
191			my ($by, $i, $list, $option) = @_;
192	wakaba	1.5	return 0 unless ref $$i; ## Already removed
193	wakaba	1.1	return 0 if $$option{type} && $$i->{type} ne $$option{type};
194			if ($by eq 'domain') {
195	wakaba	1.5	$$i = $self->_parse_value (domain => $$i);
196	wakaba	1.1	return 1 if $list->{$$i};
197			}
198			0;
199			}
200			*_item_match = \&_delete_match;
201
202			## Returns returned item value \$item-value, \%option
203			sub _item_return_value ($\$\%) {
204			if (ref ${$_[1]}) {
205			${$_[1]};
206			} else {
207			${$_[1]} = $_[0]->_parse_value (domain => ${$_[1]});
208			${$_[1]};
209			}
210			}
211			sub _item_new_value ($$\%) {
212	wakaba	1.5	$_[0]->_parse_value (domain => ($_[2]->{by} eq 'domain'? $_[1]: ''));
213	wakaba	1.1	}
214
215	wakaba	1.5	sub have_group ($) { 0 }
216	wakaba	1.2
217			sub addr_spec ($;%) {
218			my $self = shift;
219			my %o = (
220			-output_angle_bracket => 0,
221			-output_comment => 0,
222			-output_display_name => 0,
223			-output_keyword => 0,
224			-output_route => 0,
225			);
226			$self->stringify (%o, @_);
227			}
228	wakaba	1.5	*value = \&addr_spec;
229	wakaba	1.2
230	wakaba	1.5	## $self->_stringify_value (\%option)
231			sub _stringify_value ($\%) {
232	wakaba	1.1	my $self = shift;
233	wakaba	1.5	my $option = shift;
234			my %r;
235			my %s = &{$option->{hook_encode_string}} ($self,
236	wakaba	1.1	$self->{local_part}, type => 'word',
237	wakaba	1.5	charset => $option->{encoding_after_encode_local_part});
238			my $as = Message::Util::quote_unsafe_string ($s{value},
239			unsafe => $option->{unsafe_rule_local_part});
240	wakaba	1.1	my $d = '' . $self->{domain};
241	wakaba	1.5	$d \|\|= $option->{default_domain} if $option->{fill_domain};
242	wakaba	1.1	$as .= '@' . $d if length $d && length $as;
243	wakaba	1.5	if ($option->{output_angle_bracket}) {
244			if ($option->{output_route}) {
245	wakaba	1.1	my $route = join ',', grep {$_ ne '@'}
246			map {'@'.$_} @{$self->{route}};
247			$as = $route . ':' . $as if $route;
248			}
249			}
250	wakaba	1.5	$r{value} = $as;
251			$r{display_name} = $self->{display_name};
252			$r{comment} = $self->{comment};
253			$r{keyword} = $self->{keyword};
254			%r;
255			}
256
257			## $self->_option_recursive (\%argv)
258			sub _option_recursive ($\%) {
259			my $self = shift;
260			my $o = shift;
261			for (@{$self->{route}}) {
262			$_->option (%$o) if ref $_;
263	wakaba	1.1	}
264	wakaba	1.5	$self->{local_part}->option (%$o) if ref $self->{local_part};
265			$self->{domain}->option (%$o) if ref $self->{domain};
266	wakaba	1.1	}
267
268			=head1 LICENSE
269
270			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
271
272			This program is free software; you can redistribute it and/or modify
273			it under the terms of the GNU General Public License as published by
274			the Free Software Foundation; either version 2 of the License, or
275			(at your option) any later version.
276
277			This program is distributed in the hope that it will be useful,
278			but WITHOUT ANY WARRANTY; without even the implied warranty of
279			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
280			GNU General Public License for more details.
281
282			You should have received a copy of the GNU General Public License
283			along with this program; see the file COPYING. If not, write to
284			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
285			Boston, MA 02111-1307, USA.
286
287			=head1 CHANGE
288
289			See F<ChangeLog>.
290	wakaba	1.6	$Date: 2002/06/15 07:15:59 $
291	wakaba	1.1
292			=cut
293
294			1;