#!/usr/bin/perl -w

# $Id: IPv4.pm,v 0.92 2001/04/05 04:14:20 sweth Exp sweth $
package Net::Address::IPv4;

my @REVISION = qw($Revision: 0.92 $);
my $VERSION = $REVISION[1];

### set up the environment
use strict; 
use English;
use Carp;

use vars qw ( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS );

use Exporter;
@ISA = qw ( Exporter );

@EXPORT = qw( 
   IsValidIP IsValidMask
);

$EXPORT_TAGS{'ValidIP'} = [ qw(
   IsValidIP IsValidIPBin IsValidIPHex IsValidIPDottedQuad IsValidIPDec
) ];
$EXPORT_TAGS{'ValidMask'} = [ qw(
   IsValidMask IsValidMaskBin IsValidMaskDec IsValidMaskHex IsValidMaskCIDR 
   IsValidMaskDottedQuad
) ];
$EXPORT_TAGS{'ValidX'} = [
   @{ $EXPORT_TAGS{'ValidIP'} },
   @{ $EXPORT_TAGS{'ValidMask'} }
];

$EXPORT_TAGS{'Bin2X'} = [ qw(
   Bin2Dec Bin2Hex Bin2CIDR Bin2DottedQuad
) ];
$EXPORT_TAGS{'Dec2X'} = [ qw(
   Dec2Bin Dec2Hex Dec2CIDR Dec2DottedQuad 
) ];
$EXPORT_TAGS{'Hex2X'} = [ qw(
   Hex2Bin Hex2Dec Hex2CIDR Hex2DottedQuad
) ];
$EXPORT_TAGS{'CIDR2X'} = [ qw(
   CIDR2Bin CIDR2Dec CIDR2Hex CIDR2DottedQuad 
) ];
$EXPORT_TAGS{'DottedQuad2X'} = [ qw(
   DottedQuad2Bin DottedQuad2Dec DottedQuad2Hex DottedQuad2CIDR
) ];
$EXPORT_TAGS{'X2Y'} = [
   @{ $EXPORT_TAGS{'Bin2X'} },
   @{ $EXPORT_TAGS{'Dec2X'} },
   @{ $EXPORT_TAGS{'Hex2X'} },
   @{ $EXPORT_TAGS{'CIDR2X'} },
   @{ $EXPORT_TAGS{'DottedQuad2X'} }
];

$EXPORT_TAGS{'ALL'} = [
   @{ $EXPORT_TAGS{'ValidX'} },
   @{ $EXPORT_TAGS{'X2Y'} }
];

# I could use Exporter::export_ok_tags, but I 
# didn't know about it when I wrote this.
#@EXPORT_OK = (
#   @{ $EXPORT_TAGS{'ValidX'} },
#   @{ $EXPORT_TAGS{'X2Y'} }
#);
@EXPORT_OK = (
   @{ $EXPORT_TAGS{'ALL'} }
);

use subs qw( 
   @EXPORT_OK
   wcarp wcroak
);

### Debugging... don't do any of this if module is being imported.
#print "EXPORT\n", 
#   map ({ "   " . $_ . "\n" } sort (@EXPORT)),
#   "\n";
#print "EXPORT_OK\n",
#   map ({ "   " . $_ . "\n" } sort (@EXPORT_OK)),
#   "\n";
#print "EXPORT_TAGS\n", 
#   map ({ "   :" . $_ . "\n" . 
#      join ("", map { "      " . $_ . "\n" } sort (@{ $EXPORT_TAGS{$_} }))
#   } sort (keys %EXPORT_TAGS)),
#   "\n";

### here be subroutines

# wcarp and wcroak tests $WARNING: if true, they determines the caller 
# dynamically and carps/croaks the message passed as an argument.  Either 
# way, they also return 0, unless exiting, in which case they exit with 
# status 1.
sub wcarp {
   if ($WARNING) {
      (my $funcname = (caller(1))[3]) =~ s/([^:]*::)*//;
      if (defined (@_)) {
         carp ("$funcname raised non-fatal error '" . join (" ", @_) . "'");
      } else {
         carp ("$funcname raised unspecified non-fatal error");
      };
   };
   return 0;
};
   
sub wcroak {
   if ($WARNING) {
      (my $funcname = (caller(1))[3]) =~ s/([^:]*::)*//;
      $ERRNO = 1;
      if (defined (@_)) {
         croak ("$funcname raised fatal error '" . join (" ", @_) . "'");
      } else {
         croak ("$funcname raised unspecified fatal error");
      };
   } else {
      return 0;
   };
};
   

