scripts/named-conf

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use IO::File;
   5 use Data::Dumper;
   6 use POSIX;
   7
   8 use vars qw($quis
   9             $mode $doall
  10             $etcfile $where
  11             $debug $needglue $localonly $verbosity);
  12
  13 $quis= $0; $quis =~ s,.*/,,;
  14
  15 $mode= '';
  16 $doall= 0;
  17 $etcfile= "/etc/bind/chiark-conf-gen.zones";
  18 $where= '<built-in>';
  19 $debug= 0;
  20 $needglue= 2;
  21 $localonly= 0;
  22 $verbosity= 1;
  23
  24 use vars qw($dig_owner $dig_type $dig_rdata);
  25
  26 while (@ARGV && $ARGV[0] =~ m/^\-/) {
  27     $_= shift @ARGV;
  28     if (s/^\-\-//) {
  29         last if m/^$/;
  30         if (m/^(yes|no|force)$/) { m/^./; $mode= $&; }
  31         elsif (m/^all$/) { $doall=1; }
  32         elsif (m/^config$/) { $etcfile= loarg(); $where= '--config option'; }
  33         elsif (m/^glueless$/) { $needglue--; }
  34         elsif (m/^localonly$/) { $localonly=1; }
  35         elsif (m/^quiet$/) { $verbosity=0; }
  36         elsif (m/^verbose$/) { $verbosity=2; }
  37         else { usageerr("unknown option --$_"); }
  38     } else {
  39         s/^\-//;
  40         last if m/^$/;
  41         while (m/^./) {
  42             if (s/^[ynf]//) { $mode=$&; }
  43             elsif (s/^A//) { $doall=1; }
  44             elsif (s/^C//) { $etcfile= soarg(); $where= '-C option'; }
  45             elsif (s/^D//) { $debug++; }
  46             elsif (s/^g//) { $needglue--; }
  47             elsif (s/^l//) { $localonly=1; }
  48             elsif (s/^q//) { $verbosity=0; }
  49             elsif (s/^v//) { $verbosity=2; }
  50             else { usageerr("unknown option -$&"); }
  51         }
  52     }
  53 }
  54
  55 sub loarg() { usageerr("missing option value") if !@ARGV; return shift @ARGV; }
  56 sub soarg() { my ($rv); $rv=$_; $_=''; return length $rv ? $rv : loarg(); }
  57
  58 usageerr("-g may be specified at most twice") if $needglue<0;
  59 usageerr("-D may be specified at most twice") if $debug>2;
  60 usageerr("must specify either -f|-y|-n or zones (and not both)")
  61     if !!$mode == !!@ARGV;
  62
  63 sub usageerr ($) {
  64     die
  65 "$_[0]
  66 usage: named-conf-regen [-rvq] -f|-y|-n|<zone>...\n".
  67 "operation modes:\n".
  68 " -f --force   install without checking\n".
  69 " -y --yes     check and install\n".
  70 " -n --no      check only\n".
  71 "additional options:\n".
  72 " -q --quiet   no output for OK zones\n".
  73 " -v --verbose extra verbose\n";
  74 }
  75
  76 cfg_fail("config filename $etcfile should not be directory")
  77     if $etcfile =~ m,/$,;
  78
  79 use vars qw($default_dir);
  80 $default_dir= $etcfile =~ m,^.*/, ? $& : './';
  81
  82 use vars qw($slave_dir $slave_prefix $slave_suffix);
  83 $slave_dir= 'slave';
  84 $slave_prefix= '';
  85 $slave_suffix= '';
  86
  87 use vars qw(@self_ns @self_soa @self_addr);
  88 @self_ns= @self_soa= @self_addr= ();
  89
  90 use vars qw(%zone_cfg @zone_cfg_list);
  91 %zone_cfg= ();
  92 @zone_cfg_list= ();
  93
  94 use vars qw($output $default_output %output_contents);
  95 $output= '';
  96 $default_output= '';
  97 %output_contents= ();
  98
  99 use vars qw($check $install);
 100 $check= $mode !~ m/^f/;
 101 $install= $mode =~ m/^[yf]/;
 102
 103 read_config($etcfile);
 104 debug_dump('@zone_cfg_list %zone_cfg');
 105 process_zones($mode ? @zone_cfg_list : @ARGV);
 106 debug_dump('%output_contents');
 107 output_files() if $install;
 108
 109 exit 0;
 110
 111 #-------------------- configuration reading
 112
 113 sub cfg_fail ($) { die "$quis: $where:\n $_[0]\n"; }
 114
 115 sub read_config ($) {
 116     my ($if) = @_;
 117     my ($fh,$z,@self,$before, $mod,$dir,$prefix,$suffix,$lprefix,$lsuffix);
 118     local ($_);
 119
 120     $fh= new IO::File $if,'r' or cfg_fail("open $if:\n $!");
 121     $before= '';
 122     for (;;) {
 123         if (!defined($_= <$fh>)) {
 124             cfg_fail("read config file $if:\n $!") if $fh->error();
 125             last;
 126         }
 127         chomp; s/\s+$//;
 128         if (m/\\$/) { $before.= $_; next; }
 129         $_= $before.$_;
 130         $before= '';
 131         s/^\s+//;
 132         $where= "$if:$.";
 133         next if m/^\#/;
 134         last if m/^end$/;
 135         next unless m/\S/;
 136         if (m/^self(\-ns|\-soa|)\s+(\S.*\S)/) {
 137             @self= split /\s+/, $2;
 138             @self_ns= @self if $1 ne '-soa';
 139             @self_soa= @self if $1 ne '-ns';
 140         } elsif (m/^self\-addr\s+([0-9. \t]+)/) {
 141             @self_addr= split /\s+/, $1;
 142         } elsif (m/^primary\-dir([*?]?)\s+(\S+)((?:\s+(\S+))?:\s+(\S+))?$/) {
 143             ($mod, $dir, $prefix, $suffix) = ($1,qualify($2),$3,$4);
 144             $suffix= '_db' if !defined $suffix;
 145             $prefix= '' if !defined $prefix;
 146             opendir D, $dir or cfg_fail("open primary-dir $dir:\n $!");
 147             $lprefix= length $prefix; $lsuffix= length $suffix;
 148             while (defined($_= readdir D)) {
 149                 next if m/^\./ && !$lprefix;
 150                 next unless length > $lprefix+$lsuffix;
 151                 next unless substr($_,0,$lprefix) eq $prefix;
 152                 next unless substr($_,length($_)-$lsuffix) eq $suffix;
 153                 $z= substr($_,$lprefix,length($_)-($lprefix+$lsuffix));
 154                 zone_conf($z,'primary','p',$mod,"$dir/$_");
 155             }
 156             closedir D or cfg_fail("close primary-dir $dir:\n $!");
 157         } elsif (m/^primary([*?]?)\s+(\S+)\s+(\S+)$/) {
 158             zone_conf($2,'primary','p',$1,qualify($3));
 159         } elsif (m/^published([*?]?)\s+(\S+)\s+([0-9.\t]+)$/) {
 160             zone_conf($2,'published','s',$1,'',$3);
 161         } elsif (m/^stealth([*?]?)\s+(\S+)\s+([0-9. \t]+)$/) {
 162             zone_conf($2,'stealth','u',$1,'',split /\s+/, $3);
 163         } elsif (m/^slave\-dir\s+(\S+)((?:\s+(\S+))?:\s+(\S+))?$/) {
 164             ($slave_dir, $slave_prefix, $slave_suffix) = (qualify($1),$2,$3);
 165         } elsif (m/^output\s+bind8\+(\S+)$/) {
 166             cfg_fail("default output may not apply to only some zones")
 167                 if @zone_cfg_list && length $default_output;
 168             set_output(qualify($1));
 169         } elsif (m/^include\s+(\S+)$/) {
 170             read_config($1);
 171         } else {
 172             cfg_fail("unknown configuration directive".
 173                      " or incorrect syntax or arguments");
 174         }
 175     }
 176     $fh->close or cfg_fail("close config file $if:\n $!");
 177 }
 178
 179 sub qualify ($) {
 180     my ($i) = @_;
 181     $i= "$default_dir$i" unless $i =~ m,^/,;
 182     return $i;
 183 }
 184
 185 sub zone_conf ($$$$$@) {
 186     my ($zone,$style,$sabbr,$mod,$file,@servers) = @_;
 187     my ($sfx,$aref);
 188     $file= qualify("$slave_dir/$slave_prefix".$zone.$slave_suffix)
 189         unless length $file;
 190     if (!length $output) {
 191         $default_output= qualify('chiark-conf-gen.bind8')
 192             unless length $default_output;
 193         set_output($default_output);
 194     }
 195     cfg_fail("redefined zone $zone") if exists $zone_cfg{$zone};
 196     $zone_cfg{$zone}{'file'}= $file;
 197     $zone_cfg{$zone}{'style_p'}= $style.$mod;
 198     $zone_cfg{$zone}{'s'}= $sabbr.$mod; # p)rimary s)econdary u)npub f)oreign
 199     $zone_cfg{$zone}{'servers'}= [ @servers ];
 200     foreach $sfx (qw(soa ns addr)) {
 201         { no strict 'refs'; $aref= [ @{ "self_$sfx" } ]; }
 202         @$aref or cfg_fail("failed to specify self-$sfx before zone");
 203         $zone_cfg{$zone}{"self_$sfx"}= $aref;
 204     }
 205     $zone_cfg{$zone}{'output'}= $output;
 206     push @zone_cfg_list, $zone;
 207 }
 208
 209 sub set_output($) {
 210     my ($newout) = @_;
 211     $output= $newout;
 212     $output_contents{$output}= '';
 213 }
 214
 215
 216 #-------------------- checking
 217
 218 use vars qw($zone $cfg $warnings);
 219 $warnings= 0;
 220
 221 sub progress ($) {
 222     return if !$verbosity;
 223     print "$_[0]\n";
 224 }
 225
 226 sub verbose ($) {
 227     return if $verbosity<2;
 228     print "    $_[0]\n";
 229 }
 230
 231 sub process_zones (@) {
 232     my (@zones) = @_;
 233     local ($zone,$cfg);
 234
 235     foreach $zone (@zones) {
 236         $cfg= $zone_cfg{$zone} || {
 237             'style_p' => 'foreign',
 238             's' => 'f',
 239             'servers' => [ ],
 240             };
 241         progress(sprintf "%-40s %s", $zone, $$cfg{'style_p'});
 242         if ($check && ($doall || $cfg->{'s'} !~ m/\?/)) {
 243             eval {
 244                 if ($localonly && $cfg->{'s'} =~ m/f/) {
 245                     zone_warning("foreign zone specified with -l");
 246                 } elsif ($cfg->{'s'} =~ m/\*/ ||
 247                          ($localonly && $cfg->{'s'} !~ m/p/)) {
 248                     zone_check_local();
 249                 } else {
 250                     zone_check_full();
 251                 }
 252             };
 253             zone_warning("checks failed: $@") if length $@;
 254         }
 255         zone_output() if $install;
 256     }
 257     print STDERR "$quis: $warnings warnings\n" or die $!
 258         if $warnings;
 259 }
 260
 261 sub zone_warning ($) {
 262     my ($w) = @_;
 263     $w =~ s/\n$//;
 264     $w =~ s,\n, // ,g;
 265     print STDERR "$zone: warning: $w\n" or die $!;
 266     $warnings++;
 267 }
 268
 269 sub zone_warnmore ($) {
 270     print STDERR "$zone:  $_[0]\n" or die $!;
 271 }
 272
 273 use vars qw(%delgs); # $delgs{$nameserver_list} = [ $whosaidandwhy ]
 274 use vars qw(%auths); # $auths{$nameserver_list} = [ $whosaidandwhy ]
 275 use vars qw(%glue);  # $glue{$name}{$addr_list} = [ $whosaidandwhy ]
 276 use vars qw(%soas);  # $soa{"$origin $serial"} = [ $whosaidandwhy ]
 277 use vars qw(%addr_is_ok %warned_glueless %warned_mynameaddr);
 278 use vars qw($delg_to_us);
 279 use vars qw(@to_check); # ($addr,$whyask,$is_auth,$glueless_ok, ...)
 280 use vars qw(@to_check_soa); # ($addr,$whyask, ...)
 281
 282 sub zone_check_full () {
 283     zone_reset();
 284     zone_investigate();
 285     zone_consistency();
 286     zone_servers_ok();
 287 }
 288
 289 sub zone_reset() {
 290     %delgs= %auths= %glue= %soas=
 291         %warned_glueless= %warned_mynameaddr=
 292             %addr_is_ok= ();
 293     $delg_to_us= 0;
 294     @to_check= @to_check_soa= ();
 295 }
 296
 297 sub zone_investigate() {
 298     my ($super_zone, @super_nsnames,
 299         $super_ns, @super_ns_addrs, $s, $wa, $is_auth,
 300         %nsrrset_checked, %soa_checked, $addr, $glueless_ok, $rcode);
 301
 302     $super_zone= $zone;
 303     for (;;) {
 304         debug_trace("zone $zone superzone $super_zone");
 305         $super_zone =~ s/^[^.]+\.// or die "no superzone ? ($super_zone)\n";
 306         ($rcode,@super_nsnames)= lookup($super_zone,'ns-','06');
 307         last if !$rcode;
 308     }
 309     for $super_ns (@super_nsnames) {
 310         $super_ns= lc $super_ns;
 311         ($rcode,@super_ns_addrs)= lookup($super_ns,'a','0');
 312         foreach $addr (@super_ns_addrs) {
 313             push @to_check,
 314                  $addr,
 315                  "$super_ns, server for $super_zone",
 316                  0, 0;
 317         }
 318     }
 319     for (;;) {
 320         # We do these in order so that we always do NS RRset checks on
 321         # nameservers that came from other NS RRsets first; otherwise
 322         # we might set nsrrset_checked due to a glueless_ok check,
 323         # and then not check for gluefulness later.
 324         debug_dump('@to_check @to_check_soa');
 325         if (($addr,$wa,$is_auth,$glueless_ok,@to_check) = @to_check) {
 326             push @to_check_soa, $addr, $wa if $is_auth;
 327             next if $nsrrset_checked{$addr}++;
 328             zone_check_nsrrset($addr, "[$addr] $wa",
 329                                $is_auth, $glueless_ok);
 330         } elsif (($addr,$wa,@to_check_soa) = @to_check_soa) {
 331             next if $soa_checked{$addr}++;
 332             zone_check_soa($addr,"[$addr] $wa","[$addr] NS");
 333         } else {
 334             last;
 335         }
 336     }
 337 }
 338
 339 sub zone_check_nsrrset ($$$$) {
 340     my ($uaddr,$ww, $is_auth, $glueless_ok) = @_;
 341     my (@s, $s, %s2g, @glue, $glue, $delgs_or_auths, $wwn);
 342     verbose("checking delegation by $ww");
 343     dig(sub {
 344         if ($dig_type eq 'ns' && $dig_owner eq $zone) {
 345             $s2g{lc $dig_rdata} = [ ];
 346         } elsif ($dig_type eq 'a' && exists $s2g{$dig_owner}) {
 347             $wwn= "in glue from $ww";
 348             push @to_check, $dig_rdata, "$dig_owner, $wwn", 1, 0;
 349             zone_server_addr($dig_rdata,$dig_owner,$wwn,"NS [$uaddr]",0);
 350             push @{ $s2g{$dig_owner} }, $dig_rdata;
 351         }
 352     },
 353              $zone,'ns',$uaddr);
 354     if (!%s2g) { zone_warning("unable to find NS RRset at $ww"); return; }
 355     elsif (keys %s2g == 1) { zone_warning("only one nameserver at $ww"); }
 356     @s= sort keys %s2g;
 357     foreach $s (@s) {
 358         @glue= @{ $s2g{$s} };
 359         if (!@glue) {
 360             zone_warning("glueless NS $s,".
 361                          ($needglue<=1 ? " (eg)" : "").
 362                          " from $ww")
 363                 unless $glueless_ok || !$needglue ||
 364                        ($needglue<=1 && $warned_glueless{$s}++);
 365             next;
 366         }
 367         $glue= join ' ', sort @glue;
 368         push @{ $glue{$s}{$glue} }, $ww;
 369     }
 370     $s= join ' ', @s;
 371     $delgs_or_auths= $is_auth ? \%auths : \%delgs;
 372     push @{ $delgs_or_auths->{$s} }, $ww;
 373 }
 374
 375 sub zone_server_addr ($$$$$) {
 376     my ($addr,$name,$ww,$wwq,$is_soa) = @_;
 377     $addr_is_ok{$addr}= "$name ($wwq)"
 378         if $is_soa || $cfg->{'s'} =~ m/u/;
 379     zone_warning("configured as stealth but we [$addr]".
 380                  " are published ($name $wwq)")
 381         if $cfg->{'s'} =~ m/u/ && grep { $_ eq $addr } @self_addr;
 382
 383     my ($name_is_self, $addr_is_self);
 384     $name_is_self= grep { $_ eq $name }
 385         @{ $cfg->{$is_soa ? 'self_soa' : 'self_ns'} };
 386     $addr_is_self= grep { $_ eq $addr }
 387         @{ $cfg->{'self_addr'} };
 388     if ($name_is_self && !$addr_is_self) {
 389         zone_warning("our name $name with wrong address [$addr], (eg) $ww")
 390             unless $warned_mynameaddr{$name}{$addr}++;
 391     } elsif (!$name_is_self && $addr_is_self) {
 392         zone_warning(($is_soa ? "SOA ORIGIN maps to" : "allegedly served by").
 393                      " us [$addr] with wrong name $name, (eg) $ww")
 394             unless $warned_mynameaddr{$name}{$addr}++;
 395     }
 396     $delg_to_us=1 if $name_is_self;
 397 }
 398
 399 sub zone_check_soa ($$$) {
 400     my ($uaddr,$ww,$wwq) = @_;
 401     my ($lame,$origin,$got,$rcode,@soa_addrs,$soa_addr,$wwn);
 402     verbose("checking service at $wwq");
 403     $lame= 'dead or lame';
 404     dig(sub {
 405         if ($dig_type eq 'flags:') {
 406             $lame= $dig_rdata =~ m/ aa / ? '' : 'lame';
 407         } elsif ($dig_type eq 'soa' && $dig_owner eq $zone && !$lame) {
 408             die "several SOAs ? $ww" if defined $origin;
 409             $got= $dig_rdata;
 410             $got =~ m/^(\S+) \d+/ or die "$got ?";
 411             $origin= $1;
 412         }
 413     },
 414              $zone,'soa',$uaddr);
 415     $lame= 'broken' if !$lame && !defined $origin;
 416     if ($lame) { zone_warning("$lame server $ww"); return; }
 417     push @{ $soas{$got} }, $ww;
 418     ($rcode,@soa_addrs)= lookup($origin,'a','0');
 419     foreach $soa_addr (@soa_addrs) {
 420         $wwn= "SOA ORIGIN from $ww";
 421         zone_server_addr($soa_addr,$origin,$wwn,"SOA [$uaddr]",1);
 422         push @to_check, $soa_addr, "$origin, $wwn";
 423     }
 424 }
 425
 426 sub zone_consistency() {
 427     my ($d, $org_ser, $origin, $a, $h, $self_soa);
 428     zone_consistency_set('delegations',\%delgs);
 429     foreach $d (keys %delgs) { delete $auths{$d}; }
 430     zone_consistency_set('zone nameserver rrset',\%auths);
 431     foreach $h (keys %glue) {
 432         zone_consistency_set("glue for $h", $glue{$h});
 433     }
 434     zone_consistency_set("SOA ORIGIN and SERIAL",\%soas);
 435     $self_soa= $cfg->{'self_soa'};
 436     if ($cfg->{'s'} =~ m/p/) {
 437         foreach $org_ser (keys %soas) {
 438             $org_ser =~ m/^(\S+) \d+$/ or die "$org_ser ?";
 439             $origin= $1;
 440             next if grep { $_ eq $origin } @$self_soa;
 441             zone_warning("SOA ORIGIN $origin is not our name (@$self_soa),".
 442                          " eg from ".($soas{$org_ser}[0]));
 443         }
 444     }
 445 }
 446
 447 sub zone_servers_ok () {
 448     my ($showok);
 449     if (%addr_is_ok) {
 450         $showok= 0;
 451         foreach $a (@{ $cfg->{'servers'} }) {
 452             next if exists $addr_is_ok{$a};
 453             zone_warning("we slave from $a"); $showok=1;
 454         }
 455         if ($showok) {
 456             foreach $a (keys %addr_is_ok) {
 457                 zone_warnmore("permitted master [$a] $addr_is_ok{$a}");
 458             }
 459         }
 460     }
 461     if ($cfg->{'s'} =~ m/s/ && !$delg_to_us) {
 462         zone_warnmore("we are supposedly published secondary,".
 463                       " but not listed as a nameserver");
 464     }
 465 }
 466
 467 sub zone_consistency_set ($%) {
 468     my ($msg,$set) = @_;
 469     my ($d,$o);
 470     if (keys(%$set) > 1) {
 471         zone_warning("inconsistent $msg:");
 472         foreach $d (keys %$set) {
 473             foreach $o (@{ $set->{$d} }) { zone_warnmore(" $d from $o"); }
 474         }
 475     }
 476 }
 477
 478 sub zone_check_local () {
 479     zone_reset();
 480     zone_servers_simplefind();
 481     zone_servers_ok();
 482 }
 483
 484 sub zone_servers_simplefind () {
 485     my ($rcode,@nsnames,$ns,@soas,$origin);
 486
 487     ($rcode,@nsnames)= lookup($zone,'ns-','0');
 488     foreach $ns (@nsnames) { zone_server_simple($ns,'NS',0); }
 489
 490     ($rcode,@soas)= lookup($zone,'soa','0');
 491     die "multiple SOA RRs in set!  @soas ?" if @soas!=1;
 492     $soas[0] =~ m/^(\S+)\s/ or die "SOA ? $_";
 493     zone_server_simple(domain_canon($1),'SOA',1);
 494 }
 495
 496 sub zone_server_simple ($$$) {
 497     my ($name,$ww,$is_soa) = @_;
 498     my ($rcode,@addrs,$addr);
 499     ($rcode,@addrs)= lookup($name,'a','0');
 500     foreach $addr (@addrs) { zone_server_addr($addr,$name,$ww,$ww,$is_soa); }
 501 }
 502
 503 #-------------------- outputting
 504
 505 sub zone_output () {
 506     $output_contents{$$cfg{'output'}}.=
 507         sprintf(<<'END',
 508 zone "%s" {
 509     type %s;
 510     file "%s";
 511 };
 512 END
 513                 $zone,
 514                 $$cfg{'s'} =~ m/p/ ? 'master' : 'slave',
 515                 $$cfg{'file'});
 516 }
 517
 518 sub output_files () {
 519     my ($fn,$ofn,$mfn,$l,$dir, $maxmode,$h,@to_install);
 520
 521     foreach $ofn (keys %output_contents) {
 522         $fn= $ofn; $mfn= "output file $fn";
 523         for (;;) {
 524             if (!lstat $fn) {
 525                 $! == &ENOENT or die "$quis: stat $mfn:\n $!\n";
 526                 $maxmode= 0666;
 527                 last;
 528             } elsif (-f _) {
 529                 $maxmode= (stat _)[2];
 530                 last;
 531             } elsif (-l _) {
 532                 defined($l= readlink $fn)
 533                     or die "$quis: readlink $mfn:\n $!\n";
 534                 $dir= $fn =~ m,^.*/, ? $& : './';
 535                 $fn= "$dir$l" unless $l =~ m,^/,;
 536                 $mfn= "output file $fn (symlink target of $ofn)";
 537             } else {
 538                 die "$quis: output file $mfn exists but is not a file".
 539                     " (or symlink to one)";
 540             }
 541         }
 542         unlink "$fn.new" or $! == &ENOENT or
 543             die "$quis: cannot clear out old .new version of $mfn:\n $!";
 544         $h= new IO::File "$fn.new",'w',$maxmode
 545             or die("$quis: create .new version of $mfn:\n $!");
 546         print $h
 547             "# generated by $quis, do not edit\n",
 548             $output_contents{$ofn}
 549             or die "$quis: write data to .new version of $mfn:\n $!";
 550         $h->close
 551             or die "$quis: close .new version of $mfn:\n $!";
 552         push @to_install, $fn,$mfn;
 553     }
 554
 555     while (($fn,$mfn, @to_install) = @to_install) {
 556         rename "$fn.new",$fn
 557             or die "$quis: install new version of $mfn:\n $!";
 558     }
 559 }
 560
 561 #-------------------- general utilities
 562
 563 sub debug_dump ($) {
 564     my ($vn);
 565     return unless $debug>1;
 566     local $Data::Dumper::Terse=1;
 567     foreach $vn (split /\s+/, $_[0]) {
 568         print "$vn := ", eval "Dumper(\\$vn)";
 569     }
 570 }
 571
 572 sub debug_trace ($) {
 573     return unless $debug;
 574     print "D $_[0]\n";
 575 }
 576
 577 sub lookup ($$$) {
 578     my ($domain,$type,$okrcodes) = @_;
 579     my ($c,$h,@result);
 580     debug_trace("lookup ==> (->$okrcodes) $domain $type");
 581     $h= new IO::Handle;
 582
 583     defined($c= open $h, "-|") or die "$quis: fork adnshost:\n $!\n";
 584     if (!$c) {
 585         exec 'adnshost','-Fi','+Do','+Dt','+Dc','-Cf',"-t$type",
 586              '-',"$domain.";
 587         die "$quis: exec adnshost:\n $!\n";
 588     }
 589     @result= $h->getlines();
 590     $h->error and die "$quis: read from adnshost:\n $!\n";
 591     chomp @result;
 592     $!=0; $h->close;
 593     die "$quis: lookup -t$type $domain $okrcodes failed $? $! @result\n"
 594         if $! or $?>6 or index($okrcodes,$?)<0;
 595     debug_trace("lookup <== $? @result");
 596     return ($?,@result);
 597 }
 598
 599
 600 sub dig (&$$$) {
 601     my ($eachrr, $qowner,$qtype,$qaddr) = @_;
 602     # also pseudo-rr with type `flags:'
 603     my ($h,$inmid,$irdata,$c);
 604     local ($_);
 605
 606     debug_trace("dig ==> \@$qaddr $qowner $qtype");
 607
 608     $h= new IO::Handle;
 609     defined($c= open $h, "-|") or die "$quis: fork dig:\n $!\n";
 610     if (!$c) {
 611         open STDERR, ">&STDOUT" or die $!;
 612         exec ('dig',
 613               '+nodef','+nosea','+nodebug','+norecurse',
 614               "\@$qaddr",'-t',$qtype,$qowner);
 615         die "$quis: exec dig:\n $!\n";
 616     }
 617     $inmid='';
 618     for (;;) {
 619         if (!defined($_= $h->getline())) {
 620             $h->error() and die "$quis: read from dig:\n $!\n";
 621             last;
 622         }
 623         chomp;
 624         if (length $inmid) {
 625             s/^\s+/ / or die "$inmid // $_ ?";
 626             s/\;.*$//;
 627             $_= $inmid.$_;
 628             $inmid='';
 629             s/$/ \(/ unless s/\s*\)\s*$//;
 630         }
 631         if (s/\s*\(\s*$//) { $inmid= $_; next; }
 632         if (m/^\;\; flags\:( [-0-9a-z ]+)\;/) {
 633             $dig_owner=''; $dig_type='flags:'; $dig_rdata= "$1 ";
 634             debug_trace("dig  f: $dig_rdata");
 635             &$eachrr;
 636         } elsif (m/^\;/) {
 637         } elsif (!m/\S/) {
 638         } elsif (m/^([-.0-9a-z]+)\s+\d\w+\s+in\s+([a-z]+)\s+(\S.*)/i) {
 639             $dig_owner=domain_canon($1); $dig_type=lc $2; $irdata=$3;
 640             if ($dig_type eq 'a') {
 641                 $irdata =~ m/^[.0-9]+$/ or die "$irdata ?";
 642                 $dig_rdata= $&;
 643             } elsif ($dig_type eq 'ns') {
 644                 $irdata =~ m/^[-.0-9a-z]+$/i or die "bad nameserver $irdata ?";
 645                 $dig_rdata= domain_canon($irdata);
 646             } elsif ($dig_type eq 'soa') {
 647                 $irdata =~ m/^([-.0-9a-z]+)\s+.*\s+(\d+)(?:\s+\d\w+){4}$/i
 648                     or die "bad SOA $irdata ?";
 649                 $dig_rdata= domain_canon($1).' '.$2;
 650             } else {
 651                 debug_trace("ignoring uknown RR type $dig_type");
 652                 next;
 653             }
 654             debug_trace("dig  $dig_owner $dig_type $dig_rdata");
 655             &$eachrr;
 656         } else {
 657             debug_trace("ignoring unknown dig output $_");
 658         }
 659     }
 660     $h->close;
 661     debug_trace("dig <== gave $?");
 662 }
 663
 664 sub domain_canon ($) {
 665     local ($_) = @_;
 666     s/(.)\.$/$1/;
 667     die "domain $_ ?" unless m/^[0-9a-z]/i;
 668     return lc $_;
 669 }