File Coverage

blib/lib/builtins/compat.pm

Criterion	Covered	Total	%
statement	70	78	91.0
branch	25	30	83.3
condition	17	23	73.9
subroutine	17	17	100.0
pod	0	3	0.0
total	129	151	86.0

use 5.008001;
use strict;
use warnings;

package builtins::compat;

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

sub _true () {
	!!1;
}

sub _false () {
	!!0;
}

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

our %EXPORT_TAGS = (
	'5.36' => [ qw<
		true     false    is_bool
		weaken   unweaken is_weak
		blessed  refaddr  reftype
		created_as_string created_as_number
		ceil     floor    trim     indexed
	> ],
	'bool' => [ qw< true false is_bool > ],
);

sub parse_args {
	my $class = shift;
	my @args  = @_ ? @_ : ':5.36';

	my $want  = {};
	for my $arg ( @args ) {
		if ( $arg =~ /^:(.+)/ ) {
			my $tag = $1;
			if ( not exists $EXPORT_TAGS{$tag} ) {
				require Carp;
				Carp::carp( qq["$tag" is not defined in $class\::EXPORT_TAGS] );
			}
			$want->{$_} = 1 for @{ $EXPORT_TAGS{$tag} or [] };
		}
		elsif ( $arg =~ /^\!(.+)/ ) {
			my $unwanted = $1;
			delete $want->{$_};
		}
		else {
			$want->{$arg} = 1;
		}
	}

	return $want;
}

sub import {
	goto \&import_compat if LEGACY_PERL;

	my $class = shift;
	my %want  = %{ $class->parse_args( @_ ) };

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

	# uncoverable statement
	'builtin'->import( keys %want );
}

sub import_compat {
	my $class = shift;

	my $caller = caller;
	my $subs   = $class->get_subs;
	my %want   = %{ $class->parse_args( @_ ) };

	for my $name ( sort keys %want ) {

		if ( my $code = $subs->{$name} ) {
			no strict 'refs';
			*{"$caller\::$name"} = $code;
		}
		else {
			require Carp;
			Carp::carp( qq["$name" is not exported by the $class module] );
			delete $want{$name}; # hide from namespace::clean
		}
	}

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

{
	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 _true if  $value && "$value" eq '1' && $value+0 == 1;
	return _true if !$value && "$value" eq q'' && $value+0 == 0;
	return _false;
}

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

	return _false if utf8::is_utf8($value);

	require B;
	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{\A\s+|\s+\z}{}g;
	return $value;
}

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

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

1;

__END__