ACE/bin/PerlACE/ProcessVX.pm

   1 #!/usr/bin/env perl
   2
   3 package PerlACE::ProcessVX;
   4
   5 use strict;
   6 use English;
   7 use POSIX qw(:time_h);
   8
   9 $PerlACE::ProcessVX::ExeSubDir = './';
  10 $PerlACE::ProcessVX::DoVxInit = (defined $ENV{'ACE_RUN_VX_NO_INITIAL_REBOOT'}) ? 0 : 1;
  11 $PerlACE::ProcessVX::VxDefGw = 1;
  12 $PerlACE::ProcessVX::RebootTime = (defined $ENV{'ACE_RUN_VX_REBOOT_TIME'}) ? $ENV{'ACE_RUN_VX_REBOOT_TIME'} : 90;
  13 $PerlACE::ProcessVX::ExeExt = ($PerlACE::VxWorks_RTP_Test) ? '.vxe' : '.out';
  14 $PerlACE::ProcessVX::RebootCmd = $ENV{'ACE_RUN_VX_REBOOT_CMD'};
  15
  16 # Wait for the process to exit or kill after a time period
  17
  18 sub WaitKill ($)
  19 {
  20     my $self = shift;
  21     my $timeout = shift;
  22
  23     my $status = $self->TimedWait ($timeout);
  24
  25     if ($status == -1) {
  26         print STDERR "ERROR: $self->{EXECUTABLE} timedout\n";
  27         $self->Kill ();
  28         # Don't need to Wait since we are on Win32
  29
  30         $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run
  31     }
  32
  33     $self->{RUNNING} = 0;
  34
  35     return $status;
  36 }
  37
  38
  39 # Do a Spawn and immediately WaitKill
  40
  41 sub SpawnWaitKill ($)
  42 {
  43     my $self = shift;
  44     my $timeout = shift;
  45
  46     if ($self->Spawn () == -1) {
  47         return -1;
  48     }
  49
  50     return $self->WaitKill ($timeout);
  51 }
  52
  53
  54 ###############################################################################
  55
  56 ### Some Accessors
  57
  58 sub Normalize_Executable_Name
  59 {
  60     my $self = shift;
  61     my $executable = shift;
  62
  63     my $basename = basename ($executable);
  64     my $dirname = dirname ($executable). '/';
  65
  66     $executable = $dirname.$PerlACE::ProcessVX::ExeSubDir.$basename.$PerlACE::ProcessVX::ExeExt;
  67
  68     ## Installed executables do not conform to the ExeSubDir
  69     if (! -e $executable && -e $dirname.$basename.$PerlACE::ProcessVX::ExeExt) {
  70       $executable = $dirname.$basename.$PerlACE::ProcessVX::ExeExt;
  71     }
  72
  73     return $executable;
  74 }
  75
  76
  77 sub Executable
  78 {
  79     my $self = shift;
  80
  81     if (@_ != 0) {
  82         $self->{EXECUTABLE} = shift;
  83     }
  84
  85     my $executable = $self->{EXECUTABLE};
  86
  87     if ($self->{IGNOREEXESUBDIR} == 0) {
  88       $executable = $self->Normalize_Executable_Name ($executable);
  89     }
  90     else {
  91       $executable = $executable.$PerlACE::ProcessVX::ExeExt;
  92     }
  93
  94     return $executable;
  95 }
  96
  97 sub Arguments
  98 {
  99     my $self = shift;
 100
 101     if (@_ != 0) {
 102         $self->{ARGUMENTS} = shift;
 103     }
 104
 105     return $self->{ARGUMENTS};
 106 }
 107
 108 sub CommandLine ()
 109 {
 110     my $self = shift;
 111
 112     my $commandline = $self->Executable ();
 113
 114     if (defined $self->{ARGUMENTS}) {
 115         $commandline .= ' '.$self->{ARGUMENTS};
 116     }
 117
 118     return $commandline;
 119 }
 120
 121 sub IgnoreExeSubDir
 122 {
 123     my $self = shift;
 124
 125     if (@_ != 0) {
 126         $self->{IGNOREEXESUBDIR} = shift;
 127     }
 128
 129     return $self->{IGNOREEXESUBDIR};
 130 }
 131
 132 sub IgnoreHostRoot
 133 {
 134     my $self = shift;
 135
 136     if (@_ != 0) {
 137         $self->{IGNOREHOSTROOT} = shift;
 138     }
 139
 140     return $self->{IGNOREHOSTROOT};
 141 }
 142
 143 sub delay_factor
 144 {
 145     my($lps)    = 128;
 146     my($factor) = 1;
 147
 148     ## Keep increasing the loops per second until the amount of time
 149     ## exceeds the number of clocks per second.  The original code
 150     ## did not multiply $ticks by 8 but, for faster machines, it doesn't
 151     ## seem to return false values.  The multiplication is done to minimize
 152     ## the amount of time it takes to determine the correct factor.
 153     while(($lps <<= 1)) {
 154         my($ticks) = clock();
 155         for(my $i = $lps; $i >= 0; $i--) {
 156         }
 157         $ticks = clock() - $ticks;
 158         if ($ticks * 8 >= CLOCKS_PER_SEC) {
 159             $factor = 500000 / (($lps / $ticks) * CLOCKS_PER_SEC);
 160             last;
 161         }
 162     }
 163
 164     return $factor;
 165 }
 166
 167 sub iboot_cycle_power
 168 {
 169     my $self = shift;
 170     my $mode = shift;
 171
 172     # mode 0 is reboot, mode 1 is just shutdown
 173
 174     my ($iboot_host,
 175         $iboot_outlet,
 176         $iboot_user,
 177         $iboot_passwd ) = ($ENV{'ACE_RUN_VX_IBOOT'},
 178                           $ENV{'ACE_RUN_VX_IBOOT_OUTLET'},
 179                           $ENV{'ACE_RUN_VX_IBOOT_USER'},
 180                           $ENV{'ACE_RUN_VX_IBOOT_PASSWORD'});
 181
 182     my $v = $ENV{'ACE_TEST_VERBOSE'};
 183
 184     if ($v) {
 185         print "Using iBoot: $iboot_host\n";
 186         if (defined $iboot_outlet) {
 187             print "Using iBoot Outlet #: $iboot_outlet\n";
 188         }
 189     }
 190
 191     # There are three cases to handle here:
 192     # 1. using a single-outlet iBoot
 193     # 2. using a multi-outlet iBootBar with custom firmware
 194     # 3. using a multi-outlet iBootBar with standard firmware
 195     #
 196     # In cases 1 & 2, we use the iPAL protocol; in case 3 we
 197     # use a telnet connection and the command-line syntax.
 198     #
 199     # We determine that it's case #3 by the concurrent presence
 200     # of an outlet number, an iboot username, and an iboot password
 201     # in the environment.
 202     #
 203     if (defined($iboot_outlet) && defined($iboot_user) && defined($iboot_passwd)) {
 204         # We perform case #3
 205         # This case doesn't support shutdown
 206         return if $mode == 1;
 207
 208         my $t = new Net::Telnet();
 209
 210         $t->prompt('/iBootBar \> /');
 211         my $savedmode = $t->errmode();
 212         $t->errmode("return");
 213
 214         my $retries = 5;
 215         my $is_open = 0;
 216
 217         while ($retries--) {
 218             my $r = $t->open($iboot_host);
 219             if ($r == 1) {
 220                 $is_open = 1;
 221                 last;
 222             }
 223         }
 224         continue {
 225             print "Couldn't open connection; sleeping then retrying\n" if ($v);
 226             sleep(5);
 227         }
 228
 229         if (! $is_open) {
 230             print "Unable to open $iboot_host.\n" if ($v);
 231             return 0;
 232         }
 233
 234         $t->errmode($savedmode);
 235
 236         # Simple login b/c Net::Telnet::login hardcodes the prompts
 237         $t->waitfor('/User Name:\s*$/i');
 238         $t->print($iboot_user);
 239         $t->waitfor('/password:\s*/i');
 240         $t->print($iboot_passwd);
 241
 242         $t->waitfor($t->prompt);
 243
 244         print "successfully logged in to $iboot_host\n" if ($v);
 245
 246         my $output = $t->cmd("set outlet $iboot_outlet cycle");
 247
 248         print "successfully cycled power on outlet $iboot_outlet\n" if ($v);
 249
 250         $t->close();
 251     }
 252     else {
 253         # Perform cases 1 & 2
 254         my $iboot;
 255         my $text;
 256         if (!defined($iboot_passwd)) {
 257             $iboot_passwd = "PASS";
 258         }
 259
 260         my $ipal_command_series;
 261         if (defined $iboot_outlet) {
 262             $ipal_command_series = ($mode == 0 ? ['E', 'D'] : ['E']);
 263         } else {
 264             $ipal_command_series = ($mode == 0 ? ['f', 'n'] : ['f']);
 265         }
 266
 267         foreach my $ipal_cmd (@$ipal_command_series) {
 268             my $retries = 3;
 269             my $is_open = 0;
 270             while ($retries--) {
 271                 $iboot = IO::Socket::INET->new ("$iboot_host");
 272                 if ($iboot) {
 273                     # if ACE_RUN_VX_IBOOT_OUTLET is defined, we're using
 274                     # the iBootBar, and we're using the iPAL Protocol
 275                     # to communicate with the iBootBar
 276                     if (defined $iboot_outlet) {
 277                         $iboot->send ("\e".$iboot_passwd."\e".$iboot_outlet.$ipal_cmd);
 278                     }
 279                     else  {
 280                         $iboot->send ("\e".$iboot_passwd."\e$ipal_cmd\r");
 281                     }
 282                     $iboot->recv ($text,128);
 283                     print "iBoot is currently: $text (iteration $retries)\n" if ($v);
 284                     $iboot->close();
 285                     if (defined $iboot_outlet) {
 286                         $text = substr $text, $iboot_outlet - 1, 1;
 287                         if ($text eq "0" || $text eq "1") {
 288                             $is_open = 1;
 289                             last;
 290                         }
 291                         else {
 292                             print "iBoot is $text; sleeping then retrying\n" if ($v);
 293                             sleep(5);
 294                         }
 295                     }
 296                     else  {
 297                         if ($text eq "OFF" || $text eq "ON") {
 298                             $is_open = 1;
 299                             last;
 300                         }
 301                         else {
 302                             print "iBoot is $text; sleeping then retrying\n" if ($v);
 303                             sleep(5);
 304                         }
 305                     }
 306                 }
 307                 else {
 308                       print "Unable to execute 'reboot' command, going to try another $retries times!\n";
 309                 }
 310             }
 311             if (!$is_open) {
 312                 print "Unable to reboot using $iboot_host.\n" if ($v);
 313                 return 0;
 314             }
 315         }
 316     }
 317 }
 318
 319 sub reboot
 320 {
 321     my $self = shift;
 322     my $iboot;
 323     my $text;
 324     my $t;
 325     my $ok;
 326
 327     my $target_login = $ENV{'ACE_RUN_VX_LOGIN'};
 328     my $target_password = $ENV{'ACE_RUN_VX_PASSWORD'};
 329
 330     ##
 331     ## initialize VxWorks kernel (reboot!) if needed
 332     if ($PerlACE::ProcessVX::DoVxInit || $ENV{'ACE_RUN_VX_TGT_REBOOT'}) {
 333         if (defined $ENV{'ACE_RUN_VX_REBOOT_TOOL'}) {
 334             if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 335                 print "Calling: $ENV{'ACE_RUN_VX_REBOOT_TOOL'}\n";
 336             }
 337             system ($ENV{'ACE_RUN_VX_REBOOT_TOOL'});
 338         }
 339         else {
 340             if (defined $ENV{'ACE_RUN_VX_IBOOT'}) {
 341                 $self->iboot_cycle_power(0);
 342             }
 343             else {
 344                 if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 345                     print "Executing 'reboot' command over Telnet to ".$ENV{'ACE_RUN_VX_TGTHOST'}.".\n";
 346                 }
 347                 $t = new Net::Telnet(Timeout => 10,
 348                                     Prompt => '/-> $/',
 349                                     Errmode => 'return');
 350                 $t->open($ENV{'ACE_RUN_VX_TGTHOST'});
 351                 if (defined $target_login)  {
 352                     $t->waitfor('/VxWorks login: $/');
 353                     $t->print("$target_login");
 354                 }
 355                 if (defined $target_password)  {
 356                     $t->waitfor('/Password: $/');
 357                     $t->print("$target_password");
 358                 }
 359                 $t->print("");
 360                 $ok = $t->waitfor('/-> $/');
 361                 if ($ok) {
 362                     $t->print($PerlACE::ProcessVX::RebootCmd);
 363                     sleep(5);
 364                 }
 365                 else {
 366                     print "ERROR: FAILED to execute 'reboot' command!\n";
 367                 }
 368                 $t->close();
 369             }
 370         }
 371         $PerlACE::ProcessVX::VxDefGw = 1;
 372         $PerlACE::ProcessVX::DoVxInit = 0;
 373         sleep($PerlACE::ProcessVX::RebootTime);
 374     }
 375 }
 376
 377 # Helper for spawning with list of kernel modules in a .vxtest file
 378 sub handle_vxtest_file
 379 {
 380     my $self = shift;
 381     my $vxtestfile = shift;
 382     my $vx_ref = shift;
 383     my $unld_ref = shift;
 384     my $fh = new FileHandle;
 385     if (open ($fh, $vxtestfile)) {
 386         my $line1 = <$fh>;
 387         chomp $line1;
 388         while(<$fh>) {
 389             $line1 = $_;
 390             chomp $line1;
 391             push @$vx_ref, "ld < lib$line1" . ".so";
 392             unshift @$unld_ref, "unld \"lib$line1" . ".so\"";
 393         }
 394         close $fh;
 395     } else {
 396         return 0;
 397     }
 398     return 1;
 399 }
 400
 401 # Load a file that is used as startup script. This script has to be
 402 # located on the host system
 403 sub handle_startup_script
 404 {
 405     my $script = shift;
 406     my $cmds = shift;
 407     my $fh = new FileHandle;
 408     if (open ($fh, $script)) {
 409         while(<$fh>) {
 410             my $line1 = $_;
 411             chomp $line1;
 412             push @$cmds, "$line1";
 413         }
 414         close $fh;
 415     } else {
 416         return 0;
 417     }
 418     return 1;
 419 }
 420
 421 ### Check for -ExeSubDir commands, store the last one
 422 my @new_argv = ();
 423
 424 for(my $i = 0; $i <= $#ARGV; ++$i) {
 425     if ($ARGV[$i] eq '-ExeSubDir') {
 426         if (defined $ARGV[$i + 1]) {
 427             $PerlACE::ProcessVX::ExeSubDir = $ARGV[++$i].'/';
 428         }
 429         else {
 430             print STDERR "You must pass a directory with ExeSubDir\n";
 431             exit(1);
 432         }
 433     }
 434     else {
 435         push @new_argv, $ARGV[$i];
 436     }
 437 }
 438 @ARGV = @new_argv;
 439
 440 $PerlACE::ProcessVX::WAIT_DELAY_FACTOR = $ENV{'ACE_RUNTEST_DELAY'};
 441
 442 if (defined $ENV{'ACE_TEST_WINCE'}) {
 443     if ($OSNAME eq "MSWin32") {
 444         require PerlACE::ProcessWinCE;
 445     } else {
 446         require PerlACE::ProcessWinCE_Unix;
 447     }
 448 } else {
 449     if ($OSNAME eq "MSWin32") {
 450         require PerlACE::ProcessVX_Win32;
 451     }
 452     else {
 453         require PerlACE::ProcessVX_Unix;
 454     }
 455 }
 456
 457 ###
 458
 459 sub kill_all
 460 {
 461     my $procmask = shift;
 462     my $target = shift;
 463     ## NOT IMPLEMENTED YET
 464 }
 465
 466 1;