What does $^S mean in perl?
looking at https://perldoc.perl.org/perlvar all I can find is
Having to even think about the $^S variable in your exception handlers
is simply wrong.
perl -e 'print qq|What does "\$^S":$^S mean in perl?\n Thank you\n|'
perlvar actually says the following for $^S:
Current state of the interpreter.
$^S State
--------- -------------------------------------
undef Parsing module, eval, or main program
true (1) Executing an eval or try block
false (0) Otherwise
The first state may happen in $SIG{__DIE__} and $SIG{__WARN__} handlers.
Say you want to decorate exceptions with a timestamp, but only those that aren't caught to avoid breaking anything or having multiple timestamps added.
$ perl -e'
use POSIX qw( strftime );
# Decorate error messages, part 1.
local $SIG{ __DIE__ } = sub {
# Avoid exiting prematurely.
return if $^S;
my $ts = strftime( "%FT%TZ", gmtime() );
print( STDERR "[$ts] $_[0]" );
exit( $! || $? >> 8 || 255 );
};
# Decorate error messages, part 2.
local $SIG{ __WARN__ } = sub {
# Avoid mangling exceptions that are being handled.
return if $^S;
my $ts = strftime( "%FT%TZ", gmtime() );
print( STDERR "[$ts] $_[0]" );
};
eval {
die( "Some caught exception\n" );
};
if ( $# ) {
warn( "Caught: $#" );
}
die( "Some uncaught exception\n" );
'
[2022-12-15T05:57:44Z] Caught: Some caught exception
[2022-12-15T05:57:44Z] Some uncaught exception
Without checking $^S, we would have exited prematurely.
It's a bit further down on perlvar.
Current state of the interpreter.
$^S State
--------- -------------------------------------
undef Parsing module, eval, or main program
true (1) Executing an eval or try block
false (0) Otherwise
Confusingly, the variable's full use English name is $EXCEPTIONS_BEING_CAUGHT, despite, as the documentation goes on to admit, the fact that the variable really doesn't inform you as to whether or not an exception is being caught.
Related
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.
I would like to use IPC::Run to communicate with child via child's STDIN, STDOUT and STDERR (start, pump, finish). It seems to work.
I would like to know how to detect
premature child exit (e.g. caused by errors)
pipes closed by the child
The pump throws a die on errors, or writes its message to STDERR if "called after all harnessed activities have completed." See right before ROUTINES section and pump itself. The second case can come about if the child exited. So wrap the pump call in eval, and also convert warnings to die to catch both cases
if ($talk_to_child)
{
eval {
local $SIG{__WARN__} = sub { die "pump WARNING: #_" };
pump $harness;
};
if ($#) {
print $#;
$talk_to_child = 0;
};
}
# ... and eval {} for finish()
But this alone won't cut it: when a parent tries to write to a child that exited it gets a SIGPIPE, which outright terminates the process. The same goes when a child closes streams and the parent attempts to write. So also install a signal handler for SIGPIPE
$SIG{PIPE} = sub {
say "$_[0]: $!";
$talk_to_child = 0; # global
};
so that the parent survives the SIGPIPE. Consider local-izing the change to the global %SIG by doing local $SIG{PIPE} = ... instead, a good practice even just on general principle. On the other hand, there's good sense in globally handling a signal that can terminate you out of blue (even in cases where the handler may decide to exit).
The eval is still needed even as $SIG{PIPE} is handled since pump throws, too.
These together take care of all tests I came up with, practically as they stand. Still, some processing in the handler and in eval is needed to distinguish cases of interest if that is wanted.
If this adds up to too much another way is to check before each call. See this post for one-line checks (wrapped in subs) of: (1) whether a child is running, using result, and (2) whether "there are open I/O channels or active processes", using pumpable.
I think that you want both, and also throw in the SIGPIPE handler. That should cover it.
I cannot be more specific here since the question doesn't provide specifics.
Update: Thanks to #zdim for reminding me to check the SIGPIPE signal. Here is an update of my answer that also checks SIGPIPE:
I did a simple test using start, pump, and finish. Here is the main script p.pl that I used:
use feature qw(say);
use strict;
use warnings;
use IPC::Run;
my $child_in;
my $child_out;
my $child_err;
my $child_name = shift;
my $harness = eval {
IPC::Run::start [ $child_name ], \$child_in, \$child_out, \$child_err;
};
if ( $# ) {
chomp $#;
die "Caught exception: '$#'";
}
for (1..2) {
$child_in = "Joe$_\n";
say "Parent sleeping for 1 second..";
sleep 1;
eval {
local $SIG{PIPE} = sub {
die "Parent received SIGPIPE. "
. "Child is either dead or has closed its input pipe\n";
};
say "Sending data to child..";
my $result = $harness->pump;
say "IPC::Run::pump() returned: ", $result ? "TRUE" : "FALSE";
};
if ( $# ) {
chomp $#;
say "IPC::Run::pump() failed: '$#'";
last;
}
say "\$child_in = '$child_in'";
say "\$child_out = '$child_out'";
}
say "Finishing harness..";
my $res = eval {
local $SIG{PIPE} = sub {
die "Parent received SIGPIPE. "
. "Child is either dead or has closed its input pipe\n";
};
$harness->finish;
};
if ( $# ) {
chomp $#;
die "IPC::Run::finish() failed: '$#'\n";
}
printf "IPC::Run::finish() returned: '%s'\n", $res ? "TRUE" : "FALSE";
chomp $child_out;
say "STDOUT from child: '$child_out'";
chomp $child_err;
say "STDERR from child: '$child_err'";
say "Child returned exit code: ", $harness->result;
say "Parent exited normally.."
I used three different child scripts:
child.pl:
#! /usr/bin/env perl
use feature qw(say);
use strict;
use warnings;
my $reply = <STDIN>;
chomp $reply;
say "Hello $reply";
my $reply2 = <STDIN>;
chomp $reply2;
say "Got second reply: $reply2";
exit 0;
and output:
$ p.pl child.pl
Parent sleeping for 1 second..
Sending data to child..
IPC::Run::pump() returned: TRUE
$child_in = ''
$child_out = ''
Parent sleeping for 1 second..
Sending data to child..
IPC::Run::pump() returned: TRUE
$child_in = ''
$child_out = ''
Finishing harness..
IPC::Run::finish() returned: 'TRUE'
STDOUT from child: 'Hello Joe1
Got second reply: Joe2'
STDERR from child: ''
Child returned exit code:
Parent exited normally..
child2.pl:
#! /usr/bin/env perl
use feature qw(say);
use strict;
use warnings;
my $reply = <STDIN>;
chomp $reply;
say "Hello $reply";
die "Child exception\n";
and output:
$ p.pl child2.pl
Parent sleeping for 1 second..
Sending data to child..
IPC::Run::pump() returned: TRUE
$child_in = ''
$child_out = ''
Parent sleeping for 1 second..
Sending data to child..
IPC::Run::pump() failed: 'Parent received SIGPIPE. Child is either dead or has closed its input pipe'
Finishing harness..
IPC::Run::finish() failed: 'Parent received SIGPIPE. Child is either dead or has closed its input pipe'
child3.pl:
#! /usr/bin/env perl
use strict;
use warnings;
close \*STDIN;
close \*STDOUT;
close \*STDERR;
sleep 5;
exit 2;
and output:
$ p.pl child3.pl
Parent sleeping for 1 second..
Sending data to child..
IPC::Run::pump() failed: 'ack Parent received SIGPIPE. Child is either dead or has closed its input pipe'
Finishing harness..
IPC::Run::finish() failed: 'Parent received SIGPIPE. Child is either dead or has closed its input pipe'
So for these tests, it seems that the SIGPIPE signal can be used to check if a child is a alive or has closed its input pipe. Note that if you try to call pump() after a child has exited, the previous output from the child is lost, see the child2.pl example.
If I set RaiseError = 1, what exception is raised when connecting or executing?
If I were to surround my execute() method in try catch, what exception should I be catching?
The Perl Error.pm module, which provides try and catch, is deprecated. Exceptions, inasmuch as they exist in Perl, are untyped, and here's how you catch one:
eval {
do_something_which_may_throw_exception();
};
if ($#) {
print "Exception: $#\n";
};
In short, the eval { ... } block acts as a "try", and the if ($#) { ... } acts as a "catch", wherein the exception text is contained in the special variable $#.
The DBI documentation lists and explains a lot of options, many of which relate to error handling.
Perl has two major error handling idioms:
Returning a false value. The reason for the error is in some global variable.
die with some error message (fatal).
By default, DBI uses the first idiom. The error reason is in $DBI::errstr. For this to work, you have to check the return values of each and every call to the DBI API.
When you feel lazy, you can use exceptions. Setting RaiseError in the handle constructor will make DBI methods throw an exception. From the docs:
RaiseError
Type: boolean, inherited
The RaiseError attribute can be used to force errors to raise exceptions rather than simply return error codes in the normal way. It is "off" by default. When set "on", any method which results in an error will cause the DBI to effectively do a die("$class $method failed: $DBI::errstr"), where $class is the driver class and $method is the name of the method that failed. E.g.,
DBD::Oracle::db prepare failed: ... error text here ...
[…]
Typically RaiseError is used in conjunction with eval { ... } to catch the exception that's been thrown and followed by an if ($#) { ... } block to handle the caught exception. For example:
eval {
...
$sth->execute();
...
};
if ($#) {
# $sth->err and $DBI::err will be true if error was from DBI
warn $#; # print the error
... # do whatever you need to deal with the error
}
In that eval block the $DBI::lasth variable can be useful for diagnosis and reporting if you can't be sure which handle triggered the error.
As you can see, exceptions in Perl aren't handled with try/catch, but with eval { ... }. After an eval that dies, the $# error variable will be set to that error, and you are free to handle it. Note that DBI does not use exception objects.
If you'd like to get back formal exception objects from DBI, you can use the HandleError attribute and Exception::Class::DBI. I use it myself. From the Synopsis:
use DBI;
use Exception::Class::DBI;
my $dbh = DBI->connect($dsn, $user, $pass, {
PrintError => 0,
RaiseError => 0,
HandleError => Exception::Class::DBI->handler,
});
eval { $dbh->do($sql) };
if (my $ex = $#) {
print STDERR "DBI Exception:\n";
print STDERR " Exception Type: ", ref $ex, "\n";
print STDERR " Error: ", $ex->error, "\n";
print STDERR " Err: ", $ex->err, "\n";
print STDERR " Errstr: ", $ex->errstr, "\n";
print STDERR " State: ", $ex->state, "\n";
print STDERR " Return Value: ", ($ex->retval || 'undef'), "\n";
}
[EDIT] - with the benefit of hindsight, this question was misdirected. I have not deleted it because it is a good example of the incorrect use of eval and correct criticism by Perl::Critic.
Perl Critic raises the following criticism for the code below:
Return value of eval not tested. You can't depend upon the value of $#/$EVAL_ERROR to tell whether an eval failed
my $Jet = Win32::OLE->CreateObject('DAO.DBEngine.36')
or croak "Can't create Jet database engine.";
my $DB = $Jet->OpenDatabase($DBFile)
# code omitted for the sake of brevity
# perl script writes results to Access db via an append query
$DB->Execute( $SQLquery, 128 ); #128=DBFailOnError
eval {$err = Win32::OLE->LastError()} ; #<<<< PROBLEM LINE SEE FEEDBACK BELOW
if ( $err){
print $ERROR "WIN32::OLE raised an exception: $err\n";
Win32::OLE->LastError(0); # this clears your error
}
My thinking is that I am using eval to detect the existence of the error object and on the Win32:OLE module to detects the error and reports it.
Am I safe to ignore the criticism?
Leaving aside the perl-critic issuse, your code does not make much sense.
The Win32::OLE docs explain when exceptions will be thrown (and how you can automatically catch them).
LastError just gives you information about an error after it has occurred assuming your program has not died. Wrapping it in eval is pointless.
Update: I would have written something along the following lines (untested because I am on Linux with no access to Windows right now):
use strict;
use warnings;
use Carp;
use Win32;
use Win32::OLE;
$Win32::OLE::Warn = 3;
# No need for this eval if you are OK with the default error message
my $Jet = eval {
Win32::OLE->CreateObject('DAO.DBEngine.36')
} or croak sprintf(
"Can't create Jet database engine: %s",
win32_error_message(Win32::OLE->LastError)
);
# No need for this eval if you are OK with the default error message
my $DB = eval {
$Jet->OpenDatabase($DBFile)
} or croak sprintf(
"Can't open database '$DBFile': %s",
win32_error_message(Win32::OLE->LastError)
);
my $result = eval {
$DB->Execute( $SQLquery, 128 )
};
unless (defined $result) {
print $ERROR win32_error_message(Win32::OLE->LastError);
Win32::OLE->LastError(0);
}
The meaning of that message is detailed in the documentation. In short, it tells you to not rely on $# alone after an eval, but to also check the return value of eval.
However, in your case, the problem is that you aren't checking either the return value of eval nor are you checking $# and moreover it seems that your use of eval is completely superfluous because the method you are calling shouldn't be throwing any exceptions.
This is a followup to "How can I get around a ‘die’ call in a Perl library I can’t modify?".
I have a subroutine that calls a Library-Which-Crashes-Sometimes many times. Rather than couch each call within this subroutine with an eval{}, I just allow it to die, and use an eval{} on the level that calls my subroutine:
my $status=eval{function($param);};
unless($status){print $#; next;}; # print error and go to
# next file if function() fails
However, there are error conditions that I can and do catch in function(). What is the most proper/elegant way to design the error-catching in the subroutine and the calling routine so that I get the correct behavior for both caught and uncaught errors?
Block eval can be nested:
sub function {
eval {
die "error that can be handled\n";
1;
} or do {
#propagate the error if it isn't the one we expect
die $# unless $# eq "error that can be handled\n";
#handle the error
};
die "uncaught error";
}
eval { function(); 1 } or do {
warn "caught error $#";
};
I'm not completely sure what you want to do, but I think you can do it with a handler.
$SIG{__DIE__} = sub { print $# } ;
eval{ function($param); 1 } or next;