Net-CIDR-Set-0.13000755001750001750 012302646471 12511 5ustar00andyandy000000000000Net-CIDR-Set-0.13/MANIFEST000444001750001750 32612302646471 13760 0ustar00andyandy000000000000Build.PL Changes inc/MyBuilder.pm lib/Net/CIDR/Set.pm lib/Net/CIDR/Set/IPv4.pm lib/Net/CIDR/Set/IPv6.pm MANIFEST README t/00-load.t t/basic.t t/ipv6.t t/misc.t t/operations.t t/pod.t t/private.t META.yml META.json Net-CIDR-Set-0.13/README000444001750001750 101412302646471 13522 0ustar00andyandy000000000000Net-CIDR-Set version 0.13 INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install Alternatively, to install with Module::Build, you can use the following commands: perl Build.PL ./Build ./Build test ./Build install DEPENDENCIES Data::Types List::Util COPYRIGHT AND LICENCE Copyright (C) 2008, Message Systems This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Net-CIDR-Set-0.13/META.json000444001750001750 245512302646471 14275 0ustar00andyandy000000000000{ "abstract" : "Manipulate sets of IP addresses", "author" : [ "Andy Armstrong " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4205", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Net-CIDR-Set", "prereqs" : { "configure" : { "requires" : { "Module::Build" : "0.42" } }, "runtime" : { "requires" : { "Test::More" : "0" } } }, "provides" : { "Net::CIDR::Set" : { "file" : "lib/Net/CIDR/Set.pm", "version" : "0.13" }, "Net::CIDR::Set::IPv4" : { "file" : "lib/Net/CIDR/Set/IPv4.pm", "version" : "0.13" }, "Net::CIDR::Set::IPv6" : { "file" : "lib/Net/CIDR/Set/IPv6.pm", "version" : "0.13" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-CIDR-Set" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "git://github.com/AndyA/Net--CIDR--Set.git (fetch)" } }, "version" : "0.13" } Net-CIDR-Set-0.13/Build.PL000444001750001750 63012302646471 14121 0ustar00andyandy000000000000use strict; use Module::Build; use 5.005; use lib 'inc'; use MyBuilder; my $builder = MyBuilder->new( module_name => 'Net::CIDR::Set', license => 'perl', dist_author => 'Andy Armstrong ', dist_version_from => 'lib/Net/CIDR/Set.pm', requires => { 'Test::More' => 0 }, add_to_cleanup => ['Net-CIDR-Set-*'], ); $builder->create_build_script(); Net-CIDR-Set-0.13/META.yml000444001750001750 152712302646471 14124 0ustar00andyandy000000000000--- abstract: 'Manipulate sets of IP addresses' author: - 'Andy Armstrong ' build_requires: {} configure_requires: Module::Build: 0.42 dynamic_config: 1 generated_by: 'Module::Build version 0.4205, CPAN::Meta::Converter version 2.133380' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Net-CIDR-Set provides: Net::CIDR::Set: file: lib/Net/CIDR/Set.pm version: 0.13 Net::CIDR::Set::IPv4: file: lib/Net/CIDR/Set/IPv4.pm version: 0.13 Net::CIDR::Set::IPv6: file: lib/Net/CIDR/Set/IPv6.pm version: 0.13 requires: Test::More: 0 resources: bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-CIDR-Set license: http://dev.perl.org/licenses/ repository: 'git://github.com/AndyA/Net--CIDR--Set.git (fetch)' version: 0.13 Net-CIDR-Set-0.13/Changes000444001750001750 43712302646471 14125 0ustar00andyandy000000000000Revision history for Net-CIDR-Set 0.10 2009-01-29 - Initial release 0.11 2009-01-29 - Remove broken cidrcalc 0.12 2009-05-29 - Move to GitHub 0.13 2014-02-24 - Applied Brian Gottreu's fix for https://rt.cpan.org/Public/Bug/Display.html?id=49632 Net-CIDR-Set-0.13/lib000755001750001750 012302646471 13257 5ustar00andyandy000000000000Net-CIDR-Set-0.13/lib/Net000755001750001750 012302646471 14005 5ustar00andyandy000000000000Net-CIDR-Set-0.13/lib/Net/CIDR000755001750001750 012302646471 14526 5ustar00andyandy000000000000Net-CIDR-Set-0.13/lib/Net/CIDR/Set.pm000444001750001750 4336312302646471 16005 0ustar00andyandy000000000000package Net::CIDR::Set; use warnings; use strict; use Carp qw( croak confess ); use Net::CIDR::Set::IPv4; use Net::CIDR::Set::IPv6; use overload '""' => 'as_string'; our $VERSION = '0.13'; =head1 NAME Net::CIDR::Set - Manipulate sets of IP addresses =head1 VERSION This document describes Net::CIDR::Set version 0.13 =head1 SYNOPSIS use Net::CIDR::Set; my $priv = Net::CIDR::Set->new( '10.0.0.0/8', '172.16.0.0/12', '192.168.0.0/16' ); for my $ip ( @addr ) { if ( $priv->contains( $ip ) ) { print "$ip is private\n"; } } =head1 DESCRIPTION C represents sets of IP addresses and allows standard set operations (union, intersection, membership test etc) to be performed on them. In spite of the name it can work with sets consisting of arbitrary ranges of IP addresses - not just CIDR blocks. Both IPv4 and IPv6 addresses are handled - but they may not be mixed in the same set. You may explicitly set the personality of a set: my $ip4set = Net::CIDR::Set->new({ type => 'ipv4 }, '10.0.0.0/8'); Normally this isn't necessary - the set will guess its personality from the first data that is added to it. =head1 INTERFACE =head2 C<< new >> Create a new Net::CIDR::Set. All arguments are optional. May be passed a list of list of IP addresses or ranges which, if present, will be passed to C. The first argument may be a hash reference which will be inspected for named options. Currently the only option that may be passed is C which should be 'ipv4', 'ipv6' or the name of a coder class. See L and L for examples of coder classes. =cut { my %type_map = ( ipv4 => 'Net::CIDR::Set::IPv4', ipv6 => 'Net::CIDR::Set::IPv6', ); sub new { my $self = shift; my $class = ref $self || $self; my $set = bless { ranges => [] }, $class; my $opt = 'HASH' eq ref $_[0] ? shift : {}; if ( defined( my $type = delete $opt->{type} ) ) { my $coder_class = $type_map{$type} || $type; $set->{coder} = $coder_class->new; } elsif ( ref $self ) { $set->{coder} = $self->{coder}; } my @unk = keys %$opt; croak "Unknown options: ", _and( sort @unk ) if @unk; $set->add( @_ ) if @_; return $set; } } # Return the index of the first element >= the supplied value. If the # supplied value is larger than any element in the list the returned # value will be equal to the size of the list. sub _find_pos { my $self = shift; my $val = shift; my $low = shift || 0; my $high = scalar( @{ $self->{ranges} } ); while ( $low < $high ) { my $mid = int( ( $low + $high ) / 2 ); my $cmp = $val cmp $self->{ranges}[$mid]; if ( $cmp < 0 ) { $high = $mid; } elsif ( $cmp > 0 ) { $low = $mid + 1; } else { return $mid; } } return $low; } sub _inc { my @b = reverse unpack 'C*', shift; for ( @b ) { last unless ++$_ == 256; $_ = 0; } return pack 'C*', reverse @b; } sub _dec { my @b = reverse unpack 'C*', shift; for ( @b ) { last unless $_-- == 0; $_ = 255; } return pack 'C*', reverse @b; } sub _guess_coder { my ( $self, $ip ) = @_; for my $class ( qw( Net::CIDR::Set::IPv4 Net::CIDR::Set::IPv6 ) ) { my $coder = $class->new; my @rep = eval { $coder->encode( $ip ) }; return $coder unless $@; } croak "Can't decode $ip as an IPv4 or IPv6 address"; } sub _encode { my ( $self, $ip ) = @_; my $cdr = $self->{coder} ||= $self->_guess_coder( $ip ); return $cdr->encode( $ip ); } { for my $dele ( qw( _decode _nbits ) ) { no strict 'refs'; ( my $meth = $dele ) =~ s/^_//; *{$dele} = sub { my $self = shift; my $cdr = $self->{coder} || croak "Don't know how to $meth yet"; return $cdr->$meth( @_ ); }; } } sub _conjunction { my ( $conj, @list ) = @_; my $last = pop @list; return join " $conj ", join( ', ', @list ), $last; } sub _and { _conjunction( 'and', @_ ) } sub _check_and_coerce { my ( $self, @others ) = @_; my %class = map { eval { ( defined $_ && $_->nbits || '' ) => $_ } } map { $_->{coder} } grep { defined } $self, @others; my @found = sort grep $_, keys %class; croak "Can't mix ", _and( @found ), " bit addresses" if @found > 1; $self->{coder} ||= $class{ $found[0] }; return $self; } =head2 C<< invert >> Invert (negate, complement) a set in-place. my $set = Net::CIDR::Set->new; $set->invert; =cut sub invert { my $self = shift; my @pad = ( 0 ) x ( $self->_nbits / 8 ); my ( $min, $max ) = map { pack 'C*', $_, @pad } 0, 1; if ( $self->is_empty ) { $self->{ranges} = [ $min, $max ]; return; } if ( $self->{ranges}[0] eq $min ) { shift @{ $self->{ranges} }; } else { unshift @{ $self->{ranges} }, $min; } if ( $self->{ranges}[-1] eq $max ) { pop @{ $self->{ranges} }; } else { push @{ $self->{ranges} }, $max; } } =head2 C<< copy >> Make a deep copy of a set. my $set2 = $set->copy; =cut sub copy { my $self = shift; my $copy = $self->new; @{ $copy->{ranges} } = @{ $self->{ranges} }; return $copy; } sub _add_range { my ( $self, $from, $to ) = @_; my $fpos = $self->_find_pos( $from ); my $tpos = $self->_find_pos( _inc( $to ), $fpos ); $from = $self->{ranges}[ --$fpos ] if ( $fpos & 1 ); $to = $self->{ranges}[ $tpos++ ] if ( $tpos & 1 ); splice @{ $self->{ranges} }, $fpos, $tpos - $fpos, ( $from, $to ); } =head2 C<< add >> Add a number of addresses or ranges to a set. $set->add( '10.0.0.0/8', '192.168.0.32-192.168.0.63', '127.0.0.1' ); It is legal to add ranges that overlap with each other and/or with the ranges already in the set. Overlapping ranges are merged. =cut sub add { my ( $self, @addr ) = @_; for my $ip ( map { split /\s*,\s*/ } @addr ) { my ( $lo, $hi ) = $self->_encode( $ip ) or croak "Can't decode $ip"; $self->_add_range( $lo, $hi ); } } =head2 C<< remove >> Remove a number of addresses or ranges from a set. $set->remove( '8.8.0.0/16', '158.152.1.58' ); There is no requirement that the addresses being removed be members of the set. =cut sub remove { my $self = shift; $self->invert; $self->add( @_ ); $self->invert; } =head2 C<< merge >> Merge the contents of other sets into this set. $set = Net::CIDR::Set->new; $set->merge($s1, $s2); =cut sub merge { my $self = shift; $self->_check_and_coerce( @_ ); # TODO: This isn't very efficient - and merge gets called from all # sorts of other places. for my $other ( @_ ) { my $iter = $other->_iterate_runs; while ( my ( $from, $to ) = $iter->() ) { $self->_add_range( $from, $to ); } } } =head2 C<< contains >> A synonmym for C. =head2 C<< contains_all >> Return true if the set contains all of the supplied addresses. Given this set: my $set = Net::CIDR::Set->new('244.188.12.0/8'); this condition is true: if ( $set->contains_all('244.188.12.128/3') ) { # ... } while this condition is false: if ( $set->contains_all('244.188.12.0/12') ) { # ... } =cut *contains = *contains_all; sub contains_all { my $self = shift; my $class = ref $self; return $class->new( @_ )->subset( $self ); } =head2 C<< contains_any >> Return true if there is any overlap between the supplied addresses/ranges and the contents of the set. =cut sub contains_any { my $self = shift; my $class = ref $self; return !$class->new( @_ )->intersection( $self )->is_empty; } sub _iterate_runs { my $self = shift; my $pos = 0; my $limit = scalar( @{ $self->{ranges} } ); return sub { return if $pos >= $limit; my @r = @{ $self->{ranges} }[ $pos, $pos + 1 ]; $pos += 2; return @r; }; } sub compliment { croak "That's very kind of you - but I expect you meant complement"; } =head2 C<< complement >> Return a new set that is the complement of this set. my $inv = $set->complement; =cut sub complement { my $new = shift->copy; # TODO: What if it's empty? $new->invert; return $new; } =head2 C<< union >> Return a new set that is the union of a number of sets. This is equivalent to a logical OR between sets. my $everything = $east->union($west); =cut sub union { my $new = shift->copy; $new->merge( @_ ); return $new; } =head2 C<< intersection >> Return a new set that is the intersection of a number of sets. This is equivalent to a logical AND between sets. my $overlap = $north->intersection($south); =cut sub intersection { my $self = shift; my $class = ref $self; my $new = $class->new; $new->merge( map { $_->complement } $self, @_ ); $new->invert; return $new; } =head2 C<< xor >> Return a new set that is the exclusive-or of existing sets. my $xset = $this->xor($that); The resulting set will contain all addresses that are members of one set but not the other. =cut sub xor { my $self = shift; return $self->union( @_ ) ->intersection( $self->intersection( @_ )->complement ); } =head2 C<< diff >> Return a new set containing all the addresses that are present in this set but not another. my $diff = $this->diff($that); =cut sub diff { my $self = shift; my $other = shift; return $self->intersection( $other->union( @_ )->complement ); } =head2 C<< is_empty >> Return a true value if the set is empty. if ( $set->is_empty ) { print "Nothing there!\n"; } =cut sub is_empty { my $self = shift; return @{ $self->{ranges} } == 0; } =head2 C<< superset >> Return true if this set is a superset of the supplied set. =cut sub superset { my $other = pop; return $other->subset( reverse( @_ ) ); } =head2 C<< subset >> Return true if this set is a subset of the supplied set. =cut sub subset { my $self = shift; my $other = shift || croak "I need two sets to compare"; return $self->equals( $self->intersection( $other ) ); } =head2 C<< equals >> Return true if this set is identical to another set. if ( $set->equals($foo) ) { print "We have the same addresses.\n"; } =cut sub equals { return unless @_; # Array of array refs my @edges = map { $_->{ranges} } @_; my $medge = scalar( @edges ) - 1; POS: for ( my $pos = 0;; $pos++ ) { my $v = $edges[0]->[$pos]; if ( defined( $v ) ) { for ( @edges[ 1 .. $medge ] ) { my $vv = $_->[$pos]; return unless defined( $vv ) && $vv eq $v; } } else { for ( @edges[ 1 .. $medge ] ) { return if defined $_->[$pos]; } } last POS unless defined( $v ); } return 1; } =head1 Retrieving Set Contents The following methods allow the contents of a set to be retrieved in various representations. Each of the following methods accepts an optional numeric argument that controls the formatting of the returned addresses. It may take one of the following values: =over =item C<0> Format each range of addresses as compactly as possible. If the range contains only a single address format it as such. If it can be represented as a single CIDR block use CIDR representation (/) otherwise format it as an arbitrary range (-). =item C<1> Always format as either a CIDR block or an arbitrary range even if the range is just a single address. =item C<2> Always use arbitrary range format (-) even if the range is a single address or a legal CIDR block. =back Here's an example of the different formatting options: my $set = Net::CIDR::Set->new( '127.0.0.1', '192.168.37.0/24', '10.0.0.11-10.0.0.17' ); for my $fmt ( 0 .. 2 ) { print "Using format $fmt:\n"; print " $_\n" for $set->as_range_array( $fmt ); } And here's the output from that code: Using format 0: 10.0.0.11-10.0.0.17 127.0.0.1 192.168.37.0/24 Using format 1: 10.0.0.11-10.0.0.17 127.0.0.1/32 192.168.37.0/24 Using format 2: 10.0.0.11-10.0.0.17 127.0.0.1-127.0.0.1 192.168.37.0-192.168.37.255 Note that this option never affects the addresses that are returned; only how they are formatted. For most purposes the formatting argument can be omitted; it's default value is C<0> which provides the most general formatting. =head2 C<< iterate_addresses >> Return an iterator (a closure) that will return each of the addresses in the set in ascending order. This code my $set = Net::CIDR::Set->new('192.168.37.0/24'); my $iter = $set->iterate_addresses; while ( my $ip = $iter->() ) { print "Got $ip\n"; } outputs 256 distinct addresses from 192.168.37.0 to 192.168.27.255. =cut sub iterate_addresses { my ( $self, @args ) = @_; my $iter = $self->_iterate_runs; my @r = (); return sub { while ( 1 ) { @r = $iter->() or return unless @r; return $self->_decode( ( my $last, $r[0] ) = ( $r[0], _inc( $r[0] ) ), @args ) unless $r[0] eq $r[1]; @r = (); } }; } =head2 C<< iterate_cidr >> Return an iterator (a closure) that will return each of the CIDR blocks in the set in ascending order. This code my $set = Net::CIDR::Set->new('192.168.37.9-192.168.37.134'); my $iter = $set->iterate_cidr; while ( my $cidr = $iter->() ) { print "Got $cidr\n"; } outputs Got 192.168.37.9 Got 192.168.37.10/31 Got 192.168.37.12/30 Got 192.168.37.16/28 Got 192.168.37.32/27 Got 192.168.37.64/26 Got 192.168.37.128/30 Got 192.168.37.132/31 Got 192.168.37.134 This is the most compact CIDR representation of the set because its limits don't fall on convenient CIDR boundaries. =cut sub iterate_cidr { my ( $self, @args ) = @_; my $iter = $self->_iterate_runs; my $size = $self->_nbits; my @r = (); return sub { while ( 1 ) { @r = $iter->() or return unless @r; unless ( $r[0] eq $r[1] ) { ( my $bits = unpack 'B*', $r[0] ) =~ /(0*)$/; my $pad = length $1; $pad = $size if $pad > $size; while ( 1 ) { my $next = _inc( $r[0] | pack 'B*', ( '0' x ( length( $bits ) - $pad ) ) . ( '1' x $pad ) ); return $self->_decode( ( my $last, $r[0] ) = ( $r[0], $next ), @args ) if $next le $r[1]; $pad--; } } @r = (); } }; } =head2 C<< iterate_ranges >> Return an iterator (a closure) that will return each of the ranges in the set in ascending order. This code my $set = Net::CIDR::Set->new( '192.168.37.9-192.168.37.134', '127.0.0.1', '10.0.0.0/8' ); my $iter = $set->iterate_ranges; while ( my $range = $iter->() ) { print "Got $range\n"; } outputs Got 10.0.0.0/8 Got 127.0.0.1 Got 192.168.37.9-192.168.37.134 =cut sub iterate_ranges { my ( $self, @args ) = @_; my $iter = $self->_iterate_runs; return sub { return unless my @r = $iter->(); return $self->_decode( @r, @args ); }; } =head2 C<< as_array >> Convenience method that gathers all of the output from one of the iterators above into an array. my @ranges = $set->as_array( $set->iterate_ranges ); Normally you will use one of C, C or C instead. =cut sub as_array { my ( $self, $iter ) = @_; my @addr = (); while ( my $addr = $iter->() ) { push @addr, $addr; } return @addr; } =head2 C<< as_address_array >> Return an array containing all of the distinct addresses in a set. Note that this may very easily create a very large array. At the time of writing it is, for example, unlikely that you have enough memory for an array containing all of the possible IPv6 addresses... =cut sub as_address_array { my $self = shift; return $self->as_array( $self->iterate_addresses( @_ ) ); } =head2 C<< as_cidr_array >> Return an array containing all of the distinct CIDR blocks in a set. =cut sub as_cidr_array { my $self = shift; return $self->as_array( $self->iterate_cidr( @_ ) ); } =head2 C<< as_range_array >> Return an array containing all of the ranges in a set. =cut sub as_range_array { my $self = shift; return $self->as_array( $self->iterate_ranges( @_ ) ); } =head2 C<< as_string >> Return a compact string representation of a set. =cut sub as_string { join ', ', shift->as_range_array( @_ ) } 1; __END__ =head1 AUTHOR Andy Armstrong C<< >> =head1 CREDITS The encode and decode routines were stolen en masse from Douglas Wilson's L. =head1 LICENCE AND COPYRIGHT This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. Copyright (c) 2009, Message Systems, Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name Message Systems, Inc. nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Net-CIDR-Set-0.13/lib/Net/CIDR/Set000755001750001750 012302646471 15261 5ustar00andyandy000000000000Net-CIDR-Set-0.13/lib/Net/CIDR/Set/IPv6.pm000444001750001750 1150312302646471 16560 0ustar00andyandy000000000000package Net::CIDR::Set::IPv6; use warnings; use strict; use Carp; =head1 NAME Nset::CIDR::Set::IPv6 - Encode / decode IPv6 addresses =head1 VERSION This document describes Net::CIDR::Set::IPv6 version 0.13 =cut our $VERSION = '0.13'; sub new { bless \my $x, shift } sub _pack_ipv4 { my @nums = split /[.]/, shift, -1; return unless @nums == 4; for ( @nums ) { return unless /^\d{1,3}$/ and $_ < 256; } return pack "CC*", 0, @nums; } sub _426 { my @nums = split /[.]/, shift, -1; return if grep $_ > 255, @nums; return join( ":", unpack( 'H*', pack 'C*', @nums ) =~ /..../g ); } sub _pack { my $ip = shift; return pack( 'H*', '0' x 33 ) if $ip eq '::'; return if $ip =~ /^:/ and $ip !~ s/^::/:/; return if $ip =~ /:$/ and $ip !~ s/::$/:/; my @nums = split /:/, $ip, -1; return unless @nums <= 8; my ( $empty, $ipv4, $str ) = ( 0, '', '' ); for ( @nums ) { return if $ipv4; $str .= "0" x ( 4 - length ) . $_, next if /^[a-fA-F\d]{1,4}$/; do { return if $empty++ }, $str .= "X", next if $_ eq ''; next if $ipv4 = _pack_ipv4( $_ ); return; } return if $ipv4 and @nums > 6; $str =~ s/X/"0" x (($ipv4 ? 25 : 33)-length($str))/e if $empty; return pack( "H*", "00" . $str ) . $ipv4; } sub _unpack { return _compress_ipv6( join( ":", unpack( "xH*", shift ) =~ /..../g ) ); } # Replace longest run of null blocks with a double colon sub _compress_ipv6 { my $ip = shift; if ( my @runs = $ip =~ /((?:(?:^|:)(?:0000))+:?)/g ) { my $max = $runs[0]; for ( @runs[ 1 .. $#runs ] ) { $max = $_ if length( $max ) < length; } $ip =~ s/$max/::/; } $ip =~ s/:0{1,3}/:/g; return $ip; } sub _width2bits { my ( $width, $size ) = @_; return pack 'B*', ( '1' x ( $width + 8 ) ) . ( '0' x ( $size - $width ) ); } sub _is_cidr { my ( $lo, $hi ) = @_; my $mask = ~( $lo ^ $hi ); my $bits = unpack 'B*', $mask; return unless $hi eq ($lo | $hi); return unless $bits =~ /^(1*)0*$/; return length( $1 ) - 8; } sub _encode { my ( $self, $ip ) = @_; if ( $ip =~ m{^(.+?)/(.+)$} ) { my $mask = $2; return unless my $addr = _pack( $1 ); return unless my $bits = _width2bits( $mask, 128 ); return ( $addr & $bits, Net::CIDR::Set::_inc( $addr | ~$bits ) ); } elsif ( $ip =~ m{^(.+?)-(.+)$} ) { my ( $from, $to ) = ( $1, $2 ); return unless my $lo = _pack( $from ); return unless my $hi = _pack( $to ); return ( $lo, Net::CIDR::Set::_inc( $hi ) ); } else { return $self->_encode( "$ip/128" ); } } sub encode { my ( $self, $ip ) = @_; my @r = $self->_encode( $ip ) or croak "Can't decode $ip as an IPv6 address"; return @r; } sub decode { my $self = shift; my $lo = shift; my $hi = Net::CIDR::Set::_dec( shift ); my $generic = shift || 0; if ( $generic < 1 && $lo eq $hi ) { # Single address return _unpack( $lo ); } elsif ( $generic < 2 && defined( my $w = _is_cidr( $lo, $hi ) ) ) { # Valid CIDR range return join '/', _unpack( $lo ), $w; } else { # General range return join '-', _unpack( $lo ), _unpack( $hi ); } } sub nbits { 128 } 1; __END__ =head1 AUTHOR Andy Armstrong C<< >> =head1 LICENCE AND COPYRIGHT This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. Copyright (c) 2009, Message Systems, Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name Message Systems, Inc. nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Net-CIDR-Set-0.13/lib/Net/CIDR/Set/IPv4.pm000444001750001750 756012302646471 16546 0ustar00andyandy000000000000package Net::CIDR::Set::IPv4; use warnings; use strict; use Carp; =head1 NAME Net::CIDR::Set::IPv4 - Encode / decode IPv4 addresses =head1 VERSION This document describes Net::CIDR::Set::IPv4 version 0.13 =cut our $VERSION = '0.13'; sub new { bless \my $x, shift } sub _pack { my @nums = split /[.]/, shift, -1; return unless @nums == 4; for ( @nums ) { return unless /^\d{1,3}$/ and $_ < 256; } return pack "CC*", 0, @nums; } sub _unpack { join ".", unpack "xC*", shift } sub _width2bits { my ( $width, $size ) = @_; return pack 'B*', ( '1' x ( $width + 8 ) ) . ( '0' x ( $size - $width ) ); } sub _ip2bits { my $ip = shift or return; vec( $ip, 0, 8 ) = 255; my $bits = unpack 'B*', $ip; return unless $bits =~ /^1*0*$/; # Valid mask? return $ip; } sub _is_cidr { my ( $lo, $hi ) = @_; my $mask = ~( $lo ^ $hi ); my $bits = unpack 'B*', $mask; return unless $hi eq ($lo | $hi); return unless $bits =~ /^(1*)0*$/; return length( $1 ) - 8; } sub _encode { my ( $self, $ip ) = @_; if ( $ip =~ m{^(.+?)/(.+)$} ) { my $mask = $2; return unless my $addr = _pack( $1 ); return unless my $bits = ( $mask =~ /^\d+$/ ) ? _width2bits( $mask, 32 ) : _ip2bits( _pack( $mask ) ); return ( $addr & $bits, Net::CIDR::Set::_inc( $addr | ~$bits ) ); } elsif ( $ip =~ m{^(.+?)-(.+)$} ) { return unless my $lo = _pack( $1 ); return unless my $hi = _pack( $2 ); return ( $lo, Net::CIDR::Set::_inc( $hi ) ); } else { return $self->_encode( "$ip/32" ); } } sub encode { my ( $self, $ip ) = @_; my @r = $self->_encode( $ip ) or croak "Can't decode $ip as an IPv4 address"; return @r; } sub decode { my $self = shift; my $lo = shift; my $hi = Net::CIDR::Set::_dec( shift ); my $generic = shift || 0; if ( $generic < 1 && $lo eq $hi ) { # Single address return _unpack( $lo ); } elsif ( $generic < 2 && defined( my $w = _is_cidr( $lo, $hi ) ) ) { # Valid CIDR range return join '/', _unpack( $lo ), $w; } else { # General range return join '-', _unpack( $lo ), _unpack( $hi ); } } sub nbits { 32 } 1; __END__ =head1 AUTHOR Andy Armstrong C<< >> =head1 LICENCE AND COPYRIGHT This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. Copyright (c) 2009, Message Systems, Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name Message Systems, Inc. nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Net-CIDR-Set-0.13/t000755001750001750 012302646471 12754 5ustar00andyandy000000000000Net-CIDR-Set-0.13/t/misc.t000444001750001750 136712302646471 14240 0ustar00andyandy000000000000#!perl use strict; use warnings; use Test::More tests => 6; use Net::CIDR::Set; { eval { Net::CIDR::Set->new( 'foo' ) }; like $@, qr{Can't decode}, 'parse error on new'; } { my $set = Net::CIDR::Set->new; eval { $set->add( 'foo' ) }; like $@, qr{Can't decode}, 'parse error on add'; eval { $set->add( '10.0.0.0/8' ) }; ok !$@, 'can still parse ipv4'; eval { $set->add( '::' ) }; like $@, qr{Can't decode}, 'ipv4 personality set'; } { my $set = Net::CIDR::Set->new; eval { $set->add( 'foo' ) }; like $@, qr{Can't decode}, 'parse error on add'; eval { $set->add( '::' ) }; ok !$@, 'can still parse ipv6'; # eval { $set->add( '10.0.0.0/8' ) }; # like $@, qr{Can't decode}, 'ipv6 personality set'; } # vim:ts=2:sw=2:et:ft=perl Net-CIDR-Set-0.13/t/private.t000444001750001750 750712302646471 14761 0ustar00andyandy000000000000#!perl use strict; use warnings; use Test::More tests => 150; use Net::CIDR::Set; use Net::CIDR::Set::IPv4; use Net::CIDR::Set::IPv6; { # _inc for my $b ( 0 .. 31 ) { my $n = 1 << $b; my $p = $n - 1; my $q = $n + 1; is unpack( 'N', Net::CIDR::Set::_inc( pack 'N', $p ) ), $n, "_inc($p) == $n"; is unpack( 'N', Net::CIDR::Set::_inc( pack 'N', $n ) ), $q, "_inc($n) == $q"; is unpack( 'N', Net::CIDR::Set::_dec( pack 'N', $n ) ), $p, "_dec($n) == $p"; is unpack( 'N', Net::CIDR::Set::_dec( pack 'N', $q ) ), $n, "_dec($q) == $n"; } my @big = ( { name => '0 to 1', before => [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ], after => [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 ] }, { name => 'wrap some', before => [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 255, 255, 255, 255, 255, 255 ], after => [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0 ] }, { name => 'wrap all', before => [ 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255 ], after => [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ] }, ); for my $b ( @big ) { my $name = $b->{name}; my @inc = unpack 'C*', Net::CIDR::Set::_inc( pack 'C*', @{ $b->{before} } ); is_deeply [@inc], $b->{after}, "$name: _inc"; my @dec = unpack 'C*', Net::CIDR::Set::_dec( pack 'C*', @inc ); is_deeply [@dec], $b->{before}, "$name: _dec"; } } { my @case = ( { ip => '127.0.0.1', expect => [ [ 0, 127, 0, 0, 1 ], [ 0, 127, 0, 0, 2 ] ] }, { ip => '192.168.0.0/16', expect => [ [ 0, 192, 168, 0, 0 ], [ 0, 192, 169, 0, 0 ] ] }, { ip => '192.168.0.0/255.255.0.0', expect => [ [ 0, 192, 168, 0, 0 ], [ 0, 192, 169, 0, 0 ] ] }, { ip => '192.168.0.0/0.0.255.255', error => qr{Can't decode} }, { ip => '0.0.0.0/0', expect => [ [ 0, 0, 0, 0, 0 ], [ 1, 0, 0, 0, 0 ] ] }, { ip => '192.168.0.12-192.168.1.13', expect => [ [ 0, 192, 168, 0, 12 ], [ 0, 192, 168, 1, 14 ] ] }, { ip => '0.0.0.0-255.255.255.255', expect => [ [ 0, 0, 0, 0, 0 ], [ 1, 0, 0, 0, 0 ] ] }, ); for my $case ( @case ) { my @enc = eval { Net::CIDR::Set::IPv4->encode( $case->{ip} ) }; if ( my $error = $case->{error} ) { like $@, $error, 'error'; } else { my @got = map { [ unpack 'C*', $_ ] } @enc; is_deeply [@got], $case->{expect}, "encode $case->{ip}"; } } } { my @case = ( { range => [ [ 0, 127, 0, 0, 1 ], [ 0, 127, 0, 0, 2 ] ], generic => 0, expect => '127.0.0.1', }, { range => [ [ 0, 127, 0, 0, 1 ], [ 0, 127, 0, 0, 2 ] ], generic => 1, expect => '127.0.0.1/32', }, { range => [ [ 0, 127, 0, 0, 1 ], [ 0, 127, 0, 0, 2 ] ], generic => 2, expect => '127.0.0.1-127.0.0.1', }, { range => [ [ 0, 192, 168, 0, 12 ], [ 0, 192, 168, 1, 14 ] ], generic => 0, expect => '192.168.0.12-192.168.1.13', }, { range => [ [ 0, 0, 0, 0, 0 ], [ 1, 0, 0, 0, 0 ] ], generic => 0, expect => '0.0.0.0/0', }, { range => [ [ 0, 0, 0, 0, 0 ], [ 1, 0, 0, 0, 0 ] ], generic => 1, expect => '0.0.0.0/0', }, { range => [ [ 0, 0, 0, 0, 0 ], [ 1, 0, 0, 0, 0 ] ], generic => 2, expect => '0.0.0.0-255.255.255.255', }, ); for my $case ( @case ) { my $got = Net::CIDR::Set::IPv4->decode( ( map { pack 'C*', @$_ } @{ $case->{range} } ), $case->{generic} ); is $got, $case->{expect}, "$got"; } } { is Net::CIDR::Set::_conjunction( or => 1, 2, 3 ), '1, 2 or 3', '_conjunction'; is Net::CIDR::Set::_and( 1, 2, 3 ), '1, 2 and 3', '_and'; } # vim:ts=2:sw=2:et:ft=perl Net-CIDR-Set-0.13/t/pod.t000444001750001750 21412302646471 14035 0ustar00andyandy000000000000#!perl -T use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); Net-CIDR-Set-0.13/t/basic.t000444001750001750 347012302646471 14363 0ustar00andyandy000000000000#!perl use strict; use warnings; use Test::More tests => 10; use Net::CIDR::Set; { ok defined( my $set = Net::CIDR::Set->new ), "set created OK"; isa_ok $set, 'Net::CIDR::Set'; $set->add( '127.0.0.1' ); my @got = $set->as_address_array; is_deeply [@got], ['127.0.0.1'], "got address"; } { my $set = Net::CIDR::Set->new; $set->add( '192.168.0.0/16' ); { my @got = $set->as_cidr_array; is_deeply [@got], ['192.168.0.0/16'], "got cidr"; } $set->remove( '192.168.0.65' ); { my @got = $set->as_range_array; is_deeply [@got], [ '192.168.0.0-192.168.0.64', '192.168.0.66-192.168.255.255' ], "got range"; my $s2 = Net::CIDR::Set->new( @got ); ok $set->equals( $s2 ), "can reparse"; } { my @got = $set->as_cidr_array; is_deeply [@got], [ '192.168.0.0/26', '192.168.0.64', '192.168.0.66/31', '192.168.0.68/30', '192.168.0.72/29', '192.168.0.80/28', '192.168.0.96/27', '192.168.0.128/25', '192.168.1.0/24', '192.168.2.0/23', '192.168.4.0/22', '192.168.8.0/21', '192.168.16.0/20', '192.168.32.0/19', '192.168.64.0/18', '192.168.128.0/17' ], "got cidr"; my $s2 = Net::CIDR::Set->new( @got ); ok $set->equals( $s2 ), "can reparse"; } } { my @private = map { Net::CIDR::Set->new( $_ ) } '10.0.0.0/8', '192.168.0.0/16', '172.16.0.0/12'; my $all_priv = Net::CIDR::Set->new; for my $priv ( @private ) { $all_priv = $all_priv->union( $priv ); } my @got = $all_priv->as_cidr_array; is_deeply [@got], [ '10.0.0.0/8', '172.16.0.0/12', '192.168.0.0/16', ], "union"; } { my $s1 = Net::CIDR::Set->new( '10.0.0.0/9' ); my $s2 = Net::CIDR::Set->new( '10.128.0.0/9' ); my $hit = $s1->intersection( $s2 ); ok $hit->is_empty, "no intersection" or diag "got $hit"; } # vim:ts=2:sw=2:et:ft=perl Net-CIDR-Set-0.13/t/ipv6.t000444001750001750 156112302646471 14165 0ustar00andyandy000000000000#!perl use strict; use warnings; use Test::More tests => 6; use Net::CIDR::Set; { ok my $set = eval { Net::CIDR::Set->new( '2001:0db8:1234::/48' ) }, 'parsed'; ok !$@, 'no error' or diag $@; my @r = $set->as_range_array( 2 ); is_deeply [@r], ['2001:db8:1234::-2001:db8:1234:ffff:ffff:ffff:ffff:ffff'], 'range'; } { ok my $set = eval { Net::CIDR::Set->new( '2001:10::/28', '2001::/32', '2001:db8::/32', '2002::/16', '::/128', '::1/128', '::ffff:0:0/96', 'fc00::/7', 'fe80::/10', 'fec0::/10', 'ff00::/8', ); }, 'parsed'; ok !$@, 'no error' or diag $@; my @r = $set->as_cidr_array( 1 ); is_deeply [@r], [ '::/127', '::ffff:0:0/96', '2001::/32', '2001:10::/28', '2001:db8::/32', '2002::/16', 'fc00::/7', 'fe80::/9', 'ff00::/8' ], 'correct data'; } # vim:ts=2:sw=2:et:ft=perl Net-CIDR-Set-0.13/t/00-load.t000444001750001750 31012302646471 14404 0ustar00andyandy000000000000use Test::More tests => 3; BEGIN { use_ok( 'Net::CIDR::Set' ); use_ok( 'Net::CIDR::Set::IPv4' ); use_ok( 'Net::CIDR::Set::IPv6' ); } diag( "Testing Net::CIDR::Set $Net::CIDR::Set::VERSION" ); Net-CIDR-Set-0.13/t/operations.t000444001750001750 132112302646471 15456 0ustar00andyandy000000000000#!perl use strict; use warnings; use Test::More tests => 4; use Net::CIDR::Set; use Data::Dumper; { my $s1 = Net::CIDR::Set->new( '0.0.0.0-0.0.0.255', '0.0.2.0-255.255.255.255' ); my $s2 = Net::CIDR::Set->new( '0.0.1.0-0.0.1.255' ); my $s3 = $s1->union( $s2 ); is_deeply [ $s3->as_cidr_array ], ['0.0.0.0/0'], 'union'; my $s4 = $s1->intersection( $s2 ); is_deeply [ $s4->as_cidr_array ], [], 'intersection'; my $s5 = $s1->complement->union( $s2->complement->union ); is_deeply [ $s5->as_cidr_array ], ['0.0.0.0/0'], 'complement + union'; my $s6 = $s1->complement->intersection( $s2->complement ); is_deeply [ $s6->as_cidr_array ], [], 'complement + intersection'; } # vim:ts=2:sw=2:et:ft=perl Net-CIDR-Set-0.13/inc000755001750001750 012302646471 13262 5ustar00andyandy000000000000Net-CIDR-Set-0.13/inc/MyBuilder.pm000444001750001750 353112302646471 15653 0ustar00andyandy000000000000package MyBuilder; use base qw( Module::Build ); sub create_build_script { my ( $self, @args ) = @_; $self->_auto_mm; return $self->SUPER::create_build_script( @args ); } sub _auto_mm { my $self = shift; my $mm = $self->meta_merge; my @meta = qw( homepage bugtracker MailingList repository ); for my $meta ( @meta ) { next if exists $mm->{resources}{$meta}; my $auto = "_auto_$meta"; next unless $self->can( $auto ); my $av = $self->$auto(); $mm->{resources}{$meta} = $av if defined $av; } $self->meta_merge( $mm ); } sub _auto_repository { my $self = shift; if ( -d '.svn' ) { my $info = `svn info .`; return $1 if $info =~ /^URL:\s+(.+)$/m; } elsif ( -d '.git' ) { my $info = `git remote -v`; return unless $info =~ /^origin\s+(.+)$/m; my $url = $1; # Special case: patch up github URLs $url =~ s!^git\@github\.com:!git://github.com/!; return $url; } return; } sub _auto_bugtracker { 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=' . shift->dist_name; } sub ACTION_testauthor { my $self = shift; $self->test_files( 'xt/author' ); $self->ACTION_test; } sub ACTION_critic { exec qw( perlcritic -1 -q -profile perlcriticrc lib/ ), glob 't/*.t'; } sub ACTION_tags { exec( qw( ctags -f tags --recurse --totals --exclude=blib --exclude=.svn --exclude='*~' --languages=Perl t/ lib/ ) ); } sub ACTION_tidy { my $self = shift; my @extra = qw( Build.PL ); my %found_files = map { %$_ } $self->find_pm_files, $self->_find_file_by_type( 'pm', 't' ), $self->_find_file_by_type( 'pm', 'inc' ), $self->_find_file_by_type( 't', 't' ); my @files = ( keys %found_files, map { $self->localize_file_path( $_ ) } @extra ); for my $file ( @files ) { system 'perltidy', '-b', $file; unlink "$file.bak" if $? == 0; } } 1;