Perl: $SIG{__DIE__}, eval { } and stack trace - perl

I have a piece of Perl code somewhat like the following (strongly simplified): There are some levels of nested subroutine calls (actually, methods), and some of the inner ones do their own exception handling:
sub outer { middle() }
sub middle {
eval { inner() };
if ( my $x = $# ) { # caught exception
if (ref $x eq 'ARRAY') {
print "we can handle this ...";
}
else {
die $x; # rethrow
}
}
}
sub inner { die "OH NOES!" }
Now I want to change that code so that it does the following:
print a full stack trace for every exception that "bubbles up" all the way to the outermost level (sub outer). Specifically, the stack trace should not stop at the first level of "eval { }".
Not having to change the the implementation of any of the inner levels.
Right now, the way I do this is to install a localized __DIE__ handler inside the outer sub:
use Devel::StackTrace;
sub outer {
local $SIG{__DIE__} = sub {
my $error = shift;
my $trace = Devel::StackTrace->new;
print "Error: $error\n",
"Stack Trace:\n",
$trace->as_string;
};
middle();
}
[EDIT: I made a mistake, the code above actually doesn't work the way I want, it actually bypasses the exception handling of the middle sub. So I guess the question should really be: Is the behaviour I want even possible?]
This works perfectly, the only problem is that, if I understand the docs correctly, it relies on behaviour that is explicitly deprecated, namely the fact that __DIE__ handlers are triggered even for "die"s inside of "eval { }"s, which they really shouldn't. Both perlvar and perlsub state that this behaviour might be removed in future versions of Perl.
Is there another way I can achieve this without relying on deprecated behaviour, or is it save to rely on even if the docs say otherwise?

UPDATE: I changed the code to override die globally so that exceptions from other packages can be caught as well.
Does the following do what you want?
#!/usr/bin/perl
use strict;
use warnings;
use Devel::StackTrace;
use ex::override GLOBAL_die => sub {
local *__ANON__ = "custom_die";
warn (
'Error: ', #_, "\n",
"Stack trace:\n",
Devel::StackTrace->new(no_refs => 1)->as_string, "\n",
);
exit 1;
};
use M; # dummy module to functions dying in other modules
outer();
sub outer {
middle( #_ );
M::n(); # M::n dies
}
sub middle {
eval { inner(#_) };
if ( my $x = $# ) { # caught exception
if (ref $x eq 'ARRAY') {
print "we can handle this ...";
}
else {
die $x; # rethrow
}
}
}
sub inner { die "OH NOES!" }

It is not safe to rely on anything that the documentation says is deprecated. The behavior could (and likely will) change in a future release. Relying on deprecated behavior locks you into the version of Perl you're running today.
Unfortunately, I don't see a way around this that meets your criteria. The "right" solution is to modify the inner methods to call Carp::confess instead of die and drop the custom $SIG{__DIE__} handler.
use strict;
use warnings;
use Carp qw'confess';
outer();
sub outer { middle(#_) }
sub middle { eval { inner() }; die $# if $# }
sub inner { confess("OH NOES!") }
__END__
OH NOES! at c:\temp\foo.pl line 11
main::inner() called at c:\temp\foo.pl line 9
eval {...} called at c:\temp\foo.pl line 9
main::middle() called at c:\temp\foo.pl line 7
main::outer() called at c:\temp\foo.pl line 5
Since you're dieing anyway, you may not need to trap the call to inner(). (You don't in your example, your actual code may differ.)
In your example you're trying to return data via $#. You can't do that. Use
my $x = eval { inner(#_) };
instead. (I'm assuming this is just an error in simplifying the code enough to post it here.)

Note that overriding die will only catch actual calls to die, not Perl errors like dereferencing undef.
I don't think the general case is possible; the entire point of eval is to consume errors. You MIGHT be able to rely on the deprecated behavior for exactly this reason: there's no other way to do this at the moment. But I can't find any reasonable way to get a stack trace in every case without potentially breaking whatever error-handling code already exists however far down the stack.

Related

Why does "try" not cause an undefined subroutine error?

A couple of times I've ran into the situation where I've forgotten to load the Try::Tiny module in my script and I've still used its try-catch block, like this:
#!/usr/bin/env perl
use strict;
use warnings;
try {
call_a( 'x' );
} catch {
die "ACTUALLY die $_";
};
sub call_a {
die "Yes, I will";
}
For some reason, the script works fine without giving any hints that there is no try. No Undefined subroutine errors. This makes me wonder why my raised exceptions are not caught.
Why does this work silently, without an error?
EDIT
I looked into symbol table as well:
say "$_: %main::{ $_ }" for keys %main::;
and found there no try. Also I tried to call it as main::try in the script above, and it caused also no errors.
This is due to the indirect-object syntax, and is a more elaborate variation on this example.
The "indirect object notation" allows code
PackageName->method(#args);
to be written as
method PackageName #args;
So the "try" and "catch" words don't matter. The interesting bit here is the more involved and extended syntax, with two parts, each in this indirect object notation.
The code in question in fact has method BLOCK LIST form, but that also goes by indirect object syntax into (do BLOCK)->method(LIST), where do BLOCK needs to produce a name of a package or a blessed (object) reference for a meaningful method call. This is seen below in Deparse output.
Using B::Deparse compiler backend (via O module) on this code
use strict;
use warnings;
use feature 'say';
try { call_a( 'x' ) }
catch {
die "ACTUALLY die";
#say "NO DONT die";
};
sub call_a {
die "Yes it dies";
#say "no die";
}
as perl -MO=Deparse script.pl should show a very close approximation of what runs:
use warnings;
use strict;
use feature 'say';
try {
call_a('x')
} do {
die 'ACTUALLY die'
}->catch;
sub call_a {
use warnings;
use strict;
use feature 'say';
die 'Yes it dies';
}
undef_sub.pl syntax OK
The nested indirect object syntax is apparently too much for Deparse which still leaves method BLOCK LIST form in the output. The equivalent code can be spelled out as
(do { call_a('x') })->try( (do { die("ACTUALLY die") })->catch() );
what in this case is more simply
call_a('x')->try( die("ACTUALLY die")->catch() );
Thus the original code is interpreted as valid syntax (!) and it is the contents of the block after try (call_a('x')) that runs first --- so the program dies and never gets to go for the "method" try.
It gets more interesting if we change the example to
use strict;
use warnings;
use feature 'say';
try { call_a( 'x' ) }
catch {
#die "ACTUALLY die";
say "NO DONT die";
};
sub call_a {
#die "Yes it dies";
say "no die";
}
with no die-ing anywhere. Run it with -MO=Deparse to see
use warnings;
use strict;
use feature 'say';
try {
call_a('x')
} (catch {
say 'NO DONT die'
} );
sub call_a {
use warnings;
use strict;
use feature 'say';
say 'no die';
}
undef_sub.pl syntax OK
which is now in a straight-up method {} args syntax (with args itself shown by Deparse in an indirect object notation as well).
The equivalent code is
call_a('x')->try( say("NO DONT die")->catch() );
where first the call_a() goes and, after it returns, then the code for the argument list in the try method call runs next. We aren't running into a die and an actual run goes as
no die
NO DONT die
Can't call method "catch" without a package or object reference at ...
So now a problem with the method "catch" does come up.
Thanks to ikegami for comments
If the block above were to return a name of a package (or object reference) which does have a method catch then the try would finally be attempted as well
use strict;
use warnings;
use feature 'say';
BEGIN {
package Catch;
sub catch { say "In ", (caller(0))[3] };
$INC{"Catch.pm"} = 1;
};
use Catch;
try { call_a( 'x' ) }
catch {
say "NO DONT die";
"Catch";
};
sub call_a { say "no die" }
Now we have the equivalent
call_a('x')->try( do { say("NO DONT die"); 'Catch' }->catch() );
with the output
no die
NO DONT die
In Catch::catch
Can't call method "try" without a package or object reference at undef_sub.pl line 14.

How can I force exiting a perl subroutine/closure via last/next to fail the program automatically?

Given the following fully functional perl script and module:
tx_exec.pl:
#!/usr/bin/perl
use strict; # make sure $PWD is in your PERL5LIB
# no warnings!
use tx_exec qw(tx_exec);
tx_exec ("normal", sub { return "foobar"; });
tx_exec ("die", sub { die "barbaz\n"; });
tx_exec ("last", sub { last; });
tx_exec ("next", sub { next; });
tx_exec.pm:
package tx_exec;
use strict;
use warnings;
require Exporter;
our #ISA = qw(Exporter);
our #EXPORT_OK = qw(tx_exec);
my $MAX_TRIES = 3;
sub tx_exec {
my ($desc, $sub, $args) = #_;
print "\ntx_exec($desc):\n";
my $try = 0;
while (1) {
$try++;
my $sub_ret;
my $ok = eval {
# start transaction
$sub_ret = $sub->($args);
# commit transaction
1;
};
unless ($ok) {
print "failed with error: $#";
# rollback transaction
if ($try >= $MAX_TRIES) {
print "failed after $try tries\n";
return (undef, undef);
}
print "try #$try failed, retrying...\n";
next;
}
# some cleanup
print "returning (1, ".($sub_ret//'<undef>').")\n";
return (1, $sub_ret);
}
}
I get the following output:
$ ./tx_exec.pl
tx_exec(normal):
returning (1, foobar)
tx_exec(die):
failed with error: barbaz
try #1 failed, retrying...
failed with error: barbaz
try #2 failed, retrying...
failed with error: barbaz
failed after 3 tries
tx_exec(last):
tx_exec(next):
# infinite loop
I understand what is happening, and I'm getting a warning about it if I turn on warnings in the script defining the closures. However, can I force the program to fail/die automatically/idiomatically, when next/last would exit a closure-subroutine like here, under the following strict circumstances:
The $sub being passed is a closure and not a simple function (a simple function dies on bare next/last anyway, which is trivial to handle)
The library code (tx_exec) and the client code (invoking it) are in separate compilation units and the client does not use warnings.
Using perl 5.16.2 (without possibility of upgrading).
Here is a github gist documenting all the approaches so far:
use warnings FATAL => qw(exiting) doesn't make a difference in library code
local $SIG handler doesn't work if the call site doesn't have FATAL => qw(exiting) warning enabled
manual detection works, but is somewhat cumbersome and all over the place (nonlocalized)
ysth's approach with a bare block works best, as it catches the last/next, fully localizing manual detection and guaranteeing that nothing can go wrong (except next/last with labels, which is easier to avoid).
Short Using next/last in the sub (that caller passes as coderef) triggers an exception, if not within a "loop block." This affords an easy handling of such use, with a small change of tx_exec().
The wrong use of last/next raised in the question is a little nuanced. First, from last
last cannot be used to exit a block that returns a value such as eval {}, sub {}, or do {}, and should not be used to exit a grep or map operation.
and for doing this in a sub or eval we get a warning
Exiting subroutine via last at ...
(and for "eval"), and similarly for next. These are classified as W in perldiag and can be controlled by using/not the warnings pragma.† This fact foils attempts to make such use fatal by FATAL => 'exiting' warning or by $SIG{__WARN__} hook.
However, if such use of next or last (in a sub or eval) has no "loop block" in any enclosing scope (or call stack) then it also raises an exception.‡ The message is
Can't "last" outside a loop block...
and similarly for next. It is found in perldiag (search for outside a loop), classified as F.
Then one solution for the posed problem is to run the coderef passed by caller outside of loop blocks, and we get the interpreter to check for and alert us to (raise exception) the offending use. As the while (1) loop is there only to be able to try multiple times this can be implemented.
The coderef can be run and tested against this exception in a utility routine
sub run_coderef {
my ($sub, #args) = #_;
my $sub_ret;
my $ok = eval { $sub_ret = $sub->(#args); 1 };
if (not $ok) {
if ($# =~ /^Can't "(?:next|last)"/) { #'
die $#; # disallow such use
}
else { return } # other error, perhaps retry
}
else { return $sub_ret }
}
which can be used like
sub tx_exec {
my ($sub, #args) = #_;
my $sub_ret = run_coderef($sub, #args);
my $run_again = (defined $sub_ret) ? 0 : 1;
if ($run_again) {
my $MAX_TRIES = 3;
my $try = 0;
while (1) {
++$try;
$sub_ret = run_coderef($sub, #args);
if ( not defined $sub_ret ) { # "other error", run again
if ($try >= $MAX_TRIES) {
print "failed after $try tries\n";
return (undef, undef);
}
print "try #$try failed, retrying...\n";
next;
}
...
}
}
}
This approach makes perfect sense design wise: it allows an exception to be raised for the disallowed use, and it localizes the handling in its own sub.
The disallowed behavior is checked for really only on the first run, since after that run_coderef is called out of a loop, in which case (this) exception isn't thrown. This is fine since the repeated runs (for "allowed" failures) are executed with that same sub so it is enough to check the first use.
On the other hand, it also means that we can
run eval { $sub_ret = $sub->(#args) ... } directly in the while (1), since we have checked for bad use of last/next on the first run
Can add further cases to check for in run_coderef, making it a more rounded checker/enforcer. The first example is the Exiting warnings, which we can make fatal and check for them as well. This will be useful if warnings in the caller are enabled
This approach can be foiled but the caller would have to go out of their way toward that end.
Tested with v5.16.3 and v5.26.2.
† Btw, you can't fight a caller's decision to turn off warnings. Let them be. It's their code.
‡ This can be checked with
perl -wE'sub tt { last }; do { tt() }; say "done"'
where we get
Exiting subroutine via last at -e line 1.
Can't "last" outside a loop block at -e line
while if there is a "loopy" block
perl -wE'sub tt { last }; { do { tt() } }; say "done"'
we get to see the end of the program, no exception
Exiting subroutine via last at -e line 1.
done
The extra block { ... } "semantically identical to a loop that executes once" (next).
This can be checked for eval by printing its message in $#.
The original post, based on the expectation that only warnings are emitted
The warnings pragma is lexical, so adding per ysth comment
use warnings FATAL => 'exiting';
in the sub itself (or in eval to scope it more tightly) should work under the restrictions
sub tx_exec {
use warnings FATAL => "exiting";
my ($sub, $args) = #_;
$sub->($args);
};
since the warning fires inside the tx_exec scope. In my test the call to this with a coderef not doing last/next first runs fine, and it dies only for a later call with them.
Or, can implement it using $SIG{__WARN__} "signal" (hook)
sub tx_exec {
local $SIG{__WARN__} = sub {
die #_ if $_[0] =~ /^Exiting subroutine via (?:last|next)/;
warn #_
};
my ($sub, $args) = #_;
...
}
This is the manual approach I was mentioning in the question. So far this was the only approach that helped me cleanly handle misbehaving client code, without any assumptions or expectations.
I'd prefer, and will gladly consider, a more idiomatic approach, like the local $SIG or use warnings FATAL => 'exiting', if they work without any expectation from client code (specifically that it has warnings enabled in any form).
tx_exec.pl:
#!/usr/bin/perl
use strict;
# no warnings!
use tx_exec qw(tx_exec);
tx_exec ("normal", sub { return "foobar"; });
tx_exec ("die", sub { die "barbaz\n"; });
tx_exec ("last", sub { last; });
tx_exec ("next", sub { next; });
tx_exec.pm:
package tx_exec;
use strict;
use warnings;
require Exporter;
our #ISA = qw(Exporter);
our #EXPORT_OK = qw(tx_exec);
my $MAX_TRIES = 3;
sub tx_exec {
my ($desc, $sub, $args) = #_;
print "\ntx_exec($desc):\n";
my $try = 0;
my $running = 0;
while (1) {
$try++;
my $sub_ret;
my $ok = eval {
# start transaction
die "Usage of `next` disallowed in closure passed to tx_exec\n" if $running;
$running = 1;
$sub_ret = $sub->($args);
print "sub returned properly\n";
# commit transaction
1;
};
$running = 0;
unless ($ok) {
if ($# =~ /^Usage of `next`/) {
print $#;
return (undef, undef); # don't retry
}
print "failed with error: $#";
# rollback transaction
if ($try >= $MAX_TRIES) {
print "failed after $try tries\n";
return (undef, undef);
}
print "try #$try failed, retrying...\n";
next;
}
# some cleanup
print "returning (1, ".($sub_ret//'<undef>').")\n";
return (1, $sub_ret);
}
print "Usage of `last` disallowed in closure passed to tx_exec\n";
return (undef, undef);
}
output:
tx_exec(normal):
sub returned properly
returning (1, foobar)
tx_exec(die):
failed with error: barbaz
try #1 failed, retrying...
failed with error: barbaz
try #2 failed, retrying...
failed with error: barbaz
failed after 3 tries
tx_exec(last):
Usage of `last` disallowed in closure passed to tx_exec
tx_exec(next):
Usage of `next` disallowed in closure passed to tx_exec
For lack of #ysth's involvement in writing an answer, I'm writing the best solution I found so far, inspired by his first attempt from the comments to the question. (I will re-accept ysth's answer if he posts it later).
The eval calling the coderef needs to look like this:
my $ok = eval {
# start transaction
my $proper_return = 0;
{
$sub_ret = $sub->($args);
$proper_return = 1;
}
die "Usage of `next` or `last` disallowed in coderef passed to tx_exec\n" unless $proper_return;
# commit transaction
1;
};
The bare block is acting as a loop which will immediately exit on either next or last, so whether we land after the bare block, or within it, from calling the coderef, we can deduce whether the coderef executed next/last and act appropriately.
More on bare block semantics and their interaction with next/last can be found here.
It is left as an exercise for the reader to handle the rarely seen redo in the code above.

is it allowed to pass pipes to constructors?

I tried to do something very fancy in Perl, and I think I'm suffering the consequences. I don't know if what I was trying to do is possible, actually.
My main program creates a pipe like this:
pipe(my $pipe_reader, my $pipe_writer);
(originally it was pipe(PIPE_READER, PIPE_WRITER) but I changed to regular variables when I was trying to debug this)
Then it forks, but I think that is probably irrelevant here. The child does this:
my $response = Response->new($pipe_writer);
The constructor of Response is bare bones:
sub new {
my $class = shift;
my $writer = shift;
my $self = {
writer => $writer
};
bless($self, $class);
return($self);
}
Then later the child will write its response:
$response->respond(123, "Here is my response");
The code for respond is as follows:
sub respond {
my $self = shift;
my $number = shift;
my $text = shift;
print $self->{writer} "$number\n";
print $self->{writer} "$text\n";
close $self->{writer}
}
This triggers a strange compile error: 'String found where operator expected ... Missing operator before "$number\n"?' at the point of the first print. Of course this is the normal syntax for a print, except that I have the object property instead of a normal handle AND it happens to be a pipe, not a file handle. So now I'm wondering if I'm not allowed to do this.
From print
If you're storing handles in an array or hash, or in general whenever you're using any expression more complex than a bareword handle or a plain, unsubscripted scalar variable to retrieve it, you will have to use a block returning the filehandle value instead, ...
print { $files[$i] } "stuff\n";
print { $OK ? *STDOUT : *STDERR } "stuff\n";
(my emphasis)
So you need
print { $self->{writer} } "$number\n";
Or, per Borodin's comment
$self->{writer}->print("$number\n");
The syntax of print is special, see for example this post and this post. For one, after print must come either a "simple" filehandle or a block evaluating to one, as quoted above, to satisfy the parser.
But with the dereference (arrow) operator the filehandle is found to be an IO::File object† and so its parent's IO::Handle::print method is invoked on it.
Prior to v5.14 there had to be use IO::Handle; for this to work, though not anymore. See this post and links in it for more.
Note that print FILEHANDLE LIST is not an indirect method call,
even as it may appear to be. It is just a function call to the print builtin under rather special syntax rules. It is only with an explicit ->
that an IO::Handle method gets called.
† It is either blessed into the class as the method call is encountered (and fails), or at creation; I can't find it in docs or otherwise resolve whether filehandles are blessed at creation or on demand
perl -MScalar::Util=blessed -wE'
pipe(RD,WR);
say *WR{IO}; #--> IO::File=IO(0xe8cb58)
say blessed(WR)//"undef"; #--> undef
'
(warns of unused RD)   We can't do this with lexical filehandles as they are not in the symbol table.
But once needed a filehandle is an IO::File or IO::Handle object (depending on Perl version).

die with reference to an object that overloads bool

I'm using Data::FormValidator to deal with some data validation in DBIx::Class (via DBIx::Class::Validation). DBIC::Validation ultimately does croak $results if the validation fails, where $results is a Data::FormValidator::Results object. Unfortunately, that croak does not trigger my try/catch around the DBIC calls.
Digging around a bit, I made this simplified test case (excluding DBIC entirely):
use strict;
use Data::FormValidator;
use TryCatch; #or Try::Tiny or eval, same results for each
#setup a profile and values that fail under that profile
my $input_profile = {
required => [ qw( good_ip bad_ip ) ],
constraints => {
good_ip => 'ip_address',
bad_ip => 'ip_address',
}
};
my $validator = new Data::FormValidator({default => $input_profile});
my $input_hashref = {
'good_ip' => '127.0.0.1',
'bad_ip' => '300.23.1.1',
};
try {
my $results = $validator->check($input_hashref,'default');
die $results;
} catch (Data::FormValidator::Results $e) {
print STDERR "failed with ".scalar(#{$e->invalid('bad_ip')})." invalid\n";
}
I would expect that my catch block would get triggered. Instead, nothing happens (execution continues).
Looking at the source of the Results object, I see that it overloads bool with it's success method. Removing that fixes my issue, but I don't understand why. If that's the whole problem, is there a good way to work around it?
TL;DR
This is a bug in TryCatch. $results stringifies to the empty string and TryCatch calls if $# when it should call if defined $#.
Here's an example without Data::FormValidator:
use strict;
use warnings 'all';
use 5.010;
package Foo;
use overload '""' => sub { '' };
sub new {
bless {}, $_[0];
}
package main;
use TryCatch;
try {
my $foo = Foo->new;
die $foo;
}
catch($e) {
say "<<<$e>>>";
}
TryCatch uses Devel::Declare to inject custom code when the Perl lexer encounters certain keywords. In this case, it generates something like this:*
try;
{
local $#;
eval {
my $foo = Foo->new;
die $foo;
};
$TryCatch::Error = $#;
}
if ($TryCatch::Error) {
Since $# is the empty string, if ($TryCatch::Error) is false and the catch block is never entered.
This is a bug (one of many for TryCatch). Use eval or Try::Tiny instead (just remember to check for defined, not truthy/falsey).
* If you want to see exactly what gets injected, set the environment variable TRYCATCH_DEBUG to 1.

How can I determine if a Perl function exists at runtime?

I'm working on a test framework in Perl. As part of the tests, I may need to add precondition or postcondition checks for any given test, but not necessarily for all of them. What I've got so far is something like:
eval "&verify_precondition_TEST$n";
print $# if $#;
Unfortunately, this outputs "Undefined subroutine &verify_precondition_TEST1 called at ..." if the function does not exist.
How can I determine ahead of time whether the function exists, before trying to call it?
Package::Name->can('function')
or
*Package::Name::function{CODE}
# or no strict; *{ "Package::Name::$function" }{CODE}
or just live with the exception. If you call the function in an eval and $# is set, then you can't call the function.
Finally, it sounds like you may want Test::Class instead of writing this yourself.
Edit: defined &function_name (or the no strict; defined &{ $function_name } variant), as mentioned in the other answers, looks to be the best way. UNIVERSAL::can is best for something you're going to call as a method (stylistically), and why bother messing around with the symbol table when Perl gives you syntax to do what you want.
Learning++ :)
sub function_exists {
no strict 'refs';
my $funcname = shift;
return \&{$funcname} if defined &{$funcname};
return;
}
if (my $subref = function_exists("verify_precondition_TEST$n") {
...
}
With defined:
if (eval "defined(&verify_precondition_TEST$n)") {
eval "&verify_precondition_TEST$n";
print $# if $#;
}
else {
print "verify_precondition_TEST$n does not exist\n";
}
EDIT: hmm, I only thought of eval as it was in the question but with symbolic references brought up with Leon Timmermans, couldn't you do
if (defined(&{"verify_precondition_TEST$n"}) {
&{"verify_precondition_TEST$n"};
print $# if $#;
}
else {
print "verify_precondition_TEST$n does not exist\n";
}
even with strict?
I had used Leon's approach, but when I had multiple packages, it failed. I'm not sure precisely why; I think it relates to the propagation of scope between namespaces. This is the solution I came up with.
my %symbols = ();
my $package = __PACKAGE__; # bring it in at run-time
{
no strict;
%symbols = %{$package . "::"}; #S ee Symbol Tables on perlmod
}
print "$funcname not defined\n" if (!defined($symbols{$funcname});
References:
__PACKAGE__ reference on the perlmod page.
Packages/__PACKAGE__reference on Perl Training Australia.