/[suikacvs]/messaging/manakai/lib/Message/Body/Multipart.pm
Suika

Contents of /messaging/manakai/lib/Message/Body/Multipart.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations) (download)
Thu Jul 4 06:38:21 2002 UTC (22 years, 4 months ago) by wakaba
Branch: MAIN
Changes since 1.4: +55 -29 lines
2002-07-04  Wakaba <w@suika.fam.cx>

	* Util.pm (encode_printable_string, decode_printable_string,
	encode_t71_string, decode_t71_string, encode_restricted_rfc822,
	decode_restricted_rfc822): New functions.

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;

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24