view release on metacpan or  search on metacpan

Assign.pm  view on Meta::CPAN

		};

	$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 {

=pod

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

=cut

	my($self) = shift;

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

sub assignNetwork {

=pod

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.

=cut

	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'};

Assign.pm  view on Meta::CPAN

	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 {

=pod

initialiseBlock adds a new block into the allocation pool.

=cut

	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 );