=head1 NAME

CFX5::Commands - Functions for spawning processes

=cut

package CFX5::Commands;

use strict;

use CFX5::Commands::Result;

use vars qw($CVSVersion);
$CVSVersion='$Id$ ';

use Exporter;
use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS);

@ISA=qw(Exporter);
@EXPORT_OK=qw(do_cmd do_cmd_quiet do_termerr_cmd
	      bg_cmd wait_bg_cmd fork_cmd
	      parse_rv handle_rv
	      get_cmd_output do_output_cmd
              do_input_cmd
              split_cmd split_cmd_exec
             );

=head2 Export tags

There is only one export tag, C<:all>, which imports all the functions
defined in this file.

=cut

%EXPORT_TAGS = (
		all => [qw(do_cmd do_cmd_quiet bg_cmd get_cmd_output)],
	       );

use CFX5::Output qw(:all);
use CFX5::Config qw(%Config export_conf);
use CFX5::CurrentConfig qw(%Config);
use CFX5::PkgLoader qw(cfx5_require);
use Carp;

use vars qw(%bg_cmd_status);

#
# bring in the per-OS code
#
if ($^O eq 'MSWin32') {
  require CFX5::Commands::Win32;
} else {
  require CFX5::Commands::UNIX;
}

# load on demand
sub WNOHANG {
  require POSIX;
  return POSIX::WNOHANG();
}

=head2 reap_dead_children

I<Not exportable>

This is a synchronous child reaper.  It is called by the routines in
this file every now and then to ensure that any completed processes
are tidied up, and their exit statuses kept for future reference.  Do
not install this routine as a SIGCHLD handler; not only does this
cause segfaults on the IBM, but it changes the return value of
F<system> calls, which will break all the other functions in this
module!  If you are having trouble with zombie processes, it is
acceptable to call this function periodically to tidy up.

Note that calling C<reap_dead_children> will reset the child process
error indicator C<$?>, even if no child processes were reaped.

=cut

sub reap_dead_children {
  if (defined WNOHANG()) {
    #_debug("Trying to reap children ...");
    my $child;
    while (($child = waitpid(-1,WNOHANG())) and $child!=-1) {
      register_child_death($child,$?);
      _debug("Reaped $child");
    }
  } else {
    #_debug("Ignoring request to reap children on a system without WNOHANG");
  }
}

sub register_child_death {
  my $pid=shift;
  my $rv=shift;

  _debug("Noting death of PID $pid with status $rv");

  $bg_cmd_status{$pid}=$rv;

  1;
}

=head2 do_cmd

Use _trace to log the command, and then run it normally and wait for
it to finish.

The return value from C<do_cmd> is an object of type
CFX5::Commands::Result.

If we are running without a console on Windows NT (see
C<detach_from_console> in L<CFX5::Output>), and this call is used to
open an app which needs a console, this command I<will open a new
window> for the application. This is a limitation of MS-Windows, which
I don't have the time to work around now. See also C<do_cmd_quiet>.

=cut '

