dns-browse 1.9-8 / usr / bin / dns_tree

#!/usr/bin/perl -w

#
# dns_tree
# Copyright (C) 1997 by John Heidemann
# $Id: dns_tree,v 1.22 2002/05/13 16:33:34 johnh Exp $
# 
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
#


sub usage {
    print STDERR <<END;
usage: $0 domain

display a tree-structured view of the dns domain 'domain'

Options:
    -f	    override warnings (force)
    -t TYPE show only records of these TYPE (repeat for multiple types)
		(the ``all'' type does everything I know about)
    -m MATCH show only records whos first component matches the
		perl regexp MATCH
    -v       verbose (show all DNS requests)
    -d	     debug output (show internal information of the program)

(Only -f is currently implemented)

Data is cached in ~/.DNS_BROWSE with an approximation of the usual DNS
caching rules.  Remove all files in that directory to prematurely
flush the cache.

Some information is returned in ``fake records'':
    z	head of a zone
    iz	branch point internal to a zone
    i	information
    e	errors

Bugs and desired features:
Currently requires that you start it at the root of a zone.
END
    exit 1;
}

use strict;

use Carp;
use Getopt::Long;
my(%opts);
my($SORT, $A, $TTL, $TYPE, $B) = (0..20);
my($SOA_HOST, $SOA_E_MAIL, $SOA_SERIAL, $SOA_REFRESH, $SOA_RETRY, $SOA_EXPIRE, $SOA_MINIMUM) = ($B..20);
my(@default_types) = qw(NS A SOA);
my(@maximal_types) = qw(A CNAME HINFO LOC MX NS PTR TXT SOA);
# Temp creation race found by the Debian folks.
# http://bugs.debian.org/146591
# Fix: make the tmp file in the users home directory.
# Note: the following check is made just in case, we do not
# want to leave files in the / directory if the environment is messed up
die "Environment not properly set up for use in dns_tree" if ! defined($ENV{'HOME'});
my($cache_dir) = $ENV{'HOME'} . "/.DNS_TREE";
my(@dangereous_names) = qw(com. edu. org. in-addr.arpa. co.uk.); # all lc
my(@messages) = ();

