File Coverage

lib/Net/validMX.pm
Criterion Covered Total %
statement 240 339 70.8
branch 156 292 53.4
condition 34 72 47.2
subroutine 14 19 73.6
pod 5 14 35.7
total 449 736 61.0


line stmt bran cond sub pod time code
1             # The "Artistic License"
2             #
3             # Preamble
4             #
5             # The intent of this document is to state the conditions under which a
6             # Package may be copied, such that the Copyright Holder maintains some
7             # semblance of artistic control over the development of the package,
8             # while giving the users of the package the right to use and distribute
9             # the Package in a more-or-less customary fashion, plus the right to make
10             # reasonable modifications.
11             #
12             # Definitions:
13             #
14             # "Package" refers to the collection of files distributed by the
15             # Copyright Holder, and derivatives of that collection of files
16             # created through textual modification.
17             #
18             # "Standard Version" refers to such a Package if it has not been
19             # modified, or has been modified in accordance with the wishes
20             # of the Copyright Holder as specified below.
21             #
22             # "Copyright Holder" is whoever is named in the copyright or
23             # copyrights for the package.
24             #
25             # "You" is you, if you're thinking about copying or distributing
26             # this Package.
27             #
28             # "Reasonable copying fee" is whatever you can justify on the
29             # basis of media cost, duplication charges, time of people involved,
30             # and so on. (You will not be required to justify it to the
31             # Copyright Holder, but only to the computing community at large
32             # as a market that must bear the fee.)
33             #
34             # "Freely Available" means that no fee is charged for the item
35             # itself, though there may be fees involved in handling the item.
36             # It also means that recipients of the item may redistribute it
37             # under the same conditions they received it.
38             #
39             # 1. You may make and give away verbatim copies of the source form of the
40             # Standard Version of this Package without restriction, provided that you
41             # duplicate all of the original copyright notices and associated disclaimers.
42             #
43             # 2. You may apply bug fixes, portability fixes and other modifications
44             # derived from the Public Domain or from the Copyright Holder. A Package
45             # modified in such a way shall still be considered the Standard Version.
46             #
47             # 3. You may otherwise modify your copy of this Package in any way, provided
48             # that you insert a prominent notice in each changed file stating how and
49             # when you changed that file, and provided that you do at least ONE of the
50             # following:
51             #
52             # a) place your modifications in the Public Domain or otherwise make them
53             # Freely Available, such as by posting said modifications to Usenet or
54             # an equivalent medium, or placing the modifications on a major archive
55             # site such as uunet.uu.net, or by allowing the Copyright Holder to include
56             # your modifications in the Standard Version of the Package.
57             #
58             # b) use the modified Package only within your corporation or organization.
59             #
60             # c) rename any non-standard executables so the names do not conflict
61             # with standard executables, which must also be provided, and provide
62             # a separate manual page for each non-standard executable that clearly
63             # documents how it differs from the Standard Version.
64             #
65             # d) make other distribution arrangements with the Copyright Holder.
66             #
67             # 4. You may distribute the programs of this Package in object code or
68             # executable form, provided that you do at least ONE of the following:
69             #
70             # a) distribute a Standard Version of the executables and library files,
71             # together with instructions (in the manual page or equivalent) on where
72             # to get the Standard Version.
73             #
74             # b) accompany the distribution with the machine-readable source of
75             # the Package with your modifications.
76             #
77             # c) give non-standard executables non-standard names, and clearly
78             # document the differences in manual pages (or equivalent), together
79             # with instructions on where to get the Standard Version.
80             #
81             # d) make other distribution arrangements with the Copyright Holder.
82             #
83             # 5. You may charge a reasonable copying fee for any distribution of this
84             # Package. You may charge any fee you choose for support of this
85             # Package. You may not charge a fee for this Package itself. However,
86             # you may distribute this Package in aggregate with other (possibly
87             # commercial) programs as part of a larger (possibly commercial) software
88             # distribution provided that you do not advertise this Package as a
89             # product of your own. You may embed this Package's interpreter within
90             # an executable of yours (by linking); this shall be construed as a mere
91             # form of aggregation, provided that the complete Standard Version of the
92             # interpreter is so embedded.
93             #
94             # 6. The scripts and library files supplied as input to or produced as
95             # output from the programs of this Package do not automatically fall
96             # under the copyright of this Package, but belong to whoever generated
97             # them, and may be sold commercially, and may be aggregated with this
98             # Package. If such scripts or library files are aggregated with this
99             # Package via the so-called "undump" or "unexec" methods of producing a
100             # binary executable image, then distribution of such an image shall
101             # neither be construed as a distribution of this Package nor shall it
102             # fall under the restrictions of Paragraphs 3 and 4, provided that you do
103             # not represent such an executable image as a Standard Version of this
104             # Package.
105             #
106             # 7. C subroutines (or comparably compiled subroutines in other
107             # languages) supplied by you and linked into this Package in order to
108             # emulate subroutines and variables of the language defined by this
109             # Package shall not be considered part of this Package, but are the
110             # equivalent of input as in Paragraph 6, provided these subroutines do
111             # not change the language in any way that would cause it to fail the
112             # regression tests for the language.
113             #
114             # 8. Aggregation of this Package with a commercial distribution is always
115             # permitted provided that the use of this Package is embedded; that is,
116             # when no overt attempt is made to make this Package's interfaces visible
117             # to the end user of the commercial distribution. Such use shall not be
118             # construed as a distribution of this Package.
119             #
120             # 9. The name of the Copyright Holder may not be used to endorse or promote
121             # products derived from this software without specific prior written permission.
122             #
123             # 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
124             # IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
125             # WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
126              
127             package Net::validMX;
128              
129 7     7   521248 use strict;
  7         77  
  7         200  
