/usr/share/perl5/ipv4pack.pm

# Copyright (c) 1998,2001					RIPE NCC
#
# All Rights Reserved
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted,
# provided that the above copyright notice appear in all copies and that
# both that copyright notice and this permission notice appear in
# supporting documentation, and that the name of the author not be
# used in advertising or publicity pertaining to distribution of the
# software without specific, written prior permission.
#
# THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS; IN NO EVENT SHALL
# AUTHOR BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY
# DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN
# AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

#------------------------------------------------------------------------------
# Module Header
# Filename          : ipv4pack.pm
# Purpose           : provide translation functions for the different address
#			space notations, and other ip functionalities
# Author            : Monica Cortes
# Date              : August 1998
# Description       :
# Language Version  : Perl (Tested with v5.00401 and v5.00404)
# OSs Tested        : BSD/OS 3.1
# Command Line      : -
# Input Files       : -
# Output Files      : -
# External Programs : -
# Problems          :
# To Do             : 
# Comments          : most of these routines where taken form 
#			/ncc/db/dbase/src/net2net.pl coded originally by D.
#			Kessens. I have added comments! and made some changes
#			to adapt it to be a module and be able to work with
#			use strict, added more checks where relvant. (19980626)
# Comments          : the exported variables are used by the routines and
#			taken from /ncc/db/dbase/src/defines.pl (19980626)
# Comments	    : there are some non exported routines
# Comments	    : NOT all routines make all the checking! To manipulate
#			IPs the best is to use integers, so use
#				1- normalizerange
#				2- quad2int
#			To go back to a prefix or quad notation after
#			manipulation use
#				1- range2prefixes
#			  or	2- int2quad
#------------------------------------------------------------------------------
#
# Changes	: 19981130 Monica 
#			new exported routine normalizerange121 to comply 
#			with RIPE 121 document (outdated but still 
#			valid), new control value to indicate that
#			a range has been treated classfull
#
# Changes       : 19990527 Monica
#			changes to normalizerange121
#                       there are inetnums with only one IP address
#                       the routine treated this as "systax error" 
#                       will now be treated as a /32 with a proper warning code
#
# Changes	: 20001115 BaT
#			add a function to translate error code into string			
# Changes	: 20010410 BaT
#			add handling of encompassing object as valid one
#			fixed bunch of typos

require 5.004;

package ipv4pack;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

require Exporter;

@ISA = qw(Exporter);

use vars qw($O_OK $O_NOK $O_PRIVATERANGE $O_INVALIDIP $O_INVALIDPREFIX 
	$O_INVALIDRANGE $O_SYNTAXERROR $O_NOVERLAP $O_OVERLAP $O_BINAOVERLAP 
	$O_AINBOVERLAP $O_RESERVEDCLASS $O_CLASSFULL $O_IPADDRONLY);

@EXPORT=qw($O_OK $O_NOK $O_PRIVATERANGE $O_INVALIDIP $O_INVALIDPREFIX 
	$O_INVALIDRANGE $O_SYNTAXERROR $O_NOVERLAP $O_OVERLAP $O_BINAOVERLAP 
	$O_AINBOVERLAP $O_RESERVEDCLASS $O_CLASSFULL  $O_IPADDRONLY 
	&quad2int &int2quad &normalizerange &range2prefixes &testoverlap 
	&aggregate &normalizerange121 &error2str);

@EXPORT_OK=qw($O_OK $O_NOK $O_PRIVATERANGE $O_INVALIDIP $O_INVALIDPREFIX 
	$O_INVALIDRANGE $O_SYNTAXERROR $O_NOVERLAP $O_OVERLAP $O_BINAOVERLAP 
	$O_AINBOVERLAP $O_RESERVEDCLASS $O_CLASSFULL  $O_IPADDRONLY 
	&quad2int &int2quad &normalizerange &range2prefixes &testoverlap 
	&aggregate &normalizerange121 &error2str);


$VERSION = '1.04';

