File Coverage

blib/lib/Mail/Bulkmail/Server.pm
Criterion Covered Total %
statement 65 225 28.8
branch 19 106 17.9
condition 12 78 15.3
subroutine 11 19 57.8
pod 10 10 100.0
total 117 438 26.7


line stmt bran cond sub pod time code
1             package Mail::Bulkmail::Server;
2              
3             # Copyright and (c) 1999, 2000, 2001, 2002, 2003 James A Thomason III (jim@jimandkoka.com). All rights reserved.
4             # Mail::Bulkmail::Server is distributed under the terms of the Perl Artistic License.
5              
6             =pod
7              
8             =head1 NAME
9              
10             Mail::Bulkmail::Server - handles server connections and communication for Mail::Bulkmail
11              
12             =head1 AUTHOR
13              
14             Jim Thomason, jim@jimandkoka.com
15              
16             =head1 SYNOPSIS
17              
18             my $server = Mail::Bulkmail::Server->new(
19             'Smtp' => 'your.smtp.com',
20             'Port' => 25
21             ) || die Mail::Bulkmail::Server->error();
22              
23             #connect to the SMTP relay
24             $server->connect || die $server->error();
25              
26             #talk to the server
27             my $response = $server->talk_and_respond("RSET");
28              
29             =head1 DESCRIPTION
30              
31             Mail::Bulkmail::Server now handles server connections. Mail::Bulkmail 1.x and 2.x had all the server functionality
32             built into the module itself. That was nice in terms of simplicity - one module, one connection, one server, and
33             so on. But it had some downsides. For one thing, it only allowed for one connection. And since I wanted to allow
34             multiple server connections in 3.00, that had to go. For another, it was a pain in the butt to change the server
35             implementation. This way, you can easily write your own server class, drop it in here, and be off to the races.
36              
37             For example, the Mail::Bulkmail::DummyServer module for debugging purposes.
38              
39             This is not a module that you'll really need to access directly, since it is accessed internally by Mail::Bulkmail
40             when it is needed. Specify the data you need in the conf file and the server_file attribute, and you won't
41             ever need to touch this directly.
42              
43             =cut
44              
45 1     1   1027 use Mail::Bulkmail::Object;
  1         3  
  1         10  
46             @ISA = Mail::Bulkmail::Object;
47              
48             $VERSION = '3.12';
49              
50 1     1   7 use Socket;
  1         5  
  1         3009  
51 1     1   29 use 5.6.0;
  1         5  
  1         61  
52 1     1   1343 use Data::Dumper ();
  1         34650  
  1         3605  
53              
54 1     1   18 use strict;
  1         3  
  1         73  
55 1     1   9 use warnings;
  1         2  
  1         9113  
