1use strict; 2use warnings; 3 4BEGIN { $^P |= 0x210 } 5 6use Test::More tests => 21; 7 8use B::Deparse; 9use Sub::Util qw( subname set_subname ); 10use Symbol qw( delete_package ) ; 11 12{ 13 sub localfunc {} 14 sub fully::qualified::func {} 15 16 is(subname(\&subname), "Sub::Util::subname", 17 'subname of \&subname'); 18 is(subname(\&localfunc), "main::localfunc", 19 'subname of \&localfunc'); 20 is(subname(\&fully::qualified::func), "fully::qualified::func", 21 'subname of \&fully::qualfied::func'); 22 23 # Because of the $^P debug flag, we'll get [file:line] as well 24 like(subname(sub {}), qr/^main::__ANON__\[.+:\d+\]$/, 'subname of anon sub'); 25 26 ok(!eval { subname([]) }, 'subname [] dies'); 27} 28 29my $x = set_subname foo => sub { (caller 0)[3] }; 30my $line = __LINE__ - 1; 31my $file = __FILE__; 32my $anon = $DB::sub{"main::__ANON__[${file}:${line}]"}; 33 34is($x->(), "main::foo"); 35 36{ 37 package Blork; 38 39 use Sub::Util qw( set_subname ); 40 41 set_subname " Bar!", $x; 42 ::is($x->(), "Blork:: Bar!"); 43 44 set_subname "Foo::Bar::Baz", $x; 45 ::is($x->(), "Foo::Bar::Baz"); 46 47 set_subname "set_subname (dynamic $_)", \&set_subname for 1 .. 3; 48 49 for (4 .. 5) { 50 set_subname "Dynamic $_", $x; 51 ::is($x->(), "Blork::Dynamic $_"); 52 } 53 54 ::is($DB::sub{"main::foo"}, $anon); 55 56 for (4 .. 5) { 57 ::is($DB::sub{"Blork::Dynamic $_"}, $anon); 58 } 59 60 for ("Blork:: Bar!", "Foo::Bar::Baz") { 61 ::is($DB::sub{$_}, $anon); 62 } 63} 64 65# RT42725 66{ 67 my $source = eval { 68 B::Deparse->new->coderef2text(set_subname foo => sub{ @_ }); 69 }; 70 71 ok !$@; 72 73 like $source, qr/\@\_/; 74} 75 76# subname of set_subname 77{ 78 is(subname(set_subname "my-scary-name-here", sub {}), "main::my-scary-name-here", 79 'subname of set_subname'); 80} 81 82# this used to segfault 83 84{ 85 sub ToDelete::foo {} 86 87 my $foo = \&ToDelete::foo; 88 89 delete_package 'ToDelete'; 90 91 is( subname($foo), "$]" >= 5.010 ? '__ANON__::foo' : 'ToDelete::foo', 'subname in deleted package' ); 92 ok( set_subname('NewPackage::foo', $foo), 'rename from deleted package' ); 93 is( subname($foo), 'NewPackage::foo', 'subname after rename' ); 94} 95 96# vim: ft=perl 97