How can a Perl force its caller to return? [duplicate] - perl

This question already has answers here:
Closed 12 years ago.
Possible Duplicate:
Is it possible for a Perl subroutine to force its caller to return?
I want to write a subroutine which causes the caller to return under certain conditions. This is meant to be used as a shortcut for validating input to a function. What I have so far is:
sub needs($$) {
my ($condition, $message) = #_;
if (not $condition) {
print "$message\n";
# would like to return from the *parent* here
}
return $condition;
}
sub run_find {
my $arg = shift #_;
needs $arg, "arg required" or return;
needs exists $lang{$arg}, "No such language: $arg" or return;
# etc.
}
The advantage of returning from the caller in needs would then be to avoid having to write the repetitive or return inside run_find and similar functions.

I think you're focussing on the wrong thing here. I do this sort of thing with Data::Constraint, Brick, etc. and talk about this in Mastering Perl. With a little cleverness and thought about the structure of your program and the dynamic features that Perl has, you don't need such a regimented, procedural approach.
However, the first thing you need to figure out is what you really want to know in that calling subroutine. If you just want to know yes or no, it's pretty easy.
The problem with your needs is that you're thinking about calling it once for every condition, which forces you to use needs to control program flow. That's the wrong way to go. needs is only there to give you an answer. It's job is not to change program state. It becomes much less useful if you misuse it because some other calling subroutine might want to continue even if needs returns false. Call it once and let it return once. The calling subroutine uses the return value to decide what it should do.
The basic structure involves a table that you pass to needs. This is your validation profile.
sub run_find {
my $arg = shift #_;
return unless needs [
[ sub { $arg }, "arg required" ],
[ sub { exists $lang{$arg} }, "No such language: $arg" ],
];
}
...
}
You construct your table for whatever your requirements are. In needs you just process the table:
sub needs($$) {
my ($table) = #_;
foreach $test ( #$table ) {
my( $sub, $message ) = #$test;
unless( $sub->(...) ) {
print $message;
return
}
}
return 1;
}
Now, the really cool thing with this approach is that you don't have to know the table ahead of time. You can pull that from configuration or some other method. That also means that you can change the table dynamically. Now your code shrinks quite a bit:
sub run_find {
my $arg = shift #_;
return unless needs( $validators{run_find} );
...
}
You cna keep going with this. In Mastering Perl I show a couple of solutions that completely remove that from the code and moves it into a configuration file. That is, you can change the business rules without changing the code.
Remember, almost any time that you are typing the same sequence of characters, you're probably doing it wrong. :)

