File Coverage

blib/lib/Sub/Quote.pm

Criterion	Covered	Total	%
statement	197	197	100.0
branch	147	170	86.4
condition	49	70	70.0
subroutine	35	35	100.0
pod	8	8	100.0
total	436	480	90.8

package Sub::Quote;

sub _clean_eval { eval $_[0] }

use strict;
use warnings;

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

use Sub::Defer qw(defer_sub);
use Scalar::Util qw(weaken);
use Exporter ();
BEGIN { *import = \&Exporter::import }
use Carp qw(croak);
BEGIN { our @CARP_NOT = qw(Sub::Defer) }
BEGIN {
  my $TRUE  = sub(){!!1};
  my $FALSE = sub(){!!0};
  *_HAVE_IS_UTF8          = defined &utf8::is_utf8 ? $TRUE : $FALSE;
  *_CAN_TRACK_BOOLEANS    = defined &builtin::is_bool ? $TRUE : $FALSE;
  *_CAN_TRACK_NUMBERS     = defined &builtin::created_as_number ? $TRUE : $FALSE;
  *_HAVE_HEX_FLOAT        = !$ENV{SUB_QUOTE_NO_HEX_FLOAT} && "$]" >= 5.022 ? $TRUE : $FALSE;

  # This may not be perfect, as we can't tell the format purely from the size
  # but it should cover the common cases, and other formats are more likely to
  # be less precise.
  my $nvsize = 8 * length pack 'F', 0;
  my $nvmantbits
    = $nvsize == 16   ? 11
    : $nvsize == 32   ? 24
    : $nvsize == 64   ? 53
    : $nvsize == 80   ? 64
    : $nvsize == 128  ? 113
    : $nvsize == 256  ? 237
                      : 237 # unknown float format
    ;
  my $precision = int( log(2)/log(10)*$nvmantbits );

  *_NVSIZE          = sub(){ $nvsize };
  *_NVMANTBITS      = sub(){ $nvmantbits };
  *_FLOAT_PRECISION = sub(){ $precision };

  local $@;
  # if B is already loaded, just use its perlstring
  if ("$]" >= 5.008_000 && "$]" != 5.010_000 && defined &B::perlstring) {
    *_perlstring = \&B::perlstring;
  }
  # XString is smaller than B, so prefer to use it. Buggy until 0.003.
  elsif (eval { require XString; XString->VERSION(0.003) }) {
    *_perlstring = \&XString::perlstring;
  }
  # B::perlstring in perl 5.10 handles escaping incorrectly on utf8 strings
  elsif ("$]" == 5.010_000) {
    my %escape = (
      (map +(chr($_) => sprintf '\x%02x', $_), 0 .. 0x31, 0x7f),
      "\t" => "\\t",
      "\n" => "\\n",
      "\r" => "\\r",
      "\f" => "\\f",
      "\b" => "\\b",
      "\a" => "\\a",
      "\e" => "\\e",
      (map +($_ => "\\$_"), qw(" \ $ @)),
    );
    *_perlstring = sub {
      my $value = shift;
      $value =~ s{(["\$\@\\[:cntrl:]]|[^\x00-\x7f])}{
        $escape{$1} || sprintf('\x{%x}', ord($1))
      }ge;
      qq["$value"];
    };
  }
  elsif ("$]" >= 5.008_000 && eval { require B; 1 } && defined &B::perlstring ) {
    *_perlstring = \&B::perlstring;
  }
  # on perl 5.6, perlstring is not available. quotemeta will mostly serve as a
  # replacement. it quotes just by adding lots of backslashes though. if a
  # utf8 string was written out directly as bytes, it wouldn't get interpreted
  # correctly if not under 'use utf8'. this is mostly a theoretical concern,
  # but enough to stick with perlstring when possible.
  else {
    *_perlstring = sub { qq["\Q$_[0]\E"] };
  }
}

our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub qsub);
our @EXPORT_OK = qw(quotify capture_unroll inlinify sanitize_identifier);

our %QUOTED;

sub quotify {
  my $value = $_[0];
  no warnings 'numeric';
  BEGIN {
    warnings->unimport(qw(experimental::builtin))
      if _CAN_TRACK_BOOLEANS || _CAN_TRACK_NUMBERS;
  }
  ! defined $value     ? 'undef()'
  : _CAN_TRACK_BOOLEANS && builtin::is_bool($value) ? (
    $value ? '(!!1)' : '(!!0)'
  )
  # numeric detection
  : (
    _CAN_TRACK_NUMBERS
      ? builtin::created_as_number($value)
      : (
        !(_HAVE_IS_UTF8 && utf8::is_utf8($value))
        && length( (my $dummy = '') & $value )
        && 0 + $value eq $value
      )
  ) ? (
    $value != $value ? (
      $value eq (9**9**9*0)
        ? '(9**9**9*0)'    # nan
        : '(-(9**9**9*0))' # -nan
    )
    : $value == 9**9**9  ? '(9**9**9)'     # inf
    : $value == -9**9**9 ? '(-9**9**9)'    # -inf
    : $value == 0 ? (
      sprintf('%g', $value) eq '-0' ? '-0.0' : '0',
    )
    : $value !~ /[e.]/i ? (
      $value > 0 ? (sprintf '%u', $value)
                 : (sprintf '%d', $value)
    )
    : do {
      my $float = $value;
      my $max_factor = int( log( abs($value) ) / log(2) ) - _NVMANTBITS;
      my $ex_sign = $max_factor > 0 ? 1 : -1;
      FACTOR: for my $ex (0 .. abs($max_factor)) {
        my $num = $value / 2**($ex_sign * $ex);
        for my $precision (_FLOAT_PRECISION .. _FLOAT_PRECISION+2) {
          my $formatted = sprintf '%0.'.$precision.'g', $num;
          $float = $formatted
            if $ex == 0;
          if ($formatted == $num) {
            if ($ex) {
              $float
                = $formatted
                . ($ex_sign == 1 ? '*' : '/')
                . (
                  $ex > _NVMANTBITS
                    ? "2**$ex"
                    : sprintf('%u', 2**$ex)
                );
            }
            last FACTOR;
          }
        }
        if (_HAVE_HEX_FLOAT) {
          $float = sprintf '%a', $value;
          last FACTOR;
        }
      }
      "$float";
    }
  )
  : !_CAN_TRACK_BOOLEANS && !length($value) && length( (my $dummy2 = '') & $value ) ? '(!!0)' # false
  : _perlstring($value);
}

sub sanitize_identifier {
  my $name = shift;
  $name =~ s/([_\W])/sprintf('_%x', ord($1))/ge;
  $name;
}

sub capture_unroll {
  my ($from, $captures, $indent) = @_;
  join(
    '',
    map {
      /^([\@\%\$])/
        or croak "capture key should start with \@, \% or \$: $_";
      (' ' x $indent).qq{my ${_} = ${1}{${from}->{${\quotify $_}}};\n};
    } keys %$captures
  );
}

sub inlinify {
  my ($code, $args, $extra, $local) = @_;
  $args = '()'
    if !defined $args;
  my $do = 'do { '.($extra||'');
  if ($code =~ s/^(\s*package\s+([a-zA-Z0-9:]+);)//) {
    $do .= $1;
  }
  if ($code =~ s{
    \A((?:\#\ BEGIN\ quote_sub\ PRELUDE\n.*?\#\ END\ quote_sub\ PRELUDE\n)?\s*)
    (^\s*) my \s* \(([^)]+)\) \s* = \s* \@_;
  }{}xms) {
    my ($pre, $indent, $code_args) = ($1, $2, $3);
    $do .= $pre;
    if ($code_args ne $args) {
      $do .= $indent . 'my ('.$code_args.') = ('.$args.'); ';
    }
  }
  elsif ($local || $args ne '@_') {
    $do .= ($local ? 'local ' : '').'@_ = ('.$args.'); ';
  }
  $do.$code.' }';
}

sub quote_sub {
  # HOLY DWIMMERY, BATMAN!
  # $name => $code => \%captures => \%options
  # $name => $code => \%captures
  # $name => $code
  # $code => \%captures => \%options
  # $code
  my $options =
    (ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH')
      ? pop
      : {};
  my $captures = ref($_[-1]) eq 'HASH' ? pop : undef;
  undef($captures) if $captures && !keys %$captures;
  my $code = pop;
  my $name = $_[0];
  if ($name) {
    my $subname = $name;
    my $package = $subname =~ s/(.*)::// ? $1 : caller;
    $name = join '::', $package, $subname;
    croak qq{package name "$package" too long!}
      if length $package > 252;
    croak qq{package name "$package" is not valid!}
      unless $package =~ /^[^\d\W]\w*(?:::\w+)*$/;
    croak qq{sub name "$subname" too long!}
      if length $subname > 252;
    croak qq{sub name "$subname" is not valid!}
      unless $subname =~ /^[^\d\W]\w*$/;
  }
  my @caller = caller(0);
  my ($attributes, $file, $line) = @{$options}{qw(attributes file line)};
  if ($attributes) {
    /\A\w+(?:\(.*\))?\z/s || croak "invalid attribute $_"
      for @$attributes;
  }
  my $quoted_info = {
    name     => $name,
    code     => $code,
    captures => $captures,
    package      => (exists $options->{package}      ? $options->{package}      : $caller[0]),
    hints        => (exists $options->{hints}        ? $options->{hints}        : $caller[8]),
    warning_bits => (exists $options->{warning_bits} ? $options->{warning_bits} : $caller[9]),
    hintshash    => (exists $options->{hintshash}    ? $options->{hintshash}    : $caller[10]),
    ($attributes ? (attributes => $attributes) : ()),
    ($file       ? (file => $file) : ()),
    ($line       ? (line => $line) : ()),
  };
  my $unquoted;
  weaken($quoted_info->{unquoted} = \$unquoted);
  if ($options->{no_defer}) {
    my $fake = \my $var;
    local $QUOTED{$fake} = $quoted_info;
    my $sub = unquote_sub($fake);
    Sub::Defer::_install_coderef($name, $sub) if $name && !$options->{no_install};
    return $sub;
  }
  else {
    my $deferred = defer_sub(
      ($options->{no_install} ? undef : $name),
      sub {
        $unquoted if 0;
        unquote_sub($quoted_info->{deferred});
      },
      {
        ($attributes ? ( attributes => $attributes ) : ()),
        ($name ? () : ( package => $quoted_info->{package} )),
      },
    );
    weaken($quoted_info->{deferred} = $deferred);
    weaken($QUOTED{$deferred} = $quoted_info);
    return $deferred;
  }
}

sub _context {
  my $info = shift;
  $info->{context} ||= do {
    my ($package, $hints, $warning_bits, $hintshash, $file, $line)
      = @{$info}{qw(package hints warning_bits hintshash file line)};

    $line ||= 1
      if $file;

    my $line_mark = '';
    if ($line) {
      $line_mark = "#line ".($line-1);
      if ($file) {
        $line_mark .= qq{ "$file"};
      }
      $line_mark .= "\n";
    }

    $info->{context}
      ="# BEGIN quote_sub PRELUDE\n"
      ."package $package;\n"
      ."BEGIN {\n"
      ."  \$^H = ".quotify($hints).";\n"
      ."  \${^WARNING_BITS} = ".quotify($warning_bits).";\n"
      ."  \%^H = (\n"
      . join('', map
      "    ".quotify($_)." => ".quotify($hintshash->{$_}).",\n",
        grep !(ref $hintshash->{$_} && $hintshash->{$_} =~ /\A(?:\w+(?:::\w+)*=)?[A-Z]+\(0x[[0-9a-fA-F]+\)\z/),
        keys %$hintshash)
      ."  );\n"
      ."}\n"
      .$line_mark
      ."# END quote_sub PRELUDE\n";
  };
}

sub quoted_from_sub {
  my ($sub) = @_;
  my $quoted_info = $QUOTED{$sub||''} or return undef;
  my ($name, $code, $captures, $unquoted, $deferred)
    = @{$quoted_info}{qw(name code captures unquoted deferred)};
  $code = _context($quoted_info) . $code;
  $unquoted &&= $$unquoted;
  if (($deferred && $deferred eq $sub)
      || ($unquoted && $unquoted eq $sub)) {
    return [ $name, $code, $captures, $unquoted, $deferred ];
  }
  return undef;
}

sub unquote_sub {
  my ($sub) = @_;
  my $quoted_info = $QUOTED{$sub} or return undef;
  my $unquoted = $quoted_info->{unquoted};
  unless ($unquoted && $$unquoted) {
    my ($name, $code, $captures, $package, $attributes)
      = @{$quoted_info}{qw(name code captures package attributes)};

    ($package, $name) = $name =~ /(.*)::(.*)/
      if $name;

    my %captures = $captures ? %$captures : ();
    $captures{'$_UNQUOTED'} = \$unquoted;
    $captures{'$_QUOTED'} = \$quoted_info;

    my $make_sub
      = "{\n"
      . capture_unroll("\$_[1]", \%captures, 2)
      . "  package ${package};\n"
      . (
        $name
          # disable the 'variable $x will not stay shared' warning since
          # we're not letting it escape from this scope anyway so there's
          # nothing trying to share it
          ? "  no warnings 'closure';\n  sub ${name} "
          : "  \$\$_UNQUOTED = sub "
      )
      . ($attributes ? join('', map ":$_ ", @$attributes) : '') . "{\n"
      . "  (\$_QUOTED,\$_UNQUOTED) if 0;\n"
      . _context($quoted_info)
      . $code
      . "  }".($name ? "\n  \$\$_UNQUOTED = \\&${name}" : '') . ";\n"
      . "}\n"
      . "1;\n";
    if (my $debug = $ENV{SUB_QUOTE_DEBUG}) {
      if ($debug =~ m{^([^\W\d]\w*(?:::\w+)*(?:::)?)$}) {
        my $filter = $1;
        my $match
          = $filter =~ /::$/ ? $package.'::'
          : $filter =~ /::/  ? $package.'::'.($name||'__ANON__')
          : ($name||'__ANON__');
        warn $make_sub
          if $match eq $filter;
      }
      elsif ($debug =~ m{\A/(.*)/\z}s) {
        my $filter = $1;
        warn $make_sub
          if $code =~ $filter;
      }
      else {
        warn $make_sub;
      }
    }
    {
      no strict 'refs';
      local *{"${package}::${name}"} if $name;
      my ($success, $e);
      {
        local $@;
        $success = _clean_eval($make_sub, \%captures);
        $e = $@;
      }
      unless ($success) {
        my $space = length($make_sub =~ tr/\n//);
        my $line = 0;
        $make_sub =~ s/^/sprintf "%${space}d: ", ++$line/emg;
        croak "Eval went very, very wrong:\n\n${make_sub}\n\n$e";
      }
      weaken($QUOTED{$$unquoted} = $quoted_info);
    }
  }
  $$unquoted;
}

sub qsub ($) {
  goto "e_sub;
}

sub CLONE {
  my @quoted = map { defined $_ ? (
    $_->{unquoted} && ${$_->{unquoted}} ? (${ $_->{unquoted} } => $_) : (),
    $_->{deferred} ? ($_->{deferred} => $_) : (),
  ) : () } values %QUOTED;
  %QUOTED = @quoted;
  weaken($_) for values %QUOTED;
}

1;
__END__