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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations) (download)
Tue May 14 13:42:40 2002 UTC (22 years, 6 months ago) by wakaba
Branch: MAIN
Changes since 1.4: +5 -4 lines
2002-05-15  wakaba <w@suika.fam.cx>

	* Addresses.pm, Mailbox.pm, Domain.pm
	(son-of-Address.pm's): New modules.
	* Structured.pm:
	- (method_available): New method.
	- (clone): Checks _MEMBERS option.
	- (comment_add, comment_count, comment_delete, comment_item):
	New methods.
	- (item): Implemented.
	- (_delete_empty): Commentout default action.
	- (add, replace): Fix bug (parse option didn't work).
	* MsgID.pm: Don't use non-(ALPHA / DIGIT) as the first
	character of id-left.
	* Date.pm: Understands month name "Sept".

1
2 =head1 NAME
3
4 Message::Field::MsgID --- Perl module for Message-ID
5 of Internet messages
6
7 =head1 DESCRIPTION
8
9 This module supports C<msg-id> defined by RFC 2822.
10 Message-ID generating algorithm suggested by
11 draft-ietf-usefor-msg-id-alt-00 is also supported.
12
13 =cut
14
15 package Message::Field::MsgID;
16 use strict;
17 use vars qw(@ISA %REG $VERSION);
18 $VERSION=do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
19 require Message::Util;
20 require Message::Field::Structured;
21 push @ISA, qw(Message::Field::Structured);
22
23 use overload '""' => sub { $_[0]->stringify },
24 fallback => 1;
25
26 *REG = \%Message::Util::REG;
27 ## Inherited: comment, quoted_string, domain_literal
28 ## WSP, FWS, phrase, NON_atom
29 ## msg_id
30 ## M_quoted_string
31
32 =head1 CONSTRUCTORS
33
34 The following methods construct new objects:
35
36 =over 4
37
38 =cut
39
40 ## Initialize of this class -- called by constructors
41 sub _init ($;%) {
42 my $self = shift;
43 my %options = @_;
44 my %DEFAULT = (
45 -encoding_after_encode => 'unknown-8bit',
46 -encoding_before_decode => 'unknown-8bit',
47 #field_param_name
48 #field_name
49 #format
50 -hash_name => '%none',
51 #hook_encode_string
52 #hook_decode_string
53 -software_name => 'MFMpm',
54 -software_name_hash => '%none',
55 -validate => 1,
56 );
57 $self->SUPER::_init (%DEFAULT, %options);
58 }
59
60 =item $m = Message::Field::MsgID->new ([%options])
61
62 Constructs a new object. You might pass some options as parameters
63 to the constructor.
64
65 =cut
66
67 sub new ($;%) {
68 my $self = shift->SUPER::new (@_);
69 my %option = @_;
70 if ($option{id_left} && $option{id_right}) {
71 $self->{id_left} = $option{id_left};
72 $self->{id_right} = $option{id_right};
73 } elsif ($option{addr_spec}
74 || (($option{fqdn} || $option{ip_address} || $option{uucp})
75 && ($option{login}))) {
76 $self->_newid (\%option);
77 }
78 $self;
79 }
80
81 sub parse ($;$%) {
82 my $class = shift;
83 my $self = bless {}, $class;
84 my ($body, @c) = $self->Message::Util::delete_comment_to_array (shift);
85 $self->_init (@_);
86
87 $body = Message::Util::remove_wsp ($body);
88 if ($body =~ /$REG{M_addr_spec}/) {
89 my %s = &{$self->{option}->{hook_decode_string}} ($self,
90 Message::Util::unquote_quoted_string ($1), type => 'quoted-string');
91 $self->{id_left} = $s{value};
92 #my %s = &{$self->{option}->{hook_decode_string}} ($self,
93 # Message::Util::unquote_if_domain_literal ($2), type => 'domain');
94 #$self->{id_right} = $s{value};
95 $self->{id_right} = $2;
96 }
97
98 $self;
99 }
100
101 sub _newid ($\%) {
102 my $self = shift;
103 my $o = shift;
104 $$o{addr_spec} = Message::Util::remove_wsp ($$o{addr_spec});
105 if ($$o{addr_spec} =~ /$REG{M_addr_spec}/) {
106 $$o{login} = $1; $$o{fqdn} = $2;
107 }
108 if ($self->{option}->{validate} && $$o{fqdn} =~
109 /[.@](example\.(?:com|org|net)|localdomain|localhost|example|invalid|arpa)$/) {
110 Carp::croak "Msg-ID generation: invalid TLD of FQDN: .$1";
111 }
112 if (!$$o{fqdn} && $$o{ip_address}) {
113 if ($self->{option}->{validate}
114 && $$o{ip_address}=~/([0-9]+)\.([0-9]+)\.([0-9]+)\.([0-9]+)/){
115 my ($c1, $c2, $c3, $c4) = ($1, $2, $3, $4);
116 Carp::croak "Msg-ID generation: invalid IPv4 address: $c1.$c2.$c3.$c4"
117 ## See [IANAREG] and draft-iana-special-ipv4
118 if ($c1 == 0) ## "this" network
119 || ($c1 == 10) ## private [RFC1918]
120 || ($c1 == 127) ## loopback
121 || ($c1 == 169 && $c2 == 254) ## "link local"
122 || ($c1 == 172 && 16 <= $c2 && $c2 < 32) ## private [RFC1918]
123 || ($c1 == 192 && (($c2 == 0 && $c3 == 2) ## "TEST-NET"
124 || ($c2 == 88 && $c3 == 99) ## 6to4 anycast [RFC3068]
125 || ($c2 == 168))) ## private [RFC1918]
126 || ($c1 == 198 && ($c2 == 18 || $c2 == 19)) ## benchmark [RFC2544]
127 || ($c1 >= 224); ## class D,E [RFC3171]
128 }
129 $$o{fqdn} ||= '['.$$o{ip_address}.']';
130 }
131 if (!$$o{fqdn} && $$o{uucp}) {
132 $$o{uucp} .= '.uucp' if $self->{option}->{validate} && $$o{uucp} !~ /\.uucp/i;
133 $$o{fqdn} = $$o{uucp};
134 }
135 Carp::croak "Msg-ID generation: no FQDN"
136 if $self->{option}->{validate} && !$$o{fqdn};
137
138 $self->{id_right} = $$o{fqdn};
139
140 Carp::croak "Msg-ID generation: no 'login'"
141 if $self->{option}->{validate} && !$$o{login};
142 $$o{login} = $self->_hash ($$o{login}, $self->{option}->{hash_name});
143
144 my @s = ('0'..'9','a'..'z','-','=','_');
145 my @t = ('0'..'9','a'..'z');
146 my $unique = $t[rand @t].$s[rand @s].$s[rand @s].$s[rand @s].'.';
147 $unique .= join ('.', $self->_base39 (time), $self->_base39 ($$),
148 $self->_hash ($self->{option}->{software_name},
149 $self->{option}->{software_name_hash}));
150 $self->{id_left} = $unique
151 .'%'.($self->{option}->{hash_name} ne '%none'?
152 $self->_hash ($self->{option}->{hash_name}, '%none') .'%': '')
153 .$$o{login}
154 .($$o{subject_changed}? '-_-': '');
155
156 $self;
157 }
158
159 sub _hash ($$;$$) {
160 my $self = shift;
161 my ($str, $hash_name, $add_unsafe) = (shift, lc shift, shift);
162 $add_unsafe ||= qr#[/.=\x09\x20]#;
163 undef $hash_name if $hash_name eq '%none';
164 if ($hash_name eq 'md5') {
165 eval {require Digest::MD5} or Carp::croak "Msg-ID generation: $@";
166 $str = Digest::MD5::md5_base64 ($str);
167 } elsif ($hash_name eq 'sha1') {
168 eval {require Digest::SHA1} or Carp::croak "Msg-ID generation: $@";
169 $str = Digest::SHA1::sha1_base64 ($str);
170 } elsif ($hash_name eq 'md2') {
171 eval {require Digest::MD2} or Carp::croak "Msg-ID generation: $@";
172 $str = Digest::MD2::md2_base64 ($str);
173 } elsif ($hash_name eq 'crypt') {
174 my @s = ('0'..'9','A'..'Z','a'..'z');
175 my $salt = crypt('foobar', '$1$ab$') eq '$1$ab$uAP8qWqcFs3q.Gfl5PkL2.'?
176 '$1$'.join('', map($s[rand @s], 1..8)).'$': $s[rand @s].$s[rand @s];
177 $str = crypt ($str, $salt);
178 }
179 $str =~ s#($add_unsafe)#sprintf('=%02X', ord($1))#ge;
180 $str =~ s/($REG{NON_atext_dot})/sprintf('=%02X', ord($1))/ge;
181 $str;
182 }
183
184 sub _base39 ($$) {
185 my $self = shift;
186 my $number = shift;
187 my @digit = ('0'..'9','a'..'z','-','=','_');
188 my $ret = '';
189
190 my ($rem);
191 while ($number > 0) {
192 $rem = $number % @digit;
193 $ret = $digit[ $rem ].$ret;
194 $number = ($number - $rem) / @digit;
195 }
196 $ret;
197 }
198
199 sub generate ($%) {
200 my $self = shift;
201 my %parameter = @_;
202 for (grep {/^-/} keys %parameter) {$parameter{substr ($_, 1)} = $parameter{$_}}
203 $self->_newid (\%parameter);
204 }
205
206 sub id_left ($) {
207 my $self = shift;
208 my %e = &{$self->{option}->{hook_encode_string}} ($self,
209 $self->{id_left}, type => 'local-part');
210 Message::Util::quote_unsafe_string ($e{value},
211 unsafe_regex => qr/$REG{NON_atext_dot}|^\.|\.$/);
212 }
213 sub id_right ($) {
214 my $self = shift;
215 #my %e = &{$self->{option}->{hook_encode_string}} ($self,
216 # $self->{id_right}, type => 'domain');
217 #Message::Util::quote_unsafe_domain ($e{value});
218 Message::Util::quote_unsafe_domain ($self->{id_right});
219 }
220 sub content ($) {
221 my $self = shift;
222 my ($l, $r) = ($self->id_left, $self->id_right);
223 sprintf '%s@%s', $l, $r if $l && $r;
224 }
225
226 sub stringify ($;%) {
227 my $self = shift;
228 my ($l, $r) = ($self->id_left, $self->id_right);
229 sprintf '<%s@%s>', $l, $r if $l && $r;
230 }
231 *as_string = \&stringify;
232
233 =head1 EXAMPLE
234
235 use Message::Field::MsgID;
236 my $from = 'foo@bar.example';
237 my $login = 'my-login-name';
238 my $domain = 'foo.bar.example';
239 my $ipv4 = '192.168.0.1';
240 my %mid;
241 $mid{no_crypt} = new Message::Field::MsgID
242 addr_spec => $from, -validate => 0;
243 $mid{md5} = new Message::Field::MsgID
244 login => $login, ip_address => $ipv4,
245 -hash_name => 'md5', -validate => 0;
246 $mid{sha1} = new Message::Field::MsgID
247 login => $login, fqdn => $domain, subject_changed => 1,
248 -hash_name => 'sha1', -validate => 0;
249 for (keys %mid) {
250 print $_, ":\t", $mid{$_}, "\n";
251 }
252 # sha1: <t-9.bbxkfu.xsem.MFMMpm%sha1%9pnH2R6iN8KSIMby+dPU0i3M8RU-_-@foo.bar.example>
253 # md5: <7fu.bbxkfu.xsem.MFMMpm%md5%eBpd+12mupwxZBc6kMWR9g@[192.168.0.1]>
254 # no_crypt: <3vy.bbxkfu.xsem.MFMMpm%foo@bar.example>
255
256 ## IMPORTANT NOTE: This example uses -validate option with
257 ## '0' (does not validate) value since it uses example (invalid)
258 ## resource names, such as 'foo.bar.example'. Usually, this option
259 ## shall not be used (and default value = '1' = does validate
260 ## should be used).
261
262 =head1 SEE ALSO
263
264 RFC 822 E<lt>urn:ietf:rfc:822E<gt>, RFC 2822 E<lt>urn:ietf:rfc:2822E<gt>
265
266 RFC 850 E<lt>urn:ietf:rfc:850E<gt>, RFC 1036 E<lt>urn:ietf:rfc:1036E<gt>,
267 son-of-RFC1036, draft-ietf-usefor-article-06.txt
268 E<lt>urn:ietf:id:draft-ietf-usefor-article-06E<gt>
269
270 draft-ietf-usefor-message-id-01.txt
271 E<lt>urn:ietf:id:draft-ietf-usefor-message-id-01E<gt>
272
273 draft-ietf-usefor-msg-id-alt-00.txt
274 E<lt>urn:ietf:id:draft-ietf-usefor-msg-id-alt-00E<gt>
275
276 =head1 LICENSE
277
278 Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
279
280 This program is free software; you can redistribute it and/or modify
281 it under the terms of the GNU General Public License as published by
282 the Free Software Foundation; either version 2 of the License, or
283 (at your option) any later version.
284
285 This program is distributed in the hope that it will be useful,
286 but WITHOUT ANY WARRANTY; without even the implied warranty of
287 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
288 GNU General Public License for more details.
289
290 You should have received a copy of the GNU General Public License
291 along with this program; see the file COPYING. If not, write to
292 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
293 Boston, MA 02111-1307, USA.
294
295 =head1 CHANGE
296
297 See F<ChangeLog>.
298 $Date: 2002/05/04 06:03:58 $
299
300 =cut
301
302 1;

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24