#
# these are error codes for checking the results of the
# different net-routines
#
$O_OK		=	1;		# no problem found
$O_NOK		=	0;		# an unknown problem was found

$O_IPADDRONLY	=	20;		# range treated as an /32 only
$O_CLASSFULL	=	21;		# ip treated as of classfull ranges
$O_RESERVEDCLASS=	22;		# ip from reserved range was given
$O_PRIVATERANGE	=	23;		# ip from private range was given
$O_INVALIDIP	=	24;		# wrong ip was given
$O_INVALIDPREFIX=	25;		# invalid index was given
$O_INVALIDRANGE	=	26;		# invalid range was given
$O_SYNTAXERROR	=	27;		# syntax error was found

$O_NOVERLAP	=	-1;		# no overlap between two ranges
$O_OVERLAP	=	100;		# overlap between two ranges
$O_AINBOVERLAP  =	101;		# range A is part of range B
$O_BINAOVERLAP	=	110;		# range B is part of range A

# Correspondence between error codes and their meaning
my %errorcode = (
	$O_OK		=> "No problems were found",
	$O_NOK		=> "An unknown problem was found",
	
	$O_IPADDRONLY	=> "Range treated as an /32 only",
	$O_CLASSFULL	=> "IP treated as of classfull ranges",
	$O_RESERVEDCLASS=> "IP from reserved range was given",
	$O_PRIVATERANGE	=> "IP from private range was given",
	$O_INVALIDIP	=> "Wrong IP was given",
	$O_INVALIDPREFIX=> "Invalid index was given",
	$O_INVALIDRANGE	=> "Invalid range was given",
	$O_SYNTAXERROR	=> "Syntax error was found",
	
	$O_NOVERLAP	=> "No overlap between two ranges",
	$O_OVERLAP	=> "Overlap between two ranges",
	$O_AINBOVERLAP	=> "Range A is part of the range B",
	$O_BINAOVERLAP	=> "Range B is part of the range A"
	);

#
# these variables are just constants for obtaining prefix lengths
#
# TINYLOGVALUE is important if the range for which one wants to optain a
#	prefix is very big. The algorithm for obtaining the prefix relies
#	on the integer part of a logarithm (log(x)). If x is small, there
#	are no problems, but if x is big, the precision of the log can be
#	insufficient to give the correct int value (think of (2**32-1)).
#	TINYLOGVALUE is used to force precision on this cases and is
#	sufficiently small to let the other cases un-affected.
#
my($ONEDIVLOG2)=1/log(2);				# log constant
my($TINYLOGVALUE)=(32-(log(2**32-1)*$ONEDIVLOG2))/100;	# another log constant
my @masks= (0x0,
	0x80000000, 0xc0000000, 0xe0000000, 0xf0000000,
	0xf8000000, 0xfc000000, 0xfe000000, 0xff000000,
	0xff800000, 0xffc00000, 0xffe00000, 0xfff00000,
	0xfff80000, 0xfffc0000, 0xfffe0000, 0xffff0000,
	0xffff8000, 0xffffc000, 0xffffe000, 0xfffff000,
	0xfffff800, 0xfffffc00, 0xfffffe00, 0xffffff00,
	0xffffff80, 0xffffffc0, 0xffffffe0, 0xfffffff0,
	0xfffffff8, 0xfffffffc, 0xfffffffe, 0xffffffff ); # network masks


##
##
## exported functions
##
##

##
#
#
#------------------------------------------------------------------------------
# Subroutine Header
# Purpose           : translate an quad written IP number into a long int
# Side Effects      :
# Comments          :
# Exported Routine  : yes
# Routine Arguments :	scalar value of an IP in quad notation
# Return values     : 	-1 		if wrong quad number
#			long int	translation of quad to int
#------------------------------------------------------------------------------
#
sub quad2int ($) {
  my($quad) = @_;

  # split quad into each byte
  my(@bytes) = split(/\./, $quad);

  # check the value of each byte [0,255] and pack the info 
  return unpack("N",pack("C4",@bytes)) if
    (@bytes == 4 && scalar(grep {$_>=0 && $_<=255} @bytes) == 4);

  return(-1);
}

