How can I catch the output from a carp in Perl? - perl

I am writing a Perl module, and I am using carp to throw a non-fatal warning back to the calling program.
The carp warning works fine - I am checking if an input parameter meets a certain condition - if it does not meet the condition, a warning is sent with carp and the module continues on using a default for the parameter instead of the one the calling program passed. The warning is just to notify that a default parameter is being used instead of the passed in parameter.
My problem is with my test script. My test script is sending in a bad parameter to the module, and I am trying to catch the warning message that comes back and make sure I got the correct warning message.
My module looks something like this:
else {
carp "value must be numeric - using default value";
}
and my test script looks like this:
eval {
#call to my module
};
like (
$#,
qr/value must be numeric/,
"Should abort on non-numeric value"
);
When I run the test, I can see the warning (it must be going to STDERR) on the screen, but the contents of the $# variable is '' - blank.
Here is the output from my test script:
t/04bad_method_calls....ok 10/12value must be numeric - using default value at ...
# Failed test 'Should abort on non-numeric value'
# at t/04bad_method_calls.t line 98.
t/04bad_method_calls....NOK 12
# '' doesn't match '(?-xism:value must be numeric)'
# Looks like you failed 1 test of 12.
If I change the carp to a croak, my test script works - it catches the error message (but I only want to warn, not abort).
To be honest, I don't have the best understanding of eval - maybe that is not the best way to catch the warning output from carp. I tried using $SIG{__WARN__}, but that was empty as well.
Is there any way to capture the output from carp? It's not the biggest deal since this is just in my test script, but I'd still like to get my test script to work properly.
Thanks in advance!

From this page, http://perldoc.perl.org/perlvar.html, it looks like you want to set the local $SIG{__WARN__} to a subroutine that will turn warnings into fatal errors for your test script. The example they give is:
local $SIG{__WARN__} = sub { die $_[0] };
eval $proggie;

Another way how to catch warnings and also all STDERR output:
my $stderr = '';
{
local *STDERR;
open STDERR, '>', \$stderr;
do_stuf_here();
}
like( $stderr, qr/my result/, 'test stderr output' );
One can make fancy test function:
sub stderr_test (&$$) {
my ( $code, $pattern, $text ) = #_;
my $result = '';
{
local *STDERR;
open STDERR, '>', \$result;
$code->();
}
if ( UNIVERSAL::isa( $pattern, 'Regexp' ) ) {
like( $result, $pattern, $text );
}
else {
is( $result, $pattern, $text );
}
}
# usage
stderr_test {do_stuf_here} qr/my expected STDERR output/,
'stderr is like';
stderr_test {do_stuf_here} 'my expected STDERR output',
'stderr is exactly';

If you're doing this from a test script, you can use of the Test::* modules that capture output for you. I tend to like Test::Output.

Related

alternate to print STDERR

