<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: ProcessWinCE_Unix.pm 85491 2009-06-03 07:51:58Z johnnyw $

package PerlACE::ProcessVX;

use strict;
use POSIX "sys_wait_h";
use File::Basename;
use File::Spec;
use Config;
use FileHandle;
use Cwd;

eval { require Net::Telnet; };

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

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

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

# This is what GetExitCode will return if the process is still running.
my $STILL_ACTIVE = 259;

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

### Constructor and Destructor

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

    $self-&gt;{RUNNING} = 0;
    $self-&gt;{IGNOREEXESUBDIR} = 1;
    $self-&gt;{PROCESS} = undef;
    $self-&gt;{EXECUTABLE} = shift;
    $self-&gt;{ARGUMENTS} = shift;
    $self-&gt;{TARGET} = shift;
    if (!defined $PerlACE::ProcessVX::WAIT_DELAY_FACTOR) {
        $PerlACE::ProcessVX::WAIT_DELAY_FACTOR = 2;
    }
    if (!defined $PerlACE::ProcessVX::RebootCmd) {
        $PerlACE::ProcessVX::RebootCmd = "reboot 0x02";
    }
    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 ();
    }

    if (defined $ENV{'ACE_RUN_VX_IBOOT'} &amp;&amp; !defined $ENV{'ACE_RUN_VX_NO_SHUTDOWN'}) {
      # Shutdown the target to save power
      $self-&gt;iboot_cycle_power(1);
    }
}

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

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

    my $status = 0;

    my $cmdline;

    # Reboot the target if necessery
    $self-&gt;reboot();

    my $program = $self-&gt;Executable ();
    my $cwdrel = dirname ($program);
    my $prjroot = defined $ENV{"ACE_RUN_VX_PRJ_ROOT"} ? $ENV{"ACE_RUN_VX_PRJ_ROOT"} : $ENV{"ACE_ROOT"};
    if (length ($cwdrel) &gt; 0) {
        $cwdrel = File::Spec-&gt;abs2rel( cwd(), $prjroot );
    }
    else {
        $cwdrel = File::Spec-&gt;abs2rel( $cwdrel, $prjroot );
    }
    $program = basename($program, $PerlACE::ProcessVX::ExeExt);

    my @cmds;
    my $cmdnr = 0;
    my $arguments = "";
    my $prompt = '';
    my $exesubdir = defined $ENV{"ACE_RUN_VX_EXE_SUBDIR"} ? $ENV{"ACE_RUN_VX_EXE_SUBDIR"} : "";

    if (defined $ENV{"ACE_RUN_VX_STARTUP_SCRIPT"}) {
      if (defined $ENV{"ACE_RUN_VX_STARTUP_SCRIPT_ROOT"}) {
        @cmds[$cmdnr++] = 'cd "' . $ENV{'ACE_RUN_VX_STARTUP_SCRIPT_ROOT'} . '"';
      }
      @cmds[$cmdnr++] = '&lt; ' . $ENV{"ACE_RUN_VX_STARTUP_SCRIPT"};
    }

    if (defined $ENV{"ACE_RUN_VX_STARTUP_COMMAND"}) {
      @cmds[$cmdnr++] = $ENV{"ACE_RUN_VX_STARTUP_COMMAND"};
    }

        @cmds[$cmdnr++] = 'cd ' . $ENV{"ACE_RUN_VX_TGTSVR_ROOT"} . "/" . $cwdrel . "/" . $exesubdir;
        @cmds[$cmdnr++] = 'set TMPDIR=' . $ENV{"ACE_RUN_VX_TGTSVR_ROOT"} . "/" . $cwdrel;

        if (defined $ENV{'ACE_RUN_ACE_DEBUG'}) {
            @cmds[$cmdnr++] = 'set ACE_DEBUG=' . $ENV{"ACE_RUN_ACE_DEBUG"};
        }

        if (defined $ENV{'ACE_RUN_TAO_ORB_DEBUG'}) {
            @cmds[$cmdnr++] = 'set TAO_ORB_DEBUG=' . $ENV{"ACE_RUN_TAO_ORB_DEBUG"};
        }

        if (defined $ENV{'ACE_RUN_ACE_LD_SEARCH_PATH'}) {
            @cmds[$cmdnr++] = 'set ACE_LD_SEARCH_PATH=' . $ENV{"ACE_RUN_ACE_LD_SEARCH_PATH"};
        }

        my(@load_commands);
        my(@unload_commands);
        my $vxtest_file = $program . '.vxtest';
        if (handle_vxtest_file($self, $vxtest_file, \@load_commands, \@unload_commands)) {
            push @cmds, @load_commands;
            $cmdnr += scalar @load_commands;
          } else {
            print STDERR "ERROR: Cannot find &lt;", $vxtest_file, "&gt;\n";
          }

        if (defined $self-&gt;{ARGUMENTS}) {
            ($arguments = $self-&gt;{ARGUMENTS})=~ s/\"/\\\"/g;
            ($arguments = $self-&gt;{ARGUMENTS})=~ s/\'/\\\'/g;
        }
        $cmdline = $program . ' ' . $arguments;
        if (defined $ENV{'ACE_RUN_VX_TGTSRV_WORKINGDIR'}) {
            @cmds[$cmdnr++] = 'cd ' . $ENV{'ACE_RUN_VX_TGTSRV_WORKINGDIR'};
        } else {
            @cmds[$cmdnr++] = 'cd ' . $ENV{'ACE_RUN_VX_TGTSVR_ROOT'} . "/" . $cwdrel;
        }
        @cmds[$cmdnr++] = $cmdline;
        if (!defined $ENV{'ACE_TEST_VERBOSE'}) {
          push @cmds, @unload_commands;
          $cmdnr += scalar @unload_commands;
        }
        $prompt = '[\\\\].*&gt;[\ ]$';

    FORK:
    {
        if ($self-&gt;{PROCESS} = fork) {
            #parent here
            bless $self;
        }
        elsif (defined $self-&gt;{PROCESS}) {
            #child here
            my $telnet_port = $ENV{'ACE_RUN_VX_TGT_TELNET_PORT'};
            my $telnet_host = $ENV{'ACE_RUN_VX_TGT_TELNET_HOST'};
            if (!defined $telnet_host)  {
              $telnet_host = $ENV{'ACE_RUN_VX_TGTHOST'};
            }
            if (!defined $telnet_port)  {
                $telnet_port = 23;
              }
            if (defined $ENV{'ACE_TEST_VERBOSE'}) {
                print "Opening telnet connection &lt;" . $telnet_host . ":". $telnet_port . "&gt;\n";
            }
            my $t = new Net::Telnet(Timeout =&gt; 600, Errmode =&gt; 'return', Host =&gt; $telnet_host, Port =&gt; $telnet_port);
            if (!defined $t) {
              die "ERROR: Telnet failed to &lt;" . $telnet_host . ":". $telnet_port . "&gt;";
            }
            my $retries = 10;
            while ($retries--) {
              if (!$t-&gt;open()) {
                if (defined $ENV{'ACE_TEST_VERBOSE'}) {
                  print "Couldn't open telnet connection; sleeping then retrying\n";
                }
                if ($retries == 0) {
                  die "ERROR: Telnet open to &lt;" . $telnet_host . ":". $telnet_port . "&gt; " . $t-&gt;errmsg;
                }
                sleep(5);
              } else {
                last;
              }
            }

            my $target_login = $ENV{'ACE_RUN_VX_LOGIN'};
            my $target_password = $ENV{'ACE_RUN_VX_PASSWORD'};

            if (defined $target_login)  {
              $t-&gt;waitfor('/VxWorks login: $/');
              $t-&gt;print("$target_login");
            }

            if (defined $target_password)  {
              $t-&gt;waitfor('/Password: $/');
              $t-&gt;print("$target_password");
            }

            my $buf = '';
            # wait for the prompt
            while (1) {
              my $blk = $t-&gt;get;
              print $blk;
              $buf .= $blk;
              if ($buf =~ /$prompt/) {
                last;
              }
            }
            if ($buf !~ /$prompt/) {
              die "ERROR: Didn't got prompt but got &lt;$buf&gt;";
            }
            my $i = 0;
            my @lines;
            while($i &lt; $cmdnr) {
              if (defined $ENV{'ACE_TEST_VERBOSE'}) {
                print @cmds[$i]."\n";
              }
              if ($t-&gt;print (@cmds[$i++])) {
                # After each command wait for the prompt
                my $buf = '';
                while (1) {
                  my $blk = $t-&gt;get;
                  print $blk;
                  $buf .= $blk;
                  if ($buf =~ /$prompt/) {
                    last;
                  }
                }
              } else {
                print $t-&gt;errmsg;
              }
            }
            $t-&gt;close();
            sleep(2);
            exit;
        }
        elsif ($! =~ /No more process/) {
            #EAGAIN, supposedly recoverable fork error
            sleep 5;
            redo FORK;
        }
        else {
            # weird fork error
            print STDERR "ERROR: Can't fork &lt;" . $cmdline . "&gt;: $!\n";
        }
    }
    $self-&gt;{RUNNING} = 1;
    return 0;
}


