File Coverage

blib/lib/Sys/AlarmCall.pm

Criterion	Covered	Total	%
statement	35	48	72.9
branch	16	30	53.3
condition	2	6	33.3
subroutine	5	5	100.0
pod	1	1	100.0
total	59	90	65.5

package Sys::AlarmCall;
require Exporter;
use Carp qw(croak);
@ISA = qw(Exporter);
@EXPORT = qw(alarm_call);

use vars qw($SCALAR_ERROR $ARRAY_ERROR $TIMEOUT);

use strict;

# Documentation in pod format after __END__ token. See Perl
# man pages to convert pod format to man, html and other formats.

$Sys::AlarmCall::VERSION = 1.2;

my @ARG_STRINGS = (
'$_[0]',
'$_[0],$_[1]',
'$_[0],$_[1],$_[2]',
'$_[0],$_[1],$_[2],$_[3]',
'$_[0],$_[1],$_[2],$_[3],$_[4]',
'$_[0],$_[1],$_[2],$_[3],$_[4],$_[5]'
);

$SCALAR_ERROR = 'ERROR ';
$ARRAY_ERROR = 'ERROR';
$TIMEOUT = 'TIMEOUT';

sub _alarm_sig_handler {
    die "Sys::AlarmCall::alarm_call went off\n";
}

sub alarm_call {
    # usage('INTEGER(>,0)','FUNCTION','LIST_OF_ARGUMENTS');
    my $timeout = shift;
    my $sub = shift;
    $timeout >= 1 ||
	croak("Sys::AlarmCall::alarm_call: Fatal error - timeout argument must be positive\n");
    my($old_handler,$old_alarm,$wantarray,$remaining_alarm);
    my($eval,$alarmed);

    $old_alarm = alarm(0);
    if ( $old_alarm && ($timeout > $old_alarm) ) {
	$timeout = $old_alarm;
    }

    $wantarray = wantarray;
    $old_handler = $SIG{'ALRM'};
    $SIG{'ALRM'} = "Sys::AlarmCall::_alarm_sig_handler";
    if (defined(ref($sub)) && (ref($sub) eq 'CODE') ) {
	unshift(@_,$sub);
	$sub = '&{shift(@_)}(@_);';
    } elsif ($sub =~ m/^->/) {
	unshift(@_,$sub);
        $sub = 'shift(@_)' . $sub . '(@_);';
    } elsif ($#_ < @ARG_STRINGS) {
	;#This is because many perl inbuilt functions won't compile
	;#if you just say func(@_) - they need to be given the
	;#proper number of arguments.
	$sub .= '(' . $ARG_STRINGS[$#_] . ')' ;
    } else {
	$sub .= '(@_)';
    }

    my ($callpack) = caller;
    $eval = 'alarm(' . $timeout . ");\npackage " . $callpack . ";\n" . $sub;
    my(@results,$results);
    if ($wantarray) {
	@results = eval $eval;
    } else {
	$results = eval $eval;
    }
    $remaining_alarm = alarm(0);
    $alarmed = ($@ eq "Sys::AlarmCall::alarm_call went off\n");
    if ($alarmed) {$remaining_alarm = 0}

    $SIG{'ALRM'} = $old_handler ? $old_handler : 'DEFAULT';

    if ( $old_alarm ) {;#There was a previous alarm pending
	$old_alarm = $old_alarm - $timeout + $remaining_alarm;
	if ($old_alarm > 0) {;#Reset it, excluding the elapsed time (at least)
	    alarm($old_alarm);
	} else {;#It should have gone off already - so set it off
	    kill 'ALRM',$$;
	}
    }

    ;#Three things to think about:
    ;#1. Did the eval fail due to some compile error or die call?
    ;#2. Did the eval get timed out?
    ;#3. Do we return an array or scalar?

    if ($alarmed) {return $wantarray ? ($TIMEOUT) : $TIMEOUT}
    elsif ($@) {return $wantarray ? ($ARRAY_ERROR,$@) : $SCALAR_ERROR . $@}
    $wantarray ? @results : $results;
}


1;
__END__