I want to replace existing print STDERR statements in my codebase.
Apparently, I find them not very suitable to eyes, or is it just me. Should I be using warn knowing that It will be caught by $SIG{_WARN_} handler. Or is there any better option. And if yes, why use those options and not print STDERR.
The benefit of print STDERR is that you can see at once what will happen—you print something to STDERR. This may be a debug message, or something.
The warn function is slightly different:
It will trigger the warn handlers, and
it will append the line number, if you don't end with a newline.
You should probably use this for warnings, not for logging data
You might be also interested in the Carp family of functions. carp works like warn, but reports the line number/file from the point of call. cluck will warn with a stack trace.
But nothing prevents you from rolling your own. A functionally equivalent sub to print STDERR would be:
sub debug { print STDERR #_ }
You can now literally s/print STDERR/debug/g your source, except for that one occurence. Also, you will have to declare or import that debug function before you use it if you want to be able to leave out the parens around the arguments.
debug "this ", "is ", "DATA";
Point to consider: calling a sub is slooow, whereas print is a built-in opcode. You can trade beauty for performance, and vice versa.
Creating a debug subroutine to wrap print STDERR would give you a lot of flexibility above and beyond what simple print or warn statements provide, such as the ability to turn debugging messages off or redirect them to different destinations. For example, just off the top of my head:
sub debug {
my ($msg, %param) = #_;
$param{level} //= 1; # default if no level specified
return if $param{level} < $config{log_level};
given ($param{dest}) {
when ('mail') { send_email_to_admin(subject => "Application Error!", body => $msg) }
when ('log') { write_to_logfile($msg) }
default { print STDERR $msg }
}
}
debug('foo'); # goes to STDERR by default
$config{log_level} = 2;
debug('bar'); # message is ignored as unimportant at current logging level
debug('bar', level => 3, dest => mail); # still important; gets emailed to admin

Perl validate module before use

I am using Module::Pluggable to load modules from a given directory:
for my $module ( plugins() ) {
eval "use $module";
if ($#) {
my $error = (split(/\n/, $#))[0];
push #rplugin_errors, $error;
print STDOUT "Failed to load $module: $error\n";
} else {
print STDOUT "Loaded: $module\n";
my $mod = $module->new();
my $module_name = $mod->{name};
$classes{$module_name} = $mod;
}
}
This function can be called via a reload method elsewhere. But if a one of the modules I am trying to "use" throws an errors it's not loaded and the script is somewhat crippled.
I'd like to validate each module in plugins() before executing use. So Ideally I could do something like:
$error = 0;
for my $module ( plugins() ) {
eval TEST $module;
if ($#) {
print STDERR "$module failed. Will not continue";
$error = 1;
last;
}
}
if ($error == 0) {
for my $module ( plugins() ) {
use $module;
}
}
Change
eval TEST $module;
back to
eval "use $module";
Well, importing probably doesn't make sense here (or in your original code), so the following would be better:
eval "require $module";
I think you're overcomplicating this. Your code already includes a clause to test for errors in the use and report on them if any occur. (if ($#)... print STDOUT "Failed to load $module: $error\n";) According to your comment on ikegami's answer, your goal is that "If one fails, we halt and send a message stating the reload could not take place because of a module error." (Yes, I know you said your goal is to validate the modules before loading them. It isn't. Your goal is to halt if there's an error; you've just decided that pre-validation is the way to accomplish that. This is what we call an X-Y Problem.)
You're already detecting and reporting any errors that occur... You want to halt on error... So, when you detect an error, halt after reporting it.
if ($#) {
my $error = (split(/\n/, $#))[0];
push #rplugin_errors, $error;
die "Failed to load $module: $error\n";
} else {

Perl - Custom Error Output

I need to know how to customize my own errors in Perl. For instance, here's some code:
my $filename = 'filaname1.exe';
print "Copying $filename";
copy("$dir_root\\$filename", "$spcl_dir\\$filename");
if ($? == "0") {
print " - Success!\n";
}
else { print " - Failure!\n"; }
I tried to write this and "catch" the error and print "Failure" when I don't get an exit code of 0, and print "Success" when I do. I need to know how I can customize this; I don't really want to use die or anything like that where it will give a somewhat cryptic error (to the end user).
Thanks!
You need to read the documentation on $? in perlvar. This value is:
The status returned by the last pipe
close, backtick ("``") command,
successful call to wait() or
waitpid(), or from the system()
operator.
Your call to copy (presumably from File::Copy) doesn't far into any of those categories, so $? isn't set.
However, if you read the documentation for File::Copy, you'll see that its function all "return 1 on success, 0 on failure". So you can simplify your code a lot.
#!/usr/bin/perl
use strict; use warnings;
use File::Copy;
if (copy('notthere', 'somewhere else')) {
warn "success\n";
} else {
warn "failure: $!\n";
}
Note that I've used "warn" rather than "print" so that the errors go to STDERR. Note, also, the use of $! to display the operating system error. This can, of course, be omitted if it's not user-friendly enough.
Are you using File::Copy? You must be using something, because copy() isn't a perl keyword or built-in function.
The documentation of File::Copy doesn't refer to $? at all, so that's probably your mistake. You want to check the return value, and only if it's zero, refer to $!.
use strict;
use File::Copy qw(copy);
my ($from, $to) = #ARGV;
my $res = copy ($from, $to);
if( $res ){
print "Okay\n";
}
else{
print "Not Okay: $!\n";
}

Test::More doesn't know if test dies - so how do I test?

I'm collecting a bunch of subroutines that are common to a bunch of my scripts into a module. (I should've done this way earlier, but started out with inherited scripts.) I'm modelling my work on the very helpful example here, using Test::More and Module::Build
All of the subroutines that read or write from files all include a line open() or die "errmsg". I'm in the process of writing a test for the module and ran across this problem. One of the subroutines checks whether a path points to something or not, dying on fail. In the inherited scripts, the subroutine looks like this:
sub checkExist {
my ($type, $path) = #_;
if ($type eq 'd') {
if (! -d $path) {
warn("dir not found: $path\n");
die $pathNotFound;
}
}
elsif ($type eq 'f') {
if (! -f $path) {
warn("file not found: $path\n");
die $pathNotFound;
}
elsif (! -s $path) {
warn("empty file: $path\n");
die $emptyFile;
}
}
}
now, I'm testing this with the following line:
is(HomeBrew::IO::checkExist('f', $0), '', "can checkExist find file $0 ?");
which works fine unless I pick a path which doesn't doesn't exist, in which case the test script dies, but the test succeeds, producing the following output:
# Looks like your test exited with 2 just after 5.
Dubious, test returned 2 (wstat 512, 0x200)
All 5 subtests passed
I would prefer if this were a failing test (rather than a dubious pass), but since this is legacy code, I also want this subroutine to halt execution on fail. What to do? Is it stupid to write a test on a function this simple?
I've already written a checkExist2 function that I'll be using in the future that returns undef on success else a non-zero error (so I can write die if checkExist2() elsewhere). Other suggestions that do not maintain the functionality of checkExist are welcome.
The proper way to test if code lives, or dies with a proper error, is with Test::Exception. You can wrap this test around other test cases, since it just takes a coderef:
use Test::More;
use Test::Exception;
lives_ok {
is(HomeBrew::IO::checkExist('f', $0), '',
"can checkExist find file $0 ?")
} '...and code does not die';
Why not have a helper subroutine in your test module which wraps an eval{} around HomeBrew::IO::checkExist call and checks for a fail via $#?
sub runcheckExist {
my $res = eval { HomeBrew::IO::checkExist('f', $0) };
# May want more logic here
# for checking $# for specific error text pattern
# or $res
return $# ? 1 : 0;
}
my $expect_to_die = 1;
is(runcheckExist(), $expect_to_die, "can checkExist find file $0 ?");

Do I need to trap errors in my calls to Win32::OLE->LastError?

[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.