lib/Message/Header.pm


=head1 NAME

Message::Header Perl module

=head1 DESCRIPTION

Perl module for RFC 822/2822 message C<header>.

=cut

package Message::Header;
use strict;
use vars qw($VERSION %REG %DEFAULT);
$VERSION = '1.00';

use overload '@{}' => sub {shift->_delete_empty_field()->{field}},
             '""' => sub {shift->stringify};

$REG{WSP}     = qr/[\x09\x20]/;
$REG{FWS}     = qr/[\x09\x20]*/;
$REG{M_field} = qr/^([^\x3A]+):$REG{FWS}([\x00-\xFF]*)$/;
$REG{M_fromline} = qr/^\x3E?From$REG{WSP}+([\x00-\xFF]*)$/;
$REG{UNSAFE_field_name} = qr/[\x00-\x20\x3A\x7F-\xFF]/;

=head2 options

These options can be getten/set by C<get_option>/C<set_option>
method.

=head3 capitalize = 0/1

(First character of) C<field-name> is capitalized
when C<stringify>.  (Default = 1)

=head3 fold_length = numeric value

Length of line used to fold.  (Default = 70)

=head3 mail_from = 0/1

Outputs "From " line (known as Un*x From, Mail-From, and so on)
when C<stringify>.  (Default = 0)

=cut

%DEFAULT = (
  capitalize    => 1,
  fold_length   => 70,
  mail_from     => 0,
);

=head2 Message::Header->new ([%option])

Returns new Message::Header instance.  Some options can be
specified as hash.

=cut

sub new ($;%) {
  my $class = shift;
  my $self = bless {option => {@_}}, $class;
  for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
  $self;
}

=head2 Message::Header->parse ($header, [%option])

Parses given C<header> and return a new Message::Header
object.  Some options can be specified as hash.

=cut

sub parse ($$;%) {
  my $class = shift;
  my $header = shift;
  my $self = bless {option => {@_}}, $class;
  for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
  $header =~ s/\x0D?\x0A$REG{WSP}+/\x20/gos;    ## unfold
  for my $field (split /\x0D?\x0A/, $header) {
    if ($field =~ /$REG{M_fromline}/) {
      push @{$self->{field}}, {name => 'mail-from', body => $1};
    } elsif ($field =~ /$REG{M_field}/) {
      my ($name, $body) = ($1, $2);
      $name =~ s/$REG{WSP}+$//;
      $body =~ s/$REG{WSP}+$//;
      push @{$self->{field}}, {name => lc $name, body => $body};
    }
  }
  $self;
}

=head2 $self->field ($field_name)

Returns C<field-body> of given C<field-name>.
When there are two or more C<field>s whose name is C<field-name>,
this method return all C<field-body>s as array.  (On scalar
context, only first one is returned.)

=cut

sub field ($$) {
  my $self = shift;
  my $name = lc shift;
  my @ret;
  for my $field (@{$self->{field}}) {
    if ($field->{name} eq $name) {
      unless (wantarray) {
        return $field->{body};
      } else {
        push @ret, $field->{body};
      }
    }
  }
  @ret;
}

=head2 $self->field_name_list ()

Returns list of all C<field-name>s.  (Even if there are two
or more C<field>s which have same C<field-name>,  this method
returns ALL names.)

=cut

sub field_name_list ($) {
  my $self = shift;
  $self->_delete_empty_field ();
  map {$_->{name}} @{$self->{field}};
}

=head2 $self->add ($field_name, $field_body)

Adds an new C<field>.  It is not checked whether
the field which named $field_body is already exist or not.
If you don't want duplicated C<field>s, use C<replace> method.

=cut

sub add ($$$) {
  my $self = shift;
  my ($name, $body) = (lc shift, shift);
  return 0 if $name =~ /$REG{UNSAFE_field_name}/;
  push @{$self->{field}}, {name => $name, body => $body};
  $self;
}

=head2 $self->relace ($field_name, $field_body)

Set the C<field-body> named C<field-name> as $field_body.
If $field_name C<field> is already exists, it is replaced
by new $field_body value.  If not, new C<field> is inserted.
(If there are some C<field> named as $field_name,
first one is used and the others are not changed.)

=cut

sub replace ($$$) {
  my $self = shift;
  my ($name, $body) = (lc shift, shift);
  return 0 if $name =~ /$REG{UNSAFE_field_name}/;
  for my $field (@{$self->{field}}) {
    if ($field->{name} eq $name) {
      $field->{body} = $body;
      return $self;
    }
  }
  push @{$self->{field}}, {name => $name, body => $body};
  $self;
}

=head2 $self->delete ($field_name, [$index])

