1 |
|
2 |
=head1 NAME
|
3 |
|
4 |
Message::Entity Perl module
|
5 |
|
6 |
=head1 DESCRIPTION
|
7 |
|
8 |
Perl module for RFC 822/2822 C<message>.
|
9 |
MIME multipart will be also supported (but not implemented yet).
|
10 |
|
11 |
=cut
|
12 |
|
13 |
require 5.6.0; ## (require: v5.6.0 data type)
|
14 |
package Message::Entity;
|
15 |
use strict;
|
16 |
use vars qw(%DEFAULT %REG $VERSION);
|
17 |
$VERSION=do{my @r=(q$Revision: 1.39 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
|
18 |
|
19 |
require Message::Util;
|
20 |
require Message::Header;
|
21 |
require Message::MIME::MediaType;
|
22 |
require Message::MIME::Encoding;
|
23 |
use overload '""' => sub { $_[0]->stringify },
|
24 |
fallback => 1;
|
25 |
*REG = \%Message::Util::REG;
|
26 |
|
27 |
## Initialize of this class -- called by constructors
|
28 |
%DEFAULT = (
|
29 |
-_METHODS => [qw|header body content_type id|],
|
30 |
-_MEMBERS => [qw|header body _cte|],
|
31 |
## entity_header -- Don't clone.
|
32 |
-accept_coderange => '7bit', ## 7bit / 8bit / binary
|
33 |
-body_default_charset => 'iso-2022-int-1',
|
34 |
-body_default_charset_input => 'iso-2022-int-1',
|
35 |
-body_default_media_type => 'text',
|
36 |
-body_default_media_subtype => 'plain',
|
37 |
-cte_default => '7bit',
|
38 |
-fill_missing_fields => 1,
|
39 |
#add_ua => 1,
|
40 |
#fill_date => 1,
|
41 |
-fill_date_name => 'date',
|
42 |
-fill_destination => 0,
|
43 |
#fill_destination_ns
|
44 |
#fill_destination_resent_ns
|
45 |
#fill_from_ns
|
46 |
-fill_md5 => 0,
|
47 |
-fill_md5_name => 'md5',
|
48 |
#fill_msgid => 1,
|
49 |
-fill_msgid_name => 'message-id',
|
50 |
#fill_sender_ns
|
51 |
-fill_source => 0,
|
52 |
-recalc_md5 => 1,
|
53 |
-force_mime_entity => 0,
|
54 |
-format => 'mail-rfc2822',
|
55 |
-guess_media_type => 1,
|
56 |
#internal_charset_name
|
57 |
-header_default_charset => 'iso-2022-int-1',
|
58 |
-header_default_charset_input => 'iso-2022-int-1',
|
59 |
-linebreak_strict => 0, ## BUG: not work perfectly
|
60 |
-output_magic_line => 1,
|
61 |
-parse_all => 0,
|
62 |
-remove_post_newline => 0,
|
63 |
-remove_pre_newline => 0,
|
64 |
-text_coderange => 'binary',
|
65 |
## '8bit' (MIME text/*) / 'binary' (HTTP text/*)
|
66 |
#ua_field_name => 'user-agent',
|
67 |
-ua_use_Config => 1,
|
68 |
-ua_use_Win32 => 1,
|
69 |
-uri_mailto_safe_level => 4,
|
70 |
-use_magic_line => 1,
|
71 |
);
|
72 |
sub _init ($;%) {
|
73 |
my $self = shift;
|
74 |
my %options = @_;
|
75 |
$self->{option} = {};
|
76 |
my $o = Message::Util::make_clone (\%DEFAULT);
|
77 |
for my $name (keys %$o) {
|
78 |
if (substr ($name, 0, 1) eq '-') {
|
79 |
$self->{option}->{substr ($name, 1)} = $$o{$name};
|
80 |
}
|
81 |
}
|
82 |
|
83 |
my @new_fields = ();
|
84 |
for my $name (keys %options) {
|
85 |
if (substr ($name, 0, 1) eq '-') {
|
86 |
$self->{option}->{substr ($name, 1)} = $options{$name};
|
87 |
} elsif ($name eq 'entity_header') {
|
88 |
$self->{entity_header} = $options{entity_header};
|
89 |
} else {
|
90 |
push @new_fields, ($name => $options{$name});
|
91 |
}
|
92 |
}
|
93 |
|
94 |
my $format = $self->{option}->{format};
|
95 |
my $ns822 = $Message::Header::NS_phname2uri{'x-rfc822'};
|
96 |
my $nshttp = $Message::Header::NS_phname2uri{'x-http'};
|
97 |
if ($format =~ /http/) {
|
98 |
$self->{option}->{fill_date_ns} = $nshttp unless defined $options{-fill_date_ns};
|
99 |
$self->{option}->{fill_from_ns} = $nshttp unless defined $options{-fill_from_ns};
|
100 |
$self->{option}->{fill_ua_ns} = $nshttp unless defined $options{-fill_ua_ns};
|
101 |
$self->{option}->{fill_source} = 0 unless defined $options{-fill_source};
|
102 |
$self->{option}->{accept_coderange} = 'binary';
|
103 |
$self->{option}->{text_coderange} = 'binary';
|
104 |
$self->{option}->{cte_default} = 'binary';
|
105 |
} else {
|
106 |
if ($format =~ /mail-rfc822|mail-rfc2822/ && $format !~ /mime-entity/) {
|
107 |
$self->{option}->{fill_destination} = 1;
|
108 |
$self->{option}->{fill_source} = 1 unless defined $options{-fill_source};
|
109 |
}
|
110 |
$self->{option}->{fill_date_ns} = $ns822 unless defined $options{-fill_date_ns};
|
111 |
$self->{option}->{fill_from_ns} = $ns822 unless defined $options{-fill_from_ns};
|
112 |
$self->{option}->{fill_ua_ns} = $ns822 unless defined $options{-fill_ua_ns};
|
113 |
$self->{option}->{text_coderange} = '8bit';
|
114 |
if ($format =~ /news-usefor|smtp-8bitmime/) {
|
115 |
$self->{option}->{accept_coderange} = '8bit';
|
116 |
} else {
|
117 |
$self->{option}->{accept_coderange} = '7bit';
|
118 |
}
|
119 |
}
|
120 |
for (qw/fill_msgid_ns fill_msgid_from fill_mimever_ns fill_destination_ns fill_sender_ns/) {
|
121 |
$self->{option}->{$_} = $ns822;
|
122 |
}
|
123 |
$self->{option}->{fill_destination_resent_ns} = $Message::Header::NS_phname2uri{'x-rfc822-resent'};
|
124 |
unless (defined $self->{option}->{fill_date}) {
|
125 |
$self->{option}->{fill_date} = $format !~ /mime-entity|cgi|uri-url-mailto/;
|
126 |
}
|
127 |
unless (defined $self->{option}->{fill_msgid}) {
|
128 |
$self->{option}->{fill_msgid} = $format !~ /mime-entity|http|uri-url-mailto/;
|
129 |
}
|
130 |
unless (defined $self->{option}->{fill_ct}) {
|
131 |
$self->{option}->{fill_ct} = $format !~ /http/;
|
132 |
}
|
133 |
unless (defined $self->{option}->{fill_mimever}) {
|
134 |
$self->{option}->{fill_mimever} = $format !~ /http|mime-entity/;
|
135 |
}
|
136 |
unless (defined $self->{option}->{add_ua}) {
|
137 |
$self->{option}->{add_ua} = $format !~ /mime-entity/;
|
138 |
}
|
139 |
unless ($self->{option}->{fill_ua_name}) {
|
140 |
$self->{option}->{fill_ua_name} = $format =~ /response|cgi|uri-url-mailto/?
|
141 |
'server': 'user-agent';
|
142 |
}
|
143 |
unless (defined $options{-output_magic_line}) {
|
144 |
$self->{option}->{output_magic_line} = 0
|
145 |
if $format =~ /mail|news|mime/;
|
146 |
}
|
147 |
@new_fields;
|
148 |
}
|
149 |
|
150 |
=head1 CONSTRUCTORS
|
151 |
|
152 |
The following methods construct new C<Message::Entity> objects:
|
153 |
|
154 |
=over 4
|
155 |
|
156 |
=item Message::Entity->new ([%initial-fields/options])
|
157 |
|
158 |
Constructs a new C<Message::Entity> object. You might pass some initial
|
159 |
C<field-name>-C<field-body> pairs and/or options as parameters to the constructor.
|
160 |
|
161 |
Example:
|
162 |
|
163 |
$msg = new Message::Entity
|
164 |
Content_Type => 'text/html',
|
165 |
X_URI => '<http://www.foo.example/>',
|
166 |
-format => 'mail-rfc2822' ## not to be header field
|
167 |
;
|
168 |
|
169 |
=cut
|
170 |
|
171 |
sub new ($;%) {
|
172 |
my $class = shift;
|
173 |
my $self = bless {}, $class;
|
174 |
my %new_field = $self->_init (@_);
|
175 |
if (defined $new_field{body}) {
|
176 |
$self->{body} = $new_field{body}; $new_field{body} = undef;
|
177 |
$self->{body} = $self->_parse_value ([$self->content_type] => $self->{body})
|
178 |
if $self->{option}->{parse_all};
|
179 |
}
|
180 |
$self->{header} = new Message::Header
|
181 |
-format => $self->{option}->{format},
|
182 |
-header_default_charset => $self->{option}->{header_default_charset},
|
183 |
-header_default_charset_input => $self->{option}->{header_default_charset_input},
|
184 |
-parse_all => $self->{option}->{parse_all}, %new_field;
|
185 |
$self;
|
186 |
}
|
187 |
|
188 |
=item Message::Entity->parse ($message, [%options])
|
189 |
|
190 |
Parses given C<message> (a message entity) and constructs a new C<Message::Entity>
|
191 |
object. You might pass some additional C<field-name>-C<field-body> pairs
|
192 |
or/and initial options as parameters to the constructor.
|
193 |
|
194 |
=cut
|
195 |
|
196 |
sub parse ($$;%) {
|
197 |
my $class = shift;
|
198 |
my $message = shift;
|
199 |
my $self = bless {}, $class;
|
200 |
my %new_field = $self->_init (@_);
|
201 |
my $nl = "\x0D\x0A";
|
202 |
unless ($self->{option}->{linebreak_strict}) {
|
203 |
$nl = Message::Util::decide_newline ($message);
|
204 |
}
|
205 |
my ($hdr, $body);
|
206 |
$message =~ s/^(?:$nl)+//s if $self->{option}->{remove_pre_newline};
|
207 |
$message =~ s/(?:$nl)+$/$nl/s if $self->{option}->{remove_post_newline};
|
208 |
if ($self->{option}->{use_magic_line}) {
|
209 |
## TODO: Reset format option?
|
210 |
if ($message =~ s/^>?From (.+?)$nl//os) { ## Mail from line
|
211 |
## TODO: Multiple from lines
|
212 |
$new_field{'x-rfc822-mail-from'} = $1;
|
213 |
} elsif ($message =~ s#^($REG{http_token})\x20($REG{S_uri})\x20($REG{http_token})/([0-9]+)\.([0-9]+)$nl##gs) {
|
214 |
## HTTP Request
|
215 |
($self->{http_method}, $self->{http_request_uri},
|
216 |
$self->{http_protocol_name}, $self->{http_protocol_version})
|
217 |
= ($1, $2, uc $3, pack ('U2', $4, $5));
|
218 |
} elsif ($message =~ s#^($REG{http_token})/([0-9]+)\.([0-9]+)\x20([0-9][0-9][0-9]\x20.*?)$nl##gs) {
|
219 |
## HTTP Response
|
220 |
($self->{http_protocol_name}, $self->{http_protocol_version})
|
221 |
= (uc $1, pack ('U2', $2, $3));
|
222 |
$new_field{'x-http-status'} = $4;
|
223 |
} elsif ($message =~ s#^($REG{http_token})\x20($REG{S_uri})$nl##gs) {
|
224 |
## HTTP/0.9 simple-request
|
225 |
($self->{http_method}, $self->{http_request_uri},
|
226 |
$self->{http_protocol_name}, $self->{http_protocol_version})
|
227 |
= ($1, $2, 'HTTP', v0.9);
|
228 |
$message = $nl . $message; ## Has no header fields
|
229 |
}
|
230 |
}
|
231 |
if ($message !~ s/^$nl//s) {
|
232 |
($hdr, $body) = split /$nl$nl/, $message, 2;
|
233 |
} else {
|
234 |
$hdr = ''; $body = $message;
|
235 |
$body =~ s/^$nl//s;
|
236 |
}
|
237 |
$new_field{body} = undef if $new_field{body};
|
238 |
## Is this implemention good?
|
239 |
$self->{header} = parse Message::Header $hdr,
|
240 |
-header_default_charset => $self->{option}->{header_default_charset},
|
241 |
-header_default_charset_input => $self->{option}->{header_default_charset_input},
|
242 |
-parse_all => $self->{option}->{parse_all},
|
243 |
-format => $self->{option}->{format},
|
244 |
%new_field; ## Additional header fields
|
245 |
|
246 |
$self->{body} = $body;
|
247 |
$self->{body} = $self->_parse_value ([ $self->content_type ] => $self->{body})
|
248 |
if $self->{option}->{parse_all};
|
249 |
$self;
|
250 |
}
|
251 |
|
252 |
=back
|
253 |
|
254 |
=head1 METHODS
|
255 |
|
256 |
=head2 $self->header ([$new_header])
|
257 |
|
258 |
Returns Message::Header unless $new_header.
|
259 |
Set $new_header instead of current C<header>.
|
260 |
If !ref $new_header, Message::Header->parse is automatically
|
261 |
called.
|
262 |
|
263 |
=cut
|
264 |
|
265 |
## TODO: to be compatible with HTTP::Message
|
266 |
sub header ($;$) {
|
267 |
my $self = shift;
|
268 |
my $new_header = shift;
|
269 |
if (ref $new_header) {
|
270 |
$self->{header} = $new_header;
|
271 |
} elsif ($new_header) {
|
272 |
$self->{header} = Message::Header->parse ($new_header,
|
273 |
-header_default_charset => $self->{option}->{header_default_charset},
|
274 |
-header_default_charset_input => $self->{option}->{header_default_charset_input},
|
275 |
-parse_all => $self->{option}->{parse_all},
|
276 |
-format => $self->{option}->{format});
|
277 |
}
|
278 |
unless (ref $self->{header} || length $self->{header}) {
|
279 |
$self->{header} = new Message::Header (
|
280 |
-header_default_charset => $self->{option}->{header_default_charset},
|
281 |
-header_default_charset_input => $self->{option}->{header_default_charset_input},
|
282 |
-parse_all => $self->{option}->{parse_all},
|
283 |
-format => $self->{option}->{format});
|
284 |
}
|
285 |
$self->{header};
|
286 |
}
|
287 |
|
288 |
=head2 $self->body ([$new_body])
|
289 |
|
290 |
Returns C<body> as string unless $new_body.
|
291 |
Set $new_body instead of current C<body>.
|
292 |
|
293 |
=cut
|
294 |
|
295 |
sub body ($;$) {
|
296 |
my $self = shift;
|
297 |
my $new_body = shift;
|
298 |
if ($new_body) {
|
299 |
$self->{body} = $new_body;
|
300 |
}
|
301 |
$self->{body} = $self->_parse_value ([$self->content_type] => $self->{body})
|
302 |
unless ref $self->{body};
|
303 |
$self->{body};
|
304 |
}
|
305 |
|
306 |
## [SG]et its entity header. This method is or can be used
|
307 |
## when Message::Entity is used as a body (such as message/rfc822).
|
308 |
sub entity_header ($;$) {
|
309 |
my $self = shift;
|
310 |
my $new_header = shift;
|
311 |
if (ref $new_header) {
|
312 |
$self->{entity_header} = $new_header;
|
313 |
}
|
314 |
$self->{entity_header};
|
315 |
}
|
316 |
|
317 |
## Note: If you once parse body (including parse_all => 1 option),
|
318 |
## it might make validation failed.
|
319 |
sub md5_check ($) {
|
320 |
my $self = shift;
|
321 |
my $md5f = $self->{header}->field ('content-md5', -new_item_unless_exist => 0);
|
322 |
my $md5; $md5 = $md5f->value if ref $md5f;
|
323 |
unless ($md5) {
|
324 |
Carp::carp "md5_check: MD5 checksum not found";
|
325 |
return undef;
|
326 |
}
|
327 |
my $MD5;
|
328 |
eval q{
|
329 |
require Digest::MD5;
|
330 |
$MD5 = ($self->Message::MIME::Encoding::encode_base64 (Digest::MD5::md5 ($self->{body})))[0];
|
331 |
$MD5 =~ tr/\x09\x0A\x0D\x20//d;
|
332 |
1} or Carp::croak $@;
|
333 |
return $MD5 eq $md5? 1 : 0;
|
334 |
}
|
335 |
|
336 |
## $self->_parse_value ($type, $value);
|
337 |
sub _parse_value ($$$) {
|
338 |
my $self = shift;
|
339 |
my ($mt,$mst) = @{ shift(@_) };
|
340 |
my $value = shift;
|
341 |
return $value if ref $value;
|
342 |
|
343 |
## decode
|
344 |
$value = $self->_decode_body ($value);
|
345 |
|
346 |
my $mt_def = $Message::MIME::MediaType::type{$mt}->{$mst};
|
347 |
$mt_def = $Message::MIME::MediaType::type{$mt}->{'/default'} unless ref $mt_def;
|
348 |
$mt_def = $Message::MIME::MediaType::type{'/default'}->{'/default'}
|
349 |
unless ref $mt_def;
|
350 |
my $handler = $mt_def->{handler}
|
351 |
|| $Message::MIME::MediaType::type{$mt}->{'/default'}->{handler}
|
352 |
|| $Message::MIME::MediaType::type{'/default'}->{'/default'}->{handler};
|
353 |
## Ummmmmm....
|
354 |
if (ref $handler eq 'CODE') {
|
355 |
$handler = &$handler ($self, $mt, $mst);
|
356 |
}
|
357 |
my $vtype = $handler->[0];
|
358 |
my %vopt = (
|
359 |
-format => $self->{option}->{format},
|
360 |
-linebreak_strict => $self->{option}->{linebreak_strict},
|
361 |
-media_type => $mt,
|
362 |
-media_subtype => $mst,
|
363 |
-parse_all => $self->{option}->{parse_all},
|
364 |
-body_default_charset => $self->{option}->{body_default_charset},
|
365 |
-body_default_charset_input => $self->{option}->{body_default_charset_input},
|
366 |
-internal_charset_name => $self->{option}->{internal_charset_name},
|
367 |
entity_header => $self->{header},
|
368 |
);
|
369 |
## Media type specified option/parameters
|
370 |
if (ref $handler->[1] eq 'HASH') {
|
371 |
for (keys %{$handler->[1]}) {
|
372 |
$vopt{$_} = ${$handler->[1]}{$_};
|
373 |
}
|
374 |
}
|
375 |
## Inherited options
|
376 |
if (ref $handler->[2] eq 'ARRAY') {
|
377 |
for (@{$handler->[2]}) {
|
378 |
$vopt{'-'.$_} = $self->{option}->{$_};
|
379 |
}
|
380 |
}
|
381 |
|
382 |
if ($vtype eq ':none:') {
|
383 |
return $value;
|
384 |
} elsif (defined $value) {
|
385 |
eval "require $vtype" or Carp::croak qq{<parse>: $vtype: Can't load package: $@};
|
386 |
return $vtype->parse ($value, %vopt);
|
387 |
} else {
|
388 |
eval "require $vtype" or Carp::croak qq{<parse>: $vtype: Can't load package: $@};
|
389 |
return $vtype->new (%vopt);
|
390 |
}
|
391 |
}
|
392 |
|
393 |
sub _decode_body ($$) {
|
394 |
my $self = shift;
|
395 |
my $value = shift;
|
396 |
## MIME CTE
|
397 |
my $cte = $self->{_cte} || '';
|
398 |
my $ctef = $self->header->field ('content-transfer-encoding',
|
399 |
-new_item_unless_exist => 0);
|
400 |
$cte = $ctef->value if ref $ctef;
|
401 |
my $f = $Message::MIME::Encoding::DECODER{$cte};
|
402 |
if (ref $f) {
|
403 |
($value, $cte) = &$f ($self, $value);
|
404 |
}
|
405 |
$self->{_cte} = $cte;
|
406 |
$value;
|
407 |
}
|
408 |
|
409 |
sub _encode_body ($$\%) {
|
410 |
my $self = shift;
|
411 |
my $value = shift;
|
412 |
my $option = shift;
|
413 |
## MIME CTE
|
414 |
my $current_cte = $self->{_cte} || 'binary';
|
415 |
my $ctef = $self->{header}->field ('content-transfer-encoding',
|
416 |
-new_item_unless_exist => 0);
|
417 |
my $cte = ''; $cte = lc $ctef->value if ref $ctef;
|
418 |
my %enoption;
|
419 |
## Get media type of entity body and its accept CTE list
|
420 |
my ($mt,$mst) = $self->content_type;
|
421 |
my $mt_def = $Message::MIME::MediaType::type{$mt}->{$mst};
|
422 |
$mt_def = $Message::MIME::MediaType::type{$mt}->{'/default'}
|
423 |
unless ref $mt_def;
|
424 |
$mt_def = $Message::MIME::MediaType::type{'/default'}->{'/default'}
|
425 |
unless ref $mt_def;
|
426 |
$enoption{mt_is_text} = 1
|
427 |
if $mt eq 'text' || $mt eq 'multipart' || $mt eq 'message';
|
428 |
$enoption{mt_is_text} = 1 if $mt_def->{text_content};
|
429 |
my ($charset, $charset_def) = '';
|
430 |
if ($mt_def->{mime_charset}) {
|
431 |
## If CT is able to have its charset parameter,
|
432 |
my $ct = $self->{header}->field ('content-type',
|
433 |
-new_item_unless_exist => 0);
|
434 |
$charset = $ct->parameter ('charset') if ref $ct;
|
435 |
if ($charset) {
|
436 |
$charset_def = $Message::MIME::Charset::CHARSET{$charset};
|
437 |
} else {
|
438 |
$charset_def = $Message::MIME::Charset::CHARSET{'*default'};
|
439 |
## Note: 'encoding_after_encode' option's value is hardcoded.
|
440 |
}
|
441 |
} else { ## Don't have mime style "charset" parameter
|
442 |
$charset_def = {mime_text => 1};
|
443 |
}
|
444 |
$charset_def = {} unless ref $charset_def; ## dummy
|
445 |
#if ($charset_def->{mime_text} != 1) { ## See also Note above
|
446 |
if (Message::MIME::Charset::is_mime_text ($charset || '*default') != 1) {
|
447 |
$enoption{mt_is_text} = 0 if $mt eq 'text';
|
448 |
my $ct = $self->{header}->field ('content-type');
|
449 |
$ct->not_mime_text ($option->{text_coderange} eq 'binary'? 0:1);
|
450 |
}
|
451 |
## If accept CTE list is defined,
|
452 |
for my $def ($charset_def, $mt_def) {
|
453 |
if (ref $def->{accept_cte} eq 'ARRAY') {
|
454 |
my $f = 1; for (@{$def->{accept_cte}}) {
|
455 |
if ($cte eq $_) {$f = 0; last}
|
456 |
}
|
457 |
if ($f) { ## If CTE is not accepted,
|
458 |
$cte = $def->{accept_cte}->[0];
|
459 |
}
|
460 |
}
|
461 |
}
|
462 |
if ($current_cte eq 'binary' || ($current_cte && $current_cte ne $cte)) {
|
463 |
my $de = $Message::MIME::Encoding::DECODER{$current_cte};
|
464 |
my $en = $Message::MIME::Encoding::ENCODER{$cte || 'binary'};
|
465 |
if (ref $de && ref $en) {
|
466 |
my ($e, $decoded);
|
467 |
($decoded, $e) = &$de ($self, $value);
|
468 |
## Check transparent coderange
|
469 |
my $cr = $self->Message::MIME::Encoding::decide_coderange
|
470 |
($decoded, \%enoption);
|
471 |
if ($option->{accept_coderange} eq '8bit') {
|
472 |
if ($cr eq 'binary') {
|
473 |
$cte = $charset_def->{cte_7bit_preferred}
|
474 |
|| $mt_def->{cte_7bit_preferred} || 'base64';
|
475 |
$en = $Message::MIME::Encoding::ENCODER{$cte};
|
476 |
}
|
477 |
} elsif ($option->{accept_coderange} eq '7bit') {
|
478 |
if ($cr eq 'binary' || $cr eq '8bit') {
|
479 |
$cte = $charset_def->{cte_7bit_preferred}
|
480 |
|| $mt_def->{cte_7bit_preferred} || 'base64';
|
481 |
$en = $Message::MIME::Encoding::ENCODER{$cte};
|
482 |
if ($mt eq 'message') {
|
483 |
my $ct = $self->{header}->field ('content-type');
|
484 |
$ct->not_mime_text ($option->{text_coderange} eq 'binary'? 0:1);
|
485 |
}
|
486 |
}
|
487 |
}
|
488 |
if ($e eq 'binary') {
|
489 |
($value, $e) = &$en ($self, $decoded, \%enoption);
|
490 |
$e = '' if ($e eq $option->{cte_default});
|
491 |
$e = '' if $e eq '7bit'
|
492 |
&& ( $option->{cte_default} eq '8bit'
|
493 |
|| $option->{cte_default} eq 'binary');
|
494 |
$e = '' if $e eq '8bit' && $option->{cte_default} eq 'binary';
|
495 |
if ($e) {
|
496 |
$ctef = $self->{header}->field ('content-transfer-encoding')
|
497 |
unless ref $ctef;
|
498 |
$ctef->value ($e);
|
499 |
} elsif (ref $ctef) {
|
500 |
$ctef->value ('');
|
501 |
}
|
502 |
} else {
|
503 |
$ctef = $self->{header}->field ('content-transfer-encoding')
|
504 |
unless ref $ctef;
|
505 |
$ctef->value ($current_cte);
|
506 |
}
|
507 |
} else { ## Can't encode by given CTE
|
508 |
$ctef = $self->{header}->field ('content-transfer-encoding')
|
509 |
unless ref $ctef;
|
510 |
$ctef->value ($current_cte);
|
511 |
}
|
512 |
}
|
513 |
if (ref $ctef && $ctef->value eq '') {
|
514 |
$self->{header}->delete ('content-transfer-encoding');
|
515 |
}
|
516 |
$value;
|
517 |
}
|
518 |
|
519 |
=head2 $self->stringify ([%option])
|
520 |
|
521 |
Returns the C<message> as a string.
|
522 |
|
523 |
=cut
|
524 |
|
525 |
sub stringify ($;%) {
|
526 |
my $self = shift;
|
527 |
my %params = @_;
|
528 |
my %option = %{$self->{option}};
|
529 |
for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
|
530 |
my ($header, $body, $body0);
|
531 |
if (ref $self->{body}) {
|
532 |
$self->{body}->entity_header ($self->{header});
|
533 |
$body0 = $self->{body}->stringify (-parent_format => $option{format},
|
534 |
-linebreak_strict => $option{linebreak_strict});
|
535 |
} else {
|
536 |
$body0 = $self->{body};
|
537 |
}
|
538 |
$body = $self->_encode_body ($body0, \%option);
|
539 |
if (ref $self->{header}) {
|
540 |
my $ns_content = $Message::Header::NS_phname2uri{content};
|
541 |
my $filler;
|
542 |
$filler = sub {
|
543 |
my ($hdr, $exist, $hdr_option) = @_;
|
544 |
## Date: (RFC 822, HTTP)
|
545 |
if ($option{fill_date}
|
546 |
&& !$exist->{$option{fill_date_name}.':'.$option{fill_date_ns}}) {
|
547 |
$hdr->field
|
548 |
($option{fill_date_name}, -ns => $option{fill_date_ns})->unix_time (time);
|
549 |
}
|
550 |
## Message-ID: (RFC 822)
|
551 |
if ($option{fill_msgid}
|
552 |
&& !$exist->{$option{fill_msgid_name}.':'.$option{fill_msgid_ns}}) {
|
553 |
my $from = $hdr->field
|
554 |
('from', -ns => $option{fill_msgid_from_ns}, -new_item_unless_exist => 0);
|
555 |
$from = $from->addr_spec if ref $from;
|
556 |
$hdr->field ($option{fill_msgid_name}, -ns => $option{fill_msgid_ns})
|
557 |
->generate (addr_spec => $from) if $from;
|
558 |
} # fill_msgid
|
559 |
## To:, CC:, BCC:, Resent-To:, Resent-Cc:, Resent-Bcc: (RFC 822)
|
560 |
if ($option{fill_destination}) {
|
561 |
if ( !$exist->{ 'to:'.$option{fill_destination_ns} }
|
562 |
&& !$exist->{ 'cc:'.$option{fill_destination_ns} }
|
563 |
&& !$exist->{ 'bcc:'.$option{fill_destination_ns} }
|
564 |
&& !$exist->{ 'to:'.$option{fill_destination_resent_ns} }
|
565 |
&& !$exist->{ 'cc:'.$option{fill_destination_resent_ns} }
|
566 |
&& !$exist->{ 'bcc:'.$option{fill_destination_resent_ns} } ) {
|
567 |
$hdr->add (bcc => '');
|
568 |
}
|
569 |
}
|
570 |
## From:, Sender:
|
571 |
if ($option{fill_source}) {
|
572 |
## From:
|
573 |
if (!$exist->{ 'from:'.$option{fill_from_ns} }) {
|
574 |
$hdr->add (from => 'Unknown source <foo@bar.invalid>',
|
575 |
-ns => $option{fill_from_ns});
|
576 |
## From: exists, Sender: not exist
|
577 |
} elsif (!$exist->{ 'sender:'.$option{fill_sender_ns} }) {
|
578 |
my $from = $hdr->field ('from', -ns => $option{fill_from_ns});
|
579 |
if ($from->count > 1) {
|
580 |
$hdr->field ('sender', -ns => $option{fill_sender_ns})
|
581 |
->add ($from->item (0, -by => 'index'));
|
582 |
}
|
583 |
}
|
584 |
}
|
585 |
## Content-MD5:
|
586 |
if (($option{fill_md5} && !$exist->{ $option{fill_md5_name} .':'. $ns_content})
|
587 |
|| ($option{recalc_md5} && $exist->{ $option{fill_md5_name} .':'. $ns_content})) {
|
588 |
my $md5;
|
589 |
eval q{
|
590 |
require Digest::MD5;
|
591 |
$md5 = ($self->Message::MIME::Encoding::encode_base64 (Digest::MD5::md5 ($body0)))[0];
|
592 |
$md5 =~ tr/\x09\x0A\x0D\x20//d;
|
593 |
1} or Carp::carp $@;
|
594 |
if ($md5) {
|
595 |
my $md5f = $hdr->field ($option{fill_md5_name}, -ns => $ns_content);
|
596 |
$md5f->value ($md5);
|
597 |
}
|
598 |
}
|
599 |
my $ismime = 0;
|
600 |
for (keys %$exist) {if (/:$ns_content$/) { $ismime = 1; last }}
|
601 |
unless ($ismime) {
|
602 |
$ismime = 1 if $option{force_mime_entity}
|
603 |
|| $option{fill_md5}
|
604 |
|| $option{body_default_media_type} ne 'text'
|
605 |
|| $option{body_default_media_subtype} ne 'plain';
|
606 |
}
|
607 |
if ($ismime) {
|
608 |
## Content-Type: (MIME, HTTP)
|
609 |
if ($option{fill_ct} && !$exist->{'type:'.$ns_content}) {
|
610 |
my $ct = $hdr->field ('type', -ns => $ns_content);
|
611 |
$ct->media_type ($option{body_default_media_type}.'/'
|
612 |
.$option{body_default_media_subtype});
|
613 |
$ct->replace (Message::MIME::Charset::name_minimumize ($option{body_default_charset} => $body0));
|
614 |
}
|
615 |
## MIME-Version: (MIME)
|
616 |
if ($option{fill_mimever}
|
617 |
&& !$exist->{'mime-version:'.$option{fill_mimever_ns}}) {
|
618 |
## BUG: doesn't support rfc1049, HTTP (ie. non-MIME) content-*: fields
|
619 |
$hdr->add ('mime-version' => '1.0',
|
620 |
-parse => 0, -ns => $option{fill_mimever_ns});
|
621 |
}
|
622 |
} # $ismime
|
623 |
## User-Agent: (USEFOR, HTTP)
|
624 |
if ($option{add_ua}) {
|
625 |
$hdr->field ($option{fill_ua_name})->add_our_name (
|
626 |
-use_Config => $option{ua_use_Config},
|
627 |
-use_Win32 => $option{ua_use_Win32},
|
628 |
-date => q$Date: 2002/12/28 09:10:16 $,
|
629 |
);
|
630 |
}
|
631 |
} if $option{fill_missing_fields};
|
632 |
|
633 |
if ($option{format} =~ /uri-url-mailto/
|
634 |
&& $self->{header}->field_exist ('type', -ns => $ns_content)
|
635 |
&& $option{uri_mailto_safe_level} > 1) {
|
636 |
$self->{header}->field ('type', -ns => $ns_content)->media_type ('text/plain');
|
637 |
}
|
638 |
$header = $self->{header}->stringify (
|
639 |
-format => $option{format},
|
640 |
-linebreak_strict => $option{linebreak_strict},
|
641 |
-uri_mailto_safe_level => $option{uri_mailto_safe_level},
|
642 |
($filler? (-hook_stringify_fill_fields => $filler) :()),
|
643 |
);
|
644 |
} else {
|
645 |
$header = $self->{header};
|
646 |
unless ($option{linebreak_strict}) {
|
647 |
## bare \x0D and bare \x0A are unsafe
|
648 |
$header =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;
|
649 |
$header =~ s/\x0A(?=[^\x09\x20])/\x0A\x20/g;
|
650 |
}
|
651 |
}
|
652 |
if ($option{format} =~ /uri-url-mailto/) {
|
653 |
if ($option{format} =~ /rfc1738/) {
|
654 |
my $to = $self->{header}->stringify (-format => $option{format},
|
655 |
-uri_mailto_safe_level => $option{uri_mailto_safe_level});
|
656 |
$to? 'mailto:'.$to: '';
|
657 |
} else {
|
658 |
my $f = $option{format}; $f =~ s/-mailto/-mailto-to/;
|
659 |
my $to = $self->{header}->stringify (-format => $f,
|
660 |
-uri_mailto_safe_level => $option{uri_mailto_safe_level});
|
661 |
$body =~ s/([^:@+\$A-Za-z0-9\-_.!~*])/sprintf('%%%02X', ord $1)/ge;
|
662 |
if (length $body) {
|
663 |
$header .= '&' if $header;
|
664 |
$header .= 'body='.$body;
|
665 |
}
|
666 |
$header = '?'.$header if $header;
|
667 |
$to||$header? 'mailto:'.$to.$header: '';
|
668 |
}
|
669 |
} else {
|
670 |
## Magic line (<- named by the author of this module:-)
|
671 |
my $mline;
|
672 |
if ($option{use_magic_line} && $option{output_magic_line}) {
|
673 |
if ($option{format} =~ /mail|news/ && ref $self->{header}) {
|
674 |
my $mfrom = $self->{header}->field ('mail-from', -new_item_unless_exist=>0);
|
675 |
$mline = sprintf 'From %s', $mfrom->value if ref $mfrom;
|
676 |
} elsif ($option{format} =~ /http.+?request/) {
|
677 |
$mline = sprintf '%s %s %s/%vd', $self->{http_method} || 'GET',
|
678 |
$self->{http_request_uri} || '/', $self->{http_protocol_name} || 'HTTP',
|
679 |
$self->{http_protocol_version} || v1.0;
|
680 |
} elsif ($option{format} =~ /http.+?response/ && ref $self->{header}
|
681 |
&& $option{format} !~ /cgi/) {
|
682 |
my $s = $self->{header}->field ('x-http-status');
|
683 |
$mline = sprintf '%s/%vd %s', $self->{http_protocol_name} || 'HTTP',
|
684 |
$self->{http_protocol_version} || v1.0, $s->value || '200 OK';
|
685 |
}
|
686 |
}
|
687 |
$mline .= "\x0D\x0A" if $mline;
|
688 |
$mline = '' unless $mline;
|
689 |
|
690 |
$header .= "\x0D\x0A" if $header && $header !~ /\x0D\x0A$/;
|
691 |
$mline.$header."\x0D\x0A".$body;
|
692 |
}
|
693 |
}
|
694 |
*as_string = \&stringify;
|
695 |
|
696 |
|
697 |
=head1 SHORTCUT METHOD FOR MESSAGE PROPERTIES
|
698 |
|
699 |
=over 4
|
700 |
|
701 |
=item $self->content_type ([%options])
|
702 |
|
703 |
Returns Internet media type of message body
|
704 |
(aka MIME type, content type). Only media type
|
705 |
(type/subtype pair) is returned, i.e. no parameter
|
706 |
is returned, if any. To get such value, or to set
|
707 |
new value, use C<field> method.
|
708 |
|
709 |
Default is C<text/plain>.
|
710 |
|
711 |
Example:
|
712 |
|
713 |
$msg->field ('Content-Type')->media_type ('text/html');
|
714 |
print $msg->content_type; ## text/html
|
715 |
|
716 |
=cut
|
717 |
|
718 |
sub content_type ($;%) {
|
719 |
my $self = shift;
|
720 |
my $ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0);
|
721 |
my ($mt, $mst);
|
722 |
unless (ref $ct) {
|
723 |
$mt = $self->{option}->{body_default_media_type};
|
724 |
$mst = $self->{option}->{body_default_media_subtype};
|
725 |
if ($mt ne 'text' || $mst ne 'plain') {
|
726 |
$ct = $self->{header}->field ('content-type');
|
727 |
$ct->media_type_major ($mt);
|
728 |
$ct->media_type_minor ($mst);
|
729 |
}
|
730 |
if ($self->{option}->{guess_media_type} && $self->{body} && !ref $self->{body}
|
731 |
&& $self->{option}->{format} =~ /mail|news/) {
|
732 |
if ($self->{body} =~ /^-----BEGIN PGP SIGNED MESSAGE-----\x0D?$/m
|
733 |
&& $self->{body} =~ /^-----BEGIN PGP SIGNATURE-----\x0D?$/m
|
734 |
&& $self->{body} =~ /^-----END PGP SIGNATURE-----\x0D?$/m) {
|
735 |
$ct = $self->{header}->field ('content-type') unless ref $ct;
|
736 |
$mt = $ct->media_type_major ('text');
|
737 |
$mst = $ct->media_type_minor ('x-pgp-cleartext-signed');
|
738 |
} elsif ($self->{body} =~ /^-----BEGIN PGP [A-Z\x20]+-----\x0D?$/m
|
739 |
&& $self->{body} =~ /^-----END PGP [A-Z\x20]+-----\x0D?$/m) {
|
740 |
$ct = $self->{header}->field ('content-type') unless ref $ct;
|
741 |
$mt = $ct->media_type_major ('application');
|
742 |
$mst = $ct->media_type_minor ('pgp');
|
743 |
$ct->parameter (format => 'text');
|
744 |
} elsif ($self->{body} =~ /^-+ start of forwarded message \(RFC 934 encapsulation\) -+\x0D?$/m) {
|
745 |
$ct = $self->{header}->field ('content-type') unless ref $ct;
|
746 |
$mt = $ct->media_type_major ('text');
|
747 |
$mst = $ct->media_type_minor ('x-message-rfc934');
|
748 |
} elsif ($self->{body} =~ /^-{70,70}\x0D?$/m
|
749 |
&& $self->{body} =~ /^-{30,30}\x0D?$/m
|
750 |
&& $self->{body} =~ /\x0D?\x0A-{30,30}\x0D?\x0A\x0D?\x0AEnd of.+?Digest.*?\x0D?\x0A\*+(?:\x0D?\x0A)*$/s) {
|
751 |
$ct = $self->{header}->field ('content-type') unless ref $ct;
|
752 |
$mt = $ct->media_type_major ('text');
|
753 |
$mst = $ct->media_type_minor ('x-message-rfc1153');
|
754 |
} elsif ($self->{body} =~ /^-----PRIVACY-ENHANCED MESSAGE BOUNDARY-----\x0D?$/m) {
|
755 |
$ct = $self->{header}->field ('content-type') unless ref $ct;
|
756 |
$mt = $ct->media_type_major ('text');
|
757 |
$mst = $ct->media_type_minor ('x-message-pem');
|
758 |
} elsif ($self->{body} =~ /^#(?:HELO|EHLO)/mi
|
759 |
&& $self->{body} =~ /^#MAIL FROM:/mi
|
760 |
&& $self->{body} !~ /^[^#]/m) {
|
761 |
## RFC 976 Batch SMTP (BSMTP) message
|
762 |
$ct = $self->{header}->field ('content-type') unless ref $ct;
|
763 |
$mt = $ct->media_type_major ('application');
|
764 |
$mst = $ct->media_type_minor ('x-batch-smtp');
|
765 |
}
|
766 |
}
|
767 |
} else {
|
768 |
($mt, $mst) = ($ct->media_type_major, $ct->media_type_minor);
|
769 |
}
|
770 |
if ($self->{option}->{guess_media_type}) {
|
771 |
if ($mt eq 'text' && $mst eq 'plain') {
|
772 |
my $mls = $self->{header}->field ('x-mlserver', -new_item_unless_exist => 0);
|
773 |
if (ref $mls && $mls =~ /fml/) {
|
774 |
my $s = $self->{header}->field ('subject', -new_item_unless_exist => 0);
|
775 |
if (index ($s, 'RFC934(mh-burst)') >= 0) {
|
776 |
$ct = $self->{header}->field ('content-type') unless ref $ct;
|
777 |
$mt = $ct->media_type_major ('text');
|
778 |
$mst = $ct->media_type_minor ('x-message-rfc934');
|
779 |
$ct->delete ('charset');
|
780 |
} elsif (index ($s, 'Digest (RFC1153)') >= 0) {
|
781 |
$ct = $self->{header}->field ('content-type') unless ref $ct;
|
782 |
$mt = $ct->media_type_major ('text');
|
783 |
$mst = $ct->media_type_minor ('x-message-rfc1153');
|
784 |
$ct->delete ('charset');
|
785 |
}
|
786 |
}
|
787 |
}
|
788 |
}
|
789 |
if (wantarray) {
|
790 |
($mt, $mst);
|
791 |
} else {
|
792 |
ref $ct ? $ct->media_type : sprintf '%s/%s', $mt, $mst;
|
793 |
}
|
794 |
}
|
795 |
*media_type = \&content_type;
|
796 |
|
797 |
=item $self->id
|
798 |
|
799 |
Returns ID of message entity. If there are C<Message-ID:>
|
800 |
field, its value is returned. Unless, but there are
|
801 |
C<Content-ID:> field, it is returned. Without both of
|
802 |
fields, C<""> is returned.
|
803 |
|
804 |
=cut
|
805 |
|
806 |
sub id ($) {
|
807 |
my $self = shift;
|
808 |
return scalar $self->{header}->field ('message-id')->id
|
809 |
if $self->{header}->field_exist ('message-id');
|
810 |
return scalar $self->{header}->field ('content-id')->id
|
811 |
if $self->{header}->field_exist ('content-id');
|
812 |
'';
|
813 |
}
|
814 |
|
815 |
sub sender ($;%) {
|
816 |
my $self = shift;
|
817 |
my %params = @_;
|
818 |
my %option = %{$self->{option}};
|
819 |
$option{use_x_envelope_from} = 1; ## X-Envelope-From:
|
820 |
$option{use_normal} = 1; ## From:, Sender:
|
821 |
$option{use_resent} = 1; ## Resent-From:, Resent-Sender:
|
822 |
my $hdr = $self->{header};
|
823 |
if ($option{use_x_envelope_from} && $hdr->field_exist ('x-envelope-from')) {
|
824 |
return $hdr->field ('x-envelope-from')->addr_spec;
|
825 |
} elsif ($option{use_resent} && $hdr->field_exist ('resent-sender')) {
|
826 |
## TODO: Resent block support
|
827 |
return $hdr->field ('resent-sender')->addr_spec;
|
828 |
} elsif ($option{use_resent} && $hdr->field_exist ('resent-from')) {
|
829 |
## TODO: Resent block support
|
830 |
return $hdr->field ('resent-from')->addr_spec;
|
831 |
} elsif ($option{use_normal} && $hdr->field_exist ('sender')) {
|
832 |
return $hdr->field ('sender')->addr_spec;
|
833 |
} elsif ($option{use_normal} && $hdr->field_exist ('from')) {
|
834 |
return $hdr->field ('from')->addr_spec;
|
835 |
}
|
836 |
undef;
|
837 |
}
|
838 |
|
839 |
sub destination ($;%) {
|
840 |
my $self = shift;
|
841 |
my %params = @_;
|
842 |
my %option = %{$self->{option}};
|
843 |
$option{use_x_envelope_to} = 1; ## X-Envelope-To:
|
844 |
$option{use_normal} = 1; ## To:, Cc:, Bcc:
|
845 |
$option{use_resent} = 1; ## Resent-To:, Resent-Cc:, Resent-Bcc:
|
846 |
for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
|
847 |
my $hdr = $self->{header};
|
848 |
my @to;
|
849 |
if ($option{use_x_envelope_to} && $hdr->field_exist ('x-rfc822-x-envelope-to')) {
|
850 |
@to = $hdr->field ('x-rfc822-x-envelope-to')->addr_spec;
|
851 |
} elsif ($option{use_resent} && $hdr->field_exist ('x-rfc822-resent-from')) {
|
852 |
## TODO: Resent block support
|
853 |
@to = ($hdr->field ('x-rfc822-resent-to')->addr_spec,
|
854 |
$hdr->field ('x-rfc822-resent-cc')->addr_spec,
|
855 |
$hdr->field ('x-rfc822-resent-bcc')->addr_spec);
|
856 |
} elsif ($option{use_normal}) {
|
857 |
@to = ($hdr->field ('x-rfc822-to')->addr_spec,
|
858 |
$hdr->field ('x-rfc822-cc')->addr_spec,
|
859 |
$hdr->field ('x-rfc822-bcc')->addr_spec);
|
860 |
}
|
861 |
@to;
|
862 |
}
|
863 |
|
864 |
sub list_name ($) {
|
865 |
my $self = shift;
|
866 |
my $hdr = $self->{header};
|
867 |
if ($hdr->field_exist ('list-id')) {
|
868 |
my $lname = $hdr->field ('list-id')->display_name;
|
869 |
return $lname if length $lname;
|
870 |
}
|
871 |
my $v = sub {
|
872 |
my $name = shift;
|
873 |
my $f = $hdr->field ($name, -new_item_unless_exist => 0);
|
874 |
return $f->value if ref $f;
|
875 |
undef;
|
876 |
};
|
877 |
## BUG: list-name "0" is not supported.
|
878 |
my $lname = &$v ('x-ml-name') || &$v ('x-mailing-list-name')
|
879 |
|| &$v ('x-mailinglist-name') || &$v ('ml-name');
|
880 |
return $lname if length $lname;
|
881 |
if ($hdr->field_exist ('x-sequence')) {
|
882 |
if ($hdr->field ('x-sequence')->value =~ /^(\S+)\s+\d+$/) {
|
883 |
return $1;
|
884 |
}
|
885 |
}
|
886 |
if ($hdr->field_exist ('subject')) {
|
887 |
my $s = $hdr->field ('subject');
|
888 |
return $s->list_name if $s->method_available ('list_name');
|
889 |
}
|
890 |
undef;
|
891 |
}
|
892 |
|
893 |
sub list_count ($) {
|
894 |
my $self = shift;
|
895 |
my $hdr = $self->{header};
|
896 |
my $v = sub {
|
897 |
my $name = shift;
|
898 |
my $f = $hdr->field ($name, -new_item_unless_exist => 0);
|
899 |
return $f->value if ref $f;
|
900 |
undef;
|
901 |
};
|
902 |
## BUG: list-count 0 is not supported.
|
903 |
my $lc = &$v ('x-mail-count') || &$v ('x-ml-count') || &$v ('x-mailinglist-id')
|
904 |
|| &$v ('mail-count') || &$v ('x-article-no') || &$v ('x-ml-counter')
|
905 |
|| &$v ('x-ml-id') || &$v ('x-ml-sequence') || &$v ('x-serial-no')
|
906 |
|| &$v ('x-seqno');
|
907 |
return $lc if $lc;
|
908 |
if ($hdr->field_exist ('x-sequence')) {
|
909 |
my $s = $hdr->field ('x-sequence')->value;
|
910 |
if ($s =~ /^\S+\s+(\d+)$/) {
|
911 |
return $1;
|
912 |
} elsif ($s =~ /(\d+)/) {
|
913 |
return $1;
|
914 |
}
|
915 |
}
|
916 |
if ($hdr->field_exist ('subject')) {
|
917 |
my $s = $hdr->field ('subject');
|
918 |
return $s->list_count if $s->method_available ('list_count');
|
919 |
}
|
920 |
undef;
|
921 |
}
|
922 |
|
923 |
=back
|
924 |
|
925 |
=head1 MISC. METHODS
|
926 |
|
927 |
=over 4
|
928 |
|
929 |
=item $self->option ( $option-name / $option-name, $option-value, ...)
|
930 |
|
931 |
If @_ == 1, returns option value. Else...
|
932 |
|
933 |
Set option value. You can pass multiple option name-value pair
|
934 |
as parameter. Example:
|
935 |
|
936 |
$msg->option (format => 'mail-rfc822',
|
937 |
capitalize => 0);
|
938 |
print $msg->option ('format'); ## mail-rfc822
|
939 |
|
940 |
=cut
|
941 |
|
942 |
sub option ($@) {
|
943 |
my $self = shift;
|
944 |
if (@_ == 1) {
|
945 |
return $self->{option}->{ $_[0] };
|
946 |
}
|
947 |
my %option = @_;
|
948 |
while (my ($name, $value) = splice (@_, 0, 2)) {
|
949 |
$self->{option}->{$name} = $value;
|
950 |
}
|
951 |
if ($option{-recursive} && ($self->content_type)[0] ne 'message') {
|
952 |
$self->{header}->option (%option);
|
953 |
$self->{body}->option (%option) if ref $self->{body};
|
954 |
}
|
955 |
}
|
956 |
|
957 |
=item $self->clone ()
|
958 |
|
959 |
Returns a copy of Message::Entity object.
|
960 |
|
961 |
=cut
|
962 |
|
963 |
sub clone ($) {
|
964 |
my $self = shift;
|
965 |
my $clone = new Message::Entity;
|
966 |
$clone->{option} = Message::Util::make_clone ($self->{option});
|
967 |
for (@{$self->{option}->{_MEMBERS}}) {
|
968 |
$clone->{$_} = Message::Util::make_clone ($self->{$_});
|
969 |
}
|
970 |
$clone;
|
971 |
}
|
972 |
|
973 |
my %_method_default_list = qw(new 1 parse 1 stringify 1 option 1 clone 1 method_available 1);
|
974 |
sub method_available ($$) {
|
975 |
my $self = shift;
|
976 |
my $name = shift;
|
977 |
return 1 if $_method_default_list{$name};
|
978 |
for (@{$self->{option}->{_METHODS}}) {
|
979 |
return 1 if $_ eq $name;
|
980 |
}
|
981 |
0;
|
982 |
}
|
983 |
|
984 |
sub import ($;%) {
|
985 |
my $self = shift;
|
986 |
my %option = @_;
|
987 |
for (keys %option) {
|
988 |
$DEFAULT{$_} = $option{$_};
|
989 |
}
|
990 |
if ($option{-body_default_charset} && !$option{-body_default_charset_input}) {
|
991 |
$DEFAULT{-body_default_charset_input} = $option{-body_default_charset};
|
992 |
}
|
993 |
if ($option{-header_default_charset} && !$option{-header_default_charset_input}) {
|
994 |
$DEFAULT{-header_default_charset_input} = $option{-header_default_charset};
|
995 |
}
|
996 |
}
|
997 |
|
998 |
=back
|
999 |
|
1000 |
=head1 C<format>
|
1001 |
|
1002 |
=over 2
|
1003 |
|
1004 |
=item mail-rfc650
|
1005 |
|
1006 |
Internet mail message, defined by IETF RFC 650
|
1007 |
|
1008 |
=item mail-rfc724
|
1009 |
|
1010 |
Internet mail message, defined by IETF RFC 724
|
1011 |
|
1012 |
=item mail-rfc733
|
1013 |
|
1014 |
Internet mail message, defined by IETF RFC 733
|
1015 |
|
1016 |
=item mail-rfc822
|
1017 |
|
1018 |
Internet mail message, defined by IETF RFC 822
|
1019 |
|
1020 |
=item mail-rfc822+rfc1123
|
1021 |
|
1022 |
Internet mail message, defined by IETF RFC 822, ammended by RFC 1123
|
1023 |
|
1024 |
=item mail-rfc2822
|
1025 |
|
1026 |
Internet mail message, defined by IETF RFC 2822
|
1027 |
|
1028 |
=item mime-1.0
|
1029 |
|
1030 |
MIME entity
|
1031 |
|
1032 |
=item mime-1.0-rfc1341
|
1033 |
|
1034 |
MIME entity, defined by RFC 1341 (and RFC 1342)
|
1035 |
|
1036 |
=item mime-1.0-rfc1521
|
1037 |
|
1038 |
MIME entity, defined by RFC 1521 and 1522
|
1039 |
|
1040 |
=item mime-1.0-rfc2045
|
1041 |
|
1042 |
MIME entity, defined by RFC 2045,..., 2049
|
1043 |
|
1044 |
=item news-bnews
|
1045 |
|
1046 |
Usenet Bnews format
|
1047 |
|
1048 |
=item news-rfc850
|
1049 |
|
1050 |
Usenet news format, defined by IETF RFC 850
|
1051 |
|
1052 |
=item news-rfc1036
|
1053 |
|
1054 |
Usenet news format, defined by IETF RFC 1036
|
1055 |
|
1056 |
=item news-son-of-rfc1036
|
1057 |
|
1058 |
Usenet news format, defined by son-of-RFC1036
|
1059 |
|
1060 |
=item news-usefor
|
1061 |
|
1062 |
Usenet news format, defined by usefor-article (IETF Internet Draft)
|
1063 |
|
1064 |
=item http-1.0-rfc1945
|
1065 |
|
1066 |
HTTP/1.0 message, defined by IETF RFC 1945
|
1067 |
|
1068 |
=item http-1.0-rfc1945-request
|
1069 |
|
1070 |
HTTP/1.0 request message, defined by IETF RFC 1945
|
1071 |
|
1072 |
=item http-1.0-rfc1945-response
|
1073 |
|
1074 |
HTTP/1.0 response message, defined by IETF RFC 1945
|
1075 |
|
1076 |
=item http-1.1-rfc2068
|
1077 |
|
1078 |
HTTP/1.1 message, defined by IETF RFC 2068
|
1079 |
|
1080 |
=item http-1.1-rfc2068-request
|
1081 |
|
1082 |
HTTP/1.1 request message, defined by IETF RFC 2068
|
1083 |
|
1084 |
=item http-1.1-rfc2068-response
|
1085 |
|
1086 |
HTTP/1.1 response message, defined by IETF RFC 2068
|
1087 |
|
1088 |
=item http-1.1-rfc2616
|
1089 |
|
1090 |
HTTP/1.1 message, defined by IETF RFC 2616
|
1091 |
|
1092 |
=item http-1.1-rfc2616-request
|
1093 |
|
1094 |
HTTP/1.1 request message, defined by IETF RFC 2616
|
1095 |
|
1096 |
=item http-1.1-rfc2616-response
|
1097 |
|
1098 |
HTTP/1.1 response message, defined by IETF RFC 2616
|
1099 |
|
1100 |
=item http-cgi-1.1
|
1101 |
|
1102 |
CGI/1.1 output (for HTTP), defined by coar-cgi-v11 (IETF Internet Draft)
|
1103 |
|
1104 |
=item http-cgi-1.2
|
1105 |
|
1106 |
CGI/1.2 output, defined by coar-cgi-v12 (to be IETF Internet Draft)
|
1107 |
|
1108 |
=item http-sip-2.0
|
1109 |
|
1110 |
SIP/2.0 message, defined by IETF RFC 2543
|
1111 |
|
1112 |
=item http-sip-2.0-request
|
1113 |
|
1114 |
SIP/2.0 request message, defined by IETF RFC 2543
|
1115 |
|
1116 |
=item http-sip-2.0-response
|
1117 |
|
1118 |
SIP/2.0 response message, defined by IETF RFC 2543
|
1119 |
|
1120 |
=item http-sip-cgi
|
1121 |
|
1122 |
SIP/2.0 CGI (IETF Internet Draft)
|
1123 |
|
1124 |
=item cpim-1.0
|
1125 |
|
1126 |
CPIM/1.0 (IETF Internet Draft)
|
1127 |
|
1128 |
=item uri-url-mailto
|
1129 |
|
1130 |
mailto: URL scheme
|
1131 |
|
1132 |
=item uri-url-mailto-rfc1738
|
1133 |
|
1134 |
mailto: URL scheme (defined by RFC 1738)
|
1135 |
|
1136 |
=item uri-url-mailto-rfc2368
|
1137 |
|
1138 |
mailto: URL scheme (defined by RFC 2368)
|
1139 |
|
1140 |
=item uri-url-mailto-to
|
1141 |
|
1142 |
C<to> part of mailto: URL scheme (for internal use only)
|
1143 |
|
1144 |
=back
|
1145 |
|
1146 |
=head1 EXAMPLE
|
1147 |
|
1148 |
use Message::Entity;
|
1149 |
my $msg = new Message::Entity From => 'foo@example.org',
|
1150 |
Subject => 'Example message',
|
1151 |
To => 'bar@example.net',
|
1152 |
-format => 'mail-rfc2822',
|
1153 |
body => $body;
|
1154 |
$msg->header ($header);
|
1155 |
$msg->body ($body);
|
1156 |
print $msg;
|
1157 |
|
1158 |
=head1 SEE ALSO
|
1159 |
|
1160 |
Message::* Perl modules
|
1161 |
<http://suika.fam.cx/~wakaba/Message-pm/>
|
1162 |
|
1163 |
=head1 LICENSE
|
1164 |
|
1165 |
Copyright 2002 Wakaba <w@suika.fam.cx>.
|
1166 |
|
1167 |
This program is free software; you can redistribute it and/or modify
|
1168 |
it under the terms of the GNU General Public License as published by
|
1169 |
the Free Software Foundation; either version 2 of the License, or
|
1170 |
(at your option) any later version.
|
1171 |
|
1172 |
This program is distributed in the hope that it will be useful,
|
1173 |
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
1174 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
1175 |
GNU General Public License for more details.
|
1176 |
|
1177 |
You should have received a copy of the GNU General Public License
|
1178 |
along with this program; see the file COPYING. If not, write to
|
1179 |
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
1180 |
Boston, MA 02111-1307, USA.
|
1181 |
|
1182 |
=head1 CHANGE
|
1183 |
|
1184 |
See F<ChangeLog>.
|
1185 |
$Date: 2002/12/28 09:10:16 $
|
1186 |
|
1187 |
=cut
|
1188 |
|
1189 |
1;
|