##
#
#------------------------------------------------------------------------------
# Subroutine Header
# Purpose           : translate an IP written as long int into a quad
# Side Effects      :
# Comments          : different perl versions handle variables differently
#			in the sense that the default is on some "string" in
#			others "int". To avoid problems a very ugly hack is
#			put in place to make sure perl handles it as a number
# Exported Routine  : yes
# Routine Arguments :	scalar value of an IP in long int notation
# Return values     :   scalar quad     translation of int to quad
#			-1		if wrong int
#------------------------------------------------------------------------------
#
sub int2quad ($) {
   my($integer)=@_;
   my($MaxValidInt)=4294967295;		# int corresponding to 255.255.255.255 

   # here are some checks of the int value, it has to be bigger than 0
   # but smaller than the highest ip possible: 255.255.255.255
   return -1 if ($integer !~ /^\d+$/ || $integer < 0 || 
					$integer > $MaxValidInt);

   # ugly hack
   $integer += 0;

   return join(".", unpack("C4",pack("N",$integer)));
}



##
#
#------------------------------------------------------------------------------
# Subroutine Header
# Purpose           : gets a range as argument and tries to identify the 
#			range notation and translate it into quad - quad format
# Side Effects      :
# Comments          : it understands following notations:
#			quad - quad
#			quad/prefix
#			quad	(class-full ip)
#
#	      it checks for the use of private ips and reserved classes:
#
#		quad					int value
#	0.0.0.0	    - 0.255.255.255
#	10.0.0.0    - 10.255.255.255		
#	127.0.0.0   - 127.255.255.255
#	172.16.0.0  - 172.31.255.255 		2886729728 - 2887778303
#	192.168.0.0 - 192.168.255.255		3232235520 - 3232301055
#
#	Classes D,F and reserved
#	223.0.0.0   - 255.255.255.255
#
# Exported Routine  : yes
# Routine Arguments : scalar value with the range information in one
#			of the above notations
# Return values     : an array with a first field: 	quad - quad
#			and a second field:		errorcode
#------------------------------------------------------------------------------
#
sub normalizerange ($) {
    my($range)=@_;
    my($ip1);

    # test the syntax of $range 
    if ($range=~ /^(\d+)(\.[\.\d]*)?\s*([\/\-])\s*([\d\.]+)*$/) {
       # range is in format quad/prefix or quad - quad

       # check for a valid range: no CLASS-D and upper (223-255), no 127/8 
       # and no private networks allowed (10/8)
       return ("", $O_PRIVATERANGE) if ($1 eq "10" || $1 eq "127");
       return ("", $O_RESERVEDCLASS) if ($1 > 223);

       if ($3 eq '/') {	 # range is in format quad/prefix
          my($len)=$4;

	  # complete the trailing quads if missing
          ($range,$ip1)=&completeip(defined($2)?$1.$2:$1,0);
          return ("", $O_INVALIDIP) if ($ip1 < 0);

	  # check valid prefix and its mask
          if (($len=~ /^0*([12]?[\d]|3[012])$/) &&
              (!($ip1 & (~$masks[$len])))) {

	    my($ip2)=$ip1+(2**(32-$len)-1);

	    # BaT 20010410: We should reject 0/8, but accept 0/0 as legal
	    if($ip1 == 0) { 
		if($ip2 == 4294967295) {
		    return ($range." - ".int2quad($ip2), $O_OK);
		}
		elsif($ip2 <= 16777215) {
		    return ("", $O_RESERVEDCLASS);
		}
	     }

	     # check that it does not overlap a private network (172.16/12 &
	     # 192.168/16)
	     return ("",$O_PRIVATERANGE) unless 
		(&testoverlap("$ip1:$ip2","2886729728:2887778303") == -1);
	     return ("",$O_PRIVATERANGE) unless 
		(&testoverlap("$ip1:$ip2","3232235520:3232301055") == -1);

             return ($range." - ".int2quad($ip2), $O_OK);

          }

          return ("", $O_INVALIDPREFIX);

       } elsif ($3 eq '-') {	 # range is in format quad - quad
          my($torange)=$4;

          ($range,$ip1)=&completeip(defined($2)?$1.$2:$1,0);

          my($ip2);
          ($torange,$ip2)=&completeip($torange,1);
	  
	  # check that the quads where valid and the second is greater
          return ("", $O_INVALIDIP) if (($ip1 < 0) || ($ip2 < 0));
          return ("", $O_INVALIDRANGE) if ($ip2 < $ip1);
	  
	  # BaT 20010410: We should reject 0/8, but accept 0/0 as legal
	  if($ip1 == 0) { 
	    if($ip2 == 4294967295) {
    	      return ($range." - ".$torange, $O_OK);
	    }
	    elsif($ip2 <= 16777215) {
	      return ("", $O_RESERVEDCLASS);
	    }
	  }
	  
	  # check that it does not overlap a private network (172.16/12 &
	  # 192.168/16 )
	  return ("",$O_PRIVATERANGE) unless 
		(&testoverlap("$ip1:$ip2","2886729728:2887778303") == -1);
	  return ("",$O_PRIVATERANGE) unless 
		(&testoverlap("$ip1:$ip2","3232235520:3232301055") == -1);


          return ($range." - ".$torange, $O_OK);

       }

    } elsif ($range=~ /^(\d+)(\.[\.\d]*)?$/) {
       # range is in format quad it will be treated CLASSFULL so
       # the errorcodes will be $O_CLASSFULL

       return ("", $O_PRIVATERANGE) if($1=~ /^10|127$/);
       
       return ("", $O_RESERVEDCLASS) if($1 > 223 || $1 == 0);
       

       ($range,$ip1)=&completeip($range,0);
       
       return ("", $O_INVALIDIP) if ($ip1 < 0);

       # note that the order in the comparisons is important
       # *and* the order of the if's is important !!!

       if (($range=~ /^(\d+)(\.\d+\.\d+)\.0$/) &&
           ($1>=192)) {					# CLASS C

	  # check that it is not a private network 192.168/16
	  return ("",$O_PRIVATERANGE) if ( $1 == 192 && $2 =~ /^\.168/ );

          return ($1.$2.".0 - ".$1.$2.".255", $O_CLASSFULL);

       } elsif (($range=~ /^(\d+)(\.(\d+))\.0\.0$/) &&
              ($1>=128)) {				# CLASS B

	  # check that it is not a private network 172.16/12
	  return ("",$O_PRIVATERANGE) if ( $1 == 172 && 
		($3 >= 16 && $3 <= 31) );

          return ($1.$2.".0.0 - ".$1.$2.".255.255", $O_CLASSFULL);

       } elsif ($range=~ /^(\d+)\.0\.0\.0$/) {		# CLASS A

          return ($1.".0.0.0 - ".$1.".255.255.255", $O_CLASSFULL);
       }
    }
    return ("", $O_SYNTAXERROR);	 # nothing useful found
}



