File Coverage

blib/lib/builtin/compat.pm

Criterion	Covered	Total	%
statement	60	62	96.7
branch	6	8	75.0
condition	8	9	88.8
subroutine	18	18	100.0
pod	7	7	100.0
total	99	104	95.1

package builtin::compat;
use strict;
use warnings;

our $VERSION = '0.002001';
$VERSION =~ tr/_//d;

use namespace::clean ();

sub true ();
sub false ();
sub is_bool ($);
sub weaken ($);
sub unweaken ($);
sub is_weak ($);
sub blessed ($);
sub refaddr ($);
sub reftype ($);
sub created_as_string ($);
sub created_as_number ($);
sub ceil ($);
sub floor ($);
sub trim ($);
sub indexed;

BEGIN { eval { require builtin } }
{
  package #hide
    experimental::builtin;
  if(!$warnings::Offsets{+__PACKAGE__}) {
    require warnings::register;
    warnings::register->import;
  }
}

my @fb = (
  true      => 'sub true () { !!1 }',
  false     => 'sub false () { !!0 }',
  is_bool   => sprintf(qq{#line %s "%s"\n}, __LINE__+1, __FILE__).<<'END_CODE',
use Scalar::Util ();
sub is_bool ($) {
  my $value = shift;

  return (
    defined $value
    && !length ref $value
    && Scalar::Util::isdual($value)
    && (
      $value
        ? ( $value == 1 && $value eq '1' )
        : ( $value == 0 && $value eq ''  )
    )
  );
}
END_CODE
  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',
  created_as_number => sprintf(qq{#line %s "%s"\n}, __LINE__+1, __FILE__).<<'END_CODE',
sub created_as_number ($) {
  my $value = shift;

  no warnings 'numeric';
  return (
    defined $value
    && !length ref $value
    && !is_bool($value)
    && !utf8::is_utf8($value)
    && length( (my $dummy = '') & $value )
    && 0 + $value eq $value
  );
}

END_CODE
  created_as_string => sprintf(qq{#line %s "%s"\n}, __LINE__+1, __FILE__).<<'END_CODE',
sub created_as_string ($) {
  my $value = shift;

  return (
    defined $value
    && !length ref $value
    && !is_bool($value)
    && !created_as_number($value)
  );
}
END_CODE
  ceil      => sprintf(qq{#line %s "%s"\n}, __LINE__+1, __FILE__).<<'END_CODE',
use POSIX ();
sub ceil ($) {
  goto &POSIX::ceil;
}
END_CODE
  floor     => sprintf(qq{#line %s "%s"\n}, __LINE__+1, __FILE__).<<'END_CODE',
use POSIX ();
sub floor ($) {
  goto &POSIX::floor;
}
END_CODE
  trim      => sprintf(qq{#line %s "%s"\n}, __LINE__+1, __FILE__).<<'END_CODE',
sub trim ($) {
  my $string = shift;
  s/\A\s+//, s/\s+\z// for $string;
  return $string;
}
END_CODE
  indexed   => sprintf(qq{#line %s "%s"\n}, __LINE__+1, __FILE__).<<'END_CODE',
sub indexed {
  my $i = 0;
  map +($i++, $_), @_;
}
END_CODE
  is_tainted => \'Scalar::Util::tainted',
);

my @EXPORT_OK;

my $code = '';

no strict 'refs';

while (my ($sub, $fb) = splice @fb, 0, 2) {
  push @EXPORT_OK, $sub;
  if (defined &{'builtin::'.$sub}) {
    *$sub = \&{'builtin::'.$sub};
    next;
  }
  if (ref $fb) {
    my ($mod) = $$fb =~ /\A(.*)::/s;
    (my $file = "$mod.pm") =~ s{::}{/}g;
    require $file;
    die "Unable to find $$fb"
      unless defined &{$$fb};
    *$sub = \&{$$fb};
  }
  else {
    $code .= $fb . "\n";
  }

  if (!defined &{'builtin::'.$sub}) {
    *{'builtin::'.$sub} = \&$sub;
  }
}

my $e;
{
  local $@;
  eval "$code; 1" or $e = $@;
}
die $e
  if defined $e;

my %EXPORT_OK = map +($_ => 1), @EXPORT_OK;

our $NO_DISABLE_WARNINGS;
sub import {
  my $class = shift;

  # search for caller that is being compiled. can't just use caller directly,
  # beause it may not be the same level as builtin would use for its lexical
  # exports
  my $caller;
  my $level = 0;
  while (my @caller = caller(++$level)) {
    if ($caller[3] =~ /\A(.*)::BEGIN\z/s) {
      $caller = $1;
      last;
    }
  }
  if (!defined $caller) {
    require Carp;
    Carp::croak("builtin::compat::import can only be called at compile time");
  }

  for my $import (@_) {
    require Carp;
    Carp::croak("'$import' is not recognised as a builtin function")
      if !$EXPORT_OK{$import};
    *{$caller.'::'.$import} = \&$import;
  }

  unless ($NO_DISABLE_WARNINGS) {
    local $@;
    eval { warnings->unimport('experimental::builtin') };
  }
  namespace::clean->import(-cleanee => $caller, @_);
  return;
}

if (!defined &builtin::import) {
  *builtin::import = sub {
    local $NO_DISABLE_WARNINGS = 1;
    &import;
  };
}

$INC{'builtin.pm'} ||= __FILE__;

1;
__END__