I have a dispatch table that I wish to initialize only once, and is only intended to be used by one function. I was hoping to move the dispatch table outside of the subroutine and into the same anonymous block, but since the dispatch table uses closures to call methods for the object passed into the function, moving the table outside the function separates it from access to the object. What other options do I have for this dispatch table?
I'm using Perl 5.8, so unfortunately I'm unable to use state variables.
sub foo {
my ($self, $var) = #_;
my %funcs = (
a => sub { $self->_a() },
b => sub { $self->_b() },
...
);
return $funcs{$var}->();
}
Your functions in the dispatch table are closures over $self. If you pass in the $self as a parameter, you can get around that. Note that state variables are not true closures over $self, and would require an explicit parameter as well.
my %funcs = (
a => sub { shift->_a }, # these are like anonymous methods
b => sub { shift->_b },
);
sub foo {
my ($self, $var) = #_;
my $meth = $funcs{$var} || die "There is no entry $var";
return $self->$meth(); # sugary syntax
}
Here is a demonstration why state would be a bad idea:
use 5.010;
package Foo;
sub new { my ($c, $v) = #_; bless \$v, $c }
sub foo {
my ($self) = #_;
state $cb = sub { say $$self };
$cb->();
}
Foo->new($_)->foo for 1..3;
Output:
1
1
1
The inner sub is a closure, but the initialization of $cb is only performed once. Thus the closed over $self is the first one.
Related
I'm writing a subclass that encapsulates multiple objects of the parent class so I can call functions sort-of like a vector, something like this:
package OriginalClass;
sub new { return bless {bar => 123}, 'OriginalClass' }
sub foo { return shift->{bar}; }
1;
package NewClass;
use parent OriginalClass;
# Return a blessed arrayref of "OriginalClass" objects.
# new() would be called NewClass->new(OriginalClass->new(), ...)
sub new {
my $class = shift;
return bless \#_, 'NewClass';
}
# Vectorized foo(), returns a list of SUPER::foo() results:
sub foo
{
my $self = shift;
my #ret;
push #ret, $_->SUPER::foo() foreach #$self;
return #ret;
}
1;
I don't want to write a new vectorized function in NewClass for each function in OriginalClass, particularly for when OriginalClass adds new functions to be maintained (vectorized) in NewClass.
Question:
As I understand AUTOLOAD is slow, so is there a way to vectorize calls OriginalClass via something like NewClass without AUTOLOAD?
As I understand AUTOLOAD is slow
If AUTOLOAD generates the missing sub, then only the first call is "slow" since subsequent calls of the same method don't result in AUTOLOAD being called at all.
package NewClass;
use strict;
use warnings;
sub new {
my $class = shift;
return bless( \#_, $class );
}
sub AUTOLOAD {
my $method_name = our $AUTOLOAD =~ s/^.*:://sr;
my $method = sub {
my $self = shift;
return map { $_->$method_name( #_ ) } #$self;
};
{
no strict 'refs';
*$method_name = $method;
}
goto &$method;
}
1
Note that I didn't use parent and SUPER::. This isn't an inheritance relationship. And it would prevent AUTOLOAD from getting called since AUTOLOAD is only called when a method doesn't exist.
You can use Sub::Name to "name the sub" for better diagnostics.
use Sub::Name qw( subname );
my $method = subname $method_name => sub { ... };
But yes, AUTOLOAD can be avoided here, as long as you can get a list of the method names in advance.
package NewClass;
use strict;
use warnings;
sub new {
my $class = shift;
return bless( \#_, $class );
}
for my $method_name (qw( foo ... )) {
my $method = sub {
my $self = shift;
return map { $_->$method_name( #_ ) } #$self;
};
no strict 'refs';
*$method_name = $method;
}
1
The above uses a hardcoded list, but more dynamic solutions are possible. For example, the list could be obtained from inspecting the contents of the OriginalClass namespace for subs (filtering out new and anything else inappropriate such as names starting with _).
Module https://metacpan.org/pod/Array::Delegate could be helpful : it delegates method calls to an array of objects.
Is there any way to achieve partial application in Perl?
Suppose, I want to do something like:
sub each_file($arr, $op) {
$op->($_) for #{$arr};
...
}
sub each_line($op, $file) {
...
}
each_file($arr, each_line($op));
I want to partially apply each_line() to only $op, so it'll become a new function can be passed to $each_file, how do I express this in idiomatic Perl?
You can do this in Perl with two approaches combined:
A function which returns a function reference
Closures
Example:
sub each_file {
my ($arr, $line_fn) = #_;
$line_fn->($_) for #{$arr};
...
}
sub each_line {
my ($op, $file) = #_;
...
}
sub make_line_processor {
my ( $op ) = #_;
# This is closed over $op, which effectively becomes
# a constant for the returned function
my $fn = sub {
return each_line( $op, #_ );
};
return $fn;
}
# To call it:
each_file( $arr, make_line_processor($op) );
This can be an even more useful technique in cases where you don't want $op directly, but some expensive-to-fetch derivation of it. In which case you would calculate the derived value just once (in the make_line_processor function) and close over that instead.
# given some $op as implied by your code snippet
each_file($arr, sub { each_line($op, shift) });
# shift op will be applied when anonymous sub { … } is called
(Your code snippet doesn't make it entirely clear what you intend $op to be when you make the call to each_line. It's usually better to present small working programs.)
You can roll this functionality up into a class. Then you can overload the subroutine dereference operator to make it look like your class is really a code reference.
package Partial;
use overload '&{}' => \&call;
sub new {
my $class = shift;
my $code = shift;
bless {code => $code, args => \#_}, $class;
}
sub call {
my ($self) = #_;
return sub{ $self->{code}->(#{$self->{args}}, #_) }
}
You can then use it like this:
sub printArgs {
print join ", ", #_;
print "\n";
}
my $partial = Partial->new(\&printArgs, 'foo', 'bar');
$partial->('baz', 'bat');
# prints foo, bar, baz, bat
How would I create my class such that some methods will exist in the instance only if certain values were passed to the constructor?
Perhaps a more generic way of asking is: How can I add a method to an existing class instance?
You can attach an anonymous sub to an object based on flags:
use strict;
use warnings;
package Object;
sub new {
my $class = shift;
my $self = bless {}, $class;
my %args = #_;
if ($args{method}) {
$self->{method} = sub { print "hello\n" }
}
return $self;
}
sub method {
my $self = shift;
if (not defined $self->{method}) {
warn "Not bound\n";
return;
}
$self->{method}->();
}
1;
to use:
use Object;
my $obj1 = Object->new(method=>1);
$obj1->method();
my $obj2 = Object->new();
$obj2->method();
You can extend this to a number of methods through the same interface.
You can use Moose to apply a role at runtime.
package My::Class;
use Moose;
has foo => ( isa => 'Str', is => 'ro', required => 1 );
sub BUILD {
my $self = shift;
if ($self->foo eq 'bar') {
My::Class::Role->meta->apply($self);
}
}
no Moose;
package My::Class::Role;
use Moose::Role;
sub frobnicate {
my $self = shift;
print "Frobnicated!\n";
}
no Moose;
my $something = My::Class->new( foo => 'bar' );
print $something, "\n";
$something->frobnicate;
my $something_else = My::Class->new( foo => 'baz' );
print $something_else, "\n";
$something_else->frobnicate;
Gives:
Moose::Meta::Class::__ANON__::SERIAL::1=HASH(0x2fd5a10)
Frobnicated!
My::Class=HASH(0x2fd2c08)
Can't locate object method "frobnicate" via package "My::Class" at testmoose.pl line 32.
use AUTOLOAD to define the function. As a example method foo is called if $self->{foo} exists
sub AUTOLOAD {
my $methodname = $AUTOLOAD;
if ($methodname eq "foo" && exists($_[0]->{foo})){
goto &fooimplementationsub;
}
return;
}
An alternative technique is to use globs to define a new method at runtime
*PACKAGE::method = sub {
#code here
};
This has the disadvantage that the method is now visible to all instances of the class so is not quite what you want.
A third and possibly more risky/inefficient method is to use string eval
eval <<EOF
sub foo {
#code here
};
EOF
Again this has the disadvantage that the method is now visible to all instances of the class so is not quite what you want.
Methods are just subroutines in a package, and a package is just a hash holding typeglobs. And hashes can be modified at runtime.
So you could, in theory, add or remove methods given values in a constructor.
package WeirdClass;
sub new {
my ($class, $name, $code) = #_;
if ($name) {
no strict;
*{__PACKAGE__ . "::$name"} = $code;
}
bless {} => $class;
}
And then use it like:
my $object = WeirdClass->new(foo => sub {say "foo"});
$object->foo(); # prints "foo\n";
However, this method is available for all objects of that class:
my $another_object = WeirdClass->new();
$another_object->foo; # works too.
Using autoload, one can mock arbitrary methods:
package BetterClass;
sub new {
my ($class, %args) = #_;
bless \%args => $class;
}
# destructor will be called at cleanup, catch with empty implementation
sub DESTROY {};
sub AUTOLOAD {
my $self = shift;
(my $method = our $AUTOLOAD) =~ s/.*://; # $AUTOLOAD is like "BetterClass::foo"
# check if method is allowed
die "forbidden method $method" unless $self->{can}{$method};
# mock implementations
given ($method) {
say "foo" when "foo";
say "bar" when "bar";
when ("add") {
my ($x, $y) = #_;
return $x + $y;
}
default { die "unknown method $method" }
}
}
Then:
my $o = BetterClass->new(can => { foo => 1, bar => 0});
$o->foo;
my $p = BetterClass->new(can => {bar => 1, add => 1});
$p->bar;
say $p->add(5, 6);
Of course, these techniques can be combined freely.
Edit: can()
To make the AUTOLOAD work with can, the protected methods should be moved into a data structure:
my %methods;
BEGIN {
%methods = (
foo => sub {say "foo"},
bar => sub {say "bar"},
add => sub {
my ($self, $x, $y) = #_;
$x + $y;
},
);
}
Then override the can method:
# save a reference to the origional `can` before we override
my $orig_can;
BEGIN{ $orig_can = __PACKAGE__->can("can") }
sub can {
my ($self, $meth) = #_;
# check if we have a special method
my $code = $methods{$meth} if ref $self and $self->{can}{$meth};
return $code if $code;
# check if we have a normal method
return $self->$orig_can($meth);
}
And AUTOLOAD would change to
my ($self) = #_; # do not `shift`
(my $method = our $AUTOLOAD) =~ s/.*://;
my $code = $self->can($method) or die "unknown method $method";
goto &$code; # special goto. This is a AUTOLOAD idiom, and avoids extra call stack frames
Don't do too much magic. I've gotten away from AUTOLOAD because it causes maintenance issues where mysterious methods suddenly appear and disappear.
One way to handle what you want is to define all the methods you need, and if a particular object is of the wrong type, simply cause that method to croak:
sub Foo {
my $self = shift;
my $parameter = shift;
if ( $self->Class_type ne "Foo" ) {
croak qq(Invalid method 'Foo' on object #{[ref $self]});
}
print "here be dragons\";
return "Method 'Foo' successfully called";
}
The above will not allow method Foo to be called unless the class type is Foo.
If your objects won't change (or you don't want them to change) once an object is created, you can define that object as a sub-class.
Before you bless a newly created object, check that special value and decide whether or not you need to create a specific sub-class instead.
package My_class;
sub new {
my $class = shift;
my $class_type = shift;
my $self = shift;
if ( $class_type eq "Foo" ) {
bless $self, "My_class::Foo";
}
else {
bless $self, $class;
}
package My_class::Foo;
use base qw(My_class);
sub Foo {
my $self = shift;
return "Foo Method successfully called!";
}
Notice that my class My_class::Foo is a sub-class of My_class via the use base pragma. That means all methods for My_class are valid with objects of My_class::Foo. However, only objects of My_class::Foo can call the Foo method.
When I create my object (via the new subroutine), I look at the $class_type parameter. If it's a type Foo, I bless the class as My_class::Foo.
Here's an example where I use sub-classes to do what you want.
Every object is a class type of Question. You can see my constructor on line 1129. I pass in a question type as one of the parameters to my constructor.
In line 1174 to 1176, I create my object, but then append the question type to the class, and then bless the question as that sub-class type. All of my subclasses are a type Question (see my use base qw(Question); below each package declaration. However, only questions of sub-class Question::Date and Question::Regex have a method Format. And, only objects of type Question::Words have a method Force.
Hope this helps.
None of the answers so far given actually handle the question actually asked.
Adding methods to an instance in Perl is not directly supported. Object instances are always instances of some class, and that class is the thing that actually has methods. You cannot add a method to a single instance of a class, without making that method also available on every other instance of the same class.
For your problem you have two basic solutions:
Provide the methods always, but test a flag to see whether the method should apply to the given instance or not. This is by far the simplest.
Bless each object into subclasses depending on the flags. Subclass the main class to provide those methods as appropriate.
If you truely want to add methods on individual instances, then what you'll have to do is arrange that every instance is a single instance of a newly-derived class for every object. This gets harder to arrange for, doubly-so if you want to avoid leaking memory and cleaning up the classes once the objects are DESTROYed. This would however allow truely per-instance methods.
Since it is highly unlikely you'll truely need this third option it is far better to go with one of the first.
Similar to this question about iterating over subroutine references, and as a result of answering this question about a OO dispatch table, I was wondering how to call a method reference inside a reference, without removing it first, or if it was even possible.
For example:
package Class::Foo;
use 5.012; #Yay autostrict!
use warnings;
# a basic constructor for illustration purposes....
sub new {
my $class = shift;
return bless {#_}, $class;
}
# some subroutines for flavor...
sub sub1 { say 'in sub 1'; return shift->{a} }
sub sub2 { say 'in sub 2'; return shift->{b} }
sub sub3 { say 'in sub 3'; return shift->{c} }
# and a way to dynamically load the tests we're running...
sub sublist {
my $self = shift;
return [
$self->can('sub1'),
$self->can('sub3'),
$self->can('sub2'),
];
}
package main;
sub get_index { ... } # details of how we get the index not important
my $instance = Class::Foo->new(a => 1, b => 2, c => 3);
my $subs = $instance->sublist();
my $index = get_index();
# <-- HERE
So, at HERE, we could do:
my $ref = $subs->[$index];
$instance->$ref();
but how would we do this, without removing the reference first?
Edit:
Changed code example so people don't get hung up on implementation details (sigh, tried my best). The important difference between this and the first link I gave was that the function should be invoked as a method, not as a straight subroutine.
Edit 2:
See the discussion in the linked comment about the technical details, and why the longer way (storing the subref to a variable, then calling it) is probably preferable.
As written, you can get away with
$tests->[$index]();
because the methods in your question aren't using $self.
You could pass $instance explicitly, but that's clunky. Better would be to simulate delegates with closures:
sub sublist {
my $self = shift;
my $sublist;
for (qw/ sub1 sub3 sub2 /) {
my $meth = $_;
push #$sublist => sub { $self->$meth() };
}
return $sublist;
}
If you prefer to be concise, use
sub sublist {
my $self = shift;
return [ map { my $meth = $_; sub { $self->$meth() } }
qw/ sub1 sub3 sub2 / ];
}
Calling one at random is still
$tests->[$index]();
but now the methods get invocants.
Update
Grabbing subrefs via can appears to be unnecessary complexity. If a runtime-determined list of names of methods to call will do, then you can simplify your code greatly:
sub sublist {
my $self = shift;
return [ qw/ sub1 sub3 sub2 / ];
}
Below, we call them all for testing purposes, but you can also see how to call only one:
foreach my $method (#$subs) {
my $x = $instance->$method();
say "$method returned $x";
}
Output:
in sub 1
sub1 returned 1
in sub 3
sub3 returned 3
in sub 2
sub2 returned 2
(Temporary placeholder here until/unless the original poster of the answer returns):
The trick is adding a dereference:
$instance->${\$sublist->[$index]}(#args);
thus you can also do:
$instance->${\$instance->sublist->[$index]}(#args);
otherwise it thinks it's a scalar to dereference. (eg, Not a SCALAR reference at script.pl, line XX).
I often find it useful to be able to schedule code to be executed upon leaving the current scope. In my previous life in TCL, a friend created a function we called defer.
It enabled code like:
set fp [open "x"]
defer("close $fp");
which was invoked when the current scope exited. The main benefit is that it's always invoked no matter how/where I leave scope.
So I implemented something similar in Perl but it seems there'd be an easier way. Comments critiques welcome.
The way I did it in Perl:
create a global, tied variable which holds an array of subs to be executed.
whenever I want to schedule a fn to be invoked on exit, I use local to change the array.
when I leave the current scope, Perl changes the global to the previous value
because the global is tied, I know when this value change happens and can invoke the subs in the list.
The actual code is below.
Is there a better way to do this? Seems this would be a commonly needed capability.
use strict;
package tiescalar;
sub TIESCALAR {
my $class = shift;
my $self = {};
bless $self, $class;
return $self;
}
sub FETCH {
my $self = shift;
return $self->{VAL};
}
sub STORE {
my $self = shift;
my $value = shift;
if (defined($self->{VAL}) && defined($value)) {
foreach my $s (#{$self->{VAL}}) { &$s; }
}
$self->{VAL} = $value;
}
1;
package main;
our $h;
tie($h, 'tiescalar');
$h = [];
printf "1\n";
printf "2\n";
sub main {
printf "3\n";
local $h = [sub{printf "9\n"}];
push(#$h, sub {printf "10\n";});
printf "4\n";
{
local $h = [sub {printf "8\n"; }];
mysub();
printf "7\n";
return;
}
}
sub mysub {
local $h = [sub {printf "6\n"; }];
print "5\n";
}
main();
printf "11\n";
Well, your specific case is already handled if you use lexical filehandles (as opposed to the old style bareword filehandles). For other cases, you could always use the DESTROY method of an object guaranteed to go to zero references when it goes out of scope:
#!/usr/bin/perl
use strict;
use warnings;
for my $i (1 .. 5) {
my $defer = Defer::Sub->new(sub { print "end\n" });
print "start\n$i\n";
}
package Defer::Sub;
use Carp;
sub new {
my $class = shift;
croak "$class requires a function to call\n" unless #_;
my $self = {
func => shift,
};
return bless $self, $class;
}
sub DESTROY {
my $self = shift;
$self->{func}();
}
ETA: I like brian's name better, Scope::OnExit is a much more descriptive name.
Instead of using tie for this, I think I'd just create an object. You can also avoid the local that way too.
{
my $defer = Scope::OnExit->new( #subs );
$defer->push( $other_sub ); # and pop, shift, etc
...
}
When the variable goes out of scope, you have a chance to do things in the DESTROY method.
Also, in the example you posted, you need to check that the values you store are code references, and it's probably a good idea to check that the VAL value is an array reference:
sub TIESCALAR { bless { VAL => [] }, $_[0] }
sub STORE {
my( $self, $value ) = #_;
carp "Can only store array references!" unless ref $value eq ref [];
foreach { #$value } {
carp "There should only be code refs in the array"
unless ref $_ eq ref sub {}
}
foreach ( #{ $self->{VAL}} ) { $_->() }
$self->{VAL} = $value;
}
You may want to try out B::Hooks::EndOfScope
I Believe this works:
use B::Hooks::EndOfScope;
sub foo {
on_scope_end {
$codehere;
};
$morecode
return 1; # scope end code executes.
}
foo();
I think you want something like Scope::Guard, but it can't be pushed. Hmmm.
Thanks.
Trivially,
sub OnLeavingScope::DESTROY { ${$_[0]}->() }
used like:
{
...
my $onleavingscope = bless \sub { ... }, 'OnLeavingScope';
my $onleavingscope2 = bless \\&whatever, 'OnLeavingScope';
...
}
(The extra level of having a reference to a reference to a sub is necessary only to work around an optimization (that's arguably a bug) when using a non-closure anonymous sub.)