view release on metacpan or  search on metacpan

lib/CPAN/Reporter.pm  view on Meta::CPAN

sub _temp_filename {
    my ($prefix) = @_;
    $prefix = q{} unless defined $prefix;
    $prefix .= $CHARS[ int( rand(@CHARS) ) ] for 0 .. 7;
    return File::Spec->catfile(File::Spec->tmpdir(), $prefix);
}

#--------------------------------------------------------------------------#
# _timeout_wrapper
# Timeout technique adapted from App::cpanminus (thank you Miyagawa!)
#--------------------------------------------------------------------------#

sub _timeout_wrapper {
    my ($cmd, $timeout) = @_;

    # protect shell quotes
    $cmd = quotemeta($cmd);

    my $wrapper = sprintf << 'HERE', $timeout, $cmd, $cmd;
use strict;
my ($pid, $exitcode);
eval {
    $pid = fork;
    if ($pid) {
        local $SIG{CHLD};
        local $SIG{ALRM} = sub {die 'Timeout'};
        alarm %s;
        my $wstat = waitpid $pid, 0;
        alarm 0;
        $exitcode = $wstat == -1 ? -1 : $?;
    } elsif ( $pid == 0 ) {
        setpgrp(0,0); # new process group
        exec "%s";
    }
    else {
      die "Cannot fork: $!\n" unless defined $pid;
    }
};
if ($pid && $@ =~ /Timeout/){
    kill -9 => $pid; # and send to our child's whole process group
    waitpid $pid, 0;
    $exitcode = 9; # force result to look like SIGKILL
}
elsif ($@) {
    die $@;
}
print "(%s exited with $exitcode)\n";
HERE
    return $wrapper;

t/13_record_command.t  view on Meta::CPAN

        exit_code => 0,
    },
    {
        label => "Exit with args and pipe",
        program => 'print qq{foo @ARGV\n}; exit 1',
        args => "bar=1 | $perl -pe 0",
        output => [ "foo bar=1\n" ],
        exit_code => 1 << 8,
    },
    {
        label => "Timeout kills process",
        program => '$now=time(); 1 while( time() - $now < 60); print qq{foo\n}; exit 0',
        args => '',
        output => [],
        delay => 60,
        timeout => 5,
        exit_code => 9,
    },
    {
        label => "Timeout not reached",
        program => '$now=time(); 1 while( time() - $now < 2); print qq{foo\n}; exit 0',
        args => '',
        output => ["foo\n"],
        delay => 2,
        timeout => 30,
        exit_code => 0,
    },
    {
        label => "Timeout not reached (quoted args)",
        program => '$now=time(); 1 while( time() - $now < 2); print qq{foo $ARGV[0]\n}; exit 0',
        args => "${quote}apples oranges bananas${quote}",
        output => [ "foo apples oranges bananas\n" ],
        delay => 2,
        timeout => 30,
        exit_code => 0,
    },
);

my $tests_per_case = 4;