ACE/bin/PerlACE/ProcessVX_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     if (!defined $PerlACE::ProcessVX::WAIT_DELAY_FACTOR) {
  57         $PerlACE::ProcessVX::WAIT_DELAY_FACTOR = 2;
  58     }
  59     if (!defined $PerlACE::ProcessVX::RebootCmd) {
  60         $PerlACE::ProcessVX::RebootCmd = "reboot 0x02";
  61     }
  62     bless ($self, $class);
  63     return $self;
  64 }
  65
  66 sub DESTROY
  67 {
  68     my $self = shift;
  69
  70     if ($self->{RUNNING} == 1) {
  71         print STDERR "ERROR: <", $self->{EXECUTABLE},
  72                      "> still running upon object destruction\n";
  73         $self->Kill ();
  74     }
  75
  76     if (defined $ENV{'ACE_RUN_VX_IBOOT'} && !defined $ENV{'ACE_RUN_VX_NO_SHUTDOWN'}) {
  77       # Shutdown the target to save power
  78       $self->iboot_cycle_power(1);
  79     }
  80 }
  81
  82 ###############################################################################
  83
  84 # Use the "expect" program to invoke telnet, doesn't need Perl's Net::Telnet.
  85 # This is run by the child process which was forked from Spawn().
  86 sub expect_telnet
  87 {
  88     my($host, $port, $prompt, $cmdsRef) = @_;
  89     my $pid = open(EXP, "|expect -f -") or die "ERROR: Could not run 'expect'";
  90     $SIG{'TERM'} = sub {           # If the parent wants to Kill() this process,
  91         kill 'TERM', $pid;         # send a SIGTERM to the expect process and
  92         $SIG{'TERM'} = 'DEFAULT';  # then go back to the normal handler for TERM
  93         kill 'TERM', $$;           # and invoke it.
  94     };
  95     print EXP <<EOT;
  96 set timeout -1
  97 spawn telnet $host $port
  98 expect -re "$prompt"
  99 EOT
 100     # target login and password are not currently implemented
 101     for my $cmd (@$cmdsRef) {
 102         my $cmdEsc = $cmd;
 103         $cmdEsc =~ s/\"/\\\"/g; # escape quotes
 104         print EXP <<EOT;
 105 send "$cmdEsc\r"
 106 expect -re "$prompt"
 107 EOT
 108     }
 109     print EXP <<EOT;
 110 send "exit\r"
 111 expect -re "Au revoir!"
 112 exit 0
 113 EOT
 114     close EXP;
 115     waitpid $pid, 0;
 116 }
 117
 118
 119 # Spawn the process and continue.
 120
 121 sub Spawn ()
 122 {
 123     my $self = shift;
 124
 125     if ($self->{RUNNING} == 1) {
 126         print STDERR "ERROR: Cannot Spawn: <", $self->Executable (),
 127                      "> already running\n";
 128         return -1;
 129     }
 130
 131     if (!defined $self->{EXECUTABLE}) {
 132         print STDERR "ERROR: Cannot Spawn: No executable specified\n";
 133         return -1;
 134     }
 135
 136     if ($self->{IGNOREEXESUBDIR} == 0) {
 137         if (!-f $self->Executable ()) {
 138             print STDERR "ERROR: Cannot Spawn: <", $self->Executable (),
 139                          "> not found\n";
 140             return -1;
 141         }
 142     }
 143
 144     my $status = 0;
 145
 146     my $cmdline;
 147
 148     # Reboot the target if necessery
 149     $self->reboot();
 150
 151     my $program = $self->Executable ();
 152     my $exe_cwdrel = dirname ($program);
 153     my $prjroot = defined $ENV{'ACE_RUN_VX_PRJ_ROOT'} ? $ENV{'ACE_RUN_VX_PRJ_ROOT'} : $ENV{'ACE_ROOT'};
 154     $exe_cwdrel = cwd() if length ($exe_cwdrel) == 0;
 155     $exe_cwdrel = File::Spec->abs2rel($exe_cwdrel, $prjroot);
 156     my $cwdrel = File::Spec->abs2rel(cwd(), $prjroot);
 157     $program = basename($program, $PerlACE::ProcessVX::ExeExt);
 158
 159     my @cmds;
 160     my $cmdnr = 0;
 161     my $arguments = "";
 162     my $prompt = '';
 163     my $exesubdir = defined $ENV{'ACE_RUN_VX_EXE_SUBDIR'} ? $ENV{'ACE_RUN_VX_EXE_SUBDIR'} : "";
 164
 165     if (defined $ENV{'ACE_RUN_VX_STARTUP_SCRIPT'}) {
 166         if (defined $ENV{'ACE_RUN_VX_STARTUP_SCRIPT_ROOT'}) {
 167             $cmds[$cmdnr++] = 'cd "' . $ENV{'ACE_RUN_VX_STARTUP_SCRIPT_ROOT'} . '"';
 168         }
 169         $cmds[$cmdnr++] = '< ' . $ENV{'ACE_RUN_VX_STARTUP_SCRIPT'};
 170     }
 171
 172     if (defined $ENV{'ACE_RUN_VX_STARTUP_COMMAND'}) {
 173         $cmds[$cmdnr++] = $ENV{'ACE_RUN_VX_STARTUP_COMMAND'};
 174     }
 175
 176     if ($PerlACE::VxWorks_RTP_Test) {
 177         $cmds[$cmdnr++] = 'cmd';
 178         if ( defined $ENV{'ACE_RUN_VX_TGTSVR_DEFGW'} && $self->{SET_VX_DEFGW}) {
 179             $cmds[$cmdnr++] = "C mRouteAdd(\"0.0.0.0\", \"" . $ENV{'ACE_RUN_VX_TGTSVR_DEFGW'} . "\", 0,0,0)";
 180             $PerlACE::ProcessVX::VxDefGw = 0;
 181         }
 182
 183         if (defined $ENV{'ACE_RUN_VX_TGT_STARTUP_SCRIPT'}) {
 184             my(@start_commands);
 185             if (handle_startup_script ($ENV{'ACE_RUN_VX_TGT_STARTUP_SCRIPT'}, \@start_commands)) {
 186                 push @cmds, @start_commands;
 187                 $cmdnr += scalar @start_commands;
 188             }
 189          }
 190
 191         $cmds[$cmdnr++] = 'cd "' . $ENV{'ACE_RUN_VX_TGTSVR_ROOT'} . "/" . $cwdrel . '"';
 192         $cmds[$cmdnr++] = 'C putenv("TMPDIR=' . $ENV{'ACE_RUN_VX_TGTSVR_ROOT'} . "/" . $cwdrel . '")';
 193
 194         if (defined $ENV{'ACE_RUN_ACE_DEBUG'}) {
 195             $cmds[$cmdnr++] = 'C putenv("ACE_DEBUG=' . $ENV{'ACE_RUN_ACE_DEBUG'} . '")';
 196         }
 197
 198         if (defined $ENV{'ACE_RUN_TAO_ORB_DEBUG'}) {
 199             $cmds[$cmdnr++] = 'C putenv("TAO_ORB_DEBUG=' . $ENV{'ACE_RUN_TAO_ORB_DEBUG'} . '")';
 200         }
 201
 202         if (defined $ENV{'ACE_RUN_ACE_LD_SEARCH_PATH'}) {
 203             $cmds[$cmdnr++] = 'C putenv("ACE_LD_SEARCH_PATH=' . $ENV{'ACE_RUN_ACE_LD_SEARCH_PATH'} . '")';
 204         }
 205         if (defined $self->{TARGET}) {
 206             my $x_env_ref = $self->{TARGET}->{EXTRA_ENV};
 207             while ( my ($env_key, $env_value) = each(%$x_env_ref) ) {
 208                 if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 209                     print "INFO: adding target environment $env_key=$env_value\n";
 210                 }
 211                 $cmds[$cmdnr++] = 'C putenv("' . $env_key. '=' . $env_value . '")';
 212             }
 213         }
 214
 215         if (defined $ENV{'ACE_RUN_VX_CHECK_RESOURCES'}) {
 216             $cmds[$cmdnr++] = 'C memShow()';
 217         }
 218
 219         $cmdline = $program . $PerlACE::ProcessVX::ExeExt . ' ' . $self->{ARGUMENTS};
 220         $cmds[$cmdnr++] = $cmdline;
 221         $prompt = '\[vxWorks \*\]\# $';
 222     }
 223     if ($PerlACE::VxWorks_Test) {
 224         if ( defined $ENV{'ACE_RUN_VX_TGTSVR_DEFGW'} && $PerlACE::ProcessVX::VxDefGw) {
 225             $cmds[$cmdnr++] = "mRouteAdd(\"0.0.0.0\", \"" . $ENV{'ACE_RUN_VX_TGTSVR_DEFGW'} . "\", 0,0,0)";
 226             $PerlACE::ProcessVX::VxDefGw = 0;
 227         }
 228
 229         if (defined $ENV{'ACE_RUN_VX_TGT_STARTUP_SCRIPT'}) {
 230             my(@start_commands);
 231             if (handle_startup_script ($ENV{'ACE_RUN_VX_TGT_STARTUP_SCRIPT'}, \@start_commands)) {
 232                 push @cmds, @start_commands;
 233                 $cmdnr += scalar @start_commands;
 234             }
 235          }
 236
 237         my(@load_commands);
 238         my(@unload_commands);
 239         if (!$PerlACE::Static && !$PerlACE::VxWorks_RTP_Test) {
 240             my $vxtest_file = $program . '.vxtest';
 241             if (handle_vxtest_file($self, $vxtest_file, \@load_commands, \@unload_commands)) {
 242                   $cmds[$cmdnr++] = "cd \"$ENV{'ACE_RUN_VX_TGTSVR_ROOT'}/lib\"";
 243                   push @cmds, @load_commands;
 244                   $cmdnr += scalar @load_commands;
 245             } else {
 246                 print STDERR "ERROR: Cannot find <", $vxtest_file, ">\n";
 247                 return -1;
 248             }
 249         }
 250
 251         $cmds[$cmdnr++] = 'cd "' . $ENV{'ACE_RUN_VX_TGTSVR_ROOT'} . "/" . $exe_cwdrel . "/" . $exesubdir . '"';
 252         $cmds[$cmdnr++] = 'putenv("TMPDIR=' . $ENV{'ACE_RUN_VX_TGTSVR_ROOT'} . "/" . $cwdrel . '")';
 253
 254         if (defined $ENV{'ACE_RUN_VX_CHECK_RESOURCES'}) {
 255             $cmds[$cmdnr++] = 'memShow()';
 256         }
 257
 258         if (defined $ENV{'ACE_RUN_ACE_DEBUG'}) {
 259             $cmds[$cmdnr++] = 'putenv("ACE_DEBUG=' . $ENV{'ACE_RUN_ACE_DEBUG'} . '")';
 260         }
 261
 262         if (defined $ENV{'ACE_RUN_TAO_ORB_DEBUG'}) {
 263             $cmds[$cmdnr++] = 'putenv("TAO_ORB_DEBUG=' . $ENV{'ACE_RUN_TAO_ORB_DEBUG'} . '")';
 264         }
 265
 266         if (defined $ENV{'ACE_RUN_ACE_LD_SEARCH_PATH'}) {
 267             $cmds[$cmdnr++] = 'putenv("ACE_LD_SEARCH_PATH=' . $ENV{'ACE_RUN_ACE_LD_SEARCH_PATH'} . '")';
 268         }
 269         if (defined $self->{TARGET}) {
 270             my $x_env_ref = $self->{TARGET}->{EXTRA_ENV};
 271             while ( my ($env_key, $env_value) = each(%$x_env_ref) ) {
 272                 if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 273                     print "INFO: adding target environment $env_key=$env_value\n";
 274                 }
 275                 $cmds[$cmdnr++] = 'putenv("' . $env_key. '=' . $env_value . '")';
 276             }
 277         }
 278
 279         $cmds[$cmdnr++] = 'ld <'. $program . $PerlACE::ProcessVX::ExeExt;
 280         $cmdline = $program . $PerlACE::ProcessVX::ExeExt . ' ' . $self->{ARGUMENTS};
 281         if (defined $self->{ARGUMENTS}) {
 282             ($arguments = $self->{ARGUMENTS})=~ s/\"/\\\"/g;
 283             ($arguments = $self->{ARGUMENTS})=~ s/\'/\\\'/g;
 284             $arguments = ",\"" . $arguments . "\"";
 285         }
 286         if (defined $ENV{'ACE_RUN_VX_TGTSRV_WORKINGDIR'}) {
 287             $cmds[$cmdnr++] = 'cd "' . $ENV{'ACE_RUN_VX_TGTSRV_WORKINGDIR'} . '"';
 288         } else {
 289             $cmds[$cmdnr++] = 'cd "' . $ENV{'ACE_RUN_VX_TGTSVR_ROOT'} . "/" . $cwdrel . '"';
 290         }
 291         $cmds[$cmdnr++] = 'ace_vx_rc = vx_execae(ace_main' . $arguments . ')';
 292         $cmds[$cmdnr++] = 'unld "'. $program . $PerlACE::ProcessVX::ExeExt . '"';
 293         push @cmds, @unload_commands;
 294         $cmdnr += scalar @unload_commands;
 295         $prompt = '-> $';
 296     }
 297
 298     FORK: {
 299         if ($self->{PROCESS} = fork) {
 300             #parent here
 301             bless $self;
 302         }
 303         elsif (defined $self->{PROCESS}) {
 304             #child here
 305             my $telnet_port = $ENV{'ACE_RUN_VX_TGT_TELNET_PORT'};
 306             my $telnet_host = $ENV{'ACE_RUN_VX_TGT_TELNET_HOST'};
 307             if (!defined $telnet_host)  {
 308                 $telnet_host = $ENV{'ACE_RUN_VX_TGTHOST'};
 309             }
 310             if (!defined $telnet_port)  {
 311                 $telnet_port = 23;
 312             }
 313             if (defined $ENV{'ACE_RUN_VX_USE_EXPECT'}) {
 314                 expect_telnet($telnet_host, $telnet_port, $prompt, \@cmds);
 315                 sleep(2);
 316                 exit;
 317             }
 318             if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 319                 print "Opening telnet connection <" . $telnet_host . ":". $telnet_port . ">\n";
 320             }
 321             my $t = new Net::Telnet(Timeout => 600, Errmode => 'return', Host => $telnet_host, Port => $telnet_port);
 322             if (!defined $t) {
 323                 die "ERROR: Telnet failed to <" . $telnet_host . ":". $telnet_port . ">";
 324             }
 325             my $retries = 10;
 326             while ($retries--) {
 327                 if (!$t->open()) {
 328                     if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 329                         print "Couldn't open telnet connection; sleeping then retrying\n";
 330                     }
 331                     if ($retries == 0) {
 332                         die "ERROR: Telnet open to <" . $telnet_host . ":". $telnet_port . "> " . $t->errmsg;
 333                     }
 334                     sleep(5);
 335                 } else {
 336                     last;
 337                 }
 338             }
 339
 340             my $target_login = $ENV{'ACE_RUN_VX_LOGIN'};
 341             my $target_password = $ENV{'ACE_RUN_VX_PASSWORD'};
 342
 343             if (defined $target_login)  {
 344                 $t->waitfor('/VxWorks login: $/');
 345                 $t->print("$target_login");
 346             }
 347
 348             if (defined $target_password)  {
 349                 $t->waitfor('/Password: $/');
 350                 $t->print("$target_password");
 351             }
 352
 353             my $buf = '';
 354             # wait for the prompt
 355             my $prompt1 = '->[\ ]$';
 356             while (1) {
 357                 my $blk = $t->get;
 358                 print $blk;
 359                 $buf .= $blk;
 360                 if ($buf =~ /$prompt1/) {
 361                     last;
 362                 }
 363             }
 364             if ($buf !~ /$prompt1/) {
 365                 die "ERROR: Didn't got prompt but got <$buf>";
 366             }
 367             my $i = 0;
 368             my @lines;
 369             while($i < $cmdnr) {
 370                 if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 371                     print $cmds[$i]."\n";
 372                 }
 373                 if ($t->print ($cmds[$i++])) {
 374                     # After each command wait for the prompt
 375                     my $buf = '';
 376                     while (1) {
 377                         my $blk = $t->get;
 378                         print $blk;
 379                         $buf .= $blk;
 380                         if ($buf =~ /$prompt/) {
 381                             last;
 382                         }
 383                     }
 384                 } else {
 385                     print $t->errmsg;
 386                 }
 387             }
 388             $t->close();
 389             sleep(2);
 390             exit;
 391         }
 392         elsif ($! =~ /No more process/) {
 393             #EAGAIN, supposedly recoverable fork error
 394             sleep 5;
 395             redo FORK;
 396         }
 397         else {
 398             # weird fork error
 399             print STDERR "ERROR: Can't fork <" . $cmdline . ">: $!\n";
 400         }
 401     }
 402     $self->{RUNNING} = 1;
 403     return 0;
 404 }
 405
 406
 407 # Terminate the process and wait for it to finish
 408
 409 sub TerminateWaitKill ($)
 410 {
 411     my $self = shift;
 412     my $timeout = shift;
 413
 414     if ($self->{RUNNING}) {
 415         print STDERR "INFO: $self->{EXECUTABLE} being killed.\n";
 416         kill ('TERM', $self->{PROCESS});
 417
 418         $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run
 419     }
 420
 421     return $self->WaitKill ($timeout);
 422 }
 423
 424 # really only for internal use
 425 sub check_return_value ($)
 426 {
 427     my $self = shift;
 428     my $rc = shift;
 429
 430     my $CC_MASK = 0xff00;
 431
 432     # Exit code processing
 433     if ($rc == 0) {
 434         return 0;
 435     }
 436     elsif ($rc == $CC_MASK) {
 437         print STDERR "ERROR: <", $self->{EXECUTABLE},
 438                      "> failed: $!\n";
 439
 440         $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run
 441
 442         return ($rc >> 8);
 443     }
 444     elsif (($rc & 0xff) == 0) {
 445         $rc >>= 8;
 446         return $rc;
 447     }
 448
 449     # Remember Core dump flag
 450     my $dump = 0;
 451
 452     if ($rc & 0x80) {
 453         $rc &= ~0x80;
 454         $dump = 1;
 455     }
 456
 457     # check for ABRT, KILL or TERM
 458     if ($rc == 6 || $rc == 9 || $rc == 15) {
 459         return 0;
 460     }
 461
 462     print STDERR "ERROR: <", $self->{EXECUTABLE},
 463                  "> exited with ";
 464
 465     print STDERR "coredump from " if ($dump == 1);
 466
 467     print STDERR "signal $rc : ", $signame[$rc], "\n";
 468
 469     $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run
 470
 471     return 0;
 472 }
 473
 474 sub Kill ()
 475 {
 476     my $self = shift;
 477
 478     if ($self->{RUNNING} && !defined $ENV{'ACE_TEST_WINDOW'}) {
 479         kill ((defined $ENV{'ACE_RUN_VX_USE_EXPECT'}) ? 'TERM' : 'KILL',
 480               $self->{PROCESS});
 481         waitpid ($self->{PROCESS}, 0);
 482         $self->check_return_value ($?);
 483     }
 484
 485     $self->{RUNNING} = 0;
 486 }
 487
 488 # Wait until a process exits.
 489 # return -1 if the process is still alive.
 490 sub Wait ($)
 491 {
 492     my $self = shift;
 493     my $timeout = shift;
 494     if (!defined $timeout || $timeout < 0) {
 495         waitpid ($self->{PROCESS}, 0);
 496     } else {
 497         return TimedWait($self, $timeout);
 498     }
 499
 500 }
 501
 502 sub TimedWait ($)
 503 {
 504     my $self = shift;
 505     my $timeout = shift;
 506
 507     if ($PerlACE::Process::WAIT_DELAY_FACTOR > 0) {
 508         $timeout *= $PerlACE::Process::WAIT_DELAY_FACTOR;
 509     }
 510
 511     # Multiply with 10 because we wait a tenth of a second each time
 512     $timeout *= 10;
 513
 514     while ($timeout-- != 0) {
 515         my $pid = waitpid ($self->{PROCESS}, &WNOHANG);
 516         if ($pid != 0 && $? != -1) {
 517             return $self->check_return_value ($?);
 518         }
 519         select(undef, undef, undef, 0.1);
 520     }
 521
 522     $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run
 523
 524     return -1;
 525 }
 526
 527 1;