File Coverage

blib/lib/Cant.pm

Criterion	Covered	Total	%
statement	29	40	72.5
branch	9	20	45.0
condition	8	12	66.6
subroutine	6	6	100.0
pod	0	2	0.0
total	52	80	65.0

package Cant;

require 5.005_62;
use strict;
use warnings;

use Carp;

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Cant ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
	cant
	wcant
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
	cant
	wcant
);
our $VERSION = '1.01';

#
# cant and wcant -- print an error message and optionally die when a
#	system or library call fails.
#

sub _cant_fmt {
    my(@pre, @post, $first);
    @pre = "$0: Unable to ";
    $first = shift;
    if ($first =~ s:^\n::) {
	unshift @pre, "\n";
    }
    unshift @_, $first;
    if (substr($_[-1], -1, 1) eq "\n") {
	# Strip the newline
	@post = ( substr( pop @_, 0, -1) );
    } else {
	if ($!) {
	    # Stick the errno message on the end
	    @post = ( ": $!" );
	} elsif ($?>>8 == 0) {
	    # Do nothing.  No errno, no last program return code --
	    # it's kind of ambiguous
	} elsif (($? & 0377) == 0) {
	    # Error return from program
	    @post = ( ": program returned ", $? >> 8 );
	} elsif (($? & 0377) == 0177) {
	    # 'stopped' return from program
	    @post = ( ": program stopped with signal ", $? >> 8 );
	} else {
	    # Death by signal
	    @post = ( ": program died with signal ", $? & 0177 );
	    push @post, ", coredumped"		if $? & 0200;
	}
	my($temp) = $_[0];
	if ($temp =~ s:\n: join("", @post, "\n") :e) {
	    shift @_;
	    @post = ();
	    push @pre, $temp;
	}
    }
    (@pre, @_, @post)
}

sub cant {
    my($package, $file, $line) = caller;
    @_ = &_cant_fmt;
    if (!defined $package || $package eq "main" || $package eq "") {
	die @_, " at $file line $line\n"
    } else {
	goto &croak
    }
}

sub wcant {
    my($package, $file, $line) = caller;
    @_ = &_cant_fmt;
    if (!defined $package || $package eq "main" || $package eq "") {
	warn @_, " at $file line $line\n"
    } else {
	goto &carp
    }
}

1
__END__