File Coverage

blib/lib/Net/IP/Lite.pm

Criterion	Covered	Total	%
statement	344	349	98.5
branch	235	242	97.1
condition	82	88	93.1
subroutine	50	52	96.1
pod	20	21	95.2
total	731	752	97.2

package Net::IP::Lite;

use strict;
use warnings;

use Carp qw(croak);
use Scalar::Util qw(blessed);

use base 'Exporter';

our @EXPORT = qw(
	ip2bin ip_validate ip_is_ipv4 ip_is_ipv6 ip_is_ipv6ipv4
	ip_transform ip_equal ip_equal_v4 ip_equal_v6 ip_in_range
);

use constant IPV6IPV4HEAD => '0' x 80 . '1' x 16;

our $VERSION = '0.03';

sub _wrong_ip {
	my $addr = shift;
	$addr = 'UNDEFINED' unless defined $addr;
	return "Wrong IP address: '$addr'";
}

sub _wrong_ipv6ipv4 {
	my $addr = shift;
	$addr = 'UNDEFINED' unless defined $addr;
	return "Failed to convert IPv6 address '$addr' to IPv4 address";
}

sub _wrong_net {
	my $net = shift;
	$net = 'UNDEFINED' unless defined $net;
	return "Wrong network definition: '$net'";
}

sub ip2bin {
	my $addr = shift;
	return '' unless defined $addr;

	my $bin = '';

	if ($addr =~ /:/) {
		# IPv6 address

		return '0' x 128 if $addr eq '::';

		return '' if $addr =~ s/^:// && $addr !~ /^:/;
		return '' if $addr =~ s/:$// && $addr !~ /:$/;

		my @words = split(/:/, $addr, -1);
		my $words_amount = scalar @words;

		# IPv4 representation
		$words_amount++ if $addr =~ /\./;

		my $reduct = 0;
		my $i = 0;
		for my $word (@words) {
			$i++;
			if ($word =~ /\./) {
				# IPv4 representation
				return '' if $i != scalar @words || $bin ne IPV6IPV4HEAD;
				my @octets = split(/\./, $word);
				return '' if scalar @octets != 4;
				for my $octet (@octets) {
					return '' if $octet !~ /^\d+$/ || $octet > 255;
					$bin .= unpack('B8', pack('C', $octet));
				}
				return $bin;
			} elsif (!length $word) {
				return '' if $reduct;
				$reduct = 1;
				my $len = (9 - $words_amount) << 4;
				return '' unless $len;
				$bin .= '0' x ((9 - $words_amount) << 4);
			} elsif ($word =~ /^[0-9a-f]+$/i) {
				$word =~ s/^0+//i;
				return '' if length($word) > 4;
				my $int = hex($word);
				$bin .= unpack('B16', pack('n', $int));
			} else {
				return '';
			}
			return '' if length($bin) > 128;
		}
		return '' if length($bin) < 128;
	} elsif ($addr =~ /\./) {
		# IPv4
		my @octets = split(/\./, $addr, -1);
		return '' if scalar @octets > 4;
		my $i = 0;
		for my $octet (@octets) {
			$i++;
			my $dec;
			if ($octet =~ /^0[0-7]+$/) {
				# Octal octet
				$octet =~ s/^0+//;
				return '' if length($octet) > 3;
				$dec = oct($octet);
			} elsif ($octet =~ /^\d+$/) {
				# Decimal octet
				return '' if length($octet) > 3;
				$dec = $octet;
			} elsif ($octet =~ /^0x[0-9a-f]+$/i) {
				# Hexadecimal octet
				$octet =~ s/^0x0*//i;
				return '' if length($octet) > 2;
				$dec = hex($octet);
			} else {
				return '';
			}
			return '' if $dec > 255;
			if ($i == scalar @octets && $i < 4) {
				# add missed octets
				$bin .= '0' x ((4 - $i) << 3);
			}
			$bin .= unpack('B8', pack('C', $dec));
		}
	} elsif ($addr =~ /^0[0-7]+$/) {
		# Octal IPv4 address
		$addr =~ s/^0+//i;
		return '' if $addr > 37777777777;
		my $int = oct($addr);
		$bin = unpack('B32', pack('N', $int));
	} elsif ($addr =~ /^\d+$/) {
		# Decimal IPv4 address
		return '' if $addr > 4294967295;
		$bin = unpack('B32', pack('N', $addr));
	} elsif ($addr =~ /^0x[0-9a-f]+$/i) {
		# Hexadecimal IPv4 addres
		$addr =~ s/^0x0*//i;
		return '' if length($addr) > 8;
		my $int = hex($addr);
		$bin = unpack('B32', pack('N', $int));
	}
	return $bin;
}

