← Index
NYTProf Performance Profile   « line view »
For svc/members/upsert
  Run on Tue Jan 13 11:50:22 2015
Reported on Tue Jan 13 12:09:50 2015

Filename/usr/share/perl5/MIME/Lite.pm
StatementsExecuted 76 statements in 7.33ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
44115µs15µsMIME::Lite::::CORE:fteexec MIME::Lite::CORE:fteexec (opcode)
11111µs22µsMIME::Lite::::BEGIN@2 MIME::Lite::BEGIN@2
11110µs21µsMIME::Lite::::BEGIN@2284 MIME::Lite::BEGIN@2284
1119µs22µsMIME::Lite::SMTP::::BEGIN@3106 MIME::Lite::SMTP::BEGIN@3106
1119µs315µsMIME::Lite::::BEGIN@339 MIME::Lite::BEGIN@339
1118µs17µsMIME::Lite::IO_Handle::::BEGIN@3151 MIME::Lite::IO_Handle::BEGIN@3151
1117µs30µsMIME::Lite::SMTP::::BEGIN@3107 MIME::Lite::SMTP::BEGIN@3107
1117µs7µsMIME::Lite::::BEGIN@500 MIME::Lite::BEGIN@500
1117µs80µsMIME::Lite::::BEGIN@341 MIME::Lite::BEGIN@341
1115µs5µsMIME::Lite::::BEGIN@338 MIME::Lite::BEGIN@338
1114µs4µsMIME::Lite::::CORE:match MIME::Lite::CORE:match (opcode)
0000s0sMIME::Lite::IO_Handle::::print MIME::Lite::IO_Handle::print
0000s0sMIME::Lite::IO_Handle::::wrap MIME::Lite::IO_Handle::wrap
0000s0sMIME::Lite::IO_Scalar::::print MIME::Lite::IO_Scalar::print
0000s0sMIME::Lite::IO_Scalar::::wrap MIME::Lite::IO_Scalar::wrap
0000s0sMIME::Lite::IO_ScalarArray::::printMIME::Lite::IO_ScalarArray::print
0000s0sMIME::Lite::IO_ScalarArray::::wrapMIME::Lite::IO_ScalarArray::wrap
0000s0sMIME::Lite::SMTP::::_hexify MIME::Lite::SMTP::_hexify
0000s0sMIME::Lite::SMTP::::print MIME::Lite::SMTP::print
0000s0sMIME::Lite::::__opts MIME::Lite::__opts
0000s0sMIME::Lite::::_safe_attr MIME::Lite::_safe_attr
0000s0sMIME::Lite::::_unfold_stupid_params MIME::Lite::_unfold_stupid_params
0000s0sMIME::Lite::::add MIME::Lite::add
0000s0sMIME::Lite::::as_string MIME::Lite::as_string
0000s0sMIME::Lite::::attach MIME::Lite::attach
0000s0sMIME::Lite::::attr MIME::Lite::attr
0000s0sMIME::Lite::::binmode MIME::Lite::binmode
0000s0sMIME::Lite::::body_as_string MIME::Lite::body_as_string
0000s0sMIME::Lite::::build MIME::Lite::build
0000s0sMIME::Lite::::data MIME::Lite::data
0000s0sMIME::Lite::::delete MIME::Lite::delete
0000s0sMIME::Lite::::encode_7bit MIME::Lite::encode_7bit
0000s0sMIME::Lite::::encode_8bit MIME::Lite::encode_8bit
0000s0sMIME::Lite::::fh MIME::Lite::fh
0000s0sMIME::Lite::::field_order MIME::Lite::field_order
0000s0sMIME::Lite::::fields MIME::Lite::fields
0000s0sMIME::Lite::::fields_as_string MIME::Lite::fields_as_string
0000s0sMIME::Lite::::filename MIME::Lite::filename
0000s0sMIME::Lite::::fold MIME::Lite::fold
0000s0sMIME::Lite::::gen_boundary MIME::Lite::gen_boundary
0000s0sMIME::Lite::::get MIME::Lite::get
0000s0sMIME::Lite::::get_length MIME::Lite::get_length
0000s0sMIME::Lite::::header_as_string MIME::Lite::header_as_string
0000s0sMIME::Lite::::is_mime_field MIME::Lite::is_mime_field
0000s0sMIME::Lite::::last_send_successful MIME::Lite::last_send_successful
0000s0sMIME::Lite::::my_extract_full_addrs MIME::Lite::my_extract_full_addrs
0000s0sMIME::Lite::::my_extract_only_addrs MIME::Lite::my_extract_only_addrs
0000s0sMIME::Lite::::new MIME::Lite::new
0000s0sMIME::Lite::::parts MIME::Lite::parts
0000s0sMIME::Lite::::parts_DFS MIME::Lite::parts_DFS
0000s0sMIME::Lite::::path MIME::Lite::path
0000s0sMIME::Lite::::preamble MIME::Lite::preamble
0000s0sMIME::Lite::::print MIME::Lite::print
0000s0sMIME::Lite::::print_body MIME::Lite::print_body
0000s0sMIME::Lite::::print_for_smtp MIME::Lite::print_for_smtp
0000s0sMIME::Lite::::print_header MIME::Lite::print_header
0000s0sMIME::Lite::::print_simple_body MIME::Lite::print_simple_body
0000s0sMIME::Lite::::quiet MIME::Lite::quiet
0000s0sMIME::Lite::::read_now MIME::Lite::read_now
0000s0sMIME::Lite::::replace MIME::Lite::replace
0000s0sMIME::Lite::::resetfh MIME::Lite::resetfh
0000s0sMIME::Lite::::scrub MIME::Lite::scrub
0000s0sMIME::Lite::::send MIME::Lite::send
0000s0sMIME::Lite::::send_by_sendmail MIME::Lite::send_by_sendmail
0000s0sMIME::Lite::::send_by_smtp MIME::Lite::send_by_smtp
0000s0sMIME::Lite::::send_by_smtp_simple MIME::Lite::send_by_smtp_simple
0000s0sMIME::Lite::::send_by_sub MIME::Lite::send_by_sub
0000s0sMIME::Lite::::send_by_testfile MIME::Lite::send_by_testfile
0000s0sMIME::Lite::::sendmail MIME::Lite::sendmail
0000s0sMIME::Lite::::sign MIME::Lite::sign
0000s0sMIME::Lite::::suggest_encoding MIME::Lite::suggest_encoding
0000s0sMIME::Lite::::suggest_type MIME::Lite::suggest_type
0000s0sMIME::Lite::::top_level MIME::Lite::top_level
0000s0sMIME::Lite::::verify_data MIME::Lite::verify_data
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package MIME::Lite;
22167µs233µs
# spent 22µs (11+11) within MIME::Lite::BEGIN@2 which was called: # once (11µs+11µs) by C4::Letters::BEGIN@23 at line 2
use strict;
# spent 22µs making 1 call to MIME::Lite::BEGIN@2 # spent 11µs making 1 call to strict::import
3116µsrequire 5.004; ### for /c modifier in m/\G.../gc modifier
4
5=head1 NAME
6
7MIME::Lite - low-calorie MIME generator
8
9=head1 WAIT!
10
11MIME::Lite is not recommended by its current maintainer. There are a number of
12alternatives, like Email::MIME or MIME::Entity and Email::Sender, which you
13should probably use instead. MIME::Lite continues to accrue weird bug reports,
14and it is not receiving a large amount of refactoring due to the availability
15of better alternatives. Please consider using something else.
16
17=head1 SYNOPSIS
18
19Create and send using the default send method for your OS a single-part message:
20
21 use MIME::Lite;
22 ### Create a new single-part message, to send a GIF file:
23 $msg = MIME::Lite->new(
24 From => 'me@myhost.com',
25 To => 'you@yourhost.com',
26 Cc => 'some@other.com, some@more.com',
27 Subject => 'Helloooooo, nurse!',
28 Type => 'image/gif',
29 Encoding => 'base64',
30 Path => 'hellonurse.gif'
31 );
32 $msg->send; # send via default
33
34Create a multipart message (i.e., one with attachments) and send it SMTP
35
36 ### Create a new multipart message:
37 $msg = MIME::Lite->new(
38 From => 'me@myhost.com',
39 To => 'you@yourhost.com',
40 Cc => 'some@other.com, some@more.com',
41 Subject => 'A message with 2 parts...',
42 Type => 'multipart/mixed'
43 );
44
45 ### Add parts (each "attach" has same arguments as "new"):
46 $msg->attach(
47 Type => 'TEXT',
48 Data => "Here's the GIF file you wanted"
49 );
50 $msg->attach(
51 Type => 'image/gif',
52 Path => 'aaa000123.gif',
53 Filename => 'logo.gif',
54 Disposition => 'attachment'
55 );
56 ### use Net:SMTP to do the sending
57 $msg->send('smtp','some.host', Debug=>1 );
58
59Output a message:
60
61 ### Format as a string:
62 $str = $msg->as_string;
63
64 ### Print to a filehandle (say, a "sendmail" stream):
65 $msg->print(\*SENDMAIL);
66
67Send a message:
68
69 ### Send in the "best" way (the default is to use "sendmail"):
70 $msg->send;
71 ### Send a specific way:
72 $msg->send('type',@args);
73
74Specify default send method:
75
76 MIME::Lite->send('smtp','some.host',Debug=>0);
77
78with authentication
79
80 MIME::Lite->send('smtp','some.host', AuthUser=>$user, AuthPass=>$pass);
81
82=head1 DESCRIPTION
83
84In the never-ending quest for great taste with fewer calories,
85we proudly present: I<MIME::Lite>.
86
87MIME::Lite is intended as a simple, standalone module for generating
88(not parsing!) MIME messages... specifically, it allows you to
89output a simple, decent single- or multi-part message with text or binary
90attachments. It does not require that you have the Mail:: or MIME::
91modules installed, but will work with them if they are.
92
93You can specify each message part as either the literal data itself (in
94a scalar or array), or as a string which can be given to open() to get
95a readable filehandle (e.g., "<filename" or "somecommand|").
96
97You don't need to worry about encoding your message data:
98this module will do that for you. It handles the 5 standard MIME encodings.
99
100=head1 EXAMPLES
101
102=head2 Create a simple message containing just text
103
104 $msg = MIME::Lite->new(
105 From =>'me@myhost.com',
106 To =>'you@yourhost.com',
107 Cc =>'some@other.com, some@more.com',
108 Subject =>'Helloooooo, nurse!',
109 Data =>"How's it goin', eh?"
110 );
111
112=head2 Create a simple message containing just an image
113
114 $msg = MIME::Lite->new(
115 From =>'me@myhost.com',
116 To =>'you@yourhost.com',
117 Cc =>'some@other.com, some@more.com',
118 Subject =>'Helloooooo, nurse!',
119 Type =>'image/gif',
120 Encoding =>'base64',
121 Path =>'hellonurse.gif'
122 );
123
124
125=head2 Create a multipart message
126
127 ### Create the multipart "container":
128 $msg = MIME::Lite->new(
129 From =>'me@myhost.com',
130 To =>'you@yourhost.com',
131 Cc =>'some@other.com, some@more.com',
132 Subject =>'A message with 2 parts...',
133 Type =>'multipart/mixed'
134 );
135
136 ### Add the text message part:
137 ### (Note that "attach" has same arguments as "new"):
138 $msg->attach(
139 Type =>'TEXT',
140 Data =>"Here's the GIF file you wanted"
141 );
142
143 ### Add the image part:
144 $msg->attach(
145 Type =>'image/gif',
146 Path =>'aaa000123.gif',
147 Filename =>'logo.gif',
148 Disposition => 'attachment'
149 );
150
151
152=head2 Attach a GIF to a text message
153
154This will create a multipart message exactly as above, but using the
155"attach to singlepart" hack:
156
157 ### Start with a simple text message:
158 $msg = MIME::Lite->new(
159 From =>'me@myhost.com',
160 To =>'you@yourhost.com',
161 Cc =>'some@other.com, some@more.com',
162 Subject =>'A message with 2 parts...',
163 Type =>'TEXT',
164 Data =>"Here's the GIF file you wanted"
165 );
166
167 ### Attach a part... the make the message a multipart automatically:
168 $msg->attach(
169 Type =>'image/gif',
170 Path =>'aaa000123.gif',
171 Filename =>'logo.gif'
172 );
173
174
175=head2 Attach a pre-prepared part to a message
176
177 ### Create a standalone part:
178 $part = MIME::Lite->new(
179 Top => 0,
180 Type =>'text/html',
181 Data =>'<H1>Hello</H1>',
182 );
183 $part->attr('content-type.charset' => 'UTF-8');
184 $part->add('X-Comment' => 'A message for you');
185
186 ### Attach it to any message:
187 $msg->attach($part);
188
189
190=head2 Print a message to a filehandle
191
192 ### Write it to a filehandle:
193 $msg->print(\*STDOUT);
194
195 ### Write just the header:
196 $msg->print_header(\*STDOUT);
197
198 ### Write just the encoded body:
199 $msg->print_body(\*STDOUT);
200
201
202=head2 Print a message into a string
203
204 ### Get entire message as a string:
205 $str = $msg->as_string;
206
207 ### Get just the header:
208 $str = $msg->header_as_string;
209
210 ### Get just the encoded body:
211 $str = $msg->body_as_string;
212
213
214=head2 Send a message
215
216 ### Send in the "best" way (the default is to use "sendmail"):
217 $msg->send;
218
219
220=head2 Send an HTML document... with images included!
221
222 $msg = MIME::Lite->new(
223 To =>'you@yourhost.com',
224 Subject =>'HTML with in-line images!',
225 Type =>'multipart/related'
226 );
227 $msg->attach(
228 Type => 'text/html',
229 Data => qq{
230 <body>
231 Here's <i>my</i> image:
232 <img src="cid:myimage.gif">
233 </body>
234 },
235 );
236 $msg->attach(
237 Type => 'image/gif',
238 Id => 'myimage.gif',
239 Path => '/path/to/somefile.gif',
240 );
241 $msg->send();
242
243
244=head2 Change how messages are sent
245
246 ### Do something like this in your 'main':
247 if ($I_DONT_HAVE_SENDMAIL) {
248 MIME::Lite->send('smtp', $host, Timeout=>60,
249 AuthUser=>$user, AuthPass=>$pass);
250 }
251
252 ### Now this will do the right thing:
253 $msg->send; ### will now use Net::SMTP as shown above
254
255=head1 PUBLIC INTERFACE
256
257=head2 Global configuration
258
259To alter the way the entire module behaves, you have the following
260methods/options:
261
262=over 4
263
264
265=item MIME::Lite->field_order()
266
267When used as a L<classmethod|/field_order>, this changes the default
268order in which headers are output for I<all> messages.
269However, please consider using the instance method variant instead,
270so you won't stomp on other message senders in the same application.
271
272
273=item MIME::Lite->quiet()
274
275This L<classmethod|/quiet> can be used to suppress/unsuppress
276all warnings coming from this module.
277
278
279=item MIME::Lite->send()
280
281When used as a L<classmethod|/send>, this can be used to specify
282a different default mechanism for sending message.
283The initial default is:
284
285 MIME::Lite->send("sendmail", "/usr/lib/sendmail -t -oi -oem");
286
287However, you should consider the similar but smarter and taint-safe variant:
288
289 MIME::Lite->send("sendmail");
290
291Or, for non-Unix users:
292
293 MIME::Lite->send("smtp");
294
295
296=item $MIME::Lite::AUTO_CC
297
298If true, automatically send to the Cc/Bcc addresses for send_by_smtp().
299Default is B<true>.
300
301
302=item $MIME::Lite::AUTO_CONTENT_TYPE
303
304If true, try to automatically choose the content type from the file name
305in C<new()>/C<build()>. In other words, setting this true changes the
306default C<Type> from C<"TEXT"> to C<"AUTO">.
307
308Default is B<false>, since we must maintain backwards-compatibility
309with prior behavior. B<Please> consider keeping it false,
310and just using Type 'AUTO' when you build() or attach().
311
312
313=item $MIME::Lite::AUTO_ENCODE
314
315If true, automatically choose the encoding from the content type.
316Default is B<true>.
317
318
319=item $MIME::Lite::AUTO_VERIFY
320
321If true, check paths to attachments right before printing, raising an exception
322if any path is unreadable.
323Default is B<true>.
324
325
326=item $MIME::Lite::PARANOID
327
328If true, we won't attempt to use MIME::Base64, MIME::QuotedPrint,
329or MIME::Types, even if they're available.
330Default is B<false>. Please consider keeping it false,
331and trusting these other packages to do the right thing.
332
333
334=back
335
336=cut
337
338219µs15µs
# spent 5µs within MIME::Lite::BEGIN@338 which was called: # once (5µs+0s) by C4::Letters::BEGIN@23 at line 338
use Carp ();
# spent 5µs making 1 call to MIME::Lite::BEGIN@338
339238µs2621µs
# spent 315µs (9+306) within MIME::Lite::BEGIN@339 which was called: # once (9µs+306µs) by C4::Letters::BEGIN@23 at line 339
use FileHandle;
# spent 315µs making 1 call to MIME::Lite::BEGIN@339 # spent 306µs making 1 call to FileHandle::import
340
34114µs173µs
# spent 80µs (7+73) within MIME::Lite::BEGIN@341 which was called: # once (7µs+73µs) by C4::Letters::BEGIN@23 at line 351
use vars qw(
# spent 73µs making 1 call to vars::import
342 $AUTO_CC
343 $AUTO_CONTENT_TYPE
344 $AUTO_ENCODE
345 $AUTO_VERIFY
346 $PARANOID
347 $QUIET
348 $VANILLA
349 $VERSION
350 $DEBUG
3511608µs180µs);
# spent 80µs making 1 call to MIME::Lite::BEGIN@341
352
353
354# GLOBALS, EXTERNAL/CONFIGURATION...
3551400ns$VERSION = '3.030';
356
357### Automatically interpret CC/BCC for SMTP:
3581100ns$AUTO_CC = 1;
359
360### Automatically choose content type from file name:
3611100ns$AUTO_CONTENT_TYPE = 0;
362
363### Automatically choose encoding from content type:
3641100ns$AUTO_ENCODE = 1;
365
366### Check paths right before printing:
36710s$AUTO_VERIFY = 1;
368
369### Set this true if you don't want to use MIME::Base64/QuotedPrint/Types:
3701100ns$PARANOID = 0;
371
372### Don't warn me about dangerous activities:
3731200ns$QUIET = undef;
374
375### Unsupported (for tester use): don't qualify boundary with time/pid:
3761100ns$VANILLA = 0;
377
3781100ns$MIME::Lite::DEBUG = 0;
379
380#==============================
381#==============================
382#
383# GLOBALS, INTERNAL...
384
3851300nsmy $Sender = "";
3861100nsmy $SENDMAIL = "";
387
388111µs14µsif ( $^O =~ /win32|cygwin/i ) {
# spent 4µs making 1 call to MIME::Lite::CORE:match
389 $Sender = "smtp";
390} else {
391 ### Find sendmail:
3921200ns $Sender = "sendmail";
3931100ns $SENDMAIL = "/usr/lib/sendmail";
394114µs110µs ( -x $SENDMAIL ) or ( $SENDMAIL = "/usr/sbin/sendmail" );
# spent 10µs making 1 call to MIME::Lite::CORE:fteexec
39514µs12µs ( -x $SENDMAIL ) or ( $SENDMAIL = "sendmail" );
# spent 2µs making 1 call to MIME::Lite::CORE:fteexec
39614µs12µs unless (-x $SENDMAIL) {
# spent 2µs making 1 call to MIME::Lite::CORE:fteexec
397 require File::Spec;
398 for my $dir (File::Spec->path) {
399 if ( -x "$dir/sendmail" ) {
400 $SENDMAIL = "$dir/sendmail";
401 last;
402 }
403 }
404 }
40513µs11µs unless (-x $SENDMAIL) {
# spent 1µs making 1 call to MIME::Lite::CORE:fteexec
406 undef $SENDMAIL;
407 }
408}
409
410### Our sending facilities:
41113µsmy %SenderArgs = (
412 sendmail => [],
413 smtp => [],
414 sub => [],
415);
416
417### Boundary counter:
4181200nsmy $BCount = 0;
419
420### Known Mail/MIME fields... these, plus some general forms like
421### "x-*", are recognized by build():
422118µsmy %KnownField = map { $_ => 1 }
423 qw(
424 bcc cc comments date encrypted
425 from keywords message-id mime-version organization
426 received references reply-to return-path sender
427 subject to
428
429 approved
430);
431
432### What external packages do we use for encoding?
4331200nsmy @Uses;
434
435### Header order:
436my @FieldOrder;
437
438### See if we have File::Basename
4391100nsmy $HaveFileBasename = 0;
440123µsif ( eval "require File::Basename" ) { # not affected by $PARANOID, core Perl
# spent 3µs executing statements in string eval
4411200ns $HaveFileBasename = 1;
44212µs push @Uses, "F$File::Basename::VERSION";
443}
444
445### See if we have/want MIME::Types
4461100nsmy $HaveMimeTypes = 0;
447122µsif ( !$PARANOID and eval "require MIME::Types; MIME::Types->VERSION(1.28);" ) {
# spent 1.47ms executing statements in string eval
4481300ns $HaveMimeTypes = 1;
4491900ns push @Uses, "T$MIME::Types::VERSION";
450}
451
452#==============================
453#==============================
454#
455# PRIVATE UTILITY FUNCTIONS...
456
457#------------------------------
458#
459# fold STRING
460#
461# Make STRING safe as a field value. Remove leading/trailing whitespace,
462# and make sure newlines are represented as newline+space
463
464sub fold {
465 my $str = shift;
466 $str =~ s/^\s*|\s*$//g; ### trim
467 $str =~ s/\n/\n /g;
468 $str;
469}
470
471#------------------------------
472#
473# gen_boundary
474#
475# Generate a new boundary to use.
476# The unsupported $VANILLA is for test purposes only.
477
478sub gen_boundary {
479 return ( "_----------=_" . ( $VANILLA ? '' : int(time) . $$ ) . $BCount++ );
480}
481
482#------------------------------
483#
484# is_mime_field FIELDNAME
485#
486# Is this a field I manage?
487
488sub is_mime_field {
489 $_[0] =~ /^(mime\-|content\-)/i;
490}
491
492#------------------------------
493#
494# extract_full_addrs STRING
495# extract_only_addrs STRING
496#
497# Split STRING into an array of email addresses: somewhat of a KLUDGE.
498#
499# Unless paranoid, we try to load the real code before supplying our own.
500
# spent 7µs within MIME::Lite::BEGIN@500 which was called: # once (7µs+0s) by C4::Letters::BEGIN@23 at line 535
BEGIN {
5011400ns my $ATOM = '[^ \000-\037()<>@,;:\134"\056\133\135]+';
5021100ns my $QSTR = '".*?"';
5031800ns my $WORD = '(?:' . $QSTR . '|' . $ATOM . ')';
5041700ns my $DOMAIN = '(?:' . $ATOM . '(?:' . '\\.' . $ATOM . ')*' . ')';
5051600ns my $LOCALPART = '(?:' . $WORD . '(?:' . '\\.' . $WORD . ')*' . ')';
5061500ns my $ADDR = '(?:' . $LOCALPART . '@' . $DOMAIN . ')';
5071300ns my $PHRASE = '(?:' . $WORD . ')+';
50814µs my $SEP = "(?:^\\s*|\\s*,\\s*)"; ### before elems in a list
509
510 sub my_extract_full_addrs {
511 my $str = shift;
512 return unless $str;
513 my @addrs;
514 $str =~ s/\s/ /g; ### collapse whitespace
515
516 pos($str) = 0;
517 while ( $str !~ m{\G\s*\Z}gco ) {
518 ### print STDERR "TACKLING: ".substr($str, pos($str))."\n";
519 if ( $str =~ m{\G$SEP($PHRASE)\s*<\s*($ADDR)\s*>}gco ) {
520 push @addrs, "$1 <$2>";
521 } elsif ( $str =~ m{\G$SEP($ADDR)}gco or $str =~ m{\G$SEP($ATOM)}gco ) {
522 push @addrs, $1;
523 } else {
524 my $problem = substr( $str, pos($str) );
525 die "can't extract address at <$problem> in <$str>\n";
526 }
527 }
528 return wantarray ? @addrs : $addrs[0];
529 }
530
531 sub my_extract_only_addrs {
532 my @ret = map { /<([^>]+)>/ ? $1 : $_ } my_extract_full_addrs(@_);
533 return wantarray ? @ret : $ret[0];
534 }
53513.39ms17µs}
# spent 7µs making 1 call to MIME::Lite::BEGIN@500
536#------------------------------
537
538
539124µsif ( !$PARANOID and eval "require Mail::Address" ) {
# spent 651µs executing statements in string eval
5401900ns push @Uses, "A$Mail::Address::VERSION";
541185µs eval q{
542 sub extract_full_addrs {
543 my @ret=map { $_->format } Mail::Address->parse($_[0]);
544 return wantarray ? @ret : $ret[0]
545 }
546 sub extract_only_addrs {
547 my @ret=map { $_->address } Mail::Address->parse($_[0]);
548 return wantarray ? @ret : $ret[0]
549 }
550 }; ### q
551} else {
552 eval q{
553 *extract_full_addrs=*my_extract_full_addrs;
554 *extract_only_addrs=*my_extract_only_addrs;
555 }; ### q
556} ### if
557
558#==============================
559#==============================
560#
561# PRIVATE ENCODING FUNCTIONS...
562
563#------------------------------
564#
565# encode_base64 STRING
566#
567# Encode the given string using BASE64.
568# Unless paranoid, we try to load the real code before supplying our own.
569
570113µsif ( !$PARANOID and eval "require MIME::Base64" ) {
# spent 855µs executing statements in string eval
57115µs141µs import MIME::Base64 qw(encode_base64);
# spent 41µs making 1 call to Exporter::import
57211µs push @Uses, "B$MIME::Base64::VERSION";
573} else {
574 eval q{
575 sub encode_base64 {
576 my $res = "";
577 my $eol = "\n";
578
579 pos($_[0]) = 0; ### thanks, Andreas!
580 while ($_[0] =~ /(.{1,45})/gs) {
581 $res .= substr(pack('u', $1), 1);
582 chop($res);
583 }
584 $res =~ tr|` -_|AA-Za-z0-9+/|;
585
586 ### Fix padding at the end:
587 my $padding = (3 - length($_[0]) % 3) % 3;
588 $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
589
590 ### Break encoded string into lines of no more than 76 characters each:
591 $res =~ s/(.{1,76})/$1$eol/g if (length $eol);
592 return $res;
593 } ### sub
594 } ### q
595} ### if
596
597#------------------------------
598#
599# encode_qp STRING
600#
601# Encode the given string, LINE BY LINE, using QUOTED-PRINTABLE.
602# Stolen from MIME::QuotedPrint by Gisle Aas, with a slight bug fix: we
603# break lines earlier. Notice that this seems not to work unless
604# encoding line by line.
605#
606# Unless paranoid, we try to load the real code before supplying our own.
607
608123µsif ( !$PARANOID and eval "require MIME::QuotedPrint" ) {
# spent 647µs executing statements in string eval
60914µs124µs import MIME::QuotedPrint qw(encode_qp);
# spent 24µs making 1 call to Exporter::import
6101900ns push @Uses, "Q$MIME::QuotedPrint::VERSION";
611} else {
612 eval q{
613 sub encode_qp {
614 my $res = shift;
615 local($_);
616 $res =~ s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg; ### rule #2,#3
617 $res =~ s/([ \t]+)$/
618 join('', map { sprintf("=%02X", ord($_)) }
619 split('', $1)
620 )/egm; ### rule #3 (encode whitespace at eol)
621
622 ### rule #5 (lines shorter than 76 chars, but can't break =XX escapes:
623 my $brokenlines = "";
624 $brokenlines .= "$1=\n" while $res =~ s/^(.{70}([^=]{2})?)//; ### 70 was 74
625 $brokenlines =~ s/=\n$// unless length $res;
626 "$brokenlines$res";
627 } ### sub
628 } ### q
629} ### if
630
631
632#------------------------------
633#
634# encode_8bit STRING
635#
636# Encode the given string using 8BIT.
637# This breaks long lines into shorter ones.
638
639sub encode_8bit {
640 my $str = shift;
641 $str =~ s/^(.{990})/$1\n/mg;
642 $str;
643}
644
645#------------------------------
646#
647# encode_7bit STRING
648#
649# Encode the given string using 7BIT.
650# This NO LONGER protects people through encoding.
651
652sub encode_7bit {
653 my $str = shift;
654 $str =~ s/[\x80-\xFF]//g;
655 $str =~ s/^(.{990})/$1\n/mg;
656 $str;
657}
658
659#==============================
660#==============================
661
662=head2 Construction
663
664=over 4
665
666=cut
667
668
669#------------------------------
670
671=item new [PARAMHASH]
672
673I<Class method, constructor.>
674Create a new message object.
675
676If any arguments are given, they are passed into C<build()>; otherwise,
677just the empty object is created.
678
679=cut
680
681
682sub new {
683 my $class = shift;
684
685 ### Create basic object:
686 my $self = { Attrs => {}, ### MIME attributes
687 SubAttrs => {}, ### MIME sub-attributes
688 Header => [], ### explicit message headers
689 Parts => [], ### array of parts
690 };
691 bless $self, $class;
692
693 ### Build, if needed:
694 return ( @_ ? $self->build(@_) : $self );
695}
696
697
698#------------------------------
699
700=item attach PART
701
702=item attach PARAMHASH...
703
704I<Instance method.>
705Add a new part to this message, and return the new part.
706
707If you supply a single PART argument, it will be regarded
708as a MIME::Lite object to be attached. Otherwise, this
709method assumes that you are giving in the pairs of a PARAMHASH
710which will be sent into C<new()> to create the new part.
711
712One of the possibly-quite-useful hacks thrown into this is the
713"attach-to-singlepart" hack: if you attempt to attach a part (let's
714call it "part 1") to a message that doesn't have a content-type
715of "multipart" or "message", the following happens:
716
717=over 4
718
719=item *
720
721A new part (call it "part 0") is made.
722
723=item *
724
725The MIME attributes and data (but I<not> the other headers)
726are cut from the "self" message, and pasted into "part 0".
727
728=item *
729
730The "self" is turned into a "multipart/mixed" message.
731
732=item *
733
734The new "part 0" is added to the "self", and I<then> "part 1" is added.
735
736=back
737
738One of the nice side-effects is that you can create a text message
739and then add zero or more attachments to it, much in the same way
740that a user agent like Netscape allows you to do.
741
742=cut
743
744
745sub attach {
746 my $self = shift;
747 my $attrs = $self->{Attrs};
748 my $sub_attrs = $self->{SubAttrs};
749
750 ### Create new part, if necessary:
751 my $part1 = ( ( @_ == 1 ) ? shift: ref($self)->new( Top => 0, @_ ) );
752
753 ### Do the "attach-to-singlepart" hack:
754 if ( $attrs->{'content-type'} !~ m{^(multipart|message)/}i ) {
755
756 ### Create part zero:
757 my $part0 = ref($self)->new;
758
759 ### Cut MIME stuff from self, and paste into part zero:
760 foreach (qw(SubAttrs Attrs Data Path FH)) {
761 $part0->{$_} = $self->{$_};
762 delete( $self->{$_} );
763 }
764 $part0->top_level(0); ### clear top-level attributes
765
766 ### Make self a top-level multipart:
767 $attrs = $self->{Attrs} ||= {}; ### reset (sam: bug? this doesn't reset anything since Attrs is already a hash-ref)
768 $sub_attrs = $self->{SubAttrs} ||= {}; ### reset
769 $attrs->{'content-type'} = 'multipart/mixed';
770 $sub_attrs->{'content-type'}{'boundary'} = gen_boundary();
771 $attrs->{'content-transfer-encoding'} = '7bit';
772 $self->top_level(1); ### activate top-level attributes
773
774 ### Add part 0:
775 push @{ $self->{Parts} }, $part0;
776 }
777
778 ### Add the new part:
779 push @{ $self->{Parts} }, $part1;
780 $part1;
781}
782
783#------------------------------
784
785=item build [PARAMHASH]
786
787I<Class/instance method, initializer.>
788Create (or initialize) a MIME message object.
789Normally, you'll use the following keys in PARAMHASH:
790
791 * Data, FH, or Path (either one of these, or none if multipart)
792 * Type (e.g., "image/jpeg")
793 * From, To, and Subject (if this is the "top level" of a message)
794
795The PARAMHASH can contain the following keys:
796
797=over 4
798
799=item (fieldname)
800
801Any field you want placed in the message header, taken from the
802standard list of header fields (you don't need to worry about case):
803
804 Approved Encrypted Received Sender
805 Bcc From References Subject
806 Cc Keywords Reply-To To
807 Comments Message-ID Resent-* X-*
808 Content-* MIME-Version Return-Path
809 Date Organization
810
811To give experienced users some veto power, these fields will be set
812I<after> the ones I set... so be careful: I<don't set any MIME fields>
813(like C<Content-type>) unless you know what you're doing!
814
815To specify a fieldname that's I<not> in the above list, even one that's
816identical to an option below, just give it with a trailing C<":">,
817like C<"My-field:">. When in doubt, that I<always> signals a mail
818field (and it sort of looks like one too).
819
820=item Data
821
822I<Alternative to "Path" or "FH".>
823The actual message data. This may be a scalar or a ref to an array of
824strings; if the latter, the message consists of a simple concatenation
825of all the strings in the array.
826
827=item Datestamp
828
829I<Optional.>
830If given true (or omitted), we force the creation of a C<Date:> field
831stamped with the current date/time if this is a top-level message.
832You may want this if using L<send_by_smtp()|/send_by_smtp>.
833If you don't want this to be done, either provide your own Date
834or explicitly set this to false.
835
836=item Disposition
837
838I<Optional.>
839The content disposition, C<"inline"> or C<"attachment">.
840The default is C<"inline">.
841
842=item Encoding
843
844I<Optional.>
845The content transfer encoding that should be used to encode your data:
846
847 Use encoding: | If your message contains:
848 ------------------------------------------------------------
849 7bit | Only 7-bit text, all lines <1000 characters
850 8bit | 8-bit text, all lines <1000 characters
851 quoted-printable | 8-bit text or long lines (more reliable than "8bit")
852 base64 | Largely non-textual data: a GIF, a tar file, etc.
853
854The default is taken from the Type; generally it is "binary" (no
855encoding) for text/*, message/*, and multipart/*, and "base64" for
856everything else. A value of C<"binary"> is generally I<not> suitable
857for sending anything but ASCII text files with lines under 1000
858characters, so consider using one of the other values instead.
859
860In the case of "7bit"/"8bit", long lines are automatically chopped to
861legal length; in the case of "7bit", all 8-bit characters are
862automatically I<removed>. This may not be what you want, so pick your
863encoding well! For more info, see L<"A MIME PRIMER">.
864
865=item FH
866
867I<Alternative to "Data" or "Path".>
868Filehandle containing the data, opened for reading.
869See "ReadNow" also.
870
871=item Filename
872
873I<Optional.>
874The name of the attachment. You can use this to supply a
875recommended filename for the end-user who is saving the attachment
876to disk. You only need this if the filename at the end of the
877"Path" is inadequate, or if you're using "Data" instead of "Path".
878You should I<not> put path information in here (e.g., no "/"
879or "\" or ":" characters should be used).
880
881=item Id
882
883I<Optional.>
884Same as setting "content-id".
885
886=item Length
887
888I<Optional.>
889Set the content length explicitly. Normally, this header is automatically
890computed, but only under certain circumstances (see L<"Benign limitations">).
891
892=item Path
893
894I<Alternative to "Data" or "FH".>
895Path to a file containing the data... actually, it can be any open()able
896expression. If it looks like a path, the last element will automatically
897be treated as the filename.
898See "ReadNow" also.
899
900=item ReadNow
901
902I<Optional, for use with "Path".>
903If true, will open the path and slurp the contents into core now.
904This is useful if the Path points to a command and you don't want
905to run the command over and over if outputting the message several
906times. B<Fatal exception> raised if the open fails.
907
908=item Top
909
910I<Optional.>
911If defined, indicates whether or not this is a "top-level" MIME message.
912The parts of a multipart message are I<not> top-level.
913Default is true.
914
915=item Type
916
917I<Optional.>
918The MIME content type, or one of these special values (case-sensitive):
919
920 "TEXT" means "text/plain"
921 "BINARY" means "application/octet-stream"
922 "AUTO" means attempt to guess from the filename, falling back
923 to 'application/octet-stream'. This is good if you have
924 MIME::Types on your system and you have no idea what
925 file might be used for the attachment.
926
927The default is C<"TEXT">, but it will be C<"AUTO"> if you set
928$AUTO_CONTENT_TYPE to true (sorry, but you have to enable
929it explicitly, since we don't want to break code which depends
930on the old behavior).
931
932=back
933
934A picture being worth 1000 words (which
935is of course 2000 bytes, so it's probably more of an "icon" than a "picture",
936but I digress...), here are some examples:
937
938 $msg = MIME::Lite->build(
939 From => 'yelling@inter.com',
940 To => 'stocking@fish.net',
941 Subject => "Hi there!",
942 Type => 'TEXT',
943 Encoding => '7bit',
944 Data => "Just a quick note to say hi!"
945 );
946
947 $msg = MIME::Lite->build(
948 From => 'dorothy@emerald-city.oz',
949 To => 'gesundheit@edu.edu.edu',
950 Subject => "A gif for U"
951 Type => 'image/gif',
952 Path => "/home/httpd/logo.gif"
953 );
954
955 $msg = MIME::Lite->build(
956 From => 'laughing@all.of.us',
957 To => 'scarlett@fiddle.dee.de',
958 Subject => "A gzipp'ed tar file",
959 Type => 'x-gzip',
960 Path => "gzip < /usr/inc/somefile.tar |",
961 ReadNow => 1,
962 Filename => "somefile.tgz"
963 );
964
965To show you what's really going on, that last example could also
966have been written:
967
968 $msg = new MIME::Lite;
969 $msg->build(
970 Type => 'x-gzip',
971 Path => "gzip < /usr/inc/somefile.tar |",
972 ReadNow => 1,
973 Filename => "somefile.tgz"
974 );
975 $msg->add(From => "laughing@all.of.us");
976 $msg->add(To => "scarlett@fiddle.dee.de");
977 $msg->add(Subject => "A gzipp'ed tar file");
978
979=cut
980
981
982sub build {
983 my $self = shift;
984 my %params = @_;
985 my @params = @_;
986 my $key;
987
988 ### Miko's note: reorganized to check for exactly one of Data, Path, or FH
989 ( defined( $params{Data} ) + defined( $params{Path} ) + defined( $params{FH} ) <= 1 )
990 or Carp::croak "supply exactly zero or one of (Data|Path|FH).\n";
991
992 ### Create new instance, if necessary:
993 ref($self) or $self = $self->new;
994
995
996 ### CONTENT-TYPE....
997 ###
998
999 ### Get content-type or content-type-macro:
1000 my $type = ( $params{Type} || ( $AUTO_CONTENT_TYPE ? 'AUTO' : 'TEXT' ) );
1001
1002 ### Interpret content-type-macros:
1003 if ( $type eq 'TEXT' ) { $type = 'text/plain'; }
1004 elsif ( $type eq 'HTML' ) { $type = 'text/html'; }
1005 elsif ( $type eq 'BINARY' ) { $type = 'application/octet-stream' }
1006 elsif ( $type eq 'AUTO' ) { $type = $self->suggest_type( $params{Path} ); }
1007
1008 ### We now have a content-type; set it:
1009 $type = lc($type);
1010 my $attrs = $self->{Attrs};
1011 my $sub_attrs = $self->{SubAttrs};
1012 $attrs->{'content-type'} = $type;
1013
1014 ### Get some basic attributes from the content type:
1015 my $is_multipart = ( $type =~ m{^(multipart)/}i );
1016
1017 ### Add in the multipart boundary:
1018 if ($is_multipart) {
1019 my $boundary = gen_boundary();
1020 $sub_attrs->{'content-type'}{'boundary'} = $boundary;
1021 }
1022
1023
1024 ### CONTENT-ID...
1025 ###
1026 if ( defined $params{Id} ) {
1027 my $id = $params{Id};
1028 $id = "<$id>" unless $id =~ /\A\s*<.*>\s*\z/;
1029 $attrs->{'content-id'} = $id;
1030 }
1031
1032
1033 ### DATA OR PATH...
1034 ### Note that we must do this *after* we get the content type,
1035 ### in case read_now() is invoked, since it needs the binmode().
1036
1037 ### Get data, as...
1038 ### ...either literal data:
1039 if ( defined( $params{Data} ) ) {
1040 $self->data( $params{Data} );
1041 }
1042 ### ...or a path to data:
1043 elsif ( defined( $params{Path} ) ) {
1044 $self->path( $params{Path} ); ### also sets filename
1045 $self->read_now if $params{ReadNow};
1046 }
1047 ### ...or a filehandle to data:
1048 ### Miko's note: this part works much like the path routine just above,
1049 elsif ( defined( $params{FH} ) ) {
1050 $self->fh( $params{FH} );
1051 $self->read_now if $params{ReadNow}; ### implement later
1052 }
1053
1054
1055 ### FILENAME... (added by Ian Smith <ian@safeway.dircon.co.uk> on 8/4/97)
1056 ### Need this to make sure the filename is added. The Filename
1057 ### attribute is ignored, otherwise.
1058 if ( defined( $params{Filename} ) ) {
1059 $self->filename( $params{Filename} );
1060 }
1061
1062
1063 ### CONTENT-TRANSFER-ENCODING...
1064 ###
1065
1066 ### Get it:
1067 my $enc =
1068 ( $params{Encoding} || ( $AUTO_ENCODE and $self->suggest_encoding($type) ) || 'binary' );
1069 $attrs->{'content-transfer-encoding'} = lc($enc);
1070
1071 ### Sanity check:
1072 if ( $type =~ m{^(multipart|message)/} ) {
1073 ( $enc =~ m{^(7bit|8bit|binary)\Z} )
1074 or Carp::croak( "illegal MIME: " . "can't have encoding $enc with type $type\n" );
1075 }
1076
1077 ### CONTENT-DISPOSITION...
1078 ### Default is inline for single, none for multis:
1079 ###
1080 my $disp = ( $params{Disposition} or ( $is_multipart ? undef: 'inline' ) );
1081 $attrs->{'content-disposition'} = $disp;
1082
1083 ### CONTENT-LENGTH...
1084 ###
1085 my $length;
1086 if ( exists( $params{Length} ) ) { ### given by caller:
1087 $attrs->{'content-length'} = $params{Length};
1088 } else { ### compute it ourselves
1089 $self->get_length;
1090 }
1091
1092 ### Init the top-level fields:
1093 my $is_top = defined( $params{Top} ) ? $params{Top} : 1;
1094 $self->top_level($is_top);
1095
1096 ### Datestamp if desired:
1097 my $ds_wanted = $params{Datestamp};
1098 my $ds_defaulted = ( $is_top and !exists( $params{Datestamp} ) );
1099 if ( ( $ds_wanted or $ds_defaulted ) and !exists( $params{Date} ) ) {
1100 require Email::Date::Format;
1101 $self->add( "date", Email::Date::Format::email_date() );
1102 }
1103
1104 ### Set message headers:
1105 my @paramz = @params;
1106 my $field;
1107 while (@paramz) {
1108 my ( $tag, $value ) = ( shift(@paramz), shift(@paramz) );
1109 my $lc_tag = lc($tag);
1110
1111 ### Get tag, if a tag:
1112 if ( $lc_tag =~ /^-(.*)/ ) { ### old style, backwards-compatibility
1113 $field = $1;
1114 } elsif ( $lc_tag =~ /^(.*):$/ ) { ### new style
1115 $field = $1;
1116 } elsif ( $KnownField{$lc_tag} or
1117 $lc_tag =~ m{^(content|resent|x)-.} ){
1118 $field = $lc_tag;
1119 } else { ### not a field:
1120 next;
1121 }
1122
1123 ### Add it:
1124 $self->add( $field, $value );
1125 }
1126
1127 ### Done!
1128 $self;
1129}
1130
1131=back
1132
1133=cut
1134
1135
1136#==============================
1137#==============================
1138
1139=head2 Setting/getting headers and attributes
1140
1141=over 4
1142
1143=cut
1144
1145
1146#------------------------------
1147#
1148# top_level ONOFF
1149#
1150# Set/unset the top-level attributes and headers.
1151# This affects "MIME-Version" and "X-Mailer".
1152
1153sub top_level {
1154 my ( $self, $onoff ) = @_;
1155 my $attrs = $self->{Attrs};
1156 if ($onoff) {
1157 $attrs->{'mime-version'} = '1.0';
1158 my $uses = ( @Uses ? ( "(" . join( "; ", @Uses ) . ")" ) : '' );
1159 $self->replace( 'X-Mailer' => "MIME::Lite $VERSION $uses" )
1160 unless $VANILLA;
1161 } else {
1162 delete $attrs->{'mime-version'};
1163 $self->delete('X-Mailer');
1164 }
1165}
1166
1167#------------------------------
1168
1169=item add TAG,VALUE
1170
1171I<Instance method.>
1172Add field TAG with the given VALUE to the end of the header.
1173The TAG will be converted to all-lowercase, and the VALUE
1174will be made "safe" (returns will be given a trailing space).
1175
1176B<Beware:> any MIME fields you "add" will override any MIME
1177attributes I have when it comes time to output those fields.
1178Normally, you will use this method to add I<non-MIME> fields:
1179
1180 $msg->add("Subject" => "Hi there!");
1181
1182Giving VALUE as an arrayref will cause all those values to be added.
1183This is only useful for special multiple-valued fields like "Received":
1184
1185 $msg->add("Received" => ["here", "there", "everywhere"]
1186
1187Giving VALUE as the empty string adds an invisible placeholder
1188to the header, which can be used to suppress the output of
1189the "Content-*" fields or the special "MIME-Version" field.
1190When suppressing fields, you should use replace() instead of add():
1191
1192 $msg->replace("Content-disposition" => "");
1193
1194I<Note:> add() is probably going to be more efficient than C<replace()>,
1195so you're better off using it for most applications if you are
1196certain that you don't need to delete() the field first.
1197
1198I<Note:> the name comes from Mail::Header.
1199
1200=cut
1201
1202
1203sub add {
1204 my $self = shift;
1205 my $tag = lc(shift);
1206 my $value = shift;
1207
1208 ### If a dangerous option, warn them:
1209 Carp::carp "Explicitly setting a MIME header field ($tag) is dangerous:\n"
1210 . "use the attr() method instead.\n"
1211 if ( is_mime_field($tag) && !$QUIET );
1212
1213 ### Get array of clean values:
1214 my @vals = ( ( ref($value) and ( ref($value) eq 'ARRAY' ) )
1215 ? @{$value}
1216 : ( $value . '' )
1217 );
1218 map { s/\n/\n /g } @vals;
1219
1220 ### Add them:
1221 foreach (@vals) {
1222 push @{ $self->{Header} }, [ $tag, $_ ];
1223 }
1224}
1225
1226#------------------------------
1227
1228=item attr ATTR,[VALUE]
1229
1230I<Instance method.>
1231Set MIME attribute ATTR to the string VALUE.
1232ATTR is converted to all-lowercase.
1233This method is normally used to set/get MIME attributes:
1234
1235 $msg->attr("content-type" => "text/html");
1236 $msg->attr("content-type.charset" => "US-ASCII");
1237 $msg->attr("content-type.name" => "homepage.html");
1238
1239This would cause the final output to look something like this:
1240
1241 Content-type: text/html; charset=US-ASCII; name="homepage.html"
1242
1243Note that the special empty sub-field tag indicates the anonymous
1244first sub-field.
1245
1246Giving VALUE as undefined will cause the contents of the named
1247subfield to be deleted.
1248
1249Supplying no VALUE argument just returns the attribute's value:
1250
1251 $type = $msg->attr("content-type"); ### returns "text/html"
1252 $name = $msg->attr("content-type.name"); ### returns "homepage.html"
1253
1254=cut
1255
1256
1257sub attr {
1258 my ( $self, $attr, $value ) = @_;
1259 my $attrs = $self->{Attrs};
1260
1261 $attr = lc($attr);
1262
1263 ### Break attribute name up:
1264 my ( $tag, $subtag ) = split /\./, $attr;
1265 if (defined($subtag)) {
1266 $attrs = $self->{SubAttrs}{$tag} ||= {};
1267 $tag = $subtag;
1268 }
1269
1270 ### Set or get?
1271 if ( @_ > 2 ) { ### set:
1272 if ( defined($value) ) {
1273 $attrs->{$tag} = $value;
1274 } else {
1275 delete $attrs->{$tag};
1276 }
1277 }
1278
1279 ### Return current value:
1280 $attrs->{$tag};
1281}
1282
1283sub _safe_attr {
1284 my ( $self, $attr ) = @_;
1285 return defined $self->{Attrs}{$attr} ? $self->{Attrs}{$attr} : '';
1286}
1287
1288#------------------------------
1289
1290=item delete TAG
1291
1292I<Instance method.>
1293Delete field TAG with the given VALUE to the end of the header.
1294The TAG will be converted to all-lowercase.
1295
1296 $msg->delete("Subject");
1297
1298I<Note:> the name comes from Mail::Header.
1299
1300=cut
1301
1302
1303sub delete {
1304 my $self = shift;
1305 my $tag = lc(shift);
1306
1307 ### Delete from the header:
1308 my $hdr = [];
1309 my $field;
1310 foreach $field ( @{ $self->{Header} } ) {
1311 push @$hdr, $field if ( $field->[0] ne $tag );
1312 }
1313 $self->{Header} = $hdr;
1314 $self;
1315}
1316
1317
1318#------------------------------
1319
1320=item field_order FIELD,...FIELD
1321
1322I<Class/instance method.>
1323Change the order in which header fields are output for this object:
1324
1325 $msg->field_order('from', 'to', 'content-type', 'subject');
1326
1327When used as a class method, changes the default settings for
1328all objects:
1329
1330 MIME::Lite->field_order('from', 'to', 'content-type', 'subject');
1331
1332Case does not matter: all field names will be coerced to lowercase.
1333In either case, supply the empty array to restore the default ordering.
1334
1335=cut
1336
1337
1338sub field_order {
1339 my $self = shift;
1340 if ( ref($self) ) {
1341 $self->{FieldOrder} = [ map { lc($_) } @_ ];
1342 } else {
1343 @FieldOrder = map { lc($_) } @_;
1344 }
1345}
1346
1347#------------------------------
1348
1349=item fields
1350
1351I<Instance method.>
1352Return the full header for the object, as a ref to an array
1353of C<[TAG, VALUE]> pairs, where each TAG is all-lowercase.
1354Note that any fields the user has explicitly set will override the
1355corresponding MIME fields that we would otherwise generate.
1356So, don't say...
1357
1358 $msg->set("Content-type" => "text/html; charset=US-ASCII");
1359
1360unless you want the above value to override the "Content-type"
1361MIME field that we would normally generate.
1362
1363I<Note:> I called this "fields" because the header() method of
1364Mail::Header returns something different, but similar enough to
1365be confusing.
1366
1367You can change the order of the fields: see L</field_order>.
1368You really shouldn't need to do this, but some people have to
1369deal with broken mailers.
1370
1371=cut
1372
1373
1374sub fields {
1375 my $self = shift;
1376 my @fields;
1377 my $attrs = $self->{Attrs};
1378 my $sub_attrs = $self->{SubAttrs};
1379
1380 ### Get a lookup-hash of all *explicitly-given* fields:
1381 my %explicit = map { $_->[0] => 1 } @{ $self->{Header} };
1382
1383 ### Start with any MIME attributes not given explicitly:
1384 my $tag;
1385 foreach $tag ( sort keys %{ $self->{Attrs} } ) {
1386
1387 ### Skip if explicit:
1388 next if ( $explicit{$tag} );
1389
1390 # get base attr value or skip if not available
1391 my $value = $attrs->{$tag};
1392 defined $value or next;
1393
1394 ### handle sub-attrs if available
1395 if (my $subs = $sub_attrs->{$tag}) {
1396 $value .= '; ' .
1397 join('; ', map { qq{$_="$subs->{$_}"} } sort keys %$subs);
1398 }
1399
1400 # handle stripping \r\n now since we're not doing it in attr()
1401 # anymore
1402 $value =~ tr/\r\n//;
1403
1404 ### Add to running fields;
1405 push @fields, [ $tag, $value ];
1406 }
1407
1408 ### Add remaining fields (note that we duplicate the array for safety):
1409 foreach ( @{ $self->{Header} } ) {
1410 push @fields, [ @{$_} ];
1411 }
1412
1413 ### Final step:
1414 ### If a suggested ordering was given, we "sort" by that ordering.
1415 ### The idea is that we give each field a numeric rank, which is
1416 ### (1000 * order(field)) + origposition.
1417 my @order = @{ $self->{FieldOrder} || [] }; ### object-specific
1418 @order or @order = @FieldOrder; ### no? maybe generic
1419 if (@order) { ### either?
1420
1421 ### Create hash mapping field names to 1-based rank:
1422 my %rank = map { $order[$_] => ( 1 + $_ ) } ( 0 .. $#order );
1423
1424 ### Create parallel array to @fields, called @ranked.
1425 ### It contains fields tagged with numbers like 2003, where the
1426 ### 3 is the original 0-based position, and 2000 indicates that
1427 ### we wanted this type of field to go second.
1428 my @ranked = map {
1429 [ ( $_ + 1000 * ( $rank{ lc( $fields[$_][0] ) } || ( 2 + $#order ) ) ), $fields[$_] ]
1430 } ( 0 .. $#fields );
1431
1432 # foreach (@ranked) {
1433 # print STDERR "RANKED: $_->[0] $_->[1][0] $_->[1][1]\n";
1434 # }
1435
1436 ### That was half the Schwartzian transform. Here's the rest:
1437 @fields = map { $_->[1] }
1438 sort { $a->[0] <=> $b->[0] } @ranked;
1439 }
1440
1441 ### Done!
1442 return \@fields;
1443}
1444
1445
1446#------------------------------
1447
1448=item filename [FILENAME]
1449
1450I<Instance method.>
1451Set the filename which this data will be reported as.
1452This actually sets both "standard" attributes.
1453
1454With no argument, returns the filename as dictated by the
1455content-disposition.
1456
1457=cut
1458
1459
1460sub filename {
1461 my ( $self, $filename ) = @_;
1462 my $sub_attrs = $self->{SubAttrs};
1463
1464 if ( @_ > 1 ) {
1465 $sub_attrs->{'content-type'}{'name'} = $filename;
1466 $sub_attrs->{'content-disposition'}{'filename'} = $filename;
1467 }
1468 return $sub_attrs->{'content-disposition'}{'filename'};
1469}
1470
1471#------------------------------
1472
1473=item get TAG,[INDEX]
1474
1475I<Instance method.>
1476Get the contents of field TAG, which might have been set
1477with set() or replace(). Returns the text of the field.
1478
1479 $ml->get('Subject', 0);
1480
1481If the optional 0-based INDEX is given, then we return the INDEX'th
1482occurrence of field TAG. Otherwise, we look at the context:
1483In a scalar context, only the first (0th) occurrence of the
1484field is returned; in an array context, I<all> occurrences are returned.
1485
1486I<Warning:> this should only be used with non-MIME fields.
1487Behavior with MIME fields is TBD, and will raise an exception for now.
1488
1489=cut
1490
1491
1492sub get {
1493 my ( $self, $tag, $index ) = @_;
1494 $tag = lc($tag);
1495 Carp::croak "get: can't be used with MIME fields\n" if is_mime_field($tag);
1496
1497 my @all = map { ( $_->[0] eq $tag ) ? $_->[1] : () } @{ $self->{Header} };
1498 ( defined($index) ? $all[$index] : ( wantarray ? @all : $all[0] ) );
1499}
1500
1501#------------------------------
1502
1503=item get_length
1504
1505I<Instance method.>
1506Recompute the content length for the message I<if the process is trivial>,
1507setting the "content-length" attribute as a side-effect:
1508
1509 $msg->get_length;
1510
1511Returns the length, or undefined if not set.
1512
1513I<Note:> the content length can be difficult to compute, since it
1514involves assembling the entire encoded body and taking the length
1515of it (which, in the case of multipart messages, means freezing
1516all the sub-parts, etc.).
1517
1518This method only sets the content length to a defined value if the
1519message is a singlepart with C<"binary"> encoding, I<and> the body is
1520available either in-core or as a simple file. Otherwise, the content
1521length is set to the undefined value.
1522
1523Since content-length is not a standard MIME field anyway (that's right, kids:
1524it's not in the MIME RFCs, it's an HTTP thing), this seems pretty fair.
1525
1526=cut
1527
1528
1529#----
1530# Miko's note: I wasn't quite sure how to handle this, so I waited to hear
1531# what you think. Given that the content-length isn't always required,
1532# and given the performance cost of calculating it from a file handle,
1533# I thought it might make more sense to add some sort of computelength
1534# property. If computelength is false, then the length simply isn't
1535# computed. What do you think?
1536#
1537# Eryq's reply: I agree; for now, we can silently leave out the content-type.
1538
1539sub get_length {
1540 my $self = shift;
1541 my $attrs = $self->{Attrs};
1542
1543 my $is_multipart = ( $attrs->{'content-type'} =~ m{^multipart/}i );
1544 my $enc = lc( $attrs->{'content-transfer-encoding'} || 'binary' );
1545 my $length;
1546 if ( !$is_multipart && ( $enc eq "binary" ) ) { ### might figure it out cheap:
1547 if ( defined( $self->{Data} ) ) { ### it's in core
1548 $length = length( $self->{Data} );
1549 } elsif ( defined( $self->{FH} ) ) { ### it's in a filehandle
1550 ### no-op: it's expensive, so don't bother
1551 } elsif ( defined( $self->{Path} ) ) { ### it's a simple file!
1552 $length = ( -s $self->{Path} ) if ( -e $self->{Path} );
1553 }
1554 }
1555 $attrs->{'content-length'} = $length;
1556 return $length;
1557}
1558
1559#------------------------------
1560
1561=item parts
1562
1563I<Instance method.>
1564Return the parts of this entity, and this entity only.
1565Returns empty array if this entity has no parts.
1566
1567This is B<not> recursive! Parts can have sub-parts; use
1568parts_DFS() to get everything.
1569
1570=cut
1571
1572
1573sub parts {
1574 my $self = shift;
1575 @{ $self->{Parts} || [] };
1576}
1577
1578#------------------------------
1579
1580=item parts_DFS
1581
1582I<Instance method.>
1583Return the list of all MIME::Lite objects included in the entity,
1584starting with the entity itself, in depth-first-search order.
1585If this object has no parts, it alone will be returned.
1586
1587=cut
1588
1589
1590sub parts_DFS {
1591 my $self = shift;
1592 return ( $self, map { $_->parts_DFS } $self->parts );
1593}
1594
1595#------------------------------
1596
1597=item preamble [TEXT]
1598
1599I<Instance method.>
1600Get/set the preamble string, assuming that this object has subparts.
1601Set it to undef for the default string.
1602
1603=cut
1604
1605
1606sub preamble {
1607 my $self = shift;
1608 $self->{Preamble} = shift if @_;
1609 $self->{Preamble};
1610}
1611
1612#------------------------------
1613
1614=item replace TAG,VALUE
1615
1616I<Instance method.>
1617Delete all occurrences of fields named TAG, and add a new
1618field with the given VALUE. TAG is converted to all-lowercase.
1619
1620B<Beware> the special MIME fields (MIME-version, Content-*):
1621if you "replace" a MIME field, the replacement text will override
1622the I<actual> MIME attributes when it comes time to output that field.
1623So normally you use attr() to change MIME fields and add()/replace() to
1624change I<non-MIME> fields:
1625
1626 $msg->replace("Subject" => "Hi there!");
1627
1628Giving VALUE as the I<empty string> will effectively I<prevent> that
1629field from being output. This is the correct way to suppress
1630the special MIME fields:
1631
1632 $msg->replace("Content-disposition" => "");
1633
1634Giving VALUE as I<undefined> will just cause all explicit values
1635for TAG to be deleted, without having any new values added.
1636
1637I<Note:> the name of this method comes from Mail::Header.
1638
1639=cut
1640
1641
1642sub replace {
1643 my ( $self, $tag, $value ) = @_;
1644 $self->delete($tag);
1645 $self->add( $tag, $value ) if defined($value);
1646}
1647
1648
1649#------------------------------
1650
1651=item scrub
1652
1653I<Instance method.>
1654B<This is Alpha code. If you use it, please let me know how it goes.>
1655Recursively goes through the "parts" tree of this message and tries
1656to find MIME attributes that can be removed.
1657With an array argument, removes exactly those attributes; e.g.:
1658
1659 $msg->scrub(['content-disposition', 'content-length']);
1660
1661Is the same as recursively doing:
1662
1663 $msg->replace('Content-disposition' => '');
1664 $msg->replace('Content-length' => '');
1665
1666=cut
1667
1668
1669sub scrub {
1670 my ( $self, @a ) = @_;
1671 my ($expl) = @a;
1672 local $QUIET = 1;
1673
1674 ### Scrub me:
1675 if ( !@a ) { ### guess
1676
1677 ### Scrub length always:
1678 $self->replace( 'content-length', '' );
1679
1680 ### Scrub disposition if no filename, or if content-type has same info:
1681 if ( !$self->_safe_attr('content-disposition.filename')
1682 || $self->_safe_attr('content-type.name') )
1683 {
1684 $self->replace( 'content-disposition', '' );
1685 }
1686
1687 ### Scrub encoding if effectively unencoded:
1688 if ( $self->_safe_attr('content-transfer-encoding') =~ /^(7bit|8bit|binary)$/i ) {
1689 $self->replace( 'content-transfer-encoding', '' );
1690 }
1691
1692 ### Scrub charset if US-ASCII:
1693 if ( $self->_safe_attr('content-type.charset') =~ /^(us-ascii)/i ) {
1694 $self->attr( 'content-type.charset' => undef );
1695 }
1696
1697 ### TBD: this is not really right for message/digest:
1698 if ( ( keys %{ $self->{Attrs}{'content-type'} } == 1 )
1699 and ( $self->_safe_attr('content-type') eq 'text/plain' ) )
1700 {
1701 $self->replace( 'content-type', '' );
1702 }
1703 } elsif ( $expl and ( ref($expl) eq 'ARRAY' ) ) {
1704 foreach ( @{$expl} ) { $self->replace( $_, '' ); }
1705 }
1706
1707 ### Scrub my kids:
1708 foreach ( @{ $self->{Parts} } ) { $_->scrub(@a); }
1709}
1710
1711=back
1712
1713=cut
1714
1715
1716#==============================
1717#==============================
1718
1719=head2 Setting/getting message data
1720
1721=over 4
1722
1723=cut
1724
1725
1726#------------------------------
1727
1728=item binmode [OVERRIDE]
1729
1730I<Instance method.>
1731With no argument, returns whether or not it thinks that the data
1732(as given by the "Path" argument of C<build()>) should be read using
1733binmode() (for example, when C<read_now()> is invoked).
1734
1735The default behavior is that any content type other than
1736C<text/*> or C<message/*> is binmode'd; this should in general work fine.
1737
1738With a defined argument, this method sets an explicit "override"
1739value. An undefined argument unsets the override.
1740The new current value is returned.
1741
1742=cut
1743
1744
1745sub binmode {
1746 my $self = shift;
1747 $self->{Binmode} = shift if (@_); ### argument? set override
1748 return ( defined( $self->{Binmode} )
1749 ? $self->{Binmode}
1750 : ( $self->{Attrs}{"content-type"} !~ m{^(text|message)/}i )
1751 );
1752}
1753
1754#------------------------------
1755
1756=item data [DATA]
1757
1758I<Instance method.>
1759Get/set the literal DATA of the message. The DATA may be
1760either a scalar, or a reference to an array of scalars (which
1761will simply be joined).
1762
1763I<Warning:> setting the data causes the "content-length" attribute
1764to be recomputed (possibly to nothing).
1765
1766=cut
1767
1768
1769sub data {
1770 my $self = shift;
1771 if (@_) {
1772 $self->{Data} = ( ( ref( $_[0] ) eq 'ARRAY' ) ? join( '', @{ $_[0] } ) : $_[0] );
1773 $self->get_length;
1774 }
1775 $self->{Data};
1776}
1777
1778#------------------------------
1779
1780=item fh [FILEHANDLE]
1781
1782I<Instance method.>
1783Get/set the FILEHANDLE which contains the message data.
1784
1785Takes a filehandle as an input and stores it in the object.
1786This routine is similar to path(); one important difference is that
1787no attempt is made to set the content length.
1788
1789=cut
1790
1791
1792sub fh {
1793 my $self = shift;
1794 $self->{FH} = shift if @_;
1795 $self->{FH};
1796}
1797
1798#------------------------------
1799
1800=item path [PATH]
1801
1802I<Instance method.>
1803Get/set the PATH to the message data.
1804
1805I<Warning:> setting the path recomputes any existing "content-length" field,
1806and re-sets the "filename" (to the last element of the path if it
1807looks like a simple path, and to nothing if not).
1808
1809=cut
1810
1811
1812sub path {
1813 my $self = shift;
1814 if (@_) {
1815
1816 ### Set the path, and invalidate the content length:
1817 $self->{Path} = shift;
1818
1819 ### Re-set filename, extracting it from path if possible:
1820 my $filename;
1821 if ( $self->{Path} and ( $self->{Path} !~ /\|$/ ) ) { ### non-shell path:
1822 ( $filename = $self->{Path} ) =~ s/^<//;
1823
1824 ### Consult File::Basename, maybe:
1825 if ($HaveFileBasename) {
1826 $filename = File::Basename::basename($filename);
1827 } else {
1828 ($filename) = ( $filename =~ m{([^\/]+)\Z} );
1829 }
1830 }
1831 $self->filename($filename);
1832
1833 ### Reset the length:
1834 $self->get_length;
1835 }
1836 $self->{Path};
1837}
1838
1839#------------------------------
1840
1841=item resetfh [FILEHANDLE]
1842
1843I<Instance method.>
1844Set the current position of the filehandle back to the beginning.
1845Only applies if you used "FH" in build() or attach() for this message.
1846
1847Returns false if unable to reset the filehandle (since not all filehandles
1848are seekable).
1849
1850=cut
1851
1852
1853#----
1854# Miko's note: With the Data and Path, the same data could theoretically
1855# be reused. However, file handles need to be reset to be reused,
1856# so I added this routine.
1857#
1858# Eryq reply: beware... not all filehandles are seekable (think about STDIN)!
1859
1860sub resetfh {
1861 my $self = shift;
1862 seek( $self->{FH}, 0, 0 );
1863}
1864
1865#------------------------------
1866
1867=item read_now
1868
1869I<Instance method.>
1870Forces data from the path/filehandle (as specified by C<build()>)
1871to be read into core immediately, just as though you had given it
1872literally with the C<Data> keyword.
1873
1874Note that the in-core data will always be used if available.
1875
1876Be aware that everything is slurped into a giant scalar: you may not want
1877to use this if sending tar files! The benefit of I<not> reading in the data
1878is that very large files can be handled by this module if left on disk
1879until the message is output via C<print()> or C<print_body()>.
1880
1881=cut
1882
1883
1884sub read_now {
1885 my $self = shift;
1886 local $/ = undef;
1887
1888 if ( $self->{FH} ) { ### data from a filehandle:
1889 my $chunk;
1890 my @chunks;
1891 CORE::binmode( $self->{FH} ) if $self->binmode;
1892 while ( read( $self->{FH}, $chunk, 1024 ) ) {
1893 push @chunks, $chunk;
1894 }
1895 $self->{Data} = join '', @chunks;
1896 } elsif ( $self->{Path} ) { ### data from a path:
1897 open SLURP, $self->{Path} or Carp::croak "open $self->{Path}: $!\n";
1898 CORE::binmode(SLURP) if $self->binmode;
1899 $self->{Data} = <SLURP>; ### sssssssssssssslurp...
1900 close SLURP; ### ...aaaaaaaaahhh!
1901 }
1902}
1903
1904#------------------------------
1905
1906=item sign PARAMHASH
1907
1908I<Instance method.>
1909Sign the message. This forces the message to be read into core,
1910after which the signature is appended to it.
1911
1912=over 4
1913
1914=item Data
1915
1916As in C<build()>: the literal signature data.
1917Can be either a scalar or a ref to an array of scalars.
1918
1919=item Path
1920
1921As in C<build()>: the path to the file.
1922
1923=back
1924
1925If no arguments are given, the default is:
1926
1927 Path => "$ENV{HOME}/.signature"
1928
1929The content-length is recomputed.
1930
1931=cut
1932
1933
1934sub sign {
1935 my $self = shift;
1936 my %params = @_;
1937
1938 ### Default:
1939 @_ or $params{Path} = "$ENV{HOME}/.signature";
1940
1941 ### Force message in-core:
1942 defined( $self->{Data} ) or $self->read_now;
1943
1944 ### Load signature:
1945 my $sig;
1946 if ( !defined( $sig = $params{Data} ) ) { ### not given explicitly:
1947 local $/ = undef;
1948 open SIG, $params{Path} or Carp::croak "open sig $params{Path}: $!\n";
1949 $sig = <SIG>; ### sssssssssssssslurp...
1950 close SIG; ### ...aaaaaaaaahhh!
1951 }
1952 $sig = join( '', @$sig ) if ( ref($sig) and ( ref($sig) eq 'ARRAY' ) );
1953
1954 ### Append, following Internet conventions:
1955 $self->{Data} .= "\n-- \n$sig";
1956
1957 ### Re-compute length:
1958 $self->get_length;
1959 1;
1960}
1961
1962#------------------------------
1963#
1964# =item suggest_encoding CONTENTTYPE
1965#
1966# I<Class/instance method.>
1967# Based on the CONTENTTYPE, return a good suggested encoding.
1968# C<text> and C<message> types have their bodies scanned line-by-line
1969# for 8-bit characters and long lines; lack of either means that the
1970# message is 7bit-ok. Other types are chosen independent of their body:
1971#
1972# Major type: 7bit ok? Suggested encoding:
1973# ------------------------------------------------------------
1974# text yes 7bit
1975# no quoted-printable
1976# unknown binary
1977#
1978# message yes 7bit
1979# no binary
1980# unknown binary
1981#
1982# multipart n/a binary (in case some parts are not ok)
1983#
1984# (other) n/a base64
1985#
1986#=cut
1987
1988sub suggest_encoding {
1989 my ( $self, $ctype ) = @_;
1990 $ctype = lc($ctype);
1991
1992 ### Consult MIME::Types, maybe:
1993 if ($HaveMimeTypes) {
1994
1995 ### Mappings contain [suffix,mimetype,encoding]
1996 my @mappings = MIME::Types::by_mediatype($ctype);
1997 if ( scalar(@mappings) ) {
1998 ### Just pick the first one:
1999 my ( $suffix, $mimetype, $encoding ) = @{ $mappings[0] };
2000 if ( $encoding
2001 && $encoding =~ /^(base64|binary|[78]bit|quoted-printable)$/i )
2002 {
2003 return lc($encoding); ### sanity check
2004 }
2005 }
2006 }
2007
2008 ### If we got here, then MIME::Types was no help.
2009 ### Extract major type:
2010 my ($type) = split '/', $ctype;
2011 if ( ( $type eq 'text' ) || ( $type eq 'message' ) ) { ### scan message body?
2012 return 'binary';
2013 } else {
2014 return ( $type eq 'multipart' ) ? 'binary' : 'base64';
2015 }
2016}
2017
2018#------------------------------
2019#
2020# =item suggest_type PATH
2021#
2022# I<Class/instance method.>
2023# Suggest the content-type for this attached path.
2024# We always fall back to "application/octet-stream" if no good guess
2025# can be made, so don't use this if you don't mean it!
2026#
2027sub suggest_type {
2028 my ( $self, $path ) = @_;
2029
2030 ### If there's no path, bail:
2031 $path or return 'application/octet-stream';
2032
2033 ### Consult MIME::Types, maybe:
2034 if ($HaveMimeTypes) {
2035
2036 # Mappings contain [mimetype,encoding]:
2037 my ( $mimetype, $encoding ) = MIME::Types::by_suffix($path);
2038 return $mimetype if ( $mimetype && $mimetype =~ /^\S+\/\S+$/ ); ### sanity check
2039 }
2040 ### If we got here, then MIME::Types was no help.
2041 ### The correct thing to fall back to is the most-generic content type:
2042 return 'application/octet-stream';
2043}
2044
2045#------------------------------
2046
2047=item verify_data
2048
2049I<Instance method.>
2050Verify that all "paths" to attached data exist, recursively.
2051It might be a good idea for you to do this before a print(), to
2052prevent accidental partial output if a file might be missing.
2053Raises exception if any path is not readable.
2054
2055=cut
2056
2057
2058sub verify_data {
2059 my $self = shift;
2060
2061 ### Verify self:
2062 my $path = $self->{Path};
2063 if ( $path and ( $path !~ /\|$/ ) ) { ### non-shell path:
2064 $path =~ s/^<//;
2065 ( -r $path ) or die "$path: not readable\n";
2066 }
2067
2068 ### Verify parts:
2069 foreach my $part ( @{ $self->{Parts} } ) { $part->verify_data }
2070 1;
2071}
2072
2073=back
2074
2075=cut
2076
2077
2078#==============================
2079#==============================
2080
2081=head2 Output
2082
2083=over 4
2084
2085=cut
2086
2087
2088#------------------------------
2089
2090=item print [OUTHANDLE]
2091
2092I<Instance method.>
2093Print the message to the given output handle, or to the currently-selected
2094filehandle if none was given.
2095
2096All OUTHANDLE has to be is a filehandle (possibly a glob ref), or
2097any object that responds to a print() message.
2098
2099=cut
2100
2101
2102sub print {
2103 my ( $self, $out ) = @_;
2104
2105 ### Coerce into a printable output handle:
2106 $out = MIME::Lite::IO_Handle->wrap($out);
2107
2108 ### Output head, separator, and body:
2109 $self->verify_data if $AUTO_VERIFY; ### prevents missing parts!
2110 $out->print( $self->header_as_string, "\n" );
2111 $self->print_body($out);
2112}
2113
2114#------------------------------
2115#
2116# print_for_smtp
2117#
2118# Instance method, private.
2119# Print, but filter out the topmost "Bcc" field.
2120# This is because qmail apparently doesn't do this for us!
2121#
2122sub print_for_smtp {
2123 my ( $self, $out ) = @_;
2124
2125 ### Coerce into a printable output handle:
2126 $out = MIME::Lite::IO_Handle->wrap($out);
2127
2128 ### Create a safe head:
2129 my @fields = grep { $_->[0] ne 'bcc' } @{ $self->fields };
2130 my $header = $self->fields_as_string( \@fields );
2131
2132 ### Output head, separator, and body:
2133 $out->print( $header, "\n" );
2134 $self->print_body( $out, '1' );
2135}
2136
2137#------------------------------
2138
2139=item print_body [OUTHANDLE] [IS_SMTP]
2140
2141I<Instance method.>
2142Print the body of a message to the given output handle, or to
2143the currently-selected filehandle if none was given.
2144
2145All OUTHANDLE has to be is a filehandle (possibly a glob ref), or
2146any object that responds to a print() message.
2147
2148B<Fatal exception> raised if unable to open any of the input files,
2149or if a part contains no data, or if an unsupported encoding is
2150encountered.
2151
2152IS_SMPT is a special option to handle SMTP mails a little more
2153intelligently than other send mechanisms may require. Specifically this
2154ensures that the last byte sent is NOT '\n' (octal \012) if the last two
2155bytes are not '\r\n' (\015\012) as this will cause some SMTP servers to
2156hang.
2157
2158=cut
2159
2160
2161sub print_body {
2162 my ( $self, $out, $is_smtp ) = @_;
2163 my $attrs = $self->{Attrs};
2164 my $sub_attrs = $self->{SubAttrs};
2165
2166 ### Coerce into a printable output handle:
2167 $out = MIME::Lite::IO_Handle->wrap($out);
2168
2169 ### Output either the body or the parts.
2170 ### Notice that we key off of the content-type! We expect fewer
2171 ### accidents that way, since the syntax will always match the MIME type.
2172 my $type = $attrs->{'content-type'};
2173 if ( $type =~ m{^multipart/}i ) {
2174 my $boundary = $sub_attrs->{'content-type'}{'boundary'};
2175
2176 ### Preamble:
2177 $out->print( defined( $self->{Preamble} )
2178 ? $self->{Preamble}
2179 : "This is a multi-part message in MIME format.\n"
2180 );
2181
2182 ### Parts:
2183 my $part;
2184 foreach $part ( @{ $self->{Parts} } ) {
2185 $out->print("\n--$boundary\n");
2186 $part->print($out);
2187 }
2188
2189 ### Epilogue:
2190 $out->print("\n--$boundary--\n");
2191 } elsif ( $type =~ m{^message/} ) {
2192 my @parts = @{ $self->{Parts} };
2193
2194 ### It's a toss-up; try both data and parts:
2195 if ( @parts == 0 ) { $self->print_simple_body( $out, $is_smtp ) }
2196 elsif ( @parts == 1 ) { $parts[0]->print($out) }
2197 else { Carp::croak "can't handle message with >1 part\n"; }
2198 } else {
2199 $self->print_simple_body( $out, $is_smtp );
2200 }
2201 1;
2202}
2203
2204#------------------------------
2205#
2206# print_simple_body [OUTHANDLE]
2207#
2208# I<Instance method, private.>
2209# Print the body of a simple singlepart message to the given
2210# output handle, or to the currently-selected filehandle if none
2211# was given.
2212#
2213# Note that if you want to print "the portion after
2214# the header", you don't want this method: you want
2215# L<print_body()|/print_body>.
2216#
2217# All OUTHANDLE has to be is a filehandle (possibly a glob ref), or
2218# any object that responds to a print() message.
2219#
2220# B<Fatal exception> raised if unable to open any of the input files,
2221# or if a part contains no data, or if an unsupported encoding is
2222# encountered.
2223#
2224sub print_simple_body {
2225 my ( $self, $out, $is_smtp ) = @_;
2226 my $attrs = $self->{Attrs};
2227
2228 ### Coerce into a printable output handle:
2229 $out = MIME::Lite::IO_Handle->wrap($out);
2230
2231 ### Get content-transfer-encoding:
2232 my $encoding = uc( $attrs->{'content-transfer-encoding'} );
2233 warn "M::L >>> Encoding using $encoding, is_smtp=" . ( $is_smtp || 0 ) . "\n"
2234 if $MIME::Lite::DEBUG;
2235
2236 ### Notice that we don't just attempt to slurp the data in from a file:
2237 ### by processing files piecemeal, we still enable ourselves to prepare
2238 ### very large MIME messages...
2239
2240 ### Is the data in-core? If so, blit it out...
2241 if ( defined( $self->{Data} ) ) {
2242 DATA:
2243 {
2244 local $_ = $encoding;
2245
2246 /^BINARY$/ and do {
2247 $is_smtp and $self->{Data} =~ s/(?!\r)\n\z/\r/;
2248 $out->print( $self->{Data} );
2249 last DATA;
2250 };
2251 /^8BIT$/ and do {
2252 $out->print( encode_8bit( $self->{Data} ) );
2253 last DATA;
2254 };
2255 /^7BIT$/ and do {
2256 $out->print( encode_7bit( $self->{Data} ) );
2257 last DATA;
2258 };
2259 /^QUOTED-PRINTABLE$/ and do {
2260 ### UNTAINT since m//mg on tainted data loops forever:
2261 my ($untainted) = ( $self->{Data} =~ m/\A(.*)\Z/s );
2262
2263 ### Encode it line by line:
2264 while ( $untainted =~ m{^(.*[\r\n]*)}smg ) {
2265 ### have to do it line by line...
2266 my $line = $1; # copy to avoid weird bug; rt 39334
2267 $out->print( encode_qp($line) );
2268 }
2269 last DATA;
2270 };
2271 /^BASE64/ and do {
2272 $out->print( encode_base64( $self->{Data} ) );
2273 last DATA;
2274 };
2275 Carp::croak "unsupported encoding: `$_'\n";
2276 }
2277 }
2278
2279 ### Else, is the data in a file? If so, output piecemeal...
2280 ### Miko's note: this routine pretty much works the same with a path
2281 ### or a filehandle. the only difference in behaviour is that it does
2282 ### not attempt to open anything if it already has a filehandle
2283 elsif ( defined( $self->{Path} ) || defined( $self->{FH} ) ) {
228422.35ms233µs
# spent 21µs (10+12) within MIME::Lite::BEGIN@2284 which was called: # once (10µs+12µs) by C4::Letters::BEGIN@23 at line 2284
no strict 'refs'; ### in case FH is not an object
# spent 21µs making 1 call to MIME::Lite::BEGIN@2284 # spent 12µs making 1 call to strict::unimport
2285 my $DATA;
2286
2287 ### Open file if necessary:
2288 if ( defined( $self->{Path} ) ) {
2289 $DATA = new FileHandle || Carp::croak "can't get new filehandle\n";
2290 $DATA->open("$self->{Path}")
2291 or Carp::croak "open $self->{Path}: $!\n";
2292 } else {
2293 $DATA = $self->{FH};
2294 }
2295 CORE::binmode($DATA) if $self->binmode;
2296
2297 ### Encode piece by piece:
2298 PATH:
2299 {
2300 local $_ = $encoding;
2301
2302 /^BINARY$/ and do {
2303 my $last = "";
2304 while ( read( $DATA, $_, 2048 ) ) {
2305 $out->print($last) if length $last;
2306 $last = $_;
2307 }
2308 if ( length $last ) {
2309 $is_smtp and $last =~ s/(?!\r)\n\z/\r/;
2310 $out->print($last);
2311 }
2312 last PATH;
2313 };
2314 /^8BIT$/ and do {
2315 $out->print( encode_8bit($_) ) while (<$DATA>);
2316 last PATH;
2317 };
2318 /^7BIT$/ and do {
2319 $out->print( encode_7bit($_) ) while (<$DATA>);
2320 last PATH;
2321 };
2322 /^QUOTED-PRINTABLE$/ and do {
2323 $out->print( encode_qp($_) ) while (<$DATA>);
2324 last PATH;
2325 };
2326 /^BASE64$/ and do {
2327 $out->print( encode_base64($_) ) while ( read( $DATA, $_, 45 ) );
2328 last PATH;
2329 };
2330 Carp::croak "unsupported encoding: `$_'\n";
2331 }
2332
2333 ### Close file:
2334 close $DATA if defined( $self->{Path} );
2335 }
2336
2337 else {
2338 Carp::croak "no data in this part\n";
2339 }
2340 1;
2341}
2342
2343#------------------------------
2344
2345=item print_header [OUTHANDLE]
2346
2347I<Instance method.>
2348Print the header of the message to the given output handle,
2349or to the currently-selected filehandle if none was given.
2350
2351All OUTHANDLE has to be is a filehandle (possibly a glob ref), or
2352any object that responds to a print() message.
2353
2354=cut
2355
2356
2357sub print_header {
2358 my ( $self, $out ) = @_;
2359
2360 ### Coerce into a printable output handle:
2361 $out = MIME::Lite::IO_Handle->wrap($out);
2362
2363 ### Output the header:
2364 $out->print( $self->header_as_string );
2365 1;
2366}
2367
2368#------------------------------
2369
2370=item as_string
2371
2372I<Instance method.>
2373Return the entire message as a string, with a header and an encoded body.
2374
2375=cut
2376
2377
2378sub as_string {
2379 my $self = shift;
2380 my $buf = "";
2381 my $io = ( wrap MIME::Lite::IO_Scalar \$buf);
2382 $self->print($io);
2383 return $buf;
2384}
238511µs*stringify = \&as_string; ### backwards compatibility
23861200ns*stringify = \&as_string; ### ...twice to avoid warnings :)
2387
2388#------------------------------
2389
2390=item body_as_string
2391
2392I<Instance method.>
2393Return the encoded body as a string.
2394This is the portion after the header and the blank line.
2395
2396I<Note:> actually prepares the body by "printing" to a scalar.
2397Proof that you can hand the C<print*()> methods any blessed object
2398that responds to a C<print()> message.
2399
2400=cut
2401
2402
2403sub body_as_string {
2404 my $self = shift;
2405 my $buf = "";
2406 my $io = ( wrap MIME::Lite::IO_Scalar \$buf);
2407 $self->print_body($io);
2408 return $buf;
2409}
24101300ns*stringify_body = \&body_as_string; ### backwards compatibility
24111200ns*stringify_body = \&body_as_string; ### ...twice to avoid warnings :)
2412
2413#------------------------------
2414#
2415# fields_as_string FIELDS
2416#
2417# PRIVATE! Return a stringified version of the given header
2418# fields, where FIELDS is an arrayref like that returned by fields().
2419#
2420sub fields_as_string {
2421 my ( $self, $fields ) = @_;
2422 my $out = "";
2423 foreach (@$fields) {
2424 my ( $tag, $value ) = @$_;
2425 next if ( $value eq '' ); ### skip empties
2426 $tag =~ s/\b([a-z])/uc($1)/ge; ### make pretty
2427 $tag =~ s/^mime-/MIME-/i; ### even prettier
2428 $out .= "$tag: $value\n";
2429 }
2430 return $out;
2431}
2432
2433#------------------------------
2434
2435=item header_as_string
2436
2437I<Instance method.>
2438Return the header as a string.
2439
2440=cut
2441
2442
2443sub header_as_string {
2444 my $self = shift;
2445 $self->fields_as_string( $self->fields );
2446}
24471400ns*stringify_header = \&header_as_string; ### backwards compatibility
24481300ns*stringify_header = \&header_as_string; ### ...twice to avoid warnings :)
2449
2450=back
2451
2452=cut
2453
2454
2455#==============================
2456#==============================
2457
2458=head2 Sending
2459
2460=over 4
2461
2462=cut
2463
2464
2465#------------------------------
2466
2467=item send
2468
2469=item send HOW, HOWARGS...
2470
2471I<Class/instance method.>
2472This is the principal method for sending mail, and for configuring
2473how mail will be sent.
2474
2475I<As a class method> with a HOW argument and optional HOWARGS, it sets
2476the default sending mechanism that the no-argument instance method
2477will use. The HOW is a facility name (B<see below>),
2478and the HOWARGS is interpreted by the facility.
2479The class method returns the previous HOW and HOWARGS as an array.
2480
2481 MIME::Lite->send('sendmail', "d:\\programs\\sendmail.exe");
2482 ...
2483 $msg = MIME::Lite->new(...);
2484 $msg->send;
2485
2486I<As an instance method with arguments>
2487(a HOW argument and optional HOWARGS), sends the message in the
2488requested manner; e.g.:
2489
2490 $msg->send('sendmail', "d:\\programs\\sendmail.exe");
2491
2492I<As an instance method with no arguments,> sends the
2493message by the default mechanism set up by the class method.
2494Returns whatever the mail-handling routine returns: this
2495should be true on success, false/exception on error:
2496
2497 $msg = MIME::Lite->new(From=>...);
2498 $msg->send || die "you DON'T have mail!";
2499
2500On Unix systems (or rather non-Win32 systems), the default
2501setting is equivalent to:
2502
2503 MIME::Lite->send("sendmail", "/usr/lib/sendmail -t -oi -oem");
2504
2505On Win32 systems the default setting is equivalent to:
2506
2507 MIME::Lite->send("smtp");
2508
2509The assumption is that on Win32 your site/lib/Net/libnet.cfg
2510file will be preconfigured to use the appropriate SMTP
2511server. See below for configuring for authentication.
2512
2513There are three facilities:
2514
2515=over 4
2516
2517=item "sendmail", ARGS...
2518
2519Send a message by piping it into the "sendmail" command.
2520Uses the L<send_by_sendmail()|/send_by_sendmail> method, giving it the ARGS.
2521This usage implements (and deprecates) the C<sendmail()> method.
2522
2523=item "smtp", [HOSTNAME, [NAMEDPARMS] ]
2524
2525Send a message by SMTP, using optional HOSTNAME as SMTP-sending host.
2526L<Net::SMTP> will be required. Uses the L<send_by_smtp()|/send_by_smtp>
2527method. Any additional arguments passed in will also be passed through to
2528send_by_smtp. This is useful for things like mail servers requiring
2529authentication where you can say something like the following
2530
2531 MIME::Lite->send('smtp', $host, AuthUser=>$user, AuthPass=>$pass);
2532
2533which will configure things so future uses of
2534
2535 $msg->send();
2536
2537do the right thing.
2538
2539=item "sub", \&SUBREF, ARGS...
2540
2541Sends a message MSG by invoking the subroutine SUBREF of your choosing,
2542with MSG as the first argument, and ARGS following.
2543
2544=back
2545
2546I<For example:> let's say you're on an OS which lacks the usual Unix
2547"sendmail" facility, but you've installed something a lot like it, and
2548you need to configure your Perl script to use this "sendmail.exe" program.
2549Do this following in your script's setup:
2550
2551 MIME::Lite->send('sendmail', "d:\\programs\\sendmail.exe");
2552
2553Then, whenever you need to send a message $msg, just say:
2554
2555 $msg->send;
2556
2557That's it. Now, if you ever move your script to a Unix box, all you
2558need to do is change that line in the setup and you're done.
2559All of your $msg-E<gt>send invocations will work as expected.
2560
2561After sending, the method last_send_successful() can be used to determine
2562if the send was successful or not.
2563
2564=cut
2565
2566
2567sub send {
2568 my $self = shift;
2569 my $meth = shift;
2570
2571 if ( ref($self) ) { ### instance method:
2572 my ( $method, @args );
2573 if (@_) { ### args; use them just this once
2574 $method = 'send_by_' . $meth;
2575 @args = @_;
2576 } else { ### no args; use defaults
2577 $method = "send_by_$Sender";
2578 @args = @{ $SenderArgs{$Sender} || [] };
2579 }
2580 $self->verify_data if $AUTO_VERIFY; ### prevents missing parts!
2581 Carp::croak "Unknown send method '$meth'" unless $self->can($method);
2582 return $self->$method(@args);
2583 } else { ### class method:
2584 if (@_) {
2585 my @old = ( $Sender, @{ $SenderArgs{$Sender} } );
2586 $Sender = $meth;
2587 $SenderArgs{$Sender} = [@_]; ### remaining args
2588 return @old;
2589 } else {
2590 Carp::croak "class method send must have HOW... arguments\n";
2591 }
2592 }
2593}
2594
2595
2596#------------------------------
2597
2598=item send_by_sendmail SENDMAILCMD
2599
2600=item send_by_sendmail PARAM=>VALUE, ARRAY, HASH...
2601
2602I<Instance method.>
2603Send message via an external "sendmail" program
2604(this will probably only work out-of-the-box on Unix systems).
2605
2606Returns true on success, false or exception on error.
2607
2608You can specify the program and all its arguments by giving a single
2609string, SENDMAILCMD. Nothing fancy is done; the message is simply
2610piped in.
2611
2612However, if your needs are a little more advanced, you can specify
2613zero or more of the following PARAM/VALUE pairs (or a reference to hash
2614or array of such arguments as well as any combination thereof); a
2615Unix-style, taint-safe "sendmail" command will be constructed for you:
2616
2617=over 4
2618
2619=item Sendmail
2620
2621Full path to the program to use.
2622Default is "/usr/lib/sendmail".
2623
2624=item BaseArgs
2625
2626Ref to the basic array of arguments we start with.
2627Default is C<["-t", "-oi", "-oem"]>.
2628
2629=item SetSender
2630
2631Unless this is I<explicitly> given as false, we attempt to automatically
2632set the C<-f> argument to the first address that can be extracted from
2633the "From:" field of the message (if there is one).
2634
2635I<What is the -f, and why do we use it?>
2636Suppose we did I<not> use C<-f>, and you gave an explicit "From:"
2637field in your message: in this case, the sendmail "envelope" would
2638indicate the I<real> user your process was running under, as a way
2639of preventing mail forgery. Using the C<-f> switch causes the sender
2640to be set in the envelope as well.
2641
2642I<So when would I NOT want to use it?>
2643If sendmail doesn't regard you as a "trusted" user, it will permit
2644the C<-f> but also add an "X-Authentication-Warning" header to the message
2645to indicate a forged envelope. To avoid this, you can either
2646(1) have SetSender be false, or
2647(2) make yourself a trusted user by adding a C<T> configuration
2648 command to your I<sendmail.cf> file
2649 (e.g.: C<Teryq> if the script is running as user "eryq").
2650
2651=item FromSender
2652
2653If defined, this is identical to setting SetSender to true,
2654except that instead of looking at the "From:" field we use
2655the address given by this option.
2656Thus:
2657
2658 FromSender => 'me@myhost.com'
2659
2660=back
2661
2662After sending, the method last_send_successful() can be used to determine
2663if the send was successful or not.
2664
2665=cut
2666
2667sub _unfold_stupid_params {
2668 my $self = shift;
2669
2670 my %p;
2671 STUPID_PARAM: for (my $i = 0; $i < @_; $i++) { ## no critic Loop
2672 my $item = $_[$i];
2673 if (not ref $item) {
2674 $p{ $item } = $_[ ++$i ];
2675 } elsif (UNIVERSAL::isa($item, 'HASH')) {
2676 $p{ $_ } = $item->{ $_ } for keys %$item;
2677 } elsif (UNIVERSAL::isa($item, 'ARRAY')) {
2678 for (my $j = 0; $j < @$item; $j += 2) {
2679 $p{ $item->[ $j ] } = $item->[ $j + 1 ];
2680 }
2681 }
2682 }
2683
2684 return %p;
2685}
2686
2687sub send_by_sendmail {
2688 my $self = shift;
2689 my $return;
2690 if ( @_ == 1 and !ref $_[0] ) {
2691 ### Use the given command...
2692 my $sendmailcmd = shift @_;
2693 Carp::croak "No sendmail command available" unless $sendmailcmd;
2694
2695 ### Do it:
2696 local *SENDMAIL;
2697 open SENDMAIL, "|$sendmailcmd" or Carp::croak "open |$sendmailcmd: $!\n";
2698 $self->print( \*SENDMAIL );
2699 close SENDMAIL;
2700 $return = ( ( $? >> 8 ) ? undef: 1 );
2701 } else { ### Build the command...
2702 my %p = $self->_unfold_stupid_params(@_);
2703
2704 $p{Sendmail} = $SENDMAIL unless defined $p{Sendmail};
2705
2706 ### Start with the command and basic args:
2707 my @cmd = ( $p{Sendmail}, @{ $p{BaseArgs} || [ '-t', '-oi', '-oem' ] } );
2708
2709 # SetSender default is true
2710 $p{SetSender} = 1 unless defined $p{SetSender};
2711
2712 ### See if we are forcibly setting the sender:
2713 $p{SetSender} ||= defined( $p{FromSender} );
2714
2715 ### Add the -f argument, unless we're explicitly told NOT to:
2716 if ( $p{SetSender} ) {
2717 my $from = $p{FromSender} || ( $self->get('From') )[0];
2718 if ($from) {
2719 my ($from_addr) = extract_full_addrs($from);
2720 push @cmd, "-f$from_addr" if $from_addr;
2721 }
2722 }
2723
2724 ### Open the command in a taint-safe fashion:
2725 my $pid = open SENDMAIL, "|-";
2726 defined($pid) or die "open of pipe failed: $!\n";
2727 if ( !$pid ) { ### child
2728 exec(@cmd) or die "can't exec $p{Sendmail}: $!\n";
2729 ### NOTREACHED
2730 } else { ### parent
2731 $self->print( \*SENDMAIL );
2732 close SENDMAIL || die "error closing $p{Sendmail}: $! (exit $?)\n";
2733 $return = 1;
2734 }
2735 }
2736 return $self->{last_send_successful} = $return;
2737}
2738
2739#------------------------------
2740
2741=item send_by_smtp HOST, ARGS...
2742
2743=item send_by_smtp REF, HOST, ARGS
2744
2745I<Instance method.>
2746Send message via SMTP, using Net::SMTP -- which will be required for this
2747feature.
2748
2749HOST is the name of SMTP server to connect to, or undef to have
2750L<Net::SMTP|Net::SMTP> use the defaults in Libnet.cfg.
2751
2752ARGS are a list of key value pairs which may be selected from the list
2753below. Many of these are just passed through to specific
2754L<Net::SMTP|Net::SMTP> commands and you should review that module for
2755details.
2756
2757Please see L<Good-vs-bad email addresses with send_by_smtp()|/Good-vs-bad email addresses with send_by_smtp()>
2758
2759=over 4
2760
2761=item Hello
2762
2763=item LocalAddr
2764
2765=item LocalPort
2766
2767=item Timeout
2768
2769=item Port
2770
2771=item ExactAddresses
2772
2773=item Debug
2774
2775See L<Net::SMTP::new()|Net::SMTP/"mail"> for details.
2776
2777=item Size
2778
2779=item Return
2780
2781=item Bits
2782
2783=item Transaction
2784
2785=item Envelope
2786
2787See L<Net::SMTP::mail()|Net::SMTP/mail> for details.
2788
2789=item SkipBad
2790
2791If true doesn't throw an error when multiple email addresses are provided
2792and some are not valid. See L<Net::SMTP::recipient()|Net::SMTP/recipient>
2793for details.
2794
2795=item AuthUser
2796
2797Authenticate with L<Net::SMTP::auth()|Net::SMTP/auth> using this username.
2798
2799=item AuthPass
2800
2801Authenticate with L<Net::SMTP::auth()|Net::SMTP/auth> using this password.
2802
2803=item NoAuth
2804
2805Normally if AuthUser and AuthPass are defined MIME::Lite will attempt to
2806use them with the L<Net::SMTP::auth()|Net::SMTP/auth> command to
2807authenticate the connection, however if this value is true then no
2808authentication occurs.
2809
2810=item To
2811
2812Sets the addresses to send to. Can be a string or a reference to an
2813array of strings. Normally this is extracted from the To: (and Cc: and
2814Bcc: fields if $AUTO_CC is true).
2815
2816This value overrides that.
2817
2818=item From
2819
2820Sets the email address to send from. Normally this value is extracted
2821from the Return-Path: or From: field of the mail itself (in that order).
2822
2823This value overrides that.
2824
2825=back
2826
2827I<Returns:>
2828True on success, croaks with an error message on failure.
2829
2830After sending, the method last_send_successful() can be used to determine
2831if the send was successful or not.
2832
2833=cut
2834
2835
2836# Derived from work by Andrew McRae. Version 0.2 anm 09Sep97
2837# Copyright 1997 Optimation New Zealand Ltd.
2838# May be modified/redistributed under the same terms as Perl.
2839
2840# external opts
284111µsmy @_mail_opts = qw( Size Return Bits Transaction Envelope );
28421400nsmy @_recip_opts = qw( SkipBad );
284311µsmy @_net_smtp_opts = qw( Hello LocalAddr LocalPort Timeout
2844 Port ExactAddresses Debug );
2845# internal: qw( NoAuth AuthUser AuthPass To From Host);
2846
2847sub __opts {
2848 my $args=shift;
2849 return map { exists $args->{$_} ? ( $_ => $args->{$_} ) : () } @_;
2850}
2851
2852sub send_by_smtp {
2853 require Net::SMTP;
2854 my ($self,$hostname,%args) = @_;
2855 # We may need the "From:" and "To:" headers to pass to the
2856 # SMTP mailer also.
2857 $self->{last_send_successful}=0;
2858
2859 my @hdr_to = extract_only_addrs( scalar $self->get('To') );
2860 if ($AUTO_CC) {
2861 foreach my $field (qw(Cc Bcc)) {
2862 push @hdr_to, extract_only_addrs($_) for $self->get($field);
2863 }
2864 }
2865 Carp::croak "send_by_smtp: nobody to send to for host '$hostname'?!\n"
2866 unless @hdr_to;
2867
2868 $args{To} ||= \@hdr_to;
2869 $args{From} ||= extract_only_addrs( scalar $self->get('Return-Path') );
2870 $args{From} ||= extract_only_addrs( scalar $self->get('From') ) ;
2871
2872 # Create SMTP client.
2873 # MIME::Lite::SMTP is just a wrapper giving a print method
2874 # to the SMTP object.
2875
2876 my %opts = __opts(\%args, @_net_smtp_opts);
2877 my $smtp = MIME::Lite::SMTP->new( $hostname, %opts )
2878 or Carp::croak "SMTP Failed to connect to mail server: $!\n";
2879
2880 # Possibly authenticate
2881 if ( defined $args{AuthUser} and defined $args{AuthPass}
2882 and !$args{NoAuth} )
2883 {
2884 if ($smtp->supports('AUTH',500,["Command unknown: 'AUTH'"])) {
2885 $smtp->auth( $args{AuthUser}, $args{AuthPass} )
2886 or die "SMTP auth() command failed: $!\n"
2887 . $smtp->message . "\n";
2888 } else {
2889 die "SMTP auth() command not supported on $hostname\n";
2890 }
2891 }
2892
2893 # Send the mail command
2894 %opts = __opts( \%args, @_mail_opts);
2895 $smtp->mail( $args{From}, %opts ? \%opts : () )
2896 or die "SMTP mail() command failed: $!\n"
2897 . $smtp->message . "\n";
2898
2899 # Send the recipients command
2900 %opts = __opts( \%args, @_recip_opts);
2901 $smtp->recipient( @{ $args{To} }, %opts ? \%opts : () )
2902 or die "SMTP recipient() command failed: $!\n"
2903 . $smtp->message . "\n";
2904
2905 # Send the data
2906 $smtp->data()
2907 or die "SMTP data() command failed: $!\n"
2908 . $smtp->message . "\n";
2909 $self->print_for_smtp($smtp);
2910
2911 # Finish the mail
2912 $smtp->dataend()
2913 or Carp::croak "Net::CMD (Net::SMTP) DATAEND command failed.\n"
2914 . "Last server message was:"
2915 . $smtp->message
2916 . "This probably represents a problem with newline encoding ";
2917
2918 # terminate the session
2919 $smtp->quit;
2920
2921 return $self->{last_send_successful} = 1;
2922}
2923
2924=item send_by_testfile FILENAME
2925
2926I<Instance method.>
2927Print message to a file (namely FILENAME), which will default to
2928mailer.testfile
2929If file exists, message will be appended.
2930
2931=cut
2932
2933sub send_by_testfile {
2934 my $self = shift;
2935
2936 ### Use the default filename...
2937 my $filename = 'mailer.testfile';
2938
2939 if ( @_ == 1 and !ref $_[0] ) {
2940 ### Use the given filename if given...
2941 $filename = shift @_;
2942 Carp::croak "no filename given to send_by_testfile" unless $filename;
2943 }
2944
2945 ### Do it:
2946 local *FILE;
2947 open FILE, ">> $filename" or Carp::croak "open $filename: $!\n";
2948 $self->print( \*FILE );
2949 close FILE;
2950 my $return = ( ( $? >> 8 ) ? undef: 1 );
2951
2952 return $self->{last_send_successful} = $return;
2953}
2954
2955=item last_send_successful
2956
2957This method will return TRUE if the last send() or send_by_XXX() method call was
2958successful. It will return defined but false if it was not successful, and undefined
2959if the object had not been used to send yet.
2960
2961=cut
2962
2963
2964sub last_send_successful {
2965 my $self = shift;
2966 return $self->{last_send_successful};
2967}
2968
2969
2970### Provided by Andrew McRae. Version 0.2 anm 09Sep97
2971### Copyright 1997 Optimation New Zealand Ltd.
2972### May be modified/redistributed under the same terms as Perl.
2973### Aditional changes by Yves.
2974### Until 3.01_03 this was send_by_smtp()
2975sub send_by_smtp_simple {
2976 my ( $self, @args ) = @_;
2977 $self->{last_send_successful} = 0;
2978 ### We need the "From:" and "To:" headers to pass to the SMTP mailer:
2979 my $hdr = $self->fields();
2980
2981 my $from_header = $self->get('From');
2982 my ($from) = extract_only_addrs($from_header);
2983
2984 warn "M::L>>> $from_header => $from" if $MIME::Lite::DEBUG;
2985
2986
2987 my $to = $self->get('To');
2988
2989 ### Sanity check:
2990 defined($to)
2991 or Carp::croak "send_by_smtp: missing 'To:' address\n";
2992
2993 ### Get the destinations as a simple array of addresses:
2994 my @to_all = extract_only_addrs($to);
2995 if ($AUTO_CC) {
2996 foreach my $field (qw(Cc Bcc)) {
2997 my $value = $self->get($field);
2998 push @to_all, extract_only_addrs($value)
2999 if defined($value);
3000 }
3001 }
3002
3003 ### Create SMTP client:
3004 require Net::SMTP;
3005 my $smtp = MIME::Lite::SMTP->new(@args)
3006 or Carp::croak("Failed to connect to mail server: $!\n");
3007 $smtp->mail($from)
3008 or Carp::croak( "SMTP MAIL command failed: $!\n" . $smtp->message . "\n" );
3009 $smtp->to(@to_all)
3010 or Carp::croak( "SMTP RCPT command failed: $!\n" . $smtp->message . "\n" );
3011 $smtp->data()
3012 or Carp::croak( "SMTP DATA command failed: $!\n" . $smtp->message . "\n" );
3013
3014 ### MIME::Lite can print() to anything with a print() method:
3015 $self->print_for_smtp($smtp);
3016
3017 $smtp->dataend()
3018 or Carp::croak( "Net::CMD (Net::SMTP) DATAEND command failed.\n"
3019 . "Last server message was:"
3020 . $smtp->message
3021 . "This probably represents a problem with newline encoding " );
3022 $smtp->quit;
3023 $self->{last_send_successful} = 1;
3024 1;
3025}
3026
3027#------------------------------
3028#
3029# send_by_sub [\&SUBREF, [ARGS...]]
3030#
3031# I<Instance method, private.>
3032# Send the message via an anonymous subroutine.
3033#
3034sub send_by_sub {
3035 my ( $self, $subref, @args ) = @_;
3036 $self->{last_send_successful} = &$subref( $self, @args );
3037
3038}
3039
3040#------------------------------
3041
3042=item sendmail COMMAND...
3043
3044I<Class method, DEPRECATED.>
3045Declare the sender to be "sendmail", and set up the "sendmail" command.
3046I<You should use send() instead.>
3047
3048=cut
3049
3050
3051sub sendmail {
3052 my $self = shift;
3053 $self->send( 'sendmail', join( ' ', @_ ) );
3054}
3055
3056=back
3057
3058=cut
3059
3060
3061#==============================
3062#==============================
3063
3064=head2 Miscellaneous
3065
3066=over 4
3067
3068=cut
3069
3070
3071#------------------------------
3072
3073=item quiet ONOFF
3074
3075I<Class method.>
3076Suppress/unsuppress all warnings coming from this module.
3077
3078 MIME::Lite->quiet(1); ### I know what I'm doing
3079
3080I recommend that you include that comment as well. And while
3081you type it, say it out loud: if it doesn't feel right, then maybe
3082you should reconsider the whole line. C<;-)>
3083
3084=cut
3085
3086
3087sub quiet {
3088 my $class = shift;
3089 $QUIET = shift if @_;
3090 $QUIET;
3091}
3092
3093=back
3094
3095=cut
3096
3097
3098#============================================================
3099
3100package MIME::Lite::SMTP;
3101
3102#============================================================
3103# This class just adds a print() method to Net::SMTP.
3104# Notice that we don't use/require it until it's needed!
3105
3106225µs234µs
# spent 22µs (9+13) within MIME::Lite::SMTP::BEGIN@3106 which was called: # once (9µs+13µs) by C4::Letters::BEGIN@23 at line 3106
use strict;
# spent 22µs making 1 call to MIME::Lite::SMTP::BEGIN@3106 # spent 13µs making 1 call to strict::import
31072232µs254µs
# spent 30µs (7+23) within MIME::Lite::SMTP::BEGIN@3107 which was called: # once (7µs+23µs) by C4::Letters::BEGIN@23 at line 3107
use vars qw( @ISA );
# spent 30µs making 1 call to MIME::Lite::SMTP::BEGIN@3107 # spent 23µs making 1 call to vars::import
310816µs@ISA = qw(Net::SMTP);
3109
3110# some of the below is borrowed from Data::Dumper
311114µsmy %esc = ( "\a" => "\\a",
3112 "\b" => "\\b",
3113 "\t" => "\\t",
3114 "\n" => "\\n",
3115 "\f" => "\\f",
3116 "\r" => "\\r",
3117 "\e" => "\\e",
3118);
3119
3120sub _hexify {
3121 local $_ = shift;
3122 my @split = m/(.{1,16})/gs;
3123 foreach my $split (@split) {
3124 ( my $txt = $split ) =~ s/([\a\b\t\n\f\r\e])/$esc{$1}/sg;
3125 $split =~ s/(.)/sprintf("%02X ",ord($1))/sge;
3126 print STDERR "M::L >>> $split : $txt\n";
3127 }
3128}
3129
3130sub print {
3131 my $smtp = shift;
3132 $MIME::Lite::DEBUG and _hexify( join( "", @_ ) );
3133 $smtp->datasend(@_)
3134 or Carp::croak( "Net::CMD (Net::SMTP) DATASEND command failed.\n"
3135 . "Last server message was:"
3136 . $smtp->message
3137 . "This probably represents a problem with newline encoding " );
3138}
3139
3140
3141#============================================================
3142
3143package MIME::Lite::IO_Handle;
3144
3145#============================================================
3146
3147### Wrap a non-object filehandle inside a blessed, printable interface:
3148### Does nothing if the given $fh is already a blessed object.
3149sub wrap {
3150 my ( $class, $fh ) = @_;
31512171µs226µs
# spent 17µs (8+9) within MIME::Lite::IO_Handle::BEGIN@3151 which was called: # once (8µs+9µs) by C4::Letters::BEGIN@23 at line 3151
no strict 'refs';
# spent 17µs making 1 call to MIME::Lite::IO_Handle::BEGIN@3151 # spent 9µs making 1 call to strict::unimport
3152
3153 ### Get default, if necessary:
3154 $fh or $fh = select; ### no filehandle means selected one
3155 ref($fh) or $fh = \*$fh; ### scalar becomes a globref
3156
3157 ### Stop right away if already a printable object:
3158 return $fh if ( ref($fh) and ( ref($fh) ne 'GLOB' ) );
3159
3160 ### Get and return a printable interface:
3161 bless \$fh, $class; ### wrap it in a printable interface
3162}
3163
3164### Print:
3165sub print {
3166 my $self = shift;
3167 print {$$self} @_;
3168}
3169
3170
3171#============================================================
3172
3173package MIME::Lite::IO_Scalar;
3174
3175#============================================================
3176
3177### Wrap a scalar inside a blessed, printable interface:
3178sub wrap {
3179 my ( $class, $scalarref ) = @_;
3180 defined($scalarref) or $scalarref = \"";
3181 bless $scalarref, $class;
3182}
3183
3184### Print:
3185sub print {
3186 ${$_[0]} .= join( '', @_[1..$#_] );
3187 1;
3188}
3189
3190
3191#============================================================
3192
3193package MIME::Lite::IO_ScalarArray;
3194
3195#============================================================
3196
3197### Wrap an array inside a blessed, printable interface:
3198sub wrap {
3199 my ( $class, $arrayref ) = @_;
3200 defined($arrayref) or $arrayref = [];
3201 bless $arrayref, $class;
3202}
3203
3204### Print:
3205sub print {
3206 my $self = shift;
3207 push @$self, @_;
3208 1;
3209}
3210
3211125µs1;
3212__END__
 
# spent 15µs within MIME::Lite::CORE:fteexec which was called 4 times, avg 4µs/call: # once (10µs+0s) by C4::Letters::BEGIN@23 at line 394 # once (2µs+0s) by C4::Letters::BEGIN@23 at line 395 # once (2µs+0s) by C4::Letters::BEGIN@23 at line 396 # once (1µs+0s) by C4::Letters::BEGIN@23 at line 405
sub MIME::Lite::CORE:fteexec; # opcode
# spent 4µs within MIME::Lite::CORE:match which was called: # once (4µs+0s) by C4::Letters::BEGIN@23 at line 388
sub MIME::Lite::CORE:match; # opcode
Report produced by the NYTProf 5.06 Perl profiler, developed by Tim Bunce and Adam Kaplan.