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.1 $=~/\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|entity_header|],
  -_MEMBERS     => [qw|boundary|],
  #i accept_cte
  #i body_default_charset
  #i body_default_charset_input
  #i cte_default
  -default_media_type   => 'text',
  -default_media_subtype        => 'plain',
  -media_type   => 'multipart',
  -media_subtype        => 'mixed',
  #output_epilogue
  -parse_all    => 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} = ['Message::Body::TextPlain',
    {-media_type => 'text', -media_subtype => '/multipart-preamble'},
    \@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} = ['Message::Body::TextPlain',
    {-media_type => 'text', -media_subtype => '/multipart-epilogue'},
    \@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') if ref $ct;
  }
}

=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};
  if (length $b) {
    $self->{value} = [ split /\x0D\x0A--\Q$b\E[\x09\x20]*\x0D\x0A/, $body ];
    if (length $self->{value}->[0]) {
      my @p = split /(?:\x0D\x0A)?--\Q$b\E[\x09\x20]*\x0D\x0A/, $self->{value}->[0], 2;
      $self->{preamble} = $p[0];
      if (length $p[1]) {
        $self->{value}->[0] = $p[1];
      } else { shift (@{$self->{value}}) }
    }
    if (length $self->{value}->[-1]) {
      my @p = split /\x0D\x0A--\Q$b\E--[\x09\x20]*(?:\x0D\x0A)?/, $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

## entity_header: Inherited

=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{$_}}
  my $max = $option{max} || $#{$self->{value}}+1;  $max--;
  $max = $#{$self->{value}} if $max > $#{$self->{value}};
  my @parts = map { ''. $_ } @{$self->{value}}[0..$max];
  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 = 45;
  $b ||= $self->_generate_boundary ($blength);
  my $i = 1; while ($i++) {
    my @t = grep {/\Q--$b\E/} @parts;
    last if @t == 0;
    $b = $self->_generate_boundary ($blength);
    if ($i > @BCHARS ** $blength) {
      $blength++; $i = 1;
    }
  }
  if (ref $self->{header}) {
    $self->{header}->field ('content-type')->parameter (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/03/13 15:10:21 $

=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			$VERSION=do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13
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			-_METHODS => [qw\|entity_header\|],
26			-_MEMBERS => [qw\|boundary\|],
27			#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			-media_type => 'multipart',
34			-media_subtype => 'mixed',
35			#output_epilogue
36			-parse_all => 0,
37			#i text_coderange
38			#use_normalization => 0,
39			#use_param_charset => 0,
40			-value_type => {},
41			);
42
43			=head1 CONSTRUCTORS
44
45			The following methods construct new objects:
46
47			=over 4
48
49			=cut
50
51			## Initialize of this class -- called by constructors
52			sub _init ($;%) {
53			my $self = shift;
54			my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
55			my %option = @_;
56			$self->SUPER::_init (%$DEFAULT, %option);
57
58			unless (defined $self->{option}->{output_epilogue}) {
59			$self->{option}->{output_epilogue} = $self->{option}->{format} !~ /http/;
60			}
61			$self->{option}->{value_type}->{body_part}->[1]->{-format}
62			=
63			my @ilist = qw/accept_coderange body_default_charset body_default_charset_input cte_default text_coderange/;
64			$self->{option}->{value_type}->{preamble} = ['Message::Body::TextPlain',
65			{-media_type => 'text', -media_subtype => '/multipart-preamble'},
66			\@ilist];
67			$self->{option}->{value_type}->{body_part} = sub {['Message::Entity',
68			{-format => $_[0]->{option}->{format} . '/' . 'mime-entity',
69			-body_default_media_type => $_[0]->{option}->{default_media_type},
70			-body_default_media_subtype => $_[0]->{option}->{default_media_subtype}},
71			\@ilist]};
72			$self->{option}->{value_type}->{epilogue} = ['Message::Body::TextPlain',
73			{-media_type => 'text', -media_subtype => '/multipart-epilogue'},
74			\@ilist];
75
76			$self->{boundary} = $option{boundary};
77			if (!length $self->{boundary} && ref $self->{header}) {
78			my $ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0);
79			$self->{boundary} = $ct->parameter ('boundary') if ref $ct;
80			}
81			}
82
83			=item $body = Message::Body::Multipart->new ([%options])
84
85			Constructs a new object. You might pass some options as parameters
86			to the constructor.
87
88			=cut
89
90			## Inherited
91
92			=item $body = Message::Body::Multipart->parse ($body, [%options])
93
94			Constructs a new object with given field body. You might pass
95			some options as parameters to the constructor.
96
97			=cut
98
99			sub parse ($$;%) {
100			my $class = shift;
101			my $self = bless {}, $class;
102			my $body = shift;
103			$self->_init (@_);
104			my $b = $self->{boundary};
105			if (length $b) {
106			$self->{value} = [ split /\x0D\x0A--\Q$b\E[\x09\x20]*\x0D\x0A/, $body ];
107			if (length $self->{value}->[0]) {
108			my @p = split /(?:\x0D\x0A)?--\Q$b\E[\x09\x20]*\x0D\x0A/, $self->{value}->[0], 2;
109			$self->{preamble} = $p[0];
110			if (length $p[1]) {
111			$self->{value}->[0] = $p[1];
112			} else { shift (@{$self->{value}}) }
113			}
114			if (length $self->{value}->[-1]) {
115			my @p = split /\x0D\x0A--\Q$b\E--[\x09\x20]*(?:\x0D\x0A)?/, $self->{value}->[-1], 2;
116			$self->{value}->[-1] = $p[0];
117			$self->{epilogue} = $p[1];
118			}
119			} else {
120			$self->{preamble} = [ $body ];
121			}
122			if ($self->{option}->{parse_all}) {
123			$self->{value} = [map {
124			$self->_parse_value (body_part => $_);
125			} @{$self->{value}}];
126			$self->{preamble} = $self->_parse_value (preamble => $self->{preamble});
127			$self->{epilogue} = $self->_parse_value (epilogue => $self->{epilogue});
128			}
129			$self;
130			}
131
132			=back
133
134			=cut
135
136			## entity_header: Inherited
137
138			=head2 $self->stringify ([%option])
139
140			Returns the C<body> as a string.
141
142			=cut
143
144			sub stringify ($;%) {
145			my $self = shift;
146			my %o = @_; my %option = %{$self->{option}};
147			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
148			my $max = $option{max} \|\| $#{$self->{value}}+1; $max--;
149			$max = $#{$self->{value}} if $max > $#{$self->{value}};
150			my @parts = map { ''. $_ } @{$self->{value}}[0..$max];
151			my $b = $self->{boundary};
152			if ($b =~ $REG{NON_bchars} \|\| length ($b) > 70) {
153			undef $b;
154			} elsif (substr ($b, -1, 1) eq "\x20") {
155			$b .= 'B';
156			}
157			my $blength = 45;
158			$b \|\|= $self->_generate_boundary ($blength);
159			my $i = 1; while ($i++) {
160			my @t = grep {/\Q--$b\E/} @parts;
161			last if @t == 0;
162			$b = $self->_generate_boundary ($blength);
163			if ($i > @BCHARS ** $blength) {
164			$blength++; $i = 1;
165			}
166			}
167			if (ref $self->{header}) {
168			$self->{header}->field ('content-type')->parameter (boundary => $b);
169			}
170			$self->{preamble}."\x0D\x0A--".$b."\x0D\x0A".
171			join ("\x0D\x0A--".$b."\x0D\x0A", @parts)
172			."\x0D\x0A--$b--\x0D\x0A".
173			($option{output_epilogue}? $self->{epilogue}: '');
174			}
175			*as_string = \&stringify;
176
177			## Inherited: option, clone
178
179			## $self->_option_recursive (\%argv)
180			sub _option_recursive ($\%) {
181			my $self = shift;
182			my $o = shift;
183			for (@{$self->{value}}) {
184			$_->option (%$o) if ref $_;
185			}
186			$self->{preamble}->option (%$o) if ref $self->{preamble};
187			$self->{epilogue}->option (%$o) if ref $self->{epilogue};
188			}
189
190			sub _generate_boundary ($$) {
191			my $self = shift;
192			my $blength = shift \|\| 45; ## Length of boundary
193			join('', map($BCHARS[rand @BCHARS], 1..$blength));
194			}
195
196			=head1 SEE ALSO
197
198			RFC 2046 <urn:ietf:rfc:2046>
199
200			=head1 LICENSE
201
202			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
203
204			This program is free software; you can redistribute it and/or modify
205			it under the terms of the GNU General Public License as published by
206			the Free Software Foundation; either version 2 of the License, or
207			(at your option) any later version.
208
209			This program is distributed in the hope that it will be useful,
210			but WITHOUT ANY WARRANTY; without even the implied warranty of
211			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
212			GNU General Public License for more details.
213
214			You should have received a copy of the GNU General Public License
215			along with this program; see the file COPYING. If not, write to
216			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
217			Boston, MA 02111-1307, USA.
218
219			=head1 CHANGE
220
221			See F<ChangeLog>.
222			$Date: 2002/03/13 15:10:21 $
223
224			=cut
225
226			1;