#!/usr/bin/perl -w
# prettycache, by <efge@free.fr> v1.1 2000/09/16
# Available under the GPL.
# Please consult http://www.efge.org/djbdns/index.html for details.

$showttl = 0;
$now = sprintf ("4%015x",time+10);  # current time in tai in hex

while ($#ARGV >= 0 && $ARGV[0] =~ /^-/) {
  my $switch = shift(@ARGV);
  if ($switch eq "-ttl") {
    $showttl = 1;
  } else {
    print STDERR "usage: prettycache.pl [-ttl] file\n";
    exit 1;
  }
}


if ($#ARGV >= 0) {
  foreach $file (@ARGV) {
    open (FILE, "<$file") or die "$file: $!";
    process (*FILE) or die "$file: truncated";
    close (FILE);
  }
} else {
  process (*STDIN) or die "Input truncated";
}
exit 0;


sub nextname {
  my ($q) = @_;
  my ($buf, $len, $dc);

  ($len, $q) = unpack ("Ca*", $q);
  return (".", $q) if ($len == 0);
  $buf = "";
  do {
    ($dc, $q) = unpack ("a$len"."a*", $q);
    # quote nonprinting, dot and backslash
    $dc =~ s/([\000-\040\056\134\200-\377])/sprintf("\\%03o",ord($1))/ge;
#    $dc = lc ($dc);		# lowercase
    $buf .= $dc.".";
    ($len, $q) = unpack ("Ca*", $q);
  } while ($len);
  return ($buf, $q);
}

sub names {
  my ($q) = @_;
  my $name;
  my @names = ();
  while ($q ne "") {
    ($name, $q) = nextname ($q);
    push (@names, $name);
  }
  return @names;
}

sub name {
  my ($q) = @_;
  my $name;
  ($name, $q) = nextname ($q);
  return $name;
}

sub nextip {
  my ($q) = @_;
  my $ip = join(".", unpack ("CCCC", $q));
  return ($ip, substr ($q, 4));
}

sub ips {
  my ($q) = @_;
  my $ip;
  my @ips = ();
  while ($q ne "") {
    ($ip, $q) = nextip ($q);
    push (@ips, $ip);
  }
  return @ips;
}

sub mxs {
  my ($q) = @_;
  my $pref;
  my $name;
  my @mxs = ();
  while ($q ne "") {
    ($pref, $q) = unpack ("na*", $q);
    ($name, $q) = nextname ($q);
    push (@mxs, "$pref $name");
  }
  return @mxs;
}

sub nextmisc {
  my ($q) = @_;
  my $datalen;
  my $data;
  ($datalen, $q) = unpack ("na*", $q);
  ($data, $q) = unpack ("a$datalen"."a*", $q);
  $data = unpack ("H*", $data);
  return ($data, $q);
}

sub miscs {
  my ($q) = @_;
  my $misc;
  my @miscs = ();
  while ($q ne "") {
    ($misc, $q) = nextmisc ($q);
    push (@miscs, $misc);
  }
  return @miscs;
}

# txt and srv are not special cased in dnscache
# the following code interprets them out of a "misc" record

sub nexttxt {
  my ($q) = @_;
  my $datalen;
  my $data;
  my ($len, $txt);
  ($datalen, $q) = unpack ("na*", $q);
  ($data, $q) = unpack ("a$datalen"."a*", $q);
  ($len, $data) = unpack ("Ca*", $data);
  $txt = substr ($data, 0, $len);
  # quote ctrl, dblquotes and backslash
  $txt =~ s/([\000-\037\042\134])/sprintf("\\%03o",ord($1))/ge;
  $txt = '"'.$txt.'"';
  return ($txt, $q);
}

sub txts {
  my ($q) = @_;
  my $txt;
  my @txts = ();
  while ($q ne "") {
    ($txt, $q) = nexttxt ($q);
    push (@txts, $txt);
  }
  return @txts;
}

sub nextsrv {
  my ($q) = @_;
  my $datalen;
  my $data;
  my ($prio, $weight, $port, $target);
  ($datalen, $q) = unpack ("na*", $q);
  ($data, $q) = unpack ("a$datalen"."a*", $q);
  ($prio, $weight, $port, $data) = unpack ("n3a*", $data);
  $target = name ($data);
  return ("$prio $weight $port $target", $q);
}

sub srvs {
  my ($q) = @_;
  my $srv;
  my @srvs = ();
  while ($q ne "") {
    ($srv, $q) = nextsrv ($q);
    push (@srvs, $srv);
  }
  return @srvs;
}

sub hexsub {
  my ($a, $b) = @_;
  my $r = 0;
  my $mul = 1;
  while ($a ne "" && $b ne "") {
    my $al = substr ($a, -4, 4, "");
    my $bl = substr ($b, -4, 4, "");
    my $d = hex($al) - hex($bl);
    $r += $mul * $d;
    $mul <<= 16;
  }
  return $r;
}

sub ttl {
  my ($expire) = @_;
  return 0 if ($expire lt $now);
  return hexsub ($expire, $now);
}


sub process {
  my ($fh) = @_;

  while (!eof($fh)) {
    my ($buf, $len);
    my ($keylen, $datalen);
    my ($key, $data, $expire);
    my ($type, $d, $s);
    $len = read ($fh, $buf, 16);
    return 0 unless ($len == 16);
    ($keylen, $datalen, $expire) = unpack ("VVH16", $buf);
    return 0 if ($keylen > 10000); # buggy input, don't eat all mem
    $len = read ($fh, $buf, $keylen + $datalen);
    return 0 unless ($len == $keylen + $datalen);
    $key = substr ($buf, 0, $keylen);
    $data = substr ($buf, $keylen, $datalen);
    ($type, $d) = unpack ("na*", $key);
  SWITCH: {
      ($type ==   1) && do { $s = "a ".name($d)." ".join(" ",ips($data));
			     last SWITCH; };
      ($type ==   2) && do { $s = "ns ".name($d)." ".join(" ",names($data));
			     last SWITCH; };
      ($type ==   5) && do { $s = "cname ".name($d)." ".name($data);
			     last SWITCH; };
      ($type ==  12) && do { $s = "ptr ".name($d)." ".join(" ",names($data));
			     last SWITCH; };
      ($type ==  15) && do { $s = "mx ".name($d)." ".join(" ",mxs($data));
			     last SWITCH; };
      ($type ==  16) && do { $s = "txt ".name($d)." ".join(" ",txts($data));
			     last SWITCH; };
      ($type ==  33) && do { $s = "srv ".name($d)." ".join(" ",srvs($data));
			     last SWITCH; };
      ($type == 252) && do { $s = "servfail ".name($d); # axfr -> servfail
			     last SWITCH; };
      ($type == 255) && do { $s = "nxdomain ".name($d); # any -> nxdomain
			     last SWITCH; };
      $s = "$type ".name($d)." ".join(" ",miscs($data));
    }
    if ($showttl) {
      print (ttl($expire));
    } else {
      print "\@$expire"."00000000";
    }
    print " $s\n";
  }
  return 1;
}