Message/Body/Multipart.pm


=head1 NAME

Message::Body::Multipart - MIME Multipart Body for Internet Messages

=head1 DESCRIPTION

This module provides a support for C<multipart/*> Internet Media Types. 
With this module, each multipart body part can be treated 
as for standalone MIME messages.  It also provides the access
to prologue and epilogue.

This module is part of manakai, a Perl library for Internet messages.

=cut

package Message::Body::Multipart;
use strict;
use vars qw(%DEFAULT @ISA $VERSION);
$VERSION=do{my @r=(q$Revision: 1.7 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

require Message::Body::Text;
push @ISA, qw(Message::Body::Text);

my @BCHARS = ('0'..'9', 'A'..'Z', 'a'..'z', qw#+ _ , - . / =#);
#my @BCHARS = ('0'..'9', 'A'..'Z', 'a'..'z', qw#' ( ) + _ , - . / : = ?#, ' '); ## RFC 2046
my %REG;
$REG{NON_bchars} = qr#[^0-9A-Za-z'()+_,-./:=?\x20]#;

%DEFAULT = (
        ## "#i" : only inherited from parent Entity and inherits to child Entity
  -_ARRAY_NAME  => 'value',
  -_METHODS     => [qw|data_part control_part entity_header add delete count item preamble epilogue|],
  -_MEMBERS     => [qw|boundary preamble epilogue|],
  #i accept_cte
  #i body_default_charset
  #i body_default_charset_input
  #i cte_default
  -default_media_type   => 'text',
  -default_media_subtype        => 'plain',
  -linebreak_strict     => 0,
  -media_type   => 'multipart',
  -media_subtype        => 'mixed',
  #output_epilogue
  -parse_all    => 0,
  -parts_min    => 1,
  -parts_max    => 0,
  #i text_coderange
  #use_normalization    => 0,
  #use_param_charset    => 0,
  -value_type   => {},
);

=head1 CONSTRUCTORS

The following methods construct new objects:

=over 4

=cut

## Initialize of this class -- called by constructors
sub _init ($;%) {
  my $self = shift;
  my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
  my %option = @_;
  $self->SUPER::_init (%$DEFAULT, %option);
  
  unless (defined $self->{option}->{output_epilogue}) {
    $self->{option}->{output_epilogue} = $self->{option}->{format} !~ /http/;
  }
  $self->{option}->{value_type}->{body_part}->[1]->{-format}
    = 
  my @ilist = qw/accept_coderange body_default_charset body_default_charset_input cte_default text_coderange/;
  $self->{option}->{value_type}->{preamble} = sub {
    my $phdr = new Message::Header -format => 'mail-rfc822';
    my $ct = '';
    $ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0) if ref $self->{header};
    $ct = $ct->item ('x-preamble-type', -new_item_unless_exist => 0) if ref $ct;
    $phdr->add ('content-type' => $ct) if $ct;
    ['Message::Body::TextPlain',
    {-media_type => 'text', -media_subtype => '/multipart-preamble',
    entity_header => $phdr},
    \@ilist]};
  $self->{option}->{value_type}->{body_part} = sub {['Message::Entity',
    {-format => $_[0]->{option}->{format} . '/' . 'mime-entity',
    -body_default_media_type => $_[0]->{option}->{default_media_type},
    -body_default_media_subtype => $_[0]->{option}->{default_media_subtype}},
    \@ilist]};
  $self->{option}->{value_type}->{epilogue} = sub {
    my $phdr = new Message::Header -format => 'mail-rfc822';
    my $ct = '';
    $ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0) if ref $self->{header};
    $ct = $ct->item ('x-epilogue-type', -new_item_unless_exist => 0) if ref $ct;
    $phdr->add ('content-type' => $ct) if $ct;
    ['Message::Body::TextPlain',
    {-media_type => 'text', -media_subtype => '/multipart-epilogue',
    entity_header => $phdr},
    \@ilist]};
  
  $self->{boundary} = $option{boundary};
  if (!length $self->{boundary} && ref $self->{header}) {
    my $ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0);
    $self->{boundary} = $ct->parameter ('boundary', -new_item_unless_exist => 0)
      if ref $ct;
  }
  
  my $mst = $self->{option}->{media_subtype};
  if ($mst eq 'report') {
    $self->{option}->{parts_min} = 2;
    $self->{option}->{parts_max} = 3;
  } elsif ($mst eq 'signed' || $mst eq 'encrypted' || $mst eq 'appledouble') {
    $self->{option}->{parts_min} = 2;
    $self->{option}->{parts_max} = 2;
  } elsif ($mst eq 'headerset') {
    $self->{option}->{parts_min} = 2;
  }
}

=item $body = Message::Body::Multipart->new ([%options])

Constructs a new object.  You might pass some options as parameters 
to the constructor.

=cut

## Inherited

=item $body = Message::Body::Multipart->parse ($body, [%options])

Constructs a new object with given field body.  You might pass 
some options as parameters to the constructor.

=cut

sub parse ($$;%) {
  my $class = shift;
  my $self = bless {}, $class;
  my $body = shift;
  $self->_init (@_);
  my $b = $self->{boundary};
  my $nl = "\x0D\x0A";
  unless ($self->{option}->{linebreak_strict}) {
    $nl = Message::Util::decide_newline ($body);
  }
  if (length $b) {
    $body = $nl . $body if $body =~ /^--\Q$b\E[\x09\x20]*$nl/s;
    $self->{value} = [ split /$nl--\Q$b\E[\x09\x20]*$nl/s, $body ];
    $self->{preamble} = shift (@{ $self->{value} });
    if (length $self->{value}->[-1]) {
      my @p = split /$nl--\Q$b\E--[\x09\x20]*(?:$nl)?/s, $self->{value}->[-1], 2;
      $self->{value}->[-1] = $p[0];
      $self->{epilogue} = $p[1];
    }
  } else {
    $self->{preamble} = $body;
  }
  if ($self->{option}->{parse_all}) {
    $self->{value} = [ map {
      $self->_parse_value (body_part => $_);
    } @{ $self->{value} } ];
    $self->{preamble} = $self->_parse_value (preamble => $self->{preamble});
    $self->{epilogue} = $self->_parse_value (epilogue => $self->{epilogue});
  }
  $self;
}

=back

=item $obj = $mp->item ($index, %options)

Returns the C<$index>th part as a MIME message object. 
If C<$index> is equal to or greater than the number of 
body parts this multipart body contains, then a new 
part is inserted to the last of the message and it is returned. 
Note that it does not necessariliy has the index of C<$index>. 

Use semantically named methods such as C<control_part> if
the multipart type makes some assumption for the structure of 
the multipart body.  For example, extracting the signature
part from a C<multipart/signature> body, then the 
C<control_part> method is preferred to the method call C<item (0)>.

=item $num = $mp->count

Returns the number of body parts contained in this multipart body.

=cut

## add, item, delete, count

## item-by?, \$checked-item, {item-key => 1}, \%option
sub _item_match ($$\$\%\%) {
  my $self = shift;
  my ($by, $i, $list, $option) = @_;
  return 0 unless ref $$i;  ## Already removed
  if ($by eq 'content-type') {
    $$i = $self->_parse_value (body_part => $$i);
    return 1 if ref $$i && $$list{$$i->content_type};
  } elsif ($by eq 'content-id') {
    $$i = $self->_parse_value (body_part => $$i);
    return 1 if ref $$i && ( $$list{$$i->id} || $$list{'<'.$$i->id.'>'} );
  }
  0;
}
*_delete_match = \&_item_match;

## Returns returned item value    \$item-value, \%option
sub _item_return_value ($\$\%) {
  unless (ref ${$_[1]}) {
    ${$_[1]} = $_[0]->_parse_value (body_part => ${$_[1]})
      if $_[2]->{parse};
  }
  ${$_[1]};
}
*_add_return_value = \&_item_return_value;

## Returns returned (new created) item value    $name, \%option
sub _item_new_value ($$\%) {
  my $v = shift->_parse_value (body_part => '');
  my ($key, $option) = @_;
  if ($option->{by} eq 'content-type') {
    $v->header->field ('content-type')->media_type ($key);
  } elsif ($option->{by} eq 'content-id') {
    $v->header->add ('content-id' => $key);
  }
  $v;
}

sub data_part ($;%) {
  my $self = shift;
  my %option = @_;
  $option{-by} = 'index';
  my $st = $self->{option}->{media_subtype};
  if ($st eq 'signed' || $st eq 'appledouble') {
    $self->item (0, @_);
  } elsif ($st eq 'encrypted') {
    $self->item (1, @_);
  } else {
    my $msg = qq{data_part: This method is not supported for $self->{option}->{media_type}/$st};
    if ($option{-dont_croak}) {
      Carp::carp $msg;
    } else {
      Carp::croak $msg;
    }
  }
}

sub control_part ($;%) {
  my $self = shift;
  my %option = @_;
  $option{-by} = 'index';
  my $st = $self->{option}->{media_subtype};
  if ($st eq 'signed' || $st eq 'appledouble') {
    $self->item (1, @_);
  } elsif ($st eq 'encrypted') {
    $self->item (0, @_);
  } else {
    my $msg = qq{control_part: This method is not supported for $self->{option}->{media_type}/$st};
    if ($option{-dont_croak}) {
      Carp::carp $msg;
    } else {
      Carp::croak $msg;
    }
  }
}

sub _add_array_check ($$\%) {
  my $self = shift;
  my ($value, $option) = @_;
  my $value_option = {};
  if (ref $value eq 'ARRAY') {
    ($value, %$value_option) = @$value;
  }
  $value = $self->_parse_value (body_part => $value) if $$option{parse};
  $$option{parse} = 0;
  (1, value => $value);
}

## entity_header: Inherited

sub preamble ($;$) {
  my $self = shift;
  my $np = shift;
  if (defined $np) {
    $np = $self->_parse_value (preamble => $np) if $self->{option}->{parse_all};
    $self->{preamble} = $np;
  }
  $self->{preamble};
}
sub epilogue ($;$) {
  my $self = shift;
  my $np = shift;
  if (defined $np) {
    $np = $self->_parse_value (epilogue => $np) if $self->{option}->{parse_all};
    $self->{epilogue} = $np;
  }
  $self->{epilogue};
}

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

Returns the C<body> as a string.

=cut

sub stringify ($;%) {
  my $self = shift;
  my %o = @_;  my %option = %{$self->{option}};
  for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
  $self->_delete_empty;
  ## Check the number of parts
    my $min = $option{parts_min} || 1;  $min--;
    $#{ $self->{value} } = $min unless $min <= $#{ $self->{value} };
    my $max = $option{parts_max} || $#{$self->{value}}+1;  $max--;
    $max = $#{$self->{value}} if $max > $#{$self->{value}};
  ## Media type parameters
    my $ct;     ## Content-Type field of parent entity
    if (ref $self->{header}) {
      $ct = $self->{header}->field ('content-type');
      my $mt = $ct->media_type;
      if ($mt eq 'multipart/signed') {
        $ct->replace (protocol => scalar $self->item (1, -by => 'index')->content_type);
      } elsif ($mt eq 'multipart/encrypted') {
        $ct->replace (protocol => scalar $self->item (0, -by => 'index')->content_type);
      } elsif ($mt eq 'multipart/report') {
        $ct->replace ('report-type' => ($self->item (1, -by => 'index')->content_type) [1]);
      }
    }
  ## Preparates parts
    my @parts = map { ''. $_ } @{$self->{value}}[0..$max];
  ## Boundary
    my $b = $self->{boundary};
    if ($b =~ $REG{NON_bchars} || length ($b) > 70) {
      undef $b;
    } elsif (substr ($b, -1, 1) eq "\x20") {
      $b .= 'B';
    }
    my $blength = 35;
    $b ||= $self->_generate_boundary ($blength);
    my $i = 1; while ($i++) {
      my @t = grep {/\Q--$b\E/} (@parts, $self->{preamble}, $self->{epilogue});
      last if @t == 0;
      $b = $self->_generate_boundary ($blength);
      if ($i > @BCHARS ** $blength) {
        $blength++; $i = 1;
      }
    }
    if (ref $ct) {
      $ct->replace (boundary => $b);
    }
  
  $self->{preamble}."\x0D\x0A--".$b."\x0D\x0A".
  join ("\x0D\x0A--".$b."\x0D\x0A", @parts)
  ."\x0D\x0A--$b--\x0D\x0A".
  ($option{output_epilogue}? $self->{epilogue}: '');
}
*as_string = \&stringify;

## Inherited: option, clone

## $self->_option_recursive (\%argv)
sub _option_recursive ($\%) {
  my $self = shift;
  my $o = shift;
  for (@{$self->{value}}) {
    $_->option (%$o) if ref $_;
  }
  $self->{preamble}->option (%$o) if ref $self->{preamble};
  $self->{epilogue}->option (%$o) if ref $self->{epilogue};
}

sub _generate_boundary ($$) {
  my $self = shift;
  my $blength = shift || 45;    ## Length of boundary
  join('', map($BCHARS[rand @BCHARS], 1..$blength));
}

=head1 SEE ALSO

RFC 2046 <urn:ietf:rfc:2046>

SuikaWiki:multipart/*

=head1 LICENSE

Copyright 2002-2005 Wakaba <w@suika.fam.cx>.  All rights reserved.

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.

=cut

1; # $Date:$

1
2	=head1 NAME
3
4	Message::Body::Multipart - MIME Multipart Body for Internet Messages
5
6	=head1 DESCRIPTION
7
8	This module provides a support for C<multipart/*> Internet Media Types.
9	With this module, each multipart body part can be treated
10	as for standalone MIME messages. It also provides the access
11	to prologue and epilogue.
12
13	This module is part of manakai, a Perl library for Internet messages.
14
15	=cut
16
17	package Message::Body::Multipart;
18	use strict;
19	use vars qw(%DEFAULT @ISA $VERSION);
20	$VERSION=do{my @r=(q$Revision: 1.7 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
21
22	require Message::Body::Text;
23	push @ISA, qw(Message::Body::Text);
24
25	my @BCHARS = ('0'..'9', 'A'..'Z', 'a'..'z', qw#+ _ , - . / =#);
26	#my @BCHARS = ('0'..'9', 'A'..'Z', 'a'..'z', qw#' ( ) + _ , - . / : = ?#, ' '); ## RFC 2046
27	my %REG;
28	$REG{NON_bchars} = qr#[^0-9A-Za-z'()+_,-./:=?\x20]#;
29
30	%DEFAULT = (
31	## "#i" : only inherited from parent Entity and inherits to child Entity
32	-_ARRAY_NAME => 'value',
33	-_METHODS => [qw\|data_part control_part entity_header add delete count item preamble epilogue\|],
34	-_MEMBERS => [qw\|boundary preamble epilogue\|],
35	#i accept_cte
36	#i body_default_charset
37	#i body_default_charset_input
38	#i cte_default
39	-default_media_type => 'text',
40	-default_media_subtype => 'plain',
41	-linebreak_strict => 0,
42	-media_type => 'multipart',
43	-media_subtype => 'mixed',
44	#output_epilogue
45	-parse_all => 0,
46	-parts_min => 1,
47	-parts_max => 0,
48	#i text_coderange
49	#use_normalization => 0,
50	#use_param_charset => 0,
51	-value_type => {},
52	);
53
54	=head1 CONSTRUCTORS
55
56	The following methods construct new objects:
57
58	=over 4
59
60	=cut
61
62	## Initialize of this class -- called by constructors
63	sub _init ($;%) {
64	my $self = shift;
65	my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
66	my %option = @_;
67	$self->SUPER::_init (%$DEFAULT, %option);
68
69	unless (defined $self->{option}->{output_epilogue}) {
70	$self->{option}->{output_epilogue} = $self->{option}->{format} !~ /http/;
71	}
72	$self->{option}->{value_type}->{body_part}->[1]->{-format}
73	=
74	my @ilist = qw/accept_coderange body_default_charset body_default_charset_input cte_default text_coderange/;
75	$self->{option}->{value_type}->{preamble} = sub {
76	my $phdr = new Message::Header -format => 'mail-rfc822';
77	my $ct = '';
78	$ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0) if ref $self->{header};
79	$ct = $ct->item ('x-preamble-type', -new_item_unless_exist => 0) if ref $ct;
80	$phdr->add ('content-type' => $ct) if $ct;
81	['Message::Body::TextPlain',
82	{-media_type => 'text', -media_subtype => '/multipart-preamble',
83	entity_header => $phdr},
84	\@ilist]};
85	$self->{option}->{value_type}->{body_part} = sub {['Message::Entity',
86	{-format => $_[0]->{option}->{format} . '/' . 'mime-entity',
87	-body_default_media_type => $_[0]->{option}->{default_media_type},
88	-body_default_media_subtype => $_[0]->{option}->{default_media_subtype}},
89	\@ilist]};
90	$self->{option}->{value_type}->{epilogue} = sub {
91	my $phdr = new Message::Header -format => 'mail-rfc822';
92	my $ct = '';
93	$ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0) if ref $self->{header};
94	$ct = $ct->item ('x-epilogue-type', -new_item_unless_exist => 0) if ref $ct;
95	$phdr->add ('content-type' => $ct) if $ct;
96	['Message::Body::TextPlain',
97	{-media_type => 'text', -media_subtype => '/multipart-epilogue',
98	entity_header => $phdr},
99	\@ilist]};
100
101	$self->{boundary} = $option{boundary};
102	if (!length $self->{boundary} && ref $self->{header}) {
103	my $ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0);
104	$self->{boundary} = $ct->parameter ('boundary', -new_item_unless_exist => 0)
105	if ref $ct;
106	}
107
108	my $mst = $self->{option}->{media_subtype};
109	if ($mst eq 'report') {
110	$self->{option}->{parts_min} = 2;
111	$self->{option}->{parts_max} = 3;
112	} elsif ($mst eq 'signed' \|\| $mst eq 'encrypted' \|\| $mst eq 'appledouble') {
113	$self->{option}->{parts_min} = 2;
114	$self->{option}->{parts_max} = 2;
115	} elsif ($mst eq 'headerset') {
116	$self->{option}->{parts_min} = 2;
117	}
118	}
119
120	=item $body = Message::Body::Multipart->new ([%options])
121
122	Constructs a new object. You might pass some options as parameters
123	to the constructor.
124
125	=cut
126
127	## Inherited
128
129	=item $body = Message::Body::Multipart->parse ($body, [%options])
130
131	Constructs a new object with given field body. You might pass
132	some options as parameters to the constructor.
133
134	=cut
135
136	sub parse ($$;%) {
137	my $class = shift;
138	my $self = bless {}, $class;
139	my $body = shift;
140	$self->_init (@_);
141	my $b = $self->{boundary};
142	my $nl = "\x0D\x0A";
143	unless ($self->{option}->{linebreak_strict}) {
144	$nl = Message::Util::decide_newline ($body);
145	}
146	if (length $b) {
147	$body = $nl . $body if $body =~ /^--\Q$b\E[\x09\x20]*$nl/s;
148	$self->{value} = [ split /$nl--\Q$b\E[\x09\x20]*$nl/s, $body ];
149	$self->{preamble} = shift (@{ $self->{value} });
150	if (length $self->{value}->[-1]) {
151	my @p = split /$nl--\Q$b\E--[\x09\x20]*(?:$nl)?/s, $self->{value}->[-1], 2;
152	$self->{value}->[-1] = $p[0];
153	$self->{epilogue} = $p[1];
154	}
155	} else {
156	$self->{preamble} = $body;
157	}
158	if ($self->{option}->{parse_all}) {
159	$self->{value} = [ map {
160	$self->_parse_value (body_part => $_);
161	} @{ $self->{value} } ];
162	$self->{preamble} = $self->_parse_value (preamble => $self->{preamble});
163	$self->{epilogue} = $self->_parse_value (epilogue => $self->{epilogue});
164	}
165	$self;
166	}
167
168	=back
169
170	=item $obj = $mp->item ($index, %options)
171
172	Returns the C<$index>th part as a MIME message object.
173	If C<$index> is equal to or greater than the number of
174	body parts this multipart body contains, then a new
175	part is inserted to the last of the message and it is returned.
176	Note that it does not necessariliy has the index of C<$index>.
177
178	Use semantically named methods such as C<control_part> if
179	the multipart type makes some assumption for the structure of
180	the multipart body. For example, extracting the signature
181	part from a C<multipart/signature> body, then the
182	C<control_part> method is preferred to the method call C<item (0)>.
183
184	=item $num = $mp->count
185
186	Returns the number of body parts contained in this multipart body.
187
188	=cut
189
190	## add, item, delete, count
191
192	## item-by?, \$checked-item, {item-key => 1}, \%option
193	sub _item_match ($$\$\%\%) {
194	my $self = shift;
195	my ($by, $i, $list, $option) = @_;
196	return 0 unless ref $$i; ## Already removed
197	if ($by eq 'content-type') {
198	$$i = $self->_parse_value (body_part => $$i);
199	return 1 if ref $$i && $$list{$$i->content_type};
200	} elsif ($by eq 'content-id') {
201	$$i = $self->_parse_value (body_part => $$i);
202	return 1 if ref $$i && ( $$list{$$i->id} \|\| $$list{'<'.$$i->id.'>'} );
203	}
204	0;
205	}
206	*_delete_match = \&_item_match;
207
208	## Returns returned item value \$item-value, \%option
209	sub _item_return_value ($\$\%) {
210	unless (ref ${$_[1]}) {
211	${$_[1]} = $_[0]->_parse_value (body_part => ${$_[1]})
212	if $_[2]->{parse};
213	}
214	${$_[1]};
215	}
216	*_add_return_value = \&_item_return_value;
217
218	## Returns returned (new created) item value $name, \%option
219	sub _item_new_value ($$\%) {
220	my $v = shift->_parse_value (body_part => '');
221	my ($key, $option) = @_;
222	if ($option->{by} eq 'content-type') {
223	$v->header->field ('content-type')->media_type ($key);
224	} elsif ($option->{by} eq 'content-id') {
225	$v->header->add ('content-id' => $key);
226	}
227	$v;
228	}
229
230	sub data_part ($;%) {
231	my $self = shift;
232	my %option = @_;
233	$option{-by} = 'index';
234	my $st = $self->{option}->{media_subtype};
235	if ($st eq 'signed' \|\| $st eq 'appledouble') {
236	$self->item (0, @_);
237	} elsif ($st eq 'encrypted') {
238	$self->item (1, @_);
239	} else {
240	my $msg = qq{data_part: This method is not supported for $self->{option}->{media_type}/$st};
241	if ($option{-dont_croak}) {
242	Carp::carp $msg;
243	} else {
244	Carp::croak $msg;
245	}
246	}
247	}
248
249	sub control_part ($;%) {
250	my $self = shift;
251	my %option = @_;
252	$option{-by} = 'index';
253	my $st = $self->{option}->{media_subtype};
254	if ($st eq 'signed' \|\| $st eq 'appledouble') {
255	$self->item (1, @_);
256	} elsif ($st eq 'encrypted') {
257	$self->item (0, @_);
258	} else {
259	my $msg = qq{control_part: This method is not supported for $self->{option}->{media_type}/$st};
260	if ($option{-dont_croak}) {
261	Carp::carp $msg;
262	} else {
263	Carp::croak $msg;
264	}
265	}
266	}
267
268	sub _add_array_check ($$\%) {
269	my $self = shift;
270	my ($value, $option) = @_;
271	my $value_option = {};
272	if (ref $value eq 'ARRAY') {
273	($value, %$value_option) = @$value;
274	}
275	$value = $self->_parse_value (body_part => $value) if $$option{parse};
276	$$option{parse} = 0;
277	(1, value => $value);
278	}
279
280	## entity_header: Inherited
281
282	sub preamble ($;$) {
283	my $self = shift;
284	my $np = shift;
285	if (defined $np) {
286	$np = $self->_parse_value (preamble => $np) if $self->{option}->{parse_all};
287	$self->{preamble} = $np;
288	}
289	$self->{preamble};
290	}
291	sub epilogue ($;$) {
292	my $self = shift;
293	my $np = shift;
294	if (defined $np) {
295	$np = $self->_parse_value (epilogue => $np) if $self->{option}->{parse_all};
296	$self->{epilogue} = $np;
297	}
298	$self->{epilogue};
299	}
300
301	=head2 $self->stringify ([%option])
302
303	Returns the C<body> as a string.
304
305	=cut
306
307	sub stringify ($;%) {
308	my $self = shift;
309	my %o = @_; my %option = %{$self->{option}};
310	for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
311	$self->_delete_empty;
312	## Check the number of parts
313	my $min = $option{parts_min} \|\| 1; $min--;
314	$#{ $self->{value} } = $min unless $min <= $#{ $self->{value} };
315	my $max = $option{parts_max} \|\| $#{$self->{value}}+1; $max--;
316	$max = $#{$self->{value}} if $max > $#{$self->{value}};
317	## Media type parameters
318	my $ct; ## Content-Type field of parent entity
319	if (ref $self->{header}) {
320	$ct = $self->{header}->field ('content-type');
321	my $mt = $ct->media_type;
322	if ($mt eq 'multipart/signed') {
323	$ct->replace (protocol => scalar $self->item (1, -by => 'index')->content_type);
324	} elsif ($mt eq 'multipart/encrypted') {
325	$ct->replace (protocol => scalar $self->item (0, -by => 'index')->content_type);
326	} elsif ($mt eq 'multipart/report') {
327	$ct->replace ('report-type' => ($self->item (1, -by => 'index')->content_type) [1]);
328	}
329	}
330	## Preparates parts
331	my @parts = map { ''. $_ } @{$self->{value}}[0..$max];
332	## Boundary
333	my $b = $self->{boundary};
334	if ($b =~ $REG{NON_bchars} \|\| length ($b) > 70) {
335	undef $b;
336	} elsif (substr ($b, -1, 1) eq "\x20") {
337	$b .= 'B';
338	}
339	my $blength = 35;
340	$b \|\|= $self->_generate_boundary ($blength);
341	my $i = 1; while ($i++) {
342	my @t = grep {/\Q--$b\E/} (@parts, $self->{preamble}, $self->{epilogue});
343	last if @t == 0;
344	$b = $self->_generate_boundary ($blength);
345	if ($i > @BCHARS ** $blength) {
346	$blength++; $i = 1;
347	}
348	}
349	if (ref $ct) {
350	$ct->replace (boundary => $b);
351	}
352
353	$self->{preamble}."\x0D\x0A--".$b."\x0D\x0A".
354	join ("\x0D\x0A--".$b."\x0D\x0A", @parts)
355	."\x0D\x0A--$b--\x0D\x0A".
356	($option{output_epilogue}? $self->{epilogue}: '');
357	}
358	*as_string = \&stringify;
359
360	## Inherited: option, clone
361
362	## $self->_option_recursive (\%argv)
363	sub _option_recursive ($\%) {
364	my $self = shift;
365	my $o = shift;
366	for (@{$self->{value}}) {
367	$_->option (%$o) if ref $_;
368	}
369	$self->{preamble}->option (%$o) if ref $self->{preamble};
370	$self->{epilogue}->option (%$o) if ref $self->{epilogue};
371	}
372
373	sub _generate_boundary ($$) {
374	my $self = shift;
375	my $blength = shift \|\| 45; ## Length of boundary
376	join('', map($BCHARS[rand @BCHARS], 1..$blength));
377	}
378
379	=head1 SEE ALSO
380
381	RFC 2046 <urn:ietf:rfc:2046>
382
383	SuikaWiki:multipart/*
384
385	=head1 LICENSE
386
387	Copyright 2002-2005 Wakaba <w@suika.fam.cx>. All rights reserved.
388
389	This program is free software; you can redistribute it and/or modify
390	it under the terms of the GNU General Public License as published by
391	the Free Software Foundation; either version 2 of the License, or
392	(at your option) any later version.
393
394	This program is distributed in the hope that it will be useful,
395	but WITHOUT ANY WARRANTY; without even the implied warranty of
396	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
397	GNU General Public License for more details.
398
399	You should have received a copy of the GNU General Public License
400	along with this program; see the file COPYING. If not, write to
401	the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
402	Boston, MA 02111-1307, USA.
403
404	=cut
405
406	1; # $Date:$
407