I am trying a different way of calling a subroutine in a Perl script.
I have a set of functions as follows:
sub Testcase_CheckStatus {
print "TestCase_CheckStatus called\n";
}
Then I'm traversing a Perl hash with keys like "CheckStatus":
while (my ($k, $v) = each %test_cases) {
print "TestCase_$k","\n";
Testcase_$k();
}
Basically, I want to call the function Testcase_CheckStatus like above while parsing the keys of hash, but I'm getting this error:
Can't locate object method "Testcase_" via package "CheckStatus" (perhaps you forgot to load "CheckStatus"?) at ./main.pl line 17
What can I do to correct this problem? Is there any alternate way of doing the same?
Other way:
use 5.010;
use warnings;
use strict;
my $testcases = {
test_case_1 => sub {
return 1 * shift();
},
test_case_2 => sub {
return 3 * shift();
},
test_case_3 => \&SomeSub,
};
for (1 .. 3) {
say $testcases->{ 'test_case_' . $_ }(7);
}
sub SomeSub {
return 5 * shift();
}
The following should allow you to do what you want:
while (my ($k, $v) = each %test_cases) {
print "TestCase_$k","\n";
&{"Testcase_$k"}();
}
However, this won't work if strict is in use. If you are using strict you will need a no strict inside the while loop, e.g.:
while (my ($k, $v) = each %test_cases) {
no strict 'refs';
print "TestCase_$k","\n";
&{"Testcase_$k"}();
}
Related
I'm trying to make subroutine closure working like an object.
However, I cannot call the returned subs references properly.
I receive Not a CODE reference at .\closure.pl line 22. error.
#!/usr/bin/perl
use strict;
use warnings;
sub number {
my ($value) = #_;
my $val = sub { $value };
my $inc = sub { ++$value };
my $dec = sub { --$value };
my %api = (
'val' => \$val,
'inc' => \$inc,
'dec' => \$dec,
);
return %api;
}
my %numb = number(42);
$numb{'inc'}->();
print $numb{'val'}->();
How to fix the code?
Code fixed
Yes, of course, an anonymous definition must return a reference. it means that it can be put directly in the %api. Perl doesn't complain and works like a charm :)
#!/usr/bin/perl
use strict;
use warnings;
sub number {
my ($value) = #_;
my %api = (
'val' => sub { $value },
'inc' => sub { ++$value },
'dec' => sub { --$value },
);
return \%api;
}
my $m = number(14);
my $n = number(41);
$m->{'dec'}->();
$n->{'inc'}->();
print $m->{'val'}->() . "\n"; # -> 13
print $n->{'val'}->() . "\n"; # -> 42
As discussed in perlref, the sub keyword without a name creates an anonymous subroutine and returns a reference to it. So you don't need to create another level of reference using the backslash; just pass the reference you already have as the value in the hash.
I'd like to be able to write something like the following...
call_with_scope({
x => 47,
}, sub {
printf "$x\n";
printf "$y\n";
});
Where $y is bound in the environment containing the expression (either lexically or dynamically depending on the symbol).
I've found a way to do it, but it requires no strict "vars" to be in effect in the expression containing call_with_scope(...) and the implementation of call_with_scope uses eval to create local bindings before transferring control to the callback.
Is there a way to avoid either requiring no strict "vars" at the call site or refer to and change the value of a local variable without resorting to eval?
For completeness, the code snippet below implements call_with_scope and prints 47 and then 48.
#!/usr/bin/env perl
use strict;
use warnings;
sub call_with_scope {
my ($env, $func) = #_;
my %property;
my #preamble;
foreach my $k (keys %$env) {
$property{$k} = $env->{$k};
# deliberately omitted: logic to ensure that ${$k} is a well-formed variable
push #preamble, "local \$$k = \$property{'$k'};";
}
# force scalar context
do {
my $str = join('', 'no strict "vars";', #preamble, '$_[1]->();');
return scalar(eval($str));
};
}
do {
no strict 'vars';
local $x;
my $y = 48;
call_with_scope(
{
x => 47,
},
sub {
printf "$x\n";
printf "$y\n";
}
);
};
I'm trying to write something kind of like Test::LectroTest ... except that instead of using a source filter and comments like in Property { ##[ x <- Int, y <- Int ]## <body> } ... I want to write something like Property({x => gen_int, y => gen_int}, sub { <body> }) where $x and $y inside body get their values when an "instantiation" of a property test is performed.
You can do this by defining $x and $y as globals in the caller's package.
no strict 'refs';
my $caller = caller;
for my $var (keys %$properties) {
*{$caller.'::'.$var} = $properties->{$var};
}
$code->();
But this can't be easily localized. And polluting the caller's namespace with globals potentially leads to mysterious data leaking between tests. In general, use as little magic as possible in a test library; the user will have enough of their own weird magic to debug.
Instead, provide a function which returns the properties. For example, p.
package LectroTest;
use Exporter qw(import);
our #EXPORT = qw(test p);
our $P;
sub test {
my($props, $test) = #_;
local $P = $props;
$test->();
}
sub p {
return $P;
}
And the test looks like:
use LectroTest;
test(
{ x => 42 }, sub { print p->{x} }
);
The problem is that the anon sub is compiled before call_with_scope is called, so there's no chance for call_with_scope to declare variables for that sub.
Any reason you're not using arguments like any other sub?
call_with_scope([ 47 ], sub {
my ($x) = #_;
printf "%s\n", $x;
printf "%s\n", $y;
});
It's not any longer!
Here's an alternative if you're ok in declaring $x outside of the sub.
use strict;
use warnings;
use PadWalker qw( closed_over );
sub call_with_scope {
my ($inits, $cb) = #_;
my $captures = closed_over($cb);
for my $var_name_with_sigil (keys(%$captures)) {
my ($var_name) = $var_name_with_sigil =~ /^\$(.*)/s
or next;
$inits->{$var_name}
or next;
${ $captures->{$var_name_with_sigil} } = $inits->{$var_name};
}
return $cb->();
}
{
my $x;
my $y = 48;
call_with_scope({
x => 47,
}, sub {
printf "%s\n", $x;
printf "%s\n", $y;
});
}
This works because variables are created at compile-time and cleared on scope exit.
It even works if sub was compiled in a different scope and package than the call to call_with_scope.
{
my $sub = do {
my $x;
my $y = 48;
sub {
printf "%s\n", $x;
printf "%s\n", $y;
}
};
call_with_scope({ x => 47 }, $sub);
}
But do you really want that kind of magic in your program?
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.
Using sub prototypes, we can define our own subs that look like map or grep. That is, the first coderef argument has shorter syntax than a normal anonymous sub. For example:
sub thunked (&) { $_[0] }
my $val = thunked { 2 * 4 };
Works great here, since the first argument is the coderef. For latter arguments however, it simple won't parse properly.
I made a with sub designed to make writing GTK2 code cleaner. It's meant to look like this (untested since it's hypothetical code):
use 5.012;
use warnings;
use Gtk2 '-init';
sub with ($&) {
local $_ = $_[0];
$_[1]->();
$_;
}
for (Gtk2::Window->new('toplevel')) {
$_->set_title('Test Application');
$_->add(with Gtk2::VBox->new {
my $box = $_;
$box->add(Gtk2::Button->new("Button $_")) for (1..4);
});
$_->show_all;
}
Gtk2->main;
It doesn't work because with needs to take the block as a first argument for the nice syntax to work. Is there any way to pull it off?
The module Devel::Declare contains tools for extending Perl's syntax in a relatively safe way.
Using Devel::Declare you would create a hook on the with token, which will stop the parser when it reaches that word. From there, you have control over the parser and you can read ahead until you reach a { symbol. At that point, you have what you need to work with, so you rewrite it into valid Perl, and pass it back to the parser.
in the file With.pm:
package With;
use warnings;
use strict;
use Devel::Declare;
sub import {
my $caller = caller;
Devel::Declare->setup_for (
$caller => {with => {const => \&parser}}
);
no strict 'refs';
*{$caller.'::with'} = sub ($&) {
$_[1]() for $_[0];
$_[0]
}
}
our $prefix = '';
sub get {substr Devel::Declare::get_linestr, length $prefix}
sub set { Devel::Declare::set_linestr $prefix . $_[0]}
sub parser {
local $prefix = substr get, 0, length($_[0]) + $_[1];
my $with = strip_with();
strip_space();
set "scalar($with), sub " . get;
}
sub strip_space {
my $skip = Devel::Declare::toke_skipspace length $prefix;
set substr get, $skip;
}
sub strip_with {
strip_space;
my $with;
until (get =~ /^\{/) {
(my $line = get) =~ s/^([^{]+)//;
$with .= $1;
set $line;
strip_space;
}
$with =~ s/\s+/ /g;
$with
}
and to use it:
use With;
sub Window::add {say "window add: ", $_[1]->str}
sub Window::new {bless [] => 'Window'}
sub Box::new {bless [] => 'Box'}
sub Box::add {push #{$_[0]}, #_[1..$#_]}
sub Box::str {"Box(#{$_[0]})"}
sub Button::new {"Button($_[1])"}
with Window->new {
$_->add(with Box->new {
for my $num (1 .. 4) {
$_->add(Button->new($num))
}
})
};
Which prints:
window add: Box(Button(1) Button(2) Button(3) Button(4))
A completely different approach would be to skip the with keyword altogether and write a routine to generate constructor subroutines:
BEGIN {
for my $name (qw(VBox)) { # and any others you want
no strict 'refs';
*$name = sub (&#) {
use strict;
my $code = shift;
my $with = "Gtk2::$name"->new(#_);
$code->() for $with;
$with
}
}
}
and then your code could look like
for (Gtk2::Window->new('toplevel')) {
$_->set_title('Test Application');
$_->add(VBox {
my $box = $_;
$box->add(Gtk2::Button->new("Button $_")) for (1..4);
});
$_->show_all;
}
One way that you could deal with it is to add a fairly useless keyword:
sub perform(&) { $_[0] }
with GTK2::VBox->new, perform { ... }
where perform is really just a sugarier alternative to sub.
Another way is to write a Devel::Declare filter or a Syntax::Keyword:: plugin to implement your with, as long as you have some way to tell when you're done parsing the with argument and ready to start parsing the block — balanced parentheses would do (so would an opening curly brace, but then hashes become a problem). Then you could support something like
with (GTK2::VBox->new) { ... }
and let the filter rewrite it to something like
do {
local $_ = GTK2::VBox->new;
do {
...;
};
$_;
}
which, if it works, has the advantage of not actually creating a sub, and thus not interfering with #_, return, and a few other things. The two layers of do-age I think are necessary for being able to install an EndOfScope hook in the proper place.
The obvious disadvantages of this are that it's tricky, it's hairy, and it's a source filter (even if it's a tame one) which means there are problems you have to solve if you want any code using it to be debuggable at all.
I want to call a main controller function that dispatches other function dynamically, something like this:
package Controller;
my %callback_funcs = ();
sub register_callback{
my ($class,$callback,$options) = _#;
#apppend to %callback_funcs hash ... ?
}
sub main{
%callback_funcs = ( add => 'add_func', rem => 'remove_func', edit => 'edit_func');
while(<STDIN>){
last if ($_ =~ /^\s*$/);
if($_ == 'add' || _$ == 'rem' || _$ == 'edit'){
$result = ${callback_funcs['add']['func']}(callback_funcs['add']['options']);
}
}
}
sub add_func{
...
}
One caveat is that the subs are defined in other Modules, so the callbacks would have to be able to reference them... plus
I'm having a hard time getting the hashes right!
So, it's possible to have a hash that contains anonymous subroutines that you can invoke from stdin.
my %callbacks = (
add => sub {
# do stuff
},
fuzzerbligh => sub {
# other stuff
},
);
And you can insert more hashvalues into the hash:
$callbacks{next} = sub {
...
};
And you would invoke one like this
$callbacks{next}->(#args);
Or
my $coderef = $callbacks{next};
$coderef->(#args);
You can get the hashkey from STDIN, or anywhere else.
You can also define them nonymously and then take a reference to them.
sub delete {
# regular sub definition
}
$callbacks{delete} = \&delete;
I wouldn't call these callbacks, however. Callbacks are subs that get called after another subroutine has returned.
Your code is also rife with syntax errors which may be obscuring the deeper issues here. It's also not clear to me what you're trying to do with the second level of arrays. When are you defining these subs, and who is using them when, and for what?
Perhaps this simplified example will help:
# Very important.
use strict;
use warnings;
# Define some functions.
sub multiply { $_[0] * $_[1] }
sub divide { $_[0] / $_[1] }
sub add { $_[0] + $_[1] }
sub subtract { $_[0] - $_[1] }
# Create a hash of references to those functions (dispatch table).
my %funcs = (
multiply => \&multiply,
divide => \÷,
add => \&add,
subtract => \&subtract,
);
# Register some more functions.
sub register {
my ($key, $func) = #_;
$funcs{$key} = $func;
}
register('+', \&add); # As above.
register('sum', sub { # Or using an anonymous subroutine.
my $s = 0;
$s += $_ for #_;
return $s;
});
# Invoke them dynamically.
while (<>){
my ($op, #args) = split;
last unless $op and exists $funcs{$op}; # No need for equality tests.
print $funcs{$op}->(#args), "\n";
}
You've already got some good answers on how to build a dispatch table and call functions through it within a single file, but you also keep talking about wanting the functions to be defined in other modules. If that's the case, then wouldn't it be better to build the dispatch table dynamically based on what dispatchable functions each module says it has rather than having to worry about keeping it up to date manually? Of course it would!
Demonstrating this requires multiple files, of course, and I'm using Module::Pluggable from CPAN to find the modules which provide the function definitions.
dispatch_core.pl:
#!/usr/bin/env perl
use strict;
use warnings;
my %dispatch;
use lib '.'; # a demo is easier if I can put modules in the same directory
use Module::Pluggable require => 1, search_path => 'DTable';
for my $plugin (plugins) {
%dispatch = (%dispatch, $plugin->dispatchable);
}
for my $func (sort keys %dispatch) {
print "$func:\n";
$dispatch{$func}->(2, 5);
}
DTable/Add.pm:
package DTable::Add;
use strict;
use warnings;
sub dispatchable {
return (add => \&add);
}
sub add {
my ($num1, $num2) = #_;
print "$num1 + $num2 = ", $num1 + $num2, "\n";
}
1;
DTable/MultDiv.pm:
package DTable::MultDiv;
use strict;
use warnings;
sub dispatchable {
return (multiply => \&multiply, divide => \÷);
}
sub multiply {
my ($num1, $num2) = #_;
print "$num1 * $num2 = ", $num1 * $num2, "\n";
}
sub divide {
my ($num1, $num2) = #_;
print "$num1 / $num2 = ", $num1 / $num2, "\n";
}
1;
Then, on the command line:
$ ./dispatch_core.pl
add:
2 + 5 = 7
divide:
2 / 5 = 0.4
multiply:
2 * 5 = 10
Adding new functions is now as simple as dropping a new file into the DTable directory with an appropriate dispatchable sub. No need to ever touch dispatch_core.pl just to add a new function again.
Edit: In response to the comment's question about whether this can be done without Module::Pluggable, here's a modified dispatch_core.pl which doesn't use any external modules other than the ones defining the dispatchable functions:
#!/usr/bin/env perl
use strict;
use warnings;
my %dispatch;
my #dtable = qw(
DTable::Add
DTable::MultDiv
);
use lib '.';
for my $plugin (#dtable) {
eval "use $plugin";
%dispatch = (%dispatch, $plugin->dispatchable);
}
for my $func (sort keys %dispatch) {
print "$func:\n";
$dispatch{$func}->(2, 5);
}