File Coverage

blib/lib/Tie/NetAddr/IP.pm

Criterion	Covered	Total	%
statement	71	78	91.0
branch	17	24	70.8
condition	2	3	66.6
subroutine	12	13	92.3
pod	0	1	0.0
total	102	119	85.7

package Tie::NetAddr::IP;

=pod

=head1 NAME

Tie::NetAddr::IP - Implements a Hash where the key is a subnet

=head1 SYNOPSIS

  use Tie::NetAddr::IP;

  my %WhereIs;

  tie %WhereIs, Tie::NetAddr::IP;

  $WhereIs{"10.0.10.0/24"} = "Lab, First Floor";
  $WhereIs{"10.0.20.0/24"} = "Datacenter, Second Floor";
  $WhereIs{"10.0.30.0/27"} = "Remote location";
  $WhereIs{"0.0.0.0/0"} = "God knows where";

  foreach $host ("10.0.10.1", "10.0.20.15", "10.0.32.17", "10.10.0.1") {
     print "Host $host is in ", $WhereIs{$host}, "\n";
  }

  foreach $subnet (keys %WhereIs) {
     print "Network ", $subnet, " is used in ",
     $WhereIs{$subnet}, "\n";
  }

  untie %WhereIs;

=head1 DESCRIPTION

This module overloads hashes so that the key can be a subnet as in
B. When looking values up, an interpretation will be made
to find the given key B the subnets specified in the hash.

The code sample provided on the B would print out the
locations of every machine in the C loop.

Care must be taken, as only strings that can be parsed as an IP
address by B can be used as keys for this hash.

Iterators on the hash such as C, C, C and
C will only see the actual subnets provided as keys to the
hash. When looking up a value such as in C<$hash{$ipaddress}> this IP
address will be looked up among the subnets existing as keys within
the hash. The matching subnet with the longest mask (ie, the most
specific subnet) will win and its associated value will be returned.

This code can be distributed freely according to the terms set forth
in the PERL license provided that proper credit is maintained. Please
send bug reports and feedback to the author for further improvement.

=cut

use strict;
use vars qw($VERSION);
use Carp;
use NetAddr::IP 3.00;

$VERSION = '1.51';

sub new {
    TIEHASH(shift);
}

sub TIEHASH {
    my $class = shift;
    my $self = [ ];
    bless $self, $class;
}

sub FETCH {
    my $self = shift;
    my $where = shift;
    my $ip = new NetAddr::IP $where;

    if ($ip) {
	my @fles = reverse @$self;
	for my $item (@fles) {
	    next unless ref $item;
	    for my $a (keys %{$item}) {
		if ($item->{$a}->{where}->contains($ip)) {
		    return $item->{$a}->{what};
		}
	    }
	}
    } else {
	croak "$where is not a valid NetAddr::IP specification";
    }

    return;			# None of the networks matched the spec
}

sub STORE {
    my $self = shift;
    my $where = shift;
    my $what = shift;
    my $ip = new NetAddr::IP $where;

    if ($ip) {
	$self->[$ip->masklen]->{$ip->addr} = {
	    where	=> $ip,
	    what	=> $what,
	};
    } else {
	croak "$where is not a valid IP address specification";
    }
}

sub EXISTS {
    my $self = shift;
    my $where = shift;
    my $ip = new NetAddr::IP $where;

    if ($ip) {
	return exists $self->[$ip->masklen]->{$ip->addr};
    } else {
	croak "$where is not a valid NetAddr::IP specification";
    }
    return;
}

sub DELETE {
    my $self = shift;
    my $where = shift;
    my $ip = new NetAddr::IP $where;

    if ($ip) {
	my $mask = $ip->masklen;
	my $addr = $ip->addr;

	return delete $self->[$mask]->{$addr};

    } else {
	croak "$where is not a valid NetAddr::IP specification";
    }
    return;
}

sub CLEAR {
    my $self = shift;
    splice(@$self, 0, $#{$self});
    return;
}

sub NEXTKEY {
    my $self = shift;
    my $last = shift;

    if (defined $last) {
	my $l_ip = new NetAddr::IP $last;
	return undef unless $l_ip;

	my $found = 0;

	for my $bits ($l_ip->masklen .. 128) {
	    for my $a (keys %{$self->[$bits]}) {
		if ($a eq $l_ip->addr and $bits == $l_ip->masklen) {
		    $found = 1;
		    next;
		}
		if ($found) {
		    my $r = $self->[$bits]->{$a}->{where}->cidr;
		    return wantarray ? ($r) : $r;
		}
	    }
	}
    } else {
	for my $bits (0 .. 128) {
	    for my $a (keys %{$self->[$bits]}) {
		my $r = $self->[$bits]->{$a}->{where}->cidr;
		return wantarray ? ($r) : $r;
	    }
	}

    }
    return;
}

sub FIRSTKEY { NEXTKEY $_[0], undef; }

1;

__END__