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	wakaba	1.1
2			=head1 NAME
3
4	wakaba	1.8	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	wakaba	1.1
15			=cut
16
17			package Message::Body::Multipart;
18			use strict;
19			use vars qw(%DEFAULT @ISA $VERSION);
20	wakaba	1.8	$VERSION=do{my @r=(q$Revision: 1.7 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
21	wakaba	1.1
22			require Message::Body::Text;
23			push @ISA, qw(Message::Body::Text);
24
25	wakaba	1.8	my @BCHARS = ('0'..'9', 'A'..'Z', 'a'..'z', qw#+ _ , - . / =#);
26	wakaba	1.1	#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	wakaba	1.4	-_METHODS => [qw\|data_part control_part entity_header add delete count item preamble epilogue\|],
34	wakaba	1.2	-_MEMBERS => [qw\|boundary preamble epilogue\|],
35	wakaba	1.1	#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	wakaba	1.4	-linebreak_strict => 0,
42	wakaba	1.1	-media_type => 'multipart',
43			-media_subtype => 'mixed',
44			#output_epilogue
45			-parse_all => 0,
46	wakaba	1.5	-parts_min => 1,
47			-parts_max => 0,
48	wakaba	1.1	#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	wakaba	1.7	$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	wakaba	1.1	$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	wakaba	1.7	$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	wakaba	1.1
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	wakaba	1.7	$self->{boundary} = $ct->parameter ('boundary', -new_item_unless_exist => 0)
105			if ref $ct;
106	wakaba	1.1	}
107	wakaba	1.5
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	wakaba	1.1	}
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	wakaba	1.4	my $nl = "\x0D\x0A";
143	wakaba	1.6	unless ($self->{option}->{linebreak_strict}) {
144	wakaba	1.4	$nl = Message::Util::decide_newline ($body);
145			}
146	wakaba	1.1	if (length $b) {
147	wakaba	1.4	$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	wakaba	1.1	if (length $self->{value}->[-1]) {
151	wakaba	1.4	my @p = split /$nl--\Q$b\E--[\x09\x20]*(?:$nl)?/s, $self->{value}->[-1], 2;
152	wakaba	1.1	$self->{value}->[-1] = $p[0];
153			$self->{epilogue} = $p[1];
154			}
155			} else {
156	wakaba	1.4	$self->{preamble} = $body;
157	wakaba	1.1	}
158			if ($self->{option}->{parse_all}) {
159	wakaba	1.4	$self->{value} = [ map {
160	wakaba	1.1	$self->_parse_value (body_part => $_);
161	wakaba	1.4	} @{ $self->{value} } ];
162	wakaba	1.1	$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	wakaba	1.8	=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	wakaba	1.1	=cut
189
190	wakaba	1.2	## 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	wakaba	1.4	${$_[1]} = $_[0]->_parse_value (body_part => ${$_[1]})
212			if $_[2]->{parse};
213	wakaba	1.2	}
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	wakaba	1.4	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	wakaba	1.2	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	wakaba	1.1	## entity_header: Inherited
281
282	wakaba	1.2	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	wakaba	1.1	=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	wakaba	1.5	$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	wakaba	1.1	}
349	wakaba	1.5	if (ref $ct) {
350			$ct->replace (boundary => $b);
351	wakaba	1.4	}
352	wakaba	1.5
353	wakaba	1.1	$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	wakaba	1.8	SuikaWiki:multipart/*
384
385	wakaba	1.1	=head1 LICENSE
386
387	wakaba	1.8	Copyright 2002-2005 Wakaba <w@suika.fam.cx>. All rights reserved.
388	wakaba	1.1
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	wakaba	1.8	=cut
405	wakaba	1.1
406	wakaba	1.8	1; # $Date:$
407	wakaba	1.1