#! /usr/local/bin/perl -w

use strict;
use vars '$VERSION'; $VERSION = '1.00';

use Net::DNS;
use Net::Domain::TLD;
use Socket 'inet_ntoa';

# the script takes a long time to run: set to 1 if you
# want to see what is happening.
use constant VERBOSE => 0;

# look for 4 bogus hostnames (pray they don't really exist)
my @bogus = (
    join( '' => map { ('a'..'z', 0..9)[rand 36] } 1..24 ),
    join( '' => map { ('a'..'z', 0..9)[rand 36] } 1..24 ),
    join( '' => map { ('a'..'z', 0..9)[rand 36] } 1..24 ),
    join( '' => map { ('a'..'z', 0..9)[rand 36] } 1..24 ),
);

my $resolv = Net::DNS::Resolver->new;

for my $tld ( sort Net::Domain::TLD->new->All ) {
    warn ".$tld\n" if VERBOSE;
    my %ip;
    for my $dom ( @bogus) {
        my $host = "$dom.$tld";
        if( my $addr = gethostbyname( $host )) {
            # got an IP address on a hostname
            $ip{inet_ntoa($addr)}++;
        }
    }

    # skip the rest if all we received were NXDOMAINs.
    next unless keys %ip;

    # see the nature of their sins
    my $domain = "$bogus[0].$tld";
    if( my $rr = $resolv->query( $domain, 'MX' )) {
        for my $mx( $rr->answer ) {
            next unless $mx->type eq 'MX';
            my @addr = get_a( $resolv, $mx->exchange );
            @addr or @addr = get_a( $resolv, $domain );
            print ".$tld $_\n" for @addr;
        }
    }
    else {
        # no MX records for the host, try A records.
        print ".$tld $_\n" for get_a($resolv, $domain);
    }
}

sub get_a {
    my $resolv = shift;
    my $rec = shift;
    my @rr;
    if( my $rr = $resolv->query( $rec, 'A' )) {
        $_->type eq 'A' and push @rr, $_->address for $rr->answer;
    }
    @rr;
}

=head1 NAME

tldwild - list all DNS TLDs that employ wildcards

=head1 SYNOPSIS

B<tldwild>

No command line options are recognised.

=head1 DESCRIPTION

In the Domain Name System, a query for a host name that does not
map to an IP address should return an NXDOMAIN (no such domain)
error.

Sometimes, within an organisation, it is useful to declare
"wildcard" records, in order to map an arbitrary number of host
names onto a single server.

Some organisations that manage top-level domains (TLDs) also
employ such records in an attempt to guide web users who type
addresses incorrectly to a single web page where they may find
help. (This was the basis of the 2003 Verisign .com/.net
wildcard scandal). For small TLDs, this was never much of a
problem, but the times they are a-changing.

If a spammer uses a sender envelope and HELO connect strings based
on inexistent hostnames in these smaller TLDs, and if you perform
a lookup on these addresses, they will resolve correctly. The
information produced by this script allows you to make better
decisions as to whether an address is legitimate or not.

This is version 1.00.

=head1 EXAMPLES

Piping the output of this script through the following one-liner:

  perl -lane 'print "$F[1]\tREJECT .$F[0] MX wildcard"'

...will produce a Postfix access map suitable for a
C<check_sender_mx_access> restriction.

Recipes for other MTAs are welcome.

=head1 SEE ALSO

This script uses code that is documented in L<Net::DNS>
and L<Net::Domain::TLD>.

RFC 974 - Mail routing and the domain system

RFC 1035 - Domain names - implementation and specification

=head1 BUGS

The script does not deal with MX records that return numeric
IP addresses (but this is a violation of the RFC standard
anyway, and no TLD appears to do so at present).

=head1 AUTHOR

David Landgren, eval {join chr(0x40) => qw{david landgren.net}}

=head1 COPYRIGHT

Copyright (c) 2005 David Landgren.

This script is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
[download]