56              
57             =pod
58              
59             =head1 ATTRIBUTES
60              
61             =over 11
62              
63             =item Smtp
64              
65             stores the Smtp relay's address.
66              
67             $server->Smtp("your.smtp.com");
68              
69             can either be an IP or a named address
70              
71             Smtp values should be set in your server file.
72              
73             =cut
74              
75             __PACKAGE__->add_attr('Smtp');
76              
77             =pod
78              
79             =item Port
80              
81             stores the port on which you'll try to connect to the SMTP relay. Probably going to be 25, since that's the
82             standard SMTP port.
83              
84             $server->Port(25);
85              
86             Port values should be set in either your server file, or a single default in your conf file.
87              
88             =cut
89              
90             __PACKAGE__->add_attr('Port');
91              
92             =pod
93              
94             =item Domain
95              
96             When you connect to an SMTP server, you must say hello and state your domain. This is your domain that you
97             use to say hello.
98              
99             $server->Domain('mydomain.com');
100              
101             This should be the same name of the domain of the machine that you are connecting on.
102              
103             Domain should be set in your conf file.
104              
105             =cut
106              
107             __PACKAGE__->add_attr('Domain');
108              
109             =pod
110              
111             =item Tries
112              
113             When you try to connect to an SMTP server via ->connect, you may have issues with creating the socket
114             or making the connection. Tries specifies how many times you should re-try making the socket or making
115             the connection before failing to connect.
116              
117             Make this a small number.
118              
119             $server->Tries(5);
120              
121             Tries should be set in your conf file.
122              
123             =cut
124              
125             __PACKAGE__->add_attr('Tries');
126              
127             =pod
128              
129             =item max_connection_attempts
130              
131             This is similar to Tries, but this governs the number of times that you can call the ->connect method.
132             When you have multiple servers in Mail::Bulkmail's ->servers array, there's no point in constantly re-trying
133             to connect to a server that fails. it'll just slow you down. max_connection_attempts makes sure that you stop
134             trying to connect to invalid servers.
135              
136             Make this a small number as well.
137              
138             $server->max_connection_attempts(7);
139              
140             max_connection_attempts should be set in your conf file.
141              
142             =cut
143              
144             __PACKAGE__->add_attr('max_connection_attempts');
145              
146             =pod
147              
148             =item envelope_limit
149              
150             It's entirely likely that with a very large list you'll have a very large number of people in the
151             same domain. For instance, there are an awful lot of people that have yahoo addresses. So, for example,
152             say that you have a list of 100,000 people and 20,000 of them are in the yahoo.com domain and you're sending
153             using the envelope. That means that the server at yahoo.com is going to receive one message with 20,000
154             people in the envelope!
155              
156             Now, this might be a bad thing. We don't know if the yahoo.com mail server will actually process a message
157             with 20,000 envelope recipients. It may or may not and the only way to find out is to try it. If it does work,
158             then great no worries. But if it doesn't, then you're stuck. If you stop using envelope sending, you sacrifice
159             its major speed gains, but if you keep using it you can't send to yahoo.com.
160              
161             I fixes that.
162              
163             envelope_limit is precisely what it sounds like, it allows you to specify a limit on the number of recipients
164             that will be specified in your envelope. That way, with our previous example, you can specify an envelope limit of
165             1000, for example.
166              
167             $bulk->envelope_limit(1000);
168              
169             This means that yahoo.com will get 20 messages, each with 1000 recipients in the envelope. Of course, this still
170             may not be small enough, so you can tweak it as much as necessary.
171              
172             Setting an envelope limit does trade off some of the gains from using the envelope, but it's still over all
173             a vast speed boost over not using it.
174              
175             envelope_limit should be set in your conf file. I recommend setting it to 100, but tweak it as necessary. Higher values
176             allow you to send more information and do it faster, but you're more likely to run into server's that refuse that many
177             recipients. Lower values are more compatible, but slightly slower.
178              
179             Set envelope_limit to 0 for an infinite limit. You should never have to set it below 100 (unless you're using an infinite limit),
180             since RFC 2822 says that SMTP servers should always accept at least 100 recipients in the envelope
181              
182             =cut
183              
184             __PACKAGE__->add_attr('envelope_limit');
185              
186             =pod
187              
188             =item max_messages
189              
190             max_messages sets the maximum number of messages to send to a particular server. This is mainly useful if you're bulkmailing
191             to multiple servers. You may have a server that can take some of the load, but not much of it. Assume that your list has over
192             100,000 people on it, and you're using one primary SMTP relay and one smaller SMTP relay to help take some of the load off
193             of the main one. Your primary SMTP server can handle lots of messages, but your smaller one can only take a smaller load.
194             That'd a good place for max_messages.
195              
196             $aux_server->max_messages(10000);
197              
198             That way, your smaller server will relay no more than 10,000 messages.
199              
200             Set max_messages to 0 for an infinite number of messages to go through the server. It is recommended to set max_messages
201             to 0.
202              
203             =cut
204              
205             __PACKAGE__->add_attr('max_messages');
206              
207             =pod
208              
209             =item max_messages_per_robin
210              
211             when you set up your bulkmail object with multiple servers, max_messages_per_robin is used to determine how many messages
212             are sent to a server before moving onto the next.
213              
214             This is the maximum number of messages that would be sent to a server in a given iteration before moving on to the next,
215             but it is not necessarily the exact number of messages that will be sent. If the server has reached the maximum number of
216             messages allowed, or the maximum number in a given connection, it will jump to the next server before reaching
217             the robin limit.
218              
219             Set max_messages_per_robin to 0 for an infinite number of messages allowed on a given server iteration. It is recommended
220             to set this to 500 if you're using multiple servers, and to 0 if you're using 1 server.
221              
222             The message robin counter is reset by reset_all_counters
223              
224             =cut
225              
226             __PACKAGE__->add_attr('max_messages_per_robin');
227              
228             =pod
229              
230             =item max_messages_per_connection
231              
232             This sets the maximum number of messages that would be sent to a given SMTP relay in a given connection.
233             When this limit is reached, the server will disconnect and return that it has reached a limit.
234              
235             set max_messages_per_connection to 0 for infinite messages per connection. It is recommended to keep this at 0.
236              
237             The message connection counter is reset by reset_all_counters
238              
239             =cut
240              
241             __PACKAGE__->add_attr('max_messages_per_connection');
242              
243             =pod
244              
245             =item max_messages_while_awake
246              
247             Sometimes, it may be useful to pause and give your server a break. max_messages_while_awake allows this. This will
248             specify the number of messages to send to a server before going to sleep for a certain period of time.
249              
250             $server->max_messages_while_awake(100);
251              
252             Will send 100 messages to the server and then go to sleep. for the time specified by sleep_length.
253              
254             Note that reaching this limit will not cause reached_limit to return a true value, so in a multi-server environment, you'll
255             end up sleeping a lot.
256              
257             The message-while-awake counter is reset by reset_all_counters, so it is of dubious utility when using multiple servers.
258              
259             Set max_messages_while_awake to 0 to never sleep. It is recommended to have max_messages_while_awake set to 0 when using
260             multiple servers. Set it to a positive number when using one server.
261              
262             =cut
263              
264             __PACKAGE__->add_attr('max_messages_while_awake');
265              
266             =pod
267              
268             =item sleep_length
269              
270             Specifies the time to sleep (in seconds) if the server has reached the max_messages_while_awake limit.
271              
272             =cut
273              
274             __PACKAGE__->add_attr('sleep_length');
275              
276             =pod
277              
278             =item talk_attempts
279              
280             The response codes for SMTP are pretty rigorously defined, which is obviously very usefull. a 5xy error is permanently fatal.
281             a 4xy error is temporarily fatal. It is recommended that if a 4xy error is encountered, that the client (us) should try re-sending
282             the same command again. talk_attempts specifies the number of times to try resending a command after receiving a 400 level error
283             from the server.
284              
285             $server->talk_attempts(5);
286              
287             =cut
288              
289             __PACKAGE__->add_attr('talk_attempts');
290              
291             =pod
292              
293             =item time_out
294              
295             We can *finally* time out! So if your SMTP relay doesn't respond for a set period of time, the connection will automatically
296             disconnect and fail with an error. Set this to something high, the value is in seconds.
297              
298             $server->time_out(3000); # 5 minutes
299              
300             =cut
301              
302             __PACKAGE__->add_attr('time_out');
303              
304             =pod
305              
306             =item time_of_last_message
307              
308             stores the time that the last message was sent through this server, in epoch seconds.
309              
310             =cut
311              
312             __PACKAGE__->add_attr('time_of_last_message');
313              
314             =pod
315              
316             =item connected
317              
318             boolean attribute that says whether or not this server object is connected to an SMTP relay.
319              
320             Don't set this value, only read it.
321              
322             =cut
323              
324             __PACKAGE__->add_attr('connected');
325              
326             # _not_worthless is the internal counter used for the number of failed connections attempted on a server
327             # why not _connection_attempts or the like to be consistent? I just liked the way the method sounded more
328             # $self->connect if $self->_not_worthless;
329             __PACKAGE__->add_attr('_not_worthless');
330              
331             # internal counter for the total number of messages sent to this server object
332             __PACKAGE__->add_attr('_sent_messages');
333              
334             # internal counter for the total number of messages sent to this server object during this "robin"
335             # this value is reset by reset_message_counters or by reached_limit if the max_messages_per_robin limit is reached
336             __PACKAGE__->add_attr('_sent_messages_this_robin');
337              
338             # internal counter for the total number of messages sent to this server object during the current envelope
339             # this value is reset by reset_message_counters
340             # this counter can be accessed externally via the method "reached_envelope_limit"
341             __PACKAGE__->add_attr('_sent_messages_this_envelope');
342              
343             # internal counter for the total number of messages sent to this server object during this connection
344             # this value is reset by reset_message_counters or by reached_limit if the max_messages_per_connection limit is
345             # reached. Additionally, reached_limit will disconnect the server if this limit is reached
346             __PACKAGE__->add_attr('_sent_messages_this_connection');
347              
348             # internal counter for the total number of messages sent to this server object before sleeping
349             # this value is reset by reset_message_counters or by reached_limit if the max_messages_while_awake limit is
350             # reached. Additionally, reached_limit will sleep for the amount of time specified by sleep_length, if
351             # sleep_length is specified
352             __PACKAGE__->add_attr('_sent_messages_while_awake');
353              
354             =pod
355              
356             =item CONVERSATION
357              
358             This is an optional log file to keep track of your SMTP conversations
359              
360             CONVERSATION may be either a coderef, globref, arrayref, or string literal.
361              
362             If a string literal, then Mail::Bulkmail::Server will attempt to open that file (in append mode) as your log:
363              
364             $server->CONVERSATION("/path/to/my/conversation");
365              
366             If a globref, it is assumed to be an open filehandle in append mode:
367              
368             open (C, ">>/path/to/my/conversation");
369             $server->CONVERSATION(\*C);
370              
371             if a coderef, it is assumed to be a function to call with the address as an argument:
372              
373             sub C { print "CONVERSATION : ", $_[1], "\n"}; #or whatever your code is
374             $server->CONVERSATION(\&C);
375              
376             if an arrayref, then the conversation will be pushed on to the end of it
377              
378             $server->CONVERSATION(\@conversation);
379              
380             Use whichever item is most convenient, and Mail::Bulkmail::Server will take it from there.
381              
382             B: This file is going to get B. Massively huge. You should only turn this on for debugging
383             purposes and B in a production environment. It will log the first 50 characters of a message sent to the
384             server, and the full server response.
385              
386             =cut
387              
388             __PACKAGE__->add_attr(['CONVERSATION', '_file_accessor'], '>>');
389              
390             =pod
391              
392             =item socket
393              
394             socket contains the socket that this Server has opened to its SMTP relay. You'll probably never talk to this directly,
395             but it's here, just in case you want it.
396              
397             =cut
398              
399             __PACKAGE__->add_attr('socket');
400              
401             #this is a hashref to internally store our ESMTP options received from EHLO
402             __PACKAGE__->add_attr('_esmtp');
403              
404             =pod
405              
406             =back
407              
408             =head1 METHODS
409              
410             =over 11
411              
412             =item increment_messages_sent
413              
414             This method will increment the server object's internal counters storing the total number of messages
415             sent, the total sent this robin, the total sent this connection, the total sent while awake, and the total
416             sent this envelope.
417              
418             It will also store the time the last message is sent.
419              
420             =cut
421              
422             sub increment_messages_sent {
423 2     2 1 3 my $self = shift;
424              
425 2         9 $self->_sent_messages($self->_sent_messages + 1);
426              
427 2         11 $self->_sent_messages_this_robin($self->_sent_messages_this_robin + 1);
428              
429 2         10 $self->_sent_messages_this_connection($self->_sent_messages_this_connection + 1);
430              
431 2         7 $self->_sent_messages_while_awake($self->_sent_messages_while_awake + 1);
432              
433 2         10 $self->_sent_messages_this_envelope($self->_sent_messages_this_envelope + 1);
434              
435 2         14 $self->time_of_last_message(time);
436              
437 2         15 return $self;
438             };
439              
440             =pod
441              
442             =item reset_message_counters
443              
444             This message will reset the internal counters for the messages sent this robin, messages sent this connection,
445             and messages sent while awake back to 0.
446              
447             =cut
448              
449             sub reset_message_counters {
450 0     0 1 0 my $self = shift;
451              
452             #$self->_sent_messages(0); #this never gets reset
453              
454 0         0 $self->_sent_messages_this_robin(0);
455              
456             #$self->_sent_messages_this_connection(0); #this gets set upon connect
457              
458 0         0 $self->_sent_messages_while_awake(0);
459              
460 0         0 $self->_sent_messages_this_envelope(0);
461              
462 0         0 return $self;
463             };
464              
465             =pod
466              
467             =item reset_envelope_counter
468              
469             The envelope counter behaves slightly differently than the other counters, so we have a separate method to reset the internal
470             envelope counter.
471              
472             =cut
473              
474             sub reset_envelope_counter {
475 0     0 1 0 my $self = shift;
476              
477 0         0 $self->_sent_messages_this_envelope(0);
478              
479 0         0 return $self;
480             };
481              
482             =pod
483              
484             =item reached_envelope_limit
485              
486             This method returns 1 if we've reached the envelope limit, 0 otherwise
487              
488             =cut
489              
490             sub reached_envelope_limit {
491 0     0 1 0 my $self = shift;
492              
493 0 0 0     0 return 1 if $self->envelope_limit && $self->_sent_messages_this_envelope >= $self->envelope_limit;
494             };
495              
496             =pod
497              
498             =item reached_limit
499              
500             This method will tell you if the server has reached the max_messages, max_messages_per_connection, or max_messages_per_robin
501             limits. Also, if you reach the max_messages_while_awake limit, this method will cause you to sleep for the time period
502             specified in sleep_length
503              
504             Return values:
505             1 : reached max_messages limit, server becomes worthless and will not be used again
506             2 : reached max_messages_per_connection limit, server will disconnect
507             3 : reached max_messages_per_robin limit
508              
509             =cut
510              
511             sub reached_limit {
512 3     3 1 5 my $self = shift;
513              
514             #sleep if we're supposed to sleep
515 3 50 33     14 if ($self->max_messages_while_awake && $self->_sent_messages_while_awake >= $self->max_messages_while_awake){
516 0 0       0 sleep $self->sleep_length if $self->sleep_length;
517 0         0 $self->_sent_messages_while_awake(0);
518             };
519              
520 3 50 33     17 if ($self->max_messages && $self->_sent_messages >= $self->max_messages){
    50 33        
    50 33        
521 0         0 $self->disconnect();
522 0         0 $self->_sent_messages_this_connection(0);
523 0         0 $self->_sent_messages_this_robin(0);
524 0         0 $self->_not_worthless(0);
525 0         0 return 1;
526             }
527             elsif ($self->max_messages_per_connection && $self->_sent_messages_this_connection >= $self->max_messages_per_connection){
528 0         0 $self->disconnect();
529 0         0 $self->_sent_messages_this_connection(0);
530 0         0 $self->_sent_messages_this_robin(0);
531 0         0 return 2;
532             }
533             elsif ($self->max_messages_per_robin && $self->_sent_messages_this_robin >= $self->max_messages_per_robin){
534 0         0 $self->_sent_messages_this_robin(0);
535 0         0 return 3;
536             }
537             #otherwise, we've reached no limits
538             else {
539 3         14 return 0;
540             };
541             };
542              
543             =pod
544              
545             =item new
546              
547             Standard constructor. See Mail::Bulkmail::Object for more information.
548              
549             =cut
550              
551             sub new {
552 2   50 2 1 261 my $self = shift->SUPER::new(
553             '_sent_messages' => 0,
554             '_sent_messages_this_robin' => 0,
555             '_sent_messages_this_connection' => 0,
556             '_sent_messages_while_awake' => 0,
557             '_sent_messages_this_envelope' => 0,
558             'connected' => 0,
559             '_esmtp' => {},
560             '_not_worthless' => 5, #default to 5 regardless of the conf file
561             @_
562             ) || return undef;
563              
564 2 50       26 $self->_not_worthless($self->max_connection_attempts) if $self->max_connection_attempts;
565              
566 2         9 return $self;
567             };
568              
569             =pod
570              
571             =item connect
572              
573             Connects this server object to the SMTP relay specified with ->Smtp and ->Port
574             This method will set ->connected to 1 if it successfully connects.
575              
576             $server->connect() || die "Could not connect : " . $server->error;
577              
578             Upon connection, ->connect will issue a HELO command for the ->Domain specified.
579              
580             This method is known to be able to return:
581              
582             MBS001 - cannot connect to worthless servers
583             MBS002 - could not make socket
584             MBS003 - could not connect to server
585             MBS004 - no response from server
586             MBS005 - server won't say HELO
587             MBS010 - can't greet server w/o domain
588             MBS011 - server gave an error for EHLO
589             MBS015 - timed out waiting for response upon connect
590             MBS016 - server didn't respond to EHLO, trying HELO (non-returning error)
591             MBS017 - cannot connect to server, no Tries parameter
592              
593             =cut
594              
595             sub connect {
596              
597 0     0 1 0 my $self = shift;
598              
599 0 0       0 return $self if $self->connected();
600              
601             #if we have no Tries parameter, then the server is unquestionably worthless
602 0 0       0 unless ($self->Tries) {
603 0         0 $self->_not_worthless(0);
604 0         0 return $self->error("Cannot connect to server - no Tries parameter set", "MBS017");
605             };
606              
607             #if we have no Domain, then the server is unquestionably worthless
608 0 0       0 unless ($self->Domain) {
609 0         0 $self->_not_worthless(0);
610 0         0 return $self->error("Cannot greet server without domain", "MBS010");
611             };
612              
613 0 0       0 return $self->error("Cannot connect to worthless servers", "MBS001") unless $self->_not_worthless > 0;
614              
615 0         0 my $bulk = $self->gen_handle();
616              
617 0         0 my ($s_tries, $c_tries) = ($self->Tries, $self->Tries);
618              
619 0   0     0 1 while ($s_tries-- && ! socket($bulk, PF_INET, SOCK_STREAM, getprotobyname('tcp')));
620 0 0       0 if ($s_tries < 0){
621 0         0 $self->_not_worthless($self->_not_worthless - 1);
622 0         0 return $self->error("Could not make socket for " . $self->Smtp . ", Socket error ($!)", "MBS002");
623             }
624             else {
625              
626 0         0 my $paddr = sockaddr_in($self->Port, inet_aton($self->Smtp));
627              
628 0   0     0 1 while ! connect($bulk, $paddr) && $c_tries--;
629              
630 0 0       0 if ($c_tries < 0){
631 0         0 $self->_not_worthless($self->_not_worthless - 1);
632 0 0       0 return $self->error("Could not connect to " . $self->Smtp . ", Connect error ($!)", "MBS003") if $c_tries < 0;
633             }
634             else {
635              
636 0         0 $@ = undef;
637 0         0 eval {
638 0     0   0 local $SIG{"ALRM"} = sub {die "timed out"};
  0         0  
639              
640 0 0       0 eval{ alarm($self->time_out) if $self->time_out; }; #catch it in case alarm isn't implemented (stupid windows)
  0         0  
641              
642             #keep our bulk pipes piping hot.
643 0         0 select((select($bulk), $| = 1)[0]);
644              
645 0         0 local $\ = "\015\012";
646 0         0 local $/ = "\015\012";
647              
648 0   0     0 my $response = <$bulk> || "";
649 0 0 0     0 if (! $response || $response =~ /^[45]/) {
650 0         0 $self->_not_worthless($self->_not_worthless - 1);
651 0         0 return $self->error("No response from server: $response", "MBS004");
652             };
653              
654             #grab our domain
655 0         0 my $domain = $self->Domain;
656              
657             #first, we'll try to say EHLO
658 0         0 print $bulk "EHLO $domain";
659              
660 0   0     0 $response = <$bulk> || "";
661              
662             #log our conversation, if desired.
663 0 0       0 if ($self->CONVERSATION){
664 0         0 $self->logToFile($self->CONVERSATION, "Said to server: 'EHLO'");
665 0         0 $self->logToFile($self->CONVERSATION, "\tServer replied: '$response'");
666             };
667              
668             #now, if the server didn't respond or gave us an error, we'll fall back and try saying HELO instead
669 0 0 0     0 if (! $response || $response =~ /^[45]/){
670              
671 0         0 $self->error("Server did not respond to EHLO...trying HELO", "MBS016");
672              
673 0         0 print $bulk "HELO $domain";
674              
675 0   0     0 $response = <$bulk> || "";
676              
677             #log our conversation, if desired
678 0 0       0 if ($self->CONVERSATION){
679 0         0 $self->logToFile($self->CONVERSATION, "Said to server: 'HELO'");
680 0         0 $self->logToFile($self->CONVERSATION, "\tServer replied: '$response'");
681             };
682              
683 0 0 0     0 if (! $response || $response =~ /^[45]/) {
684 0         0 $self->_not_worthless($self->_not_worthless - 1);
685 0         0 return $self->error("Server won't say HELO: $response", "MBS005");
686             };
687             }
688             #otherwise, it accepted our EHLO, so we'll read in our list of ESMTP options
689             else {
690 0         0 my $receiving = 1;
691              
692 0         0 while ($receiving) {
693 0   0     0 my $r = <$bulk> || "";
694              
695             #log our conversation, if desired
696 0 0       0 if ($self->CONVERSATION){
697 0         0 $self->logToFile($self->CONVERSATION, "\tServer replied: '$r'");
698             };
699              
700 0 0 0     0 $self->error("Server gave an error for EHLO : $r", "MBS011") if ! $r || $r =~ /^[45]/;
701              
702             #extract out and store our ESMTP options for possible later use
703 0         0 $r =~ /^\d\d\d[ -](\w+)/;
704 0         0 my $esmtp_option = $1;
705 0 0       0 $self->_esmtp->{$esmtp_option} = 1 if $esmtp_option;
706              
707             #multi-line replies are of the form \d\d\d-, single line (or last line replies are \d\d\d" "
708 0 0       0 $receiving = 0 if $r =~ /^\d\d\d /;
709             };
710              
711             }; #end successful EHLO
712              
713             #clear our alarm
714 0         0 eval { alarm(0); }; #catch it in case alarm isn't implemented (stupid windows)
  0         0  
715              
716             }; #end eval wrapping up our time out
717              
718              
719 0 0       0 if ($@){
720 0         0 $self->_not_worthless($self->_not_worthless - 1);
721 0         0 return $self->error("Timed out waiting for response on connect", "MBS015");
722             };
723              
724 0         0 $self->socket($bulk);
725              
726 0         0 $self->connected(1);
727 0         0 $self->_sent_messages_this_connection(0);
728              
729 0         0 return $self;
730             };
731             };
732             };
733              
734             =pod
735              
736             =item disconnect
737              
738             disconnects the server object from the SMTP relay. Before disconnect, it will issue a "RSET" and then a "quit" command
739             to the SMTP server, then close the socket. disconnect sets ->connected to 0.
740              
741             disconnect can also disconnect quietly, i.e., it won't try to issue a RSET and then quit before closing the socket.
742              
743             $server->disconnect(); #issues RSET and quit
744             $server->disconnect('quietly'); #issues nothing
745              
746             =cut
747              
748             sub disconnect {
749              
750 0     0 1 0 my $self = shift;
751 0         0 my $quietly = shift;
752              
753 0 0       0 return $self unless $self->connected();
754              
755 0 0       0 $self->talk_and_respond('RSET') unless $quietly; #just to be polite
756 0 0       0 $self->talk_and_respond('quit') unless $quietly;
757              
758 0 0       0 if (my $socket = $self->socket) {
759 0         0 close $socket;
760 0         0 $socket = undef;
761             };
762              
763 0         0 $self->socket(undef);
764              
765             #wipe out our ESMTP hash, since it may not be valid upon next connect
766 0         0 $self->_esmtp({});
767              
768 0         0 $self->connected(0);
769              
770 0         0 return $self;
771              
772             };
773              
774             =pod
775              
776             =item talk_and_respond
777              
778             talk_and_respond takes one argument and sends it to your SMTP relay. It then listens for a response.
779              
780             my $response = $server->talk_and_respond("RSET");
781              
782             If you're not connected to the relay, talk_and_respond will attempt to connect.
783              
784             This method is known to be able to return:
785              
786             MBS006 - cannot talk w/o speech
787             MBS007 - cannot talk to server
788             MBS008 - server won't respond to speech
789             MBS009 - server disconnected
790             MBS012 - temporarily won't respond to speech...re-trying
791             MBS013 - could never resolve temporary error
792             MBS014 - timed out waiting for response
793             MBS018 - No file descriptor
794              
795             =cut
796              
797             sub talk_and_respond {
798 12     12 1 20 my $self = shift;
799              
800 12   50     33 my $talk = shift || return $self->error("Cannot talk w/o speech", "MBS006");
801              
802 12   33     53 my $attempts= shift || $self->talk_attempts;
803              
804 12 50       38 unless ($self->connected){
805 0 0       0 $self->connect || return undef;
806             };
807              
808 12         40 my $bulk = $self->socket();
809              
810 12         51 local $\ = "\015\012";
811 12         37 local $/ = "\015\012";
812              
813 12 50       109 unless (fileno($bulk)) {
814 0         0 $self->disconnect('quietly');
815 0         0 return $self->error("No file descriptor...socket appears to be closed. Disconnecting to be safe", "MBS018");
816             };
817              
818 12 50       44 unless (print $bulk $talk){
819 0         0 return $self->error("Cannot talk to server : $!", "MBS007");
820             };
821              
822             #keep track of the first 50 characters, w/o returns for logging purposes
823 12         36 my $short_talk = substr($talk, 0, 50);
824 12 100       36 $short_talk .= "...(truncated)" if length $talk > length $short_talk;
825              
826 12 50       45 if ($self->CONVERSATION){
827 0         0 $self->logToFile($self->CONVERSATION, "Said to server: '$short_talk'");
828             };
829              
830 12         18 my $response = undef;
831              
832             #this is true as long as we're expecting more responses from the server
833 12         15 my $receiving = 1;
834              
835 12         17 $@ = undef;
836 12         19 eval {
837              
838 12     0   236 local $SIG{"ALRM"} = sub {die "timed out"};
  0         0  
839              
840 12 50       25 eval { alarm($self->time_out) if $self->time_out; }; #catch it in case alarm isn't implemented (stupid windows)
  12         41  
841              
842 12         29 while ($receiving) {
843              
844 12   50     43 my $r = <$bulk> || "";
845              
846 12 50       46 if ($self->CONVERSATION){
847 0         0 $self->logToFile($self->CONVERSATION, "\tServer replied: '$r'");
848             };
849              
850             #500 codes are permanent fatal errors
851 12 50 33     191 if (! $r || $r =~ /^5/){
    50 33        
    50 33        
852              
853 0         0 return $self->error("Server won't respond to '$talk' : $r" . $self->Smtp, "MBS008");
854             }
855              
856             #400 error codes are temporary fatal errors
857             #If we get a 4xy error, we're going to retry this same command up to our
858             #talk_attempts parameter. If it never works, we'll fail completely
859             elsif ($r && $r =~ /^4/){
860 0         0 my $next_attempts = $attempts - 1;
861 0 0       0 if ($next_attempts > 0) {
862 0         0 $self->error("Temporary response to $talk : $r...retrying", "MBS012");
863 0         0 return $self->talk_and_respond($talk, $next_attempts);
864             }
865             else {
866 0         0 return $self->error("Server won't respond to $talk, and re-attempts for temporary code exhausted", "MBS013");
867             };
868             }
869              
870             #otherwise, if we got a 221, we were disconnected.
871             elsif ($r && $r =~ /^221/){
872             #if we disconnected from something other than a quit, then log the error
873 0 0       0 if ($talk ne 'quit'){
874 0         0 $self->disconnect();
875 0         0 return $self->error("Server disconnected in response to '$talk': $r", "MBS009");
876             }
877             #otherwise, we're happy, so we'll return a true value
878             else {
879 0         0 return 'disconnected';
880             };
881             }
882              
883             #finally, if it's something else, then we're gonna assume it's a happy response
884             #and tack it on to the response we return
885             else {
886             # Responses of \d\d\d" " indicate we're done and there's nothing
887             # else coming
888 12 50 33     73 $receiving = 0 if $r =~ /^\d\d\d / || $r =~ /^\d\d\d$/;
889              
890 12         43 $response .= $r;
891             };
892              
893             }; #end while
894              
895             #clear our alarm
896 12         17 eval { alarm(0); }; #catch it in case alarm isn't implemented (stupid windows)
  12         204  
897              
898             }; #end eval
899              
900 12 50       28 if ($@){
901 0         0 $self->disconnect('quietly');
902 0         0 return $self->error("Timed out waiting for response to $talk", "MBS014");
903             };
904              
905 12         87 return $response;
906             };
907              
908             #make sure that we're disconnected
909             sub DESTROY {
910 1     1   99 my $self = shift;
911 1 50       5 $self->disconnect if $self->connected;
912 1         144 $self = undef;
913             };
914              
915             =pod
916              
917             =item create_all_servers
918              
919             create_all_servers will iterate through the file specified in server_file in the conf file and return an arrayref of all
920             server objects created.
921              
922             define package Mail::Bulkmail::Server
923              
924             server_file = ./server_file.txt
925              
926             your server file should be of the format of another Mail::Bulkmail conf file, containing definitions
927             for all of the SMTP servers you want to use. See the examples below for how to set up the conf files.
928              
929             If you would like to specify a different conf file, pass that as an argument.
930              
931             my $servers = Mail::Bulkmail::Server->create_all_servers('/path/to/new/server_file.txt');
932              
933             This will then ignore the server_file in the conf file and use the one passed.
934              
935             You may also pass hashrefs of init data for new servers.
936              
937             my $servers = Mail::Bulkmail::Server->create_all_servers(
938             {
939             'Smtp' => 'smtp.yourdomain.com'
940             },
941             {
942             'Smtp' => 'smtp2.yourdomain.com'
943             },
944             {
945             'Smtp' => 'smtp3.yourdomain.com'
946             }
947             ) || die Mail::Bulkmail::Server->error;
948              
949             This is called internally by Mail::Bulkmail's constructor, so you probably won't ever need to touch it.
950              
951             =cut
952              
953             sub create_all_servers {
954 0     0 1   my $self = shift;
955              
956 0   0       my $class = ref $self || $self;
957              
958 0           my $master_conf = $self->read_conf_file();
959              
960 0           my $conf = {};
961              
962 0 0 0       if ($_[0] && ! ref $_[0]){
963 0           my $file = shift;
964 0           $conf = $self->read_conf_file($file);
965             }
966             else {
967 0 0         foreach my $pkg (@{$class->isa_path() || []}){
  0            
968 0 0         if ($master_conf->{$pkg}->{"server_file"}){
969 0           $conf = $self->read_conf_file($master_conf->{$pkg}->{"server_file"});
970             };
971             };
972             };
973              
974 0           my $data = {'Smtp' => []};
975              
976 0           my @settables = qw(Smtp Port Tries Domain max_messages max_messages_per_robin max_messages_per_connection
977             max_messages_while_awake sleep_length max_connection_attempts envelope_limit
978             talk_attempts time_out CONVERSATION);
979              
980 0           foreach my $attribute (@settables) {
981              
982 0 0         foreach my $pkg (@{$class->isa_path() || []}){
  0            
983 0           foreach my $method (keys %{$conf->{$pkg}}){
  0            
984 0   0       $conf->{$class}->{$attribute} ||= $conf->{$pkg}->{$attribute};
985             };
986             };
987              
988 0 0         next unless defined $conf->{$class}->{$attribute};
989              
990 0           @{$data->{$attribute}} = ref $conf->{$class}->{$attribute}
  0            
991 0 0         ? @{$conf->{$class}->{$attribute}}
992             : ($conf->{$class}->{$attribute});
993              
994             };
995              
996 0           my @servers = ();
997              
998 0           while (@{$data->{"Smtp"}}){
  0            
999 0           my %init = ();
1000              
1001 0           foreach my $attribute (@settables) {
1002 0 0 0       $init{$attribute} = shift @{$data->{$attribute}} if $data->{$attribute} && @{$data->{$attribute}};
  0            
  0            
1003             };
1004              
1005 0   0       my $server = $class->new(
1006             %init
1007             ) || return undef;
1008              
1009 0           push @servers, $server;
1010             };
1011              
1012 0 0         if (@_){
1013 0           while (my $init = shift){
1014 0   0       my $server = $class->new(
1015             %$init
1016             ) || return undef;
1017              
1018 0           push @servers, $server;
1019             };
1020             };
1021              
1022 0           return \@servers;
1023              
1024             };
1025              
1026             1;
1027              
1028             __END__