Deletes C<field> named as $field_name.
If $index is specified, only $index'th C<field> is deleted.
If not, ($index == 0), all C<field>s that have the C<field-name>
$field_name are deleted.

=cut

sub delete ($$;$) {
  my $self = shift;
  my ($name, $index) = (lc shift, shift);
  my $i = 0;
  for my $field (@{$self->{field}}) {
    if ($field->{name} eq $name) {
      $i++;
      if ($index == 0 || $i == $index) {
        undef $field;
        return $self if $i == $index;
      }
    }
  }
  $self;
}

=head2 $self->count ($field_name)

Returns the number of times the given C<field> appears.

=cut

sub count ($$) {
  my $self = shift;
  my ($name) = (lc shift);
  my $count = 0;
  for my $field (@{$self->{field}}) {
    if ($field->{name} eq $name) {
      $count++;
    }
  }
  $count;
}

=head2 $self->stringify ([%option])

Returns the C<header> as a string.

=cut

sub stringify ($;%) {
  my $self = shift;
  my %OPT = @_;
  my @ret;
  $OPT{capitalize} ||= $self->{option}->{capitalize};
  $OPT{mail_from} ||= $self->{option}->{mail_from};
  push @ret, 'From '.$self->field ('mail-from') if $OPT{mail_from};
  for my $field (@{$self->{field}}) {
    my $name = $field->{name};
    next unless $field->{name};
    next if !$OPT{mail_from} && $name eq 'mail-from';
    $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $OPT{capitalize};
    push @ret, $name.': '.$self->fold ($field->{body});
  }
  join "\n", @ret;
}

=head2 $self->get_option ($option_name)

Returns value of the option.

=head2 $self->set_option ($option_name, $option_value)

Set new value of the option.

=cut

sub get_option ($$) {
  my $self = shift;
  my ($name) = @_;
  $self->{option}->{$name};
}
sub set_option ($$$) {
  my $self = shift;
  my ($name, $value) = @_;
  $self->{option}->{$name} = $value;
  $self;
}

sub _delete_empty_field ($) {
  my $self = shift;
  my @ret;
  for my $field (@{$self->{field}}) {
    push @ret, $field if $field->{name};
  }
  $self->{field} = \@ret;
  $self;
}

