ACE/bin/PerlACE/ProcessLVRT.pm

   1 #!/usr/bin/env perl
   2 #
   3 # ProcessLVRT - how to run ACE+TAO tests on a LabVIEW RT target.
   4 # Tests on LabVIEW RT are not executables - LabVIEW RT can't start plain
   5 # executables; the tests are built/packaged as DLLs and loaded and executed
   6 # from a DLL loaded at LabVIEW RT boot time. The DLL on the target listens
   7 # on a TCP port (8888 by default) for connections from the host. Host requests
   8 # actions using text commands to the target.
   9 #
  10 # NOTE: This module requires the Net-Telnet Perl module.
  11 #
  12 # We can FTP files to and from the LabVIEW target, but there's no NFS or
  13 # SMB shares.
  14
  15 package PerlACE::ProcessLVRT;
  16 our @ISA = "PerlACE::Process";
  17
  18 use strict;
  19 use Cwd;
  20 use English;
  21 use File::Basename;
  22 use Net::FTP;
  23 use Net::Telnet;
  24 use POSIX qw(:time_h);
  25
  26 $PerlACE::ProcessLVRT::ExeSubDir = './';
  27
  28 ### Check for -ExeSubDir commands, store the last one
  29 my @new_argv = ();
  30
  31 for(my $i = 0; $i <= $#ARGV; ++$i) {
  32     if ($ARGV[$i] eq '-ExeSubDir') {
  33         if (defined $ARGV[$i + 1]) {
  34             $PerlACE::ProcessLVRT::ExeSubDir = $ARGV[++$i].'/';
  35         }
  36         else {
  37             print STDERR "You must pass a directory with ExeSubDir\n";
  38             exit(1);
  39         }
  40     }
  41     else {
  42         push @new_argv, $ARGV[$i];
  43     }
  44 }
  45 @ARGV = @new_argv;
  46
  47 ### Constructor and Destructor
  48
  49 sub new
  50 {
  51     my $proto = shift;
  52     my $class = ref ($proto) || $proto;
  53     my $self = {};
  54
  55     $self->{TARGET} = shift;
  56     $self->{EXECUTABLE} = shift;
  57     $self->{ARGUMENTS} = shift;
  58     $self->{RUNNING} = 0;
  59     $self->{IGNOREEXESUBDIR} = 1;
  60
  61     bless ($self, $class);
  62     return $self;
  63 }
  64
  65 sub DESTROY
  66 {
  67     my $self = shift;
  68
  69     if ($self->{RUNNING} == 1) {
  70         print STDERR "ERROR: <", $self->{EXECUTABLE},
  71                      "> still running upon object destruction\n";
  72         $self->Kill ();
  73     }
  74     if (defined $self->{TELNET}) {
  75         $self->{TELNET}->close();
  76         $self->{TELNET} = undef;
  77     }
  78 }
  79
  80 ###############################################################################
  81
  82 # Adjust executable name for LabVIEW RT testing needs. These tests are DLLs.
  83
  84 sub Executable
  85 {
  86     my $self = shift;
  87
  88     if (@_ != 0) {
  89         $self->{EXECUTABLE} = shift;
  90     }
  91
  92     my $executable = $self->{EXECUTABLE};
  93
  94     my $basename = basename ($executable);
  95     my $dirname = dirname ($executable). '/';
  96     my $subdir = $PerlACE::ProcessLVRT::ExeSubDir;
  97     if (defined $self->{TARGET}) {
  98         $subdir = $self->{TARGET}->ExeSubDir();
  99     }
 100     $executable = $dirname.$subdir.$basename.".DLL";
 101     $executable =~ s/\//\\/g; # / <- # color coding issue in devenv
 102
 103     return $executable;
 104 }
 105
 106 sub Arguments
 107 {
 108     my $self = shift;
 109
 110     if (@_ != 0) {
 111         $self->{ARGUMENTS} = shift;
 112     }
 113
 114     return $self->{ARGUMENTS};
 115 }
 116
 117 sub CommandLine ()
 118 {
 119     my $self = shift;
 120
 121     my $commandline = "run " . basename($self->Executable(), ".dll");
 122     if (defined $self->{ARGUMENTS}) {
 123         $commandline .= ' '.$self->{ARGUMENTS};
 124     }
 125
 126     return $commandline;
 127 }
 128
 129 ###############################################################################
 130
 131 # Spawn the process and continue.
 132
 133 sub Spawn ()
 134 {
 135     my $self = shift;
 136
 137     if ($self->{RUNNING} == 1) {
 138         print STDERR "ERROR: Cannot Spawn: <", $self->Executable (),
 139                      "> already running\n";
 140         return -1;
 141     }
 142
 143     if (!defined $self->{EXECUTABLE}) {
 144         print STDERR "ERROR: Cannot Spawn: No executable specified\n";
 145         return -1;
 146     }
 147
 148     if ($self->{IGNOREEXESUBDIR} == 0) {
 149         if (!-f $self->Executable ()) {
 150             print STDERR "ERROR: Cannot Spawn: <", $self->Executable (),
 151                          "> not found\n";
 152             return -1;
 153         }
 154     }
 155
 156     my $status = 0;
 157
 158     my $program = $self->Executable ();
 159     my $cwdrel = dirname ($program);
 160     my $target_ace_root = $self->{TARGET}->ACE_ROOT();
 161     if (length ($cwdrel) > 0) {
 162         $cwdrel = File::Spec->abs2rel(cwd(), $target_ace_root);
 163     }
 164     else {
 165         $cwdrel = File::Spec->abs2rel($cwdrel, $target_ace_root);
 166     }
 167
 168     $self->{TARGET}->{FTP}->cwd($self->{TARGET}->{FSROOT});
 169     $self->{TARGET}->{FTP}->binary();
 170     $self->{TARGET}->{FTP}->put($program);
 171
 172     my $targethost = $self->{TARGET}->{IPNAME};
 173     my $targetport = $self->{TARGET}->{CTLPORT};
 174     $self->{TELNET} = new Net::Telnet(Errmode => 'return');
 175     if (!$self->{TELNET}->open(Host => $targethost, Port => $targetport)) {
 176         print STDERR "ERROR: target $targethost:$targetport: ",
 177                       $self->{TELNET}->errmsg(), "\n";
 178         $self->{TELNET} = undef;
 179         $self->{TARGET}->NeedReboot;
 180         $self->{TARGET}->{FTP}->delete($program);
 181         return -1;
 182     }
 183     my $cmdline = $self->CommandLine();
 184     if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 185       print "-> $cmdline\n";
 186     }
 187     $self->{TELNET}->print("$cmdline");
 188     my $reply;
 189     $reply = $self->{TELNET}->getline();
 190     if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 191       print "<- $reply\n";
 192     }
 193     if ($reply eq "OK\n") {
 194         $self->{RUNNING} = 1;
 195         return 0;
 196     }
 197     print STDERR "ERROR: can't $cmdline: " . $reply . "\n";
 198     $self->{TARGET}->{FTP}->delete($program);
 199     # Not unless can't get the response.  $self->{TARGET}->NeedReboot;
 200     return -1;
 201 }
 202
 203
 204 # Wait for the process to exit or kill after a time period
 205
 206 sub WaitKill ($)
 207 {
 208     my $self = shift;
 209     my $timeout = shift;
 210
 211     my $status = $self->TimedWait ($timeout);
 212
 213     $self->{RUNNING} = 0;
 214
 215     # If the test timed out, the target is probably toast. Don't bother
 216     # trying to get the log file until after rebooting and resetting FTP.
 217     if ($status == -1) {
 218         print STDERR "ERROR: $self->{EXECUTABLE} timedout\n";
 219         $self->Kill();
 220     }
 221
 222     # Now get the log file from the test, and delete the test from
 223     # the target. The FTP session should still be open.
 224     my $program = $self->Executable ();
 225     my $logname = basename($program,".dll") . ".log";
 226     my $target_log_path = $self->{TARGET}->{FSROOT} . "\\log\\" . $logname;
 227     $program = basename($program);
 228     $self->{TARGET}->{FTP}->delete($program);
 229     $self->{TARGET}->{FTP}->get($target_log_path,"log\\$logname");
 230     $self->{TARGET}->{FTP}->delete($target_log_path);
 231
 232     return $status;
 233 }
 234
 235
 236 # Do a Spawn and immediately WaitKill
 237
 238 sub SpawnWaitKill ($)
 239 {
 240     my $self = shift;
 241     my $timeout = shift;
 242     my $status = $self->Spawn ();
 243     if ($status == 0) {
 244         $status = $self->WaitKill ($timeout);
 245     }
 246
 247     return $status;
 248 }
 249
 250 sub TerminateWaitKill ($)
 251 {
 252     my $self = shift;
 253     my $timeout = shift;
 254
 255     if ($self->{RUNNING}) {
 256         print STDERR "INFO: $self->{EXECUTABLE} being killed.\n";
 257         $self->Kill();
 258     }
 259
 260     return $self->WaitKill ($timeout);
 261 }
 262
 263 sub Kill ()
 264 {
 265     my $self = shift;
 266
 267     if ($self->{RUNNING}) {
 268         if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 269             print "-> kill\n";
 270         }
 271         $self->{TELNET}->print("kill");
 272         # Just wait for any reply; don't care what it is.
 273         my $reply = $self->{TELNET}->getline();
 274         if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 275             print "<- $reply\n";
 276         }
 277     }
 278
 279     $self->{RUNNING} = 0;
 280     # Trying to kill a LabVIEW RT thread and recover is probably futile. Just
 281     # reboot and reset the FTP connection.
 282     if (defined $self->{TELNET}) {
 283         $self->{TELNET}->close();
 284         $self->{TELNET} = undef;
 285     }
 286     $self->{TARGET}->RebootReset;
 287 }
 288
 289 # Wait until a process exits.
 290 # return -1 if the process is still alive.
 291 sub Wait ($)
 292 {
 293     my $self = shift;
 294     my $timeout = shift;
 295     if (!defined $timeout || $timeout < 0) {
 296         if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 297             print "-> wait\n";
 298         }
 299         $self->{TELNET}->print("wait");
 300         my $reply = $self->{TELNET}->getline(Timeout => 300);
 301         $self->{RUNNING} = 0;
 302         if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 303           print "<- $reply\n";
 304         }
 305         return 0+ $reply;
 306     } else {
 307         return TimedWait($self, $timeout);
 308     }
 309
 310 }
 311
 312 sub TimedWait ($)
 313 {
 314     my $self = shift;
 315     my $timeout = shift;
 316     my $reply;
 317     if (!$self->{RUNNING}) {
 318       return -1;
 319     }
 320
 321 CHECK:
 322     while ($timeout > 0) {
 323         $self->{TELNET}->print ("status");
 324         if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 325           print "-> status\n";
 326         }
 327         $reply = $self->{TELNET}->getline(Timeout => $timeout);
 328         if (!defined $reply) {
 329             last CHECK;
 330         }
 331         if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 332           print "<- $reply\n";
 333         }
 334         if ($reply =~ /^RUNNING/) {
 335             sleep 2;
 336             $timeout -= 2;
 337             next CHECK;
 338         }
 339         # Have a status; return it.
 340         $self->{RUNNING} = 0;
 341         return 0+ $reply;
 342     }
 343
 344     return -1;
 345 }
 346
 347 ###
 348
 349 sub kill_all
 350 {
 351     my $procmask = shift;
 352     my $target = shift;
 353     ## NOT IMPLEMENTED YET
 354 }
 355
 356 1;