# The validation subroutines all fail to check to see if $_[0]
# is defined.  This is intentional; since the validation checks are
# positive, a null argument passed to a validation sub will return
# false, which I think is better than invoking croak and stopping all
# processing.  If -w is set, the validation subs _do_ use carp to
# provide a warning; -w will also complain because of use of uninitialized
# vars, but this will help track down why.

# the IsValidIP and IsValidMask subs are just wrappers for the other
# validation subroutines.
sub IsValidIP {
   if (not defined ($_[0])) {
      wcarp "No argument provided"
   } else {
      my ($incoming_ip, $incoming_format);
      chomp ($incoming_ip = $_[0]);
      if (defined ($_[1])) {
         chomp ($incoming_format = $_[1]);
      } else {
         $incoming_format = "dq";
      };
   
      if ($incoming_format =~ /^bin$/i) {
         IsValidIPBin ($incoming_ip);
      } elsif ($incoming_format =~ /^dec$/i) {
         IsValidIPDec ($incoming_ip);
      } elsif ($incoming_format =~ /^hex$/i) {
         IsValidIPHex ($incoming_ip);
      } elsif ($incoming_format =~ /^dq$/i) {
         IsValidIPDottedQuad ($incoming_ip);
      } else {
         wcroak "Invalid incoming format \"$incoming_format\"";
      };
   };
};
  
sub IsValidMask {
   if (not defined ($_[0])) {
      wcarp "No argument provided"
   } else {
      my ($incoming_mask, $incoming_format);
      chomp ($incoming_mask = $_[0]);
      if (defined ($_[1])) {
         chomp ($incoming_format = $_[1]);
      } else {
         $incoming_format = "dq";
      };
   
      if ($incoming_format =~ /^bin$/i) {
         IsValidMaskBin ($incoming_mask);
      } elsif ($incoming_format =~ /dec/i) {
         IsValidMaskDec ($incoming_mask);
      } elsif ($incoming_format =~ /hex/i) {
         IsValidMaskHex ($incoming_mask);
      } elsif ($incoming_format =~ /cidr/i) {
         IsValidMaskCIDR ($incoming_mask);
      } elsif ($incoming_format =~ /dq/i) {
         IsValidMaskDottedQuad ($incoming_mask);
      } else {
         wcroak "Invalid incoming format \"$incoming_format\"";
      };
   };
};
  

# The real validation subs.  I use regexes for validation rather than
# numeric comparisons, because some of the formats (e.g. dotted quad)
# are not straight numeric values, and because the regex also takes care of
# catching non-numeric values.  
sub IsValidIPDottedQuad {
   if (not defined ($_[0])) {
      wcarp "No argument provided"
   } else {
      my ($incoming_ip);
      chomp ($incoming_ip = $_[0]);
      # this regex matches any number from 000 to 255, with or without
      # leading 0s for numbers under 100.
      my $dq_regex = "([01]?[0-9][0-9]?|2([0-4][0-9]|5[0-5]))";
      $incoming_ip =~ m/^($dq_regex\.){3}$dq_regex$/;
   };
};

sub IsValidIPBin {
   if (not defined ($_[0])) {
      wcarp "No argument provided"
   } else {
      my ($incoming_ip);
      chomp ($incoming_ip = $_[0]);
      $incoming_ip =~ m/^[01]{1,32}$/;
   };
};

sub IsValidIPHex {
   if (not defined ($_[0])) {
      wcarp "No argument provided"
   } else {
      my ($incoming_ip);
      chomp ($incoming_ip = $_[0]);
      $incoming_ip =~ m/^[0-9A-Fa-f]{1,8}$/;
   };
};

sub IsValidIPDec {
   if (not defined ($_[0])) {
      wcarp "No argument provided"
   } else {
      my ($incoming_ip);
      chomp ($incoming_ip = $_[0]);
      # This returns true for any number from 0 to 4294967296 (2**32), with or
      # without leading 0s for numbers under 1000000000.  Doing it as a pure
      # regex was cumbersome and inefficient, and I'm lazy.
      $incoming_ip =~ m/^[0-9]{1,10}$/ and $incoming_ip < 4294967296;
   };
};

