CIDR::Assign - Manage assignments out of a group of CIDR blocks

CIDR-Assign documentation Contained in the CIDR-Assign distribution.

Index

Code Index:

NAME

Top

CIDR::Assign - Manage assignments out of a group of CIDR blocks

SYNOPSIS

Top

use CIDR::Assign;

$obj = CIDR::Assign->new($filename);

$obj->DESTROY;

$network = $obj->assignNetwork($length, $customer, $ones, $zeros, $location);

$obj->changeState($network, $state, $customer, $location);

$obj->initialiseBlock($network);

($network, $state, $date, $customer, $location) = $obj->iterateAllocations;

DESCRIPTION

Top

This module can be used to manage customer assigments out of a provider block. The CIDR block is represented as a B-Tree in a Berkeley DB database and is originally populated by invoking initialiseBlock with each provider block.

new will create the DB file, whose name is passed as a parameter, if necessary, and then tie it to an internal hash used by the other routines. This routine attempts to acquire a lock on the DB file using lockf in an attempt to control access to the file. Should acquiring the lock fail the routine will return "undef".

DESTROY closes the DB file and releases the lock on the file.

Networks can be allocated out of the assigned blocks by calling assignNetwork specifying the size of the block required. The system then scans the tree for a "free" block that is of the required size. If a block isn't available then it splits the next largest block and invokes itself. Should there be no free block available for allocation then the routing returns "undef".

The parameters "ones" and "zeroes" are used to indicate if the allocation can make use of an all ones or all zeros network if necessary.

The parameter "location" is optional but if present and the allocation is smaller than a /24 it will try to choose a block in the same location as other allocations in order to avoid too much fragmentation of the address space.

changeState can be used to change the state of a block in the free, for example, to add existing allocations to the tree or return an allocation to the free pool.

initialiseBlock adds a new block into the allocation pool.

iterateAllocations allows the caller to traverse the tree, much like "each", and returns a list of information about each allocation. This list is comprised of network, state (currently 'taken', 'free' or 'holding'), date of last operation and customer indentifer (and possibly location) if the block is not free.

errorMessage return a string suitable for printing that describes the latest error condition.

AUTHOR

Top

Mark Prior <mrp@connect.com.au>

Original idea and code by Andrew Rutherford <andrewr@iagu.net>

NOTES

Top

This module uses the following modules

DB_File

The Berkeley DB is used for storage of the allocations, in B-Tree format.

File::lockf

The allocations file is locked with lockf to avoid problems with NFS.

CIDR-Assign documentation Contained in the CIDR-Assign distribution. 
package CIDR::Assign;

# $Id: Assign.pm,v 1.14 1998/05/28 02:50:02 mrp Exp $


# The B-Tree is keyed to the address, which is "normalised" into CIDR length
# form where the address component always contains 4 octets.
#
# The value of each element is constructed as a series of $separator terminated
# strings which are interpreted as key/value pairs.
#
# The keys present in the element are
#	state		- 'free', 'taken' or 'holding' (required)
#	date		- date of the last operation on the block (required)
#	customer	- some customer "code", at Connect this a customer ID
#	location	- a location code, Connect use a 3 letter city code
#

require 5.003;
require Exporter;

use Carp;
use FileHandle;
use DB_File;
use File::lockf;

$VERSION = '0.01';	# should be tied to the RCS rev eventually

($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time);
$today = sprintf "%4d%02d%02d", $year+1900, $mon+1, $mday,

%states = (
	free	=> 'unallocated',
	taken	=> 'allocated',
	holding	=> 'being considered for reuse',
);

%messages = (
	OK	=> '',
	LENGTH	=> 'Length of request is invalid, must be between 2 and 32',
	NOMATCH	=> 'No suitable allocation available',
	STATE	=> 'New state "%s" is unrecognised',
	NETWORK	=> 'Network "%s" is invalid, illegal octet value %s',
	RANGE	=> 'Network not within the allocation pool',
	OVERLAP	=> 'New block "%s" overlaps existing allocation',
);

$separator = chr(0);

