In Perl, can you subclass and hook all parent-class functions without `AUTOLOAD`? - perl

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.

Related

Can I associate a CODE reference with a HASH reference that contains it in Perl?

I want to create a hash reference with code references mapped to scalars (strings) as its members.
So far I have a map reference that looks something like this:
my $object;
$object = {
'code1' => sub {
print $_[0];
},
'code2' => sub {
return 'Hello, World!';
},
'code3' => sub {
$object->{code1}->($object->{code2}->());
}
};
$object->{code3}->();
I would like to be able to "bless" the 'code3' reference in $object with $object, so I can do something like:
my $object;
$object = {
'code1' => sub {
print $_[0];
},
'code2' => sub {
return 'Hello, World!';
},
'code3' => sub {
$self = shift;
$self->{code1}->($self->{code2}->());
}
};
$object->{code3}->();
However, bless only works with packages, rather than hash tables.
Is there a way to do this in Perl 5 version 22?
Note: now that I think of it, it's better to pass $object to the method explicitly, as it solves JavaScript's "this" problem. I am just too used to Java's "this" which makes sense in Java where everything is a class and therefore all methods have a "this", but in scripting, it really helps to know if the "this" is actually passed, or is it just called as a function(and you end up accidentally polluting global scope or triggering strict warning) passing $self explicitly makes it clear that you are not calling it as a function, but as a method.
You are doing sub calls (not method calls), so you simply forgot to pass $self as a parameter.
my $object = {
code1 => sub {
print $_[0];
},
code2 => sub {
return 'Hello, World!';
},
code3 => sub {
my $self = shift;
$self->{code1}->( $self, $self->{code2}->($self) );
}
};
$object->{code3}->($object);
But I think you're trying to create JavaScript-like objects. You can start with the following:
package PrototypeObject;
sub new {
my $class = shift;
my $self = bless({}, $class);
%$self = #_;
return $self;
}
sub AUTOLOAD {
my $self = shift;
( my $method = our $AUTOLOAD ) =~ s/^.*:://s;
return $self->{$method}->($self, #_);
}
1;
use PrototypeObject qw( );
my $object = PrototypeObject->new(
code1 => sub {
print $_[1];
},
code2 => sub {
return 'Hello, World!';
},
code3 => sub {
my $self = shift;
$self->code1( $self->code2() );
}
);
$object->code3();
Note that this will slow down your method calls as it must call AUTOLOAD before calling your method. This could be addressed by overloading the method call operator.
Check on CPAN. Someone might already have a more complete implementation.
This is not the exact syntax you want, but Perl 5 supports many ways of making method calls, including method calls via strings. So you could say:
#!/usr/bin/perl
{ package Foo;
use strict;
use warnings;
sub new { bless {}, shift }
sub code1 { my $self = shift; print "$_[0]\n" };
sub code2 { "Hello, World!" }
sub code3 {
my $self = shift;
my $method1 = "code1";
my $method2 = "code2";
$self->$method1($self->$method2);
}
}
use strict;
use warnings;
my $o = Foo->new;
print "normal call\n";
$o->code3;
print "via string\n";
my $method = "code3";
$o->$method;
Also, remember that a package's symbol table is a hash: %Foo::, so you can always go spelunking in there yourself:
#!/usr/bin/perl
{ package Foo;
use strict;
use warnings;
sub new { bless {}, shift }
sub code1 { my $self = shift; print "$_[0]\n" };
sub code2 { "Hello, World!" }
sub code3 {
my $self = shift;
my $method1 = "code1";
my $method2 = "code2";
$self->$method1($self->$method2);
}
}
use strict;
use warnings;
print $Foo::{code2}->(), "\n";
However, I would suggest having a really code reason for these techniques as it can make maintenance a nightmare (eg imaging trying to find all of the code calling Foo::approved, you can't just grep for "->approved" because the actual call is ->$state()).
I just read the comments and noticed you said
my concern with packages is that I can't seem to create packages at runtime, but I can create hash tables at runtime
Perl 5 does allow you to create packages at runtime. In fact, depending on how you define runtime, you can do anything at runtime with string eval as it reenters compile time when it is called. But there is also a pure-runtime method of manipulating the symbol tables with typeglobs:
#!/usr/bin/perl
{ package Foo;
use strict;
use warnings;
sub new { bless {}, shift }
}
use strict;
use warnings;
my $o = Foo->new;
# here we add functions at runtime to the package Foo
{
no warnings "once";
*Foo::code1 = sub { my $self = shift; print "$_[0]\n" };
*Foo::code2 = sub { "Hello, World!" };
*Foo::code3 = sub {
my $self = shift;
my $method1 = "code1";
my $method2 = "code2";
$self->$method1($self->$method2);
};
}
$o->code3;
Because Perl 5 is object oriented (and not object based like JavaScript) these methods are attached to all Foo objects. If you want individual objects have their own symbol tables, then I am there are certainly ways to do that. Off the top of my head, AUTOLOAD comes to mind:
#!/usr/bin/perl
{ package Foo;
use strict;
use Carp;
use warnings;
sub new {
bless {
symtab => {}
}, shift
}
sub AUTOLOAD {
my $self = shift;
our $AUTOLOAD;
my $method = $AUTOLOAD =~ s/.*:://r;
my (undef, $file, $line) = caller();
die "$method does not exist at $file line $line"
unless exists $self->{symtab}{$method};
$self->{symtab}{$method}->($self, #_);
}
sub DESTROY {} # prevent DESTROY method from being hijacked by AUTOLOAD
}
use v5.22;
use warnings;
my $o1 = Foo->new;
my $o2 = Foo->new;
$o1->{symtab}{inc} = sub { my $self = shift; $self->{i}++; };
$o1->inc;
$o1->inc;
$o1->inc;
say "inc called on o1 $o1->{i} times";
$o2->inc; #dies because we haven't defined inc for $o2 yet
Perl 5 is very flexible and will let you do just about anything you want (after all the motto is TIMTOWTDI), but you should always keep in mind the future programmer tasked with maintaining your code who may want to hunt you down and wear your skin for doing some of these tricks.
This question has a definite XY problem feel. It seems like you are trying to solve a problem in Perl 5 the same way you would have solved it in JavaScript. While Perl 5 will let you do that (as I have demonstrated), there may be a more idiomatic way of achieving the same effect. Can you describe what you are trying to do (not how you want to do it) in a different question and we can suggest the ways in which we would solve your problem.

How can I pass a module's function as a reference to another module in Perl?

How can I pass a reference to a module's function as parameter in a function call of another module?
I tried the following (simple example):
This is the module that has a function (process_staff) that takes as a parameter a function reference (is_ok).
#!/usr/bin/perl
use strict;
use warnings;
package Objs::Processing;
sub new {
my ($class) = #_;
bless {} ;
}
sub process_staff {
my ($employee, $func) = #_;
if($func->is_ok($employee)) {
print "Is ok to process\n";
}
else {
print "Not ok to process\n";
}
}
1;
This is the module that implements the passed function (is_ok)
#!usr/bin/perl
use strict;
use warnings;
package Objs::Employee;
my $started;
sub new {
my ($class) = #_;
my $cur_time = localtime;
my $self = {
started => $cur_time,
};
print "Time: $cur_time \n";
bless $self;
}
sub get_started {
my ($class) = #_;
return $class->{started};
}
sub set_started {
my ($class, $value) = #_;
$class->{started} = $value;
}
sub is_ok {
my ($emp) = #_;
print "In is ok I received:\n";
use Data::Dumper;
print Dumper($emp);
return 1;
}
This is my test script that I run:
#!/usr/bin/perl
use strict;
use warnings;
use Objs::Manager;
use Objs::Processing;
my $emp = Objs::Manager->new('John Smith');
use Data::Dumper;
print Dumper($emp);
my $processor = Objs::Processing->new();
$processor->process_staff(\&$emp->is_ok); #error is here
I get a:
Not a CODE reference at testScript.pl line 14.
I also tried: $processor->process_staff(\&$emp->is_ok()); but also still does not work.
What am I doing wrong here
You appear to want to pass an object and a method to call on it; the easiest way to do that would be:
$processor->process_staff( sub { $emp->is_ok } );
where process_staff looks like:
sub process_staff {
my ($self, $func) = #_;
if ( $func->() ) {
...
or you can pass the reference and the object separately:
sub process_staff {
my ($self, $emp, $method) = #_;
if ( $emp->$method() ) {
...
$processor->process_staff( $emp, $emp->can('is_ok') );
I think this could work with:
$processor->process_staff(\&Objs::Employee::is_ok);
where you pass in the method ref.
and where you currently have
if( $func->is_ok($employee) ) {
you need
if( $func->( $employee ) ) {
This is because you cannot reference named methods simply from an object, by the syntax \&$obj->method.
However, in your example code it is not at all clear why you don't do this instead:
if( $employee->is_ok() ) {
in which case you would not need to reference the method to call in process_staff at all. There are also other ways to achieve the same method indirection that might give you better encapsulation in future.
In this expression:
$processor->process_staff(\&$emp->is_ok);
You are saying "call the method $emp->is_ok, take the return value, treat it as a CODE reference, dereference it, and return a reference to that. That doesn't work, since the return value from that sub is not a CODE reference.
To do what you want, you can use a reference to an anonymous sub to wrap the call to your object method:
$processor->process_staff( sub { $emp->is_ok } );
You can pass anonymous coderef which returns result from desired method,
$processor->process_staff(sub{ $emp->is_ok(#_) });
#_ can be dropped as is_ok method doesn't take any arguments.
It's not specifically what you asked for, but I think you simply need the following:
sub process_staff {
my ($self, $emp) = #_;
if ($emp->is_ok()) {
print "Is ok to process\n";
}
else {
print "Not ok to process\n";
}
}
$processor->process_staff($emp);

Extending a Perl non-Moose respecting encapsulation

I have a legacy project and I would like to extend a couple of classes in it with a few attributes and methods. I have access to the source code and know that the class uses a blessed hashref. I can of course go ahead and extend that hashref adding the keys that I want and re-bless into my class. But obviously this breaks encapsulation and I would like to avoid it as much as I can.
Is there a way to extend a (non-Moose) Perl class with attributes, not just methods, in a way that does not break encapsulation of the orginal class? The option to use Moose to do this is not available. Thank you.
First, one best practice for writing objects based on hashrefs is to prefix all fields with the package name, e.g.
package Parent;
sub new {
my ($class, $x, $y) = #_;
bless { "Parent::x" => $x, "Parent::y" => $y } => $class;
}
sub x { shift()->{"Parent::x"} }
sub y { shift()->{"Parent::y"} }
In that case, the issue doesn't arise, as every class has its own attribute namespace. But who writes his classes that way?
There are two ways I can think of to circumvent any problems: Proxying the original object via Autoload, or using inside-out object patterns. The third solution is to use prefixed attributes in your class, and hope that the parent never ever uses these names.
Inside-Out Objects
An inside-out object uses the blessed reference as an ID, and stores the attributes in lexical variables inside your class:
package Child;
use Scalar::Util qw/refaddr/;
use parent 'Parent';
my %foo;
sub new {
my ($class, $foo, #args) = #_;
my $self = $class->SUPER::new(#args);
$foo{refaddr $self} = $foo;
return $self;
}
sub foo {
my ($self) = #_;
$foo{refaddr $self};
}
sub set_foo {
my ($self, $val) = #_;
$foo{refaddr $self} = $val;
}
sub DESTROY {
my ($self) = #_;
# remove entries for this object
delete $foo{refaddr $self};
$self->SUPER::DESTROY if $self->SUPER::can('DESTROY');
}
This is a slightly dated pattern, but it works extremely well for your use case.
Proxy objects
We can contain a parent instance in a field of our class (i.e. both has-a and is-a relationship). Whenever we encounter unknown methods, we delegate to that object:
package Child;
use Parent ();
our $SUPER = 'Parent';
use Carp;
sub new {
my ($class, $foo, #args) = #_;
bless {
parent => $SUPER->new(#args),
foo => $foo,
} => $class;
}
sub foo {
my ($self) = #_;
$self->{foo};
}
sub set_foo {
my ($self, $val) = #_;
$self->{foo} = $val;
}
# manually establish pseudo-inheritance
# return true if our class inherits a given package
sub isa {
my ($self, $class) = #_;
return !!1 if $class eq __PACKAGE__;
return +(ref $self ? $self->{parent} : $SUPER)->isa($class);
}
# return a coderef to that method, or false
sub can {
my ($self, $meth) = #_;
my %methods = (new => \&new, foo => \&foo, set_foo => \&set_foo, DESTROY => \&DESTROY);
if (my $code = $methods{$meth}) {
return $code;
}
# check parent
my $code = ( ref $self ? $self->{parent} : $SUPER)->can($meth);
return undef unless $code;
return sub {
my $self = shift;
unshift #_, ref $self ? $self->{parent} : $self;
goto &$code;
};
}
# write explicit destroy to satisfy autoload
sub DESTROY {
my ($self) = #_;
$self->{parent}->DESTROY if ref $self and $SUPER->can('DESTROY');
}
sub AUTOLOAD {
# fetch appropriate method coderef
my $meth = our $AUTOLOAD;
$meth =~ s/.*:://; # clean package name from name
my $code = $_[0]->can($meth);
$code or croak qq(Can't locate object method "$meth" via package "#{[__PACKAGE__]}");
goto &$code;
}
The ugly part is to fake methods defined in superclasses in the can code: We have to wrap the actual method inside a anonymous sub that unpacks our object to call the method on the proxied object. The gotos make our extra levels invisible to the called code, which is neccessary when somebody uses caller.
Most of this boilerplate proxying code can be abstracted into another module (and probably is, somewhere on CPAN).

How to check some value on every call to object's methods?

I'd like to check on every call to my object's methods some value (in this case: token's age). Is it possible to set it to all methods at once? Like in constructor? I have such simple constructor:
sub new {
my $class = shift;
my %args = #_;
my $self = {};
$self->{key} = $args{key};
bless($self, $class);
($self->{token}, $self->{token_start}) = $self->_get_authorized_token();
return $self;
}
And bunch of methods, which depends of tokens age, like this:
sub add_item {
my $self = shift;
my %args = #_;
...
}
I'd like to avoid including age-checking in every method, so i look for more general way to implement it. Has there some?
All I can think of is to hide all your 'real' methods - either in the classical way with a preceding underscore, or in a hash of subroutines - and use AUTOLOAD to direct the call properly.
The example below shos the idea
module MyClass.pm
package MyClass;
use strict;
use warnings;
sub new {
bless {}, __PACKAGE__;
}
sub _method1 {
print "In method1\n";
}
sub _method2 {
print "In method2\n";
}
sub AUTOLOAD {
our $AUTOLOAD;
my ($class, $method) = $AUTOLOAD =~ /(.+)::(.+)/;
return if $method eq 'DESTROY';
my $newmethod = "${class}::_$method";
unless (exists &$newmethod) {
die qq(Can't locate object method "$method" via package "$class");
}
print "Preprocessing...\n";
goto &$newmethod
}
1;
program
use strict;
use warnings;
use MyClass;
my $thing = MyClass->new;
$thing->method1;
$thing->method2;
$thing->method3;
output
Preprocessing...
In method1
Preprocessing...
In method2
Can't locate object method "method3" via package "MyClass" at MyClass.pm line 23.
See Class::Method::Modifiers or Class::Method::Modifiers::Fast module.
I honestly think that if you're doing OO in Perl and you want to deal with things like attributes, method modifiers and deferred resource loading without the boilerplate, it's worth investing in learning Moose. To illustrate, this is one way to write what you want using Moose:
use Moose;
has key => (isa => 'Str', is => 'ro');
has token => (isa => 'HashRef', is => 'ro', lazy_build => 1);
before [qw(add_item method2 method3)] => sub {
my $self = shift;
if (do something with $self->token) {
# return, die, etc.
}
};
sub _build_token {
my $self = shift;
my $key = $self->key;
return { token => 'foo', token_start => time };
}
These might be helpful:
Moose::Manual::MethodModifiers
Moose::Cookbook::Basics::BinaryTree_BuilderAndLazyBuild

Define the method in the constructor of class in perl

I am reading code snippets like below:
sub new {
my $pkg = shift;
my $args = shift;
my #keys = keys %$args;
my $self = bless \%{$args}, $pkg;
$self->{'__properties'} = \#keys;
my $class = ref($self);
foreach my $meth (#keys) {
if (! $self->can($meth)) {
no strict "refs";
*{ $class . "::" . $meth } = sub {
my $instance = shift;
return $instance->{$meth};
};
}
}
return $self;
}
In the foreach loop, it seems that it creates some methods according to the parameters. There are two lines which I don't understand.Could someone help me? What's the * and {} used for?
no strict "refs";
*{ $class . "::" . $meth }
Best Regards,
This creates a symbol table alias.
The right side contains a reference to a function, so Perl will alias it to the subroutine $meth in the package $class.
See Symbol Tables in perlmod.
As eugene y have already explained, those lines manipulate the symbol table. In practical terms, they do so in order to create read-only accessor methods in the class based on whatever arbitrary list of attributes get passed into the constructor:
#!/usr/bin/env perl
use strict;
use warnings;
use 5.10.0;
package SomeClass;
sub new {
my $pkg = shift;
my $args = shift;
my #keys = keys %$args;
my $self = bless \%{$args}, $pkg;
$self->{'__properties'} = \#keys;
my $class = ref($self);
foreach my $meth (#keys) {
if (!$self->can($meth)) {
no strict "refs";
*{$class . "::" . $meth} = sub {
my $instance = shift;
return $instance->{$meth};
};
}
}
return $self;
}
package main;
my $foo = SomeClass->new({foo => 5}); # Creates SomeClass::foo
say $foo->foo; # 5
my $bar = SomeClass->new({foo => 3, bar => 7}); # Creates SomeClass::bar
say $bar->foo; # 3
say $bar->bar; # 7
say $foo->bar; # undef - ::bar was added to all instances of SomeClass
say $foo->baz; # Boom! No such method.
Personally, I think this is questionable OO practice (a class should generally have a known set of attributes instead of potentially adding new ones each time an instance is constructed), but that's what it does...