File Coverage

blib/lib/Mail/Sender.pm
Criterion Covered Total %
statement 282 1259 22.4
branch 72 734 9.8
condition 58 360 16.1
subroutine 57 99 57.5
pod 27 38 71.0
total 496 2490 19.9


line stmt bran cond sub pod time code
1             package Mail::Sender;
2              
3 2     2   17358 use strict;
  2         3  
  2         49  
4 2     2   8 use warnings;
  2         3  
  2         59  
5 2     2   8 use base 'Exporter';
  2         4  
  2         234  
6              
7             # no warnings 'uninitialized';
8 2     2   8 use Carp ();
  2         2  
  2         24  
9 2     2   943 use Encode ();
  2         15556  
  2         45  
10 2     2   11 use File::Basename ();
  2         3  
  2         22  
11 2     2   1003 use IO::Socket::INET ();
  2         34804  
  2         44  
12 2     2   1030 use MIME::Base64 ();
  2         1187  
  2         39  
13 2     2   739 use MIME::QuotedPrint ();
  2         380  
  2         32  
14 2     2   15 use Socket ();
  2         1  
  2         21  
15 2     2   815 use Time::Local ();
  2         2305  
  2         298  
16              
17             our @EXPORT = qw();
18             our @EXPORT_OK = qw(@error_str GuessCType);
19              
20             our $VERSION = '0.901'; # VERSION
21             $VERSION = eval $VERSION;
22              
23             our $GMTdiff;
24             our $Error;
25             our %default; # loaded in from our config files
26             our $MD5_loaded = 0;
27             our $debug = 0;
28             our %CTypes = (
29             GIF => 'image/gif',
30             JPE => 'image/jpeg',
31             JPEG => 'image/jpeg',
32             SHTML => 'text/html',
33             SHTM => 'text/html',
34             HTML => 'text/html',
35             HTM => 'text/html',
36             TXT => 'text/plain',
37             INI => 'text/plain',
38             DOC => 'application/x-msword',
39             EML => 'message/rfc822',
40             );
41             our @Errors = (
42             'OK',
43             'Unknown encoding',
44             'TLS unsupported by server',
45             'TLS unsupported by script',
46             'IO::SOCKET::SSL failed',
47             'STARTTLS failed',
48             'debug file cannot be opened',
49             'file cannot be read',
50             'all recipients have been rejected',
51             'authentication protocol is not implemented',
52             'login not accepted',
53             'authentication protocol not accepted by the server',
54             'no From: address specified',
55             'no SMTP server specified',
56             'connection not established. Did you mean MailFile instead of SendFile?',
57             'site specific error',
58             'not available in singlepart mode',
59             'file not found',
60             'no file name specified in call to MailFile or SendFile',
61             'no message specified in call to MailMsg or MailFile',
62             'argument $to empty',
63             'transmission of message failed',
64             'local user $to unknown on host $smtp',
65             'unspecified communication error',
66             'service not available',
67             'connect() failed',
68             'socket() failed',
69             '$smtphost unknown'
70             );
71              
72             # if you do not use MailFile or SendFile and only send 7BIT or 8BIT "encoded"
73             # messages you may comment out these lines.
74             #MIME::Base64 and MIME::QuotedPrint may be found at CPAN.
75              
76             my $TLS_notsupported;
77              
78             BEGIN {
79             eval <<'END'
80             use IO::Socket::SSL;# qw(debug4);
81             use Net::SSLeay;
82             1;
83             END
84 2 50   2   105 or $TLS_notsupported = $@;
  2     2   1444  
  2     2   91551  
  2         17  
  2         336  
  2         3  
  2         56  
85             }
86              
87             # include config file and libraries when packaging the script
88             if (0) {
89             require 'Mail/Sender.config'; # local configuration
90             require 'Symbol.pm'; # for debuging and GetHandle() method
91             require 'Tie/Handle.pm'; # for debuging and GetHandle() method
92             require 'IO/Handle.pm'; # for debuging and GetHandle() method
93             require 'Digest/HMAC_MD5.pm'; # for CRAM-MD5 authentication only
94             require 'Authen/NTLM.pm'; # for NTLM authentication only
95             } # this block above is there to let PAR, PerlApp, PerlCtrl, PerlSvc and Perl2Exe know I may need those files.
96              
97             BEGIN {
98 2     2   4 my $config = $INC{'Mail/Sender.pm'};
99 2 50       7 die
100             "Wrong case in use statement or Mail::Sender module renamed. Perl is case sensitive!!!\n"
101             unless $config;
102 2         69 my $compiled = !(-e $config)
103             ; # if the module was not read from disk => the script has been "compiled"
104 2         10 $config =~ s/\.pm$/.config/;
105 2 50 33     3269 if ($compiled or -e $config) {
106              
107             # in a Perl2Exe or PerlApp created executable or PerlCtrl generated COM object
108             # or the config is known to exist
109 0         0 eval { require $config };
  0         0  
110 0 0 0     0 if ($@ and $@ !~ /Can't locate /) {
111 0         0 print STDERR "Error in Mail::Sender.config : $@";
112             }
113             }
114             }
115              
116             #local IP address and name
117             my $local_name
118             = $ENV{HOSTNAME} || $ENV{HTTP_HOST} || (gethostbyname 'localhost')[0];
119             $local_name
120             =~ s/:.*$//; # the HTTP_HOST may be set to something like "foo.bar.com:1000"
121             my $local_IP = join('.', unpack('CCCC', (gethostbyname $local_name)[4]));
122              
123             #time diference to GMT - Windows will not set $ENV{'TZ'}, if you know a better way ...
124              
125             sub ResetGMTdiff {
126 3     3 1 226 my $local = time;
127 3         33 my $gm = Time::Local::timelocal(gmtime $local);
128 3         218 my $sign = qw( + + - ) [$local <=> $gm];
129 3         19 $GMTdiff = sprintf "%s%02d%02d", $sign, (gmtime abs($local - $gm))[2, 1];
130 3         7 return $GMTdiff;
131             }
132             ResetGMTdiff();
133              
134             #
135             my @priority
136             = ('', '1 (Highest)', '2 (High)', '3 (Normal)', '4 (Low)', '5 (Lowest)');
137              
138             #data encoding
139             my $chunksize = 1024 * 4;
140             my $chunksize64 = 71 * 57; # must be divisible by 57 !
141             my $enc_base64_chunk = 57;
142              
143             sub enc_base64 {
144 2 100   2 0 804 if ($_[0]) {
145 1         2 my $charset = $_[0];
146             return sub {
147 0     0   0 my $s
148             = MIME::Base64::encode_base64(Encode::encode($charset, $_[0]));
149 0         0 $s =~ s/\x0A/\x0D\x0A/sg;
150 0         0 return $s;
151             }
152 1         6 }
153             else {
154             return sub {
155 0     0   0 my $s = MIME::Base64::encode_base64($_[0]);
156 0         0 $s =~ s/\x0A/\x0D\x0A/sg;
157 0         0 return $s;
158             }
159 1         8 }
160             }
161              
162             sub enc_qp {
163 2 100   2 0 5 if ($_[0]) {
164 1         2 my $charset = $_[0];
165             return sub {
166 0     0   0 my $s = Encode::encode($charset, $_[0]);
167 0         0 $s =~ s/\x0D\x0A/\n/g;
168 0         0 $s = MIME::QuotedPrint::encode_qp($s);
169 0         0 $s =~ s/^\./../gm;
170 0         0 $s =~ s/\x0A/\x0D\x0A/sg;
171 0         0 return $s;
172             }
173 1         5 }
174             else {
175             return sub {
176 0     0   0 my $s = $_[0];
177 0         0 $s =~ s/\x0D\x0A/\n/g;
178 0         0 $s = MIME::QuotedPrint::encode_qp($s);
179 0         0 $s =~ s/^\./../gm;
180 0         0 $s =~ s/\x0A/\x0D\x0A/sg;
181 0         0 return $s;
182             }
183 1         6 }
184             }
185              
186             sub enc_plain {
187 2 100   2 0 5 if ($_[0]) {
188 1         1 my $charset = $_[0];
189             return sub {
190 0     0   0 my $s = Encode::encode($charset, $_[0]);
191 0         0 $s =~ s/^\./../gm;
192 0         0 $s =~ s/(?:\x0D\x0A?|\x0A)/\x0D\x0A/sg;
193 0         0 return $s;
194             }
195 1         6 }
196             else {
197             return sub {
198 0     0   0 my $s = $_[0];
199 0         0 $s =~ s/^\./../gm;
200 0         0 $s =~ s/(?:\x0D\x0A?|\x0A)/\x0D\x0A/sg;
201 0         0 return $s;
202             }
203 1         6 }
204             }
205              
206             sub enc_xtext {
207 9     9 0 10 my $input = shift;
208 9         15 $input =~ s/([^!-*,-<>-~])/'+'.uc(unpack('H*', $1))/eg;
  0         0  
209 9         19 return $input;
210             }
211              
212             {
213             my $username;
214              
215             sub getusername () {
216 2 100   2 0 457 return $username if defined($username);
217 1   33     1 return $username = eval { getlogin || getpwuid($<) } || $ENV{USERNAME};
218             }
219             }
220              
221             #IO
222              
223             #reads the whole SMTP response
224             # converts
225             # nnn-very
226             # nnn-long
227             # nnn message
228             # to
229             # nnn very
230             # long
231             # message
232             sub get_response ($) {
233 0     0 0 0 my $s = shift;
234 0         0 my $res = <$s>;
235 0 0       0 if ($res =~ s/^(\d\d\d)-/$1 /) {
236 0         0 my $nextline = <$s>;
237 0         0 while ($nextline =~ s/^\d\d\d-//) {
238 0         0 $res .= $nextline;
239 0         0 $nextline = <$s>;
240             }
241 0         0 $nextline =~ s/^\d\d\d //;
242 0         0 $res .= $nextline;
243             }
244 0         0 $Mail::Sender::LastResponse = $res;
245 0         0 return $res;
246             }
247              
248             sub send_cmd ($$) {
249 0     0 0 0 my ($s, $cmd) = @_;
250 0         0 chomp $cmd;
251 0 0       0 if ($s->opened()) {
252 0         0 print $s "$cmd\x0D\x0A";
253 0         0 get_response($s);
254             }
255             else {
256 0         0 return '400 connection lost';
257             }
258             }
259              
260             sub _print_hdr {
261 0     0   0 my ($s, $hdr, $str, $charset) = @_;
262 0 0 0     0 return if !defined $str or $str eq '';
263 0         0 $str =~ s/[\x0D\x0A\s]+$//;
264              
265 0 0 0     0 if ($charset && $str =~ /[^[:ascii:]]/) {
266 0         0 $str = Encode::encode($charset, $str);
267 0         0 my @parts = split /(\s*[,;<> ]\s*)/, $str;
268 0         0 $str = '';
269 0         0 for (my $i = 0; $i < @parts; $i++) {
270 0         0 my $part = $parts[$i];
271 0 0 0     0 $part .= $parts[++$i]
272             if ($i < $#parts && $parts[$i + 1] =~ /^\s+$/);
273 0 0 0     0 if ($part =~ /[^[:ascii:]]/ || $part =~ /[\r\n\t]/) {
274 0         0 $part = MIME::QuotedPrint::encode_qp($part, '');
275 0         0 $part =~ s/([\s\?])/'=' . sprintf '%02x',ord($1)/ge;
  0         0  
276 0         0 $str .= "=?$charset?Q?$part?=";
277             }
278             else {
279 0         0 $str .= $part;
280             }
281             }
282             }
283              
284 0         0 $str =~ s/(?:\x0D\x0A?|\x0A)/\x0D\x0A/sg; # \n or \r => \r\n
285 0         0 $str =~ s/\x0D\x0A([^\t])/\x0D\x0A\t$1/sg;
286 0 0       0 if (length($str) + length($hdr) > 997) { # header too long, max 1000 chars
287 0         0 $str =~ s/(.{1,980}[;,])\s+(\S)/$1\x0D\x0A\t$2/g;
288             }
289 0         0 print $s "$hdr: $str\x0D\x0A";
290             }
291              
292              
293             sub _say_helo {
294 0     0   0 my ($self, $s) = @_;
295 0         0 my $res = send_cmd $s, "EHLO $self->{'client'}";
296 0 0       0 if ($res !~ /^[123]/) {
297 0         0 $res = send_cmd $s, "HELO $self->{'client'}";
298 0 0       0 if ($res !~ /^[123]/) { return $self->Error(_COMMERROR($_)); }
  0         0  
299 0         0 return;
300             }
301              
302 0         0 $res =~ s/^.*\n//;
303 0         0 $self->{'supports'} = {map { split /(?:\s+|=)/, $_, 2 } split /\n/, $res};
  0         0  
304              
305 0 0       0 if (exists $self->{'supports'}{AUTH}) {
306 0         0 my @auth = split /\s+/, uc($self->{'supports'}{AUTH});
307 0         0 $self->{'auth_protocols'} = {map { $_, 1 } @auth};
  0         0  
308              
309             # create a hash with accepted authentication protocols
310             }
311              
312 0         0 $self->{esmtp}{_MAIL_FROM} = '';
313 0         0 $self->{esmtp}{_RCPT_TO} = '';
314 0 0 0     0 if (exists $self->{'supports'}{DSN} and exists $self->{esmtp}) {
315 0         0 for (qw(RET ENVID)) {
316             $self->{esmtp}{_MAIL_FROM} .= " $_=$self->{esmtp}{$_}"
317 0 0       0 if $self->{esmtp}{$_} ne '';
318             }
319 0         0 for (qw(NOTIFY ORCPT)) {
320             $self->{esmtp}{_RCPT_TO} .= " $_=$self->{esmtp}{$_}"
321 0 0       0 if $self->{esmtp}{$_} ne '';
322             }
323             }
324 0         0 return;
325             }
326              
327             sub login {
328 0     0 0 0 my $self = shift();
329 0   0     0 my $auth = uc($self->{'auth'}) || 'LOGIN';
330 0 0       0 if (!$self->{'auth_protocols'}->{$auth}) {
331 0         0 return $self->Error(_INVALIDAUTH($auth));
332             }
333              
334             $self->{'authid'} = $self->{'username'}
335 0 0 0     0 if (exists $self->{'username'} and !exists $self->{'authid'});
336              
337             $self->{'authpwd'} = $self->{'password'}
338 0 0 0     0 if (exists $self->{'password'} and !exists $self->{'authpwd'});
339              
340             # change all characters except letters, numbers and underscores to underscores
341 0         0 $auth =~ tr/a-zA-Z0-9_/_/c;
342 2     2   13 no strict qw'subs refs';
  2         4  
  2         20923  
343 0         0 my $method = "Mail::Sender::Auth::$auth";
344 0         0 $method->($self);
345             }
346              
347             # authentication code stolen from http://support.zeitform.de/techinfo/e-mail_prot.html
348             sub Mail::Sender::Auth::LOGIN {
349 0     0   0 my $self = shift();
350 0         0 my $s = $self->{'socket'};
351              
352 0         0 $_ = send_cmd $s, 'AUTH LOGIN';
353 0 0       0 if (!/^[123]/) { return $self->Error(_INVALIDAUTH('LOGIN', $_)); }
  0         0  
354              
355 0 0       0 if ($self->{auth_encoded}) {
356              
357             # I assume the username and password had been base64 encoded already!
358 0         0 $_ = send_cmd $s, $self->{'authid'};
359 0 0       0 if (!/^[123]/) { return $self->Error(_LOGINERROR($_)); }
  0         0  
360              
361 0         0 $_ = send_cmd $s, $self->{'authpwd'};
362 0 0       0 if (!/^[123]/) { return $self->Error(_LOGINERROR($_)); }
  0         0  
363             }
364             else {
365 0         0 $_ = send_cmd $s, MIME::Base64::encode_base64($self->{'authid'}, '');
366 0 0       0 if (!/^[123]/) { return $self->Error(_LOGINERROR($_)); }
  0         0  
367              
368 0         0 $_ = send_cmd $s, MIME::Base64::encode_base64($self->{'authpwd'}, '');
369 0 0       0 if (!/^[123]/) { return $self->Error(_LOGINERROR($_)); }
  0         0  
370             }
371 0         0 return;
372             }
373              
374             sub Mail::Sender::Auth::CRAM_MD5 {
375 0     0   0 my $self = shift();
376 0         0 my $s = $self->{'socket'};
377              
378 0         0 $_ = send_cmd $s, "AUTH CRAM-MD5";
379 0 0       0 if (!/^[123]/) { return $self->Error(_INVALIDAUTH('CRAM-MD5', $_)); }
  0         0  
380 0 0       0 my $stamp = $1 if /^\d{3}\s+(.*)$/;
381              
382 0 0       0 unless ($MD5_loaded) {
383 0         0 eval 'use Digest::HMAC_MD5 qw(hmac_md5_hex)';
384 0 0       0 die "$@\n" if $@;
385 0         0 $MD5_loaded = 1;
386             }
387              
388 0         0 my $user = $self->{'authid'};
389 0         0 my $secret = $self->{'authpwd'};
390              
391 0         0 my $decoded_stamp = MIME::Base64::decode_base64($stamp);
392 0         0 my $hmac = hmac_md5_hex($decoded_stamp, $secret);
393 0         0 my $answer = MIME::Base64::encode_base64($user . ' ' . $hmac, '');
394 0         0 $_ = send_cmd $s, $answer;
395 0 0       0 if (!/^[123]/) { return $self->Error(_LOGINERROR($_)); }
  0         0  
396 0         0 return;
397             }
398              
399             sub Mail::Sender::Auth::PLAIN {
400 0     0   0 my $self = shift();
401 0         0 my $s = $self->{'socket'};
402              
403 0         0 $_ = send_cmd $s, "AUTH PLAIN";
404 0 0       0 if (!/^[123]/) { return $self->Error(_INVALIDAUTH('PLAIN', $_)); }
  0         0  
405              
406             $_ = send_cmd $s,
407             MIME::Base64::encode_base64(
408 0         0 "\000" . $self->{'authid'} . "\000" . $self->{'authpwd'}, '');
409 0 0       0 if (!/^[123]/) { return $self->Error(_LOGINERROR($_)); }
  0         0  
410 0         0 return;
411             }
412              
413             {
414             my $NTLM_loaded = 0;
415              
416             sub Mail::Sender::Auth::NTLM {
417 0 0   0   0 unless ($NTLM_loaded) {
418 0         0 eval "use Authen::NTLM qw();";
419 0 0       0 die "$@\n" if $@;
420 0         0 $NTLM_loaded = 1;
421             }
422 0         0 my $self = shift();
423 0         0 my $s = $self->{'socket'};
424              
425 0         0 $_ = send_cmd $s, "AUTH NTLM";
426 0 0       0 if (!/^[123]/) { return $self->Error(_INVALIDAUTH('NTLM', $_)); }
  0         0  
427              
428 0         0 Authen::NTLM::ntlm_reset();
429 0         0 Authen::NTLM::ntlm_user($self->{'authid'});
430 0         0 Authen::NTLM::ntlm_password($self->{'authpwd'});
431             Authen::NTLM::ntlm_domain($self->{'authdomain'})
432 0 0       0 if defined $self->{'authdomain'};
433              
434 0         0 $_ = send_cmd $s, Authen::NTLM::ntlm();
435 0 0       0 if (!/^3\d\d (.*)$/s) { return $self->Error(_LOGINERROR($_)); }
  0         0  
436 0         0 my $response = $1;
437 0         0 $_ = send_cmd $s, Authen::NTLM::ntlm($response);
438 0 0       0 if (!/^[123]/) { return $self->Error(_LOGINERROR($_)); }
  0         0  
439 0         0 return;
440             }
441             }
442              
443             sub Mail::Sender::Auth::AUTOLOAD {
444 0     0   0 (my $auth = $Mail::Sender::Auth::AUTOLOAD) =~ s/.*:://;
445 0         0 my $self = shift();
446 0         0 my $s = $self->{'socket'};
447 0         0 send_cmd $s, "QUIT";
448 0         0 close $s;
449 0         0 delete $self->{'socket'};
450 0         0 return $self->Error(_UNKNOWNAUTH($auth));
451             }
452              
453             my $debug_code;
454              
455             sub __Debug {
456 0     0   0 my ($socket, $file) = @_;
457 0 0       0 if (defined $file) {
458 0 0       0 unless (@Mail::Sender::DBIO::ISA) {
459 0         0 eval "use Symbol;";
460 0         0 eval $debug_code;
461 0 0       0 die $@ if $@;
462             }
463 0         0 my $handle = gensym();
464 0         0 *$handle = \$socket;
465 0 0       0 if (!ref $file) {
466 0 0       0 open my $DEBUG, '>', $file
467             or die "Cannot open the debug file '$file': $^E\n";
468 0         0 binmode $DEBUG;
469 0         0 $DEBUG->autoflush();
470 0         0 tie *$handle, 'Mail::Sender::DBIO', $socket, $DEBUG, 1;
471             }
472             else {
473 0         0 my $DEBUG = $file;
474 0         0 tie *$handle, 'Mail::Sender::DBIO', $socket, $DEBUG, 0;
475             }
476 0         0 bless $handle, 'Mail::Sender::DBIO';
477 0         0 return $handle;
478             }
479             else {
480 0         0 return $socket;
481             }
482             }
483              
484             #internale
485              
486             sub _HOSTNOTFOUND {
487 3   100 3   651 my $msg = shift || '';
488 3         5 $! = 2;
489 3         9 $Error = "The SMTP server $msg was not found";
490 3         10 return -1, $Error;
491             }
492              
493             sub _CONNFAILED {
494 1     1   421 $! = 5;
495 1         6 $Error = "connect() failed: $^E";
496 1         2 return -3, $Error;
497             }
498              
499             sub _SERVNOTAVAIL {
500 2   100 2   862 my $msg = shift || '';
501 2         3 $! = 40;
502 2 100       8 $Error = "Service not available. "
503             . ($msg ? "Reply: $msg" : "Server closed the connection unexpectedly");
504 2         4 return -4, $Error;
505             }
506              
507             sub _COMMERROR {
508 2   100 2   863 my $msg = shift || '';
509 2         3 $! = 5;
510 2 100       5 if ($msg eq '') {
511 1         2 $Error = "No response from server";
512             }
513             else {
514 1         2 $Error = "Server error: $msg";
515             }
516 2         5 return -5, $Error;
517             }
518              
519             sub _USERUNKNOWN {
520 5   100 5   2325 my $user = shift || '';
521 5   100     13 my $host = shift || '';
522 5   100     11 my $err = shift || '';
523 5         6 $! = 2;
524 5 100 100     22 if ($err and $err !~ /Local user/i) {
525 2         6 $err =~ s/^\d+\s*//;
526 2         7 $err =~ s/\s*$//s;
527 2   100     6 $err ||= "Error";
528 2         5 $Error = "$err for \"$user\" on host \"$host\"";
529             }
530             else {
531 3         8 $Error = "Local user \"$user\" unknown on host \"$host\"";
532             }
533 5         10 return -6, $Error;
534             }
535              
536             sub _TRANSFAILED {
537 2   100 2   1025 my $msg = shift || '';
538 2         4 $! = 5;
539 2         4 $Error = "Transmission of message failed ($msg)";
540 2         6 return -7, $Error;
541             }
542              
543             sub _TOEMPTY {
544 1     1   589 $! = 14;
545 1         3 $Error = "Argument \$to empty";
546 1         2 return -8, $Error;
547             }
548              
549             sub _NOMSG {
550 1     1   497 $! = 22;
551 1         2 $Error = "No message specified";
552 1         2 return -9, $Error;
553             }
554              
555             sub _NOFILE {
556 1     1   420 $! = 22;
557 1         3 $Error = "No file name specified";
558 1         2 return -10, $Error;
559             }
560              
561             sub _FILENOTFOUND {
562 2   100 2   1316 my $msg = shift || '';
563 2         6 $! = 2;
564 2         5 $Error = "File \"$msg\" not found";
565 2         5 return -11, $Error;
566             }
567              
568             sub _NOTMULTIPART {
569 2   100 2   1479 my $msg = shift || '';
570 2         3 $! = 40;
571 2         6 $Error = "$msg not available in singlepart mode";
572 2         5 return -12, $Error;
573             }
574              
575             sub _SITEERROR {
576 1     1   728 $! = 15;
577 1         4 $Error = "Site specific error";
578 1         3 return -13, $Error;
579             }
580              
581             sub _NOTCONNECTED {
582 1     1   750 $! = 1;
583 1         3 $Error = "Connection not established";
584 1         3 return -14, $Error;
585             }
586              
587             sub _NOSERVER {
588 1     1   730 $! = 22;
589 1         3 $Error = "No SMTP server specified";
590 1         2 return -15, $Error;
591             }
592              
593             sub _NOFROMSPECIFIED {
594 1     1   656 $! = 22;
595 1         2 $Error = "No From: address specified";
596 1         3 return -16, $Error;
597             }
598              
599             sub _INVALIDAUTH {
600 3   100 3   2579 my $proto = shift || '';
601 3   100     15 my $res = shift || '';
602 3         6 $! = 22;
603 3         7 $Error = "Authentication protocol $proto is not accepted by the server";
604 3 100       7 $Error .= ",\nresponse: $res" if $res;
605 3         8 return -17, $Error;
606             }
607              
608             sub _LOGINERROR {
609 1     1   801 $! = 22;
610 1         2 $Error = "Login not accepted";
611 1         3 return -18, $Error;
612             }
613              
614             sub _UNKNOWNAUTH {
615 2   100 2   1319 my $msg = shift || '';
616 2         4 $! = 22;
617 2         4 $Error = "Authentication protocol $msg is not implemented by Mail::Sender";
618 2         5 return -19, $Error;
619             }
620              
621             sub _ALLRECIPIENTSBAD {
622 1     1   687 $! = 2;
623 1         3 $Error = "All recipients are bad";
624 1         5 return -20, $Error;
625             }
626              
627             sub _FILECANTREAD {
628 2   100 2   1427 my $msg = shift || '';
629 2         16 $Error = "File \"$msg\" cannot be read: $^E";
630 2         6 return -21, $Error;
631             }
632              
633             sub _DEBUGFILE {
634 2     2   1287 $Error = shift;
635 2         5 return -22, $Error;
636             }
637              
638             sub _STARTTLS {
639 3   100 3   2193 my $msg = shift || '';
640 3   100     11 my $two = shift || '';
641 3         6 $! = 5;
642 3         7 $Error = "STARTTLS failed: $msg $two";
643 3         46 return -23, $Error;
644             }
645              
646             sub _IO_SOCKET_SSL {
647 2   100 2   1387 my $msg = shift || '';
648 2         3 $! = 5;
649 2         5 $Error = "IO::Socket::SSL->start_SSL failed: $msg";
650 2         4 return -24, $Error;
651             }
652              
653             sub _TLS_UNSUPPORTED_BY_ME {
654 2   100 2   1363 my $msg = shift || '';
655 2         4 $! = 5;
656 2         18 $Error = "TLS unsupported by the script: $msg";
657 2         6 return -25, $Error;
658             }
659              
660             sub _TLS_UNSUPPORTED_BY_SERVER {
661 1     1   720 $! = 5;
662 1         4 $Error = "TLS unsupported by server";
663 1         3 return -26, $Error;
664             }
665              
666             sub _UNKNOWNENCODING {
667 2   100 2   1407 my $msg = shift || '';
668 2         3 $! = 5;
669 2         6 $Error = "Unknown encoding '$msg'";
670 2         4 return -27, $Error;
671             }
672              
673             sub new {
674 19     19 1 4479 my $this = shift;
675 19         19 my $self = {};
676 19         17 my $class;
677 19 100       33 if (ref($this)) {
678 2         3 $class = ref($this);
679 2         12 %$self = %$this;
680             }
681             else {
682 17         14 $class = $this;
683             }
684 19         19 bless $self, $class;
685 19         32 return $self->_initialize(@_);
686             }
687              
688             sub _initialize {
689 19     19   13 undef $Error;
690 19         17 my $self = shift;
691              
692 19         20 delete $self->{'_buffer'};
693 19         24 $self->{'debug'} = 0;
694 19         891 $self->{'proto'} = (getprotobyname('tcp'))[2];
695              
696             $self->{'port'} = getservbyname('smtp', 'tcp') || 25
697 19 100 50     734 unless $self->{'port'};
698              
699 19         46 $self->{'boundary'} = 'Message-Boundary-by-Mail-Sender-' . time();
700 19         26 $self->{'multipart'} = 'mixed'; # default is multipart/mixed
701 19         13 $self->{'tls_allowed'} = 1;
702              
703 19         23 $self->{'client'} = $local_name;
704              
705             # Copy defaults from %default
706 19         51 foreach my $key (keys %default) {
707 36         62 $self->{lc $key} = $default{$key};
708             }
709              
710 19 100       40 if (@_ != 0) {
711 18 100       39 if (ref $_[0] eq 'HASH') {
712 17         15 my $hash = $_[0];
713 17         28 foreach my $key (keys %$hash) {
714 5         11 $self->{lc $key} = $hash->{$key};
715             }
716             $self->{'reply'} = $self->{'replyto'}
717 17 100 100     58 if ($self->{'replyto'} and !$self->{'reply'});
718             }
719             else {
720             (
721             $self->{'from'}, $self->{'reply'}, $self->{'to'},
722             $self->{'smtp'}, $self->{'subject'}, $self->{'headers'},
723 1         6 $self->{'boundary'}
724             ) = @_;
725             }
726             }
727              
728 19         28 $self->{'fromaddr'} = $self->{'from'};
729 19         18 $self->{'replyaddr'} = $self->{'reply'};
730              
731 19 100       40 $self->_prepare_addresses('to') if $self->{'to'};
732 19 100       29 $self->_prepare_addresses('cc') if $self->{'cc'};
733 19 100       32 $self->_prepare_addresses('bcc') if $self->{'bcc'};
734              
735 19 100       31 $self->_prepare_ESMTP() if defined $self->{'esmtp'};
736              
737             # get from email address
738 19 100       28 $self->{'fromaddr'} =~ s/.*<([^\s]*?)>/$1/ if ($self->{'fromaddr'});
739              
740 19 100       27 if ($self->{'replyaddr'}) {
741 4         8 $self->{'replyaddr'} =~ s/.*<([^\s]*?)>/$1/; # get reply email address
742 4         19 $self->{'replyaddr'} =~ s/^([^\s]+).*/$1/; # use first address
743             }
744              
745 19 100       310 if ($self->{'smtp'}) {
746 3         6 $self->{'smtp'} =~ s/^\s+//g; # remove spaces around $smtp
747 3         6 $self->{'smtp'} =~ s/\s+$//g;
748              
749 3 100       9414 unless ($self->{'smtpaddr'} = Socket::inet_aton($self->{'smtp'})) {
750 1         5 return $self->Error(_HOSTNOTFOUND($self->{'smtp'}));
751             }
752 2 50       14 $self->{'smtpaddr'} = $1 if ($self->{'smtpaddr'} =~ /(.*)/s); # Untaint
753             }
754              
755 18 100       43 $self->{'boundary'} =~ tr/=/-/ if defined $self->{'boundary'};
756              
757 18 100       33 $self->_prepare_headers() if defined $self->{'headers'};
758              
759 18         49 return $self;
760             }
761              
762             sub GuessCType {
763 7     7 1 1931 my $file = shift;
764 7 100 100     38 if (defined $file && $file =~ /\.(.*)$/) {
765 5   100     79 return $CTypes{uc($1)} || 'application/octet-stream';
766             }
767 2         4 return 'application/octet-stream';
768             }
769              
770             sub Connect {
771 0     0 1 0 my $self = shift();
772              
773             my $s = IO::Socket::INET->new(
774             PeerHost => $self->{'smtp'},
775             PeerPort => $self->{'port'},
776             Proto => "tcp",
777 0 0 0     0 Timeout => ($self->{'timeout'} || 120),
778             ) or return $self->Error(_CONNFAILED);
779              
780 0         0 $s->autoflush(1);
781 0         0 binmode($s);
782              
783 0 0       0 if ($self->{'debug'}) {
784 0 0       0 eval { $s = __Debug($s, $self->{'debug'}); }
  0         0  
785             or return $self->Error(_DEBUGFILE($@));
786 0 0       0 $self->{'debug_level'} = 4 unless defined $self->{'debug_level'};
787             }
788              
789 0         0 $_ = get_response($s);
790 0 0 0     0 if (not $_ or !/^[123]/) { return $self->Error(_SERVNOTAVAIL($_)); }
  0         0  
791 0         0 $self->{'server'} = substr $_, 4;
792 0         0 $self->{'!greeting'} = $_;
793              
794             {
795 0         0 my $res = $self->_say_helo($s);
  0         0  
796 0 0       0 return $res if $res;
797             }
798              
799 0 0 0     0 if (
    0 0        
      0        
      0        
800             ($self->{tls_required} or $self->{tls_allowed})
801             and !$TLS_notsupported
802             and ( defined($self->{'supports'}{STARTTLS})
803             or defined($self->{'supports'}{TLS}))
804             )
805             {
806 0         0 Net::SSLeay::load_error_strings();
807 0         0 Net::SSLeay::SSLeay_add_ssl_algorithms();
808 0 0       0 $Net::SSLeay::random_device = $0 if (!-s $Net::SSLeay::random_device);
809 0         0 Net::SSLeay::randomize();
810              
811 0         0 my $res = send_cmd $s, "STARTTLS";
812 0         0 my ($code, $text) = split(/\s/, $res, 2);
813              
814 0 0       0 return $self->Error(_STARTTLS($code, $text)) if ($code != 220);
815              
816 0         0 my %ssl_options = (
817             SSL_version => 'TLSv1',
818             SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE(),
819             );
820 0 0       0 if (exists $self->{ssl_version}) {
821 0         0 $ssl_options{SSL_version} = $self->{ssl_version};
822             }
823 0 0       0 if (exists $self->{ssl_verify_mode}) {
824 0         0 $ssl_options{SSL_verify_mode} = $self->{ssl_verify_mode};
825             }
826 0 0       0 if (exists $self->{ssl_ca_path}) {
827 0         0 $ssl_options{SSL_ca_path} = $self->{ssl_ca_path};
828             }
829 0 0       0 if (exists $self->{ssl_ca_file}) {
830 0         0 $ssl_options{SSL_ca_file} = $self->{ssl_ca_file};
831             }
832 0 0       0 if (exists $self->{ssl_verifycb_name}) {
833 0         0 $ssl_options{SSL_verifycb_name} = $self->{ssl_verifycb_name};
834             }
835 0 0       0 if (exists $self->{ssl_verifycn_schema}) {
836 0         0 $ssl_options{ssl_verifycn_schema} = $self->{ssl_verifycn_schema};
837             }
838 0 0       0 if (exists $self->{ssl_hostname}) {
839 0         0 $ssl_options{SSL_hostname} = $self->{ssl_hostname};
840             }
841              
842 0 0       0 if ($self->{'debug'}) {
843 0         0 $res = IO::Socket::SSL->start_SSL(tied(*$s)->[0], %ssl_options);
844             }
845             else {
846 0         0 $res = IO::Socket::SSL->start_SSL($s, %ssl_options);
847             }
848 0 0       0 if (!$res) {
849 0         0 return $self->Error(_IO_SOCKET_SSL(IO::Socket::SSL::errstr()));
850             }
851              
852             {
853 0         0 my $res = $self->_say_helo($s);
  0         0  
854 0 0       0 return $res if $res;
855             }
856             }
857             elsif ($self->{tls_required}) {
858 0 0       0 if ($TLS_notsupported) {
859 0         0 return $self->Error(_TLS_UNSUPPORTED_BY_ME($TLS_notsupported));
860             }
861             else {
862 0         0 return $self->Error(_TLS_UNSUPPORTED_BY_SERVER());
863             }
864             }
865              
866 0 0 0     0 if ($self->{'auth'} or $self->{'username'}) {
867 0         0 $self->{'socket'} = $s;
868 0         0 my $res = $self->login();
869 0 0       0 return $res if $res;
870 0         0 delete $self->{'socket'}; # it's supposed to be added later
871             }
872              
873 0         0 return $s;
874             }
875              
876             sub Error {
877 1     1 0 2 my $self = shift();
878 1 50       4 if (@_) {
879 1 50       4 if (defined $self->{'socket'}) {
880 0         0 my $s = $self->{'socket'};
881 0         0 print $s "quit\x0D\x0A";
882 0         0 close $s;
883 0         0 delete $self->{'socket'};
884             }
885 1         1 delete $self->{'_data'};
886 1         4 ($self->{'error'}, $self->{'error_msg'}) = @_;
887             }
888 1 50 33     12 if ($self->{'die_on_errors'} or ($self->{on_errors} && $self->{'on_errors'} eq 'die')) {
    50 33        
      0        
      33        
889 0         0 die $self->{'error_msg'} . "\n";
890             }
891             elsif (exists $self->{'on_errors'}
892             and (!defined($self->{'on_errors'}) or $self->{'on_errors'} eq 'undef'))
893             {
894 0         0 return;
895             }
896 1         7 return $self->{'error'};
897             }
898              
899             sub ClearErrors {
900 1     1 1 326 my $self = shift();
901 1         2 delete $self->{'error'};
902 1         1 delete $self->{'error_msg'};
903 1         3 undef $Error;
904             }
905              
906             sub _prepare_addresses {
907 17     17   1028 my ($self, $type) = @_;
908 17 100       27 if (ref $self->{$type}) {
909             $self->{$type . '_list'}
910 1         1 = [map { s/\s+$//; s/^\s+//; $_ } @{$self->{$type}}];
  2         3  
  2         3  
  2         6  
  1         4  
911 1         1 $self->{$type} = join ', ', @{$self->{$type . '_list'}};
  1         5  
912             }
913             else {
914 16         22 $self->{$type} =~ s/\s+/ /g;
915 16         16 $self->{$type} =~ s/, ?,/,/g;
916 16         16 $self->{$type . '_list'} = [map { s/\s+$//; $_ }
  16         43  
917 16         56 $self->{$type} =~ /((?:[^",]+|"[^"]*")+)(?:,\s*|\s*$)/g ];
918             }
919             }
920              
921             sub _prepare_ESMTP {
922 4     4   1094 my $self = shift;
923             $self->{esmtp}
924 4         4 = {%{$self->{esmtp}}}; # make a copy of the hash. Just in case
  4         17  
925              
926             $self->{esmtp}{ORCPT} = 'rfc822;' . $self->{esmtp}{ORCPT}
927 4 100 100     30 if $self->{esmtp}{ORCPT} ne '' and $self->{esmtp}{ORCPT} !~ /;/;
928 4         7 for (qw(ENVID ORCPT)) {
929 8         14 $self->{esmtp}{$_} = enc_xtext($self->{esmtp}{$_});
930             }
931             }
932              
933             sub _prepare_headers {
934 10     10   3561 my $self = shift;
935 10 100       24 return unless exists $self->{'headers'};
936 9 100       20 if ($self->{'headers'} eq '') {
937 5         6 delete $self->{'headers'};
938 5         5 delete $self->{'_headers'};
939 5         7 return;
940             }
941 4 100       14 if (ref($self->{'headers'}) eq 'HASH') {
    100          
942 2         3 my $headers = '';
943 2         2 while (my ($hdr, $value) = each %{$self->{'headers'}}) {
  4         14  
944 2         4 for ($hdr, $value) {
945 4         9 s/(?:\x0D\x0A?|\x0A)/\x0D\x0A/sg
946             ; # convert all end-of-lines to CRLF
947 4         4 s/^(?:\x0D\x0A)+//; # strip leading
948 4         6 s/(?:\x0D\x0A)+$//; # and trailing end-of-lines
949 4         3 s/\x0D\x0A(\S)/\x0D\x0A\t$1/sg;
950 4 100       9 if (length($_) > 997) { # header too long, max 1000 chars
951 1         340 s/(.{1,980}[;,])\s+(\S)/$1\x0D\x0A\t$2/g;
952             }
953             }
954 2         7 $headers .= "$hdr: $value\x0D\x0A";
955             }
956 2         9 $headers =~ s/(?:\x0D\x0A)+$//; # and trailing end-of-lines
957 2         6 $self->{'_headers'} = $headers;
958             }
959             elsif (ref($self->{'headers'})) {
960             }
961             else {
962 1         3 $self->{'_headers'} = $self->{'headers'};
963 1         2 for ($self->{'_headers'}) {
964 1         4 s/(?:\x0D\x0A?|\x0A)/\x0D\x0A/sg; # convert all end-of-lines to CRLF
965 1         1 s/^(?:\x0D\x0A)+//; # strip leading
966 1         4 s/(?:\x0D\x0A)+$//; # and trailing end-of-lines
967             }
968             }
969             }
970              
971             sub Open {
972 0     0 1 0 undef $Error;
973 0         0 my $self = shift;
974 0         0 local $_;
975 0 0 0     0 if (!$self->{'keepconnection'} and $self->{'_data'})
976             { # the user did not Close() or Cancel() the previous mail
977 0 0       0 if ($self->{'error'}) {
978 0         0 $self->Cancel;
979             }
980             else {
981 0         0 $self->Close;
982             }
983             }
984              
985 0         0 delete $self->{'error'};
986 0         0 delete $self->{'encoding'};
987 0         0 delete $self->{'messageid'};
988 0         0 my %changed;
989 0         0 $self->{'multipart'} = 0;
990 0         0 $self->{'_had_newline'} = 1;
991              
992 0 0       0 if (ref $_[0] eq 'HASH') {
993 0         0 my $key;
994 0         0 my $hash = $_[0];
995             $hash->{'reply'} = $hash->{'replyto'}
996 0 0 0     0 if (defined $hash->{'replyto'} and !defined $hash->{'reply'});
997 0         0 foreach $key (keys %$hash) {
998 0 0 0     0 if (ref($hash->{$key}) eq 'HASH' and exists $self->{lc $key}) {
999 0 0       0 if (ref($self->{lc $key}) eq 'HASH') {
1000 0         0 $self->{lc $key} = {%{$self->{lc $key}}, %{$hash->{$key}}};
  0         0  
  0         0  
1001             }
1002             else {
1003 0         0 $self->{lc $key} = {%{$hash->{$key}}}; # make a shallow copy
  0         0  
1004             }
1005             }
1006             else {
1007 0         0 $self->{lc $key} = $hash->{$key};
1008             }
1009 0         0 $changed{lc $key} = 1;
1010             }
1011             }
1012             else {
1013 0         0 my ($from, $reply, $to, $smtp, $subject, $headers) = @_;
1014              
1015 0 0       0 if ($from) { $self->{'from'} = $from; $changed{'from'} = 1; }
  0         0  
  0         0  
1016 0 0       0 if ($reply) { $self->{'reply'} = $reply; $changed{'reply'} = 1; }
  0         0  
  0         0  
1017 0 0       0 if ($to) { $self->{'to'} = $to; $changed{'to'} = 1; }
  0         0  
  0         0  
1018 0 0       0 if ($smtp) { $self->{'smtp'} = $smtp; $changed{'smtp'} = 1; }
  0         0  
  0         0  
1019 0 0       0 if ($subject) {
1020 0         0 $self->{'subject'} = $subject;
1021 0         0 $changed{'subject'} = 1;
1022             }
1023 0 0       0 if ($headers) {
1024 0         0 $self->{'headers'} = $headers;
1025 0         0 $changed{'headers'} = 1;
1026             }
1027             }
1028              
1029 0 0       0 $self->_prepare_addresses('to') if $changed{'to'};
1030 0 0       0 $self->_prepare_addresses('cc') if $changed{'cc'};
1031 0 0       0 $self->_prepare_addresses('bcc') if $changed{'bcc'};
1032              
1033 0 0       0 $self->_prepare_ESMTP() if defined $changed{'esmtp'};
1034              
1035 0 0       0 $self->{'boundary'} =~ tr/=/-/ if defined $changed{'boundary'};
1036              
1037 0 0       0 return $self->Error(_NOFROMSPECIFIED) unless defined $self->{'from'};
1038              
1039 0 0       0 if ($changed{'from'}) {
1040 0         0 $self->{'fromaddr'} = $self->{'from'};
1041 0         0 $self->{'fromaddr'} =~ s/.*<([^\s]*?)>/$1/; # get from email address
1042             }
1043              
1044 0 0       0 if ($changed{'reply'}) {
1045 0         0 $self->{'replyaddr'} = $self->{'reply'};
1046 0         0 $self->{'replyaddr'} =~ s/.*<([^\s]*?)>/$1/; # get reply email address
1047 0         0 $self->{'replyaddr'} =~ s/^([^\s]+).*/$1/; # use first address
1048             }
1049              
1050 0 0       0 if ($changed{'smtp'}) {
1051 0         0 $self->{'smtp'} =~ s/^\s+//g; # remove spaces around $smtp
1052 0         0 $self->{'smtp'} =~ s/\s+$//g;
1053 0         0 $self->{'smtpaddr'} = Socket::inet_aton($self->{'smtp'});
1054 0 0       0 if (!defined($self->{'smtpaddr'})) {
1055 0         0 return $self->Error(_HOSTNOTFOUND($self->{'smtp'}));
1056             }
1057 0 0       0 $self->{'smtpaddr'} = $1 if ($self->{'smtpaddr'} =~ /(.*)/s); # Untaint
1058 0 0       0 if (exists $self->{'socket'}) {
1059 0         0 my $s = $self->{'socket'};
1060 0         0 close $s;
1061 0         0 delete $self->{'socket'};
1062             }
1063             }
1064              
1065 0 0       0 $self->_prepare_headers() if ($changed{'headers'});
1066              
1067 0 0       0 if (!$self->{'to'}) { return $self->Error(_TOEMPTY); }
  0         0  
1068              
1069 0 0       0 return $self->Error(_NOSERVER) unless defined $self->{'smtp'};
1070              
1071 0 0 0     0 if ($Mail::Sender::{'SiteHook'} and !$self->SiteHook()) {
1072 0 0       0 return defined $self->{'error'} ? $self->{'error'} : $self->{'error'}
1073             = _SITEERROR();
1074             }
1075              
1076 0   0     0 my $s = $self->{'socket'} || $self->Connect();
1077 0 0       0 return $s
1078             unless ref $s; # return the error number if we did not get a socket
1079 0         0 $self->{'socket'} = $s;
1080              
1081             $_ = send_cmd $s,
1082 0   0     0 "MAIL FROM:<".($self->{'fromaddr'}||'').">".($self->{esmtp}{_MAIL_FROM}||'');
      0        
1083 0 0       0 if (!/^[123]/) { return $self->Error(_COMMERROR($_)); }
  0         0  
1084              
1085             {
1086 0         0 local $^W;
  0         0  
1087 0 0       0 if ($self->{'skip_bad_recipients'}) {
1088 0         0 my $good_count = 0;
1089 0         0 my %failed;
1090 0         0 foreach my $addr (
1091 0         0 @{$self->{'to_list'}},
1092 0         0 @{$self->{'cc_list'}},
1093 0         0 @{$self->{'bcc_list'}}
1094             )
1095             {
1096 0 0       0 if ($addr =~ /<(.*)>/) {
1097 0         0 $_ = send_cmd $s, "RCPT TO:<$1>$self->{esmtp}{_RCPT_TO}";
1098             }
1099             else {
1100 0         0 $_ = send_cmd $s, "RCPT TO:<$addr>$self->{esmtp}{_RCPT_TO}";
1101             }
1102 0 0       0 if (!/^[123]/) {
1103 0         0 chomp;
1104 0         0 s/^\d{3} //;
1105 0         0 $failed{$addr} = $_;
1106             }
1107             else {
1108 0         0 $good_count++;
1109             }
1110             }
1111 0 0       0 $self->{'skipped_recipients'} = \%failed if %failed;
1112 0 0       0 if ($good_count == 0) {
1113 0         0 return $self->Error(_ALLRECIPIENTSBAD);
1114             }
1115             }
1116             else {
1117 0         0 foreach my $addr (
1118 0         0 @{$self->{'to_list'}},
1119 0         0 @{$self->{'cc_list'}},
1120 0         0 @{$self->{'bcc_list'}}
1121             )
1122             {
1123 0 0       0 if ($addr =~ /<(.*)>/) {
1124 0         0 $_ = send_cmd $s, "RCPT TO:<$1>$self->{esmtp}{_RCPT_TO}";
1125             }
1126             else {
1127 0   0     0 $_ = send_cmd $s, "RCPT TO:<".($addr||'').">".($self->{esmtp}{_RCPT_TO}||'');
      0        
1128             }
1129 0 0       0 if (!/^[123]/) {
1130             return $self->Error(
1131 0         0 _USERUNKNOWN($addr, $self->{'smtp'}, $_));
1132             }
1133             }
1134             }
1135             }
1136              
1137 0         0 $_ = send_cmd $s, "DATA";
1138 0 0       0 if (!/^[123]/) { return $self->Error(_COMMERROR($_)); }
  0         0  
1139              
1140             $self->{'socket'}
1141             ->stop_logging("\x0D\x0A... message headers and data skipped ...")
1142 0 0 0     0 if ($self->{'debug'} and $self->{'debug_level'} <= 1);
1143 0         0 $self->{'_data'} = 1;
1144              
1145             $self->{'ctype'} = 'text/plain'
1146 0 0 0     0 if (defined $self->{'charset'} and !defined $self->{'ctype'});
1147              
1148 0         0 my $headers;
1149 0 0 0     0 if (defined $self->{'encoding'} or defined $self->{'ctype'}) {
1150 0         0 $headers = 'MIME-Version: 1.0';
1151             $headers .= "\r\nContent-Type: $self->{'ctype'}"
1152 0 0       0 if defined $self->{'ctype'};
1153             $headers .= "; charset=$self->{'charset'}"
1154 0 0       0 if defined $self->{'charset'};
1155              
1156 0         0 undef $self->{'chunk_size'};
1157 0 0       0 if (defined $self->{'encoding'}) {
1158 0         0 $headers .= "\r\nContent-Transfer-Encoding: $self->{'encoding'}";
1159 0 0       0 if ($self->{'encoding'} =~ /Base64/i) {
    0          
    0          
1160 0         0 $self->{'code'} = enc_base64($self->{'charset'});
1161 0         0 $self->{'chunk_size'} = $enc_base64_chunk;
1162             }
1163             elsif ($self->{'encoding'} =~ /Quoted[_\-]print/i) {
1164 0         0 $self->{'code'} = enc_qp($self->{'charset'});
1165             }
1166             elsif ($self->{'encoding'} =~ /^[78]bit$/i) {
1167 0         0 $self->{'code'} = enc_plain($self->{charset});
1168             }
1169             else {
1170 0         0 return $self->Error(_UNKNOWNENCODING($self->{'encoding'}));
1171             }
1172             }
1173             }
1174              
1175 0 0       0 $self->{'code'} = enc_plain($self->{charset}) unless $self->{'code'};
1176              
1177             _print_hdr $s,
1178             "To" =>
1179             (defined $self->{'fake_to'} ? $self->{'fake_to'} : $self->{'to'}),
1180 0 0       0 $self->{'charset'};
1181             _print_hdr $s,
1182             "From" =>
1183             (defined $self->{'fake_from'} ? $self->{'fake_from'} : $self->{'from'}),
1184 0 0       0 $self->{'charset'};
1185 0 0 0     0 if (defined $self->{'fake_cc'} and $self->{'fake_cc'}) {
    0 0        
1186 0         0 _print_hdr $s, "Cc" => $self->{'fake_cc'}, $self->{'charset'};
1187             }
1188             elsif (defined $self->{'cc'} and $self->{'cc'}) {
1189 0         0 _print_hdr $s, "Cc" => $self->{'cc'}, $self->{'charset'};
1190             }
1191             _print_hdr $s, "Reply-To", $self->{'reply'}, $self->{'charset'}
1192 0 0       0 if defined $self->{'reply'};
1193              
1194 0 0       0 $self->{'subject'} = "" unless defined $self->{'subject'};
1195 0         0 _print_hdr $s, "Subject" => $self->{'subject'}, $self->{'charset'};
1196              
1197 0 0 0     0 unless (defined $Mail::Sender::NO_DATE and $Mail::Sender::NO_DATE
      0        
      0        
      0        
      0        
1198             or defined $self->{'_headers'} and $self->{'_headers'} =~ /^Date:/m
1199             or defined $Mail::Sender::SITE_HEADERS
1200             && $Mail::Sender::SITE_HEADERS =~ /^Date:/m)
1201             {
1202 0         0 my $date = localtime();
1203 0         0 $date
1204             =~ s/^(\w+)\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)$/$1, $3 $2 $5 $4/;
1205 0         0 _print_hdr $s, "Date" => "$date $GMTdiff";
1206             }
1207              
1208 0 0       0 if ($self->{'priority'}) {
1209             $self->{'priority'} = $priority[$self->{'priority'}]
1210 0 0       0 if ($self->{'priority'} + 0 eq $self->{'priority'});
1211 0         0 _print_hdr $s, "X-Priority" => $self->{'priority'};
1212             }
1213              
1214 0 0       0 if ($self->{'confirm'}) {
1215 0         0 for my $confirm (split /\s*,\s*/, $self->{'confirm'}) {
1216 0 0       0 if ($confirm =~ /^\s*reading\s*(?:\:\s*(.*))?/i) {
    0          
1217             _print_hdr $s,
1218             "X-Confirm-Reading-To" => ($1 || $self->{'from'}),
1219 0   0     0 $self->{'charset'};
1220             }
1221             elsif ($confirm =~ /^\s*delivery\s*(?:\:\s*(.*))?/i) {
1222             _print_hdr $s,
1223             "Return-Receipt-To" => ($1 || $self->{'fromaddr'}),
1224 0   0     0 $self->{'charset'};
1225             _print_hdr $s,
1226             "Disposition-Notification-To" =>
1227             ($1 || $self->{'fromaddr'}),
1228 0   0     0 $self->{'charset'};
1229             }
1230             }
1231             }
1232              
1233 0 0       0 unless (defined $Mail::Sender::NO_X_MAILER) {
1234 0         0 my $script = File::Basename::basename($0);
1235 0         0 _print_hdr $s,
1236             "X-Mailer" =>
1237             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 "}
1238             . getusername()
1239             . qq{"\r\n};
1240             }
1241              
1242 0 0 0     0 unless (defined $Mail::Sender::NO_MESSAGE_ID
1243             and $Mail::Sender::NO_MESSAGE_ID)
1244             {
1245 0 0 0     0 if (!defined $self->{'messageid'} or $self->{'messageid'} eq '') {
1246 0 0 0     0 if (defined $self->{'createmessageid'}
1247             and ref $self->{'createmessageid'} eq 'CODE')
1248             {
1249             $self->{'messageid'}
1250 0         0 = $self->{'createmessageid'}->($self->{'fromaddr'});
1251             }
1252             else {
1253 0         0 $self->{'messageid'} = MessageID($self->{'fromaddr'});
1254             }
1255             }
1256 0         0 _print_hdr $s, "Message-ID" => $self->{'messageid'};
1257             }
1258              
1259 0 0       0 print $s $Mail::Sender::SITE_HEADERS,
1260             "\x0D\x0A" # should handle \r\n at the end of the headers
1261             if (defined $Mail::Sender::SITE_HEADERS);
1262              
1263             print $s $self->{'_headers'}, "\x0D\x0A"
1264 0 0 0     0 if defined $self->{'_headers'} and $self->{'_headers'};
1265 0 0       0 print $s $headers, "\r\n" if defined $headers;
1266              
1267 0         0 print $s "\r\n";
1268              
1269             $self->{'socket'}->stop_logging("... message data skipped ...")
1270 0 0 0     0 if ($self->{'debug'} and $self->{'debug_level'} <= 2);
1271              
1272 0         0 return $self;
1273             }
1274              
1275             sub OpenMultipart {
1276 0     0 1 0 undef $Error;
1277 0         0 my $self = shift;
1278              
1279 0         0 local $_;
1280 0 0 0     0 if (!$self->{'keepconnection'} and $self->{'_data'})
1281             { # the user did not Close() or Cancel() the previous mail
1282 0 0       0 if ($self->{'error'}) {
1283 0         0 $self->Cancel;
1284             }
1285             else {
1286 0         0 $self->Close;
1287             }
1288             }
1289              
1290 0         0 delete $self->{'error'};
1291 0         0 delete $self->{'encoding'};
1292 0         0 delete $self->{'messageid'};
1293 0         0 $self->{'_part'} = 0;
1294              
1295 0         0 my %changed;
1296 0 0 0     0 if (defined $self->{'type'} and $self->{'type'}) {
1297 0 0       0 $self->{'multipart'} = $1 if $self->{'type'} =~ m{^multipart/(.*)}i;
1298             }
1299 0 0       0 $self->{'multipart'} = 'Mixed' unless $self->{'multipart'};
1300 0         0 $self->{'idcounter'} = 0;
1301              
1302 0 0       0 if (ref $_[0] eq 'HASH') {
1303 0         0 my $key;
1304 0         0 my $hash = $_[0];
1305 0 0       0 $hash->{'multipart'} = $hash->{'subtype'} if defined $hash->{'subtype'};
1306             $hash->{'reply'} = $hash->{'replyto'}
1307 0 0 0     0 if (defined $hash->{'replyto'} and !defined $hash->{'reply'});
1308 0         0 foreach $key (keys %$hash) {
1309 0 0 0     0 if ((ref($hash->{$key}) eq 'HASH') and exists($self->{lc $key})) {
1310 0 0       0 if (ref($self->{lc $key}) eq 'HASH') {
1311 0         0 $self->{lc $key} = {%{$self->{lc $key}}, %{$hash->{$key}}};
  0         0  
  0         0  
1312             }
1313             else {
1314 0         0 $self->{lc $key} = {%{$hash->{$key}}}; # make a shallow copy
  0         0  
1315             }
1316             }
1317             else {
1318 0         0 $self->{lc $key} = $hash->{$key};
1319             }
1320 0         0 $changed{lc $key} = 1;
1321             }
1322             }
1323             else {
1324 0         0 my ($from, $reply, $to, $smtp, $subject, $headers, $boundary) = @_;
1325              
1326 0 0       0 if ($from) { $self->{'from'} = $from; $changed{'from'} = 1; }
  0         0  
  0         0  
1327 0 0       0 if ($reply) { $self->{'reply'} = $reply; $changed{'reply'} = 1; }
  0         0  
  0         0  
1328 0 0       0 if ($to) { $self->{'to'} = $to; $changed{'to'} = 1; }
  0         0  
  0         0  
1329 0 0       0 if ($smtp) { $self->{'smtp'} = $smtp; $changed{'smtp'} = 1; }
  0         0  
  0         0  
1330 0 0       0 if ($subject) {
1331 0         0 $self->{'subject'} = $subject;
1332 0         0 $changed{'subject'} = 1;
1333             }
1334 0 0       0 if ($headers) {
1335 0         0 $self->{'headers'} = $headers;
1336 0         0 $changed{'headers'} = 1;
1337             }
1338 0 0       0 if ($boundary) { $self->{'boundary'} = $boundary; }
  0         0  
1339             }
1340              
1341 0 0       0 $self->_prepare_addresses('to') if $changed{'to'};
1342 0 0       0 $self->_prepare_addresses('cc') if $changed{'cc'};
1343 0 0       0 $self->_prepare_addresses('bcc') if $changed{'bcc'};
1344              
1345 0 0       0 $self->_prepare_ESMTP() if defined $changed{'esmtp'};
1346              
1347 0 0       0 $self->{'boundary'} =~ tr/=/-/ if $changed{'boundary'};
1348              
1349 0 0       0 $self->_prepare_headers() if ($changed{'headers'});
1350              
1351 0 0       0 return $self->Error(_NOFROMSPECIFIED) unless defined $self->{'from'};
1352 0 0       0 if ($changed{'from'}) {
1353 0         0 $self->{'fromaddr'} = $self->{'from'};
1354 0         0 $self->{'fromaddr'} =~ s/.*<([^\s]*?)>/$1/; # get from email address
1355             }
1356              
1357 0 0       0 if ($changed{'reply'}) {
1358 0         0 $self->{'replyaddr'} = $self->{'reply'};
1359 0         0 $self->{'replyaddr'} =~ s/.*<([^\s]*?)>/$1/; # get reply email address
1360 0         0 $self->{'replyaddr'} =~ s/^([^\s]+).*/$1/; # use first address
1361             }
1362              
1363 0 0       0 if ($changed{'smtp'}) {
1364 0         0 $self->{'smtp'} =~ s/^\s+//g; # remove spaces around $smtp
1365 0         0 $self->{'smtp'} =~ s/\s+$//g;
1366 0         0 $self->{'smtpaddr'} = Socket::inet_aton($self->{'smtp'});
1367 0 0       0 if (!defined($self->{'smtpaddr'})) {
1368 0         0 return $self->Error(_HOSTNOTFOUND($self->{'smtp'}));
1369             }
1370 0 0       0 $self->{'smtpaddr'} = $1 if ($self->{'smtpaddr'} =~ /(.*)/s); # Untaint
1371 0 0       0 if (exists $self->{'socket'}) {
1372 0         0 my $s = $self->{'socket'};
1373 0         0 close $s;
1374 0         0 delete $self->{'socket'};
1375             }
1376             }
1377              
1378 0 0       0 if (!$self->{'to'}) { return $self->Error(_TOEMPTY); }
  0         0  
1379              
1380 0 0       0 return $self->Error(_NOSERVER) unless defined $self->{'smtp'};
1381              
1382             # if (!defined($self->{'smtpaddr'})) { return $self->Error(_HOSTNOTFOUND($self->{'smtp'})); }
1383              
1384 0 0 0     0 if ($Mail::Sender::{'SiteHook'} and !$self->SiteHook()) {
1385 0 0       0 return defined $self->{'error'} ? $self->{'error'} : $self->{'error'}
1386             = _SITEERROR();
1387             }
1388              
1389 0   0     0 my $s = $self->{'socket'} || $self->Connect();
1390 0 0       0 return $s
1391             unless ref $s; # return the error number if we did not get a socket
1392 0         0 $self->{'socket'} = $s;
1393              
1394 0         0 $_ = send_cmd $s,
1395             "MAIL FROM:<$self->{'fromaddr'}>$self->{esmtp}{_MAIL_FROM}";
1396 0 0       0 if (!/^[123]/) { return $self->Error(_COMMERROR($_)); }
  0         0  
1397              
1398             {
1399 0         0 local $^W;
  0         0  
1400 0 0       0 if ($self->{'skip_bad_recipients'}) {
1401 0         0 my $good_count = 0;
1402 0         0 my %failed;
1403 0         0 foreach my $addr (
1404 0         0 @{$self->{'to_list'}},
1405 0         0 @{$self->{'cc_list'}},
1406 0         0 @{$self->{'bcc_list'}}
1407             )
1408             {
1409 0 0       0 if ($addr =~ /<(.*)>/) {
1410 0         0 $_ = send_cmd $s, "RCPT TO:<$1>$self->{esmtp}{_RCPT_TO}";
1411             }
1412             else {
1413 0         0 $_ = send_cmd $s, "RCPT TO:<$addr>$self->{esmtp}{_RCPT_TO}";
1414             }
1415 0 0       0 if (!/^[123]/) {
1416 0         0 s/^\d{3} //;
1417 0         0 $failed{$addr} = $_;
1418             }
1419             else {
1420 0         0 $good_count++;
1421             }
1422             }
1423 0 0       0 $self->{'skipped_recipients'} = \%failed if %failed;
1424 0 0       0 if ($good_count == 0) {
1425 0         0 return $self->Error(_ALLRECIPIENTSBAD);
1426             }
1427             }
1428             else {
1429 0         0 foreach my $addr (
1430 0         0 @{$self->{'to_list'}},
1431 0         0 @{$self->{'cc_list'}},
1432 0         0 @{$self->{'bcc_list'}}
1433             )
1434             {
1435 0 0       0 if ($addr =~ /<(.*)>/) {
1436 0         0 $_ = send_cmd $s, "RCPT TO:<$1>$self->{esmtp}{_RCPT_TO}";
1437             }
1438             else {
1439 0         0 $_ = send_cmd $s, "RCPT TO:<$addr>$self->{esmtp}{_RCPT_TO}";
1440             }
1441 0 0       0 if (!/^[123]/) {
1442             return $self->Error(
1443 0         0 _USERUNKNOWN($addr, $self->{'smtp'}, $_));
1444             }
1445             }
1446             }
1447             }
1448              
1449 0         0 $_ = send_cmd $s, "DATA";
1450 0 0       0 if (!/^[123]/) { return $self->Error(_COMMERROR($_)); }
  0         0  
1451              
1452             $self->{'socket'}
1453             ->stop_logging("\x0D\x0A... message headers and data skipped ...")
1454 0 0 0     0 if ($self->{'debug'} and $self->{'debug_level'} <= 1);
1455 0         0 $self->{'_data'} = 1;
1456              
1457             _print_hdr $s,
1458             "To" =>
1459             (defined $self->{'fake_to'} ? $self->{'fake_to'} : $self->{'to'}),
1460 0 0       0 $self->{'charset'};
1461             _print_hdr $s,
1462             "From" =>
1463             (defined $self->{'fake_from'} ? $self->{'fake_from'} : $self->{'from'}),
1464 0 0       0 $self->{'charset'};
1465 0 0 0     0 if (defined $self->{'fake_cc'} and $self->{'fake_cc'}) {
    0 0        
1466 0         0 _print_hdr $s, "Cc" => $self->{'fake_cc'}, $self->{'charset'};
1467             }
1468             elsif (defined $self->{'cc'} and $self->{'cc'}) {
1469 0         0 _print_hdr $s, "Cc" => $self->{'cc'}, $self->{'charset'};
1470             }
1471             _print_hdr $s,
1472             "Reply-To" => $self->{'reply'},
1473             $self->{'charset'}
1474 0 0       0 if defined $self->{'reply'};
1475              
1476 0 0       0 $self->{'subject'} = "" unless defined $self->{'subject'};
1477 0         0 _print_hdr $s, "Subject" => $self->{'subject'}, $self->{'charset'};
1478              
1479 0 0 0     0 unless (defined $Mail::Sender::NO_DATE and $Mail::Sender::NO_DATE
      0        
      0        
      0        
      0        
1480             or defined $self->{'_headers'} and $self->{'_headers'} =~ /^Date:/m
1481             or defined $Mail::Sender::SITE_HEADERS
1482             && $Mail::Sender::SITE_HEADERS =~ /^Date:/m)
1483             {
1484 0         0 my $date = localtime();
1485 0         0 $date
1486             =~ s/^(\w+)\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)$/$1, $3 $2 $5 $4/;
1487 0         0 _print_hdr $s, "Date" => "$date $GMTdiff";
1488             }
1489              
1490 0 0       0 if ($self->{'priority'}) {
1491             $self->{'priority'} = $priority[$self->{'priority'}]
1492 0 0       0 if ($self->{'priority'} + 0 eq $self->{'priority'});
1493 0         0 _print_hdr $s, "X-Priority" => $self->{'priority'};
1494             }
1495              
1496 0 0       0 if ($self->{'confirm'}) {
1497 0         0 for my $confirm (split /\s*,\s*/, $self->{'confirm'}) {
1498 0 0       0 if ($confirm =~ /^\s*reading\s*(?:\:\s*(.*))?/i) {
    0          
1499             _print_hdr $s,
1500             "X-Confirm-Reading-To" => ($1 || $self->{'from'}),
1501 0   0     0 $self->{'charset'};
1502             }
1503             elsif ($confirm =~ /^\s*delivery\s*(?:\:\s*(.*))?/i) {
1504             _print_hdr $s,
1505             "Return-Receipt-To" => ($1 || $self->{'fromaddr'}),
1506 0   0     0 $self->{'charset'};
1507             _print_hdr $s,
1508             "Disposition-Notification-To" =>
1509             ($1 || $self->{'fromaddr'}),
1510 0   0     0 $self->{'charset'};
1511             }
1512             }
1513             }
1514              
1515 0 0 0     0 unless (defined $Mail::Sender::NO_X_MAILER and $Mail::Sender::NO_X_MAILER) {
1516 0         0 my $script = File::Basename::basename($0);
1517 0         0 _print_hdr $s,
1518             "X-Mailer" =>
1519             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 "}
1520             . getusername()
1521             . qq{"\r\n};
1522             }
1523              
1524 0 0       0 print $s $Mail::Sender::SITE_HEADERS, "\r\n"
1525             if (defined $Mail::Sender::SITE_HEADERS);
1526              
1527 0 0 0     0 unless (defined $Mail::Sender::NO_MESSAGE_ID
1528             and $Mail::Sender::NO_MESSAGE_ID)
1529             {
1530 0 0 0     0 if (!defined $self->{'messageid'} or $self->{'messageid'} eq '') {
1531 0 0 0     0 if (defined $self->{'createmessageid'}
1532             and ref $self->{'createmessageid'} eq 'CODE')
1533             {
1534             $self->{'messageid'}
1535 0         0 = $self->{'createmessageid'}->($self->{'fromaddr'});
1536             }
1537             else {
1538 0         0 $self->{'messageid'} = MessageID($self->{'fromaddr'});
1539             }
1540             }
1541 0         0 _print_hdr $s, "Message-ID" => $self->{'messageid'};
1542             }
1543              
1544             print $s $self->{'_headers'}, "\r\n"
1545 0 0 0     0 if defined $self->{'_headers'} and $self->{'_headers'};
1546 0         0 print $s "MIME-Version: 1.0\r\n";
1547 0         0 _print_hdr $s, "Content-Type",
1548             qq{multipart/$self->{'multipart'};\r\n\tboundary="$self->{'boundary'}"};
1549              
1550 0         0 print $s "\r\n";
1551             $self->{'socket'}->stop_logging("... message data skipped ...")
1552 0 0 0     0 if ($self->{'debug'} and $self->{'debug_level'} <= 2);
1553              
1554 0         0 print $s
1555             "This message is in MIME format. Since your mail reader does not understand\r\n"
1556             . "this format, some or all of this message may not be legible.\r\n"
1557             . "\r\n--$self->{'boundary'}\r\n";
1558              
1559 0         0 return $self;
1560             }
1561              
1562             sub Connected {
1563 0     0 1 0 my $self = shift();
1564 0 0 0     0 return unless exists $self->{'socket'} and $self->{'socket'};
1565 0         0 my $s = $self->{'socket'};
1566 0         0 return $s->opened();
1567             }
1568              
1569             sub MailMsg {
1570 0     0 1 0 my $self = shift;
1571 0         0 my $msg;
1572 0         0 local $_;
1573 0 0       0 if (ref $_[0] eq 'HASH') {
1574 0         0 my $hash = $_[0];
1575 0         0 $msg = $hash->{'msg'};
1576             }
1577             else {
1578 0         0 $msg = pop;
1579             }
1580 0 0       0 return $self->Error(_NOMSG) unless $msg;
1581              
1582 0 0 0     0 if (ref $self->Open(@_) and ref $self->SendEnc($msg) and ref $self->Close())
      0        
1583             {
1584 0         0 return $self;
1585             }
1586             else {
1587 0         0 return $self->{'error'};
1588             }
1589             }
1590              
1591             sub MailFile {
1592 0     0 1 0 my $self = shift;
1593 0         0 my $msg;
1594 0         0 local $_;
1595 0         0 my ($file, $desc, $haddesc, $ctype, $charset, $encoding);
1596 0         0 my @files;
1597 0         0 my $hash;
1598 0 0       0 if (ref $_[0] eq 'HASH') {
1599 0         0 $hash = {%{$_[0]}}; # make a copy
  0         0  
1600              
1601 0         0 $msg = delete $hash->{'msg'};
1602              
1603 0         0 $file = delete $hash->{'file'};
1604              
1605 0         0 $desc = delete $hash->{'description'};
1606 0 0       0 $haddesc = 1 if defined $desc;
1607              
1608 0         0 $ctype = delete $hash->{'ctype'};
1609              
1610 0         0 $charset = delete $hash->{'charset'};
1611              
1612 0         0 $encoding = delete $hash->{'encoding'};
1613             }
1614             else {
1615 0 0       0 $desc = pop if ($#_ >= 2);
1616 0 0       0 $haddesc = 1 if defined $desc;
1617 0         0 $file = pop;
1618 0         0 $msg = pop;
1619             }
1620 0 0       0 return $self->Error(_NOMSG) unless $msg;
1621 0 0       0 return $self->Error(_NOFILE) unless $file;
1622              
1623 0 0       0 if (ref $file eq 'ARRAY') {
    0          
1624 0         0 @files = @$file;
1625             }
1626             elsif ($file =~ /,/) {
1627 0         0 @files = split / *, */, $file;
1628             }
1629             else {
1630 0         0 @files = ($file);
1631             }
1632 0         0 foreach $file (@files) {
1633 0 0 0     0 return $self->Error(_FILENOTFOUND($file))
1634             unless ($file =~ /^&/ or -e $file);
1635             }
1636              
1637             ref $self->OpenMultipart($hash ? $hash : @_)
1638             and ref $self->Body($self->{'b_charset'} || $self->{'charset'},
1639             $self->{'b_encoding'}, $self->{'b_ctype'})
1640             and $self->SendEnc($msg)
1641 0 0 0     0 or return $self->{'error'};
    0 0        
      0        
1642              
1643 0         0 $Error = '';
1644 0         0 foreach $file (@files) {
1645 0         0 my $cnt;
1646 0         0 my $filename = File::Basename::basename $file;
1647 0   0     0 my $ctype = $ctype || GuessCType $filename, $file;
1648 0   0     0 my $encoding = $encoding
1649             || ($ctype =~ m#^text/#i ? 'Quoted-printable' : 'Base64');
1650              
1651 0 0       0 $desc = $filename unless (defined $haddesc);
1652              
1653             $self->Part(
1654             {
1655             encoding => $encoding,
1656             disposition => (
1657 0 0       0 defined $self->{'disposition'} ? $self->{'disposition'}
    0          
    0          
1658             : "attachment; filename=\"$filename\""
1659             ),
1660             ctype => (
1661             $ctype =~ /;\s*name(?:\*(?:0\*?)?)?=/ ? $ctype
1662             : "$ctype; name=\"$filename\""
1663             )
1664             . (defined $charset ? "; charset=$charset" : ''),
1665             description => $desc
1666             }
1667             );
1668              
1669 0         0 my $code = $self->{'code'};
1670              
1671 0 0       0 open my $FH, "<", $file or return $self->Error(_FILECANTREAD($file));
1672 0 0 0     0 binmode $FH
1673             unless $ctype =~ m#^text/#i
1674             and $encoding =~ /Quoted[_\-]print|Base64/i;
1675 0         0 my $s;
1676 0         0 $s = $self->{'socket'};
1677 0         0 my $mychunksize = $chunksize;
1678 0 0       0 $mychunksize = $chunksize64 if defined $self->{'chunk_size'};
1679 0         0 while (read $FH, $cnt, $mychunksize) {
1680 0         0 $cnt = $code->($cnt);
1681 0 0       0 $cnt =~ s/^\.\././ unless $self->{'_had_newline'};
1682 0         0 print $s $cnt;
1683 0         0 $self->{'_had_newline'} = ($cnt =~ /[\n\r]$/);
1684             }
1685 0         0 close $FH;
1686             }
1687              
1688 0 0       0 if ($Error eq '') {
1689 0         0 undef $Error;
1690             }
1691             else {
1692 0         0 chomp $Error;
1693             }
1694 0         0 return $self->Close;
1695             }
1696              
1697             sub Send {
1698 0     0 1 0 my $self = shift;
1699 0         0 my $s;
1700 0         0 $s = $self->{'socket'};
1701 0         0 print $s @_;
1702 0         0 return $self;
1703             }
1704              
1705             sub SendLine {
1706 0     0 1 0 my $self = shift;
1707 0         0 my $s = $self->{'socket'};
1708 0         0 print $s (@_, "\x0D\x0A");
1709 0         0 return $self;
1710             }
1711              
1712 0     0 1 0 sub print { return shift->SendEnc(@_) }
1713 0     0 1 0 sub SendLineEnc { push @_, "\r\n"; return shift->SendEnc(@_) }
  0         0  
1714              
1715             sub SendEnc {
1716 0     0 1 0 my $self = shift;
1717 0         0 local $_;
1718 0         0 my $code = $self->{'code'};
1719 0 0       0 $self->{'code'} = $code = enc_plain($self->{'charset'})
1720             unless defined $code;
1721 0         0 my $s;
1722 0 0       0 $s = $self->{'socket'} or return $self->Error(_NOTCONNECTED);
1723 0 0       0 if (defined $self->{'chunk_size'}) {
1724 0         0 my $str;
1725 0         0 my $chunk = $self->{'chunk_size'};
1726 0 0       0 if (defined $self->{'_buffer'}) {
1727 0         0 $str = (join '', ($self->{'_buffer'}, @_));
1728             }
1729             else {
1730 0         0 $str = join '', @_;
1731             }
1732 0         0 my ($len, $blen);
1733 0         0 $len = length $str;
1734 0 0       0 if (($blen = ($len % $chunk)) > 0) {
1735 0         0 $self->{'_buffer'} = substr($str, ($len - $blen));
1736 0         0 print $s ($code->(substr($str, 0, $len - $blen)));
1737             }
1738             else {
1739 0         0 delete $self->{'_buffer'};
1740 0         0 print $s ($code->($str));
1741             }
1742             }
1743             else {
1744 0         0 my $encoded = $code->(join('', @_));
1745 0 0       0 $encoded =~ s/^\.\././ unless $self->{'_had_newline'};
1746 0         0 print $s $encoded;
1747 0         0 $self->{'_had_newline'} = ($_[-1] =~ /[\n\r]$/);
1748             }
1749 0         0 return $self;
1750             }
1751              
1752 0     0 1 0 sub SendLineEx { push @_, "\r\n"; shift->SendEx(@_) }
  0         0  
1753              
1754             sub SendEx {
1755 0     0 1 0 my $self = shift;
1756 0         0 my $s;
1757 0 0       0 $s = $self->{'socket'} or return $self->Error(_NOTCONNECTED);
1758 0         0 my $str;
1759 0         0 my @data = @_;
1760 0         0 foreach $str (@data) {
1761 0         0 $str =~ s/(?:\x0D\x0A?|\x0A)/\x0D\x0A/sg;
1762 0         0 $str =~ s/^\./../mg;
1763             }
1764 0         0 print $s @data;
1765 0         0 return $self;
1766             }
1767              
1768             sub Part {
1769 0     0 1 0 my $self = shift;
1770 0         0 local $_;
1771 0 0       0 if (!$self->{'multipart'}) {
1772 0         0 return $self->Error(_NOTMULTIPART("\$sender->Part()"));
1773             }
1774 0         0 $self->EndPart();
1775              
1776 0         0 my ($description, $ctype, $encoding, $disposition, $content_id, $msg,
1777             $charset);
1778 0 0       0 if (ref $_[0] eq 'HASH') {
1779 0         0 my $hash = $_[0];
1780 0         0 $description = $hash->{'description'};
1781 0         0 $ctype = $hash->{'ctype'};
1782 0         0 $encoding = $hash->{'encoding'};
1783 0         0 $disposition = $hash->{'disposition'};
1784 0         0 $content_id = $hash->{'content_id'};
1785 0         0 $msg = $hash->{'msg'};
1786 0         0 $charset = $hash->{'charset'};
1787             }
1788             else {
1789 0         0 ($description, $ctype, $encoding, $disposition, $content_id, $msg) = @_;
1790             }
1791              
1792 0 0       0 $ctype = "application/octet-stream" unless defined $ctype;
1793 0 0       0 $disposition = "attachment" unless defined $disposition;
1794 0 0       0 $encoding = "7BIT" unless defined $encoding;
1795 0         0 $self->{'encoding'} = $encoding;
1796 0 0 0     0 if (defined $charset and $charset and $ctype !~ /charset=/i) {
    0 0        
      0        
1797 0         0 $ctype .= qq{; charset="$charset"};
1798             }
1799             elsif (!defined $charset and $ctype =~ /charset="([^"]+)"/) {
1800 0         0 $charset = $1;
1801             }
1802              
1803 0         0 my $s;
1804 0 0       0 $s = $self->{'socket'} or return $self->Error(_NOTCONNECTED);
1805              
1806 0         0 undef $self->{'chunk_size'};
1807 0 0       0 if ($encoding =~ /Base64/i) {
    0          
1808 0         0 $self->{'code'} = enc_base64($charset);
1809 0         0 $self->{'chunk_size'} = $enc_base64_chunk;
1810             }
1811             elsif ($encoding =~ /Quoted[_\-]print/i) {
1812 0         0 $self->{'code'} = enc_qp($charset);
1813             }
1814             else {
1815 0         0 $self->{'code'} = enc_plain($charset);
1816             }
1817              
1818             $self->{'socket'}->start_logging()
1819 0 0 0     0 if ($self->{'debug'} and $self->{'debug_level'} == 3);
1820              
1821 0 0       0 if ($ctype =~ m{^multipart/}i) {
1822 0         0 $self->{'_part'} += 2;
1823 0         0 print $s
1824             "Content-Type: $ctype; boundary=\"Part-$self->{'boundary'}_$self->{'_part'}\"\r\n\r\n";
1825             }
1826             else {
1827 0         0 $self->{'_part'}++;
1828 0         0 print $s "Content-Type: $ctype\r\n";
1829 0 0       0 if ($description) { print $s "Content-Description: $description\r\n"; }
  0         0  
1830 0         0 print $s "Content-Transfer-Encoding: $encoding\r\n";
1831 0 0 0     0 print $s "Content-Disposition: $disposition\r\n"
1832             unless $disposition eq ''
1833             or uc($disposition) eq 'NONE';
1834 0 0       0 print $s "Content-ID: <$content_id>\r\n" if (defined $content_id);
1835 0         0 print $s "\r\n";
1836              
1837             $self->{'socket'}->stop_logging("... data skipped ...")
1838 0 0 0     0 if ($self->{'debug'} and $self->{'debug_level'} == 3);
1839 0 0       0 $self->SendEnc($msg) if defined $msg;
1840             }
1841              
1842             #$self->{'_had_newline'} = 1;
1843 0         0 return $self;
1844             }
1845              
1846             sub Body {
1847 0     0 1 0 my $self = shift;
1848 0 0       0 if (!$self->{'multipart'}) {
1849              
1850             # ->Body() has no meanin in singlepart messages
1851 0 0       0 if (@_) {
1852              
1853             # they called it with some parameters? Too late for them, let's scream.
1854 0         0 return $self->Error(_NOTMULTIPART("\$sender->Body()"));
1855             }
1856             else {
1857             # $sender->Body() ... OK, let's ignore it.
1858 0         0 return $self;
1859             }
1860             }
1861 0         0 my $hash;
1862 0 0       0 $hash = shift() if (ref $_[0] eq 'HASH');
1863 0   0     0 my $charset = shift || $hash->{'charset'} || 'US-ASCII';
1864             my $encoding
1865 0   0     0 = shift || $hash->{'encoding'} || $self->{'encoding'} || '7BIT';
1866 0   0     0 my $ctype = shift || $hash->{'ctype'} || $self->{'ctype'} || 'text/plain';
1867              
1868 0 0       0 $ctype .= qq{; charset="$charset"} unless $ctype =~ /charset=/i;
1869              
1870 0         0 $self->{'encoding'} = $encoding;
1871 0         0 $self->{'ctype'} = $ctype;
1872              
1873             $self->Part("Mail message body",
1874 0         0 $ctype, $encoding, 'inline', undef, $hash->{'msg'});
1875 0         0 return $self;
1876             }
1877              
1878 0     0 1 0 sub Attach { shift->SendFile(@_) }
1879              
1880             sub SendFile {
1881 0     0 1 0 my $self = shift;
1882 0         0 local $_;
1883 0 0       0 if (!$self->{'multipart'}) {
1884 0         0 return $self->Error(_NOTMULTIPART("\$sender->SendFile()"));
1885             }
1886 0 0       0 if (!$self->{'socket'}) { return $self->Error(_NOTCONNECTED); }
  0         0  
1887              
1888 0         0 my ($description, $ctype, $encoding, $disposition, $file, $content_id,
1889             @files);
1890 0 0       0 if (ref $_[0] eq 'HASH') {
1891 0         0 my $hash = $_[0];
1892 0         0 $description = $hash->{'description'};
1893 0         0 $ctype = $hash->{'ctype'};
1894 0         0 $encoding = $hash->{'encoding'};
1895 0         0 $disposition = $hash->{'disposition'};
1896 0         0 $file = $hash->{'file'};
1897 0         0 $content_id = $hash->{'content_id'};
1898             }
1899             else {
1900 0         0 ($description, $ctype, $encoding, $disposition, $file, $content_id)
1901             = @_;
1902             }
1903 0 0       0 return ($self->{'error'} = _NOFILE) unless $file;
1904              
1905 0 0       0 if (ref $file eq 'ARRAY') {
    0          
1906 0         0 @files = @$file;
1907             }
1908             elsif ($file =~ /,/) {
1909 0         0 @files = split / *, */, $file;
1910             }
1911             else {
1912 0         0 @files = ($file);
1913             }
1914 0         0 foreach $file (@files) {
1915 0 0 0     0 return $self->Error(_FILENOTFOUND($file))
1916             unless ($file =~ /^&/ or -e $file);
1917             }
1918              
1919 0 0       0 $disposition = "attachment; filename=*" unless defined $disposition;
1920 0 0       0 $encoding = 'Base64' unless $encoding;
1921              
1922 0         0 my $s = $self->{'socket'};
1923              
1924 0 0       0 if ($self->{'_buffer'}) {
1925 0         0 my $code = $self->{'code'};
1926 0         0 print $s ($code->($self->{'_buffer'}));
1927 0         0 delete $self->{'_buffer'};
1928             }
1929              
1930 0         0 my $code;
1931 0 0       0 if ($encoding =~ /Base64/i) {
    0          
1932 0         0 $code = enc_base64();
1933             }
1934             elsif ($encoding =~ /Quoted[_\-]print/i) {
1935 0         0 $code = enc_qp();
1936             }
1937             else {
1938 0         0 $code = enc_plain();
1939             }
1940 0         0 $self->{'code'} = $code;
1941              
1942 0         0 foreach $file (@files) {
1943 0         0 $self->EndPart();
1944 0         0 $self->{'_part'}++;
1945 0         0 $self->{'encoding'} = $encoding;
1946 0         0 my $cnt = '';
1947 0         0 my $name = File::Basename::basename $file;
1948 0 0       0 my $fctype = $ctype ? $ctype : GuessCType $name, $file;
1949 0         0 $self->{'ctype'} = $fctype;
1950              
1951             $self->{'socket'}->start_logging()
1952 0 0 0     0 if ($self->{'debug'} and $self->{'debug_level'} == 3);
1953              
1954 0 0       0 if ($fctype =~ /;\s*name(?:\*(?:0\*?)?)?=/)
1955             { # looking for name=, name*=, name*0= or name*0*=
1956 0         0 print $s ("Content-Type: $fctype\r\n");
1957             }
1958             else {
1959 0         0 print $s ("Content-Type: $fctype; name=\"$name\"\r\n");
1960             }
1961              
1962 0 0       0 if ($description) {
1963 0         0 print $s ("Content-Description: $description\r\n");
1964             }
1965 0         0 print $s ("Content-Transfer-Encoding: $encoding\r\n");
1966              
1967 0 0 0     0 if ($disposition =~ /^(.*)filename=\*(.*)$/i) {
    0          
1968 0         0 print $s ("Content-Disposition: ${1}filename=\"$name\"$2\r\n");
1969             }
1970             elsif ($disposition and uc($disposition) ne 'NONE') {
1971 0         0 print $s ("Content-Disposition: $disposition\r\n");
1972             }
1973              
1974 0 0       0 if ($content_id) {
1975 0 0       0 if ($content_id eq '*') {
    0          
1976 0         0 print $s ("Content-ID: <$name>\r\n");
1977             }
1978             elsif ($content_id eq '#') {
1979 0         0 print $s ("Content-ID: {'idcounter'}++ . ">\r\n");
1980             }
1981             else {
1982 0         0 print $s ("Content-ID: <$content_id>\r\n");
1983             }
1984             }
1985 0         0 print $s "\r\n";
1986              
1987             $self->{'socket'}->stop_logging("... data skipped ...")
1988 0 0 0     0 if ($self->{'debug'} and $self->{'debug_level'} == 3);
1989              
1990 0 0       0 open my $FH, "<", $file or return $self->Error(_FILECANTREAD($file));
1991 0 0 0     0 binmode $FH
1992             unless $fctype =~ m#^text/#i
1993             and $encoding =~ /Quoted[_\-]print|Base64/i;
1994              
1995 0         0 my $mychunksize = $chunksize;
1996 0 0       0 $mychunksize = $chunksize64 if lc($encoding) eq "base64";
1997 0         0 my $s;
1998 0 0       0 $s = $self->{'socket'} or return $self->Error(_NOTCONNECTED);
1999 0         0 while (read $FH, $cnt, $mychunksize) {
2000 0         0 print $s ($code->($cnt));
2001             }
2002 0         0 close $FH;
2003             }
2004              
2005 0         0 return $self;
2006             }
2007              
2008             sub EndPart {
2009 0     0 1 0 my $self = shift;
2010 0 0       0 return unless $self->{'_part'};
2011 0         0 my $end = shift();
2012 0         0 my $s;
2013 0         0 my $LN = "\x0D\x0A";
2014 0 0       0 $s = $self->{'socket'} or return $self->Error(_NOTCONNECTED);
2015              
2016             # flush the buffer (if it contains anything)
2017 0 0       0 if ($self->{'_buffer'}) { # used only for base64
2018 0         0 my $code = $self->{'code'};
2019 0 0       0 if (defined $code) {
2020 0         0 print $s ($code->($self->{'_buffer'}));
2021             }
2022             else {
2023 0         0 print $s ($self->{'_buffer'});
2024             }
2025 0         0 delete $self->{'_buffer'};
2026             }
2027 0 0       0 if ($self->{'_had_newline'}) {
2028 0         0 $LN = '';
2029             }
2030             else {
2031             print $s "="
2032             if !$self->{'bypass_outlook_bug'}
2033 0 0 0     0 and $self->{'encoding'}
2034             =~ /Quoted[_\-]print/i; # make sure we do not add a newline
2035             }
2036              
2037             $self->{'socket'}->start_logging()
2038 0 0 0     0 if ($self->{'debug'} and $self->{'debug_level'} == 3);
2039              
2040 0 0       0 if ($self->{'_part'} > 1) { # end of a subpart
2041 0 0       0 print $s "$LN--Part-$self->{'boundary'}_$self->{'_part'}",
2042             ($end ? "--" : ()), "\r\n";
2043             }
2044             else {
2045 0 0       0 print $s "$LN--$self->{'boundary'}", ($end ? "--" : ()), "\r\n";
2046             }
2047              
2048 0         0 $self->{'_part'}--;
2049 0         0 $self->{'code'} = enc_plain($self->{'charset'});
2050 0         0 $self->{'encoding'} = '';
2051 0         0 return $self;
2052             }
2053              
2054             sub Close {
2055 0     0 1 0 my $self = shift;
2056 0         0 local $_;
2057 0         0 my $s = $self->{'socket'};
2058 0 0       0 return 0 unless $s;
2059              
2060 0 0       0 if ($self->{'_data'}) {
2061              
2062             # flush the buffer (if it contains anything)
2063 0 0       0 if ($self->{'_buffer'}) {
2064 0         0 my $code = $self->{'code'};
2065 0 0       0 if (defined $code) {
2066 0         0 print $s ($code->($self->{'_buffer'}));
2067             }
2068             else {
2069 0         0 print $s ($self->{'_buffer'});
2070             }
2071 0         0 delete $self->{'_buffer'};
2072             }
2073              
2074 0 0       0 if ($self->{'_part'}) {
2075 0         0 while ($self->{'_part'}) {
2076 0         0 $self->EndPart(1);
2077             }
2078             }
2079              
2080 0 0       0 $self->{'socket'}->start_logging() if ($self->{'debug'});
2081 0         0 print $s "\r\n.\r\n";
2082 0         0 $self->{'_data'} = 0;
2083 0         0 $_ = get_response($s);
2084 0 0       0 if (/^[45]\d* (.*)$/) { return $self->Error(_TRANSFAILED($1)); }
  0         0  
2085 0         0 $self->{message_response} = $_;
2086             }
2087              
2088 0         0 delete $self->{'encoding'};
2089 0         0 delete $self->{'ctype'};
2090              
2091 0 0 0     0 if ($_[0] or !$self->{'keepconnection'}) {
2092 0         0 $_ = send_cmd $s, "QUIT";
2093 0 0       0 if (!/^[123]/) { return $self->Error(_COMMERROR($_)); }
  0         0  
2094 0         0 close $s;
2095 0         0 delete $self->{'socket'};
2096 0         0 delete $self->{'debug'};
2097             }
2098 0         0 return $self;
2099             }
2100              
2101             sub Cancel {
2102 0     0 1 0 my $self = shift;
2103 0         0 my $s;
2104 0 0       0 $s = $self->{'socket'} or return $self->Error(_NOTCONNECTED);
2105 0         0 close $s;
2106 0         0 delete $self->{'socket'};
2107 0         0 delete $self->{'error'};
2108 0         0 return $self;
2109             }
2110              
2111             sub DESTROY {
2112 19 50   19   2426 return if ref($_[0]) ne 'Mail::Sender';
2113 19         13 my $self = shift;
2114 19 50       150 if (defined $self->{'socket'}) {
2115 0           delete $self->{'keepconnection'};
2116 0           $self->Close;
2117             }
2118             }
2119              
2120             sub MessageID {
2121 0     0 1   my $from = shift;
2122 0           my ($sec, $min, $hour, $mday, $mon, $year) = gmtime(time);
2123 0           $mon++;
2124 0           $year += 1900;
2125              
2126 0           return sprintf "<%04d%02d%02d_%02d%02d%02d_%06d.%s>", $year, $mon, $mday,
2127             $hour, $min, $sec, rand(100000), $from;
2128             }
2129              
2130             sub QueryAuthProtocols {
2131 0     0 1   my $self = shift;
2132 0 0         Carp::croak(
2133             "Mail::Sender::QueryAuthProtocols() called without any parameter!")
2134             unless defined $self;
2135 0           local $_;
2136 0 0         if (ref $self) {
    0          
2137              
2138             # $sender->QueryAuthProtocols() or $sender->QueryAuthProtocols('the.server.com)
2139 0 0         if ($self->{'socket'}) {
2140              
2141             # the user did not Close() or Cancel() the previous mail
2142 0           die
2143             "You forgot to close the mail before calling QueryAuthProtocols!\n";
2144             }
2145 0 0         if (@_) {
2146 0           $self->{'smtp'} = shift();
2147 0           $self->{'smtp'} =~ s/^\s+//g; # remove spaces around $smtp
2148 0           $self->{'smtp'} =~ s/\s+$//g;
2149 0           $self->{'smtpaddr'} = Socket::inet_aton($self->{'smtp'});
2150 0 0         if (!defined($self->{'smtpaddr'})) {
2151 0           return $self->Error(_HOSTNOTFOUND($self->{'smtp'}));
2152             }
2153             $self->{'smtpaddr'} = $1
2154 0 0         if ($self->{'smtpaddr'} =~ /(.*)/s); # Untaint
2155             }
2156             }
2157             elsif ($self =~ /::/) { # Mail::Sender->QueryAuthProtocols('the.server.com')
2158 0 0         Carp::croak
2159             "Mail::Sender->QueryAuthProtocols() called without any parameter!"
2160             if !@_;
2161 0           $self = Mail::Sender->new({smtp => $_[0]});
2162 0 0         return unless ref $self;
2163             }
2164             else { # Mail::Sender::QueryAuthProtocols('the.server.com')
2165 0           $self = Mail::Sender->new({smtp => $self});
2166 0 0         return unless ref $self;
2167             }
2168              
2169 0 0         return $self->Error(_NOSERVER) unless defined $self->{'smtp'};
2170              
2171             my $s = IO::Socket::INET->new(
2172             PeerHost => $self->{'smtp'},
2173             PeerPort => $self->{'port'},
2174             Proto => "tcp",
2175 0 0 0       Timeout => $self->{'timeout'} || 120,
2176             ) or return $self->Error(_CONNFAILED);
2177              
2178 0           $s->autoflush(1);
2179              
2180 0           $_ = get_response($s);
2181 0 0 0       if (not $_ or !/^[123]/) { return $self->Error(_SERVNOTAVAIL($_)); }
  0            
2182 0           $self->{'server'} = substr $_, 4;
2183              
2184             {
2185 0           my $res = $self->_say_helo($s);
  0            
2186 0 0         return $res if $res;
2187             }
2188              
2189 0           $_ = send_cmd $s, "QUIT";
2190 0           close $s;
2191 0           delete $self->{'socket'};
2192              
2193 0 0         if (wantarray) {
2194 0           return keys %{$self->{'auth_protocols'}};
  0            
2195             }
2196             else {
2197 0           my $key = each %{$self->{'auth_protocols'}};
  0            
2198 0           return $key;
2199             }
2200             }
2201              
2202             sub printAuthProtocols {
2203 0   0 0 0   print "$_[1] supports: ",
2204             join(", ", Mail::Sender->QueryAuthProtocols($_[1] || 'localhost')),
2205             "\n";
2206             }
2207              
2208             sub TestServer {
2209 0     0 0   my $self = shift;
2210 0           local $_;
2211 0 0         if (!defined $self) {
    0          
    0          
2212 0           Carp::croak "Mail::Sender::TestServer() called without any parameter!";
2213             }
2214             elsif (ref $self)
2215             { # $sender->TestServer() or $sender->TestServer('the.server.com)
2216 0 0         if ($self->{'socket'})
2217             { # the user did not Close() or Cancel() the previous mail
2218 0           die "You forgot to close the mail before calling TestServer!\n";
2219             }
2220 0 0         if (@_) {
2221 0           $self->{'smtp'} = shift();
2222 0           $self->{'smtp'} =~ s/^\s+//g; # remove spaces around $smtp
2223 0           $self->{'smtp'} =~ s/\s+$//g;
2224 0           $self->{'smtpaddr'} = Socket::inet_aton($self->{'smtp'});
2225 0 0         if (!defined($self->{'smtpaddr'})) {
2226 0           return $self->Error(_HOSTNOTFOUND($self->{'smtp'}));
2227             }
2228             $self->{'smtpaddr'} = $1
2229 0 0         if ($self->{'smtpaddr'} =~ /(.*)/s); # Untaint
2230             }
2231 0           $self->{'on_errors'} = 'die';
2232             }
2233             elsif ($self =~ /::/) { # Mail::Sender->TestServer('the.server.com')
2234 0 0         Carp::croak("Mail::Sender->TestServer() called without any parameter!")
2235             if !@_;
2236 0           $self = Mail::Sender->new({smtp => $_[0], on_errors => 'die'});
2237 0 0         return unless ref $self;
2238             }
2239             else { # Mail::Sender::QueryAuthProtocols('the.server.com')
2240 0           $self = Mail::Sender->new({smtp => $self, on_errors => 'die'});
2241 0 0         return unless ref $self;
2242             }
2243              
2244 0 0         return $self->Error(_NOSERVER) unless defined $self->{'smtp'};
2245              
2246             # if (!defined($self->{'smtpaddr'})) { return $self->Error(_HOSTNOTFOUND($self->{'smtp'})); }
2247              
2248 0 0 0       if (exists $self->{'on_errors'}
    0 0        
      0        
2249             and (!defined($self->{'on_errors'}) or $self->{'on_errors'} eq 'undef'))
2250             {
2251 0   0       return ($self->Connect() and $self->Close() and 1);
2252             }
2253             elsif (exists $self->{'on_errors'} and $self->{'on_errors'} eq 'die') {
2254 0           $self->Connect();
2255 0           $self->Close();
2256 0           return 1;
2257             }
2258             else {
2259 0           my $res = $self->Connect();
2260 0 0         return $res unless ref $res;
2261 0           $res = $self->Close();
2262 0 0         return $res unless ref $res;
2263 0           return $self;
2264             }
2265             }
2266              
2267             #====== Debuging bazmecks
2268              
2269             $debug_code = <<'END';
2270             package Mail::Sender::DBIO;
2271             use IO::Handle;
2272             use Tie::Handle;
2273             @Mail::Sender::DBIO::ISA = qw(Tie::Handle);
2274              
2275             sub SOCKET () {0}
2276             sub LOG () {1}
2277             sub ENDLINE () {2}
2278             sub CLOSELOG () {3}
2279             sub OFF () {4}
2280              
2281             sub TIEHANDLE {
2282             my ($pkg,$socket,$debughandle, $mayCloseLog) = @_;
2283             return bless [$socket,$debughandle,1, $mayCloseLog,0], $pkg;
2284             }
2285              
2286             sub PRINT {
2287             my $self = shift;
2288             my $text = join(($\ || ''), @_);
2289             $self->[SOCKET]->print($text);
2290             return if $self->[OFF];
2291             $text =~ s/\x0D\x0A(?=.)/\x0D\x0A<< /g;
2292             $text = "<< ".$text if $self->[ENDLINE];
2293             $self->[ENDLINE] = ($text =~ /\x0D\x0A$/);
2294             $self->[LOG]->print($text);
2295             }
2296              
2297             sub READLINE {
2298             my $self = shift();
2299             my $socket = $self->[SOCKET];
2300             my $line = <$socket>;
2301             $self->[LOG]->print(">> $line") if defined $line and !$self->[OFF];
2302             return $line;
2303             }
2304              
2305             sub CLOSE {
2306             my $self = shift();
2307             $self->[SOCKET]->close();
2308             $self->[LOG]->close() if $self->[CLOSELOG];
2309             return $self->[SOCKET];
2310             }
2311              
2312             sub opened {
2313             our $SOCKET;
2314             local *SOCKET = $_[SOCKET] or return;
2315             $SOCKET->opened();
2316             }
2317              
2318             use Data::Dumper;
2319             sub stop_logging {
2320             my $self = tied(${$_[0]});
2321              
2322             #print "stop_logging( ".$self." )\n";
2323              
2324             return if $self->[OFF];
2325             $self->[OFF] = 1;
2326              
2327             my $text = join(($\ || ''), $_[1])
2328             or return;
2329             $text .= "\x0D\x0A";
2330             $text =~ s/\x0D\x0A(?=.)/\x0D\x0A<< /g;
2331             $text = "<< ".$text if $self->[ENDLINE];
2332             $self->[ENDLINE] = ($text =~ /\x0D\x0A$/);
2333             $self->[LOG]->print($text);
2334             }
2335              
2336             sub start_logging {
2337             my $self = tied(${$_[0]});
2338             $self->[OFF] = 0;
2339             }
2340             END
2341              
2342             my $pseudo_handle_code = <<'END';
2343             package Mail::Sender::IO;
2344             use IO::Handle;
2345             use Tie::Handle;
2346             @Mail::Sender::IO::ISA = qw(Tie::Handle);
2347              
2348             sub TIEHANDLE {
2349             my ($pkg,$sender) = @_;
2350             return bless [$sender, $sender->{'_part'}], $pkg;
2351             }
2352              
2353             sub PRINT {
2354             my $self = shift;
2355             $self->[0]->SendEnc(@_);
2356             }
2357              
2358             sub PRINTF {
2359             my $self = shift;
2360             my $format = shift;
2361             $self->[0]->SendEnc( sprintf $format, @_);
2362             }
2363              
2364             sub CLOSE {
2365             my $self = shift();
2366             if ($self->[1]) {
2367             $self->[1]->EndPart();
2368             } else {
2369             $self->[0]->Close();
2370             }
2371             }
2372             END
2373              
2374             package Mail::Sender;
2375              
2376             sub GetHandle {
2377 0     0 1   my $self = shift();
2378 0 0         unless (@Mail::Sender::IO::ISA) {
2379 0           eval "use Symbol;";
2380 0           eval $pseudo_handle_code;
2381             }
2382 0           my $handle = gensym();
2383 0           tie *$handle, 'Mail::Sender::IO', $self;
2384 0           return $handle;
2385             }
2386              
2387             1;
2388              
2389             __END__