| 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__ |