<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: ProcessLVRT.pm 89840 2010-04-12 09:36:32Z mcorino $
#
# ProcessLVRT - how to run ACE+TAO tests on a LabVIEW RT target.
# Tests on LabVIEW RT are not executables - LabVIEW RT can't start plain
# executables; the tests are built/packaged as DLLs and loaded and executed
# from a DLL loaded at LabVIEW RT boot time. The DLL on the target listens
# on a TCP port (8888 by default) for connections from the host. Host requests
# actions using text commands to the target.
#
# NOTE: This module requires the Net-Telnet Perl module.
#
# We can FTP files to and from the LabVIEW target, but there's no NFS or
# SMB shares.

package PerlACE::ProcessLVRT;
our @ISA = "PerlACE::Process";

use strict;
use Cwd;
use English;
use File::Basename;
use Net::FTP;
use Net::Telnet;
use POSIX qw(:time_h);

$PerlACE::ProcessLVRT::ExeSubDir = './';

### Check for -ExeSubDir commands, store the last one
my @new_argv = ();

for(my $i = 0; $i &lt;= $#ARGV; ++$i) {
    if ($ARGV[$i] eq '-ExeSubDir') {
        if (defined $ARGV[$i + 1]) {
            $PerlACE::ProcessLVRT::ExeSubDir = $ARGV[++$i].'/';
        }
        else {
            print STDERR "You must pass a directory with ExeSubDir\n";
            exit(1);
        }
    }
    else {
        push @new_argv, $ARGV[$i];
    }
}
@ARGV = @new_argv;

### Constructor and Destructor

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

    $self-&gt;{TARGET} = shift;
    $self-&gt;{EXECUTABLE} = shift;
    $self-&gt;{ARGUMENTS} = shift;
    $self-&gt;{RUNNING} = 0;
    $self-&gt;{IGNOREEXESUBDIR} = 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 ();
    }
    if (defined $self-&gt;{TELNET}) {
        $self-&gt;{TELNET}-&gt;close();
        $self-&gt;{TELNET} = undef;
    }
}

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

# Adjust executable name for LabVIEW RT testing needs. These tests are DLLs.

sub Executable
{
    my $self = shift;

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

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

    my $basename = basename ($executable);
    my $dirname = dirname ($executable). '/';
    my $subdir = $PerlACE::ProcessLVRT::ExeSubDir;
    if (defined $self-&gt;{TARGET}) {
        $subdir = $self-&gt;{TARGET}-&gt;ExeSubDir();
    }
    $executable = $dirname.$subdir.$basename.".DLL";
    $executable =~ s/\//\\/g; # / &lt;- # color coding issue in devenv

    return $executable;
}

sub Arguments
{
    my $self = shift;

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

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

sub CommandLine ()
{
    my $self = shift;

    my $commandline = "run " . basename($self-&gt;Executable(), ".dll");
    if (defined $self-&gt;{ARGUMENTS}) {
        $commandline .= ' '.$self-&gt;{ARGUMENTS};
    }

    return $commandline;
}

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

# 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 $program = $self-&gt;Executable ();
    my $cwdrel = dirname ($program);
    my $target_ace_root = $self-&gt;{TARGET}-&gt;ACE_ROOT();
    if (length ($cwdrel) &gt; 0) {
        $cwdrel = File::Spec-&gt;abs2rel(cwd(), $target_ace_root);
    }
    else {
        $cwdrel = File::Spec-&gt;abs2rel($cwdrel, $target_ace_root);
    }

    $self-&gt;{TARGET}-&gt;{FTP}-&gt;cwd($self-&gt;{TARGET}-&gt;{FSROOT});
    $self-&gt;{TARGET}-&gt;{FTP}-&gt;binary();
    $self-&gt;{TARGET}-&gt;{FTP}-&gt;put($program);

    my $targethost = $self-&gt;{TARGET}-&gt;{IPNAME};
    my $targetport = $self-&gt;{TARGET}-&gt;{CTLPORT};
    $self-&gt;{TELNET} = new Net::Telnet(Errmode =&gt; 'return');
    if (!$self-&gt;{TELNET}-&gt;open(Host =&gt; $targethost, Port =&gt; $targetport)) {
        print STDERR "ERROR: target $targethost:$targetport: ",
                      $self-&gt;{TELNET}-&gt;errmsg(), "\n";
        $self-&gt;{TELNET} = undef;
        $self-&gt;{TARGET}-&gt;NeedReboot;
        $self-&gt;{TARGET}-&gt;{FTP}-&gt;delete($program);
        return -1;
    }
    my $cmdline = $self-&gt;CommandLine();
    if (defined $ENV{'ACE_TEST_VERBOSE'}) {
      print "-&gt; $cmdline\n";
    }
    $self-&gt;{TELNET}-&gt;print("$cmdline");
    my $reply;
    $reply = $self-&gt;{TELNET}-&gt;getline();
    if (defined $ENV{'ACE_TEST_VERBOSE'}) {
      print "&lt;- $reply\n";
    }
    if ($reply eq "OK\n") {
        $self-&gt;{RUNNING} = 1;
        return 0;
    }
    print STDERR "ERROR: can't $cmdline: " . $reply . "\n";
    $self-&gt;{TARGET}-&gt;{FTP}-&gt;delete($program);
    # Not unless can't get the response.  $self-&gt;{TARGET}-&gt;NeedReboot;
    return -1;
}