# the nice things about masks is that their true bits must be contiguous,
# so all we have to do to validate them is make sure that they would be valid
# ips, and then convert them to binary and check to see if the resulting
# string matches that description.  (Thanks to EMF, I now know that masks
# don't need to be contiguous, but I'm not going to rewrite these, since he
# and I are the only two people I know of who have ever used non-contiguous
# masks for anything other than intellectual exercises.)
sub IsValidMaskCIDR {
   if (not defined ($_[0])) {
      wcarp "No argument provided"
   } else {
      my ($incoming_mask);
      chomp ($incoming_mask = $_[0]);
      # This regex allows optional leading zeroes for numbers under 10.  I
      # use this rather than the convert-to-binary + check-for-contiguous-1s
      # test because cidr is just so easy to validate directly.
      $incoming_mask =~ m/^([0-2]?[0-9]|3[0-2])$/;
   };
};

sub IsValidMaskBin {
   if (not defined ($_[0])) {
      wcarp "No argument provided"
   } else {
      my ($incoming_mask);
      chomp ($incoming_mask = $_[0]);
      if (IsValidIP ($incoming_mask, 'bin')) {
         $incoming_mask =~ m/^1*0*$/;
      } else {
         return 0;
      };
   };
};

sub IsValidMaskDottedQuad {
   if (not defined ($_[0])) {
      wcarp "No argument provided"
   } else {
      my ($incoming_mask);
      chomp ($incoming_mask = $_[0]);
      if (IsValidIP ($incoming_mask, 'dq')) {
         (DottedQuad2Bin ($incoming_mask)) =~ m/^1*0*$/
      } else {
         return 0;
      };
   };
};

sub IsValidMaskHex {
   if (not defined ($_[0])) {
      wcarp "No argument provided"
   } else {
      my ($incoming_mask);
      chomp ($incoming_mask = $_[0]);
      if (IsValidIP ($incoming_mask, 'hex')) {
         (Hex2Bin ($incoming_mask)) =~ m/^1*0*$/
      } else {
         return 0;
      };
   };
};

sub IsValidMaskDec {
   if (not defined ($_[0])) {
      wcarp "No argument provided"
   } else {
      my ($incoming_mask);
      chomp ($incoming_mask = $_[0]);
      if (IsValidIP ($incoming_mask, 'dec')) {
         (Dec2Bin (incoming_mask)) =~ m/^1*0*$/;
      } else {
         return 0;
      };
   };
};

# the conversion subroutines.  most use pack and unpack to convert to
# and from various formats; the dotted quad ones also use split and join
# to break the numbers into dotted quads (obviously).
sub DottedQuad2Dec {
   if (not defined ($_[0])) {
      wcarp "No argument provided";
   } else {
      my ($incoming_value);
      chomp ($incoming_value = $_[0]);
      if (IsValidIP ($incoming_value, 'dq')) {
         return unpack ('N', pack ('C4', split (/\./, $incoming_value)));
      } else {
         wcroak "Invalid dotted-quad IPv4 value";
      };
   };
};

sub Dec2DottedQuad {
   if (not defined ($_[0])) {
      wcarp "No argument provided";
   } else {
      my ($incoming_value);
      chomp ($incoming_value = $_[0]);
      if (IsValidIP ($incoming_value, 'dec')) {
         return join ('.', unpack ('C4', pack ('N', $incoming_value)));
      } else {
         wcroak "Invalid decimal IPv4 value";
      };
   };
};

sub DottedQuad2Bin {
   if (not defined ($_[0])) {
      wcarp "No argument provided";
   } else {
      my ($incoming_value);
      chomp ($incoming_value = $_[0]);
      if (IsValidIP ($incoming_value, 'dq')) {
         return unpack ('B32', pack ('C4', split (/\./, $incoming_value)));
      } else {
         wcroak "Invalid dotted-quad IPv4 value";
      };
   };
};

sub Bin2DottedQuad {
   if (not defined ($_[0])) {
      wcarp "No argument provided";
   } else {
      my ($incoming_value);
      chomp ($incoming_value = $_[0]);
      if (IsValidIP ($incoming_value, 'bin')) {
         return join ('.', unpack ('C4',
            pack ('B32', substr ("0" x 32 . $incoming_value, -32))));
      } else {
         wcroak "Invalid binary IPv4 value";
      };
   };
};

sub DottedQuad2Hex {
   if (not defined ($_[0])) {
      wcarp "No argument provided";
   } else {
      my ($incoming_value);
      chomp ($incoming_value = $_[0]);
      if (IsValidIP ($incoming_value, 'dq')) {
         return unpack ('H8', pack ('C4', split (/\./, $incoming_value)));
      } else {
         wcroak "Invalid dotted-quad IPv4 value";
      };
   };
};

