How can I get the name of a function reference [duplicate] - perl

How would one determine the subroutine name of a Perl code reference? I would also like to distinguish between named and anonymous subroutines.
Thanks to this question I know how to print out the code, but I still don't know how to get the name.
For example, I'd like to get 'inigo_montoya' from the following:
#!/usr/bin/env perl
use strict;
use warnings;
use Data::Dumper;
$Data::Dumper::Deparse = 1;
my $sub_ref = \&inigo_montoya;
print Dumper $sub_ref;
# === subroutines ===
sub inigo_montoya {
print <<end_quote;
I will go up to the six-fingered man and say, "Hello. My name is Inigo
Montoya. You killed my father. Prepare to die."';
end_quote
}

Why not ask, what the compiler sees? (It would return __ANON__ on anonymous subs).
#!/usr/bin/perl
use strict;
use warnings;
my $sub_ref = \&inigo_montoya;
use B qw(svref_2object);
my $cv = svref_2object ( $sub_ref );
my $gv = $cv->GV;
print "name: " . $gv->NAME . "\n";
sub inigo_montoya {
print "...\n";
}

Sub::Identify does exactly this, hiding all that nasty B::svref_2object() stuff from you so you don't have to think about it.
#!/usr/bin/env perl
use strict;
use warnings;
use feature 'say';
use Sub::Identify ':all';
my $sub_ref = \&inigo_montoya;
say "Sub Name: ", sub_name($sub_ref);
say "Stash Name: ", stash_name($sub_ref);
say "Full Name: ", sub_fullname($sub_ref);
# === subroutines ===
sub inigo_montoya {
print <<' end_quote';
I will go up to the six-fingered man and say, "Hello. My name is Inigo
Montoya. You killed my father. Prepare to die."';
end_quote
}
Which outputs:
$ ./sub_identify.pl
Sub Name: inigo_montoya
Stash Name: main
Full Name: main::inigo_montoya

Expanding on Jan Hartung's idea (and scrapping my own), you could get a fully qualified name and some trace information for no matter what it is or where it came from:
use B qw(svref_2object);
sub sub_name {
return unless ref( my $r = shift );
return unless my $cv = svref_2object( $r );
return unless $cv->isa( 'B::CV' )
and my $gv = $cv->GV
;
my $name = '';
if ( my $st = $gv->STASH ) {
$name = $st->NAME . '::';
}
my $n = $gv->NAME;
if ( $n ) {
$name .= $n;
if ( $n eq '__ANON__' ) {
$name .= ' defined at ' . $gv->FILE . ':' . $gv->LINE;
}
}
return $name;
}

I'm not sure about calling the name of the function from the outside, but you can get it from within the subroutine via the caller function:
sub Foo {print "foo!\n";return (caller(0))[3];}
$function_name=Foo();
print "Called $function_name\n";
This has the following output:
foo!
Called main::Foo
Of course, you can return the function name as one of the items that the subroutine returns. That way, you can capture it and have the option of displaying it (or using it in other logic, etc).

Related

Locally change an attribute of a class in Perl

