in reply to Is there a way to access the name under which a subroutine was first defined?
I am using this code (which was inspired by Devel::Symdump) to get from coderef to name in my attribute handlers:
This only works if you know which package you are looking at, but I think in your case, you do.# code for this inspired by Devel::Symdump sub _find_name_of_sub_in_pkg{ my ($ref, $pkg) = @_; no strict 'refs'; #return *{$ref}{NAME} if ref $ref eq 'GLOB'; while (my ($key,$val) = each(%{*{"$pkg\::"}})) { local(*ENTRY) = $val; if (defined $val && defined *ENTRY{CODE}) { next unless *ENTRY{CODE} eq $ref; # rewind "each" my $a = scalar keys %{*{"$pkg\::"}}; return $key; } } die "failed to find name for StartRunmode code ref $ref in package + $pkg\n"; }
Update: Another major catch is that depending on which phase the handler runs, the subroutine will not yet be installed in the symbol table, so there is no name yet. Attribute::Handlers I think allows you to run at CHECK, when it may work. Maybe. Attributes are not for the faint of heart.
Update 2: I probably managed to confuse not only myself by now, but have a look at this:
The CHECK phase attribute can print the name by just looking at the GLOB it gets, whereas it is still anonymous for the BEGIN attribute. Not sure how to write anything except BEGIN handlers without Attribute::Handlers (only with plain MODIFY_CODE_ATTRIBUTES).use strict; package Beth; use Attribute::Handlers; sub print_name { my ($package, $symbol, $referent, $attr, $data, $phase, $filename, $linenum) = @_; if (ref $symbol eq 'GLOB'){ print *{$symbol}{NAME}; } print "\n"; } sub Lion :ATTR(CODE,BEGIN) { print_name(@_); } sub Tiger :ATTR(CODE,CHECK) { print_name(@_); } sub bar : Lion { print "pling.\n"; } sub foo : Tiger { print "pling.\n"; }
|
---|
Replies are listed 'Best First'. | |
---|---|
Re^2: Is there a way to access the name under which a subroutine was first defined?
by ELISHEVA (Prior) on Feb 16, 2009 at 12:31 UTC | |
by Thilosophy (Curate) on Feb 16, 2009 at 13:12 UTC |
In Section
Seekers of Perl Wisdom