130 7     7   38 use warnings;
  7         22  
  7         166  
131              
132 7     7   3744 use Net::DNS;
  7         688501  
  7         922  
133              
134 7         948 use vars qw(
135             $VERSION
136             @ISA
137             @EXPORT_OK
138             $DEBUG
139             $ALLOW_IP_ADDRESS_AS_MX
140             $FLAG_INTRANETS
141             $RESOLUTION_PROBLEM_RETURN
142 7     7   106 $QUERY_TIMEOUT);
  7         19  
143              
144             BEGIN {
145 7     7   52 require DynaLoader;
146 7         27 require Exporter;
147              
148 7         157 @ISA = qw(Exporter DynaLoader);
149 7         34 $VERSION = '2.5.2';
150 7         13 $DEBUG = 0;
151 7         16 $ALLOW_IP_ADDRESS_AS_MX = 1;
152 7         12 $FLAG_INTRANETS = 1;
153 7         11 $RESOLUTION_PROBLEM_RETURN = 1;
154 7         32329 $QUERY_TIMEOUT = 4;
155             }
156              
157 0     0 0 0 sub version { $VERSION; }
158              
159             @EXPORT_OK = qw(check_valid_mx get_output_result check_email_and_mx check_email_validity get_domain_from_email);
160              
161             sub new {
162 1     1 0 896 my $self = bless {}, shift;
163              
164 1 50 33     11 $DEBUG = $self->{'debug'} if (defined $self->{'debug'} and $self->{'debug'} ne '');
165 1 50 33     33 $ALLOW_IP_ADDRESS_AS_MX = $self->{'allow_ip_address_as_mx'} if (defined $self->{'allow_ip_address_as_mx'} and $self->{'allow_ip_address_as_mx'} ne '');
166 1 50 33     10 $FLAG_INTRANETS = $self->{'flag_intranets'} if (defined $self->{'flag_intranets'} and $self->{'flag_intranets'} ne '');
167 1 50 33     6 $RESOLUTION_PROBLEM_RETURN = $self->{'resolution_problem_return'} if (defined $self->{'resolution_problem_return'} and $self->{'resolution_problem_return'} ne '');
168 1 50 33     3 $QUERY_TIMEOUT = $self->{'query_timeout'} if (defined $self->{'query_timeout'} and $self->{'query_timeout'} ne '');
169              
170 1         3 return $self;
171             }
172              
173             sub get_debug {
174 0     0 0 0 return $DEBUG;
175             }
176              
177             sub set_debug {
178 0     0 0 0 my $debug = shift;
179 0         0 $DEBUG = $debug;
180             }
181              
182             sub get_output_result {
183 37     37 0 664 my ($email, $rv, $reason) = @_;
184 37         59 my ($output);
185              
186 37         205 $output = "$email\n\tValid MX? ".Net::validMX::int_to_truefalse($rv);
187 37 100       128 if ($reason ne '') {
188 13         52 $output .= " - $reason";
189             }
190 37         89 $output .= "\n\n";
191              
192 37         1961 return $output;
193             }
194              
195             sub check_valid_mx {
196             #Based on Idea from Les Miksell and much input from Jan Pieter Cornet
197             #KAM 9-12-05 updated 10-24-05 & 11-3-05.
198             #takes the email address, extracts the domain name and performs multiple MX tests to see if the domain has valid
199             #MX exchange records
200              
201 36     36 1 26558 my ($res, $packet, @answer, $domain, @answer2, @answer3, $rv, $reason, $i, @unsorted_answer);
202 36         0 my ($check_implicit_mx, %params, $self, $ref, $resolution_problem_status);
203              
204             #print "DEBUG: ref for \$_[0] ".ref($_[0]). "\n";
205             #IN OO INSTEAD OF PROCEDURAL MODE?
206 36 100       169 if (uc(ref($_[0])) eq 'NET::VALIDMX') {
207 1         2 $self = shift(@_);
208             #foreach $ref (keys %$self) {
209             # print "DEBUG: OO MODE - $ref: $self->{$ref} \n";
210             #}
211             }
212              
213             #DID WE RECEIVE A HASH INSTEAD OF A SINGLE EMAIL?
214 36 100       159 if ($#_ % 2 == 0) {
215 34         109 ($params{'email'}) = @_;
216             } else {
217 2         20 %params = @_;
218             }
219              
220 36 0 33     143 $params{'email'} || $params{'sender'} || return (0, 'A blank email address will not be tested.');
221              
222             #CONSTANTS / SETTABLE OPTIONS
223 36 100       134 $params{'debug'} = $DEBUG unless (defined $params{'debug'});
224 36 100       152 $params{'allow_ip_address_as_mx'} = $ALLOW_IP_ADDRESS_AS_MX unless (defined $params{'allow_ip_address_as_mx'});
225 36 50       109 $params{'resolution_problem_return'} = $RESOLUTION_PROBLEM_RETURN unless (defined $params{'resolution_problem_return'});
226 36 50       106 $params{'query_timeout'} = $QUERY_TIMEOUT unless (defined $params{'query_timeout'});
227              
228 36 50       92 if ($params{'resolution_problem_return'} > 0) {
229 36         63 $resolution_problem_status = 'Passed';
230             } else {
231 0         0 $resolution_problem_status = 'Failed';
232             }
233              
234 36 100       111 print "DEBUG: function debug setting is $params{'debug'}\n" if $params{'debug'};
235 36 100       150 print "DEBUG: function allow_ip_address_as_mx setting is $params{'allow_ip_address_as_mx'}\n" if $params{'debug'};
236 36 100       94 print "DEBUG: function resolution_problem_return setting is $params{'resolution_problem_return'}\n" if $params{'debug'};
237 36 100       93 print "DEBUG: function query_timeout setting is $params{'query_timeout'}\n" if $params{'debug'};
238              
239             #FLAGS - I THINK THIS HAS A LOGIC ISSUE - I LIKELY MEANT ALLOW_IMPLICIT_MX as an option FIX
240 36         54 $check_implicit_mx = 0;
241              
242             #Setup a DNS Resolver Resource
243 36         278 $res = Net::DNS::Resolver->new;
244              
245 36 50       5474 if (defined ($res)) {
246 36         60 $check_implicit_mx = 0;
247 36         184 $res->defnames(0); #Turn off appending the default domain for names that have no dots just in case
248 36         580 $res->searchlist(); #Set the search list to undefined just in case
249              
250             #We have also set the default timeout to only 4 seconds which means we might get network
251             #delays which we do not want to handle as an error.
252 36         562 $res->tcp_timeout($params{'query_timeout'}); #Number of Seconds before query will fail
253 36         471 $res->udp_timeout($params{'query_timeout'}); #Number of Seconds before query will fail
254              
255             #Strip domain name from an email address
256 36         451 $domain = get_domain_from_email($params{'email'});
257              
258             #Deny Explicit IP Address Domains
259 36 100       146 if ($domain =~ /^\[.*\]$/) {
260 1         6 $reason = "Use of IP Address $domain instead of a hostname is not allowed";
261 1 50       4 print "DEBUG: Test Failed - $reason\n" if $params{'debug'};
262 1         12 return (0, $reason);
263             }
264              
265             #Perform the DNS Query - Changed to Send instead of Query method to utilize the ancount method
266 35         152 $packet = $res->send($domain,'MX');
267              
268             #Net::DNS::Resolver had an error
269 35 50       1705754 if (!defined $packet) {
270 0 0       0 print "DEBUG: There was an error retrieving the MX Records for $domain\n" if $params{'debug'};
271 0 0       0 print "DEBUG: Test Passed by Default\n" if $params{'debug'};
272 0         0 return($params{'resolution_problem_return'}, "Test $resolution_problem_status due to a Resolution Problem retrieving the MX Records");
273             }
274              
275 35 100       175 print "DEBUG: Number of Answers in the MX resolution packet is: ".$packet->header->ancount."\n" if $params{'debug'};
276             #Parse the Query
277 35 100       227 if ($packet->header->ancount > 0) {
278 33 50       660 if (defined ($packet->answer)) {
279 33         336 @answer = $packet->answer;
280              
281 33         310 for ($i = 0; $i < scalar(@answer); $i++) {
282 43 100       209 if ($answer[$i]->type ne 'MX') {
283             #DISCARD ANSWER IF THE RECORD IS NOT AN MX RECORD SUCH AS THE CNAME FOR londo.cysticercus.com
284 4 50       65 print "DEBUG: Discarding one non-MX answer of type: ".$answer[$i]->type."\n" if $params{'debug'};
285             } else {
286 39         774 push @unsorted_answer, $answer[$i];
287             }
288             }
289              
290 33         89 undef @answer;
291              
292 33 100       144 print "DEBUG: Number of Answers Left to Check after discarding all but MX: ".scalar(@unsorted_answer)."\n" if $params{'debug'};
293 33 100       100 if (scalar(@unsorted_answer) < 1) {
294 2         6 $check_implicit_mx++;
295             } else {
296             #Sort to put answers into ascending order by mail exchange preference
297 31         134 @answer = sort {$a->preference <=> $b->preference} @unsorted_answer;
  10         102  
298             }
299              
300             #LOOP THROUGH THE ANSWERS WE HAVE
301 33         217 for ($i = 0; $i < scalar(@answer); $i++) {
302 38         95 undef $packet;
303 38 100       127 print "DEBUG: $i - MX Answer - Type: ".$answer[$i]->type." - Exchange: ".$answer[$i]->exchange." - Length: ".length($answer[$i]->exchange)."\n" if $params{'debug'};
304              
305             #localhost isn't a valid MX so return false
306 38 50       295 if ($answer[$i]->exchange eq 'localhost') {
307 0         0 $reason = 'Invalid use of Localhost as an MX record';
308 0 0       0 print "DEBUG: Test Failed - $reason\n" if $params{'debug'};
309 0         0 return (0, $reason);
310             }
311              
312             #IF the exchange is blank and the priority is 0 and it's the last answer, let's fail
313 38 0 33     2658 if ($answer[$i]->exchange eq '' && int($answer[$i]->preference) == 0 && $i == $#answer) {
      33        
314             #Test if there is a Blank MX record in the first slot Per Jan-Pieter Cornet recommendation
315             #and based on http://ietfreport.isoc.org/all-ids/draft-delany-nullmx-00.txt
316 0         0 $reason = 'Domain is publishing a blank MX record at Priority 0';
317 0 0       0 print "DEBUG: Test Failed - $reason\n" if $params{'debug'};
318 0         0 return (0, $reason);
319             }
320              
321             #resolve the exchange record
322 38 100 66     753 if ($answer[$i]->exchange ne '' and $answer[$i]->exchange !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {
323 36         1173 $packet = $res->send($answer[$i]->exchange, 'A');
324            
325 36 50       754717 if (!defined ($packet)) {
326             #THERE WAS AN ERROR TRYING TO RESOLVE THE MAIL EXCHANGE
327 0 0       0 print "DEBUG: Test Passed by Default\n" if $params{'debug'};
328 0         0 return ($params{'resolution_problem_return'}, 'Test '.$resolution_problem_status.' due to a Resolution Problem');
329             }
330 36 100       161 print "DEBUG: $i - Number of Answers in the MX->A resolution packet is: ".$packet->header->ancount."\n" if $params{'debug'};
331              
332             #TEST TO SEE IF IT'S AN AAAA IPv6 RECORD - Thanks to Subramanian MOONESAMY sm@megawatt.resistor.net for pointing this out!
333 36 100 66     237 if (defined $packet && $packet->header->ancount < 1) {
334 7         181 $packet = $res->send($answer[$i]->exchange, 'AAAA');
335              
336 7 50       279415 if (!defined ($packet)) {
337             #THERE WAS AN ERROR TRYING TO RESOLVE THE MAIL EXCHANGE
338 0 0       0 print "DEBUG: Test Passed by Default\n" if $params{'debug'};
339 0         0 return ($params{'resolution_problem_return'}, 'Test '.$resolution_problem_status.' due to a Resolution Problem');
340             }
341 7 50       49 print "DEBUG: $i - Number of Answers in the MX->AAAA resolution packet is: ".$packet->header->ancount."\n" if $params{'debug'};
342             }
343             }
344              
345 38 100 100     918 if (defined $packet && $packet->header->ancount > 0) {
346 31         491 @answer2 = $packet->answer;
347              
348 31 100       317 print "DEBUG: $i - Resolution type of ".$answer[$i]->exchange.": ".$answer2[0]->type."\n" if $params{'debug'};
349 31 100       227 if ($answer2[0]->type =~ /^A{1,4}/) {
    50          
350 29 100       569 print "DEBUG: $i - A Name Address for ".$answer[$i]->exchange.": ".$answer2[0]->address."\n" if $params{'debug'};
351 29         151 ($rv, $reason) = invalid_mx($answer2[0]->address);
352 29 100 100     230 if ($rv == 1 or ($rv == 2 && $i == $#answer)) {
    100 100        
353 2 100       8 if ($rv == 2) {
354 1         3 $reason .= ' - All MX Records Failed';
355             }
356 2 50       11 print "DEBUG: Test Failed - $reason\n" if $params{'debug'};
357 2         56 return (0, $reason);
358             } elsif ($rv < 1) {
359 22 100       63 print "DEBUG: Test Passed ".$answer2[0]->address." looks good\n" if $params{'debug'};
360 22         415 return (1, '');
361             }
362             } elsif ($answer2[0]->type eq "CNAME") {
363 2         81 $packet = $res->send($answer2[0]->cname,'A');
364              
365 2 50       7525 if (!defined ($packet)) {
366             #THERE WAS AN ERROR TRYING TO RESOLVE THE CNAME FOR THE MAIL EXCHANGE
367 0 0       0 print "DEBUG: Test Passed by Default\n" if $params{'debug'};
368 0         0 return ($params{'resolution_problem_return'}, 'Test '.$resolution_problem_status.' due to a Resolution Problem');
369             }
370              
371 2 50       10 if ($packet->header->ancount > 0) {
372 2 50       35 if (defined ($packet->answer)) {
373 2         24 @answer3 = $packet->answer;
374 2 50       18 print "DEBUG: $i - CNAME Resolution of Type: ".$answer3[0]->type." - Address: ".$answer3[0]->address."\n" if $params{'debug'};
375 2 100       16 if ($answer3[0]->type eq "A") {
376 1         18 ($rv, $reason) = invalid_mx($answer3[0]->address);
377 1 50 33     12 if ($rv == 1 or ($rv == 2 && $i == $#answer)) {
    50 33        
378 0 0       0 if ($rv == 2) {
379 0         0 $reason .= ' - All MX Records Failed';
380             }
381 0 0       0 print "DEBUG: Test Failed - $reason\n" if $params{'debug'};
382 0         0 return (0, $reason);
383             } elsif ($rv < 1) {
384 1 50       5 print "DEBUG: Test Passed ".$answer3[0]->address." looks good\n" if $params{'debug'};
385 1         21 return (1,'');
386             }
387             } else {
388             #CNAMEs aren't RFC valid for MX's so if they chained two together, I'm not recursively resolving anymore levels, I'm just failing it
389 1         20 $reason = 'Invalid use of CNAME for MX record';
390 1 50       4 print "DEBUG: Test Failed - $reason\n" if $params{'debug'};
391 1         20 return (0, $reason);
392             }
393             }
394             } else {
395 0 0 0     0 if ($params{'allow_ip_address_as_mx'} > 0 && $answer[$i]->exchange =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {
396 0         0 ($rv, $reason) = invalid_mx($answer[$i]->exchange);
397 0 0       0 if ($rv) {
398 0         0 return (0, $reason);
399             } else {
400 0 0       0 print "DEBUG: Test Passed - Allowing IP Address as Hostname\n" if $params{'debug'};
401 0         0 return (1, '');
402             }
403             }
404              
405             #MX RECORD IS A CNAME WHICH DOES NOT RESOLVE
406 0         0 $reason = "MX Record: ".$answer2[0]->cname." does not resolve";
407 0 0       0 print "DEBUG: Test Failed - $reason\n" if $params{'debug'};
408 0         0 return (0, $reason);
409             }
410             }
411             } else { # ! $packet->header->ancount > 0
412              
413             #IF THIS IS THE LAST MX RECORD AND THE EXCHANGE IS BLANK, WE FAIL IT
414 7 50       155 if ($answer[$i]->exchange eq '') {
415 0 0       0 if ($i == $#answer) {
416 0         0 $reason = 'Domain is publishing only invalid and/or blank MX records';
417 0 0       0 print "DEBUG: Test Failed - $reason\n" if $params{'debug'};
418 0         0 return (0, $reason);
419             }
420             } else {
421             #PERHAPS WE'LL ALLOW AN IP ADDRESS AS AN MX FOR CLOWNS WHO CONFIGURE DNS INCORRECTLY
422 7 100 66     174 if ($params{'allow_ip_address_as_mx'} > 0 && $answer[$i]->exchange =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {
423 2         76 ($rv, $reason) = invalid_mx($answer[$i]->exchange);
424 2 100       13 if ($rv) {
425 1         29 return (0, $reason);
426             } else {
427 1 50       3 print "DEBUG: Test Passed - Allowing IP Address as Hostname\n" if $params{'debug'};
428 1         22 return (1, '');
429             }
430             }
431             }
432              
433             # Keep looping, unless this was the last answer in the MX
434             # resolution packet.
435             # XXX $packet->header->ancount, in the case of corrupt packets,
436             # may differ from the actual number of records and may return unwanted failures
437 5 100       108 if ($i == $#answer) {
438              
439             #MX RECORD RETURNED DOES NOT RESOLVE
440 3         13 $reason = "MX Record: ".$answer[$i]->exchange." does not resolve";
441 3 50       60 print "DEBUG: Test Failed - $reason\n" if $params{'debug'};
442 3         66 return (0, $reason);
443             }
444             }
445              
446             } # for
447             }
448             } else {
449 2         43 ($rv, $reason) = $check_implicit_mx++;
450             }
451              
452 4 50       26 print "DEBUG: Checking Implicit MX is set to $check_implicit_mx\n" if $params{'debug'};
453              
454 4 50       23 if ($check_implicit_mx > 0) {
455 4         25 ($rv, $reason) = check_implicit_mx($domain, $res, $params{'debug'}, $params{'resolution_problem_return'});
456 4 50       97 if (defined $rv) {
457 4         138 return ($rv, $reason);
458             }
459             }
460             } else {
461 0 0       0 print "DEBUG: There was an error setting up a Net::DNS::Resolver resource\n" if $params{'debug'};
462 0 0       0 print "DEBUG: Test Passed by Default\n" if $params{'debug'};
463 0         0 return ($params{'resolution_problem_return'}, 'Test '.$resolution_problem_status.' due to a Resolution Problem');
464             }
465              
466 0 0       0 print "DEBUG: Test Passed\n" if $params{'debug'};
467 0         0 return (1,'');
468             }
469              
470             sub check_implicit_mx {
471 4     4 0 15 my ($SenderDomain, $res, $debug, $resolution_problem_return) = @_;
472            
473 4         11 my ($rv, $reason, $packet, @answer, @answer2, $resolution_problem_status);
474              
475             #CONSTANTS/SETTABLE OPTIONS
476 4   33     17 $resolution_problem_return ||= $RESOLUTION_PROBLEM_RETURN;
477              
478 4 50       16 if ($resolution_problem_return > 0) {
479 4         12 $resolution_problem_status = 'Passed';
480             } else {
481 0         0 $resolution_problem_status = 'Failed';
482             }
483              
484 4 50       27 print "DEBUG: Checking for Implicit MX Records\n" if $debug;
485             #NO MX RECORDS RETURNED - CHECK FOR IMPLICIT MX RECORD BY A RECORD per Jan-Pieter Cornet recommendation
486 4         19 $packet = $res->send($SenderDomain,'A');
487 4 50       114227 if (!defined ($packet)) {
488             #THERE WAS AN ERROR - NO IMPLICIT A RECORD COULD BE RESOLVED
489 0 0       0 print "DEBUG: Test Passed by Default\n" if $debug;
490 0         0 return ($resolution_problem_return, 'Test '.$resolution_problem_status.' due to a Resolution Problem');
491             }
492              
493 4 50       22 print "DEBUG: Number of Answers in the Implicit A record resolution packet is: ".$packet->header->ancount."\n" if $debug;
494 4 100       18 if ($packet->header->ancount > 0) {
495 3         69 @answer = $packet->answer;
496 3 100       39 if ($answer[0]->type eq "A") {
    50          
497 1 50       25 print "DEBUG: $SenderDomain has no MX Records - Using Implicit A Record: ".$answer[0]->address."\n" if $debug;
498 1         7 ($rv, $reason) = invalid_mx($answer[0]->address);
499 1 50       7 if ($rv) {
500 0 0       0 print "DEBUG: Test Failed - $reason\n" if $debug;
501 0         0 return (0, $reason);
502             } else {
503 1 50       54 print "DEBUG: Test Passed ".$answer[0]->address." looks good\n" if $debug;
504 1         26 return (1, '');
505             }
506             } elsif ($answer[0]->type eq "CNAME") {
507             #IS THIS REALLY A NECESSARY TEST? SHOULD WE BE TESTING FOR IMPLICIT CNAME RECORDS?
508 2 50       61 print "DEBUG: $SenderDomain has no MX Records - Using CNAME to Check for Implicit A Record: ".$answer[0]->cname."\n" if $debug;
509 2         10 $packet = $res->send($answer[0]->cname,'A');
510              
511 2 50       6523 if (!defined ($packet)) {
512             #THERE WAS AN ERROR TRYING TO RESOLVE THE CNAME FOR THE MAIL EXCHANGE
513 0 0       0 print "DEBUG: Test Passed by Default\n" if $debug;
514 0         0 return (1, '');
515             }
516              
517 2 50       9 if ($packet->header->ancount > 0) {
518 2 50       70 if (defined ($packet->answer)) {
519 2         23 @answer2 = $packet->answer;
520 2 100       21 if ($answer2[0]->type eq "A") {
521 1 50       61 print "DEBUG: CNAME Resolution of Type: ".$answer2[0]->type." - Address: ".$answer2[0]->address."\n" if $debug;
522 1         5 ($rv, $reason) = invalid_mx($answer2[0]->address);
523 1 50       8 if ($rv > 0) {
524 0 0       0 print "DEBUG: Test Failed - $reason\n" if $debug;
525 0         0 return (0, $reason);
526             } else {
527 1 50       6 print "DEBUG: Test Passed ".$answer2[0]->address." looks good\n" if $debug;
528 1         7 return (1, '');
529             }
530             } else {
531             #CNAMEs aren't RFC valid for MX's so if they chained two together, I'm not recursively resolving anymore levels, I'm just failing it
532 1         16 $reason = 'Invalid use of CNAME for Implicit MX record';
533 1 50       22 print "DEBUG: Test Failed - $reason\n" if $debug;
534 1         9 return (0, $reason);
535             }
536             }
537             }
538             }
539             } else {
540 1         29 $reason = "No MX or A Records Exist for $SenderDomain";
541 1 50       5 print "DEBUG: Test Failed - $reason\n" if $debug;
542 1         7 return (0, $reason);
543             }
544 0         0 return;
545             }
546              
547             sub invalid_mx {
548 34     34 0 597 my ($ip) = @_;
549 34         57 my ($flag_intranets);
550              
551             #UPDATED MORE ON 11-18-2011 based on RFC 5735
552              
553             #0/8, 255/8, 127/8 aren't a valid MX so return false - added per Matthew van Eerde recomendation
554 34 50       181 if ($ip =~ /^(255|127|0)\./) {
555 0         0 return (1, "Invalid use of 0/8, 255/8 or 127/8 ($ip) as an MX record");
556             }
557              
558 34         71 $flag_intranets = $FLAG_INTRANETS;
559              
560             #10/8
561 34 100 66     193 if ($flag_intranets && $ip =~ /^10\./) {
562 3         29 return (2, "Invalid use of private IP (e.g. $ip) range for MX");
563             }
564             #172.16/12 - Fixed per Matthen van Eerde
565 31 50 33     168 if ($flag_intranets && $ip =~ /^172\.(16|17|18|19|20|21|22|23|24|25|26|27|28|29|30|31)\./) {
566 0         0 return (2, "Invalid use of private IP (e.g. $ip) range for MX");
567             }
568             #192.168/16
569 31 100 66     154 if ($flag_intranets && $ip =~ /^192\.168\./) {
570 4         32 return (2, "Invalid use of private IP (e.g. $ip) range for MX");
571             }
572              
573             #fc00::/7
574 27 50 33     150 if ($flag_intranets && $ip =~ /^fc00\:0\:/i) {
575 0         0 return (2, "Invalid use of unique local address (e.g. $ip) range for MX");
576             }
577              
578             #fd00::/8
579 27 50 33     133 if ($flag_intranets && $ip =~ /^fd00\:0\:/i) {
580 0         0 return (2, "Invalid use of private IP (e.g. $ip) range for MX");
581             }
582              
583             #DHCP auto-discover added per Matthew van Eerde recomendation 169.254/16
584 27 50       79 if ($ip =~ /^169\.254\./) {
585 0         0 return (1, "Invalid use of a DHCP auto-discover IP range ($ip) as an MX record");
586             }
587              
588             #IPv6 link-local addresses fe80::/10
589 27 100       77 if ($ip =~ /^fe80\:0\:/i) {
590 1         14 return (1, "Invalid use of a link-local IP range ($ip) as an MX record");
591             }
592              
593             #Multicast 224/8 through 239/8 added per Matthew van Eerde recomendation
594 26 50       86 if ($ip =~ /^(224|225|226|227|228|229|230|231|232|233|234|235|236|237|238|239)\./) {
595 0         0 return (1, "Invalid use of a Multicast IP range ($ip) as an MX record");
596             }
597              
598             #Experimental block - Former Class E - 240.0.0.0/4 courtesy of Mark Damrose
599 26 50       61 if ($ip =~ /^2[45]\d\./) {
600 0         0 return (1, "Invalid use of an experimental IP ($ip) as an MX record");
601             }
602              
603             #Reserved for benchmark tests of interconnect devices 192.18.0.0/15 courtesy of Mark Damrose
604 26 50       73 if ($ip =~ /^192\.1[89]\./) {
605 0         0 return (1, "Invalid use of a reserved IP ($ip) as an MX record");
606             }
607              
608             #Reserved for documentation or published examples 192.0.2.0/24 courtesy of Mark Damrose
609 26 50       82 if ($ip =~ /^192\.0\.2\./) {
610 0         0 return (1, "Invalid use of a reserved IP ($ip) as an MX record");
611             }
612              
613            
614 26         97 return (0,'');
615             }
616              
617             sub int_to_truefalse {
618 37     37 0 87 my ($int) = @_;
619              
620 37 100       112 if ($int) {
621 25         84 return "True";
622             } else {
623 12         54 return "False";
624             }
625             }
626              
627             sub check_email_and_mx {
628 3     3 1 2872 my ($email) = @_;
629 3         7 my ($rv, $fail_reason, $status, $debug);
630              
631 3         5 $debug = 0;
632              
633 3 50       10 $email || return 0;
634            
635 3 50       16 print "DEBUG: e-mail address is: $email
\n" if $debug;
636            
637             # SANITIZE THE E-MAIL ADDRESS OF SPACES
638 3         18 $email =~ s/ //g;
639              
640             # CHECK FOR INCOMPLETE ADDRESSES AT LARGE ISPS
641 3         12 $email =~ s/\@aol\.?$/\@aol.com/i;
642 3         6 $email =~ s/\@hotmail\.?$/\@hotmail.com/i;
643 3         6 $email =~ s/\@gmail\.?$/\@gmail.com/i;
644              
645 3 50       8 print "DEBUG: e-mail address is now: $email
\n" if $debug;
646              
647             # CHECK FOR A VALIDLY CONSTRUCTED E-MAIL ADDRESS
648 3         8 ($rv) = Net::validMX::check_email_validity($email);
649            
650 3 50       8 if ($rv < 1) {
651 0         0 return($rv, "Failed check_email_validity", $email);
652             }
653              
654             # CHECK FOR VALID MX RECORD
655 3         10 ($rv, $fail_reason) = Net::validMX::check_valid_mx($email);
656              
657 3 50       66 if ($rv < 1) {
658 0         0 return($rv, $fail_reason, $email);
659             }
660              
661 3         13 return($rv, "Passed", $email);
662             }
663              
664             sub check_email_validity {
665 11     11 1 3198 my ($email) = @_;
666 11         20 my ($local);
667              
668             #allows an email address that contains -()/!#$%&*+~. A through Z a through Z and 0 through 9 in a format of [valid]@([valid].[valid]...).[valid]. = will also be
669             #allowed in the username. Thanks to Paul Whittney for reporting the issue.
670              
671             #PER WIKIPEDIA
672             #Per Wikipedia:
673              
674             #The format of email addresses is local-part@domain where the local-part may be up to 64 characters long and the domain name may have a maximum of 253 characters - but the maximum 256 characters length of a forward or reverse path restricts the entire email address to be no more than 254 characters.[1] - formally defined in RFC 5322 (sections 3.2.3 and 3.4.1) and by RFC 5321.
675            
676             #Can't have two dots
677 11 50       54 if ($email =~ /\.\./) {
678 0         0 return 0;
679             }
680              
681             #Can't be longer than 254 chars
682 11 50       42 if (length($email) > 254) {
683 0         0 return 0;
684             }
685              
686             #Can't end in a period
687 11 50       42 if ($email =~ /\.$/) {
688 0         0 return 0;
689             }
690              
691 11 100       257 if ($email =~ /^(.*)@[-()\/!#$%&*+~_A-Za-z0-9\.]+\.[-()\/!#$%&*+~_A-Za-z0-9\.]+$/) {
692            
693 8         29 $local = $1;
694            
695             #check local length
696 8 100       27 if (length($local) > 64) {
697 2         9 return 0;
698             }
699             #no need to check if domain is over 253 chars, as it would not pass both overall length and regex if it was
700              
701             # per RFC 3696 section 3 the local part of an address cannot begin or end with a period
702 6 50 33     65 if ($local =~ /^\./ or $local =~ /\.$/g) {
703 0         0 return 0;
704             }
705            
706             # PURGE BACKSLASHES
707 6         23 $local =~ s/\\//g;
708            
709             # per RFC 3696 section 3 the local part of the email can be quoted, which allows any character to appear if inside quotes
710             # PURGE BEGINNING AND END QUOTE IF IT CONTAINS QUOTES
711 6 100       24 if ($local =~ /"/) {
712 1 50       9 if($local =~ /^".*"$/) {
713 0         0 $local =~ s/^"//g;
714 0         0 $local =~ s/"$//g;
715             }
716            
717             # IF IT STILL CONTAINS A QUOTE, IT IS INVALID, OTHERWISE THE LOCAL PART IS VALID
718 1 50       10 if ($local =~ /"/) {
719 1         9 return 0;
720             } else {
721 0         0 return 1;
722             }
723             }
724            
725             # check for allowed characters, per RFC 3696 section 3
726 5 50       22 if ($local =~ /^[\@'-`\/!\?=#\$\%&*+~_A-Za-z0-9\.{}|]+$/) {
727 5         25 return 1;
728             } else {
729 0         0 return 0;
730             }
731              
732             }
733 3         24 return 0;
734              
735             }
736              
737             #get domain name from an email address
738             sub get_domain_from_email {
739 38     38 1 1112 my ($email, %params) = @_;
740              
741 38         63 my ($domain, $local);
742              
743 38         52 $domain = $email;
744              
745             #REMOVE ANY LEADING/TRAILING <>'s
746 38         309 $domain =~ s/(^<|>$)//g;
747             #REMOVE ANY LEADING/TRAILING SPACE'S
748 38         230 $domain =~ s/^ *//g;
749 38         391 $domain =~ s/ *$//g;
750             #REMOVE EVERYTHING UP TO THE @ SYMBOL
751 38         186 $domain =~ s/(.*)\@//g;
752              
753 38         111 $local = $1;
754              
755 38 50       136 print "\nDEBUG: Extracted Sender Domain: $domain / Local: $local from $params{'email'}\n" if $params{'debug'};
756              
757 38 100       153 return wantarray ? ($local,$domain) : $domain;
758             }
759              
760             sub dns_lookup {
761 0     0 0   my ($domain, $type) = @_;
762 0           my ($dns, $query);
763              
764 0           $dns = Net::DNS::Resolver->new;
765 0           $query = $dns->search($domain, $type);
766 0 0         if ($query) {
767 0           return $query->answer;
768             } else {
769 0           warn "Error performing $type query for $domain! ". $dns->errorstring;
770             }
771             }
772              
773             sub check_spf_for_domain {
774 0     0 1   my ($domain, %params) = @_;
775 0           my ($dns, $query, $spf_line, @clauses, $found_spf);
776              
777 0           $dns = Net::DNS::Resolver->new;
778 0           $query = $dns->search($domain, 'TXT');
779 0 0         if (not $query) {
780 0           warn "Error performing TXT query for $domain! ". $dns->errorstring;
781 0           return ("suspect", "no TXT record found");
782             }
783              
784 0           foreach my $result ($query->answer) {
785 0 0         next unless $result->type eq 'TXT';
786 0           $spf_line = $result->txtdata;
787              
788 0 0         if ($spf_line =~ /^v=spf[12]/i) {
789 0           $found_spf++;
790              
791             # split into clauses
792 0           @clauses = split / /, $spf_line;
793              
794 0           foreach my $clause (@clauses) {
795             # ignore clauses that reject email - only false accepts are good spam indicators
796 0 0         next if $clause =~ /^[-~]/;
797 0 0         if ($clause =~ /^.?all/) {
798             # if accepting email from all, rule is clearly useless
799 0           return ("bad", "use of universal pass rule $clause");
800             }
801             }
802             }
803             }
804              
805 0 0         if ($found_spf == 0) {
    0          
806 0           return ("suspect", "no TXT record matching SPF format found");
807             } elsif ($found_spf > 1) {
808 0           return ("suspect", "multiple TXT records matching SPF format found");
809             }
810              
811 0           return ("valid", undef);
812             }
813              
814             1;
815              
816             __END__