ACE/bin/PerlACE/ProcessWinCE_Unix.pm

   1 #!/usr/bin/env perl
   2
   3 package PerlACE::ProcessVX;
   4
   5 use strict;
   6 use POSIX "sys_wait_h";
   7 use File::Basename;
   8 use File::Spec;
   9 use Config;
  10 use FileHandle;
  11 use Cwd;
  12
  13 eval { require Net::Telnet; };
  14
  15 ###############################################################################
  16
  17 ###  Grab signal names
  18
  19 my @signame;
  20
  21 if (defined $Config{sig_name}) {
  22     my $i = 0;
  23     foreach my $name (split (' ', $Config{sig_name})) {
  24         $signame[$i] = $name;
  25         $i++;
  26     }
  27 }
  28 else {
  29     my $i;
  30     for ($i = 0; $i < 255; ++$i) {
  31         $signame[$i] = $i;
  32     }
  33 }
  34
  35 ###############################################################################
  36
  37 # This is what GetExitCode will return if the process is still running.
  38 my $STILL_ACTIVE = 259;
  39
  40 ###############################################################################
  41
  42 ### Constructor and Destructor
  43
  44 sub new
  45 {
  46     my $proto = shift;
  47     my $class = ref ($proto) || $proto;
  48     my $self = {};
  49
  50     $self->{RUNNING} = 0;
  51     $self->{IGNOREEXESUBDIR} = 1;
  52     $self->{IGNOREHOSTROOT} = 0;
  53     $self->{PROCESS} = undef;
  54     $self->{EXECUTABLE} = shift;
  55     $self->{ARGUMENTS} = shift;
  56     $self->{TARGET} = shift;
  57     if (!defined $PerlACE::ProcessVX::WAIT_DELAY_FACTOR) {
  58         $PerlACE::ProcessVX::WAIT_DELAY_FACTOR = 2;
  59     }
  60     if (!defined $PerlACE::ProcessVX::RebootCmd) {
  61         $PerlACE::ProcessVX::RebootCmd = "reboot 0x02";
  62     }
  63     bless ($self, $class);
  64     return $self;
  65 }
  66
  67 sub DESTROY
  68 {
  69     my $self = shift;
  70
  71     if ($self->{RUNNING} == 1) {
  72         print STDERR "ERROR: <", $self->{EXECUTABLE},
  73                      "> still running upon object destruction\n";
  74         $self->Kill ();
  75     }
  76
  77     if (defined $ENV{'ACE_RUN_VX_IBOOT'} && !defined $ENV{'ACE_RUN_VX_NO_SHUTDOWN'}) {
  78         # Shutdown the target to save power
  79         $self->iboot_cycle_power(1);
  80     }
  81 }
  82
  83 ###############################################################################
  84
  85 # Spawn the process and continue.
  86
  87 sub Spawn ()
  88 {
  89     my $self = shift;
  90
  91     if ($self->{RUNNING} == 1) {
  92         print STDERR "ERROR: Cannot Spawn: <", $self->Executable (),
  93                      "> already running\n";
  94         return -1;
  95     }
  96
  97     if (!defined $self->{EXECUTABLE}) {
  98         print STDERR "ERROR: Cannot Spawn: No executable specified\n";
  99         return -1;
 100     }
 101
 102     if ($self->{IGNOREEXESUBDIR} == 0) {
 103         if (!-f $self->Executable ()) {
 104             print STDERR "ERROR: Cannot Spawn: <", $self->Executable (),
 105                          "> not found\n";
 106             return -1;
 107         }
 108     }
 109
 110     my $status = 0;
 111
 112     my $cmdline;
 113
 114     # Reboot the target if necessery
 115     $self->reboot();
 116
 117     my $program = $self->Executable ();
 118     my $cwdrel = dirname ($program);
 119     my $prjroot = defined $ENV{'ACE_RUN_VX_PRJ_ROOT'} ? $ENV{'ACE_RUN_VX_PRJ_ROOT'} : $ENV{'ACE_ROOT'};
 120     if (length ($cwdrel) > 0) {
 121         $cwdrel = File::Spec->abs2rel( cwd(), $prjroot );
 122     }
 123     else {
 124         $cwdrel = File::Spec->abs2rel( $cwdrel, $prjroot );
 125     }
 126     $program = basename($program, $PerlACE::ProcessVX::ExeExt);
 127
 128     my @cmds;
 129     my $cmdnr = 0;
 130     my $arguments = "";
 131     my $prompt = '';
 132     my $exesubdir = defined $ENV{'ACE_RUN_VX_EXE_SUBDIR'} ? $ENV{'ACE_RUN_VX_EXE_SUBDIR'} : "";
 133
 134     if (defined $ENV{'ACE_RUN_VX_STARTUP_SCRIPT'}) {
 135         if (defined $ENV{'ACE_RUN_VX_STARTUP_SCRIPT_ROOT'}) {
 136             $cmds[$cmdnr++] = 'cd "' . $ENV{'ACE_RUN_VX_STARTUP_SCRIPT_ROOT'} . '"';
 137         }
 138         $cmds[$cmdnr++] = '< ' . $ENV{'ACE_RUN_VX_STARTUP_SCRIPT'};
 139     }
 140
 141     if (defined $ENV{'ACE_RUN_VX_STARTUP_COMMAND'}) {
 142         $cmds[$cmdnr++] = $ENV{'ACE_RUN_VX_STARTUP_COMMAND'};
 143     }
 144
 145     $cmds[$cmdnr++] = 'cd ' . $ENV{'ACE_RUN_VX_TGTSVR_ROOT'} . "/" . $cwdrel . "/" . $exesubdir;
 146     $cmds[$cmdnr++] = 'set TMPDIR=' . $ENV{'ACE_RUN_VX_TGTSVR_ROOT'} . "/" . $cwdrel;
 147
 148     if (defined $ENV{'ACE_RUN_ACE_DEBUG'}) {
 149         $cmds[$cmdnr++] = 'set ACE_DEBUG=' . $ENV{'ACE_RUN_ACE_DEBUG'};
 150     }
 151
 152     if (defined $ENV{'ACE_RUN_TAO_ORB_DEBUG'}) {
 153         $cmds[$cmdnr++] = 'set TAO_ORB_DEBUG=' . $ENV{'ACE_RUN_TAO_ORB_DEBUG'};
 154     }
 155
 156     if (defined $ENV{'ACE_RUN_ACE_LD_SEARCH_PATH'}) {
 157         $cmds[$cmdnr++] = 'set ACE_LD_SEARCH_PATH=' . $ENV{'ACE_RUN_ACE_LD_SEARCH_PATH'};
 158     }
 159
 160     my(@load_commands);
 161     my(@unload_commands);
 162     my $vxtest_file = $program . '.vxtest';
 163     if (handle_vxtest_file($self, $vxtest_file, \@load_commands, \@unload_commands)) {
 164         push @cmds, @load_commands;
 165         $cmdnr += scalar @load_commands;
 166     } else {
 167         print STDERR "ERROR: Cannot find <", $vxtest_file, ">\n";
 168     }
 169
 170     if (defined $self->{ARGUMENTS}) {
 171         ($arguments = $self->{ARGUMENTS})=~ s/\"/\\\"/g;
 172         ($arguments = $self->{ARGUMENTS})=~ s/\'/\\\'/g;
 173     }
 174
 175     $cmdline = $program . ' ' . $arguments;
 176     if (defined $ENV{'ACE_RUN_VX_TGTSRV_WORKINGDIR'}) {
 177         $cmds[$cmdnr++] = 'cd ' . $ENV{'ACE_RUN_VX_TGTSRV_WORKINGDIR'};
 178     } else {
 179         $cmds[$cmdnr++] = 'cd ' . $ENV{'ACE_RUN_VX_TGTSVR_ROOT'} . "/" . $cwdrel;
 180     }
 181     $cmds[$cmdnr++] = $cmdline;
 182     if (!defined $ENV{'ACE_TEST_VERBOSE'}) {
 183         push @cmds, @unload_commands;
 184         $cmdnr += scalar @unload_commands;
 185     }
 186     $prompt = '[\\\\].*>[\ ]$';
 187
 188     FORK: {
 189         if ($self->{PROCESS} = fork) {
 190             #parent here
 191             bless $self;
 192         }
 193         elsif (defined $self->{PROCESS}) {
 194             #child here
 195             my $telnet_port = $ENV{'ACE_RUN_VX_TGT_TELNET_PORT'};
 196             my $telnet_host = $ENV{'ACE_RUN_VX_TGT_TELNET_HOST'};
 197             if (!defined $telnet_host)  {
 198                 $telnet_host = $ENV{'ACE_RUN_VX_TGTHOST'};
 199             }
 200             if (!defined $telnet_port)  {
 201                 $telnet_port = 23;
 202               }
 203             if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 204                 print "Opening telnet connection <" . $telnet_host . ":". $telnet_port . ">\n";
 205             }
 206             my $t = new Net::Telnet(Timeout => 600, Errmode => 'return', Host => $telnet_host, Port => $telnet_port);
 207             if (!defined $t) {
 208                 die "ERROR: Telnet failed to <" . $telnet_host . ":". $telnet_port . ">";
 209             }
 210             my $retries = 10;
 211             while ($retries--) {
 212                 if (!$t->open()) {
 213                     if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 214                         print "Couldn't open telnet connection; sleeping then retrying\n";
 215                     }
 216                     if ($retries == 0) {
 217                         die "ERROR: Telnet open to <" . $telnet_host . ":". $telnet_port . "> " . $t->errmsg;
 218                     }
 219                     sleep(5);
 220                 } else {
 221                   last;
 222                 }
 223             }
 224
 225             my $target_login = $ENV{'ACE_RUN_VX_LOGIN'};
 226             my $target_password = $ENV{'ACE_RUN_VX_PASSWORD'};
 227
 228             if (defined $target_login)  {
 229                 $t->waitfor('/VxWorks login: $/');
 230                 $t->print("$target_login");
 231             }
 232
 233             if (defined $target_password)  {
 234                 $t->waitfor('/Password: $/');
 235                 $t->print("$target_password");
 236             }
 237
 238             my $buf = '';
 239             # wait for the prompt
 240             while (1) {
 241                 my $blk = $t->get;
 242                 print $blk;
 243                 $buf .= $blk;
 244                 if ($buf =~ /$prompt/) {
 245                     last;
 246                 }
 247             }
 248             if ($buf !~ /$prompt/) {
 249                 die "ERROR: Didn't got prompt but got <$buf>";
 250             }
 251             my $i = 0;
 252             my @lines;
 253             while($i < $cmdnr) {
 254                 if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 255                     print $cmds[$i]."\n";
 256                 }
 257                 if ($t->print ($cmds[$i++])) {
 258                     # After each command wait for the prompt
 259                     my $buf = '';
 260                     while (1) {
 261                         my $blk = $t->get;
 262                         print $blk;
 263                         $buf .= $blk;
 264                         if ($buf =~ /$prompt/) {
 265                             last;
 266                         }
 267                     }
 268                 } else {
 269                     print $t->errmsg;
 270                 }
 271             }
 272             $t->close();
 273             sleep(2);
 274             exit;
 275         }
 276         elsif ($! =~ /No more process/) {
 277             #EAGAIN, supposedly recoverable fork error
 278             sleep 5;
 279             redo FORK;
 280         }
 281         else {
 282             # weird fork error
 283             print STDERR "ERROR: Can't fork <" . $cmdline . ">: $!\n";
 284         }
 285     }
 286     $self->{RUNNING} = 1;
 287     return 0;
 288 }
 289
 290
 291 # Terminate the process and wait for it to finish
 292
 293 sub TerminateWaitKill ($)
 294 {
 295     my $self = shift;
 296     my $timeout = shift;
 297
 298     if ($self->{RUNNING}) {
 299         print STDERR "INFO: $self->{EXECUTABLE} being killed.\n";
 300         kill ('TERM', $self->{PROCESS});
 301
 302         $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run
 303     }
 304
 305     return $self->WaitKill ($timeout);
 306 }
 307
 308 # really only for internal use
 309 sub check_return_value ($)
 310 {
 311     my $self = shift;
 312     my $rc = shift;
 313
 314     my $CC_MASK = 0xff00;
 315
 316     # Exit code processing
 317     if ($rc == 0) {
 318         return 0;
 319     }
 320     elsif ($rc == $CC_MASK) {
 321         print STDERR "ERROR: <", $self->{EXECUTABLE},
 322                      "> failed: $!\n";
 323
 324         $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run
 325
 326         return ($rc >> 8);
 327     }
 328     elsif (($rc & 0xff) == 0) {
 329         $rc >>= 8;
 330         return $rc;
 331     }
 332
 333     # Remember Core dump flag
 334     my $dump = 0;
 335
 336     if ($rc & 0x80) {
 337         $rc &= ~0x80;
 338         $dump = 1;
 339     }
 340
 341     # check for ABRT, KILL or TERM
 342     if ($rc == 6 || $rc == 9 || $rc == 15) {
 343         return 0;
 344     }
 345
 346     print STDERR "ERROR: <", $self->{EXECUTABLE},
 347                  "> exited with ";
 348
 349     print STDERR "coredump from " if ($dump == 1);
 350
 351     print STDERR "signal $rc : ", $signame[$rc], "\n";
 352
 353     $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run
 354
 355     return 0;
 356 }
 357
 358 sub Kill ()
 359 {
 360     my $self = shift;
 361
 362     if ($self->{RUNNING} && !defined $ENV{'ACE_TEST_WINDOW'}) {
 363         kill ('KILL', $self->{PROCESS});
 364         waitpid ($self->{PROCESS}, 0);
 365         $self->check_return_value ($?);
 366     }
 367
 368     $self->{RUNNING} = 0;
 369 }
 370
 371 # Wait until a process exits.
 372 # return -1 if the process is still alive.
 373 sub Wait ($)
 374 {
 375     my $self = shift;
 376     my $timeout = shift;
 377     if (!defined $timeout || $timeout < 0) {
 378         waitpid ($self->{PROCESS}, 0);
 379     } else {
 380         return TimedWait($self, $timeout);
 381     }
 382
 383 }
 384
 385 sub TimedWait ($)
 386 {
 387     my $self = shift;
 388     my $timeout = shift;
 389
 390     if ($PerlACE::Process::WAIT_DELAY_FACTOR > 0) {
 391         $timeout *= $PerlACE::Process::WAIT_DELAY_FACTOR;
 392     }
 393
 394     while ($timeout-- != 0) {
 395         my $pid = waitpid ($self->{PROCESS}, &WNOHANG);
 396         if ($pid != 0 && $? != -1) {
 397             return $self->check_return_value ($?);
 398         }
 399         sleep 1;
 400     }
 401
 402     $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run
 403
 404     return -1;
 405 }
 406
 407 sub handle_vxtest_file
 408 {
 409     my $self = shift;
 410     my $vxtestfile = shift;
 411     my $vx_ref = shift;
 412     my $unld_ref = shift;
 413     my $fh = new FileHandle;
 414
 415     if (defined $self->{TARGET} && $self->{TARGET}->SystemLibs()) {
 416         my @tokens = split(/;/, $self->{TARGET}->SystemLibs());
 417         foreach my $token (@tokens) {
 418             push @$vx_ref, "copy " . $ENV{'ACE_RUN_VX_TGTSVR_ROOT'} . "/lib/" . $token . " .";
 419             unshift @$unld_ref, "del " . $token;
 420         }
 421     }
 422     if (!$PerlACE::Static) {
 423         if (open ($fh, $vxtestfile)) {
 424             my $line1 = <$fh>;
 425             chomp $line1;
 426             while(<$fh>) {
 427                 $line1 = $_;
 428                 chomp $line1;
 429                 push @$vx_ref, "copy " . $ENV{'ACE_RUN_VX_TGTSVR_ROOT'} . "/lib/$line1" . ".dll .";
 430                 unshift @$unld_ref, "del $line1" . ".dll";
 431             }
 432             close $fh;
 433         } else {
 434             return 0;
 435         }
 436     }
 437     return 1;
 438 }
 439
 440 1;