##
#
#------------------------------------------------------------------------------
# Subroutine Header
# Purpose           : gets a range as argument and tries to identify the
#                       range notation and translate it into quad - quad format
#			this routine is compliant with RIPE 121 document
# Side Effects      :
# Comments          : it understands following notations:
#                       quad - quad
#                       quad/prefix
#                       quad    (class-full ip)
#
#             it checks for the use of private ips and reserved classes:
#         
#               quad                                    int value
#       0.0.0.0     - 0.255.255.255
#       10.0.0.0    - 10.255.255.255
#       127.0.0.0   - 127.255.255.255
#       172.16.0.0  - 172.31.255.255            2886729728 - 2887778303
#       192.168.0.0 - 192.168.255.255           3232235520 - 3232301055
#         
#       Classes D,F and reserved
#       223.0.0.0   - 255.255.255.255
#
# Exported Routine  : yes
# Routine Arguments : scalar value with the range information in one
#                       of the above notations
# Return values     : an array with a first field:      quad - quad
#                       and a second field:             errorcode
#
# Changes	: 19981130 Monica
#			this routine was included to be compliant with 
#			RIPE 121 document which should be updated and then
#			this routine can be removed again
#
# Changes	: 19990527 Monica
#			there are inetnums with only one IP address
#			the routine treated this as "systax error" 
#			will now be treated as a /32 with a proper warning code
#------------------------------------------------------------------------------
#   
sub normalizerange121 ($) {
    my($range)=@_;
    my($ip1);
       
    # test the syntax of $range
    if ($range=~ /^(\d+)(\.[\.\d]*)?\s*([\/\-])\s*([\d\.]+)*$/) {
       # range is in format quad/prefix or quad - quad

       # check for a valid range: no CLASS-D and upper (223-255), no 127/8
       # and no private networks allowed (10/8)
       return ("", $O_PRIVATERANGE) if ($1 =~ /^10|127$/);
       return ("", $O_RESERVEDCLASS) if ($1 > 223);
          
       if ($3 eq '/') {         # range is in format quad/prefix
          my($len)=$4;

          # complete the trailing quads if missing
          ($range,$ip1)=&completeip(defined($2)?$1.$2:$1,0);
          return ("", $O_INVALIDIP) if ($ip1 < 0);
          
          # check valid prefix and its mask
          if (($len=~ /^0*([12]?[\d]|3[012])$/) &&
              (!($ip1 & (~$masks[$len])))) {
          
       	    my($ip2)=$ip1+(2**(32-$len)-1);

	    # BaT 20010410: We should reject 0/8, but accept 0/0 as legal
	    if($ip1 == 0) { 
		if($ip2 == 4294967295) {
		    return ($range." - ".int2quad($ip2), $O_OK);
		}
		elsif($ip2 <= 16777215) {
		    return ("", $O_RESERVEDCLASS);
		}
	     }

             # check that it does not overlap a private network (172.16/12 &
             # 192.168/16)
             return ("",$O_PRIVATERANGE) unless
                (&testoverlap("$ip1:$ip2","2886729728:2887778303") == -1);
             return ("",$O_PRIVATERANGE) unless
                (&testoverlap("$ip1:$ip2","3232235520:3232301055") == -1);
      
             return ($range." - ".&int2quad($ip2), $O_OK);
          }

          return ("", $O_INVALIDPREFIX);


       } elsif ($3 eq '-') {    # range is in format quad - quad
          my($torange)=$4;
	  my($errorcode)=$O_OK;

          ($range,$ip1)=&completeip(defined($2)?$1.$2:$1,0);

          my($ip2);
          ($torange,$ip2)=&completeip($torange,1);


          # check that the quads where valid and the second is greater
          return ("", $O_INVALIDIP) if (($ip1 < 0) || ($ip2 < 0));
          return ("", $O_INVALIDRANGE) if ($ip2 < $ip1);

	  # BaT 20010410: We should reject 0/8, but accept 0/0 as legal
	  if($ip1 == 0) { 
	    if($ip2 == 4294967295) {
    	      return ($range." - ".$torange, $O_OK);
	    }
	    elsif($ip2 <= 16777215) {
	      return ("", $O_RESERVEDCLASS);
	    }
	  }

          # check that it does not overlap a private network (172.16/12 &
          # 192.168/16)
          return ("",$O_PRIVATERANGE) unless
                (&testoverlap("$ip1:$ip2","2886729728:2887778303") == -1);
          return ("",$O_PRIVATERANGE) unless
                (&testoverlap("$ip1:$ip2","3232235520:3232301055") == -1);

	  # 19981130 Monica
	  # changes to routine normalizerange
	  my(@quads_ip1)=split(/\./,$range);
	  my(@quads_ip2)=split(/\./,$torange);
	  if ( $quads_ip1[-1] == 0 && $quads_ip2[-1] == 0 ) {
		# old classfull notation, check if it is an old CLASS C
		if ($quads_ip1[0] >= 192) {
			# replace ip2 last quad by 255
			$quads_ip2[-1] = 255;
	  		$torange=join('.',@quads_ip2);
			$errorcode=$O_CLASSFULL;
		} else {
			# NOT a CLASS C: do give an error, invalid range
			return ("", $O_INVALIDRANGE);
		}
	  }

          return ($range." - ".$torange, $errorcode);

       }

    } elsif ($range=~ /^(\d+)(\.[\.\d]*)?$/) {
       # range is in format quad it will be treated CLASSFULL

       return ("", $O_PRIVATERANGE) if($1=~ /^10|127$/);
       
       return ("", $O_RESERVEDCLASS) if($1 > 223 || $1 == 0);

       ($range,$ip1)=&completeip($range,0);
       return ("", $O_INVALIDIP) if ($ip1 < 0);

       # note that the order in the comparisons is important
       # *and* the order of the if's is important !!!

       if ($range !~ /\.0$/) {

	  # the last quad contains a non null argument
	  # it will be treated as on IP number => /32 with a 
	  # warning that it was treated as such
	  return ( $range." - ".$range, $O_IPADDRONLY);

       } elsif (($range=~ /^(\d+)(\.\d+\.\d+)\.0$/) &&
           ($1>=192)) {                                 # CLASS C

          # check that it is not a private network 192.168/16
          return ("",$O_PRIVATERANGE) if ( $1 == 192 && $2 =~ /^\.168/ );

          return ($1.$2.".0 - ".$1.$2.".255", $O_CLASSFULL);

       } elsif (($range=~ /^(\d+)(\.(\d+))\.0\.0$/) &&
              ($1>=128)) {                              # CLASS B

          # check that it is not a private network 172.16/12
          return ("",$O_PRIVATERANGE) if ( $1 == 172 &&
                ($3 >= 16 && $3 <= 31) );

          return ($1.$2.".0.0 - ".$1.$2.".255.255", $O_CLASSFULL);

       } elsif ($range=~ /^(\d+)\.0\.0\.0$/) {          # CLASS A

          return ($1.".0.0.0 - ".$1.".255.255.255", $O_CLASSFULL);
       }
    }
    return ("", $O_SYNTAXERROR);         # nothing useful found
}


