File: //proc/self/root/usr/bin/spfquery.perl-Mail-SPF
#!/usr/bin/perl 
# 
# spfquery: Command-line tool for performing SPF queries
#
# (C) 2005-2012 Julian Mehnle <julian@mehnle.net>
#     2004      Wayne Schlitt <wayne@schlitt.net>
# $Id: spfquery 138 2006-01-22 18:00:34Z julian $
#
##############################################################################
=head1 NAME
spfquery - (Mail::SPF) - Checks if a given set of e-mail parameters matches a
domain's SPF policy
=head1 VERSION
2.501
=head1 SYNOPSIS
=over
=item B<Preferred usage:>
B<spfquery> [B<--versions>|B<-v> B<1>|B<2>|B<1,2>] [B<--scope>|B<-s> B<helo>|B<mfrom>|B<pra>]
B<--identity>|B<--id> I<identity> B<--ip-address>|B<--ip> I<ip-address>
[B<--helo-identity>|B<--helo-id> I<helo-identity>] [I<OPTIONS>]
B<spfquery> [B<--versions>|B<-v> B<1>|B<2>|B<1,2>] [B<--scope>|B<-s> B<helo>|B<mfrom>|B<pra>]
B<--file>|B<-f> I<filename>|B<-> [I<OPTIONS>]
=item B<Legacy usage:>
B<spfquery> B<--helo> I<helo-identity> B<--ip-address>|B<--ip> I<ip-address> [I<OPTIONS>]
B<spfquery> B<--mfrom> I<mfrom-identity> B<--ip-address>|B<--ip> I<ip-address>
[B<--helo> I<helo-identity>] [I<OPTIONS>]
B<spfquery> B<--pra> I<pra-identity> B<--ip-address>|B<--ip> I<ip-address> [I<OPTIONS>]
=item B<Other usage:>
B<spfquery> B<--version>|B<-V>
B<spfquery> B<--help>
=back
=head1 DESCRIPTION
B<spfquery> checks if a given set of e-mail parameters (e.g., the SMTP sender's
IP address) matches the responsible domain's Sender Policy Framework (SPF)
policy.  For more information on SPF see L<http://www.openspf.org>.
=head2 Preferred Usage
The following usage forms are preferred over the L<legacy forms|/Legacy usage>
used by older B<spfquery> versions:
The B<--identity> form checks if the given I<ip-address> is an authorized SMTP
sender for the given C<helo> hostname, C<mfrom> envelope sender e-mail address,
or C<pra> (so-called purported resonsible address) e-mail address, depending
on the value of the B<--scope> option (which defaults to B<mfrom> if omitted).
The B<--file> form reads "I<ip-address> I<identity> [I<helo-identity>]" tuples
from the file with the specified I<filename>, or from standard input if
I<filename> is B<->, and checks them against the specified scope (B<mfrom> by
default).
Both forms support an optional B<--versions> option, which specifies a
comma-separated list of the SPF version numbers of SPF records that may be
used.  B<1> means that C<v=spf1> records should be used.  B<2> means that
C<spf2.0> records should be used.  Defaults to B<1,2>, i.e., uses any SPF
records that are available.  Records of a higher version are preferred.
=head2 Legacy Usage
B<spfquery> versions before 2.500 featured the following usage forms, which are
discouraged but still supported for L<backwards compatibility|/COMPATIBILITY>:
The B<--helo> form checks if the given I<ip-address> is an authorized SMTP
sender for the C<HELO> hostname given as the I<identity> (so-called C<HELO>
check).
The B<--mfrom> form checks if the given I<ip-address> is an authorized SMTP
sender for the envelope sender email-address (or domain) given as the
I<identity> (so-called C<MAIL FROM> check).  If a domain is given instead of an
e-mail address, C<postmaster> will be substituted for the localpart.
The B<--pra> form checks if the given I<ip-address> is an authorized SMTP
sender for the PRA (Purported Responsible Address) e-mail address given as the
identity.
=head2 Other Usage
The B<--version> form prints version information of spfquery.  The B<--help>
form prints usage information for spfquery.
=head1 OPTIONS
=head2 Standard Options
The preferred and legacy forms optionally take any of the following
I<OPTIONS>:
=over
=item B<--default-explanation> I<string>
=item B<--def-exp> I<string>
Use the specified I<string> as the default explanation if the authority domain
does not specify an explanation string of its own.
=item B<--hostname> I<hostname>
Use I<hostname> as the host name of the local system instead of auto-detecting
it.
=item B<--keep-comments>
=item B<--no-keep-comments>
Do (not) print any comments found when reading from a file or from standard
input.
=item B<--sanitize> (currently ignored)
=item B<--no-sanitize> (currently ignored)
Do (not) sanitize the output by condensing consecutive white-space into a
single space and replacing non-printable characters with question marks.
Enabled by default.
=item B<--debug> (currently ignored)
Print out debug information.
=back
=head2 Black Magic Options
Several options that were supported by earlier versions of B<spfquery> are
considered black magic (i.e. potentially dangerous for the innocent user) and
are thus disabled by default.  If the L<B<Mail::SPF::BlackMagic>> Perl module
is installed, they may be enabled by specifying B<--enable-black-magic>.
=over
=item B<--max-dns-interactive-terms> I<n>
Evaluate a maximum of I<n> DNS-interactive mechanisms and modifiers per SPF
check.  Defaults to B<10>.  Do I<not> override the default unless you know what
you are doing!
=item B<--max-name-lookups-per-term> I<n>
Perform a maximum of I<n> DNS name look-ups per mechanism or modifier.
Defaults to B<10>.  Do I<not> override the default unless you know what you are
doing!
=item B<--authorize-mxes-for> I<email-address>|I<domain>B<,>...
Consider all the MXes of the comma-separated list of I<email-address>es and
I<domain>s as inherently authorized.
=item B<--tfwl>
Perform C<trusted-forwarder.org> accreditation checking.
=item B<--guess> I<spf-terms>
Use I<spf-terms> as a default record if no SPF record is found.
=item B<--local> I<spf-terms>
Process I<spf-terms> as local policy before resorting to a default result
(the implicit or explicit C<all> mechanism at the end of the domain's SPF
record).  For example, this could be used for white-listing one's secondary
MXes: C<mx:mydomain.example.org>.
=item B<--override> I<domain>B<=>I<spf-record>
=item B<--fallback> I<domain>B<=>I<spf-record>
Set overrides and fallbacks.  Each option can be specified multiple times.  For
example:
    --override example.org='v=spf1 -all'
    --override '*.example.net'='v=spf1 a mx -all'
    --fallback example.com='v=spf1 -all'
