"no warnings;" in a Safe compartment - perl

I am using reval from Perl's Safe module and I want to prevent it from generating warnings if the string being eval'ed can't be parsed (actually, I want to prevent it from generating any warnings at all).
For example, the following code:
use strict; use warnings;
use Safe;
use feature qw/say/;
my $cft = Safe->new;
my $x = $cft->reval(') 1' );
my $y = $cft->reval('2' );
say "x: $x";
say "y: $y";
results in:
Number found where operator expected at (eval 5) line 1, near ") 1"
(Missing operator before 1?)
Use of uninitialized value $x in concatenation (.) or string at ./test line 12.
x:
y: 2
What I'm trying to achieve is to have $x = undef and $y = 2, and no warnings.
I tried to put a "no warnings;" inside a new scope, but it has no effect on the warnings produced from within the reval (although, as pointed out by #DavidO, it silences the 'uninitialized value' warning):
use strict; use warnings;
use Safe;
use feature qw/say/;
my $cft = Safe->new;
{
no warnings;
my $x = $cft->reval(') 1' );
my $y = $cft->reval('2' );
say "x: $x";
say "y: $y";
}
I guess that somehow the 'no warnings' has to be inside the Safe compartment, so I also tried to prepend "no warnings;" to the strings being eval'ed:
use strict; use warnings;
use Safe;
use feature qw/say/;
my $cft = Safe->new;
{
my $x = $cft->reval( 'no warnings;' . ') 1' );
my $y = $cft->reval( 'no warnings;' . '2' );
say "x: $x";
say "y: $y";
}
This way reval does not issue any warnings, but both variables are undef:
Use of uninitialized value $x in concatenation (.) or string at ./test line 10.
x:
Use of uninitialized value $y in concatenation (.) or string at ./test line 11.
y:
I don't know what else to try, and I hope that the problem description was clear enough.

If you check $# you'll see that $cft->reval( 'no warnings;' . ') 1' ); failed. 'require' trapped by operation mask at (eval 5) line 1.. In other words, Safe is doing its job and preventing that code from trying to load a library.
$cft->reval( 'BEGIN { warnings->unimport; } ) 1' ); would work, presuming warnings is already loaded outside the compartment. However, that won't quiet compile time errors. Unlike eval, reval seems to let them through. Use amon's technique of quieting STDERR.

no warnings suppresses all the warnings the use warnings pragma generates. You would probably want to remove any strictures as well. But severe parsing errors will pop up any way.
If you want to execute any code, no matter how pathological, without any output to STDERR, you should locally modify the signal handler:
{
# I know what I'm doing!
local $SIG{__WARN__} = sub {}; # locally ignore any warnings
eval $code; # catches all "die"
}
or we could reopen STDERR to /dev/null:
{
# I know what I'm doing!
open my $oldSTDERR, '>&' \*STDERR or die;
close STDERR or die;
open STDERR, '>', '/dev/null' or die;
eval $code;
close STDERR or die;
open STDERR, '>&', $oldSTDERR or die;
close $oldSTDERR;
}

Related

Given a number of variables to test for definedness, how to (easily) find out the one which was left undefined?

Today I saw this piece of code:
if ( not defined($reply_address)
or not defined($from_name)
or not defined($subject)
or not defined($date) )
{
die "couldn’t glean the required information!";
}
(Jeffrey Friedl, "Mastering Regular Expressions", p. 59, 3rd ed.)
and I thought "How can I know which variable misfired?"
Of course, if there are only 4 variables to test, as in the example above, one could come up with:
if ( not defined $reply_address )
{
die "\$reply_address is not defined"
}
elsif ( not defined $from_name )
{
die "\$from_name is not defined"
}
elsif ...
But what if there are 14 variables? Or 40...?
One still needs to go through all of them, manually testing each and every one?
Isn't there a shorter, more "magical" way of telling which variable was left undefined?
You could create a table to simplify a little bit:
use strict;
use warnings;
my $reply_address = "xyz";
my $from_name;
my $subject = "test";
my $date;
my #checks = (
[\$reply_address, '$reply_adress'],
[\$from_name, '$from_name'],
[\$subject, '$subject'],
[\$date, '$date'],
);
for my $check (#checks) {
if (not defined ${$check->[0]}) {
die $check->[1] . " is not defined";
}
}
You can do what you want with symbolic references, though using them is generally not a great idea, and it can only be done with package variables, not lexically scoped variables (and lexically scoped variables are preferred to package variables -- see this answer for a brief comparison of the two).
#!/usr/bin/env perl
use strict;
use warnings;
use 5.014;
our($foo1) = 1;
our($bar1) = undef;
our($baz1) = 3;
foreach my $name (qw(foo1 bar1 baz1)) {
{
no strict 'refs';
my($value) = $$name;
warn "$name: is not defined" unless defined $value;
say "$name: <$value>";
}
}
Using warn instead of die for illustrative purposes.
</tmp> $ ./test.pl
foo1: <1>
bar1: is not defined at ./test.pl line 16.
Use of uninitialized value $value in concatenation (.) or string at ./test.pl line 17.
bar1: <>
baz1: <3>
You can also just loop through all of the variables using common code to check them:
#!/usr/bin/env perl
use strict;
use warnings;
use 5.014;
my($foo2) = 1;
my($bar2) = undef;
my($baz2) = 3;
foreach my $vardef (["foo2", $foo2], ["bar2", $bar2], ["baz2", $baz2]) {
my($name) = $vardef->[0];
my($value) = $vardef->[1];
warn "$name: is not defined" unless defined $value;
say "$name: <$value>";
}
which gives similar output:
foo2: <1>
bar2: is not defined at ./test.pl line 29.
Use of uninitialized value $value in concatenation (.) or string at ./test.pl line 30.
bar2: <>
baz2: <3>
Finally, if you can manage to get the variables into a hash, you can loop through the keys of the hash and test them that way:
#!/usr/bin/env perl
use strict;
use warnings;
use 5.014;
my($vars) = {
foo3 => 1,
bar3 => undef,
baz3 => 3,
};
foreach my $name (sort keys %$vars) {
my($value) = $vars->{$name};
warn "$name: is not defined" unless defined $value;
say "$name: <$value>";
}
I threw the sort in there because I like deterministic behavior...
bar3: is not defined at ./test.pl line 42.
Use of uninitialized value $value in concatenation (.) or string at ./test.pl line 43.
bar3: <>
baz3: <3>
foo3: <1>
If the test really was as simple as die if ! defined then I would probably just list them out:
#!/usr/bin/env perl
use strict;
use warnings;
use 5.014;
my($foo4) = 1;
my($bar4) = undef;
my($baz4) = 3;
die qq([ERROR] \$foo4 not defined\n) unless defined $foo4;
die qq([ERROR] \$bar4 not defined\n) unless defined $bar4;
die qq([ERROR] \$baz4 not defined\n) unless defined $baz4;
which just gives us:
[ERROR] $bar4 not defined
The last approach is just very straightforward and unambiguous. If the test is not as dead simple as this, then I'd go with the second approach. If you're worried about a list of 40 (or even 14) checks of this nature, then I'd look at the design.
See also this PadWalker code example for a very complicated version of the first option, but allowing lexically scoped variables.
Could be done with a string-eval:
use strict;
use warnings;
my ($reply_address, $from_name, $subject, $date) = ('', '', undef, '');
for my $var (qw(reply_address from_name subject date)) {
my $defined;
eval "\$defined = defined \$$var";
die "eval failed: $#" if $#;
die "\$$var is not defined" unless $defined;
}

