pure perl Sub::Name, mostly

test.pl

use strict;
use warnings;

use Carp qw/longmess/;
use B;

my @STASH;

sub set_sub_name {
    my ($name, $sub) = @_;

    $_[1] = sub {
        no strict 'refs';
        my $code_ob = B::svref_2object($sub);
        my $package = $code_ob->GV->STASH->NAME;

        my $anon_gv = B::svref_2object(\*{"$package\::__ANON__"});
        my $old_name = $anon_gv->NAME;

        push @STASH => [$package, $old_name];
        *{"$package\::__ANON__"} = $name;

        bless(\@_, 'main');
        goto &$sub;
    };
}

sub DESTROY {
    my $set = pop @STASH || return;
    my ($pkg, $name) = @$set;
    no strict 'refs';
    *{"$pkg\::__ANON__"} = $name;
}

sub mess { print longmess() };

my $sub = sub { mess() };
set_sub_name('bob::foo', $sub);

$sub->('x', 'y', 'z');

# Unfortunately ALL anon subs in a package share the __ANON__, as such they all
# get the last name set :-(
my $sub2 = sub { $sub->() };
set_sub_name('new::sub', $sub2);

$sub2->('x', 'y', 'z');

package Uhg;

my $sub3 = sub { $sub->() };
main::set_sub_name('Uhg::sub3', $sub3);

$sub3->('x', 'y', 'z');

__END__
 at test.pl line 37.
        bob::foo("x", "y", "z") called at test.pl line 40
 at test.pl line 37.
        bob::foo() called at test.pl line 44
        bob::foo("x", "y", "z") called at test.pl line 47  <--- can't be fixed?
 at test.pl line 37.
        bob::foo() called at test.pl line 51
        Uhg::sub3("x", "y", "z") called at test.pl line 54