File Coverage

blib/lib/builtins/compat.pm

Criterion	Covered	Total	%
statement	50	52	98.0
branch	11	12	91.6
condition	12	14	85.7
subroutine	16	16	100.0
pod	0	2	0.0
total	89	96	93.7

use 5.008001;
use strict;
use warnings;

package builtins::compat;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.002';

sub _true () {
	!!1;
}

sub _false () {
	!!0;
}

BEGIN {
	# uncoverable statement
	*LEGACY_PERL = ( $] lt '5.036' ) ? \&_true : \&_false;
};

sub import {
	goto \&import_compat if LEGACY_PERL;

	# uncoverable statement
	'warnings'->unimport('experimental::builtin');

	# uncoverable statement
	'builtin'->import( qw<
		true false is_bool
		weaken unweaken is_weak
		blessed refaddr reftype
		created_as_string created_as_number
		ceil floor
		trim
		indexed
	> );
}

sub import_compat {
	my $class = shift;

	my $caller = caller;
	my $subs   = $class->get_subs;

	while ( my ( $name, $code ) = each %$subs ) {
		no strict 'refs';
		*{"$caller\::$name"} = $code;
	}

	require namespace::clean;
	'namespace::clean'->import(
		-cleanee => $caller,
		keys %$subs,
	);
}

{
	my $subs;
	sub get_subs {
		require Scalar::Util;
		'Scalar::Util'->VERSION( '1.36' );

		$subs ||= {
			true               => \&_true,
			false              => \&_false,
			is_bool            => \&_is_bool,
			weaken             => \&Scalar::Util::weaken,
			unweaken           => \&Scalar::Util::unweaken,
			is_weak            => \&Scalar::Util::isweak,
			blessed            => \&Scalar::Util::blessed,
			refaddr            => \&Scalar::Util::refaddr,
			reftype            => \&Scalar::Util::reftype,
			weaken             => \&Scalar::Util::weaken,
			created_as_string  => \&_created_as_string,
			created_as_number  => \&_created_as_number,
			ceil               => \&_ceil,   # POSIX::ceil has wrong prototype
			floor              => \&_floor,  # POSIX::floor has wrong prototype
			trim               => \&_trim,
			indexed            => \&_indexed,
		};
	}
}

if ( LEGACY_PERL ) {
	my $subs = __PACKAGE__->get_subs;
	while ( my ( $name, $code ) = each %$subs ) {
		no strict 'refs';
		*{"builtin::$name"} = $code
			unless exists &{"builtin::$name"};
	}
}

sub _is_bool ($) {
	my $value = shift;

	return _false unless defined $value;
	return _false if ref $value;
	return _false unless Scalar::Util::isdual( $value );
	return !! (
		( "$value" eq "1" or "$value" eq "" )
		and ( $value+0 == 1 or $value+0 == 0 )
	);
}

sub _created_as_number ($) {
	require B;

	my $value = shift;

	my $b_obj = B::svref_2object(\$value);
	my $flags = $b_obj->FLAGS;
	return _true if $flags & ( B::SVp_IOK() | B::SVp_NOK() ) and !( $flags & B::SVp_POK() );
	return _false;
}

sub _created_as_string ($) {
	my $value = shift;

	defined($value)
		&& !ref($value)
		&& !_is_bool($value)
		&& !_created_as_number($value);
}

sub _indexed {
	my $ix = 0;
	return map { $ix++, $_ } @_;
}

sub _trim ($) {
	my $value = shift;

	$value =~ s{^\s+|\s+$}{}g;
	return $value;
}

sub _ceil ($) {
	require POSIX;
	return POSIX::ceil( $_[0] );
}

sub _floor ($) {
	require POSIX;
	return POSIX::floor( $_[0] );
}

1;

__END__