Scalar::Number - numeric aspects of scalars

	use Scalar::Number qw(scalar_num_part);

	$num = scalar_num_part($scalar);

	use Scalar::Number qw(sclnum_is_natint sclnum_is_float);

	if(sclnum_is_natint($value)) { ...
	if(sclnum_is_float($value)) { ...

	use Scalar::Number qw(sclnum_val_cmp sclnum_id_cmp);

	@sorted_nums = sort { sclnum_val_cmp($a, $b) } @floats;
	@sorted_nums = sort { sclnum_id_cmp($a, $b) } @floats;

package Scalar::Number;

{ use 5.006; }
use warnings;
use strict;

our $VERSION = "0.006";

use parent "Exporter";
our @EXPORT_OK = qw(
	scalar_num_part
	sclnum_is_natint sclnum_is_float
	sclnum_val_cmp sclnum_id_cmp
);

eval { local $SIG{__DIE__};
	require XSLoader;
	XSLoader::load(__PACKAGE__, $VERSION);
};

if($@ eq "") {
	close(DATA);
	*scalar_num_part = sub($) {
		no warnings qw(numeric uninitialized);
		return _warnable_scalar_num_part($_[0]);
	};
} else {
	local $/ = undef;
	my $pp_code = <DATA>;
	close(DATA);
	{
		local $SIG{__DIE__};
		eval $pp_code;
	}
	die $@ if $@ ne "";
}

1;

__DATA__

use Carp qw(croak);
use Data::Float 0.008 qw(
	have_signed_zero significand_bits max_integer
	float_is_infinite pow2 mult_pow2
);
use Data::Integer 0.003 qw(natint_bits min_natint max_natint hex_natint);
use overload ();

BEGIN {
	# In perl 5.6, arithmetic is performed in floating point by default,
	# even if the arguments are native integers that lose precision upon
	# conversion to float.  If there are such native integers then these
	# semantics make it impossible in some cases to tell the difference
	# between an integer and a nearby floating point value.  Specifically,
	# the maximum integer and its float approximation (which has a
	# numeric value 1 higher) are indistinguishable.  In that case, this
	# module cannot be implemented in pure Perl.  Detect that here by
	# max_natint-2 appearing to be even.  (perl 5.6.0 has even more messed
	# up arithmetic, such that max_natint%2 misleadingly gives the result
	# 1.)
	if((max_natint-2) % 2 != 1) {
		die "Scalar::Number cannot operate in pure Perl due to there ".
			"being native integer values not exactly ".
			"representable as native floats combined with ".
			"uncooperative numeric semantics";
	}
	# With that case excluded, it is guaranteed that default arithmetic
	# will operate correctly on all native integer values when performing
	# operations within the native integer range.  The correctness is
	# either due to perl 5.8+ numeric semantics, which perform such
	# operations in native integer arithmetic, or due to all native
	# integers being losslessly representable in floating point.
}

# Floating point constants arount max_natint: high_max has the value
# max_natint+1, and low_max is the next lower floating point value.
# reduced_high_max is the difference between them.  These are only
# valid if there are native integers that are not representable in
# floating point.  In other cases they have unpredictable values and
# are not used.
#
# Note: bug in Perl (bug in v5.8.8, bug ID #41288): floating point values
# in the high positive part of the native integer range don't necessarily
# get translated to native integers for integer operations as they're
# supposed to.  Therefore it is vital that low_max below is defined using
# integer arithmetic.

use constant high_max => pow2(natint_bits);
use constant low_max => ((1 << (natint_bits-1)) -
			 (1 << (natint_bits - (significand_bits+1)))) +
			(1 << (natint_bits-1));
use constant reduced_high_max => 1 << (natint_bits - (significand_bits+1));

BEGIN {
	# We need the refaddr() function from Scalar::Util.  However, if
	# Scalar::Util isn't available then we can reimplement it less
	# efficiently.
	eval { local $SIG{__DIE__}; require Scalar::Util; };
	if($@ eq "") {
		*_refaddr = \&Scalar::Util::refaddr;
	} else {
		*_refaddr = sub($) {
			overload::StrVal($_[0]) =~ /0x([0-9a-f]+)\)\z/
				or die "don't understand StrVal output";
			return hex_natint($1);
		};
	}
}

my %zero = (
	"+0+0" => 0,
	"+0-0" => +0.0,
	"-0+0" => -0.0,
);
sub scalar_num_part($) {
	my($val) = @_;
	no warnings qw(numeric uninitialized);
	while(ref($val) ne "") {
		my $meth = overload::Method($val, "0+");
		return _refaddr($val) unless defined $meth;
		my $newval = eval { local $SIG{__DIE__};
			$meth->($val, undef, "");
		};
		if($@ ne "" || (ref($newval) ne "" &&
				_refaddr($newval) == _refaddr($val))) {
			return _refaddr($val);
		}
		$val = $newval;
	}
	if(have_signed_zero && (my $tval = $val) == 0) {
		if(!defined($val) || ref(\$val) eq "GLOB") {
			$val = 0.0;
		} elsif(do {
			my $warned;
			local $SIG{__WARN__} = sub { $warned = 1; };
			use warnings qw(numeric uninitialized);
			no warnings "void";
			0 + (my $tval = $val);
			$warned;
		}) {
			$val = "0";
		}
		return my $zero = $zero{sprintf("%+.f%+.f", $val, -$val)};
	} else {
		return 0 + $val;
	}
}

sub sclnum_is_natint($) {
	my($val) = @_;
	if(have_signed_zero && $val == 0) {
		$val = $_[0];
		return sprintf("%+.f%+.f", $val, -$val) eq "+0+0";
	} elsif(int($val) != $val) {
		return 0;
	} elsif(significand_bits+1 >= natint_bits) {
		# all native integers are representable as floats, so
		# straight comparison against max_natint works
		return $val >= min_natint && $val <= max_natint;
	} else {
		# Some native integers can't be exactly represented as
		# floats, so naive comparisons will cause lossy
		# conversions.  min_natint, being the negation of a power
		# of two, can be represented correctly as a float, but
		# max_natint cannot.  We have two float constants, low_max
		# and high_max, which are the adjacent representable
		# values bracketing the value of max_natint.  A value
		# below low_max compares so, and so is easily accepted.
		# A float that is above high_max compares so, and so is
		# easily rejected.
		#
		# What remains is the float values low_max and high_max
		# themselves, and all the integers in the range [low_max,
		# high_max).  The only one of these values that is to be
		# rejected is high_max itself, but it can't be directly
		# detected because any of the integers except for low_max
		# might convert to high_max when floated for comparison.
		# The solution is to subtract out low_max, leaving much
		# smaller values that are all exactly representable as
		# integers.  high_max can then be correctly detected.
		return $val >= min_natint &&
			($val < low_max ||
			 ($val <= high_max &&
			  $val - low_max != reduced_high_max));
	}
}

sub sclnum_is_float($) {
	my($val) = @_;
	if(have_signed_zero && $val == 0.0) {
		$val = $_[0];
		return sprintf("%+.f%+.f", $val, -$val) ne "+0+0";
	} elsif(int($val) != $val || float_is_infinite($val)) {
		return 1;
	} elsif(significand_bits+1 >= natint_bits) {
		# all native integers are representable as floats
		# (except possibly zero, handled above)
		return 1;
	} else {
		# any integer within the continuous integer range of the
		# float type is a float
		return 1 if $val >= -max_integer() && $val <= max_integer;
		# Anything outside the native integer range is trivially
		# a float.  We can't reliably detect the upper end of this
		# range, because max_natint isn't representable as a
		# float, so compare against the representable high_max.
		return 1 if $val < min_natint || $val > high_max;
		# What remains is an integer that is either high_max or
		# representable as a native integer.  Whether it is a
		# float depends on the length of its binary representation.
		if($val > low_max) {
			# Might be high_max, so we can't use integer
			# arithmetic on it directly.  Shift it down one
			# bit so that we definitely can.  If the bit we
			# lose is set then it's definitely not a float.
			$val -= (1 << (natint_bits-1));
			return 0 if ($val & 1);
			$val = ($val >> 1) + (1 << (natint_bits-2));
		} else {
			$val = abs($val);
		}
		while($val >= (1 << (significand_bits+1))) {
			return 0 if ($val & 1);
			$val >>= 1;
		}
		return 1;
	}
}

sub sclnum_val_cmp($$) {
	my($a, $b) = @_;
	# Due to perl bug #41202, a text->float conversion sometimes
	# gives the wrong answer, but if a text->integer conversion is
	# done first then a later integer->float conversion can give a
	# more accurate answer.  Here we trigger such text->integer
	# conversions, in the situations where it is useful.
	{
		no warnings "void";
		0 + $a;
		0 + $b;
	}
	# Comparison between an integer and a float might be lossy.
	# Specifically, it could show values as equal when they're
	# not.  It can never show equal values as unequal, or give
	# the opposite of the correct order.  So first do the basic
	# comparison, and perform further analysis only if that
	# shows equality and integer->float conversion is in fact
	# lossy.
	my $cmp = $a <=> $b;
	return $cmp unless natint_bits > significand_bits+1 &&
			   defined($cmp) && $cmp == 0;
	# do the rest in positive values
	($a, $b) = (-$b, -$a) if $a < 0;
	# Subtract out powers of two until a difference is detected or we
	# get into the safely comparable range.  Powers of two can be
	# represented as both float and int, so all the arithmetic is exact.
	for(my $t = -min_natint(); $t != (1 << significand_bits); $t >>= 1) {
		next unless $a >= $t && $b >= $t;
		$a -= $t;
		$b -= $t;
		$cmp = $a <=> $b;
		return $cmp unless $cmp == 0;
	}
	return 0;
}

my %zero_order = (
	"-0+0" => 0,
	"+0+0" => 1,
	"+0-0" => 2,
);
sub sclnum_id_cmp($$) {
	my($a, $b) = @_;
	if($a != $a) {
		return $b != $b ? 0 : -1;
	} elsif($b != $b) {
		return +1;
	} elsif(have_signed_zero && $a == 0 && $b == 0) {
		($a, $b) = @_;
		return $zero_order{sprintf("%+.f%+.f", $a, -$a)} <=>
			$zero_order{sprintf("%+.f%+.f", $b, -$b)};
	} else {
		return sclnum_val_cmp($a, $b);
	}
}

1;