# $Id: LVPnet.pm 2400 2011-08-15 19:10:37Z reuteler $
#
# Copyright (c) 2004-2011 David Reuteler
# 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 of the  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  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.

package LVPnet;
require 5.000;
require Exporter;
use strict;
use Socket;

@LVPnet::ISA = qw(Exporter);
@LVPnet::EXPORT =
qw(
	netmask_validate
	netmask_convert
	netmask_type
	netmask_texttype
	netmask_hostcount

	network_validate_correcting
	network_detect_collisions
	network_contains
	network_next
	network_bounds

	ipaddress_validate
	ipaddress_validate_with_netmask
	ipaddress_increment
	ipaddress_decrement

	fqhn_validate

	BITCOUNT
	DECIMAL
	HEX
	ANY

	COLLISION
	NOCOLLISION
	CONTAINS
	DOESNOTCONTAIN
);

# /24 is bitcount
# 255.255.255.0 decimal
# FFFFFF00 hex

$LVPnet::errstring = undef;

use constant SUCCESS => 1;
use constant ERROR => 0;

use constant COLLISION => 1;
use constant NOCOLLISION => 2;

use constant CONTAINS => 1;
use constant DOESNOTCONTAIN => 2;

use constant BITCOUNT => 1;
use constant DECIMAL => 2;
use constant HEX => 3;
use constant ANY => 4;
use constant DEFAULT_NETMASK_TYPE => DECIMAL;

#
# OO Style first.
#

sub new
{
	my $foo = shift;
	my $class = ref($foo) || $foo || undef;
	my $netmask = shift || undef;

	if(defined($netmask) && ! netmask_convert(DEFAULT_NETMASK_TYPE, $netmask, \$netmask))
	{
		return undef;
	}

	my $self =
	{
		'netmask' => $netmask,
		'errstring' => undef
	};

	bless($self, $class);

	return $self;
}

sub set
{
	my $self = shift;
	_assert_method_call($self) || return 0;

	my $netmask = shift;
	if(! defined($netmask)) { return $self->_self_print_errstring_return(0, "null netmask given"); }
	if(scalar(@_)) { return $self->_self_print_errstring_return(0, "netmask takes one argument"); }

	netmask_convert(DEFAULT_NETMASK_TYPE, $netmask, \$netmask) || $self->_self_print_errstring_return(0, $LVPnet::errstring);
	$self->{'netmask'} = $netmask;
	return 1;
}

sub get
{
	my $self = shift;
	_assert_method_call($self) || return 0;

	if(scalar(@_)) { return $self->_self_print_errstring_return(undef, "get takes no arguments"); }

	defined($self->{'netmask'}) || return $self->_self_print_errstring_return(undef, "netmask is not set");

	return $self->{'netmask'};
}

sub get_decimal
{
	my $self = shift;
	_assert_method_call($self) || return 0;

	if(scalar(@_)) { return $self->_self_print_errstring_return(undef, "get_decimal takes no arguments"); }

	defined($self->{'netmask'}) || return $self->_self_print_errstring_return(undef, "netmask is not set");

	my $netmask = undef;
	netmask_convert(DECIMAL, $self->{'netmask'}, \$netmask);
	return $netmask;
}

sub get_hex
{
	my $self = shift;
	_assert_method_call($self) || return 0;

	if(scalar(@_)) { return $self->_self_print_errstring_return(undef, "hex takes no arguments"); }

	defined($self->{'netmask'}) || return $self->_self_print_errstring_return(undef, "netmask is not set");

	my $netmask = undef;
	netmask_convert(HEX, $self->{'netmask'}, \$netmask);
	return $netmask;
}

sub get_bitcount
{
	my $self = shift;
	_assert_method_call($self) || return 0;

	if(scalar(@_)) { return $self->_self_print_errstring_return(undef, "get_bitcount takes no arguments"); }

	defined($self->{'netmask'}) || return $self->_self_print_errstring_return(undef, "netmask is not set");

	my $netmask = undef;
	netmask_convert(BITCOUNT, $self->{'netmask'}, \$netmask);
	return $netmask;
}

sub hostcount
{
	my $self = shift;
	_assert_method_call($self) || return 0;

	if(scalar(@_)) { return $self->_self_print_errstring_return(undef, "hostcount takes no arguments"); }

	defined($self->{'netmask'}) || return $self->_self_print_errstring_return(undef, "netmask is not set");

	return (2**(32-$self->get_bitcount()))-2;
}