=back
=head1 RESULT CODES
=over 12
=item B<pass>
The specified IP address is an authorized SMTP sender for the identity.
=item B<fail>
The specified IP address is not an authorized SMTP sender for the identity.
=item B<softfail>
The specified IP address is not an authorized SMTP sender for the identity,
however the authority domain is still testing out its SPF policy.
=item B<neutral>
The identity's authority domain makes no assertion about the status of the IP
address.
=item B<permerror>
A permanent error occurred while evaluating the authority domain's policy
(e.g., a syntax error in the SPF record).  Manual intervention is required
from the authority domain.
=item B<temperror>
A temporary error occurred while evaluating the authority domain's policy
(e.g., a DNS error).  Try again later.
=item B<none>
There is no applicable SPF policy for the identity domain.
=back
=head1 EXIT CODES
  Result    | Exit code
 -----------+-----------
  pass      |     0
  fail      |     1
  softfail  |     2
  neutral   |     3
  permerror |     4
  temperror |     5
  none      |     6
=head1 EXAMPLES
    spfquery --scope mfrom --id user@example.com --ip 1.2.3.4
    spfquery --file test_data
    echo "127.0.0.1 user@example.com helohost.example.com" | spfquery -f -
=head1 COMPATIBILITY
B<spfquery> has undergone the following interface changes compared to earlier
versions:
=over
=item B<2.500>
=over
=item *
A new preferred usage style for performing individual SPF checks has been
introduced.  The new style accepts a unified B<--identity> option and an
optional B<--scope> option that specifies the type (scope) of the identity.  In
contrast, the legacy usage style requires a separate usage form for every
supported scope.  See L</Preferred usage> and L</Legacy usage> for details.
=item *
The former C<unknown> and C<error> result codes have been renamed to C<permerror>
and C<temperror>, respectively, in order to comply with RFC 4408 terminology.
=item *
SPF checks with an empty identity are no longer supported.  In the case of an
empty C<MAIL FROM> SMTP transaction parameter, perform a check with the C<helo>
scope directly.
=item *
The B<--debug> and B<--(no-)sanitize> options are currently ignored by this
version of B<spfquery>.  They will again be supported in the future.
=item *
Several features that were supported by earlier versions of B<spfquery> are
considered black magic and thus are now disabled by default.  See L</Black
Magic Options>.
=item *
Several option names have been deprecated.  This is a list of them and their
preferred synonyms:
  Deprecated options  | Preferred options
 ---------------------+-----------------------------
  --sender, -s        | --mfrom
  --ipv4, -i          | --ip-address, --ip
  --name              | --hostname
  --max-lookup-count, | --max-dns-interactive-terms
    --max-lookup      |
  --rcpt-to, -r       | --authorize-mxes-for
  --trusted           | --tfwl
