Sub::Name::PP

snpp.pl

#!/usr/bin/perl
# Sub::Name::PP without B. pack/unpack with our structs is enough
# See http://www.perlmonks.org/?node_id=379428
# and https://github.com/ribasushi/snpp/blob/subname_pp/lib/Sub/Name/PP.pm
use Devel::Peek;
$DEBUG = 1;
$sub = sub {$word};

Dump($sub) if $DEBUG;

sub Sub::Name::PP ($$) {
  $sub = shift or die;
  $newname = shift or die;
  use Config;
  $p = $Config{ptrsize};
  $w = $p==8 ? "Q" : "L";

  $cv = unpack("P".4*$p,pack($w, 0+$sub));
  $pvcv = unpack("P".11*$p, substr $cv,0,$p);
  $off = 7; # gv offset in pvcv
  printf STDERR "old CvGV: 0x%x\n", unpack($w,substr $pvcv,$off*$p,$p) 
    if $DEBUG;
  # $gv = unpack("P".12*$p, substr $pvcv,$off*$p,$p);

  # create a pvcv->gv for the new name
  ($stash) = $newname =~ /^(.+::)/;
  $stash = "main::" unless $stash;
  $newname = $stash.$newname;
  eval "sub $newname {1}";

  $newcv = unpack("P".4*$p,pack($w,0+\&{$newname}));
  $newpvcv = unpack("P".11*$p, substr $newcv,0,$p);
  $gv = unpack($w, substr $newpvcv,$off*$p,$p);
  printf STDERR "new CvGV: 0x%x\n", $gv 
    if $DEBUG;

  substr($pvcv,$off*$p,$p) = pack($w, 0+$gv);
}

Sub::Name::PP($sub, "newname");
Dump(\&newname) if $DEBUG;
Dump($sub) if $DEBUG;