| 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;
|
Parent Directory
| 
Revision Log