=back
=back
=head1 SEE ALSO
L<Mail::SPF>, L<spfd(8)>
L<http://tools.ietf.org/html/rfc4408>
=head1 AUTHORS
This version of B<spfquery> is a complete rewrite by Julian Mehnle
<julian@mehnle.net>, based on an earlier version written by Meng Weng Wong
<mengwong+spf@pobox.com> and Wayne Schlitt <wayne@schlitt.net>.
=cut
our $VERSION = '2.501';
use warnings;
use strict;
use IO::File;
use Getopt::Long qw(:config gnu_compat no_ignore_case);
use Error ':try';
use Mail::SPF;
use constant TRUE   => (0 == 0);
use constant FALSE  => not TRUE;
use constant exit_codes_by_result_code => {
    pass        => 0,
    fail        => 1,
    softfail    => 2,
    neutral     => 3,
    permerror   => 4,
    temperror   => 5,
    none        => 6
};
# Helper Functions
##############################################################################
sub usage {
    STDERR->printf(<<'EOT');
Preferred Usage:
    spfquery [--versions|-v 1|2|1,2] [--scope|-s helo|mfrom|pra]
        --identity|--id <identity> --ip-address|--ip <ip-address>
        [--helo-identity|--helo-id <helo-identity>] [OPTIONS]
    spfquery [--versions|-v 1|2|1,2] [--scope|-s helo|mfrom|pra]
        --file|-f <filename>|- [OPTIONS]
Legacy Usage:
    spfquery --helo <helo-identity> --ip-address|--ip <ip-address> [OPTIONS]
    spfquery --mfrom <mfrom-identity> --ip-address|--ip <ip-address>
        [--helo <helo-identity>] [OPTIONS]
    spfquery --pra <pra-identity> --ip-address|--ip <ip-address> [OPTIONS]
Other Usage:
    spfquery --version|-V
See `spfquery --help` for more information.
EOT
    return;
}
sub help {
    print(<<'EOT');
Preferred Usage:
    spfquery [--versions|-v 1|2|1,2] [--scope|-s helo|mfrom|pra]
        --identity|--id <identity> --ip-address|--ip <ip-address>
        [--helo-identity|--helo-id <helo-identity>] [OPTIONS]
    spfquery [--versions|-v 1|2|1,2] [--scope|-s helo|mfrom|pra]
        --file|-f <filename>|- [OPTIONS]
Legacy Usage:
    spfquery --helo <helo-identity> --ip-address|--ip <ip-address> [OPTIONS]
    spfquery --mfrom <mfrom-identity> --ip-address|--ip <ip-address>
        [--helo <helo-identity>] [OPTIONS]
    spfquery --pra <pra-identity> --ip-address|--ip <ip-address> [OPTIONS]
Other Usage:
    spfquery --version|-V
spfquery performs SPF checks based on the command-line arguments or data given
in a file or on standard input.
Only the preferred and other usage forms are explained here.  See the
spfquery(1) man-page for an explanation of the legacy usage forms.
The "--identity" form checks if the given <ip-address> is an authorized SMTP
sender for the given "helo" hostname, "mfrom" envelope sender e-mail address,
or "pra" (purported resonsible address) e-mail address, depending on the value
of the "--scope" option (which defaults to "mfrom" if omitted).
The "--file" form reads "<ip-address> <identity> [<helo-identity>]" tuples from
the file with the specified <filename>, or from standard input if <filename> is
"-", and checks them against the specified scope ("mfrom" by default).
The "--version" form prints version information of spfquery.
Valid OPTIONS (and their defaults) are:
    --default-explanation <string>
                        Default explanation string to use (sensible default).
    --hostname <hostname>
                        The name of the system doing the SPF checking (local
                        system's configured hostname).
    --keep-comments     Print comments found when reading from a file.
    --no-sanitize       Do not clean up invalid characters in output.
    --debug             Output debugging information.
Black-magic OPTIONS are:
    --max-dns-interactive-terms <n>
                        Maximum number of DNS-interactive mechanisms and
                        modifiers (10).
    --max-name-lookups-per-term <n>
                        Maximum number of DNS name look-ups per mechanism or
                        modifier (10).
    --authorize-mxes-for <email-address>|<domain>,...
                        A comma-separated list of e-mail addresses and domains
                        whose MXes will be considered inherently authorized.
    --tfwl              Check trusted-forwarder.org white-list.
    --guess <spf-terms> Default checks if no SPF record is found.
    --local <spf-terms> Local policy to process before default result.
    --override <domain>=<spf-record>
    --fallback <domain>=<spf-record>
                        Set override and fallback SPF records for domains.
Examples:
    spfquery --scope mfrom --id user@example.com --ip 1.2.3.4
    spfquery --file test_data
    echo "127.0.0.1 user@example.com helohost.example.com" | spfquery -f -
EOT
    return;
}
sub deprecated_option {
    my ($old_option, $new_option, $options) = @_;
    return FALSE if not exists($options->{$old_option});
    STDERR->print(
        "Warning: '$old_option' option is deprecated" .
        ($new_option ? "; use '$new_option' instead" : '') .
        ".\n"
    );
    $options->{$new_option} = delete($options->{$old_option});
    return TRUE;
}
sub unsupported_option {
    my ($option_name, $options) = @_;
    return FALSE if not exists($options->{$option_name});
    STDERR->print("Error: '$option_name' option is no longer supported.\n");
    return TRUE;
}
sub black_magic_option {
    my ($option_name, $options) = @_;
    return FALSE if not exists($options->{$option_name});
    STDERR->print("Error: '$option_name' option is black magic! Do not use it!\n");
    return TRUE;
}
# Command-line Option Handling
##############################################################################
my $options = {};
my $getopt_result = GetOptions(
    $options,
    'file|f=s',
    'versions|v=s',
    'scope=s',
    's=s',  # Special handling for ambiguous 's' option (formerly a synonym
            # for 'sender', now preferredly a synonym for 'scope').
    'identity|id=s',
    'ip-address|ip=s',
    'helo-identity|helo-id=s',
    # Legacy/shortcut options:
    'mfrom|mail-from|m=s',
    'helo|h=s',
    'default-explanation|def-exp=s',
    'hostname=s',
    'keep-comments!',
    'debug!',       # TODO Implement!
    'sanitize!',    # TODO Implement!
    # Black Magic options:
    'enable-black-magic!',
    'max-dns-interactive-terms=i',
    'max-name-lookups-per-term=i',
    'authorize-mxes-for=s',
                    # TODO implement!
    'tfwl!',        # TODO Implement!
    'guess=s',      # TODO Implement!
    'local=s',      # TODO Implement!
    'override=s%',  # TODO Implement!
    'fallback=s%',  # TODO Implement!
    # Meta actions:
    'version|V!',
    'help!',
    # Deprecated options:
    'sender=s',     # Now 'scope'/'identity' or 'mfrom'
    'ipv4=s',       # Now 'ip-address'
    'i=s',          # Now 'ip-address'
    'name=s',       # Now 'hostname'
    'max-lookup-count=i',
    'max-lookup=i', # Now 'max-dns-interactive-terms'
    'rcpt-to=s',    # Now 'authorize-mxes-for'
    'r=s',          # Now 'authorize-mxes-for'
    'trusted!'      # Now 'tfwl'
);
if (not $getopt_result) {
    usage();
    exit(255);
}
if ($options->{help}) {
    help();
    exit(0);
}
if ($options->{version}) {
    print("spfquery version $VERSION (using Mail::SPF)\n");
    exit(0);
}
deprecated_option('sender',           'mfrom',                     $options);
deprecated_option('ipv4',             'ip-address',                $options);
deprecated_option('i',                'ip-address',                $options);
deprecated_option('name',             'hostname',                  $options);
deprecated_option('max-lookup-count', 'max-dns-interactive-terms', $options);
deprecated_option('max-lookup',       'max-dns-interactive-terms', $options);
deprecated_option('rcpt-to',          'authorize-mxes-for',        $options);
deprecated_option('r',                'authorize-mxes-for',        $options);
deprecated_option('trusted',          'tfwl',                      $options);
if ($options->{'enable-black-magic'}) {
    if (not defined(eval('require Mail::SPF::BlackMagic'))) {
        STDERR->print("Error: Cannot enable black magic. Unable to load Mail::SPF::BlackMagic.\n");
        exit(255);
    }
    # else: Black magic enabled!
}
elsif (
    black_magic_option('max-dns-interactive-terms', $options) or
    black_magic_option('max-name-lookups-per-term', $options) or
    black_magic_option('rcpt-to',                   $options) or
    black_magic_option('trusted',                   $options) or
    black_magic_option('guess',                     $options) or
    black_magic_option('local',                     $options) or
    black_magic_option('override',                  $options) or
    black_magic_option('fallback',                  $options)
) {
    exit(255);
}
my @versions            = split(',', $options->{versions} || '');
my $scope               = $options->{scope};
my $identity            = $options->{identity};
my $ip_address          = $options->{'ip-address'};
my $helo_identity       = $options->{'helo-identity'};
# Heuristic for distinguishing between 's(cope)' and 's(ender)':
if (defined(my $s = $options->{s})) {
    if (
        not defined($scope) and  # No explicit 'scope' option has been specified, and
        $s !~ /[@.]/             # 's' option contains neither an '@' nor a dot,
                                 # so it cannot be an e-mail address or a domain.
    ) {
        # Thus it must be meant as the 'scope' option:
        $scope = $s;
    }
    else {
        # Else, it must be meant as the deprecated 'sender' option:
        $options->{mfrom} = $s;
    }
}
# Heuristic for when explicit 'scope'/'s(cope)' option is absent:
if (not defined($scope)) {
    if (defined($identity) or defined($options->{file})) {
        # Identity has been specified, or input will be read from file:
        # apply the 'scope' option default:
        $scope    = 'mfrom';
    }
    elsif (defined($options->{helo})) {
        $scope    = 'helo';
        $identity = $options->{helo};
    }
    elsif (defined($options->{mfrom})) {
        $scope    = 'mfrom';
        $identity = $options->{mfrom};
        $helo_identity ||= $options->{helo};
    }
    elsif (defined($options->{pra})) {
        $scope    = 'pra';
        $identity = $options->{pra};
    }
}
my $default_explanation = $options->{'default-explanation'};
my $hostname            = $options->{hostname};
if (
    not defined($scope) or
    not (defined($identity) xor defined($options->{file}))
) {
    usage();
    exit(255);
}
if (defined($identity) and $identity eq '') {
    STDERR->print("Error: Empty identities are not supported. See spfquery(1).\n");
    exit(255);
}
# Process the SPF Request(s)
##############################################################################
try {
    my $spf_server = Mail::SPF::Server->new(
        default_authority_explanation
                        => $default_explanation,
        hostname        => $hostname,
    #    debug           => $options->{debug},
    #    sanitize        => $options->{sanitize},
        # Black Magic:
        (
            exists($options->{'max-dns-interactive-terms'}) ?
                (max_dns_interactive_terms  => $options->{'max-dns-interactive-terms'} || undef)
            :   ()
        ),
        (
            exists($options->{'max-name-lookups-per-term'}) ?
                (max_name_lookups_per_term  => $options->{'max-name-lookups-per-term'} || undef)
            :   ()
        )
    #    rcpt_to         => $options->{'rcpt-to'},
    #    trusted         => $options->{trusted},
    #    guess           => $options->{guess},
    #    local           => $options->{local},
    #    override        => $options->{override},
    #    fallback        => $options->{fallback},
    );
    my $exit_code;
    if (not defined($options->{file})) {
        # Single request:
        my $result_code = do_process(
            $spf_server,
            versions        => @versions ? [@versions] : undef,
            scope           => $scope,
            identity        => $identity,
            ip_address      => $ip_address,
            helo_identity   => $helo_identity
        );
        $exit_code = exit_codes_by_result_code->{$result_code};
    }
    else {
        # File request:
        my $file = $options->{file} eq '-' ? \*STDIN : IO::File->new($options->{file})
            or die("Could not open: $options->{file}\n");
        while (<$file>) {
            chomp;
            s/^\s*//;
            next if /^$/;
            if (/^#/) {
                print("$_\n") if $options->{'keep-comments'};
                next;
            }
            ($ip_address, $identity, $helo_identity) = split;
            my $result_code = do_process(
                $spf_server,
                versions        => @versions ? [@versions] : undef,
                scope           => $scope,
                identity        => $identity,
                ip_address      => $ip_address,
                helo_identity   => $helo_identity
            );
            $exit_code ||= exit_codes_by_result_code->{$result_code};
        }
    }
    exit($exit_code);
}
catch Mail::SPF::Exception with {
    my ($e) = @_;
    STDERR->printf("Error: %s.\n", $e->text);
    exit(255);
};
# Helper Function
##############################################################################
sub do_process {
    my ($spf_server, %request_options) = @_;
    my $request = Mail::SPF::Request->new(%request_options);
    my $result  = $spf_server->process($request);
    printf(
        "%s\n%s\n%s\n%s\n",
        $result->code,
        (
            $result->can('authority_explanation') ?
                $result->authority_explanation
            :   $result->local_explanation
        ),
        $result->local_explanation,
        $result->received_spf_header
    );
    return $result->code;
}