##
#
#------------------------------------------------------------------------------
# Subroutine Header
# Purpose           : gets a range in the format "int - int" or "quad - quad"
#			and splits it into the necessary prefixes finding 
#			always the smallest prefix possible
# Side Effects      : 
# Comments          : No checks are performed on the validity of the ips
#			for checks use normalizerange and quad2int first
# Comments	    : To get the prefix decomposition of a range one
#			needs to do two things:
#			- get the smallest posible prefix, which depends
#				on the size of the range
#			- the mask for that prefix has to match the start
#				address of the range
# Exported Routine  : yes
# Routine Arguments : a scalar value with the range in "int - int" 
#			or "quad - quad" format
# Return values     : an array of ip-ranges in the format quad/prefix
#			or -1 	if a problem ocurred
#------------------------------------------------------------------------------
#
sub range2prefixes ($) {
    my(@prefixes)=();
    my($bits);
    my($ip1,$ip2)=split(/ \- /, $_[0], 2);

    $ip1=&quad2int($ip1) if ($ip1 =~ /\./); 	# quad notation
    $ip2=&quad2int($ip2) if ($ip2 =~ /\./); 	# quad notation
    
    # check ip1 and ip2
    return (-1) if ( $ip1 == -1 || $ip2 == -1 );


    do {

      # get smallest useful prefix length based on size of range.
      # $TINYLOGVALUE is used to account for the pecision lost by 
      # the log calculation on large range sizes (see definition of
      # TINYLOGVALUE at the begining of the module).
      $bits = 32-int(log($ip2-$ip1+1)*$ONEDIVLOG2+$TINYLOGVALUE);

      {
        use integer;       # for the following bitwise &

        # find smallest prefix that masks all bits of starting address of the
	# range
        until ($ip1 == ($ip1 & $masks[$bits])) {
          $bits++;
        }
      }
  
      push(@prefixes, &int2quad($ip1)."/".$bits);

      # add on block we've just found
      $ip1 += 2**(32-$bits);

      # stop when we've reached the top end of range
    } until (($ip1-1) == $ip2);


    return @prefixes;
}


