#!/usr/bin/perl -w
#
# dumpcache-expire.pl v0.1
# (C) 2003 Jakob Hirsch (dumpcache@plonk.de)
# http://plonk.de/sw/djb/dumpcache-expire.pl
#
# History:
# 2003-04-20	created v0.1
#
# expire a entry in dnscache's cache (by setting expiry to 0)
# needs the dumpcache-patch from http://www.efge.org/djbdns/
# based on prettycache.pl from this site
#
#
# Licenced under the GPL (http://www.fsf.org/licenses/gpl.txt)
#

# Specify your dumpcache file here
$f = "/service/dnscache/root/dump/dumpcache";
#
$expires = "\000\000\000\000\000\000\000\000";

####### 
#

if ($#ARGV < 0) {
  print STDERR "usage: dumpcache-expire.pl record1 record2 ...\n";
  exit 0;
}

# dump the cache
system "svc -a /service/dnscache";

# we sleep for one second so dnscache can dump
# if you have a large cache you may have to increase the time
# or rewrite this to wait for the "dump" log line
sleep 1;

open (FILE, "+<$f") or die "$f: $!";

my $count = 0;

while (!eof(FILE)) {
  my $pos = tell FILE;
  my ($buf, $len);
  my ($keylen, $datalen);
  my ($key, $data, $expire);
  my ($type, $d, $s);
  # read length of key, data and the expiration time
  $len = read (FILE, $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
  # read key and data
  $len = read (FILE, $buf, $keylen + $datalen);
  return 0 unless ($len == $keylen + $datalen);
  $key = substr ($buf, 0, $keylen);
  (undef, $d) = unpack ("na*", $key);
  
  foreach (@ARGV) { 
    if (name($d) eq $_.".") {
      #print "\@".$expire."00000000 ".$pos."\n";
      $count++;	
      seek FILE, $pos + 8, 0 or die "$f: $!"; 
      print FILE $expires or die "$f: $!";
      seek FILE, $pos + 16 + $keylen + $datalen, 0 or die "$f: $!";
    }
  }
}

close(FILE);

# restart dnscache to load the cachedump
system "svc -h /service/dnscache"; 

# return the number of expired entries
exit $count;



# convert name to readable format
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;
}

#