view release on metacpan or  search on metacpan

Reliable.pm  view on Meta::CPAN

  else {
    $do_single_list = !wantarray();
  }

  my($pid, $t, $i);

  my $ntry= 0;
  my $starttime= time();
  my $endtime= time() + $self->maxtime();
  my $time_per_try= $self->time_per_try();
  
  my $patout= $self->pattern_stdout();
  my $paterr= $self->pattern_stderr();
  
  my $redo = 0;
  
  #foreach $t (keys(%$self)) {
  #  print("$t $self->{$t}\n");
  #}
  
  $t = 0;

  # initialize object output variables
  $self->{msg} = undef;
  
  my($fileno_getstdout,
     $fileno_getstderr,
     $fileno_getstdin,
     $fileno_putstdout,
     $fileno_putstderr,
     $fileno_putstdin);
  while(1) {
    $Debug && $self->_dprt("ATTEMPT $ntry: '$cmdstr' ");

    # initialize object output variables
    $self->{stdout} = undef;
    $self->{stderr} = undef;
    $self->{status} = undef;
    
    # set up pipes to collect STDOUT and STDERR from child process
    pipe(GETSTDOUT,PUTSTDOUT) || die("couldn't create pipe 1");
    pipe(GETSTDERR,PUTSTDERR) || die("couldn't create pipe 2");
    $fileno_getstdout = fileno(GETSTDOUT) || die("couldn't get fileno 1");
    $fileno_getstderr = fileno(GETSTDERR) || die("couldn't get fileno 2");
    $fileno_putstdout = fileno(PUTSTDOUT) || die("couldn't get fileno 3");
    $fileno_putstderr = fileno(PUTSTDERR) || die("couldn't get fileno 4");
    PUTSTDOUT->autoflush(1);
    PUTSTDERR->autoflush(1);
    if(defined($inputref)) {
      pipe(GETSTDIN,PUTSTDIN) || die("couldn't create pipe 3");
      $fileno_getstdin = fileno(GETSTDIN) || die("couldn't get fileno 5");
      $fileno_putstdin = fileno(PUTSTDIN) || die("couldn't get fileno 6");
      PUTSTDIN->autoflush(1);
    }
    
    # fork starts a child process, returns pid for parent, 0 for child
    STDOUT->flush();   # don't dup a non-empty buffer
    $redo = 0;

    #jvr added
    my($oldsigchld) = $SIG{CHLD};
    $SIG{CHLD} = sub { $self->_collect_child(); };

    ##### PARENT PROCESS #####
    if($pid = fork()) {
      # close the ends of the pipes the child will be using
      close(PUTSTDOUT);
      close(PUTSTDERR);
      if(defined($inputref)) {
	close(GETSTDIN);
      }

      #print("sigs 1: ",$SIG{ALRM}," , ",$SIG{PIPE}," , ",$SIG{CHLD},"\n");
      # set up handler to collect child return status no matter when it dies

      eval {
	# exit the eval if child takes too long or dies abnormally
	local $SIG{ALRM} = sub { die("SIGALRM") };
	local $SIG{PIPE} = sub { die("SIGPIPE") };
	#print("sigs 2: ",$SIG{ALRM}," , ",$SIG{PIPE}," , ",$SIG{CHLD},"\n");
        $t = min($endtime - time(), $time_per_try);
        if($t < 1) {
	  return 1;
        }
	alarm($t);

	# set up and do a select() to read/write the child to avoid deadlocks
	my($stdinlen);
	my($stdoutdone, $stderrdone, $stdindone) = (0, 0, 0);
	my($nfound, $fdopen, $bytestodo, $blocksize, $s);
	my($rin, $win, $ein) = ('', '', '');
	my($rout, $wout, $eout) = ('', '', '');
	my($gotread) = 0;
# bug: occational death with: 'Modification of a read-only value attempted at /home/public/dgold/acsim//Proc/Reliable.pm line 416.'
	vec($rin, $fileno_getstdout, 1) = 1;
	vec($rin, $fileno_getstderr, 1) = 1;
	$blocksize = (stat(GETSTDOUT))[11];
	$fdopen = 2;  # stdout and stderr
	if(defined($inputref)) {
# bug: same bug here
	  vec($win, $fileno_putstdin, 1) = 1;
	  $stdinlen = length($$inputref);
	  if($self->in_after_out_closed()) {
	    $fdopen++;
	  }
	}
	my $cbStdout = $self->{stdout_cb};
	my $cbStderr = $self->{stderr_cb};
	my ($outs,$oute);
	while($fdopen) {
	  $nfound = select($rout=$rin, $wout=$win, $eout=$ein, undef);

	  if(defined($win) && vec($wout, $fileno_putstdin, 1)) {  # ready to write
	    #print("write ready\n");
	    my($indone) = 0;
	    if($self->input_chunking()) {
	      if($gotread) {
		$gotread = 0;
		my($inputline) = shift(@inputlines) . "\n";
		$stdinlen = length($inputline);
		#print("writing $stdinlen '$inputline'\n");

Reliable.pm  view on Meta::CPAN

	#print("bytes processed: $stdindone $stdoutdone $stderrdone\n");
	#if($self->input_chunking() && scalar(@inputlines)) {
	#  print(scalar(@inputlines) . " lines of stdin not fed\n");
	#}
	alarm(0);
	return 1;
      };  # end of eval

      # check return status of eval()
      if($@) {  # exited from eval() via die()
	if($@ =~ /SIG(ALRM|PIPE)/) {
	  my($sig) = $1;
	  if($sig eq "ALRM") {
	    $self->{msg} .= "Timed out after $t seconds\n";
	  }
	  else {
	    $self->{msg} .= "Pipe error talking to subprocess\n";
	  }
	  $redo++;
	}
	else {   # only a code bug should get here
	  croak("unexpected error talking to subprocess: '$@'");
	}
      }

      # wait until child exits, kill it if it doesn't.
      # normally child will exit shortly unless eval failed via SIGALRM.
      # if eval() succeeded, wait up to child_exit_time for child to exit
      my($s) = 0;
      while(!$redo && !defined($self->{status}) && kill(0, $pid) && ($s < $self->child_exit_time)) {
	#print("waiting for exit\n");
	select(undef, undef, undef, $_WAIT_INCR_SEC);
	$s += $_WAIT_INCR_SEC;
      }
      
      # if child has not exited yet, send sigterm.
      if(!defined($self->{status}) && kill(0, $pid) && $self->sigterm_exit_time) {  # child still alive
	#print("sending term\n");
	kill('TERM', $pid);
      }

      # wait until process exits or wait-time is exceeded.
      $s = 0;
      while(!defined($self->{status}) && kill(0, $pid) && ($s < $self->sigterm_exit_time)) {
	select(undef, undef, undef, $_WAIT_INCR_SEC);
	$s += $_WAIT_INCR_SEC;
      }

      if(!defined($self->{status}) && kill(0, $pid) && $self->sigkill_exit_time) {  # child still alive
	#print("sending kill\n");
	kill('KILL', $pid);
      }

      # wait until process exits or wait-time is exceeded.
      $s = 0;
      while(!defined($self->{status}) && kill(0, $pid) && ($s < $self->sigkill_exit_time)) {
	select(undef, undef, undef, $_WAIT_INCR_SEC);
	$s += $_WAIT_INCR_SEC;
      }

      $SIG{CHLD} = $oldsigchld;  # why is this giving '-w' warning?

      #print("sigs 3: ",$SIG{ALRM}," , ",$SIG{PIPE}," , ",$SIG{CHLD},"\n");
      
      if(!defined($self->{status})) {
	if(kill(0, $pid)) {
	  # get here if unable to kill or if coredump takes longer than sigkill_exit_time
	  $self->{msg} .= "unable to kill subprocess $pid";
	}
	$self->{status} = -1;
	$self->{msg} .= "no return status from subprocess\n";
      }
      else {
	if(kill(0, $pid)) {
	  # most likely coredumping?
	  $self->{msg} .= "got return status but subprocess still alive\n";
	}
      }
   }

    ##### CHILD PROCESS #####
    elsif(defined($pid)) {    # if child process: $pid == 0
      #jvr added
      $SIG{CHLD} = 'DEFAULT';

      close(GETSTDOUT); close(GETSTDERR);
      if(defined($inputref)) {
	close(PUTSTDIN);
      }
      
      open(STDOUT, ">&=PUTSTDOUT") || croak("Couldn't redirect STDOUT: $!");
      if($do_single_list) {
	open(STDERR, ">&=PUTSTDOUT") || croak("Couldn't redirect STDERR: $!");
      }
      else {
	open(STDERR, ">&=PUTSTDERR") || croak("Couldn't redirect STDERR: $!");
      }
      
      if(defined($inputref)) {
	open(STDIN, "<&=GETSTDIN") || croak("Couldn't redirect STDIN: $!");
      }

      my($status) = -1;
      if(ref($cmd) eq "CODE") {
	$status = &$cmd;           # Start perl subroutine
      }
      elsif(ref($cmd) eq "ARRAY") {  # direct exec(), no shell parsing
	exec(@$cmd);
	#croak("exec() failure: '$!'");  # causes warnings with '-w'
      }
      else {                         # start shell process
	exec($cmd);
	#croak("exec() failure: '$!'");  # causes warnings with '-w'
      }

      # we get here for the perl subroutine normally.
      exit $status;
    }
    
    ##### FORK FAILURES #####
    elsif($! =~ /No more process/) {  # temporary fork error