dynamic call to subroutines in perl - perl

I'm a bit messed up with the following:
I have a function that calls subroutines in the following way:
sub someFunction {
my $self = shift;
my $type = $self->{'type'};
if($type eq 'one_subroutine') {
$self->updateOneSubroutine();
}
elsif($type eq 'another_one_sub') {
$self->updateAnotherOneSub();
}
(...)
else {
die "Unsupported '$type'";
}
I have to change this to let each subroutine be coded in its own file, include all available files, and automagically call the subroutine inside.
I did this in a test file with the following code:
# Assume a routines subdir with one_subroutine.pm file with
sub updateOneSubroutine(){
$self = shift;
$self->doSomeThings();
(...) #my code
}
1;
test.pl
# Saves in routines hash_ref a pair of file_name => subRoutineName for each file in routines subdir.
# This will be used later to call subroutine.
opendir(DIR,"lib/routines") or die "routines directory not found";
for my $filename (readdir(DIR)) {
if($filename=~m/\.pm$/){
# includes file
require "lib/routines/$filename";
# get rid of file extension
$filename=~s/(.*)\.pm/$1/g;
my $subroutine = "update_${file}";
# camelizes the subroutine name
$subroutine=~s/_([a-z0-9])/\u$1/g;
$routine->{ $filename } = $subroutine;
}
}
{
no strict "refs";
$routine->{$param}();
}
where param is something like "one_subroutine", that matches with a filename available.
Since each subroutine receives $self in the call, I should call the routine by $self->something();
I've tried $self->$routine->{$param}() , $self->${routine->${param}}() and many other things without success. I've checked chapter 9 "dynamic subroutines" of mastering perl, and a similar question to perl monks, but I can't still figure out how to reference the subroutine in a way that represents $self->updateAnotherOneSub() , or something similar that lets $self be read as a param in those subroutines.
Thanks in advance, Keber.

This seems a bit like an X/Y problem. What exactly are you trying to do? If it is to reduce loading time, then modules like AutoSplit/AutoLoader might be of interest to you.
If it is to create some sort of data structure of subroutines, you should be installing anonymous subs into a hash, rather than giving them all names.
Given a subroutine reference:
my $code = sub {...};
you would call it as:
$self->$code(...);
If instead you have a subroutine name, you can lookup the coderef:
my $code = 'Package::With::The::Subroutines'->can('method_name');
and if that succeeds (check it), then you can use $self->$code(...) to call it.
Given this code:
{
no strict "refs";
$routine->{$param}();
}
You would pass $self to the routine with:
{
no strict "refs";
$routine->{$param}($self);
}
Or you could approach it the way I did above with can:
'package'->can($routine->{$param})->($self)
if you don't want to turn off strict 'refs'

Try to extract the method name first, then it should work. I did a small test script that may do something like you want to, so:
my $method = $routine->{$param};
$self->$method->();
You can and of course should check, if the desired method exists like Eric said:
if ($self->can($method)) {
$self->$method->();
}
The important part here is, that you extract the method name so you have it in a single variable; otherwise perl won't figure that out for you - and as far as I know there is no way of setting parens or braces to do so.

Related

How can I apply a method modifier to a method generated by AUTOLOAD?

I have a very interesting predicament. I am working on a Perl script interface to the CVS repository and have created Perl Objects to represent Modules,Paths, and Files. Since Modules, Paths, and Files can all have CVS commands issued on them, I set up the AUTOLOAD routine to take any unidentified methods and issue them on the object as if they were CVS commands.
All of these CVS commands are executed exactly the same way, but some of them need special processing done with the output to get the result i desire.
For example, I want to take the output from the diff command and reformat it before I return it.
I am using Moose, so typically this special processing could be done as follows:
after 'diff' => sub {
# Reformat output here
}
The problem is... I never explicitly created the diff method since it is being generated by AUTOLOAD and Perl won't let me create a method modifier for it since it technically doesn't exist!
Is there a way to get this to work how I want?
Apply after to your AUTOLOAD method.
after 'AUTOLOAD' => sub {
my $method = $The::Package::AUTOLOAD;
$method =~ s/.*:://;
if ($method eq 'diff') {
# do after diff stuff
} elsif ($method eq 'foo') {
# do after foo stuff
} else {
# never mind, don't want to do anything after this function
}
};
EDIT:
I found that I may want even more control over the diff command so I have added more detail to your answer. Hopefully someone will find this information useful.
For even more control you can use around!
around 'AUTOLOAD' => sub {
my $orig = shift;
my $self = shift;
(my $command = $AUTOLOAD) =~ s{.+::}{};
# Special processing
if ($command eq 'diff') {
#
# Add "before" special processing here
#
my $output = $self->$orig(#_);
#
# Add "after" special processing here
#
}
else {
return $self->$orig(#_);
}
};
This allows you to do special processing before the function is called AND after.
For more information see: Moose::Manual::MethodModifiers
Depending on how well the AUTOLOAD-using class is implemented, you may find that it respects the can method too, and that simply calling can is enough to create the method.
__PACKAGE__->can( "diff" );
after diff => sub { ... };
I'd suggest that you re-architect your system to use traits, instead of relying on AUTOLOAD behavior. The maintainability and intent will be much more obvious, if you don't have behavior scattered all over the place.
As an example, you can do what you want with something like the following:
package Trait::CVSActions;
use Moose::Role;
sub commit { print 'in commit for ' . shift . "\n" }
sub diff { print 'diffing for ' . shift . "\n" }
package Module;
use Moose;
with 'Trait::CVSActions';
package Path;
use Moose;
with 'Trait::CVSActions';
after commit => sub { print "after commit on Path\n" };
package main;
my $module = new Module;
my $path = new Path;
$module->commit;
$path->commit;
If you're looking to use AUTOLOAD to dispatch to unknown commands, then this is dangerous, since there may be some that you will have to have special handling for that you aren't aware of, so you may be causing yourself future problems.

Replacing a class in Perl ("overriding"/"extending" a class with same name)?

I am trying to Iterate directories in Perl, getting introspectable objects as result, mostly so I can print fields like mtime when I'm using Dumper on the returns from IO::All.
I have discovered, that it can be done, if in the module IO::All::File (for me, /usr/local/share/perl/5.10.1/IO/All/File.pm), I add the line field mtimef => undef;, and then modify its sub file so it runs $self->mtimef($self->mtime); (note, this field cannot have the same name (mtime) as the corresponding method/property, as those are dynamically assigned in IO::All). So, in essence, I'm not interested in "overloading", as in having the same name for multiple function signatures - I'd want to "replace" or "override" a class with its extended version (not sure how this is properly called), but under the same name; so all other classes that may use it, get on to using the extended version from that point on.
The best approach for me now would be, if I could somehow "replace" the IO::All::File class, from my actual "runnable" Perl script -- if somehow possible, by using the mechanisms for inheritance, so I can just add what is "extra". To show what I mean, here is an example:
use warnings;
use strict;
use Data::Dumper;
my #targetDirsToScan = ("./");
use IO::All -utf8 ; # Turn on utf8 for all io
# try to "replace" the IO::All::File class
{ # recursive inheritance!
package IO::All::File;
use IO::All::File -base;
# hacks work if directly in /usr/local/share/perl/5.10.1/IO/All/File.pm
field mtimef => undef; # hack
sub file {
my $self = shift;
bless $self, __PACKAGE__;
$self->name(shift) if #_;
$self->mtimef($self->mtime); # hack
return $self->_init;
}
1;
}
# main script start
my $io = io(#targetDirsToScan);
my #contents = $io->all(0); # Get all contents of dir
for my $contentry ( #contents ) {
print Dumper \%{*$contentry};
}
... which fails with "Recursive inheritance detected in package 'IO::All::Filesys' at /usr/local/share/perl/5.10.1/IO/All/Base.pm line 13."; if you comment out the "recursive inheritance" section, it all works.
I'm sort of clear on why this happens with this kind of syntax - however, is there a syntax, or a way, that can be used to "replace" a class with its extended version but of the same name, similar to how I've tried it above? Obviously, I want the same name, so that I wouldn't have to change anything in IO::All (or any other files in the package). Also, I would preferably do this in the "runner" Perl script (so that I can have everything in a single script file, and I don't have to maintain multiple files) - but if the only way possible is to have a separate .pm file, I'd like to know about it as well.
So, is there a technique I could use for something like this?
Well, I honestly have no idea what is going on, but I poked around with the code above, and it seems all that is required, is to remove the -base from the use IO::All::File statement; and the code otherwise seems to work as I expect it - that is, the package does get "overriden" - if you change this snippet in the code above:
# ...
{ # no more recursive inheritance!? IO::All::File gets overriden with this?!
package IO::All::File;
use IO::All::File; # -base; # just do not use `-base` here?!
# hacks work if directly in /usr/local/share/perl/5.10.1/IO/All/File.pm
field mtimef => undef; # hack
sub file {
my $self = shift;
bless $self, __PACKAGE__;
$self->name(shift) if #_;
$self->mtimef($self->mtime); # hack
print("!! *haxx0rz'd* file() reporting in\n");
return $self->_init;
}
1;
}
# ...
I found this so unbelievable, I even added the print() there to make sure it is the "overriden" function that runs, and sure enough, it is; this is what I get in output:
...
!! *haxx0rz'd* file() reporting in
$VAR1 = {
'_utf8' => 1,
'mtimef' => 1394828707,
'constructor' => sub { "DUMMY" },
'is_open' => 0,
'io_handle' => undef,
'name' => './test.blg',
'_encoding' => 'utf8',
'package' => 'IO::All'
};
...
... and sure enough,the field is there, as expected, too...
Well - I hope someone eventually puts a more qualified answer here; for the time being, I hope this is as good as a fix to my problems :) ...

Pass by reference within File Find function in perl

I have read a few post similar to this, but they dont quite have the answer I want. Basically, I am struggling to do pass by reference with this File::find function. The original code is huge. So I take out pieces of the code.
Note that
$node,$ref_p, $ref_alphaSUM ,$ref_rank, $ref_sorted_alpha, $output_file
are all variables or references of global variables. I need to recursively traverse through the directories and apply the &eachFile subroutine to each file, which will update my variables stated above. The "&whichFiles" subroutine just sorts the filenames.
First problem: Since not all files in the directories contains the string nfcapd, i have added the line if(/^nfcapd./) to check the if the name of the file contains this string. But since I am also passing those variables above to eachFile, the "$_" cannot be used now.
Thus, I believe This is why I kept getting the following error:(please correct me if I am wrong):
Use of uninitialized value $File::Find::name in pattern match (m//) at
./pvalues.pl line 178, <PRE> line 65184 (#1)
Line 178 is the line where if(/^nfcapd./) appears in the code below.
This leads to 2nd problem: How to do pass by reference within find function and at the same time preserving a variable for the name of file such that I can still check if the "&eachFile" is being applied to the correct files?
#!/usr/bin/perl
use strict;
use warnings;
use File::Find;
find ({wanted => \&eachFile($node,$ref_p, $ref_alphaSUM ,$ref_rank, $ref_sorted_alpha, $output_file), preprocess => \&whichFiles},$flow_data_path);
sub eachFile {
my ($node , $ref_p, $ref_alphaSUM ,$ref_rank, $ref_sorted_alpha , $output_file) = #_;
if(/^nfcapd\./){
#do something
}
}
To pass variables to your wanted sub, you need a closure:
sub eachFile {
my ($node , $ref_p, $ref_alphaSUM ,$ref_rank, $ref_sorted_alpha , $output_file) = #_;
if(/^nfcapd\./){
#do something
}
}
my $wanted = sub { eachFile($node,$ref_p, $ref_alphaSUM ,$ref_rank, $ref_sorted_alpha, $output_file) };
find({wanted => $wanted, ...});

accessing to the children package variable from the base class by using only $self or ref($self)

I have the following problem, may be I am trying to solve it in a bad way so if you tell me how to do it in a right way I would be very grateful!
I have a base class which has a method which I want to access to a package variable based on real object class (ref($self)).
#!/usr/bin/env perl
my $var = SubClass->new();
$var->method();
package BaseClass;
sub new { construct... }
sub method {
my $self = shift;
# in this method I wan to get values from 'our %VAR' of the children class or ref($self) class, something like that:
return ${ref($self)::VAR}{k1};
# of course I can create a method and do it in the following way but I am not sure that it's a good idea
return $self->get_var()->{k1};
}
sub get_var { die "Imaplement in children"; }
package SubClass;
use base 'BaseClass';
our %VAR = (k1 => 'smth', k2 => 'smth', ...);
sub get_var { return \%VAR } # don't like this idea
1;
Using the %{ref($self)::VAR} solution may sometimes be the easiest, although a paranoid programmer would include some checks:
# Accessing %__PACKAGE__::VAR:
# I hope that I'm not in a subclass,
# because that would change the value reported by `ref($self)`
# and I can't be bothered to search #ISA manually...
unless (defined ref $self) {
die "\$self is not a reference!";
}
if (ref $self ~~ [qw/SCALAR ARRAY HASH
CODE REF GLOB LVALUE FORMAT IO VSTRING Regexp /]) {
die "\$self is not an object!";
}
no strict 'refs'; # Hehe, I can't use strict here :S
unless (%{ref($self).'::VAR'}) {
warn "Umm, this hash is empty."
. "I don't know if I just created it, or it is meant to be that way.";
}
return ${ref($self).'::VAR'}{k1};
In conclusion, using an accessor method does not only save us repetition, it is also safer, less hackish and far more object oriented:
sub return_var {
# We know that we are in the right package.
# We know we are accessing the correct hash.
# It is irrelevant whether I call this method
# from the package/class or from an object.
# And I'm glad to take the method performance penalty
# in exchange for clear code.
return \%VAR;
}
In conclusion #2, there is more than one way to do it. And in Perl, there is no "right" way. Although you might understand why I find the second solution more elegant.

How can I get the name of the current subroutine in Perl?

In Perl we can get the name of the current package and current line number Using the predefined variables like __PACKAGE__ and __LINE__.
Like this I want to get the name of the current subroutine:
use strict;
use warnings;
print __PACKAGE__;
sub test()
{
print __LINE__;
}
&test();
In the above code I want to get the name of the subroutine inside the function test.
Use the caller() function:
my $sub_name = (caller(0))[3];
This will give you the name of the current subroutine, including its package (e.g. 'main::test'). Closures return names like 'main::__ANON__'and in eval it will be '(eval)'.
caller is the right way to do at #eugene pointed out if you want to do this inside the subroutine.
If you want another piece of your program to be able to identify the package and name information for a coderef, use Sub::Identify.
Incidentally, looking at
sub test()
{
print __LINE__;
}
&test();
there are a few important points to mention: First, don't use prototypes unless you are trying to mimic builtins. Second, don't use & when invoking a subroutine unless you specifically need the effects it provides.
Therefore, that snippet is better written as:
sub test
{
print __LINE__;
}
test();
I was just looking for an answer to this question as well, I found caller as well, but I was not interested in the fully qualified path, simply the literal current package name of the sub, so I used:
my $current_sub = (split(/::/,(caller(0))[3]))[-1];
Seems to work perfectly, just adding it in for if anyone else trips over this questions :)
There special __SUB__ exists from perl-5.16.
use v5.16;
use Sub::Identify qw/sub_fullname/;
sub foo {
print sub_fullname( __SUB__ ); # main::foo
}
foo();
Actually you can pass to sub_fullname any subroutine reference (even anonymous):
use Sub::Identify qw/sub_fullname/;
sub foo {
print sub_fullname( \&foo ); # main::foo
print sub_fullname( sub{} ); # main::__ANON__
}
foo();