I have come across an odd problem in one of my Perl scripts. I have a Perl object. Within a certain scope I want one of the objects attributes to be changed, but I want the attribute to be restored to it's old value after it leaves the scope.
Example:
my $object = Object->new('name' => 'Bob');
{
# I know this doesn't work, but it is the best way
# I can represent what I amd trying to do.
local $object->name('Lenny');
# Prints "Lenny"
print $object->name();
}
# Prints "Bob"
print $object->name();
Is there a way to achieve something like this?
This might not be as much encapsulation as you were asking for, but you can local-ize an attribute of a hash. This outputs "CarlLennyCarl"
sub Object::new { bless { _name => $_[1] }, $_[0] } }
sub Object::name { $_[0]->{_name} }
my $obj = Object->new("Carl");
print $obj->name;
{
local $obj->{_name} = "Lenny";
print $obj->name;
}
print $obj->name;
You could also local-ize the entire method. This also outputs "CarlLennyCarl":
sub Object::new { bless { _name => $_[1] }, $_[0] } }
sub Object::name { $_[0]->{_name} }
my $obj = Object->new("Carl");
print $obj->name;
{
local *Object::name = sub { "Lenny" };
print $obj->name;
}
print $obj->name;
I was completely misunderstanding what was occurring there. You cannot use local on subroutine calls, that is the issue you are having.
Lets use a code example from one that I know works and try to explain what eval is actually doing.
#!/usr/bin/perl
use strict;
use warnings;
use Data::Dumper;
use Cwd;
print getcwd() . "\n";
eval{
local #INC = ('/tmp');
require 'test.pl';
print 'local: ' . Dumper(\#INC);
};
print Dumper(\#INC);
That works because I am modifying a variable, not calling on another subroutine to modify my variable.
In order for it to work as you are expecting, you would have to create a deep copy of the object to modify in local scope or something of the sort. (which I'm pretty sure is what is occurring in the first place)
local creates scope for the given brackets, eval, OR file (your problem there)
If you were able to access the elements directly without the method call (bad practice IMHO) you would likely be able to localize the scope of that element in the object.
Example:
name.pm:
package name;
use strict;
use warnings;
{
sub new {
my ($class,$name) = #_;
my $self = bless {}, $class;
$self->{'name'} = $name if defined $name;
return $self;
}
sub name
{
my ($self,$name) = #_;
$self->{'name'} = $name if defined $name;
return $self->{'name'};
}
}
index.pl:
#!/usr/bin/perl -w
use strict;
use warnings FATAL => 'all';
use name;
my $obj = name->new('test');
print $obj->{'name'} . "\n";
{
local $obj->{'name'} = 'test2';
print $obj->{'name'} . "\n";
}
print $obj->{'name'} . "\n";

Perl print out all subs arguments at every call at runtime

I'm looking for way to debug print each subroutine call from the namespace Myapp::* (e.g. without dumping the CPAN modules), but without the need edit every .pm file manually for to inserting some module or print statement.
I just learning (better to say: trying to understand) the package DB, what allows me tracing the execution (using the shebang #!/usr/bin/perl -d:Mytrace)
package DB;
use 5.010;
sub DB {
my( $package, $file, $line ) = caller;
my $code = \#{"::_<$file"};
print STDERR "--> $file $line $code->[$line]";
}
#sub sub {
# print STDERR "$sub\n";
# &$sub;
#}
1;
and looking for a way how to use the sub call to print the actual arguments of the called sub from the namespace of Myapp::*.
Or is here some easier (common) method to
combine the execution line-tracer DB::DB
with the Dump of the each subroutine call arguments (and its return values, if possible)?
I don't know if it counts as "easier" in any sane meaning of the word, but you can walk the symbol table and wrap all functions in code that prints their arguments and return values. Here's an example of how it might be done:
#!/usr/bin/env perl
use 5.14.2;
use warnings;
package Foo;
sub first {
my ( $m, $n ) = #_;
return $m+$n;
}
sub second {
my ( $m, $n ) = #_;
return $m*$n;
}
package main;
no warnings 'redefine';
for my $k (keys %{$::{'Foo::'}}) {
my $orig = *{$::{'Foo::'}{$k}}{CODE};
$::{'Foo::'}{$k} = sub {
say "Args: #_";
unless (wantarray) {
my $r = $orig->(#_);
say "Scalar return: $r";
return $r;
}
else {
my #r = $orig->(#_);
say "List return: #r";
return #r
}
}
}
say Foo::first(2,3);
say Foo::second(4,6);

Generating a subroutine reference from a string

I'm creating a dispatch table:
my $dispatch = {
'do_this' => \&do_this,
'do_that' => \&do_that,
'do_something' => \&do_something,
'do_something_else' => \&do_something_else,
};
Instead of typing in the same string of chars for the key and the value, I'd like to do this:
my $dispatch_values = ['do_this', 'do_that', 'do_something', 'do_something_else'];
my $dispatch = generate_dispatch_table($dispatch_values);
sub generate_dispatch_table {
my $values = shift;
my $table = {};
foreach $value (#$values) {
$table{$value} = #WHAT GOES HERE?
}
return $table;
}
I don't know how to generate a subroutine reference from a string, though.
Just use \&{ $sub_name }:
#! /usr/bin/perl
use warnings;
use strict;
sub hi { print "Hi\n" }
sub bye { print "Bye\n" }
my %dispatch = map { $_, \&{$_} } qw(hi bye);
chomp(my $action = <>);
$dispatch{$action}->();
Alternatives include:
use an object.
use a package.
For an object, it's pretty much exactly what you're used to:
#! /usr/bin/perl
package Foo;
use warnings;
use strict;
sub hi { print "Hi\n" }
sub bye { print "Bye\n" }
sub new { bless {} }
package main;
my $dispatcher = Foo->new;
chomp(my $action = <>);
$dispatcher->$action();
Of course, one should check if you can do the action, but we're omitting some basic checks here.
Another good check is to not use the action as is, but to use a prefix that indicates it's dispatchable in case you have other non-dispatch methods in the object:
#! /usr/bin/perl
package Foo;
use warnings;
use strict;
sub do_hi { print "Hi\n" }
sub do_bye { print "Bye\n" }
sub new { bless {} }
package main;
my $dispatcher = Foo->new;
chomp(my $action = <>);
$action = "do_" . $action;
$dispatcher->$action();
The only difference is the do_ prefix, but now the caller can't call new through the dispatcher. Otherwise, it's the same - this dispatcher will dispatch hi and bye like choroba's answer.
Remember, of course, that $self is the first parameter, if you're passing in parameters at all.
Doing this via packages is almost the same:
#! /usr/bin/perl
package Foo;
use warnings;
use strict;
sub do_hi { print "Hi\n" }
sub do_bye { print "Bye\n" }
package main;
chomp(my $action = <>);
$action = 'do_' . $action;
Foo->$action();
Here, the first parameter is, of course, "Foo". We also don't need an object, so no constructor required.
However, you can take this and apply it directly to your original question and avoid some of the extra sigils. Just remove the package declarations, and change Foo->$action() to __PACKAGE__->$action() even in the default (main) package. But, if you don't want to have the package name being passed in, we take this just a tiny step further:
sub do_hi { print "Hi\n" }
sub do_bye { print "Bye\n" }
chomp(my $action = <>);
$action = 'do_' . $action;
__PACKAGE__->can($action)->();
TMTOWTDI. Pick the one that makes the most sense to you and your code layout. Sometimes I use the object model, sometimes another one.

Determining the subroutine name of a Perl code reference

How would one determine the subroutine name of a Perl code reference? I would also like to distinguish between named and anonymous subroutines.
Thanks to this question I know how to print out the code, but I still don't know how to get the name.
For example, I'd like to get 'inigo_montoya' from the following:
#!/usr/bin/env perl
use strict;
use warnings;
use Data::Dumper;
$Data::Dumper::Deparse = 1;
my $sub_ref = \&inigo_montoya;
print Dumper $sub_ref;
# === subroutines ===
sub inigo_montoya {
print <<end_quote;
I will go up to the six-fingered man and say, "Hello. My name is Inigo
Montoya. You killed my father. Prepare to die."';
end_quote
}
Why not ask, what the compiler sees? (It would return __ANON__ on anonymous subs).
#!/usr/bin/perl
use strict;
use warnings;
my $sub_ref = \&inigo_montoya;
use B qw(svref_2object);
my $cv = svref_2object ( $sub_ref );
my $gv = $cv->GV;
print "name: " . $gv->NAME . "\n";
sub inigo_montoya {
print "...\n";
}
Sub::Identify does exactly this, hiding all that nasty B::svref_2object() stuff from you so you don't have to think about it.
#!/usr/bin/env perl
use strict;
use warnings;
use feature 'say';
use Sub::Identify ':all';
my $sub_ref = \&inigo_montoya;
say "Sub Name: ", sub_name($sub_ref);
say "Stash Name: ", stash_name($sub_ref);
say "Full Name: ", sub_fullname($sub_ref);
# === subroutines ===
sub inigo_montoya {
print <<' end_quote';
I will go up to the six-fingered man and say, "Hello. My name is Inigo
Montoya. You killed my father. Prepare to die."';
end_quote
}
Which outputs:
$ ./sub_identify.pl
Sub Name: inigo_montoya
Stash Name: main
Full Name: main::inigo_montoya
Expanding on Jan Hartung's idea (and scrapping my own), you could get a fully qualified name and some trace information for no matter what it is or where it came from:
use B qw(svref_2object);
sub sub_name {
return unless ref( my $r = shift );
return unless my $cv = svref_2object( $r );
return unless $cv->isa( 'B::CV' )
and my $gv = $cv->GV
;
my $name = '';
if ( my $st = $gv->STASH ) {
$name = $st->NAME . '::';
}
my $n = $gv->NAME;
if ( $n ) {
$name .= $n;
if ( $n eq '__ANON__' ) {
$name .= ' defined at ' . $gv->FILE . ':' . $gv->LINE;
}
}
return $name;
}
I'm not sure about calling the name of the function from the outside, but you can get it from within the subroutine via the caller function:
sub Foo {print "foo!\n";return (caller(0))[3];}
$function_name=Foo();
print "Called $function_name\n";
This has the following output:
foo!
Called main::Foo
Of course, you can return the function name as one of the items that the subroutine returns. That way, you can capture it and have the option of displaying it (or using it in other logic, etc).

How can I list all variables that are in a given scope?

I know I can list all of the package and lexcial variables in a given scope using Padwalker's peek_our and peek_my, but how can I get the names and values of all of the global variables like $" and $/?
#!/usr/bin/perl
use strict;
use warnings;
use PadWalker qw/peek_our peek_my/;
use Data::Dumper;
our $foo = 1;
our $bar = 2;
{
my $foo = 3;
print Dumper in_scope_variables();
}
print Dumper in_scope_variables();
sub in_scope_variables {
my %in_scope = %{peek_our(1)};
my $lexical = peek_my(1);
#lexicals hide package variables
while (my ($var, $ref) = each %$lexical) {
$in_scope{$var} = $ref;
}
##############################################
#FIXME: need to add globals to %in_scope here#
##############################################
return \%in_scope;
}
You can access the symbol table, check out p. 293 of "Programming Perl"
Also look at "Mastering Perl: http://www252.pair.com/comdog/mastering_perl/
Specifically: http://www252.pair.com/comdog/mastering_perl/Chapters/08.symbol_tables.html
Those variables you are looking for will be under the main namespace
A quick Google search gave me:
{
no strict 'refs';
foreach my $entry ( keys %main:: )
{
print "$entry\n";
}
}
You can also do
*sym = $main::{"/"}
and likewise for other values
If you want to find the type of the symbol you can do (from mastering perl):
foreach my $entry ( keys %main:: )
{
print "-" x 30, "Name: $entry\n";
print "\tscalar is defined\n" if defined ${$entry};
print "\tarray is defined\n" if defined #{$entry};
print "\thash is defined\n" if defined %{$entry};
print "\tsub is defined\n" if defined &{$entry};
}
And that does it. Thanks to MGoDave and kbosak for providing the answer in front of my face that I was too stupid to see (I looked in %main:: to start with, but missed that they didn't have their sigils). Here is the complete code:
#!/usr/bin/perl
use strict;
use warnings;
use PadWalker qw/peek_our peek_my/;
use Data::Dumper;
our $foo = 1;
our $bar = 2;
{
my $foo = 3;
print Dumper in_scope_variables();
}
print Dumper in_scope_variables();
sub in_scope_variables {
my %in_scope = %{peek_our(1)};
my $lexical = peek_my(1);
for my $name (keys %main::) {
my $glob = $main::{$name};
if (defined ${$glob}) {
$in_scope{'$' . $name} = ${$glob};
}
if (defined #{$glob}) {
$in_scope{'#' . $name} = [#{$glob}];
}
if (defined %{$glob}) {
$in_scope{'%' . $name} = {%{$glob}};
}
}
#lexicals hide package variables
while (my ($var, $ref) = each %$lexical) {
$in_scope{$var} = $ref;
}
return \%in_scope;
}
You can do something like the following to check the symbol table of the main package:
{
no strict 'refs';
for my $var (keys %{'main::'}) {
print "$var\n";
}
}
Thanks, Chas, very useful code.
As a note for future users of your code with perl > 5.12:
I was using it in in my pdl2 .perldlrc to find out lexical variables (like the 'y' command in the debugger) and I had this warning:
load_rcfile: loading
/homes/pmg/.perldlrc defined(%hash) is deprecated at (eval 254) line 36.
(Maybe you should just omit the defined()?)
From perldoc -f defined
Use of defined on aggregates (hashes
and arrays) is deprecated. It used to
report whether memory for that
aggregate had ever been allocated.
This behavior may disappear in future
versions of Perl. You should instead
use a simple test for size:
> if (#an_array) { print "has array elements\n" }
> if (%a_hash) { print "has hash members\n" }
What I don't understand is why it only complained with the defined hash and not also with the array?