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