How to get name of the called aliased subroutine? - perl

How could I get know which alias was used to call aliased subroutine? caller gives the original sub-name, but I'd like to see name used on calling.
Example:
use 5.010;
sub x_y_z {
return ( caller(0) )[3];
}
*foo_bar_baz = \&x_y_z;
say x_y_z(); # x_y_z
say foo_bar_baz(); # x_y_z, but need foo_bar_baz
Edit to address XY problem
I add another example to show my deeper intentsions. I want to create dispatch-table to route some tasks:
my $dispatch = {
x => {
y => {
z => sub {
&x_y_z;
},
}
},
a => {
b => {
c => {
d => sub {
&a_b_c_d;
},
}
}
}
}
sub foo {
my #arg = ( split '_', ( split( '::', ( caller(0) )[3] ) )[1] );
return #arg;
}
*x_y_z = \&foo;
*a_b_c_d = \&foo;
As you may imagine, this tree may grow pretty big. Now many leaves in dispatch-tree needs basically same sub, they differ just how they are called (named) and I'd like to have just one sub and alias it for specific task.

What you're trying to do is simply not possible within Perl's datamodel. An alias is just an alias, not an object with its own identity.
Note that it's possible to copy a subroutine and give it a new name, for example:
use Sub::Name;
*x_y_z = subname x_y_z => \&foo;
But you will have to do this manually.
It is not a good idea to depend on subnames for anything except for stack traces. Trying to build any logic on top of these names will likely end up in a hard to debug mess, not elegant software.
It might be better to pass the route name into the handler function as an explicit parameter, and to create a helper function to abstract over the necessary plumbing. For example:
my %routes;
sub route {
my ($name, $handler) = #_;
$routes{$name} = sub { $handler->($name => #_) };
return;
}
sub common_handler { ... }
route a_b_c => \&common_handler;
route x_y_z => \&common_handler;
route foo_bar => sub {
my ($route) = #_;
say "Custom handler invoked for route $route";
};
$routes{$name}->(#args);
If absolutely necessary you can of course implement such a route function so that it installs the handlers as a named subroutine. But at that point you are building some kind of framework like Moo(se), not an ordinary Perl module.

You can't. foo_bar_baz is an alias. caller reports the name of the subroutine as declared, not the name by which it was called. Note that not all subroutines have names and not all calls are by name. (Anonymous subs exist only as a CODE reference; they don't have an entry in the symbol table. Any sub—named or not—can be called via a reference.)
That said, you don't need aliasing here. What you really want is extra parameters for the database, table, etc., on which the sub should operate. The idiomatic way to do that is to wrap the generic sub and pass that information via the wrapper:
my %dispatch = (
a => { b => { c => sub { foo('a', 'b', 'c', #_) } } },
x => { y => { z => sub { foo('x', 'y', 'z', #_) } } },
);
$dispatch{a}{b}{c}->('foo');
$dispatch{x}{y}{z}->('bar');
sub foo {
my $db = shift;
my $table = shift;
my $task = shift;
my #params = #_;
say "$db $table $task: #params";
}

Related

How to change if/else to hash function? perl

sub funcA{
my ($A) = #_; <--require 1
}
sub funcB{
my ($A, $B) = #_; <--require 2
}
sub funcC{
my ($A, $B, $C) = #_; <--require 3
}
sub funcRun{
my ($param) = #_;
my $other1, $other2, $other3; <--will be assigned at ',,,,,'
,,,,,
if($param eq 'a'){
funcA, $other1;
return;
}elsif($param eq = 'b'){
funcB, $other1, $other2;
return;
}elsif($param eq = 'c'){
funcC, $other1, $other2, $other3;
return;
}
}
I want to change this to next code
sub funcA{
my ($A) = #_; #<--require 1
}
sub funcB{
my ($A, $B) = #_; #<--require 2
}
sub funcC{
my ($A, $B, $C) = #_; #<--require 3
}
my $hash_ref = {
'a' => \&funcA,
'b' => \&funcB,
'c' => \&funcC
}
sub funcRun{
my ($param) = #_;
my $other1, $other2, $other3; #<--will be assigned at ',,,,,'
,,,,,
$hash_ref->{$param}(ARGUMENTS); #<--my problem
}
But I can't think how to make ARGUMENTS section including variable number of arguments.
I considered each function to be defined in the funcRun code, but then I don't know the difference with if/else code. And I heard that passing 3 arguments values and accepting parameters in order from first, is not good from someone
Updated following a clarification. The very last code segment may be exactly what is asked for.
The design where a parameter decides what argument set to use from a list generated at runtime is what is giving you trouble; it's complicated. Not knowing about the actual problem I don't know what else to offer though (other than guesses). Perhaps clarify the use of this?
Having said that, one way to complete what you want is to store a specification of what arguments go with a function along with the function name in the hashref; another would be to have a separate structure with argument sets for each parameter.
For example
use warnings;
use strict;
use feature 'say';
my $dispatch = {
'a' => { name => \&funcA, lastidx => 0 },
'b' => { name => \&funcB, lastidx => 1 },
'c' => { name => \&funcC, lastidx => 2 }
};
sub funcRun {
my ($param) = #_;
my #args = qw(one two three);
my $func = $dispatch->{$param}{name};
my $lastidx = $dispatch->{$param}{lastidx};
$func->( #args[0..$lastidx] );
}
sub funcA { say "#_" }
sub funcB { say "#_" }
sub funcC { say "#_" }
funcRun($_) for qw(a b c);
Prints
one
one two
one two three
If you really need to pick arguments positionally from a list then use an array.
However, I suggest that you clarify what this is for so that we can offer a simpler design.
Following an explanation in a comment, a property I thought was accidental may in fact help.
If the function funcA indeed takes only the first argument, funcB the first two and funcC all three (from a list built at runtime), then you can nicely pass all to all of them
$func->( #args );
sub funcA {
my ($A) = #_; # arguments other than the first are discarded
...
}
Each function takes what it needs and the rest of the arguments are discarded.
Further, if functions in any way know which of a given list of arguments to take then again you can simply pass all of them. Then they can pick their arguments either positionally
sub funcB {
my ($A, undef, $B) = #_; # if it needs first and third
...
}
or by a named key
# Work out what arguments are for which function
my $args = { for_A => ..., for_B => ..., for_C => ... };
...
$func->( $args );
sub funcA {
my ($args) = #_
my $A = $args->{for_A};
...
}
where now arguments need be stored in a hash.
Finally and best, this can all be worked out ahead of the call
my $dispatch = { a => \&funcA, b => \&funcB, c => \&funcC };
sub funcRun {
my ($param) = #_;
# Work out arguments for functions
my $args = { a => ..., b => ..., c => ... };
$dispatch->{$param}->( $args->{$param} );
}
# subs funcA, funcB, funcC are the same
funcRun($_) for qw(a b c);
what requires minimal changes to your code (just store arguments in a hash).
Here neither the functions nor the dispatch table need knowledge of the possible argument lists, what is all resolved in funcRun. This avoids entangling functions with outside code.
Your problem stems from the fact that you're passing in a selection of values from arbitrary, unrelated variables. The solution, therefore, is to put all the data you might want to pass to you subroutines in a single data structure and define a mechanism for extracting the correct data for each call. You already have a solution which uses an array for this, but I think it's slightly easier to understand in a hash.
#!/usr/bin/perl
use strict;
use warnings;
use feature 'say';
sub funcA{
my ($A) = #_;
say $A;
}
sub funcB{
my ($A, $B) = #_;
say "$A / $B";
}
sub funcC{
my ($A, $B, $C) = #_;
say "$A / $B / $C";
}
my $hash_ref = {
'a' => { func => \&funcA, args => [ qw[ other1 ] ] },
'b' => { func => \&funcB, args => [ qw[ other1 other2 ] ] },
'c' => { func => \&funcC, args => [ qw[ other1 other2 other3 ] ] },
};
sub funcRun{
my ($param) = #_;
my %args = (
other1 => 'foo',
other2 => 'bar',
other3 => 'baz',
);
# $hash_ref->{$param}{args} is an array reference containing
# the names of the arguments you need.
# #{ ... } turns that array reference into an array.
# #args{ ... } uses that array to look up those keys in the
# %args hash (this is called a hash slice)
$hash_ref->{$param}{func}(#args{ #{ $hash_ref->{$param}{args} } });
}
funcRun($_) for qw[a b c];
But, to be honest, having stored your data in a hash, it's only a small step to passing the whole hash into every subroutine and letting them determine which data they want to use. Or even turning your hash into an object.

Changing writer prefix when (is => “rwp”)

If I want to change write protected attribute ie.
use Moops;
class foo {
has attr => (is => "rwp");
}
one have to use _set_attr().
Is it possible to change that to _attr() without using explicit writer?
Tried use MooseX::::AttributeShortcuts -writer_prefix => 'prefix'; but it did not work.
No, you need to do that yourself by setting the writer.
TLDR: At the bottom is a monkey-patch to do it anyway.
The Moops docs say (emphasys mine):
Moops uses MooseX::MungeHas in your classes so that the has keyword
supports some Moo-specific features, even when you're using Moose or
Mouse. Specifically, it supports is => 'rwp', is => 'lazy', builder =>
1, clearer => 1, predicate => 1, and trigger => 1.
Now let's go look at Moo. In the has section of the doc, it says (emphasys mine):
rwp stands for "read-write protected" and generates a reader like ro,
but also sets writer to _set_${attribute_name} for attributes that are
designed to be written from inside of the class, but read-only from
outside. This feature comes from MooseX::AttributeShortcuts.
Ok, on to MooseX::AttributeShortcuts:
Specifying is => 'rwp' will cause the following options to be set:
is => 'ro'
writer => "_set_$name"
However, this is just where it was inspired. It is actually implemented in Moo in Method::Generate::Accessor1.
} elsif ($is eq 'rwp') {
$spec->{reader} = $name unless exists $spec->{reader};
$spec->{writer} = "_set_${name}" unless exists $spec->{writer};
} elsif ($is ne 'bare') {
And even more actually, that is also not where it is done in Moops. In fact, that happens in MooseX::MungeHas, which Moops uses, but only if the caller is not Moo:
push #code, ' if ($_{is} eq q(rwp)) {';
push #code, ' $_{is} = "ro";';
push #code, ' $_{writer} = "_set_$_" unless exists($_{writer});';
push #code, ' }';
Looks pretty clear. It's in generated code. The below solution might work if it uses only Moo, but I don't know how to force that.
You are indeed able to change that in Moo by hooking into Moo's Method::Generate::Accessor using Class::Method::Modifiers and adding a bit of logic in an around modifier to generate_method. This does not work works for Moops as long as there is no Moose-stuff involved.
use Moops;
BEGIN {
require Method::Generate::Accessor; # so it's in %INC;
require Class::Method::Modifiers;
Class::Method::Modifiers::around( 'Method::Generate::Accessor::generate_method' => sub {
my $orig = shift;
# 0 1 2 3 4
# my ($self, $into, $name, $spec, $quote_opts) = #_;
if ($_[3]->{is} eq 'rwp') {
$_[3]->{writer} = "_explicitly_set_$_[2]" unless exists $_[3]->{reader};
}
$orig->(#_);
});
}
class Foo {
has attr => ( is => "rwp" );
}
use Data::Printer;
my $foo = Foo->new( attr => 1 );
p $foo;
Output:
Foo {
Parents Moo::Object
public methods (2) : attr, new
private methods (1) : _explicitly_set_attr
internals: {
attr 1
}
}
1) I found that using grep.cpan.me.

Perl - how to create function that accepts various data types

In some perl functions I want be able to work with various types of arguments and of course treat them differently. Now I am using for this ref function and execute appropriate part of code based on ref result, e.g.
sub method_that_accept_various_data_types(){
if (ref $_[0] eq "ARRAY"){
# ...
}
elsif (ref $_[0] eq "SCALAR"){
# ...
}
elsif (ref $_[0] eq "HASH"){
# ...
}
}
Is there some elegant way by which I can say that all my functions should follow this pattern or I have to use mentioned code at the beginning of all my subroutines? I am writing procedural code and I thing something similar is polymorphism and inheritance in OOP but I am newbie in this area.
Edit
All answers needs to append the code to all newly created function. I am asking if there is some generic way of doing this for every function defined from now without the need for adding code to new function.
You can also use hash of functions/dispatch table, but it is basically the same approach,
sub method_that_accept_various_data_types {
my $ref = ref($_[0]);
my $func = {
ARRAY => sub {
print "$ref\n";
},
SCALAR => sub {
print "$ref\n";
},
HASH => sub {
print "$ref\n";
},
}->{$ref} or return;
$func->(#_);
}
You could use the switch statement from the Switch module
use Switch;
sub polymorph_function {
my ($arg1, $arg2, ...) = #_;
switch (ref $arg1) {
case 'ARRAY' { ... }
case 'HASH' { ... }
...
}
}
I'm adding this based on Сухой27's example as an additional answer because I'd personally consider it bad code. But if you prefer short code you might like it:
sub polymorph_function {
({
ARRAY => sub { ... },
HASH => sub { ... },
...
}->{ref $_[0]} || return)->(#_);
}
It's basically the same, except that there are no temporary variables. It creates an anonymous hash and its reference is directly dereferenced and the appropriate key selected based on ref $_[0] (type of the 1st argument). The resulting coderef to one of the subs is then called immediately with all arguments to the original sub.
I just thought about ways to move much of the code to a central place.
sub polymorph_function {
poly \#_, (
ARRAY => sub { ... },
HASH => sub { ... },
...
);
}
sub poly {
my ($args, %subs) = #_;
my $sub = $subs{ref $args->[0]} or return;
$sub->( #$args );
}

How to append some logic before a function using Test::MockModule?

This is the mock module I'm using:
http://metacpan.org/pod/Test::MockModule
How to mock sub a to sub b,
where sub b just does something else before call sub a?
sub b {
#do something else
a(#_);
}
You can grab the un-mocked method with can ( UNIVERSAL::can ). After that you can either goto it or just use the ampersand calling style to pass the same arguments. That's what I did below.
my $old_a = Package::To::Be::Mocked->can( 'a' );
$pkg->mock( a => sub {
# do some stuff
&$old_a;
});
This of course assumes that your sub isn't AUTOLOAD or generated through AUTOLOAD without redefining can. (I learned years back that if you're going to mess with AUTOLOAD, it's probably best to do the work in can.)
You could also create your own utility that does this automatically, by invading modifying the Test::MockModule's namespace.
{ package Test::MockModule;
sub modify {
my ( $self, $name, $modfunc ) = #_;
my $mock_class = $self->get_package();
my $old_meth = $mock_class->can( $name );
croak( "Method $name not defined for $mock_class!" ) unless $old_meth;
return $self->mock( $name => $modfunc->( $old_meth ));
}
}
And you could call it like so:
$mock->modify( a => sub {
my $old_a = shift;
return sub {
my ( $self ) = #_;
# my stuff and I can mess with $self
local $Carp::CarpLevel += 1;
my #returns = &$old_a;
# do stuff with returns
return #returns;
};
});

How can I redefine Perl class methods?

The question "How can I monkey-patch an instance method in Perl?" got me thinking. Can I dynamically redefine Perl methods? Say I have a class like this one:
package MyClass;
sub new {
my $class = shift;
my $val = shift;
my $self = { val=> $val};
bless($self, $class);
return $self;
};
sub get_val {
my $self = shift;
return $self->{val}+10;
}
1;
And let's say that adding two numbers is really expensive.
I'd like to modify the class so that $val+10 is only computed the first time I call the method on that object. Subsequent calls to the method would return a cached value.
I could easily modify the method to include caching, but:
I have a bunch of methods like this.
I'd rather not dirty up this method.
What I really want to do is specify a list of methods that I know always return the same value for a given instance. I then want to take this list and pass it to a function to add caching support to those methods
Is there an effective way to accomplish this?
Follow up. The code below works, but because use strict doesn't allow references by string I'm not 100% where I want to be.
sub myfn {
printf("computing\n");
return 10;
}
sub cache_fn {
my $fnref = shift;
my $orig = $fnref;
my $cacheval;
return sub {
if (defined($cacheval)) { return $cacheval; }
$cacheval = &$orig();
return $cacheval;
}
}
*{myfn} = cache_fn(\&myfn);
How do I modify to just do this?:
cache_fn(&myfn);
You can overwrite methods like get_val from another package like this:
*{MyClass::get_val} = sub { return $some_cached_value };
If you have a list of method names, you could do something like this:
my #methods = qw/ foo bar get_val /;
foreach my $meth ( #methods ) {
my $method_name = 'MyClass::' . $meth;
no strict 'refs';
*{$method_name} = sub { return $some_cached_value };
}
Is that what you imagine?
I write about several different things you might want to do in the "Dynamic Subroutines" chapter of Mastering Perl. Depending on what you are doing, you might want to wrap the subroutine, or redefine it, or subclass, or all sorts of other things.
Perl's a dynamic language, so there is a lot of black magic that you can do. Using it wisely is the trick.
I've never tried it with methods, but Memoize may be what you're looking for. But be sure to read the caveats.
Not useful in your case but had your class been written in Moose then you can dynamically override methods using its Class::MOP underpinnings....
{
package MyClass;
use Moose;
has 'val' => ( is => 'rw' );
sub get_val {
my $self = shift;
return $self->val + 10;
}
}
my $A = MyClass->new( val => 100 );
say 'A: before: ', $A->get_val;
$A->meta->remove_method( 'get_val' );
$A->meta->add_method( 'get_val', sub { $_[0]->val } );
say 'A: after: ', $A->get_val;
my $B = MyClass->new( val => 100 );
say 'B: after: ', $B->get_val;
# gives u...
# => A: before: 110
# => A: after: 100
# => B: after: 100
How do I modify to just do this?:
cache_fn(\&myfn);
Well based on your current example you could do something like this....
sub cache_fn2 {
my $fn_name = shift;
no strict 'refs';
no warnings 'redefine';
my $cache_value = &{ $fn_name };
*{ $fn_name } = sub { $cache_value };
}
cache_fn2( 'myfn' );
However looking at this example I can't help thinking that you could use Memoize instead?