/[suikacvs]/messaging/manakai/lib/Message/Field/Address.pm
Suika

Contents of /messaging/manakai/lib/Message/Field/Address.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations) (download)
Wed Mar 13 07:26:22 2002 UTC (23 years, 1 month ago) by wakaba
Branch: MAIN
Branch point for: wakaba
Initial revision

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;

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24