##
#
#------------------------------------------------------------------------------
# Subroutine Header
# Purpose           : gets two ip ranges in the format "int [-:] int" or
#			"quad [-:] quad" and test if they overlap and what 
#                       type of overlap
# Side Effects      :
# Comments          :
# Exported Routine  : yes
# Routine Arguments : two scalar variables,
#                       1- range A in format "int [-:] int" or "quad [-:] quad"
#                       2- range B in format "int [-:] int" or "quad [-:] quad"
# Return values     : a scalar value indicating the type of overlap
#------------------------------------------------------------------------------
#
sub testoverlap {
    my($rangeA,$rangeB)=@_;
    my($Aip1,$Aip2,$Bip1,$Bip2);

    if ($rangeA =~ /^\s*(\S*)\s*[\-:]\s*(\S*)\s*$/ ) {
        $Aip1=$1;
        $Aip2=$2;
        $Aip1=&quad2int($Aip1) if ( $Aip1 =~ /\./ );
        $Aip2=&quad2int($Aip2) if ( $Aip2 =~ /\./ );
        return $O_INVALIDRANGE if ($Aip1 == -1 || $Aip2 == -1);
    } else {
        return $O_SYNTAXERROR;  #wrong syntax
    }
    return $O_INVALIDRANGE if ($Aip1 > $Aip2);  #wrong syntax


    if ($rangeB =~ /^\s*(\S*)\s*[\-:]\s*(\S*)\s*$/ ) {
        $Bip1=$1;
        $Bip2=$2;
        $Bip1=&quad2int($Bip1) if( $Bip1 =~ /\./ );
        $Bip2=&quad2int($Bip2) if( $Bip2 =~ /\./ );
        return $O_INVALIDRANGE if ($Bip1 == -1 || $Bip2 == -1);
    } else {
        return $O_SYNTAXERROR;  #wrong syntax
    }
    return $O_INVALIDRANGE if ($Bip1 > $Bip2);  #wrong syntax


    # test if both ranges overlap
    if ( $Bip1 <= $Aip2 && $Bip2 >=$Aip1 ) {
	# range A is part of range B
        return $O_AINBOVERLAP if ( $Bip1 <= $Aip1 && $Bip2 >=$Aip2 );
	# range B is part of range A
        return $O_BINAOVERLAP if ( $Bip1 >= $Aip1 && $Bip2 <=$Aip2 );
	# partial overlap only
        return $O_OVERLAP;
    }


    return $O_NOVERLAP;         # no overlap

}


