← Index
Performance Profile   « block view • line view • sub view »
For opac/opac-main.pl
  Run on Mon Aug 24 11:28:47 2009
Reported on Mon Aug 24 11:29:07 2009

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