package Net::SegmentOwner;

use Net::DNS;
use strict;

use Exporter;
use vars qw( @ISA $VERSION @EXPORT @EXPORT_OK );
@ISA       = qw( Exporter );
$VERSION   = '0.01';
@EXPORT    = qw();
@EXPORT_OK = qw( owner );

use vars qw( $debug $resolver );
$debug = 0;
$resolver = new Net::DNS::Resolver;

### helpers

# uniq(LIST) -- remove duplicates and return a (sorted) list
sub uniq (@) {
  my (@data) = sort(@_);
  my ($i, $j);
  for ($i=0; $i<$#data; $i++) {
    $j = $i;
    while ( ($j < $#data) && ($data[$j+1] eq $data[$i]) ) { $j++; }
    splice @data, $i+1, $j-$i  if ($j > $i);
  }
  @data;
}

### add sanity to DNS stuff

use vars qw( %rcode );
%rcode = (NOERROR  =>	'No error',
	  FORMERR  =>	'Format error',
	  SERVFAIL =>	'Internal server failure',
	  NXDOMAIN =>	'Name not found',
	  NOTIMP   =>	'Not implemented',
	  REFUSED  =>	'Refused',
	  YXDOMAIN =>	'Name exists',
	  YXRRSET  =>	'RRset exists',
	  NXRRSET  =>	'RRset does not exist',
	  NOTAUTH  =>	'Not authoritative',
	  NOTZONE  =>   'Name does not match zone');
sub rcode ($) {exists $rcode{$_[0]} ? $rcode{$_[0]} : "Unknown error ($_[0])"}

# name2addr(NAME) -- turn name into an addr by replacing first
#   unquoted '.' with '@', and unquoting everything else.
sub name2addr {
  local($_) = @_;
  s/^\./@/ || s/([^\\])\./\1@/ || warn "no dots in supposed address '$_'";
  s/\\([^\\])/\1/g;
  $_;
}

### DNS stuff

# ask(NAME, TYPE) -- make a query and return answer records
#   [arguments should be given in usual order, eg. 18,177,0,1]
sub ask ($$) {
  my ($name, $qtype) = @_;
  my $ans = $resolver->send($name, $qtype, 'IN')
    or do { warn "ask: $name: No answer ($!)";  return () };
  print "ask: $name: " . rcode($resolver->errorstring) . "\n" if $debug;
  $ans->answer;
}

# authority(NAME, TYPE) -- reverse-resolve PTR record and return
#   authority records
sub authority ($) {
  my ($name) = @_;
  my $ans = $resolver->send($name, 'PTR', 'IN')
    or do { warn "authority: $name: No answer ($!)";  return () };
  print "authority: $name: " . rcode($resolver->errorstring) . "\n" if $debug;
  $ans->authority;
}

# soa(NAME) -- reverse-resolve IP address and return SOA
sub soa ($) {
  my ($name) = @_;
  my @auth = authority($name);
  if (! @auth) {
    warn "no auth records for '$name'; retrying...\n" if $debug;
    @auth = authority($name);
  }
  if (! @auth) {
    warn "soa: $name: no authority";
    return ();
  }
  my @soa = grep $_->class eq 'IN' && $_->type eq 'SOA', @auth;
  return @soa if @soa;
  my @domain = uniq map lc($_->name), @auth;
  warn "Multiple domains, using first: @domain\n  " if (@domain > 1);
  grep $_->class eq 'IN' && $_->type eq 'SOA',
  	ask($domain[0], 'SOA');
}

# soa_owner(N[,N[,N[,N]]]) -- return owner of the network segment
sub soa_owner {
  my $name = join('.', reverse(@_), 'in-addr.arpa.');
  my @soa = uniq soa $name
    or return undef;
  join ', ', grep defined($_), map name2addr($_->rname), @soa;
}

# owner(N,N,N,N) -- return owner of network segment or its ancestors
sub owner {
  my (@addr) = @_;
  my (@zeros) = ();
  my ($owner);

  if ((@addr == 1) && ($addr[0] =~ /\./)) {
    @addr = split /\./, $addr[0];
  }

  while (@addr) {
    ($owner = soa_owner(@addr))
      and return $owner;
    @zeros and ($owner = soa_owner(@addr, @zeros))
      and return $owner;
    pop(@addr);
    push(@zeros, 0);
  }
  return undef;
}