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 Carp;
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,
  field_type    => {':DEFAULT' => 'Message::Field::Unstructured'},
  format        => 'rfc2822',   ## rfc2822, usefor, http
  mail_from     => -1,
  output_bcc    => -1,
  parse_all     => -1,
);
my @field_type_Structured = qw(cancel-lock
  importance path precedence
  x-face x-mail-count x-msmail-priority x-priority xref);
for (@field_type_Structured)
  {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
my @field_type_Address = qw(approved bcc cc delivered-to disposition-notification-to 
  envelope-to
  errors-to fcc from mail-followup-to mail-followup-cc mail-from 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 x-nfrom x-nto);
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(article-updates content-id in-reply-to message-id
  references resent-message-id see-also supersedes);
for (@field_type_MsgID)
  {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgID'}
for (qw(received x-received))
  {$DEFAULT{field_type}->{$_} = 'Message::Field::Received'}
$DEFAULT{field_type}->{'content-type'} = 'Message::Field::ContentType';
$DEFAULT{field_type}->{'content-disposition'} = 'Message::Field::ContentDisposition';
for (qw(archive link x-face-type))
  {$DEFAULT{field_type}->{$_} = 'Message::Field::ValueParams'}
for (qw(accept accept-charset accept-encoding accept-language
  content-language 
  content-transfer-encoding encrypted followup-to keywords 
  list-archive list-digest list-help list-owner
  list-post list-subscribe list-unsubscribe list-url uri newsgroups
  x-brother x-daughter x-respect x-moe x-syster x-wife))
  {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}
for (qw(content-alias content-base content-location location referer
  url x-home-page x-http_referer
  x-info x-pgp-key x-ml-url x-uri x-url x-web))
  {$DEFAULT{field_type}->{$_} = 'Message::Field::URI'}
for (qw(list-id))
  {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
for (qw(subject title x-nsubject))
  {$DEFAULT{field_type}->{$_} = 'Message::Field::Subject'}
for (qw(list-software user-agent server))
  {$DEFAULT{field_type}->{$_} = 'Message::Field::UA'}
for (qw(content-length lines max-forwards mime-version))
  {$DEFAULT{field_type}->{$_} = 'Message::Field::Numval'}

=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}/) {
      my $body = $1;
      $body = $self->_field_body ($body, 'mail-from')
        if $self->{option}->{parse_all}>0;
      push @{$self->{field}}, {name => 'mail-from', body => $body};
    } elsif ($field =~ /$REG{M_field}/) {
      my ($name, $body) = (lc $1, $2);
      $name =~ s/$REG{WSP}+$//;
      $body =~ s/$REG{WSP}+$//;
      $body = $self->_field_body ($body, $name) if $self->{option}->{parse_all}>0;
      push @{$self->{field}}, {name => $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};
      }
    }
  }
  if ($#ret < 0) {
    return $self->add ($name);
  }
  @ret;
}

sub field_exist ($$) {
  my $self = shift;
  my $name = lc shift;
  my @ret;
  for my $field (@{$self->{field}}) {
    return 1 if ($field->{name} eq $name);
  }
  0;
}

=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, format => $self->{option}->{format});
    } else {
      $body = $type->parse ($body, field_name => $name,
        format => $self->{option}->{format});
    }
  }
  $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);
  my %option = @_;
  return 0 if $name =~ /$REG{UNSAFE_field_name}/;
  $body = $self->_field_body ($body, $name);
  if ($option{prepend}) {
    unshift @{$self->{field}}, {name => $name, body => $body};
  } else {
    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}/;
  $body = $self->_field_body ($body, $name);
  for my $field (@{$self->{field}}) {
    if ($field->{name} eq $name) {
      $field->{body} = $body;
      return $body;
    }
  }
  push @{$self->{field}}, {name => $name, body => $body};
  $body;
}

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

Deletes C<field> named as $field_name.
If $index is specified, only $index'th C<field> is deleted.
($index of first field is C<1>, not C<0>.)
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->rename ($field_name, [$index])

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

