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,
  field_type    => {_DEFAULT => 'Message::Field::Unstructured'},
);
my @field_type_Structured = qw(cancel-lock content-language
  content-transfer-encoding
  encrypted followup-to importance mime-version newsgroups 
  path precedence user-agent x-cite
  x-face x-mail-count
  x-msmail-priority x-priority x-uidl xref);
for (@field_type_Structured)
  {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
my @field_type_Address = qw(approved bcc cc delivered-to envelope-to
  errors-to from mail-followup-to reply-to resent-bcc
  resent-cc resent-to resent-from resent-sender return-path
  return-receipt-to sender to x-approved x-beenthere
  x-complaints-to x-envelope-from x-envelope-sender
  x-envelope-to x-ml-address x-ml-command x-ml-to);
for (@field_type_Address)
  {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}
my @field_type_Date = qw(date date-received delivery-date expires
  expire-date nntp-posting-date posted reply-by resent-date x-tcup-date);
for (@field_type_Date)
  {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}
my @field_type_MsgID = qw(content-id in-reply-to message-id
  references resent-message-id see-also supersedes);
for (@field_type_MsgID)
  {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgID'}
my @field_type_Received = qw(received x-received);
for (@field_type_Received)
  {$DEFAULT{field_type}->{$_} = 'Message::Field::Received'}
my @field_type_Param = qw(content-disposition content-type
  x-brother x-daughter x-face-type x-respect x-moe
  x-syster x-wife);
for (@field_type_Param)
  {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
my @field_type_URI = qw(list-archive list-help list-owner
  list-post list-subscribe list-unsubscribe uri url x-home-page x-http_referer
  x-info x-pgp-key x-ml-url x-uri x-url x-web);
for (@field_type_URI)
  {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
my @field_type_ListID = qw(list-id);
for (@field_type_ListID)
  {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
my @field_type_Subject = qw(content-description subject title);
for (@field_type_Subject)
  {$DEFAULT{field_type}->{$_} = 'Message::Field::Subject'}

=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) {
        $field->{body} = $self->_field_body ($field->{body}, $name);
        return $field->{body};
      } else {
        $field->{body} = $self->_field_body ($field->{body}, $name);
        push @ret, $field->{body};
      }
    }
  }
  @ret;
}

=head2 $self->field_name ($index)

Returns C<field-name> of $index'th C<field>.

=head2 $self->field_body ($index)

Returns C<field-body> of $index'th C<field>.

=cut

sub field_name ($$) {
  my $self = shift;
  $self->{field}->[shift]->{name};
}
sub field_body ($$) {
  my $self = shift;
  my $i = shift;
  $self->{field}->[$i]->{body}
   = $self->_field_body ($self->{field}->[$i]->{body}, $self->{field}->[$i]->{name});
  $self->{field}->[$i]->{body};
}

sub _field_body ($$$) {
  my $self = shift;
  my ($body, $name) = @_;
  unless (ref $body) {
    my $type = $self->{option}->{field_type}->{$name}
            || $self->{option}->{field_type}->{_DEFAULT};
    eval "require $type";
    unless ($body) {
      $body = $type->new (field_name => $name);
    } else {
      $body = $type->parse ($body, field_name => $name);
    }
  }
  $body;
}

=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}/;
  $body = $self->_field_body ($body, $name);
  push @{$self->{field}}, {name => $name, body => $body};
  $body;
}

=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.
If no $field_name is given, returns the number
of fields.  (Same as $#$self+1)

=cut

sub count ($;$) {
  my $self = shift;
  my ($name) = (lc shift);
  unless ($name) {
    $self->_delete_empty_field ();
    return $#{$self->{field}}+1;
  }
  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';
    my $fbody = scalar $field->{body};
    next unless $fbody;
    $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $OPT{capitalize};
    push @ret, $name.': '.$self->fold ($fbody);
  }
  my $ret = join ("\n", @ret);
  $ret? $ret."\n": "";
}

=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 field_type ($$;$) {
  my $self = shift;
  my $field_name = shift;
  my $new_field_type = shift;
  if ($new_field_type) {
    $self->{option}->{field_type}->{$field_name} = $new_field_type;
  }
  $self->{option}->{field_type}->{$field_name}
  || $self->{option}->{field_type}->{_DEFAULT};
}

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);
  
  ## Next sample is better.
  #for my $field (@$header) {
  #  print $field->{name}, "\t=> ", $field->{body}, "\n";
  #}
  
  for my $i (0..$#$header) {
    print $header->field_name ($i), "\t=> ", $header->field_body ($i), "\n";
  }
  
  
  ## Make simple header
  
  use Message::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>.
$Date: 2002/03/16 08:54:39 $

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