<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">#! /usr/bin/perl
# $Id: Process_VMS.pm 82648 2008-08-21 06:55:54Z johnnyw $

package PerlACE::Process;

use strict;
use POSIX "sys_wait_h";
use Cwd;
use File::Basename;
use Config;
use VmsProcess;

###############################################################################

### Chorus stuff

$PerlACE::Process::chorushostname = "localhost";
$PerlACE::Process::chorus = 0;

$PerlACE::Process::cwd = getcwd();

for(my $i = 0; $i &lt;= $#ARGV; $i++) {
    if ($ARGV[$i] eq '-chorus') {
        if (defined $ARGV[$i + 1]) {
            $PerlACE::Process::chorus = 1;
            $PerlACE::Process::chorushostname = $ARGV[$1 + 1];
        }
        else {
            print STDERR "The -chorus option requires " .
                         "the hostname of the target\n";
            exit(1);
        }

        splice(@ARGV, $i, 2);
        # Don't break from the loop just in case there
        # is an accidental duplication of the -chorus option
    }
}

###############################################################################

###  Grab signal names

my @signame;

if (defined $Config{sig_name}) {
    my $i = 0;
    foreach my $name (split (' ', $Config{sig_name})) {
        $signame[$i] = $name;
        $i++;
    }
}
else {
    my $i;
    for ($i = 0; $i &lt; 255; ++$i) {
        $signame[$i] = $i;
    }
}

###############################################################################

### Constructor and Destructor

sub new
{
    my $proto = shift;
    my $class = ref ($proto) || $proto;
    my $self = {};

    $self-&gt;{RUNNING} = 0;
    $self-&gt;{IGNOREEXESUBDIR} = 0;
    $self-&gt;{PROCESS} = undef;
    $self-&gt;{EXECUTABLE} = shift;
    $self-&gt;{ARGUMENTS} = shift;
    $self-&gt;{VALGRIND_CMD} = $ENV{"ACE_RUN_VALGRIND_CMD"};

    if (!defined $PerlACE::Process::WAIT_DELAY_FACTOR) {
         if (defined $self-&gt;{PURIFY_CMD}) {
           $PerlACE::Process::WAIT_DELAY_FACTOR = 10;
         }
         elsif (defined $self-&gt;{VALGRIND_CMD}) {
           $PerlACE::Process::WAIT_DELAY_FACTOR = 5;
         }
         else {
           $PerlACE::Process::WAIT_DELAY_FACTOR = 1;
        }
    }

    bless ($self, $class);
    return $self;
}

sub DESTROY
{
    my $self = shift;

    if ($self-&gt;{RUNNING} == 1) {
        print STDERR "ERROR: &lt;", $self-&gt;{EXECUTABLE},
                     "&gt; still running upon object destruction\n";
        $self-&gt;Kill ();
    }
}

###############################################################################

### Some Accessors

sub Executable
{
    my $self = shift;

    if (@_ != 0) {
        $self-&gt;{EXECUTABLE} = shift;
    }

    my $executable = $self-&gt;{EXECUTABLE};

    if ($self-&gt;{IGNOREEXESUBDIR}) {
        return $executable;
    }

    my $basename = basename ($executable);
    my $dirname = dirname ($executable). '/';
    if ($dirname != "") {
      $executable = $dirname.$PerlACE::Process::ExeSubDir.$basename;
    }
    else {
      $executable = $dirname.$basename;
    }

    if ( !-x $executable ) {
      if ( -x $executable.'.exe' ) {
        $executable = $executable.'.exe';
      }
    }

    return $executable;
}

sub Arguments
{
    my $self = shift;

    if (@_ != 0) {
        $self-&gt;{ARGUMENTS} = shift;
    }

    return $self-&gt;{ARGUMENTS};
}

sub CommandLine ()
{
    my $self = shift;

    my $commandline = $self-&gt;Executable ();

    if (defined $self-&gt;{ARGUMENTS}) {
        $commandline .= ' '.$self-&gt;{ARGUMENTS};
    }

    if ($PerlACE::Process::chorus == 1) {
        $commandline = "rsh "
                       . $PerlACE::Process::chorushostname
                       . " arun "
                       . $PerlACE::Process::cwd
                       . "/"
                       . $commandline;
    }

    return $commandline;
}

sub IgnoreExeSubDir
{
    my $self = shift;

    if (@_ != 0) {
        $self-&gt;{IGNOREEXESUBDIR} = shift;
    }

    return $self-&gt;{IGNOREEXESUBDIR};
}

###############################################################################

# Spawn the process and continue;