sub parse_time_spec {
    my($spec) = @_;
    $spec = lc($spec);
    my($secs) = 0;
    while ($spec ne '') {
	# seconds, minutes, hours, days, weeks
        $secs += $1, next if ($spec =~ s/^([.0-9]+)s[a-z]*//);
        $secs += $1 * 60, next if ($spec =~ s/^([.0-9]+)m[a-z]*//);
        $secs += $1 * 60*60, next if ($spec =~ s/^([.0-9]+)h[a-z]*//);
        $secs += $1 * 60*60*24, next if ($spec =~ s/^([.0-9]+)d[a-z]*//);
        $secs += $1 * 60*60*24*7, next if ($spec =~ s/^([.0-9]+)w[a-z]*//);
	# no units, assume seconds
        $secs += $1, next if ($spec =~ s/^([.0-9]+)$//);
        die "$0: unknown time specification: $spec\n";
    };
    return $secs;
}

sub dns_make_absolute {
    my($name) = @_;
    return $name if ($name =~ /\.$/);
    return "$name.";
}

sub dns_to_sort {
    my($name) = lc($_[0]);
    my(@f) = reverse split(/\./, $name);
    return join('.', @f);
}

sub rec_to_sort {
    my($rec_ref) = @_;
    my($sort, $a, $ttl, $type, $b) = @$rec_ref;
    return dns_to_sort($a);
}

sub sort_level {
    my($res_ref) = @_;
    my($count) = $#$res_ref;

    # generate sorting keys
    foreach (0..$count) {
	$res_ref->[$_][$SORT] = rec_to_sort(\@{$res_ref->[$_]});
	# print $res_ref->[$_][$A] . " => " . $res_ref->[$_][$SORT] . "\n";
    };

    # do it
    my(@keys) = sort {
	$res_ref->[$a][$SORT] cmp $res_ref->[$b][$SORT]
    } (0..$count);

    return \@keys;
}

sub display_rec {
	my($name, $rec_aref, $stats_href, $depth) = @_;
	my($sort, $a, $ttl, $type, $b) = @$rec_aref;

	return if ($a !~ /$name$/i);  # skip stuff not in our domain

	my($suba) = $a;
	$suba =~ s/$name$//i;
	# return if ($suba eq '');   # skip records for our level
	return if ($suba eq '' && !($type eq 'TXT' || $type eq 'MX'));   # skip some records for our level
	$suba =~ s/\.$//;   # trim . between sub and old name

	# only show one NS for each subthing
	if ($type eq 'NS' || $type eq 'iz') {
	    my($lc_suba) = lc($suba);
	    return if (defined($stats_href->{subns_shown_href}{$lc_suba}));
	    $stats_href->{subns_shown_href}{$lc_suba} = 1;
	    $stats_href->{subns_shown_count}++;
	};

	# only show A/CNAMES records pointing to web servers
	if (!($type eq 'NS' || $type eq 'iz') && defined($opts{'match'})) {
	    return if ($suba !~ /$opts{'match'}/i);
	};

	# getting subdomain without NSes up to it?  fake them?
	if ($suba =~ /\./) {
	    my($car, $cdr) = ($a =~ /^([^.]+)\.(.+)$/);
	    my(@fake_rec) = (0, $cdr, 1, 'iz');
	    display_rec($name, \@fake_rec, $stats_href, $depth);
	};

	my($dots) = $suba =~ tr/././;
	my($tabs) = "\t" x ($dots + $depth);
	my($subsuba) = ($dots > 0) ? ($suba =~ /^([^.]+)\./): ($suba);

	my($rest) = "";
	$rest = $b if ($type eq 'TXT');

	print "$tabs$type\t$subsuba$rest\n";
}

sub display_level {
    my($name, $res_ref, $ns) = @_;

    my($count) = $#$res_ref;
    print "z\t$name\n";
    foreach (@messages) {
	print "\ti\t$_\n";
    };
    print "\ti\t($count records, from $ns)\n";

    my($keys_ref) = sort_level($res_ref);    

    my(%stats);
    $stats{'subnses_shown_count'} = 0;
    $stats{'subnses_shown_href'} = { };
    my($i);
    foreach $i (@$keys_ref) {
	display_rec($name, \@{$res_ref->[$i]}, \%stats, 1);
    };
    # print "\ti\t" . $stats{'subnses_shown_count'} . "\tsub-domains\n";
}

sub dig {
    my($ah_ref) = @_;
    my($cmd, $name, $server, $cache_duration, $options) = ($ah_ref->{cmd}, $ah_ref->{name}, $ah_ref->{server},  $ah_ref->{cache_duration}, $ah_ref->{options});
    my(@msgs);

    # What should we keep from the dig output?
    my($typesa_ref) = $ah_ref->{types};
    $typesa_ref = \@default_types if (!defined($typesa_ref));
    my(%types) = ();
    foreach (@$typesa_ref) {
	$types{$_} = 1;
    };

    croak "bad cmd" if (!defined($cmd));
    croak "bad name" if (!defined($name));
    if (!defined($server)) {
	$server = "";
    } else {
	$server = '@' . $server;
    };
    $cache_duration = 60 * 60 * 12 if (!defined($cache_duration));   # 12 hours

    # Normalize case (important for cache files).
    ($cmd, $name, $server) = (lc($cmd), lc($name), lc($server));

    my(@res);
    my($ok) = 0;

    # Implement caching (of the raw dig output).
    # check cache 
    my($from_cache) = 0;
    my($fn) = "$cache_dir/" . lc("$cmd:$name:$server");
    my($done) = 0;
    # check cache validity
    if (-f $fn) {
	my($age) = (-M $fn) * 24 * 60 * 60;
	if ($age > $cache_duration) {
	    # print STDERR "$fn is out of date\n";
	    unlink($fn);
	};
    };
    if (-f $fn) {
    	print STDERR "Reading dig information fron standard input\n" if defined($opts{'debug'});
	open(DIG, "< $fn") || croak "cached dig";
	$from_cache = 1;
    } else {
    	print STDERR "Calling dig $options $cmd $name $server\n" if defined($opts{'debug'});
	if ( defined ($options) ) {
		open(DIG, "dig $options $cmd $name $server |") || croak "dig";
	} else {
		open(DIG, "dig $cmd $name $server |") || croak "dig";
	}
	open(CACHE, "> $fn") || croak "dig to cache $fn";
    };

    # Parse dig output line-by-line.
    # Currently we implement a simple two-state machine
    # to handle SOA records.
    my($in_soa)  = 0;
    my($old_dig) = 1;  # default to pre-bind-8.0 dig
    my(@soa);
    my($origin) = ".";
    my($lasta) = undef;
    while (<DIG>) {
    	print STDERR "Reading dig input: $_" if defined($opts{'debug'});
	print CACHE $_ if (!$from_cache);
	if ($in_soa) {
	    my($dummy, $n) = split(/\s+/);
	    push(@soa, $n);
	    $in_soa++;
	    if ($in_soa > $SOA_MINIMUM) {
		$in_soa = 0;
		push(@res, [@soa]);
		@soa = ();
	    };
	    next;
	};
	next if (/^\s*$/);
	next if (/^\s+/);
	$done = 1 if (/^;; ADDITIONAL RECORDS/);
	if (/^;\s*\<\<\>\> DiG\s+([0-9]+)\s*.*\<\<\>\>\s*(.*)$/) {
	    $old_dig = 0 if ($1 >= 8);
	    # record signatures
	    push(@msgs, $2);
	};
	if (/^;; (Received 0 answers.*)$/) {
	    push(@msgs, $1);
	};
	next if ($done);
	next if (/^;/);
	if (/^\$ORIGIN\s+(\S+)$/) {
	    $origin = $1;
	    next;
	};
	$ok++;
	#
	# parse it.
	my($a, $ttl, $type, $b, $c, @rest);
	if ($old_dig) {
	    ($a, $ttl, $type, $b, $c, @rest) = split(/\s+/);
	} else {
	    my($in);
	    ($a, $ttl, $in, $type, $b, $c, @rest) = split(/\s+/);
	};
	#
	# handle default names and the origin
	if ($a eq '') {
	    die "$0: undef lasta.\n" if (!defined($lasta));
	    $a = $lasta;
	} else {
	    $lasta = $a;
	};
	$a .= $origin if ($a !~ /\.$/);
	#
	next if (!defined($type));
	if ($type eq 'SOA') {
	    # special case: multi-line SOAs
	    @soa = (0, $a, $ttl, $type, $b, $c);
	    $in_soa = $SOA_SERIAL;
	    next;
	};
	if ($type eq 'TXT') {   # hack
	    $c = '' if (!defined($c));
	    @rest = ("") if ($#rest == -1);
	    $b = "$b $c " . join(" ", @rest);
	    $c = undef; @rest = ();
	};
	if (defined($types{$type})) {
	    push(@res, [0, $a, $ttl, $type, $b]);
	};
    };
    close DIG;
    close CACHE if (!$from_cache);
    return (undef, \@msgs) if (!$ok);

    return (\@res, \@msgs);
}

sub push_msgs {
    my($msgs_ref) = @_;
    if (defined($msgs_ref)) {
	push(@messages, @$msgs_ref);
    };
}

sub fetch_nses {
    my($name, $cache_duration) = @_;

    my($res_ref, $msgs_ref) = dig({cmd => 'ns', name => $name, types => [qw(NS)], cache_duration => $cache_duration, options => ''});
    push_msgs($msgs_ref) if (defined($opts{'verbose'}));
    die "fetch_nses: dig ns failed\n" if (!defined($res_ref));

    my(@nses);
    foreach (@$res_ref) {
	push(@nses, $_->[$B]);
    };
    return \@nses;
}

sub fetch_level_from_ns {
    my($name, $ns, $types_aref, $cache_duration) = @_;

    my($res_ref, $msgs_ref) = dig({cmd => 'axfr', name => $name, server => $ns, types => $types_aref}, cache_duration => $cache_duration, options => '');
    push_msgs($msgs_ref);
    die "fetch_level_from_ns: dig axfr failed\n" if (!defined($res_ref));
    return $res_ref;
}

sub fetch_level_from_nses {
    my($name, $nses_ref, $types_aref, $cache_duration) = @_;

    my($ns);
    foreach $ns (@$nses_ref) {
	my($res_ref) = fetch_level_from_ns($name, $ns, $types_aref, $cache_duration);
	return ($res_ref, $ns) if defined($res_ref);
    };
    return undef;
}

sub fetch_soa {
    my($name) = @_;

    my($soa_ref, $msgs_ref) = dig({cmd => 'soa', name => $name, types => [qw(SOA)], options => '+multiline' });
    push_msgs($msgs_ref) if (defined($opts{'verbose'}));
    die "fetch_soa: dig soa failed\n" if (!defined($soa_ref));
    return $soa_ref->[0];
}

sub fetch_level {
    my($name, $types_aref) = @_;
    my($soa_ref) = fetch_soa($name);
    return undef if (!defined($soa_ref));
    my($cache_duration) = parse_time_spec($soa_ref->[$SOA_MINIMUM]);
    my($nses_ref) = fetch_nses($name, $cache_duration);
    return undef if (!defined($nses_ref));
    my(@f) = fetch_level_from_nses($name, $nses_ref, $types_aref, $cache_duration);
    return @f;
}

sub dangereous_name {
    my($name) = @_;

    return undef if (defined($opts{'force'}));

    $name = lc($name);
    foreach (@dangereous_names) {
	return 1 if ($name eq $_);
    };
    return 0;
}

sub main {
    &usage if ($#ARGV >= 0 && ( $ARGV[0] eq '-?' || $ARGV[0] eq '-h' ));
    &GetOptions(\%opts, qw(f m=s t=s@ v d));
    &usage if ($#ARGV != 0);

    $opts{'force'} = $opts{'f'};
    $opts{'match'} = $opts{'m'};
    $opts{'types'} = $opts{'t'};
    $opts{'verbose'} = $opts{'v'};
    $opts{'debug'} = $opts{'d'};
    my($types_aref) = $opts{'types'};
    if (defined($types_aref) && $#$types_aref == 0 && $types_aref->[0] eq 'all') {
	# special case "all"
	$types_aref = $opts{'types'} = \@maximal_types;
    };

    # Be careful about perms on the cache dir (thanks, Debian).
    if (! -d $cache_dir) {
	mkdir($cache_dir,0700) or die "$0: cannot mkdir $cache_dir.\n";
    };

    my($name) = $ARGV[0];
    $name = dns_make_absolute($name);

    if (dangereous_name($name)) {
	print "z\t$name\n\te\tdangerously-large-zone\n";
	return;
    };

    $types_aref = (defined($opts{'types'}) ? $opts{'types'} : [qw(NS A CNAME)]);
    push (@$types_aref, qw(i e m));
    my($res_ref, $ns) = fetch_level($name, $types_aref);
    if (defined($res_ref)) {
        display_level($name, $res_ref, $ns);
    } else {
	foreach (@messages) {
	    print "\ti\t$_\n";
        };
	print "\te\terror looking up $name\n";
	exit 1;
    };
}

main;
exit 0;