view release on metacpan or  search on metacpan

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

# _special_vars_report
#--------------------------------------------------------------------------#

sub _special_vars_report {
    my $special_vars = << "HERE";
    \$^X = $^X
    \$UID/\$EUID = $< / $>
    \$GID = $(
    \$EGID = $)
HERE
    if ( $^O eq 'MSWin32' && eval "require Win32" ) { ## no critic
        my @getosversion = Win32::GetOSVersion();
        my $getosversion = join(", ", @getosversion);
        $special_vars .= "    Win32::GetOSName = " . Win32::GetOSName() . "\n";
        $special_vars .= "    Win32::GetOSVersion = $getosversion\n";
        $special_vars .= "    Win32::FsType = " . Win32::FsType() . "\n";
        $special_vars .= "    Win32::IsAdminUser = " . Win32::IsAdminUser() . "\n";
    }
    return $special_vars;
}

#--------------------------------------------------------------------------#
# _split_redirect
#--------------------------------------------------------------------------#

sub _split_redirect {
    my $command = shift;
    my ($cmd, $prefix) = ($command =~ m{\A(.+?)(\|.*)\z});
    if (defined $cmd) {
        return ($cmd, $prefix);
    }
    else { # didn't match a redirection
        return $command
    }
}

#--------------------------------------------------------------------------#
# _temp_filename -- stand-in for File::Temp for backwards compatibility
#
# takes an optional prefix, adds 8 random chars and returns
# an absolute pathname
#
# NOTE -- manual unlink required
#--------------------------------------------------------------------------#

# @CHARS from File::Temp
my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
                 a b c d e f g h i j k l m n o p q r s t u v w x y z
                 0 1 2 3 4 5 6 7 8 9 _
             /);

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;
}

#--------------------------------------------------------------------------#
# _timeout_wrapper_win32
#--------------------------------------------------------------------------#

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

    $timeout ||= 0;  # just in case upstream doesn't guarantee it

    eval "use Win32::Job ();";
    if ($@) {
        $CPAN::Frontend->mywarn( << 'HERE' );
CPAN::Reporter: you need Win32::Job for inactivity_timeout support.
Continuing without timeout...
HERE
        return;
    }

    my ($program) = split " ", $cmd;
    if (! File::Spec->file_name_is_absolute( $program ) ) {
        my $exe = $program . ".exe";
        my ($path) = grep { -e File::Spec->catfile($_,$exe) }
                     split /$Config{path_sep}/, $ENV{PATH};
        if (! $path) {
            $CPAN::Frontend->mywarn( << "HERE" );
CPAN::Reporter: can't locate $exe in the PATH.
Continuing without timeout...
HERE
            return;
        }
        $program = File::Spec->catfile($path,$exe);
    }

    # protect shell quotes and other things
    $_ = quotemeta($_) for ($program, $cmd);

    my $wrapper = sprintf << 'HERE', $program, $cmd, $timeout;
use strict;
use Win32::Job;
my $executable = "%s";
my $cmd_line = "%s";
my $timeout = %s;

my $job = Win32::Job->new() or die $^E;
my $ppid = $job->spawn($executable, $cmd_line);
$job->run($timeout);
my $status = $job->status;
my $exitcode = $status->{$ppid}{exitcode};