sub Hex2DottedQuad {
   if (not defined ($_[0])) {
      wcarp "No argument provided";
   } else {
      my ($incoming_value);
      chomp ($incoming_value = $_[0]);
      if (IsValidIP ($incoming_value, 'hex')) {
         return join ('.', unpack ('C4',
            pack ('H8', substr ("0" x 8 . $incoming_value, -8))));
      } else {
         wcroak "Invalid hexadecimal IPv4 value";
      };
   };
};

sub Hex2Bin {
   if (not defined ($_[0])) {
      wcarp "No argument provided";
   } else {
      my ($incoming_value);
      chomp ($incoming_value = $_[0]);
      if (IsValidIP ($incoming_value, 'hex')) {
         return unpack ('B32',
            pack ('H8', substr ("0" x 8 . $incoming_value, -8)));
      } else {
         wcroak "Invalid hexadecimal IPv4 value";
      };
   };
};

sub Bin2Hex {
   if (not defined ($_[0])) {
      wcarp "No argument provided";
   } else {
      my ($incoming_value);
      chomp ($incoming_value = $_[0]);
      if (IsValidIP ($incoming_value, 'bin')) {
         return unpack ('H8',
            pack ('B32', substr ("0" x 32 . $incoming_value, -32)));
      } else {
         wcroak "Invalid binary IPv4 value";
      };
   };
};

sub Dec2Bin {
   if (not defined ($_[0])) {
      wcarp "No argument provided";
   } else {
      my ($incoming_value);
      chomp ($incoming_value = $_[0]);
      if (IsValidIP ($incoming_value, 'dec')) {
         return unpack ('B32', pack ('N', $incoming_value));
      } else {
         wcroak "Invalid decimal IPv4 value";
      };
   };
};

sub Bin2Dec {
   if (not defined ($_[0])) {
      wcarp "No argument provided";
   } else {
      my ($incoming_value);
      chomp ($incoming_value = $_[0]);
      if (IsValidIP ($incoming_value, 'bin')) {
         return unpack ('N', 
            pack ('B32', substr ("0" x 32 . $incoming_value, -32)));
      } else {
         wcroak "Invalid binary IPv4 value";
      };
   };
};

sub Dec2Hex {
   if (not defined ($_[0])) {
      wcarp "No argument provided";
   } else {
      my ($incoming_value);
      chomp ($incoming_value = $_[0]);
      if (IsValidIP ($incoming_value, 'dec')) {
         return unpack ('H8', pack ('N', $incoming_value));
      } else {
         wcroak "Invalid decimal IPv4 value";
      };
   };
};

sub Hex2Dec {
   if (not defined ($_[0])) {
      wcarp "No argument provided";
   } else {
      my ($incoming_value);
      chomp ($incoming_value = $_[0]);
      if (IsValidIP ($incoming_value, 'hex')) {
         return unpack ('N', 
            pack ('H8', substr ("0" x 8 . $incoming_value, -8)));
      } else {
         wcroak "Invalid hexadecimal IPv4 value";
      };
   };
};

sub CIDR2DottedQuad {
   if (not defined ($_[0])) {
      wcarp "No argument provided";
   } else {
      my ($incoming_value);
      chomp ($incoming_value = $_[0]);
      if (IsValidMask ($incoming_value, 'cidr')) {
         return Bin2DottedQuad (2 ** $incoming_value);
      } else {
         wcroak "Invalid CIDR IPv4 mask value";
      };
   };
};