# Wait for the process to exit or kill after a time period

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

    my $status = $self-&gt;TimedWait ($timeout);

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

    # If the test timed out, the target is probably toast. Don't bother
    # trying to get the log file until after rebooting and resetting FTP.
    if ($status == -1) {
        print STDERR "ERROR: $self-&gt;{EXECUTABLE} timedout\n";
        $self-&gt;Kill();
    }

    # Now get the log file from the test, and delete the test from
    # the target. The FTP session should still be open.
    my $program = $self-&gt;Executable ();
    my $logname = basename($program,".dll") . ".log";
    my $target_log_path = $self-&gt;{TARGET}-&gt;{FSROOT} . "\\log\\" . $logname;
    $program = basename($program);
    $self-&gt;{TARGET}-&gt;{FTP}-&gt;delete($program);
    $self-&gt;{TARGET}-&gt;{FTP}-&gt;get($target_log_path,"log\\$logname");
    $self-&gt;{TARGET}-&gt;{FTP}-&gt;delete($target_log_path);

    return $status;
}


# Do a Spawn and immediately WaitKill

sub SpawnWaitKill ($)
{
    my $self = shift;
    my $timeout = shift;
    my $status = $self-&gt;Spawn ();
    if ($status == 0) {
        $status = $self-&gt;WaitKill ($timeout);
    }

    return $status;
}

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

    if ($self-&gt;{RUNNING}) {
        print STDERR "INFO: $self-&gt;{EXECUTABLE} being killed.\n";
        $self-&gt;Kill();
    }

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

sub Kill ()
{
    my $self = shift;

    if ($self-&gt;{RUNNING}) {
        if (defined $ENV{'ACE_TEST_VERBOSE'}) {
            print "-&gt; kill\n";
        }
        $self-&gt;{TELNET}-&gt;print("kill");
        # Just wait for any reply; don't care what it is.
        my $reply = $self-&gt;{TELNET}-&gt;getline();
        if (defined $ENV{'ACE_TEST_VERBOSE'}) {
            print "&lt;- $reply\n";
        }
    }

    $self-&gt;{RUNNING} = 0;
    # Trying to kill a LabVIEW RT thread and recover is probably futile. Just
    # reboot and reset the FTP connection.
    if (defined $self-&gt;{TELNET}) {
        $self-&gt;{TELNET}-&gt;close();
        $self-&gt;{TELNET} = undef;
    }
    $self-&gt;{TARGET}-&gt;RebootReset;
}

# 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) {
        if (defined $ENV{'ACE_TEST_VERBOSE'}) {
            print "-&gt; wait\n";
        }
        $self-&gt;{TELNET}-&gt;print("wait");
        my $reply = $self-&gt;{TELNET}-&gt;getline(Timeout =&gt; 300);
        $self-&gt;{RUNNING} = 0;
        if (defined $ENV{'ACE_TEST_VERBOSE'}) {
          print "&lt;- $reply\n";
        }
        return 0+ $reply;
    } else {
        return TimedWait($self, $timeout);
    }

}

sub TimedWait ($)
{
    my $self = shift;
    my $timeout = shift;
    my $reply;
    if (!$self-&gt;{RUNNING}) {
      return -1;
    }

CHECK:
    while ($timeout &gt; 0) {
        $self-&gt;{TELNET}-&gt;print ("status");
        if (defined $ENV{'ACE_TEST_VERBOSE'}) {
          print "-&gt; status\n";
        }
        $reply = $self-&gt;{TELNET}-&gt;getline(Timeout =&gt; $timeout);
        if (!defined $reply) {
            last CHECK;
        }
        if (defined $ENV{'ACE_TEST_VERBOSE'}) {
          print "&lt;- $reply\n";
        }
        if ($reply =~ /^RUNNING/) {
            sleep 2;
            $timeout -= 2;
            next CHECK;
        }
        # Have a status; return it.
        $self-&gt;{RUNNING} = 0;
        return 0+ $reply;
    }

    return -1;
}

###

sub kill_all
{
  my $procmask = shift;
  my $target = shift;
  ## NOT IMPLEMENTED YET
}

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