diff --git a/IP.pm b/IP.pm index c136de2..9a3d252 100644 --- a/IP.pm +++ b/IP.pm @@ -1,6 +1,6 @@ #!/usr/bin/perl -w -# $Id: IP.pm,v 1.30 2005/03/24 21:14:46 lem Exp $ +# $Id: IP.pm,v 1.32 2005/08/25 15:37:29 lem Exp $ package NetAddr::IP; @@ -28,7 +28,7 @@ =head1 DESCRIPTION This module provides an object-oriented abstraction on top of IP -addresses or IP subnets, that allows for easy manipulations. Many +addresses or IP subnets, that allows for easy manipulations. Many operations are supported, as described below: =head2 Overloaded Operators @@ -48,7 +48,13 @@ our @ISA = qw(Exporter); -our $VERSION = '3.24'; +our $VERSION = '3.25'; + +# Set to true, to enable recognizing of 4-octet binary notation IP +# addresses. Thanks to Steve Snodgrass for reporting. This can be done +# at the time of use-ing the module. See docs for details. + +our $Accept_Binary_IP = 0; ############################################# # These are the overload methods, placed here @@ -294,6 +300,8 @@ return $ip; } +=pod + =item B Auto-decrementing a NetAddr::IP object performs exactly the opposite @@ -426,13 +434,13 @@ } sub _parse_mask ($$) { - my $mask = lc shift; + my $mask = shift; my $bits = shift; my $bmask = ''; if ($bits == 128) { - if (grep($mask eq $_ , qw(unspecified loopback))) { + if (grep(lc $mask eq $_ , qw(unspecified loopback))) { for (0..3) { vec($bmask, $_, 32) = 0xFFFFFFFF; } @@ -456,13 +464,13 @@ } return $bmask; } - elsif ($mask eq 'default' or $mask eq 'any') { + elsif (lc $mask eq 'default' or lc $mask eq 'any') { vec($bmask, 0, $bits) = 0x0; } - elsif ($mask eq 'broadcast' or $mask eq 'host') { + elsif (lc $mask eq 'broadcast' or lc $mask eq 'host') { vec($bmask, 0, $bits) = _ones $bits; } - elsif ($mask eq 'loopback') { + elsif (lc $mask eq 'loopback') { vec($bmask, 0, 8) = 255; vec($bmask, 1, 8) = 0; vec($bmask, 2, 8) = 0; @@ -511,20 +519,20 @@ } sub _v4 ($$$) { - my $ip = lc shift; + my $ip = shift; my $mask = shift; my $present = shift; my $addr = ''; my $a; - if ($ip eq 'default' or $ip eq 'any') { + if (lc $ip eq 'default' or lc $ip eq 'any') { vec($addr, 0, 32) = 0x0; } - elsif ($ip eq 'broadcast') { + elsif (lc $ip eq 'broadcast') { vec($addr, 0, 32) = _ones 32; } - elsif ($ip eq 'loopback') { + elsif (lc $ip eq 'loopback') { vec($addr, 0, 8) = 127; vec($addr, 3, 8) = 1; } @@ -694,6 +702,23 @@ vec($mask, 1, 8) = _obits $2, $6; vec($mask, 2, 8) = _obits $3, $7; vec($mask, 3, 8) = _obits $4, $8; + + # Barf on invalid ranges. There can only be one + # octet in the netmask that is neither 0 nor 255. + + return + if grep ({ + vec($mask, $_, 8) != 0 + and vec($mask, $_, 8) != 255 + } (0 .. 3)) > 1; + + # Barf on invalid ranges. No octet on the right + # can be larger that any octet on the left + + for (0 .. 2) + { + return if vec($mask, $_, 8) < vec($mask, $_ + 1, 8); + } } elsif (($a = gethostbyname($ip)) and defined($a) and ($a ne pack("C4", 0, 0, 0, 0))) { @@ -704,7 +729,8 @@ vec($addr, 3, 8) = $4; } } - elsif (!$present and length($ip) == 4) { + elsif ($Accept_Binary_IP + and !$present and length($ip) == 4) { my @o = unpack("C4", $ip); vec($addr, $_, 8) = $o[$_] for 0 .. 3; @@ -712,7 +738,7 @@ } else { # croak "Cannot obtain an IP address out of $ip"; - return undef; + return; } return { addr => $addr, mask => $mask, bits => 32 }; @@ -829,7 +855,13 @@ }; } + if (grep { $_ eq ':aton' } @_) + { + $Accept_Binary_IP = 1; + } + @_ = grep { $_ ne ':old_storable' } @_; + @_ = grep { $_ ne ':aton' } @_; NetAddr::IP->export_to_level(1, @_); } @@ -853,8 +885,13 @@ speficied by the prefix must match with a valid subnet. Addresses in the same format returned by C or -C are also understood, although no mask can be -specified for them. +C can also be understood, although no mask can be +specified for them. The default is to not attempt to recognize this +format, as it seems to be seldom used. + +To accept addresses in that format, invoke the module as in + + use NetAddr::IP ':aton' If called with no arguments, 'default' is assumed. @@ -866,7 +903,7 @@ sub new ($$;$) { my $type = $_[0]; my $class = ref($type) || $type || "NetAddr::IP"; - my $ip = lc $_[1]; + my $ip = $_[1]; my $hasmask = 1; my $bits; my $mask; @@ -879,7 +916,7 @@ $ip = $1; $mask = $2; } - elsif (grep { $ip eq $_ } (qw(default any broadcast loopback))) + elsif (grep { lc $ip eq $_ } (qw(default any broadcast loopback))) { $mask = $ip; } @@ -887,7 +924,7 @@ if (defined $_[2]) { if ($_[2] =~ /^ipv6$/i) { - if (grep { $ip eq $_ } (qw(unspecified loopback))) { + if (grep { lc $ip eq $_ } (qw(unspecified loopback))) { $bits = 128; $mask = _parse_mask $ip, $bits; } @@ -1264,7 +1301,7 @@ } } -*{compact_addr} = \&short; +# *{compact_addr} = \&short; =pod @@ -1764,7 +1801,7 @@ =head1 HISTORY -$Id: IP.pm,v 1.30 2005/03/24 21:14:46 lem Exp $ +$Id: IP.pm,v 1.32 2005/08/25 15:37:29 lem Exp $ =over @@ -2363,6 +2400,14 @@ Version bump. Transfer of 3.23 to CPAN ended up in a truncated file being uploaded. +=item 3.25 + +Some IP specs resembling range notations but not depicting actual CIDR +ranges, were being erroneously recognized. Thanks to Steve Snodgrass +for reporting a bug with parsing IP addresses in 4-octet binary +format. Added optional Pod::Coverage tests. compact_addr has been +commented out, after a long time as deprecated. + =back =head1 AUTHOR diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP index d9961d4..c5a17ca 100644 --- a/MANIFEST.SKIP +++ b/MANIFEST.SKIP @@ -11,6 +11,7 @@ ^tmp/ \.old$ \.bak$ +\.tmp$ ~$ ^# \.shar$ diff --git a/META.yml b/META.yml index 8db21c1..ea8e13e 100644 --- a/META.yml +++ b/META.yml @@ -1,11 +1,12 @@ +# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: NetAddr-IP -version: 3.24 +version: 3.25 version_from: IP.pm installdirs: site requires: - Test::More: 0 Math::BigInt: 0 + Test::More: 0 distribution_type: module -generated_by: ExtUtils::MakeMaker version 6.12 +generated_by: ExtUtils::MakeMaker version 6.17 diff --git a/Makefile.PL b/Makefile.PL index b67741d..f535d17 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -2,7 +2,7 @@ # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. -# $Id: Makefile.PL,v 1.10 2005/03/24 18:55:10 lem Exp $ +# $Id: Makefile.PL,v 1.11 2005/08/25 15:36:09 lem Exp $ my $checker = 0; @@ -26,6 +26,25 @@ ; } +$checker = 0; + +eval q{ use Pod::Coverage; + $checker = 1; }; + +unless ($checker) +{ + print < 2 * scalar @modules; +plan tests => 3 * scalar @modules; use_ok($_) for @modules; my $checker = 0; +my $coverage = 0; eval { require Test::Pod; Test::Pod::import(); $checker = 1; }; +eval { require Pod::Coverage; + Pod::Coverage::import(); + $coverage = 1; }; + for my $m (@modules) { my $p = $m . ".pm"; @@ -27,11 +32,35 @@ push @paths, $INC{$p}; } -END { unlink "./out.$$" }; - SKIP: { skip "Test::Pod is not available on this host", scalar @paths unless $checker; pod_file_ok($_) for @paths; + + skip "Pod::Coverage is not available on this host", scalar @paths + unless $coverage; + + for my $m (@modules) + { + my $pc = Pod::Coverage->new(package => $m, + also_private => [qr/^STORABLE_/, + qr/^new4$/, + qr/^expand_v6$/, + qr/^do_prefix$/, + ], + trustme => [ qr/^Coalesce$|^Compact$/, + qr/^(plus){1,2}$/, + qr/^(minus){1,2}$/ + ], + ); + unless (is($pc->coverage, 1, "Coverage for $m")) + { +# diag "Symbols covered:\n", +# join("\n", map { " " . $_ } $pc->covered); + diag "Symbols NOT covered:\n", + join("\n", map { " " . $_ } $pc->naked); + } + } } + diff --git a/t/v4-aton.t b/t/v4-aton.t index f32cc95..7766aab 100644 --- a/t/v4-aton.t +++ b/t/v4-aton.t @@ -1,8 +1,7 @@ -use Test::More tests => 15; +use Test::More tests => 18; use Socket; -use NetAddr::IP; -# $Id: v4-aton.t,v 1.2 2002/10/31 13:45:29 lem Exp $ +# $Id: v4-aton.t,v 1.3 2005/08/25 15:38:03 lem Exp $ my @addr = ( [ 'localhost', '127.0.0.1' ], @@ -13,11 +12,29 @@ ); -is(NetAddr::IP->new($_->[0])->aton, inet_aton($_->[1]), "->aton($_->[0])") - for @addr; +# Verify that Accept_Binary_IP works... -ok(defined NetAddr::IP->new(inet_aton($_->[1])), "->new aton($_->[1])") - for @addr; +SKIP: +{ + skip "Failed to load NetAddr::IP", 17 + unless use_ok('NetAddr::IP'); -is(NetAddr::IP->new(inet_aton($_->[1]))->addr, $_->[1], "->new aton($_->[1])") - for @addr; + ok(! defined NetAddr::IP->new("\1\1\1\1"), + "binary unrecognized by default..."); + + # This mimicks the actual use with :aton + NetAddr::IP::import(':aton'); + + ok(defined NetAddr::IP->new("\1\1\1\1"), + "...but can be recognized"); + + is(NetAddr::IP->new($_->[0])->aton, inet_aton($_->[1]), "->aton($_->[0])") + for @addr; + + ok(defined NetAddr::IP->new(inet_aton($_->[1])), "->new aton($_->[1])") + for @addr; + + is(NetAddr::IP->new(inet_aton($_->[1]))->addr, $_->[1], + "->new aton($_->[1])") + for @addr; +} diff --git a/t/v4-badnm.t b/t/v4-badnm.t index 096a371..d5d4511 100644 --- a/t/v4-badnm.t +++ b/t/v4-badnm.t @@ -1,58 +1,44 @@ # I know this does not look like -*- perl -*-, but I swear it is... -# $Id: v4-badnm.t,v 1.2 2002/10/31 04:30:35 lem Exp $ +# $Id: v4-badnm.t,v 1.3 2005/08/08 02:42:05 lem Exp $ -use NetAddr::IP; use strict; +use Test::More; $| = 1; our @badnets = ( - '10.10.10.10/255.255.0.255', - '10.10.10.10/255.0.255.255', - '10.10.10.10/0.255.255.255', - '10.10.10.10/128.255.0.255', - '10.10.10.10/255.128.0.255', - '10.10.10.10/255.255.255.129', - '10.10.10.10/255.255.129.0', - '10.10.10.10/255.255.255.130', - '10.10.10.10/255.255.130.0', - '10.10.10.10/255.0.0.1', - '10.10.10.10/255.129.0.1', - '10.10.10.10/0.255.0.255', - ); + '10.10.10.10/255.255.0.255', + '10.10.10.10/255.0.255.255', + '10.10.10.10/0.255.255.255', + '10.10.10.10/128.255.0.255', + '10.10.10.10/255.128.0.255', + '10.10.10.10/255.255.255.129', + '10.10.10.10/255.255.129.0', + '10.10.10.10/255.255.255.130', + '10.10.10.10/255.255.130.0', + '10.10.10.10/255.0.0.1', + '10.10.10.10/255.129.0.1', + '10.10.10.10/0.255.0.255', + '58.26.0.0-58.27.127.255', # Taken from APNIC's WHOIS case +); our @goodnets = (); push @goodnets, "10.0.0.1/$_" for (0 .. 32); push @goodnets, "10.0.0.1/255.255.255.255"; -print '1..', (scalar @badnets + scalar @goodnets) , "\n"; +plan tests => 1 + @badnets + @goodnets; + +die "# Cannot continue without NetAddr::IP\n" + unless use_ok('NetAddr::IP'); my $count = 1; -for my $bad (@badnets) { +ok(! defined NetAddr::IP->new($_), "new $_ should fail") + for @badnets; - if (defined NetAddr::IP->new($bad)) { - print "not ok $count # $bad should fail but succeeded\n"; - } - else { - print "ok $count # $bad must fail\n"; - } - - ++ $count; -} - -for my $good (@goodnets) { - - if (defined NetAddr::IP->new($good)) { - print "ok $count # $good should not fail\n"; - } - else { - print "not ok $count # $good must not fail\n"; - } - - ++ $count; -} +ok(defined NetAddr::IP->new($_), "new $_ should work") + for @goodnets;