view release on metacpan or  search on metacpan

Assign.pm  view on Meta::CPAN

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

=pod

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.

=cut

	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

Assign.pm  view on Meta::CPAN

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

=pod

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.

=cut

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

	unless ( wantarray ) {