sub errstring
{
	my $self = shift;
	_assert_method_call($self) || return undef;

	return $self->{'errstring'};
}

sub _self_set_errstring_return
{
	my $self = shift;
	my $rc = shift;
	$self->{'errstring'} = shift || 'unknown error';
	$self->{'errstring'} .= "\n";
	return $rc;
}

sub _self_print_errstring_return
{
	my $self = shift;
	my $rc = shift;
	$self->{'errstring'} = shift || 'unknown error';
	$self->{'errstring'} .= "\n";
	print $self->{'errstring'};
	return $rc;
}

#
# NETMASK VALIDATION
#

sub netmask_validate
{
	my $type = shift || return _set_errstring_return(ERROR, "received no type");
	if(! _assert_netmask_type($type) && $type != ANY) { return _set_errstring_return(ERROR, "invalid type $type"); }
	my $netmask = shift;
	if(! defined($netmask)) { return _set_errstring_return(ERROR, "null netmask"); }

	if($type == BITCOUNT)
	{
		return _netmask_validate_bitcount($netmask);
	}
	elsif($type == DECIMAL)
	{
		return _netmask_validate_decimal($netmask);
	}
	elsif($type == HEX)
	{
		return _netmask_validate_hex($netmask);
	}
	elsif($type == ANY)
	{
		if(_netmask_validate_decimal($netmask) || _netmask_validate_bitcount($netmask) || _netmask_validate_hex($netmask))
		{
			return(SUCCESS);
		}
		else
		{
			return(ERROR);
		}
	}
	else
	{
		return _print_errstring_return(ERROR, "netmask_validate faceplant on type $type");
	}
}

sub _netmask_validate_decimal
{
	my $netmask = shift;
	if(! defined($netmask)) { return _set_errstring_return(ERROR, "no netmask given"); }

	if($netmask !~ m/^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/)
	{
		return _set_errstring_return(ERROR, "invalid netmask");
	}

	my $intip;
	_ipaddress2int($netmask, \$intip) || return(ERROR);

	my $foundzero = 0;
	my $foundone = 0;
	foreach my $digit (split(undef, _dec2bin($intip)))
	{
		if($digit == 0) { $foundzero = 1; next; }
		if($digit == 1) { $foundone = 1; }

		if($foundzero && $digit == 1)
		{
			return _set_errstring_return(ERROR, "invalid netmask");
		}
	}

	# actually, 0.0.0.0 and 255.255.255.255 aren't actually valid netmasks
	#if(! $foundzero || ! $foundone)
	#{
	#	return _set_errstring_return(ERROR, "invalid netmask");
	#}

	return(SUCCESS);
}
sub _netmask_validate_bitcount
{
	my $netmask = shift;
	if(! defined($netmask)) { return _set_errstring_return(ERROR, "no netmask given"); }

	($netmask =~ m/^(\d{1,2})$/) || return _set_errstring_return(ERROR, "invalid netmask");
	# as above.. 0 and 32 technically aren't valid
	if($1 >= 0 && $1 <= 32)
	{
		return(SUCCESS);
	}
	else
	{
		return _set_errstring_return(ERROR, "invalid netmask");
	}
}
sub _netmask_validate_hex
{
	my $netmask = shift;
	if(! defined($netmask)) { return _set_errstring_return(ERROR, "no netmask given"); }

	($netmask =~ m/^([0-9A-F]{2})([0-9A-F]{2})([0-9A-F]{2})([0-9A-F]{2})$/i) || return _set_errstring_return(ERROR, "invalid netmask");
	my $decimal = hex($1) . '.' . hex($2) . '.' . hex($3) . '.' . hex($4);
	return _netmask_validate_decimal($decimal);
}

#
# NETMASK CONVERSION
#