##
#
#------------------------------------------------------------------------------
# Subroutine Header
# Purpose           : gets two ip ranges in the format "int [-:] int" or
#			"quad [-:] quad" and checks if they are aggregatable
# Side Effects      :
# Comments          : only checks if the second range is contiguos with the
#			first range
# Comments          : To get the prefix of a range one needs to do:
#                       - get the smallest posible prefix, which depends
#                               on the size of the range
#			- check that the size of the prefix found accounts
#				for the complete range size
#                       - the mask for that prefix has to match the start
#                               address of the range
# Exported Routine  : yes
# Routine Arguments : two scalar variables,
#                       1- range A in format "int [-:] int" or "quad [-:] quad"
#                       2- range B in format "int [-:] int" or "quad [-:] quad"
# Return values     : a scalar value indicating 
#				the aggregate in quad/prefix
#			or	-1 if not aggregatable
#------------------------------------------------------------------------------
#
sub aggregate {
    my($rangeA,$rangeB)=@_;
    my($Aip1,$Aip2,$Bip1,$Bip2);

    if ($rangeA =~ /^\s*(\S*)\s*[\-:]\s*(\S*)\s*$/ ) {
        $Aip1=$1;
        $Aip2=$2;
        $Aip1=&quad2int($Aip1) if ( $Aip1 =~ /\./ );
        $Aip2=&quad2int($Aip2) if ( $Aip2 =~ /\./ );
        return $O_INVALIDRANGE if ($Aip1 == -1 || $Aip2 == -1);
    } else {
        return $O_SYNTAXERROR;  #wrong syntax
    }
    return $O_INVALIDRANGE if ($Aip1 > $Aip2);   #wrong syntax


    if ($rangeB =~ /^\s*(\S*)\s*[-:]\s*(\S*)\s*$/ ) {
        $Bip1=$1;
        $Bip2=$2;
        $Bip1=&quad2int($Bip1) if( $Bip1 =~ /\./ );
        $Bip2=&quad2int($Bip2) if( $Bip2 =~ /\./ );
        return $O_INVALIDRANGE if ($Bip1 == -1 || $Bip2 == -1);
    } else {
        return $O_SYNTAXERROR;  #wrong syntax
    }
    return $O_INVALIDRANGE if ($Bip1 > $Bip2);   #wrong syntax


    # test contiguity
    return -1 unless ( ($Aip2+1) == $Bip1 );


    # get smallest useful prefix length based on size of range.
    # $TINYLOGVALUE is used to account for the pecision lost by
    # the log calculation on large range sizes (see definition of
    # TINYLOGVALUE at the begining of the module).
    my($bits)=32-int(log($Bip2-$Aip1+1)*$ONEDIVLOG2+$TINYLOGVALUE);


    # check that the prefix found accounts for the size of the range
    return -1 unless ( ($Bip2-$Aip1+1) == (2**(32-$bits)));

    
    use integer; 		# for the following bitwise &
    if ($Aip1 == ($Aip1 & $masks[$bits])) {
	return &int2quad($Aip1).'/'.$bits;
    }

    # ranges are not aggregatable
    return -1;
}