# Terminate the process and wait for it to finish

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

        $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run
    }

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

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

    my $CC_MASK = 0xff00;

    # Exit code processing
    if ($rc == 0) {
        return 0;
    }
    elsif ($rc == $CC_MASK) {
        print STDERR "ERROR: &lt;", $self-&gt;{EXECUTABLE},
                     "&gt; failed: $!\n";

        $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run

        return ($rc &gt;&gt; 8);
    }
    elsif (($rc &amp; 0xff) == 0) {
        $rc &gt;&gt;= 8;
        return $rc;
    }

    # Remember Core dump flag
    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";

    $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run

    return 0;
}

sub Kill ()
{
    my $self = shift;

    if ($self-&gt;{RUNNING} &amp;&amp; !defined $ENV{'ACE_TEST_WINDOW'}) {
        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;

    if ($PerlACE::Process::WAIT_DELAY_FACTOR &gt; 0) {
      $timeout *= $PerlACE::Process::WAIT_DELAY_FACTOR;
    }

    while ($timeout-- != 0) {
        my $pid = waitpid ($self-&gt;{PROCESS}, &amp;WNOHANG);
        if ($pid != 0 &amp;&amp; $? != -1) {
            return $self-&gt;check_return_value ($?);
        }
        sleep 1;
    }

    $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run

    return -1;
}

sub handle_vxtest_file
{
  my $self = shift;
  my $vxtestfile = shift;
  my $vx_ref = shift;
  my $unld_ref = shift;
  my $fh = new FileHandle;

  if (defined $self-&gt;{TARGET} &amp;&amp; $self-&gt;{TARGET}-&gt;SystemLibs())
    {
      my @tokens = split(/;/, $self-&gt;{TARGET}-&gt;SystemLibs());
      foreach my $token (@tokens) {
        push @$vx_ref, "copy " . $ENV{"ACE_RUN_VX_TGTSVR_ROOT"} . "/lib/" . $token . " .";
      }
    }
  if (!$PerlACE::Static) {
    if (open ($fh, $vxtestfile)) {
      my $line1 = &lt;$fh&gt;;
      chomp $line1;
      while(&lt;$fh&gt;) {
        $line1 = $_;
        chomp $line1;
        push @$vx_ref, "copy " . $ENV{"ACE_RUN_VX_TGTSVR_ROOT"} . "/lib/$line1" . ".dll .";
        unshift @$unld_ref, "del $line1" . "d.dll";
      }
      close $fh;
    } else {
      return 0;
    }
  }
  return 1;
}

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