/[suikacvs]/messaging/manakai/lib/Message/Header.pm
Suika

Contents of /messaging/manakai/lib/Message/Header.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (hide annotations) (download)
Sat Mar 16 08:54:39 2002 UTC (22 years, 8 months ago) by wakaba
Branch: MAIN
Changes since 1.3: +69 -4 lines
2002-03-16  wakaba <w@suika.fam.cx>

	* Header.pm: Use Message::Field::Date.

1 wakaba 1.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    
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     mail_from => 0,
51 wakaba 1.4 field_type => {_DEFAULT => 'Message::Field::Unstructured'},
52 wakaba 1.1 );
53 wakaba 1.4 my @field_type_Structured = qw(cancel-lock content-language
54     content-transfer-encoding
55     encrypted importance mime-version precedence user-agent x-cite
56     x-face x-mail-count
57     x-msmail-priority x-priority x-uidl xref);
58     for (@field_type_Structured)
59     {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
60     my @field_type_Address = qw(approved bcc cc delivered-to envelope-to
61     errors-to from mail-followup-to reply-to resent-bcc
62     resent-cc resent-to resent-from resent-sender return-path
63     return-receipt-to sender to x-approved x-beenthere
64     x-complaints-to x-envelope-from x-envelope-sender
65     x-envelope-to x-ml-address x-ml-command x-ml-to);
66     for (@field_type_Address)
67     {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}
68     my @field_type_Date = qw(date date-received delivery-date expires
69     expire-date nntp-posting-date posted reply-by resent-date x-tcup-date);
70     for (@field_type_Date)
71     {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}
72     my @field_type_MsgID = qw(content-id in-reply-to message-id
73     references resent-message-id supersedes);
74     for (@field_type_MsgID)
75     {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
76     my @field_type_Received = qw(received x-received);
77     for (@field_type_Received)
78     {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
79     my @field_type_Param = qw(content-disposition content-type
80     x-brother x-daughter x-face-type x-respect x-moe
81     x-syster x-wife);
82     for (@field_type_Param)
83     {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
84     my @field_type_URI = qw(list-archive list-help list-owner
85     list-post list-subscribe list-unsubscribe uri url x-home-page x-http_referer
86     x-info x-pgp-key x-ml-url x-uri x-url x-web);
87     for (@field_type_URI)
88     {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
89     my @field_type_ListID = qw(list-id);
90     for (@field_type_ListID)
91     {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
92 wakaba 1.1
93     =head2 Message::Header->new ([%option])
94    
95     Returns new Message::Header instance. Some options can be
96     specified as hash.
97    
98     =cut
99    
100     sub new ($;%) {
101     my $class = shift;
102     my $self = bless {option => {@_}}, $class;
103     for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
104     $self;
105     }
106    
107     =head2 Message::Header->parse ($header, [%option])
108    
109     Parses given C<header> and return a new Message::Header
110     object. Some options can be specified as hash.
111    
112     =cut
113    
114     sub parse ($$;%) {
115     my $class = shift;
116     my $header = shift;
117     my $self = bless {option => {@_}}, $class;
118     for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
119     $header =~ s/\x0D?\x0A$REG{WSP}+/\x20/gos; ## unfold
120     for my $field (split /\x0D?\x0A/, $header) {
121     if ($field =~ /$REG{M_fromline}/) {
122     push @{$self->{field}}, {name => 'mail-from', body => $1};
123     } elsif ($field =~ /$REG{M_field}/) {
124     my ($name, $body) = ($1, $2);
125     $name =~ s/$REG{WSP}+$//;
126     $body =~ s/$REG{WSP}+$//;
127     push @{$self->{field}}, {name => lc $name, body => $body};
128     }
129     }
130     $self;
131     }
132    
133     =head2 $self->field ($field_name)
134    
135     Returns C<field-body> of given C<field-name>.
136     When there are two or more C<field>s whose name is C<field-name>,
137     this method return all C<field-body>s as array. (On scalar
138     context, only first one is returned.)
139    
140     =cut
141    
142     sub field ($$) {
143     my $self = shift;
144     my $name = lc shift;
145     my @ret;
146     for my $field (@{$self->{field}}) {
147     if ($field->{name} eq $name) {
148     unless (wantarray) {
149 wakaba 1.4 return $self->_field_body ($field->{body}, $name);
150 wakaba 1.1 } else {
151 wakaba 1.4 push @ret, $self->_field_body ($field->{body}, $name);
152 wakaba 1.1 }
153     }
154     }
155     @ret;
156     }
157    
158 wakaba 1.2 =head2 $self->field_name ($index)
159    
160     Returns C<field-name> of $index'th C<field>.
161    
162     =head2 $self->field_body ($index)
163    
164     Returns C<field-body> of $index'th C<field>.
165    
166     =cut
167    
168     sub field_name ($$) {
169     my $self = shift;
170     $self->{field}->[shift]->{name};
171     }
172     sub field_body ($$) {
173     my $self = shift;
174 wakaba 1.4 my $i = shift;
175     $self->_field_body ($self->{field}->[$i]->{body}, $self->{field}->[$i]->{name});
176     }
177    
178     sub _field_body ($$$) {
179     my $self = shift;
180     my ($body, $name) = @_;
181     if (ref $body) {
182     return $body;
183     } else {
184     my $type = $self->{option}->{field_type}->{$name}
185     || $self->{option}->{field_type}->{_DEFAULT};
186     eval "use $type";
187     return $type->parse ($body);
188     }
189 wakaba 1.2 }
190    
191 wakaba 1.1 =head2 $self->field_name_list ()
192    
193     Returns list of all C<field-name>s. (Even if there are two
194     or more C<field>s which have same C<field-name>, this method
195     returns ALL names.)
196    
197     =cut
198    
199     sub field_name_list ($) {
200     my $self = shift;
201     $self->_delete_empty_field ();
202     map {$_->{name}} @{$self->{field}};
203     }
204    
205     =head2 $self->add ($field_name, $field_body)
206    
207     Adds an new C<field>. It is not checked whether
208     the field which named $field_body is already exist or not.
209     If you don't want duplicated C<field>s, use C<replace> method.
210    
211     =cut
212    
213     sub add ($$$) {
214     my $self = shift;
215     my ($name, $body) = (lc shift, shift);
216     return 0 if $name =~ /$REG{UNSAFE_field_name}/;
217     push @{$self->{field}}, {name => $name, body => $body};
218     $self;
219     }
220    
221     =head2 $self->relace ($field_name, $field_body)
222    
223     Set the C<field-body> named C<field-name> as $field_body.
224     If $field_name C<field> is already exists, it is replaced
225     by new $field_body value. If not, new C<field> is inserted.
226     (If there are some C<field> named as $field_name,
227     first one is used and the others are not changed.)
228    
229     =cut
230    
231     sub replace ($$$) {
232     my $self = shift;
233     my ($name, $body) = (lc shift, shift);
234     return 0 if $name =~ /$REG{UNSAFE_field_name}/;
235     for my $field (@{$self->{field}}) {
236     if ($field->{name} eq $name) {
237     $field->{body} = $body;
238     return $self;
239     }
240     }
241     push @{$self->{field}}, {name => $name, body => $body};
242     $self;
243     }
244    
245     =head2 $self->delete ($field_name, [$index])
246    
247     Deletes C<field> named as $field_name.
248     If $index is specified, only $index'th C<field> is deleted.
249     If not, ($index == 0), all C<field>s that have the C<field-name>
250     $field_name are deleted.
251    
252     =cut
253    
254     sub delete ($$;$) {
255     my $self = shift;
256     my ($name, $index) = (lc shift, shift);
257     my $i = 0;
258     for my $field (@{$self->{field}}) {
259     if ($field->{name} eq $name) {
260     $i++;
261     if ($index == 0 || $i == $index) {
262     undef $field;
263     return $self if $i == $index;
264     }
265     }
266     }
267     $self;
268     }
269    
270 wakaba 1.2 =head2 $self->count ([$field_name])
271 wakaba 1.1
272     Returns the number of times the given C<field> appears.
273 wakaba 1.2 If no $field_name is given, returns the number
274     of fields. (Same as $#$self+1)
275 wakaba 1.1
276     =cut
277    
278 wakaba 1.2 sub count ($;$) {
279 wakaba 1.1 my $self = shift;
280     my ($name) = (lc shift);
281 wakaba 1.2 unless ($name) {
282     $self->_delete_empty_field ();
283     return $#{$self->{field}}+1;
284     }
285 wakaba 1.1 my $count = 0;
286     for my $field (@{$self->{field}}) {
287     if ($field->{name} eq $name) {
288     $count++;
289     }
290     }
291     $count;
292     }
293    
294     =head2 $self->stringify ([%option])
295    
296     Returns the C<header> as a string.
297    
298     =cut
299    
300     sub stringify ($;%) {
301     my $self = shift;
302     my %OPT = @_;
303     my @ret;
304     $OPT{capitalize} ||= $self->{option}->{capitalize};
305     $OPT{mail_from} ||= $self->{option}->{mail_from};
306     push @ret, 'From '.$self->field ('mail-from') if $OPT{mail_from};
307     for my $field (@{$self->{field}}) {
308     my $name = $field->{name};
309     next unless $field->{name};
310     next if !$OPT{mail_from} && $name eq 'mail-from';
311     $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $OPT{capitalize};
312     push @ret, $name.': '.$self->fold ($field->{body});
313     }
314 wakaba 1.3 my $ret = join ("\n", @ret);
315     $ret? $ret."\n": "";
316 wakaba 1.1 }
317    
318     =head2 $self->get_option ($option_name)
319    
320     Returns value of the option.
321    
322     =head2 $self->set_option ($option_name, $option_value)
323    
324     Set new value of the option.
325    
326     =cut
327    
328     sub get_option ($$) {
329     my $self = shift;
330     my ($name) = @_;
331     $self->{option}->{$name};
332     }
333     sub set_option ($$$) {
334     my $self = shift;
335     my ($name, $value) = @_;
336     $self->{option}->{$name} = $value;
337     $self;
338     }
339    
340 wakaba 1.4 sub field_type ($$;$) {
341     my $self = shift;
342     my $field_name = shift;
343     my $new_field_type = shift;
344     if ($new_field_type) {
345     $self->{option}->{field_type}->{$field_name} = $new_field_type;
346     }
347     $self->{option}->{field_type}->{$field_name}
348     || $self->{option}->{field_type}->{_DEFAULT};
349     }
350    
351 wakaba 1.1 sub _delete_empty_field ($) {
352     my $self = shift;
353     my @ret;
354     for my $field (@{$self->{field}}) {
355     push @ret, $field if $field->{name};
356     }
357     $self->{field} = \@ret;
358     $self;
359     }
360    
361     sub fold ($$;$) {
362     my $self = shift;
363     my $string = shift;
364     my $len = shift || $self->{option}->{fold_length};
365     $len = 60 if $len < 60;
366    
367     ## This code is taken from Mail::Header 1.43 in MailTools,
368     ## by Graham Barr (Maintained by Mark Overmeer <mailtools@overmeer.net>).
369     my $max = int($len - 5); # 4 for leading spcs + 1 for [\,\;]
370     my $min = int($len * 4 / 5) - 4;
371     my $ml = $len;
372    
373     if (length($string) > $ml) {
374     #Split the line up
375     # first bias towards splitting at a , or a ; >4/5 along the line
376     # next split a whitespace
377     # else we are looking at a single word and probably don't want to split
378     my $x = "";
379     $x .= "$1\n "
380     while($string =~ s/^$REG{WSP}*(
381     [^"]{$min,$max}?[\,\;]
382     |[^"]{1,$max}$REG{WSP}
383     |[^\s"]*(?:"[^"]*"[^\s"]*)+$REG{WSP}
384     |[^\s"]+$REG{WSP}
385     )
386     //x);
387     $x .= $string;
388     $string = $x;
389     $string =~ s/(\A$REG{WSP}+|$REG{WSP}+\Z)//sog;
390     $string =~ s/\s+\n/\n/sog;
391     }
392     $string;
393     }
394    
395     =head1 EXAMPLE
396    
397     ## Print field list
398    
399     use Message::Header;
400     my $header = Message::Header->parse ($header);
401    
402 wakaba 1.2 ## Next sample is better.
403     #for my $field (@$header) {
404     # print $field->{name}, "\t=> ", $field->{body}, "\n";
405     #}
406    
407     for my $i (0..$#$header) {
408     print $header->field_name ($i), "\t=> ", $header->field_body ($i), "\n";
409 wakaba 1.1 }
410    
411    
412     ## Make simple header
413    
414 wakaba 1.2 use Message::Header;
415 wakaba 1.1 use Message::Field::Address;
416     my $header = new Message::Header;
417    
418     my $from = new Message::Field::Address;
419     $from->add ('foo@foo.example', name => 'F. Foo');
420     my $to = new Message::Field::Address;
421     $to->add ('bar@bar.example', name => 'Mr. Bar');
422     $to->add ('hoge@foo.example', name => 'Hoge-san');
423     $header->add ('From' => $from);
424     $header->add ('To' => $to);
425     $header->add ('Subject' => 'Re: Meeting');
426     $header->add ('References' => '<hoge.msgid%foo@foo.example>');
427     print $header;
428    
429     =head1 LICENSE
430    
431     Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
432    
433     This program is free software; you can redistribute it and/or modify
434     it under the terms of the GNU General Public License as published by
435     the Free Software Foundation; either version 2 of the License, or
436     (at your option) any later version.
437    
438     This program is distributed in the hope that it will be useful,
439     but WITHOUT ANY WARRANTY; without even the implied warranty of
440     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
441     GNU General Public License for more details.
442    
443     You should have received a copy of the GNU General Public License
444     along with this program; see the file COPYING. If not, write to
445     the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
446     Boston, MA 02111-1307, USA.
447    
448     =head1 CHANGE
449    
450     See F<ChangeLog>.
451 wakaba 1.4 $Date: 2002/03/13 14:47:07 $
452 wakaba 1.1
453     =cut
454    
455     1;

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24