sub fold ($$;$) {
  my $self = shift;
  my $string = shift;
  my $len = shift || $self->{option}->{fold_length};
  $len = 60 if $len < 60;
  
  ## This code is taken from Mail::Header 1.43 in MailTools,
  ## by Graham Barr (Maintained by Mark Overmeer <mailtools@overmeer.net>).
  my $max = int($len - 5);         # 4 for leading spcs + 1 for [\,\;]
  my $min = int($len * 4 / 5) - 4;
  my $ml = $len;
  
  if (length($string) > $ml) {
     #Split the line up
     # first bias towards splitting at a , or a ; >4/5 along the line
     # next split a whitespace
     # else we are looking at a single word and probably don't want to split
     my $x = "";
     $x .= "$1\n    "
       while($string =~ s/^$REG{WSP}*(
                          [^"]{$min,$max}?[\,\;]
                          |[^"]{1,$max}$REG{WSP}
                          |[^\s"]*(?:"[^"]*"[^\s"]*)+$REG{WSP}
                          |[^\s"]+$REG{WSP}
                          )
                        //x);
     $x .= $string;
     $string = $x;
     $string =~ s/(\A$REG{WSP}+|$REG{WSP}+\Z)//sog;
     $string =~ s/\s+\n/\n/sog;
  }
  $string;
}

=head1 EXAMPLE

  ## Print field list
  
  use Message::Header;
  my $header = Message::Header->parse ($header);
  
  for my $field (@$header) {
    print $field->{name}, "\t=> ", $field->{body}, "\n";
  }
  
  
  ## Make simple header
  
  use Message::Field::Address;
  my $header = new Message::Header;
  
  my $from = new Message::Field::Address;
     $from->add ('foo@foo.example', name => 'F. Foo');
  my $to = new Message::Field::Address;
     $to->add ('bar@bar.example', name => 'Mr. Bar');
     $to->add ('hoge@foo.example', name => 'Hoge-san');
  $header->add ('From' => $from);
  $header->add ('To' => $to);
  $header->add ('Subject' => 'Re: Meeting');
  $header->add ('References' => '<hoge.msgid%foo@foo.example>');
  print $header;

=head1 LICENSE

Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.

=head1 CHANGE

See F<ChangeLog>.

=cut

1;
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			);
52
53			=head2 Message::Header->new ([%option])
54
55			Returns new Message::Header instance. Some options can be
56			specified as hash.
57
58			=cut
59
60			sub new ($;%) {
61			my $class = shift;
62			my $self = bless {option => {@_}}, $class;
63			for (keys %DEFAULT) {$self->{option}->{$_} \|\|= $DEFAULT{$_}}
64			$self;
65			}
66
67			=head2 Message::Header->parse ($header, [%option])
68
69			Parses given C<header> and return a new Message::Header
70			object. Some options can be specified as hash.
71
72			=cut
73
74			sub parse ($$;%) {
75			my $class = shift;
76			my $header = shift;
77			my $self = bless {option => {@_}}, $class;
78			for (keys %DEFAULT) {$self->{option}->{$_} \|\|= $DEFAULT{$_}}
79			$header =~ s/\x0D?\x0A$REG{WSP}+/\x20/gos; ## unfold
80			for my $field (split /\x0D?\x0A/, $header) {
81			if ($field =~ /$REG{M_fromline}/) {
82			push @{$self->{field}}, {name => 'mail-from', body => $1};
83			} elsif ($field =~ /$REG{M_field}/) {
84			my ($name, $body) = ($1, $2);
85			$name =~ s/$REG{WSP}+$//;
86			$body =~ s/$REG{WSP}+$//;
87			push @{$self->{field}}, {name => lc $name, body => $body};
88			}
89			}
90			$self;
91			}
92
93			=head2 $self->field ($field_name)
94
95			Returns C<field-body> of given C<field-name>.
96			When there are two or more C<field>s whose name is C<field-name>,
97			this method return all C<field-body>s as array. (On scalar
98			context, only first one is returned.)
99
100			=cut
101
102			sub field ($$) {
103			my $self = shift;
104			my $name = lc shift;
105			my @ret;
106			for my $field (@{$self->{field}}) {
107			if ($field->{name} eq $name) {
108			unless (wantarray) {
109			return $field->{body};
110			} else {
111			push @ret, $field->{body};
112			}
113			}
114			}
115			@ret;
116			}
117
118			=head2 $self->field_name_list ()
119
120			Returns list of all C<field-name>s. (Even if there are two
121			or more C<field>s which have same C<field-name>, this method
122			returns ALL names.)
123
124			=cut
125
126			sub field_name_list ($) {
127			my $self = shift;
128			$self->_delete_empty_field ();
129			map {$_->{name}} @{$self->{field}};
130			}
131
132			=head2 $self->add ($field_name, $field_body)
133
134			Adds an new C<field>. It is not checked whether
135			the field which named $field_body is already exist or not.
136			If you don't want duplicated C<field>s, use C<replace> method.
137
138			=cut
139
140			sub add ($$$) {
141			my $self = shift;
142			my ($name, $body) = (lc shift, shift);
143			return 0 if $name =~ /$REG{UNSAFE_field_name}/;
144			push @{$self->{field}}, {name => $name, body => $body};
145			$self;
146			}
147
148			=head2 $self->relace ($field_name, $field_body)
149
150			Set the C<field-body> named C<field-name> as $field_body.
151			If $field_name C<field> is already exists, it is replaced
152			by new $field_body value. If not, new C<field> is inserted.
153			(If there are some C<field> named as $field_name,
154			first one is used and the others are not changed.)
155
156			=cut
157
158			sub replace ($$$) {
159			my $self = shift;
160			my ($name, $body) = (lc shift, shift);
161			return 0 if $name =~ /$REG{UNSAFE_field_name}/;
162			for my $field (@{$self->{field}}) {
163			if ($field->{name} eq $name) {
164			$field->{body} = $body;
165			return $self;
166			}
167			}
168			push @{$self->{field}}, {name => $name, body => $body};
169			$self;
170			}
171
172			=head2 $self->delete ($field_name, [$index])
173
174			Deletes C<field> named as $field_name.
175			If $index is specified, only $index'th C<field> is deleted.
176			If not, ($index == 0), all C<field>s that have the C<field-name>
177			$field_name are deleted.
178
179			=cut
180
181			sub delete ($$;$) {
182			my $self = shift;
183			my ($name, $index) = (lc shift, shift);
184			my $i = 0;
185			for my $field (@{$self->{field}}) {
186			if ($field->{name} eq $name) {
187			$i++;
188			if ($index == 0 \|\| $i == $index) {
189			undef $field;
190			return $self if $i == $index;
191			}
192			}
193			}
194			$self;
195			}
196
197			=head2 $self->count ($field_name)
198
199			Returns the number of times the given C<field> appears.
200
201			=cut
202
203			sub count ($$) {
204			my $self = shift;
205			my ($name) = (lc shift);
206			my $count = 0;
207			for my $field (@{$self->{field}}) {
208			if ($field->{name} eq $name) {
209			$count++;
210			}
211			}
212			$count;
213			}
214
215			=head2 $self->stringify ([%option])
216
217			Returns the C<header> as a string.
218
219			=cut
220
221			sub stringify ($;%) {
222			my $self = shift;
223			my %OPT = @_;
224			my @ret;
225			$OPT{capitalize} \|\|= $self->{option}->{capitalize};
226			$OPT{mail_from} \|\|= $self->{option}->{mail_from};
227			push @ret, 'From '.$self->field ('mail-from') if $OPT{mail_from};
228			for my $field (@{$self->{field}}) {
229			my $name = $field->{name};
230			next unless $field->{name};
231			next if !$OPT{mail_from} && $name eq 'mail-from';
232			$name =~ s/((?:^\|-)[a-z])/uc($1)/ge if $OPT{capitalize};
233			push @ret, $name.': '.$self->fold ($field->{body});
234			}
235			join "\n", @ret;
236			}
237
238			=head2 $self->get_option ($option_name)
239
240			Returns value of the option.
241
242			=head2 $self->set_option ($option_name, $option_value)
243
244			Set new value of the option.
245
246			=cut
247
248			sub get_option ($$) {
249			my $self = shift;
250			my ($name) = @_;
251			$self->{option}->{$name};
252			}
253			sub set_option ($$$) {
254			my $self = shift;
255			my ($name, $value) = @_;
256			$self->{option}->{$name} = $value;
257			$self;
258			}
259
260			sub _delete_empty_field ($) {
261			my $self = shift;
262			my @ret;
263			for my $field (@{$self->{field}}) {
264			push @ret, $field if $field->{name};
265			}
266			$self->{field} = \@ret;
267			$self;
268			}
269
270			sub fold ($$;$) {
271			my $self = shift;
272			my $string = shift;
273			my $len = shift \|\| $self->{option}->{fold_length};
274			$len = 60 if $len < 60;
275
276			## This code is taken from Mail::Header 1.43 in MailTools,
277			## by Graham Barr (Maintained by Mark Overmeer <mailtools@overmeer.net>).
278			my $max = int($len - 5); # 4 for leading spcs + 1 for [\,\;]
279			my $min = int($len * 4 / 5) - 4;
280			my $ml = $len;
281
282			if (length($string) > $ml) {
283			#Split the line up
284			# first bias towards splitting at a , or a ; >4/5 along the line
285			# next split a whitespace
286			# else we are looking at a single word and probably don't want to split
287			my $x = "";
288			$x .= "$1\n "
289			while($string =~ s/^$REG{WSP}*(
290			[^"]{$min,$max}?[\,\;]
291			\|[^"]{1,$max}$REG{WSP}
292			\|[^\s"](?:"[^"]"[^\s"]*)+$REG{WSP}
293			\|[^\s"]+$REG{WSP}
294			)
295			//x);
296			$x .= $string;
297			$string = $x;
298			$string =~ s/(\A$REG{WSP}+\|$REG{WSP}+\Z)//sog;
299			$string =~ s/\s+\n/\n/sog;
300			}
301			$string;
302			}
303
304			=head1 EXAMPLE
305
306			## Print field list
307
308			use Message::Header;
309			my $header = Message::Header->parse ($header);
310
311			for my $field (@$header) {
312			print $field->{name}, "\t=> ", $field->{body}, "\n";
313			}
314
315
316			## Make simple header
317
318			use Message::Field::Address;
319			my $header = new Message::Header;
320
321			my $from = new Message::Field::Address;
322			$from->add ('foo@foo.example', name => 'F. Foo');
323			my $to = new Message::Field::Address;
324			$to->add ('bar@bar.example', name => 'Mr. Bar');
325			$to->add ('hoge@foo.example', name => 'Hoge-san');
326			$header->add ('From' => $from);
327			$header->add ('To' => $to);
328			$header->add ('Subject' => 'Re: Meeting');
329			$header->add ('References' => '<hoge.msgid%foo@foo.example>');
330			print $header;
331
332			=head1 LICENSE
333
334			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
335
336			This program is free software; you can redistribute it and/or modify
337			it under the terms of the GNU General Public License as published by
338			the Free Software Foundation; either version 2 of the License, or
339			(at your option) any later version.
340
341			This program is distributed in the hope that it will be useful,
342			but WITHOUT ANY WARRANTY; without even the implied warranty of
343			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
344			GNU General Public License for more details.
345
346			You should have received a copy of the GNU General Public License
347			along with this program; see the file COPYING. If not, write to
348			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
349			Boston, MA 02111-1307, USA.
350
351			=head1 CHANGE
352
353			See F<ChangeLog>.
354
355			=cut
356
357			1;