sub _ip_validate {
	return length(shift) > 0;
}

sub ip_validate {
	return _ip_validate(ip2bin(shift)) > 0;
}

sub _ip_is_ipv4 {
	return length(shift) eq 32;
}

sub ip_is_ipv4 {
	return _ip_is_ipv4(ip2bin(shift));
}

sub _ip_type_equal {
	return length(shift) == length(shift);
}

sub _ip_is_ipv6 {
	return length(shift) eq 128;
}

sub ip_is_ipv6 {
	return _ip_is_ipv6(ip2bin(shift));
}

sub _ip_is_ipv6ipv4 {
	return substr(shift, 0, 96) eq IPV6IPV4HEAD;
}

sub ip_is_ipv6ipv4 {
	return _ip_is_ipv6ipv4(ip2bin(shift));
}

sub _bin2ipv6 {
	my ($bin, $lead_zeros, $short) = @_;
	my $result = '';
	my @chunks = $bin =~ m/[0..1]{16}/g;

	my $short_len = 0;
	if ($short) {
		my @zero_chunks;
		my $i = 0;
		for my $chunk (@chunks) {
			if ($chunk !~ /1/) {
				$zero_chunks[$i]++;
			} else {
				$i++ if defined $zero_chunks[$i];
			}
		}
		@zero_chunks = sort @zero_chunks;
		$short_len = pop @zero_chunks if scalar @zero_chunks;
	}
	for my $chunk (@chunks) {
		my $word = unpack('H4', pack('B16', $chunk)) . ':';
		$word =~ s/^0{1,3}// unless $lead_zeros;
		$result .= $word;
	}

	$result =~ s/(^|:)(0{1,4}:){$short_len}/::/ if $short_len > 1;
	$result =~ s/:$// if $result !~ /::$/;
	return $result;
}

sub _bin2ipv4 {
	my ($bin, $format, $lead_zeros, $short) = @_;

	$format ||= '';
	my @chunks = $bin =~ m/[0..1]{8}/g;

	if ($format =~ /^(D|O|X)$/) {
		my $result = 0;
		my $i = 0;
		for my $chunk (reverse @chunks) {
			$result += unpack('C', pack('B8', $chunk)) << $i;
			$i +=8;
		}

		return sprintf("%#1o", $result) if $format eq 'O';
		return sprintf("0x%.8x", $result) if $format eq 'X' && $lead_zeros;
		return sprintf("0x%x", $result) if $format eq 'X';
		return $result;
	} else {
		my $result = '';
		my $f = '';
		if ($format eq 'o') {
			$f = '%#.1o';
		} elsif ($format eq 'x') {
			$f = $lead_zeros ? '0x%.2x' : '0x%x' ;
		}

		my $i = 4;
		for my $chunk (reverse @chunks) {
			$i--;
			my $octet = unpack('C', pack('B8', $chunk));
			if ($short) {
				next if (!$octet && $i && $i < 3 );
				$short = 0 if $i == 2;
			}
			if ($format eq 'o') {
				$octet = sprintf($f, $octet);
			} elsif ($format eq 'x') {
				$octet = sprintf($f, $octet);
			}
			$result = "$octet.$result";
		}
		$result =~ s/\.$//;
		return $result;
	}
}