sub netmask_convert
{
	my $type = shift || return _set_errstring_return(ERROR, "sreceived no type");
	_assert_netmask_type($type) || return _set_errstring_return(ERROR, "invalid type $type");
	my $netmask = shift;
	if(! defined($netmask)) { return _set_errstring_return(ERROR, "null netmask"); }
	my $netmaskref = shift || return _print_errstring_return(ERROR, "netmask_convert received null netmaskref");
	if(ref($netmaskref) ne 'SCALAR') { return _print_errstring_return(ERROR, "netmask_convert netmaskref is not a scalar reference"); }

	${ $netmaskref } = undef;

	if(netmask_validate(BITCOUNT, $netmask))
	{
		if($type == BITCOUNT)
		{
			${ $netmaskref } = $netmask;
			return(SUCCESS);
		}
		elsif($type == DECIMAL)
		{
			return _netmask_convert_bitcount2decimal($netmask, $netmaskref);
		}
		elsif($type == HEX)
		{
			return _netmask_convert_bitcount2hex($netmask, $netmaskref);
		}
		else { return _print_errstring_return(ERROR, "netmask_convert faceplant on type $type"); }
	}
	elsif(netmask_validate(DECIMAL, $netmask))
	{
		if($type == BITCOUNT)
		{
			return _netmask_convert_decimal2bitcount($netmask, $netmaskref);
		}
		elsif($type == DECIMAL)
		{
			${ $netmaskref } = $netmask;
			return(SUCCESS);
		}
		elsif($type == HEX)
		{
			return _netmask_convert_decimal2hex($netmask, $netmaskref);
		}
		else { return _print_errstring_return(ERROR, "netmask_convert faceplant on type $type"); }
	}
	elsif(netmask_validate(HEX, $netmask))
	{
		if($type == BITCOUNT)
		{
			return _netmask_convert_hex2bitcount($netmask, $netmaskref);
		}
		elsif($type == DECIMAL)
		{
			return _netmask_convert_hex2decimal($netmask, $netmaskref);
		}
		elsif($type == HEX)
		{
			${ $netmaskref } = $netmask;
			return(SUCCESS);
		}
		else { return _set_errstring_return(ERROR, "netmask_convert faceplant on type $type"); }
	}
	else
	{
		return _set_errstring_return(ERROR, "invalid netmask");
	}
}

#
# these conversion subs do no validation of their own, so yea, don't export them.
#

sub _netmask_convert_decimal2bitcount
{
	my $netmask = shift;
	my $netmaskref = shift;
	${ $netmaskref } = undef;
	$netmask =~ m/^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/;
	${ $netmaskref } = _get_bitcount($1) + _get_bitcount($2) + _get_bitcount($3) + _get_bitcount($4);
	return(SUCCESS);
}
sub _netmask_convert_decimal2hex
{
	my $netmask = shift;
	my $netmaskref = shift;
	${ $netmaskref } = undef;
	$netmask =~ m/^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/;
	${ $netmaskref } = sprintf("%02x%02x%02x%02x", $1, $2, $3, $4);
	return(SUCCESS);
}
sub _netmask_convert_bitcount2decimal
{
	my $netmask = shift;
	my $netmaskref = shift;
	${ $netmaskref } = undef;
	my $octets = int($netmask/8);
	my $remainder = $netmask % 8;
	if($octets == 4)
	{
		${ $netmaskref } = "255.255.255.255";
		return(SUCCESS);
	}
	${ $netmaskref } = '255.' x $octets;
	my $lastoctet = '1' x $remainder;
	for(my $i=$remainder+1; $i<=8; $i++)
	{
		$lastoctet .= '0';
	}
	${ $netmaskref } .= _bin2dec($lastoctet) . '.';
	for(my $i=1; $i<(4-$octets); $i++)
	{
		${ $netmaskref } .= '0.';
	}
	${ $netmaskref } =~ s/^(.*?)\.$/$1/;
	return(SUCCESS);
}
sub _netmask_convert_bitcount2hex
{
	my $netmask = shift;
	my $netmaskref = shift;
	${ $netmaskref } = undef;
	_netmask_convert_bitcount2decimal($netmask, $netmaskref);
	_netmask_convert_decimal2hex(${ $netmaskref }, $netmaskref);
	return(SUCCESS);
}
sub _netmask_convert_hex2bitcount
{
	my $netmask = shift;
	my $netmaskref = shift;
	${ $netmaskref } = undef;
	_netmask_convert_hex2decimal($netmask, $netmaskref);
	_netmask_convert_decimal2bitcount(${ $netmaskref }, $netmaskref);
	return(SUCCESS);
}
sub _netmask_convert_hex2decimal
{
	my $netmask = shift;
	my $netmaskref = shift;
	${ $netmaskref } = undef;
	$netmask =~ m/^([0-9A-F]{2})([0-9A-F]{2})([0-9A-F]{2})([0-9A-F]{2})$/i;
	${ $netmaskref } = hex($1) . '.' . hex($2) . '.' . hex($3) . '.' . hex($4);
	return(SUCCESS);
}

