File Coverage

lib/MIME/Lite.pm
Criterion Covered Total %
statement 367 662 55.4
branch 136 368 36.9
condition 38 107 35.5
subroutine 47 76 61.8
pod 37 54 68.5
total 625 1267 49.3


line stmt bran cond sub pod time code
1             package MIME::Lite;
2 8     8   13838 use 5.006; ### for /c modifier in m/\G.../gc modifier
  8         59  
3 8     8   33 use strict;
  8         28  
  8         252  
4 8     8   42 use warnings;
  8         14  
  8         755  
5              
6             =head1 NAME
7              
8             MIME::Lite - low-calorie MIME generator
9              
10             =head1 WAIT!
11              
12             MIME::Lite is not recommended by its current maintainer. There are a number of
13             alternatives, like Email::MIME or MIME::Entity and Email::Sender, which you
14             should probably use instead. MIME::Lite continues to accrue weird bug reports,
15             and it is not receiving a large amount of refactoring due to the availability
16             of better alternatives. Please consider using something else.
17              
18             =head1 SYNOPSIS
19              
20             Create and send using the default send method for your OS a single-part message:
21              
22             use MIME::Lite;
23             ### Create a new single-part message, to send a GIF file:
24             $msg = MIME::Lite->new(
25             From => 'me@myhost.com',
26             To => 'you@yourhost.com',
27             Cc => 'some@other.com, some@more.com',
28             Subject => 'Helloooooo, nurse!',
29             Type => 'image/gif',
30             Encoding => 'base64',
31             Path => 'hellonurse.gif'
32             );
33             $msg->send; # send via default
34              
35             Create a multipart message (i.e., one with attachments) and send it via SMTP
36              
37             ### Create a new multipart message:
38             $msg = MIME::Lite->new(
39             From => 'me@myhost.com',
40             To => 'you@yourhost.com',
41             Cc => 'some@other.com, some@more.com',
42             Subject => 'A message with 2 parts...',
43             Type => 'multipart/mixed'
44             );
45              
46             ### Add parts (each "attach" has same arguments as "new"):
47             $msg->attach(
48             Type => 'TEXT',
49             Data => "Here's the GIF file you wanted"
50             );
51             $msg->attach(
52             Type => 'image/gif',
53             Path => 'aaa000123.gif',
54             Filename => 'logo.gif',
55             Disposition => 'attachment'
56             );
57             ### use Net::SMTP to do the sending
58             $msg->send('smtp','some.host', Debug=>1 );
59              
60             Output a message:
61              
62             ### Format as a string:
63             $str = $msg->as_string;
64              
65             ### Print to a filehandle (say, a "sendmail" stream):
66             $msg->print(\*SENDMAIL);
67              
68             Send a message:
69              
70             ### Send in the "best" way (the default is to use "sendmail"):
71             $msg->send;
72             ### Send a specific way:
73             $msg->send('type',@args);
74              
75             Specify default send method:
76              
77             MIME::Lite->send('smtp','some.host',Debug=>0);
78              
79             with authentication
80              
81             MIME::Lite->send('smtp','some.host', AuthUser=>$user, AuthPass=>$pass);
82              
83             using SSL
84              
85             MIME::Lite->send('smtp','some.host', SSL => 1, Port => 465 );
86              
87             =head1 DESCRIPTION
88              
89             In the never-ending quest for great taste with fewer calories,
90             we proudly present: I.
91              
92             MIME::Lite is intended as a simple, standalone module for generating
93             (not parsing!) MIME messages... specifically, it allows you to
94             output a simple, decent single- or multi-part message with text or binary
95             attachments. It does not require that you have the Mail:: or MIME::
96             modules installed, but will work with them if they are.
97              
98             You can specify each message part as either the literal data itself (in
99             a scalar or array), or as a string which can be given to open() to get
100             a readable filehandle (e.g., "
101              
102             You don't need to worry about encoding your message data:
103             this module will do that for you. It handles the 5 standard MIME encodings.
104              
105             =head1 EXAMPLES
106              
107             =head2 Create a simple message containing just text
108              
109             $msg = MIME::Lite->new(
110             From =>'me@myhost.com',
111             To =>'you@yourhost.com',
112             Cc =>'some@other.com, some@more.com',
113             Subject =>'Helloooooo, nurse!',
114             Data =>"How's it goin', eh?"
115             );
116              
117             =head2 Create a simple message containing just an image
118              
119             $msg = MIME::Lite->new(
120             From =>'me@myhost.com',
121             To =>'you@yourhost.com',
122             Cc =>'some@other.com, some@more.com',
123             Subject =>'Helloooooo, nurse!',
124             Type =>'image/gif',
125             Encoding =>'base64',
126             Path =>'hellonurse.gif'
127             );
128              
129              
130             =head2 Create a multipart message
131              
132             ### Create the multipart "container":
133             $msg = MIME::Lite->new(
134             From =>'me@myhost.com',
135             To =>'you@yourhost.com',
136             Cc =>'some@other.com, some@more.com',
137             Subject =>'A message with 2 parts...',
138             Type =>'multipart/mixed'
139             );
140              
141             ### Add the text message part:
142             ### (Note that "attach" has same arguments as "new"):
143             $msg->attach(
144             Type =>'TEXT',
145             Data =>"Here's the GIF file you wanted"
146             );
147              
148             ### Add the image part:
149             $msg->attach(
150             Type =>'image/gif',
151             Path =>'aaa000123.gif',
152             Filename =>'logo.gif',
153             Disposition => 'attachment'
154             );
155              
156              
157             =head2 Attach a GIF to a text message
158              
159             This will create a multipart message exactly as above, but using the
160             "attach to singlepart" hack:
161              
162             ### Start with a simple text message:
163             $msg = MIME::Lite->new(
164             From =>'me@myhost.com',
165             To =>'you@yourhost.com',
166             Cc =>'some@other.com, some@more.com',
167             Subject =>'A message with 2 parts...',
168             Type =>'TEXT',
169             Data =>"Here's the GIF file you wanted"
170             );
171              
172             ### Attach a part... the make the message a multipart automatically:
173             $msg->attach(
174             Type =>'image/gif',
175             Path =>'aaa000123.gif',
176             Filename =>'logo.gif'
177             );
178              
179              
180             =head2 Attach a pre-prepared part to a message
181              
182             ### Create a standalone part:
183             $part = MIME::Lite->new(
184             Top => 0,
185             Type =>'text/html',
186             Data =>'

Hello

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