I have 4 sub rountines (sub room1 {do stuuf...}, sub room2{do stuff...}, sub room3{do other stuff...}) that will each do different things inside the routine.
What I want to do is to be able to dynamically call a routine based on a variable name.
For exmaple,
if ($currentRoom == 1) { &room1; }
if ($currentRoom == 2) { &room2; }
if ($currentRoom == 3) { &room3; }
What I would rather do, is just call the correct sub routine using $currentRoom as the value after &room. Something like &room{$currentRoom};
Can this be done and if so, how can I achieve this.
Create a hash relating room numbers to subroutine references:
my %room_actions = (
1 => \&room1,
2 => \&room2,
3 => \&room3,
);
if ($room_actions{$currentRoom}) {
$room_actions{$currentRoom}->();
} else {
die "room doesn't exist: $currentRoom";
}
You could try this:
use strict;
use warnings;
sub test1 {print 1}
sub test2 {print 2}
my $test = 1;
{ # naked block, to make no strict 'refs' not global
no strict 'refs';
&{'test'.$test}();
}
Output:
1
but be prepared, if you try to access a sub (e.g. 3 at code above), which does not exists, you will get a warning:
Undefined subroutine &main::test3 called at test.pl .....
This is almost 2 years late, but I landed here after a somehow related search and I was struck by the lack of this solution:
__PACKAGE__->can('room' . $currentRoom)->();
You can also add some custom error checking:
if (my $sub = __PACKAGE__->can('room' . $currentRoom)) {
$sub->();
}
This is a kind of quick and dirty dispatch table, using can instead of a hash access but without giving up any safenets.
Related
In the following script, I declare and modify #basearray in the main program. Inside the dosomething subroutine, I access #basearray, assign it to an array local to the script, and modify the local copy. Because I have been careful to change the value only of local variables inside the subroutine, #basearray is not changed.
If I had made the mistake of assigning a value to #basearray inside the subroutine, though, it would have been changed and that value would have persisted after the call to the subroutine.
This is demonstrated in the 2nd subroutine, doagain.
Also, doagain receives the reference \#basearray as an argument rather than accessing #basearray directly. But going to that additional trouble provides no additional safety. Why do it that way at all?
Is there a way to guarantee that I cannot inadvertently change #basearray inside any subroutine? Any kind of hard safety device that I can build into my code, analogous to use strict;, some combination perhaps of my and local?
Am I correct in thinking that the answer is No, and that the only solution is to not make careless programmer errors?
#!/usr/bin/perl
use strict; use warnings;
my #basearray = qw / amoeba /;
my $count;
{
print "\#basearray==\n";
$count = 0;
foreach my $el (#basearray) { $count++; print "$count:\t$el\n" };
}
sub dosomething
{
my $sb_name = (caller(0))[3];
print "entered $sb_name\n";
my #sb_array=( #basearray , 'dog' );
{
print "\#sb_array==\n";
$count = 0;
foreach my $el (#sb_array) { $count++; print "$count:\t$el\n" };
}
print "return from $sb_name\n";
}
dosomething();
#basearray = ( #basearray, 'rats' );
{
print "\#basearray==\n";
$count = 0;
foreach my $el (#basearray) { $count++; print "$count:\t$el\n" };
}
sub doagain
{
my $sb_name = (caller(0))[3];
print "entered $sb_name\n";
my $sf_array=$_[0];
my #sb_array=#$sf_array;
#sb_array=( #sb_array, "piglets ... influenza" );
{
print "\#sb_array==\n";
$count = 0;
foreach my $el (#sb_array) { $count++; print "$count:\t$el\n" };
}
print "now we demonstrate that passing an array as an argument to a subroutine does not protect it from being globally changed by programmer error\n";
#basearray = ( #sb_array );
print "return from $sb_name\n";
}
doagain( \#basearray );
{
print "\#basearray==\n";
$count = 0;
foreach my $el (#basearray) { $count++; print "$count:\t$el\n" };
}
There isn't a pragma or a keyword or such, but there are well established "good practices," which in this case completely resolve what you reasonably ponder about.
The first sub, dosomething, commits the sin of using variables visible in its scope but defined in the higher scope. Instead, always pass needed data to a subroutine (exceptions are rare, in crystal clear cases).
Directly using data from "outside" defies the idea of a function as an encapsulated procedure, exchanging data with its users via a well defined and clear interface. It entangles ("couples") sections of code that are in principle completely unrelated. In practice, it can also be outright dangerous.
Also, the fact the #basearray is up for grabs in the sub is best considered an accident -- what when that sub gets moved to a module? Or another sub is introduced to consolidate code where #basearray is defined?
The second sub, doagain, nicely takes a reference to that array. Then, to protect the data in the caller, one can copy the caller's array to another one which is local to the sub
sub doagain {
my ($ref_basearray) = #_;
my #local_ba = #$ref_basearray;
# work with local_ba and the caller's basearray is safe
}
The names of local lexical variables are of course arbitrary, but a convention where they resemble the caller's data names may be useful.
Then you can adopt a general practice, for safety, to always copy input variables to local ones. Work directly with references that are passed in only when you want to change the caller's data (relatively rare in Perl). This may hurt efficiency if it's done a lot with sizeable data, or when really large data structures are involved. So perhaps then make an exception and change data via its reference, and be extra careful.
(Putting my comment as answer)
One way to guarantee not changing a variable inside a subroutine is to not change it. Use only lexically scoped variables inside the subroutine, and pass whatever values you need inside the subroutine as arguments to the subroutine. It is a common enough coding practice, encapsulation.
One idea that you can use -- mainly as practice, I would say -- to force yourself to use encapsulation, is to put a block around your "main" code, and place subroutines outside of it. That way, if you should accidentally refer to a (formerly) global variable, use strict will be able to do it's job and produce a fatal error. Before runtime.
use strict;
use warnings;
main: { # lexical scope reduced to this block
my #basearray = qw / amoeba /;
print foo(#basearray); # works
print bar(); # fatal error
} # END OF MAIN lexical scope of #basearray ends here
sub foo {
my #basearray = #_; # encapsulated
return $basearray[1]++;
}
sub bar {
return $basearray[1]++; # out of scope ERROR
}
This will not compile, and will produce the error:
Global symbol "#basearray" requires explicit package name at foo.pl line 15.
Execution of foo.pl aborted due to compilation errors.
I would consider this a training device to force yourself to using good coding practices, and not something to necessarily use in production code.
There are several solutions with various levels of pithiness from "just don't change it" to "use an object or tied array and lock down the update functions". An intermediate solution, not unlike using an object with a getter method, is to define a function that returns your array but can only operate as an rvalue, and to use that function inside subroutines.
my #basearray = (...);
sub basearray { return #basearray }
sub foo {
foreach my $elem (basearray()) {
...
}
#bar = map { $_ *= 2 } basearray(); # ok
#bar = map { $_ *= 2 } #basearray; # modifies #basearray!
}
TLDR: yes, but.
I'll start with the "but". But it's better to design your code so that the variable simply doesn't exist in the scope where the untrusted function is defined.
sub untrusted_function {
...
}
my #basearray = qw( ... ); # declared after untrusted_function
If untrusted_function needs to be able to access the contents of the array, pass it a copy of the array as a parameter, so it can't modify the original.
Now here's the "yes".
You can mark the array as read-only before calling the untrusted function.
Internals::SvREADONLY($_, 1) for #basearray;
Internals::SvREADONLY(#basearray, 1);
Then mark it read-write again after the function has finished.
Internals::SvREADONLY(#basearray, 0);
Internals::SvREADONLY($_, 0) for #basearray;
Using Internals::SvREADONLY(#basearray, $bool) modifies the read-only state of the array itself, preventing elements from being added or removed from it; Internals::SvREADONLY($_, $bool) for #basearray modifies the read-only state of each element in the array too, which you probably want.
Of course, if your array contains references like blessed objects, you then need to consider whether you need to recurse into the references, marking them read-only too. (But can also be a concern with the shallow copy of the array I mentioned in the preferred solution!)
So yes, it is possible to prevent a sub from accidentally modifying a variable by marking that variable read-only before calling the sub, but it's a better idea to restructure your code so the sub simply doesn't have access to the variable at all.
Yes, but.
Here is a prototype that uses #TLP's answer.
#!/usr/bin/perl
use strict; use warnings;
{ # block_main BEG
my #basearray = qw / amoeba elephants sequoia /;
print join ( ' ', 'in main, #basearray==', join ( ' ', #basearray ), "\n" );
print "Now we call subroutine to print it:\n"; enumerateprintarray ( \#basearray );
my $ref_basearray = changearray ( \#basearray, 'wolves or coyotes . . . ' );
#basearray = #$ref_basearray;
print "Now we call subroutine to print it:\n"; enumerateprintarray ( \#basearray );
} # block_main END
sub enumerateprintarray
{
my $sb_name = (caller(0))[3];
#print join ( '' , #basearray ); # mortal sin! for in the day that thou eatest thereof thou shalt surely die.
my $sb_exact_count_arg = 1;
die "$sb_name must have exactly $sb_exact_count_arg arguments" unless ( ( scalar #_ ) == $sb_exact_count_arg );
my $sf_array = $_[0];
my #sb_array = #$sf_array;
my $sb_count = 0;
foreach (#sb_array)
{
$sb_count++;
print "\t$sb_count:\t$_\n";
}
}
sub changearray
{
my $sb_name = (caller(0))[3];
#print join ( '' , #basearray ); # in the day that thou eatest thereof thou shalt surely die.
my $sb_exact_count_arg = 2;
die "$sb_name must have exactly $sb_exact_count_arg arguments" unless ( ( scalar #_ ) == $sb_exact_count_arg );
my ( $sf_array, $addstring ) = #_;
my #sb_array = #$sf_array;
push #sb_array, $addstring;
return ( \#sb_array );
}
I have one script (A.pl) and one package (B.pm), I want to create a static variable in B.pm so that it can accessible to A.pl.
A.pl
use lib 'path/to/B_Package';
for loop 10 times {
fun(age);
}
if ($count>0) {
print "script fails";
}
B.pm
package B {
fun() {
my $age_given = shift;
my $count;
eval {
result = someFileHandling;
} or die {
$count++;
}
}
}
I'd question such design, and some alternatives are offered below.
But yes it can be done -- a variable declared as our can be accessed by its fully qualified name.
In the package file Pack.pm
package Pack;
use warnings;
use strict;
use Exporter qw(import);
our #EXPORT_OK = qw(func);
our $count = 7;
sub func { ++$count }
1;
and in its user
use warnings;
use strict;
use feature 'say';
use Pack qw(func);
for (1..2) {
func();
say "Current value of a global in 'Pack': ", $Pack::count;
}
$Pack::count = 123;
say "Current value of a global in 'Pack': ", $Pack::count;
So changes to $count made in Pack::func() are seen in the calling program. More to the point, $Pack::count can be directly written by any code in the interpreter.
The package globals that are meant to be used directly, like $count above,† are tricky creatures that can be hard to use sensibly but are very easy to end up abusing.
In general you don't want them: their use runs contrary to the critical idea of dividing software in components that communicate via clearly defined interface, they introduce uncontrolled coupling and thus defeat scope, etc. With such variables in use distinct components in the code get entangled.
But they can of course be useful and are used in libraries, mostly for constants and parameters.
Now, having them change as well? That can get out of control, and even though that, too, is used in libraries (to control their behavior by setting parameters) it veers closer to an analogue of a "God Class," an all-controlling entity. At that point I would flatly call it flawed and a trouble-maker.
Why not have subs handle the counting and return updated values? They can keep values using state pragma for instance. Or even using a file-scoped variable, as long as that is internal to its business and outsiders aren't allowed to poke at it.
Here's a sample for the two mentioned approaches in revised Pack.pm
package Pack;
use warnings;
use strict;
use feature qw(state);
use Exporter qw(import);
our #EXPORT_OK = qw(count func1 func2);
my $count = 7;
sub func1 { ++$count } # sets counter while doing its other work
sub count { # add check that input is numeric
$count += shift for #_; # Set count if values passed,
return $count; # return value in either case
}
sub func2 {
state $count = 0; # keeps count (its own $count)
return $count += shift // 1; # demo: add some and return
}
1;
Demo for its use:
use warnings;
use strict;
use feature 'say';
use Pack qw(count func1 func2);
say "Call func2(), using 'state' feature, with its own counter: ";
for (1..2) { say "func2($_): ", func2($_) }
say '';
say "Set value for a file-wide counter, retrieve using count(): ";
for (1..2) { func1() }
say "Count is: ", count();
say "Use count() to set values as well: ";
for (1..2) { say "For #$_: ", count($_) }
This prints
Call func2(), using 'state' feature, with its own counter:
func2(1): 1
func2(2): 3
Set value for a file-wide counter, retrieve using count():
Count is: 9
Use count() to set values as well:
With 1: 10
With 2: 12
The next step up is to make this a class, and then you can implement any and all kinds of counters in very natural ways.
For more on variables, see this post and this post and this Effective Perler article, for starters.
† An our variable is strictly speaking not a global, but a lexical that is aliased to a package variable (a "true" global) with the same name.
I think there's a better way to do what I'm guessing that you want to do. I think that you want to try something a certain number of times and give up if you can't acheive that goal.
When you call your subroutine, you want it to know how many times to try. Also, you want to know when it fails.
You don't need to share a variable for this. The die is going to take care of that for you. Call the sub as many times as you like, and each time you don't get back a value from eval, count that as an error:
my $errors = 0;
foreach ( 1 .. 10 ) {
my $result = eval { do_this($age) };
$errors++ unless defined $result;
}
print "Script fails" if $errors > 0;
In the subroutine, you don't need to worry about how many times this has been done because that's happening at the higher level for you. You look at the result of the subroutine to decide if it failed and adjust a counter at the higher level. Now the subroutine can focus on it's small part instead of thinking about why you are calling it. You also don't need the eval at this level because you already have it at the higher level.
sub do_this {
my( $age ) = #_;
... some file handling ...
}
Factories
But let's say that there is some good reason for a lower subroutine to know its count. I don't want to pollute that subroutine for everyone—suppose that 10 other places in the program also call this subroutine and they all fail. Should that count against your call? You probably don't want that. But, there's a way around this. You can create a new version of the subroutine when you need to. A factory is a subroutine that makes other subroutines.
Let's say you want to try something a certain number of times. But, you might want to do that multiple times too. Make a new subroutine every time that you want to try this. Tell that subroutine how many tries it gets:
sub some_factory {
my( $max_tries ) = #_;
sub anon_thingy {
my( $age ) = #_;
for ( 1 .. $max_tries ) {
... file handling ... or die ...
}
}
}
Your program would then look something like:
my $try_this = some_factory( 10 );
my $result = eval { $try_this->($age) };
print "Script fails" unless defined $result;
In the same program, you can do it again, and each generated code reference tracks its own use and doesn't bother other subs:
foreach $age ( list_of_ages() ) {
my $new_sub = some_factory( 10 );
my $result = eval { $new_sub->($age) };
print "Script fails" unless defined $result;
}
I spend quite a bit of time on this sort of stuff in Intermediate Perl and Mastering Perl.
This question already has answers here:
How can I elegantly call a Perl subroutine whose name is held in a variable?
(12 answers)
Closed 6 years ago.
Let say I have one array that contains all subroutine name and I want to call all one by one.
foreach $sub (#arr){
print "Calling $sub\n";
#---How to call $sub?----
&$sub; ## will not work
}
Your code is correct in general, but you need to turn off strict 'refs' to make Perl allow you to use variable content as code refs.
use strict;
use warnings;
sub foo { print "foo" }
sub bar { print "bar" }
my #arr = qw/foo bar/;
foreach my $sub (#arr) {
no strict 'refs';
print "Calling $sub\n";
&$sub();
}
The output here is:
Calling foo
fooCalling bar
bar
I've also added parenthesis () after the call. That way we pass no arguments to %$sub. If we do not those, the #_ argument list of the current subroutine will be used.
However, you should probably not do this. Especially if #arr contains user input, this is a big problem. Your user can inject code. Consider this:
my #arr = qw/CORE::die/;
Now we get the following output:
Calling CORE::die
Died at /home/code/scratch.pl line 1492.
Oops. You don't want to do this. The die example is not very bad, but like this you could easily call code in some different package that wasn't intended.
It's probably better to make a dispatch table. There is a whole chapter about those in Higher Order Perl by Mark Jason Dominus, which you can download for free on his website.
It basically means you put all the subs into a hash as code references, and then call those in your loop. That way you can control which ones are allowed.
use strict;
use warnings;
sub baz { print "baz" }
my %dispatch = (
foo => sub { print "foo" },
bar => sub { print "bar" },
baz => \&baz,
);
my #arr = qw/foo bar baz wrong_entry/;
foreach my $sub ( #arr ) {
die "$sub is not allowed"
unless exists $dispatch{$sub};
$dispatch{$sub}->();
}
This outputs:
foobarbaz
wrong_entry is not allowed at /home/code/scratch.pl line 1494.
You want to do that using code references.
foreach my $sub (#arr)
{
$sub->();
}
where #arr contains scalars such as
my $rc = sub { print "Anonymous subroutine\n" };
or
sub func { print "Named sub\n" }
my $rc = \&func;
You can manipulate these scalars as you would any other, to form your array. However, it is more common and useful to use them as values in a hash, creating a dispatch table.
See perlref and perlsub, and (for example) this post and links in it for comments and details.
I want to add the return value from the function call to an array iff something is returned (not by default, i.e. if I have a return statement in the subroutine.)
so I'm using unshift #{$errors}, "HashValidator::$vfunction($hashref)"; but this actually adds the string of the function call to the array. I also tried unshift #{$errors}, $temp if defined my $temp = "HashValidator::$vfunction($hashref)"; with the same result. What would a perl one-liner look like that does this efficiently (I know I can do the ugly, multi-line check but I want to learn).
Thanks,
iff something is returned (not by
default, i.e. if I have a return
statement in the subroutine.)
There could be a gotcha here. Perl always returns something, even if you don't mean to:
my $failures = 0;
sub word_to_number {
my $_ = shift;
/one/ and return 1;
/two/ and return 2;
++$failures; # whoops, equivalent to return ++$failures
}
The last expression in a sub is used as the return value if there is no explicit return. To return "nothing", use bare return, which returns undef or the empty list, depending on context:
my $failures = 0;
sub word_to_number {
my $_ = shift;
/one/ and return 1;
/two/ and return 2;
++$failures;
return;
}
This behaviour is actually useful for things like sorting:
my #results = sort { $a->name cmp $b->name } #list;
where we have passed in the anonymous subroutine:
{
$a->name cmp $b->name # equivalent to return $a->name cmp $b->name
}
In this case, there is no need to use the string form of eval (or any form for that matter). Not only is it slow, but it also can silently trap errors and could lead to untrusted code execution if used with a tainted input. To write a virtual function call in Perl, you can either work with the symbol table directly, or use a symbolic reference:
use 5.010;
use warnings;
use strict;
{package HashValidator;
sub test_ok {exists $_[0]{ok}}
sub test_fail {exists $_[0]{fail}}
}
my $hashref = {ok => 1};
my $errors;
for my $vFunction qw(test_ok test_fail) {
# to call the function:
say "glob deref: $vFunction: ", $HashValidator::{$vFunction}->($hashref);
{no strict 'refs';
say "symbolic: $vFunction: ", &{"HashValidator::$vFunction"}($hashref)}
# to conditionally use the result (if it is a true boolean value):
if (my $ret = $HashValidator::{$vFunction}->($hashref)) {
push #$errors, $ret;
}
# or to keep the function call in list context:
push #$errors, grep $_, $HashValidator::{$vFunction}->($hashref);
# or to golf it:
push #$errors, $HashValidator::{$vFunction}->($hashref) || ();
}
say #$errors.': ', join ', ' => #$errors;
which prints:
glob deref: test_ok: 1
symbolic: test_ok: 1
glob deref: test_fail:
symbolic: test_fail:
3: 1, 1, 1
If you are working with object oriented code, virtual method calls are even easier, with no symbol table or symbolic references:
$obj->$vMethod(...)
try using eval:
push #{$errors}, eval "HashValidator::$vfunction($hashref)"
The following works for me with perl 5.12, and checks for undef return values:
my $foo = "foo";
my $val = eval "Foo::$foo()"
push #arry,$val if ($val);
Imagine this subroutine:
sub test(&&)
{
my $cr1 = shift;
my $cr2 = shift;
$cr1->();
$cr2->();
}
I know I can call it like: test(\&sub1,\&sub2), but how can I call it like:
test { print 1 },{ print 2 };
If I say that the subroutine takes only one &, than sending a block will work. I don't know how to make it work with 2.
If I try to run it like that, I get:
Not enough arguments for main::test at script.pl line 38, near "},"
EDIT: is there no way of invoking without sub?
You need to explicitly say
test( sub { print 1 }, sub { print 2 } );
or
test { print 1 } sub { print 2 };
The implicit "sub" is only available for the first argument. http://perldoc.perl.org/perlsub.html#Prototypes:
An & requires an anonymous subroutine, which, if passed as the first argument, does not require the sub keyword or a subsequent comma.
Some things use an extra word in there to fake it:
test { print 1 } against { print 2 };
sub against (&) { $_[0] }
sub test (&#) { ... }
but I've never liked that much.
You can do this:
test(sub { print 1 }, sub { print 2 });
I've got the following code in one of my programs:
sub generate($$$$)
{
my ($paramRef, $waypointCodeRef, $headerRef,
$debugCodeRef) = #_;
...
&$headerRef();
...
my $used = &$waypointCodeRef(\%record);
And I call it with
CreateDB::generate(\%param, \&wayPointCode, \&doHeader, \&debugCode);
If you really want to bend the syntax more then take look at Devel::Declare
Examples of modules that use Devel::Declare:
MooseX::Declare (GitHub repo)
Test::Class::Sugar (GitHub repo)
PerlX::MethodCallWithBlock (GitHub repo)
Full list of modules on CPAN dependant on Devel::Declare can be found via CPANTS
Here is example from Test::Class::Sugar pod:
use Test::Class::Sugar;
testclass exercises Person {
# Test::Most has been magically included
startup >> 1 {
use_ok $test->subject;
}
test autonaming {
is ref($test), 'Test::Person';
}
test the naming of parts {
is $test->current_method, 'test_the_naming_of_parts';
}
test multiple assertions >> 2 {
is ref($test), 'Test::Person';
is $test->current_method, 'test_multiple_assertions';
}
}
Test::Class->runtests;
And here is something sexy from PerlX::MethodCallWithBlock pod:
use PerlX::MethodCallWithBlock;
Foo->bar(1, 2, 3) {
say "and a block";
};
Devel::Declare is a much more robust and saner way of contorting your Perl code compared to using a source filter like Filter::Simple.
Here is a video from its author which may help a bit more.
/I3az/