sub Spawn ()
{
    my $self = shift;

    if ($self-&gt;{RUNNING} == 1) {
        print STDERR "ERROR: Cannot Spawn: &lt;", $self-&gt;Executable (),
                     "&gt; already running\n";
        return -1;
    }

    if (!defined $self-&gt;{EXECUTABLE}) {
        print STDERR "ERROR: Cannot Spawn: No executable specified\n";
        return -1;
    }

    if ($self-&gt;{IGNOREEXESUBDIR} == 0) {
        if (!-f $self-&gt;Executable ()) {
            print STDERR "ERROR: Cannot Spawn: &lt;", $self-&gt;Executable (),
                         "&gt; not found\n";
            return -1;
        }

        if (!$PerlACE::Process::chorus &amp;&amp; !-x $self-&gt;Executable ()) {
            print STDERR "ERROR: Cannot Spawn: &lt;", $self-&gt;Executable (),
                         "&gt; not executable\n";
            return -1;
        }
    }

    {
        $self-&gt;{PROCESS} = VmsProcess::Spawn $self-&gt;{EXECUTABLE}, $self-&gt;{ARGUMENTS};
        if ($self-&gt;{PROCESS}) {
            #parent here
            bless $self;
        }
        else {
            # weird fork error
            print STDERR "ERROR: Can't spawn &lt;" . $self-&gt;CommandLine () . "&gt;: $!\n";
        }
    }
    $self-&gt;{RUNNING} = 1;
    return 0;
}

sub WaitKill ($)
{
    my $self = shift;
    my $timeout = shift;
    my $status = $self-&gt;TimedWait ($timeout);

    if ($status == -1) {
        print STDERR "ERROR: $self-&gt;{EXECUTABLE} timedout\n";
        $self-&gt;Kill ();
    }

    $self-&gt;{RUNNING} = 0;

    return $status;
}


# Do a Spawn and immediately WaitKill

sub SpawnWaitKill ($)
{
    my $self = shift;
    my $timeout = shift;

    if ($self-&gt;Spawn () == -1) {
        return -1;
    }

    return $self-&gt;WaitKill ($timeout);
}

sub TerminateWaitKill ($)
{
    my $self = shift;
    my $timeout = shift;

    if ($self-&gt;{RUNNING}) {
        print STDERR "INFO: $self-&gt;{EXECUTABLE} being killed.\n";
        kill ('TERM', $self-&gt;{PROCESS});
    }

    return $self-&gt;WaitKill ($timeout);
}

# really only for internal use
sub check_return_value ($)
{
    my $self = shift;
    my $rc = shift;

    if ($rc == 0) {
        return 0;
    }
    elsif ($rc == 0xff00) {
        print STDERR "ERROR: &lt;", $self-&gt;{EXECUTABLE},
                     "&gt; failed: $!\n";
        return ($rc &gt;&gt; 8);
    }
    elsif (($rc &amp; 0xff) == 0) {
        $rc &gt;&gt;= 8;
        return $rc;
    }

    my $dump = 0;

    if ($rc &amp; 0x80) {
        $rc &amp;= ~0x80;
        $dump = 1;
    }

    # check for ABRT, KILL or TERM
    if ($rc == 6 || $rc == 9 || $rc == 15) {
        return 0;
    }

    print STDERR "ERROR: &lt;", $self-&gt;{EXECUTABLE},
                 "&gt; exited with ";

    print STDERR "coredump from " if ($dump == 1);

    print STDERR "signal $rc : ", $signame[$rc], "\n";

    return 0;
}

sub Kill ()
{
    my $self = shift;

    if ($self-&gt;{RUNNING}) {
        kill ('KILL', $self-&gt;{PROCESS});
        waitpid ($self-&gt;{PROCESS}, 0);
        $self-&gt;check_return_value ($?);
    }

    $self-&gt;{RUNNING} = 0;
}

# Wait until a process exits.
# return -1 if the process is still alive.
sub Wait ($)
{
    my $self = shift;
    my $timeout = shift;
    if (!defined $timeout || $timeout &lt; 0) {
      waitpid ($self-&gt;{PROCESS}, 0);
    } else {
      return TimedWait($self, $timeout);
    }

}

sub TimedWait ($)
{
    my $self = shift;
    my $timeout = shift;

    $timeout *= $PerlACE::Process::WAIT_DELAY_FACTOR;

    my $status;
    my $pid = VmsProcess::TimedWaitPid ($self-&gt;{PROCESS}, $timeout, $status);
    if ($pid &gt; 0) {
      return $self-&gt;check_return_value ($status);
    }
    return -1;
}

1;
</pre></body></html>