14 |
use vars qw($VERSION %REG); |
use vars qw($VERSION %REG); |
15 |
$VERSION = '1.00'; |
$VERSION = '1.00'; |
16 |
use Carp (); |
use Carp (); |
17 |
use overload '@{}' => sub {shift->_delete_empty_field()->{field}}, |
use overload '@{}' => sub { shift->_delete_empty_field->{field} }, |
18 |
'""' => sub {shift->stringify}; |
'""' => sub { shift->stringify }, |
19 |
|
fallback => 1; |
20 |
|
|
21 |
$REG{WSP} = qr/[\x09\x20]/; |
$REG{WSP} = qr/[\x09\x20]/; |
22 |
$REG{FWS} = qr/[\x09\x20]*/; |
$REG{FWS} = qr/[\x09\x20]*/; |
45 |
|
|
46 |
=cut |
=cut |
47 |
|
|
48 |
|
=head1 CONSTRUCTORS |
49 |
|
|
50 |
|
The following methods construct new C<Message::Header> objects: |
51 |
|
|
52 |
|
=over 4 |
53 |
|
|
54 |
|
=cut |
55 |
|
|
56 |
|
## Initialize |
57 |
my %DEFAULT = ( |
my %DEFAULT = ( |
58 |
capitalize => 1, |
capitalize => 1, |
59 |
|
fold => 1, |
60 |
fold_length => 70, |
fold_length => 70, |
61 |
|
field_format_pattern => '%s: %s', |
62 |
#field_type => {}, |
#field_type => {}, |
63 |
format => 'mail-rfc2822', |
format => 'mail-rfc2822', |
64 |
|
linebreak_strict => 0, |
65 |
mail_from => 0, |
mail_from => 0, |
66 |
output_bcc => 0, |
output_bcc => 0, |
67 |
parse_all => 0, |
parse_all => 0, |
68 |
sort => 'none', |
sort => 'none', |
69 |
translate_underscore => 1, |
translate_underscore => 1, |
70 |
|
uri_mailto_safe => { |
71 |
|
## 1 all (no check) 2 no trace & bcc & from |
72 |
|
## 3 no sender's info 4 (default) (currently not used) |
73 |
|
## 5 only a few |
74 |
|
':default' => 4, |
75 |
|
'cc' => 4, |
76 |
|
'bcc' => 1, |
77 |
|
'body' => 1, |
78 |
|
'comment' => 5, |
79 |
|
'content-id' => 1, |
80 |
|
'date' => 1, |
81 |
|
'from' => 1, |
82 |
|
'keywords' => 5, |
83 |
|
'list-id' => 1, |
84 |
|
'mail-from' => 1, |
85 |
|
'message-id' => 1, |
86 |
|
'received' => 1, |
87 |
|
'resent-bcc' => 1, |
88 |
|
'resent-date' => 1, |
89 |
|
'resent-from' => 1, |
90 |
|
'resent-sender' => 1, |
91 |
|
'return-path' => 1, |
92 |
|
'sender' => 1, |
93 |
|
'subject' => 5, |
94 |
|
'summary' => 5, |
95 |
|
'to' => 4, |
96 |
|
'user-agent' => 3, |
97 |
|
'x-face' => 2, |
98 |
|
'x-mailer' => 3, |
99 |
|
'x-nsubject' => 5, |
100 |
|
'x-received' => 1, |
101 |
|
'x400-received' => 1, |
102 |
|
}, |
103 |
|
uri_mailto_safe_level => 4, |
104 |
validate => 1, |
validate => 1, |
105 |
); |
); |
106 |
$DEFAULT{field_type} = { |
$DEFAULT{field_type} = { |
110 |
'x-received' => 'Message::Field::Received', |
'x-received' => 'Message::Field::Received', |
111 |
|
|
112 |
'content-type' => 'Message::Field::ContentType', |
'content-type' => 'Message::Field::ContentType', |
113 |
'content-disposition' => 'Message::Field::ContentDisposition', |
p3p => 'Message::Field::Params', |
114 |
|
'auto-submitted' => 'Message::Field::ValueParams', |
115 |
|
'content-disposition' => 'Message::Field::ValueParams', |
116 |
link => 'Message::Field::ValueParams', |
link => 'Message::Field::ValueParams', |
117 |
archive => 'Message::Field::ValueParams', |
archive => 'Message::Field::ValueParams', |
118 |
'x-face-type' => 'Message::Field::ValueParams', |
'x-face-type' => 'Message::Field::ValueParams', |
119 |
|
'x-mozilla-draft-info' => 'Message::Field::ValueParams', |
120 |
|
|
121 |
subject => 'Message::Field::Subject', |
subject => 'Message::Field::Subject', |
122 |
'x-nsubject' => 'Message::Field::Subject', |
'x-nsubject' => 'Message::Field::Subject', |
123 |
|
|
124 |
'list-software' => 'Message::Field::UA', |
'list-software' => 'Message::Field::UA', |
125 |
'user-agent' => 'Message::Field::UA', |
'user-agent' => 'Message::Field::UA', |
126 |
|
'resent-user-agent' => 'Message::Field::UA', |
127 |
server => 'Message::Field::UA', |
server => 'Message::Field::UA', |
128 |
|
|
129 |
|
## A message id |
130 |
|
'content-id' => 'Message::Field::MsgID', |
131 |
|
'message-id' => 'Message::Field::MsgID', |
132 |
|
'resent-message-id' => 'Message::Field::MsgID', |
133 |
|
|
134 |
|
## Numeric value |
135 |
'content-length' => 'Message::Field::Numval', |
'content-length' => 'Message::Field::Numval', |
136 |
lines => 'Message::Field::Numval', |
lines => 'Message::Field::Numval', |
137 |
'max-forwards' => 'Message::Field::Numval', |
'max-forwards' => 'Message::Field::Numval', |
138 |
'mime-version' => 'Message::Field::Numval', |
'mime-version' => 'Message::Field::Numval', |
139 |
|
'x-jsmail-priority' => 'Message::Field::Numval', |
140 |
|
'x-mail-count' => 'Message::Field::Numval', |
141 |
|
'x-ml-count' => 'Message::Field::Numval', |
142 |
|
'x-priority' => 'Message::Field::Numval', |
143 |
|
|
144 |
path => 'Message::Field::Path', |
path => 'Message::Field::Path', |
145 |
}; |
}; |
146 |
for (qw(cancel-lock importance precedence list-id |
for (qw(archive cancel-lock content-features content-md5 |
147 |
x-face x-mail-count x-msmail-priority x-priority xref)) |
disposition-notification-options encoding |
148 |
|
importance injector-info |
149 |
|
pics-label posted-and-mailed precedence list-id message-type |
150 |
|
original-recipient priority x-list-id |
151 |
|
sensitivity status x-face x-msmail-priority xref)) |
152 |
{$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'} |
{$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'} |
153 |
for (qw(approved bcc cc delivered-to disposition-notification-to envelope-to |
## Not supported yet, but to be supported... |
154 |
errors-to fcc from mail-followup-to mail-followup-cc reply-to resent-bcc |
# x-list: unstructured, ml name |
155 |
|
for (qw(abuse-reports-to apparently-to approved approved-by bcc cc complaints-to |
156 |
|
delivered-to disposition-notification-to envelope-to |
157 |
|
errors-to from mail-copies-to mail-followup-to mail-reply-to |
158 |
|
notice-requested-upon-delivery-to read-receipt-to register-mail-reply-requested-by |
159 |
|
reply-to resent-bcc |
160 |
resent-cc resent-to resent-from resent-sender return-path |
resent-cc resent-to resent-from resent-sender return-path |
161 |
return-receipt-to sender to x-approved x-beenthere |
return-receipt-to return-receipt-requested-to sender to x-abuse-reports-to |
162 |
|
x-admin x-approved x-beenthere x-confirm-reading-to |
163 |
x-complaints-to x-envelope-from x-envelope-sender |
x-complaints-to x-envelope-from x-envelope-sender |
164 |
x-envelope-to x-ml-address x-ml-command x-ml-to x-nfrom x-nto)) |
x-envelope-to x-ml-address x-ml-command x-ml-to x-nfrom x-nto |
165 |
{$DEFAULT{field_type}->{$_} = 'Message::Field::Address'} |
x-rcpt-to x-sender x-x-sender)) |
166 |
for (qw(date date-received delivery-date expires |
{$DEFAULT{field_type}->{$_} = 'Message::Field::Addresses'} |
167 |
expire-date nntp-posting-date posted reply-by resent-date x-tcup-date)) |
for (qw(client-date date date-received delivery-date expires |
168 |
|
expire-date nntp-posting-date posted posted-date received-date |
169 |
|
reply-by resent-date |
170 |
|
x-originalarrivaltime x-tcup-date)) |
171 |
{$DEFAULT{field_type}->{$_} = 'Message::Field::Date'} |
{$DEFAULT{field_type}->{$_} = 'Message::Field::Date'} |
172 |
for (qw(article-updates client-date content-id in-reply-to message-id |
for (qw(article-updates in-reply-to |
173 |
references resent-message-id see-also supersedes)) |
obsoletes references replaces see-also supersedes)) |
174 |
{$DEFAULT{field_type}->{$_} = 'Message::Field::MsgID'} |
{$DEFAULT{field_type}->{$_} = 'Message::Field::MsgIDs'} |
175 |
for (qw(accept accept-charset accept-encoding accept-language |
for (qw(accept accept-charset accept-encoding accept-language |
176 |
content-language |
content-language |
177 |
content-transfer-encoding encrypted followup-to keywords |
content-transfer-encoding encrypted followup-to keywords |
178 |
list-archive list-digest list-help list-owner |
list-archive list-digest list-help list-owner |
179 |
list-post list-subscribe list-unsubscribe list-url uri newsgroups |
list-post list-subscribe list-unsubscribe list-url uri newsgroups |
180 |
x-brother x-daughter x-respect x-moe x-syster x-wife)) |
posted-to)) |
181 |
{$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'} |
{$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'} |
182 |
|
for (qw(x-brother x-boss x-classmate x-daughter x-dearfriend x-favoritesong |
183 |
|
x-friend x-me |
184 |
|
x-moe x-respect |
185 |
|
x-sublimate x-son x-sister x-wife)) |
186 |
|
{$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'} ## NOT M::F::XMOE! |
187 |
for (qw(content-alias content-base content-location location referer |
for (qw(content-alias content-base content-location location referer |
188 |
url x-home-page x-http_referer |
url x-home-page x-http_referer |
189 |
x-info x-pgp-key x-ml-url x-uri x-url x-web)) |
x-info x-pgp-key x-ml-url x-uri x-url x-web)) |
190 |
{$DEFAULT{field_type}->{$_} = 'Message::Field::URI'} |
{$DEFAULT{field_type}->{$_} = 'Message::Field::URI'} |
191 |
|
|
192 |
|
my %header_goodcase = ( |
193 |
|
'article-i.d.' => 'Article-I.D.', |
194 |
|
'content-id' => 'Content-ID', |
195 |
|
'content-md5' => 'Content-MD5', |
196 |
|
'content-sgml-entity' => 'Content-SGML-Entity', |
197 |
|
etag => 'ETag', |
198 |
|
fax => 'FAX', |
199 |
|
'pics-label' => 'PICS-Label', |
200 |
|
'list-url' => 'List-URL', |
201 |
|
'list-id' => 'List-ID', |
202 |
|
'message-id' => 'Message-ID', |
203 |
|
'mime-version' => 'MIME-Version', |
204 |
|
'nic' => 'NIC', |
205 |
|
'nntp-posting-date' => 'NNTP-Posting-Date', |
206 |
|
'nntp-posting-host' => 'NNTP-Posting-Host', |
207 |
|
'resent-message-id' => 'Resent-Message-ID', |
208 |
|
te => 'TE', |
209 |
|
url => 'URL', |
210 |
|
'www-authenticate' => 'WWW-Authenticate', |
211 |
|
'x-dearfriend' => 'X-DearFriend', |
212 |
|
'x-mime-autoconverted' => 'X-MIME-Autoconverted', |
213 |
|
'x-nntp-posting-date' => 'X-NNTP-Posting-Date', |
214 |
|
'x-nntp-posting-host' => 'X-NNTP-Posting-Host', |
215 |
|
'x-uri' => 'X-URI', |
216 |
|
'x-url' => 'X-URL', |
217 |
|
); |
218 |
|
$DEFAULT{capitalize} = sub { |
219 |
|
my $self = shift; |
220 |
|
my $name = shift; |
221 |
|
if ($header_goodcase{$name}) { |
222 |
|
return $header_goodcase{$name}; |
223 |
|
} |
224 |
|
$name =~ s/(?:^|-)cgi-/uc $&/ge; |
225 |
|
$name =~ s/(?:^|-)[a-z]/uc $&/ge; |
226 |
|
$name; |
227 |
|
}; |
228 |
|
|
229 |
## taken from L<HTTP::Header> |
## taken from L<HTTP::Header> |
230 |
# "Good Practice" order of HTTP message headers: |
# "Good Practice" order of HTTP message headers: |
231 |
# - General-Headers |
# - General-Headers |
269 |
push @new_fields, ($name => $options{$name}); |
push @new_fields, ($name => $options{$name}); |
270 |
} |
} |
271 |
} |
} |
272 |
$self->add (@new_fields, -parse => $self->{option}->{parse_all}) |
$self->_init_by_format ($self->{option}->{format}, $self->{option}); |
|
if $#new_fields > -1; |
|
|
|
|
|
my $format = $self->{option}->{format}; |
|
|
if ($format =~ /^cgi/) { |
|
|
unshift @header_order, qw(content-type location); |
|
|
$self->{option}->{sort} = 'good-practice'; |
|
|
} elsif ($format =~ /^http/) { |
|
|
$self->{option}->{sort} = 'good-practice'; |
|
|
} |
|
|
|
|
273 |
# Make alternative representations of @header_order. This is used |
# Make alternative representations of @header_order. This is used |
274 |
# for sorting. |
# for sorting. |
275 |
my $i = 1; |
my $i = 1; |
276 |
for (@header_order) { |
for (@header_order) { |
277 |
$header_order{$_} = $i++ unless $header_order{$_}; |
$header_order{$_} = $i++ unless $header_order{$_}; |
278 |
} |
} |
279 |
|
|
280 |
|
$self->add (@new_fields, -parse => $self->{option}->{parse_all}) |
281 |
|
if $#new_fields > -1; |
282 |
|
} |
283 |
|
|
284 |
|
sub _init_by_format ($$\%) { |
285 |
|
my $self = shift; |
286 |
|
my ($format, $option) = @_; |
287 |
|
if ($format =~ /rfc822/) { |
288 |
|
$header_goodcase{bcc} = 'bcc'; |
289 |
|
$header_goodcase{cc} = 'cc'; |
290 |
|
$header_goodcase{'resent-bcc'} = 'Resent-bcc'; |
291 |
|
$header_goodcase{'resent-cc'} = 'Resent-cc'; |
292 |
|
} elsif ($format =~ /cgi/) { |
293 |
|
unshift @header_order, qw(content-type location); |
294 |
|
$option->{sort} = 'good-practice'; |
295 |
|
$option->{fold} = 0; |
296 |
|
} elsif ($format =~ /http/) { |
297 |
|
$option->{sort} = 'good-practice'; |
298 |
|
} |
299 |
|
if ($format =~ /uri-url-mailto/) { |
300 |
|
$option->{output_bcc} = 0; |
301 |
|
$option->{capitalize} = 0; |
302 |
|
$option->{field_format_pattern} = '%s=%s'; |
303 |
|
$option->{fold} = sub { |
304 |
|
$_[1] =~ s/([^:@+\$A-Za-z0-9\-_.!~*])/sprintf('%%%02X', ord $1)/ge; |
305 |
|
$_[1]; |
306 |
|
}; |
307 |
|
} |
308 |
} |
} |
309 |
|
|
310 |
=head2 Message::Header->new ([%initial-fields/options]) |
=item Message::Header->new ([%initial-fields/options]) |
311 |
|
|
312 |
Constructs a new C<Message::Headers> object. You might pass some initial |
Constructs a new C<Message::Headers> object. You might pass some initial |
313 |
C<field-name>-C<field-body> pairs and/or options as parameters to the constructor. |
C<field-name>-C<field-body> pairs and/or options as parameters to the constructor. |
314 |
|
|
315 |
=head3 example |
Example: |
316 |
|
|
317 |
$hdr = new Message::Headers |
$hdr = new Message::Headers |
318 |
Date => 'Thu, 03 Feb 1994 00:00:00 +0000', |
Date => 'Thu, 03 Feb 1994 00:00:00 +0000', |
330 |
$self; |
$self; |
331 |
} |
} |
332 |
|
|
333 |
=head2 Message::Header->parse ($header, [%initial-fields/options]) |
=item Message::Header->parse ($header, [%initial-fields/options]) |
334 |
|
|
335 |
Parses given C<header> and constructs a new C<Message::Headers> |
Parses given C<header> and constructs a new C<Message::Headers> |
336 |
object. You might pass some additional C<field-name>-C<field-body> pairs |
object. You might pass some additional C<field-name>-C<field-body> pairs |
342 |
my $class = shift; |
my $class = shift; |
343 |
my $header = shift; |
my $header = shift; |
344 |
my $self = bless {}, $class; |
my $self = bless {}, $class; |
345 |
$self->_init (@_); |
$self->_init (@_); ## BUG: don't check linebreak_strict |
346 |
$header =~ s/\x0D?\x0A$REG{WSP}/\x20/gos; ## unfold |
$header =~ s/\x0D?\x0A$REG{WSP}/\x20/gos; ## unfold |
347 |
for my $field (split /\x0D?\x0A/, $header) { |
for my $field (split /\x0D?\x0A/, $header) { |
348 |
if ($field =~ /$REG{M_fromline}/) { |
if ($field =~ /$REG{M_fromline}/) { |
361 |
$self; |
$self; |
362 |
} |
} |
363 |
|
|
364 |
|
=item Message::Header->parse_array (\@header, [%initial-fields/options]) |
365 |
|
|
366 |
|
Parses given C<header> and constructs a new C<Message::Headers> |
367 |
|
object. Same as C<Message::Header-E<lt>parse> but this method |
368 |
|
is given an array reference. You might pass some additional |
369 |
|
C<field-name>-C<field-body> pairs or/and initial options |
370 |
|
as parameters to the constructor. |
371 |
|
|
372 |
|
=cut |
373 |
|
|
374 |
sub parse_array ($\@;%) { |
sub parse_array ($\@;%) { |
375 |
my $class = shift; |
my $class = shift; |
376 |
my $header = shift; |
my $header = shift; |
385 |
$field .= shift @$header; |
$field .= shift @$header; |
386 |
} else {last} |
} else {last} |
387 |
} |
} |
388 |
$field =~ tr/\x0D\x0A//d; ## BUG: not safe for bar CR/LF |
if ($self->{option}->{linebreak_strict}) { |
389 |
|
$field =~ s/\x0D\x0A//g; |
390 |
|
} else { |
391 |
|
$field =~ tr/\x0D\x0A//d; |
392 |
|
} |
393 |
if ($field =~ /$REG{M_fromline}/) { |
if ($field =~ /$REG{M_fromline}/) { |
394 |
my $body = $1; |
my $body = $1; |
395 |
$body = $self->_field_body ($body, 'mail-from') |
$body = $self->_field_body ($body, 'mail-from') |
407 |
$self; |
$self; |
408 |
} |
} |
409 |
|
|
410 |
|
=back |
411 |
|
|
412 |
|
=head1 METHODS |
413 |
|
|
414 |
=head2 $self->field ($field_name) |
=head2 $self->field ($field_name) |
415 |
|
|
416 |
Returns C<field-body> of given C<field-name>. |
Returns C<field-body> of given C<field-name>. |
481 |
|| $self->{option}->{field_type}->{':DEFAULT'}; |
|| $self->{option}->{field_type}->{':DEFAULT'}; |
482 |
eval "require $type" or Carp::croak ("_field_body: $type: $@"); |
eval "require $type" or Carp::croak ("_field_body: $type: $@"); |
483 |
unless ($body) { |
unless ($body) { |
484 |
$body = $type->new (-field_name => $name, |
$body = $type->new (-field_name => $name, |
485 |
-format => $self->{option}->{format}); |
-format => $self->{option}->{format}, |
486 |
|
-parse_all => $self->{option}->{parse_all}); |
487 |
} else { |
} else { |
488 |
$body = $type->parse ($body, -field_name => $name, |
$body = $type->parse ($body, -field_name => $name, |
489 |
-format => $self->{option}->{format}); |
-format => $self->{option}->{format}, |
490 |
|
-parse_all => $self->{option}->{parse_all}); |
491 |
} |
} |
492 |
} |
} |
493 |
$body; |
$body; |
507 |
map {$_->{name}} @{$self->{field}}; |
map {$_->{name}} @{$self->{field}}; |
508 |
} |
} |
509 |
|
|
510 |
=head2 $self->add ($field-name, $field-body, [$name, $body, ...]) |
=item $hdr->add ($field-name, $field-body, [$name, $body, ...]) |
511 |
|
|
512 |
Adds an new C<field>. It is not checked whether |
Adds some field name/body pairs. Even if there are |
513 |
the field which named $field_body is already exist or not. |
one or more fields named given C<$field-name>, |
514 |
If you don't want duplicated C<field>s, use C<replace> method. |
given name/body pairs are ADDed. Use C<replace> |
515 |
|
to remove same-name-fields. |
516 |
|
|
517 |
Instead of field name-body pair, you might pass some options. |
Instead of field name-body pair, you might pass some options. |
518 |
Four options are available for this method. |
Four options are available for this method. |
534 |
my $self = shift; |
my $self = shift; |
535 |
my %fields = @_; |
my %fields = @_; |
536 |
my %option = %{$self->{option}}; |
my %option = %{$self->{option}}; |
537 |
$option{parse} = defined wantarray unless defined $option{parse}; |
$option{parse} = 1 if defined wantarray; |
538 |
for (grep {/^-/} keys %fields) {$option{substr ($_, 1)} = $fields{$_}} |
for (grep {/^-/} keys %fields) {$option{substr ($_, 1)} = $fields{$_}} |
539 |
my $body; |
my $body; |
540 |
for (grep {/^[^-]/} keys %fields) { |
for (grep {/^[^-]/} keys %fields) { |
568 |
my %option = %{$self->{option}}; |
my %option = %{$self->{option}}; |
569 |
$option{parse} = defined wantarray unless defined $option{parse}; |
$option{parse} = defined wantarray unless defined $option{parse}; |
570 |
for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}} |
for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}} |
571 |
my (%new_field, $body); |
my (%new_field); |
572 |
for (grep {/^[^-]/} keys %params) { |
for (grep {/^[^-]/} keys %params) { |
573 |
my $name = lc $_; |
my $name = lc $_; |
574 |
$name =~ tr/_/-/ if $option{translate_underscore}; |
$name =~ tr/_/-/ if $option{translate_underscore}; |
577 |
$params{$_} = $self->_field_body ($params{$_}, $name) if $option{parse}; |
$params{$_} = $self->_field_body ($params{$_}, $name) if $option{parse}; |
578 |
$new_field{$name} = $params{$_}; |
$new_field{$name} = $params{$_}; |
579 |
} |
} |
580 |
|
my $body = (%new_field)[-1]; |
581 |
for my $field (@{$self->{field}}) { |
for my $field (@{$self->{field}}) { |
582 |
if (defined $new_field{$field->{name}}) { |
if (defined $new_field{$field->{name}}) { |
583 |
$body = $new_field {$field->{name}}; |
$field->{body} = $new_field {$field->{name}}; |
|
$field->{body} = $body; |
|
584 |
$new_field{$field->{name}} = undef; |
$new_field{$field->{name}} = undef; |
585 |
} |
} |
586 |
} |
} |
598 |
|
|
599 |
sub delete ($@) { |
sub delete ($@) { |
600 |
my $self = shift; |
my $self = shift; |
601 |
my %delete; |
my %delete; for (@_) {$delete{lc $_} = 1} |
|
for (@_) {$delete{lc $_} = 1} |
|
602 |
for my $field (@{$self->{field}}) { |
for my $field (@{$self->{field}}) { |
603 |
undef $field if $delete{$field->{name}}; |
undef $field if $delete{$field->{name}}; |
604 |
} |
} |
705 |
my $self = shift; |
my $self = shift; |
706 |
my %params = @_; |
my %params = @_; |
707 |
my %option = %{$self->{option}}; |
my %option = %{$self->{option}}; |
708 |
|
$option{format} = $params{-format} if $params{-format}; |
709 |
|
$self->_init_by_format ($option{format}, \%option); |
710 |
for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}} |
for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}} |
711 |
my @ret; |
my @ret; |
712 |
if ($option{mail_from}) { |
my $_stringify = sub { |
713 |
my $fromline = $self->field ('mail-from'); |
my ($name, $body) = (@_); |
714 |
push @ret, 'From '.$fromline if $fromline; |
return unless length $name; |
715 |
} |
return if $option{mail_from} && $name eq 'mail-from'; |
716 |
$self->scan (sub { |
return if !$option{output_bcc} && ($name eq 'bcc' || $name eq 'resent-bcc'); |
717 |
my ($name, $body) = (@_); |
if ($option{format} =~ /uri-url-mailto/) { |
718 |
return unless length $name; |
return if (( $option{uri_mailto_safe}->{$name} |
719 |
return if $option{mail_from} && $name eq 'mail-from'; |
|| $option{uri_mailto_safe}->{':default'}) |
720 |
return if !$option{output_bcc} && ($name eq 'bcc' || $name eq 'resent-bcc'); |
< $option{uri_mailto_safe_level}); |
721 |
my $fbody; |
if ($name eq 'to') { |
722 |
if (ref $body) { |
$body = $self->field ('to'); |
723 |
$fbody = $body->stringify (-format => $option{format}); |
return unless ref $body && $body->have_group; |
724 |
} else { |
} |
725 |
$fbody = $body; |
} |
726 |
|
my $fbody; |
727 |
|
if (ref $body) { |
728 |
|
$fbody = $body->stringify (-format => $option{format}); |
729 |
|
} else { |
730 |
|
$fbody = $body; |
731 |
|
} |
732 |
|
return unless length $fbody; |
733 |
|
unless ($option{linebreak_strict}) { |
734 |
|
## bare \x0D and bare \x0A are unsafe |
735 |
|
$fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g; |
736 |
|
$fbody =~ s/\x0A(?=[^\x09\x20])/\x0A\x20/g; |
737 |
|
} else { |
738 |
|
$fbody =~ s/\x0D\x0A(?=[^\x09\x20])/\x0D\x0A\x20/g; |
739 |
|
} |
740 |
|
if (ref $option{capitalize}) { |
741 |
|
$name = &{$option{capitalize}} ($self, $name); |
742 |
|
} elsif ($option{capitalize}) { |
743 |
|
$name =~ s/((?:^|-)[a-z])/uc($1)/ge; |
744 |
|
} |
745 |
|
if (ref $option{fold}) { |
746 |
|
$fbody = &{$option{fold}} ($self, $fbody); |
747 |
|
} elsif ($option{fold}) { |
748 |
|
$fbody = $self->_fold ($fbody); |
749 |
|
} |
750 |
|
push @ret, sprintf $option{field_format_pattern}, $name, $fbody; |
751 |
|
}; |
752 |
|
if ($option{format} =~ /uri-url-mailto-to/) { |
753 |
|
if ($self->field_exist ('to')) { |
754 |
|
my $to = $self->field ('to'); |
755 |
|
unless ($to->have_group) { |
756 |
|
my $fbody = $to->stringify (-format => $option{format}); |
757 |
|
return &{$option{fold}} ($self, $fbody); |
758 |
|
} |
759 |
} |
} |
760 |
return unless length $fbody; |
''; |
761 |
$fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g; |
} elsif ($option{format} =~ /uri-url-mailto/) { |
762 |
$fbody =~ s/\x0A(?=[^\x09\x20])/\x0A\x20/g; |
$self->scan ($_stringify); |
763 |
$name =~ s/((?:^|-)[a-z])/uc($1)/ge if $option{capitalize}; |
my $ret = join ('&', @ret); |
764 |
push @ret, $name.': '.$self->fold ($fbody); |
$ret; |
765 |
}); |
} else { |
766 |
my $ret = join ("\n", @ret); |
if ($option{mail_from}) { |
767 |
$ret? $ret."\n": ''; |
my $fromline = $self->field ('mail-from'); |
768 |
|
push @ret, 'From '.$fromline if $fromline; |
769 |
|
} |
770 |
|
$self->scan ($_stringify); |
771 |
|
my $ret = join ("\n", @ret); |
772 |
|
$ret? $ret."\n": ''; |
773 |
|
} |
774 |
} |
} |
775 |
*as_string = \&stringify; |
*as_string = \&stringify; |
776 |
|
|
819 |
$self; |
$self; |
820 |
} |
} |
821 |
|
|
822 |
sub fold ($$;$) { |
sub _fold ($$;$) { |
823 |
my $self = shift; |
my $self = shift; |
824 |
my $string = shift; |
my $string = shift; |
825 |
my $len = shift || $self->{option}->{fold_length}; |
my $len = shift || $self->{option}->{fold_length}; |