/[suikacvs]/test/cvs
Suika

Contents of /test/cvs

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (show annotations) (download)
Sun Mar 31 13:12:41 2002 UTC (22 years, 1 month ago) by wakaba
Branch: MAIN
Changes since 1.11: +65 -27 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 mime-version path precedence x-cite
58 x-face x-mail-count x-msmail-priority x-priority x-uidl 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
102 =head2 Message::Header->new ([%option])
103
104 Returns new Message::Header instance. Some options can be
105 specified as hash.
106
107 =cut
108
109 sub new ($;%) {
110 my $class = shift;
111 my $self = bless {option => {@_}}, $class;
112 for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
113 $self;
114 }
115
116 =head2 Message::Header->parse ($header, [%option])
117
118 Parses given C<header> and return a new Message::Header
119 object. Some options can be specified as hash.
120
121 =cut
122
123 sub parse ($$;%) {
124 my $class = shift;
125 my $header = shift;
126 my $self = bless {option => {@_}}, $class;
127 for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
128 $header =~ s/\x0D?\x0A$REG{WSP}+/\x20/gos; ## unfold
129 for my $field (split /\x0D?\x0A/, $header) {
130 if ($field =~ /$REG{M_fromline}/) {
131 my $body = $1;
132 $body = $self->_field_body ($body, 'mail-from')
133 if $self->{option}->{parse_all}>0;
134 push @{$self->{field}}, {name => 'mail-from', body => $body};
135 } elsif ($field =~ /$REG{M_field}/) {
136 my ($name, $body) = (lc $1, $2);
137 $name =~ s/$REG{WSP}+$//;
138 $body =~ s/$REG{WSP}+$//;
139 $body = $self->_field_body ($body, $name) if $self->{option}->{parse_all}>0;
140 push @{$self->{field}}, {name => $name, body => $body};
141 }
142 }
143 $self;
144 }
145
146 =head2 $self->field ($field_name)
147
148 Returns C<field-body> of given C<field-name>.
149 When there are two or more C<field>s whose name is C<field-name>,
150 this method return all C<field-body>s as array. (On scalar
151 context, only first one is returned.)
152
153 =cut
154
155 sub field ($$) {
156 my $self = shift;
157 my $name = lc shift;
158 my @ret;
159 for my $field (@{$self->{field}}) {
160 if ($field->{name} eq $name) {
161 unless (wantarray) {
162 $field->{body} = $self->_field_body ($field->{body}, $name);
163 return $field->{body};
164 } else {
165 $field->{body} = $self->_field_body ($field->{body}, $name);
166 push @ret, $field->{body};
167 }
168 }
169 }
170 if ($#ret < 0) {
171 return $self->add ($name);
172 }
173 @ret;
174 }
175
176 sub field_exist ($$) {
177 my $self = shift;
178 my $name = lc shift;
179 my @ret;
180 for my $field (@{$self->{field}}) {
181 return 1 if ($field->{name} eq $name);
182 }
183 0;
184 }
185
186 =head2 $self->field_name ($index)
187
188 Returns C<field-name> of $index'th C<field>.
189
190 =head2 $self->field_body ($index)
191
192 Returns C<field-body> of $index'th C<field>.
193
194 =cut
195
196 sub field_name ($$) {
197 my $self = shift;
198 $self->{field}->[shift]->{name};
199 }
200 sub field_body ($$) {
201 my $self = shift;
202 my $i = shift;
203 $self->{field}->[$i]->{body}
204 = $self->_field_body ($self->{field}->[$i]->{body}, $self->{field}->[$i]->{name});
205 $self->{field}->[$i]->{body};
206 }
207
208 sub _field_body ($$$) {
209 my $self = shift;
210 my ($body, $name) = @_;
211 unless (ref $body) {
212 my $type = $self->{option}->{field_type}->{$name}
213 || $self->{option}->{field_type}->{':DEFAULT'};
214 eval "require $type";
215 unless ($body) {
216 $body = $type->new (field_name => $name, format => $self->{option}->{format});
217 } else {
218 $body = $type->parse ($body, field_name => $name,
219 format => $self->{option}->{format});
220 }
221 }
222 $body;
223 }
224
225 =head2 $self->field_name_list ()
226
227 Returns list of all C<field-name>s. (Even if there are two
228 or more C<field>s which have same C<field-name>, this method
229 returns ALL names.)
230
231 =cut
232
233 sub field_name_list ($) {
234 my $self = shift;
235 $self->_delete_empty_field ();
236 map {$_->{name}} @{$self->{field}};
237 }
238
239 =head2 $self->add ($field_name, $field_body)
240
241 Adds an new C<field>. It is not checked whether
242 the field which named $field_body is already exist or not.
243 If you don't want duplicated C<field>s, use C<replace> method.
244
245 =cut
246
247 sub add ($$;$%) {
248 my $self = shift;
249 my ($name, $body) = (lc shift, shift);
250 my %option = @_;
251 return 0 if $name =~ /$REG{UNSAFE_field_name}/;
252 $body = $self->_field_body ($body, $name);
253 if ($option{prepend}) {
254 unshift @{$self->{field}}, {name => $name, body => $body};
255 } else {
256 push @{$self->{field}}, {name => $name, body => $body};
257 }
258 $body;
259 }
260
261 =head2 $self->relace ($field_name, $field_body)
262
263 Set the C<field-body> named C<field-name> as $field_body.
264 If $field_name C<field> is already exists, it is replaced
265 by new $field_body value. If not, new C<field> is inserted.
266 (If there are some C<field> named as $field_name,
267 first one is used and the others are not changed.)
268
269 =cut
270
271 sub replace ($$$) {
272 my $self = shift;
273 my ($name, $body) = (lc shift, shift);
274 return 0 if $name =~ /$REG{UNSAFE_field_name}/;
275 $body = $self->_field_body ($body, $name);
276 for my $field (@{$self->{field}}) {
277 if ($field->{name} eq $name) {
278 $field->{body} = $body;
279 return $body;
280 }
281 }
282 push @{$self->{field}}, {name => $name, body => $body};
283 $body;
284 }
285
286 =head2 $self->delete ($field_name, [$index])
287
288 Deletes C<field> named as $field_name.
289 If $index is specified, only $index'th C<field> is deleted.
290 ($index of first field is C<1>, not C<0>.)
291 If not, ($index == 0), all C<field>s that have the C<field-name>
292 $field_name are deleted.
293
294 =cut
295
296 sub delete ($$;$) {
297 my $self = shift;
298 my ($name, $index) = (lc shift, shift);
299 my $i = 0;
300 for my $field (@{$self->{field}}) {
301 if ($field->{name} eq $name) {
302 $i++;
303 if ($index == 0 || $i == $index) {
304 undef $field;
305 return $self if $i == $index;
306 }
307 }
308 }
309 $self;
310 }
311
312 =head2 $self->count ([$field_name])
313
314 Returns the number of times the given C<field> appears.
315 If no $field_name is given, returns the number
316 of fields. (Same as $#$self+1)
317
318 =cut
319
320 sub count ($;$) {
321 my $self = shift;
322 my ($name) = (lc shift);
323 unless ($name) {
324 $self->_delete_empty_field ();
325 return $#{$self->{field}}+1;
326 }
327 my $count = 0;
328 for my $field (@{$self->{field}}) {
329 if ($field->{name} eq $name) {
330 $count++;
331 }
332 }
333 $count;
334 }
335
336 =head2 $self->rename ($field_name, [$index])
337
338 Renames C<field> named as $field_name.
339 If $index is specified, only $index'th C<field> is renamed.
340 ($index of first field is C<1>, not C<0>.)
341 If not, ($index == 0), all C<field>s that have the C<field-name>
342 $field_name are renamed.
343
344 =cut
345
346 sub rename ($$$;$) {
347 my $self = shift;
348 my ($name, $newname, $index) = (lc shift, lc shift, shift);
349 my $i = 0;
350 croak "rename: new field-name contains of unsafe character: $newname"
351 if !$newname || $newname =~ /$REG{UNSAFE_field_name}/;
352 for my $field (@{$self->{field}}) {
353 if ($field->{name} eq $name) {
354 $i++;
355 if ($index == 0 || $i == $index) {
356 $field->{name} = $newname;
357 return $self if $i == $index;
358 }
359 }
360 }
361 $self;
362 }
363
364 =head2 $self->stringify ([%option])
365
366 Returns the C<header> as a string.
367
368 =cut
369
370 sub stringify ($;%) {
371 my $self = shift;
372 my %OPT = @_;
373 my @ret;
374 $OPT{capitalize} ||= $self->{option}->{capitalize};
375 $OPT{mail_from} ||= $self->{option}->{mail_from};
376 $OPT{output_bcc} ||= $self->{option}->{output_bcc};
377 $OPT{format} ||= $self->{option}->{format};
378 push @ret, 'From '.$self->field ('mail-from') if $OPT{mail_from}>0;
379 for my $field (@{$self->{field}}) {
380 my $name = $field->{name};
381 next unless $name;
382 next if $OPT{mail_from}<0 && $name eq 'mail-from';
383 next if $OPT{output_bcc}<0 && ($name eq 'bcc' || $name eq 'resent-bcc');
384 my $fbody;
385 if (ref $field->{body}) {
386 $fbody = $field->{body}->stringify (format => $OPT{format});
387 } else {
388 $fbody = $field->{body};
389 }
390 next unless $fbody;
391 $fbody =~ s/\x0D([^\x09\x0A\x20])/\x0D\x20$1/g;
392 $fbody =~ s/\x0A([^\x09\x20])/\x0A\x20$1/g;
393 $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $OPT{capitalize};
394 push @ret, $name.': '.$self->fold ($fbody);
395 }
396 my $ret = join ("\n", @ret);
397 $ret? $ret."\n": "";
398 }
399
400 =head2 $self->option ($option_name, [$option_value])
401
402 Set/gets new value of the option.
403
404 =cut
405
406 sub option ($$;$) {
407 my $self = shift;
408 my ($name, $value) = @_;
409 if (defined $value) {
410 $self->{option}->{$name} = $value;
411 if ($name eq 'format') {
412 for my $f (@{$self->{field}}) {
413 if (ref $f) {
414 $f->option (format => $value);
415 }
416 }
417 }
418 }
419 $self->{option}->{$name};
420 }
421
422 sub field_type ($$;$) {
423 my $self = shift;
424 my $field_name = shift;
425 my $new_field_type = shift;
426 if ($new_field_type) {
427 $self->{option}->{field_type}->{$field_name} = $new_field_type;
428 }
429 $self->{option}->{field_type}->{$field_name}
430 || $self->{option}->{field_type}->{':DEFAULT'};
431 }
432
433 sub _delete_empty_field ($) {
434 my $self = shift;
435 my @ret;
436 for my $field (@{$self->{field}}) {
437 push @ret, $field if $field->{name};
438 }
439 $self->{field} = \@ret;
440 $self;
441 }
442
443 sub fold ($$;$) {
444 my $self = shift;
445 my $string = shift;
446 my $len = shift || $self->{option}->{fold_length};
447 $len = 60 if $len < 60;
448
449 ## This code is taken from Mail::Header 1.43 in MailTools,
450 ## by Graham Barr (Maintained by Mark Overmeer <mailtools@overmeer.net>).
451 my $max = int($len - 5); # 4 for leading spcs + 1 for [\,\;]
452 my $min = int($len * 4 / 5) - 4;
453 my $ml = $len;
454
455 if (length($string) > $ml) {
456 #Split the line up
457 # first bias towards splitting at a , or a ; >4/5 along the line
458 # next split a whitespace
459 # else we are looking at a single word and probably don't want to split
460 my $x = "";
461 $x .= "$1\n "
462 while($string =~ s/^$REG{WSP}*(
463 [^"]{$min,$max}?[\,\;]
464 |[^"]{1,$max}$REG{WSP}
465 |[^\s"]*(?:"[^"]*"[^\s"]*)+$REG{WSP}
466 |[^\s"]+$REG{WSP}
467 )
468 //x);
469 $x .= $string;
470 $string = $x;
471 $string =~ s/(\A$REG{WSP}+|$REG{WSP}+\Z)//sog;
472 $string =~ s/\s+\n/\n/sog;
473 }
474 $string;
475 }
476
477 =head1 EXAMPLE
478
479 ## Print field list
480
481 use Message::Header;
482 my $header = Message::Header->parse ($header);
483
484 ## Next sample is better.
485 #for my $field (@$header) {
486 # print $field->{name}, "\t=> ", $field->{body}, "\n";
487 #}
488
489 for my $i (0..$#$header) {
490 print $header->field_name ($i), "\t=> ", $header->field_body ($i), "\n";
491 }
492
493
494 ## Make simple header
495
496 use Message::Header;
497 use Message::Field::Address;
498 my $header = new Message::Header;
499
500 my $from = new Message::Field::Address;
501 $from->add ('foo@foo.example', name => 'F. Foo');
502 my $to = new Message::Field::Address;
503 $to->add ('bar@bar.example', name => 'Mr. Bar');
504 $to->add ('hoge@foo.example', name => 'Hoge-san');
505 $header->add ('From' => $from);
506 $header->add ('To' => $to);
507 $header->add ('Subject' => 'Re: Meeting');
508 $header->add ('References' => '<hoge.msgid%foo@foo.example>');
509 print $header;
510
511 =head1 LICENSE
512
513 Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
514
515 This program is free software; you can redistribute it and/or modify
516 it under the terms of the GNU General Public License as published by
517 the Free Software Foundation; either version 2 of the License, or
518 (at your option) any later version.
519
520 This program is distributed in the hope that it will be useful,
521 but WITHOUT ANY WARRANTY; without even the implied warranty of
522 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
523 GNU General Public License for more details.
524
525 You should have received a copy of the GNU General Public License
526 along with this program; see the file COPYING. If not, write to
527 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
528 Boston, MA 02111-1307, USA.
529
530 =head1 CHANGE
531
532 See F<ChangeLog>.
533 $Date: 2002/03/31 13:12:41 $
534
535 =cut
536
537 1;

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24