sub DottedQuad2CIDR {
   if (not defined ($_[0])) {
      wcarp "No argument provided";
   } else {
      my ($incoming_value);
      chomp ($incoming_value = $_[0]);
      if (IsValidMask ($incoming_value, 'dq')) {
         # since we know this is a valid mask, we can just count the 1s,
         # by getting the return value of a tr with no substitution.  The
         # temp value is so that tr is working on an assignment to a variable
         # rather than on the subroutine itself.
         return ((my $temp = DottedQuad2Bin ($incoming_value)) =~ tr/1//);
      } else {
         wcroak "Invalid dotted-quad IPv4 mask value";
      };
   };
};

sub CIDR2Bin {
   if (not defined ($_[0])) {
      wcarp "No argument provided";
   } else {
      my ($incoming_value);
      chomp ($incoming_value = $_[0]);
      if (IsValidMask ($incoming_value, 'cidr')) {
         return (2 ** $incoming_value);
      } else {
         wcroak "Invalid CIDR IPv4 mask value";
      };
   };
};

sub Bin2CIDR {
   if (not defined ($_[0])) {
      wcarp "No argument provided";
   } else {
      my ($incoming_value);
      chomp ($incoming_value = $_[0]);
      if (IsValidMask ($incoming_value, 'bin')) {
         return ($incoming_value =~ tr/1//);
      } else {
         wcroak "Invalid binary IPv4 mask value";
      };
   };
};

sub CIDR2Hex {
   if (not defined ($_[0])) {
      wcarp "No argument provided";
   } else {
      my ($incoming_value);
      chomp ($incoming_value = $_[0]);
      if (IsValidMask ($incoming_value, 'cidr')) {
         return Bin2Hex (2 ** $incoming_value);
      } else {
         wcroak "Invalid CIDR IPv4 mask value";
      };
   };
};

sub Hex2CIDR {
   if (not defined ($_[0])) {
      wcarp "No argument provided";
   } else {
      my ($incoming_value);
      chomp ($incoming_value = $_[0]);
      if (IsValidMask ($incoming_value, 'hex')) {
         # since we know this is a valid mask, we can just count the 1s,
         # by getting the return value of a tr with no substitution.  The
         # temp value is so that tr is working on an assignment to a variable
         # rather than on the subroutine itself.
         return ((my $temp = Hex2Bin ($incoming_value)) =~ tr/1//);
      } else {
         wcroak "Invalid hexadecimal IPv4 mask value";
      };
   };
};

sub CIDR2Dec {
   if (not defined ($_[0])) {
      wcarp "No argument provided";
   } else {
      my ($incoming_value);
      chomp ($incoming_value = $_[0]);
      if (IsValidMask ($incoming_value, 'cidr')) {
         return Bin2Dec (2 ** $incoming_value);
      } else {
         wcroak "Invalid CIDR IPv4 mask value";
      };
   };
};

sub Dec2CIDR {
   if (not defined ($_[0])) {
      wcarp "No argument provided";
   } else {
      my ($incoming_value);
      chomp ($incoming_value = $_[0]);
      if (IsValidMask ($incoming_value, 'dec')) {
         # since we know this is a valid mask, we can just count the 1s,
         # by getting the return value of a tr with no substitution.  The
         # temp value is so that tr is working on an assignment to a variable
         # rather than on the subroutine itself.
         return ((my $temp = Dec2Bin ($incoming_value)) =~ tr/1//);
      } else {
         wcroak "Invalid decimal IPv4 mask value";
      };
   };
};

# the fun subroutines.

# EnumerateNetAddrs (Network/Mask, [NetFormat/MaskFormat]) will return
# a list of all valid IP addresses in the specified netblock.
# EnumerateNetNodes does the same after stripping off the network and
# broadcast addresses.
sub EnumerateNetAddrs {
   my ($net_format, $net_value, $mask_format, $mask_value, @net_addrs);
   if (defined ($_[1])) {
      ($net_format, $mask_format) = split (/\//, $_[1])
   } else {
      ($net_format, $mask_format) = ('dq', 'cidr');
   };
   if (defined ($_[0])) {
      ($net_value, $mask_value) = split (/\//, $_[0])
   } else {
      (my $funcname = (caller(0))[3]) =~ s/([^:]*::)*//;
      croak "No network specified for ${funcname} to enumerate!" ;
   };
   if (IsValidIP ($net_value, $net_format)) {
      if (IsValidMask ($mask_value, $mask_format)) {
      
      } else {
         return;
      };
   } else {
      return;
   };
};

sub EnumerateNetNodes {
};

# IsValidSubnetIP will check to see if a given IP address is a valid member
# of a given subnet.  IsValidSubnetNode will do the same, but will also
# return false if the IP address would conflict with the network or
# broadcast addresses for the subnet.  I'm not implementing these yet, as
# I think I need to use a more object-oriented approach given the number of
# parameters that these routines should allow.  I should then go back and do
# the same for the EnumerateNet* routines.

# SummarizeNetAddrs will turn an array of addresses into a set of
# network numbers with netmasks.  By default, it will create the "most 
# concise" description of that block of addresses; I may give it some 
# options, though.
sub SummarizeNetAddrs {                                     
};