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 |
|
|
use vars qw(%REG $VERSION);
|
17 |
|
|
$VERSION = '1.00';
|
18 |
|
|
|
19 |
|
|
use overload '@{}' => sub {shift->{address}};
|
20 |
|
|
|
21 |
|
|
$REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]+|(??{$REG{comment}}))*\x29/;
|
22 |
|
|
$REG{quoted_string} = qr/\x22(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*\x22/;
|
23 |
|
|
$REG{domain_literal} = qr/\x5B(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x5A\x5E-\xFF])*\x5D/;
|
24 |
|
|
|
25 |
|
|
$REG{WSP} = qr/[\x20\x09]+/;
|
26 |
|
|
$REG{FWS} = qr/[\x20\x09]*/;
|
27 |
|
|
$REG{atext} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
|
28 |
|
|
$REG{dot_atom} = qr/$REG{atext}(?:$REG{FWS}\x2E$REG{FWS}$REG{atext})*/;
|
29 |
|
|
$REG{dot_word} = qr/(?:$REG{atext}|$REG{quoted_string})(?:$REG{FWS}\x2E$REG{FWS}(?:$REG{atext}|$REG{quoted_string}))*/;
|
30 |
|
|
$REG{phrase} = qr/(?:$REG{atext}|$REG{quoted_string})(?:$REG{atext}|$REG{quoted_string}|\.|$REG{FWS})*/;
|
31 |
|
|
$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}))*):/;
|
32 |
|
|
$REG{addr_spec} = qr/$REG{dot_word}$REG{FWS}\x40$REG{FWS}(?:$REG{dot_atom}|$REG{domain_literal})/;
|
33 |
|
|
$REG{mailbox} = qr/(?:(?:$REG{phrase})?<$REG{FWS}(?:$REG{obs_route})?$REG{FWS}$REG{addr_spec}$REG{FWS}>|$REG{addr_spec})/;
|
34 |
|
|
$REG{mailbox_list} = qr/$REG{mailbox}(?:$REG{FWS},(?:$REG{FWS}$REG{mailbox})?)*/;
|
35 |
|
|
$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})/;
|
36 |
|
|
$REG{address_list} = qr/$REG{address}(?:$REG{FWS},(?:$REG{FWS}$REG{address})?)*/;
|
37 |
|
|
$REG{M_group} = qr/($REG{phrase}):/;
|
38 |
|
|
$REG{M_mailbox} = qr/(?:($REG{phrase})?<$REG{FWS}($REG{obs_route})?$REG{FWS}($REG{addr_spec})$REG{FWS}>|($REG{addr_spec}))/;
|
39 |
|
|
$REG{M_quoted_string} = qr/\x22((?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*)\x22/;
|
40 |
|
|
|
41 |
|
|
$REG{NON_atom} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
|
42 |
|
|
|
43 |
|
|
=head2 $self->new ()
|
44 |
|
|
|
45 |
|
|
Return empty address object.
|
46 |
|
|
|
47 |
|
|
=cut
|
48 |
|
|
|
49 |
|
|
sub new ($) {
|
50 |
|
|
bless {type => '_ROOT'}, shift;
|
51 |
|
|
}
|
52 |
|
|
|
53 |
|
|
=head2 $self->parse ($unfolded_field_body)
|
54 |
|
|
|
55 |
|
|
Parse structured C<field-body> contain of C<address-list>.
|
56 |
|
|
|
57 |
|
|
=cut
|
58 |
|
|
|
59 |
|
|
sub parse ($$) {
|
60 |
|
|
my $self = bless {}, shift;
|
61 |
|
|
my $field_body = shift;
|
62 |
|
|
$field_body = $self->delete_comment ($field_body);
|
63 |
|
|
my %addr = $self->parse_address_list ($field_body);
|
64 |
|
|
$self->{address} = $addr{address};
|
65 |
|
|
$self->{type} = $addr{type};
|
66 |
|
|
$self;
|
67 |
|
|
}
|
68 |
|
|
|
69 |
|
|
=head2 $self->address ()
|
70 |
|
|
|
71 |
|
|
Return address list in the format described in
|
72 |
|
|
L<$self-E<gt>parse_address_list ()>.
|
73 |
|
|
|
74 |
|
|
=cut
|
75 |
|
|
|
76 |
|
|
sub address ($) {@{shift->{address}}}
|
77 |
|
|
|
78 |
|
|
=head2 $self->add ($addr_spec, [%option])
|
79 |
|
|
|
80 |
|
|
Add an mail address to C<$self> (address object).
|
81 |
|
|
%option = (name => C<display-name>, route => C<route>,
|
82 |
|
|
group => C<display-name> of C<group>)
|
83 |
|
|
|
84 |
|
|
Note that this method (and other methods) does not check
|
85 |
|
|
$addr_spec and $option{route} is valid or not.
|
86 |
|
|
|
87 |
|
|
=cut
|
88 |
|
|
|
89 |
|
|
sub add ($$;%) {
|
90 |
|
|
my $self = shift;
|
91 |
|
|
my ($addr, %option) = @_;
|
92 |
|
|
my $name = $option{name} || $option{display_name};
|
93 |
|
|
unless ($option{group}) {
|
94 |
|
|
push @{$self->{address}}, {type => 'mailbox',
|
95 |
|
|
addr_spec => $addr, display_name => $name, route => $option{route}};
|
96 |
|
|
} else {
|
97 |
|
|
for my $i (@{$self->{address}}) {
|
98 |
|
|
if ($i->{type} eq 'group' && $i->{display_name} eq $option{group}) {
|
99 |
|
|
push @{$i->{address}}, {type => 'mailbox',
|
100 |
|
|
addr_spec => $addr, display_name => $name, route => $option{route}};
|
101 |
|
|
return $self;
|
102 |
|
|
}
|
103 |
|
|
}
|
104 |
|
|
push @{$self->{address}}, {type => 'group', display_name => $option{group},
|
105 |
|
|
address => [
|
106 |
|
|
{type => 'mailbox',
|
107 |
|
|
addr_spec => $addr, display_name => $name, route => $option{route}}
|
108 |
|
|
]};
|
109 |
|
|
}
|
110 |
|
|
$self;
|
111 |
|
|
}
|
112 |
|
|
|
113 |
|
|
sub stringify ($) {
|
114 |
|
|
my $self = shift;
|
115 |
|
|
my @return;
|
116 |
|
|
for my $address (@{$self->{address}}) {
|
117 |
|
|
my $return = '';
|
118 |
|
|
next if !$address->{addr_spec} && $address->{type} ne 'group';
|
119 |
|
|
if ($address->{display_name}) {
|
120 |
|
|
$return = $self->quote_unsafe_string ($address->{display_name})
|
121 |
|
|
.($address->{type} eq 'group'? ': ': ' ');
|
122 |
|
|
}
|
123 |
|
|
if ($address->{type} ne 'group') {
|
124 |
|
|
$return .= '<'.$address->{route}.$address->{addr_spec}.'>';
|
125 |
|
|
} else {
|
126 |
|
|
my (@g_return);
|
127 |
|
|
for my $mailbox (@{$address->{address}}) {
|
128 |
|
|
next unless $mailbox->{addr_spec};
|
129 |
|
|
my $g_return = '';
|
130 |
|
|
$g_return = $self->quote_unsafe_string ($mailbox->{display_name}) .' '
|
131 |
|
|
if $mailbox->{display_name};
|
132 |
|
|
$g_return .= '<'.$mailbox->{route}.$mailbox->{addr_spec}.'>';
|
133 |
|
|
push @g_return, $g_return;
|
134 |
|
|
}
|
135 |
|
|
$return .= join ', ', @g_return;
|
136 |
|
|
$return .= ';' if $address->{type} eq 'group';
|
137 |
|
|
}
|
138 |
|
|
push @return, $return;
|
139 |
|
|
}
|
140 |
|
|
join ', ', @return;
|
141 |
|
|
}
|
142 |
|
|
|
143 |
|
|
sub quote_unsafe_string ($$) {
|
144 |
|
|
my $self = shift;
|
145 |
|
|
my $string = shift;
|
146 |
|
|
if ($string =~ /$REG{NON_atom}/ || $string =~ /$REG{WSP}$REG{WSP}+/) {
|
147 |
|
|
$string =~ s/([\x22\x5C])/\x5C$1/g;
|
148 |
|
|
$string = '"'.$string.'"';
|
149 |
|
|
}
|
150 |
|
|
$string;
|
151 |
|
|
}
|
152 |
|
|
|
153 |
|
|
=head2 $self->unquote_quoted_string ($string)
|
154 |
|
|
|
155 |
|
|
Unquote C<quoted-string>. Get rid of C<DQUOTE>s and
|
156 |
|
|
C<REVERSED SOLIDUS> included in C<quoted-pair>.
|
157 |
|
|
This method is intended for internal use.
|
158 |
|
|
|
159 |
|
|
=cut
|
160 |
|
|
|
161 |
|
|
sub unquote_quoted_string ($$) {
|
162 |
|
|
my $self = shift;
|
163 |
|
|
my $quoted_string = shift;
|
164 |
|
|
$quoted_string =~ s{$REG{M_quoted_string}}{
|
165 |
|
|
my $qtext = $1;
|
166 |
|
|
$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
|
167 |
|
|
$qtext;
|
168 |
|
|
}goex;
|
169 |
|
|
$quoted_string;
|
170 |
|
|
}
|
171 |
|
|
|
172 |
|
|
=head2 $self->parse_mailbox ($mailbox)
|
173 |
|
|
|
174 |
|
|
Parse C<mailbox> and return array of C<addr-spec>,
|
175 |
|
|
C<display-name> and C<route> (aka C<obs-route> of RFC 2822).
|
176 |
|
|
This method is intended for internal use.
|
177 |
|
|
|
178 |
|
|
=cut
|
179 |
|
|
|
180 |
|
|
sub parse_mailbox ($$) {
|
181 |
|
|
my $self = shift;
|
182 |
|
|
my $mailbox = shift;
|
183 |
|
|
if ($mailbox =~ /$REG{M_mailbox}/) {
|
184 |
|
|
my ($display_name, $route, $addr_spec) = ($1, $2, $3 || $4);
|
185 |
|
|
$display_name =~ s/$REG{WSP}+$//;
|
186 |
|
|
$display_name = $self->unquote_quoted_string ($display_name);
|
187 |
|
|
$addr_spec =~ s{($REG{quoted_string}|$REG{domain_literal})|$REG{WSP}}{$1}go;
|
188 |
|
|
$route =~ s{($REG{quoted_string}|$REG{domain_literal})|$REG{WSP}}{$1}go;
|
189 |
|
|
return ($addr_spec, $display_name, $route);
|
190 |
|
|
}
|
191 |
|
|
}
|
192 |
|
|
|
193 |
|
|
=head2 $self->parse_address_list ($address_list)
|
194 |
|
|
|
195 |
|
|
Parse C<address-list> and return hash.
|
196 |
|
|
This method is intended for internal use.
|
197 |
|
|
|
198 |
|
|
=head3 Structure of hash returned by parse_address_list
|
199 |
|
|
|
200 |
|
|
%address = (
|
201 |
|
|
|
202 |
|
|
type => '_ROOT',
|
203 |
|
|
address => [
|
204 |
|
|
|
205 |
|
|
## mailbox
|
206 |
|
|
{
|
207 |
|
|
type => 'mailbox',
|
208 |
|
|
display_name => 'Foo H. Bar',
|
209 |
|
|
addr_spec => 'foo@bar.example',
|
210 |
|
|
route => '@hoge.example:',
|
211 |
|
|
},
|
212 |
|
|
|
213 |
|
|
## group
|
214 |
|
|
{
|
215 |
|
|
type => 'group',
|
216 |
|
|
display_name => 'The committee',
|
217 |
|
|
address => [
|
218 |
|
|
|
219 |
|
|
## mailbox
|
220 |
|
|
{
|
221 |
|
|
type => 'mailbox',
|
222 |
|
|
display_name => 'Tom (Director)',
|
223 |
|
|
addr_spec => 'tom@committee.example',
|
224 |
|
|
route => '',
|
225 |
|
|
}
|
226 |
|
|
|
227 |
|
|
],
|
228 |
|
|
},
|
229 |
|
|
|
230 |
|
|
],
|
231 |
|
|
|
232 |
|
|
);
|
233 |
|
|
|
234 |
|
|
=cut
|
235 |
|
|
|
236 |
|
|
sub parse_address_list ($$) {
|
237 |
|
|
my $self = shift;
|
238 |
|
|
my $address_list = shift;
|
239 |
|
|
my %r_addr = (type => '_ROOT');
|
240 |
|
|
$address_list =~ s{($REG{address})}{
|
241 |
|
|
my $address = $1;
|
242 |
|
|
if ($address =~ /^$REG{M_group}/) {
|
243 |
|
|
my %r_group = (type => 'group', display_name => $1);
|
244 |
|
|
$r_group{display_name} =~ s/$REG{WSP}+$//;
|
245 |
|
|
$r_group{display_name} = $self->unquote_quoted_string ($r_group{display_name});
|
246 |
|
|
$address =~ s{($REG{mailbox})}{
|
247 |
|
|
my ($addr, $name, $route) = $self->parse_mailbox ($1);
|
248 |
|
|
push @{$r_group{address}}, {type => 'mailbox',
|
249 |
|
|
display_name => $name, route => $route, addr_spec => $addr};
|
250 |
|
|
}goex;
|
251 |
|
|
push @{$r_addr{address}}, \%r_group;
|
252 |
|
|
} else {
|
253 |
|
|
my ($addr, $name, $route) = $self->parse_mailbox ($address);
|
254 |
|
|
push @{$r_addr{address}}, {type => 'mailbox',
|
255 |
|
|
display_name => $name, route => $route, addr_spec => $addr};
|
256 |
|
|
}
|
257 |
|
|
}goex;
|
258 |
|
|
%r_addr;
|
259 |
|
|
}
|
260 |
|
|
|
261 |
|
|
=head2 $self->delete_comment ($field_body)
|
262 |
|
|
|
263 |
|
|
Remove all C<comment> in given strictured C<field-body>.
|
264 |
|
|
This method is intended for internal use.
|
265 |
|
|
|
266 |
|
|
=cut
|
267 |
|
|
|
268 |
|
|
sub delete_comment ($$) {
|
269 |
|
|
my $self = shift;
|
270 |
|
|
my $body = shift;
|
271 |
|
|
$body =~ s{($REG{quoted_string}|$REG{domain_literal})|$REG{comment}}{
|
272 |
|
|
my $o = $1; $o? $o : ' ';
|
273 |
|
|
}gex;
|
274 |
|
|
$body;
|
275 |
|
|
}
|
276 |
|
|
|
277 |
|
|
=head1 EXAMPLE
|
278 |
|
|
|
279 |
|
|
## Compose field-body for To: field.
|
280 |
|
|
|
281 |
|
|
my $addr = new Message::Field::Address;
|
282 |
|
|
$addr->add ('foo@example.org', name => 'Mr. foo bar');
|
283 |
|
|
$addr->add ('webmaster@example.org', group => 'administrators');
|
284 |
|
|
$addr->add ('postmaster@example.org', group => 'administrators');
|
285 |
|
|
|
286 |
|
|
my $field_body = $addr->stringify ();
|
287 |
|
|
|
288 |
|
|
|
289 |
|
|
## Output parsed address-list tree.
|
290 |
|
|
|
291 |
|
|
use Message::Field::Address;
|
292 |
|
|
my $addr = Message::Field::Address->parse ($field_body);
|
293 |
|
|
|
294 |
|
|
for my $i (@$addr) {
|
295 |
|
|
if ($i->{type} eq 'group') {
|
296 |
|
|
print "\x40 $i->{display_name}: \n";
|
297 |
|
|
for my $j (@{$i->{address}}) {
|
298 |
|
|
print "\t- $j->{display_name} <$j->{route}$j->{addr_spec}>\n";
|
299 |
|
|
}
|
300 |
|
|
} else {
|
301 |
|
|
print "- $i->{display_name} <$i->{route}$i->{addr_spec}>\n";
|
302 |
|
|
}
|
303 |
|
|
}
|
304 |
|
|
|
305 |
|
|
=head1 LICENSE
|
306 |
|
|
|
307 |
|
|
Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
|
308 |
|
|
|
309 |
|
|
This program is free software; you can redistribute it and/or modify
|
310 |
|
|
it under the terms of the GNU General Public License as published by
|
311 |
|
|
the Free Software Foundation; either version 2 of the License, or
|
312 |
|
|
(at your option) any later version.
|
313 |
|
|
|
314 |
|
|
This program is distributed in the hope that it will be useful,
|
315 |
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
316 |
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
317 |
|
|
GNU General Public License for more details.
|
318 |
|
|
|
319 |
|
|
You should have received a copy of the GNU General Public License
|
320 |
|
|
along with this program; see the file COPYING. If not, write to
|
321 |
|
|
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
322 |
|
|
Boston, MA 02111-1307, USA.
|
323 |
|
|
|
324 |
|
|
=head1 CHANGE
|
325 |
|
|
|
326 |
|
|
See F<ChangeLog>.
|
327 |
|
|
|
328 |
|
|
=cut
|
329 |
|
|
|
330 |
|
|
1;
|