sub _reverse {
	my $bin = shift;
	my $len = _ip_is_ipv4($bin) ? 8 : 16;
	my @chunks = $bin =~ m/[0..1]{$len}/g;
	return join('', reverse @chunks);
}

sub _ip_transform {
	my ($bin, $opts) = @_;

	my $format = $opts->{format_ipv4} || '';
	my $convert_to = $opts->{convert_to} || '';

	my $ipv6;
	my $ipv4;

	if ($convert_to eq 'ipv4' && _ip_is_ipv6ipv4($bin)) {
		# convert ipv6ipv4 to ipv4
		$bin = substr($bin, 96, 32);
	}

	if (($convert_to eq 'ipv6' || $convert_to eq 'ipv6ipv4') && _ip_is_ipv4($bin)) {
		# convert ipv4 to ipv6
		$bin = IPV6IPV4HEAD . $bin;
	}

	if ($convert_to eq 'ipv6ipv4' && _ip_is_ipv6ipv4($bin)) {
		# convert ipv4 to ipv6ipv4
		$ipv4 = substr($bin, 96, 32);
		$ipv4 = _reverse($ipv4) if $opts->{reverse};
		$bin = IPV6IPV4HEAD;
	} else {
		$bin = _reverse($bin) if $opts->{reverse};
	}

	my $result = '';
	if (length($bin) > 32) {
		# IPv6
		$result = _bin2ipv6($bin, $opts->{lead_zeros}, $opts->{short_ipv6});
		if ($ipv4) {
			$bin = $ipv4;
			$ipv6 = $result;
		}
	}

	if (length($bin) == 32) {
		# IPv4
		if ($ipv6) {
			$result = "$ipv6:" . _bin2ipv4($bin);
		} else {
			$result = _bin2ipv4($bin, $format, $opts->{lead_zeros}, $opts->{short_ipv4});
		}
	}

	return $result;
}

sub ip_transform {
	my ($addr, $opts) = @_;

	$opts ||= {};
	croak 'Options must be a hash' unless ref($opts) eq 'HASH';

	my $bin = ip2bin($addr);
	croak _wrong_ip($addr) unless _ip_validate($bin);
	return _ip_transform($bin, $opts);
}

sub _ip_equal {
	my ($bin1, $bin2) = @_;
	return $bin1 eq $bin2;
}

sub ip_equal {
	my ($addr1, $addr2) = @_;
	my $bin1 = ip2bin($addr1);
	my $bin2 = ip2bin($addr2);

	croak _wrong_ip($addr1) unless _ip_validate($bin1);
	croak _wrong_ip($addr2) unless _ip_validate($bin2);

	return $bin1 eq $bin2;
}

sub _ip_equal_v4 {
	my ($bin1, $bin2) = @_;
	$bin1 = substr($bin1, 96, 32) if _ip_is_ipv6ipv4($bin1);
	$bin2 = substr($bin2, 96, 32) if _ip_is_ipv6ipv4($bin2);
	return _ip_equal($bin1, $bin2);
}

sub ip_equal_v4 {
	my ($addr1, $addr2) = @_;
	my $bin1 = ip2bin($addr1);
	my $bin2 = ip2bin($addr2);

	croak _wrong_ip($addr1) unless _ip_validate($bin1);
	croak _wrong_ip($addr2) unless _ip_validate($bin2);

	if ((_ip_is_ipv6($bin1) && ! _ip_is_ipv6ipv4($bin1))) {
		croak _wrong_ipv6ipv4($addr1);
	}

	if ((_ip_is_ipv6($bin2) && ! _ip_is_ipv6ipv4($bin2))) {
		croak _wrong_ipv6ipv4($addr2);
	}

	return _ip_equal_v4($bin1, $bin2);
}

sub _ip_equal_v6 {
	my ($bin1, $bin2) = @_;
	$bin1 = IPV6IPV4HEAD . $bin1 if _ip_is_ipv4($bin1);
	$bin2 = IPV6IPV4HEAD . $bin2 if _ip_is_ipv4($bin2);
	return _ip_equal($bin1, $bin2);
}