@ISA	= qw(Exporter);
@EXPORT	= qw($VERSION new DESTROY assignNetwork changeState iterateAllocations
		errorMessage);
@EXPORT_OK = qw(compareIP maskOfLength parseNet printIP overlap);

sub compareIP {
	my($netA, $lenA) = split(/\//, shift);
	my($netB, $lenB) = split(/\//, shift);
	my(@a) = split(/\./, $netA);
	my(@b) = split(/\./, $netB);

	return $a[0] <=> $b[0] || $a[1] <=> $b[1]
		|| $a[2] <=> $b[2] || $a[3] <=> $b[3]
		|| $lenA <=> $lenB;
}

sub new {


	my($class) = shift;
	my($i, %hash);
	my($self) = {
		NAME	=> shift,
		FILE	=> new FileHandle,
		DB	=> undef,
		POS	=> undef,
		ERROR	=> 'OK',
		PARAMS	=> undef,
		};

	$DB_BTREE->{'compare'} = \&compareIP;

	unless ( $self->{DB} = tie(%hash, 'DB_File', $self->{NAME},
		O_CREAT|O_RDWR, 0660, $DB_BTREE) ) {
		carp "dbopen failed: $!\n";
		return undef;
	}

	$self->{FILE}->fdopen($self->{DB}->fd, "r+") || die "fdopen: $!\n";
	if ( File::lockf::tlock( $self->{FILE} ) != 0 ) {
		# wait for the lock
		my($i);
		for ( $i = 5; $i > 0 ; $i-- ) {
			sleep 5;
			break if File::lockf::tlock( $self->{FILE} ) == 0;
		}
		if ( $i == 0 ) {
			carp "Unable to acquire lock on DB\n";
			undef $self->{DB};
			$self->{FILE}->close;
			return undef;
		}
	}
	return bless ($self, ref $class || $class);
}

sub DESTROY {


	my($self) = shift;

	return unless defined $self->{DB};
	File::lockf::ulock( $self->{FILE} );
	$self->{FILE}->close;
	undef $self->{DB};
}

sub assignNetwork {


	my($self) = shift;
	my($length, $customer, $ones, $zeroes, $location) = @_;
	my($status, $network, $value, $bits);
	my($spare, $match, $contents) = '';
	my($smallest) = 0;
	my($timestamp) = undef;
	my(%hash);

	# Sanity check.
	if ( $length < 2 || $length > 32 ) {
		$self->{ERROR} = 'LENGTH';
		return undef;
	}

	$location = lc $location;

	# Look for a free block that matches our requirements
	for ( $status = $self->{DB}->seq($network, $value, R_FIRST);
	    $status == 0;
	    $status = $self->{DB}->seq($network, $value, R_NEXT) ) {
		%hash = split($separator, $value);
		next unless $hash{'state'} eq 'free';
		$network =~ /\/(\d+)$/;
		$bits = $1;
		next if $length > 24
			&& $location ne '' && $hash{'location'} ne $location;
		if ( $bits > $length ) {	# Too small.
			next;
		} elsif ( $bits == $length ) {	# Match
			next if $match ne ''
				&& defined $timestamp && $hash{'date'} >= $timestamp;
			if ( $ones && $zeroes ) {
				$timestamp = $hash{'date'};
				$match = $network;
			} elsif ( $network =~ /^\d+\.\d+\.(\d+)\.\d+\// ) {
				my $subnet = $1;
				if ( ( $subnet != 0 && $subnet != 255 )
				    || ( $subnet == 0 && $zeroes )
				    || ( $subnet == 255 && $ones ) ) {
					$timestamp = $hash{'date'};
					$match = $network;
				}
			}
		} elsif ( $match eq '' ) {
			$network =~ /^\d+\.\d+\.(\d+)\.\d+\//;
			next if $bits >= 24
			    && ( ( $1 == 0 && $zeroes == 0 )
				|| ( $1 == 255 && $ones == 0 ) );
			# No match, store for possible later breakdown
			if ( $smallest < $bits ) {
				$timestamp = $hash{'date'};
				$smallest = $bits;
				$spare = $network;
			} elsif ( $smallest == $bits
			    && ( !defined $timestamp || $hash{'date'} < $timestamp ) ) {
				$timestamp = $hash{'date'};
				$spare = $network;
			}
		}
	}
	if ( $match ne '' ) {
		$self->{DB}->get($match, $value);
		%hash = split($separator, $value);
		$hash{'state'} = 'taken';
		$hash{'date'} = $today;
		$hash{'customer'} = $customer;
		$hash{'location'} = $location
			if $length > 24 && defined $location && $location ne '';
		$self->{DB}->put($match, join($separator, %hash) );
		$self->{DB}->sync;
		return $match;
	}

	# OK, if we've got this far, there's no match.
	# Do we have anything we can break down?
	# If not, we can't succeed, so return now.

	if ( $spare eq '' ) {
		$self->{ERROR} = 'NOMATCH';
		return undef;
	}

	# OK, we have something. Break it down, then try again.

	$self->{DB}->get($spare, $contents);
	$self->{DB}->del($spare);
	$spare =~ s/\/(\d+)$//;
	$bits = $1;
	%hash = split($separator, $contents);
	$hash{'location'} = $location
		if $bits == 24 && defined $location && $location ne '';
	$network = sprintf "%s/%d", $spare, $bits + 1;
	$self->{DB}->put( $network, join($separator, %hash) );
	$self->{DB}->sync;
	$spare = join ('.', unpack('C4',
		(pack('C4', split(/\./, $spare)) |
			pack('B32', scalar ('0' x $bits) . '1' .
				scalar ('0' x (31 - $bits))))));
	$network = sprintf "%s/%d", $spare, $bits + 1;
	$self->{DB}->put( $network, join($separator, %hash) );
	$self->{DB}->sync;
	return $self->assignNetwork(@_);
}

sub changeState {


	my($self) = shift;
	my($network, $state, $customer, $location) = @_;
	my($ip, $length) = parseNet($network);
	my($allocation) = sprintf "%s/%d", printIP($ip), $length;
	my(@candidates) = ();;
	my($net, $contents, $status, $bits);

	unless ( defined $states{$state} ) {
		$self->{ERROR} = 'STATE',
		$self->{PARAMS} = [ $state ];
		return undef;
	}
	if ( $ip == 0 ) {
		$self->{ERROR} = 'NETWORK';
		$self->{PARAMS} = [ $network, $length ];
		return undef;
	}

	if ( $self->{DB}->get($allocation, $contents) == 0 ) {
		%hash = split($separator, $contents);
		$hash{'state'} = $state;
		$hash{'date'} = $today;
		$hash{'customer'} = $customer if defined $customer;
		$hash{'location'} = $location
			if $length > 24 && defined $location && $location ne '';
		$self->{DB}->put($allocation, join($separator, %hash) );
		$self->{DB}->sync;
		# Should try to merge with surrounding nets if possible
		return $self->mergeNetwork( $allocation );
	}

	# It would be nice to use the cursor to just search the subtree
	# where the allocation would be located but it will return the
	# element in the tree after the one we want, since it returns
	# equal or greater than. As a consequence we need to run through
	# the whole of the tree looking for the bit we want.
	#
	for ( $status = $self->{DB}->seq($network, $value, R_FIRST);
	    $status == 0;
	    $status = $self->{DB}->seq($network, $value, R_NEXT) ) {
		push @candidates, $network if overlap($allocation, $network);
	}

	# Did we find an allocation that overlaps the bit we want to change?
	if ( $#candidates == 0 ) {
		($net, $bits) = split(/\//, $candidates[0]);
		if ( $bits < $length ) {
			# OK, we have something bigger.
			# Break it down, then try again.
			$self->{DB}->get($candidates[0], $contents);
			$self->{DB}->del($candidates[0]);
			%hash = split($separator, $contents);
			$hash{'location'} = $location
				if $bits == 24
				    && defined $location && $location ne '';
			$network = sprintf("%s/%d", $net, $bits + 1);
			$self->{DB}->put($network, join($separator, %hash) );
			$self->{DB}->sync;
			$net = join ('.', unpack('C4',
				(pack('C4', split(/\./, $net) ) |
					pack('B32', scalar ('0' x $bits) . '1' .
						scalar ('0' x (31 - $bits))))));
			$network = sprintf("%s/%d", $net, $bits + 1);
			$self->{DB}->put($network, join($separator, %hash) );
			$self->{DB}->sync;
			return $self->changeState(@_);
		} else {
			# The user wants us to change something that is not
			# in the allocation pool, complain...
			$self->{ERROR} = 'RANGE';
			return undef;
		}
	} elsif ( $#candidates > 0 ) {
		# We should check that these elements completely cover the
		# entry we want to change but that's too hard for now so
		# just assume they do...
		#
		# Remove the fragments enclosed by the new element
		foreach ( @candidates ) {
			$self->{DB}->del($_);
		}
		%hash = {};
		$hash{'state'} = $state;
		$hash{'date'} = $today;
		$hash{'customer'} = $customer if defined $customer;
		$hash{'location'} = $location
			if $length > 24 && defined $location && $location ne '';
		$self->{DB}->put($allocation, join($separator, %hash) );
		$self->{DB}->sync;
		return $self->mergeNetwork( $allocation );
	} else {
		# We can't find any evidence of the entry being part of
		# the allocation pool. 
		$self->{ERROR} = 'RANGE';
		return undef;
	}
}

sub initialiseBlock {


	my($self) = shift;
	my($network, $length) = parseNet(@_);
	my($allocation) = sprintf "%s/%d", printIP($network), $length;
	my($status);
	my(%hash) = {};
	my(@candidates) = ();

	if ( $network == 0 ) {
		$self->{ERROR} = 'NETWORK';
		$self->{PARAMS} = [ @_, $length ];
		return undef;
	}

	if ( $self->{DB}->get($allocation, $contents) == 0 ) {
		$self->{ERROR} = 'OVERLAP';
		$self->{PARAMS} = [ $allocation ];
		return undef;
	}

	# OK now check that it's not part of an existing allocation
	for ( $status = $self->{DB}->seq($network, $value, R_FIRST);
	    $status == 0;
	    $status = $self->{DB}->seq($network, $value, R_NEXT) ) {
		push @candidates, $network if overlap($allocation, $network);
	}

	if ( $#candidates < 0 ) {
		$hash{'state'} = 'free';
		$hash{'date'} = $today;
		$status = $self->{DB}->put($allocation, join($separator, %hash) );
		$status = $self->{DB}->sync;
		return $self->mergeNetwork( $allocation );
	} else {
		$self->{ERROR} = 'OVERLAP';
		$self->{PARAMS} = [ $allocation ];
		return undef;
	}
}

sub mergeNetwork {
	my($self) = shift;
	my($network, $length) = parseNet(@_);
	my($allocation) = sprintf "%s/%d", printIP($network), $length;
	my($contents);
	my($bits, $merge, $status, $value, $dummy, $larger);
	my(@overlap) = ();
	my($state, $location, $customer, $date);
	my(%hash, %original);

	# Save the value of the component we want to merge so we can check
	# that all the other components are like it.
	$self->{DB}->get($allocation, $contents);

	%original = split($separator, $contents);

	$state = $original{state};
	$location = $original{location};
	$customer = $original{customer};
	$date = $original{date};

	# Should try to merge networks into larger CIDR blocks if surrounding
	# blocks are free or have the same customer ID
	#
	$bits = $length - 1;
	$larger = join('.', unpack('C4', ( pack('L', $network) &
			pack('B32', scalar('1' x $bits) .
				scalar('0' x (32 - $bits))))));
	$network = sprintf "%s/%d", $larger, $bits;

	# Initialise the cursor, this shouldn't be necessary but the for loop
	# below doesn't work as I expected without it for the last subtree :-(
	#
	$status = $self->{DB}->seq($dummy, $value, R_FIRST);

	# Just run through the subtree checking that the components are the
	# same, we don't care if the "free" date is different.
	#
	$merge = 1;
	for ( $status = $self->{DB}->seq($network, $value, R_CURSOR);
	    $status == 0 && $merge;
	    $status = $self->{DB}->seq($network, $value, R_NEXT) ) {
		if ( overlap( sprintf("%s/%d", $larger, $bits), $network ) ) {
			%hash = split($separator, $value);
			if ( $state ne $hash{'state'} ) {
				$merge = 0;
			} elsif ( $hash{'state'} ne 'free' ) {
				$merge = $customer eq $hash{'customer'};
				push @overlap, $network;
			} else {
				push @overlap, $network;
			}
		} else {
			last;
		}
	}

	# We have a valid overlap of like components so merge them into a
	# supernet then try to merge it
	#
	if ( $merge && $#overlap > 0 ) {
		$allocation = sprintf "%s/%d", $larger, $bits;
		undef $original{location} if defined $location && $bits >= 24;
		$self->{DB}->put($allocation, join($separator, %original) );
		$self->{DB}->sync;
		foreach ( @overlap ) {
			$self->{DB}->del($_);
		}
		return $self->mergeNetwork( $allocation );
	} else {
		return $allocation;
	}
}

sub iterateAllocations {


	my($self) = shift;
	my($status, $value);
	my(%hash);

	unless ( wantarray ) {
		$self->{POS} = undef;
		return undef;
	}
	if ( defined $self->{POS} ) {
		$self->{DB}->seq($self->{POS}, $value, R_CURSOR);
		$status = $self->{DB}->seq($self->{POS}, $value, R_NEXT);
	} else {
		$status = $self->{DB}->seq($self->{POS}, $value, R_FIRST);
	}
	if ( $status == 0 ) {
		%hash = split($separator, $value);
		return ($self->{POS}, $hash{'state'}, $hash{'date'},
			$hash{'customer'}, $hash{'location'});
	} else {
		$self->{POS} = undef;
		return ();
	}
}

sub errorMessage {


	my($self) = shift;
	my(@params) = @{ $self->{PARAMS} };

	return sprintf $messages{$self->{ERROR}}, @params;
}

sub maskOfLength {
	my($len) = @_;

	return(-( 1 << (32 - $len )));
}

sub parseNet {
	my($prefix, $length) = split('/', shift, 2);
	my(@bytes) = split(/\./, $prefix, 4);
	my($ip, $byte);

	foreach $byte ( @bytes ) {
		if ( $byte !~ /^\d+$/ || $byte > 255 ) {
			return (0, $byte);
		}
	}

	$ip = unpack('L', pack('C4', @bytes));
 
	#  Supply a classful default length ONLY if no length was specified.

	if ( $length eq "" ) {
		#  Old version:  user the classful default lengths.
		#
		# No explicit length given so default to classful definition
		$length = ( $bytes[0] < 128 ) ? 8 :
			  ( $bytes[0] < 192 ) ? 16:
						24;

		#  *IF* this default causes a CIDR-alignment problem,
		#    then that's probably not what they wanted.  Try
		#    8, 16, 24, or 32 based on the number of octets 
		#    that they supplied when they typed the address.  
		#    E.g.,:
		#    35   ->  35/8
		#    35.1 -> 35/16
		#    193  -> 193/8
		#    193.128.2.15 -> 193.128.2.15/32

		$mask = &maskOfLength($length);
		$length = (8,16,24,32)[$#bytes] if ($mask & $ip) != $ip;
	}

	return ( $ip, $length );
}

sub printIP {
	return join('.', unpack('C4', pack('L', @_)));
}

sub overlap {
	my($old, $new) = @_;
	my(@old, @new);

	@old = &parseNet($old);
	@new = &parseNet($new);
	if ( $old[1] == $new[1] ) {
		return $old[0] == $new[0];
	} else { # different lengths so we need to see if one is inside other
		if ( $old[1] < $new[1] ) {
			$mask = &maskOfLength($old[1]);
		} else {
			$mask = &maskOfLength($new[1]);
		}
		return ($old[0] & $mask) == ($new[0] & $mask);
	}
}

1;