61 |
field_format_pattern => '%s: %s', |
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 |
|
p3p => 'Message::Field::Params', |
114 |
'auto-submitted' => 'Message::Field::ValueParams', |
'auto-submitted' => 'Message::Field::ValueParams', |
115 |
'content-disposition' => 'Message::Field::ValueParams', |
'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', |
125 |
'user-agent' => 'Message::Field::UA', |
'user-agent' => 'Message::Field::UA', |
126 |
server => 'Message::Field::UA', |
server => 'Message::Field::UA', |
127 |
|
|
128 |
|
## A message id |
129 |
|
'content-id' => 'Message::Field::MsgID', |
130 |
|
'message-id' => 'Message::Field::MsgID', |
131 |
|
'resent-message-id' => 'Message::Field::MsgID', |
132 |
|
|
133 |
## Numeric value |
## Numeric value |
134 |
'content-length' => 'Message::Field::Numval', |
'content-length' => 'Message::Field::Numval', |
135 |
lines => 'Message::Field::Numval', |
lines => 'Message::Field::Numval', |
146 |
disposition-notification-options encoding |
disposition-notification-options encoding |
147 |
importance injector-info |
importance injector-info |
148 |
pics-label posted-and-mailed precedence list-id message-type |
pics-label posted-and-mailed precedence list-id message-type |
149 |
original-recipient priority |
original-recipient priority x-list-id |
150 |
sensitivity status x-face x-msmail-priority xref)) |
sensitivity status x-face x-msmail-priority xref)) |
151 |
{$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'} |
{$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'} |
152 |
## Not supported yet, but to be supported... |
## Not supported yet, but to be supported... |
153 |
|
# x-list: unstructured, ml name |
154 |
for (qw(abuse-reports-to apparently-to approved approved-by bcc cc complaints-to |
for (qw(abuse-reports-to apparently-to approved approved-by bcc cc complaints-to |
155 |
delivered-to disposition-notification-to envelope-to |
delivered-to disposition-notification-to envelope-to |
156 |
errors-to from mail-copies-to mail-followup-to mail-reply-to |
errors-to from mail-copies-to mail-followup-to mail-reply-to |
165 |
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 |
166 |
x-rcpt-to x-sender x-x-sender)) |
x-rcpt-to x-sender x-x-sender)) |
167 |
{$DEFAULT{field_type}->{$_} = 'Message::Field::Address'} |
{$DEFAULT{field_type}->{$_} = 'Message::Field::Address'} |
168 |
for (qw(date date-received delivery-date expires |
for (qw(client-date date date-received delivery-date expires |
169 |
expire-date nntp-posting-date posted posted-date reply-by resent-date |
expire-date nntp-posting-date posted posted-date received-date |
170 |
|
reply-by resent-date |
171 |
x-originalarrivaltime x-tcup-date)) |
x-originalarrivaltime x-tcup-date)) |
172 |
{$DEFAULT{field_type}->{$_} = 'Message::Field::Date'} |
{$DEFAULT{field_type}->{$_} = 'Message::Field::Date'} |
173 |
for (qw(article-updates client-date content-id in-reply-to message-id |
for (qw(article-updates in-reply-to |
174 |
obsoletes references replaces resent-message-id see-also supersedes)) |
obsoletes references replaces see-also supersedes)) |
175 |
{$DEFAULT{field_type}->{$_} = 'Message::Field::MsgID'} |
{$DEFAULT{field_type}->{$_} = 'Message::Field::MsgIDs'} |
176 |
for (qw(accept accept-charset accept-encoding accept-language |
for (qw(accept accept-charset accept-encoding accept-language |
177 |
content-language |
content-language |
178 |
content-transfer-encoding encrypted followup-to keywords |
content-transfer-encoding encrypted followup-to keywords |
179 |
list-archive list-digest list-help list-owner |
list-archive list-digest list-help list-owner |
180 |
list-post list-subscribe list-unsubscribe list-url uri newsgroups |
list-post list-subscribe list-unsubscribe list-url uri newsgroups |
181 |
posted-to |
posted-to)) |
|
x-brother x-daughter x-respect x-moe x-syster x-wife)) |
|
182 |
{$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'} |
{$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'} |
183 |
|
for (qw(x-brother x-boss x-classmate x-daughter x-dearfriend x-favoritesong |
184 |
|
x-friend x-me |
185 |
|
x-moe x-respect |
186 |
|
x-sublimate x-son x-sister x-wife)) |
187 |
|
{$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'} ## NOT M::F::XMOE! |
188 |
for (qw(content-alias content-base content-location location referer |
for (qw(content-alias content-base content-location location referer |
189 |
url x-home-page x-http_referer |
url x-home-page x-http_referer |
190 |
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)) |
191 |
{$DEFAULT{field_type}->{$_} = 'Message::Field::URI'} |
{$DEFAULT{field_type}->{$_} = 'Message::Field::URI'} |
192 |
|
|
193 |
|
my %header_goodcase = ( |
194 |
|
'article-i.d.' => 'Article-I.D.', |
195 |
|
'content-id' => 'Content-ID', |
196 |
|
'content-md5' => 'Content-MD5', |
197 |
|
'content-sgml-entity' => 'Content-SGML-Entity', |
198 |
|
etag => 'ETag', |
199 |
|
fax => 'FAX', |
200 |
|
'pics-label' => 'PICS-Label', |
201 |
|
'list-url' => 'List-URL', |
202 |
|
'list-id' => 'List-ID', |
203 |
|
'message-id' => 'Message-ID', |
204 |
|
'mime-version' => 'MIME-Version', |
205 |
|
'nic' => 'NIC', |
206 |
|
'nntp-posting-date' => 'NNTP-Posting-Date', |
207 |
|
'nntp-posting-host' => 'NNTP-Posting-Host', |
208 |
|
'resent-message-id' => 'Resent-Message-ID', |
209 |
|
te => 'TE', |
210 |
|
url => 'URL', |
211 |
|
'www-authenticate' => 'WWW-Authenticate', |
212 |
|
'x-dearfriend' => 'X-DearFriend', |
213 |
|
'x-mime-autoconverted' => 'X-MIME-Autoconverted', |
214 |
|
'x-nntp-posting-date' => 'X-NNTP-Posting-Date', |
215 |
|
'x-nntp-posting-host' => 'X-NNTP-Posting-Host', |
216 |
|
'x-uri' => 'X-URI', |
217 |
|
'x-url' => 'X-URL', |
218 |
|
); |
219 |
|
$DEFAULT{capitalize} = sub { |
220 |
|
my $self = shift; |
221 |
|
my $name = shift; |
222 |
|
if ($header_goodcase{$name}) { |
223 |
|
return $header_goodcase{$name}; |
224 |
|
} |
225 |
|
$name =~ s/(?:^|-)cgi-/uc $&/ge; |
226 |
|
$name =~ s/(?:^|-)[a-z]/uc $&/ge; |
227 |
|
$name; |
228 |
|
}; |
229 |
|
|
230 |
## taken from L<HTTP::Header> |
## taken from L<HTTP::Header> |
231 |
# "Good Practice" order of HTTP message headers: |
# "Good Practice" order of HTTP message headers: |
232 |
# - General-Headers |
# - General-Headers |
270 |
push @new_fields, ($name => $options{$name}); |
push @new_fields, ($name => $options{$name}); |
271 |
} |
} |
272 |
} |
} |
273 |
$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'; |
|
|
$self->{option}->{fold} = 0; |
|
|
} elsif ($format =~ /^http/) { |
|
|
$self->{option}->{sort} = 'good-practice'; |
|
|
} |
|
|
|
|
274 |
# Make alternative representations of @header_order. This is used |
# Make alternative representations of @header_order. This is used |
275 |
# for sorting. |
# for sorting. |
276 |
my $i = 1; |
my $i = 1; |
277 |
for (@header_order) { |
for (@header_order) { |
278 |
$header_order{$_} = $i++ unless $header_order{$_}; |
$header_order{$_} = $i++ unless $header_order{$_}; |
279 |
} |
} |
280 |
|
|
281 |
|
$self->add (@new_fields, -parse => $self->{option}->{parse_all}) |
282 |
|
if $#new_fields > -1; |
283 |
|
} |
284 |
|
|
285 |
|
sub _init_by_format ($$\%) { |
286 |
|
my $self = shift; |
287 |
|
my ($format, $option) = @_; |
288 |
|
if ($format =~ /rfc822/) { |
289 |
|
$header_goodcase{bcc} = 'bcc'; |
290 |
|
$header_goodcase{cc} = 'cc'; |
291 |
|
$header_goodcase{'resent-bcc'} = 'Resent-bcc'; |
292 |
|
$header_goodcase{'resent-cc'} = 'Resent-cc'; |
293 |
|
} elsif ($format =~ /cgi/) { |
294 |
|
unshift @header_order, qw(content-type location); |
295 |
|
$option->{sort} = 'good-practice'; |
296 |
|
$option->{fold} = 0; |
297 |
|
} elsif ($format =~ /http/) { |
298 |
|
$option->{sort} = 'good-practice'; |
299 |
|
} |
300 |
|
if ($format =~ /uri-url-mailto/) { |
301 |
|
$option->{output_bcc} = 0; |
302 |
|
$option->{capitalize} = 0; |
303 |
|
$option->{field_format_pattern} = '%s=%s'; |
304 |
|
$option->{fold} = sub { |
305 |
|
$_[1] =~ s/([^:@+\$A-Za-z0-9\-_.!~*])/sprintf('%%%02X', ord $1)/ge; |
306 |
|
$_[1]; |
307 |
|
}; |
308 |
|
} |
309 |
} |
} |
310 |
|
|
311 |
=item Message::Header->new ([%initial-fields/options]) |
=item Message::Header->new ([%initial-fields/options]) |
343 |
my $class = shift; |
my $class = shift; |
344 |
my $header = shift; |
my $header = shift; |
345 |
my $self = bless {}, $class; |
my $self = bless {}, $class; |
346 |
$self->_init (@_); |
$self->_init (@_); ## BUG: don't check linebreak_strict |
347 |
$header =~ s/\x0D?\x0A$REG{WSP}/\x20/gos; ## unfold |
$header =~ s/\x0D?\x0A$REG{WSP}/\x20/gos; ## unfold |
348 |
for my $field (split /\x0D?\x0A/, $header) { |
for my $field (split /\x0D?\x0A/, $header) { |
349 |
if ($field =~ /$REG{M_fromline}/) { |
if ($field =~ /$REG{M_fromline}/) { |
386 |
$field .= shift @$header; |
$field .= shift @$header; |
387 |
} else {last} |
} else {last} |
388 |
} |
} |
389 |
$field =~ tr/\x0D\x0A//d; ## BUG: not safe for bar CR/LF |
if ($self->{option}->{linebreak_strict}) { |
390 |
|
$field =~ s/\x0D\x0A//g; |
391 |
|
} else { |
392 |
|
$field =~ tr/\x0D\x0A//d; |
393 |
|
} |
394 |
if ($field =~ /$REG{M_fromline}/) { |
if ($field =~ /$REG{M_fromline}/) { |
395 |
my $body = $1; |
my $body = $1; |
396 |
$body = $self->_field_body ($body, 'mail-from') |
$body = $self->_field_body ($body, 'mail-from') |
483 |
eval "require $type" or Carp::croak ("_field_body: $type: $@"); |
eval "require $type" or Carp::croak ("_field_body: $type: $@"); |
484 |
unless ($body) { |
unless ($body) { |
485 |
$body = $type->new (-field_name => $name, |
$body = $type->new (-field_name => $name, |
486 |
-format => $self->{option}->{format} |
-format => $self->{option}->{format}, |
487 |
, field_name => $name, format => $self->{option}->{format}); |
-parse_all => $self->{option}->{parse_all}, |
488 |
|
field_name => $name, format => $self->{option}->{format}); |
489 |
} else { |
} else { |
490 |
$body = $type->parse ($body, -field_name => $name, |
$body = $type->parse ($body, -field_name => $name, |
491 |
-format => $self->{option}->{format}, |
-format => $self->{option}->{format}, |
492 |
|
-parse_all => $self->{option}->{parse_all}, |
493 |
field_name => $name,format => $self->{option}->{format}); |
field_name => $name,format => $self->{option}->{format}); |
494 |
} |
} |
495 |
} |
} |
537 |
my $self = shift; |
my $self = shift; |
538 |
my %fields = @_; |
my %fields = @_; |
539 |
my %option = %{$self->{option}}; |
my %option = %{$self->{option}}; |
540 |
$option{parse} = defined wantarray unless defined $option{parse}; |
$option{parse} = 1 if defined wantarray; |
541 |
for (grep {/^-/} keys %fields) {$option{substr ($_, 1)} = $fields{$_}} |
for (grep {/^-/} keys %fields) {$option{substr ($_, 1)} = $fields{$_}} |
542 |
my $body; |
my $body; |
543 |
for (grep {/^[^-]/} keys %fields) { |
for (grep {/^[^-]/} keys %fields) { |
708 |
my $self = shift; |
my $self = shift; |
709 |
my %params = @_; |
my %params = @_; |
710 |
my %option = %{$self->{option}}; |
my %option = %{$self->{option}}; |
711 |
|
$option{format} = $params{-format} if $params{-format}; |
712 |
|
$self->_init_by_format ($option{format}, \%option); |
713 |
for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}} |
for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}} |
714 |
my @ret; |
my @ret; |
715 |
if ($option{mail_from}) { |
my $_stringify = sub { |
716 |
my $fromline = $self->field ('mail-from'); |
my ($name, $body) = (@_); |
717 |
push @ret, 'From '.$fromline if $fromline; |
return unless length $name; |
718 |
} |
return if $option{mail_from} && $name eq 'mail-from'; |
719 |
$self->scan (sub { |
return if !$option{output_bcc} && ($name eq 'bcc' || $name eq 'resent-bcc'); |
720 |
my ($name, $body) = (@_); |
if ($option{format} =~ /uri-url-mailto/) { |
721 |
return unless length $name; |
return if (( $option{uri_mailto_safe}->{$name} |
722 |
return if $option{mail_from} && $name eq 'mail-from'; |
|| $option{uri_mailto_safe}->{':default'}) |
723 |
return if !$option{output_bcc} && ($name eq 'bcc' || $name eq 'resent-bcc'); |
< $option{uri_mailto_safe_level}); |
724 |
my $fbody; |
if ($name eq 'to') { |
725 |
if (ref $body) { |
$body = $self->field ('to'); |
726 |
$fbody = $body->stringify (-format => $option{format}); |
return unless ref $body && $body->have_group; |
727 |
} else { |
} |
728 |
$fbody = $body; |
} |
729 |
|
my $fbody; |
730 |
|
if (ref $body) { |
731 |
|
$fbody = $body->stringify (-format => $option{format}); |
732 |
|
} else { |
733 |
|
$fbody = $body; |
734 |
|
} |
735 |
|
return unless length $fbody; |
736 |
|
unless ($option{linebreak_strict}) { |
737 |
|
## bare \x0D and bare \x0A are unsafe |
738 |
|
$fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g; |
739 |
|
$fbody =~ s/\x0A(?=[^\x09\x20])/\x0A\x20/g; |
740 |
|
} else { |
741 |
|
$fbody =~ s/\x0D\x0A(?=[^\x09\x20])/\x0D\x0A\x20/g; |
742 |
|
} |
743 |
|
if (ref $option{capitalize}) { |
744 |
|
$name = &{$option{capitalize}} ($self, $name); |
745 |
|
} elsif ($option{capitalize}) { |
746 |
|
$name =~ s/((?:^|-)[a-z])/uc($1)/ge; |
747 |
|
} |
748 |
|
if (ref $option{fold}) { |
749 |
|
$fbody = &{$option{fold}} ($self, $fbody); |
750 |
|
} elsif ($option{fold}) { |
751 |
|
$fbody = $self->_fold ($fbody); |
752 |
|
} |
753 |
|
push @ret, sprintf $option{field_format_pattern}, $name, $fbody; |
754 |
|
}; |
755 |
|
if ($option{format} =~ /uri-url-mailto-to/) { |
756 |
|
if ($self->field_exist ('to')) { |
757 |
|
my $to = $self->field ('to'); |
758 |
|
unless ($to->have_group) { |
759 |
|
my $fbody = $to->stringify (-format => $option{format}); |
760 |
|
return &{$option{fold}} ($self, $fbody); |
761 |
|
} |
762 |
} |
} |
763 |
return unless length $fbody; |
''; |
764 |
$fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g; |
} elsif ($option{format} =~ /uri-url-mailto/) { |
765 |
$fbody =~ s/\x0A(?=[^\x09\x20])/\x0A\x20/g; |
$self->scan ($_stringify); |
766 |
$name =~ s/((?:^|-)[a-z])/uc($1)/ge if $option{capitalize}; |
my $ret = join ('&', @ret); |
767 |
$fbody = $self->_fold ($fbody) if $self->{option}->{fold}; |
$ret; |
768 |
push @ret, sprintf $self->{option}->{field_format_pattern}, $name, $fbody; |
} else { |
769 |
}); |
if ($option{mail_from}) { |
770 |
my $ret = join ("\n", @ret); |
my $fromline = $self->field ('mail-from'); |
771 |
$ret? $ret."\n": ''; |
push @ret, 'From '.$fromline if $fromline; |
772 |
|
} |
773 |
|
$self->scan ($_stringify); |
774 |
|
my $ret = join ("\n", @ret); |
775 |
|
$ret? $ret."\n": ''; |
776 |
|
} |
777 |
} |
} |
778 |
*as_string = \&stringify; |
*as_string = \&stringify; |
779 |
|
|