line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package MIME::Entity; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
=head1 NAME |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
MIME::Entity - class for parsed-and-decoded MIME message |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
=head1 SYNOPSIS |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
Before reading further, you should see L to make sure that |
12
|
|
|
|
|
|
|
you understand where this module fits into the grand scheme of things. |
13
|
|
|
|
|
|
|
Go on, do it now. I'll wait. |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
Ready? Ok... |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
### Create an entity: |
18
|
|
|
|
|
|
|
$top = MIME::Entity->build(From => 'me@myhost.com', |
19
|
|
|
|
|
|
|
To => 'you@yourhost.com', |
20
|
|
|
|
|
|
|
Subject => "Hello, nurse!", |
21
|
|
|
|
|
|
|
Data => \@my_message); |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
### Attach stuff to it: |
24
|
|
|
|
|
|
|
$top->attach(Path => $gif_path, |
25
|
|
|
|
|
|
|
Type => "image/gif", |
26
|
|
|
|
|
|
|
Encoding => "base64"); |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
### Sign it: |
29
|
|
|
|
|
|
|
$top->sign; |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
### Output it: |
32
|
|
|
|
|
|
|
$top->print(\*STDOUT); |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
=head1 DESCRIPTION |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
A subclass of B. |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
This package provides a class for representing MIME message entities, |
40
|
|
|
|
|
|
|
as specified in RFCs 2045, 2046, 2047, 2048 and 2049. |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
=head1 EXAMPLES |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
=head2 Construction examples |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
Create a document for an ordinary 7-bit ASCII text file (lots of |
48
|
|
|
|
|
|
|
stuff is defaulted for us): |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
$ent = MIME::Entity->build(Path=>"english-msg.txt"); |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
Create a document for a text file with 8-bit (Latin-1) characters: |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
$ent = MIME::Entity->build(Path =>"french-msg.txt", |
55
|
|
|
|
|
|
|
Encoding =>"quoted-printable", |
56
|
|
|
|
|
|
|
From =>'jean.luc@inria.fr', |
57
|
|
|
|
|
|
|
Subject =>"C'est bon!"); |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
Create a document for a GIF file (the description is completely optional; |
60
|
|
|
|
|
|
|
note that we have to specify content-type and encoding since they're |
61
|
|
|
|
|
|
|
not the default values): |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
$ent = MIME::Entity->build(Description => "A pretty picture", |
64
|
|
|
|
|
|
|
Path => "./docs/mime-sm.gif", |
65
|
|
|
|
|
|
|
Type => "image/gif", |
66
|
|
|
|
|
|
|
Encoding => "base64"); |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
Create a document that you already have the text for, using "Data": |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
$ent = MIME::Entity->build(Type => "text/plain", |
71
|
|
|
|
|
|
|
Encoding => "quoted-printable", |
72
|
|
|
|
|
|
|
Data => ["First line.\n", |
73
|
|
|
|
|
|
|
"Second line.\n", |
74
|
|
|
|
|
|
|
"Last line.\n"]); |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
Create a multipart message, with the entire structure given |
77
|
|
|
|
|
|
|
explicitly: |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
### Create the top-level, and set up the mail headers: |
80
|
|
|
|
|
|
|
$top = MIME::Entity->build(Type => "multipart/mixed", |
81
|
|
|
|
|
|
|
From => 'me@myhost.com', |
82
|
|
|
|
|
|
|
To => 'you@yourhost.com', |
83
|
|
|
|
|
|
|
Subject => "Hello, nurse!"); |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
### Attachment #1: a simple text document: |
86
|
|
|
|
|
|
|
$top->attach(Path=>"./testin/short.txt"); |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
### Attachment #2: a GIF file: |
89
|
|
|
|
|
|
|
$top->attach(Path => "./docs/mime-sm.gif", |
90
|
|
|
|
|
|
|
Type => "image/gif", |
91
|
|
|
|
|
|
|
Encoding => "base64"); |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
### Attachment #3: text we'll create with text we have on-hand: |
94
|
|
|
|
|
|
|
$top->attach(Data => $contents); |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
Suppose you don't know ahead of time that you'll have attachments? |
97
|
|
|
|
|
|
|
No problem: you can "attach" to singleparts as well: |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
$top = MIME::Entity->build(From => 'me@myhost.com', |
100
|
|
|
|
|
|
|
To => 'you@yourhost.com', |
101
|
|
|
|
|
|
|
Subject => "Hello, nurse!", |
102
|
|
|
|
|
|
|
Data => \@my_message); |
103
|
|
|
|
|
|
|
if ($GIF_path) { |
104
|
|
|
|
|
|
|
$top->attach(Path => $GIF_path, |
105
|
|
|
|
|
|
|
Type => 'image/gif'); |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
Copy an entity (headers, parts... everything but external body data): |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
my $deepcopy = $top->dup; |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
=head2 Access examples |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
### Get the head, a MIME::Head: |
117
|
|
|
|
|
|
|
$head = $ent->head; |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
### Get the body, as a MIME::Body; |
120
|
|
|
|
|
|
|
$bodyh = $ent->bodyhandle; |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
### Get the intended MIME type (as declared in the header): |
123
|
|
|
|
|
|
|
$type = $ent->mime_type; |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
### Get the effective MIME type (in case decoding failed): |
126
|
|
|
|
|
|
|
$eff_type = $ent->effective_type; |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
### Get preamble, parts, and epilogue: |
129
|
|
|
|
|
|
|
$preamble = $ent->preamble; ### ref to array of lines |
130
|
|
|
|
|
|
|
$num_parts = $ent->parts; |
131
|
|
|
|
|
|
|
$first_part = $ent->parts(0); ### an entity |
132
|
|
|
|
|
|
|
$epilogue = $ent->epilogue; ### ref to array of lines |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
=head2 Manipulation examples |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
Muck about with the body data: |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
### Read the (unencoded) body data: |
140
|
|
|
|
|
|
|
if ($io = $ent->open("r")) { |
141
|
|
|
|
|
|
|
while (defined($_ = $io->getline)) { print $_ } |
142
|
|
|
|
|
|
|
$io->close; |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
### Write the (unencoded) body data: |
146
|
|
|
|
|
|
|
if ($io = $ent->open("w")) { |
147
|
|
|
|
|
|
|
foreach (@lines) { $io->print($_) } |
148
|
|
|
|
|
|
|
$io->close; |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
### Delete the files for any external (on-disk) data: |
152
|
|
|
|
|
|
|
$ent->purge; |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
Muck about with the signature: |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
### Sign it (automatically removes any existing signature): |
157
|
|
|
|
|
|
|
$top->sign(File=>"$ENV{HOME}/.signature"); |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
### Remove any signature within 15 lines of the end: |
160
|
|
|
|
|
|
|
$top->remove_sig(15); |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
Muck about with the headers: |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
### Compute content-lengths for singleparts based on bodies: |
165
|
|
|
|
|
|
|
### (Do this right before you print!) |
166
|
|
|
|
|
|
|
$entity->sync_headers(Length=>'COMPUTE'); |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
Muck about with the structure: |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
### If a 0- or 1-part multipart, collapse to a singlepart: |
171
|
|
|
|
|
|
|
$top->make_singlepart; |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
### If a singlepart, inflate to a multipart with 1 part: |
174
|
|
|
|
|
|
|
$top->make_multipart; |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
Delete parts: |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
### Delete some parts of a multipart message: |
179
|
|
|
|
|
|
|
my @keep = grep { keep_part($_) } $msg->parts; |
180
|
|
|
|
|
|
|
$msg->parts(\@keep); |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
=head2 Output examples |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
Print to filehandles: |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
### Print the entire message: |
188
|
|
|
|
|
|
|
$top->print(\*STDOUT); |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
### Print just the header: |
191
|
|
|
|
|
|
|
$top->print_header(\*STDOUT); |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
### Print just the (encoded) body... includes parts as well! |
194
|
|
|
|
|
|
|
$top->print_body(\*STDOUT); |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
Stringify... note that C can also be written C; |
197
|
|
|
|
|
|
|
the methods are synonymous, and neither form will be deprecated: |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
### Stringify the entire message: |
200
|
|
|
|
|
|
|
print $top->stringify; ### or $top->as_string |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
### Stringify just the header: |
203
|
|
|
|
|
|
|
print $top->stringify_header; ### or $top->header_as_string |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
### Stringify just the (encoded) body... includes parts as well! |
206
|
|
|
|
|
|
|
print $top->stringify_body; ### or $top->body_as_string |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
Debug: |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
### Output debugging info: |
211
|
|
|
|
|
|
|
$entity->dump_skeleton(\*STDERR); |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
=head1 PUBLIC INTERFACE |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
=cut |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
#------------------------------ |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
### Pragmas: |
222
|
18
|
|
|
18
|
|
94580
|
use vars qw(@ISA $VERSION); |
|
18
|
|
|
|
|
33
|
|
|
18
|
|
|
|
|
727
|
|
223
|
18
|
|
|
18
|
|
59
|
use strict; |
|
18
|
|
|
|
|
23
|
|
|
18
|
|
|
|
|
275
|
|
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
### System modules: |
226
|
18
|
|
|
18
|
|
51
|
use Carp; |
|
18
|
|
|
|
|
18
|
|
|
18
|
|
|
|
|
764
|
|
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
### Other modules: |
229
|
18
|
|
|
18
|
|
7359
|
use Mail::Internet 1.28 (); |
|
18
|
|
|
|
|
96950
|
|
|
18
|
|
|
|
|
552
|
|
230
|
18
|
|
|
18
|
|
1673
|
use Mail::Field 1.05 (); |
|
18
|
|
|
|
|
10087
|
|
|
18
|
|
|
|
|
395
|
|
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
### Kit modules: |
233
|
18
|
|
|
18
|
|
973
|
use MIME::Tools qw(:config :msgs :utils); |
|
18
|
|
|
|
|
27
|
|
|
18
|
|
|
|
|
2677
|
|
234
|
18
|
|
|
18
|
|
1625
|
use MIME::Head; |
|
18
|
|
|
|
|
50
|
|
|
18
|
|
|
|
|
330
|
|
235
|
18
|
|
|
18
|
|
1417
|
use MIME::Body; |
|
18
|
|
|
|
|
24
|
|
|
18
|
|
|
|
|
331
|
|
236
|
18
|
|
|
18
|
|
7158
|
use MIME::Decoder; |
|
18
|
|
|
|
|
34
|
|
|
18
|
|
|
|
|
53107
|
|
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
@ISA = qw(Mail::Internet); |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
#------------------------------ |
242
|
|
|
|
|
|
|
# |
243
|
|
|
|
|
|
|
# Globals... |
244
|
|
|
|
|
|
|
# |
245
|
|
|
|
|
|
|
#------------------------------ |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
### The package version, both in 1.23 style *and* usable by MakeMaker: |
248
|
|
|
|
|
|
|
$VERSION = "5.508"; |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
### Boundary counter: |
251
|
|
|
|
|
|
|
my $BCount = 0; |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
### Standard "Content-" MIME fields, for scrub(): |
254
|
|
|
|
|
|
|
my $StandardFields = 'Description|Disposition|Id|Type|Transfer-Encoding'; |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
### Known Mail/MIME fields... these, plus some general forms like |
257
|
|
|
|
|
|
|
### "x-*", are recognized by build(): |
258
|
|
|
|
|
|
|
my %KnownField = map {$_=>1} |
259
|
|
|
|
|
|
|
qw( |
260
|
|
|
|
|
|
|
bcc cc comments date encrypted |
261
|
|
|
|
|
|
|
from keywords message-id mime-version organization |
262
|
|
|
|
|
|
|
received references reply-to return-path sender |
263
|
|
|
|
|
|
|
subject to |
264
|
|
|
|
|
|
|
); |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
### Fallback preamble and epilogue: |
267
|
|
|
|
|
|
|
my $DefPreamble = [ "This is a multi-part message in MIME format...\n" ]; |
268
|
|
|
|
|
|
|
my $DefEpilogue = [ ]; |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
#============================== |
272
|
|
|
|
|
|
|
# |
273
|
|
|
|
|
|
|
# Utilities, private |
274
|
|
|
|
|
|
|
# |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
#------------------------------ |
277
|
|
|
|
|
|
|
# |
278
|
|
|
|
|
|
|
# known_field FIELDNAME |
279
|
|
|
|
|
|
|
# |
280
|
|
|
|
|
|
|
# Is this a recognized Mail/MIME field? |
281
|
|
|
|
|
|
|
# |
282
|
|
|
|
|
|
|
sub known_field { |
283
|
65
|
|
|
65
|
0
|
60
|
my $field = lc(shift); |
284
|
65
|
100
|
|
|
|
240
|
$KnownField{$field} or ($field =~ m{^(content|resent|x)-.}); |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
#------------------------------ |
288
|
|
|
|
|
|
|
# |
289
|
|
|
|
|
|
|
# make_boundary |
290
|
|
|
|
|
|
|
# |
291
|
|
|
|
|
|
|
# Return a unique boundary string. |
292
|
|
|
|
|
|
|
# This is used both internally and by MIME::ParserBase, but it is NOT in |
293
|
|
|
|
|
|
|
# the public interface! Do not use it! |
294
|
|
|
|
|
|
|
# |
295
|
|
|
|
|
|
|
# We generate one containing a "=_", as RFC2045 suggests: |
296
|
|
|
|
|
|
|
# A good strategy is to choose a boundary that includes a character |
297
|
|
|
|
|
|
|
# sequence such as "=_" which can never appear in a quoted-printable |
298
|
|
|
|
|
|
|
# body. See the definition of multipart messages in RFC 2046. |
299
|
|
|
|
|
|
|
# |
300
|
|
|
|
|
|
|
sub make_boundary { |
301
|
5
|
|
|
5
|
0
|
32
|
return "----------=_".scalar(time)."-$$-".$BCount++; |
302
|
|
|
|
|
|
|
} |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
|
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
#============================== |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
=head2 Construction |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
=over 4 |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
=cut |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
#------------------------------ |
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
=item new [SOURCE] |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
I |
323
|
|
|
|
|
|
|
Create a new, empty MIME entity. |
324
|
|
|
|
|
|
|
Basically, this uses the Mail::Internet constructor... |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
If SOURCE is an ARRAYREF, it is assumed to be an array of lines |
327
|
|
|
|
|
|
|
that will be used to create both the header and an in-core body. |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
Else, if SOURCE is defined, it is assumed to be a filehandle |
330
|
|
|
|
|
|
|
from which the header and in-core body is to be read. |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
B in either case, the body will not be I merely read! |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
=cut |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
sub new { |
337
|
208
|
|
|
208
|
1
|
263
|
my $class = shift; |
338
|
208
|
|
|
|
|
826
|
my $self = $class->Mail::Internet::new(@_); ### inherited |
339
|
208
|
|
|
|
|
8434
|
$self->{ME_Parts} = []; ### no parts extracted |
340
|
208
|
|
|
|
|
309
|
$self; |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
###------------------------------ |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
=item add_part ENTITY, [OFFSET] |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
I |
349
|
|
|
|
|
|
|
Assuming we are a multipart message, add a body part (a MIME::Entity) |
350
|
|
|
|
|
|
|
to the array of body parts. Returns the part that was just added. |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
If OFFSET is positive, the new part is added at that offset from the |
353
|
|
|
|
|
|
|
beginning of the array of parts. If it is negative, it counts from |
354
|
|
|
|
|
|
|
the end of the array. (An INDEX of -1 will place the new part at the |
355
|
|
|
|
|
|
|
very end of the array, -2 will place it as the penultimate item in the |
356
|
|
|
|
|
|
|
array, etc.) If OFFSET is not given, the new part is added to the end |
357
|
|
|
|
|
|
|
of the array. |
358
|
|
|
|
|
|
|
I |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
B in general, you only want to attach parts to entities |
361
|
|
|
|
|
|
|
with a content-type of C). |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
=cut |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
sub add_part { |
366
|
123
|
|
|
123
|
1
|
178
|
my ($self, $part, $index) = @_; |
367
|
123
|
50
|
|
|
|
239
|
defined($index) or $index = -1; |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
### Make $index count from the end if negative: |
370
|
123
|
50
|
|
|
|
219
|
$index = $#{$self->{ME_Parts}} + 2 + $index if ($index < 0); |
|
123
|
|
|
|
|
213
|
|
371
|
123
|
|
|
|
|
100
|
splice(@{$self->{ME_Parts}}, $index, 0, $part); |
|
123
|
|
|
|
|
196
|
|
372
|
123
|
|
|
|
|
167
|
$part; |
373
|
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
#------------------------------ |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
=item attach PARAMHASH |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
I |
380
|
|
|
|
|
|
|
The real quick-and-easy way to create multipart messages. |
381
|
|
|
|
|
|
|
The PARAMHASH is used to C a new entity; this method is |
382
|
|
|
|
|
|
|
basically equivalent to: |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
$entity->add_part(ref($entity)->build(PARAMHASH, Top=>0)); |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
B normally, you attach to multipart entities; however, if you |
387
|
|
|
|
|
|
|
attach something to a singlepart (like attaching a GIF to a text |
388
|
|
|
|
|
|
|
message), the singlepart will be coerced into a multipart automatically. |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
=cut |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
sub attach { |
393
|
5
|
|
|
5
|
1
|
16
|
my $self = shift; |
394
|
5
|
|
|
|
|
12
|
$self->make_multipart; |
395
|
5
|
|
|
|
|
19
|
$self->add_part(ref($self)->build(@_, Top=>0)); |
396
|
|
|
|
|
|
|
} |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
#------------------------------ |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
=item build PARAMHASH |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
I |
403
|
|
|
|
|
|
|
A quick-and-easy catch-all way to create an entity. Use it like this |
404
|
|
|
|
|
|
|
to build a "normal" single-part entity: |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
$ent = MIME::Entity->build(Type => "image/gif", |
407
|
|
|
|
|
|
|
Encoding => "base64", |
408
|
|
|
|
|
|
|
Path => "/path/to/xyz12345.gif", |
409
|
|
|
|
|
|
|
Filename => "saveme.gif", |
410
|
|
|
|
|
|
|
Disposition => "attachment"); |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
And like this to build a "multipart" entity: |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
$ent = MIME::Entity->build(Type => "multipart/mixed", |
415
|
|
|
|
|
|
|
Boundary => "---1234567"); |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
A minimal MIME header will be created. If you want to add or modify |
418
|
|
|
|
|
|
|
any header fields afterwards, you can of course do so via the underlying |
419
|
|
|
|
|
|
|
head object... but hey, there's now a prettier syntax! |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
$ent = MIME::Entity->build(Type =>"multipart/mixed", |
422
|
|
|
|
|
|
|
From => $myaddr, |
423
|
|
|
|
|
|
|
Subject => "Hi!", |
424
|
|
|
|
|
|
|
'X-Certified' => ['SINED', |
425
|
|
|
|
|
|
|
'SEELED', |
426
|
|
|
|
|
|
|
'DELIVERED']); |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
Normally, an C header field is output which contains this |
429
|
|
|
|
|
|
|
toolkit's name and version (plus this module's RCS version). |
430
|
|
|
|
|
|
|
This will allow any bad MIME we generate to be traced back to us. |
431
|
|
|
|
|
|
|
You can of course overwrite that header with your own: |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
$ent = MIME::Entity->build(Type => "multipart/mixed", |
434
|
|
|
|
|
|
|
'X-Mailer' => "myprog 1.1"); |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
Or remove it entirely: |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
$ent = MIME::Entity->build(Type => "multipart/mixed", |
439
|
|
|
|
|
|
|
'X-Mailer' => undef); |
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
OK, enough hype. The parameters are: |
442
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
=over 4 |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
=item (FIELDNAME) |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
Any field you want placed in the message header, taken from the |
448
|
|
|
|
|
|
|
standard list of header fields (you don't need to worry about case): |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
Bcc Encrypted Received Sender |
451
|
|
|
|
|
|
|
Cc From References Subject |
452
|
|
|
|
|
|
|
Comments Keywords Reply-To To |
453
|
|
|
|
|
|
|
Content-* Message-ID Resent-* X-* |
454
|
|
|
|
|
|
|
Date MIME-Version Return-Path |
455
|
|
|
|
|
|
|
Organization |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
To give experienced users some veto power, these fields will be set |
458
|
|
|
|
|
|
|
I the ones I set... so be careful: I |
459
|
|
|
|
|
|
|
(like C) unless you know what you're doing! |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
To specify a fieldname that's I in the above list, even one that's |
462
|
|
|
|
|
|
|
identical to an option below, just give it with a trailing C<":">, |
463
|
|
|
|
|
|
|
like C<"My-field:">. When in doubt, that I signals a mail |
464
|
|
|
|
|
|
|
field (and it sort of looks like one too). |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
=item Boundary |
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
I |
469
|
|
|
|
|
|
|
The boundary string. As per RFC-2046, it must consist only |
470
|
|
|
|
|
|
|
of the characters C<[0-9a-zA-Z'()+_,-./:=?]> and space (you'll be |
471
|
|
|
|
|
|
|
warned, and your boundary will be ignored, if this is not the case). |
472
|
|
|
|
|
|
|
If you omit this, a random string will be chosen... which is probably |
473
|
|
|
|
|
|
|
safer. |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
=item Charset |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
I |
478
|
|
|
|
|
|
|
The character set. |
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
=item Data |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
I |
483
|
|
|
|
|
|
|
An alternative to Path (q.v.): the actual data, either as a scalar |
484
|
|
|
|
|
|
|
or an array reference (whose elements are joined together to make |
485
|
|
|
|
|
|
|
the actual scalar). The body is opened on the data using |
486
|
|
|
|
|
|
|
MIME::Body::InCore. |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
=item Description |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
I |
491
|
|
|
|
|
|
|
The text of the content-description. |
492
|
|
|
|
|
|
|
If you don't specify it, the field is not put in the header. |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
=item Disposition |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
I |
497
|
|
|
|
|
|
|
The basic content-disposition (C<"attachment"> or C<"inline">). |
498
|
|
|
|
|
|
|
If you don't specify it, it defaults to "inline" for backwards |
499
|
|
|
|
|
|
|
compatibility. I |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
=item Encoding |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
I |
504
|
|
|
|
|
|
|
The content-transfer-encoding. |
505
|
|
|
|
|
|
|
If you don't specify it, a reasonable default is put in. |
506
|
|
|
|
|
|
|
You can also give the special value '-SUGGEST', to have it chosen for |
507
|
|
|
|
|
|
|
you in a heavy-duty fashion which scans the data itself. |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
=item Filename |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
I |
512
|
|
|
|
|
|
|
The recommended filename. Overrides any name extracted from C. |
513
|
|
|
|
|
|
|
The information is stored both the deprecated (content-type) and |
514
|
|
|
|
|
|
|
preferred (content-disposition) locations. If you explicitly want to |
515
|
|
|
|
|
|
|
I a recommended filename (even when Path is used), supply this |
516
|
|
|
|
|
|
|
as empty or undef. |
517
|
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
=item Id |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
I |
521
|
|
|
|
|
|
|
Set the content-id. |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
=item Path |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
I |
526
|
|
|
|
|
|
|
The path to the file to attach. The body is opened on that file |
527
|
|
|
|
|
|
|
using MIME::Body::File. |
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
=item Top |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
I |
532
|
|
|
|
|
|
|
Is this a top-level entity? If so, it must sport a MIME-Version. |
533
|
|
|
|
|
|
|
The default is true. (NB: look at how C uses it.) |
534
|
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
=item Type |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
I |
538
|
|
|
|
|
|
|
The basic content-type (C<"text/plain">, etc.). |
539
|
|
|
|
|
|
|
If you don't specify it, it defaults to C<"text/plain"> |
540
|
|
|
|
|
|
|
as per RFC 2045. I |
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
=back |
543
|
|
|
|
|
|
|
|
544
|
|
|
|
|
|
|
=cut |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
sub build { |
547
|
29
|
|
|
29
|
1
|
9410
|
my ($self, @paramlist) = @_; |
548
|
29
|
|
|
|
|
78
|
my %params = @paramlist; |
549
|
29
|
|
|
|
|
29
|
my ($field, $filename, $boundary); |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
### Create a new entity, if needed: |
552
|
29
|
50
|
|
|
|
90
|
ref($self) or $self = $self->new; |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
### GET INFO... |
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
### Get sundry field: |
558
|
29
|
|
100
|
|
|
88
|
my $type = $params{Type} || 'text/plain'; |
559
|
29
|
|
|
|
|
36
|
my $charset = $params{Charset}; |
560
|
29
|
|
|
|
|
50
|
my $is_multipart = ($type =~ m{^multipart/}i); |
561
|
29
|
|
100
|
|
|
79
|
my $encoding = $params{Encoding} || ''; |
562
|
29
|
|
|
|
|
28
|
my $desc = $params{Description}; |
563
|
29
|
100
|
|
|
|
51
|
my $top = exists($params{Top}) ? $params{Top} : 1; |
564
|
29
|
|
100
|
|
|
87
|
my $disposition = $params{Disposition} || 'inline'; |
565
|
29
|
|
|
|
|
25
|
my $id = $params{Id}; |
566
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
### Get recommended filename, allowing explicit no-value value: |
568
|
29
|
|
100
|
|
|
135
|
my ($path_fname) = (($params{Path}||'') =~ m{([^/]+)\Z}); |
569
|
29
|
100
|
|
|
|
44
|
$filename = (exists($params{Filename}) ? $params{Filename} : $path_fname); |
570
|
29
|
50
|
66
|
|
|
96
|
$filename = undef if (defined($filename) and $filename eq ''); |
571
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
### Type-check sanity: |
573
|
29
|
100
|
|
|
|
67
|
if ($type =~ m{^(multipart/|message/(rfc822|partial|external-body|delivery-status|disposition-notification|feedback-report)$)}i) { |
574
|
5
|
100
|
|
|
|
322
|
($encoding =~ /^(|7bit|8bit|binary|-suggest)$/i) |
575
|
|
|
|
|
|
|
or croak "can't have encoding $encoding for message type $type!"; |
576
|
|
|
|
|
|
|
} |
577
|
|
|
|
|
|
|
|
578
|
|
|
|
|
|
|
### Multipart or not? Do sanity check and fixup: |
579
|
27
|
100
|
|
|
|
38
|
if ($is_multipart) { ### multipart... |
580
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
### Get any supplied boundary, and check it: |
582
|
3
|
50
|
|
|
|
9
|
if (defined($boundary = $params{Boundary})) { ### they gave us one... |
583
|
0
|
0
|
|
|
|
0
|
if ($boundary eq '') { |
|
|
0
|
|
|
|
|
|
584
|
0
|
|
|
|
|
0
|
whine "empty string not a legal boundary: I'm ignoring it"; |
585
|
0
|
|
|
|
|
0
|
$boundary = undef; |
586
|
|
|
|
|
|
|
} |
587
|
|
|
|
|
|
|
elsif ($boundary =~ m{[^0-9a-zA-Z_\'\(\)\+\,\.\/\:\=\?\- ]}) { |
588
|
0
|
|
|
|
|
0
|
whine "boundary ignored: illegal characters ($boundary)"; |
589
|
0
|
|
|
|
|
0
|
$boundary = undef; |
590
|
|
|
|
|
|
|
} |
591
|
|
|
|
|
|
|
} |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
### If we have to roll our own boundary, do so: |
594
|
3
|
50
|
|
|
|
24
|
defined($boundary) or $boundary = make_boundary(); |
595
|
|
|
|
|
|
|
} |
596
|
|
|
|
|
|
|
else { ### single part... |
597
|
|
|
|
|
|
|
### Create body: |
598
|
24
|
100
|
|
|
|
48
|
if ($params{Path}) { |
|
|
50
|
|
|
|
|
|
599
|
14
|
|
|
|
|
64
|
$self->bodyhandle(new MIME::Body::File $params{Path}); |
600
|
|
|
|
|
|
|
} |
601
|
|
|
|
|
|
|
elsif (defined($params{Data})) { |
602
|
10
|
|
|
|
|
104
|
$self->bodyhandle(new MIME::Body::InCore $params{Data}); |
603
|
|
|
|
|
|
|
} |
604
|
|
|
|
|
|
|
else { |
605
|
0
|
|
|
|
|
0
|
die "can't build entity: no body, and not multipart\n"; |
606
|
|
|
|
|
|
|
} |
607
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
### Check whether we need to binmode(): [Steve Kilbane] |
609
|
24
|
100
|
|
|
|
57
|
$self->bodyhandle->binmode(1) unless textual_type($type); |
610
|
|
|
|
|
|
|
} |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
### MAKE HEAD... |
614
|
|
|
|
|
|
|
|
615
|
|
|
|
|
|
|
### Create head: |
616
|
27
|
|
|
|
|
65
|
my $head = new MIME::Head; |
617
|
27
|
|
|
|
|
494
|
$self->head($head); |
618
|
27
|
|
|
|
|
44
|
$head->modify(1); |
619
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
### Add content-type field: |
621
|
27
|
|
|
|
|
169
|
$field = new Mail::Field 'Content_type'; ### not a typo :-( |
622
|
27
|
|
|
|
|
88
|
$field->type($type); |
623
|
27
|
100
|
|
|
|
49
|
$field->charset($charset) if $charset; |
624
|
27
|
100
|
|
|
|
73
|
$field->name($filename) if defined($filename); |
625
|
27
|
100
|
|
|
|
55
|
$field->boundary($boundary) if defined($boundary); |
626
|
27
|
|
|
|
|
57
|
$head->replace('Content-type', $field->stringify); |
627
|
|
|
|
|
|
|
|
628
|
|
|
|
|
|
|
### Now that both body and content-type are available, we can suggest |
629
|
|
|
|
|
|
|
### content-transfer-encoding (if desired); |
630
|
27
|
100
|
|
|
|
3246
|
if (!$encoding) { |
|
|
100
|
|
|
|
|
|
631
|
22
|
|
|
|
|
59
|
$encoding = $self->suggest_encoding_lite; |
632
|
|
|
|
|
|
|
} |
633
|
|
|
|
|
|
|
elsif (lc($encoding) eq '-suggest') { |
634
|
3
|
|
|
|
|
9
|
$encoding = $self->suggest_encoding; |
635
|
|
|
|
|
|
|
} |
636
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
### Add content-disposition field (if not multipart): |
638
|
27
|
100
|
|
|
|
62
|
unless ($is_multipart) { |
639
|
24
|
|
|
|
|
67
|
$field = new Mail::Field 'Content_disposition'; ### not a typo :-( |
640
|
24
|
|
|
|
|
95
|
$field->type($disposition); |
641
|
24
|
100
|
|
|
|
68
|
$field->filename($filename) if defined($filename); |
642
|
24
|
|
|
|
|
53
|
$head->replace('Content-disposition', $field->stringify); |
643
|
|
|
|
|
|
|
} |
644
|
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
### Add other MIME fields: |
646
|
27
|
50
|
|
|
|
2315
|
$head->replace('Content-transfer-encoding', $encoding) if $encoding; |
647
|
27
|
50
|
|
|
|
2360
|
$head->replace('Content-description', $desc) if $desc; |
648
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
# Content-Id value should be surrounded by < >, but versions before 5.428 |
650
|
|
|
|
|
|
|
# did not do this. So, we check, and add if the caller has not done so |
651
|
|
|
|
|
|
|
# already. |
652
|
27
|
100
|
|
|
|
43
|
if( defined $id ) { |
653
|
2
|
100
|
|
|
|
6
|
if( $id !~ /^<.*>$/ ) { |
654
|
1
|
|
|
|
|
4
|
$id = "<$id>"; |
655
|
|
|
|
|
|
|
} |
656
|
2
|
|
|
|
|
4
|
$head->replace('Content-id', $id); |
657
|
|
|
|
|
|
|
} |
658
|
27
|
100
|
|
|
|
246
|
$head->replace('MIME-Version', '1.0') if $top; |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
### Add the X-Mailer field, if top level (use default value if not given): |
661
|
27
|
100
|
|
|
|
1922
|
$top and $head->replace('X-Mailer', |
662
|
|
|
|
|
|
|
"MIME-tools ".(MIME::Tools->version). |
663
|
|
|
|
|
|
|
" (Entity " .($VERSION).")"); |
664
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
### Add remaining user-specified fields, if any: |
666
|
27
|
|
|
|
|
1853
|
while (@paramlist) { |
667
|
67
|
|
|
|
|
513
|
my ($tag, $value) = (shift @paramlist, shift @paramlist); |
668
|
|
|
|
|
|
|
|
669
|
|
|
|
|
|
|
### Get fieldname, if that's what it is: |
670
|
67
|
100
|
|
|
|
205
|
if ($tag =~ /^-(.*)/s) { $tag = lc($1) } ### old style, b.c. |
|
2
|
50
|
|
|
|
6
|
|
|
|
100
|
|
|
|
|
|
671
|
0
|
|
|
|
|
0
|
elsif ($tag =~ /(.*):$/s ) { $tag = lc($1) } ### new style |
672
|
6
|
|
|
|
|
6
|
elsif (known_field(lc($tag))) { 1 } ### known field |
673
|
59
|
|
|
|
|
123
|
else { next; } ### not a field |
674
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
### Clear head, get list of values, and add them: |
676
|
8
|
|
|
|
|
30
|
$head->delete($tag); |
677
|
8
|
50
|
|
|
|
117
|
foreach $value (ref($value) ? @$value : ($value)) { |
678
|
8
|
50
|
33
|
|
|
34
|
(defined($value) && ($value ne '')) or next; |
679
|
8
|
|
|
|
|
27
|
$head->add($tag, $value); |
680
|
|
|
|
|
|
|
} |
681
|
|
|
|
|
|
|
} |
682
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
### Done! |
684
|
27
|
|
|
|
|
350
|
$self; |
685
|
|
|
|
|
|
|
} |
686
|
|
|
|
|
|
|
|
687
|
|
|
|
|
|
|
#------------------------------ |
688
|
|
|
|
|
|
|
|
689
|
|
|
|
|
|
|
=item dup |
690
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
I |
692
|
|
|
|
|
|
|
Duplicate the entity. Does a deep, recursive copy, I |
693
|
|
|
|
|
|
|
external data in bodyhandles is I copied to new files! |
694
|
|
|
|
|
|
|
Changing the data in one entity's data file, or purging that entity, |
695
|
|
|
|
|
|
|
I affect its duplicate. Entities with in-core data probably need |
696
|
|
|
|
|
|
|
not worry. |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
=cut |
699
|
|
|
|
|
|
|
|
700
|
|
|
|
|
|
|
sub dup { |
701
|
7
|
|
|
7
|
1
|
10
|
my $self = shift; |
702
|
7
|
|
|
|
|
7
|
local($_); |
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
### Self (this will also dup the header): |
705
|
7
|
|
|
|
|
32
|
my $dup = bless $self->SUPER::dup(), ref($self); |
706
|
|
|
|
|
|
|
|
707
|
|
|
|
|
|
|
### Any simple inst vars: |
708
|
7
|
50
|
|
|
|
762
|
foreach (keys %$self) {$dup->{$_} = $self->{$_} unless ref($self->{$_})}; |
|
20
|
|
|
|
|
39
|
|
709
|
|
|
|
|
|
|
|
710
|
|
|
|
|
|
|
### Bodyhandle: |
711
|
7
|
100
|
|
|
|
19
|
$dup->bodyhandle($self->bodyhandle ? $self->bodyhandle->dup : undef); |
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
### Preamble and epilogue: |
714
|
7
|
|
|
|
|
13
|
foreach (qw(ME_Preamble ME_Epilogue)) { |
715
|
14
|
100
|
|
|
|
25
|
$dup->{$_} = [@{$self->{$_}}] if $self->{$_}; |
|
2
|
|
|
|
|
5
|
|
716
|
|
|
|
|
|
|
} |
717
|
|
|
|
|
|
|
|
718
|
|
|
|
|
|
|
### Parts: |
719
|
7
|
|
|
|
|
11
|
$dup->{ME_Parts} = []; |
720
|
7
|
|
|
|
|
7
|
foreach (@{$self->{ME_Parts}}) { push @{$dup->{ME_Parts}}, $_->dup } |
|
7
|
|
|
|
|
15
|
|
|
4
|
|
|
|
|
4
|
|
|
4
|
|
|
|
|
8
|
|
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
### Done! |
723
|
7
|
|
|
|
|
13
|
$dup; |
724
|
|
|
|
|
|
|
} |
725
|
|
|
|
|
|
|
|
726
|
|
|
|
|
|
|
=back |
727
|
|
|
|
|
|
|
|
728
|
|
|
|
|
|
|
=cut |
729
|
|
|
|
|
|
|
|
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
|
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
|
734
|
|
|
|
|
|
|
#============================== |
735
|
|
|
|
|
|
|
|
736
|
|
|
|
|
|
|
=head2 Access |
737
|
|
|
|
|
|
|
|
738
|
|
|
|
|
|
|
=over 4 |
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
=cut |
741
|
|
|
|
|
|
|
|
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
#------------------------------ |
744
|
|
|
|
|
|
|
|
745
|
|
|
|
|
|
|
=item body [VALUE] |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
I |
748
|
|
|
|
|
|
|
Get the I (transport-ready) body, as an array of lines. |
749
|
|
|
|
|
|
|
Returns an array reference. Each array entry is a newline-terminated |
750
|
|
|
|
|
|
|
line. |
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
This is a read-only data structure: changing its contents will have |
753
|
|
|
|
|
|
|
no effect. Its contents are identical to what is printed by |
754
|
|
|
|
|
|
|
L. |
755
|
|
|
|
|
|
|
|
756
|
|
|
|
|
|
|
Provided for compatibility with Mail::Internet, so that methods |
757
|
|
|
|
|
|
|
like C will work. Note however that if VALUE is given, |
758
|
|
|
|
|
|
|
a fatal exception is thrown, since you cannot use this method to |
759
|
|
|
|
|
|
|
I the lines of the encoded message. |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
If you want the raw (unencoded) body data, use the L |
762
|
|
|
|
|
|
|
method to get and use a MIME::Body. The content-type of the entity |
763
|
|
|
|
|
|
|
will tell you whether that body is best read as text (via getline()) |
764
|
|
|
|
|
|
|
or raw data (via read()). |
765
|
|
|
|
|
|
|
|
766
|
|
|
|
|
|
|
=cut |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
sub body { |
769
|
3
|
|
|
3
|
1
|
2755
|
my ($self, $value) = @_; |
770
|
3
|
50
|
|
|
|
14
|
if (@_ > 1) { ### setting body line(s)... |
771
|
0
|
|
|
|
|
0
|
croak "you cannot use body() to set the encoded contents\n"; |
772
|
|
|
|
|
|
|
} else { |
773
|
3
|
|
|
|
|
6
|
my $output = ''; |
774
|
3
|
50
|
|
|
|
44
|
my $fh = IO::File->new(\$output, '>:') or croak("Cannot open in-memory file: $!"); |
775
|
3
|
|
|
|
|
901
|
$self->print_body($fh); |
776
|
3
|
|
|
|
|
4
|
close($fh); |
777
|
3
|
|
|
|
|
19
|
my @ary = split(/\n/, $output); |
778
|
|
|
|
|
|
|
# Each line needs the terminating newline |
779
|
3
|
|
|
|
|
6
|
@ary = map { "$_\n" } @ary; |
|
27
|
|
|
|
|
38
|
|
780
|
|
|
|
|
|
|
|
781
|
3
|
|
|
|
|
21
|
return \@ary; |
782
|
|
|
|
|
|
|
} |
783
|
|
|
|
|
|
|
} |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
#------------------------------ |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
=item bodyhandle [VALUE] |
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
I |
790
|
|
|
|
|
|
|
Get or set an abstract object representing the body of the message. |
791
|
|
|
|
|
|
|
The body holds the decoded message data. |
792
|
|
|
|
|
|
|
|
793
|
|
|
|
|
|
|
B |
794
|
|
|
|
|
|
|
An entity will have either a body or parts: not both. |
795
|
|
|
|
|
|
|
This method will I return an object if this entity can |
796
|
|
|
|
|
|
|
have a body; otherwise, it will return undefined. |
797
|
|
|
|
|
|
|
Whether-or-not a given entity can have a body is determined by |
798
|
|
|
|
|
|
|
(1) its content type, and (2) whether-or-not the parser was told to |
799
|
|
|
|
|
|
|
extract nested messages: |
800
|
|
|
|
|
|
|
|
801
|
|
|
|
|
|
|
Type: | Extract nested? | bodyhandle() | parts() |
802
|
|
|
|
|
|
|
----------------------------------------------------------------------- |
803
|
|
|
|
|
|
|
multipart/* | - | undef | 0 or more MIME::Entity |
804
|
|
|
|
|
|
|
message/* | true | undef | 0 or 1 MIME::Entity |
805
|
|
|
|
|
|
|
message/* | false | MIME::Body | empty list |
806
|
|
|
|
|
|
|
(other) | - | MIME::Body | empty list |
807
|
|
|
|
|
|
|
|
808
|
|
|
|
|
|
|
If C I given, the current bodyhandle is returned, |
809
|
|
|
|
|
|
|
or undef if the entity cannot have a body. |
810
|
|
|
|
|
|
|
|
811
|
|
|
|
|
|
|
If C I given, the bodyhandle is set to the new value, |
812
|
|
|
|
|
|
|
and the previous value is returned. |
813
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
See L for more info. |
815
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
=cut |
817
|
|
|
|
|
|
|
|
818
|
|
|
|
|
|
|
sub bodyhandle { |
819
|
605
|
|
|
605
|
1
|
8146
|
my ($self, $newvalue) = @_; |
820
|
605
|
|
|
|
|
566
|
my $value = $self->{ME_Bodyhandle}; |
821
|
605
|
100
|
|
|
|
961
|
$self->{ME_Bodyhandle} = $newvalue if (@_ > 1); |
822
|
605
|
|
|
|
|
1167
|
$value; |
823
|
|
|
|
|
|
|
} |
824
|
|
|
|
|
|
|
|
825
|
|
|
|
|
|
|
#------------------------------ |
826
|
|
|
|
|
|
|
|
827
|
|
|
|
|
|
|
=item effective_type [MIMETYPE] |
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
I |
830
|
|
|
|
|
|
|
Set/get the I MIME type of this entity. This is I |
831
|
|
|
|
|
|
|
identical to the actual (or defaulted) MIME type, but in some cases |
832
|
|
|
|
|
|
|
it differs. For example, from RFC-2045: |
833
|
|
|
|
|
|
|
|
834
|
|
|
|
|
|
|
Any entity with an unrecognized Content-Transfer-Encoding must be |
835
|
|
|
|
|
|
|
treated as if it has a Content-Type of "application/octet-stream", |
836
|
|
|
|
|
|
|
regardless of what the Content-Type header field actually says. |
837
|
|
|
|
|
|
|
|
838
|
|
|
|
|
|
|
Why? because if we can't decode the message, then we have to take |
839
|
|
|
|
|
|
|
the bytes as-is, in their (unrecognized) encoded form. So the |
840
|
|
|
|
|
|
|
message ceases to be a "text/foobar" and becomes a bunch of undecipherable |
841
|
|
|
|
|
|
|
bytes -- in other words, an "application/octet-stream". |
842
|
|
|
|
|
|
|
|
843
|
|
|
|
|
|
|
Such an entity, if parsed, would have its effective_type() set to |
844
|
|
|
|
|
|
|
C<"application/octet_stream">, although the mime_type() and the contents |
845
|
|
|
|
|
|
|
of the header would remain the same. |
846
|
|
|
|
|
|
|
|
847
|
|
|
|
|
|
|
If there is no effective type, the method just returns what |
848
|
|
|
|
|
|
|
mime_type() would. |
849
|
|
|
|
|
|
|
|
850
|
|
|
|
|
|
|
B the effective type is "sticky"; once set, that effective_type() |
851
|
|
|
|
|
|
|
will always be returned even if the conditions that necessitated setting |
852
|
|
|
|
|
|
|
the effective type become no longer true. |
853
|
|
|
|
|
|
|
|
854
|
|
|
|
|
|
|
=cut |
855
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
sub effective_type { |
857
|
284
|
|
|
284
|
1
|
233
|
my $self = shift; |
858
|
284
|
50
|
|
|
|
467
|
$self->{ME_EffType} = shift if @_; |
859
|
284
|
50
|
|
|
|
683
|
return ($self->{ME_EffType} ? lc($self->{ME_EffType}) : $self->mime_type); |
860
|
|
|
|
|
|
|
} |
861
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
#------------------------------ |
864
|
|
|
|
|
|
|
|
865
|
|
|
|
|
|
|
=item epilogue [LINES] |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
I |
868
|
|
|
|
|
|
|
Get/set the text of the epilogue, as an array of newline-terminated LINES. |
869
|
|
|
|
|
|
|
Returns a reference to the array of lines, or undef if no epilogue exists. |
870
|
|
|
|
|
|
|
|
871
|
|
|
|
|
|
|
If there is a epilogue, it is output when printing this entity; otherwise, |
872
|
|
|
|
|
|
|
a default epilogue is used. Setting the epilogue to undef (not []!) causes |
873
|
|
|
|
|
|
|
it to fallback to the default. |
874
|
|
|
|
|
|
|
|
875
|
|
|
|
|
|
|
=cut |
876
|
|
|
|
|
|
|
|
877
|
|
|
|
|
|
|
sub epilogue { |
878
|
51
|
|
|
51
|
1
|
80
|
my ($self, $lines) = @_; |
879
|
51
|
100
|
|
|
|
123
|
$self->{ME_Epilogue} = $lines if @_ > 1; |
880
|
51
|
|
|
|
|
110
|
$self->{ME_Epilogue}; |
881
|
|
|
|
|
|
|
} |
882
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
#------------------------------ |
884
|
|
|
|
|
|
|
|
885
|
|
|
|
|
|
|
=item head [VALUE] |
886
|
|
|
|
|
|
|
|
887
|
|
|
|
|
|
|
I |
888
|
|
|
|
|
|
|
Get/set the head. |
889
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
If there is no VALUE given, returns the current head. If none |
891
|
|
|
|
|
|
|
exists, an empty instance of MIME::Head is created, set, and returned. |
892
|
|
|
|
|
|
|
|
893
|
|
|
|
|
|
|
B This is a patch over a problem in Mail::Internet, which doesn't |
894
|
|
|
|
|
|
|
provide a method for setting the head to some given object. |
895
|
|
|
|
|
|
|
|
896
|
|
|
|
|
|
|
=cut |
897
|
|
|
|
|
|
|
|
898
|
|
|
|
|
|
|
sub head { |
899
|
1755
|
|
|
1755
|
1
|
1044022
|
my ($self, $value) = @_; |
900
|
1755
|
100
|
|
|
|
2526
|
(@_ > 1) and $self->{'mail_inet_head'} = $value; |
901
|
1755
|
|
66
|
|
|
5516
|
$self->{'mail_inet_head'} ||= new MIME::Head; ### KLUDGE! |
902
|
|
|
|
|
|
|
} |
903
|
|
|
|
|
|
|
|
904
|
|
|
|
|
|
|
#------------------------------ |
905
|
|
|
|
|
|
|
|
906
|
|
|
|
|
|
|
=item is_multipart |
907
|
|
|
|
|
|
|
|
908
|
|
|
|
|
|
|
I |
909
|
|
|
|
|
|
|
Does this entity's effective MIME type indicate that it's a multipart entity? |
910
|
|
|
|
|
|
|
Returns undef (false) if the answer couldn't be determined, 0 (false) |
911
|
|
|
|
|
|
|
if it was determined to be false, and true otherwise. |
912
|
|
|
|
|
|
|
Note that this says nothing about whether or not parts were extracted. |
913
|
|
|
|
|
|
|
|
914
|
|
|
|
|
|
|
NOTE: we switched to effective_type so that multiparts with |
915
|
|
|
|
|
|
|
bad or missing boundaries could be coerced to an effective type |
916
|
|
|
|
|
|
|
of C. |
917
|
|
|
|
|
|
|
|
918
|
|
|
|
|
|
|
|
919
|
|
|
|
|
|
|
=cut |
920
|
|
|
|
|
|
|
|
921
|
|
|
|
|
|
|
sub is_multipart { |
922
|
28
|
|
|
28
|
1
|
85
|
my $self = shift; |
923
|
28
|
50
|
|
|
|
40
|
$self->head or return undef; ### no head, so no MIME type! |
924
|
28
|
|
|
|
|
51
|
my ($type, $subtype) = split('/', $self->effective_type); |
925
|
28
|
100
|
|
|
|
115
|
(($type eq 'multipart') ? 1 : 0); |
926
|
|
|
|
|
|
|
} |
927
|
|
|
|
|
|
|
|
928
|
|
|
|
|
|
|
#------------------------------ |
929
|
|
|
|
|
|
|
|
930
|
|
|
|
|
|
|
=item mime_type |
931
|
|
|
|
|
|
|
|
932
|
|
|
|
|
|
|
I |
933
|
|
|
|
|
|
|
A purely-for-convenience method. This simply relays the request to the |
934
|
|
|
|
|
|
|
associated MIME::Head object. |
935
|
|
|
|
|
|
|
If there is no head, returns undef in a scalar context and |
936
|
|
|
|
|
|
|
the empty array in a list context. |
937
|
|
|
|
|
|
|
|
938
|
|
|
|
|
|
|
B consider using effective_type() instead, |
939
|
|
|
|
|
|
|
especially if you obtained the entity from a MIME::Parser. |
940
|
|
|
|
|
|
|
|
941
|
|
|
|
|
|
|
=cut |
942
|
|
|
|
|
|
|
|
943
|
|
|
|
|
|
|
sub mime_type { |
944
|
363
|
|
|
363
|
1
|
824
|
my $self = shift; |
945
|
363
|
0
|
|
|
|
503
|
$self->head or return (wantarray ? () : undef); |
|
|
50
|
|
|
|
|
|
946
|
363
|
|
|
|
|
510
|
$self->head->mime_type; |
947
|
|
|
|
|
|
|
} |
948
|
|
|
|
|
|
|
|
949
|
|
|
|
|
|
|
#------------------------------ |
950
|
|
|
|
|
|
|
|
951
|
|
|
|
|
|
|
=item open READWRITE |
952
|
|
|
|
|
|
|
|
953
|
|
|
|
|
|
|
I |
954
|
|
|
|
|
|
|
A purely-for-convenience method. This simply relays the request to the |
955
|
|
|
|
|
|
|
associated MIME::Body object (see MIME::Body::open()). |
956
|
|
|
|
|
|
|
READWRITE is either 'r' (open for read) or 'w' (open for write). |
957
|
|
|
|
|
|
|
|
958
|
|
|
|
|
|
|
If there is no body, returns false. |
959
|
|
|
|
|
|
|
|
960
|
|
|
|
|
|
|
=cut |
961
|
|
|
|
|
|
|
|
962
|
|
|
|
|
|
|
sub open { |
963
|
68
|
|
|
68
|
1
|
50
|
my $self = shift; |
964
|
68
|
50
|
|
|
|
95
|
$self->bodyhandle and $self->bodyhandle->open(@_); |
965
|
|
|
|
|
|
|
} |
966
|
|
|
|
|
|
|
|
967
|
|
|
|
|
|
|
#------------------------------ |
968
|
|
|
|
|
|
|
|
969
|
|
|
|
|
|
|
=item parts |
970
|
|
|
|
|
|
|
|
971
|
|
|
|
|
|
|
=item parts INDEX |
972
|
|
|
|
|
|
|
|
973
|
|
|
|
|
|
|
=item parts ARRAYREF |
974
|
|
|
|
|
|
|
|
975
|
|
|
|
|
|
|
I |
976
|
|
|
|
|
|
|
Return the MIME::Entity objects which are the sub parts of this |
977
|
|
|
|
|
|
|
entity (if any). |
978
|
|
|
|
|
|
|
|
979
|
|
|
|
|
|
|
I returns the array of all sub parts, |
980
|
|
|
|
|
|
|
returning the empty array if there are none (e.g., if this is a single |
981
|
|
|
|
|
|
|
part message, or a degenerate multipart). In a scalar context, this |
982
|
|
|
|
|
|
|
returns you the number of parts. |
983
|
|
|
|
|
|
|
|
984
|
|
|
|
|
|
|
I return the INDEXed part, |
985
|
|
|
|
|
|
|
or undef if it doesn't exist. |
986
|
|
|
|
|
|
|
|
987
|
|
|
|
|
|
|
I then this method I |
988
|
|
|
|
|
|
|
the parts to a copy of that array, and returns the parts. This can |
989
|
|
|
|
|
|
|
be used to delete parts, as follows: |
990
|
|
|
|
|
|
|
|
991
|
|
|
|
|
|
|
### Delete some parts of a multipart message: |
992
|
|
|
|
|
|
|
$msg->parts([ grep { keep_part($_) } $msg->parts ]); |
993
|
|
|
|
|
|
|
|
994
|
|
|
|
|
|
|
|
995
|
|
|
|
|
|
|
B for multipart messages, the preamble and epilogue are I |
996
|
|
|
|
|
|
|
considered parts. If you need them, use the C and C |
997
|
|
|
|
|
|
|
methods. |
998
|
|
|
|
|
|
|
|
999
|
|
|
|
|
|
|
B there are ways of parsing with a MIME::Parser which cause |
1000
|
|
|
|
|
|
|
certain message parts (such as those of type C) |
1001
|
|
|
|
|
|
|
to be "reparsed" into pseudo-multipart entities. You should read the |
1002
|
|
|
|
|
|
|
documentation for those options carefully: it I possible for |
1003
|
|
|
|
|
|
|
a diddled entity to not be multipart, but still have parts attached to it! |
1004
|
|
|
|
|
|
|
|
1005
|
|
|
|
|
|
|
See L for a discussion of parts vs. bodies. |
1006
|
|
|
|
|
|
|
|
1007
|
|
|
|
|
|
|
=cut |
1008
|
|
|
|
|
|
|
|
1009
|
|
|
|
|
|
|
sub parts { |
1010
|
211
|
|
|
211
|
1
|
3657
|
my $self = shift; |
1011
|
211
|
100
|
|
|
|
354
|
ref($_[0]) and return @{$self->{ME_Parts} = [@{$_[0]}]}; ### set the parts |
|
5
|
|
|
|
|
8
|
|
|
5
|
|
|
|
|
20
|
|
1012
|
206
|
100
|
|
|
|
449
|
(@_ ? $self->{ME_Parts}[$_[0]] : @{$self->{ME_Parts}}); |
|
100
|
|
|
|
|
213
|
|
1013
|
|
|
|
|
|
|
} |
1014
|
|
|
|
|
|
|
|
1015
|
|
|
|
|
|
|
#------------------------------ |
1016
|
|
|
|
|
|
|
|
1017
|
|
|
|
|
|
|
=item parts_DFS |
1018
|
|
|
|
|
|
|
|
1019
|
|
|
|
|
|
|
I |
1020
|
|
|
|
|
|
|
Return the list of all MIME::Entity objects included in the entity, |
1021
|
|
|
|
|
|
|
starting with the entity itself, in depth-first-search order. |
1022
|
|
|
|
|
|
|
If the entity has no parts, it alone will be returned. |
1023
|
|
|
|
|
|
|
|
1024
|
|
|
|
|
|
|
I |
1025
|
|
|
|
|
|
|
|
1026
|
|
|
|
|
|
|
=cut |
1027
|
|
|
|
|
|
|
|
1028
|
|
|
|
|
|
|
sub parts_DFS { |
1029
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
1030
|
0
|
|
|
|
|
0
|
return ($self, map { $_->parts_DFS } $self->parts); |
|
0
|
|
|
|
|
0
|
|
1031
|
|
|
|
|
|
|
} |
1032
|
|
|
|
|
|
|
|
1033
|
|
|
|
|
|
|
#------------------------------ |
1034
|
|
|
|
|
|
|
|
1035
|
|
|
|
|
|
|
=item preamble [LINES] |
1036
|
|
|
|
|
|
|
|
1037
|
|
|
|
|
|
|
I |
1038
|
|
|
|
|
|
|
Get/set the text of the preamble, as an array of newline-terminated LINES. |
1039
|
|
|
|
|
|
|
Returns a reference to the array of lines, or undef if no preamble exists |
1040
|
|
|
|
|
|
|
(e.g., if this is a single-part entity). |
1041
|
|
|
|
|
|
|
|
1042
|
|
|
|
|
|
|
If there is a preamble, it is output when printing this entity; otherwise, |
1043
|
|
|
|
|
|
|
a default preamble is used. Setting the preamble to undef (not []!) causes |
1044
|
|
|
|
|
|
|
it to fallback to the default. |
1045
|
|
|
|
|
|
|
|
1046
|
|
|
|
|
|
|
=cut |
1047
|
|
|
|
|
|
|
|
1048
|
|
|
|
|
|
|
sub preamble { |
1049
|
58
|
|
|
58
|
1
|
1731
|
my ($self, $lines) = @_; |
1050
|
58
|
100
|
|
|
|
165
|
$self->{ME_Preamble} = $lines if @_ > 1; |
1051
|
58
|
|
|
|
|
99
|
$self->{ME_Preamble}; |
1052
|
|
|
|
|
|
|
} |
1053
|
|
|
|
|
|
|
|
1054
|
|
|
|
|
|
|
|
1055
|
|
|
|
|
|
|
|
1056
|
|
|
|
|
|
|
|
1057
|
|
|
|
|
|
|
|
1058
|
|
|
|
|
|
|
=back |
1059
|
|
|
|
|
|
|
|
1060
|
|
|
|
|
|
|
=cut |
1061
|
|
|
|
|
|
|
|
1062
|
|
|
|
|
|
|
|
1063
|
|
|
|
|
|
|
|
1064
|
|
|
|
|
|
|
|
1065
|
|
|
|
|
|
|
#============================== |
1066
|
|
|
|
|
|
|
|
1067
|
|
|
|
|
|
|
=head2 Manipulation |
1068
|
|
|
|
|
|
|
|
1069
|
|
|
|
|
|
|
=over 4 |
1070
|
|
|
|
|
|
|
|
1071
|
|
|
|
|
|
|
=cut |
1072
|
|
|
|
|
|
|
|
1073
|
|
|
|
|
|
|
#------------------------------ |
1074
|
|
|
|
|
|
|
|
1075
|
|
|
|
|
|
|
=item make_multipart [SUBTYPE], OPTSHASH... |
1076
|
|
|
|
|
|
|
|
1077
|
|
|
|
|
|
|
I |
1078
|
|
|
|
|
|
|
Force the entity to be a multipart, if it isn't already. |
1079
|
|
|
|
|
|
|
We do this by replacing the original [singlepart] entity with a new |
1080
|
|
|
|
|
|
|
multipart that has the same non-MIME headers ("From", "Subject", etc.), |
1081
|
|
|
|
|
|
|
but all-new MIME headers ("Content-type", etc.). We then create |
1082
|
|
|
|
|
|
|
a copy of the original singlepart, I the non-MIME headers |
1083
|
|
|
|
|
|
|
from that, and make it a part of the new multipart. So this: |
1084
|
|
|
|
|
|
|
|
1085
|
|
|
|
|
|
|
From: me |
1086
|
|
|
|
|
|
|
To: you |
1087
|
|
|
|
|
|
|
Content-type: text/plain |
1088
|
|
|
|
|
|
|
Content-length: 12 |
1089
|
|
|
|
|
|
|
|
1090
|
|
|
|
|
|
|
Hello there! |
1091
|
|
|
|
|
|
|
|
1092
|
|
|
|
|
|
|
Becomes something like this: |
1093
|
|
|
|
|
|
|
|
1094
|
|
|
|
|
|
|
From: me |
1095
|
|
|
|
|
|
|
To: you |
1096
|
|
|
|
|
|
|
Content-type: multipart/mixed; boundary="----abc----" |
1097
|
|
|
|
|
|
|
|
1098
|
|
|
|
|
|
|
------abc---- |
1099
|
|
|
|
|
|
|
Content-type: text/plain |
1100
|
|
|
|
|
|
|
Content-length: 12 |
1101
|
|
|
|
|
|
|
|
1102
|
|
|
|
|
|
|
Hello there! |
1103
|
|
|
|
|
|
|
------abc------ |
1104
|
|
|
|
|
|
|
|
1105
|
|
|
|
|
|
|
The actual type of the new top-level multipart will be "multipart/SUBTYPE" |
1106
|
|
|
|
|
|
|
(default SUBTYPE is "mixed"). |
1107
|
|
|
|
|
|
|
|
1108
|
|
|
|
|
|
|
Returns 'DONE' if we really did inflate a singlepart to a multipart. |
1109
|
|
|
|
|
|
|
Returns 'ALREADY' (and does nothing) if entity is I multipart |
1110
|
|
|
|
|
|
|
and Force was not chosen. |
1111
|
|
|
|
|
|
|
|
1112
|
|
|
|
|
|
|
If OPTSHASH contains Force=>1, then we I bump the top-level's |
1113
|
|
|
|
|
|
|
content and content-headers down to a subpart of this entity, even if |
1114
|
|
|
|
|
|
|
this entity is already a multipart. This is apparently of use to |
1115
|
|
|
|
|
|
|
people who are tweaking messages after parsing them. |
1116
|
|
|
|
|
|
|
|
1117
|
|
|
|
|
|
|
=cut |
1118
|
|
|
|
|
|
|
|
1119
|
|
|
|
|
|
|
sub make_multipart { |
1120
|
7
|
|
|
7
|
1
|
10
|
my ($self, $subtype, %opts) = @_; |
1121
|
7
|
|
|
|
|
11
|
my $tag; |
1122
|
7
|
|
50
|
|
|
29
|
$subtype ||= 'mixed'; |
1123
|
7
|
|
|
|
|
11
|
my $force = $opts{Force}; |
1124
|
|
|
|
|
|
|
|
1125
|
|
|
|
|
|
|
### Trap for simple case: already a multipart? |
1126
|
7
|
100
|
66
|
|
|
18
|
return 'ALREADY' if ($self->is_multipart and !$force); |
1127
|
|
|
|
|
|
|
|
1128
|
|
|
|
|
|
|
### Rip out our guts, and spew them into our future part: |
1129
|
2
|
|
|
|
|
8
|
my $part = bless {%$self}, ref($self); ### part is a shallow copy |
1130
|
2
|
|
|
|
|
6
|
%$self = (); ### lobotomize ourselves! |
1131
|
2
|
|
|
|
|
5
|
$self->head($part->head->dup); ### dup the header |
1132
|
|
|
|
|
|
|
|
1133
|
|
|
|
|
|
|
### Remove content headers from top-level, and set it up as a multipart: |
1134
|
2
|
|
|
|
|
6
|
foreach $tag (grep {/^content-/i} $self->head->tags) { |
|
3
|
|
|
|
|
9
|
|
1135
|
0
|
|
|
|
|
0
|
$self->head->delete($tag); |
1136
|
|
|
|
|
|
|
} |
1137
|
2
|
|
|
|
|
10
|
$self->head->mime_attr('Content-type' => "multipart/$subtype"); |
1138
|
2
|
|
|
|
|
31
|
$self->head->mime_attr('Content-type.boundary' => make_boundary()); |
1139
|
|
|
|
|
|
|
|
1140
|
|
|
|
|
|
|
### Remove NON-content headers from the part: |
1141
|
2
|
|
|
|
|
6
|
foreach $tag (grep {!/^content-/i} $part->head->tags) { |
|
3
|
|
|
|
|
8
|
|
1142
|
3
|
|
|
|
|
100
|
$part->head->delete($tag); |
1143
|
|
|
|
|
|
|
} |
1144
|
|
|
|
|
|
|
|
1145
|
|
|
|
|
|
|
### Add the [sole] part: |
1146
|
2
|
|
|
|
|
35
|
$self->{ME_Parts} = []; |
1147
|
2
|
|
|
|
|
6
|
$self->add_part($part); |
1148
|
2
|
|
|
|
|
4
|
'DONE'; |
1149
|
|
|
|
|
|
|
} |
1150
|
|
|
|
|
|
|
|
1151
|
|
|
|
|
|
|
#------------------------------ |
1152
|
|
|
|
|
|
|
|
1153
|
|
|
|
|
|
|
=item make_singlepart |
1154
|
|
|
|
|
|
|
|
1155
|
|
|
|
|
|
|
I |
1156
|
|
|
|
|
|
|
If the entity is a multipart message with one part, this tries hard to |
1157
|
|
|
|
|
|
|
rewrite it as a singlepart, by replacing the content (and content headers) |
1158
|
|
|
|
|
|
|
of the top level with those of the part. Also crunches 0-part multiparts |
1159
|
|
|
|
|
|
|
into singleparts. |
1160
|
|
|
|
|
|
|
|
1161
|
|
|
|
|
|
|
Returns 'DONE' if we really did collapse a multipart to a singlepart. |
1162
|
|
|
|
|
|
|
Returns 'ALREADY' (and does nothing) if entity is already a singlepart. |
1163
|
|
|
|
|
|
|
Returns '0' (and does nothing) if it can't be made into a singlepart. |
1164
|
|
|
|
|
|
|
|
1165
|
|
|
|
|
|
|
=cut |
1166
|
|
|
|
|
|
|
|
1167
|
|
|
|
|
|
|
sub make_singlepart { |
1168
|
1
|
|
|
1
|
1
|
9
|
my $self = shift; |
1169
|
|
|
|
|
|
|
|
1170
|
|
|
|
|
|
|
### Trap for simple cases: |
1171
|
1
|
50
|
|
|
|
5
|
return 'ALREADY' if !$self->is_multipart; ### already a singlepart? |
1172
|
1
|
50
|
|
|
|
4
|
return '0' if ($self->parts > 1); ### can this even be done? |
1173
|
|
|
|
|
|
|
|
1174
|
|
|
|
|
|
|
# Get rid of all our existing content info |
1175
|
1
|
|
|
|
|
2
|
my $tag; |
1176
|
1
|
|
|
|
|
5
|
foreach $tag (grep {/^content-/i} $self->head->tags) { |
|
13
|
|
|
|
|
35
|
|
1177
|
1
|
|
|
|
|
3
|
$self->head->delete($tag); |
1178
|
|
|
|
|
|
|
} |
1179
|
|
|
|
|
|
|
|
1180
|
1
|
50
|
|
|
|
172
|
if ($self->parts == 1) { ### one part |
1181
|
0
|
|
|
|
|
0
|
my $part = $self->parts(0); |
1182
|
|
|
|
|
|
|
|
1183
|
|
|
|
|
|
|
### Populate ourselves with any content info from the part: |
1184
|
0
|
|
|
|
|
0
|
foreach $tag (grep {/^content-/i} $part->head->tags) { |
|
0
|
|
|
|
|
0
|
|
1185
|
0
|
|
|
|
|
0
|
foreach ($part->head->get($tag)) { $self->head->add($tag, $_) } |
|
0
|
|
|
|
|
0
|
|
1186
|
|
|
|
|
|
|
} |
1187
|
|
|
|
|
|
|
|
1188
|
|
|
|
|
|
|
### Save reconstructed header, replace our guts, and restore header: |
1189
|
0
|
|
|
|
|
0
|
my $new_head = $self->head; |
1190
|
0
|
|
|
|
|
0
|
%$self = %$part; ### shallow copy is ok! |
1191
|
0
|
|
|
|
|
0
|
$self->head($new_head); |
1192
|
|
|
|
|
|
|
|
1193
|
|
|
|
|
|
|
### One more thing: the part *may* have been a multi with 0 or 1 parts! |
1194
|
0
|
0
|
|
|
|
0
|
return $self->make_singlepart(@_) if $self->is_multipart; |
1195
|
|
|
|
|
|
|
} |
1196
|
|
|
|
|
|
|
else { ### no parts! |
1197
|
1
|
|
|
|
|
5
|
$self->head->mime_attr('Content-type'=>'text/plain'); ### simple |
1198
|
|
|
|
|
|
|
} |
1199
|
1
|
|
|
|
|
9
|
'DONE'; |
1200
|
|
|
|
|
|
|
} |
1201
|
|
|
|
|
|
|
|
1202
|
|
|
|
|
|
|
#------------------------------ |
1203
|
|
|
|
|
|
|
|
1204
|
|
|
|
|
|
|
=item purge |
1205
|
|
|
|
|
|
|
|
1206
|
|
|
|
|
|
|
I |
1207
|
|
|
|
|
|
|
Recursively purge (e.g., unlink) all external (e.g., on-disk) body parts |
1208
|
|
|
|
|
|
|
in this message. See MIME::Body::purge() for details. |
1209
|
|
|
|
|
|
|
|
1210
|
|
|
|
|
|
|
B this does I delete the directories that those body parts |
1211
|
|
|
|
|
|
|
are contained in; only the actual message data files are deleted. |
1212
|
|
|
|
|
|
|
This is because some parsers may be customized to create intermediate |
1213
|
|
|
|
|
|
|
directories while others are not, and it's impossible for this class |
1214
|
|
|
|
|
|
|
to know what directories are safe to remove. Only your application |
1215
|
|
|
|
|
|
|
program truly knows that. |
1216
|
|
|
|
|
|
|
|
1217
|
|
|
|
|
|
|
B one good way is to |
1218
|
|
|
|
|
|
|
use C, and then do this before parsing |
1219
|
|
|
|
|
|
|
your next message: |
1220
|
|
|
|
|
|
|
|
1221
|
|
|
|
|
|
|
$parser->filer->purge(); |
1222
|
|
|
|
|
|
|
|
1223
|
|
|
|
|
|
|
I wouldn't attempt to read those body files after you do this, for |
1224
|
|
|
|
|
|
|
obvious reasons. As of MIME-tools 4.x, each body's path I undefined |
1225
|
|
|
|
|
|
|
after this operation. I warned you I might do this; truly I did. |
1226
|
|
|
|
|
|
|
|
1227
|
|
|
|
|
|
|
I |
1228
|
|
|
|
|
|
|
|
1229
|
|
|
|
|
|
|
=cut |
1230
|
|
|
|
|
|
|
|
1231
|
|
|
|
|
|
|
sub purge { |
1232
|
4
|
|
|
4
|
1
|
6
|
my $self = shift; |
1233
|
4
|
100
|
|
|
|
6
|
$self->bodyhandle and $self->bodyhandle->purge; ### purge me |
1234
|
4
|
|
|
|
|
6
|
foreach ($self->parts) { $_->purge } ### recurse |
|
3
|
|
|
|
|
6
|
|
1235
|
4
|
|
|
|
|
6
|
1; |
1236
|
|
|
|
|
|
|
} |
1237
|
|
|
|
|
|
|
|
1238
|
|
|
|
|
|
|
#------------------------------ |
1239
|
|
|
|
|
|
|
# |
1240
|
|
|
|
|
|
|
# _do_remove_sig |
1241
|
|
|
|
|
|
|
# |
1242
|
|
|
|
|
|
|
# Private. Remove a signature within NLINES lines from the end of BODY. |
1243
|
|
|
|
|
|
|
# The signature must be flagged by a line containing only "-- ". |
1244
|
|
|
|
|
|
|
|
1245
|
|
|
|
|
|
|
sub _do_remove_sig { |
1246
|
4
|
|
|
4
|
|
5
|
my ($body, $nlines) = @_; |
1247
|
4
|
|
100
|
|
|
13
|
$nlines ||= 10; |
1248
|
4
|
|
|
|
|
4
|
my $i = 0; |
1249
|
|
|
|
|
|
|
|
1250
|
4
|
|
50
|
|
|
8
|
my $line = int(@$body) || return; |
1251
|
4
|
|
66
|
|
|
15
|
while ($i++ < $nlines and $line--) { |
1252
|
25
|
100
|
|
|
|
75
|
if ($body->[$line] =~ /\A--[ \040][\r\n]+\Z/) { |
1253
|
2
|
|
|
|
|
3
|
$#{$body} = $line-1; |
|
2
|
|
|
|
|
7
|
|
1254
|
2
|
|
|
|
|
3
|
return; |
1255
|
|
|
|
|
|
|
} |
1256
|
|
|
|
|
|
|
} |
1257
|
|
|
|
|
|
|
} |
1258
|
|
|
|
|
|
|
|
1259
|
|
|
|
|
|
|
#------------------------------ |
1260
|
|
|
|
|
|
|
|
1261
|
|
|
|
|
|
|
=item remove_sig [NLINES] |
1262
|
|
|
|
|
|
|
|
1263
|
|
|
|
|
|
|
I |
1264
|
|
|
|
|
|
|
Attempts to remove a user's signature from the body of a message. |
1265
|
|
|
|
|
|
|
|
1266
|
|
|
|
|
|
|
It does this by looking for a line matching C^-- $/> within the last |
1267
|
|
|
|
|
|
|
C of the message. If found then that line and all lines after |
1268
|
|
|
|
|
|
|
it will be removed. If C is not given, a default value of 10 |
1269
|
|
|
|
|
|
|
will be used. This would be of most use in auto-reply scripts. |
1270
|
|
|
|
|
|
|
|
1271
|
|
|
|
|
|
|
For MIME entity, this method is reasonably cautious: it will only |
1272
|
|
|
|
|
|
|
attempt to un-sign a message with a content-type of C. |
1273
|
|
|
|
|
|
|
|
1274
|
|
|
|
|
|
|
If you send remove_sig() to a multipart entity, it will relay it to |
1275
|
|
|
|
|
|
|
the first part (the others usually being the "attachments"). |
1276
|
|
|
|
|
|
|
|
1277
|
|
|
|
|
|
|
B currently slurps the whole message-part into core as an |
1278
|
|
|
|
|
|
|
array of lines, so you probably don't want to use this on extremely |
1279
|
|
|
|
|
|
|
long messages. |
1280
|
|
|
|
|
|
|
|
1281
|
|
|
|
|
|
|
Returns truth on success, false on error. |
1282
|
|
|
|
|
|
|
|
1283
|
|
|
|
|
|
|
=cut |
1284
|
|
|
|
|
|
|
|
1285
|
|
|
|
|
|
|
sub remove_sig { |
1286
|
3
|
|
|
3
|
1
|
633
|
my $self = shift; |
1287
|
3
|
|
|
|
|
3
|
my $nlines = shift; |
1288
|
|
|
|
|
|
|
|
1289
|
|
|
|
|
|
|
# If multipart, we only attempt to remove the sig from the first |
1290
|
|
|
|
|
|
|
# part. This is usually a good assumption for multipart/mixed, but |
1291
|
|
|
|
|
|
|
# may not always be correct. It is also possibly incorrect on |
1292
|
|
|
|
|
|
|
# multipart/alternative (both may have sigs). |
1293
|
3
|
100
|
|
|
|
8
|
if( $self->is_multipart ) { |
1294
|
2
|
|
|
|
|
6
|
my $first_part = $self->parts(0); |
1295
|
2
|
100
|
|
|
|
5
|
if( $first_part ) { |
1296
|
1
|
|
|
|
|
4
|
return $first_part->remove_sig(@_); |
1297
|
|
|
|
|
|
|
} |
1298
|
1
|
|
|
|
|
4
|
return undef; |
1299
|
|
|
|
|
|
|
} |
1300
|
|
|
|
|
|
|
|
1301
|
|
|
|
|
|
|
### Refuse non-textual unless forced: |
1302
|
1
|
50
|
|
|
|
4
|
textual_type($self->head->mime_type) |
1303
|
|
|
|
|
|
|
or return error "I won't un-sign a non-text message unless I'm forced"; |
1304
|
|
|
|
|
|
|
|
1305
|
|
|
|
|
|
|
### Get body data, as an array of newline-terminated lines: |
1306
|
1
|
50
|
|
|
|
4
|
$self->bodyhandle or return undef; |
1307
|
1
|
|
|
|
|
3
|
my @body = $self->bodyhandle->as_lines; |
1308
|
|
|
|
|
|
|
|
1309
|
|
|
|
|
|
|
### Nuke sig: |
1310
|
1
|
|
|
|
|
3
|
_do_remove_sig(\@body, $nlines); |
1311
|
|
|
|
|
|
|
|
1312
|
|
|
|
|
|
|
### Output data back into body: |
1313
|
1
|
|
|
|
|
3
|
my $io = $self->bodyhandle->open("w"); |
1314
|
1
|
|
|
|
|
3
|
foreach (@body) { $io->print($_) }; ### body data |
|
6
|
|
|
|
|
27
|
|
1315
|
1
|
|
|
|
|
4
|
$io->close; |
1316
|
|
|
|
|
|
|
|
1317
|
|
|
|
|
|
|
### Done! |
1318
|
1
|
|
|
|
|
25
|
1; |
1319
|
|
|
|
|
|
|
} |
1320
|
|
|
|
|
|
|
|
1321
|
|
|
|
|
|
|
#------------------------------ |
1322
|
|
|
|
|
|
|
|
1323
|
|
|
|
|
|
|
=item sign PARAMHASH |
1324
|
|
|
|
|
|
|
|
1325
|
|
|
|
|
|
|
I |
1326
|
|
|
|
|
|
|
Append a signature to the message. The params are: |
1327
|
|
|
|
|
|
|
|
1328
|
|
|
|
|
|
|
=over 4 |
1329
|
|
|
|
|
|
|
|
1330
|
|
|
|
|
|
|
=item Attach |
1331
|
|
|
|
|
|
|
|
1332
|
|
|
|
|
|
|
Instead of appending the text, add it to the message as an attachment. |
1333
|
|
|
|
|
|
|
The disposition will be C, and the description will indicate |
1334
|
|
|
|
|
|
|
that it is a signature. The default behavior is to append the signature |
1335
|
|
|
|
|
|
|
to the text of the message (or the text of its first part if multipart). |
1336
|
|
|
|
|
|
|
I |
1337
|
|
|
|
|
|
|
|
1338
|
|
|
|
|
|
|
=item File |
1339
|
|
|
|
|
|
|
|
1340
|
|
|
|
|
|
|
Use the contents of this file as the signature. |
1341
|
|
|
|
|
|
|
Fatal error if it can't be read. |
1342
|
|
|
|
|
|
|
I |
1343
|
|
|
|
|
|
|
|
1344
|
|
|
|
|
|
|
=item Force |
1345
|
|
|
|
|
|
|
|
1346
|
|
|
|
|
|
|
Sign it even if the content-type isn't C. Useful for |
1347
|
|
|
|
|
|
|
non-standard types like C, but be careful! |
1348
|
|
|
|
|
|
|
I |
1349
|
|
|
|
|
|
|
|
1350
|
|
|
|
|
|
|
=item Remove |
1351
|
|
|
|
|
|
|
|
1352
|
|
|
|
|
|
|
Normally, we attempt to strip out any existing signature. |
1353
|
|
|
|
|
|
|
If true, this gives us the NLINES parameter of the remove_sig call. |
1354
|
|
|
|
|
|
|
If zero but defined, tells us I to remove any existing signature. |
1355
|
|
|
|
|
|
|
If undefined, removal is done with the default of 10 lines. |
1356
|
|
|
|
|
|
|
I |
1357
|
|
|
|
|
|
|
|
1358
|
|
|
|
|
|
|
=item Signature |
1359
|
|
|
|
|
|
|
|
1360
|
|
|
|
|
|
|
Use this text as the signature. You can supply it as either |
1361
|
|
|
|
|
|
|
a scalar, or as a ref to an array of newline-terminated scalars. |
1362
|
|
|
|
|
|
|
I |
1363
|
|
|
|
|
|
|
|
1364
|
|
|
|
|
|
|
=back |
1365
|
|
|
|
|
|
|
|
1366
|
|
|
|
|
|
|
For MIME messages, this method is reasonably cautious: it will only |
1367
|
|
|
|
|
|
|
attempt to sign a message with a content-type of C, unless |
1368
|
|
|
|
|
|
|
C is specified. |
1369
|
|
|
|
|
|
|
|
1370
|
|
|
|
|
|
|
If you send this message to a multipart entity, it will relay it to |
1371
|
|
|
|
|
|
|
the first part (the others usually being the "attachments"). |
1372
|
|
|
|
|
|
|
|
1373
|
|
|
|
|
|
|
B currently slurps the whole message-part into core as an |
1374
|
|
|
|
|
|
|
array of lines, so you probably don't want to use this on extremely |
1375
|
|
|
|
|
|
|
long messages. |
1376
|
|
|
|
|
|
|
|
1377
|
|
|
|
|
|
|
Returns true on success, false otherwise. |
1378
|
|
|
|
|
|
|
|
1379
|
|
|
|
|
|
|
=cut |
1380
|
|
|
|
|
|
|
|
1381
|
|
|
|
|
|
|
sub sign { |
1382
|
6
|
|
|
6
|
1
|
643
|
my $self = shift; |
1383
|
6
|
|
|
|
|
12
|
my %params = @_; |
1384
|
6
|
|
|
|
|
4
|
my $io; |
1385
|
|
|
|
|
|
|
|
1386
|
|
|
|
|
|
|
### If multipart and not attaching, try to sign our first part: |
1387
|
6
|
100
|
66
|
|
|
12
|
if ($self->is_multipart and !$params{Attach}) { |
1388
|
3
|
|
|
|
|
5
|
return $self->parts(0)->sign(@_); |
1389
|
|
|
|
|
|
|
} |
1390
|
|
|
|
|
|
|
|
1391
|
|
|
|
|
|
|
### Get signature: |
1392
|
3
|
|
|
|
|
4
|
my $sig; |
1393
|
3
|
50
|
|
|
|
9
|
if (defined($sig = $params{Signature})) { ### scalar or array |
|
|
50
|
|
|
|
|
|
1394
|
0
|
0
|
|
|
|
0
|
$sig = (ref($sig) ? join('', @$sig) : $sig); |
1395
|
|
|
|
|
|
|
} |
1396
|
|
|
|
|
|
|
elsif ($params{File}) { ### file contents |
1397
|
3
|
50
|
|
|
|
13
|
my $fh = IO::File->new( $params{File} ) or croak "can't open $params{File}: $!"; |
1398
|
3
|
|
|
|
|
204
|
$sig = join('', $fh->getlines); |
1399
|
3
|
50
|
|
|
|
124
|
$fh->close or croak "can't close $params{File}: $!"; |
1400
|
|
|
|
|
|
|
} |
1401
|
|
|
|
|
|
|
else { |
1402
|
0
|
|
|
|
|
0
|
croak "no signature given!"; |
1403
|
|
|
|
|
|
|
} |
1404
|
|
|
|
|
|
|
|
1405
|
|
|
|
|
|
|
### Add signature to message as appropriate: |
1406
|
3
|
50
|
|
|
|
49
|
if ($params{Attach}) { ### Attach .sig as new part... |
1407
|
0
|
|
|
|
|
0
|
return $self->attach(Type => 'text/plain', |
1408
|
|
|
|
|
|
|
Description => 'Signature', |
1409
|
|
|
|
|
|
|
Disposition => 'inline', |
1410
|
|
|
|
|
|
|
Encoding => '-SUGGEST', |
1411
|
|
|
|
|
|
|
Data => $sig); |
1412
|
|
|
|
|
|
|
} |
1413
|
|
|
|
|
|
|
else { ### Add text of .sig to body data... |
1414
|
|
|
|
|
|
|
|
1415
|
|
|
|
|
|
|
### Refuse non-textual unless forced: |
1416
|
3
|
0
|
33
|
|
|
7
|
($self->head->mime_type =~ m{text/}i or $params{Force}) or |
1417
|
|
|
|
|
|
|
return error "I won't sign a non-text message unless I'm forced"; |
1418
|
|
|
|
|
|
|
|
1419
|
|
|
|
|
|
|
### Get body data, as an array of newline-terminated lines: |
1420
|
3
|
50
|
|
|
|
7
|
$self->bodyhandle or return undef; |
1421
|
3
|
|
|
|
|
5
|
my @body = $self->bodyhandle->as_lines; |
1422
|
|
|
|
|
|
|
|
1423
|
|
|
|
|
|
|
### Nuke any existing sig? |
1424
|
3
|
50
|
66
|
|
|
12
|
if (!defined($params{Remove}) || ($params{Remove} > 0)) { |
1425
|
3
|
|
|
|
|
10
|
_do_remove_sig(\@body, $params{Remove}); |
1426
|
|
|
|
|
|
|
} |
1427
|
|
|
|
|
|
|
|
1428
|
|
|
|
|
|
|
### Output data back into body, followed by signature: |
1429
|
3
|
|
|
|
|
3
|
my $line; |
1430
|
3
|
50
|
|
|
|
7
|
$io = $self->open("w") or croak("open: $!"); |
1431
|
3
|
|
|
|
|
6
|
foreach $line (@body) { $io->print($line) }; ### body data |
|
18
|
|
|
|
|
61
|
|
1432
|
3
|
50
|
50
|
|
|
21
|
(($body[-1]||'') =~ /\n\Z/) or $io->print("\n"); ### ensure final \n |
1433
|
3
|
|
|
|
|
11
|
$io->print("-- \n$sig"); ### separator + sig |
1434
|
3
|
50
|
|
|
|
11
|
$io->close or croak("close: $!"); |
1435
|
3
|
|
|
|
|
82
|
return 1; ### done! |
1436
|
|
|
|
|
|
|
} |
1437
|
|
|
|
|
|
|
} |
1438
|
|
|
|
|
|
|
|
1439
|
|
|
|
|
|
|
#------------------------------ |
1440
|
|
|
|
|
|
|
|
1441
|
|
|
|
|
|
|
=item suggest_encoding |
1442
|
|
|
|
|
|
|
|
1443
|
|
|
|
|
|
|
I |
1444
|
|
|
|
|
|
|
Based on the effective content type, return a good suggested encoding. |
1445
|
|
|
|
|
|
|
|
1446
|
|
|
|
|
|
|
C and C types have their bodies scanned line-by-line |
1447
|
|
|
|
|
|
|
for 8-bit characters and long lines; lack of either means that the |
1448
|
|
|
|
|
|
|
message is 7bit-ok. Other types are chosen independent of their body: |
1449
|
|
|
|
|
|
|
|
1450
|
|
|
|
|
|
|
Major type: 7bit ok? Suggested encoding: |
1451
|
|
|
|
|
|
|
----------------------------------------------------------- |
1452
|
|
|
|
|
|
|
text yes 7bit |
1453
|
|
|
|
|
|
|
text no quoted-printable |
1454
|
|
|
|
|
|
|
message yes 7bit |
1455
|
|
|
|
|
|
|
message no binary |
1456
|
|
|
|
|
|
|
multipart * binary (in case some parts are bad) |
1457
|
|
|
|
|
|
|
image, etc... * base64 |
1458
|
|
|
|
|
|
|
|
1459
|
|
|
|
|
|
|
=cut |
1460
|
|
|
|
|
|
|
|
1461
|
|
|
|
|
|
|
### TO DO: resolve encodings of nested entities (possibly in sync_headers). |
1462
|
|
|
|
|
|
|
|
1463
|
|
|
|
|
|
|
sub suggest_encoding { |
1464
|
3
|
|
|
3
|
1
|
3
|
my $self = shift; |
1465
|
|
|
|
|
|
|
|
1466
|
3
|
|
|
|
|
6
|
my ($type) = split '/', $self->effective_type; |
1467
|
3
|
100
|
66
|
|
|
12
|
if (($type eq 'text') || ($type eq 'message')) { ### scan message body |
1468
|
2
|
0
|
|
|
|
4
|
$self->bodyhandle || return ($self->parts ? 'binary' : '7bit'); |
|
|
50
|
|
|
|
|
|
1469
|
2
|
|
|
|
|
3
|
my ($IO, $unclean); |
1470
|
2
|
50
|
|
|
|
3
|
if ($IO = $self->bodyhandle->open("r")) { |
1471
|
|
|
|
|
|
|
### Scan message for 7bit-cleanliness |
1472
|
2
|
|
|
|
|
3
|
local $_; |
1473
|
2
|
|
|
|
|
48
|
while (defined($_ = $IO->getline)) { |
1474
|
6
|
100
|
66
|
|
|
224
|
last if ($unclean = ((length($_) > 999) or /[\200-\377]/)); |
1475
|
|
|
|
|
|
|
} |
1476
|
|
|
|
|
|
|
|
1477
|
|
|
|
|
|
|
### Return '7bit' if clean; try and encode if not... |
1478
|
|
|
|
|
|
|
### Note that encodings are not permitted for messages! |
1479
|
2
|
50
|
|
|
|
28
|
return ($unclean |
|
|
100
|
|
|
|
|
|
1480
|
|
|
|
|
|
|
? (($type eq 'message') ? 'binary' : 'quoted-printable') |
1481
|
|
|
|
|
|
|
: '7bit'); |
1482
|
|
|
|
|
|
|
} |
1483
|
|
|
|
|
|
|
} |
1484
|
|
|
|
|
|
|
else { |
1485
|
1
|
50
|
|
|
|
4
|
return ($type eq 'multipart') ? 'binary' : 'base64'; |
1486
|
|
|
|
|
|
|
} |
1487
|
|
|
|
|
|
|
} |
1488
|
|
|
|
|
|
|
|
1489
|
|
|
|
|
|
|
sub suggest_encoding_lite { |
1490
|
22
|
|
|
22
|
0
|
22
|
my $self = shift; |
1491
|
22
|
|
|
|
|
48
|
my ($type) = split '/', $self->effective_type; |
1492
|
22
|
100
|
|
|
|
100
|
return (($type =~ /^(text|message|multipart)$/) ? 'binary' : 'base64'); |
1493
|
|
|
|
|
|
|
} |
1494
|
|
|
|
|
|
|
|
1495
|
|
|
|
|
|
|
#------------------------------ |
1496
|
|
|
|
|
|
|
|
1497
|
|
|
|
|
|
|
=item sync_headers OPTIONS |
1498
|
|
|
|
|
|
|
|
1499
|
|
|
|
|
|
|
I |
1500
|
|
|
|
|
|
|
This method does a variety of activities which ensure that |
1501
|
|
|
|
|
|
|
the MIME headers of an entity "tree" are in-synch with the body parts |
1502
|
|
|
|
|
|
|
they describe. It can be as expensive an operation as printing |
1503
|
|
|
|
|
|
|
if it involves pre-encoding the body parts; however, the aim is to |
1504
|
|
|
|
|
|
|
produce fairly clean MIME. B
|
1505
|
|
|
|
|
|
|
this if processing and re-sending MIME from an outside source.> |
1506
|
|
|
|
|
|
|
|
1507
|
|
|
|
|
|
|
The OPTIONS is a hash, which describes what is to be done. |
1508
|
|
|
|
|
|
|
|
1509
|
|
|
|
|
|
|
=over 4 |
1510
|
|
|
|
|
|
|
|
1511
|
|
|
|
|
|
|
|
1512
|
|
|
|
|
|
|
=item Length |
1513
|
|
|
|
|
|
|
|
1514
|
|
|
|
|
|
|
One of the "official unofficial" MIME fields is "Content-Length". |
1515
|
|
|
|
|
|
|
Normally, one doesn't care a whit about this field; however, if |
1516
|
|
|
|
|
|
|
you are preparing output destined for HTTP, you may. The value of |
1517
|
|
|
|
|
|
|
this option dictates what will be done: |
1518
|
|
|
|
|
|
|
|
1519
|
|
|
|
|
|
|
B means to set a C field for every non-multipart |
1520
|
|
|
|
|
|
|
part in the entity, and to blank that field out for every multipart |
1521
|
|
|
|
|
|
|
part in the entity. |
1522
|
|
|
|
|
|
|
|
1523
|
|
|
|
|
|
|
B means that C fields will all |
1524
|
|
|
|
|
|
|
be blanked out. This is fast, painless, and safe. |
1525
|
|
|
|
|
|
|
|
1526
|
|
|
|
|
|
|
B (the default) means to take no action. |
1527
|
|
|
|
|
|
|
|
1528
|
|
|
|
|
|
|
|
1529
|
|
|
|
|
|
|
=item Nonstandard |
1530
|
|
|
|
|
|
|
|
1531
|
|
|
|
|
|
|
Any header field beginning with "Content-" is, according to the RFC, |
1532
|
|
|
|
|
|
|
a MIME field. However, some are non-standard, and may cause problems |
1533
|
|
|
|
|
|
|
with certain MIME readers which interpret them in different ways. |
1534
|
|
|
|
|
|
|
|
1535
|
|
|
|
|
|
|
B means that all such fields will be blanked out. This is |
1536
|
|
|
|
|
|
|
done I the B option (q.v.) is examined and acted upon. |
1537
|
|
|
|
|
|
|
|
1538
|
|
|
|
|
|
|
B (the default) means to take no action. |
1539
|
|
|
|
|
|
|
|
1540
|
|
|
|
|
|
|
|
1541
|
|
|
|
|
|
|
=back |
1542
|
|
|
|
|
|
|
|
1543
|
|
|
|
|
|
|
Returns a true value if everything went okay, a false value otherwise. |
1544
|
|
|
|
|
|
|
|
1545
|
|
|
|
|
|
|
=cut |
1546
|
|
|
|
|
|
|
|
1547
|
|
|
|
|
|
|
sub sync_headers { |
1548
|
5
|
|
|
5
|
1
|
11
|
my $self = shift; |
1549
|
5
|
100
|
|
|
|
15
|
my $opts = ((int(@_) % 2 == 0) ? {@_} : shift); |
1550
|
5
|
|
|
|
|
2
|
my $ENCBODY; ### keep it around until done! |
1551
|
|
|
|
|
|
|
|
1552
|
|
|
|
|
|
|
### Get options: |
1553
|
5
|
|
50
|
|
|
11
|
my $o_nonstandard = ($opts->{Nonstandard} || 0); |
1554
|
5
|
|
50
|
|
|
9
|
my $o_length = ($opts->{Length} || 0); |
1555
|
|
|
|
|
|
|
|
1556
|
|
|
|
|
|
|
### Get head: |
1557
|
5
|
|
|
|
|
8
|
my $head = $self->head; |
1558
|
|
|
|
|
|
|
|
1559
|
|
|
|
|
|
|
### What to do with "nonstandard" MIME fields? |
1560
|
5
|
50
|
|
|
|
10
|
if ($o_nonstandard eq 'ERASE') { ### Erase them... |
1561
|
5
|
|
|
|
|
4
|
my $tag; |
1562
|
5
|
|
|
|
|
15
|
foreach $tag ($head->tags()) { |
1563
|
19
|
50
|
66
|
|
|
177
|
if (($tag =~ /\AContent-/i) && |
1564
|
|
|
|
|
|
|
($tag !~ /\AContent-$StandardFields\Z/io)) { |
1565
|
0
|
|
|
|
|
0
|
$head->delete($tag); |
1566
|
|
|
|
|
|
|
} |
1567
|
|
|
|
|
|
|
} |
1568
|
|
|
|
|
|
|
} |
1569
|
|
|
|
|
|
|
|
1570
|
|
|
|
|
|
|
### What to do with the "Content-Length" MIME field? |
1571
|
5
|
50
|
|
|
|
11
|
if ($o_length eq 'COMPUTE') { ### Compute the content length... |
|
|
0
|
|
|
|
|
|
1572
|
5
|
|
|
|
|
5
|
my $content_length = ''; |
1573
|
|
|
|
|
|
|
|
1574
|
|
|
|
|
|
|
### We don't have content-lengths in multiparts... |
1575
|
5
|
100
|
|
|
|
43
|
if ($self->is_multipart) { ### multipart... |
1576
|
1
|
|
|
|
|
6
|
$head->delete('Content-length'); |
1577
|
|
|
|
|
|
|
} |
1578
|
|
|
|
|
|
|
else { ### singlepart... |
1579
|
|
|
|
|
|
|
|
1580
|
|
|
|
|
|
|
### Get the encoded body, if we don't have it already: |
1581
|
4
|
50
|
|
|
|
7
|
unless ($ENCBODY) { |
1582
|
4
|
|
50
|
|
|
9
|
$ENCBODY = tmpopen() || die "can't open tmpfile"; |
1583
|
4
|
|
|
|
|
1124
|
$self->print_body($ENCBODY); ### write encoded to tmpfile |
1584
|
|
|
|
|
|
|
} |
1585
|
|
|
|
|
|
|
|
1586
|
|
|
|
|
|
|
### Analyse it: |
1587
|
4
|
|
|
|
|
15
|
$ENCBODY->seek(0,2); ### fast-forward |
1588
|
4
|
|
|
|
|
119
|
$content_length = $ENCBODY->tell; ### get encoded length |
1589
|
4
|
|
|
|
|
21
|
$ENCBODY->seek(0,0); ### rewind |
1590
|
|
|
|
|
|
|
|
1591
|
|
|
|
|
|
|
### Remember: |
1592
|
4
|
|
|
|
|
15
|
$self->head->replace('Content-length', $content_length); |
1593
|
|
|
|
|
|
|
} |
1594
|
|
|
|
|
|
|
} |
1595
|
|
|
|
|
|
|
elsif ($o_length eq 'ERASE') { ### Erase the content-length... |
1596
|
0
|
|
|
|
|
0
|
$head->delete('Content-length'); |
1597
|
|
|
|
|
|
|
} |
1598
|
|
|
|
|
|
|
|
1599
|
|
|
|
|
|
|
### Done with everything for us! |
1600
|
5
|
|
|
|
|
379
|
undef($ENCBODY); |
1601
|
|
|
|
|
|
|
|
1602
|
|
|
|
|
|
|
### Recurse: |
1603
|
5
|
|
|
|
|
693
|
my $part; |
1604
|
5
|
50
|
|
|
|
10
|
foreach $part ($self->parts) { $part->sync_headers($opts) or return undef } |
|
4
|
|
|
|
|
11
|
|
1605
|
5
|
|
|
|
|
15
|
1; |
1606
|
|
|
|
|
|
|
} |
1607
|
|
|
|
|
|
|
|
1608
|
|
|
|
|
|
|
#------------------------------ |
1609
|
|
|
|
|
|
|
|
1610
|
|
|
|
|
|
|
=item tidy_body |
1611
|
|
|
|
|
|
|
|
1612
|
|
|
|
|
|
|
I |
1613
|
|
|
|
|
|
|
Currently unimplemented for MIME messages. Does nothing, returns false. |
1614
|
|
|
|
|
|
|
|
1615
|
|
|
|
|
|
|
=cut |
1616
|
|
|
|
|
|
|
|
1617
|
|
|
|
|
|
|
sub tidy_body { |
1618
|
0
|
|
|
0
|
1
|
0
|
usage "MIME::Entity::tidy_body currently does nothing"; |
1619
|
0
|
|
|
|
|
0
|
0; |
1620
|
|
|
|
|
|
|
} |
1621
|
|
|
|
|
|
|
|
1622
|
|
|
|
|
|
|
=back |
1623
|
|
|
|
|
|
|
|
1624
|
|
|
|
|
|
|
=cut |
1625
|
|
|
|
|
|
|
|
1626
|
|
|
|
|
|
|
|
1627
|
|
|
|
|
|
|
|
1628
|
|
|
|
|
|
|
|
1629
|
|
|
|
|
|
|
|
1630
|
|
|
|
|
|
|
#============================== |
1631
|
|
|
|
|
|
|
|
1632
|
|
|
|
|
|
|
=head2 Output |
1633
|
|
|
|
|
|
|
|
1634
|
|
|
|
|
|
|
=over 4 |
1635
|
|
|
|
|
|
|
|
1636
|
|
|
|
|
|
|
=cut |
1637
|
|
|
|
|
|
|
|
1638
|
|
|
|
|
|
|
#------------------------------ |
1639
|
|
|
|
|
|
|
|
1640
|
|
|
|
|
|
|
=item dump_skeleton [FILEHANDLE] |
1641
|
|
|
|
|
|
|
|
1642
|
|
|
|
|
|
|
I |
1643
|
|
|
|
|
|
|
Dump the skeleton of the entity to the given FILEHANDLE, or |
1644
|
|
|
|
|
|
|
to the currently-selected one if none given. |
1645
|
|
|
|
|
|
|
|
1646
|
|
|
|
|
|
|
Each entity is output with an appropriate indentation level, |
1647
|
|
|
|
|
|
|
the following selection of attributes: |
1648
|
|
|
|
|
|
|
|
1649
|
|
|
|
|
|
|
Content-type: multipart/mixed |
1650
|
|
|
|
|
|
|
Effective-type: multipart/mixed |
1651
|
|
|
|
|
|
|
Body-file: NONE |
1652
|
|
|
|
|
|
|
Subject: Hey there! |
1653
|
|
|
|
|
|
|
Num-parts: 2 |
1654
|
|
|
|
|
|
|
|
1655
|
|
|
|
|
|
|
This is really just useful for debugging purposes; I make no guarantees |
1656
|
|
|
|
|
|
|
about the consistency of the output format over time. |
1657
|
|
|
|
|
|
|
|
1658
|
|
|
|
|
|
|
=cut |
1659
|
|
|
|
|
|
|
|
1660
|
|
|
|
|
|
|
sub dump_skeleton { |
1661
|
0
|
|
|
0
|
1
|
0
|
my ($self, $fh, $indent) = @_; |
1662
|
0
|
0
|
|
|
|
0
|
$fh or $fh = select; |
1663
|
0
|
0
|
|
|
|
0
|
defined($indent) or $indent = 0; |
1664
|
0
|
|
|
|
|
0
|
my $ind = ' ' x $indent; |
1665
|
0
|
|
|
|
|
0
|
my $part; |
1666
|
18
|
|
|
18
|
|
119
|
no strict 'refs'; |
|
18
|
|
|
|
|
23
|
|
|
18
|
|
|
|
|
3471
|
|
1667
|
|
|
|
|
|
|
|
1668
|
|
|
|
|
|
|
|
1669
|
|
|
|
|
|
|
### The content type: |
1670
|
0
|
|
0
|
|
|
0
|
print $fh $ind,"Content-type: ", ($self->mime_type||'UNKNOWN'),"\n"; |
1671
|
0
|
|
0
|
|
|
0
|
print $fh $ind,"Effective-type: ", ($self->effective_type||'UNKNOWN'),"\n"; |
1672
|
|
|
|
|
|
|
|
1673
|
|
|
|
|
|
|
### The name of the file containing the body (if any!): |
1674
|
0
|
0
|
|
|
|
0
|
my $path = ($self->bodyhandle ? $self->bodyhandle->path : undef); |
1675
|
0
|
|
0
|
|
|
0
|
print $fh $ind, "Body-file: ", ($path || 'NONE'), "\n"; |
1676
|
|
|
|
|
|
|
|
1677
|
|
|
|
|
|
|
### The recommended file name (thanks to Allen Campbell): |
1678
|
0
|
|
|
|
|
0
|
my $filename = $self->head->recommended_filename; |
1679
|
0
|
0
|
|
|
|
0
|
print $fh $ind, "Recommended-filename: ", $filename, "\n" if ($filename); |
1680
|
|
|
|
|
|
|
|
1681
|
|
|
|
|
|
|
### The subject (note: already a newline if 2.x!) |
1682
|
0
|
|
|
|
|
0
|
my $subj = $self->head->get('subject',0); |
1683
|
0
|
0
|
|
|
|
0
|
defined($subj) or $subj = ''; |
1684
|
0
|
|
|
|
|
0
|
chomp($subj); |
1685
|
0
|
0
|
|
|
|
0
|
print $fh $ind, "Subject: $subj\n" if $subj; |
1686
|
|
|
|
|
|
|
|
1687
|
|
|
|
|
|
|
### The parts: |
1688
|
0
|
|
|
|
|
0
|
my @parts = $self->parts; |
1689
|
0
|
0
|
|
|
|
0
|
print $fh $ind, "Num-parts: ", int(@parts), "\n" if @parts; |
1690
|
0
|
|
|
|
|
0
|
print $fh $ind, "--\n"; |
1691
|
0
|
|
|
|
|
0
|
foreach $part (@parts) { |
1692
|
0
|
|
|
|
|
0
|
$part->dump_skeleton($fh, $indent+1); |
1693
|
|
|
|
|
|
|
} |
1694
|
|
|
|
|
|
|
} |
1695
|
|
|
|
|
|
|
|
1696
|
|
|
|
|
|
|
#------------------------------ |
1697
|
|
|
|
|
|
|
|
1698
|
|
|
|
|
|
|
=item print [OUTSTREAM] |
1699
|
|
|
|
|
|
|
|
1700
|
|
|
|
|
|
|
I |
1701
|
|
|
|
|
|
|
Print the entity to the given OUTSTREAM, or to the currently-selected |
1702
|
|
|
|
|
|
|
filehandle if none given. OUTSTREAM can be a filehandle, or any object |
1703
|
|
|
|
|
|
|
that responds to a print() message. |
1704
|
|
|
|
|
|
|
|
1705
|
|
|
|
|
|
|
The entity is output as a valid MIME stream! This means that the |
1706
|
|
|
|
|
|
|
header is always output first, and the body data (if any) will be |
1707
|
|
|
|
|
|
|
encoded if the header says that it should be. |
1708
|
|
|
|
|
|
|
For example, your output may look like this: |
1709
|
|
|
|
|
|
|
|
1710
|
|
|
|
|
|
|
Subject: Greetings |
1711
|
|
|
|
|
|
|
Content-transfer-encoding: base64 |
1712
|
|
|
|
|
|
|
|
1713
|
|
|
|
|
|
|
SGkgdGhlcmUhCkJ5ZSB0aGVyZSEK |
1714
|
|
|
|
|
|
|
|
1715
|
|
|
|
|
|
|
I |
1716
|
|
|
|
|
|
|
the preamble, parts, and epilogue are all output with appropriate |
1717
|
|
|
|
|
|
|
boundaries separating each. |
1718
|
|
|
|
|
|
|
Any bodyhandle is ignored: |
1719
|
|
|
|
|
|
|
|
1720
|
|
|
|
|
|
|
Content-type: multipart/mixed; boundary="*----*" |
1721
|
|
|
|
|
|
|
Content-transfer-encoding: 7bit |
1722
|
|
|
|
|
|
|
|
1723
|
|
|
|
|
|
|
[Preamble] |
1724
|
|
|
|
|
|
|
--*----* |
1725
|
|
|
|
|
|
|
[Entity: Part 0] |
1726
|
|
|
|
|
|
|
--*----* |
1727
|
|
|
|
|
|
|
[Entity: Part 1] |
1728
|
|
|
|
|
|
|
--*----*-- |
1729
|
|
|
|
|
|
|
[Epilogue] |
1730
|
|
|
|
|
|
|
|
1731
|
|
|
|
|
|
|
I |
1732
|
|
|
|
|
|
|
then we're looking at a normal singlepart entity: the body is output |
1733
|
|
|
|
|
|
|
according to the encoding specified by the header. |
1734
|
|
|
|
|
|
|
If no body exists, a warning is output and the body is treated as empty: |
1735
|
|
|
|
|
|
|
|
1736
|
|
|
|
|
|
|
Content-type: image/gif |
1737
|
|
|
|
|
|
|
Content-transfer-encoding: base64 |
1738
|
|
|
|
|
|
|
|
1739
|
|
|
|
|
|
|
[Encoded body] |
1740
|
|
|
|
|
|
|
|
1741
|
|
|
|
|
|
|
I |
1742
|
|
|
|
|
|
|
then we're probably looking at a "re-parsed" singlepart, usually one |
1743
|
|
|
|
|
|
|
of type C (you can get entities like this if you set the |
1744
|
|
|
|
|
|
|
C option on the parser to true). |
1745
|
|
|
|
|
|
|
In this case, the parts are output with single blank lines separating each, |
1746
|
|
|
|
|
|
|
and any bodyhandle is ignored: |
1747
|
|
|
|
|
|
|
|
1748
|
|
|
|
|
|
|
Content-type: message/rfc822 |
1749
|
|
|
|
|
|
|
Content-transfer-encoding: 7bit |
1750
|
|
|
|
|
|
|
|
1751
|
|
|
|
|
|
|
[Entity: Part 0] |
1752
|
|
|
|
|
|
|
|
1753
|
|
|
|
|
|
|
[Entity: Part 1] |
1754
|
|
|
|
|
|
|
|
1755
|
|
|
|
|
|
|
In all cases, when outputting a "part" of the entity, this method |
1756
|
|
|
|
|
|
|
is invoked recursively. |
1757
|
|
|
|
|
|
|
|
1758
|
|
|
|
|
|
|
B the output is very likely I going to be identical |
1759
|
|
|
|
|
|
|
to any input you parsed to get this entity. If you're building |
1760
|
|
|
|
|
|
|
some sort of email handler, it's up to you to save this information. |
1761
|
|
|
|
|
|
|
|
1762
|
|
|
|
|
|
|
=cut |
1763
|
|
|
|
|
|
|
|
1764
|
18
|
|
|
18
|
|
84
|
use Symbol; |
|
18
|
|
|
|
|
25
|
|
|
18
|
|
|
|
|
11943
|
|
1765
|
|
|
|
|
|
|
sub print { |
1766
|
59
|
|
|
59
|
1
|
6931
|
my ($self, $out) = @_; |
1767
|
59
|
100
|
|
|
|
118
|
$out = select if @_ < 2; |
1768
|
59
|
100
|
|
|
|
126
|
$out = Symbol::qualify($out,scalar(caller)) unless ref($out); |
1769
|
|
|
|
|
|
|
|
1770
|
59
|
|
|
|
|
192
|
$self->print_header($out); ### the header |
1771
|
59
|
|
|
|
|
321
|
$out->print("\n"); |
1772
|
59
|
|
|
|
|
223
|
$self->print_body($out); ### the "stuff after the header" |
1773
|
|
|
|
|
|
|
} |
1774
|
|
|
|
|
|
|
|
1775
|
|
|
|
|
|
|
#------------------------------ |
1776
|
|
|
|
|
|
|
|
1777
|
|
|
|
|
|
|
=item print_body [OUTSTREAM] |
1778
|
|
|
|
|
|
|
|
1779
|
|
|
|
|
|
|
I |
1780
|
|
|
|
|
|
|
Print the body of the entity to the given OUTSTREAM, or to the |
1781
|
|
|
|
|
|
|
currently-selected filehandle if none given. OUTSTREAM can be a |
1782
|
|
|
|
|
|
|
filehandle, or any object that responds to a print() message. |
1783
|
|
|
|
|
|
|
|
1784
|
|
|
|
|
|
|
The body is output for inclusion in a valid MIME stream; this means |
1785
|
|
|
|
|
|
|
that the body data will be encoded if the header says that it should be. |
1786
|
|
|
|
|
|
|
|
1787
|
|
|
|
|
|
|
B by "body", we mean "the stuff following the header". |
1788
|
|
|
|
|
|
|
A printed multipart body includes the printed representations of its subparts. |
1789
|
|
|
|
|
|
|
|
1790
|
|
|
|
|
|
|
B The body is I in an un-encoded form; however, the idea is that |
1791
|
|
|
|
|
|
|
the transfer encoding is used to determine how it should be I |
1792
|
|
|
|
|
|
|
This means that the C method is always guaranteed to get you |
1793
|
|
|
|
|
|
|
a sendmail-ready stream whose body is consistent with its head. |
1794
|
|
|
|
|
|
|
If you want the I to be output, you can either read it from |
1795
|
|
|
|
|
|
|
the bodyhandle yourself, or use: |
1796
|
|
|
|
|
|
|
|
1797
|
|
|
|
|
|
|
$ent->bodyhandle->print($outstream); |
1798
|
|
|
|
|
|
|
|
1799
|
|
|
|
|
|
|
which uses read() calls to extract the information, and thus will |
1800
|
|
|
|
|
|
|
work with both text and binary bodies. |
1801
|
|
|
|
|
|
|
|
1802
|
|
|
|
|
|
|
B Please supply an OUTSTREAM. This override method differs |
1803
|
|
|
|
|
|
|
from Mail::Internet's behavior, which outputs to the STDOUT if no |
1804
|
|
|
|
|
|
|
filehandle is given: this may lead to confusion. |
1805
|
|
|
|
|
|
|
|
1806
|
|
|
|
|
|
|
=cut |
1807
|
|
|
|
|
|
|
|
1808
|
|
|
|
|
|
|
sub print_body { |
1809
|
75
|
|
|
75
|
1
|
2605
|
my ($self, $out) = @_; |
1810
|
75
|
|
33
|
|
|
117
|
$out ||= select; |
1811
|
75
|
|
|
|
|
107
|
my ($type) = split '/', lc($self->mime_type); ### handle by MIME type |
1812
|
|
|
|
|
|
|
|
1813
|
|
|
|
|
|
|
### Multipart... |
1814
|
75
|
100
|
|
|
|
194
|
if ($type eq 'multipart') { |
|
|
50
|
|
|
|
|
|
1815
|
10
|
|
|
|
|
22
|
my $boundary = $self->head->multipart_boundary; |
1816
|
|
|
|
|
|
|
|
1817
|
|
|
|
|
|
|
### Preamble: |
1818
|
10
|
|
|
|
|
32
|
my $plines = $self->preamble; |
1819
|
10
|
100
|
|
|
|
20
|
if (defined $plines) { |
1820
|
|
|
|
|
|
|
# Defined, so output the preamble if it exists (avoiding additional |
1821
|
|
|
|
|
|
|
# newline as per ticket 60931) |
1822
|
9
|
100
|
|
|
|
31
|
$out->print( join('', @$plines) . "\n") if (@$plines > 0); |
1823
|
|
|
|
|
|
|
} else { |
1824
|
|
|
|
|
|
|
# Undefined, so use default preamble |
1825
|
1
|
|
|
|
|
10
|
$out->print( join('', @$DefPreamble) . "\n" ); |
1826
|
|
|
|
|
|
|
} |
1827
|
|
|
|
|
|
|
|
1828
|
|
|
|
|
|
|
### Parts: |
1829
|
10
|
|
|
|
|
22
|
my $part; |
1830
|
10
|
|
|
|
|
21
|
foreach $part ($self->parts) { |
1831
|
29
|
|
|
|
|
129
|
$out->print("--$boundary\n"); |
1832
|
29
|
|
|
|
|
139
|
$part->print($out); |
1833
|
29
|
|
|
|
|
50
|
$out->print("\n"); ### needed for next delim/close |
1834
|
|
|
|
|
|
|
} |
1835
|
10
|
|
|
|
|
59
|
$out->print("--$boundary--\n"); |
1836
|
|
|
|
|
|
|
|
1837
|
|
|
|
|
|
|
### Epilogue: |
1838
|
10
|
100
|
|
|
|
32
|
my $epilogue = join('', @{ $self->epilogue || $DefEpilogue }); |
|
10
|
|
|
|
|
24
|
|
1839
|
10
|
100
|
|
|
|
30
|
if ($epilogue ne '') { |
1840
|
1
|
|
|
|
|
2
|
$out->print($epilogue); |
1841
|
1
|
50
|
|
|
|
7
|
$out->print("\n") if ($epilogue !~ /\n\Z/); ### be nice |
1842
|
|
|
|
|
|
|
} |
1843
|
|
|
|
|
|
|
} |
1844
|
|
|
|
|
|
|
|
1845
|
|
|
|
|
|
|
### Singlepart type with parts... |
1846
|
|
|
|
|
|
|
### This makes $ent->print handle message/rfc822 bodies |
1847
|
|
|
|
|
|
|
### when parse_nested_messages('NEST') is on [idea by Marc Rouleau]. |
1848
|
|
|
|
|
|
|
elsif ($self->parts) { |
1849
|
0
|
|
|
|
|
0
|
my $need_sep = 0; |
1850
|
0
|
|
|
|
|
0
|
my $part; |
1851
|
0
|
|
|
|
|
0
|
foreach $part ($self->parts) { |
1852
|
0
|
0
|
|
|
|
0
|
$out->print("\n\n") if $need_sep++; |
1853
|
0
|
|
|
|
|
0
|
$part->print($out); |
1854
|
|
|
|
|
|
|
} |
1855
|
|
|
|
|
|
|
} |
1856
|
|
|
|
|
|
|
|
1857
|
|
|
|
|
|
|
### Singlepart type, or no parts: output body... |
1858
|
|
|
|
|
|
|
else { |
1859
|
65
|
50
|
|
|
|
116
|
$self->bodyhandle ? $self->print_bodyhandle($out) |
1860
|
|
|
|
|
|
|
: whine "missing body; treated as empty"; |
1861
|
|
|
|
|
|
|
} |
1862
|
75
|
|
|
|
|
112
|
1; |
1863
|
|
|
|
|
|
|
} |
1864
|
|
|
|
|
|
|
|
1865
|
|
|
|
|
|
|
#------------------------------ |
1866
|
|
|
|
|
|
|
# |
1867
|
|
|
|
|
|
|
# print_bodyhandle |
1868
|
|
|
|
|
|
|
# |
1869
|
|
|
|
|
|
|
# Instance method, unpublicized. Print just the bodyhandle, *encoded*. |
1870
|
|
|
|
|
|
|
# |
1871
|
|
|
|
|
|
|
# WARNING: $self->print_bodyhandle() != $self->bodyhandle->print()! |
1872
|
|
|
|
|
|
|
# The former encodes, and the latter does not! |
1873
|
|
|
|
|
|
|
# |
1874
|
|
|
|
|
|
|
sub print_bodyhandle { |
1875
|
65
|
|
|
65
|
0
|
57
|
my ($self, $out) = @_; |
1876
|
65
|
|
33
|
|
|
99
|
$out ||= select; |
1877
|
|
|
|
|
|
|
|
1878
|
65
|
|
50
|
|
|
108
|
my $IO = $self->open("r") || die "open body: $!"; |
1879
|
65
|
100
|
|
|
|
1267
|
if ( $self->bodyhandle->is_encoded ) { |
1880
|
|
|
|
|
|
|
### Transparent mode: data is already encoded, so no |
1881
|
|
|
|
|
|
|
### need to encode it again |
1882
|
7
|
|
|
|
|
5
|
my $buf; |
1883
|
7
|
|
|
|
|
17
|
$out->print($buf) while ($IO->read($buf, 8192)); |
1884
|
|
|
|
|
|
|
} else { |
1885
|
|
|
|
|
|
|
### Get the encoding, defaulting to "binary" if unsupported: |
1886
|
58
|
|
50
|
|
|
87
|
my $encoding = ($self->head->mime_encoding || 'binary'); |
1887
|
58
|
|
|
|
|
224
|
my $decoder = best MIME::Decoder $encoding; |
1888
|
58
|
|
|
|
|
102
|
$decoder->head($self->head); ### associate with head, if any |
1889
|
58
|
100
|
|
|
|
81
|
$decoder->encode($IO, $out, textual_type($self->head->mime_type) ? 1 : 0) || return error "encoding failed"; |
|
|
50
|
|
|
|
|
|
1890
|
|
|
|
|
|
|
} |
1891
|
|
|
|
|
|
|
|
1892
|
65
|
|
|
|
|
235
|
$IO->close; |
1893
|
65
|
|
|
|
|
469
|
1; |
1894
|
|
|
|
|
|
|
} |
1895
|
|
|
|
|
|
|
|
1896
|
|
|
|
|
|
|
#------------------------------ |
1897
|
|
|
|
|
|
|
|
1898
|
|
|
|
|
|
|
=item print_header [OUTSTREAM] |
1899
|
|
|
|
|
|
|
|
1900
|
|
|
|
|
|
|
I |
1901
|
|
|
|
|
|
|
Output the header to the given OUTSTREAM. You really should supply |
1902
|
|
|
|
|
|
|
the OUTSTREAM. |
1903
|
|
|
|
|
|
|
|
1904
|
|
|
|
|
|
|
=cut |
1905
|
|
|
|
|
|
|
|
1906
|
|
|
|
|
|
|
### Inherited. |
1907
|
|
|
|
|
|
|
|
1908
|
|
|
|
|
|
|
#------------------------------ |
1909
|
|
|
|
|
|
|
|
1910
|
|
|
|
|
|
|
=item stringify |
1911
|
|
|
|
|
|
|
|
1912
|
|
|
|
|
|
|
I |
1913
|
|
|
|
|
|
|
Return the entity as a string, exactly as C would print it. |
1914
|
|
|
|
|
|
|
The body will be encoded as necessary, and will contain any subparts. |
1915
|
|
|
|
|
|
|
You can also use C. |
1916
|
|
|
|
|
|
|
|
1917
|
|
|
|
|
|
|
=cut |
1918
|
|
|
|
|
|
|
|
1919
|
|
|
|
|
|
|
sub stringify { |
1920
|
15
|
|
|
15
|
1
|
307
|
my ($self) = @_; |
1921
|
15
|
|
|
|
|
14
|
my $output = ''; |
1922
|
15
|
50
|
|
|
|
69
|
my $fh = IO::File->new( \$output, '>:' ) or croak("Cannot open in-memory file: $!"); |
1923
|
15
|
|
|
|
|
1361
|
$self->print($fh); |
1924
|
15
|
|
|
|
|
29
|
$fh->close; |
1925
|
15
|
|
|
|
|
83
|
return $output; |
1926
|
|
|
|
|
|
|
} |
1927
|
|
|
|
|
|
|
|
1928
|
14
|
|
|
14
|
1
|
2960
|
sub as_string { shift->stringify }; ### silent BC |
1929
|
|
|
|
|
|
|
|
1930
|
|
|
|
|
|
|
#------------------------------ |
1931
|
|
|
|
|
|
|
|
1932
|
|
|
|
|
|
|
=item stringify_body |
1933
|
|
|
|
|
|
|
|
1934
|
|
|
|
|
|
|
I |
1935
|
|
|
|
|
|
|
Return the I message body as a string, exactly as C |
1936
|
|
|
|
|
|
|
would print it. You can also use C. |
1937
|
|
|
|
|
|
|
|
1938
|
|
|
|
|
|
|
If you want the I body, and you are dealing with a |
1939
|
|
|
|
|
|
|
singlepart message (like a "text/plain"), use C instead: |
1940
|
|
|
|
|
|
|
|
1941
|
|
|
|
|
|
|
if ($ent->bodyhandle) { |
1942
|
|
|
|
|
|
|
$unencoded_data = $ent->bodyhandle->as_string; |
1943
|
|
|
|
|
|
|
} |
1944
|
|
|
|
|
|
|
else { |
1945
|
|
|
|
|
|
|
### this message has no body data (but it might have parts!) |
1946
|
|
|
|
|
|
|
} |
1947
|
|
|
|
|
|
|
|
1948
|
|
|
|
|
|
|
=cut |
1949
|
|
|
|
|
|
|
|
1950
|
|
|
|
|
|
|
sub stringify_body { |
1951
|
0
|
|
|
0
|
1
|
|
my ($self) = @_; |
1952
|
0
|
|
|
|
|
|
my $output = ''; |
1953
|
0
|
0
|
|
|
|
|
my $fh = IO::File->new( \$output, '>:' ) or croak("Cannot open in-memory file: $!"); |
1954
|
0
|
|
|
|
|
|
$self->print_body($fh); |
1955
|
0
|
|
|
|
|
|
$fh->close; |
1956
|
0
|
|
|
|
|
|
return $output; |
1957
|
|
|
|
|
|
|
} |
1958
|
|
|
|
|
|
|
|
1959
|
0
|
|
|
0
|
0
|
|
sub body_as_string { shift->stringify_body } |
1960
|
|
|
|
|
|
|
|
1961
|
|
|
|
|
|
|
#------------------------------ |
1962
|
|
|
|
|
|
|
|
1963
|
|
|
|
|
|
|
=item stringify_header |
1964
|
|
|
|
|
|
|
|
1965
|
|
|
|
|
|
|
I |
1966
|
|
|
|
|
|
|
Return the header as a string, exactly as C would print it. |
1967
|
|
|
|
|
|
|
You can also use C. |
1968
|
|
|
|
|
|
|
|
1969
|
|
|
|
|
|
|
=cut |
1970
|
|
|
|
|
|
|
|
1971
|
|
|
|
|
|
|
sub stringify_header { |
1972
|
0
|
|
|
0
|
1
|
|
shift->head->stringify; |
1973
|
|
|
|
|
|
|
} |
1974
|
0
|
|
|
0
|
0
|
|
sub header_as_string { shift->stringify_header } |
1975
|
|
|
|
|
|
|
|
1976
|
|
|
|
|
|
|
|
1977
|
|
|
|
|
|
|
1; |
1978
|
|
|
|
|
|
|
__END__ |