/[suikacvs]/test/cvs
Suika

Contents of /test/cvs

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show annotations) (download)
Mon Apr 1 05:32:37 2002 UTC (22 years, 1 month ago) by wakaba
Branch: MAIN
Changes since 1.12: +5 -3 lines
2002-03-31  wakaba <w@suika.fam.cx>

	* Header.pm: Support Message::Field::URI.

1
2 =head1 NAME
3
4 Message::Header Perl module
5
6 =head1 DESCRIPTION
7
8 Perl module for RFC 822/2822 message C<header>.
9
10 =cut
11
12 package Message::Header;
13 use strict;
14 use vars qw($VERSION %REG %DEFAULT);
15 $VERSION = '1.00';
16 use Carp;
17 use overload '@{}' => sub {shift->_delete_empty_field()->{field}},
18 '""' => sub {shift->stringify};
19
20 $REG{WSP} = qr/[\x09\x20]/;
21 $REG{FWS} = qr/[\x09\x20]*/;
22 $REG{M_field} = qr/^([^\x3A]+):$REG{FWS}([\x00-\xFF]*)$/;
23 $REG{M_fromline} = qr/^\x3E?From$REG{WSP}+([\x00-\xFF]*)$/;
24 $REG{UNSAFE_field_name} = qr/[\x00-\x20\x3A\x7F-\xFF]/;
25
26 =head2 options
27
28 These options can be getten/set by C<get_option>/C<set_option>
29 method.
30
31 =head3 capitalize = 0/1
32
33 (First character of) C<field-name> is capitalized
34 when C<stringify>. (Default = 1)
35
36 =head3 fold_length = numeric value
37
38 Length of line used to fold. (Default = 70)
39
40 =head3 mail_from = 0/1
41
42 Outputs "From " line (known as Un*x From, Mail-From, and so on)
43 when C<stringify>. (Default = 0)
44
45 =cut
46
47 %DEFAULT = (
48 capitalize => 1,
49 fold_length => 70,
50 field_type => {':DEFAULT' => 'Message::Field::Unstructured'},
51 format => 'rfc2822', ## rfc2822, usefor, http
52 mail_from => -1,
53 output_bcc => -1,
54 parse_all => -1,
55 );
56 my @field_type_Structured = qw(cancel-lock
57 importance path precedence
58 x-face x-mail-count x-msmail-priority x-priority xref);
59 for (@field_type_Structured)
60 {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
61 my @field_type_Address = qw(approved bcc cc delivered-to disposition-notification-to
62 envelope-to
63 errors-to fcc from mail-followup-to mail-followup-cc mail-from reply-to resent-bcc
64 resent-cc resent-to resent-from resent-sender return-path
65 return-receipt-to sender to x-approved x-beenthere
66 x-complaints-to x-envelope-from x-envelope-sender
67 x-envelope-to x-ml-address x-ml-command x-ml-to x-nfrom x-nto);
68 for (@field_type_Address)
69 {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}
70 my @field_type_Date = qw(date date-received delivery-date expires
71 expire-date nntp-posting-date posted reply-by resent-date x-tcup-date);
72 for (@field_type_Date)
73 {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}
74 my @field_type_MsgID = qw(article-updates content-id in-reply-to message-id
75 references resent-message-id see-also supersedes);
76 for (@field_type_MsgID)
77 {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgID'}
78 for (qw(received x-received))
79 {$DEFAULT{field_type}->{$_} = 'Message::Field::Received'}
80 $DEFAULT{field_type}->{'content-type'} = 'Message::Field::ContentType';
81 $DEFAULT{field_type}->{'content-disposition'} = 'Message::Field::ContentDisposition';
82 for (qw(archive link x-face-type))
83 {$DEFAULT{field_type}->{$_} = 'Message::Field::ValueParams'}
84 for (qw(accept accept-charset accept-encoding accept-language
85 content-language
86 content-transfer-encoding encrypted followup-to keywords
87 list-archive list-digest list-help list-owner
88 list-post list-subscribe list-unsubscribe list-url uri newsgroups
89 x-brother x-daughter x-respect x-moe x-syster x-wife))
90 {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}
91 for (qw(content-alias content-base content-location location referer
92 url x-home-page x-http_referer
93 x-info x-pgp-key x-ml-url x-uri x-url x-web))
94 {$DEFAULT{field_type}->{$_} = 'Message::Field::URI'}
95 for (qw(list-id))
96 {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
97 for (qw(subject title x-nsubject))
98 {$DEFAULT{field_type}->{$_} = 'Message::Field::Subject'}
99 for (qw(list-software user-agent server))
100 {$DEFAULT{field_type}->{$_} = 'Message::Field::UA'}
101 for (qw(content-length lines max-forwards mime-version))
102 {$DEFAULT{field_type}->{$_} = 'Message::Field::Numval'}
103
104 =head2 Message::Header->new ([%option])
105
106 Returns new Message::Header instance. Some options can be
107 specified as hash.
108
109 =cut
110
111 sub new ($;%) {
112 my $class = shift;
113 my $self = bless {option => {@_}}, $class;
114 for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
115 $self;
116 }
117
118 =head2 Message::Header->parse ($header, [%option])
119
120 Parses given C<header> and return a new Message::Header
121 object. Some options can be specified as hash.
122
123 =cut
124
125 sub parse ($$;%) {
126 my $class = shift;
127 my $header = shift;
128 my $self = bless {option => {@_}}, $class;
129 for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
130 $header =~ s/\x0D?\x0A$REG{WSP}+/\x20/gos; ## unfold
131 for my $field (split /\x0D?\x0A/, $header) {
132 if ($field =~ /$REG{M_fromline}/) {
133 my $body = $1;
134 $body = $self->_field_body ($body, 'mail-from')
135 if $self->{option}->{parse_all}>0;
136 push @{$self->{field}}, {name => 'mail-from', body => $body};
137 } elsif ($field =~ /$REG{M_field}/) {
138 my ($name, $body) = (lc $1, $2);
139 $name =~ s/$REG{WSP}+$//;
140 $body =~ s/$REG{WSP}+$//;
141 $body = $self->_field_body ($body, $name) if $self->{option}->{parse_all}>0;
142 push @{$self->{field}}, {name => $name, body => $body};
143 }
144 }
145 $self;
146 }
147
148 =head2 $self->field ($field_name)
149
150 Returns C<field-body> of given C<field-name>.
151 When there are two or more C<field>s whose name is C<field-name>,
152 this method return all C<field-body>s as array. (On scalar
153 context, only first one is returned.)
154
155 =cut
156
157 sub field ($$) {
158 my $self = shift;
159 my $name = lc shift;
160 my @ret;
161 for my $field (@{$self->{field}}) {
162 if ($field->{name} eq $name) {
163 unless (wantarray) {
164 $field->{body} = $self->_field_body ($field->{body}, $name);
165 return $field->{body};
166 } else {
167 $field->{body} = $self->_field_body ($field->{body}, $name);
168 push @ret, $field->{body};
169 }
170 }
171 }
172 if ($#ret < 0) {
173 return $self->add ($name);
174 }
175 @ret;
176 }
177
178 sub field_exist ($$) {
179 my $self = shift;
180 my $name = lc shift;
181 my @ret;
182 for my $field (@{$self->{field}}) {
183 return 1 if ($field->{name} eq $name);
184 }
185 0;
186 }
187
188 =head2 $self->field_name ($index)
189
190 Returns C<field-name> of $index'th C<field>.
191
192 =head2 $self->field_body ($index)
193
194 Returns C<field-body> of $index'th C<field>.
195
196 =cut
197
198 sub field_name ($$) {
199 my $self = shift;
200 $self->{field}->[shift]->{name};
201 }
202 sub field_body ($$) {
203 my $self = shift;
204 my $i = shift;
205 $self->{field}->[$i]->{body}
206 = $self->_field_body ($self->{field}->[$i]->{body}, $self->{field}->[$i]->{name});
207 $self->{field}->[$i]->{body};
208 }
209
210 sub _field_body ($$$) {
211 my $self = shift;
212 my ($body, $name) = @_;
213 unless (ref $body) {
214 my $type = $self->{option}->{field_type}->{$name}
215 || $self->{option}->{field_type}->{':DEFAULT'};
216 eval "require $type";
217 unless ($body) {
218 $body = $type->new (field_name => $name, format => $self->{option}->{format});
219 } else {
220 $body = $type->parse ($body, field_name => $name,
221 format => $self->{option}->{format});
222 }
223 }
224 $body;
225 }
226
227 =head2 $self->field_name_list ()
228
229 Returns list of all C<field-name>s. (Even if there are two
230 or more C<field>s which have same C<field-name>, this method
231 returns ALL names.)
232
233 =cut
234
235 sub field_name_list ($) {
236 my $self = shift;
237 $self->_delete_empty_field ();
238 map {$_->{name}} @{$self->{field}};
239 }
240
241 =head2 $self->add ($field_name, $field_body)
242
243 Adds an new C<field>. It is not checked whether
244 the field which named $field_body is already exist or not.
245 If you don't want duplicated C<field>s, use C<replace> method.
246
247 =cut
248
249 sub add ($$;$%) {
250 my $self = shift;
251 my ($name, $body) = (lc shift, shift);
252 my %option = @_;
253 return 0 if $name =~ /$REG{UNSAFE_field_name}/;
254 $body = $self->_field_body ($body, $name);
255 if ($option{prepend}) {
256 unshift @{$self->{field}}, {name => $name, body => $body};
257 } else {
258 push @{$self->{field}}, {name => $name, body => $body};
259 }
260 $body;
261 }
262
263 =head2 $self->relace ($field_name, $field_body)
264
265 Set the C<field-body> named C<field-name> as $field_body.
266 If $field_name C<field> is already exists, it is replaced
267 by new $field_body value. If not, new C<field> is inserted.
268 (If there are some C<field> named as $field_name,
269 first one is used and the others are not changed.)
270
271 =cut
272
273 sub replace ($$$) {
274 my $self = shift;
275 my ($name, $body) = (lc shift, shift);
276 return 0 if $name =~ /$REG{UNSAFE_field_name}/;
277 $body = $self->_field_body ($body, $name);
278 for my $field (@{$self->{field}}) {
279 if ($field->{name} eq $name) {
280 $field->{body} = $body;
281 return $body;
282 }
283 }
284 push @{$self->{field}}, {name => $name, body => $body};
285 $body;
286 }
287
288 =head2 $self->delete ($field_name, [$index])
289
290 Deletes C<field> named as $field_name.
291 If $index is specified, only $index'th C<field> is deleted.
292 ($index of first field is C<1>, not C<0>.)
293 If not, ($index == 0), all C<field>s that have the C<field-name>
294 $field_name are deleted.
295
296 =cut
297
298 sub delete ($$;$) {
299 my $self = shift;
300 my ($name, $index) = (lc shift, shift);
301 my $i = 0;
302 for my $field (@{$self->{field}}) {
303 if ($field->{name} eq $name) {
304 $i++;
305 if ($index == 0 || $i == $index) {
306 undef $field;
307 return $self if $i == $index;
308 }
309 }
310 }
311 $self;
312 }
313
314 =head2 $self->count ([$field_name])
315
316 Returns the number of times the given C<field> appears.
317 If no $field_name is given, returns the number
318 of fields. (Same as $#$self+1)
319
320 =cut
321
322 sub count ($;$) {
323 my $self = shift;
324 my ($name) = (lc shift);
325 unless ($name) {
326 $self->_delete_empty_field ();
327 return $#{$self->{field}}+1;
328 }
329 my $count = 0;
330 for my $field (@{$self->{field}}) {
331 if ($field->{name} eq $name) {
332 $count++;
333 }
334 }
335 $count;
336 }
337
338 =head2 $self->rename ($field_name, [$index])
339
340 Renames C<field> named as $field_name.
341 If $index is specified, only $index'th C<field> is renamed.
342 ($index of first field is C<1>, not C<0>.)
343 If not, ($index == 0), all C<field>s that have the C<field-name>
344 $field_name are renamed.
345
346 =cut
347
348 sub rename ($$$;$) {
349 my $self = shift;
350 my ($name, $newname, $index) = (lc shift, lc shift, shift);
351 my $i = 0;
352 croak "rename: new field-name contains of unsafe character: $newname"
353 if !$newname || $newname =~ /$REG{UNSAFE_field_name}/;
354 for my $field (@{$self->{field}}) {
355 if ($field->{name} eq $name) {
356 $i++;
357 if ($index == 0 || $i == $index) {
358 $field->{name} = $newname;
359 return $self if $i == $index;
360 }
361 }
362 }
363 $self;
364 }
365
366 =head2 $self->stringify ([%option])
367
368 Returns the C<header> as a string.
369
370 =cut
371
372 sub stringify ($;%) {
373 my $self = shift;
374 my %OPT = @_;
375 my @ret;
376 $OPT{capitalize} ||= $self->{option}->{capitalize};
377 $OPT{mail_from} ||= $self->{option}->{mail_from};
378 $OPT{output_bcc} ||= $self->{option}->{output_bcc};
379 $OPT{format} ||= $self->{option}->{format};
380 push @ret, 'From '.$self->field ('mail-from') if $OPT{mail_from}>0;
381 for my $field (@{$self->{field}}) {
382 my $name = $field->{name};
383 next unless $name;
384 next if $OPT{mail_from}<0 && $name eq 'mail-from';
385 next if $OPT{output_bcc}<0 && ($name eq 'bcc' || $name eq 'resent-bcc');
386 my $fbody;
387 if (ref $field->{body}) {
388 $fbody = $field->{body}->stringify (format => $OPT{format});
389 } else {
390 $fbody = $field->{body};
391 }
392 next unless $fbody;
393 $fbody =~ s/\x0D([^\x09\x0A\x20])/\x0D\x20$1/g;
394 $fbody =~ s/\x0A([^\x09\x20])/\x0A\x20$1/g;
395 $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $OPT{capitalize};
396 push @ret, $name.': '.$self->fold ($fbody);
397 }
398 my $ret = join ("\n", @ret);
399 $ret? $ret."\n": "";
400 }
401
402 =head2 $self->option ($option_name, [$option_value])
403
404 Set/gets new value of the option.
405
406 =cut
407
408 sub option ($$;$) {
409 my $self = shift;
410 my ($name, $value) = @_;
411 if (defined $value) {
412 $self->{option}->{$name} = $value;
413 if ($name eq 'format') {
414 for my $f (@{$self->{field}}) {
415 if (ref $f) {
416 $f->option (format => $value);
417 }
418 }
419 }
420 }
421 $self->{option}->{$name};
422 }
423
424 sub field_type ($$;$) {
425 my $self = shift;
426 my $field_name = shift;
427 my $new_field_type = shift;
428 if ($new_field_type) {
429 $self->{option}->{field_type}->{$field_name} = $new_field_type;
430 }
431 $self->{option}->{field_type}->{$field_name}
432 || $self->{option}->{field_type}->{':DEFAULT'};
433 }
434
435 sub _delete_empty_field ($) {
436 my $self = shift;
437 my @ret;
438 for my $field (@{$self->{field}}) {
439 push @ret, $field if $field->{name};
440 }
441 $self->{field} = \@ret;
442 $self;
443 }
444
445 sub fold ($$;$) {
446 my $self = shift;
447 my $string = shift;
448 my $len = shift || $self->{option}->{fold_length};
449 $len = 60 if $len < 60;
450
451 ## This code is taken from Mail::Header 1.43 in MailTools,
452 ## by Graham Barr (Maintained by Mark Overmeer <mailtools@overmeer.net>).
453 my $max = int($len - 5); # 4 for leading spcs + 1 for [\,\;]
454 my $min = int($len * 4 / 5) - 4;
455 my $ml = $len;
456
457 if (length($string) > $ml) {
458 #Split the line up
459 # first bias towards splitting at a , or a ; >4/5 along the line
460 # next split a whitespace
461 # else we are looking at a single word and probably don't want to split
462 my $x = "";
463 $x .= "$1\n "
464 while($string =~ s/^$REG{WSP}*(
465 [^"]{$min,$max}?[\,\;]
466 |[^"]{1,$max}$REG{WSP}
467 |[^\s"]*(?:"[^"]*"[^\s"]*)+$REG{WSP}
468 |[^\s"]+$REG{WSP}
469 )
470 //x);
471 $x .= $string;
472 $string = $x;
473 $string =~ s/(\A$REG{WSP}+|$REG{WSP}+\Z)//sog;
474 $string =~ s/\s+\n/\n/sog;
475 }
476 $string;
477 }
478
479 =head1 EXAMPLE
480
481 ## Print field list
482
483 use Message::Header;
484 my $header = Message::Header->parse ($header);
485
486 ## Next sample is better.
487 #for my $field (@$header) {
488 # print $field->{name}, "\t=> ", $field->{body}, "\n";
489 #}
490
491 for my $i (0..$#$header) {
492 print $header->field_name ($i), "\t=> ", $header->field_body ($i), "\n";
493 }
494
495
496 ## Make simple header
497
498 use Message::Header;
499 use Message::Field::Address;
500 my $header = new Message::Header;
501
502 my $from = new Message::Field::Address;
503 $from->add ('foo@foo.example', name => 'F. Foo');
504 my $to = new Message::Field::Address;
505 $to->add ('bar@bar.example', name => 'Mr. Bar');
506 $to->add ('hoge@foo.example', name => 'Hoge-san');
507 $header->add ('From' => $from);
508 $header->add ('To' => $to);
509 $header->add ('Subject' => 'Re: Meeting');
510 $header->add ('References' => '<hoge.msgid%foo@foo.example>');
511 print $header;
512
513 =head1 LICENSE
514
515 Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
516
517 This program is free software; you can redistribute it and/or modify
518 it under the terms of the GNU General Public License as published by
519 the Free Software Foundation; either version 2 of the License, or
520 (at your option) any later version.
521
522 This program is distributed in the hope that it will be useful,
523 but WITHOUT ANY WARRANTY; without even the implied warranty of
524 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
525 GNU General Public License for more details.
526
527 You should have received a copy of the GNU General Public License
528 along with this program; see the file COPYING. If not, write to
529 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
530 Boston, MA 02111-1307, USA.
531
532 =head1 CHANGE
533
534 See F<ChangeLog>.
535 $Date: 2002/04/01 05:32:37 $
536
537 =cut
538
539 1;

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24