Sounds like you are re-inventing exception handling.
The needs function should not magically deduce its parent and interrupt the parent's control flow - that's bad manners. What if you add additional functions to the call chain, and you need to go back two or even three functions back? How can you determine this programmatically? Will the caller be expecting his or her function to return early? You should follow the principle of least surprise if you want to avoid bugs - and that means using exceptions to indicate that there is a problem, and having the caller decide how to deal with it:
use Carp;
use Try::Tiny;
sub run_find {
my $arg = shift;
defined $arg or croak "arg required";
exists $lang{$arg} or croak "no such language: $arg";
...
}
sub parent {
try { run_find('foo') }
catch { print $#; }
}
Any code inside of the try block is special: if something dies, the exception is caught and stored in $#. In this case, the catch block is executed, which prints the error to STDOUT and control flow continues as normal.
Disclaimer: exception handling in Perl is a pain. I recommend Try::Tiny, which protects against many common gotchas (and provides familiar try/catch semantics) and Exception::Class to quickly make exception objects so you can distinguish between Perl's errors and your own.
For validation of arguments, you might find it easier to use a CPAN module such as Params::Validate.

You may want to look at a similar recent question by kinopiko:
Is it possible for a Perl subroutine to force its caller to return?
The executive summary for that is: best solution is to use exceptions (die/eval, Try::Tiny, etc...). You van also use GOTO and possibly Continuation::Escape

It doesn't make sense to do things this way; ironically, ya doesn't needs needs.
Here's why.
run_find is poorly written. If your first condition is true, you'll never test the second one since you'll have returned already.
The warn and die functions will provide you printing and/or exiting behavior anyway.
Here's how I would write your run_find sub if you wanted to terminate execution if your argument fails (renamed it to well_defined):
sub well_defined {
my $arg = shift;
$arg or die "arg required";
exists $lang{$arg} or die "no such language: $arg";
return 1;
}
There should be a way to return 0 and warn at the same time, but I'll need to play around with it a little more.
run_find can also be written to return 0 and the appropriate warn message if conditions are not met, and return 1 if they are (renamed to well_defined).
sub well_defined {
my $arg = shift;
$arg or warn "arg required" and return 0;
exists $lang{$arg} or warn "no such language: $arg" and return 0;
return 1;
}
This enables Boolean-esque behavior, as demonstrated below:
perform_calculation $arg if well_defined $arg; # executes only if well-defined

Related

Perl sub returns a subroutine

I haven't used Perl for around 20 years, and this is confusing me. I've g******d for it, but I obviously haven't used a suitable search string because I haven't found anything relating to this...
Why would I want to do the following? I understand what it's doing, but the "why" escapes me. Why not just return 0 or 1 to begin with?
I'm working on some code where a sub uses "return sub"; here's a very truncated example e.g.
sub test1 {
$a = shift #_;
if ($a eq "cat") {
return sub {
print("cat test OK\n");
return 0;
}
}
# default if "cat" wasn't the argument
return sub {
print("test for cat did not work\n");
return 1;
}
}
$c = test1("cat");
print ("received: $c\n");
print ("value is: ",&$c,"\n");
$c = test1("bat");
print ("received: $c\n");
print ("value is: ",&$c,"\n");
In your code there is no reason to return a sub. However, with a little tweak
sub test1 {
my $animal = shift #_;
if ($animal eq "cat" || $animal eq "dog") {
return sub {
print("$animal test OK\n");
return 0;
};
}
# default if "cat" or "dog" wasn't the argument
return sub {
print("test for cat or dog did not work\n");
return 1;
};
}
We now have a closure around $animal this saves memory as the test for cat and dog share the same code. Note that this only works with my variables. Also note that $a and $b are slightly special to Perl, they are used in the block of code that you can pass to the sort function and bypass some of the checks on visibility so it's best to avoid them for anything except sort.
You probably want to search "perl closures".
There are many reasons that you'd want to return a code reference, but it's not something I can shortly answer in a StackOverflow question. Mark Jason Dominus's Higher Order Perl is a good way to expand your mind, and we cover a little of that in Intermediate Perl.
I wrote File::Find::Closures as a way to demonstrate this is class. Each subroutine in that module returns two code references—one for the callback to File::Find and the other as a way to access the results. The two share a common variable which nothing else can access.
Notice in your case, you aren't merely calling a subroutine to "get a zero". It's doing other things. Even in your simple example there's some output. Some behavior is then deferred until you actually use the result for something.
Having said that, we have no chance of understanding why the programmer who wrote your particular code did it. One plausible guess was that the system was set up for more complex situations and you're looking at a trivial example that fits into that. Another plausible guess was that the programmer just learned that feature and fell in love with it then used it everywhere for a year. There's always a reason, but that doesn't mean there's always a good reason.

Perl:Issue passing self

I'm having an issue with a recent code review. I've been advised to change the following function call:
storeShmcoreservJobsLogs(
$self->{'shmJobDetails'},
$self->{'nhcJobDetails'},
$self->{'cppDetails'},
$self->{'siteId'},
$neTypesIdMap,
$dbh
);
To only use two arguments, being $self and $dbh. So I have coded as follows
storeShmcoreservJobsLogs($self, $dbh);
And the function signature as follows:
sub storeShmcoreservJobsLogs($$) {
my($self, $dbh) = #_;
if ( $#{$self->$shmJobDetails} > -1 ) {
The if statement unfortunately throws an error with the value of $shmJobDetails when I test the change
Global symbol "$shmJobDetails" requires explicit package name at /data/ddp/current/analysis/TOR/elasticsearch/handlers/misc/Shm.pm line 148.
So I must have misinterpreted the instruction. Is anything obvious wrong?
There's no variable $shmJobDetails so you get the compilation error. Do the same thing that you were doing before:
sub storeShmcoreservJobsLogs {
my($self,$dbh)=#_;
if ( $#{ $self->{'shmJobDetails'} } > -1 ) {
Now you're passing the complete object and the subroutine can use any part of the object it needs.
You might want to make some object methods to answer the questions you'll ask it instead of accessing its internals. That method can do all the work to figure out true or false:
sub storeShmcoreservJobsLogs {
my($self,$dbh)=#_;
if ( $self->has_jobs ) {
The use of a lexical variable called $self implies that you're using object-oriented methods, but your code is far from being object-oriented
Are you sure that you understand the points being made in the code review? It's looking like you're writing a method, and the fields should be extracted from the hash within the method
The method definition should be more like this
sub store_shmcoreserv_jobs_logs {
my $self = shift;
my ($id_map, $dbh) = #_;
my #fields = #{$self}{qw/ shmJobDetails nhcJobDetails cppDetails siteId /};
...
while the call should look like this
$self->storeShmcoreservJobsLogs($neTypesIdMap, $dbh)
All of this is essential to Perl object-oriented programming. You should study perlobj together with the rest of the Perl language reference

Why does this Perl produce "Not a CODE reference?"

I need to remove a method from the Perl symbol table at runtime. I attempted to do this using undef &Square::area, which does delete the function but leaves some traces behind. Specifically, when $square->area() is called, Perl complains that it is "Not a CODE reference" instead of "Undefined subroutine &Square::area called" which is what I expect.
You might ask, "Why does it matter? You deleted the function, why would you call it?" The answer is that I'm not calling it, Perl is. Square inherits from Rectangle, and I want the inheritance chain to pass $square->area through to &Rectangle::area, but instead of skipping Square where the method doesn't exist and then falling through to Rectangle's area(), the method call dies with "Not a CODE reference."
Oddly, this appears to only happen when &Square::area was defined by typeglob assignment (e.g. *area = sub {...}). If the function is defined using the standard sub area {} approach, the code works as expected.
Also interesting, undefining the whole glob works as expected. Just not undefining the subroutine itself.
Here's a short example that illustrates the symptom, and contrasts with correct behavior:
#!/usr/bin/env perl
use strict;
use warnings;
# This generates "Not a CODE reference". Why?
sub howdy; *howdy = sub { "Howdy!\n" };
undef &howdy;
eval { howdy };
print $#;
# Undefined subroutine &main::hi called (as expected)
sub hi { "Hi!\n" }
undef &hi;
eval { hi };
print $#;
# Undefined subroutine &main::hello called (as expected)
sub hello; *hello = sub { "Hello!\n" };
undef *hello;
eval { hello };
print $#;
Update: I have since solved this problem using Package::Stash (thanks #Ether), but I'm still confused by why it's happening in the first place. perldoc perlmod says:
package main;
sub Some_package::foo { ... } # &foo defined in Some_package
This is just a shorthand for a typeglob assignment at compile time:
BEGIN { *Some_package::foo = sub { ... } }
But it appears that it isn't just shorthand, because the two cause different behavior after undefining the function. I'd appreciate if someone could tell me whether this is a case of (1) incorrect docs, (2) bug in perl, or (3) PEBCAK.
Manipulating symbol table references yourself is bound to get you into trouble, as there are lots of little fiddly things that are hard to get right. Fortunately there is a module that does all the heavy lifting for you, Package::Stash -- so just call its methods add_package_symbol and remove_package_symbol as needed.
Another good method installer that you may want to check out is Sub::Install -- especially nice if you want to generate lots of similar functions.
As to why your approach is not correct, let's take a look at the symbol table after deleting the code reference:
sub foo { "foo!\n"}
sub howdy; *howdy = sub { "Howdy!\n" };
undef &howdy;
eval { howdy };
print $#;
use Data::Dumper;
no strict 'refs';
print Dumper(\%{"main::"});
prints (abridged):
$VAR1 = {
'howdy' => *::howdy,
'foo' => *::foo,
};
As you can see, the 'howdy' slot is still present - undefining &howdy doesn't actually do anything enough. You need to explicitly remove the glob slot, *howdy.
The reason it happens is precisely because you assigned a typeglob.
When you delete the CODE symbol, the rest of typeglob is still lingering, so when you try to execute howdy it will point to the non-CODE piece of typeglob.

How do I implement a dispatch table in a Perl OO module?

I want to put some subs that are within an OO package into an array - also within the package - to use as a dispatch table. Something like this
package Blah::Blah;
use fields 'tests';
sub new {
my($class )= #_;
my $self = fields::new($class);
$self->{'tests'} = [
$self->_sub1
,$self->_sub2
];
return $self;
}
_sub1 { ... };
_sub2 { ... };
I'm not entirely sure on the syntax for this?
$self->{'tests'} = [
$self->_sub1
,$self->_sub2
];
or
$self->{'tests'} = [
\&{$self->_sub1}
,\&{$self->_sub2}
];
or
$self->{'tests'} = [
\&{_sub1}
,\&{_sub2}
];
I don't seem to be able to get this to work within an OO package, whereas it's quite straightforward in a procedural fashion, and I haven't found any examples for OO.
Any help is much appreciated,
Iain
Your friend is can. It returns a reference to the subroutine if it exists, null otherwise. It even does it correctly walking up the OO chain.
$self->{tests} = [
$self->can('_sub1'),
$self->can('_sub2'),
];
# later
for $tn (0..$#{$self->{tests}}) {
ok defined $self->{tests}[$tn], "Function $tn is available.";
}
# and later
my $ref = $self->{tests}[0];
$self->$ref(#args1);
$ref = $self->{tests}[1];
$self->$ref(#args2);
Or, thanks to this question (which happens to be a variation of this question), you can call it directly:
$self->${\$self->{tests}[0]}(#args1);
$self->${\$self->{tests}[1]}(#args1);
Note that the \ gives us a reference to a the subref, which then gets dereferenced by the ${} after $self->. Whew!
To solve the timeliness issue brain d foy mentions, an alternative would be to simply make the {test} a subroutine itself, that returns a ref, and then you could get it at exactly the time you need it:
sub tests {
return [
$self->can('_sub1'),
$self->can('_sub2')
];
}
and then use it:
for $tn (0..$#{$self->tests()}) {
...
}
Of course, if you have to iterate over the refs anyway, you might as well just go straight for passing the reference out:
for my $ref (0..$#{$self->tests()}) {
$self->$ref(#args);
}
Although Robert P's answer might work for you, it has the problem of fixing the dispatch very early in the process. I tend to resolve the methods as late as I can, so I would leave the things in the tests array as method names until you want to use them:
$self->{tests} = [
qw( _sub1 _sub2 )
];
The strength of a dynamic language is that you can wait as long as you like to decide what's going to happen.
When you want to run them, you can go through the same process that Robert already noted. I'd add an interface to it though:
foreach my $method_name ( $obj->get_test_methods )
{
$obj->$method_name();
}
That might even be better as not tying the test to an existing method name:
foreach my $method_name ( $obj->get_test_methods )
{
$obj->run_test_named( $method_name );
}
That run_test_named could then be your dispatcher, and it can be very flexible:
sub run_test_named
{
my( $self, $name ) = #_;
# do anything you want, like in Robert's answer
}
Some things you might want to do:
Run a method on an object
Pass the object as an argument to something else
Temporarily override a test
Do nothing
etc, etc
When you separate what you decide to do from its implementation, you have a lot more freedom. Not only that, the next time you call the same test name, you can do something different.
use lib Alpha;
my $foo = Alpha::Foo->new; # indirect object syntax is deprecated
$foo->bar();
my %disp_table = ( bar => sub { $foo->bar() } );
$disp_table{bar}->(); # call it
You need a closure because you want to turn a method call into an ordinary subroutine call, so you have to capture the object you're calling the method on.
There are a few ways to do this. Your third approach is closest. That will store a reference to the two subs in the array. Then when you want to call them, you have to be sure to pass them an object as their first argument.
Is there a reason you are using the use fields construct?
if you want to create self contained test subs, you could do it this way:
$$self{test} = [
map {
my $code = $self->can($_); # retrieve a reference to the method
sub { # construct a closure that will call it
unshift #_, $self; # while passing $self as the first arg
goto &$code; # goto jumps to the method, to keep 'caller' working
}
} qw/_sub1 _sub2/
];
and then to call them
for (#{ $$self{test} }) {
eval {$_->(args for the test); 1} or die $#;
}

How can I override Perl functions, enabling multiple overrides?

some time ago, I asked This question about overriding building perl functions.
How do I do this in a way that allows multiple overrides? The following code yields an infinite recursion.
What's the proper way to do this? If I redefine a function, I don't want to step on someone else's redefinition.
package first;
my $orig_system1;
sub mysystem {
my #args = #_;
print("in first mysystem\n");
return &{$orig_system1}(#args);
}
BEGIN {
if (defined(my $orig = \&CORE::GLOBAL::system)) {
$orig_system1 = $orig;
*CORE::GLOBAL::system = \&first::mysystem;
printf("first defined\n");
} else {
printf("no orig for first\n");
}
}
package main;
system("echo hello world");
The proper way to do it is not to do it. Find some other way to accomplish what you're doing. This technique has all the problems of a global variable, squared. Unless you get your rewrite of the function exactly right, you could break all sorts of code you never even knew existed. And while you might be polite in not blowing over an existing override, somebody else probably will not be.
Overriding system is particularly touchy because it does not have a proper prototype. This is because it does things not expressible in the prototype system. This means your override cannot do some things that system can. Namely...
system {$program} #args;
This is a valid way to call system, though you need to read the exec docs to do it. You might think "oh, well I just won't do that then", but if any module that you use does it, or any module it uses does it, then you're out of luck.
That said, there's little different from overriding any other function politely. You have to trap the existing function and be sure you call it in your new one. Whether you do it before or after is up to you.
The problem in your code is that the proper way to check if a function is defined is defined &function. Taking a code ref, even of an undefined function, will always return a true code ref. I'm not sure why, maybe its like how \undef will return a scalar ref. Why calling this code ref is causing mysystem() to go infinitely recursive is anyone's guess.
There's an additional complexity in that you can't take a reference to a core function. \&CORE::system doesn't do what you mean. Nor can you get at it with a symbolic reference. So if you want to call CORE::system or an existing override depending on which is defined you can't just assign one or the other to a code ref. You have to split your logic.
Here is one way to do it.
package first;
use strict;
use warnings;
sub override_system {
my $after = shift;
my $code;
if( defined &CORE::GLOBAL::system ) {
my $original = \&CORE::GLOBAL::system;
$code = sub {
my $exit = $original->(#_);
return $after->($exit, #_);
};
}
else {
$code = sub {
my $exit = CORE::system(#_);
return $after->($exit, #_);
};
}
no warnings 'redefine';
*CORE::GLOBAL::system = $code;
}
sub mysystem {
my($exit, #args) = #_;
print("in first mysystem, got $exit and #args\n");
}
BEGIN { override_system(\&mysystem) }
package main;
system("echo hello world");
Note that I've changed mysystem() to merely be a hook that runs after the real system. It gets all the arguments and the exit code, and it can change the exit code, but it doesn't change what system() actually does. Adding before/after hooks is the only thing you can do if you want to honor an existing override. Its quite a bit safer anyway. The mess of overriding system is now in a subroutine to keep BEGIN from getting too cluttered.
You should be able to modify this for your needs.