use vars qw($LastCmd @LastCmd $LastCmdOutput $LastCmdPID $LastCmdError);
sub do_cmd {
  _trace("do_cmd:", map { qq("$_") } @_);
  $LastCmd=$_[0];
  @LastCmd=@_;
  undef $LastCmdPID;
  undef $LastCmdError;

  # Export the CFX_DATA_DIR environment for solver exec for interpolation.
  export_conf(qw(CFX_DATA_DIR));

  # make sure we are tidied up before we start
  reap_dead_children();

  check_for_executable(@_)
    or return CFX5::Commands::Result->new_not_run("Executable $_[0] not found");

  my $rv;
  my $prog=shift;
  {
    my $arg0=$prog;
    if (@_ and $arg0 =~ m! ! and $arg0 !~ m!\"! and $Config{windows_nt}) {
      # path with spaces and not quoted.  Some commands (Digital
      # Fortran, grrr) do not like this, and Perl seems to have
      # trouble with quoted arguments; to round it all off, we can't
      # use the short pathnames on w2k.  We can, however, use the
      # indirect object syntax of system to specify the binary to run
      # separately from its rendering in the argument vector.
      $arg0='"'.$arg0.'"';
      # $arg0=Win32::GetShortPathName($arg0) || $arg0;
      _debug("Command name containing spaces quoted in command line");
    }
    if (defined $Config{CFX5_SHELL_ON_RUN_RE}
        and $prog =~ m!$Config{CFX5_SHELL_ON_RUN_RE}!) {
      # for debugging, we allow people to provide a RE which starts a
      # shell rather than running the exec directly
      my $shell = $Config{CFX5_SHELL} || $Config{SHELL} || ($Config{windows_nt} ? "cmd" : "/bin/sh");
      my $via='';
      if ($arg0 ne $prog) {
        $via = "via the executable path:\n\n   $prog\n\n";
      }
      _print("\n\n*** Starting shell in place of executable ***\n\nWould run:\n\n   ", join(' ', $arg0, @_) . "\n\n$via");
      $rv = system $shell;
    } else {
      # when run with -w (which one should always do ;-), Perl prints
      # a warning if a system command fails to find its binary. This
      # should supress this warning.
      local $^W=0;
      # reset errno, in the hope that it will only be set if sensible.
      # No guarantee, but it's worth a try.
      $!=0;
      if ($prog =~ m![<>|"']! and not @_) {
        # "program name" contains shell metacharacters, and there's
        # only one argument, so it must be a shell command. Run it as
        # such.
        $rv=system($arg0,@_);
      } else {
        # use exec directly (indirect object version of system forces
        # use of the $prog binary)
        $rv=system $prog ($arg0,@_);
      }
    }
  }

  my $prv=CFX5::Commands::Result->new($rv, $prog);

  if ($Config{windows_nt}) {
    $prv->set_runerr($^E);
  } else {
    if ($!) {
      $prv->set_runerr($!);
    }
  }

  # register the death of a 'dummy' child
  register_child_death(0,$prv->wait_rv());

  # preserve the return value in $?, the standard Perl place for it
  $?=$prv->wait_rv();

  return $prv;
}

=head2 do_cmd_quiet

Use _trace to log the command, and then run it normally and wait for
it to finish.

The return value from C<do_cmd> is the return value from B<wait>, or
its equivalent; see C<parse_rv> for more details.

The difference between this command and C<do_cmd> is only visible on
Windows NT, where C<do_cmd> will start up a command normally, but this
command will start up the command in a minimised window. This is
useful for uninteresting console-mode commands, pending a more general
solution. 

=cut

=head2 do_output_cmd

I<Return value is parsed>

Trace the command line and then run a program, collecting the output
and returning it with the parsed return value.  See also the standard
C<qx{}> (backtick) operator.

The advantage of this function over backticks is that, on Windows NT,
it (a) makes sure the program has a console to run in, which stops a
lot of programs failing to run, and (b) tries to keep any new windows
out of the way as much as possible; it is basically an equivalent of
C<do_cmd_quiet> which collects the output of the program.

Note that, unlike the C<system> call and the C<qx{}> operator, this
function I<may> not send the command to the shell for execution; you
should do that explicitly if required.

Callers wanting a timeout on UNIX can set the alarm before calling
this routine: it will handle SIGALRM appropriately if set, but will
not do anything to set it.  It will also not clear the alarm, so it is
recommended that callers using this feature write code along the lines
of:

  {
    local $SIG{ALRM} = 'IGNORE';
    alarm 60;
    @out=get_output_cmd('prone_to_hang', 'args');
    alarm 0;
  }

=cut

=head2 get_cmd_output

Trace the command line and then run a program. The return value is the
output from the program, or undef if the program cannot be run.  Now
deprecated in favour of do_output_cmd, which returns a parsed rv
object, but still widely used.

=cut

sub get_cmd_output {
  my $prv=do_output_cmd(@_);
  _debug($prv->errstr());
  $prv->cmd_output();
}

=head2 do_termerr_cmd

I<Return value is parsed>

do_termerr_cmd is short for "do a command which might produce terminal
output on error".  It usually calls C<do_cmd> on UNIX, or on Windows
NT if we have a console, under the expectation that the user has a
console on which to display any error messages which may be produced.
However, if we have no console, it will run with C<get_cmd_output> and
pass the terminal output back in the return value, for use in any
error messages which might be produced.  This text is recorded with
for reading via the C<term_error> call on the returned object, and
will automatically be included in any error messages produced.

=cut

sub do_termerr_cmd {
  if (CFX5::Output::have_console()) {
    return parse_rv(do_cmd_quiet(@_));
  }

  # OK, we don't have a console.  This means we need to run the
  # command without one too, get its output, and make it available
  # somewhere.
  my $rv=do_output_cmd(@_);
  # move the output to the error slot.  The reason for two slots is
  # that the error slot is treated specially when constructing error
  # messages. 
  $rv->set_term_error($rv->cmd_output());
  $rv->set_cmd_output();
  return $rv;
}

=head2 do_input_cmd

I<Return value is parsed>

  my $prv=do_input_cmd(\@input, $cmd, @args);

Trace the command line and then run a program, sending the supplied
data to its stdin.  When the list of data is exhausted, closes the
programs stdin and waits for it to exit.

Note that, unlike the C<system> call and the C<qx{}> operator, this
function I<may> not send the command to the shell for execution; you
should do that explicitly if required.

=cut

sub do_input_cmd {
  if ($^O eq 'MSWin32') {
     return do_input_cmd_(@_);
  }
  my $rinput=shift;
  my @cmd=@_;
  _trace "do_input_cmd: @_";
  $LastCmd=$_[0];
  @LastCmd=@_;
  undef $LastCmdPID;
  undef $LastCmdError;

  my @input;

  # ignore pipe signals, as we may well get some.  (Not sure why, but
  # it definitely happens ...)
  local $SIG{PIPE}='IGNORE';

  check_for_executable(@_)
    or return -1;

  # make sure we are tidied up before we start
  reap_dead_children();

  # see perlipc

  local *KID_TO_WRITE;
  my $pid = open(KID_TO_WRITE, "|-");

  if ($pid) {   # parent
    1;
  } elsif (defined $pid) {      # child
    exec(@_)
      || die "can't exec $_[0]: $!";
    # NOTREACHED
  } else {
    _abort("Cannot fork: $!");
  }

  for my $l (@$rinput) {
    print KID_TO_WRITE $l;
  }

  _debug("Finished writing, closing pipe and waiting for exit");

  close(KID_TO_WRITE);

  my $rv=$?;

  $LastCmdPID=$pid;
  register_child_death($pid,$rv);

  reap_dead_children();

  $?=$rv;

  my $prv=parse_rv($rv);

  return $prv;
}

=head2 bg_cmd

Trace the command line for a program, and then run it in the
background. The return value is a scalar which may be passed to
wait_bg_cmd to identify this process, or undef if the command fails.

This command is not implemented on Windows NT, because (I hope!) it is
never used.

=cut

use vars qw(%BGCmdLines);

sub bg_cmd {
  _trace "bg_cmd: @_";
  my @cmdline=@_;

  check_for_executable(@_)
    or return undef;

  # make sure we are tidied up before we start
  reap_dead_children();

  # we could just use system("cmd &"), but that's cheating. ;-) More
  # seriously, one then gets into all sorts of issues with quoting
  # arguments which I'd rather avoid. So we fork/exec.  On UNIX,
  # anyway; on NT, we have to use system, but we can at least use the
  # list form to fork into the background.
  my $pid;
  if ($Config{windows_nt}) {
    {
      # when run with -w (which one should always do ;-), Perl prints
      # a warning if a system command fails to find its binary. This
      # should supress this warning.
      local $^W=0;
      # this usage is undocumented, and therefore may be subject to
      # change, but it is kind of useful!
      $pid=system(1,@cmdline);
    }
  } else {
    $pid=fork();
    if ($pid) {
      # parent
      1;
    } elsif (defined $pid) {
      # child
      exec(@cmdline);
      die join(" ","Unable to exec",@cmdline,": $!\n");
    } else {
      _abort "Cannot fork: $!";
    }
  }

  # parent

  _debug("Started $cmdline[0] in background as PID $pid");

  # unset the return value so we know the process hasn't finished;
  # this is no longer a race condition, as we don't handle SIGCHLD
  # explicitly any more.
  delete $bg_cmd_status{$pid};
  # and record the command line for Ron
  $BGCmdLines{$pid}=[@cmdline];

  return $pid;
}

=head2 wait_bg_cmd

This is, basically, L<waitpid>.  It takes the PID of a child process
as an argument, and returns the exit status.  However, it also acts
like L<do_cmd> and friends in that it sets up all the "last command
executed" variables and so forth to reflect the command which had the
given PID.  This means that you can use C<handle_rv> et al to parse
the return value of this command without worrying too much.

Note that L<waitpid> will I<not> work, as this file replaces the Perl
child reaper with one of our own.  Note also that this function will
tidy up the internal data structures associated with the process, so
it is not idempotent.

=cut

sub wait_bg_cmd {
  my $pid=shift;

  # tidy up existing processes
  reap_dead_children();

  # first of all, if we have a command line stored for this command,
  # process that
  if (exists $BGCmdLines{$pid}) {
    @LastCmd=@{$BGCmdLines{$pid}};
    $LastCmd=$LastCmd[0];
    _debug("Command was $LastCmd");
  } else {
    @LastCmd=();
    $LastCmd=undef;
  }
  $LastCmdPID=$pid;
  undef $LastCmdError;

  # now, do we know about an exit value for this PID already?
  unless (exists $bg_cmd_status{$pid}) {
    _debug("Waiting for $pid ...");
    my $rv=waitpid($pid,0);
    if ($rv == -1) {
      _debug("Got -1 from waitpid => no such process");
      $?=-1;
      $LastCmdError="Error reading exit status of child process $pid";
      return -1;
    }
    _debug("Status from $rv was $?");
    register_child_death($rv,$?);
  } else {
    _debug("Already have return value for $pid");
  }

  # now, is there anything to process?
  reap_dead_children();
  unless (defined $bg_cmd_status{$pid}) {
    # return status is not recorded => command did not run?  Whatever.
    _debug("No status for $pid");
    $?=-1;
    $LastCmdError="No exit status was recorded for child process $pid";
    return -1;
  }

  # yes, get the return value
  my $rv=$bg_cmd_status{$pid};

  _debug("Status was $rv");
  
  # remove all the rest of the info about it
  delete $bg_cmd_status{$pid};
  delete $BGCmdLines{$pid};

  # and return the return value!
  $?=$rv;
  return $rv;    
}

# Checks if a command is still running. If there isn't a return status then assume it is.
sub poll_bg_cmd {
  my $pid=shift;

  # tidy up existing processes
  reap_dead_children();

  # On unix we can check the pid with signal 0
  if ( not $Config{windows_nt}){
    return 1 if kill 0,$pid;
  }

  return not defined $bg_cmd_status{$pid};
}

=head2 wait_bg_cmd_list

Like wait_bg_cmd, but takes a list of PIDs, and returns a
CFX5::Commands::Result object for the first one to exit.

=cut

sub wait_bg_cmd_list {
  my @pids=@_;

  #if ($Config{windows_nt}) {
  #  internal_error("wait_bg_cmd_list is not implemented for NT");
  #}

 WAITLOOP: while (1) {
    # tidy up existing processes
    reap_dead_children();

    # now, do we know about an exit value for this PID already?  If
    # so, we skip out, and we'll process it below.
    for my $pid (@pids) {
      if (exists $bg_cmd_status{$pid}) {
        last WAITLOOP;
      }
    }

    # we don't have any relevant exit statuses, so we wait for
    # something to exit, and then have another go.
    _debug("Waiting for any child process ...");
    # blocking wait for anything to exit
    my $rv=wait;
    if ($rv == -1) {
      # no child processes, so something must have gone wrong
      internal_error("No child processes but some unexited children");
    }
    _debug("Status from $rv was $?");
    register_child_death($rv,$?);
  }

  # since we got here, we should have an exit status for (at least)
  # one of the requested PIDs.  The first thing to ask is, which?!
  my $pid;
  for my $p (@pids) {
    if (exists $bg_cmd_status{$p}) {
      $pid=$p;
      last;
    }
  }

  unless (defined $pid) {
    internal_error("Status for PID seems to have disappeared");
  }

  my $rv=CFX5::Commands::Result->parse_rv($bg_cmd_status{$pid});
  $rv->set_pid($pid);
  $rv->set_cmd(@{$BGCmdLines{$pid}});

  # remove all the rest of the info about it
  delete $bg_cmd_status{$pid};
  delete $BGCmdLines{$pid};

  # and return the return value!
  return $rv;
}

=head2 fork_cmd

  my $pid=fork_cmd('Output filter');

This routine is a fairly thin wrapper around the Perl C<fork> call; it
sets up the infrastructure used by the rest of the file, and then
calls the Perl C<fork> and returns the result.  If you use this
wrapper, things like C<wait_bg_cmd> will work better with your child
process.  If the fork fails, this routine will C<_abort>.

In addition, if L<CFX5::ExitRoutines> is loaded, C<fork_cmd> will
remove all registered tidy-up routines (if any), and reset the signals
trapped by L<CFX5::ExitRoutines> to their default values.  If it is
not loaded, this step will be skipped.

The only argument is the 'command' which you are running in the child,
for use in error messages etc.

Like C<bg_cmd>, this routine is not implemented for Windows NT.

=cut

=head2 parse_rv

  $rv = parse_rv(do_cmd("ls"));
  unless ($rv->is_success()) {
    _error($rv->errstr("Directory listing"));
  }

Takes the return value of a C<do_cmd> call, or equivalent, and returns
a L<CFX5::Commands::Result> object representing the parsed return
status.

=cut

sub parse_rv {
  my $rv=shift;
  my @cmd=@_;

  my $prv=CFX5::Commands::Result->parse_rv($rv, @cmd);
  return $prv;
}

=head2 handle_rv

  handle_rv(system("build"));
or
  my $parsed_rv=parse_rv(system("command"));
  if ($parsed_rv->signal() == 9) {
    die "Process terminated by somebody nasty, chickening out";
  } else {
    handle_rv($parsed_rv);
  }

Processes the return value from a C<system> or C<do_cmd> call, and
takes appropriate action.  In earlier releases, this call would
re-kill the current process with any signals received by the child,
but this is not necessary or helpful so long as the return value of
processes is being checked.

C<handle_rv> returns the error code if the process exited with an
error code.  Otherwise, if it either exited with a signal or did not
run at all, it returns undef and signals an error.

Use of this call is deprecated, and existing code using it should be
replaced with code similar to the following:

  $rv = parse_rv(do_cmd("ls"));
  unless ($rv->is_success()) {
    _error($rv->errstr("Directory listing"));
  }

=cut

sub handle_rv {
  my $trv=shift;
  my $rv;

  #carp "Call to deprecated function handle_rv";

  if (ref($trv)) {
    $rv=$trv;
  } else {
    $rv=parse_rv($trv, @_);
  }

  unless (defined $rv->rv()) {
    _error($rv->errstr());
    return undef;
  }

  return $rv->rv();
}

=head2 check_for_executable

If it looks like an executable name, check that it exists.

=cut

sub check_for_executable {
  my $exec=shift;

  # check for the program's existance, and if it's not there, don't
  # try to run it.  (Unless it looks like a whole shell command, in
  # which case, we just have to hope). 
  if ($exec =~ m![\\/]! and $exec !~ m![|<>&()]!) {
    CFX5::FileTests::execfile($exec)
        or return '';
  }

  # if it's a bare command name (not including spaces or shell
  # metacharacters), look on the PATH for it.
  if ($exec =~ m!^[^\\/ |<>&()]+$!) {
    cfx5_require('CFX5::PathManip');
    my $dir=CFX5::PathManip::findbin_by_path($exec);
    unless (defined $dir and $dir ne '.') {
      _error("Unable to find \"$exec\" on the PATH.  Please ensure that all required software is correctly installed.");
      return '';
    }
  }

  1;
}

=head3 split_cmd

  @parts=CFX5::Commands::split_cmd($command);

If possible, splits the command into its constituent arguments, taking
into account quoted arguments containing spaces, to put it into a form
suitable for passing to C<exec>.

If for some reason this is not possible -- for example, it might just
be too complicated, or there may be shell metacharacters in the
command which we can't handle using exec -- the return is an empty
list, and the caller should pass the whole thing as a lump to
C<system> instead.

=cut

sub split_cmd {
  my $command=shift;
  my $max_comps=shift;

  # start by stripping leading whitespace.  Further whitespace will be
  # handled by the RE in the loop.
  $command =~ s!^\s+!!;

  my @split;
  while ($command ne '' and $command ne '"' and $command ne "'") {
    my $part;
    my @part=($command =~ m!(?:             # either
                             \"([^\"]*)\" #   double-quoted string
                           |
                             \'([^\']*)\' #   single-quoted string
                           |
                             (
                              (?:
                               [^\s]     #     a non-space character
                                |
                               \\\s       #     or a \-quoted space
                              )+          #   one or more times
                             )
                          )+
                          (?:\s+|$)       # followed by space or EOL
                          !x);
    if (@part) {
      # we are basically stripping quotes here, so we want to take all
      # the matches and join them up.  This accounts for cases like
      #   "C:\Program Files"\foo
      $part=join('', grep { defined $_ } @part);

      # we have to use m// to get the whole list of matches, so now we
      # manually strip off the thing we just matched.  The @+ array
      # includes the position of the last character in each match,
      # unfortunately including the failed ones (!).  So we strip out
      # failed matches, sort for good measure, and then take the last
      # one. 
      my @matchpos=sort {$a <=> $b} grep { defined $_ } @+;
      $command=substr($command, $matchpos[$#matchpos]);
    } else {
      _error("Error finding components of command: unable to parse starting at $command");
      return ();
    }

    # just refuse some things.  If we need to later, we could check if
    # they occur inside a string, and only refuse them if not ...
    #
    # we do this check on a part-by-part basis so that we can use the
    # same code for split_cmd_exec and not fail if later commands
    # contain metachars
    if ($part =~ m![|`<>]!) {
      _debug("$part contains shell metacharacters");
      return ();
    }

    push @split, $part;

    # this is used by split_cmd_exec to just get the first part of the
    # command
    if (defined $max_comps and @split == $max_comps) {
      return @split;
    }
  }

  # we made it all the way through the command, good job.  Return it.
  @split;
}

sub split_cmd_exec {
  my $command=shift;
  my @cmd=split_cmd($command, 1);
  return $cmd[0];
}
1;
