Message/Body/Multipart.pm


=head1 NAME

Message::Body::Multipart --- Perl module
for "multipart/*" Internet Media Types

=cut

package Message::Body::Multipart;
use strict;
use vars qw(%DEFAULT @ISA $VERSION);
$VERSION=do{my @r=(q$Revision: 1.6 $=~/\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

=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>

=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/07/08 11:48:12 $

=cut

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