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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (hide annotations) (download)
Fri Jul 26 12:42:00 2002 UTC (22 years, 4 months ago) by wakaba
Branch: MAIN
CVS Tags: before-dis2-200411, manakai-release-0-3-2, manakai-release-0-3-1, manakai-release-0-4-0, manakai-200612, msg-0-1, HEAD
Branch point for: branch-suikawiki-1, experimental-xml-parser-200401, stable
Changes since 1.7: +3 -3 lines
2002-07-25  Wakaba <w@suika.fam.cx>

	* Tool.pm: New module.

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;

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24