1# Mail::Sender.pm version 0.8.22 2# 3# Copyright (c) 2001 Jan Krynicky <Jenda@Krynicky.cz>. All rights reserved. 4# This program is free software; you can redistribute it and/or 5# modify it under the same terms as Perl itself. 6 7package Mail::Sender; local $^W; 8require 'Exporter.pm'; 9use vars qw(@ISA @EXPORT @EXPORT_OK); 10@ISA = (Exporter); 11@EXPORT = qw(); 12@EXPORT_OK = qw(@error_str GuessCType); 13 14$Mail::Sender::VERSION = '0.8.22'; 15$Mail::Sender::ver=$Mail::Sender::VERSION; 16 17use 5.008; 18 19use strict; 20use warnings; 21no warnings 'uninitialized'; 22use Carp; 23use FileHandle; 24use IO::Socket::INET; 25use File::Basename; 26 27use Encode qw(encode decode); 28use MIME::Base64; 29use MIME::QuotedPrint; 30 # if you do not use MailFile or SendFile and only send 7BIT or 8BIT "encoded" 31 # messages you may comment out these lines. 32 #MIME::Base64 and MIME::QuotedPrint may be found at CPAN. 33 34my $TLS_notsupported; 35BEGIN { 36 eval <<'*END*' 37 use IO::Socket::SSL;# qw(debug4); 38 use Net::SSLeay; 39 1; 40*END* 41 or $TLS_notsupported = $@; 42} 43 44# include config file and libraries when packaging the script 45if (0) { 46 require 'Mail/Sender.config'; # local configuration 47 require 'Symbol.pm'; # for debuging and GetHandle() method 48 require 'Tie/Handle.pm'; # for debuging and GetHandle() method 49 require 'IO/Handle.pm'; # for debuging and GetHandle() method 50 require 'Digest/HMAC_MD5.pm'; # for CRAM-MD5 authentication only 51 require 'Authen/NTLM.pm'; # for NTLM authentication only 52} # this block above is there to let PAR, PerlApp, PerlCtrl, PerlSvc and Perl2Exe know I may need those files. 53 54BEGIN { 55 my $config = $INC{'Mail/Sender.pm'}; 56 die "Wrong case in use statement or Mail::Sender module renamed. Perl is case sensitive!!!\n" unless $config; 57 my $compiled = !(-e $config); # if the module was not read from disk => the script has been "compiled" 58 $config =~ s/\.pm$/.config/; 59 if ($compiled or -e $config) { 60 # in a Perl2Exe or PerlApp created executable or PerlCtrl generated COM object 61 # or the config is known to exist 62 eval {require $config}; 63 if ($@ and $@ !~ /Can't locate /) { 64 print STDERR "Error in Mail::Sender.config : $@" ; 65 } 66 } 67} 68 69#local IP address and name 70my $local_name = $ENV{HOSTNAME} || $ENV{HTTP_HOST} || (gethostbyname 'localhost')[0]; 71$local_name =~ s/:.*$//; # the HTTP_HOST may be set to something like "foo.bar.com:1000" 72my $local_IP = join('.',unpack('CCCC',(gethostbyname $local_name)[4])); 73 74#time diference to GMT - Windows will not set $ENV{'TZ'}, if you know a better way ... 75my $GMTdiff; 76 77use Time::Local; 78sub ResetGMTdiff { 79 my $local = time; 80 my $gm = timelocal( gmtime $local ); 81 my $sign = qw( + + - )[ $local <=> $gm ]; 82 $GMTdiff = sprintf "%s%02d%02d", $sign, (gmtime abs( $local - $gm ))[2,1]; 83} 84ResetGMTdiff(); 85 86# 87my @priority = ('','1 (Highest)','2 (High)', '3 (Normal)','4 (Low)','5 (Lowest)'); 88 89#data encoding 90my $chunksize=1024*4; 91my $chunksize64=71*57; # must be divisible by 57 ! 92 93sub enc_base64 { 94 if ($_[0]) { 95 my $charset = $_[0]; 96 sub {my $s = encode_base64(encode( $charset, $_[0])); $s =~ s/\x0A/\x0D\x0A/sg; return $s;} 97 } else { 98 sub {my $s = encode_base64($_[0]); $s =~ s/\x0A/\x0D\x0A/sg; return $s;} 99 } 100} 101my $enc_base64_chunk = 57; 102 103sub enc_qp { 104 if ($_[0]) { 105 my $charset = $_[0]; 106 sub {my $s = encode( $charset, $_[0]);$s =~ s/\x0D\x0A/\n/g;$s = encode_qp($s); $s=~s/^\./../gm; $s =~ s/\x0A/\x0D\x0A/sg; return $s} 107 } else { 108 sub {my $s = $_[0];$s =~ s/\x0D\x0A/\n/g;$s = encode_qp($s); $s=~s/^\./../gm; $s =~ s/\x0A/\x0D\x0A/sg; return $s} 109 } 110} 111 112sub enc_plain { 113 if ($_[0]) { 114 my $charset = $_[0]; 115 sub {my $s = encode( $charset, $_[0]); $s=~s/^\./../gm; $s =~ s/(?:\x0D\x0A?|\x0A)/\x0D\x0A/sg; return $s} 116 } else { 117 sub {my $s = $_[0]; $s=~s/^\./../gm; $s =~ s/(?:\x0D\x0A?|\x0A)/\x0D\x0A/sg; return $s} 118 } 119} 120 121sub enc_xtext { 122 my $input = shift; 123 $input =~ s/([^!-*,-<>-~])/'+'.uc(unpack('H*', $1))/eg; 124 return $input; 125} 126 127{ my $username; 128sub getusername () { 129 return $username if defined($username); 130 return $username=eval{getlogin || getpwuid($<)} || $ENV{USERNAME}; 131} 132} 133 134#IO 135use vars qw($debug); 136$debug = 0; 137 138#reads the whole SMTP response 139# converts 140# nnn-very 141# nnn-long 142# nnn message 143# to 144# nnn very 145# long 146# message 147sub get_response ($) { 148 my $s = shift; 149 my $res = <$s>; 150 if ($res =~ s/^(\d\d\d)-/$1 /) { 151 my $nextline = <$s>; 152 while ($nextline =~ s/^\d\d\d-//) { 153 $res .= $nextline; 154 $nextline = <$s>; 155 } 156 $nextline =~ s/^\d\d\d //; 157 $res .= $nextline; 158 } 159 $Mail::Sender::LastResponse = $res; 160 return $res; 161} 162 163sub send_cmd ($$) { 164 my ($s, $cmd) = @_; 165 chomp $cmd; 166 if ($s->opened()) { 167 print $s "$cmd\x0D\x0A"; 168 get_response($s); 169 } else { 170 return '400 connection lost'; 171 } 172} 173 174sub print_hdr { 175 my ($s, $hdr, $str, $charset) = @_; 176 return if !defined $str or $str eq ''; 177 $str =~ s/[\x0D\x0A\s]+$//; 178 179 if ($charset && $str =~ /[^[:ascii:]]/) { 180 $str = encode( $charset, $str); 181 my @parts = split /(\s*[,;<>]\s*)/, $str; 182 for (@parts) { 183 next unless /[^[:ascii:]]/; 184 $_ = encode_qp($_); 185 s/=\r?\n$//; 186 s/(\s)/'=' . sprintf '%x',ord($1)/ge; 187 $_ = "=?$charset?Q?" . $_ . "?="; 188 } 189 $str = join '', @parts; 190 } 191 192 $str =~ s/(?:\x0D\x0A?|\x0A)/\x0D\x0A/sg; # \n or \r => \r\n 193 $str =~ s/\x0D\x0A([^\t])/\x0D\x0A\t$1/sg; 194 if (length($str)+length($hdr) > 997) { # header too long, max 1000 chars 195 $str =~ s/(.{1,980}[;,])\s+(\S)/$1\x0D\x0A\t$2/g; 196 } 197 print $s "$hdr: $str\x0D\x0A"; 198} 199 200 201sub say_helo { 202 my ($self, $s) = @_; 203 my $res = send_cmd $s, "EHLO $self->{'client'}"; 204 if ($res !~ /^[123]/) { 205 $res = send_cmd $s, "HELO $self->{'client'}"; 206 if ($res !~ /^[123]/) { return $self->Error(COMMERROR($_));} 207 return; 208 } 209 210 $res =~ s/^.*\n//; 211 $self->{'supports'} = {map {split /(?:\s+|=)/, $_, 2} split /\n/, $res}; 212 213 if (exists $self->{'supports'}{AUTH}) { 214 my @auth = split /\s+/, uc($self->{'supports'}{AUTH}); 215 $self->{'auth_protocols'} = {map {$_, 1} @auth}; 216 # create a hash with accepted authentication protocols 217 } 218 219 $self->{esmtp}{_MAIL_FROM} = ''; 220 $self->{esmtp}{_RCPT_TO} = ''; 221 if (exists $self->{'supports'}{DSN} and exists $self->{esmtp}) { 222 for (qw(RET ENVID)) { 223 $self->{esmtp}{_MAIL_FROM} .= " $_=$self->{esmtp}{$_}" 224 if $self->{esmtp}{$_} ne ''; 225 } 226 for (qw(NOTIFY ORCPT)) { 227 $self->{esmtp}{_RCPT_TO} .= " $_=$self->{esmtp}{$_}" 228 if $self->{esmtp}{$_} ne ''; 229 } 230 } 231 return; 232} 233 234sub login { 235 my $self = shift(); 236 my $auth = uc( $self->{'auth'}) || 'LOGIN'; 237 if (! $self->{'auth_protocols'}->{$auth}) { 238 return $self->Error(INVALIDAUTH($auth)); 239 } 240 241 $self->{'authid'} = $self->{'username'} 242 if (exists $self->{'username'} and !exists $self->{'authid'}); 243 244 $self->{'authpwd'} = $self->{'password'} 245 if (exists $self->{'password'} and !exists $self->{'authpwd'}); 246 247 $auth =~ tr/a-zA-Z0-9_/_/c; # change all characters except letters, numbers and underscores to underscores 248 no strict qw'subs refs'; 249 &{"Mail::Sender::Auth::".$auth}($self); 250} 251 252# authentication code stolen from http://support.zeitform.de/techinfo/e-mail_prot.html 253sub Mail::Sender::Auth::LOGIN { 254 my $self = shift(); 255 my $s = $self->{'socket'}; 256 257 $_ = send_cmd $s, 'AUTH LOGIN'; 258 if (!/^[123]/) { return $self->Error(INVALIDAUTH('LOGIN', $_)); } 259 260 if ($self->{auth_encoded}) { 261 # I assume the username and password had been base64 encoded already! 262 $_ = send_cmd $s, $self->{'authid'}; 263 if (!/^[123]/) { return $self->Error(LOGINERROR($_)); } 264 265 $_ = send_cmd $s, $self->{'authpwd'}; 266 if (!/^[123]/) { return $self->Error(LOGINERROR($_)); } 267 } else { 268 $_ = send_cmd $s, &encode_base64($self->{'authid'}); 269 if (!/^[123]/) { return $self->Error(LOGINERROR($_)); } 270 271 $_ = send_cmd $s, &encode_base64($self->{'authpwd'}); 272 if (!/^[123]/) { return $self->Error(LOGINERROR($_)); } 273 } 274 return; 275} 276 277use vars qw($MD5_loaded); 278$MD5_loaded = 0; 279sub Mail::Sender::Auth::CRAM_MD5 { 280 my $self = shift(); 281 my $s = $self->{'socket'}; 282 283 $_ = send_cmd $s, "AUTH CRAM-MD5"; 284 if (!/^[123]/) { return $self->Error(INVALIDAUTH('CRAM-MD5', $_)); } 285 my $stamp = $1 if /^\d{3}\s+(.*)$/; 286 287 unless ($MD5_loaded) { 288 eval 'use Digest::HMAC_MD5 qw(hmac_md5_hex)'; 289 die "$@\n" if $@; 290 $MD5_loaded = 1; 291 } 292 293 my $user = $self->{'authid'}; 294 my $secret = $self->{'authpwd'}; 295 296 my $decoded_stamp = decode_base64($stamp); 297 my $hmac = hmac_md5_hex($decoded_stamp, $secret); 298 my $answer = encode_base64($user . ' ' . $hmac); 299 $_ = send_cmd $s, $answer; 300 if (!/^[123]/) { return $self->Error(LOGINERROR($_)); } 301 return; 302} 303 304sub Mail::Sender::Auth::PLAIN { 305 my $self = shift(); 306 my $s = $self->{'socket'}; 307 308 $_ = send_cmd $s, "AUTH PLAIN"; 309 if (!/^[123]/) { return $self->Error(INVALIDAUTH('PLAIN', $_)); } 310 311 $_ = send_cmd $s, encode_base64("\000" . $self->{'authid'} . "\000" . $self->{'authpwd'}); 312 if (!/^[123]/) { return $self->Error(LOGINERROR($_)); } 313 return; 314} 315 316{ 317my $NTLM_loaded=0; 318sub Mail::Sender::Auth::NTLM { 319 unless ($NTLM_loaded) { 320 eval "use Authen::NTLM qw();"; 321 die "$@\n" if $@; 322 $NTLM_loaded = 1; 323 } 324 my $self = shift(); 325 my $s = $self->{'socket'}; 326 327 $_ = send_cmd $s, "AUTH NTLM"; 328 if (!/^[123]/) { return $self->Error(INVALIDAUTH('NTLM', $_)); } 329 330 Authen::NTLM::ntlm_user($self->{'authid'}); 331 Authen::NTLM::ntlm_password($self->{'authpwd'}); 332 Authen::NTLM::ntlm_domain($self->{'authdomain'}) 333 if defined $self->{'authdomain'}; 334 335 $_ = send_cmd $s, Authen::NTLM::ntlm(); 336 if (!/^3\d\d (.*)$/s) { return $self->Error(LOGINERROR($_)); } 337 my $response = $1; 338 $_ = send_cmd $s, Authen::NTLM::ntlm($response); 339 if (!/^[123]/) { return $self->Error(LOGINERROR($_)); } 340 return; 341}} 342 343sub Mail::Sender::Auth::AUTOLOAD { 344 (my $auth = $Mail::Sender::Auth::AUTOLOAD) =~ s/.*:://; 345 my $self = shift(); 346 my $s = $self->{'socket'}; 347 send_cmd $s, "QUIT"; 348 close $s; 349 delete $self->{'socket'}; 350 return $self->Error( UNKNOWNAUTH($auth)); 351} 352 353my $debug_code; 354sub __Debug { 355 my ($socket, $file) = @_; 356 if (defined $file) { 357 unless (@Mail::Sender::DBIO::ISA) { 358 eval "use Symbol;"; 359 eval $debug_code; 360 die $@ if $@; 361 } 362 my $handle = gensym(); 363 *$handle = \$socket; 364 if (! ref $file) { 365 my $DEBUG = new FileHandle; 366 open $DEBUG, "> $file" or die "Cannot open the debug file '$file': $^E\n"; 367 binmode $DEBUG; 368 $DEBUG->autoflush(); 369 tie *$handle, 'Mail::Sender::DBIO', $socket, $DEBUG, 1; 370 } else { 371 my $DEBUG = $file; 372 tie *$handle, 'Mail::Sender::DBIO', $socket, $DEBUG, 0; 373 } 374 bless $handle, 'Mail::Sender::DBIO'; 375 return $handle; 376 } else { 377 return $socket; 378 } 379} 380 381#internale 382 383sub HOSTNOTFOUND { 384 $!=2; 385 $Mail::Sender::Error="The SMTP server $_[0] was not found"; 386 return -1, $Mail::Sender::Error; 387} 388 389sub SOCKFAILED { 390 $Mail::Sender::Error='socket() failed: $^E'; 391 $!=5; 392 return -2, $Mail::Sender::Error; 393} 394 395sub CONNFAILED { 396 $Mail::Sender::Error="connect() failed: $^E"; 397 $!=5; 398 return -3, $Mail::Sender::Error; 399} 400 401sub SERVNOTAVAIL { 402 $!=40; 403 $Mail::Sender::Error="Service not available. " . ($_[0] ? "Reply: $_[0]" : "Server closed the connection unexpectedly"); 404 return -4, $Mail::Sender::Error; 405} 406 407sub COMMERROR { 408 $!=5; 409 if ($_[0] eq '') { 410 $Mail::Sender::Error="No response from server"; 411 } else { 412 $Mail::Sender::Error="Server error: $_[0]"; 413 } 414 return -5, $Mail::Sender::Error; 415} 416 417sub USERUNKNOWN { 418 $!=2; 419 if ($_[2] and $_[2] !~ /Local user/i) { 420 my $err= $_[2]; 421 $err =~ s/^\d+\s*//; 422 $err =~ s/\s*$//s; 423 $err ||= "Error"; 424 $Mail::Sender::Error="$err for \"$_[0]\" on host \"$_[1]\""; 425 } else { 426 $Mail::Sender::Error="Local user \"$_[0]\" unknown on host \"$_[1]\""; 427 } 428 return -6, $Mail::Sender::Error; 429} 430 431sub TRANSFAILED { 432 $!=5; 433 $Mail::Sender::Error="Transmission of message failed ($_[0])"; 434 return -7, $Mail::Sender::Error; 435} 436 437sub TOEMPTY { 438 $!=14; 439 $Mail::Sender::Error="Argument \$to empty"; 440 return -8, $Mail::Sender::Error; 441} 442 443sub NOMSG { 444 $!=22; 445 $Mail::Sender::Error="No message specified"; 446 return -9, $Mail::Sender::Error; 447} 448 449sub NOFILE { 450 $!=22; 451 $Mail::Sender::Error="No file name specified"; 452 return -10, $Mail::Sender::Error; 453} 454 455sub FILENOTFOUND { 456 $!=2; 457 $Mail::Sender::Error="File \"$_[0]\" not found"; 458 return -11, $Mail::Sender::Error; 459} 460 461sub NOTMULTIPART { 462 $!=40; 463 $Mail::Sender::Error="$_[0] not available in singlepart mode"; 464 return -12, $Mail::Sender::Error; 465} 466 467sub SITEERROR { 468 $!=15; 469 $Mail::Sender::Error="Site specific error"; 470 return -13, $Mail::Sender::Error; 471} 472 473sub NOTCONNECTED { 474 $!=1; 475 $Mail::Sender::Error="Connection not established"; 476 return -14, $Mail::Sender::Error; 477} 478 479sub NOSERVER { 480 $!=22; 481 $Mail::Sender::Error="No SMTP server specified"; 482 return -15, $Mail::Sender::Error; 483} 484 485sub NOFROMSPECIFIED { 486 $!=22; 487 $Mail::Sender::Error="No From: address specified"; 488 return -16, $Mail::Sender::Error; 489} 490 491sub INVALIDAUTH { 492 $!=22; 493 $Mail::Sender::Error="Authentication protocol $_[0] is not accepted by the server"; 494 $Mail::Sender::Error.=",\nresponse: $_[1]" if defined $_[1]; 495 return -17, $Mail::Sender::Error; 496} 497 498sub LOGINERROR { 499 $!=22; 500 $Mail::Sender::Error="Login not accepted"; 501 return -18, $Mail::Sender::Error; 502} 503 504sub UNKNOWNAUTH { 505 $!=22; 506 $Mail::Sender::Error="Authentication protocol $_[0] is not implemented by Mail::Sender"; 507 return -19, $Mail::Sender::Error; 508} 509 510sub ALLRECIPIENTSBAD { 511 $!=2; 512 return -20, $Mail::Sender::Error; 513} 514 515sub FILECANTREAD { 516 $Mail::Sender::Error="File \"$_[0]\" cannot be read: $^E"; 517 return -21, $Mail::Sender::Error; 518} 519 520sub DEBUGFILE { 521 $Mail::Sender::Error=$_[0]; 522 return -22, $Mail::Sender::Error; 523} 524 525sub STARTTLS { 526 $Mail::Sender::Error="STARTTLS failed: $_[0] $_[1]"; 527 $!=5; 528 return -23, $Mail::Sender::Error; 529} 530 531sub IO_SOCKET_SSL { 532 $Mail::Sender::Error="IO::Socket::SSL->start_SSL failed: $_[0]"; 533 $!=5; 534 return -24, $Mail::Sender::Error; 535} 536 537sub TLS_UNSUPPORTED_BY_ME { 538 $Mail::Sender::Error="TLS unsupported by the script: $_[0]"; 539 $!=5; 540 return -25, $Mail::Sender::Error; 541} 542sub TLS_UNSUPPORTED_BY_SERVER { 543 $Mail::Sender::Error="TLS unsupported by server"; 544 $!=5; 545 return -26, $Mail::Sender::Error; 546} 547sub UNKNOWNENCODING { 548 $Mail::Sender::Error="Unknown encoding '$_[0]'"; 549 $!=5; 550 return -27, $Mail::Sender::Error; 551} 552 553@Mail::Sender::Errors = ( 554 'OK', 555 'Unknown encoding', 556 'TLS unsupported by server', 557 'TLS unsupported by script', 558 'IO::SOCKET::SSL failed', 559 'STARTTLS failed', 560 'debug file cannot be opened', 561 'file cannot be read', 562 'all recipients have been rejected', 563 'authentication protocol is not implemented', 564 'login not accepted', 565 'authentication protocol not accepted by the server', 566 'no From: address specified', 567 'no SMTP server specified', 568 'connection not established. Did you mean MailFile instead of SendFile?', 569 'site specific error', 570 'not available in singlepart mode', 571 'file not found', 572 'no file name specified in call to MailFile or SendFile', 573 'no message specified in call to MailMsg or MailFile', 574 'argument $to empty', 575 'transmission of message failed', 576 'local user $to unknown on host $smtp', 577 'unspecified communication error', 578 'service not available', 579 'connect() failed', 580 'socket() failed', 581 '$smtphost unknown' 582); 583 584=head1 NAME 585 586Mail::Sender - module for sending mails with attachments through an SMTP server 587 588Version 0.8.22 589 590=head1 SYNOPSIS 591 592 use Mail::Sender; 593 $sender = new Mail::Sender 594 {smtp => 'mail.yourdomain.com', from => 'your@address.com'}; 595 $sender->MailFile({to => 'some@address.com', 596 subject => 'Here is the file', 597 msg => "I'm sending you the list you wanted.", 598 file => 'filename.txt'}); 599 600=head1 DESCRIPTION 601 602C<Mail::Sender> provides an object oriented interface to sending mails. 603It doesn't need any outer program. It connects to a mail server 604directly from Perl, using Socket. 605 606Sends mails directly from Perl through a socket connection. 607 608=head1 new Mail::Sender 609 610 new Mail::Sender ([from [,replyto [,to [,smtp [,subject [,headers [,boundary]]]]]]]) 611 new Mail::Sender {[from => 'somebody@somewhere.com'] , [to => 'else@nowhere.com'] [...]} 612 613Prepares a sender. This doesn't start any connection to the server. You 614have to use C<$Sender->Open> or C<$Sender->OpenMultipart> to start 615talking to the server. 616 617The parameters are used in subsequent calls to C<$Sender->Open> and 618C<$Sender->OpenMultipart>. Each such call changes the saved variables. 619You can set C<smtp>, C<from> and other options here and then use the info 620in all messages. 621 622=head2 Parameters 623 624=over 4 625 626=item from 627 628C<>=> the sender's e-mail address 629 630=item fake_from 631 632C<>=> the address that will be shown in headers. 633 634If not specified we use the value of C<from>. 635 636=item replyto 637 638C<>=> the reply-to address 639 640=item to 641 642C<>=> the recipient's address(es) 643 644This parameter may be either a comma separated list of email addresses 645or a reference to a list of addresses. 646 647=item fake_to 648 649C<>=> the recipient's address that will be shown in headers. 650If not specified we use the value of "to". 651 652If the list of addresses you want to send your message to is long or if you do not want 653the recipients to see each other's address set the C<fake_to> parameter to some informative, 654yet bogus, address or to the address of your mailing/distribution list. 655 656=item cc 657 658C<>=> address(es) to send a copy (CC:) to 659 660=item fake_cc 661 662C<>=> the address that will be shown in headers. 663 664If not specified we use the value of "cc". 665 666=item bcc 667 668C<>=> address(es) to send a copy (BCC: or blind carbon copy). 669these addresses will not be visible in the mail! 670 671=item smtp 672 673C<>=> the IP or domain address of your SMTP (mail) server 674 675This is the name of your LOCAL mail server, do NOT try 676to contact directly the adressee's mailserver! That would be slow and buggy, 677your script should only pass the messages to the nearest mail server and leave 678the rest to it. Keep in mind that the recipient's server may be down temporarily. 679 680=item port 681 682C<>=> the TCP/IP port used form the connection. By default getservbyname('smtp', 'tcp')||25. 683You should only need to use this option if your mail server waits on a nonstandard port. 684 685=item subject 686 687C<>=> the subject of the message 688 689=item headers 690 691C<>=> the additional headers 692 693You may use this parameter to add custom headers into the message. The parameter may 694be either a string containing the headers in the right format or a hash containing the headers 695and their values. 696 697=item boundary 698 699C<>=> the message boundary 700 701You usually do not have to change this, it might only come in handy if you need 702to attach a multipart mail created by Mail::Sender to your message as a single part. 703Even in that case any problems are unlikely. 704 705=item multipart 706 707C<>=> the MIME subtype for the whole message (Mixed/Related/Alternative) 708 709You may need to change this setting if you want to send a HTML body with some 710inline images, or if you want to post the message in plain text as well as 711HTML (alternative). See the examples at the end of the docs. 712You may also use the nickname "subtype". 713 714=item ctype 715 716C<>=> the content type of a single part message or the body of the multipart one. 717 718Please do not confuse these two. The 'multipart' parameter is used to specify 719the overall content type of a multipart message (for example a HTML document 720with inlined images) while ctype is an ordinary content type for a single 721part message or the body of a multipart message. 722 723=item encoding 724 725C<>=> encoding of a single part message or the body of a multipart message. 726 727If the text of the message contains some extended characters or 728very long lines you should use 'encoding => "Quoted-printable"' in the 729call to Open(), OpenMultipart(), MailMsg() or MailFile(). 730 731Keep in mind that if you use some encoding you should either use SendEnc() 732or encode the data yourself ! 733 734=item charset 735 736C<>=> the charset of the single part message or the body of the multipart one 737 738=item client 739 740C<>=> the name of the client computer. 741 742During the connection you send 743the mailserver your computer's name. By default Mail::Sender sends 744C<(gethostbyname 'localhost')[0]>. 745If that is not the address you need, you can specify a different one. 746 747=item priority 748 749C<>=> the message priority number 750 7511 = highest, 2 = high, 3 = normal, 4 = low, 5 = lowest 752 753=item confirm 754 755C<>=> whether you request reading or delivery confirmations and to what addresses: 756 757 "delivery" - only delivery, to the C<from> address 758 "reading" - only reading, to the C<from> address 759 "delivery, reading" - both confirmations, to the C<from> address 760 "delivery: my.other@address.com" - only delivery, to my.other@address.com 761 ... 762 763Keep in mind though that neither of those is guaranteed to work. Some servers/mail clients do not support 764this feature and some users/admins may have disabled it. So it's possible that your mail was delivered and read, 765but you won't get any confirmation! 766 767=item ESMPT 768 769 ESMTP => { 770 NOTIFY => 'SUCCESS,FAILURE,DELAY', 771 RET => 'HDRS', 772 ORCPT => 'rfc822;my.other@address.com', 773 ENVID => 'iuhsdfobwoe8t237', 774 } 775 776This option contains data for SMTP extensions, for example it allows you to request delivery 777status notifications according to RFC1891. 778 779NOTIFY - to specify the conditions under which a delivery status notification should be generated. 780Should be either "NEVER" or a comma separated list of "SUCCESS", "FAILURE" and "DELAY". 781 782ORCPT - used to convey the "original" (sender-specified) recipient address 783 784RET - to request that Delivery Status Notifications containing an indication of delivery 785failure either return the entire contents of a message or only the message headers. Must be either 786FULL or HDRS 787 788ENVID - used to propagate an identifier for this message transmission envelope, which is also 789known to the sender and will, if present, be returned in any Delivery Status Notifications issued 790for this transmission 791 792You do not need to worry about encoding the ORCPT or ENVID parameters. 793 794If the SMTP server you connect to doesn't support this extension, the options will be ignored. 795 796=item debug 797 798C<>=> C<"/path/to/debug/file.txt"> 799 800or 801 802C<>=> \*FILEHANDLE 803 804or 805 806C<>=> $FH 807 808All the conversation with the server will be logged to that file or handle. 809All lines in the file should end with CRLF (the Windows and Internet format). 810If even a single one of them does not, please let me know! 811 812If you pass the path to the log file, Mail::Sender will overwrite it. If you want to append to the file, 813you have to open it yourself and pass the filehandle: 814 815 open my $DEBUG, ">> /path/to/debug/file.txt" 816 or die "Can't open the debug file: $!\n" 817 $sender = new Mail::Sender ({ 818 ... 819 debug => $DEBUG, 820 }); 821 822=item debug_level 823 824Only taken into account if the C<debug> option is specified. 825 826 1 - only log the conversation with the server, skip all message data 827 2 - log the conversation and message headers 828 3 - log the conversation and the message and part headers 829 4 - log everything (default) 830 831=item auth 832 833the SMTP authentication protocol to use to login to the server 834currently the only ones supported are LOGIN, PLAIN, CRAM-MD5 and NTLM. 835 836Some protocols have module dependencies. CRAM-MD5 depends on 837Digest::HMAC_MD5 and NTLM on Authen::NTLM. 838 839You may add support for other authentication protocols yourself. See below. 840 841=item authid 842 843the username used to login to the server 844 845=item authpwd 846 847the password used to login to the server 848 849=item authdomain 850 851the domain name. Used optionaly by the NTLM authentication. 852 853Other authentication protocols may use other options as well. 854They should all start with "auth" though. 855 856Please see the authentication section bellow. 857 858=item auth_encoded 859 860If set to a true value the LOGIN authentication assumes the authid and authpwd 861is already base64 encoded. 862 863=item TLS_allowed 864 865If set to a true value Mail::Sender attempts to use LTS (SSL encrypted connection) whenever 866the server supports it and you have IO::Socket::SSL and Net::SSLeay. 867 868The default value of ths option is TRUE! This means that if Mail::Server can send the data encrypted, it will. 869 870=item TLS_required 871 872If you set this option to a true value, the module will fail whenever it's unable to use TLS. 873 874=item keepconnection 875 876If set to a true value causes the Mail::Sender to keep the connection open for several messages. 877The connection will be closed if you call the Close() method with a true value or if you call Open, 878OpenMultipart, MailMsg or MailFile with the "smtp" parameter. 879This means that if you want the object to keep the connection you should pass the "smtp" either to "new Mail::Sender" 880or only to the first Open, OpenMultipart, MailMsg or MailFile! 881 882=item skip_bad_recipients 883 884If this option is set to false or not specified then Mail::Sender stops trying to send a message as soon as 885the first recipient's address fails. If it is set to a true value Mail::Sender skips the bad addresses and tries 886to send the message at least to the good ones. If all addresses are rejected by the server it reports an 887"All recipients were rejected" message. 888 889If any addresses were skipped the C<$sender-E<gt>{'skipped_recipients'}> will be a reference to a hash 890containing the failed address and the server's response. 891 892=item createmessageid 893 894This option allows you to overwrite the function that generates the message IDs for the emails. 895The function gets the "pure" sender's address as it's only parameter and is supposed to return a string. 896See the MessageID subroutine in Mail::Sender.pm. 897 898If you want to specify a message id you can also use the "messageid" parameter for the Open, OpenMultipart, 899MailMsg or MailFile methods. 900 901=item on_errors 902 903This option allows you to affect the way Mail::Sender reports errors. 904 905 => 'die' - raise an exception 906 => 'code' - return the negative error code (default) 907 => 'undef' - return an undef 908 909$Mail::Sender::Error, $sender->{'error'} and $sender->{'error_msg'} are set in all the cases. 910 911All methods return the $sender object if they succeed. 912 913P.S.: The die_on_errors option is deprecated. You may still use it, but it may be removed in future versions! 914 915=back 916 917=head2 Return codes 918 919 ref to a Mail::Sender object = success 920 921 -1 = $smtphost unknown 922 -2 = socket() failed 923 -3 = connect() failed 924 -4 = service not available 925 -5 = unspecified communication error 926 -6 = local user $to unknown on host $smtp 927 -7 = transmission of message failed 928 -8 = argument $to empty 929 -9 = no message specified in call to MailMsg or MailFile 930 -10 = no file name specified in call to SendFile or MailFile 931 -11 = file not found 932 -12 = not available in singlepart mode 933 -13 = site specific error 934 -14 = connection not established. Did you mean MailFile instead of SendFile? 935 -15 = no SMTP server specified 936 -16 = no From: address specified 937 -17 = authentication protocol not accepted by the server 938 -18 = login not accepted 939 -19 = authentication protocol is not implemented 940 941$Mail::Sender::Error contains a textual description of last error. 942 943=cut 944 945sub new { 946 my $this = shift; 947 my $self = {}; 948 my $class; 949 if (ref($this)) { 950 $class = ref($this); 951 %$self = %$this; 952 } else { 953 $class = $this; 954 } 955 bless $self, $class; 956 return $self->initialize(@_); 957} 958 959sub initialize { 960 undef $Mail::Sender::Error; 961 my $self = shift; 962 963 delete $self->{'_buffer'}; 964 $self->{'debug'} = 0; 965 $self->{'proto'} = (getprotobyname('tcp'))[2]; 966 $self->{'port'} = getservbyname('smtp', 'tcp')||25 if not defined $self->{'port'}; 967 968 $self->{'boundary'} = 'Message-Boundary-by-Mail-Sender-'.time(); 969 $self->{'multipart'} = 'mixed'; # default is multipart/mixed 970 $self->{'tls_allowed'} = 1; 971 972 $self->{'client'} = $local_name; 973 974 # Copy defaults from %Mail::Sender::default 975 my $key; 976 foreach $key (keys %Mail::Sender::default) { 977 $self->{lc $key}=$Mail::Sender::default{$key}; 978 } 979 980 if (@_ != 0) { 981 if (ref $_[0] eq 'HASH') { 982 my $hash=$_[0]; 983 foreach $key (keys %$hash) { 984 $self->{lc $key}=$hash->{$key}; 985 } 986 $self->{'reply'} = $self->{'replyto'} if (defined $self->{'replyto'} and !defined $self->{'reply'}); 987 } else { 988 ($self->{'from'}, $self->{'reply'}, $self->{'to'}, $self->{'smtp'}, 989 $self->{'subject'}, $self->{'headers'}, $self->{'boundary'} 990 ) = @_; 991 } 992 } 993 994 $self->{'fromaddr'} = $self->{'from'}; 995 $self->{'replyaddr'} = $self->{'reply'}; 996 997 $self->_prepare_addresses('to') if defined $self->{'to'}; 998 $self->_prepare_addresses('cc') if defined $self->{'cc'}; 999 $self->_prepare_addresses('bcc') if defined $self->{'bcc'}; 1000 1001 $self->_prepare_ESMTP() if defined $self->{'esmtp'}; 1002 1003 $self->{'fromaddr'} =~ s/.*<([^\s]*?)>/$1/ if ($self->{'fromaddr'}); # get from email address 1004 if (defined $self->{'replyaddr'} and $self->{'replyaddr'}) { 1005 $self->{'replyaddr'} =~ s/.*<([^\s]*?)>/$1/; # get reply email address 1006 $self->{'replyaddr'} =~ s/^([^\s]+).*/$1/; # use first address 1007 } 1008 1009 if (defined $self->{'smtp'}) { 1010 $self->{'smtp'} =~ s/^\s+//g; # remove spaces around $smtp 1011 $self->{'smtp'} =~ s/\s+$//g; 1012 1013 $self->{'smtpaddr'} = inet_aton($self->{'smtp'}); 1014 if (!defined($self->{'smtpaddr'})) { return $self->Error(HOSTNOTFOUND($self->{'smtp'})); } 1015 $self->{'smtpaddr'} = $1 if ($self->{'smtpaddr'} =~ /(.*)/s); # Untaint 1016 } 1017 1018 $self->{'boundary'} =~ tr/=/-/ if defined $self->{'boundary'}; 1019 1020 $self->_prepare_headers() if (exists $self->{'headers'}); 1021 1022 return $self; 1023} 1024 1025use vars qw(%CTypes); 1026%CTypes = ( 1027 GIF => 'image/gif', 1028 JPE => 'image/jpeg', 1029 JPEG => 'image/jpeg', 1030 SHTML => 'text/html', 1031 SHTM => 'text/html', 1032 HTML => 'text/html', 1033 HTM => 'text/html', 1034 TXT => 'text/plain', 1035 INI => 'text/plain', 1036 DOC => 'application/x-msword', 1037 EML => 'message/rfc822', 1038); 1039 1040sub GuessCType { 1041 my $ext = shift; 1042 $ext =~ s/^.*\.//; 1043 return $CTypes{uc $ext} || 'application/octet-stream'; 1044} 1045 1046sub Connect { 1047 my $self = shift(); 1048 1049 my $s = IO::Socket::INET->new( 1050 PeerHost => $self->{'smtp'}, 1051 PeerPort => $self->{'port'}, 1052 Proto => "tcp", 1053 Timeout => ($self->{'timeout'} || 120), 1054 ) or return $self->Error(CONNFAILED); 1055 1056 $s->autoflush(1); 1057 binmode($s); 1058 1059 if ($self->{'debug'}) { 1060 eval { 1061 $s = __Debug( $s, $self->{'debug'}); 1062 } 1063 or return $self->Error(DEBUGFILE($@)); 1064 $self->{'debug_level'} = 4 unless defined $self->{'debug_level'}; 1065 } 1066 1067 $_ = get_response($s); if (not $_ or !/^[123]/) { return $self->Error(SERVNOTAVAIL($_)); } 1068 $self->{'server'} = substr $_, 4; 1069 1070 { my $res = $self->say_helo($s); 1071 return $res if $res; 1072 } 1073 1074 if (($self->{tls_required} or $self->{tls_allowed}) 1075 and ! $TLS_notsupported and (defined($self->{'supports'}{STARTTLS}) or defined($self->{'supports'}{TLS}))) { 1076 Net::SSLeay::load_error_strings(); 1077 Net::SSLeay::SSLeay_add_ssl_algorithms(); 1078 $Net::SSLeay::random_device = $0 if (!-s $Net::SSLeay::random_device); 1079 Net::SSLeay::randomize(); 1080 1081 my $res=send_cmd $s, "STARTTLS"; 1082 my ($code,$text)=split(/\s/,$res,2); 1083 1084 return $self->Error(STARTTLS($code,$text)) if ($code != 220); 1085 1086 if ($self->{'debug'}) { 1087#print "Debug: \$s=$s\ntied(\$s)=" . tied($s) . "\n\${tied(\$s)}=${tied($s)}\n"; 1088#print "Debug: \$s=$s\n\${\$s}=" . ${$s} . "\n"; 1089#use PSH; 1090#$::S = $s; 1091#PSH::prompt; 1092 $res = IO::Socket::SSL->start_SSL( tied(*$s)->[0], SSL_version=>'TLSv1', SSL_verify_mode=>1) 1093 } else { 1094 $res = IO::Socket::SSL->start_SSL( $s, SSL_version=>'TLSv1', SSL_verify_mode=>1) 1095 } 1096 if (! $res) { 1097 return $self->Error(IO_SOCKET_SSL(IO::Socket::SSL::errstr())); 1098 } 1099 1100 { 1101 my $res = $self->say_helo($s); 1102 return $res if $res; 1103 } 1104 } elsif ($self->{tls_required}) { 1105 if ($TLS_notsupported) { 1106 return $self->Error(TLS_UNSUPPORTED_BY_ME($TLS_notsupported)) 1107 } else { 1108 return $self->Error(TLS_UNSUPPORTED_BY_SERVER()) 1109 } 1110 } 1111 1112 if ($self->{'auth'} or $self->{'username'}) { 1113 $self->{'socket'} = $s; 1114 my $res = $self->login(); 1115 return $res if $res; 1116 delete $self->{'socket'}; # it's supposed to be added later 1117 } 1118 1119 return $s; 1120} 1121 1122sub Error { 1123 my $self = shift(); 1124 if (@_) { 1125 if (defined $self->{'socket'}) { 1126 my $s = $self->{'socket'}; 1127 print $s "quit\x0D\x0A"; 1128 close $s; 1129 delete $self->{'socket'}; 1130 } 1131 delete $self->{'_data'}; 1132 ($self->{'error'},$self->{'error_msg'}) = @_; 1133 } 1134 if ($self->{'die_on_errors'} or $self->{'on_errors'} eq 'die') { 1135 die $self->{'error_msg'}."\n" ; 1136 } elsif (exists $self->{'on_errors'} and (!defined($self->{'on_errors'}) or $self->{'on_errors'} eq 'undef')) { 1137 return 1138 } else { 1139 return $self->{'error'} 1140 } 1141} 1142 1143sub ClearErrors { 1144 my $self = shift(); 1145 delete $self->{'error'}; 1146 delete $self->{'error_msg'}; 1147 undef $Mail::Sender::Error; 1148} 1149 1150sub _prepare_addresses { 1151 my ($self, $type) = @_; 1152 if (ref $self->{$type}) { 1153 $self->{$type.'_list'} = $self->{$type}; 1154 $self->{$type} = join ', ', @{$self->{$type.'_list'}}; 1155 } else { 1156 $self->{$type} =~ s/\s+/ /g; 1157 $self->{$type} =~ s/, ?,/,/g; 1158 $self->{$type.'_list'} = [map {s/\s+$//;$_} $self->{$type} =~ /((?:[^",]+|"[^"]*")+)(?:,\s*|\s*$)/g]; 1159 } 1160} 1161 1162sub _prepare_ESMTP { 1163 my $self = shift; 1164 $self->{esmtp} = {%{$self->{esmtp}}}; # make a copy of the hash. Just in case 1165 1166 $self->{esmtp}{ORCPT} = 'rfc822;' . $self->{esmtp}{ORCPT} if $self->{esmtp}{ORCPT} ne '' and $self->{esmtp}{ORCPT} !~ /;/; 1167 for (qw(ENVID ORCPT)) { 1168 $self->{esmtp}{$_} = enc_xtext($self->{esmtp}{$_}); 1169 } 1170} 1171 1172sub _prepare_headers { 1173 my $self = shift; 1174 return unless exists $self->{'headers'}; 1175 if ($self->{'headers'} eq '') { 1176 delete $self->{'headers'}; 1177 delete $self->{'_headers'}; 1178 return; 1179 } 1180 if (ref($self->{'headers'}) eq 'HASH') { 1181 my $headers = ''; 1182 while ( my ($hdr, $value) = each %{$self->{'headers'}}) { 1183 for ($hdr, $value) { 1184 s/(?:\x0D\x0A?|\x0A)/\x0D\x0A/sg; # convert all end-of-lines to CRLF 1185 s/^(?:\x0D\x0A)+//; # strip leading 1186 s/(?:\x0D\x0A)+$//; # and trailing end-of-lines 1187 s/\x0D\x0A(\S)/\x0D\x0A\t$1/sg; 1188 if (length($_) > 997) { # header too long, max 1000 chars 1189 s/(.{1,980}[;,])\s+(\S)/$1\x0D\x0A\t$2/g; 1190 } 1191 } 1192 $headers .= "$hdr: $value\x0D\x0A"; 1193 } 1194 $headers =~ s/(?:\x0D\x0A)+$//; # and trailing end-of-lines 1195 $self->{'_headers'} = $headers; 1196 } elsif (ref($self->{'headers'})) { 1197 } else { 1198 $self->{'_headers'} = $self->{'headers'}; 1199 for ($self->{'_headers'}) { 1200 s/(?:\x0D\x0A?|\x0A)/\x0D\x0A/sg; # convert all end-of-lines to CRLF 1201 s/^(?:\x0D\x0A)+//; # strip leading 1202 s/(?:\x0D\x0A)+$//; # and trailing end-of-lines 1203 } 1204 } 1205} 1206=head1 METHODS 1207 1208 1209=head2 Open 1210 1211 Open([from [, replyto [, to [, smtp [, subject [, headers]]]]]]) 1212 Open({[from => "somebody@somewhere.com"] , [to => "else@nowhere.com"] [...]}) 1213 1214Opens a new message. If some parameters are unspecified or empty, it uses 1215the parameters passed to the "C<$Sender=new Mail::Sender(...)>"; 1216 1217See C<new Mail::Sender> for info about the parameters. 1218 1219The only additional parameter that may not be specified directly in the C<new Mail::Sender> 1220is messageid. If you set this option then the message will be sent with this Message-ID, 1221otherwise a new Message ID will be generated out of the sender's address, current date+time 1222and a random number (or by the function you specified in the C<createmessageid> option). 1223 1224After the message is sent C<$sender-E<gt>{messageid}> will contain the Message-ID with 1225which the message was sent. 1226 1227Returns ref to the Mail::Sender object if successful. 1228 1229=cut 1230 1231sub Open { 1232 undef $Mail::Sender::Error; 1233 my $self = shift; 1234 local $_; 1235 if (!$self->{'keepconnection'} and $self->{'_data'}) { # the user did not Close() or Cancel() the previous mail 1236 if ($self->{'error'}) { 1237 $self->Cancel; 1238 } else { 1239 $self->Close; 1240 } 1241 } 1242 1243 delete $self->{'error'}; 1244 delete $self->{'encoding'}; 1245 delete $self->{'messageid'}; 1246 my %changed; 1247 $self->{'multipart'} = 0; 1248 $self->{'_had_newline'} = 1; 1249 1250 if (ref $_[0] eq 'HASH') { 1251 my $key; 1252 my $hash=$_[0]; 1253 $hash->{'reply'} = $hash->{'replyto'} if (defined $hash->{'replyto'} and !defined $hash->{'reply'}); 1254 foreach $key (keys %$hash) { 1255 if (ref($hash->{$key}) eq 'HASH' and exists $self->{lc $key}) { 1256 if (ref($self->{lc $key}) eq 'HASH') { 1257 $self->{lc $key} = { %{$self->{lc $key}}, %{$hash->{$key}} }; 1258 } else { 1259 $self->{lc $key} = { %{$hash->{$key}} }; # make a shallow copy 1260 } 1261 } else { 1262 $self->{lc $key} = $hash->{$key}; 1263 } 1264 $changed{lc $key}=1; 1265 } 1266 } else { 1267 my ($from, $reply, $to, $smtp, $subject, $headers) = @_; 1268 1269 if ($from) {$self->{'from'}=$from;$changed{'from'}=1;} 1270 if ($reply) {$self->{'reply'}=$reply;$changed{'reply'}=1;} 1271 if ($to) {$self->{'to'}=$to;$changed{'to'}=1;} 1272 if ($smtp) {$self->{'smtp'}=$smtp;$changed{'smtp'}=1;} 1273 if ($subject) {$self->{'subject'}=$subject;$changed{'subject'}=1;} 1274 if ($headers) {$self->{'headers'}=$headers;$changed{'headers'}=1;} 1275 } 1276 1277 $self->_prepare_addresses('to') if $changed{'to'}; 1278 $self->_prepare_addresses('cc') if $changed{'cc'}; 1279 $self->_prepare_addresses('bcc') if $changed{'bcc'}; 1280 1281 $self->_prepare_ESMTP() if defined $changed{'esmtp'}; 1282 1283 $self->{'boundary'} =~ tr/=/-/ if defined $changed{'boundary'}; 1284 1285 return $self->Error( NOFROMSPECIFIED) unless defined $self->{'from'}; 1286 1287 if ($changed{'from'}) { 1288 $self->{'fromaddr'} = $self->{'from'}; 1289 $self->{'fromaddr'} =~ s/.*<([^\s]*?)>/$1/; # get from email address 1290 } 1291 1292 if ($changed{'reply'}) { 1293 $self->{'replyaddr'} = $self->{'reply'}; 1294 $self->{'replyaddr'} =~ s/.*<([^\s]*?)>/$1/; # get reply email address 1295 $self->{'replyaddr'} =~ s/^([^\s]+).*/$1/; # use first address 1296 } 1297 1298 if ($changed{'smtp'}) { 1299 $self->{'smtp'} =~ s/^\s+//g; # remove spaces around $smtp 1300 $self->{'smtp'} =~ s/\s+$//g; 1301 $self->{'smtpaddr'} = inet_aton($self->{'smtp'}); 1302 if (!defined($self->{'smtpaddr'})) { return $self->Error(HOSTNOTFOUND($self->{'smtp'})); } 1303 $self->{'smtpaddr'} = $1 if ($self->{'smtpaddr'} =~ /(.*)/s); # Untaint 1304 if (exists $self->{'socket'}) { 1305 my $s = $self->{'socket'}; 1306 close $s; 1307 delete $self->{'socket'}; 1308 } 1309 } 1310 1311 $self->_prepare_headers() if ($changed{'headers'}); 1312 1313 if (!$self->{'to'}) { return $self->Error(TOEMPTY); } 1314 1315 return $self->Error(NOSERVER) unless defined $self->{'smtp'}; 1316# if (!defined($self->{'smtpaddr'})) { return $self->Error(HOSTNOTFOUND($self->{'smtp'})); } 1317 1318 if ($Mail::Sender::{'SiteHook'} and !$self->SiteHook()) { 1319 return defined $self->{'error'} ? $self->{'error'} : $self->{'error'}=&SITEERROR; 1320 } 1321 1322 my $s = $self->{'socket'} || $self->Connect(); 1323 return $s unless ref $s; # return the error number if we did not get a socket 1324 $self->{'socket'} = $s; 1325 1326 $_ = send_cmd $s, "MAIL FROM:<$self->{'fromaddr'}>$self->{esmtp}{_MAIL_FROM}"; 1327 if (!/^[123]/) { return $self->Error(COMMERROR($_)); } 1328 1329 { local $^W; 1330 if ($self->{'skip_bad_recipients'}) { 1331 my $good_count = 0; 1332 my %failed; 1333 foreach my $addr ( @{$self->{'to_list'}}, @{$self->{'cc_list'}}, @{$self->{'bcc_list'}}) { 1334 if ($addr =~ /<(.*)>/) { 1335 $_ = send_cmd $s, "RCPT TO:<$1>$self->{esmtp}{_RCPT_TO}"; 1336 } else { 1337 $_ = send_cmd $s, "RCPT TO:<$addr>$self->{esmtp}{_RCPT_TO}"; 1338 } 1339 if (!/^[123]/) { 1340 chomp; 1341 s/^\d{3} //; 1342 $failed{$addr} = $_; 1343 } else { 1344 $good_count++ 1345 } 1346 } 1347 $self->{'skipped_recipients'} = \%failed 1348 if %failed; 1349 if ($good_count == 0) { 1350 return $self->Error(ALLRECIPIENTSBAD); 1351 } 1352 } else { 1353 foreach my $addr ( @{$self->{'to_list'}}, @{$self->{'cc_list'}}, @{$self->{'bcc_list'}}) { 1354 if ($addr =~ /<(.*)>/) { 1355 $_ = send_cmd $s, "RCPT TO:<$1>$self->{esmtp}{_RCPT_TO}"; 1356 } else { 1357 $_ = send_cmd $s, "RCPT TO:<$addr>$self->{esmtp}{_RCPT_TO}"; 1358 } 1359 if (!/^[123]/) { 1360 return $self->Error(USERUNKNOWN($addr, $self->{'smtp'}, $_)); } 1361 } 1362 } 1363 } 1364 1365 $_ = send_cmd $s, "DATA"; 1366 if (!/^[123]/) { return $self->Error(COMMERROR($_)); } 1367 1368 $self->{'socket'}->stop_logging("\x0D\x0A... message headers and data skipped ...") if ($self->{'debug'} and $self->{'debug_level'} <= 1); 1369 $self->{'_data'} = 1; 1370 1371 $self->{'ctype'} = 'text/plain' if (defined $self->{'charset'} and !defined $self->{'ctype'}); 1372 1373 my $headers; 1374 if (defined $self->{'encoding'} or defined $self->{'ctype'}) { 1375 $headers = 'MIME-Version: 1.0'; 1376 $headers .= "\r\nContent-Type: $self->{'ctype'}" if defined $self->{'ctype'}; 1377 $headers .= "; charset=$self->{'charset'}" if defined $self->{'charset'}; 1378 1379 undef $self->{'chunk_size'}; 1380 if (defined $self->{'encoding'}) { 1381 $headers .= "\r\nContent-Transfer-Encoding: $self->{'encoding'}"; 1382 if ($self->{'encoding'} =~ /Base64/i) { 1383 $self->{'code'} = enc_base64($self->{'charset'}); 1384 $self->{'chunk_size'} = $enc_base64_chunk; 1385 } elsif ($self->{'encoding'} =~ /Quoted[_\-]print/i) { 1386 $self->{'code'} = enc_qp($self->{'charset'}); 1387 } elsif ($self->{'encoding'} =~ /^[78]bit$/i) { 1388 $self->{'code'} = enc_plain($self->{charset}) 1389 } else { 1390 return $self->Error(UNKNOWNENCODING($self->{'encoding'})); 1391 } 1392 } 1393 } 1394 1395 $self->{'code'} = enc_plain($self->{charset}) unless $self->{'code'}; 1396 1397 print_hdr $s, "To" => (defined $self->{'fake_to'} ? $self->{'fake_to'} : $self->{'to'}), $self->{'charset'}; 1398 print_hdr $s, "From" => (defined $self->{'fake_from'} ? $self->{'fake_from'} : $self->{'from'}), $self->{'charset'}; 1399 if (defined $self->{'fake_cc'} and $self->{'fake_cc'}) { 1400 print_hdr $s, "Cc" => $self->{'fake_cc'}, $self->{'charset'}; 1401 } elsif (defined $self->{'cc'} and $self->{'cc'}) { 1402 print_hdr $s, "Cc" => $self->{'cc'}, $self->{'charset'}; 1403 } 1404 print_hdr $s, "Reply-To", $self->{'reply'},$self->{'charset'} if defined $self->{'reply'}; 1405 1406 $self->{'subject'} = "<No subject>" unless defined $self->{'subject'}; 1407 print_hdr $s, "Subject" => $self->{'subject'}, $self->{'charset'}; 1408 1409 unless (defined $Mail::Sender::NO_DATE and $Mail::Sender::NO_DATE 1410 or 1411 defined $self->{'_headers'} and $self->{'_headers'} =~ /^Date:/m 1412 or 1413 defined $Mail::Sender::SITE_HEADERS && $Mail::Sender::SITE_HEADERS =~ /^Date:/m 1414 ) { 1415 my $date = localtime(); $date =~ s/^(\w+)\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)$/$1, $3 $2 $5 $4/; 1416 print_hdr $s, "Date" => "$date $GMTdiff"; 1417 } 1418 1419 if ($self->{'priority'}) { 1420 $self->{'priority'} = $priority[$self->{'priority'}] 1421 if ($self->{'priority'}+0 eq $self->{'priority'}); 1422 print_hdr $s, "X-Priority" => $self->{'priority'}; 1423 } 1424 1425 if ($self->{'confirm'}) { 1426 for my $confirm (split /\s*,\s*/, $self->{'confirm'}) { 1427 if ($confirm =~ /^\s*reading\s*(?:\:\s*(.*))?/i) { 1428 print_hdr $s, "X-Confirm-Reading-To" => ($1 || $self->{'from'}), $self->{'charset'}; 1429 } elsif ($confirm =~ /^\s*delivery\s*(?:\:\s*(.*))?/i) { 1430 print_hdr $s, "Return-Receipt-To" => ($1 || $self->{'fromaddr'}), $self->{'charset'}; 1431 print_hdr $s, "Disposition-Notification-To" => ($1 || $self->{'fromaddr'}), $self->{'charset'}; 1432 } 1433 } 1434 } 1435 1436 unless (defined $Mail::Sender::NO_X_MAILER) { 1437 my $script = basename($0); 1438 print_hdr $s, "X-Mailer" => qq{Perl script "$script"\r\n\tusing Mail::Sender $Mail::Sender::ver by Jenda Krynicky, Czechlands\r\n\trunning on $local_name ($local_IP)\r\n\tunder account "}.getusername().qq{"\r\n} 1439 } 1440 1441 unless (defined $Mail::Sender::NO_MESSAGE_ID and $Mail::Sender::NO_MESSAGE_ID) { 1442 if (!defined $self->{'messageid'} or $self->{'messageid'} eq '') { 1443 if (defined $self->{'createmessageid'} and ref $self->{'createmessageid'} eq 'CODE') { 1444 $self->{'messageid'} = $self->{'createmessageid'}->($self->{'fromaddr'}); 1445 } else { 1446 $self->{'messageid'} = MessageID($self->{'fromaddr'}); 1447 } 1448 } 1449 print_hdr $s, "Message-ID" => $self->{'messageid'}; 1450 } 1451 1452 print $s $Mail::Sender::SITE_HEADERS,"\x0D\x0A" #<???> should handle \r\n at the end of the headers 1453 if (defined $Mail::Sender::SITE_HEADERS); 1454 1455 print $s $self->{'_headers'},"\x0D\x0A" if defined $self->{'_headers'} and $self->{'_headers'}; 1456 print $s $headers,"\r\n" if defined $headers; 1457 1458 print $s "\r\n"; 1459 1460 $self->{'socket'}->stop_logging("... message data skipped ...") if ($self->{'debug'} and $self->{'debug_level'} <= 2); 1461 1462 return $self; 1463} 1464 1465=head2 OpenMultipart 1466 1467 OpenMultipart([from [, replyto [, to [, smtp [, subject [, headers [, boundary]]]]]]]) 1468 OpenMultipart({[from => "somebody@somewhere.com"] , [to => "else@nowhere.com"] [...]}) 1469 1470Opens a multipart message. If some parameters are unspecified or empty, it uses 1471the parameters passed to the C<$Sender=new Mail::Sender(...)>. 1472 1473See C<new Mail::Sender> for info about the parameters. 1474 1475Returns ref to the Mail::Sender object if successful. 1476 1477=cut 1478 1479sub OpenMultipart { 1480 undef $Mail::Sender::Error; 1481 my $self = shift; 1482 1483 local $_; 1484 if (!$self->{'keepconnection'} and $self->{'_data'}) { # the user did not Close() or Cancel() the previous mail 1485 if ($self->{'error'}) { 1486 $self->Cancel; 1487 } else { 1488 $self->Close; 1489 } 1490 } 1491 1492 delete $self->{'error'}; 1493 delete $self->{'encoding'}; 1494 delete $self->{'messageid'}; 1495 $self->{'_part'} = 0; 1496 1497 my %changed; 1498 if (defined $self->{'type'} and $self->{'type'}) { 1499 $self->{'multipart'} = $1 1500 if $self->{'type'} =~ m{^multipart/(.*)}i; 1501 } 1502 $self->{'multipart'} ='Mixed' unless $self->{'multipart'}; 1503 $self->{'idcounter'} = 0; 1504 1505 if (ref $_[0] eq 'HASH') { 1506 my $key; 1507 my $hash=$_[0]; 1508 $hash->{'multipart'} = $hash->{'subtype'} if defined $hash->{'subtype'}; 1509 $hash->{'reply'} = $hash->{'replyto'} if (defined $hash->{'replyto'} and !defined $hash->{'reply'}); 1510 foreach $key (keys %$hash) { 1511 if ((ref($hash->{$key}) eq 'HASH') and exists($self->{lc $key})) { 1512 if (ref($self->{lc $key}) eq 'HASH') { 1513 $self->{lc $key} = { %{$self->{lc $key}}, %{$hash->{$key}} }; 1514 } else { 1515 $self->{lc $key} = { %{$hash->{$key}} }; # make a shallow copy 1516 } 1517 } else { 1518 $self->{lc $key} = $hash->{$key}; 1519 } 1520 $changed{lc $key}=1; 1521 } 1522 } else { 1523 my ($from, $reply, $to, $smtp, $subject, $headers, $boundary) = @_; 1524 1525 if ($from) {$self->{'from'}=$from;$changed{'from'}=1;} 1526 if ($reply) {$self->{'reply'}=$reply;$changed{'reply'}=1;} 1527 if ($to) {$self->{'to'}=$to;$changed{'to'}=1;} 1528 if ($smtp) {$self->{'smtp'}=$smtp;$changed{'smtp'}=1;} 1529 if ($subject) {$self->{'subject'}=$subject;$changed{'subject'}=1;} 1530 if ($headers) {$self->{'headers'}=$headers;$changed{'headers'}=1;} 1531 if ($boundary) {$self->{'boundary'}=$boundary;} 1532 } 1533 1534 $self->_prepare_addresses('to') if $changed{'to'}; 1535 $self->_prepare_addresses('cc') if $changed{'cc'}; 1536 $self->_prepare_addresses('bcc') if $changed{'bcc'}; 1537 1538 $self->_prepare_ESMTP() if defined $changed{'esmtp'}; 1539 1540 $self->{'boundary'} =~ tr/=/-/ if $changed{'boundary'}; 1541 1542 $self->_prepare_headers() if ($changed{'headers'}); 1543 1544 return $self->Error( NOFROMSPECIFIED) unless defined $self->{'from'}; 1545 if ($changed{'from'}) { 1546 $self->{'fromaddr'} = $self->{'from'}; 1547 $self->{'fromaddr'} =~ s/.*<([^\s]*?)>/$1/; # get from email address 1548 } 1549 1550 if ($changed{'reply'}) { 1551 $self->{'replyaddr'} = $self->{'reply'}; 1552 $self->{'replyaddr'} =~ s/.*<([^\s]*?)>/$1/; # get reply email address 1553 $self->{'replyaddr'} =~ s/^([^\s]+).*/$1/; # use first address 1554 } 1555 1556 if ($changed{'smtp'}) { 1557 $self->{'smtp'} =~ s/^\s+//g; # remove spaces around $smtp 1558 $self->{'smtp'} =~ s/\s+$//g; 1559 $self->{'smtpaddr'} = inet_aton($self->{'smtp'}); 1560 if (!defined($self->{'smtpaddr'})) { return $self->Error(HOSTNOTFOUND($self->{'smtp'})); } 1561 $self->{'smtpaddr'} = $1 if ($self->{'smtpaddr'} =~ /(.*)/s); # Untaint 1562 if (exists $self->{'socket'}) { 1563 my $s = $self->{'socket'}; 1564 close $s; 1565 delete $self->{'socket'}; 1566 } 1567 } 1568 1569 if (!$self->{'to'}) { return $self->Error(TOEMPTY); } 1570 1571 return $self->Error(NOSERVER) unless defined $self->{'smtp'}; 1572# if (!defined($self->{'smtpaddr'})) { return $self->Error(HOSTNOTFOUND($self->{'smtp'})); } 1573 1574 if ($Mail::Sender::{'SiteHook'} and !$self->SiteHook()) { 1575 return defined $self->{'error'} ? $self->{'error'} : $self->{'error'}=&SITEERROR; 1576 } 1577 1578 my $s = $self->{'socket'} || $self->Connect(); 1579 return $s unless ref $s; # return the error number if we did not get a socket 1580 $self->{'socket'} = $s; 1581 1582 $_ = send_cmd $s, "MAIL FROM:<$self->{'fromaddr'}>$self->{esmtp}{_MAIL_FROM}"; 1583 if (!/^[123]/) { return $self->Error(COMMERROR($_)); } 1584 1585 { local $^W; 1586 if ($self->{'skip_bad_recipients'}) { 1587 my $good_count = 0; 1588 my %failed; 1589 foreach my $addr ( @{$self->{'to_list'}}, @{$self->{'cc_list'}}, @{$self->{'bcc_list'}}) { 1590 if ($addr =~ /<(.*)>/) { 1591 $_ = send_cmd $s, "RCPT TO:<$1>$self->{esmtp}{_RCPT_TO}"; 1592 } else { 1593 $_ = send_cmd $s, "RCPT TO:<$addr>$self->{esmtp}{_RCPT_TO}"; 1594 } 1595 if (!/^[123]/) { 1596 s/^\d{3} //; 1597 $failed{$addr} = $_; 1598 } else { 1599 $good_count++ 1600 } 1601 } 1602 $self->{'skipped_recipients'} = \%failed 1603 if %failed; 1604 if ($good_count == 0) { 1605 return $self->Error(ALLRECIPIENTSBAD); 1606 } 1607 } else { 1608 foreach my $addr ( @{$self->{'to_list'}}, @{$self->{'cc_list'}}, @{$self->{'bcc_list'}}) { 1609 if ($addr =~ /<(.*)>/) { 1610 $_ = send_cmd $s, "RCPT TO:<$1>$self->{esmtp}{_RCPT_TO}"; 1611 } else { 1612 $_ = send_cmd $s, "RCPT TO:<$addr>$self->{esmtp}{_RCPT_TO}"; 1613 } 1614 if (!/^[123]/) { 1615 return $self->Error(USERUNKNOWN($addr, $self->{'smtp'}, $_)); 1616 } 1617 } 1618 } 1619 } 1620 1621 $_ = send_cmd $s, "DATA"; 1622 if (!/^[123]/) { return $self->Error(COMMERROR($_)); } 1623 1624 $self->{'socket'}->stop_logging("\x0D\x0A... message headers and data skipped ...") if ($self->{'debug'} and $self->{'debug_level'} <= 1); 1625 $self->{'_data'} = 1; 1626 1627 print_hdr $s, "To" => (defined $self->{'fake_to'} ? $self->{'fake_to'} : $self->{'to'}), $self->{'charset'}; 1628 print_hdr $s, "From" => (defined $self->{'fake_from'} ? $self->{'fake_from'} : $self->{'from'}), $self->{'charset'}; 1629 if (defined $self->{'fake_cc'} and $self->{'fake_cc'}) { 1630 print_hdr $s, "Cc" => $self->{'fake_cc'}, $self->{'charset'}; 1631 } elsif (defined $self->{'cc'} and $self->{'cc'}) { 1632 print_hdr $s, "Cc" => $self->{'cc'}, $self->{'charset'}; 1633 } 1634 print_hdr $s, "Reply-To" => $self->{'reply'}, $self->{'charset'} if defined $self->{'reply'}; 1635 1636 $self->{'subject'} = "<No subject>" unless defined $self->{'subject'}; 1637 print_hdr $s, "Subject" => $self->{'subject'}, $self->{'charset'}; 1638 1639 unless (defined $Mail::Sender::NO_DATE and $Mail::Sender::NO_DATE 1640 or 1641 defined $self->{'_headers'} and $self->{'_headers'} =~ /^Date:/m 1642 or 1643 defined $Mail::Sender::SITE_HEADERS && $Mail::Sender::SITE_HEADERS =~ /^Date:/m 1644 ) { 1645 my $date = localtime(); $date =~ s/^(\w+)\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)$/$1, $3 $2 $5 $4/; 1646 print_hdr $s, "Date" => "$date $GMTdiff"; 1647 } 1648 1649 if ($self->{'priority'}) { 1650 $self->{'priority'} = $priority[$self->{'priority'}] 1651 if ($self->{'priority'}+0 eq $self->{'priority'}); 1652 print_hdr $s, "X-Priority" => $self->{'priority'}; 1653 } 1654 1655 if ($self->{'confirm'}) { 1656 for my $confirm (split /\s*,\s*/, $self->{'confirm'}) { 1657 if ($confirm =~ /^\s*reading\s*(?:\:\s*(.*))?/i) { 1658 print_hdr $s, "X-Confirm-Reading-To" => ($1 || $self->{'from'}), $self->{'charset'}; 1659 } elsif ($confirm =~ /^\s*delivery\s*(?:\:\s*(.*))?/i) { 1660 print_hdr $s, "Return-Receipt-To" => ($1 || $self->{'fromaddr'}), $self->{'charset'}; 1661 print_hdr $s, "Disposition-Notification-To" => ($1 || $self->{'fromaddr'}), $self->{'charset'}; 1662 } 1663 } 1664 } 1665 1666 unless (defined $Mail::Sender::NO_X_MAILER and $Mail::Sender::NO_X_MAILER) { 1667 my $script = basename($0); 1668 print_hdr $s, "X-Mailer" => qq{Perl script "$script"\r\n\tusing Mail::Sender $Mail::Sender::ver by Jenda Krynicky, Czechlands\r\n\trunning on $local_name ($local_IP)\r\n\tunder account "}.getusername().qq{"\r\n} 1669 } 1670 1671 print $s $Mail::Sender::SITE_HEADERS,"\r\n" 1672 if (defined $Mail::Sender::SITE_HEADERS); 1673 1674 unless (defined $Mail::Sender::NO_MESSAGE_ID and $Mail::Sender::NO_MESSAGE_ID) { 1675 if (!defined $self->{'messageid'} or $self->{'messageid'} eq '') { 1676 if (defined $self->{'createmessageid'} and ref $self->{'createmessageid'} eq 'CODE') { 1677 $self->{'messageid'} = $self->{'createmessageid'}->($self->{'fromaddr'}); 1678 } else { 1679 $self->{'messageid'} = MessageID($self->{'fromaddr'}); 1680 } 1681 } 1682 print_hdr $s, "Message-ID" => $self->{'messageid'}; 1683 } 1684 1685 print $s $self->{'_headers'},"\r\n" if defined $self->{'_headers'} and $self->{'_headers'}; 1686 print $s "MIME-Version: 1.0\r\n"; 1687 print_hdr $s, "Content-Type", qq{multipart/$self->{'multipart'};\r\n\tboundary="$self->{'boundary'}"}; 1688 1689 print $s "\r\n"; 1690 $self->{'socket'}->stop_logging("... message data skipped ...") if ($self->{'debug'} and $self->{'debug_level'} <= 2); 1691 1692 print $s "This message is in MIME format. Since your mail reader does not understand\r\n" 1693 . "this format, some or all of this message may not be legible.\r\n" 1694 . "\r\n--$self->{'boundary'}\r\n"; 1695 1696 return $self; 1697} 1698 1699sub Connected { 1700 my $self = shift(); 1701 return unless exists $self->{'socket'} and $self->{'socket'}; 1702 my $s = $self->{'socket'}; 1703 return $s->opened(); 1704} 1705 1706 1707 1708=head2 MailMsg 1709 1710 MailMsg([from [, replyto [, to [, smtp [, subject [, headers]]]]]], message) 1711 MailMsg({[from => "somebody@somewhere.com"] 1712 [, to => "else@nowhere.com"] [...], msg => "Message"}) 1713 1714Sends a message. If a mail in $sender is opened it gets closed 1715and a new mail is created and sent. $sender is then closed. 1716If some parameters are unspecified or empty, it uses 1717the parameters passed to the "C<$Sender=new Mail::Sender(...)>"; 1718 1719See C<new Mail::Sender> for info about the parameters. 1720 1721The module was made so that you could create an object initialized with 1722all the necesary options and then send several messages without need to 1723specify the SMTP server and others each time. If you need to send only 1724one mail using MailMsg() or MailFile() you do not have to create a named 1725object and then call the method. You may do it like this : 1726 1727 (new Mail::Sender)->MailMsg({smtp => 'mail.company.com', ...}); 1728 1729Returns ref to the Mail::Sender object if successful. 1730 1731=cut 1732 1733sub MailMsg { 1734 my $self = shift; 1735 my $msg; 1736 local $_; 1737 if (ref $_[0] eq 'HASH') { 1738 my $hash=$_[0]; 1739 $msg=$hash->{'msg'}; 1740 } else { 1741 $msg = pop; 1742 } 1743 return $self->Error(NOMSG) unless $msg; 1744 1745 if (ref $self->Open(@_) 1746 and 1747 ref $self->SendEnc($msg) 1748 and 1749 ref $self->Close() 1750 ) { 1751 return $self 1752 } else { 1753 return $self->{'error'} 1754 } 1755} 1756 1757 1758=head2 MailFile 1759 1760 MailFile([from [, replyto [, to [, smtp [, subject [, headers]]]]]], message, file(s)) 1761 MailFile({[from => "somebody@somewhere.com"] 1762 [, to => "else@nowhere.com"] [...], 1763 msg => "Message", file => "File"}) 1764 1765Sends one or more files by mail. If a mail in $sender is opened it gets closed 1766and a new mail is created and sent. $sender is then closed. 1767If some parameters are unspecified or empty, it uses 1768the parameters passed to the "C<$Sender=new Mail::Sender(...)>"; 1769 1770The C<file> parameter may be a "filename", a "list, of, file, names" or a \@list_of_file_names. 1771 1772see C<new Mail::Sender> for info about the parameters. 1773 1774Just keep in mind that parameters like ctype, charset and encoding 1775will be used for the attached file, not the body of the message. 1776If you want to specify those parameters for the body you have to use 1777b_ctype, b_charset and b_encoding. Sorry. 1778 1779Returns ref to the Mail::Sender object if successful. 1780 1781=cut 1782 1783sub MailFile { 1784 my $self = shift; 1785 my $msg; 1786 local $_; 1787 my ($file, $desc, $haddesc,$ctype,$charset,$encoding); 1788 my @files; 1789 my $hash; 1790 if (ref $_[0] eq 'HASH') { 1791 $hash = {%{$_[0]}}; # make a copy 1792 1793 $msg = delete $hash->{'msg'}; 1794 1795 $file=delete $hash->{'file'}; 1796 1797 $desc=delete $hash->{'description'}; $haddesc = 1 if defined $desc; 1798 1799 $ctype=delete $hash->{'ctype'}; 1800 1801 $charset=delete $hash->{'charset'}; 1802 1803 $encoding=delete $hash->{'encoding'}; 1804 } else { 1805 $desc=pop if ($#_ >=2); $haddesc = 1 if defined $desc; 1806 $file = pop; 1807 $msg = pop; 1808 } 1809 return $self->Error(NOMSG) unless $msg; 1810 return $self->Error(NOFILE) unless $file; 1811 1812 if (ref $file eq 'ARRAY') { 1813 @files=@$file; 1814 } elsif ($file =~ /,/) { 1815 @files=split / *, */,$file; 1816 } else { 1817 @files = ($file); 1818 } 1819 foreach $file (@files) { 1820 return $self->Error(FILENOTFOUND($file)) unless ($file =~ /^&/ or -e $file); 1821 } 1822 1823 ref $self->OpenMultipart($hash ? $hash : @_) 1824 and 1825 ref $self->Body( 1826 $self->{'b_charset'}||$self->{'charset'}, 1827 $self->{'b_encoding'}, 1828 $self->{'b_ctype'} 1829 ) 1830 and 1831 $self->SendEnc($msg) 1832 or return $self->{'error'}; 1833 1834 $Mail::Sender::Error = ''; 1835 foreach $file (@files) { 1836 my $cnt; 1837 my $filename = basename $file; 1838 my $ctype = $ctype || GuessCType $filename, $file; 1839 my $encoding = $encoding || ($ctype =~ m#^text/#i ? 'Quoted-printable' : 'Base64'); 1840 1841 $desc = $filename unless (defined $haddesc); 1842 1843 $self->Part({encoding => $encoding, 1844 disposition => (defined $self->{'disposition'} ? $self->{'disposition'} : "attachment; filename=\"$filename\""), 1845 ctype => ($ctype =~ /;\s*name(?:\*(?:0\*?)?)?=/ ? $ctype : "$ctype; name=\"$filename\"") . (defined $charset ? "; charset=$charset" : ''), 1846 description => $desc}); 1847 1848 my $code = $self->{'code'}; 1849 1850 my $FH = new FileHandle; 1851 open $FH, "<", $file 1852 or return $self->Error(FILECANTREAD($file)); 1853 binmode $FH unless $ctype =~ m#^text/#i and $encoding =~ /Quoted[_\-]print|Base64/i; 1854 my $s; 1855 $s = $self->{'socket'}; 1856 my $mychunksize = $chunksize; 1857 $mychunksize = $chunksize64 if defined $self->{'chunk_size'}; 1858 while (read $FH, $cnt, $mychunksize) { 1859 $cnt = &$code($cnt); 1860 $cnt =~ s/^\.\././ unless $self->{'_had_newline'}; 1861 print $s $cnt; 1862 $self->{'_had_newline'} = ($cnt =~ /[\n\r]$/); 1863 } 1864 close $FH; 1865 } 1866 1867 if ($Mail::Sender::Error eq '') { 1868 undef $Mail::Sender::Error; 1869 } else { 1870 chomp $Mail::Sender::Error; 1871 } 1872 return $self->Close; 1873} 1874 1875 1876 1877=head2 Send 1878 1879 Send(@strings) 1880 1881Prints the strings to the socket. Doesn't add any end-of-line characters. 1882Doesn't encode the data! You should use C<\r\n> as the end-of-line! 1883 1884UNLESS YOU ARE ABSOLUTELY SURE YOU KNOW WHAT YOU ARE DOING 1885YOU SHOULD USE SendEnc() INSTEAD! 1886 1887Returns the object if successful. 1888 1889=cut 1890 1891sub Send { 1892 my $self = shift; 1893 my $s; 1894 $s = $self->{'socket'}; 1895 print $s @_; 1896 return $self; 1897} 1898 1899=head2 SendLine 1900 1901 SendLine(@strings) 1902 1903Prints the strings to the socket. Adds the end-of-line character at the end. 1904Doesn't encode the data! You should use C<\r\n> as the end-of-line! 1905 1906UNLESS YOU ARE ABSOLUTELY SURE YOU KNOW WHAT YOU ARE DOING 1907YOU SHOULD USE SendLineEnc() INSTEAD! 1908 1909Returns the object if successful. 1910 1911=cut 1912 1913sub SendLine { 1914 my $self = shift; 1915 my $s = $self->{'socket'}; 1916 print $s (@_,"\x0D\x0A"); 1917 return $self; 1918} 1919 1920=head2 print 1921 1922Alias to SendEnc(). 1923 1924Keep in mind that you can't write : 1925 1926 print $sender "..."; 1927 1928you have to use 1929 1930 $sender->print("..."); 1931 1932If you want to be able to print into the message as if it was a normal file handle take a look at C<GetHandle>() 1933 1934=head2 SendEnc 1935 1936 SendEnc(@strings) 1937 1938Prints the strings to the socket. Doesn't add any end-of-line characters. 1939 1940Encodes the text using the selected encoding (none/Base64/Quoted-printable) 1941 1942Returns the object if successful. 1943 1944=cut 1945 1946sub SendEnc { 1947 my $self = shift; 1948 local $_; 1949 my $code = $self->{'code'}; 1950 $self->{'code'}= $code = enc_plain($self->{'charset'}) 1951 unless defined $code; 1952 my $s; 1953 $s = $self->{'socket'} 1954 or return $self->Error(NOTCONNECTED); 1955 if (defined $self->{'chunk_size'}) { 1956 my $str; 1957 my $chunk = $self->{'chunk_size'}; 1958 if (defined $self->{'_buffer'}) { 1959 $str=(join '',($self->{'_buffer'},@_)); 1960 } else { 1961 $str=join '',@_; 1962 } 1963 my ($len,$blen); 1964 $len = length $str; 1965 if (($blen=($len % $chunk)) >0) { 1966 $self->{'_buffer'} = substr($str,($len-$blen)); 1967 print $s (&$code(substr( $str,0,$len-$blen))); 1968 } else { 1969 delete $self->{'_buffer'}; 1970 print $s (&$code($str)); 1971 } 1972 } else { 1973 my $encoded = &$code(join('',@_)); 1974 $encoded =~ s/^\.\././ unless $self->{'_had_newline'}; 1975 print $s $encoded; 1976 $self->{'_had_newline'} = ($_[-1] =~ /[\n\r]$/); 1977 } 1978 return $self; 1979} 1980 1981sub print;*print = \&SendEnc; 1982 1983=head2 SendLineEnc 1984 1985 SendLineEnc(@strings) 1986 1987Prints the strings to the socket and adds the end-of-line character at the end. 1988Encodes the text using the selected encoding (none/Base64/Quoted-printable). 1989 1990Do NOT mix up /Send(Line)?(Ex)?/ and /Send(Line)?Enc/! SendEnc does some buffering 1991necessary for correct Base64 encoding, and /Send(Ex)?/ is not aware of that! 1992 1993Usage of /Send(Line)?(Ex)?/ in non xBIT parts not recommended. 1994Using C<Send(encode_base64($string))> may work, but more likely it will not! 1995In particular if you use several such to create one part, 1996the data is very likely to get crippled. 1997 1998Returns the object if successful. 1999 2000=cut 2001 2002sub SendLineEnc { 2003 push @_, "\r\n"; 2004 goto &SendEnc; 2005} 2006 2007=head2 SendEx 2008 2009 SendEx(@strings) 2010 2011Prints the strings to the socket. Doesn't add any end-of-line characters. 2012Changes all end-of-lines to C<\r\n>. Doesn't encode the data! 2013 2014UNLESS YOU ARE ABSOLUTELY SURE YOU KNOW WHAT YOU ARE DOING 2015YOU SHOULD USE SendEnc() INSTEAD! 2016 2017Returns the object if successful. 2018 2019=cut 2020 2021sub SendEx { 2022 my $self = shift; 2023 my $s; 2024 $s = $self->{'socket'} 2025 or return $self->Error(NOTCONNECTED); 2026 my $str;my @data = @_; 2027 foreach $str (@data) { 2028 $str =~ s/(?:\x0D\x0A?|\x0A)/\x0D\x0A/sg; 2029 $str =~ s/^\./../mg; 2030 } 2031 print $s @data; 2032 return $self; 2033} 2034 2035=head2 SendLineEx 2036 2037 SendLineEx(@strings) 2038 2039Prints the strings to the socket. Adds an end-of-line character at the end. 2040Changes all end-of-lines to C<\r\n>. Doesn't encode the data! 2041 2042UNLESS YOU ARE ABSOLUTELY SURE YOU KNOW WHAT YOU ARE DOING 2043YOU SHOULD USE SendEnc() INSTEAD! 2044 2045Returns the object if successful. 2046 2047=cut 2048 2049sub SendLineEx { 2050 push @_, "\r\n"; 2051 goto &SendEx; 2052} 2053 2054 2055=head2 Part 2056 2057 Part( I<description>, I<ctype>, I<encoding>, I<disposition> [, I<content_id> [, I<msg>]]); 2058 Part( {[description => "desc"], [ctype => "content/type"], [encoding => "..."], 2059 [disposition => "..."], [content_id => "..."], [msg => ...]}); 2060 2061Prints a part header for the multipart message and (if specified) the contents. 2062The undefined or empty variables are ignored. 2063 2064=over 2 2065 2066=item description 2067 2068The title for this part. 2069 2070=item ctype 2071 2072the content type (MIME type) of this part. May contain some other 2073parameters, such as B<charset> or B<name>. 2074 2075Defaults to "application/octet-stream". 2076 2077Since 0.8.00 you may use even "multipart/..." types. Such a multipart part should be 2078closed by a call to $sender->EndPart($ctype). 2079 2080 ... 2081 $sender->Part({ctype => "multipart/related", ...}); 2082 $sender->Part({ctype => 'text/html', ...}); 2083 $sender->Attach({file => 'some_image.gif', content_id => 'foo', ...}); 2084 $sender->EndPart("multipart/related"); 2085 ... 2086 2087Please see the examples below. 2088 2089=item encoding 2090 2091the encoding used for this part of message. Eg. Base64, Uuencode, 7BIT 2092... 2093 2094Defaults to "7BIT". 2095 2096=item disposition 2097 2098This parts disposition. Eg: 'attachment; filename="send.pl"'. 2099 2100Defaults to "attachment". If you specify "none" or "", the 2101Content-Disposition: line will not be included in the headers. 2102 2103=item content_id 2104 2105The content id of the part, used in multipart/related. 2106If not specified, the header is not included. 2107 2108=item msg 2109 2110The content of the part. You do not have to specify the content here, you may use SendEnc() 2111to add content to the part. 2112 2113=item charset 2114 2115The charset of the part. 2116 2117=back 2118 2119Returns the Mail::Sender object if successful, negative error code if not. 2120 2121=cut 2122 2123sub Part { 2124 my $self = shift; 2125 local $_; 2126 if (! $self->{'multipart'}) { return $self->Error(NOTMULTIPART("\$sender->Part()")); } 2127 $self->EndPart(); 2128 2129 my ($description, $ctype, $encoding, $disposition, $content_id, $msg, $charset); 2130 if (ref $_[0] eq 'HASH') { 2131 my $hash=$_[0]; 2132 $description=$hash->{'description'}; 2133 $ctype=$hash->{'ctype'}; 2134 $encoding=$hash->{'encoding'}; 2135 $disposition=$hash->{'disposition'}; 2136 $content_id = $hash->{'content_id'}; 2137 $msg = $hash->{'msg'}; 2138 $charset = $hash->{'charset'}; 2139 } else { 2140 ($description, $ctype, $encoding, $disposition, $content_id, $msg) = @_; 2141 } 2142 2143 $ctype = "application/octet-stream" unless defined $ctype; 2144 $disposition = "attachment" unless defined $disposition; 2145 $encoding="7BIT" unless defined $encoding; 2146 $self->{'encoding'} = $encoding; 2147 if (defined $charset and $charset and $ctype !~ /charset=/i) { 2148 $ctype .= qq{; charset="$charset"} 2149 } elsif (!defined $charset and $ctype =~ /charset="([^"]+)"/) { 2150 $charset = $1; 2151 } 2152 2153 my $s; 2154 $s = $self->{'socket'} 2155 or return $self->Error(NOTCONNECTED); 2156 2157 undef $self->{'chunk_size'}; 2158 if ($encoding =~ /Base64/i) { 2159 $self->{'code'} = enc_base64($charset); 2160 $self->{'chunk_size'} = $enc_base64_chunk; 2161 } elsif ($encoding =~ /Quoted[_\-]print/i) { 2162 $self->{'code'} = enc_qp($charset); 2163 } else { 2164 $self->{'code'} = enc_plain($charset); 2165 } 2166 2167 $self->{'socket'}->start_logging() if ($self->{'debug'} and $self->{'debug_level'} == 3); 2168 2169 if ($ctype =~ m{^multipart/}i) { 2170 $self->{'_part'}+=2; 2171 print $s "Content-Type: $ctype; boundary=\"Part-$self->{'boundary'}_$self->{'_part'}\"\r\n\r\n"; 2172 } else { 2173 $self->{'_part'}++; 2174 print $s "Content-Type: $ctype\r\n"; 2175 if ($description) {print $s "Content-Description: $description\r\n";} 2176 print $s "Content-Transfer-Encoding: $encoding\r\n"; 2177 print $s "Content-Disposition: $disposition\r\n" unless $disposition eq '' or uc($disposition) eq 'NONE'; 2178 print $s "Content-ID: <$content_id>\r\n" if (defined $content_id); 2179 print $s "\r\n"; 2180 2181 $self->{'socket'}->stop_logging("... data skipped ...") if ($self->{'debug'} and $self->{'debug_level'} == 3); 2182 $self->SendEnc($msg) if defined $msg; 2183 } 2184 2185 #$self->{'_had_newline'} = 1; 2186 return $self; 2187} 2188 2189 2190=head2 Body 2191 2192 Body([charset [, encoding [, content-type]]]); 2193 Body({charset => '...', encoding => '...', ctype => '...', msg => '...'); 2194 2195Sends the head of the multipart message body. You can specify the 2196charset and the encoding. Default is "US-ASCII","7BIT",'text/plain'. 2197 2198If you pass undef or zero as the parameter, this function uses the default 2199value: 2200 2201 Body(0,0,'text/html'); 2202 2203Returns the Mail::Sender object if successful, negative error code if not. 2204You should NOT use this method in single part messages, that is, it works after OpenMultipart(), 2205but has no meaning after Open()! 2206 2207=cut 2208 2209sub Body { 2210 my $self = shift; 2211 if (! $self->{'multipart'}) { 2212 # ->Body() has no meanin in singlepart messages 2213 if (@_) { 2214 # they called it with some parameters? Too late for them, let's scream. 2215 return $self->Error(NOTMULTIPART("\$sender->Body()")); 2216 } else { 2217 # $sender->Body() ... OK, let's ignore it. 2218 return $self; 2219 } 2220 } 2221 my $hash; 2222 $hash = shift() if (ref $_[0] eq 'HASH'); 2223 my $charset = shift || $hash->{'charset'} || 'US-ASCII'; 2224 my $encoding = shift || $hash->{'encoding'} || $self->{'encoding'} || '7BIT'; 2225 my $ctype = shift || $hash->{'ctype'} || $self->{'ctype'} || 'text/plain'; 2226 2227 $ctype .= qq{; charset="$charset"} 2228 unless $ctype =~ /charset=/i; 2229 2230 $self->{'encoding'} = $encoding; 2231 $self->{'ctype'} = $ctype; 2232 2233 $self->Part("Mail message body", $ctype, 2234 $encoding, 'inline', undef, $hash->{'msg'}); 2235 return $self; 2236} 2237 2238=head2 SendFile 2239 2240Alias to Attach() 2241 2242=head2 Attach 2243 2244 Attach( I<description>, I<ctype>, I<encoding>, I<disposition>, I<file>); 2245 Attach( { [description => "desc"] , [ctype => "ctype"], [encoding => "encoding"], 2246 [disposition => "disposition"], file => "file"}); 2247 2248 Sends a file as a separate part of the mail message. Only in multipart mode. 2249 2250=over 2 2251 2252=item description 2253 2254The title for this part. 2255 2256=item ctype 2257 2258the content type (MIME type) of this part. May contain some other 2259parameters, such as B<charset> or B<name>. 2260 2261Defaults to "application/octet-stream". 2262 2263=item encoding 2264 2265the encoding used for this part of message. Eg. Base64, Uuencode, 7BIT 2266... 2267 2268Defaults to "Base64". 2269 2270=item disposition 2271 2272This parts disposition. Eg: 'attachment; filename="send.pl"'. If you use 2273'attachment; filename=*' the * will be replaced by the respective names 2274of the sent files. 2275 2276Defaults to "attachment; filename=*". If you do not want to include this header use 2277"" as the value. 2278 2279=item file 2280 2281The name of the file to send or a 'list, of, names' or a 2282['reference','to','a','list','of','filenames']. Each file will be sent as 2283a separate part. 2284 2285Please keep in mind that if you pass a string as this parameter the module 2286will split it on commas! If your filenames may contain commas and you 2287want to be sure they are sent correctly you have to use the reference to array 2288format: 2289 2290 file => [ $filename], 2291 2292=item content_id 2293 2294The content id of the message part. Used in multipart/related. 2295 2296 Special values: 2297 "*" => the name of the file 2298 "#" => autoincremented number (starting from 0) 2299 2300=back 2301 2302Returns the Mail::Sender object if successful, negative error code if not. 2303 2304=cut 2305 2306sub SendFile { 2307 my $self = shift; 2308 local $_; 2309 if (! $self->{'multipart'}) { return $self->Error(NOTMULTIPART("\$sender->SendFile()")); } 2310 if (! $self->{'socket'}) { return $self->Error(NOTCONNECTED); } 2311 2312 my ($description, $ctype, $encoding, $disposition, $file, $content_id, @files); 2313 if (ref $_[0] eq 'HASH') { 2314 my $hash=$_[0]; 2315 $description=$hash->{'description'}; 2316 $ctype=$hash->{'ctype'}; 2317 $encoding=$hash->{'encoding'}; 2318 $disposition=$hash->{'disposition'}; 2319 $file=$hash->{'file'}; 2320 $content_id=$hash->{'content_id'}; 2321 } else { 2322 ($description, $ctype, $encoding, $disposition, $file, $content_id) = @_; 2323 } 2324 return ($self->{'error'}=NOFILE) unless $file; 2325 2326 if (ref $file eq 'ARRAY') { 2327 @files=@$file; 2328 } elsif ($file =~ /,/) { 2329 @files=split / *, */,$file; 2330 } else { 2331 @files = ($file); 2332 } 2333 foreach $file (@files) { 2334 return $self->Error(FILENOTFOUND($file)) unless ($file =~ /^&/ or -e $file); 2335 } 2336 2337 $disposition = "attachment; filename=*" unless defined $disposition; 2338 $encoding='Base64' unless $encoding; 2339 2340 my $s=$self->{'socket'}; 2341 2342 if ($self->{'_buffer'}) { 2343 my $code = $self->{'code'}; 2344 print $s (&$code($self->{'_buffer'})); 2345 delete $self->{'_buffer'}; 2346 } 2347 2348 my $code; 2349 if ($encoding =~ /Base64/i) { 2350 $code = enc_base64(); 2351 } elsif ($encoding =~ /Quoted[_\-]print/i) { 2352 $code = enc_qp(); 2353 } else { 2354 $code = enc_plain(); 2355 } 2356 $self->{'code'}=$code; 2357 2358 foreach $file (@files) { 2359 $self->EndPart();$self->{'_part'}++; 2360 $self->{'encoding'} = $encoding; 2361 my $cnt=''; 2362 my $name = basename $file; 2363 my $fctype = $ctype ? $ctype : GuessCType $name, $file; 2364 $self->{'ctype'} = $fctype; 2365 2366 $self->{'socket'}->start_logging() if ($self->{'debug'} and $self->{'debug_level'} == 3); 2367 2368 if ($fctype =~ /;\s*name(?:\*(?:0\*?)?)?=/) { # looking for name=, name*=, name*0= or name*0*= 2369 print $s ("Content-Type: $fctype\r\n"); 2370 } else { 2371 print $s ("Content-Type: $fctype; name=\"$name\"\r\n"); 2372 } 2373 2374 if ($description) {print $s ("Content-Description: $description\r\n");} 2375 print $s ("Content-Transfer-Encoding: $encoding\r\n"); 2376 2377 if ($disposition =~ /^(.*)filename=\*(.*)$/i) { 2378 print $s ("Content-Disposition: ${1}filename=\"$name\"$2\r\n"); 2379 } elsif ($disposition and uc($disposition) ne 'NONE') { 2380 print $s ("Content-Disposition: $disposition\r\n"); 2381 } 2382 2383 if ($content_id) { 2384 if ($content_id eq '*') { 2385 print $s ("Content-ID: <$name>\r\n"); 2386 } elsif ($content_id eq '#') { 2387 print $s ("Content-ID: <id".$self->{'idcounter'}++.">\r\n"); 2388 } else { 2389 print $s ("Content-ID: <$content_id>\r\n"); 2390 } 2391 } 2392 print $s "\r\n"; 2393 2394 $self->{'socket'}->stop_logging("... data skipped ...") if ($self->{'debug'} and $self->{'debug_level'} == 3); 2395 2396 my $FH = new FileHandle; 2397 open $FH, "<", $file 2398 or return $self->Error(FILECANTREAD($file)); 2399 binmode $FH unless $fctype =~ m#^text/#i and $encoding =~ /Quoted[_\-]print|Base64/i; 2400 2401 my $mychunksize = $chunksize; 2402 $mychunksize = $chunksize64 if lc($encoding) eq "base64"; 2403 my $s; 2404 $s = $self->{'socket'} 2405 or return $self->Error(NOTCONNECTED); 2406 while (read $FH, $cnt, $mychunksize) { 2407 print $s (&$code($cnt)); 2408 } 2409 close $FH; 2410 } 2411 2412 return $self; 2413} 2414 2415sub Attach; *Attach = \&SendFile; 2416 2417=head2 EndPart 2418 2419 $sender->EndPart($ctype); 2420 2421Closes a multipart part. 2422 2423If the $ctype is not present or evaluates to false, only the current SIMPLE part is closed! 2424Don't do that unless you are really sure you know what you are doing. 2425 2426It's best to always pass to the ->EndPart() the content type of the corresponding ->Part(). 2427 2428=cut 2429 2430sub EndPart { 2431 my $self = shift; 2432 return unless $self->{'_part'}; 2433 my $end = shift(); 2434 my $s; 2435 my $LN = "\x0D\x0A"; 2436 $s = $self->{'socket'} 2437 or return $self->Error(NOTCONNECTED); 2438 # flush the buffer (if it contains anything) 2439 if ($self->{'_buffer'}) { # used only for base64 2440 my $code = $self->{'code'}; 2441 if (defined $code) { 2442 print $s (&$code($self->{'_buffer'})); 2443 } else { 2444 print $s ($self->{'_buffer'}); 2445 } 2446 delete $self->{'_buffer'}; 2447 } 2448 if ($self->{'_had_newline'}) { 2449 $LN = ''; 2450 } else { 2451 print $s "=" if !$self->{'bypass_outlook_bug'} and $self->{'encoding'} =~ /Quoted[_\-]print/i; # make sure we do not add a newline 2452 } 2453 2454 $self->{'socket'}->start_logging() if ($self->{'debug'} and $self->{'debug_level'} == 3); 2455 2456 if ($self->{'_part'}>1) { # end of a subpart 2457 print $s "$LN--Part-$self->{'boundary'}_$self->{'_part'}", 2458 ($end ? "--" : ()), 2459 "\r\n"; 2460 } else { 2461 print $s "$LN--$self->{'boundary'}", 2462 ($end ? "--" : ()), 2463 "\r\n"; 2464 } 2465 2466 $self->{'_part'}--; 2467 $self->{'code'} = enc_plain($self->{'charset'}); 2468 $self->{'encoding'} = ''; 2469 return $self; 2470} 2471 2472=head2 Close 2473 2474 $sender->Close; 2475 $sender->Close(1); 2476 2477Close and send the email message. If you pass a true value to the method the connection will be closed even 2478if the "keepconnection" was specified. You should only keep the connection open if you plan to send another 2479message immediately. And you should not keep it open for hundreds of emails even if you do send them all in a row. 2480 2481This method should be called automatically when destructing the object, but you should not rely on it. If you want to be sure 2482your message WAS processed by the SMTP server you SHOULD call Close() explicitely. 2483 2484Returns the Mail::Sender object if successful, negative error code if not, zero if $sender was not connected at all. 2485The zero usually means that the Open/OpenMultipart failed and you did not test its return value. 2486 2487=cut 2488 2489sub Close { 2490 my $self = shift; 2491 local $_; 2492 my $s = $self->{'socket'}; 2493 return 0 unless $s; 2494 2495 if ($self->{'_data'}) { 2496 # flush the buffer (if it contains anything) 2497 if ($self->{'_buffer'}) { 2498 my $code = $self->{'code'}; 2499 if (defined $code) { 2500 print $s (&$code($self->{'_buffer'})); 2501 } else { 2502 print $s ($self->{'_buffer'}); 2503 } 2504 delete $self->{'_buffer'}; 2505 } 2506 2507 if ($self->{'_part'}) { 2508 while ($self->{'_part'}) { 2509 $self->EndPart(1); 2510 } 2511 } 2512 2513 $self->{'socket'}->start_logging() if ($self->{'debug'}); 2514 print $s "\r\n.\r\n" ; 2515 $self->{'_data'} = 0; 2516 $_ = get_response($s); if (/^[45]\d* (.*)$/) { return $self->Error(TRANSFAILED($1)); } 2517 $self->{message_response} = $_; 2518 } 2519 2520 delete $self->{'encoding'}; 2521 delete $self->{'ctype'}; 2522 2523 if ($_[0] or !$self->{'keepconnection'}) { 2524 $_ = send_cmd $s, "QUIT"; 2525 if (!/^[123]/) { return $self->Error(COMMERROR($_)); } 2526 close $s; 2527 delete $self->{'socket'}; 2528 delete $self->{'debug'}; 2529 } 2530 return $self; 2531} 2532 2533=head2 Cancel 2534 2535 $sender->Cancel; 2536 2537Cancel an opened message. 2538 2539SendFile and other methods may set $sender->{'error'}. 2540In that case "undef $sender" calls C<$sender->>Cancel not C<$sender->>Close!!! 2541 2542Returns the Mail::Sender object if successful, negative error code if not. 2543 2544=cut 2545 2546sub Cancel { 2547 my $self = shift; 2548 my $s; 2549 $s = $self->{'socket'} 2550 or return $self->Error(NOTCONNECTED); 2551 close $s; 2552 delete $self->{'socket'}; 2553 delete $self->{'error'}; 2554 return $self; 2555} 2556 2557sub DESTROY { 2558 return if ref($_[0]) ne 'Mail::Sender'; 2559 my $self = shift; 2560 if (defined $self->{'socket'}) { 2561 delete $self->{'keepconnection'}; 2562 $self->Close; 2563 } 2564} 2565 2566sub MessageID { 2567 my $from = shift; 2568 my ($sec,$min,$hour,$mday,$mon,$year) 2569 = gmtime(time); 2570 $mon++;$year+=1900; 2571 2572 return sprintf "<%04d%02d%02d_%02d%02d%02d_%06d.%s>", 2573 $year,$mon,$mday,$hour,$min,$sec,rand(100000), 2574 $from; 2575} 2576 2577=head2 QueryAuthProtocols 2578 2579 @protocols = $sender->QueryAuthProtocols(); 2580 @protocols = $sender->QueryAuthProtocols( $smtpserver); 2581 2582 2583Queryies the server (specified either in the default options for Mail::Sender, 2584the "new Mail::Sender" command or as a parameter to this method for 2585the authentication protocols it supports. 2586 2587=cut 2588 2589sub QueryAuthProtocols { 2590 my $self = shift; 2591 local $_; 2592 if (!defined $self) { 2593 croak "Mail::Sender::QueryAuthProtocols() called without any parameter!"; 2594 } elsif (ref $self) { # $sender->QueryAuthProtocols() or $sender->QueryAuthProtocols('the.server.com) 2595 if ($self->{'socket'}) { # the user did not Close() or Cancel() the previous mail 2596 die "You forgot to close the mail before calling QueryAuthProtocols!\n" 2597 } 2598 if (@_) { 2599 $self->{'smtp'} = shift(); 2600 $self->{'smtp'} =~ s/^\s+//g; # remove spaces around $smtp 2601 $self->{'smtp'} =~ s/\s+$//g; 2602 $self->{'smtpaddr'} = inet_aton($self->{'smtp'}); 2603 if (!defined($self->{'smtpaddr'})) { return $self->Error(HOSTNOTFOUND($self->{'smtp'})); } 2604 $self->{'smtpaddr'} = $1 if ($self->{'smtpaddr'} =~ /(.*)/s); # Untaint 2605 } 2606 } elsif ($self =~ /::/) { # Mail::Sender->QueryAuthProtocols('the.server.com') 2607 croak "Mail::Sender->QueryAuthProtocols() called without any parameter!" 2608 if ! @_; 2609 $self = new Mail::Sender {smtp => $_[0]}; 2610 return unless ref $self; 2611 } else { # Mail::Sender::QueryAuthProtocols('the.server.com') 2612 $self = new Mail::Sender {smtp => $self}; 2613 return unless ref $self; 2614 } 2615 2616 return $self->Error(NOSERVER) unless defined $self->{'smtp'}; 2617 2618 my $s = IO::Socket::INET->new( 2619 PeerHost => $self->{'smtp'}, 2620 PeerPort => $self->{'port'}, 2621 Proto => "tcp", 2622 Timeout => $self->{'timeout'} || 120, 2623 ) or return $self->Error(CONNFAILED); 2624 2625 $s->autoflush(1); 2626 2627 $_ = get_response($s); if (not $_ or !/^[123]/) { return $self->Error(SERVNOTAVAIL($_)); } 2628 $self->{'server'} = substr $_, 4; 2629 2630 { my $res = $self->say_helo($s); 2631 return $res if $res; 2632 } 2633 2634 $_ = send_cmd $s, "QUIT"; 2635 close $s; 2636 delete $self->{'socket'}; 2637 2638 if (wantarray) { 2639 return keys %{$self->{'auth_protocols'}}; 2640 } else { 2641 my $key = each %{$self->{'auth_protocols'}}; 2642 return $key; 2643 } 2644} 2645 2646sub printAuthProtocols { 2647 print "$_[1] supports: ",join(", ", Mail::Sender->QueryAuthProtocols($_[1] || 'localhost')),"\n"; 2648} 2649 2650sub TestServer { 2651 my $self = shift; 2652 local $_; 2653 if (!defined $self) { 2654 croak "Mail::Sender::TestServer() called without any parameter!"; 2655 } elsif (ref $self) { # $sender->TestServer() or $sender->TestServer('the.server.com) 2656 if ($self->{'socket'}) { # the user did not Close() or Cancel() the previous mail 2657 die "You forgot to close the mail before calling TestServer!\n" 2658 } 2659 if (@_) { 2660 $self->{'smtp'} = shift(); 2661 $self->{'smtp'} =~ s/^\s+//g; # remove spaces around $smtp 2662 $self->{'smtp'} =~ s/\s+$//g; 2663 $self->{'smtpaddr'} = inet_aton($self->{'smtp'}); 2664 if (!defined($self->{'smtpaddr'})) { return $self->Error(HOSTNOTFOUND($self->{'smtp'})); } 2665 $self->{'smtpaddr'} = $1 if ($self->{'smtpaddr'} =~ /(.*)/s); # Untaint 2666 } 2667 $self->{'on_errors'} = 'die'; 2668 } elsif ($self =~ /::/) { # Mail::Sender->TestServer('the.server.com') 2669 croak "Mail::Sender->TestServer() called without any parameter!" 2670 if ! @_; 2671 $self = new Mail::Sender {smtp => $_[0], on_errors => 'die'}; 2672 return unless ref $self; 2673 } else { # Mail::Sender::QueryAuthProtocols('the.server.com') 2674 $self = new Mail::Sender {smtp => $self, on_errors => 'die'}; 2675 return unless ref $self; 2676 } 2677 2678 return $self->Error(NOSERVER) unless defined $self->{'smtp'}; 2679# if (!defined($self->{'smtpaddr'})) { return $self->Error(HOSTNOTFOUND($self->{'smtp'})); } 2680 2681 if (exists $self->{'on_errors'} and (!defined($self->{'on_errors'}) or $self->{'on_errors'} eq 'undef')) { 2682 return $self->Connect() and $self->Close() and 1; 2683 } elsif (exists $self->{'on_errors'} and $self->{'on_errors'} eq 'die') { 2684 $self->Connect(); 2685 $self->Close(); 2686 return 1; 2687 } else { 2688 my $res = $self->Connect(); 2689 return $res unless ref $res; 2690 $res = $self->Close(); 2691 return $res unless ref $res; 2692 return $self; 2693 } 2694} 2695 2696#====== Debuging bazmecks 2697 2698$debug_code = <<'*END*'; 2699package Mail::Sender::DBIO; 2700use IO::Handle; 2701use Tie::Handle; 2702@Mail::Sender::DBIO::ISA = qw(Tie::Handle); 2703 2704sub SOCKET () {0} 2705sub LOG () {1} 2706sub ENDLINE () {2} 2707sub CLOSELOG () {3} 2708sub OFF () {4} 2709 2710sub TIEHANDLE { 2711 my ($pkg,$socket,$debughandle, $mayCloseLog) = @_; 2712 return bless [$socket,$debughandle,1, $mayCloseLog,0], $pkg; 2713} 2714 2715sub PRINT { 2716 my $self = shift; 2717 my $text = join(($\ || ''), @_); 2718 $self->[SOCKET]->print($text); 2719 return if $self->[OFF]; 2720 $text =~ s/\x0D\x0A(?=.)/\x0D\x0A<< /g; 2721 $text = "<< ".$text if $self->[ENDLINE]; 2722 $self->[ENDLINE] = ($text =~ /\x0D\x0A$/); 2723 $self->[LOG]->print($text); 2724} 2725 2726sub READLINE { 2727 my $self = shift(); 2728 my $socket = $self->[SOCKET]; 2729 my $line = <$socket>; 2730 $self->[LOG]->print(">> $line") if defined $line and !$self->[OFF]; 2731 return $line; 2732} 2733 2734sub CLOSE { 2735 my $self = shift(); 2736 $self->[SOCKET]->close(); 2737 $self->[LOG]->close() if $self->[CLOSELOG]; 2738 return $self->[SOCKET]; 2739} 2740 2741sub opened { 2742 our $SOCKET; 2743 local *SOCKET = $_[SOCKET] or return; 2744 $SOCKET->opened(); 2745} 2746 2747use Data::Dumper; 2748sub stop_logging { 2749 my $self = tied(${$_[0]}); 2750 2751#print "stop_logging( ".$self." )\n"; 2752 2753 return if $self->[OFF]; 2754 $self->[OFF] = 1; 2755 2756 my $text = join(($\ || ''), $_[1]) 2757 or return; 2758 $text .= "\x0D\x0A"; 2759 $text =~ s/\x0D\x0A(?=.)/\x0D\x0A<< /g; 2760 $text = "<< ".$text if $self->[ENDLINE]; 2761 $self->[ENDLINE] = ($text =~ /\x0D\x0A$/); 2762 $self->[LOG]->print($text); 2763} 2764 2765sub start_logging { 2766 my $self = tied(${$_[0]}); 2767 $self->[OFF] = 0; 2768} 2769 2770*END* 2771 2772my $pseudo_handle_code = <<'*END*'; 2773package Mail::Sender::IO; 2774use IO::Handle; 2775use Tie::Handle; 2776@Mail::Sender::IO::ISA = qw(Tie::Handle); 2777 2778sub TIEHANDLE { 2779 my ($pkg,$sender) = @_; 2780 return bless [$sender, $sender->{'_part'}], $pkg; 2781} 2782 2783sub PRINT { 2784 my $self = shift; 2785 $self->[0]->SendEnc(@_); 2786} 2787 2788sub PRINTF { 2789 my $self = shift; 2790 my $format = shift; 2791 $self->[0]->SendEnc( sprintf $format, @_); 2792} 2793 2794sub CLOSE { 2795 my $self = shift(); 2796 if ($self->[1]) { 2797 $self->[1]->EndPart(); 2798 } else { 2799 $self->[0]->Close(); 2800 } 2801} 2802*END* 2803 2804=head2 GetHandle 2805 2806Returns a "filehandle" to which you can print the message or file to attach or whatever. 2807The data you print to this handle will be encoded as necessary. Closing this handle closes 2808either the message (for single part messages) or the part. 2809 2810 $sender->Open({...}); 2811 my $handle = $sender->GetHandle(); 2812 print $handle "Hello world.\n" 2813 my ($mday,$mon,$year) = (localtime())[3,4,5]; 2814 printf $handle "Today is %04d/%02d/%02d.", $year+1900, $mon+1, $mday; 2815 close $handle; 2816 2817P.S.: There is a big difference between the handle stored in $sender->{'socket'} and the handle 2818returned by this function ! If you print something to $sender->{'socket'} it will be sent to the server 2819without any modifications, encoding, escaping, ... 2820You should NOT touch the $sender->{'socket'} unless you really really know what you are doing. 2821 2822=cut 2823 2824package Mail::Sender; 2825sub GetHandle { 2826 my $self = shift(); 2827 unless (@Mail::Sender::IO::ISA) { 2828 eval "use Symbol;"; 2829 eval $pseudo_handle_code; 2830 } 2831 my $handle = gensym(); 2832 tie *$handle, 'Mail::Sender::IO', $self; 2833 return $handle; 2834} 2835 2836=head1 FUNCTIONS 2837 2838=head2 GuessCType 2839 2840 $ctype = GuessCType $filename, $filepath; 2841 2842Guesses the content type based on the filename or the file contents. 2843This function is used when you attach a file and do not specify the content type. 2844It is not exported by default! 2845 2846The builtin version uses the filename extension to guess the type. 2847Currently there are only a few extensions defined, you may add other extensions this way: 2848 2849 $Mail::Sender::CTypes{'EXT'} = 'content/type'; 2850 ... 2851 2852The extension has to be in UPPERCASE and will be matched case sensitively. 2853 2854The package now includes three addins improving the guesswork. If you "use" one of them in your script, 2855it replaces the builtin GuessCType() subroutine with a better one: 2856 2857 Mail::Sender::CType::Win32 2858 Win32 only, the content type is read from the registry 2859 Mail::Sender::CType::Ext 2860 any OS, a longer list of extensions from A. Guillaume 2861 Mail::Sender::CType::LWP 2862 any OS, uses LWP::MediaTypes::guess_media_type 2863 2864=head2 ResetGMTdiff 2865 2866 ResetGMTdiff() 2867 2868The module computes the local vs. GMT time difference to include in the timestamps 2869added into the message headers. As the time difference may change due to summer 2870savings time changes you may want to reset the time difference ocassionaly 2871in long running programs. 2872 2873=head1 CONFIG 2874 2875If you create a file named Sender.config in the same directory where 2876Sender.pm resides, this file will be "require"d as soon as you "use 2877Mail::Sender" in your script. Of course the Sender.config MUST "return a 2878true value", that is it has to be succesfully compiled and the last 2879statement must return a true value. You may use this to forbide the use 2880of Mail::Sender to some users. 2881 2882You may define the default settings for new Mail::Sender objects and do 2883a few more things. 2884 2885The default options are stored in hash %Mail::Sender::default. You may 2886use all the options you'd use in C<new>, C<Open>, C<OpenMultipart>, 2887C<MailMsg> or C<MailFile>. 2888 2889 Eg. 2890 %default = ( 2891 smtp => 'mail.yourhost.cz', 2892 from => getlogin.'yourhost.cz', 2893 client => getlogin.'.yourhost.cz' 2894 ); 2895 # of course you will use your own mail server here ! 2896 2897The other options you may set here (or later of course) are 2898$Mail::Sender::SITE_HEADERS, $Mail::Sender::NO_X_MAILER and 2899$Mail::Sender::NO_DATE. (These are plain old scalar variables, there is no 2900function or method for modifying them. Just set them to anything you need.) 2901 2902The $Mail::Sender::SITE_HEADERS may contain headers that will be added 2903to each mail message sent by this script, the $Mail::Sender::NO_X_MAILER 2904disables the header item specifying that the message was sent by 2905Mail::Sender and $Mail::Sender::NO_DATE turns off the Date: header generation. 2906 2907!!! $Mail::Sender::SITE_HEADERS may NEVER end with \r\n !!! 2908 2909If you want to set the $Mail::Sender::SITE_HEADERS for every script sent 2910from your server without your users being able to change it you may use 2911this hack: 2912 2913 $loginname = something_that_identifies_the_user(); 2914 *Mail::Sender::SITE_HEADERS = \"X-Sender: $loginname via $0"; 2915 $Mail::Sender::NO_X_MAILER = 1; 2916 2917You may even "install" your custom function that will be evaluated for 2918each message just before contacting the server. You may change all the 2919options from within as well as stop sending the message. 2920 2921All you have to do is to create a function named SiteHook in 2922Mail::Sender package. This function will get the Mail::Sender object as 2923its first argument. If it returns a TRUE value the message is sent, 2924if it returns FALSE the sending is canceled and the user gets 2925"Site specific error" error message. 2926 2927If you want to give some better error message you may do it like this : 2928 2929 sub SiteHook { 2930 my $self = shift; 2931 if (whatever($self)) { 2932 $self->Error( SITEERROR); 2933 $Mail::Sender::Error = "I don't like this mail"; 2934 return 0 2935 } else { 2936 return 1; 2937 } 2938 } 2939 2940 2941This example will ensure the from address is the users real address : 2942 2943 sub SiteHook { 2944 my $self = shift; 2945 $self->{'fromaddr'} = getlogin.'@yoursite.com'; 2946 $self->{'from'} = getlogin.'@yoursite.com'; 2947 1; 2948 } 2949 2950Please note that at this stage the from address is in two different 2951object properties. 2952 2953$self->{'from'} is the address as it will appear in the mail, that is 2954it may include the full name of the user or any other comment 2955( "Jan Krynicky <jenda@krynicky.cz>" for example), while the 2956$self->{'fromaddr'} is realy just the email address per se and it will 2957be used in conversation with the SMTP server. It must be without 2958comments ("jenda@krynicky.cz" for example)! 2959 2960 2961Without write access to .../lib/Mail/Sender.pm or 2962.../lib/Mail/Sender.config your users will then be unable to get rid of 2963this header. Well ... everything is doable, if they are cheeky enough ... :-( 2964 2965So if you take care of some site with virtual servers for several 2966clients and implement some policy via SiteHook() or 2967$Mail::Sender::SITE_HEADERS search the clients' scripts for "SiteHook" 2968and "SITE_HEADERS" from time to time. To see who's cheating. 2969 2970=head1 AUTHENTICATION 2971 2972If you get a "Local user "xxx@yyy.com" unknown on host "zzz"" message it usually means that 2973your mail server is set up to forbid mail relay. That is it only accepts messages to or from a local user. 2974If you need to be able to send a message with both the sender's and recipient's address remote, you 2975need to somehow authenticate to the server. You may need the help of the mail server's administrator 2976to find out what username and password and/or what authentication protocol are you supposed to use. 2977 2978There are many authentication protocols defined for ESTMP, Mail::Sender natively supports 2979only PLAIN, LOGIN, CRAM-MD5 and NTLM (please see the docs for C<new Mail::Sender>). 2980 2981If you want to know what protocols are supported by your server you may get the list by this: 2982 2983 /tmp# perl -MMail::Sender -e 'Mail::Sender->printAuthProtocols("the.server.com")' 2984 or 2985 c:\> perl -MMail::Sender -e "Mail::Sender->printAuthProtocols('the.server.com')" 2986 2987 2988There is one more way to authenticate. Some servers want you to login by POP3 before you 2989can send a message. You have to use Net::POP3 or Mail::POP3Client to do this. 2990 2991=head2 Other protocols 2992 2993It is possible to add new authentication protocols to Mail::Sender. All you have to do is 2994to define a function Mail::Sender::Auth::PROTOCOL_NAME that will implement 2995the login. The function gets one parameter ... the Mail::Sender object. 2996It can access these properties: 2997 2998 $obj->{'socket'} : the socket to print to and read from 2999 you may use the send_cmd() function to send a request 3000 and read a response from the server 3001 $obj->{'authid'} : the username specified in the new Mail::Sender, 3002 Open or OpenMultipart call 3003 $obj->{'authpwd'} : the password 3004 $obj->{auth...} : all unknown parameters passed to the constructor or the mail 3005 opening/creation methods are preserved in the object. If the protocol requires 3006 any other options, please use names starting with "auth". Eg. "authdomain", ... 3007 $obj->{'error'} : this should be set to a negative error number. Please use numbers 3008 below -1000 for custom errors. 3009 $obj->{'error_msg'} : this should be set to the error message 3010 3011 If the login fails you should 3012 1) Set $Mail::Sender::Error to the error message 3013 2) Set $obj->{'error_msg'} to the error message 3014 2) Set $obj->{'error'} to a negative number 3015 3) return a negative number 3016 If it succeeds, please return "nothing" : 3017 return; 3018 3019Please use the protocols defined within Sender.pm as examples. 3020 3021=head1 EXAMPLES 3022 3023=head2 Object creation 3024 3025 ref ($sender = new Mail::Sender { from => 'somebody@somewhere.com', 3026 smtp => 'mail.yourISP.com', boundary => 'This-is-a-mail-boundary-435427'}) 3027 or die "Error in mailing : $Mail::Sender::Error\n"; 3028 3029or 3030 3031 my $sender = new Mail::Sender { ... }; 3032 die "Error in mailing : $Mail::Sender::Error\n" unless ref $sender; 3033 3034or 3035 3036 my $sender = new Mail::Sender { ..., on_errors => 'undef' } 3037 or die "Error in mailing : $Mail::Sender::Error\n"; 3038 3039You may specify the options either when creating the Mail::Sender object 3040or later when you open a message. You may also set the default options when 3041installing the module (See C<CONFIG> section). This way the admin may set 3042the SMTP server and even the authentication options and the users do not have 3043to specify it again. 3044 3045You should keep in mind that the way Mail::Sender reports failures depends on the 'on_errors'=> 3046option. If you set it to 'die' it throws an exception, if you set it to C<undef> or C<'undef'> it returns 3047undef and otherwise it returns a negative error code! 3048 3049=head2 Simple single part message 3050 3051 $sender = new Mail::Sender { 3052 smtp => 'mail.yourISP.com', 3053 from => 'somebody@somewhere.com', 3054 on_errors => undef, 3055 } 3056 or die "Can't create the Mail::Sender object: $Mail::Sender::Error\n"; 3057 $sender->Open({ 3058 to => 'mama@home.org, papa@work.com', 3059 cc => 'somebody@somewhere.com', 3060 subject => 'Sorry, I\'ll come later.' 3061 }) 3062 or die "Can't open the message: $sender->{'error_msg'}\n"; 3063 $sender->SendLineEnc("I'm sorry, but thanks to the lusers, 3064 I'll come at 10pm at best."); 3065 $sender->SendLineEnc("\nHi, Jenda"); 3066 $sender->Close() 3067 or die "Failed to send the message: $sender->{'error_msg'}\n"; 3068 3069or 3070 3071 eval { 3072 $sender = new Mail::Sender { 3073 smtp => 'mail.yourISP.com', 3074 from => 'somebody@somewhere.com', 3075 on_errors => 'die', 3076 }; 3077 $sender->Open({ 3078 to => 'mama@home.org, papa@work.com', 3079 cc => 'somebody@somewhere.com', 3080 subject => 'Sorry, I\'ll come later.' 3081 }); 3082 $sender->SendLineEnc("I'm sorry, but thanks to the lusers, 3083 I'll come at 10pm at best."); 3084 $sender->SendLineEnc("\nHi, Jenda"); 3085 $sender->Close(); 3086 }; 3087 if ($@) { 3088 die "Failed to send the message: $@\n"; 3089 } 3090 3091or 3092 3093 $sender = new Mail::Sender { 3094 smtp => 'mail.yourISP.com', 3095 from => 'somebody@somewhere.com', 3096 on_errors => 'code', 3097 }; 3098 die "Can't create the Mail::Sender object: $Mail::Sender::Error\n" 3099 unless ref $sender; 3100 ref $sender->Open({ 3101 to => 'mama@home.org, papa@work.com', 3102 cc => 'somebody@somewhere.com', 3103 subject => 'Sorry, I\'ll come later.' 3104 }) 3105 or die "Can't open the message: $sender->{'error_msg'}\n"; 3106 $sender->SendLineEnc("I'm sorry, but thanks to the lusers, 3107 I'll come at 10pm at best."); 3108 $sender->SendLineEnc("\nHi, Jenda"); 3109 ref $sender->Close 3110 or die "Failed to send the message: $sender->{'error_msg'}\n"; 3111 3112=head2 Using GetHandle() 3113 3114 ref $sender->Open({to => 'friend@other.com', subject => 'Hello dear friend'}) 3115 or die "Error: $Mail::Sender::Error\n"; 3116 my $FH = $sender->GetHandle(); 3117 print $FH "How are you?\n\n"; 3118 print $FH <<'*END*'; 3119 I've found these jokes. 3120 3121 Doctor, I feel like a pack of cards. 3122 Sit down and I'll deal with you later. 3123 3124 Doctor, I keep thinking I'm a dustbin. 3125 Don't talk rubbish. 3126 3127 Hope you like'em. Jenda 3128 *END* 3129 3130 $sender->Close; 3131 # or 3132 # close $FH; 3133 3134or 3135 3136 eval { 3137 $sender->Open({ on_errors => 'die', 3138 to => 'mama@home.org, papa@work.com', 3139 cc => 'somebody@somewhere.com', 3140 subject => 'Sorry, I\'ll come later.'}); 3141 $sender->SendLineEnc("I'm sorry, but due to a big load of work, 3142 I'll come at 10pm at best."); 3143 $sender->SendLineEnc("\nHi, Jenda"); 3144 $sender->Close; 3145 }; 3146 if ($@) { 3147 print "Error sending the email: $@\n"; 3148 } else { 3149 print "The mail was sent.\n"; 3150 } 3151 3152=head2 Multipart message with attachment 3153 3154 $sender->OpenMultipart({to => 'Perl-Win32-Users@activeware.foo', 3155 subject => 'Mail::Sender.pm - new module'}); 3156 $sender->Body; 3157 $sender->SendEnc(<<'*END*'); 3158 Here is a new module Mail::Sender. 3159 It provides an object based interface to sending SMTP mails. 3160 It uses a direct socket connection, so it doesn't need any 3161 additional program. 3162 3163 Enjoy, Jenda 3164 *END* 3165 $sender->Attach( 3166 {description => 'Perl module Mail::Sender.pm', 3167 ctype => 'application/x-zip-encoded', 3168 encoding => 'Base64', 3169 disposition => 'attachment; filename="Sender.zip"; type="ZIP archive"', 3170 file => 'sender.zip' 3171 }); 3172 $sender->Close; 3173 3174or 3175 3176 $sender->OpenMultipart({to => 'Perl-Win32-Users@activeware.foo', 3177 subject => 'Mail::Sender.pm - new version'}); 3178 $sender->Body({ msg => <<'*END*' }); 3179 Here is a new module Mail::Sender. 3180 It provides an object based interface to sending SMTP mails. 3181 It uses a direct socket connection, so it doesn't need any 3182 additional program. 3183 3184 Enjoy, Jenda 3185 *END* 3186 $sender->Attach( 3187 {description => 'Perl module Mail::Sender.pm', 3188 ctype => 'application/x-zip-encoded', 3189 encoding => 'Base64', 3190 disposition => 'attachment; filename="Sender.zip"; type="ZIP archive"', 3191 file => 'sender.zip' 3192 }); 3193 $sender->Close; 3194 3195or (in case you have the file contents in a scalar) 3196 3197 $sender->OpenMultipart({to => 'Perl-Win32-Users@activeware.foo', 3198 subject => 'Mail::Sender.pm - new version'}); 3199 $sender->Body({ msg => <<'*END*' }); 3200 Here is a new module Mail::Sender. 3201 It provides an object based interface to sending SMTP mails. 3202 It uses a direct socket connection, so it doesn't need any 3203 additional program. 3204 3205 Enjoy, Jenda 3206 *END* 3207 $sender->Part( 3208 {description => 'Perl module Mail::Sender.pm', 3209 ctype => 'application/x-zip-encoded', 3210 encoding => 'Base64', 3211 disposition => 'attachment; filename="Sender.zip"; type="ZIP archive"', 3212 msg => $sender_zip_contents, 3213 }); 3214 $sender->Close; 3215 3216 3217=head2 Using exceptions (no need to test return values after each function) 3218 3219 use Mail::Sender; 3220 eval { 3221 (new Mail::Sender {on_errors => 'die'}) 3222 ->OpenMultipart({smtp=> 'jenda.krynicky.cz', to => 'jenda@krynicky.cz',subject => 'Mail::Sender.pm - new version'}) 3223 ->Body({ msg => <<'*END*' }) 3224 Here is a new module Mail::Sender. 3225 It provides an object based interface to sending SMTP mails. 3226 It uses a direct socket connection, so it doesn't need any 3227 additional program. 3228 3229 Enjoy, Jenda 3230 *END* 3231 ->Attach({ 3232 description => 'Perl module Mail::Sender.pm', 3233 ctype => 'application/x-zip-encoded', 3234 encoding => 'Base64', 3235 disposition => 'attachment; filename="Sender.zip"; type="ZIP archive"', 3236 file => 'W:\jenda\packages\Mail\Sender\Mail-Sender-0.7.14.3.tar.gz' 3237 }) 3238 ->Close(); 3239 } or print "Error sending mail: $@\n"; 3240 3241=head2 Using MailMsg() shortcut to send simple messages 3242 3243If everything you need is to send a simple message you may use: 3244 3245 if (ref ($sender->MailMsg({to =>'Jenda@Krynicky.czX', subject => 'this is a test', 3246 msg => "Hi Johnie.\nHow are you?"}))) { 3247 print "Mail sent OK." 3248 } else { 3249 die "$Mail::Sender::Error\n"; 3250 } 3251 3252or 3253 3254 if ($sender->MailMsg({ 3255 smtp => 'mail.yourISP.com', 3256 from => 'somebody@somewhere.com', 3257 to =>'Jenda@Krynicky.czX', 3258 subject => 'this is a test', 3259 msg => "Hi Johnie.\nHow are you?" 3260 }) < 0) { 3261 die "$Mail::Sender::Error\n"; 3262 } 3263 print "Mail sent OK." 3264 3265=head2 Using MailMsg and authentication 3266 3267 if ($sender->MailMsg({ 3268 smtp => 'mail.yourISP.com', 3269 from => 'somebody@somewhere.com', 3270 to =>'Jenda@Krynicky.czX', 3271 subject => 'this is a test', 3272 msg => "Hi Johnie.\nHow are you?" 3273 auth => 'NTLM', 3274 authid => 'jenda', 3275 authpwd => 'benda', 3276 }) < 0) { 3277 die "$Mail::Sender::Error\n"; 3278 } 3279 print "Mail sent OK." 3280 3281=head2 Using MailFile() shortcut to send an attachment 3282 3283If you want to attach some files: 3284 3285 (ref ($sender->MailFile( 3286 {to =>'you@address.com', subject => 'this is a test', 3287 msg => "Hi Johnie.\nI'm sending you the pictures you wanted.", 3288 file => 'image1.jpg,image2.jpg' 3289 })) 3290 and print "Mail sent OK." 3291 ) 3292 or die "$Mail::Sender::Error\n"; 3293 3294=head2 Sending HTML messages 3295 3296If you are sure the HTML doesn't contain any accentuated characters (with codes above 127). 3297 3298 open IN, $htmlfile or die "Cannot open $htmlfile : $!\n"; 3299 $sender->Open({ from => 'your@address.com', to => 'other@address.com', 3300 subject => 'HTML test', 3301 ctype => "text/html", 3302 encoding => "7bit" 3303 }) or die $Mail::Sender::Error,"\n"; 3304 3305 while (<IN>) { $sender->SendEx($_) }; 3306 close IN; 3307 $sender->Close(); 3308 3309Otherwise use SendEnc() instead of SendEx() and "quoted-printable" instead of "7bit". 3310 3311Another ... quicker way ... would be: 3312 3313 open IN, $htmlfile or die "Cannot open $htmlfile : $!\n"; 3314 $sender->Open({ from => 'your@address.com', to => 'other@address.com', 3315 subject => 'HTML test', 3316 ctype => "text/html", 3317 encoding => "quoted-printable" 3318 }) or die $Mail::Sender::Error,"\n"; 3319 3320 while (read IN, $buff, 4096) { $sender->SendEnc($buff) }; 3321 close IN; 3322 $sender->Close(); 3323 3324=head2 Sending HTML messages with inline images 3325 3326 if (ref $sender->OpenMultipart({ 3327 from => 'someone@somewhere.net', to => $recipients, 3328 subject => 'Embedded Image Test', 3329 boundary => 'boundary-test-1', 3330 multipart => 'related'})) { 3331 $sender->Attach( 3332 {description => 'html body', 3333 ctype => 'text/html; charset=us-ascii', 3334 encoding => '7bit', 3335 disposition => 'NONE', 3336 file => 'test.html' 3337 }); 3338 $sender->Attach({ 3339 description => 'ed\'s gif', 3340 ctype => 'image/gif', 3341 encoding => 'base64', 3342 disposition => "inline; filename=\"apache_pb.gif\";\r\nContent-ID: <img1>", 3343 file => 'apache_pb.gif' 3344 }); 3345 $sender->Close() or die "Close failed! $Mail::Sender::Error\n"; 3346 } else { 3347 die "Cannot send mail: $Mail::Sender::Error\n"; 3348 } 3349 3350And in the HTML you'll have this : 3351 ... <IMG src="cid:img1"> ... 3352on the place where you want the inlined image. 3353 3354Please keep in mind that the image name is unimportant, it's the Content-ID what counts! 3355 3356# or using the eval{ $obj->Method()->Method()->...->Close()} trick ... 3357 3358 use Mail::Sender; 3359 eval { 3360 (new Mail::Sender) 3361 ->OpenMultipart({ 3362 to => 'someone@somewhere.com', 3363 subject => 'Embedded Image Test', 3364 boundary => 'boundary-test-1', 3365 type => 'multipart/related' 3366 }) 3367 ->Attach({ 3368 description => 'html body', 3369 ctype => 'text/html; charset=us-ascii', 3370 encoding => '7bit', 3371 disposition => 'NONE', 3372 file => 'c:\temp\zk\HTMLTest.htm' 3373 }) 3374 ->Attach({ 3375 description => 'Test gif', 3376 ctype => 'image/gif', 3377 encoding => 'base64', 3378 disposition => "inline; filename=\"test.gif\";\r\nContent-ID: <img1>", 3379 file => 'test.gif' 3380 }) 3381 ->Close() 3382 } 3383 or die "Cannot send mail: $Mail::Sender::Error\n"; 3384 3385=head2 Sending message with plaintext and HTML alternatives 3386 3387 use Mail::Sender; 3388 3389 eval { 3390 (new Mail::Sender) 3391 ->OpenMultipart({ 3392 to => 'someone@somewhere.com', 3393 subject => 'Alternatives', 3394 # debug => 'c:\temp\zkMailFlow.log', 3395 multipart => 'mixed', 3396 }) 3397 ->Part({ctype => 'multipart/alternative'}) 3398 ->Part({ ctype => 'text/plain', disposition => 'NONE', msg => <<'*END*' }) 3399 A long 3400 mail 3401 message. 3402 *END* 3403 ->Part({ctype => 'text/html', disposition => 'NONE', msg => <<'*END*'}) 3404 <html><body><h1>A long</h1><p align=center> 3405 mail 3406 message. 3407 </p></body></html> 3408 *END* 3409 ->EndPart("multipart/alternative") 3410 ->Close(); 3411 } or print "Error sending mail: $Mail::Sender::Error\n"; 3412 3413=head2 Sending message with plaintext and HTML alternatives with inline images 3414 3415 use Mail::Sender; 3416 3417 eval { 3418 (new Mail::Sender) 3419 ->OpenMultipart({ 3420 to => 'someone@somewhere.com', 3421 subject => 'Alternatives with images', 3422 # debug => 'c:\temp\zkMailFlow.log', 3423 multipart => 'related', 3424 }) 3425 ->Part({ctype => 'multipart/alternative'}) 3426 ->Part({ ctype => 'text/plain', disposition => 'NONE', msg => <<'*END*' }) 3427 A long 3428 mail 3429 message. 3430 *END* 3431 ->Part({ctype => 'text/html', disposition => 'NONE', msg => <<'*END*'}) 3432 <html><body><h1>A long</h1><p align=center> 3433 mail 3434 message. 3435 <img src="cid:img1"> 3436 </p></body></html> 3437 *END* 3438 ->EndPart("multipart/alternative") 3439 ->Attach({ 3440 description => 'ed\'s jpg', 3441 ctype => 'image/jpeg', 3442 encoding => 'base64', 3443 disposition => "inline; filename=\"0518m_b.jpg\";\r\nContent-ID: <img1>", 3444 file => 'E:\pix\humor\0518m_b.jpg' 3445 }) 3446 ->Close(); 3447 } or print "Error sending mail: $Mail::Sender::Error\n"; 3448 3449Keep in mind please that different mail clients display messages differently. You may 3450need to try several ways to create messages so that they appear the way you need. 3451These two examples looked like I expected in Pegasus Email and MS Outlook. 3452 3453If this doesn't work with your mail client, please let me know and we might find a way. 3454 3455 3456=head2 Sending a file that was just uploaded from an HTML form 3457 3458 use CGI; 3459 use Mail::Sender; 3460 3461 $query = new CGI; 3462 3463 # uploading the file... 3464 $filename = $query->param('mailformFile'); 3465 if ($filename ne ""){ 3466 $tmp_file = $query->tmpFileName($filename); 3467 } 3468 3469 $sender = new Mail::Sender {from => 'script@krynicky.cz',smtp => 'mail.krynicky.czX'}; 3470 $sender->OpenMultipart({to=> 'jenda@krynicky.czX',subject=> 'test CGI attach'}); 3471 $sender->Body(); 3472 $sender->Send(<<"*END*"); 3473 This is just a test of mail with an uploaded file. 3474 3475 Jenda 3476 *END* 3477 $sender->Attach({ 3478 encoding => 'Base64', 3479 description => $filename, 3480 ctype => $query->uploadInfo($filename)->{'Content-Type'}, 3481 disposition => "attachment; filename = $filename", 3482 file => $tmp_file 3483 }); 3484 $sender->Close(); 3485 3486 print "Content-Type: text/plain\n\nYes, it's sent\n\n"; 3487 3488=head2 Listing the authentication protocols supported by the server 3489 3490 use Mail::Sender; 3491 my $sender = new Mail::Sender {smtp => 'localhost'}; 3492 die "Error: $Mail::Sender::Error\n" unless ref $sender; 3493 print join(', ', $sender->QueryAuthProtocols()),"\n"; 3494 3495or (if you have Mail::Sender 0.8.05 or newer) 3496 3497 use Mail::Sender; 3498 print join(', ', Mail::Sender->QueryAuthProtocols('localhost')),"\n"; 3499 3500or 3501 3502 use Mail::Sender; 3503 print join(', ', Mail::Sender::QueryAuthProtocols('localhost')),"\n"; 3504 3505=head2 FAQ 3506 3507=head3 Forwarding the messages created by Mail::Sender removes accents. Why? 3508 3509The most likely colprit is missing or incorrect charset specified for the body or 3510a part of the email. You should add something like 3511 3512 charset => 'iso-8859-1', 3513 encoding => 'quoted-printable', 3514 3515to the parameters passed to Open(), OpenMultipart(), MailMsg(), Body() or Part() or 3516 3517 b_charset => 'iso-8859-1', 3518 b_encoding => 'quoted-printable', 3519 3520to the parameters for MailFile(). 3521 3522If you use a different charset ('iso-8859-2', 'win-1250', ...) you will of course need 3523to specify that charset. If you are not sure, try to send a mail with some other mail client 3524and then look at the message/part headers. 3525 3526=head2 Sometimes there is an equals sign at the end of an attached file when 3527I open the email in Outlook. What's wrong? 3528 3529Outlook is. It has (had) a bug in its quoted printable decoding routines. 3530This problem happens only in quoted-printable encoded parts on multipart messages. 3531And only if the data in that part do not end with a newline. (This is new in 0.8.08, in older versions 3532it happened in all QP encoded parts.) 3533 3534The problem is that an equals sign at the end of a line in a quoted printable encoded text means 3535"ignore the newline". That is 3536 3537 fooo sdfg sdfg sdfh dfh = 3538 dfsgdsfg 3539 3540should be decoded as 3541 3542 fooo sdfg sdfg sdfh dfh dfsgdsfg 3543 3544The problem is at the very end of a file. The part boundary (text separating different 3545parts of a multipart message) has to start on a new line, if the attached file ends by a newline everything is cool. 3546If it doesn't I need to add a newline and to denote that the newline is not part of the original file I add an equals: 3547 3548 dfgd dsfgh dfh dfh dfhdfhdfhdfgh 3549 this is the last line.= 3550 --message-boundary-146464-- 3551 3552Otherwise I'd add a newline at the end of the file. 3553If you do not care about the newline and want to be sure Outlook doesn't add the equals to the file add 3554 3555 bypass_outlook_bug => 1 3556 3557parameter to C<new Mail::Sender> or C<Open>/C<OpenMultipart>. 3558 3559=head2 WARNING 3560 3561DO NOT mix Open(Multipart)|Send(Line)(Ex)|Close with MailMsg or MailFile. 3562Both Mail(Msg/File) close any Open-ed mail. 3563Do not try this: 3564 3565 $sender = new Mail::Sender ...; 3566 $sender->OpenMultipart...; 3567 $sender->Body; 3568 $sender->Send("..."); 3569 $sender->MailFile({file => 'something.ext'); 3570 $sender->Close; 3571 3572This WON'T work!!! 3573 3574=head2 GOTCHAS 3575 3576=head3 Local user "someone@somewhere.com" doesn't exist 3577 3578"Thanks" to spammers mail servers usually do not allow just anyone to post a message through them. 3579Most often they require that either the sender or the recipient is local to the server 3580 3581=head3 Mail::Sendmail works, Mail::Sender doesn't 3582 3583If you are able to connect to the mail server and scripts using Mail::Sendmail work, but Mail::Sender fails with 3584"connect() failed", please review the settings in /etc/services. The port for SMTP should be 25. 3585 3586=head3 $/ and $\ 3587 3588If you change the $/ ($RS, $INPUT_RECORD_SEPARATOR) or $\ ($ORS, $OUTPUT_RECORD_SEPARATOR) 3589or $, ($OFS, $OUTPUT_FIELD_SEPARATOR) Mail::Sender may stop working! Keep in mind that those variables are global 3590and therefore they change the behaviour of <> and print everywhere. 3591And since the SMTP is a plain text protocol if you change the notion of lines you can break it. 3592 3593If you have to fiddle with $/, $\ or $, do it in the smallest possible block of code and local()ize the change! 3594 3595 open my $IN, '<', $filename or die "Can't open $filename: $!\n"; 3596 my $data = do {local $/; <$IN>}; 3597 close $IN; 3598 3599=head1 BUGS 3600 3601I'm sure there are many. Please let me know if you find any. 3602 3603The problem with multiline responses from some SMTP servers (namely qmail) is solved. At last. 3604 3605=head1 SEE ALSO 3606 3607MIME::Lite, MIME::Entity, Mail::Sendmail, Mail::Mailer, ... 3608 3609There are lots of mail related modules on CPAN, with different capabilities and interfaces. You 3610have to find the right one yourself :-) 3611 3612=head1 DISCLAIMER 3613 3614This module is based on SendMail.pm Version : 1.21 that appeared in 3615Perl-Win32-Users@activeware.com mailing list. I don't remember the name 3616of the poster and it's not mentioned in the script. Thank you mr. C<undef>. 3617 3618=head1 AUTHOR 3619 3620Jan Krynicky <Jenda@Krynicky.cz> 3621http://Jenda.Krynicky.cz 3622 3623With help of Rodrigo Siqueira <rodrigo@insite.com.br>, 3624Ed McGuigan <itstech1@gate.net>, 3625John Sanche <john@quadrant.net>, 3626Brian Blakley <bblakley@mp5.net>, 3627and others. 3628 3629=head1 COPYRIGHT 3630 3631Copyright (c) 1997-2012 Jan Krynicky <Jenda@Krynicky.cz>. All rights reserved. 3632 3633This program is free software; you can redistribute it and/or 3634modify it under the same terms as Perl itself. There is only one additional condition, you may 3635NOT use this module for SPAMing! NEVER! (see http://spam.abuse.net/ for definition) 3636 3637=cut 3638