?????????? ????????? - ??????????????? - /home/.cpan/build/Data-Validate-IP-0.31-0/t/lib/Test/Data/Validate/IP.pm
???????
package # hide from PAUSE Test::Data::Validate::IP; use strict; use warnings; use Data::Validate::IP; use Exporter qw( import ); use Test::More 0.88; ## no critic (Modules::ProhibitAutomaticExportation) our @EXPORT = 'run_tests'; ## use critic my $object = Data::Validate::IP->new(); my %ipv4_types = ( private => [qw(10.0.0.1 172.16.0.1 192.168.0.1)], public => [qw(1.2.3.4 123.123.44.55 216.17.184.1)], loopback => [qw(127.0.0.1)], testnet => [qw(192.0.2.9 198.51.100.33 203.0.113.44)], multicast => [qw(224.0.0.1)], anycast => [qw(192.88.99.45)], linklocal => [qw(169.254.0.1)], unroutable => [ qw( 0.0.0.1 100.64.1.2 192.0.0.4 198.18.0.55 240.0.0.4 255.255.255.254 255.255.255.255 ) ], ); my %ipv6_types = ( private => [ qw( fc00:: fc01::1234 fdef:: fdff:ffff:ffff:ffff:ffff:ffff:ffff:ffff ) ], public => [ qw( ::abcd:1234 1:: 2:: 1:1:1:1:: 2001:abcd:: abcd:: ) ], loopback => [qw(::1)], ipv4_mapped => [ qw( ::ffff:0:0 ::ffff:0:1234 ::ffff:1.2.3.4 ::ffff:ffff:ffff ) ], discard => [ qw( 100:: 100::1234 100:0000:0000:0000:ffff:ffff:ffff:ffff ) ], multicast => [ qw( ff00:: ffff:: ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff ) ], linklocal => [ qw( fe80:: fe89:: febf:: febf:ffff:ffff:ffff:ffff:ffff:ffff:ffff ) ], special => [ [ '2001::' => [qw( teredo )] ], [ '2001::1234' => [qw( teredo )] ], qw( 2001:1ff:ffff:ffff:ffff:ffff:ffff:ffff ) ], teredo => [ qw( 2001:: 2001::1234 2001:0:ffff:ffff:ffff:ffff:ffff:ffff ) ], orchid => [ qw( 2001:10:: 2001:10::1234 2001:001F:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF ) ], documentation => [ qw( 2001:db8:: 2001:db8::1234 2001:0db8:ffff:ffff:ffff:ffff:ffff:ffff ) ], unspecified => [ qw( :: ::0 ) ], ); my %ip_types = map { $_ => [ @{ $ipv4_types{$_} }, @{ $ipv6_types{$_} } ] } qw( linklocal loopback multicast private public ); sub run_tests { _ipv4_basic_tests(); _type_tests( \%ipv4_types, 4 ); _ipv4_innet_tests(); _ipv6_basic_tests(); _type_tests( \%ipv6_types, 6 ); # Tests for subs without a family _ip_basic_tests(); _type_tests( \%ip_types ); } sub _ipv4_basic_tests { my @valid_ipv4 = qw( 0.0.0.0 1.2.3.4 216.17.184.1 255.255.255.255 ); for my $ip (@valid_ipv4) { is( is_ipv4($ip), $ip, "is_ipv4($ip) returns $ip" ); is( $object->is_ipv4($ip), $ip, "->is_ipv4($ip) returns $ip" ); } my @invalid_ipv4 = ( qw( 2067:fa88::0 www.neely.cx 216.17.184.G 216.17.184.1. 216.17.184 216.17.184. 256.17.184.1 216.017.184.1 016.17.184.1 ), "1.1.1.1\0 exploit goes here", ); for my $ip (@invalid_ipv4) { is( is_ipv4($ip), undef, "is_ipv4($ip) returns undef" ); is( $object->is_ipv4($ip), undef, "->is_ipv4($ip) returns undef" ); for my $type ( sort keys %ipv4_types ) { my ( $is_sub_name, $is_sub ) = _sub_for_type( $type, 4 ); is( $is_sub->($ip), undef, "$is_sub_name($ip) returns undef" ); is( $object->$is_sub_name($ip), undef, "->$is_sub_name($ip) returns undef" ); } } } sub _ipv4_innet_tests { my @tests = ( [ '216.17.184.1', '216.17.184.0/24', 1 ], [ '127.0.0.1', '216.17.184.0/24', 0 ], [ 'invalid', '216.17.184.0/24', 0 ], [ '0.0.0.0', 'default', 1 ], [ '1.2.3.4', 'default', 1 ], [ '216.240.32.1', '216.240.32.1', 1 ], ); # These are accepted for backwards compatibility with the time when we # used Net::Netmask. my @deprecated = ( [ '216.240.32.1', '216.240.32/24', 1, 1 ], [ '216.240.32.1', '216.240/16', 1, 1 ], [ '216.240.32.1', '216.240.32.0:255.255.255.0', 1, 1 ], [ '216.240.32.1', '216.240.32.0-255.255.255.0', 1, 1 ], [ '216.240.32.1', '216.240.32', 1, 1 ], [ '216.240.32.1', '216.240', 1, 1 ], [ '216.240.32.1', '216', 1, 1 ], [ '216.240.32.1', '216.240.32.0#0.0.31.255', 1, 1 ], ); my @warnings; for my $triplet ( @tests, @deprecated ) { my ( $ip, $network, $is_member, $is_deprecated ) = @{$triplet}; my $expect = $is_member ? $ip : undef; my $expect_string = $expect || 'undef'; local $SIG{__WARN__} = sub { push @warnings, @_ } if $is_deprecated; is( is_innet_ipv4( $ip, $network ), $expect, "is_innet_ipv4($ip, $network) returns $expect_string" ); } is( scalar @warnings, 1, 'got one warning from is_innet_ipv4' ); like( $warnings[0], qr/\QUse of non-CIDR notation for networks with is_innet_ipv4() is deprecated/, 'got expected deprecation warning' ); like( $warnings[0], qr/at line \d+ of Test::Data::Validate::IP in sub Test::Data::Validate::IP::_ipv4_innet_tests/, 'deprecation warning identifies caller' ); } sub _ipv6_basic_tests { my @valid = qw( 2067:fa88::0 2067:FA88::1 2067:FA88:: 2001:4888:205:7126:e0:120:: 2607:fa88::8a2e:370:7334 2001:0db8:0000:0000:0000:0000:1428:57ab 2001:0db8:0000:0000:0000::1428:57ab 2001:0db8:0:0:0:0:1428:57ab 2001:0db8:0:0::1428:57ab 2001:0db8::1428:57ab 2001:db8::1428:57ab :: ::0 ::1 ::ffff:12.34.56.78 0:0:0:0:0:ffff:12.34.56.78 ); for my $ip (@valid) { is( is_ipv6($ip), $ip, "is_ipv6($ip) returns $ip" ); is( $object->is_ipv6($ip), $ip, "->is_ipv6($ip) returns $ip" ); } my @invalid = ( qw( 0000:00:0000:0000:0000:0000:0000:00000 2067:fa88 2067:FA88 2067::: 2067:::1 2067::1: 216.17.184.1 bbb.bbb.bbb ::: g123::1234 :abcd ), "::1\0 invalid", ); for my $ip (@invalid) { is( is_ipv6($ip), undef, "is_ipv6($ip) returns undef" ); is( $object->is_ipv6($ip), undef, "->is_ipv6($ip) returns undef" ); for my $type ( sort keys %ipv6_types ) { my ( $is_sub_name, $is_sub ) = _sub_for_type( $type, 6 ); is( $is_sub->($ip), undef, "$is_sub_name($ip) returns undef" ); is( $object->$is_sub_name($ip), undef, "->$is_sub_name($ip) returns undef" ); } } } sub _ip_basic_tests { my @valid = qw( 1.1.1.1 2067:fa88::0 ::1.1.1.1 ); for my $ip (@valid) { is( is_ip($ip), $ip, "is_ip($ip) returns $ip" ); is( $object->is_ip($ip), $ip, "->is_ip($ip) returns $ip" ); } my @invalid = ( qw( 2067:fa88 216.17.184 :216.17.184 ), "::1\0 invalid" ); for my $ip (@invalid) { is( is_ip($ip), undef, "is_ip($ip) returns undef" ); is( $object->is_ip($ip), undef, "->is_ip($ip) returns undef" ); } } sub _type_tests { my $types = shift; my $ip_number = shift; my @types = sort keys %{$types}; for my $type (@types) { for my $test ( @{ $types->{$type} } ) { my ( $ip, $is_also ) = ref $test ? @{$test} : ( $test, [] ); my ( $is_sub_name, $is_sub ) = _sub_for_type( $type, $ip_number ); is( $is_sub->($ip), $ip, "$is_sub_name($ip) returns $ip" ); is( $object->$is_sub_name($ip), $ip, "->$is_sub_name($ip) returns $ip" ); for my $other ( sort grep { $_ ne $type } @types ) { next if grep { $_ eq $other } @{$is_also}; my ( $other_sub_name, $other_sub ) = _sub_for_type( $other, $ip_number ); ## no critic (Subroutines::ProtectPrivateSubs) if ( Data::Validate::IP::_network_is_subnet_of( $type, $other ) ) { is( $other_sub->($ip), $ip, "$other_sub_name($ip) returns $ip" ); is( $object->$other_sub_name($ip), $ip, "->$other_sub_name($ip) returns $ip" ); } else { is( $other_sub->($ip), undef, "$other_sub_name($ip) returns undef" ); is( $object->$other_sub_name($ip), undef, "->$other_sub_name($ip) returns undef" ); } } } } } sub _sub_for_type { my $type = shift; my $ip_number = shift; my $sub_name = 'is_' . $type . '_ip'; $sub_name .= 'v' . $ip_number if defined $ip_number; my $sub = do { ## no critic (TestingAndDebugging::ProhibitNoStrict) no strict 'refs'; \&{$sub_name}; } or die "No sub named $sub_name was imported"; return ( $sub_name, $sub ); } 1;
| ver. 1.6 |
Github
|
.
| PHP 8.2.30 | ??????????? ?????????: 0.01 |
proxy
|
phpinfo
|
???????????