ACE/bin/PerlACE/ProcessWinCE.pm

   1 #!/usr/bin/env perl
   2
   3 package PerlACE::ProcessVX;
   4
   5 use strict;
   6 use Win32::Process;
   7 use File::Basename;
   8 use File::Spec;
   9 use FileHandle;
  10 use Cwd;
  11
  12 eval { require Net::Telnet; };
  13
  14 ###############################################################################
  15
  16 # This is what GetExitCode will return if the process is still running.
  17 my $STILL_ACTIVE = 259;
  18
  19 ###############################################################################
  20
  21 ### Constructor and Destructor
  22
  23 sub new
  24 {
  25     my $proto = shift;
  26     my $class = ref ($proto) || $proto;
  27     my $self = {};
  28
  29     $self->{RUNNING} = 0;
  30     $self->{IGNOREEXESUBDIR} = 1;
  31     $self->{IGNOREHOSTROOT} = 0;
  32     $self->{PROCESS} = undef;
  33     $self->{TARGET} = shift;
  34     $self->{EXECUTABLE} = shift;
  35     $self->{ARGUMENTS} = shift;
  36     if (!defined $PerlACE::ProcessVX::WAIT_DELAY_FACTOR) {
  37         $PerlACE::ProcessVX::WAIT_DELAY_FACTOR = 3;
  38     }
  39     if (!defined $PerlACE::ProcessVX::RebootCmd) {
  40         $PerlACE::ProcessVX::RebootCmd = "reboot";
  41     }
  42     bless ($self, $class);
  43     return $self;
  44 }
  45
  46 sub DESTROY
  47 {
  48     my $self = shift;
  49
  50     if ($self->{RUNNING} == 1) {
  51         print STDERR "ERROR: <", $self->{EXECUTABLE},
  52                      "> still running upon object destruction\n";
  53         $self->Kill ();
  54     }
  55
  56     if (!defined $ENV{'ACE_TEST_VERBOSE'}) {
  57         unlink "run_vx.pl";
  58     }
  59
  60     if (defined $ENV{'ACE_RUN_VX_IBOOT'} && !defined $ENV{'ACE_RUN_VX_NO_SHUTDOWN'}) {
  61       # Shutdown the target to save power
  62       $self->iboot_cycle_power(1);
  63     }
  64 }
  65
  66 ###############################################################################
  67
  68 ### Spawning processes
  69
  70
  71 # Spawn the process and continue.
  72
  73 sub Spawn ()
  74 {
  75     my $self = shift;
  76
  77     if ($self->{RUNNING} == 1) {
  78         print STDERR "ERROR: Cannot Spawn: <", $self->Executable (),
  79                      "> already running\n";
  80         return -1;
  81     }
  82
  83     if (!defined $self->{EXECUTABLE}) {
  84         print STDERR "ERROR: Cannot Spawn: No executable specified\n";
  85         return -1;
  86     }
  87
  88     if ($self->{IGNOREEXESUBDIR} == 0) {
  89         if (!-f $self->Executable ()) {
  90             print STDERR "ERROR: Cannot Spawn: <", $self->Executable (),
  91                          "> not found\n";
  92             return -1;
  93         }
  94     }
  95
  96     my $status = 0;
  97
  98     my $cmdline;
  99
 100     # Reboot the target if necessery
 101     $self->reboot();
 102
 103     my $program = $self->Executable ();
 104     my $cwdrel = dirname ($program);
 105     my $prjroot = defined $ENV{'ACE_RUN_VX_PRJ_ROOT'} ? $ENV{'ACE_RUN_VX_PRJ_ROOT'} : $ENV{'ACE_ROOT'};
 106     if (length ($cwdrel) > 0) {
 107         $cwdrel = File::Spec->abs2rel( cwd(), $prjroot );
 108     }
 109     else {
 110         $cwdrel = File::Spec->abs2rel( $cwdrel, $prjroot );
 111     }
 112     $cwdrel =~ s/\\/\//g;
 113     $program = basename($program, $PerlACE::ProcessVX::ExeExt);
 114
 115     unlink "run_vx.pl";
 116     my $oh = new FileHandle();
 117     if (!open($oh, ">run_vx.pl")) {
 118         print STDERR "ERROR: Unable to write to run_vx.pl\n";
 119         exit -1;
 120     }
 121
 122     my @cmds;
 123     my $cmdnr = 0;
 124     my $arguments = "";
 125     my $prompt = '';
 126     my $exesubdir = defined $ENV{'ACE_RUN_VX_EXE_SUBDIR'} ? $ENV{'ACE_RUN_VX_EXE_SUBDIR'} : "";
 127
 128     if (defined $ENV{'ACE_RUN_VX_STARTUP_SCRIPT'}) {
 129       if (defined $ENV{'ACE_RUN_VX_STARTUP_SCRIPT_ROOT'}) {
 130         @cmds[$cmdnr++] = 'cd "' . $ENV{'ACE_RUN_VX_STARTUP_SCRIPT_ROOT'} . '"';
 131       }
 132       @cmds[$cmdnr++] = '< ' . $ENV{'ACE_RUN_VX_STARTUP_SCRIPT'};
 133     }
 134
 135     if (defined $ENV{'ACE_RUN_VX_STARTUP_COMMAND'}) {
 136       @cmds[$cmdnr++] = $ENV{'ACE_RUN_VX_STARTUP_COMMAND'};
 137     }
 138
 139         @cmds[$cmdnr++] = 'cd ' . $ENV{'ACE_RUN_VX_TGTSVR_ROOT'} . "/" . $cwdrel . "/" . $exesubdir;
 140         @cmds[$cmdnr++] = 'set TMPDIR=' . $ENV{'ACE_RUN_VX_TGTSVR_ROOT'} . "/" . $cwdrel;
 141
 142         if (defined $ENV{'ACE_RUN_ACE_DEBUG'}) {
 143             @cmds[$cmdnr++] = 'set ACE_DEBUG=' . $ENV{'ACE_RUN_ACE_DEBUG'};
 144         }
 145
 146         if (defined $ENV{'ACE_RUN_TAO_ORB_DEBUG'}) {
 147             @cmds[$cmdnr++] = 'set TAO_ORB_DEBUG=' . $ENV{'ACE_RUN_TAO_ORB_DEBUG'};
 148         }
 149
 150         if (defined $ENV{'ACE_RUN_ACE_LD_SEARCH_PATH'}) {
 151             @cmds[$cmdnr++] = 'set ACE_LD_SEARCH_PATH=' . $ENV{'ACE_RUN_ACE_LD_SEARCH_PATH'};
 152         }
 153
 154         my(@load_commands);
 155         my(@unload_commands);
 156         my $vxtest_file = $program . '.vxtest';
 157         if (handle_vxtest_file($self, $vxtest_file, \@load_commands, \@unload_commands)) {
 158             push @cmds, @load_commands;
 159             $cmdnr += scalar @load_commands;
 160           } else {
 161             print STDERR "ERROR: Cannot find <", $vxtest_file, ">\n";
 162           }
 163
 164         if (defined $self->{ARGUMENTS}) {
 165             ($arguments = $self->{ARGUMENTS})=~ s/\"/\\\"/g;
 166             ($arguments = $self->{ARGUMENTS})=~ s/\'/\\\'/g;
 167         }
 168         $cmdline = $program . ' ' . $arguments;
 169         if (defined $ENV{'ACE_RUN_VX_TGTSRV_WORKINGDIR'}) {
 170             @cmds[$cmdnr++] = 'cd ' . $ENV{'ACE_RUN_VX_TGTSRV_WORKINGDIR'};
 171         } else {
 172             @cmds[$cmdnr++] = 'cd ' . $ENV{'ACE_RUN_VX_TGTSVR_ROOT'} . "/" . $cwdrel;
 173         }
 174         @cmds[$cmdnr++] = $cmdline;
 175         if (!defined $ENV{'ACE_TEST_VERBOSE'}) {
 176           push @cmds, @unload_commands;
 177           $cmdnr += scalar @unload_commands;
 178         }
 179         $prompt = '\> $';
 180
 181     print $oh "require Net::Telnet;\n";
 182     print $oh "my \@cmds;\n";
 183     print $oh "my \$prompt = '$prompt';\n";
 184     my $i = 0;
 185     while($i < $cmdnr) {
 186       print $oh "\@cmds[$i] = '" . @cmds[$i++] . "';\n";
 187     }
 188     print $oh "my \$cmdnr = $cmdnr;\n\n";
 189
 190     print $oh <<'__END__';
 191
 192 my $telnet_port = $ENV{'ACE_RUN_VX_TGT_TELNET_PORT'};
 193 my $telnet_host = $ENV{'ACE_RUN_VX_TGT_TELNET_HOST'};
 194 if (!defined $telnet_host)  {
 195     $telnet_host = $ENV{'ACE_RUN_VX_TGTHOST'};
 196 }
 197 if (!defined $telnet_port)  {
 198     $telnet_port = 23;
 199 }
 200 my $t = new Net::Telnet(Timeout => 600, Errmode => 'return', Host => $telnet_host, Port => $telnet_port);
 201 if (!defined $t) {
 202     die "ERROR: Telnet failed to <" . $telnet_host . ":". $telnet_port . ">";
 203 }
 204 $t->open();
 205
 206 my $ok = false;
 207 my $buf = '';
 208 while (1) {
 209     my $blk = $t->get;
 210     print $blk;
 211     $buf .= $blk;
 212     if ($buf =~ /$prompt/) {
 213         $ok = true;
 214         last;
 215     }
 216 }
 217 if ($ok) {
 218     my $i = 0;
 219     my @lines;
 220     while($i < $cmdnr) {
 221         if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 222             print STDERR @cmds[$i]."\n";
 223         }
 224         if ($t->print (@cmds[$i++])) {
 225             my $buf = '';
 226             while (1) {
 227                 my $blk = $t->get;
 228                 printf $blk;
 229                 $buf .= $blk;
 230                 if ($buf =~ /$prompt/) {
 231                     last;
 232                 }
 233             }
 234         } else {
 235             print $t->errmsg;
 236         }
 237     }
 238 }
 239 else {
 240     die "ERROR: No prompt appeared\n";
 241 }
 242 $t->close();
 243 sleep(2);
 244 exit;
 245 __END__
 246
 247     close($oh);
 248
 249     Win32::Process::Create ($self->{PROCESS},
 250                             "$^X",
 251                             "$^X run_vx.pl",
 252                             0,
 253                             0,
 254                             '.');
 255
 256     Win32::Process::GetExitCode ($self->{PROCESS}, $status);
 257
 258     if ($status != $STILL_ACTIVE) {
 259         print STDERR "ERROR: Spawn failed for <", "$^X run_vx.pl", ">\n";
 260         exit $status;
 261     }
 262
 263     $self->{RUNNING} = 1;
 264     return 0;
 265 }
 266
 267 # Wait for a process to exit with a timeout
 268
 269 sub TimedWait ($)
 270 {
 271     my($self) = shift;
 272     my($timeout) = shift;
 273     return $self->Wait($timeout);
 274 }
 275
 276
 277 # Terminate the process and wait for it to finish
 278
 279 sub TerminateWaitKill ($)
 280 {
 281     my $self = shift;
 282     my $timeout = shift;
 283
 284     if ($self->{RUNNING}) {
 285         print STDERR "INFO: $self->{EXECUTABLE} being killed.\n";
 286         Win32::Process::Kill ($self->{PROCESS}, 0);
 287         $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run
 288     }
 289
 290     return $self->WaitKill ($timeout);
 291 }
 292
 293 # Wait until a process exits.
 294 # return -1 if the process is still alive.
 295 sub Wait ($)
 296 {
 297     my $self = shift;
 298     my $timeout = shift;
 299     if (!defined $timeout || $timeout < 0) {
 300         $timeout = INFINITE;
 301     } else {
 302         $timeout = $timeout * 1000 * $PerlACE::ProcessVX::WAIT_DELAY_FACTOR;
 303     }
 304
 305     my $result = 0;
 306
 307     if ($self->{RUNNING}) {
 308         $result = Win32::Process::Wait ($self->{PROCESS}, $timeout);
 309         if ($result == 0) {
 310             return -1;
 311         }
 312     }
 313     Win32::Process::GetExitCode ($self->{PROCESS}, $result);
 314     if ($result != 0) {
 315         $PerlACE::ProcessVX::DoVxInit = 1; # force reboot on next run
 316     }
 317     return $result;
 318 }
 319
 320
 321
 322 # Kill the process
 323
 324 sub Kill ()
 325 {
 326     my $self = shift;
 327
 328     if ($self->{RUNNING}) {
 329         Win32::Process::Kill ($self->{PROCESS}, -1);
 330     }
 331
 332     $self->{RUNNING} = 0;
 333 }
 334
 335 sub handle_vxtest_file
 336 {
 337     my $self = shift;
 338     my $vxtestfile = shift;
 339     my $vx_ref = shift;
 340     my $unld_ref = shift;
 341     my $fh = new FileHandle;
 342
 343     if (defined $self->{TARGET} && $self->{TARGET}->SystemLibs()) {
 344         my @tokens = split(/;/, $self->{TARGET}->SystemLibs());
 345         foreach my $token (@tokens) {
 346             push @$vx_ref, "copy \"" . $ENV{'ACE_RUN_VX_TGTSVR_ROOT'} . "/lib/" . $token . "\" .";
 347         }
 348     }
 349     if (!$PerlACE::Static) {
 350         if (open ($fh, $vxtestfile)) {
 351             my $line1 = <$fh>;
 352             chomp $line1;
 353             while(<$fh>) {
 354                 $line1 = $_;
 355                 chomp $line1;
 356                 push @$vx_ref, "copy \"" . $ENV{'ACE_RUN_VX_TGTSVR_ROOT'} . "/lib/$line1" . "d.dll\" .";
 357                 unshift @$unld_ref, "del $line1" . "d.dll";
 358             }
 359             close $fh;
 360         } else {
 361             return 0;
 362         }
 363     }
 364     return 1;
 365 }
 366
 367
 368 1;