=cut

sub rename ($$$;$) {
  my $self = shift;
  my ($name, $newname, $index) = (lc shift, lc shift, shift);
  my $i = 0;
  croak "rename: new field-name contains of unsafe character: $newname"
    if !$newname || $newname =~ /$REG{UNSAFE_field_name}/;
  for my $field (@{$self->{field}}) {
    if ($field->{name} eq $name) {
      $i++;
      if ($index == 0 || $i == $index) {
        $field->{name} = $newname;
        return $self if $i == $index;
      }
    }
  }
  $self;
}

=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};
  $OPT{output_bcc} ||= $self->{option}->{output_bcc};
  $OPT{format} ||= $self->{option}->{format};
  push @ret, 'From '.$self->field ('mail-from') if $OPT{mail_from}>0;
  for my $field (@{$self->{field}}) {
    my $name = $field->{name};
    next unless $name;
    next if $OPT{mail_from}<0 && $name eq 'mail-from';
    next if $OPT{output_bcc}<0 && ($name eq 'bcc' || $name eq 'resent-bcc');
    my $fbody;
    if (ref $field->{body}) {
      $fbody = $field->{body}->stringify (format => $OPT{format});
    } else {
      $fbody = $field->{body};
    }
    next unless $fbody;
    $fbody =~ s/\x0D([^\x09\x0A\x20])/\x0D\x20$1/g;
    $fbody =~ s/\x0A([^\x09\x20])/\x0A\x20$1/g;
    $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->option ($option_name, [$option_value])

Set/gets new value of the option.

=cut

sub option ($$;$) {
  my $self = shift;
  my ($name, $value) = @_;
  if (defined $value) {
    $self->{option}->{$name} = $value;
    if ($name eq 'format') {
      for my $f (@{$self->{field}}) {
        if (ref $f) {
          $f->option (format => $value);
        }
      }
    }
  }
  $self->{option}->{$name};
}

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/31 13:12:41 $

=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	wakaba	1.12	use Carp;
17	wakaba	1.1	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	wakaba	1.7	field_type => {':DEFAULT' => 'Message::Field::Unstructured'},
51	wakaba	1.12	format => 'rfc2822', ## rfc2822, usefor, http
52	wakaba	1.9	mail_from => -1,
53	wakaba	1.10	output_bcc => -1,
54	wakaba	1.9	parse_all => -1,
55	wakaba	1.1	);
56	wakaba	1.7	my @field_type_Structured = qw(cancel-lock
57	wakaba	1.13	importance path precedence
58			x-face x-mail-count x-msmail-priority x-priority xref);
59	wakaba	1.4	for (@field_type_Structured)
60			{$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
61	wakaba	1.8	my @field_type_Address = qw(approved bcc cc delivered-to disposition-notification-to
62			envelope-to
63	wakaba	1.7	errors-to fcc from mail-followup-to mail-followup-cc mail-from reply-to resent-bcc
64	wakaba	1.4	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	wakaba	1.7	x-envelope-to x-ml-address x-ml-command x-ml-to x-nfrom x-nto);
68	wakaba	1.4	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	wakaba	1.12	my @field_type_MsgID = qw(article-updates content-id in-reply-to message-id
75	wakaba	1.6	references resent-message-id see-also supersedes);
76	wakaba	1.4	for (@field_type_MsgID)
77	wakaba	1.6	{$DEFAULT{field_type}->{$_} = 'Message::Field::MsgID'}
78	wakaba	1.7	for (qw(received x-received))
79	wakaba	1.5	{$DEFAULT{field_type}->{$_} = 'Message::Field::Received'}
80	wakaba	1.8	$DEFAULT{field_type}->{'content-type'} = 'Message::Field::ContentType';
81			$DEFAULT{field_type}->{'content-disposition'} = 'Message::Field::ContentDisposition';
82	wakaba	1.12	for (qw(archive link x-face-type))
83	wakaba	1.8	{$DEFAULT{field_type}->{$_} = 'Message::Field::ValueParams'}
84	wakaba	1.7	for (qw(accept accept-charset accept-encoding accept-language
85	wakaba	1.8	content-language
86	wakaba	1.12	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	wakaba	1.8	x-brother x-daughter x-respect x-moe x-syster x-wife))
90	wakaba	1.7	{$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}
91	wakaba	1.12	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	wakaba	1.7	for (qw(list-id))
96	wakaba	1.4	{$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
97	wakaba	1.10	for (qw(subject title x-nsubject))
98	wakaba	1.5	{$DEFAULT{field_type}->{$_} = 'Message::Field::Subject'}
99	wakaba	1.10	for (qw(list-software user-agent server))
100			{$DEFAULT{field_type}->{$_} = 'Message::Field::UA'}
101	wakaba	1.13	for (qw(content-length lines max-forwards mime-version))
102			{$DEFAULT{field_type}->{$_} = 'Message::Field::Numval'}
103	wakaba	1.1
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	wakaba	1.9	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	wakaba	1.1	} elsif ($field =~ /$REG{M_field}/) {
138	wakaba	1.9	my ($name, $body) = (lc $1, $2);
139	wakaba	1.1	$name =~ s/$REG{WSP}+$//;
140			$body =~ s/$REG{WSP}+$//;
141	wakaba	1.9	$body = $self->_field_body ($body, $name) if $self->{option}->{parse_all}>0;
142			push @{$self->{field}}, {name => $name, body => $body};
143	wakaba	1.1	}
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	wakaba	1.5	$field->{body} = $self->_field_body ($field->{body}, $name);
165			return $field->{body};
166	wakaba	1.1	} else {
167	wakaba	1.5	$field->{body} = $self->_field_body ($field->{body}, $name);
168			push @ret, $field->{body};
169	wakaba	1.1	}
170			}
171			}
172	wakaba	1.9	if ($#ret < 0) {
173			return $self->add ($name);
174			}
175	wakaba	1.1	@ret;
176			}
177
178	wakaba	1.9	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	wakaba	1.2	=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	wakaba	1.4	my $i = shift;
205	wakaba	1.5	$self->{field}->[$i]->{body}
206			= $self->_field_body ($self->{field}->[$i]->{body}, $self->{field}->[$i]->{name});
207			$self->{field}->[$i]->{body};
208	wakaba	1.4	}
209
210			sub _field_body ($$$) {
211			my $self = shift;
212			my ($body, $name) = @_;
213	wakaba	1.5	unless (ref $body) {
214	wakaba	1.4	my $type = $self->{option}->{field_type}->{$name}
215	wakaba	1.7	\|\| $self->{option}->{field_type}->{':DEFAULT'};
216	wakaba	1.5	eval "require $type";
217			unless ($body) {
218	wakaba	1.12	$body = $type->new (field_name => $name, format => $self->{option}->{format});
219	wakaba	1.5	} else {
220	wakaba	1.12	$body = $type->parse ($body, field_name => $name,
221			format => $self->{option}->{format});
222	wakaba	1.5	}
223	wakaba	1.4	}
224	wakaba	1.5	$body;
225	wakaba	1.2	}
226
227	wakaba	1.1	=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	wakaba	1.9	sub add ($$;$%) {
250	wakaba	1.1	my $self = shift;
251			my ($name, $body) = (lc shift, shift);
252	wakaba	1.8	my %option = @_;
253	wakaba	1.1	return 0 if $name =~ /$REG{UNSAFE_field_name}/;
254	wakaba	1.5	$body = $self->_field_body ($body, $name);
255	wakaba	1.8	if ($option{prepend}) {
256	wakaba	1.9	unshift @{$self->{field}}, {name => $name, body => $body};
257	wakaba	1.8	} else {
258			push @{$self->{field}}, {name => $name, body => $body};
259			}
260	wakaba	1.5	$body;
261	wakaba	1.1	}
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	wakaba	1.9	$body = $self->_field_body ($body, $name);
278	wakaba	1.1	for my $field (@{$self->{field}}) {
279			if ($field->{name} eq $name) {
280			$field->{body} = $body;
281	wakaba	1.8	return $body;
282	wakaba	1.1	}
283			}
284			push @{$self->{field}}, {name => $name, body => $body};
285	wakaba	1.9	$body;
286	wakaba	1.1	}
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	wakaba	1.12	($index of first field is C<1>, not C<0>.)
293	wakaba	1.1	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	wakaba	1.2	=head2 $self->count ([$field_name])
315	wakaba	1.1
316			Returns the number of times the given C<field> appears.
317	wakaba	1.2	If no $field_name is given, returns the number
318			of fields. (Same as $#$self+1)
319	wakaba	1.1
320			=cut
321
322	wakaba	1.2	sub count ($;$) {
323	wakaba	1.1	my $self = shift;
324			my ($name) = (lc shift);
325	wakaba	1.2	unless ($name) {
326			$self->_delete_empty_field ();
327			return $#{$self->{field}}+1;
328			}
329	wakaba	1.1	my $count = 0;
330			for my $field (@{$self->{field}}) {
331			if ($field->{name} eq $name) {
332			$count++;
333			}
334			}
335			$count;
336			}
337
338	wakaba	1.12	=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	wakaba	1.1	=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	wakaba	1.10	$OPT{output_bcc} \|\|= $self->{option}->{output_bcc};
379	wakaba	1.12	$OPT{format} \|\|= $self->{option}->{format};
380	wakaba	1.9	push @ret, 'From '.$self->field ('mail-from') if $OPT{mail_from}>0;
381	wakaba	1.1	for my $field (@{$self->{field}}) {
382			my $name = $field->{name};
383	wakaba	1.10	next unless $name;
384	wakaba	1.9	next if $OPT{mail_from}<0 && $name eq 'mail-from';
385	wakaba	1.10	next if $OPT{output_bcc}<0 && ($name eq 'bcc' \|\| $name eq 'resent-bcc');
386	wakaba	1.12	my $fbody;
387			if (ref $field->{body}) {
388			$fbody = $field->{body}->stringify (format => $OPT{format});
389			} else {
390			$fbody = $field->{body};
391			}
392	wakaba	1.5	next unless $fbody;
393	wakaba	1.9	$fbody =~ s/\x0D([^\x09\x0A\x20])/\x0D\x20$1/g;
394			$fbody =~ s/\x0A([^\x09\x20])/\x0A\x20$1/g;
395	wakaba	1.1	$name =~ s/((?:^\|-)[a-z])/uc($1)/ge if $OPT{capitalize};
396	wakaba	1.5	push @ret, $name.': '.$self->fold ($fbody);
397	wakaba	1.1	}
398	wakaba	1.3	my $ret = join ("\n", @ret);
399			$ret? $ret."\n": "";
400	wakaba	1.1	}
401
402	wakaba	1.12	=head2 $self->option ($option_name, [$option_value])
403	wakaba	1.1
404	wakaba	1.12	Set/gets new value of the option.
405	wakaba	1.1
406			=cut
407
408	wakaba	1.12	sub option ($$;$) {
409	wakaba	1.1	my $self = shift;
410	wakaba	1.12	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	wakaba	1.1	$self->{option}->{$name};
422			}
423
424	wakaba	1.4	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	wakaba	1.7	\|\| $self->{option}->{field_type}->{':DEFAULT'};
433	wakaba	1.4	}
434
435	wakaba	1.1	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	wakaba	1.11	$x .= "$1\n "
464	wakaba	1.1	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	wakaba	1.2	## 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	wakaba	1.1	}
494
495
496			## Make simple header
497
498	wakaba	1.2	use Message::Header;
499	wakaba	1.1	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	wakaba	1.13	$Date: 2002/03/31 13:12:41 $
536	wakaba	1.1
537			=cut
538
539			1;