Perl die with string without appending file name and line number

Is there a way of dieing in Perl in such a way that $# is not modified? As far as I can tell, die mangles the contents of $# under certain circumstances and "throws", transferring control non-locally. I just want to do the latter.
When die is a string appends the file name and line number to $# when the exceptionish object passed to die is a string (or undef).
For example,
#!/usr/bin/env perl
# foo.pl
use strict;
use warnings;
use Data::Dumper;
eval { die '1'; };
my $hash_ref = {
msg => $#,
};
print Dumper($hash_ref);
prints:
$VAR1 = {
'msg' => '1 at foo.pl line 7.
'
};
But if the argument is not a string (or undef) it isn't modified.
#!/usr/bin/env perl
# foo2.pl
use strict;
use warnings;
use Data::Dumper;
eval { die ['string-inside-arrayref']; };
my $hash_ref = {
msg => $#,
};
print Dumper($hash_ref);
This snippet produces:
$VAR1 = {
'msg' => [
'string-inside-arrayref'
]
};
perldoc -f die:
die LIST
die raises an exception. [...]
If the last element of LIST does not end in a newline, the current script line number and input line number (if any) are also printed, and a newline is supplied.
If you want to suppress the addition of file name and line number, make sure your error message ends with "\n".
To rethrow an existing exception, you can simply use die $#. Either $# is an exception object (then it won't get mangled anyway), or it is a string ending with "\n" (because the previous die will have made sure to add one if there wasn't one to begin with).

How to print code embedded in a here-doc to lexical filehandle

