ACE/bin/PerlACE/Process_Unix.pm

   1 #!/usr/bin/env perl
   2
   3 package PerlACE::Process;
   4
   5 use strict;
   6 use POSIX "sys_wait_h";
   7 use Cwd;
   8 use File::Basename;
   9 use Config;
  10
  11 ###############################################################################
  12
  13 ###  Grab signal names
  14
  15 my @signame;
  16
  17 if (defined $Config{sig_name}) {
  18     my $i = 0;
  19     foreach my $name (split (' ', $Config{sig_name})) {
  20         $signame[$i] = $name;
  21         $i++;
  22     }
  23 }
  24 else {
  25     my $i;
  26     for ($i = 0; $i < 255; ++$i) {
  27         $signame[$i] = $i;
  28     }
  29 }
  30
  31 ###############################################################################
  32
  33 ### Constructor and Destructor
  34
  35 sub new
  36 {
  37     my $proto = shift;
  38     my $class = ref ($proto) || $proto;
  39     my $self = {};
  40
  41     $self->{RUNNING} = 0;
  42     $self->{IGNOREEXESUBDIR} = 0;
  43     $self->{IGNOREHOSTROOT} = 0;
  44     $self->{PROCESS} = undef;
  45     $self->{EXECUTABLE} = shift;
  46     $self->{ARGUMENTS} = shift;
  47     $self->{VALGRIND_CMD} = $ENV{'ACE_RUN_VALGRIND_CMD'};
  48
  49     if (!defined $PerlACE::Process::WAIT_DELAY_FACTOR) {
  50          if (defined $self->{PURIFY_CMD}) {
  51             $PerlACE::Process::WAIT_DELAY_FACTOR = 10;
  52          }
  53          elsif (defined $self->{VALGRIND_CMD}) {
  54             $PerlACE::Process::WAIT_DELAY_FACTOR = 10;
  55          }
  56          else {
  57             $PerlACE::Process::WAIT_DELAY_FACTOR = 1;
  58         }
  59     }
  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
  75     if (defined $self->{SCRIPTFILE}) {
  76         unlink $self->{SCRIPTFILE};
  77     }
  78 }
  79
  80 ###############################################################################
  81
  82 ### Some Accessors
  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     if ($self->{IGNOREHOSTROOT} == 0) {
  95         if (PerlACE::is_vxworks_test()) {
  96             $executable = PerlACE::VX_HostFile ($executable);
  97         }
  98     }
  99
 100     if ($self->{IGNOREEXESUBDIR}) {
 101         return $executable;
 102     }
 103
 104     my $basename = basename ($executable);
 105     my $dirname = dirname ($executable).'/';
 106
 107     my $subdir = $PerlACE::Process::ExeSubDir;
 108     if (defined $self->{TARGET} && defined $self->{TARGET}->{EXE_SUBDIR}) {
 109         $subdir = $self->{TARGET}->{EXE_SUBDIR};
 110     }
 111
 112     $executable = $dirname . $subdir . $basename;
 113     return $executable;
 114 }
 115
 116 sub Arguments
 117 {
 118     my $self = shift;
 119
 120     if (@_ != 0) {
 121         $self->{ARGUMENTS} = shift;
 122     }
 123
 124     return $self->{ARGUMENTS};
 125 }
 126
 127 sub ReadPidFile ()
 128 {
 129     my $self = shift;
 130     my $tgt_pidfile = shift;
 131     my $rc = 0;
 132     # If a filesystem mapping exists
 133     if (defined $self->{TARGET} && defined $self->{TARGET}{TEST_FSROOT} &&
 134         defined $ENV{TEST_ROOT}) {
 135       my $pidfile = PerlACE::rebase_path ($tgt_pidfile,
 136                                           $self->{TARGET}->{TEST_FSROOT},
 137                                           $self->{TARGET}->{TEST_ROOT});
 138       if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 139         print STDERR "Checking for pid file $pidfile\n";
 140       }
 141
 142       if (-f $pidfile) {
 143         if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 144           print STDERR "Found mapped pid file\n";
 145         }
 146         if (open(PID, "<$pidfile")) {
 147           $rc = <PID>;
 148           close PID;
 149           if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 150             print STDERR "Read $rc from mapped file\n";
 151           }
 152           if ($rc) {
 153             unlink $pidfile;
 154           }
 155         } else {
 156           if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 157             print STDERR "Could not open mapped pid file\n";
 158           }
 159         }
 160       } else {
 161         if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 162           print STDERR "Could not find mapped file " . basename($pidfile) . "\n";
 163         }
 164       }
 165     } else {
 166       my $shell = $self->{TARGET}->{REMOTE_SHELL};
 167       print STDERR "trying to remote read PID from file $tgt_pidfile\n";
 168       $rc = int(`$shell 'if [ -e $tgt_pidfile -a -s $tgt_pidfile ] ; then cat $tgt_pidfile; rm -f $tgt_pidfile >/dev/null 2>&1; else echo 0; fi'`);
 169     }
 170     return $rc;
 171 }
 172
 173 sub CommandLine ()
 174 {
 175     my $self = shift;
 176
 177     my $exe = File::Spec->rel2abs ($self->Executable ());
 178     my $cur_root = $ENV{TEST_ROOT};
 179
 180     # Translate to target
 181     if (defined $self->{TARGET} && defined $ENV{TEST_ROOT} &&
 182         defined $self->{TARGET}->{TEST_ROOT}) {
 183       $exe = PerlACE::rebase_path ($exe,
 184                                    $ENV{TEST_ROOT},
 185                                    $self->{TARGET}->{TEST_ROOT});
 186       $cur_root = $self->{TARGET}->{TEST_ROOT};
 187     }
 188
 189     # Translate to different filesystem
 190     if (defined $self->{TARGET} && defined $ENV{TEST_ROOT} &&
 191         defined $self->{TARGET}->{TEST_FSROOT}) {
 192       $exe = PerlACE::rebase_path ($exe,
 193                                    $cur_root,
 194                                    $self->{TARGET}->{TEST_FSROOT});
 195
 196     } elsif (defined $self->{TARGET} && defined $self->{TARGET}->{TARGET_FSROOT}) {
 197       # If the target's config has a different filesystem root, rebase the executable
 198       # from local root to the target's root.
 199       $exe = File::Spec->rel2abs ($exe);
 200       $exe = PerlACE::rebase_path ($exe,
 201                                    $self->{TARGET}->{HOST_FSROOT},
 202                                    $self->{TARGET}->{TARGET_FSROOT});
 203     }
 204
 205     my $commandline = $exe;
 206     if (defined $self->{REMOTEINFO}) {
 207         my($method)   = $self->{REMOTEINFO}->{method};
 208         my($username) = $self->{REMOTEINFO}->{username};
 209         my($remote)   = $self->{REMOTEINFO}->{hostname};
 210         my($exepath)  = $self->{REMOTEINFO}->{exepath};
 211         my($libpath)  = $self->{REMOTEINFO}->{libpath};
 212         my($exe)      = (defined $exepath ?
 213                         "$exepath/" . basename($commandline) : $commandline);
 214         $commandline  = "$method -l $username $remote \"";
 215         if (defined $libpath) {
 216             my($csh) = (defined $self->{REMOTEINFO}->{shell} &&
 217                         $self->{REMOTEINFO}->{shell} =~ /csh/);
 218             foreach my $pvar ('DYLD_LIBRARY_PATH', 'LD_LIBRARY_PATH',
 219                               'LIBPATH', 'SHLIB_PATH') {
 220                 if ($csh) {
 221                     $commandline .= "if (! \\\$?$pvar) setenv $pvar; " .
 222                                     "setenv $pvar $libpath:\\\$$pvar; ";
 223                 }
 224                 else {
 225                     $commandline .= "$pvar=$libpath:\\\$$pvar; export $pvar; ";
 226                 }
 227             }
 228             my($env) = $self->{REMOTEINFO}->{env};
 229             if (defined $env) {
 230                 foreach my $pvar (keys %$env) {
 231                     if ($csh) {
 232                         $commandline .= "setenv $pvar $$env{$pvar}; ";
 233                     }
 234                     else {
 235                         $commandline .= "$pvar=$$env{$pvar}; export $pvar; ";
 236                     }
 237                 }
 238             }
 239         }
 240         $commandline .= $exe;
 241     }
 242     if (defined $self->{ARGUMENTS}) {
 243         $commandline .= ' '.$self->{ARGUMENTS};
 244     }
 245     # Avoid modifying TAO/tests run_test.pl scripts by using the
 246     # ACE_RUNTEST_ARGS environment variable to append command line
 247     # arguments.
 248     if ($^O eq "nonstop_kernel") {
 249         my $global_args = $ENV{'ACE_RUNTEST_ARGS'};
 250         if ((length($global_args) > 0)
 251             && ($commandline !~ /tao_idl/)) {
 252             $commandline = $commandline
 253                            . ' '
 254                            . $global_args;
 255         }
 256     }
 257     if (defined $self->{REMOTEINFO}) {
 258         $commandline .= '"';
 259     } elsif (defined $self->{TARGET} && defined $self->{TARGET}->{REMOTE_SHELL}) {
 260         my($shell)     = $self->{TARGET}->{REMOTE_SHELL};
 261         my $x_env_ref  = $self->{TARGET}->{EXTRA_ENV};
 262         my($root)      = $self->{TARGET}->ACE_ROOT();
 263         if (!defined $root) {
 264             $root = $ENV{'ACE_ROOT'};
 265         }
 266         my $exedir = cwd ();
 267         if (defined $self->{TARGET} && defined $ENV{TEST_ROOT} &&
 268             defined $self->{TARGET}->{TEST_ROOT}) {
 269           $exedir = PerlACE::rebase_path ($exedir,
 270                                           $ENV{TEST_ROOT},
 271                                           $self->{TARGET}->{TEST_ROOT});
 272           if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 273               print STDERR "INFO: rebased run script exedir to [",$exedir,"]\n";
 274           }
 275         }
 276         my $tgt_exedir = $exedir;
 277
 278         if (defined $self->{TARGET} && defined $ENV{TEST_ROOT} &&
 279             defined $self->{TARGET}->{TEST_FSROOT}) {
 280           $tgt_exedir = PerlACE::rebase_path ($exedir,
 281                                               $self->{TARGET}->{TEST_ROOT},
 282                                               $self->{TARGET}->{TEST_FSROOT});
 283         } elsif (defined $self->{TARGET} &&
 284                  defined $self->{TARGET}->{TARGET_FSROOT}) {
 285           $tgt_exedir = PerlACE::rebase_path ($exedir,
 286                                               $self->{TARGET}->{HOST_FSROOT},
 287                                               $self->{TARGET}->{TARGET_FSROOT});
 288           if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 289               print STDERR "INFO: rebased run script exedir to [",$tgt_exedir,"]\n";
 290           }
 291         }
 292         if (!defined $self->{PIDFILE}) {
 293             # PIDFILE is based on target file system
 294             $self->{PIDFILE} = "$tgt_exedir/ace-".rand(time).".pid";
 295         }
 296         if (!defined $self->{SCRIPTFILE}) {
 297             # SCRIPTFILE is based on host file system
 298             $self->{SCRIPTFILE} = "$exedir/run-".rand(time).".sh";
 299         }
 300         ## create scriptfile
 301         my $libpath = "$root/lib";
 302         if (defined $self->{TARGET}->{LIBPATH}) {
 303             $libpath = PerlACE::concat_path ($libpath, $self->{TARGET}->{LIBPATH});
 304         }
 305         # add working dir by default as for local executions
 306         my $run_script =
 307             # "if [ ! -e /tmp/.acerun ]; then mkdir /tmp/.acerun; fi\n".
 308             "cd $tgt_exedir\n".
 309             "export LD_LIBRARY_PATH=$libpath:.:\$LD_LIBRARY_PATH\n".
 310             "export DYLD_LIBRARY_PATH=$libpath:.:\$DYLD_LIBRARY_PATH\n".
 311             "export LIBPATH=$libpath:.:\$LIBPATH\n".
 312             "export SHLIB_PATH=$libpath:.:\$SHLIB_PATH\n".
 313             "export PATH=\$PATH:$root/bin:$root/lib:$libpath:.\n";
 314         if (defined $self->{TARGET}->{ace_root}) {
 315           $run_script .=
 316             "export ACE_ROOT=$self->{TARGET}->{ace_root}\n";
 317         }
 318         if (defined $self->{TARGET}->{tao_root}) {
 319           $run_script .=
 320             "export TAO_ROOT=$self->{TARGET}->{tao_root}\n";
 321         }
 322
 323         while ( my ($env_key, $env_value) = each(%$x_env_ref) ) {
 324             $run_script .=
 325             "export $env_key=\"$env_value\"\n";
 326         }
 327         $run_script .=
 328           "$commandline &\n";
 329         $run_script .=
 330           "MY_PID=\$!\n".
 331           "echo \$MY_PID > ".$self->{PIDFILE}."\n";
 332         if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 333             $run_script .=
 334               "echo INFO: Process started remote with pid [\$MY_PID]\n";
 335         }
 336         $run_script .= "wait \$MY_PID\n";
 337         unless (open (RUN_SCRIPT, ">".$self->{SCRIPTFILE})) {
 338             print STDERR "ERROR: Cannot Spawn: <", $self->Executable (),
 339                           "> failed to create ",$self->{SCRIPTFILE},"\n";
 340             return -1;
 341         }
 342         print RUN_SCRIPT $run_script;
 343         close RUN_SCRIPT;
 344
 345         if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 346             print STDERR "INFO: created run script [",$self->{SCRIPTFILE},"]\n", $run_script;
 347         }
 348         if ($self->{TARGET}->PutFile ($self->{SCRIPTFILE}) == -1) {
 349           print STDERR "ERROR: Failed to copy <", $self->{SCRIPTFILE},
 350                         "> to target \n";
 351           return -1;
 352         }
 353
 354         $commandline = "$shell \"source $tgt_exedir/".basename ($self->{SCRIPTFILE})."\"";
 355
 356
 357     }
 358
 359     return $commandline;
 360 }
 361
 362 sub IgnoreExeSubDir
 363 {
 364     my $self = shift;
 365
 366     # If we have -Config ARCH, do not set IGNOREEXESUBDIR, since with ARCH
 367     # all executables (even those in $ACE_ROOT/bin, etc.) are located in the
 368     # architecture-specific subdirectory.
 369     if (@_ != 0 && !grep(($_ eq 'ARCH'), @PerlACE::ConfigList::Configs)) {
 370         $self->{IGNOREEXESUBDIR} = shift;
 371     }
 372     elsif (@_ != 0 && $self->{EXECUTABLE} =~ /perl$/) {
 373         $self->{IGNOREEXESUBDIR} = shift;
 374     }
 375
 376     return $self->{IGNOREEXESUBDIR};
 377 }
 378
 379 sub IgnoreHostRoot
 380 {
 381     my $self = shift;
 382
 383     if (@_ != 0) {
 384         $self->{IGNOREHOSTROOT} = shift;
 385     }
 386
 387     return $self->{IGNOREHOSTROOT};
 388 }
 389
 390 sub RemoteInformation
 391 {
 392     my($self)   = shift;
 393     my(%params) = @_;
 394
 395     ## Valid keys for %params
 396     ##  hostname - The remote hostname
 397     ##  method   - either rsh or ssh
 398     ##  username - The remote user name
 399     ##  exepath  - The remote path to the executable
 400     ##  shell    - The shell of the remote user
 401     ##  libpath  - A library path for libraries required by the executable
 402     ##  env      - A hash reference of name value pairs to be set in the
 403     ##             environment prior to executing the executable.
 404     ##
 405     ## At a minimum, the user must provide the remote hostname.
 406
 407     if (defined $params{'hostname'}) {
 408         my(@pwd) = getpwuid($<);
 409         $self->{REMOTEINFO} = \%params;
 410         if (!defined $self->{REMOTEINFO}->{'method'}) {
 411             $self->{REMOTEINFO}->{'method'} = 'ssh';
 412         }
 413         if (!defined $self->{REMOTEINFO}->{'username'}) {
 414             $self->{REMOTEINFO}->{'username'} = $pwd[0] ||
 415                     $ENV{LOGNAME} || $ENV{USERNAME};
 416         }
 417         if (!defined $self->{REMOTEINFO}->{'shell'}) {
 418             $self->{REMOTEINFO}->{'shell'} = basename($pwd[8]);
 419         }
 420     }
 421 }
 422
 423 ###############################################################################
 424
 425 # Spawn the process and continue;
 426
 427 sub Normalize_Executable_Name
 428 {
 429     my $executable = shift;
 430
 431     my $basename = basename ($executable);
 432     my $dirname = dirname ($executable). '/';
 433
 434     $executable = $dirname.$PerlACE::Process::ExeSubDir.$basename;
 435
 436     return $executable;
 437 }
 438
 439 sub Spawn ()
 440 {
 441     my $self = shift;
 442
 443     if ($self->{RUNNING} == 1) {
 444         print STDERR "ERROR: Cannot Spawn: <", $self->Executable (),
 445                      "> already running\n";
 446         return -1;
 447     }
 448
 449     if (!defined $self->{EXECUTABLE}) {
 450         print STDERR "ERROR: Cannot Spawn: No executable specified\n";
 451         return -1;
 452     }
 453
 454     if ($self->{IGNOREEXESUBDIR} == 0) {
 455         if (!defined $self->{REMOTEINFO} &&
 456             !(defined $self->{TARGET} && (defined $self->{TARGET}->{REMOTE_SHELL} || defined $self->{TARGET}->{TARGET_FSROOT})) &&
 457             !-f $self->Executable ()) {
 458             print STDERR "ERROR: Cannot Spawn: <", $self->Executable (),
 459                          "> not found\n";
 460             return -1;
 461         }
 462     }
 463
 464     my $cmdline = "";
 465     my $executable = "";
 466
 467     if (defined $self->{VALGRIND_CMD}) {
 468         my $orig_cmdline = $self->CommandLine();
 469         $executable = $self->{VALGRIND_CMD};
 470         my $basename = basename ($self->{EXECUTABLE});
 471
 472         $cmdline = "$executable $orig_cmdline";
 473     }
 474     elsif (defined $ENV{'ACE_TEST_WINDOW'}) {
 475         $cmdline = $ENV{'ACE_TEST_WINDOW'} . ' ' . $self->CommandLine();
 476     }
 477     else {
 478         $executable = $self->Executable();
 479         $executable = File::Spec->rel2abs ($executable);
 480
 481         if (defined $self->{TARGET} && defined $self->{TARGET}->{TARGET_FSROOT}) {
 482           # If the target's config has a different filesystem root, rebase the executable
 483           # from local root to the target's root.
 484           $executable = PerlACE::rebase_path ($executable,
 485                                        $self->{TARGET}->{HOST_FSROOT},
 486                                        $self->{TARGET}->{TARGET_FSROOT});
 487         }
 488         $cmdline = $self->CommandLine();
 489     }
 490
 491     FORK: {
 492         if ($self->{PROCESS} = fork) {
 493             #parent here
 494             bless $self;
 495         }
 496         elsif (defined $self->{PROCESS}) {
 497             #child here
 498             my @cmdlist = $self->parse_command_line($cmdline);
 499             if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 500                 print "INFO: $cmdline\n";
 501                 foreach my $arg (@cmdlist) {
 502                     print "INFO: argument - '$arg'\n";
 503                 }
 504             }
 505             # update environment for target
 506             if (defined $self->{TARGET}) {
 507                 if (!(defined $self->{TARGET}->{REMOTE_SHELL} || defined $self->{REMOTEINFO})) {
 508                     my $x_env_ref = $self->{TARGET}->{EXTRA_ENV};
 509                     while ( my ($env_key, $env_value) = each(%$x_env_ref) ) {
 510                         if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 511                             print "INFO: adding target environment $env_key=$env_value\n";
 512                         }
 513                         $ENV{$env_key} = $env_value;
 514                     }
 515                 }
 516                 if ($self->{TARGET}->{LIBPATH}) {
 517                     if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 518                         print "INFO: adding target libpath ".$self->{TARGET}->{LIBPATH}."\n";
 519                     }
 520                     PerlACE::add_lib_path ($self->{TARGET}->{LIBPATH});
 521                 }
 522             }
 523             if (!(defined $self->{VALGRIND_CMD} || defined $ENV{'ACE_TEST_WINDOW'}) &&
 524                   (defined $self->{TARGET}) && ($ENV{'ACE_ROOT'} ne $self->{TARGET}->ACE_ROOT ())) {
 525                 my $x_dir = dirname ($executable);
 526                 chdir ($x_dir);
 527             }
 528             exec @cmdlist;
 529             die "ERROR: exec failed for <" . $cmdline . ">\n";
 530         }
 531         elsif ($! =~ /No more process/) {
 532             #EAGAIN, supposedly recoverable fork error
 533             sleep 5;
 534             redo FORK;
 535         }
 536         else {
 537             # weird fork error
 538             print STDERR "ERROR: Can't fork <" . $cmdline . ">: $!\n";
 539         }
 540     }
 541
 542     if (defined $self->{TARGET} && defined $self->{TARGET}->{REMOTE_SHELL}) {
 543         my $pidfile = $self->{PIDFILE};
 544         ## wait max 10 * $PerlACE::Process::WAIT_DELAY_FACTOR sec for pid file to appear
 545         my $start_tm = time ();
 546         my $max_wait = 10;
 547         if ($PerlACE::Process::WAIT_DELAY_FACTOR > 0) {
 548             $max_wait *= $PerlACE::Process::WAIT_DELAY_FACTOR;
 549         }
 550         my $rc = 1;
 551         while ((time() - $start_tm) < $max_wait) {
 552             select(undef, undef, undef, 0.2);
 553             $rc = $self->ReadPidFile($pidfile);
 554             if ($rc != 0) {
 555                 $self->{REMOTE_PID} = $rc;
 556                 last;
 557             }
 558         }
 559         if (!defined $self->{REMOTE_PID}) {
 560             print STDERR "Remote command <" . $cmdline . ">: No PID found at Spawn.\n";
 561         }
 562     }
 563
 564     $self->{RUNNING} = 1;
 565     return 0;
 566 }
 567
 568 sub print_stacktrace_linux
 569 {
 570     my $self = shift;
 571
 572     # Get the core file pattern
 573     my $core_pattern_file = "/proc/sys/kernel/core_pattern";
 574     if (!(-e $core_pattern_file)) {
 575         print STDERR "WARNING: print_stacktrace_linux: Core file pattern $core_pattern_file does not exist\n";
 576         return;
 577     }
 578
 579     my $pattern_fh;
 580     if (!open ($pattern_fh, "<", "$core_pattern_file")) {
 581         print STDERR "WARNING: print_stacktrace_linux: Could not open $core_pattern_file: $!\n";
 582         return;
 583     }
 584
 585     my $line = <$pattern_fh>;
 586     chomp ($line);
 587     close ($pattern_fh);
 588
 589     if ($line =~ /\|/) {
 590         print STDERR "WARNING: print_stacktrace_linux: Core files are handled by a separate service. Core pattern: $line\n";
 591         return;
 592     }
 593
 594     # Find the core file from the pattern
 595     my $path = ".";
 596     my $pattern;
 597     if ($line =~ /^(.*)\/([^\/]*)$/) {
 598         $path = $1;
 599         $pattern = $2;
 600     }
 601     else {
 602         $pattern = $line;
 603     }
 604
 605     # If /proc/sys/kernel/core_uses_pid is non-zero and the pattern
 606     # doesn't have %p, then .PID is appended to the core file name.
 607     my $uses_pid_file = "/proc/sys/kernel/core_uses_pid";
 608     my $uses_pid = 0;
 609     if (!open (my $uses_pid_fh, "<", "$uses_pid_file")) {
 610         print STDERR "WARNING: print_stacktrace_linux: Could not open $uses_pid_file: $!\n";
 611     }
 612     else {
 613         $line = <$uses_pid_fh>;
 614         chomp ($line);
 615         if ($line ne "" || $line ne "\n") {
 616             $uses_pid = $line;
 617         }
 618         close ($uses_pid_fh);
 619     }
 620
 621     my $exec_path = $self->Executable ();
 622
 623     my $exec_name_idx = index ($pattern, "%e");
 624     if ($exec_name_idx != -1) {
 625         my $exec_name = File::Basename::basename ($exec_path);
 626         # The core file name contains at most 15 characters from the executable name
 627         # (https://man7.org/linux/man-pages/man5/core.5.html).
 628         $exec_name = substr ($exec_name, 0, 15);
 629         substr ($pattern, $exec_name_idx, 2) = $exec_name;
 630     }
 631
 632     my $hname_idx = index ($pattern, "%h");
 633     if ($hname_idx != -1) {
 634         substr ($pattern, $hname_idx, 2) = Sys::Hostname::hostname ();
 635     }
 636
 637     my $pid_idx = index ($pattern, "%p");
 638     if ($pid_idx != -1) {
 639         substr ($pattern, $pid_idx, 2) = $self->{PROCESS};
 640     }
 641     elsif ($uses_pid != 0) {
 642         $pattern = $pattern . "." . $self->{PROCESS};
 643     }
 644
 645     my $timestamp_idx = index ($pattern, "%t");
 646     my $core_file_path;
 647     if ($timestamp_idx != -1) {
 648         my $prefix = substr ($pattern, 0, $timestamp_idx);
 649         my $suffix_len = length ($pattern) - $timestamp_idx - 2;
 650         my $suffix = substr ($pattern, $timestamp_idx + 2, $suffix_len);
 651
 652         # Get the core file with latest timestamp.
 653         my $dh;
 654         if (!opendir ($dh, $path)) {
 655             print STDERR "WARNING: print_stacktrace_linux: Couldn't opendir $path: $!\n";
 656             return;
 657         }
 658         my @files = grep (/$prefix[0-9]+$suffix/, readdir ($dh));
 659         my $latest_timestamp;
 660         my $chosen_core_file;
 661         foreach my $file (@files) {
 662             my $timestamp_len = length ($file) - $timestamp_idx - $suffix_len;
 663             my $timestamp = substr ($file, $timestamp_idx, $timestamp_len);
 664             if (!defined $latest_timestamp) {
 665                 $latest_timestamp = $timestamp;
 666                 $chosen_core_file = $file;
 667             }
 668             elsif ($latest_timestamp < $timestamp) {
 669                 $latest_timestamp = $timestamp;
 670                 $chosen_core_file = $file;
 671             }
 672         }
 673         closedir ($dh);
 674         if (defined $chosen_core_file) {
 675             $core_file_path = $path . "/" . $chosen_core_file;
 676         }
 677         else {
 678             print STDERR "WARNING: print_stacktrace_linux: Could not determine a core file with timestamp\n";
 679             return;
 680         }
 681     }
 682     else {
 683         $core_file_path = $path . "/" . $pattern;
 684     }
 685
 686     my $debugger = "gdb";
 687     if ($ENV{ACE_TEST_DEBUGGER}) {
 688         $debugger = $ENV{ACE_TEST_DEBUGGER};
 689     }
 690     $self->print_stacktrace_common($exec_path, $core_file_path, $debugger);
 691 }
 692
 693 sub print_stacktrace_darwin
 694 {
 695     my $self = shift;
 696     my $core_file_path = "/cores/core." . $self->{PROCESS};
 697
 698     my $debugger = "lldb";
 699     if ($ENV{ACE_TEST_DEBUGGER}) {
 700         $debugger = $ENV{ACE_TEST_DEBUGGER};
 701     }
 702     $self->print_stacktrace_common($self->Executable (), $core_file_path, $debugger);
 703 }
 704
 705 sub print_stacktrace_common
 706 {
 707     my $self = shift;
 708     my $exec_path = shift;
 709     my $core_file_path = shift;
 710     my $preferred_db = shift;
 711
 712     if (!(-e $core_file_path)) {
 713         print STDERR "WARNING: print_stacktrace_common: Core file $core_file_path does not exist\n";
 714         return;
 715     }
 716     if (!defined $preferred_db) {
 717         $preferred_db = "gdb";
 718     }
 719     my $preferred_cmd;
 720     my $secondary_db;
 721     my $secondary_cmd;
 722     my $gdb_args = " $exec_path -c $core_file_path -ex bt -ex quit";
 723     my $lldb_args = " $exec_path -c $core_file_path -o bt -o quit";
 724
 725     if ($preferred_db =~ /gdb/) {
 726         $preferred_cmd = $preferred_db . $gdb_args;
 727         $secondary_db = "lldb";
 728         $secondary_cmd = $secondary_db . $lldb_args;
 729     }
 730     elsif ($preferred_db =~ /lldb/) {
 731         $preferred_cmd = $preferred_db . $lldb_args;
 732         $secondary_db = "gdb";
 733         $secondary_cmd = $secondary_db . $gdb_args;
 734     }
 735     else {
 736         print STDERR "ERROR: print_stacktrace_common: Unknown debugger ($preferred_db) requested\n";
 737         return;
 738     }
 739
 740     my $stack_trace;
 741     if (system ("$preferred_db --version") != -1) {
 742         $stack_trace = `$preferred_cmd`;
 743     }
 744     elsif (system ("$secondary_db --version") != -1) {
 745         print STDERR "WARNING: print_stacktrace_common: Failed printing stack trace with $preferred_db. Trying $secondary_db...\n";
 746         $stack_trace = `$secondary_cmd`;
 747     }
 748     else {
 749         print STDERR "WARNING: print_stacktrace_common: Failed printing stack trace with both $preferred_db and $secondary_db\n";
 750     }
 751
 752     if (defined $stack_trace) {
 753         print STDERR "\n======= Begin stack trace of $exec_path from core file $core_file_path =======\n";
 754         print STDERR $stack_trace;
 755         print STDERR "======= End stack trace =======\n";
 756     }
 757 }
 758
 759 # The second argument is an optional output argument that, if present,
 760 # will be passed to check_return_value function to get the signal number
 761 # the process has received, if any, and/or whether there was a core dump.
 762 sub WaitKill ($;$)
 763 {
 764     my $self = shift;
 765     my $timeout = shift;
 766     my $opts = shift;
 767
 768     if ($self->{RUNNING} == 0) {
 769         return 0;
 770     }
 771
 772     my $has_core;
 773     my %my_opts = (dump_ref => \$has_core);
 774
 775     if (defined $opts) {
 776         if (defined $opts->{self_crash}) {
 777             $my_opts{self_crash} = $opts->{self_crash};
 778         }
 779         if (defined $opts->{signal_ref}) {
 780             $my_opts{signal_ref} = $opts->{signal_ref};
 781         }
 782     }
 783
 784     my $status = $self->TimedWait ($timeout, \%my_opts);
 785
 786     if ($status == -1) {
 787         print STDERR "ERROR: $self->{EXECUTABLE} timedout\n";
 788
 789         if ($ENV{ACE_TEST_LOG_STUCK_STACKS}) {
 790             my $debugger = $ENV{ACE_TEST_DEBUGGER};
 791             if (!defined $debugger) {
 792                 $debugger = ($^O eq 'darwin') ? 'lldb' : 'gdb';
 793             }
 794
 795             my $commands = ($debugger eq 'gdb') ?
 796               "-ex 'set pagination off' -ex 'thread apply all backtrace'" : "-o 'bt all'";
 797             print STDERR "\n======= Begin stuck stacks =======\n";
 798             system "$debugger --batch -p $self->{PROCESS} $commands";
 799             print STDERR "======= End stuck stacks =======\n";
 800         }
 801
 802         if ($ENV{ACE_TEST_GENERATE_CORE_FILE}) {
 803             system ($^O ne 'darwin') ? "gcore $self->{PROCESS}"
 804               : "lldb -b -p $self->{PROCESS} -o " .
 805               "'process save-core core.$self->{PROCESS}'";
 806         }
 807
 808         $self->Kill ();
 809     }
 810     elsif ($status == 255 && $has_core && !$ENV{ACE_TEST_DISABLE_STACK_TRACE}) {
 811         if ($^O eq 'linux') {
 812             $self->print_stacktrace_linux ();
 813         }
 814         elsif ($^O eq 'darwin') {
 815             $self->print_stacktrace_darwin ();
 816         }
 817     }
 818
 819     if (defined $opts && defined $opts->{dump_ref}) {
 820         ${$opts->{dump_ref}} = $has_core;
 821     }
 822
 823     $self->{RUNNING} = 0;
 824
 825     return $status;
 826 }
 827
 828 # Do a Spawn and immediately WaitKill
 829 sub SpawnWaitKill ($;$)
 830 {
 831     my $self = shift;
 832     my $timeout = shift;
 833     my $opts = shift;
 834
 835     if ($self->Spawn () == -1) {
 836         return -1;
 837     }
 838
 839     return $self->WaitKill ($timeout, $opts);
 840 }
 841
 842 sub TerminateWaitKill ($)
 843 {
 844     my $self = shift;
 845     my $timeout = shift;
 846
 847     if ($self->{RUNNING}) {
 848         print STDERR "INFO: $self->{EXECUTABLE} being killed.\n";
 849         kill ('TERM', $self->{PROCESS});
 850     }
 851
 852     return $self->WaitKill ($timeout, {self_crash => 1});
 853 }
 854
 855 # Really only for internal use.
 856 # The second optional argument is a hash reference with the following keys.
 857 # 1. "self_crash" indicates if the process may receive a signal intentionally.
 858 # In that case, a signal may originate from the process, e.g., by calling abort(),
 859 # or from an associated Perl script, e.g., by calling kill. If "self_crash" is
 860 # missing, it has the same meaning as if "self_crash" is evaluated to false.
 861 # A signal intentionally received can be either KILL, TERM, or ABRT. Any other
 862 # signal indicates there was an actual error.
 863 # 2. "signal_ref" is a scalar reference that will hold the signal number, if any.
 864 # 3. "dump_ref" is a scalar reference that indicates if there was a core dump.
 865 sub check_return_value ($)
 866 {
 867     my $self = shift;
 868     my $rc = shift;
 869     my $opts = shift // {};
 870
 871     # NSK OSS has a 32-bit waitpid() status
 872     my $is_NSK = ($^O eq "nonstop_kernel");
 873     my $CC_MASK = $is_NSK ? 0xffff00 : 0xff00;
 874
 875     # Exit code processing
 876     if ($rc == 0) {
 877         return 0;
 878     }
 879     elsif ($rc == $CC_MASK) {
 880         print STDERR "ERROR: <", $self->{EXECUTABLE},
 881                      "> failed: $!\n";
 882         return ($rc >> 8);
 883     }
 884     elsif (($rc & 0xff) == 0) {
 885         return ($rc >> 8);
 886     }
 887
 888     # Ignore NSK 16-bit completion code
 889     $rc &= 0xff if $is_NSK;
 890
 891     # Remember Core dump flag
 892     my $dump = 0;
 893
 894     if ($rc & 0x80) {
 895         $rc &= ~0x80;
 896         $dump = 1;
 897     }
 898
 899     # A undef means the process does not self crash
 900     my $self_crash = $opts->{self_crash};
 901
 902     # ABRT, KILL or TERM can be sent deliberately
 903     if ($self_crash && ($rc == 6 || $rc == 9 || $rc == 15)) {
 904         return 0;
 905     }
 906
 907     my $signal_ref = $opts->{signal_ref};
 908     if (defined $signal_ref) {
 909         ${$signal_ref} = $rc;
 910     }
 911
 912     my $dump_ref = $opts->{dump_ref};
 913     if (defined $dump_ref) {
 914         ${$dump_ref} = $dump;
 915     }
 916
 917     print STDERR "ERROR: <", $self->{EXECUTABLE},
 918                  "> exited with ";
 919
 920     print STDERR "coredump from " if ($dump == 1);
 921
 922     print STDERR "signal $rc : ", $signame[$rc], "\n";
 923
 924     return 255;
 925 }
 926
 927 # for internal use
 928 sub parse_command_line ($)
 929 {
 930     my $self = shift;
 931     my $cmdline = shift;
 932     $cmdline =~ s/^\s+//;
 933
 934     my @cmdlist = ();
 935     while ($cmdline ne '') {
 936         if ($cmdline =~ /^\"([^\"\\]*(?:\\.[^\"\\]*)*)\"(.*)/) {
 937             my $unquoted = $1;
 938             $cmdline = $2;
 939             $unquoted =~ s/\\\"/\"/g;
 940             push @cmdlist, $unquoted;
 941         }
 942         elsif ($cmdline =~ /^\'([^\'\\]*(?:\\.[^\'\\]*)*)\'(.*)/) {
 943             my $unquoted = $1;
 944             $cmdline = $2;
 945             $unquoted =~ s/\\\'/\'/g;
 946             push @cmdlist, $unquoted;
 947         }
 948         elsif ($cmdline =~ /^([^\s]*)(.*)/) {
 949             push @cmdlist, $1;
 950             $cmdline = $2;
 951         }
 952         else {
 953             # this must be some kind of error
 954             push @cmdlist, $cmdline;
 955         }
 956         $cmdline =~ s/^\s+//;
 957     }
 958
 959     return @cmdlist;
 960 }
 961
 962 sub Kill ($)
 963 {
 964     my $self = shift;
 965     my $ignore_return_value = shift;
 966
 967     # If Remote PID not known, but should be
 968     if (defined $self->{TARGET} &&
 969         defined $self->{TARGET}->{REMOTE_SHELL} &&
 970         !defined $self->{REMOTE_PID}) {
 971         my $rc = $self->ReadPidFile($self->{PIDFILE});
 972         if ($rc != 0) {
 973             $self->{REMOTE_PID} = $rc;
 974         }
 975     }
 976
 977     my $child_killed = 0;
 978
 979     if ($self->{RUNNING} && !defined $ENV{'ACE_TEST_WINDOW'}) {
 980         if (defined $self->{TARGET} && defined $self->{TARGET}->{REMOTE_SHELL}) {
 981             # Kill remote process
 982             if (defined $self->{REMOTE_PID}) {
 983                 my $cmd = $self->{TARGET}->{REMOTE_SHELL}." kill -s KILL ".$self->{REMOTE_PID};
 984                 if (defined $ENV{'ACE_TEST_VERBOSE'}) {
 985                     print STDERR "INFO: Killing remote process <", $cmd, ">\n";
 986                 select(undef, undef, undef, .5);
 987                 }
 988                 $cmd = `$cmd 2>&1`;
 989                 # Wait to give remote process time to exit
 990                 select(undef, undef, undef, 3.0);
 991             } else {
 992                 print STDERR "INFO: remote process PID unknown, can't kill\n";
 993             }
 994         } else {
 995             kill ('KILL', $self->{PROCESS});
 996             $child_killed = 1;
 997         }
 998
 999
1000         for(my $i = 0; $i < 10; $i++) {
1001             my $pid = waitpid ($self->{PROCESS}, WNOHANG);
1002             if ($pid > 0) {
1003                 if (! $ignore_return_value) {
1004                     $self->check_return_value ($?, {self_crash => 1});
1005                 }
1006                 last;
1007             }
1008             else {
1009                 if (!$child_killed) {
1010                   # Kill child process (may be remote shell))
1011                   kill ('KILL', $self->{PROCESS});
1012                   $child_killed = 1;
1013                 }
1014                 select(undef, undef, undef, .5);
1015             }
1016         }
1017     }
1018
1019     $self->{RUNNING} = 0;
1020 }
1021
1022 # Wait until a process exits.
1023 # return -1 if the process is still alive.
1024 sub Wait ($)
1025 {
1026     my $self = shift;
1027     my $timeout = shift;
1028     if (!defined $self->{PROCESS}) {
1029         return 0;
1030     }
1031     if (!defined $timeout || $timeout < 0) {
1032         return waitpid ($self->{PROCESS}, 0);
1033     } else {
1034         return TimedWait($self, $timeout);
1035     }
1036
1037 }
1038
1039 # The second argument is an optional output argument that, if present,
1040 # will contain the signal number that the process has received, if any,
1041 # and/or whether there was a core dump.
1042 sub TimedWait ($;$)
1043 {
1044     my $self = shift;
1045     my $timeout = shift;
1046     my $opts = shift;
1047
1048     if (!defined $self->{PROCESS}) {
1049         return 0;
1050     }
1051
1052     if ($PerlACE::Process::WAIT_DELAY_FACTOR > 0) {
1053         $timeout *= $PerlACE::Process::WAIT_DELAY_FACTOR;
1054     }
1055
1056     # Multiply with 10 because we wait a tenth of a second each time
1057     $timeout *= 10;
1058
1059     while ($timeout-- != 0) {
1060         my $pid = waitpid ($self->{PROCESS}, &WNOHANG);
1061         if ($pid != 0 && $? != -1) {
1062             return $self->check_return_value ($?, $opts);
1063         }
1064         select(undef, undef, undef, 0.1);
1065     }
1066
1067     return -1;
1068 }
1069
1070 ###
1071
1072 sub kill_all
1073 {
1074     my $procmask = shift;
1075     my $target = shift;
1076     my $pid = -1;
1077     my $cmd;
1078     my $valgrind_cmd = $ENV{'ACE_RUN_VALGRIND_CMD'};
1079     my $ps_cmd = 'ps -ef';
1080     my $ps_pid_field = 1;
1081     my $ps_cmd_field = 7;
1082     my $ps_skip_first = 1;
1083     my @ps_fields = 0;
1084     if (defined $target && defined $target->{PS_CMD}) {
1085         ## in case a special command is required
1086         ## format: <cmd>:<pid field index>:<cmd field index>[:<skip headers flag>]
1087         $ps_cmd_field = -1;
1088         @ps_fields = split (/:/, $target->{PS_CMD});
1089         $ps_cmd = $ps_fields[0];
1090         if (@ps_fields > 1) {
1091             $ps_pid_field = $ps_fields[1];
1092             if (@ps_fields > 2) {
1093                 $ps_cmd_field = $ps_fields[2];
1094                 if (@ps_fields > 3) {
1095                     $ps_skip_first = ($ps_fields[3] == '1' ? 1 : 0);
1096                 }
1097             }
1098         } else {
1099             print STDERR "ERROR: Missing field index for PID in [PS_CMD=".$target->{PS_CMD}."]\n";
1100             return 0;
1101         }
1102         @ps_fields = 0;
1103     } else {
1104         my $which_ps;
1105         if (defined $target && defined $target->{REMOTE_SHELL}) {
1106           $which_ps = $target->{REMOTE_SHELL} . ' which ps';
1107         } else {
1108           $which_ps = 'which ps';
1109         }
1110         my $ps_file = `$which_ps`;
1111         if (defined $target && defined $target->{REMOTE_SHELL}) {
1112           $which_ps = $target->{REMOTE_SHELL} . " readlink $ps_file";
1113           $ps_file = `$which_ps`;
1114         }
1115         $ps_file =~ s/^\s+//;
1116         $ps_file =~ s/\s+$//;
1117         if (($ps_file =~ /busybox/) or ((-l $ps_file) and (readlink ($ps_file)) =~ /busybox/)) {
1118             ## some embedded targets use BusyBox for base tools
1119             ## with different arguments
1120             $ps_cmd = 'ps w';
1121             $ps_pid_field = 0;
1122             $ps_cmd_field = 4;
1123         }
1124     }
1125     if (defined $target && defined $target->{REMOTE_SHELL}) {
1126         $ps_cmd = $target->{REMOTE_SHELL}.' '.$ps_cmd;
1127     }
1128     for my $line (`$ps_cmd`) {
1129         if ($ps_skip_first) {
1130             # skip first line (headers)
1131             $ps_skip_first = 0;
1132         } else {
1133             # split line
1134             @ps_fields = split (/\s+/, $line);
1135             if (@ps_fields > $ps_pid_field && @ps_fields > $ps_cmd_field) {
1136
1137                 $pid = $ps_fields[$ps_pid_field]; # process PID
1138                 # take care of valgrind runs
1139                 if (defined $valgrind_cmd) {
1140                     my $pos = index ($line, $valgrind_cmd);
1141                     if ($pos >= 0) {
1142                         $cmd = substr ($line, $pos + length ($valgrind_cmd));
1143                         $cmd =~ s/^\s+//; # strip leading ws
1144                         @ps_fields = split (/\s+/, $cmd);
1145                         $cmd = $ps_fields[0];
1146                     } else {
1147                         $cmd = $line;
1148                     }
1149                 } else {
1150                     if ($ps_cmd_field >= 0) {
1151                         $cmd = $ps_fields[$ps_cmd_field]; # process cmd / executable
1152                     } else {
1153                         $cmd = $line;
1154                     }
1155                 }
1156
1157                 # match process cmd
1158                 if ($cmd =~ /$procmask/) {
1159                     if (defined $target && defined $target->{REMOTE_SHELL}) {
1160                         my $kill_cmd = $target->{REMOTE_SHELL}." kill -s KILL $pid";
1161                         $kill_cmd =  `$kill_cmd`;
1162                     } else {
1163                         kill ('KILL', $pid); # kill process
1164                     }
1165                     if (defined $ENV{'ACE_TEST_VERBOSE'}) {
1166                         print STDERR "INFO: Killed process at [$line]\n";
1167                     }
1168                 }
1169             }
1170         }
1171     }
1172 }
1173
1174 1;