sub ip_equal_v6 {
	my ($addr1, $addr2) = @_;
	my $bin1 = ip2bin($addr1);
	my $bin2 = ip2bin($addr2);

	croak _wrong_ip($addr1) unless _ip_validate($bin1);
	croak _wrong_ip($addr2) unless _ip_validate($bin2);

	return _ip_equal_v6($bin1, $bin2);
}

sub __ip_in_range {
	my ($bin_addr, $bin_net, $bin_mask) = @_;

	my @addr_bits = split(//, $bin_addr);
	my @mask_bits = split(//, $bin_mask);
	my $result = '';

	my $i = 0;
	for my $bit (@addr_bits) {
		$result	.= $bit & $mask_bits[$i];
		$i++;
	}

	return _ip_equal($bin_net, $result);
}

sub _ip_in_range {
	my ($bin_addr, $net, $addr) = @_;

	my $bin_net;
	my $bin_mask;

	if ($net =~ /^(.+)\/(\d+)$/) {
		my $mask = $2;
		$bin_net = ip2bin($1);
		croak _wrong_net($net) unless _ip_validate($bin_net);

		my $mask_len = _ip_is_ipv4($bin_net) ? 32 : 128;
		croak _wrong_net($net) if $mask > $mask_len;

		$bin_mask = '1' x $mask . '0' x ($mask_len - $mask);
	} elsif ($net =~ /^(\S+)\s+(\S+)$/) {
		$bin_net = ip2bin($1);
		$bin_mask = ip2bin($2);
	} else {
		$bin_net = ip2bin($net);
		$bin_mask = '1' x (_ip_is_ipv4($bin_net) ? 32 : 128);
	}

	unless (_ip_validate($bin_net) && _ip_validate($bin_mask) && _ip_type_equal($bin_net, $bin_mask)) {
		croak _wrong_net($net);
	}

	return 0 unless _ip_type_equal($bin_addr, $bin_net);

	return __ip_in_range($bin_addr, $bin_net, $bin_mask);
}

sub ip_in_range {
	my ($addr, $range) = @_;

	croak _wrong_net($range) unless defined $range;

	if (ref($range) eq 'ARRAY') {
		for my $net (@$range) {
			return 1 if ip_in_range($addr, $net);
		}
		return 0;
	}

	my $bin_addr = ip2bin($addr);
	croak _wrong_ip($addr) unless _ip_validate($bin_addr);

	return _ip_in_range($bin_addr, $range, $addr);
}

sub new {
	my ($class, $addr) = @_;

	my $bin = ip2bin($addr);
	return 0 unless _ip_validate($bin);

	my $self = {
		bin => $bin,
		addr => $addr
	};

	bless $self, $class;
	return $self;
}

sub _set_binary {
	my ($self, $bin) = @_;
	$self->{bin} = $bin;
	$self->{addr} = $self->transform();
}

sub address {
	my $self = shift;
	return $self->{addr};
}

sub binary {
	my $self = shift;
	return $self->{bin};
}

sub is_ipv4 {
	my $self = shift;
	return _ip_is_ipv4($self->binary);
}

sub is_ipv6 {
	my $self = shift;
	return _ip_is_ipv6($self->binary);
}

sub is_ipv6ipv4 {
	my $self = shift;
	return _ip_is_ipv6ipv4($self->binary);
}

sub transform {
	my ($self, $opts) = @_;
	$opts ||= {};
	croak 'Options must be a hash' unless ref($opts) eq 'HASH';
	return _ip_transform($self->binary, $opts);
}

sub equal {
	my ($self, $addr) = @_;

	if (blessed($addr) && $addr->isa('Net::IP::Lite')) {
		return _ip_equal($self->binary, $addr->binary);
	}

	my $bin2 = ip2bin($addr);
	croak _wrong_ip($addr) unless _ip_validate($bin2);

	return _ip_equal($self->binary, $bin2);
}

sub equal_v4 {
	my ($self, $addr) = @_;

	my $bin2 = (blessed($addr) && $addr->isa('Net::IP::Lite')) ? $addr->binary : ip2bin($addr);
	croak _wrong_ip($addr) unless _ip_validate($bin2);

	if (($self->is_ipv6() && ! $self->is_ipv6ipv4())) {
		croak _wrong_ipv6ipv4($self->address);
	}

	if ((_ip_is_ipv6($bin2) && ! _ip_is_ipv6ipv4($bin2))) {
		croak _wrong_ipv6ipv4($addr);
	}

	return _ip_equal_v4($self->binary, $bin2);
}

sub equal_v6 {
	my ($self, $addr) = @_;

	my $bin2 = (blessed($addr) && $addr->isa('Net::IP::Lite')) ? $addr->binary : ip2bin($addr);

	croak _wrong_ip($addr) unless _ip_validate($bin2);

	return _ip_equal_v6($self->binary, $bin2);
}

sub in_range {
	my ($self, $range) = @_;

	croak _wrong_net($range) unless defined $range;

	if (ref($range) eq 'ARRAY') {
		for my $net (@$range) {
			return 1 if $self->in_range($net);
		}
		return 0;
	}

	if (blessed($range) && $range->isa('Net::IP::Lite::Net')) {
		return $range->contains($self);
	}

	return _ip_in_range($self->binary, $range, $self->address);
}

package Net::IP::Lite::Net;
use Carp qw(croak);
use Scalar::Util qw(blessed);

use base qw(Net::IP::Lite);

sub new {
	my ($class, $net) = @_;

	return 0 unless defined $net;

	my $self = {};
	my $bin_mask;

	if ($net =~ /^(.+)\/(\d+)$/) {
		my $mask = $2;
		$self = $class->SUPER::new($1);

		my $mask_len = $self->is_ipv4() ? 32 : 128;
		return 0 if $mask > $mask_len;

		$bin_mask = '1' x $mask . '0' x ($mask_len - $mask);
	} elsif ($net =~ /^(\S+)\s+(\S+)$/) {
		$self = $class->SUPER::new($1);
		return 0 unless $self;
		$self->{mask} = Net::IP::Lite->new($2);
	} else {
		$self = $class->SUPER::new($net);
		return 0 unless $self;
		$bin_mask = '1' x ($self->is_ipv4 ? 32 : 128);
	}

	if ($bin_mask) {
		if (length($bin_mask) == 32) {
			$self->{mask} = Net::IP::Lite->new(Net::IP::Lite::_bin2ipv4($bin_mask));
		} else {
			$self->{mask} = Net::IP::Lite->new(Net::IP::Lite::_bin2ipv6($bin_mask));
		}
	}

	return 0 unless $self->{mask};

	my $ipv4_mask = $self->{mask}->is_ipv4;
	return 0 unless (($self->is_ipv4 && $ipv4_mask) || ($self->is_ipv6 && ! $ipv4_mask));

	$self->{net} = $net;
	return $self;
}

sub mask {
	my ($self) = @_;
	return $self->{mask};
}

sub network {
	my ($self) = @_;
	return $self->{net};
}

sub contains {
	my ($self, $addr) = @_;

	if (blessed($addr) && $addr->isa('Net::IP::Lite')) {
		return 0 unless Net::IP::Lite::_ip_type_equal($self->binary, $addr->binary);
		return Net::IP::Lite::__ip_in_range($addr->binary, $self->binary, $self->mask->binary);
	} else {
		my $bin_addr = Net::IP::Lite::ip2bin($addr);
		croak Net::IP::Lite::_wrong_ip($addr) unless Net::IP::Lite::_ip_validate($bin_addr);
		return 0 unless Net::IP::Lite::_ip_type_equal($self->binary, $bin_addr);
		return Net::IP::Lite::__ip_in_range($bin_addr, $self->binary, $self->mask->binary);
	}
}


1;

__END__