home *** CD-ROM | disk | FTP | other *** search
/ ftp.f-secure.com / 2014.06.ftp.f-secure.com.tar / ftp.f-secure.com / support / hotfix / fsis / IS-SpamControl.fsfix / iufssc / lib / Mail / SPF / Query.pm
Text File  |  2006-11-29  |  65KB  |  1,933 lines
  1. package Mail::SPF::Query;
  2.  
  3. # ----------------------------------------------------------
  4. #                Mail::SPF::Query
  5. #
  6. #                Meng Weng Wong
  7. #          <mengwong+spf@pobox.com>
  8. # $Id: Query.pm 2056 2005-09-27 10:32:40Z kankri $
  9. # test an IP / sender address pair for pass/fail/nodata/error
  10. #
  11. # http://spf.pobox.com/
  12. #
  13. # this version is compatible with spf-draft-20040209.txt
  14. #
  15. # license: Academic Free License
  16. #          modulo issues relating to Microsoft Caller-ID For Email
  17. #
  18. # The result of evaluating a SPF record associated with a domain is one of:
  19. # 
  20. # none - the domain does not have an SPF record.
  21. # 
  22. # neutral - domain explicitly wishes you to pretend it had no SPF record.
  23. # 
  24. # unknown - a permanent error -- such as missing SPF record
  25. #           during "include" or "redirect", parse error, unknown
  26. #           mechanism, record loop
  27. # 
  28. # error - some type of temporary failure, usually DNS related
  29. # 
  30. # softfail - explicit softfail --- please apply strict antispam checks
  31. # 
  32. # fail - explicit fail --- MTA may reject, MUA may discard
  33. # 
  34. # pass - explicit pass --- message is not a forgery
  35. #
  36. # TODO:
  37. #  - add ipv6 support
  38. #  - rename to v2.0 when we add caller-id support and the header syntax
  39. # 
  40. #  - also, Received-SPF should support a local-secret argument to prevent Received-SPF forgery.
  41. #  - set up a default fallback yahoo.com domain
  42. # 
  43. #  - add support for doing HELO tests before return-path tests.
  44. # 
  45. #  - if the spf_source is not original-spf-record, do not return why.html.  this doesn't make sense:
  46. # perl -MData::Dumper -MMail::SPF::Query -le 'my $query = Mail::SPF::Query->new(ipv4=>$ARGV[0], helo=>$ARGV[1], sender=>$ARGV[2], max_lookup_count=>2, myhostname=>"poopy.com", debug=>1); print Dumper($query->result);' 208.210.125.24 "testing..com" mengwong@dumbo.pobox.com 
  47. #    $VAR1 = 'fail';
  48. #    $VAR2 = 'Please see http://spf.pobox.com/why.html?sender=mengwong%40www.mailzone.com&ip=208.210.125.1&receiver=poopy.com';
  49. #    $VAR3 = 'poopy.com: explicit fallback found: *. defines v=spf1 -all';
  50. #    $VAR4 = 'v=spf1 -all';
  51. #    $VAR5 = {
  52. #              'result' => 'fail',
  53. #              'header_pairs' => 'receiver=poopy.com; client-ip=208.210.125.1; envelope-from=mengwong@www.mailzone.com; helo=testing.com; mechanism=-all; x-spf-source=explicit fallback found: *. defines v=spf1 -all;',
  54. #              'unknown_mechs' => [],
  55. #              'vouches' => [],
  56. #              'modifiers' => undef,
  57. #              'header_comment' => 'poopy.com: explicit fallback found: *. defines v=spf1 -all',
  58. #              'smtp_comment' => 'Please see http://spf.pobox.com/why.html?sender=mengwong%40www.mailzone.com&ip=208.210.125.1&receiver=poopy.com',
  59. #              'spf_record' => 'v=spf1 -all'
  60. #            };
  61. #    
  62. #    perl -MData::Dumper -MMail::SPF::Query -le  208.210.125.1 "testing.com"   0.11s user 0.03s system 126% cpu 0.110 total
  63. #    20040425-14:57:53 root@dumbo:~mengwong/src/site_perl/SPF#
  64. #    
  65. # 
  66. # BUGS:
  67. #  mengwong 20031211
  68. #    if there are multiple unrecognized mechanisms, they all
  69. #    need to be preserved in the 'unknown' Received-SPF header.
  70. #    right now only the first appears.
  71. # 
  72. #  mengwong 20040225: override and fallback keys need to be lc'ed at start
  73. # 
  74. # ----------------------------------------------------------
  75.  
  76. use 5.006;
  77. use strict;
  78. use warnings;
  79. no warnings 'uninitialized';
  80. use vars qw($VERSION $CACHE_TIMEOUT $DNS_RESOLVER_TIMEOUT);
  81.  
  82. use URI::Escape;
  83. use Net::CIDR::Lite;
  84. use Net::DNS qw(); # by default it exports mx, which we define.
  85.  
  86. # ----------------------------------------------------------
  87. #                initialization
  88. # ----------------------------------------------------------
  89.  
  90. my $GUESS_MECHS = "a/24 mx/24 ptr";
  91.  
  92. my $TRUSTED_FORWARDER = "include:spf.trusted-forwarder.org";
  93.  
  94. my $DEFAULT_EXPLANATION = "Please see http://spf.pobox.com/why.html?sender=%{S}&ip=%{I}&receiver=%{xR}";
  95.  
  96. my @KNOWN_MECHANISMS = qw( a mx ptr include ip4 ip6 exists all );
  97.  
  98. my $MAX_LOOKUP_COUNT    = 20;
  99.  
  100. my $Domains_Queried = {};
  101.  
  102. # if not set, then softfail is treated as neutral.
  103. my $softfail_supported = 1;
  104.  
  105. $VERSION = "1.997";
  106.  
  107. $CACHE_TIMEOUT = 120;
  108.  
  109. $DNS_RESOLVER_TIMEOUT = 15;
  110.  
  111. # ----------------------------------------------------------
  112. #      no user-serviceable parts below this line
  113. # ----------------------------------------------------------
  114.  
  115. my $looks_like_ipv4  = qr/\d+\.\d+\.\d+\.\d+/;
  116. my $looks_like_email = qr/\S+\@\S+/;
  117.  
  118. =head1 NAME
  119.  
  120. Mail::SPF::Query - query Sender Policy Framework for an IP,email,helo
  121.  
  122. =head1 SYNOPSIS
  123.  
  124.   my $query = new Mail::SPF::Query (ip => "127.0.0.1", sender=>'foo@example.com', helo=>"somehost.example.com", trusted=>1, guess=>1);
  125.   my ($result,           # pass | fail | softfail | neutral | none | error | unknown [mechanism]
  126.       $smtp_comment,     # "please see http://spf.pobox.com/why.html?..."  when rejecting, return this string to the SMTP client
  127.       $header_comment,   # prepend_header("Received-SPF" => "$result ($header_comment)")
  128.       $spf_record,       # "v=spf1 ..." original SPF record for the domain
  129.      ) = $query->result();
  130.  
  131.     if    ($result eq "pass") { "domain is (probably) not forged.  apply RHSBL and content filters" }
  132.     elsif ($result eq "fail") { "domain is forged.  reject or save to spambox" }
  133.  
  134.   The default mechanism for trusted=>1 is "include:spf.trusted-forwarder.org".
  135.   The default mechanisms for guess=>1 are "a/24 mx/24 ptr".
  136.  
  137. =head1 ABSTRACT
  138.  
  139. The SPF protocol relies on sender domains to describe their
  140. designated outbound mailers in DNS.  Given an email address,
  141. Mail::SPF::Query determines the legitimacy of an SMTP client
  142. IP.
  143.  
  144. =head1 DESCRIPTION
  145.  
  146. There are two ways to use Mail::SPF::Query.  Your choice
  147. depends on whether the domains your server is an MX for have
  148. secondary MXes which your server doesn't know about.
  149.  
  150. The first and more common style, calling ->result(), is
  151. suitable when all mail is received directly from the
  152. originator's MTA.  If the domains you receive do not have
  153. secondary MX entries, this is appropriate.  This style of
  154. use is outlined in the SYNOPSIS above.  This is the common
  155. case.
  156.  
  157. The second style is more complex, but works when your server
  158. receives mail from secondary MXes.  This performs checks as
  159. each recipient is handled.  If the message is coming from a
  160. valid MX secondary for a recipient, then the SPF check is
  161. not performed, and a "pass" response is returned right away.
  162. To do this, call C<result2()> and C<message_result2()>
  163. instead of C<result()>.
  164.  
  165. If you do not know what a secondary MX is, you probably
  166. don't have one.  Use the first style.
  167.  
  168. You can try out Mail::SPF::Query on the command line with
  169. the following command:
  170.  
  171.   perl -MMail::SPF::Query -le 'print for Mail::SPF::Query->new(helo=>shift, ipv4=>shift, sender=>shift)->result' myhost.mydomain.com 1.2.3.4 myname@myhost.mydomain.com
  172.  
  173.  
  174. =head1 METHODS
  175.  
  176. =over
  177.  
  178. =item C<< Mail::SPF::Query->new() >>
  179.  
  180.   my $query = eval { new Mail::SPF::Query (ip    =>"127.0.0.1",
  181.                                            sender=>'foo@example.com',
  182.                                            helo  =>"host.example.com") };
  183.  
  184.   optional parameters:
  185.      debug => 1, debuglog => sub { print STDERR "@_\n" },
  186.      local => 'extra mechanisms',
  187.      trusted => 1,                    # do trusted forwarder processing
  188.      guess => 1,                      # do best_guess if no SPF record
  189.      default_explanation => 'Please see http://spf.my.isp/spferror.html for details',
  190.      max_lookup_count => 20,          # total number of SPF include/redirect queries
  191.      sanitize => 0,                   # do not sanitize all returned strings
  192.      myhostname => "foo.example.com", # prepended to header_comment
  193.      fallback => {   "foo.com" => { record => "v=spf1 a mx -all", OPTION => VALUE },
  194.                    "*.foo.com" => { record => "v=spf1 a mx -all", OPTION => VAULE }, },
  195.      override => {   "bar.com" => { record => "v=spf1 a mx -all", OPTION => VALUE },
  196.                    "*.bar.com" => { record => "v=spf1 a mx -all", OPTION => VAULE }, },
  197.      callerid => {   "hotmail.com" => { check => 1 },
  198.                    "*.hotmail.com" => { check => 1 },
  199.                    "*."            => { check => 0 }, },
  200.  },
  201.  
  202.   if ($@) { warn "bad input to Mail::SPF::Query: $@" }
  203.  
  204. Set C<trusted=E<gt>1> to turned on automatic trusted_forwarder processing.
  205. The mechanism C<include:spf.trusted-forwarder.org> is used just before a C<-all> or C<?all>.
  206. The precise circumstances are somewhat more complicated, but it does get the case of C<v=spf1 -all>
  207. right -- i.e. spf.trusted-forwarder.org is not checked.
  208.  
  209. Set C<guess=E<gt>1> to turned on automatic best_guess processing.
  210. This will use the best_guess SPF record when one cannot be found
  211. in the DNS. Note that this can only return C<pass> or C<neutral>. 
  212. The C<trusted> and C<local> flags also operate when the best_guess is being used.
  213.  
  214. Set C<local=E<gt>'include:local.domain'> to include some extra processing just before a C<-all> or C<?all>.
  215. The local processing happens just before the trusted processing.
  216.  
  217. Set C<default_explanation> to a string to be used if the SPF record does not provide
  218. a specific explanation. The default value will direct the user to a page at spf.pobox.com with 
  219. "Please see http://spf.pobox.com/why.html?sender=%{S}&ip=%{I}&receiver=%{xR}". Note that the
  220. string has macro substitution performed.
  221.  
  222. Set C<sanitize> to 0 to get all the returned strings unsanitized. Alternatively, pass a function reference
  223. and this function will be used to sanitize the returned values. The function must take a single string
  224. argument and return a single string which contains the sanitized result.
  225.  
  226. Set C<debug=E<gt>1> to watch the queries happen.
  227.  
  228. Set C<fallback> to define "pretend" SPF records for domains
  229. that don't publish them yet.  Wildcards are supported.
  230.  
  231. Set C<override> to define SPF records for domains that do
  232. publish but which you want to override anyway.  Wildcards
  233. are supported.
  234.  
  235. Set C<callerid> to look for Microsoft "Caller-ID for Email"
  236. records if an SPF record is not found.  Wildcards are
  237. supported.  You will need Expat, XML::Parser, and
  238. LMAP::CID2SPF installed for this to work; if you do not have
  239. these libraries installed, the lookup will not occur.  By
  240. default, this library will only look for those records in
  241. hotmail.com and microsoft.com domains.
  242.  
  243. If you want to always look for Caller-ID records, set
  244.  
  245.   ->new(..., callerid => { "*." => { check => 1 } })
  246.  
  247. If you never want to do Caller-ID,
  248.  
  249.   ->new(..., callerid => { "*." => { check => 0 } })
  250.  
  251. NOTE: domain name arguments to fallback, override, and
  252. callerid need to be in all lowercase.
  253.  
  254. =cut
  255.  
  256. # ----------------------------------------------------------
  257. sub new {
  258. # ----------------------------------------------------------
  259.   my $class = shift;
  260.   my $query = bless { depth => 0,
  261.               @_,
  262.             }, $class;
  263.  
  264.   $query->{ipv4} = delete $query->{ip}   if $query->{ip}   and $query->{ip} =~ $looks_like_ipv4;
  265.   $query->{helo} = delete $query->{ehlo} if $query->{ehlo};
  266.  
  267.   $query->{local} .= ' ' . $TRUSTED_FORWARDER if ($query->{trusted});
  268.  
  269.   $query->{trusted} = undef;
  270.  
  271.   $query->{spf_error_explanation} ||= "SPF record error";
  272.  
  273.   $query->{default_explanation} ||= $DEFAULT_EXPLANATION;
  274.  
  275.   $query->{default_record} = $GUESS_MECHS if ($query->{guess});
  276.  
  277.   if (($query->{sanitize} && !ref($query->{sanitize})) || !defined($query->{sanitize})) {
  278.       # Apply default sanitizer
  279.       $query->{sanitize} = \&strict_sanitize;
  280.   }
  281.  
  282.   $query->{sender} =~ s/<(.*)>/$1/g;
  283.  
  284.   if (not ($query->{ipv4}   and length $query->{ipv4}))   { die "no IP address given to spfquery"   }
  285.  
  286.   for ($query->{sender}) { s/^\s+//; s/\s+$//; }
  287.  
  288.   $query->{spf_source} = "domain of $query->{sender}";
  289.   $query->{spf_source_type} = "original-spf-record";
  290.  
  291.   ($query->{domain}) = $query->{sender} =~ /([^@]+)$/; # given foo@bar@baz.com, the domain is baz.com, not bar@baz.com.
  292.  
  293.   # the domain should not be an address literal --- [1.2.3.4]
  294.   if ($query->{domain} =~ /^\[\d+\.\d+\.\d+\.\d+\]$/) {
  295.     die "sender domain should be an FQDN, not an address literal";
  296.   }
  297.  
  298.   if (not $query->{helo}) { require Carp; import Carp qw(cluck); cluck ("Mail::SPF::Query: ->new() requires a \"helo\" argument.\n");
  299.                 $query->{helo} = $query->{domain};
  300.               }
  301.  
  302.   $query->debuglog("new: ipv4=$query->{ipv4}, sender=$query->{sender}, helo=$query->{helo}");
  303.  
  304.   ($query->{helo}) =~ s/.*\@//; # strip localpart from helo
  305.  
  306.   if (not $query->{domain}) {
  307.     $query->debuglog("spfquery: sender $query->{sender} has no domain, using HELO domain $query->{helo} instead.");
  308.     $query->{domain} = $query->{helo};
  309.     $query->{sender} = $query->{helo};
  310.   }
  311.  
  312.   if (not length $query->{domain}) { die "unable to identify domain of sender $query->{sender}" }
  313.  
  314.   $query->{orig_domain} = $query->{domain};
  315.  
  316.   $query->{loop_report} = [$query->{domain}];
  317.  
  318.   ($query->{localpart}) = $query->{sender} =~ /(.+)\@/;
  319.   $query->{localpart} = "postmaster" if not length $query->{localpart};
  320.  
  321.   $query->debuglog("localpart is $query->{localpart}");
  322.  
  323.   $query->{Reversed_IP} = ($query->{ipv4} ? reverse_in_addr($query->{ipv4}) :
  324.                $query->{ipv6} ? die "IPv6 not supported" : "");
  325.  
  326.   if (not $query->{myhostname}) {
  327.     use Sys::Hostname; 
  328.     eval { require Sys::Hostname::Long };
  329.     $query->{myhostname} = $@ ? hostname() : Sys::Hostname::Long::hostname_long();
  330.   }
  331.  
  332.   $query->{myhostname} ||= "localhost";
  333.  
  334.   $query->{callerid} ||= 
  335.     {     "hotmail.com" => { check => 1 }, # by default, check microsoft and hotmail domains
  336.     "*.hotmail.com" => { check => 1 }, # for caller-id records when no SPF record is found.
  337.     "microsoft.com" => { check => 1 },
  338.       "*.microsoft.com" => { check => 1 },
  339.                "*." => { check => 0 }, # by default, do not check any other domains
  340.     };
  341.  
  342.   $query->post_new(@_) if $class->can("post_new");
  343.  
  344.   return $query;
  345. }
  346.  
  347. =head2 $query->result()
  348.  
  349.   my ($result, $smtp_comment, $header_comment, $spf_record, $detail) = $query->result();
  350.  
  351. C<$result> will be one of C<pass>, C<fail>, C<softfail>, C<neutral>, C<none>, C<error> or C<unknown [...]>.
  352.  
  353. C<pass> means the client IP is a designated mailer for the
  354. sender.  The mail should be accepted subject to local policy
  355. regarding the sender.
  356.  
  357. C<fail> means the client IP is not a designated mailer, and
  358. the sender wants you to reject the transaction for fear of
  359. forgery.
  360.  
  361. C<softfail> means the client IP is not a designated mailer,
  362. but the sender prefers that you accept the transaction
  363. because it isn't absolutely sure all its users are mailing
  364. through approved servers.  The C<softfail> status is often
  365. used during initial deployment of SPF records by a domain.
  366.  
  367. C<neutral> means that the sender makes no assertion about the
  368. status of the client IP.
  369.  
  370. C<none> means that there is no SPF record for this domain.
  371.  
  372. C<unknown [...]> means the domain has a configuration error in
  373. the published data or defines a mechanism which this library
  374. does not understand.  If the data contained an unrecognized
  375. mechanism, it will be presented following "unknown".  You
  376. should test for unknown using a regexp C</^unknown/> rather
  377. than C<eq "unknown">.
  378.  
  379. C<error> means the DNS lookup encountered a temporary error
  380. during processing.
  381.  
  382. Results are cached internally for a default of 120 seconds.
  383. You can call C<-E<gt>result()> repeatedly; subsequent
  384. lookups won't hit your DNS.
  385.  
  386. The smtp_comment should be displayed to the SMTP client.
  387.  
  388. The header_comment goes into a Received-SPF header, like so: C<Received-SPF: $result ($header_comment)>
  389.  
  390. The spf_record shows the original SPF record fetched for the
  391. query.  If there is no SPF record, it is blank.  Otherwise,
  392. it will start with "v=spf1" and contain the SPF mechanisms
  393. and such that describe the domain.
  394.  
  395. Note that the strings returned by this method (and most of the other methods)
  396. are (at least partially) under the control of the sender's 
  397. domain. This means that, if the sender is an attacker,
  398. the contents can be assumed to be hostile. 
  399. The various methods that return these strings make sure
  400. that (by default) the strings returned contain only
  401. characters in the range 32 - 126. This behavior can
  402. be changed by setting C<sanitize> to 0 to turn off sanitization
  403. entirely. You can also set C<sanitize> to a function reference to
  404. perform custom sanitization.
  405. In particular, assume that the C<smtp_comment> might
  406. contain a newline character. 
  407.  
  408. The C<detail> element is a hash of all the foregoing
  409. elements, plus extra data returned by the SPF result.
  410.  
  411. Why the weird duplication?  In the beginning, C<result()>
  412. returned only one value, the C<$result>.  Then
  413. C<$smtp_comment> and C<$header_comment> came along.  Then
  414. C<$spf_record>.  Past a certain number of positional
  415. results, it makes more sense to have a hash.  But we didn't
  416. want to break backwards compatibility, so we just declared
  417. that the fifth result would be a hash and future return
  418. value would go in there.
  419.  
  420. The keys of the hash are:
  421.  
  422.   result
  423.   smtp_comment
  424.   header_comment
  425.   header_pairs
  426.   spf_record
  427.   modifiers
  428.   vouches
  429.  
  430. $query->result();
  431.  
  432. =cut
  433.  
  434.  
  435. # ----------------------------------------------------------
  436. #                result
  437. # ----------------------------------------------------------
  438.  
  439. sub result {
  440.   my $query = shift;
  441.   my %result_set;
  442.  
  443.   my ($result, $smtp_explanation, $smtp_why, $orig_txt) = $query->spfquery( ($query->{best_guess} ? $query->{guess_mechs} : () ) );
  444.  
  445.   # print STDERR "*** result = $result, exp = $smtp_explanation, why = $smtp_why\n";
  446.  
  447.   # before this, we weould see a "default" on the end: Please see http://spf.pobox.com/why.html?sender=mengwong%40vw.mailzone.com&ip=208.210.125.1&receiver=poopy.com: default
  448.   $smtp_why = "" if $smtp_why eq "default";
  449.  
  450.   my $smtp_comment = ($smtp_explanation && $smtp_why) ? "$smtp_explanation: $smtp_why" : ($smtp_explanation || $smtp_why);
  451.  
  452.   $query->{smtp_comment} = $smtp_comment;
  453.  
  454.   my $header_comment = "$query->{myhostname}: ". $query->header_comment($result);
  455.  
  456.   # $result =~ s/\s.*$//; # this regex truncates "unknown some:mechanism" to just "unknown"
  457.  
  458.   $query->{result} = $result;
  459.  
  460.   my $hash = { result         => $query->sanitize(lc $result),
  461.            smtp_comment   => $query->sanitize($smtp_comment),
  462.            header_comment => $query->sanitize($header_comment),
  463.            spf_record     => $query->sanitize($orig_txt),
  464.            modifiers      => $query->{modifiers},
  465.            vouches        => [ ], # reserved for accreditation vouches.
  466.            unknown_mechs  => [ ], # reserved for unknown mechanisms.
  467.            header_pairs   => $query->sanitize(scalar $query->header_pairs()),
  468.          };           
  469.  
  470.   return ($hash->{result},
  471.       $hash->{smtp_comment},
  472.       $hash->{header_comment},
  473.       $hash->{spf_record},
  474.       $hash,
  475.      ) if wantarray;
  476.  
  477.   return  $query->sanitize(lc $result);
  478. }
  479.  
  480. sub header_comment {
  481.   my $query = shift;
  482.   my $result = shift;
  483.   my $ip = $query->ip;
  484.   if ($result eq "pass" and $query->{smtp_comment} eq "localhost is always allowed.") { return $query->{smtp_comment} }
  485.  
  486.   $query->debuglog("header_comment: spf_source = $query->{spf_source}");
  487.   $query->debuglog("header_comment: spf_source_type = $query->{spf_source_type}");
  488.  
  489.   if ($query->{spf_source_type} eq "original-spf-record") {
  490.   return
  491.     (  $result eq "pass"      ? "$query->{spf_source} designates $ip as permitted sender"
  492.      : $result eq "fail"      ? "$query->{spf_source} does not designate $ip as permitted sender"
  493.      : $result eq "softfail"  ? "transitioning $query->{spf_source} does not designate $ip as permitted sender"
  494.      : $result =~ /^unknown / ? "encountered unrecognized mechanism during SPF processing of $query->{spf_source}"
  495.      : $result eq "unknown"   ? "error in processing during lookup of $query->{sender}"
  496.      : $result eq "neutral"   ? "$ip is neither permitted nor denied by domain of $query->{sender}"
  497.      : $result eq "error"     ? "encountered temporary error during SPF processing of $query->{spf_source}"
  498.      : $result eq "none"      ? "$query->{spf_source} does not designate permitted sender hosts" 
  499.      :                          "could not perform SPF query for $query->{spf_source}" );
  500.   }
  501.  
  502.   return $query->{spf_source};
  503.  
  504. }
  505.  
  506. sub header_pairs {
  507.   my $query = shift;
  508. # from spf-draft-200404.txt
  509. #    SPF clients may append zero or more of the following key-value-pairs
  510. #    at their discretion:
  511. # 
  512. #       receiver       the hostname of the SPF client
  513. #       client-ip      the IP address of the SMTP client
  514. #       envelope-from  the envelope sender address
  515. #       helo           the hostname given in the HELO or EHLO command
  516. #       mechanism      the mechanism that matched (if no mechanisms
  517. #                      matched, substitute the word "default".)
  518. #       problem        if an error was returned, details about the error
  519. # 
  520. #    Other key-value pairs may be defined by SPF clients.  Until a new key
  521. #    name becomes widely accepted, new key names should start with "x-".
  522.  
  523.   my @pairs = (
  524.            "receiver"      => $query->{myhostname},
  525.            "client-ip"     => ($query->{ipv4} || $query->{ipv6} || ""),
  526.            "envelope-from" => $query->{sender},
  527.            "helo"          => $query->{helo},
  528.            mechanism       => ($query->{matched_mechanism} ? display_mechanism($query->{matched_mechanism}) : "default"),
  529.            ($query->{result} eq "error"
  530.         ? (problem         => $query->{spf_error_explanation})
  531.         : ()),
  532.            ($query->{spf_source_type} ne "original-spf-record" ? ("x-spf-source" => $query->{spf_source}) : ()),
  533.           );
  534.  
  535.   if (wantarray) { return @pairs; }
  536.   my @pair_text;
  537.   while (@pairs) {
  538.     my ($key, $val) = (shift(@pairs), shift (@pairs));
  539.     push @pair_text, "$key=$val;";
  540.   }
  541.   return join " ", @pair_text;
  542. }
  543.  
  544. =item C<< $query->result2() >>
  545.  
  546.   my ($result, $smtp_comment, $header_comment, $spf_record) = $query->result2('recipient@domain', 'recipient2@domain');
  547.  
  548. C<result2> does everything that C<result> does, but it first
  549. checks to see if the sending system is a recognized MX
  550. secondary for the recipient(s). If so, then it returns C<pass>
  551. and does not perform the SPF query. Note that the sending
  552. system may be a MX secondary for some (but not all) of the
  553. recipients for a multi-recipient message, which is why
  554. result2 takes an argument list.  See also C<message_result2()>.
  555.  
  556. C<$result> will be one of C<pass>, C<fail>, C<neutral [...]>, or C<unknown>.
  557. See C<result()> above for meanings.
  558.  
  559. If you have MX secondaries and if you are unable to
  560. explicitly whitelist those secondaries before SPF tests
  561. occur, you can use this method in place of C<result()>, calling
  562. it as many times as there are recipients, or just providing
  563. all the recipients at one time.
  564.  
  565. The smtp_comment can be displayed to the SMTP client.
  566.  
  567. For example:
  568.  
  569.   my $query = new Mail::SPF::Query (ip => "127.0.0.1",
  570.                                     sender=>'foo@example.com',
  571.                                     helo=>"somehost.example.com");
  572.  
  573.   ...
  574.  
  575.   my ($result, $smtp_comment, $header_comment);
  576.  
  577.   ($result, $smtp_comment, $header_comment) = $query->result2('recip1@mydomain.com');
  578.   # return suitable error code based on $result eq 'fail' or not
  579.  
  580.   ($result, $smtp_comment, $header_comment) = $query->result2('recip2@mydom.org');
  581.   # return suitable error code based on $result eq 'fail' or not
  582.  
  583.   ($result, $smtp_comment, $header_comment) = $query->message_result2();
  584.   # return suitable error if $result eq 'fail'
  585.   # prefix message with "Received-SPF: $result ($header_comment)"
  586.  
  587. This feature is relatively new to the module.  You can get
  588. support on the mailing list spf-devel@listbox.com.
  589.  
  590. The methods C<result2()> and C<message_result2()> use "2" because they
  591. work for secondary MXes. C<result2()> takes care to minimize the number of DNS operations
  592. so that there is little performance penalty from using it in place of C<result()>.
  593. In particular, if no arguments are supplied, then it just calls C<result()> and
  594. returns the method response.
  595.  
  596. =cut
  597.  
  598. # ----------------------------------------------------------
  599. #                result2
  600. # ----------------------------------------------------------
  601.  
  602. sub result2 {
  603.   my $query = shift;
  604.   my @recipients = @_;
  605.  
  606.   if (!$query->{result2}) {
  607.       my $all_mx_secondary = 'neutral';
  608.  
  609.       foreach my $recip (@recipients) {
  610.           my ($rhost) = $recip =~ /([^@]+)$/;
  611.  
  612.           $query->debuglog("result2: Checking status of recipient $recip (at host $rhost)");
  613.  
  614.           my $cache_result = $query->{mx_cache}->{$rhost};
  615.           if (not defined($cache_result)) {
  616.               $cache_result = $query->{mx_cache}->{$rhost} = is_secondary_for($rhost, $query->{ipv4}) ? 'yes' : 'no';
  617.               $query->debuglog("result2: $query->{ipv4} is a MX for $rhost: $cache_result");
  618.           }
  619.  
  620.           if ($cache_result eq 'yes') {
  621.               $query->{is_mx_good} = [$query->sanitize('pass'),
  622.                                       $query->sanitize('message from secondary MX'),
  623.                                       $query->sanitize("$query->{myhostname}: message received from $query->{ipv4} which is an MX secondary for $recip"),
  624.                                       undef];
  625.               $all_mx_secondary = 'yes';
  626.           } else {
  627.               $all_mx_secondary = 'no';
  628.               last;
  629.           }
  630.       }
  631.  
  632.       if ($all_mx_secondary eq 'yes') {
  633.           return @{$query->{is_mx_good}} if wantarray;
  634.           return $query->{is_mx_good}->[0];
  635.       }
  636.  
  637.       my @result = $query->result();
  638.  
  639.       $query->{result2} = \@result;
  640.   }
  641.  
  642.   return @{$query->{result2}} if wantarray;
  643.   return $query->{result2}->[0];
  644. }
  645.  
  646. sub is_secondary_for {
  647.     my ($host, $addr) = @_;
  648.  
  649.     my $resolver = Net::DNS::Resolver->new(
  650.                        tcp_timeout => $DNS_RESOLVER_TIMEOUT,
  651.                        udp_timeout => $DNS_RESOLVER_TIMEOUT,
  652.                        )
  653.                        ;
  654.     if ($resolver) {
  655.         my $mx = $resolver->send($host, 'MX');
  656.         if ($mx) {
  657.             my @mxlist = sort { $a->preference <=> $b->preference } (grep { $_->type eq 'MX' } $mx->answer);
  658.             # discard the first entry (top priority) - we shouldn't get mail from them
  659.             shift @mxlist;
  660.             foreach my $rr (@mxlist) {
  661.                 my $a = $resolver->send($rr->exchange, 'A');
  662.                 if ($a) {
  663.                     foreach my $rra ($a->answer) {
  664.                         if ($rra->type eq 'A') {
  665.                             if ($rra->address eq $addr) {
  666.                                 return 1;
  667.                             }
  668.                         }
  669.                     }
  670.                 }
  671.             }
  672.         }
  673.     }
  674.  
  675.     return undef;
  676. }
  677.  
  678. =item C<< $query->message_result2() >>
  679.  
  680.   my ($result, $smtp_comment, $header_comment, $spf_record) = $query->message_result2();
  681.  
  682. C<message_result2()> returns an overall status for the message
  683. after zero or more calls to C<result2()>. It will always be the last 
  684. status returned by C<result2()>, or the status returned by C<result()> if
  685. C<result2()> was never called.
  686.  
  687. C<$result> will be one of C<pass>, C<fail>, C<neutral [...]>, or C<error>.
  688. See C<result()> above for meanings.
  689.  
  690. =cut
  691.  
  692. # ----------------------------------------------------------
  693. #                message_result2
  694. # ----------------------------------------------------------
  695.  
  696. sub message_result2 {
  697.   my $query = shift;
  698.  
  699.   if (!$query->{result2}) {
  700.       if ($query->{is_mx_good}) {
  701.           return @{$query->{is_mx_good}} if wantarray;
  702.           return $query->{is_mx_good}->[0];
  703.       }
  704.  
  705.       # we are very unlikely to get here -- unless result2 was not called.
  706.  
  707.       my @result = $query->result();
  708.  
  709.       $query->{result2} = \@result;
  710.   }
  711.  
  712.   return @{$query->{result2}} if wantarray;
  713.   return $query->{result2}->[0];
  714. }
  715.  
  716. =item C<< $query->best_guess() >>
  717.  
  718.       my ($result, $smtp_comment, $header_comment) = $query->best_guess();
  719.  
  720. When a domain does not publish SPF records, this library can
  721. produce an educated guess anyway.
  722.  
  723. It pretends the domain defined A, MX, and PTR mechanisms,
  724. plus a few others.  The default set of directives is
  725.  
  726.   "a/24 mx/24 ptr"
  727.  
  728. That default set will return either "pass" or "neutral".
  729.  
  730. If you want to experiment with a different default, you can
  731. pass it as an argument: C<< $query->best_guess("a mx ptr") >>
  732.  
  733. Note that this method is deprecated. You should set C<guess=E<gt>1>
  734. on the C<new> method instead.
  735.  
  736. =item C<< $query->trusted_forwarder() >>
  737.  
  738.       my ($result, $smtp_comment, $header_comment) = $query->best_guess();
  739.  
  740. It is possible that the message is coming through a
  741. known-good relay like acm.org or pobox.com.  During the
  742. transitional period, many legitimate services may appear to
  743. forge a sender address: for example, a news website may have
  744. a "send me this article in email" link.
  745.  
  746. The trusted-forwarder.org domain is a whitelist of
  747. known-good hosts that either forward mail or perform
  748. legitimate envelope sender forgery.
  749.  
  750.   "include:spf.trusted-forwarder.org"
  751.  
  752. This will return either "pass" or "neutral".
  753.  
  754. Note that this method is deprecated. You should set C<trusted=E<gt>1>
  755. on the C<new> method instead.
  756.  
  757.  
  758. =cut
  759.  
  760. sub clone {
  761.   my $query = shift;
  762.   my $class = ref $query;
  763.  
  764.   my %guts = (%$query, @_, parent=>$query);
  765.  
  766.   my $clone = bless \%guts, $class;
  767.  
  768.   push @{$clone->{loop_report}}, delete $clone->{reason};
  769.  
  770.   $query->debuglog("  clone: new object:");
  771.   for ($clone->show) { $clone->debuglog( "clone: $_" ) }
  772.  
  773.   return $clone;
  774. }
  775.  
  776. sub top {
  777.   my $query = shift;
  778.   if ($query->{parent}) { return $query->{parent}->top }
  779.   return $query;
  780. }
  781.  
  782. sub set_temperror {
  783.   my $query = shift;
  784.   $query->{error} = shift;
  785. }
  786.  
  787. sub show {
  788.   my $query = shift;
  789.  
  790.   return map { sprintf ("%20s = %s", $_, $query->{$_}) } keys %$query;
  791. }
  792.  
  793. sub best_guess {
  794.   my $query = shift;
  795.   my $guess_mechs = shift || $GUESS_MECHS;
  796.  
  797.   # clone the query object with best_guess mode turned on.
  798.   my $guess_query = $query->clone( best_guess => 1,
  799.                    guess_mechs => $guess_mechs,
  800.                    reason => "has no data.  best guess",
  801.                  );
  802.  
  803.   $guess_query->{depth} = 0;
  804.   $guess_query->top->{lookup_count} = 0;
  805.  
  806.   # if result is not defined, the domain has no SPF.
  807.   #    perform fallback lookups.
  808.   #    perform trusted-forwarder lookups.
  809.   #    perform guess lookups.
  810.   #
  811.   # if result is defined, return it.
  812.  
  813.   my ($result, $smtp_comment, $header_comment) = $guess_query->result();
  814.   if (defined $result and $result eq "pass") {
  815.     my $ip = $query->ip;
  816.     $header_comment = $query->sanitize("seems reasonable for $query->{sender} to mail through $ip");
  817.     return ($result, $smtp_comment, $header_comment) if wantarray;
  818.     return $result;
  819.   }
  820.  
  821.   return $query->sanitize("neutral");
  822. }
  823.  
  824. sub trusted_forwarder {
  825.   my $query = shift;
  826.   my $guess_mechs = shift || $TRUSTED_FORWARDER;
  827.   return $query->best_guess($guess_mechs);
  828. }
  829.  
  830. # ----------------------------------------------------------
  831.  
  832. =item C<< $query->sanitize('string') >>
  833.  
  834. This applies the sanitization rules for the particular query
  835. object. These rules are controlled by the C<sanitize> parameter
  836. to the Mail::SPF::Query new method.
  837.  
  838. =cut
  839.  
  840. sub sanitize {
  841.   my $query = shift;
  842.   my $txt = shift;
  843.  
  844.   if (ref($query->{sanitize})) {
  845.       $txt = $query->{sanitize}->($txt);
  846.   }
  847.  
  848.   return $txt;
  849. }
  850.  
  851. # ----------------------------------------------------------
  852.  
  853. =item C<< strict_sanitize('string') >>
  854.  
  855. This ensures that all the characters in the returned string are printable.
  856. All whitespace is converted into spaces, and all other non-printable
  857. characters are converted into question marks. This is probably
  858. over aggressive for many applications.
  859.  
  860. This function is used by default when the C<sanitize> option is passed to
  861. the new method of Mail::SPF::Query.
  862.  
  863. Note that this function is not a class method.
  864.  
  865. =cut
  866.  
  867. sub strict_sanitize {
  868.   my $txt = shift;
  869.  
  870.   $txt =~ s/\s/ /g;
  871.   $txt =~ s/[^[:print:]]/?/g;
  872.  
  873.   return $txt;
  874. }
  875.  
  876. # ----------------------------------------------------------
  877.  
  878. =item C<< $query->debuglog() >>
  879.  
  880. Subclasses may override this with their own debug logger.
  881. I recommend Log::Dispatch.
  882.  
  883. Alternatively, pass the C<new()> constructor a
  884. C<debuglog => sub { ... }> callback, and we'll pass
  885. debugging lines to that.
  886.  
  887. =cut
  888.  
  889. sub debuglog {
  890.   my $self = shift;
  891.   return if ref $self and not $self->{debug};
  892.   
  893.   my $toprint = join (" ", @_);
  894.   chomp $toprint;
  895.   $toprint = sprintf ("%-8s %s %s %s",
  896.               ("|" x ($self->{depth}+1)),
  897.               $self->{localpart},
  898.               $self->{domain},
  899.               $toprint);
  900.  
  901.   if (exists $self->{debuglog} and ref $self->{debuglog} eq "CODE") { eval { $self->{debuglog}->($toprint) } ; }
  902.   else { printf STDERR "%s", "$toprint\n"; }
  903. }
  904.  
  905. # ----------------------------------------------------------
  906. #                spfquery
  907. # ----------------------------------------------------------
  908.  
  909. sub spfquery {
  910.   #
  911.   # usage: my ($result, $explanation, $text, $time) = $query->spfquery( [ GUESS_MECHS ] )
  912.   #
  913.   #  performs a full SPF resolution using the data in $query.  to use different data, clone the object.
  914.   #
  915.   #  if GUESS_MECHS is present, we are operating in "guess" mode so we will not actually query the domain for TXT; we will use the guess_mechs instead.
  916.   #
  917.   my $query = shift;
  918.   my $guess_mechs = shift;
  919.  
  920.   if ($query->{ipv4} and
  921.       $query->{ipv4}=~ /^127\./) { return "pass", "localhost is always allowed." }
  922.  
  923.   $query->top->{lookup_count}++;
  924.  
  925.   if ($query->is_looping)            { return "unknown", $query->{spf_error_explanation}, $query->is_looping }
  926.   if ($query->can_use_cached_result) { return $query->cached_result; }
  927.   else                               { $query->tell_cache_that_lookup_is_underway; }
  928.  
  929.   my $directive_set = DirectiveSet->new($query->{domain}, $query, $guess_mechs, $query->{local}, $query->{default_record});
  930.  
  931.   if (not defined $directive_set) {
  932.     $query->debuglog("no SPF record found for $query->{domain}");
  933.     $query->delete_cache_point;
  934.     if ($query->{domain} ne $query->{orig_domain}) {
  935.         if ($query->{error}) {
  936.             return "error", $query->{spf_error_explanation}, $query->{error};
  937.         }
  938.         return "unknown", $query->{spf_error_explanation}, "Missing SPF record at $query->{domain}";
  939.     }
  940.     if ($query->{last_dns_error} eq 'NXDOMAIN') {
  941.         my $explanation = $query->macro_substitute($query->{default_explanation});
  942.         return "unknown", $explanation, "domain of sender $query->{sender} does not exist";
  943.     }
  944.     return "none", "SPF", "domain of sender $query->{sender} does not designate mailers";
  945.   }
  946.  
  947.   if ($directive_set->{hard_syntax_error}) {
  948.     $query->debuglog("  syntax error while parsing $directive_set->{txt}");
  949.     $query->delete_cache_point;
  950.     return "unknown", $query->{spf_error_explanation}, $directive_set->{hard_syntax_error};
  951.   }
  952.  
  953.   $query->{directive_set} = $directive_set;
  954.  
  955.   foreach my $mechanism ($directive_set->mechanisms) {
  956.     my ($result, $comment) = $query->evaluate_mechanism($mechanism);
  957.  
  958.     if ($query->{error}) {
  959.       $query->debuglog("  returning temporary error: $query->{error}");
  960.       $query->delete_cache_point;
  961.       return "error", $query->{spf_error_explanation}, $query->{error};
  962.     }
  963.  
  964.     if (defined $result) {
  965.       $query->debuglog("  saving result $result to cache point and returning.");
  966.       my $explanation = $query->interpolate_explanation(
  967.             ($result =~ /^unknown/)
  968.             ? $query->{spf_error_explanation} : $query->{default_explanation});
  969.       $query->save_result_to_cache($result,
  970.                    $explanation,
  971.                    $comment,
  972.                    $query->{directive_set}->{orig_txt});
  973.       $query->{matched_mechanism} = $mechanism;
  974.       return $result, $explanation, $comment, $query->{directive_set}->{orig_txt};
  975.     }
  976.   }
  977.  
  978.   # run the redirect modifier
  979.   if ($query->{directive_set}->redirect) {
  980.     my $new_domain = $query->macro_substitute($query->{directive_set}->redirect);
  981.  
  982.     $query->debuglog("  executing redirect=$new_domain");
  983.  
  984.     my $inner_query = $query->clone(domain => $new_domain,
  985.                     depth  => $query->{depth} + 1,
  986.                     reason => "redirects to $new_domain",
  987.                    );
  988.  
  989.     my @inner_result = $inner_query->spfquery();
  990.  
  991.     $query->delete_cache_point;
  992.  
  993.     $query->debuglog("  executed redirect=$new_domain, got result @inner_result");
  994.  
  995.     $query->{spf_source} = $inner_query->{spf_source};
  996.     $query->{spf_source_type} = $inner_query->{spf_source_type};
  997.     $query->{matched_mechanism} = $inner_query->{matched_mechanism};
  998.  
  999.     return @inner_result;
  1000.   }
  1001.  
  1002.   $query->debuglog("  no mechanisms matched; deleting cache point and using neutral");
  1003.   $query->delete_cache_point;
  1004.   return "neutral", $query->interpolate_explanation($query->{default_explanation}), $directive_set->{soft_syntax_error};
  1005. }
  1006.  
  1007. # ----------------------------------------------------------
  1008. #           we cache into $Domains_Queried.
  1009. # ----------------------------------------------------------
  1010.  
  1011. sub cache_point {
  1012.   my $query = shift;
  1013.   return my $cache_point = join "/", ($query->{best_guess}  || 0,
  1014.                       $query->{guess_mechs} || "",
  1015.                       $query->{ipv4},
  1016.                       $query->{localpart},
  1017.                       $query->{domain},
  1018.                       $query->{default_record},
  1019.                       $query->{local});
  1020. }
  1021.  
  1022. sub is_looping {
  1023.   my $query = shift;
  1024.   my $cache_point = $query->cache_point;
  1025.   return (join " ", "loop encountered:", @{$query->{loop_report}})
  1026.     if (exists $Domains_Queried->{$cache_point}
  1027.     and
  1028.     not defined $Domains_Queried->{$cache_point}->[0]);
  1029.  
  1030.   return (join " ", "exceeded maximum recursion depth:", @{$query->{loop_report}})
  1031.     if ($query->{depth} >= $query->max_lookup_count);
  1032.  
  1033.   return ("query caused more than " . $query->max_lookup_count . " lookups") if ($query->max_lookup_count 
  1034.                                          and
  1035.                                          $query->top->{lookup_count} > $query->max_lookup_count);
  1036.  
  1037.   return 0;
  1038. }
  1039.  
  1040. sub max_lookup_count {
  1041.   my $query = shift;
  1042.   return $query->{max_lookup_count} || $MAX_LOOKUP_COUNT;
  1043. }
  1044.  
  1045. sub can_use_cached_result {
  1046.   my $query = shift;
  1047.   my $cache_point = $query->cache_point;
  1048.  
  1049.   if ($Domains_Queried->{$cache_point}) {
  1050.     $query->debuglog("  lookup: we have already processed $query->{domain} before with $query->{ipv4}.");
  1051.     my @cached = @{ $Domains_Queried->{$cache_point} };
  1052.     if (not defined $CACHE_TIMEOUT
  1053.     or time - $cached[-1] > $CACHE_TIMEOUT) {
  1054.       $query->debuglog("  lookup: but its cache entry is stale; deleting it.");
  1055.       delete $Domains_Queried->{$cache_point};
  1056.       return 0;
  1057.     }
  1058.  
  1059.     $query->debuglog("  lookup: the cache entry is fresh; returning it.");
  1060.     return 1;
  1061.   }
  1062.   return 0;
  1063. }
  1064.  
  1065. sub tell_cache_that_lookup_is_underway {
  1066.   my $query = shift;
  1067.  
  1068.   # define an entry here so we don't loop endlessly in an Include loop.
  1069.   $Domains_Queried->{$query->cache_point} = [undef, undef, undef, undef, time];
  1070. }
  1071.  
  1072. sub save_result_to_cache {
  1073.   my $query = shift;
  1074.   my ($result, $explanation, $comment, $orig_txt) = (shift, shift, shift, shift);
  1075.  
  1076.   # define an entry here so we don't loop endlessly in an Include loop.
  1077.   $Domains_Queried->{$query->cache_point} = [$result, $explanation, $comment, $orig_txt, time];
  1078. }
  1079.  
  1080. sub cached_result {
  1081.   my $query = shift;
  1082.   my $cache_point = $query->cache_point;
  1083.  
  1084.   if ($Domains_Queried->{$cache_point}) {
  1085.     return @{ $Domains_Queried->{$cache_point} };
  1086.   }
  1087.   return;
  1088. }
  1089.  
  1090. sub delete_cache_point {
  1091.   my $query = shift;
  1092.   delete $Domains_Queried->{$query->cache_point};
  1093. }
  1094.  
  1095. sub clear_cache {
  1096.   $Domains_Queried = {};
  1097. }
  1098.  
  1099. sub get_ptr_domain {
  1100.     my ($query) = shift;
  1101.  
  1102.     return $query->{ptr_domain} if ($query->{ptr_domain});
  1103.     
  1104.     foreach my $ptrdname ($query->myquery(reverse_in_addr($query->{ipv4}) . ".in-addr.arpa", "PTR", "ptrdname")) {
  1105.         $query->debuglog("  get_ptr_domain: $query->{ipv4} is $ptrdname");
  1106.     
  1107.         $query->debuglog("  get_ptr_domain: checking hostname $ptrdname for legitimacy.");
  1108.     
  1109.         # check for legitimacy --- PTR -> hostname A -> PTR
  1110.         foreach my $ptr_to_a ($query->myquery($ptrdname, "A", "address")) {
  1111.           
  1112.             $query->debuglog("  get_ptr_domain: hostname $ptrdname -> $ptr_to_a");
  1113.       
  1114.             if ($ptr_to_a eq $query->{ipv4}) {
  1115.                 return $query->{ptr_domain} = $ptrdname;
  1116.             }
  1117.         }
  1118.     }
  1119.  
  1120.     return undef;
  1121. }
  1122.  
  1123. sub macro_substitute_item {
  1124.     my $query = shift;
  1125.     my $arg = shift;
  1126.  
  1127.     if ($arg eq "%") { return "%" }
  1128.     if ($arg eq "_") { return " " }
  1129.     if ($arg eq "-") { return "%20" }
  1130.  
  1131.     $arg =~ s/^{(.*)}$/$1/;
  1132.  
  1133.     my ($field, $num, $reverse, $delim) = $arg =~ /^(x?\w)(\d*)(r?)(.*)$/;
  1134.  
  1135.     $delim = '.' if not length $delim;
  1136.  
  1137.     my $newval = $arg;
  1138.     my $timestamp = time;
  1139.  
  1140.     $newval = $query->{localpart}       if (lc $field eq 'u');
  1141.     $newval = $query->{localpart}       if (lc $field eq 'l');
  1142.     $newval = $query->{domain}          if (lc $field eq 'd');
  1143.     $newval = $query->{sender}          if (lc $field eq 's');
  1144.     $newval = $query->{orig_domain}     if (lc $field eq 'o');
  1145.     $newval = $query->ip                if (lc $field eq 'i');
  1146.     $newval = $timestamp                if (lc $field eq 't');
  1147.     $newval = $query->{helo}            if (lc $field eq 'h');
  1148.     $newval = $query->get_ptr_domain    if (lc $field eq 'p');
  1149.     $newval = $query->{myhostname}      if (lc $field eq 'xr');  # only used in explanation
  1150.     $newval = $query->{ipv4} ? 'in-addr' : 'ip6'
  1151.                                         if (lc $field eq 'v');
  1152.  
  1153.     # We need to escape a bunch of characters inside a character class
  1154.     $delim =~ s/([\^\-\]\:\\])/\\$1/g;
  1155.  
  1156.     if (length $delim) {
  1157.         my @parts = split /[$delim]/, $newval;
  1158.  
  1159.         @parts = reverse @parts if ($reverse);
  1160.  
  1161.         if ($num) {
  1162.             while (@parts > $num) { shift @parts }
  1163.         }
  1164.  
  1165.         $newval = join ".", @parts;
  1166.     }
  1167.  
  1168.     $newval = uri_escape($newval)       if ($field ne lc $field);
  1169.  
  1170.     $query->debuglog("  macro_substitute_item: $arg: field=$field, num=$num, reverse=$reverse, delim=$delim, newval=$newval");
  1171.  
  1172.     return $newval;
  1173. }
  1174.  
  1175. sub macro_substitute {
  1176.     my $query = shift;
  1177.     my $arg = shift;
  1178.     my $maxlen = shift;
  1179.  
  1180.     my $original = $arg;
  1181.  
  1182. #      macro-char   = ( '%{' alpha *digit [ 'r' ] *delim '}' )
  1183. #                     / '%%'
  1184. #                     / '%_'
  1185. #                     / '%-'
  1186.  
  1187.     $arg =~ s/%([%_-]|{(\w[^}]*)})/$query->macro_substitute_item($1)/ge;
  1188.  
  1189.     if ($maxlen && length $arg > $maxlen) {
  1190.       $arg = substr($arg, -$maxlen);  # super.long.string -> er.long.string
  1191.       $arg =~ s/[^.]*\.//;            #    er.long.string ->    long.string
  1192.     }
  1193.     $query->debuglog("  macro_substitute: $original -> $arg") if ($original ne $arg);
  1194.     return $arg;
  1195. }
  1196.  
  1197. # ----------------------------------------------------------
  1198. #              display_mechanism
  1199. # 
  1200. # in human-readable form; used in header_pairs above.
  1201. # ----------------------------------------------------------
  1202.  
  1203. sub display_mechanism {
  1204.   my ($modifier, $mechanism, $argument, $source) = @{shift()};
  1205.  
  1206.   return "$modifier$mechanism" . (length($argument) ? ":$argument" : "");
  1207. }
  1208.  
  1209. # ----------------------------------------------------------
  1210. #             evaluate_mechanism
  1211. # ----------------------------------------------------------
  1212.  
  1213. sub evaluate_mechanism {
  1214.   my $query = shift;
  1215.   my ($modifier, $mechanism, $argument, $source) = @{shift()};
  1216.  
  1217.   $modifier = "+" if not length $modifier;
  1218.  
  1219.   $query->debuglog("  evaluate_mechanism: $modifier$mechanism($argument) for domain=$query->{domain}");
  1220.  
  1221.   if ({ map { $_=>1 } @KNOWN_MECHANISMS }->{$mechanism}) {
  1222.     my $mech_sub = "mech_$mechanism";
  1223.     my ($hit, $text) = $query->$mech_sub($query->macro_substitute($argument, 255));
  1224.     no warnings 'uninitialized';
  1225.     $query->debuglog("  evaluate_mechanism: $modifier$mechanism($argument) returned $hit $text");
  1226.  
  1227.     return if not $hit;
  1228.  
  1229.     return ($hit, $text) if ($hit ne "hit");
  1230.     
  1231.     if ($source) {
  1232.       $query->{spf_source} = $source;
  1233.       $query->{spf_source_type} = "from mechanism $mechanism";
  1234.     }
  1235.  
  1236.     return $query->shorthand2value($modifier), $text;
  1237.   }
  1238.   else {
  1239.     my $unrecognized_mechanism = join ("",
  1240.                        ($modifier eq "+" ? "" : $modifier),
  1241.                        $mechanism,
  1242.                        ($argument ? ":" : ""),
  1243.                        $argument);
  1244.     my $error_string = "unknown $unrecognized_mechanism";
  1245.     $query->debuglog("  evaluate_mechanism: unrecognized mechanism $unrecognized_mechanism, returning $error_string");
  1246.     return $error_string => "unrecognized mechanism $unrecognized_mechanism";
  1247.   }
  1248.  
  1249.   return ("neutral", "evaluate-mechanism: neutral");
  1250. }
  1251.  
  1252. # ----------------------------------------------------------
  1253. #          myquery wraps DNS resolver queries
  1254. #
  1255. # ----------------------------------------------------------
  1256.  
  1257. sub myquery {
  1258.   my $query = shift;
  1259.   my $label = shift;
  1260.   my $qtype = shift;
  1261.   my $method = shift;
  1262.   my $sortby = shift;
  1263.  
  1264.   $query->debuglog("  myquery: doing $qtype query on $label");
  1265.  
  1266.   for ($label) {
  1267.     if (/\.\./ or /^\./) {
  1268.       # convert .foo..com to foo.com, etc.
  1269.       $query->debuglog("  myquery: fixing up invalid syntax in $label");
  1270.       s/\.\.+/\./g;
  1271.       s/^\.//;
  1272.       $query->debuglog("  myquery: corrected label is $label");
  1273.     }
  1274.   }
  1275.   my $resquery = $query->resolver->query($label, $qtype);
  1276.  
  1277.   my $errorstring = $query->resolver->errorstring;
  1278.   if (not $resquery and $errorstring eq "NOERROR") {
  1279.     return;
  1280.   }
  1281.  
  1282.   $query->{last_dns_error} = $errorstring;
  1283.  
  1284.   if (not $resquery) {
  1285.     if ($errorstring eq "NXDOMAIN") {
  1286.       $query->debuglog("  myquery: $label $qtype failed: NXDOMAIN.");
  1287.       return;
  1288.     }
  1289.  
  1290.     $query->debuglog("  myquery: $label $qtype lookup error: $errorstring");
  1291.     $query->debuglog("  myquery: will set error condition.");
  1292.     $query->set_temperror("DNS error while looking up $label $qtype: $errorstring");
  1293.     return;
  1294.   }
  1295.  
  1296.   my @answers = grep { lc $_->type eq lc $qtype } $resquery->answer;
  1297.  
  1298.   # $query->debuglog("  myquery: found $qtype response: @answers");
  1299.  
  1300.   my @toreturn;
  1301.   if ($sortby) { @toreturn = map { rr_method($_,$method) } sort { $a->$sortby() <=> $b->$sortby() } @answers; }
  1302.   else         { @toreturn = map { rr_method($_,$method) }                                          @answers; }
  1303.  
  1304.   if (not @toreturn) {
  1305.     $query->debuglog("  myquery: result had no data.");
  1306.     return;
  1307.   }
  1308.  
  1309.   return @toreturn;
  1310. }
  1311.  
  1312. sub rr_method {
  1313.   my ($answer, $method) = @_;
  1314.   if ($method ne "char_str_list") { return $answer->$method() }
  1315.  
  1316.   # long TXT records can't be had with txtdata; they need to be pulled out with char_str_list which returns a list of strings
  1317.   # that need to be joined.
  1318.  
  1319.   my @char_str_list = $answer->$method();
  1320.   # print "rr_method returning join of @char_str_list\n";
  1321.  
  1322.   return join "", @char_str_list;
  1323. }
  1324.  
  1325. #
  1326. # Mechanisms return one of the following:
  1327. #
  1328. # hit
  1329. #       mechanism matched
  1330. # undef
  1331. #       mechanism did not match
  1332. #
  1333. # unknown
  1334. #       some error happened during processing
  1335. # error
  1336. #       some temporary error
  1337. #
  1338. # ----------------------------------------------------------
  1339. #                 all
  1340. # ----------------------------------------------------------
  1341.  
  1342. sub mech_all {
  1343.   my $query = shift;
  1344.   return "hit" => "default";
  1345. }
  1346.  
  1347. # ----------------------------------------------------------
  1348. #              include
  1349. # ----------------------------------------------------------
  1350.  
  1351. sub mech_include {
  1352.   my $query = shift;
  1353.   my $argument = shift;
  1354.  
  1355.   if (not $argument) {
  1356.     $query->debuglog("  mechanism include: no argument given.");
  1357.     return "unknown", "include mechanism not given an argument";
  1358.   }
  1359.  
  1360.   $query->debuglog("  mechanism include: recursing into $argument");
  1361.  
  1362.   my $inner_query = $query->clone(domain => $argument,
  1363.                   depth  => $query->{depth} + 1,
  1364.                   reason => "includes $argument",
  1365.                                   local => undef,
  1366.                                   trusted => undef,
  1367.                                   guess => undef,
  1368.                                   default_record => undef,
  1369.                  );
  1370.  
  1371.   my ($result, $explanation, $text, $orig_txt, $time) = $inner_query->spfquery();
  1372.  
  1373.   $query->debuglog("  mechanism include: got back result $result / $text / $time");
  1374.  
  1375.   if ($result eq "pass")            { return hit     => $text, $time; }
  1376.   if ($result eq "error")           { return $result => $text, $time; }
  1377.   if ($result eq "unknown")         { return $result => $text, $time; }
  1378.   if ($result eq "none")            { return unknown => $text, $time; } # fail-safe mode.  convert an included NONE into an UNKNOWN error.
  1379.   if ($result eq "fail" ||
  1380.       $result eq "neutral" ||
  1381.       $result eq "softfail")        { return undef,     $text, $time; }
  1382.   
  1383.   $query->debuglog("  mechanism include: reducing result $result to unknown");
  1384.   return "unknown", $text, $time;
  1385. }
  1386.  
  1387. # ----------------------------------------------------------
  1388. #                  a
  1389. # ----------------------------------------------------------
  1390.  
  1391. sub mech_a {
  1392.   my $query = shift;
  1393.   my $argument = shift;
  1394.   
  1395.   my $ip4_cidr_length = ($argument =~ s/  \/(\d+)//x) ? $1 : 32;
  1396.   my $ip6_cidr_length = ($argument =~ s/\/\/(\d+)//x) ? $1 : 128;
  1397.  
  1398.   my $domain_to_use = $argument || $query->{domain};
  1399.  
  1400.   # see code below in ip4
  1401.   foreach my $a ($query->myquery($domain_to_use, "A", "address")) {
  1402.     $query->debuglog("  mechanism a: $a");
  1403.     if ($a eq $query->{ipv4}) {
  1404.       $query->debuglog("  mechanism a: match found: $domain_to_use A $a == $query->{ipv4}");
  1405.       return "hit", "$domain_to_use A $query->{ipv4}";
  1406.     }
  1407.     elsif ($ip4_cidr_length < 32) {
  1408.       my $cidr = Net::CIDR::Lite->new("$a/$ip4_cidr_length");
  1409.  
  1410.       $query->debuglog("  mechanism a: looking for $query->{ipv4} in $a/$ip4_cidr_length");
  1411.       
  1412.       return (hit => "$domain_to_use A $a /$ip4_cidr_length contains $query->{ipv4}")
  1413.     if $cidr->find($query->{ipv4});
  1414.     }
  1415.   }
  1416.   return;
  1417. }
  1418.  
  1419. # ----------------------------------------------------------
  1420. #                  mx
  1421. # ----------------------------------------------------------
  1422.  
  1423. sub mech_mx {
  1424.   my $query = shift;
  1425.   my $argument = shift;
  1426.  
  1427.   my $ip4_cidr_length = ($argument =~ s/  \/(\d+)//x) ? $1 : 32;
  1428.   my $ip6_cidr_length = ($argument =~ s/\/\/(\d+)//x) ? $1 : 128;
  1429.  
  1430.   my $domain_to_use = $argument || $query->{domain};
  1431.  
  1432.   my @mxes = $query->myquery($domain_to_use, "MX", "exchange", "preference");
  1433.  
  1434.   # if a domain has no MX record, we MUST NOT use its IP address instead.
  1435.   # if (! @mxes) {
  1436.   #   $query->debuglog("  mechanism mx: no MX found for $domain_to_use.  Will pretend it is its own MX, and test its IP address.");
  1437.   #   @mxes = ($domain_to_use);
  1438.   # }
  1439.  
  1440.   foreach my $mx (@mxes) {
  1441.     # $query->debuglog("  mechanism mx: $mx");
  1442.  
  1443.     foreach my $a ($query->myquery($mx, "A", "address")) {
  1444.       if ($a eq $query->{ipv4}) {
  1445.     $query->debuglog("  mechanism mx: we have a match; $domain_to_use MX $mx A $a == $query->{ipv4}");
  1446.     return "hit", "$domain_to_use MX $mx A $a";
  1447.       }
  1448.       elsif ($ip4_cidr_length < 32) {
  1449.     my $cidr = Net::CIDR::Lite->new("$a/$ip4_cidr_length");
  1450.  
  1451.     $query->debuglog("  mechanism mx: looking for $query->{ipv4} in $a/$ip4_cidr_length");
  1452.  
  1453.     return (hit => "$domain_to_use MX $mx A $a /$ip4_cidr_length contains $query->{ipv4}")
  1454.       if $cidr->find($query->{ipv4});
  1455.  
  1456.       }
  1457.     }
  1458.   }
  1459.   return;
  1460. }
  1461.  
  1462. # ----------------------------------------------------------
  1463. #                 ptr
  1464. # ----------------------------------------------------------
  1465.  
  1466. sub mech_ptr {
  1467.   my $query = shift;
  1468.   my $argument = shift;
  1469.  
  1470.   if ($query->{ipv6}) { return "neutral", "ipv6 not yet supported"; }
  1471.  
  1472.   my $domain_to_use = $argument || $query->{domain};
  1473.  
  1474.   foreach my $ptrdname ($query->myquery(reverse_in_addr($query->{ipv4}) . ".in-addr.arpa", "PTR", "ptrdname")) {
  1475.     $query->debuglog("  mechanism ptr: $query->{ipv4} is $ptrdname");
  1476.     
  1477.     $query->debuglog("  mechanism ptr: checking hostname $ptrdname for legitimacy.");
  1478.     
  1479.     # check for legitimacy --- PTR -> hostname A -> PTR
  1480.     foreach my $ptr_to_a ($query->myquery($ptrdname, "A", "address")) {
  1481.       
  1482.       $query->debuglog("  mechanism ptr: hostname $ptrdname -> $ptr_to_a");
  1483.       
  1484.       if ($ptr_to_a eq $query->{ipv4}) {
  1485.     $query->debuglog("  mechanism ptr: we have a valid PTR: $query->{ipv4} PTR $ptrdname A $ptr_to_a");
  1486.     $query->debuglog("  mechanism ptr: now we see if $ptrdname ends in $domain_to_use.");
  1487.     
  1488.     if ($ptrdname =~ /(^|\.)\Q$domain_to_use\E$/i) {
  1489.       $query->debuglog("  mechanism ptr: $query->{ipv4} PTR $ptrdname does end in $domain_to_use.");
  1490.       return hit => "$query->{ipv4} PTR $ptrdname matches $domain_to_use";
  1491.     }
  1492.     else {
  1493.       $query->debuglog("  mechanism ptr: $ptrdname does not end in $domain_to_use.  no match.");
  1494.     }
  1495.       }
  1496.     }
  1497.   }
  1498.   return;
  1499. }
  1500.  
  1501. # ----------------------------------------------------------
  1502. #                  exists
  1503. # ----------------------------------------------------------
  1504.  
  1505. sub mech_exists {
  1506.   my $query = shift;
  1507.   my $argument = shift;
  1508.  
  1509.   return if (!$argument);
  1510.  
  1511.   my $domain_to_use = $argument;
  1512.  
  1513.   $query->debuglog("  mechanism exists: looking up $domain_to_use");
  1514.   
  1515.   foreach ($query->myquery($domain_to_use, "A", "address")) {
  1516.     $query->debuglog("  mechanism exists: $_");
  1517.     $query->debuglog("  mechanism exists: we have a match.");
  1518.     my @txt = map { s/^"//; s/"$//; $_ } $query->myquery($domain_to_use, "TXT", "char_str_list");
  1519.     if (@txt) {
  1520.         return hit => join(" ", @txt);
  1521.     }
  1522.     return hit => "$domain_to_use found";
  1523.   }
  1524.   return;
  1525. }
  1526.  
  1527. # ----------------------------------------------------------
  1528. #                 ip4
  1529. # ----------------------------------------------------------
  1530.  
  1531. sub mech_ip4 {
  1532.   my $query = shift;
  1533.   my $cidr_spec = shift;
  1534.  
  1535.   return if not length $cidr_spec;
  1536.  
  1537.   my ($network, $cidr_length) = split (/\//, $cidr_spec, 2);
  1538.  
  1539.   my $dot_count = $network =~ tr/././;
  1540.   
  1541.   # turn "1.2.3/24" into "1.2.3.0/24"
  1542.   for (1 .. (3 - $dot_count)) { $network .= ".0"; }
  1543.  
  1544.   # TODO: add library compatibility test for ill-formed ip4 syntax
  1545.   if ($network !~ /^\d+\.\d+\.\d+\.\d+$/) { return ("unknown" => "bad argument to ip4: $cidr_spec"); }
  1546.   
  1547.   $cidr_length = "32" if not defined $cidr_length;
  1548.  
  1549.   my $cidr = eval { Net::CIDR::Lite->new("$network/$cidr_length") }; # TODO: make this work for ipv6 as well
  1550.   if ($@) { return ("unknown" => "unable to parse ip4:$cidr_spec"); }
  1551.  
  1552.   $query->debuglog("  mechanism ip4: looking for $query->{ipv4} in $cidr_spec");
  1553.  
  1554.   return (hit => "$cidr_spec contains $query->{ipv4}") if $cidr->find($query->{ipv4});
  1555.  
  1556.   return;
  1557. }
  1558.  
  1559. # ----------------------------------------------------------
  1560. #                 ip6
  1561. # ----------------------------------------------------------
  1562.  
  1563. sub mech_ip6 {
  1564.   my $query = shift;
  1565.  
  1566.   return;
  1567. }
  1568.  
  1569. # ----------------------------------------------------------
  1570. #              functions
  1571. # ----------------------------------------------------------
  1572.  
  1573. sub ip { # accessor
  1574.   my $query = shift;
  1575.   return $query->{ipv4} || $query->{ipv6};
  1576. }
  1577.  
  1578. sub reverse_in_addr {
  1579.   return join (".", (reverse split /\./, shift));
  1580. }
  1581.  
  1582. sub resolver {
  1583.   my $query = shift;
  1584.   return $query->{res} ||= Net::DNS::Resolver->new(
  1585.                            tcp_timeout => $DNS_RESOLVER_TIMEOUT,
  1586.                            udp_timeout => $DNS_RESOLVER_TIMEOUT,
  1587.                           );
  1588. }
  1589.  
  1590. sub fallbacks {
  1591.   my $query = shift;
  1592.   return @{$query->{fallbacks}};
  1593. }
  1594.  
  1595. sub shorthand2value {
  1596.   my $query = shift;
  1597.   my $shorthand = shift;
  1598.   return { "-" => "fail",
  1599.        "+" => "pass",
  1600.        "~" => "softfail",
  1601.        "?" => "neutral" } -> {$shorthand} || $shorthand;
  1602. }
  1603.  
  1604. sub value2shorthand {
  1605.   my $query = shift;
  1606.   my $value = lc shift;
  1607.   return { "fail"     => "-",
  1608.        "pass"     => "+",
  1609.        "softfail" => "~",
  1610.        "deny"     => "-",
  1611.        "allow"    => "+",
  1612.        "softdeny" => "~",
  1613.        "unknown"  => "?",
  1614.        "neutral"  => "?" } -> {$value} || $value;
  1615. }
  1616.  
  1617. sub interpolate_explanation {
  1618.   my $query = shift;
  1619.   my $txt = shift;
  1620.  
  1621.   if ($query->{directive_set}->explanation) {
  1622.     my @txt = map { s/^"//; s/"$//; $_ } $query->myquery($query->macro_substitute($query->{directive_set}->explanation), "TXT", "char_str_list");
  1623.     $txt = join " ", @txt;
  1624.   }
  1625.  
  1626.   return $query->macro_substitute($txt);
  1627. }
  1628.  
  1629. sub find_ancestor {
  1630.   my $query = shift;
  1631.   my $which_hash = shift;
  1632.   my $current_domain = shift;
  1633.  
  1634.   return if not exists $query->{$which_hash};
  1635.  
  1636.   $current_domain =~ s/\.$//g;
  1637.   my @current_domain = split /\./, $current_domain;
  1638.  
  1639.   foreach my $ancestor_level (0 .. @current_domain) {
  1640.     my @ancestor = @current_domain;
  1641.     for (1 .. $ancestor_level) { shift @ancestor }
  1642.     my $ancestor = join ".", @ancestor;
  1643.  
  1644.     for my $match ($ancestor_level > 0 ? "*.$ancestor" : $ancestor) {
  1645.       $query->debuglog("  DirectiveSet $which_hash: is $match in the $which_hash hash?");
  1646.       if (my $found = $query->{$which_hash}->{lc $match}) {
  1647.     $query->debuglog("  DirectiveSet $which_hash: yes, it is.");
  1648.     return wantarray ? ($which_hash, $match, $found) : $found;
  1649.       }
  1650.     }
  1651.   }
  1652.   return;
  1653. }
  1654.  
  1655. sub found_record_for {
  1656.   my $query = shift;
  1657.   my ($which_hash, $matched_domain_glob, $found) = $query->find_ancestor(@_);
  1658.   return if not $found;
  1659.   my $txt = $found->{record};
  1660.   $query->{spf_source} = "explicit $which_hash found: $matched_domain_glob defines $txt";
  1661.   $query->{spf_source_type} = "full-explanation";
  1662.   $txt = "v=spf1 $txt" if $txt !~ /^v=spf1\b/i;
  1663.   return $txt;
  1664. }
  1665.  
  1666. sub try_override {
  1667.   my $query = shift;
  1668.   return $query->found_record_for("override", @_);
  1669. }
  1670.  
  1671. sub try_fallback {
  1672.   my $query = shift;
  1673.   return $query->found_record_for("fallback", @_);
  1674. }
  1675.  
  1676. sub callerid_wanted_for {
  1677.   my $query = shift;
  1678.   my ($which_hash, $matched_domain_glob, $found) = $query->find_ancestor("callerid" => @_);
  1679.  
  1680.   if (not $found) {
  1681.     $query->debuglog("  callerid_wanted_for(@_) did not return a match in the callerid config hash.");
  1682.     return;
  1683.   }
  1684.   my $check = $found->{check};
  1685.   $query->debuglog("  callerid_wanted_for: callerid config defines check=$check for $matched_domain_glob");
  1686.   return $check;
  1687. }
  1688.  
  1689. # ----------------------------------------------------------
  1690. #               algo
  1691. # ----------------------------------------------------------
  1692.  
  1693. {
  1694.   package DirectiveSet;
  1695.  
  1696.   sub new {
  1697.     my $class = shift;
  1698.     my $current_domain = shift;
  1699.     my $query = shift;
  1700.     my $override_text = shift;
  1701.     my $localpolicy = shift;
  1702.     my $default_record = shift;
  1703.  
  1704.     my $txt;
  1705.  
  1706.     # overrides can come from two places:
  1707.     #  1 - when operating in best_guess mode, spfquery may be called with a ($guess_mechs) argument, which comes in as $override_text.
  1708.     #  2 - when operating with ->new(..., override => { ... }) we need to load the override dynamically.
  1709.  
  1710.     if (not $override_text
  1711.     and
  1712.     exists $query->{override}
  1713.        ) {
  1714.       $txt = $query->try_override($current_domain);
  1715.     }
  1716.  
  1717.     if ($override_text) {
  1718.       $txt = "v=spf1 $override_text ?all";
  1719.       $query->{spf_source} = "local policy";
  1720.       $query->{spf_source_type} = "full-explanation";
  1721.     }
  1722.     else {
  1723.       my @txt;
  1724.  
  1725.       if ($current_domain !~ /^_ep\./) {
  1726.     $query->debuglog("  DirectiveSet->new(): doing TXT query on $current_domain");
  1727.     @txt = $query->myquery($current_domain, "TXT", "char_str_list");
  1728.     $query->debuglog("  DirectiveSet->new(): TXT query on $current_domain returned error=$query->{error}, last_dns_error=$query->{last_dns_error}");
  1729.  
  1730.     if ($query->{error} || $query->{last_dns_error} eq 'NXDOMAIN' || ! @txt) {
  1731.       # try the fallbacks.
  1732.       $query->debuglog("  DirectiveSet->new(): will try fallbacks.");
  1733.       if (exists $query->{fallback}
  1734.           and
  1735.           my $found_txt = $query->try_fallback($current_domain, "fallback")) {
  1736.         @txt = $found_txt;
  1737.       }
  1738.       else {
  1739.         $query->debuglog("  DirectiveSet->new(): fallback search failed.");
  1740.       }
  1741.     }
  1742.       }
  1743.  
  1744.       if (not @txt
  1745.       and
  1746.       $query->callerid_wanted_for($current_domain)
  1747.      ) {
  1748.  
  1749.     eval { require LMAP::CID2SPF; };
  1750.     if ($@) { 
  1751.       $query->debuglog("  DirectiveSet->new(): LMAP::CID2SPF not available, will not do Caller-ID lookup.");
  1752.     }
  1753.     else {
  1754.       my @errors_before_ep = ($query->{error}, $query->{last_dns_error});
  1755.       my $ep_version = "_ep.$current_domain"; $ep_version =~ s/^_ep\._ep/_ep/i;
  1756.       $query->debuglog("  DirectiveSet->new(): doing TXT query on $ep_version");
  1757.       my @eptxt = $query->myquery($ep_version, "TXT", "char_str_list");
  1758.       $query->debuglog("  DirectiveSet->new(): TXT query on $current_domain returned error=$query->{error}, last_dns_error=$query->{last_dns_error}");
  1759.  
  1760.       if (@eptxt) {
  1761.         my $xml = join "", @eptxt;
  1762.         
  1763.         # "<ep xmlns='http://ms.net/1'>...</ep>"
  1764.         if ($xml =~ m(^<ep xmlns='http://ms.net/1')) {
  1765.           my $c2s = LMAP::CID2SPF->new();
  1766.           $c2s->cid($xml);
  1767.           my $spf = $c2s->convert();
  1768.           $query->debuglog("  CID2SPF:  in: $xml");
  1769.           $query->debuglog("  CID2SPF: out: $spf");
  1770.           $query->{spf_source} = "Microsoft Caller-ID for Email record at $ep_version";
  1771.           $query->{spf_source_type} = "full-explanation";
  1772.           @txt = $spf;
  1773.         }
  1774.       }
  1775.       else {
  1776.         $query->debuglog("  restoring error from @errors_before_ep; had become previously $query->{error}");
  1777.         ($query->{error}, $query->{last_dns_error}) = @errors_before_ep;
  1778.       }
  1779.     }
  1780.       }
  1781.  
  1782.       # squish multiline responses into one first.
  1783.       foreach (@txt) {
  1784.     s/^"(.*)"$/$1/;
  1785.     s/^\s+//;
  1786.     s/\s+$//;
  1787.     
  1788.     if (/^v=spf1(\s.*|)$/i) {
  1789.       $txt .= $1;
  1790.     }
  1791.       }
  1792.  
  1793.       if (!defined $txt && $default_record) {
  1794.           $txt = "v=spf1 $default_record ?all";
  1795.           $query->{spf_source} = "local policy";
  1796.       $query->{spf_source_type} = "full-explanation";
  1797.       }
  1798.     }
  1799.  
  1800.     $query->debuglog("  DirectiveSet->new(): SPF policy: $txt");
  1801.  
  1802.     return if not defined $txt;
  1803.  
  1804.     # TODO: the prepending of the v=spf1 is a massive hack; get it right by saving the actual raw orig_txt.
  1805.     my $directive_set = bless { orig_txt => ($txt =~ /^v=spf1/ ? $txt : "v=spf1$txt"), txt => $txt } , $class;
  1806.  
  1807.     TXT_RESPONSE:
  1808.     for ($txt) {
  1809.       $query->debuglog("  lookup:   TXT $_");
  1810.  
  1811.       # parse the policy record
  1812.       
  1813.       while (/\S/) {
  1814.     s/^\s*(\S+)\s*//;
  1815.     my $word = $1;
  1816.     # $query->debuglog("  lookup:  word parsing word $word");
  1817.     if ($word =~ /^v=(\S+)/i) {
  1818.       my $version = $1;
  1819.       $query->debuglog("  lookup:   TXT version=$version");
  1820.       $directive_set->{version} = $version;
  1821.       next TXT_RESPONSE if ($version ne "spf1");
  1822.       next;
  1823.     }
  1824.  
  1825.     # modifiers always have an = sign.
  1826.     if (my ($lhs, $rhs) = $word =~ /^([^:\/]+)=(\S*)$/) {
  1827.       # $query->debuglog("  lookup:   TXT modifier found: $lhs = $rhs");
  1828.  
  1829.       # if we ever come to support multiple of the same modifier, we need to make this a list.
  1830.       $directive_set->{modifiers}->{lc $lhs} = $rhs;
  1831.       next;
  1832.     }
  1833.  
  1834.     # RHS optional, defaults to domain.
  1835.     # [:/] matches a:foo and a/24
  1836.     if (my ($prefix, $lhs, $rhs) = $word =~ /^([-~+?]?)([\w_-]+)([\/:]\S*)?$/i) {
  1837.       $rhs =~ s/^://;
  1838.       $prefix ||= "+";
  1839.       $query->debuglog("  lookup:   TXT prefix=$prefix, lhs=$lhs, rhs=$rhs");
  1840.       push @{$directive_set->{mechanisms}}, [$prefix => lc $lhs => $rhs];
  1841.       next;
  1842.     }
  1843.  
  1844.       }
  1845.     }
  1846.  
  1847.     if (my $rhs = delete $directive_set->{modifiers}->{default}) {
  1848.       push @{$directive_set->{mechanisms}}, [ $query->value2shorthand($rhs), all => undef ];
  1849.     }
  1850.  
  1851.     $directive_set->{mechanisms} = []           if not $directive_set->{mechanisms};
  1852.     if ($localpolicy) {
  1853.         my $mechanisms = $directive_set->{mechanisms};
  1854.         my $lastmech = $mechanisms->[$#$mechanisms];
  1855.         if (($lastmech->[0] eq '-' || $lastmech->[0] eq '?') &&
  1856.              $lastmech->[1] eq 'all') {
  1857.             my $index;
  1858.  
  1859.             for ($index = $#$mechanisms - 1; $index >= 0; $index--) {
  1860.                 last if ($lastmech->[0] ne $mechanisms->[$index]->[0]);
  1861.             }
  1862.             if ($index >= 0) {
  1863.                 # We want to insert the localpolicy just *after* $index
  1864.                 $query->debuglog("  inserting local policy mechanisms into @{[$directive_set->show_mechanisms]} after position $index");
  1865.                 my $localset = DirectiveSet->new($current_domain, $query->clone, $localpolicy);
  1866.  
  1867.                 if ($localset) {
  1868.                     my @locallist = $localset->mechanisms;
  1869.                     # Get rid of the ?all at the end of the list
  1870.                     pop @locallist;
  1871.             # $_->[3] goes into $query->{spf_source}.
  1872.                     map { $_->[3] = ($_->[1] eq 'include'
  1873.                      ? "local policy includes SPF record at " . $query->macro_substitute($_->[2])
  1874.                      : "local policy") }
  1875.               @locallist;
  1876.                     splice(@$mechanisms, $index + 1, 0, @locallist);
  1877.                 }
  1878.             }
  1879.         }
  1880.     }
  1881.     $query->debuglog("  lookup:  mec mechanisms=@{[$directive_set->show_mechanisms]}");
  1882.     return $directive_set;
  1883.   }
  1884.  
  1885.   sub version      {   shift->{version}      }
  1886.   sub mechanisms   { @{shift->{mechanisms}}  }
  1887.   sub explanation  {   shift->{modifiers}->{exp}      }
  1888.   sub redirect     {   shift->{modifiers}->{redirect} }
  1889.   sub get_modifier {   shift->{modifiers}->{shift()}  }
  1890.   sub syntax_error {   shift->{syntax_error} }
  1891.  
  1892.   sub show_mechanisms   {
  1893.     my $directive_set = shift;
  1894.     my @toreturn = map { $_->[0] . $_->[1] . "(" . ($_->[2]||"") . ")" } $directive_set->mechanisms;
  1895.     # print STDERR ("showing mechanisms @toreturn: " . Dumper($directive_set)); use Data::Dumper;
  1896.     return @toreturn;
  1897.   }
  1898. }
  1899.  
  1900. 1;
  1901.  
  1902. =item EXPORT
  1903.  
  1904. None by default.
  1905.  
  1906. =back
  1907.  
  1908. =head1 WARNINGS
  1909.  
  1910. Mail::Query::SPF should only be used at the point where messages are received from the Internet.
  1911. The underlying assumption is that the sender of the email is sending the message directly to you
  1912. or one of your secondaries. If your MTA does not have an exhaustive list of secondaries, then
  1913. the C<result2()> and C<message_result2()> methods should be used. These methods take care to
  1914. permit mail from secondaries.
  1915.  
  1916. =head1 AUTHORS
  1917.  
  1918. Meng Weng Wong, <mengwong+spf@pobox.com>
  1919.  
  1920. Philip Gladstone
  1921.  
  1922. =head1 ACKNOWLEDGEMENTS
  1923.  
  1924. Joe Christy joe@eshu.net 2004-04-20 for the $DNS_RESOLVER_TIMEOUT patch.
  1925.  
  1926.  
  1927. =head1 SEE ALSO
  1928.  
  1929. http://spf.pobox.com/
  1930.  
  1931. =cut
  1932.  
  1933.