#
# NETMASK INFORMATION
#

sub netmask_type
{
	my $netmask = shift;
	if(! defined($netmask)) { return _set_errstring_return(ERROR, "null netmask"); }

	if(netmask_validate(BITCOUNT, $netmask))
	{
		return BITCOUNT;
	}
	elsif(netmask_validate(DECIMAL, $netmask))
	{
		return DECIMAL;
	}
	elsif(netmask_validate(HEX, $netmask))
	{
		return HEX;
	}
	else
	{
		return _set_errstring_return(ERROR, "invalid netmask");
	}
}

sub netmask_texttype
{
	my $netmask = shift;
	if(! defined($netmask)) { return _set_errstring_return(undef, "null netmask"); }

	if(netmask_validate(BITCOUNT, $netmask))
	{
		return "bitcount";
	}
	elsif(netmask_validate(DECIMAL, $netmask))
	{
		return "decimal";
	}
	elsif(netmask_validate(HEX, $netmask))
	{
		return "hex";
	}
	else
	{
		return _set_errstring_return(undef, "invalid netmask");
	}
}

sub netmask_hostcount
{
	my $netmask = shift || 0;
	if(! defined($netmask)) { return _set_errstring_return(ERROR, "null netmask"); }
	my $hostcountref = shift || return _print_errstring_return(ERROR, "netmask_hostcount() received null hostcount ref");
	if(ref($hostcountref) ne 'SCALAR') { return _print_errstring_return(ERROR, "netmask_hostcount() hostcountref is not a scalar reference"); }

	${ $hostcountref } = undef;

	netmask_convert(BITCOUNT, $netmask, \$netmask) || return(ERROR);

	${ $hostcountref } = (2**(32-$netmask))-2;

	return(SUCCESS);
}

#
# VALIDATES 192.168.0.0/255.255.255.0 OR 192.168.0.0/24
#
# corrects the network ipaddress if it's not actually the network (ie, it's an ipaddress within the subnet)
#

sub network_validate_correcting
{
	my $network = shift || undef;
	defined($network) || return _set_errstring_return(ERROR, "no network given");
	my $subnetref = shift || undef;
	my $netmaskref = shift || undef;

	${ $subnetref } = undef if(ref($subnetref) eq 'SCALAR');
	${ $netmaskref } = undef if(ref($netmaskref) eq 'SCALAR');

	($network =~ m/^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})[\/\s](.*)$/) || return _set_errstring_return(ERROR, "invalid network");
	my $subnet = $1;
	my $netmask = $2;

	ipaddress_validate($subnet) || return(ERROR);
	netmask_convert(BITCOUNT, $netmask, \$netmask) || return(ERROR);

	my $ip_address_binary = inet_aton($subnet);
	my $netmask_binary = ~pack("N", (2**(32-$netmask))-1);
	my $network_address = inet_ntoa($ip_address_binary & $netmask_binary );
	my $broadcast_address = inet_ntoa($ip_address_binary | ~$netmask_binary);

	if(ref($subnetref) eq 'SCALAR' && $subnet ne $network_address)
	{
		$subnet = $network_address;
	}
	elsif($subnet ne $network_address)
	{
		return _set_errstring_return(ERROR, "ipaddress is not the network address in the subnet");
	}

	${ $subnetref } = $subnet if(ref($subnetref) eq 'SCALAR');
	netmask_convert(DECIMAL, $netmask, $netmaskref) if(ref($netmaskref) eq 'SCALAR');

	return(SUCCESS);
}

#
# checks for collisions in network space (eg, 192.168.0.0/16 and 192.168.2.0/24).
#

sub network_detect_collisions
{
	my %networkstring;
	$networkstring{'1'} = shift || return _set_errstring_return(ERROR, "received null networkstring1");
	$networkstring{'2'} = shift || return _set_errstring_return(ERROR, "received null networkstring2");

	my %top = ();
	my %bottom = ();

	foreach my $key (keys %networkstring)
	{
		my($subnet, $netmask);
		network_validate_correcting($networkstring{$key}, \$subnet, \$netmask) || return(ERROR);
		netmask_convert(BITCOUNT, $netmask, \$netmask) || return(ERROR);

		my $ip_address_binary = inet_aton($subnet);
		my $netmask_binary = ~pack("N", (2**(32-$netmask))-1);
		my $network_address = inet_ntoa( $ip_address_binary & $netmask_binary );
		my $broadcast_address = inet_ntoa( $ip_address_binary | ~$netmask_binary );

		_ipaddress2int($network_address, \$bottom{$key}) || return(ERROR);
		_ipaddress2int($broadcast_address, \$top{$key}) || return(ERROR);
	}

	if(($bottom{'2'} > $top{'1'}) || ($bottom{'1'} > $top{'2'}))
	{
		return(NOCOLLISION);
	}
	else
	{
		return(COLLISION);
	}
}

