How can I redefine Perl class methods? - perl

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?

Related

Can I inject a perl sub in a package?

I'd like to be able to "inject" methods in a class on the fly, similarly to what happens with Mojolicious helpers. Something like this:
my $s = SomeThing->new;
$s->helper(do_this => sub {
my $self = shift;
$foo = shift;
});
$s->do_this('bar');
I've made it some distance, but I would like the subs that get injected to be operating in the namespace of the class they get injected into, not in the main one. In other words this currently works as follows:
$s->do_this('bar');
print 'in main: ', $foo;
this prints "bar" - and I'd like it not to, while I'd like this
print 'in SomeThing: ', $SomeThing::foo;
to print "bar" instead
while this works but seems clunky to me
$s->helper(do_this => sub {
my $self = shift;
${(ref $self) . '::foo'} = shift;
});
$s->do_this('foo');
print 'in SomeThing: ', $SomeThing::foo; # now this prints "foo"
The package where all this happens looks like this:
package SomeThing {
use Mojo::Base -base;
use Carp;
sub helper {
my $self = shift;
my $name = shift || croak "The helper name is required";
my $sub = shift || sub {};
my $namespace = __PACKAGE__;
no strict 'refs';
{
*{"$namespace\::$name"} = $sub
}
}
};
Is there a way to do this? I suspect I'd be messing up strictness real bad - but I kind of don't want to give up just yet (and it'd be a nice trick to learn).
You are asking to change the package associated with an already-compiled anon sub for the purpose of variable lookups. I don't know if that's possible.
Even if it was possible, it's not something you want to do because your code still wouldn't work. You'd have to add use vars qw( foo ); to the file in which the sub { } literal is found. And that's in addition to using our $foo; or use vars qw( $foo ); in Something.pm if you accessed it there.
That's pretty magical and messy. And it's easily avoided by using accessors. Simple replace
$s->helper(
do_this => sub {
my $self = shift;
$foo = shift;
},
);
with
$s->helper(
do_this => sub {
my $self = shift;
$self->foo(shift);
},
);
If you also need to add the accessor, you can use the following:
$s->helper(
foo => sub {
shift;
state $foo;
$foo = shift if #_;
$foo
},
do_this => sub {
my $self = shift;
$self->foo(shift);
},
);
As an aside, monkey_patch from Mojo::Util can be used as a replacement for helper. (Credit to #brian d foy for bringing it up.) It does the same thing, but it has the two added benefits:
You don't need to support it.
It sets the name of the anon sub so that stack traces use a meaningful name instead of __ANON__.
Switching to monkey_patch doesn't address your problem, but I do recommend using it (or similar) in addition to the change of approach I mentioned above.
use Mojo::Util qw( );
sub helper { shift; Mojo::Util::monkey_patch(__PACKAGE__, #_); }
Consider roles.
# role module
package SomeThing::Role::Foo;
use Role::Tiny;
sub foo { 42 }
1;
# user
use strict;
use warnings;
use SomeThing;
use With::Roles;
my $something_with_foo = SomeThing->with::roles('+Foo');
# new subclass of SomeThing, doesn't affect other usage of SomeThing
my $obj = $something_with_foo->new;
# can also dynamically apply to an existing object
my $obj = SomeThing->new->with::roles('+Foo');
print $obj->foo;

perl -- call method from hash

I have a hash table of methods:
my %makefileMacroSimplifiers = (
"or" => \&makefileSimplifyOr,
"and" => \&makefileSimplifyAnd,
"strip" => \&makefileSimplifyStrip,
);
sub makefileSimplifyStrip {
my $self = shift;
my $prefix = shift;
my $paramsRef = shift;
...
}
where each method requires $self. What I have is:
$makefileMacroSimplifiers{$macroName}->($self, $macroName.$ws1, \#parms);
This seems to work, but it seems a bit odd to me to explicitly pass in $self to a method. Is there a better way of doing this, or is this considered a normal coding practice? (I didn't find any better ways to do this on the web, but I thought I would ask in case I'm not using the right search criteria).
You can also call a code ref on an object. That way the thing on the left will be passed in.
my $coderef = sub { ... };
$self->$coderef(#args);
Using a hash element does not work like this.
$self->$dispatch{foo}(1, 2, 3); # BOOM
This is a syntax error. So you need to grab the code reference first. Borodin also explains this above in their comment.
my %dispatch = (
foo => sub { print "#_" },
);
require HTTP::Request;
my $obj = HTTP::Request->new;
my $method = $dispatch{foo};
$obj->$method(1, 2, 3);
I've used HTTP::Request here as an example of an arbitrary class/object.

Hiding a tie call from the user in Perl

How can I hide a "tie" call from the user so calling an accessor will implicitly do it for them?
I want to do this, because I have a data structure that can be accessed by the user, but values stored in this structure can be modified without the user's knowledge.
If an attribute in the data structure changes, I want any variables referencing that attribute modified as well so the user will always be using fresh data. Since the user will always want fresh data, it's simpler and more intuitive if the user doesn't even need to know it's happening.
This is what I have so far... it doesn't seem to work though, the output is:
hello
hello
What I want is:
hello
goodbye
Code:
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
{
package File;
use Moose;
has '_text' => (is => 'rw', isa => 'Str', required => 1);
sub text {
my ($self) = #_;
tie my $text, 'FileText', $self;
return $text;
}
}
{
package FileText;
use Tie::Scalar;
sub TIESCALAR {
my ($class, $obj) = #_;
return bless \$obj, $class;
}
sub FETCH {
my ($self) = #_;
return $$self->_text();
}
sub STORE {
die "READ ONLY";
}
}
my $file = 'File'->new('_text' => 'hello');
my $text = $file->text();
say $text;
$file->_text('goodbye');
say $text;
I would not recommend doing this. You're introducing "action at a distance" which leads to some very difficult to catch bugs. The user thinks they're getting a string. A lexical string can only be altered by changing it directly and obviously. It has to be altered in place or obviously passed into a function or a reference attached to something.
my $text = $file->text;
say $text; # let's say it's 'foo'
...do some stuff...
$file->text('bar');
...do some more stuff...
# I should be able to safely assume it will still be 'foo'
say $text;
That block of code is easy to understand because all the things which could affect $text are immediately visible. This is what lexical context is all about, isolating what can change a variable.
By returning a thing which can change at any time, you've quietly broken this assumption. There's no indication to the user that assumption has been broken. When they go to print $text and get bar it is non-obvious what changed $text. Anything in the whole program could change $text. That small block of code is now infinitely more complicated.
Another way to look at it is this: scalar variables in Perl have a defined interface. Part of that interface says how they can be changed. You are breaking this interface and lying to the user. This is how overloaded/tied variables are typically abused.
Whatever problem you're trying to solve, you're solving it by adding more problems, by making the code more complex and difficult to understand. I would step back and ask what problem you're trying to solve with tying.
What I would do instead is to just return a scalar reference. This alerts the user that it can be changed out from under them at any time. No magic to cover up a very important piece of information.
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
{
package File;
use Moose;
has 'text_ref' => (
is => 'rw',
isa => 'Ref',
default => sub {
return \("");
}
);
sub BUILDARGS {
my $class = shift;
my %args = #_;
# "Cast" a scalar to a scalar ref.
if( defined $args{text} ) {
$args{text_ref} = \(delete $args{text});
}
return \%args;
}
sub text {
my $self = shift;
if( #_ ) {
# Change the existing text object.
${$self->text_ref} = shift;
return;
}
else {
return $self->text_ref;
}
}
}
my $file = 'File'->new('text' => 'hello');
my $text = $file->text();
say $$text;
$file->text('goodbye');
say $$text;
That said, here's how you do what you want.
I would recommend against using tie. It is very slow, considerably slower than a method call, buggy and quirky. One of its quirks is that the tied nature is attached to the variable itself, not the referenced data. That means you can't return a tied variable.
Instead, I would recommend using an overloaded object to store your changing text.
{
package ChangingText;
# Moose wants class types to be in a .pm file. We have to explciitly
# tell it this is a class type.
use Moose::Util::TypeConstraints qw(class_type);
class_type('ChangingText');
use overload
'""' => sub {
my $self = shift;
return $$self;
},
fallback => 1;
sub new {
my $class = shift;
my $text = shift;
return bless \$text, $class;
}
sub set_text {
my $self = shift;
my $new_text = shift;
$$self = $new_text;
return;
}
}
Overloaded objects have their own caveats, mostly due to code which expects strings writing things like if !ref $arg, but they are easier to deal with than the deep tie bugs.
To make this transparent, store the ChangingText object in the File object and then put a hand made text accessor around it to handle plain strings. The accessor makes sure to reuse the same ChangingText object.
To complete the illusion, BUILDARGS is used to change plain text initialization arguments into a ChangingText object.
{
package File;
use Moose;
has 'text_obj' => (
is => 'rw',
isa => 'ChangingText',
default => sub {
return ChangingText->new;
}
);
sub BUILDARGS {
my $class = shift;
my %args = #_;
# "Cast" plain text into a text object
if( defined $args{text} ) {
$args{text_obj} = ChangingText->new(delete $args{text});
}
return \%args;
}
sub text {
my $self = shift;
if( #_ ) {
# Change the existing text object.
$self->text_obj->set_text(shift);
return;
}
else {
return $self->text_obj;
}
}
}
Then it works transparently.
my $file = File->new('text' => 'hello');
my $text = $file->text();
say $text; # hello
$file->text('goodbye');
say $text; # goodbye
return $text just returns the value of the variable, not the variable itself. You can return a reference to it, though:
sub text {
my ($self) = #_;
tie my $text, 'FileText', $self;
return \$text;
}
You then have to use $$text to dereference it:
my $file = 'File'->new('_text' => 'hello');
my $text = $file->text();
say $$text;
$file->_text('goodbye');
say $$text;

Is there a convenience for safe dereferencing in Perl?

So perl5porters is discussing to add a safe dereferencing operator, to allow stuff like
$ceo_car_color = $company->ceo->car->color
if defined $company
and defined $company->ceo
and defined $company->ceo->car;
to be shortened to e.g.
$ceo_car_color = $company->>ceo->>car->>color;
where $foo->>bar means defined $foo ? $foo->bar : undef.
The question: Is there some module or unobstrusive hack that gets me this operator, or similar behavior with a visually pleasing syntax?
For your enjoyment, I'll list ideas that I was able to come up with.
A multiple derefencing method (looks ugly).
sub multicall {
my $instance = shift // return undef;
for my $method (#_) {
$instance = $instance->$method() // return undef;
}
return $instance;
}
$ceo_car_color = multicall($company, qw(ceo car color));
A wrapper that turns undef into a proxy object (looks even uglier) which returns undef from all function calls.
{ package Safe; sub AUTOLOAD { return undef } }
sub safe { (shift) // bless {}, 'Safe' }
$ceo_car_color = safe(safe(safe($company)->ceo)->car)->color;
Since I have access to the implementations of ceo(), car() and color(), I thought about returning the safe proxy directly from these methods, but then existing code might break:
my $ceo = $company->ceo;
my $car = $ceo->car if defined $ceo; # defined() breaks
Unfortunately, I don't see anything in perldoc overload about overloading the meaning of defined and // in my safe proxy.
Maybe this is not the most useful solution, but it's one more WTDI (a variant of nr. 1) and it's a non-trivial use-case for List::Util's reduce, which are very rare. ;)
Code
#!/usr/bin/env perl
use strict;
use warnings;
use feature 'say';
use List::Util 'reduce';
my $answer = 42;
sub new { bless \$answer }
sub foo { return shift } # just chaining
sub bar { return undef } # break the chain
sub baz { return ${shift()} } # return the answer
sub multicall { reduce { our ($a, $b); $a and $a = $a->$b } #_ }
my $obj = main->new();
say $obj->multicall(qw(foo foo baz)) // 'undef!';
say $obj->multicall(qw(foo bar baz)) // 'undef!';
Output
42
undef!
Note:
Of course it should be
return unless defined $a;
$a = $a->$b;
instead of the shorter $a and $a = $a->$b from above to work correctly with defined but false values, but my point here is to use reduce.
You can use eval:
$ceo_car_color = eval { $company->ceo->car->color };
But it will of course catch any errors, not just calling a method on an undef.

Sharing variables between multiple submodules

I have a module foo that has extended sub-modules bar and baz. I want bar and baz to modify the same set of hashes that are in foo.
Right now I have something like:
my $foo = new foo;
my $bar = new foo::bar( $foo );
$bar->doStuff();
$bar->printSelf();
my $baz = new foo::bar( $foo );
$baz->doOtherStuff();
$baz->printSelf();
Inside one of the sub-modules the constructor looks like:
sub new {
my $class = shift;
my $self = shift;
--stuff--
bless $self, $class;
return $self;
}
Please don't laugh too hard. Is there a way I can do this without passing in $foo?
Thanks for reading. :)
I prefer to share things through methods. That way, no one has to know anything about the data structures or variables names (although you do need to know the method name):
{
package SomeParent;
my %hash1 = ();
my %hash2 = ();
sub get_hash1 { \%hash1 }
sub get_hash2 { \%hash2 }
sub set_hash1_value { ... }
sub set_hash1_value { ... }
}
Since SomeParent provides the interface to get at the private data structures, that's what you use in SomeChild:
{
package SomeChild;
use parent 'SomeParent';
sub some_method {
my $self = shift;
my $hash = $self->get_hash1;
...;
}
sub some_other_method {
my $self = shift;
$self->set_hash2_value( 'foo', 'bar' );
}
}
Your question is not very clear nor there is any code with hashes. But if you need module variables modified, you can use fully qualified name:
package Foo; # don't use lowercase named, they are reserved for pragmas
our %hash1 = ();
our %hash2 = ();
package Foo::Bar;
use Data::Dump qw(dd);
sub do_stuff {
$Foo::hash1{new_item} = 'thing';
}
sub do_other_stuff {
dd \%Foo::hash1;
}
package main;
Foo::Bar->do_stuff();
Foo::Bar->do_other_stuff();
But if you need to modify instance variables, you need to have reference to this instance. I see some strategies that would work:
inherit from Foo, so the hashes will be in instance of Foo::Bar
pass reference to Foo in constructor and store it as property in Foo::Bar
pass Foo reference as parameter to method
Proper solution depends on what you are trying to do and how you going to use it.