1 |
|
2 |
=head1 NAME
|
3 |
|
4 |
Message::Partial --- Perl module for partial message defined by MIME
|
5 |
(message/partial)
|
6 |
|
7 |
=cut
|
8 |
|
9 |
package Message::Partial;
|
10 |
use strict;
|
11 |
use vars qw(%OPTION $VERSION);
|
12 |
$VERSION=do{my @r=(q$Revision: 1.5 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
|
13 |
|
14 |
require Message::Entity;
|
15 |
require Message::Header;
|
16 |
require Message::Field::MsgID;
|
17 |
|
18 |
%OPTION = (
|
19 |
-part_length => 60 * 1024,
|
20 |
-subject_format_pattern => '%s (%d/%d)',
|
21 |
);
|
22 |
|
23 |
my %ENCLOSED_FIELD = (
|
24 |
'disposition-notification-to' => 1, ## RFC 2298
|
25 |
'disposition-notification-options' => 1, ## RFC 2298
|
26 |
encrypted => 1, ## RFC 1521
|
27 |
'message-id' => 2, ## RFC 1341
|
28 |
'mime-version' => 2, ## RFC 1521
|
29 |
'original-recipient' => 1, ## RFC 2298
|
30 |
subject => 1, ## RFC 2046
|
31 |
'user-agent' => 1, ## non-standard extension
|
32 |
## Note: If value is 2, that header field from the first fragment
|
33 |
## is removed. 1 or 0, not removed. Usually, 1-valued fields
|
34 |
## are encapsulated and does not occur in fragments. Such
|
35 |
## context, 1 and 2 have no difference.
|
36 |
);
|
37 |
sub fragmentate ($;%) {
|
38 |
my $msg = shift;
|
39 |
my %params = @_;
|
40 |
my %option = %OPTION;
|
41 |
for (grep {/^-/} keys %params) {$option{$_} = $params{$_}}
|
42 |
|
43 |
if (ref $msg) {
|
44 |
$msg = $msg->clone;
|
45 |
} else {
|
46 |
$msg = parse Message::Entity $msg;
|
47 |
}
|
48 |
my @copy_field;
|
49 |
$msg->option (force_mime_entity => 1);
|
50 |
$msg->stringify; ## Make fill_* work
|
51 |
$msg->header->scan (sub {
|
52 |
my $i = $_[1];
|
53 |
my $rfc822 = $Message::Header::NS_phname2uri{'x-rfc822'};
|
54 |
if ($i->{ns} eq $Message::Header::NS_phname2uri{content}) {
|
55 |
push @copy_field, {%$i};
|
56 |
$i->{name} = undef;
|
57 |
} elsif ($i->{ns} eq $rfc822 && $ENCLOSED_FIELD{ $i->{name} }) {
|
58 |
#push @copy_field, Message::Util::make_clone ($i);
|
59 |
##$i->{name} = undef; ## Don't remove to keep compatible w/ RFC 1341/1521
|
60 |
push @copy_field, {%$i};
|
61 |
$i->{name} = undef;
|
62 |
}
|
63 |
});
|
64 |
my $outer_header = $msg->header;
|
65 |
my $inner_header = new Message::Header;
|
66 |
$inner_header->{value} = \@copy_field; ## Warning: direct access to internal structure!
|
67 |
$msg->header ($inner_header);
|
68 |
my @msg = split /\x0D\x0A/, $msg->stringify (-accept_cte => '7bit');
|
69 |
my @pbody = ('');
|
70 |
for (@msg) {
|
71 |
if (length $pbody[$#pbody] > $option{-part_length}) {
|
72 |
push @pbody, '';
|
73 |
}
|
74 |
$pbody[$#pbody] .= $_."\x0D\x0A";
|
75 |
}
|
76 |
my @pmsg;
|
77 |
my $subject = $inner_header->field ('subject', -new_item_unless_exist => 0);
|
78 |
my $ct = $outer_header->field ('content-type');
|
79 |
$ct->media_type ('message/partial');
|
80 |
my $as = $outer_header->field ('resent-from', -new_item_unless_exist => 0)
|
81 |
|| $outer_header->field ('from', -new_item_unless_exist => 0);
|
82 |
$as = $as->addr_spec if ref $as;
|
83 |
$as ||= 'part@partial.message.pm.invalid';
|
84 |
my $pid = Message::Field::MsgID->new (addr_spec => $as);
|
85 |
$ct->parameter (id => $pid->content);
|
86 |
my $first_mid;
|
87 |
for my $i (0..$#pbody) {
|
88 |
my %eo; %eo = (
|
89 |
-add_ua => 0,
|
90 |
# -fill_date => 0,
|
91 |
) if $i == 0;
|
92 |
$pmsg[$i] = new Message::Entity %eo;
|
93 |
$pmsg[$i]->header ($outer_header->clone);
|
94 |
my $hdr = $pmsg[$i]->header;
|
95 |
$hdr->replace (subject
|
96 |
=> $i == 0? $subject:
|
97 |
sprintf ($option{-subject_format_pattern}, $subject, $i+1, $#pbody+1));
|
98 |
my $ct = $hdr->field ('content-type');
|
99 |
$ct->parameter (number => $i +1);
|
100 |
$ct->parameter (total => $#pbody +1);
|
101 |
$pmsg[$i]->body ($pbody[$i]);
|
102 |
if ($i == 0) {
|
103 |
$pmsg[$i]->stringify;
|
104 |
$first_mid = $hdr->field ('message-id');
|
105 |
} else {
|
106 |
$hdr->field ('references')->add ($first_mid);
|
107 |
$hdr->field ('user-agent')->add ('Message-Partial-pm' => $VERSION);
|
108 |
}
|
109 |
}
|
110 |
@pmsg;
|
111 |
}
|
112 |
|
113 |
sub reassembly (@) {
|
114 |
my @msg = @_;
|
115 |
my ($id, @part);
|
116 |
for my $msg (@msg) {
|
117 |
unless (ref $msg) {
|
118 |
$msg = parse Message::Entity $msg;
|
119 |
}
|
120 |
my $ct = $msg->header->field ('content-type', -new_item_unless_exist => 0) if ref $msg;
|
121 |
if (ref $ct && $ct->media_type eq 'message/partial') {
|
122 |
unless (length $id) {
|
123 |
$id = $ct->parameter ('id');
|
124 |
} elsif ($id ne $ct->parameter ('id')) {
|
125 |
next;
|
126 |
}
|
127 |
$part[ $ct->parameter ('number') ] = $msg;
|
128 |
my $total = $ct->parameter ('total');
|
129 |
$#part = $total if $total && $#part < $total;
|
130 |
}
|
131 |
}
|
132 |
my $msg = '';
|
133 |
for my $i (1..$#part) {
|
134 |
if (ref $part[$i]) {
|
135 |
$msg .= $part[$i]->body;
|
136 |
} else {
|
137 |
Carp::carp "reassembly: part $i of $#part is missing";
|
138 |
}
|
139 |
};
|
140 |
$msg = parse Message::Entity $msg,
|
141 |
-fill_missing_fields => 0,
|
142 |
;
|
143 |
my $inner_header = $msg->header;
|
144 |
my $hdr;
|
145 |
if (ref $part[1]) {
|
146 |
$hdr = $msg->header ($part[1]->header);
|
147 |
$hdr->delete ({-by => 'ns'}, $Message::Header::NS_phname2uri{content});
|
148 |
$hdr->delete (grep {$ENCLOSED_FIELD{$_} > 1} keys %ENCLOSED_FIELD);
|
149 |
} else {
|
150 |
$hdr = $msg->header ('');
|
151 |
}
|
152 |
$inner_header->scan (sub {
|
153 |
my $i = $_[1];
|
154 |
my $rfc822 = $Message::Header::NS_phname2uri{'x-rfc822'};
|
155 |
if ($i->{ns} eq $Message::Header::NS_phname2uri{content}
|
156 |
|| $i->{ns} eq $rfc822 && $ENCLOSED_FIELD{ $i->{name} }) {
|
157 |
$msg->header->replace ($i->{name} => [ $i->{body} , ns => $i->{ns} ] );
|
158 |
}
|
159 |
});
|
160 |
$msg;
|
161 |
}
|
162 |
|
163 |
=head1 SEE ALSO
|
164 |
|
165 |
L<Message::Entity>
|
166 |
|
167 |
RFC 1341 E<lt>urn:ietf:rfc:1341E<gt>,
|
168 |
RFC 1521 E<lt>urn:ietf:rfc:1521E<gt>,
|
169 |
RFC 2046 E<lt>urn:ietf:rfc:2046E<gt>
|
170 |
|
171 |
RFC 822 E<lt>urn:ietf:rfc:822E<gt>,
|
172 |
RFC 2822 E<lt>urn:ietf:rfc:2822E<gt>
|
173 |
|
174 |
=head1 LICENSE
|
175 |
|
176 |
Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
|
177 |
|
178 |
This program is free software; you can redistribute it and/or modify
|
179 |
it under the terms of the GNU General Public License as published by
|
180 |
the Free Software Foundation; either version 2 of the License, or
|
181 |
(at your option) any later version.
|
182 |
|
183 |
This program is distributed in the hope that it will be useful,
|
184 |
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
185 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
186 |
GNU General Public License for more details.
|
187 |
|
188 |
You should have received a copy of the GNU General Public License
|
189 |
along with this program; see the file COPYING. If not, write to
|
190 |
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
191 |
Boston, MA 02111-1307, USA.
|
192 |
|
193 |
=head1 CHANGE
|
194 |
|
195 |
See F<ChangeLog>.
|
196 |
$Date: 2002/07/07 00:46:07 $
|
197 |
|
198 |
=cut
|
199 |
|
200 |
1;
|