#
# check that a network contains an ip address
#

sub network_contains
{
	my $network = shift || return _set_errstring_return(ERROR, "received null network");
	my $ipaddress = shift || return _set_errstring_return(ERROR, "received null ipaddress");

	my $rc = network_detect_collisions($network, "$ipaddress 255.255.255.255");
	if($rc == COLLISION)
	{
		return CONTAINS;
	}
	elsif($rc == NOCOLLISION)
	{
		return DOESNOTCONTAIN;
	}
	else
	{
		return ERROR;
	}
}

#
# given a network and netmask find the next network address in line
#
# eg, 192.168.1.0/24 returns 192.168.2.0
#

sub network_next
{
	my $network = shift || return _set_errstring_return(ERROR, "received null network");
	my $network_addressref = shift || return _print_errstring_return(ERROR, "network_next() received null network_addressref");
	if(ref($network_addressref) ne 'SCALAR') { return _print_errstring_return(ERROR, "network_next() network_addressref is not a scalar reference"); }

	my($subnet, $netmask);
	network_validate_correcting($network, \$subnet, \$netmask) || return(ERROR);
	netmask_convert(BITCOUNT, $netmask, \$netmask) || return(ERROR);

	my $ip_address_binary = inet_aton($subnet);
	my $netmask_binary = ~pack("N", (2**(32-$netmask))-1);
	my $broadcast_address = inet_ntoa( $ip_address_binary | ~$netmask_binary );

	my $int_network_address;
	_ipaddress2int($broadcast_address, \$int_network_address) || return(ERROR);
	_int2ipaddress($int_network_address+1, $network_addressref) || return(ERROR);

	return 1;
}

#
# RETURNS NETWORK AND BROADCAST IP GIVEN AN IPADDRESS/NETMASK
#

sub network_bounds
{
	my $network = shift || undef;
	defined($network) || return _set_errstring_return(ERROR, "no network given");
	my $subnetref = shift || undef;
	if(defined($subnetref) && ref($subnetref) ne 'SCALAR') { return _print_errstring_return(ERROR, "network_bounds() subnetref is not a scalar reference"); }
	my $broadcastref = shift || undef;
	if(defined($broadcastref) && ref($broadcastref) ne 'SCALAR') { return _print_errstring_return(ERROR, "network_bounds() broadcastref is not a scalar reference"); }

	${ $subnetref } = undef if(ref($subnetref) eq 'SCALAR');
	${ $broadcastref } = undef if(ref($broadcastref) eq 'SCALAR');

	($network =~ m/^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})[\/\s](.*)$/) || return _set_errstring_return(ERROR, "invalid network");
	my $subnet = $1;
	my $netmask = $2;

	ipaddress_validate($subnet) || return(ERROR);
	netmask_convert(BITCOUNT, $netmask, \$netmask) || return(ERROR);

	my $ip_address_binary = inet_aton($subnet);
	my $netmask_binary = ~pack("N", (2**(32-$netmask))-1);
	my $network_address = inet_ntoa($ip_address_binary & $netmask_binary );
	my $broadcast_address = inet_ntoa($ip_address_binary | ~$netmask_binary);

	${ $subnetref } = $network_address if(ref($subnetref) eq 'SCALAR');
	${ $broadcastref } = $broadcast_address if(ref($broadcastref) eq 'SCALAR');

	return(SUCCESS);
}

#
# HOSTNAME VALIDATION
#

sub fqhn_validate
{
	my $hostname = shift || return _set_errstring_return(ERROR, "received no hostname");

	if($hostname !~ m/^[a-z0-9]{1}[a-z0-9\.]*\.[a-z]+$/ || $hostname =~ /\.\./)
	{
		return _set_errstring_return(ERROR, "invalid hostname");
	}
	elsif(length($hostname) > 128)
	{
		return _set_errstring_return(ERROR, "hostname too long");
	}

	return(SUCCESS);
}

