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.8 |
$VERSION=do{my @r=(q$Revision: 1.8 $=~/\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.8 |
-output_angle_bracket => 1,
|
47 |
wakaba |
1.5 |
#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.7 |
sub value ($;$) {
|
185 |
|
|
my $self = shift;
|
186 |
|
|
my $v = shift;
|
187 |
|
|
if ($v =~ /^((?:$REG{quoted_string}|[^\x22])+?)\x40((?:$REG{domain_literal}|[^\x5B\x40])+)$/) {
|
188 |
|
|
$self->{local_part} = $1; $self->{domain} = $2;
|
189 |
|
|
$self->{domain} = $self->_parse_value (domain => $self->{domain})
|
190 |
|
|
if $self->{option}->{parse_domain} || $self->{option}->{parse_all};
|
191 |
|
|
$self->{local_part}
|
192 |
|
|
= $self->Message::Util::decode_quoted_string ($self->{local_part},
|
193 |
|
|
type => 'word',
|
194 |
|
|
charset => $self->{option}->{encoding_before_decode_local_part});
|
195 |
|
|
}
|
196 |
|
|
defined wantarray? $self->addr_spec:'';
|
197 |
|
|
}
|
198 |
|
|
|
199 |
wakaba |
1.5 |
sub route_add ($@) { shift->SUPER::add (@_) }
|
200 |
|
|
sub route_count ($@) { shift->SUPER::count (@_) }
|
201 |
|
|
sub route_delete ($@) { shift->SUPER::delete (@_) }
|
202 |
|
|
sub route_item ($@) { shift->SUPER::item (@_) }
|
203 |
wakaba |
1.1 |
|
204 |
|
|
sub _delete_match ($$$\%\%) {
|
205 |
|
|
my $self = shift;
|
206 |
|
|
my ($by, $i, $list, $option) = @_;
|
207 |
wakaba |
1.5 |
return 0 unless ref $$i; ## Already removed
|
208 |
wakaba |
1.1 |
return 0 if $$option{type} && $$i->{type} ne $$option{type};
|
209 |
|
|
if ($by eq 'domain') {
|
210 |
wakaba |
1.5 |
$$i = $self->_parse_value (domain => $$i);
|
211 |
wakaba |
1.1 |
return 1 if $list->{$$i};
|
212 |
|
|
}
|
213 |
|
|
0;
|
214 |
|
|
}
|
215 |
|
|
*_item_match = \&_delete_match;
|
216 |
|
|
|
217 |
|
|
## Returns returned item value \$item-value, \%option
|
218 |
|
|
sub _item_return_value ($\$\%) {
|
219 |
|
|
if (ref ${$_[1]}) {
|
220 |
|
|
${$_[1]};
|
221 |
|
|
} else {
|
222 |
|
|
${$_[1]} = $_[0]->_parse_value (domain => ${$_[1]});
|
223 |
|
|
${$_[1]};
|
224 |
|
|
}
|
225 |
|
|
}
|
226 |
|
|
sub _item_new_value ($$\%) {
|
227 |
wakaba |
1.5 |
$_[0]->_parse_value (domain => ($_[2]->{by} eq 'domain'? $_[1]: ''));
|
228 |
wakaba |
1.1 |
}
|
229 |
|
|
|
230 |
wakaba |
1.5 |
sub have_group ($) { 0 }
|
231 |
wakaba |
1.2 |
|
232 |
|
|
sub addr_spec ($;%) {
|
233 |
|
|
my $self = shift;
|
234 |
|
|
my %o = (
|
235 |
|
|
-output_angle_bracket => 0,
|
236 |
|
|
-output_comment => 0,
|
237 |
|
|
-output_display_name => 0,
|
238 |
|
|
-output_keyword => 0,
|
239 |
|
|
-output_route => 0,
|
240 |
|
|
);
|
241 |
|
|
$self->stringify (%o, @_);
|
242 |
|
|
}
|
243 |
wakaba |
1.7 |
#*value = \&addr_spec;
|
244 |
wakaba |
1.2 |
|
245 |
wakaba |
1.5 |
## $self->_stringify_value (\%option)
|
246 |
|
|
sub _stringify_value ($\%) {
|
247 |
wakaba |
1.1 |
my $self = shift;
|
248 |
wakaba |
1.5 |
my $option = shift;
|
249 |
|
|
my %r;
|
250 |
|
|
my %s = &{$option->{hook_encode_string}} ($self,
|
251 |
wakaba |
1.1 |
$self->{local_part}, type => 'word',
|
252 |
wakaba |
1.5 |
charset => $option->{encoding_after_encode_local_part});
|
253 |
|
|
my $as = Message::Util::quote_unsafe_string ($s{value},
|
254 |
|
|
unsafe => $option->{unsafe_rule_local_part});
|
255 |
wakaba |
1.1 |
my $d = '' . $self->{domain};
|
256 |
wakaba |
1.5 |
$d ||= $option->{default_domain} if $option->{fill_domain};
|
257 |
wakaba |
1.1 |
$as .= '@' . $d if length $d && length $as;
|
258 |
wakaba |
1.5 |
if ($option->{output_angle_bracket}) {
|
259 |
|
|
if ($option->{output_route}) {
|
260 |
wakaba |
1.1 |
my $route = join ',', grep {$_ ne '@'}
|
261 |
|
|
map {'@'.$_} @{$self->{route}};
|
262 |
|
|
$as = $route . ':' . $as if $route;
|
263 |
|
|
}
|
264 |
|
|
}
|
265 |
wakaba |
1.5 |
$r{value} = $as;
|
266 |
|
|
$r{display_name} = $self->{display_name};
|
267 |
|
|
$r{comment} = $self->{comment};
|
268 |
|
|
$r{keyword} = $self->{keyword};
|
269 |
|
|
%r;
|
270 |
|
|
}
|
271 |
|
|
|
272 |
|
|
## $self->_option_recursive (\%argv)
|
273 |
|
|
sub _option_recursive ($\%) {
|
274 |
|
|
my $self = shift;
|
275 |
|
|
my $o = shift;
|
276 |
|
|
for (@{$self->{route}}) {
|
277 |
|
|
$_->option (%$o) if ref $_;
|
278 |
wakaba |
1.1 |
}
|
279 |
wakaba |
1.5 |
$self->{local_part}->option (%$o) if ref $self->{local_part};
|
280 |
|
|
$self->{domain}->option (%$o) if ref $self->{domain};
|
281 |
wakaba |
1.1 |
}
|
282 |
|
|
|
283 |
|
|
=head1 LICENSE
|
284 |
|
|
|
285 |
|
|
Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
|
286 |
|
|
|
287 |
|
|
This program is free software; you can redistribute it and/or modify
|
288 |
|
|
it under the terms of the GNU General Public License as published by
|
289 |
|
|
the Free Software Foundation; either version 2 of the License, or
|
290 |
|
|
(at your option) any later version.
|
291 |
|
|
|
292 |
|
|
This program is distributed in the hope that it will be useful,
|
293 |
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
294 |
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
295 |
|
|
GNU General Public License for more details.
|
296 |
|
|
|
297 |
|
|
You should have received a copy of the GNU General Public License
|
298 |
|
|
along with this program; see the file COPYING. If not, write to
|
299 |
|
|
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
300 |
|
|
Boston, MA 02111-1307, USA.
|
301 |
|
|
|
302 |
|
|
=head1 CHANGE
|
303 |
|
|
|
304 |
|
|
See F<ChangeLog>.
|
305 |
wakaba |
1.8 |
$Date: 2002/07/26 12:42:00 $
|
306 |
wakaba |
1.1 |
|
307 |
|
|
=cut
|
308 |
|
|
|
309 |
|
|
1;
|