##
## non exported subroutines
##
##

##
#
#------------------------------------------------------------------------------
# Subroutine Header
# Purpose           : gets an ip in quad format of any length and tries
#                       to complete it with as many trailing ".0" as necessary
# Side Effects      :
# Comments          : 
# Exported Routine  : no (called by normalizerange)
# Routine Arguments : two scalar variables, 
#			1- ip quad to complete
#			2- flag to know if it completes the ip with 0 o 255
#				0		completes with .0
#				>0		completes with .255
# Return values     : an array of two field:
#			first field:		completed quad
#			second field:		integer value of the quad
#							or
#						-1 if there was a problem
#------------------------------------------------------------------------------
#   
sub completeip {
    my($range,$type)=@_;
    my($int,$CompleteQuad);

    # what do we complete with?
    if ($type) {
	$CompleteQuad='.255';
    } else {
	$CompleteQuad='.0';
    }

    # clean up the range of trailing dots
    $range=~ s/\.*$//;

    # get number of valid dots
    my($nrofdots)= $range=~ s/\./\./g;

    # complete the quad with trailing .0
    $range=join("", $range, ("$CompleteQuad") x (3 - $nrofdots)) 
			if ($nrofdots<3);


    # get the int value of the completed quad
    if (($int=&quad2int($range))>=0) {

       return (&int2quad($int),$int);

    }

    # nothing valid found

    return ("",-1);

}


##
#
#------------------------------------------------------------------------------
# Subroutine Header
# Purpose           : conver error code into the string
# Side Effects      : 
# Comments          : BaT 20001115
# Exported Routine  : yes
# Routine Arguments : error code if any
# Return values     : an error string
#------------------------------------------------------------------------------
#

sub error2str {
    my($code) = @_;
    
    my $str = $errorcode{$code};
    # Return the string if exists
    return $str if($str);
    # Nothing to return
    return "";
}

1;
asused 3.72-12 / usr / share / perl5 / ipv4pack.pm