#
# IPADDRESS VALIDATION
#

sub ipaddress_validate
{
	my $ipaddress = shift || return _set_errstring_return(ERROR, "received no ipaddress");

	if($ipaddress =~ m/^\s*((([0-9A-Fa-f]{1,4}:){7}([0-9A-Fa-f]{1,4}|:))|(([0-9A-Fa-f]{1,4}:){6}(:[0-9A-Fa-f]{1,4}|((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3})|:))|(([0-9A-Fa-f]{1,4}:){5}(((:[0-9A-Fa-f]{1,4}){1,2})|:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3})|:))|(([0-9A-Fa-f]{1,4}:){4}(((:[0-9A-Fa-f]{1,4}){1,3})|((:[0-9A-Fa-f]{1,4})?:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:))|(([0-9A-Fa-f]{1,4}:){3}(((:[0-9A-Fa-f]{1,4}){1,4})|((:[0-9A-Fa-f]{1,4}){0,2}:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:))|(([0-9A-Fa-f]{1,4}:){2}(((:[0-9A-Fa-f]{1,4}){1,5})|((:[0-9A-Fa-f]{1,4}){0,3}:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:))|(([0-9A-Fa-f]{1,4}:){1}(((:[0-9A-Fa-f]{1,4}){1,6})|((:[0-9A-Fa-f]{1,4}){0,4}:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:))|(:(((:[0-9A-Fa-f]{1,4}){1,7})|((:[0-9A-Fa-f]{1,4}){0,5}:((25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)(\.(25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)){3}))|:)))(%.+)?\s*$/i)
	{
		return _set_errstring_return(ERROR, "you wish");
	}
	elsif($ipaddress !~ m/^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/)
	{
		return _set_errstring_return(ERROR, "invalid ipaddress");
	}
	elsif( ($1 < 0 || $1 > 255) || ($2 < 0 || $2 > 255) || ($3 < 0 || $3 > 255) || ($4 < 0 || $4 > 255) )
	{
		return _set_errstring_return(ERROR, "invalid ipaddress");
	}

	return(SUCCESS);
}

sub ipaddress_validate_with_netmask
{
	my $ipaddress = shift || return _set_errstring_return(ERROR, "received no ipaddress");
	my $ipaddressref = shift || return _print_errstring_return(ERROR, "ipaddress_validate_with_netmask received no ipaddressref");
	if(ref($ipaddressref) ne 'SCALAR') { return _print_errstring_return(ERROR, "ipaddress_validate_with_netmask ipaddressref is not a scalar reference"); }
	my $netmaskref = shift || return _print_errstring_return(ERROR, "ipaddress_validate_with_netmask received no netmaskref");
	if(ref($netmaskref) ne 'SCALAR') { return _print_errstring_return(ERROR, "ipaddress_validate_with_netmask netmaskref is not a scalar reference"); }

	${ $ipaddressref } = undef;
	${ $netmaskref } = undef;

	($ipaddress =~ m/^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})[\/\s](.*)$/) || return _set_errstring_return(ERROR, "invalid ipaddress/netmask");
	$ipaddress = $1;
	my $netmask = $2;

	ipaddress_validate($ipaddress) || return(ERROR);
	netmask_convert(BITCOUNT, $netmask, \$netmask) || return(ERROR);

	my $ip_address_binary = inet_aton($ipaddress);
	my $netmask_binary = ~pack("N", (2**(32-$netmask))-1);
	my $network_address = inet_ntoa($ip_address_binary & $netmask_binary);
	my $broadcast_address = inet_ntoa($ip_address_binary | ~$netmask_binary);

	if($ipaddress eq $network_address)
	{
		return _set_errstring_return(ERROR, "ipaddress is the network address in the subnet");
	}
	elsif($ipaddress eq $broadcast_address)
	{
		return _set_errstring_return(ERROR, "ipaddress is the broadcast address in the subnet");
	}

	${ $ipaddressref } = $ipaddress if(ref($ipaddressref) eq 'SCALAR');
	netmask_convert(DECIMAL, $netmask, $netmaskref) if(ref($netmaskref) eq 'SCALAR');

	return(SUCCESS);
}

