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