I'm trying to create a script that will generate perl code from a template, and I'm having trouble understanding the error being thrown and why my workaround fixes it.
This example is contrived, but it demonstrates the issue:
use strict;
use warnings;
my $name = shift; # from #ARGV
my $file = sprintf "%s.pm", $name;
open my $fh, ">", $file
or die "error: open(>, '$file'): $!";
print $fh << "MODULE";
package $name;
#
# blah blah
#
use strict;
use warnings;
require Exporter;
our \#ISA = qw| Exporter |;
our \#EXPORT = qw| |; # automatic exports
our \#EXPORT_OK = qw| |; # on-demand exports
# CODE
1;
MODULE
close $fh;
When running this script, I get the following error:
$ perl script.pl Foo
Invalid version format (non-numeric data) at script.pl line 11, near "package "
syntax error at script.pl line 11, near "package $name"
BEGIN not safe after errors--compilation aborted at script.pl line 17.
Originally this script was just printing to stdout instead of writing to file -- no errors thrown. After adding the file handling and receiving this error, I then tried to just use a bare filehandle -- again no errors thrown.
So if I merely replace "$fh" with "FH" everywhere, the script works as expected. What is it about the lexical filehandle causing this to choke?
There should be no space after << marking the here document, so
print $fh << "MODULE";
should be
print $fh <<"MODULE";
or more neatly
print $fh <<MODULE;
or perhaps
print $fh (<< "MODULE");
As it is the << is being treated as a left-shift operator and Perl continues to try to compile the package statement. Finding no valid package name it tries to use $nameas a version number, and complains because it isn't one
Perl is an ambiguous language. It means that it's not always clear how it should be parsed. In some situations, perl has to guess how to parse something. There's a grammatical ambiguity in
print $fh << "MODULE";
Specifically, the << can be a left shift operator or the start of here-doc.
There are two paths you can follow to address the issue.
You can remove the ambiguity:
print $fh +<< "MODULE";
print $fh (<< "MODULE");
print { $fh } << "MODULE";
$fh->print(<< "MODULE");
You can trick perl into guessing correctly:
print $fh <<"MODULE";
Note that print $fh +<< "MODULE"; introduces an alternate ambiguity. Is + a binary or unary + operator? Thankfully, it's interpreted as a unary-+ as desired.
By the way, <<"MODULE" can be shortened to <<MODULE.

Avoid redefining a perl format in an eval

I've got a subroutine that delares a format in an eval expression. If this subroutine gets called more than once, perl warns that a format has been redefined.
This code:
use warnings;
routine();
routine();
sub routine{
my $s = "FAIL";
my $def = "format =\n#<<<<#>>>>\n\$s, \$s\n.";
eval $def;
write;
}
prints
FAIL FAIL
Format STDOUT redefined at (eval 2) line 1.
FAIL FAIL
Is it possible to delete the format declaration at the end of the subroutine?
Here is a simple solution that uses a flag to avoid redefining the format.
use strict;
use warnings;
routine();
routine();
my $format_defined;
sub routine{
my $s = "FAIL";
if (!$format_defined) {
my $def = "format =\n#<<<<#>>>>\n\$s, \$s\n.";
eval $def;
$format_defined = 1;
}
write;
}
Here is a more sophisticated solution that allows for the format to be redefined for each call. It uses a temporary filehandle in place of STDOUT that redirects the output to a scalar, which you can then print to STDOUT.
routine('FAIL');
routine('PASS');
sub routine{
my $s = shift;
format REPORT =
#<<<<#>>>>
$s, $s
.
my $report;
open my $fh, '>', \$report;
select $fh;
$~ = 'REPORT';
write;
close $fh;
select STDOUT;
print $report;
}

How can I change some specific carps into croaks in Perl?

I tried to catch a carp-warning:
carp "$start is > $end" if (warnings::enabled()); )
with eval {} but it didn't work, so I looked in the eval documentation and I discovered, that eval catches only syntax-errors, run-time-errors or executed die-statements.
How could I catch a carp warning?
#!/usr/bin/env perl
use warnings;
use strict;
use 5.012;
use List::Util qw(max min);
use Number::Range;
my #array;
my $max = 20;
print "Input (max $max): ";
my $in = <>;
$in =~ s/\s+//g;
$in =~ s/(?<=\d)-/../g;
eval {
my $range = new Number::Range( $in );
#array = sort { $a <=> $b } $range->range;
};
if ( $# =~ /\d+ is > \d+/ ) { die $# }; # catch the carp-warning doesn't work
die "Input greater than $max not allowed $!" if defined $max and max( #array ) > $max;
die "Input '0' or less not allowed $!" if min( #array ) < 1;
say "#array";
Based on your comments, my understanding is that you would like to make carp into a fatal warning.
If it is acceptable to make all carp warnings in your target package into fatal errors you can monkey-patch carp.
Carping Package:
package Foo;
use Carp;
sub annoying_sub {
carp "Whine whine whine";
}
Main program:
use Foo;
*Foo::carp = \&Foo::croak;
Foo::annoying_sub();
If you want to limit the monkey patch to a dynamic scope, you can use local:
use Foo;
Foo::annoying_sub(); # non-fatal
{ local *Foo::carp = \&Foo::croak;
Foo::annoying_sub(); # Fatal
}
carp does not die but just prints a warning, so there's nothing to catch with eval or whatever. You can, however, overwrite the warn handler locally to prevent the warning from being sent to stderr:
#!/usr/bin/env perl
use warnings;
use strict;
use Carp;
carp "Oh noes!";
{
local $SIG{__WARN__} = sub {
my ($warning) = #_;
# Replace some warnings:
if($warning =~ /replaceme/) {
print STDERR "My new warning.\n";
}
else {
print STDERR $warning;
}
# Or do nothing to silence the warning.
};
carp "Wh00t!";
carp "replaceme";
}
carp "Arrgh!";
Output:
Oh noes! at foo.pl line 8
Wh00t! at foo.pl line 25
My new warning.
Arrgh! at foo.pl line 29
In almost all cases you should prefer fixing the cause of the carp instead.