sub ipaddress_increment
{
	my $ipaddress = shift || return _set_errstring_return(ERROR, "received no ipaddress");
	my $amount = shift || 1;
	my $ipaddressref = shift || return _print_errstring_return(ERROR, "ipaddress_increment received no ipaddressref");
	if(ref($ipaddressref) ne 'SCALAR') { return _print_errstring_return(ERROR, "ipaddress_increment ipaddressref is not a scalar reference"); }

	ipaddress_validate($ipaddress) || return(ERROR);
	my $temp;
	_ipaddress2int($ipaddress, \$temp) || return(ERROR);
	$temp += $amount;
	_int2ipaddress($temp, $ipaddressref) || return(ERROR);

	return 1;
}

sub ipaddress_decrement
{
	my $ipaddress = shift || return _set_errstring_return(ERROR, "received no ipaddress");
	my $amount = shift || 1;
	my $ipaddressref = shift || return _print_errstring_return(ERROR, "ipaddress_decrement received no ipaddressref");
	if(ref($ipaddressref) ne 'SCALAR') { return _print_errstring_return(ERROR, "ipaddress_decrement ipaddressref is not a scalar reference"); }

	ipaddress_validate($ipaddress) || return(ERROR);
	my $temp;
	_ipaddress2int($ipaddress, \$temp) || return(ERROR);
	$temp -= $amount;
	_int2ipaddress($temp, $ipaddressref) || return(ERROR);

	return 1;
}

sub _ipaddress2int
{
	my $ipaddress = shift || return _print_errstring_return(ERROR, "_ipaddress2int received no ipaddress");
	my $intref = shift || return _print_errstring_return(ERROR, "_ipaddress2int received no intref");
	if(ref($intref) ne 'SCALAR') { return _print_errstring_return(ERROR, "_ipaddress2int intref is not a scalar reference"); }

	${ $intref } = undef;

	ipaddress_validate($ipaddress) || return _set_errstring_return(ERROR, "invalid ipaddress");

	$ipaddress =~ m/^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/ || return _print_errstring_return(ERROR, "_ipaddress2int regex failed");

	${ $intref } = $1 * 16777216 + $2 * 65536 + $3 * 256 + $4;

	return(SUCCESS);
}

sub _int2ipaddress
{
	my $integer = shift || return _print_errstring_return(ERROR, "_int2ipaddress received no ipaddress");
	my $ipaddressref = shift || return _print_errstring_return(ERROR, "_int2ipaddress received no ipaddressref");
	if(ref($ipaddressref) ne 'SCALAR') { return _print_errstring_return(ERROR, "_int2ipaddress ipaddressref is not a scalar reference"); }

	${ $ipaddressref } = undef;

	if($integer !~ m/^\d+$/ || $integer < 0 || $integer > 4294967295)
	{
		return _print_errstring_return(ERROR, "_int2ipaddress invalid ipaddress integer");
	}

	my @quads = ();
	for(my $i=0; $i<4; $i++)
	{
		my $power = 256 ** (3 - $i);
		$quads[$i] = int($integer / $power);
		$integer -= $quads[$i] * $power;
	}

	${ $ipaddressref } = join('.', @quads);

	return(SUCCESS);
}

sub _dec2bin
{
	my $decimal = shift || return undef;
	if($decimal !~ m/^\d+$/) { return undef; }
	return unpack("B32", pack("N", $decimal));
}
sub _bin2dec
{
	return unpack("N", pack("B32", substr("0" x 32 . shift, -32)));
}
sub _get_bitcount
{
	my $octet = shift || return(ERROR);
	my $bitcount = 0;
	for(my $i=128; $i>0; $i=$i/2)
	{
		if($octet - $i >= 0)
		{
			$bitcount++;
			$octet -= $i
		}
		else
		{
			last;
		}
	}
	return $bitcount;
}

sub _assert_netmask_type
{
	my $type = shift || 0;
	return(grep(/^${type}$/, (BITCOUNT,DECIMAL,HEX)) ? 1 : 0);
}

sub _assert_method_call
{
	my $input = shift || undef;
	if(ref($input) ne "LVPnet")
	{
		print("LVPnet object method called as function");
		return 0;
	}
	return 1;
}

sub _set_errstring_return
{
	my $rc = shift;
	$LVPnet::errstring = shift || 'unknown error';
	$LVPnet::errstring .= "\n";
	return $rc;
}

sub _print_errstring_return
{
	my $rc = shift;
	$LVPnet::errstring = shift || 'unknown error';
	$LVPnet::errstring .= "\n";
	print($LVPnet::errstring);
	return $rc;
}

1;