=head1 NAME

CFX5::Parallel::Pvm - PVM daemon control routines

=head1 SYNOPSIS

This module contains routines for starting, stopping and interrogating a
PVM daemon, as well as reading PVMhost files etc.

There is an existing module on CPAN called L<Parallel::Pvm> which should
provide a lot of this functionality by linking with the PVM libraries,
which is a much better way of achieving this result; unfortunately,
however, I cannot get this to link on Windows NT. It would be nice to
work this way at some point in the future, and I have tried to design
the functions in here with this in mind.

See also L<CFX5::Parallel>, for more general parallel routines; this
module contains only the building blocks.

=head1 DESCRIPTION

B<Please Note:> All C<$host> arguments and similar are objects of type
C<CFX5::Parallel::Host>, and not just hostnames.

=cut

package CFX5::Parallel::Pvm;

use strict;

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

use CFX5::Output qw(:all);
use CFX5::FileTests;
use CFX5::Config qw(%Config export_conf);

use CFX5::PathManip qw(join_file fullpath findbin_by_path basename);

use CFX5::Commands qw(do_cmd do_cmd_quiet get_cmd_output do_output_cmd parse_rv);

use CFX5::FileOps 'set_file_contents';

use CFX5::PkgLoader qw(cfx5_require);

use vars qw($PVM);

use CFX5::Parallel::Host;

sub pvm_dbg {
  my $sub=((caller(1))[3]);
  _trace "$sub:", @_;
}

sub mychomp {
  local $/="\r\n";
  chomp @_;
}

=head2 setup

  CFX5::Parallel::Pvm::setup();

Makes sure the correct environment variables etc are set, signalling
errors with C<_error>. Also locates the local PVM console executable.
This function should be called before any of the functions in this
module which communicate with PVM.

If possible, this should be called before C<show_vars_by_verbosity>,
since it sets and exports variables.

=cut

use CFX5::Config::def PVM_RSH => sub { 
  my $rsh=$Config{CFX5RSH};
  if (defined $rsh) {
    # if it's already an absolute pathname, this won't really change
    # anything, just split it up and put it back together again.
    my $dir=findbin_by_path($rsh);
    my $file=basename($rsh);
    unless (defined $dir) {
      _error("Unable to find $rsh on the PATH");
      return undef;
    }
    return join_file($dir, $file);
  } else {
    return undef;
  }
};

sub setup {
  # don't do it twice!
  return $PVM if defined $PVM;

  pvm_dbg 'not already done';

  unless (defined $Config{PVM_ROOT} and
	  CFX5::FileTests::datadir($Config{PVM_ROOT},
				   "PVM root directory $Config{PVM_ROOT}")) {
    $PVM=0;
    return 0;
  }

  # because we are going to pass this (possibly) to the NT shell, we
  # need to make very sure that PVM_ROOT has the correct
  # backslashes. Grr. 
  $Config{PVM_ROOT} = fullpath($Config{PVM_ROOT});

  if ($Config{windows_nt}) {
    # old versions
    #$PVM=join_file($Config{PVM_ROOT}, 'console', $Config{PVM_ARCH}, 'pvm.exe');
    # new versions
    $PVM=join_file($Config{PVM_ROOT}, 'lib', $Config{PVM_ARCH}, 'pvm.exe');
  } else {
    # NB can't use the arch-specific one here
    $PVM=join_file($Config{PVM_ROOT}, 'lib', 'pvm');
  }

  unless (CFX5::FileTests::execfile($PVM, "PVM executable $PVM")) {
    $PVM=0;
    return 0;
  }

  export_conf(qw(PVM_ROOT PVM_ARCH PVM_RSH));

  return 1;
}

=head2 start_console

Start the PVM console interactively.  The return value is a
CFX5::Commands::Result object.

=cut

sub start_console {
  my $self=shift;

  setup();

  my $hosts = $Config{PVM_HOSTS_FILE} || '';

  return parse_rv(do_cmd($PVM, $hosts));
}

=head2 run_pvm

I<For internal use only>

  my @out = run_pvm('mstat hydra');

Send the given command to the PVM console, and return a list of newline-
removed lines, or undef.

=cut

sub run_pvm {
  my $cmd=shift;
  my $ignore_error=shift;

  setup();

  my $hosts = $Config{PVM_HOSTS_FILE} || '';

  my $rv;
  my @out;
  my $err;

  if ($Config{windows_nt}) {
    # from cmd /?:
    #     1.  If all of the following conditions are met, then quote characters
    #         on the command line are preserved:
    # [...]
    #         - no special characters between the two quote characters,
    #           where special is one of: &<>()@^|
    # [...]
    #
    #     2.  Otherwise, old behavior is to see if the first character is
    #         a quote character and if so, strip the leading character and
    #         remove the last quote character on the command line, preserving
    #         any text after the last quote character.

    # Further, PVM needs to actually get double quotes around its
    # hosts file argument when it is passed onto the daemon process.
    # After some experimentation, I found that passing three double
    # quotes on each end would work.  If PVM is ever fixed, this
    # should be replaced by a single pair of double quotes, I
    # expect. NB if this fails, PVM will hang waiting for the daemon's
    # lock file to appear, which it never does, in this code in
    # lpvm.c:
    # 	while (stat(sfn, &sb) == -1)
    # 		Sleep(5000);		/* what a hack */

   #$rv=do_output_cmd("cmd", qq(/c echo $cmd | "$PVM" \\\""$hosts"\\\"));
    # For some reason this fails with a bizarre error. I suspect the Win32 perl
    # module that is used to launch process groups has been linked against
    # a different runtime than perl.

    # For now use an evil work around.

    # Run it in system() and pipe to a temp file
    $rv=system("cmd", qq(/c echo $cmd | "$PVM" \\\""$hosts"\\\"), ">", "$ENV{TEMP}\\cfxpvm.$$");
    if($rv != 0){
      $err=$^E;
    }

    if(-e "$ENV{TEMP}\\cfxpvm.$$") {
      open(IN, "<$ENV{TEMP}\\cfxpvm.$$") or die "Could not open temporary pvm file.\n";
      @out=<IN>;
      close(IN);
      unlink("$ENV{TEMP}\\cfxpvm.$$");
    } 

    if($rv != 0 and not $ignore_error ){
      _error($err);
    }    

  } else {
    $rv=do_output_cmd(qq(echo $cmd | "$PVM" "$hosts"));
    @out=$rv->cmd_output();

    if (not $rv->is_success() and not $ignore_error) {
      _error($rv->errstr());
    }

    #_debug($rv->errstr());
  }

#   unless ($Config{windows_nt}) {
#   } else {
#     _trace "Running $PVM $hosts (minimised) with input $cmd";
 
#     local (*IN,*OUT);
#     #open IN, '<&STDIN';
#     #open OUT, '>&STDOUT';
#     {
#       # make sure open2 can play with stdin/out/err; we already have
#       # stdout/stderr because we made sure those were valid when we
#       # threw away our console, but stdin we don't necessarily have.

#       local (*STDIN); #, *STDOUT, *STDERR);
#       open STDIN, "<NUL";
#       #open STDOUT, ">NUL";
#       #open STDERR, ">NUL";

#       open2(\*OUT, \*IN, 'cmd', '/c', "echo $cmd | $PVM $hosts");
#     }

#     if (!defined *IN{IO} || !defined *OUT{IO}) {
#       _abort("Error opening connection to PVM");
#     }

#     #print IN "$cmd\n";
#     #print IN "\032";		# quit doesn't work ...
#     #close IN;

#     @out=<OUT>;
#   }    


  # we filter some things from the output, looks like debug
  # information left over:
  #    "trace *"
  @out=grep { !m/^trace\s+\*$/ } @out;

  mychomp @out;
  _debug("Output from \"$cmd\" was: [",join("]\n[",@out),"]");

  return @out;
}

=head2 conf

  ($info, @hosts) = CFX5::Parallel::Pvm::conf(@hosts);
  ($info, @hosts) = CFX5::Parallel::Pvm::conf();

Gets the current status of the PVM daemon. Returns the info line ("1
host, 1 data format") in C<$info>, and a list of
C<CFX5::Parallel::Host> objects in C<@hosts>.  The returned objects
are taken from the list passed in; if a host is found which was not in
the input list, the hostname will be returned as a string.

The list will be returned in the order it was read; in particular, the
master host will always be the first in the list.  Any hosts found
will also have their hostname field set to the PVM host name.

On error, the $info will be 0, and no hosts will be returned.

No information about the hosts is currently read from the
configuration apart from the order, although this extension would be
easy to make if it was to be found to be useful.

=cut

sub conf {
  my @ohosts=@_;
  my @hosts;
  my $info;

  pvm_dbg 'start';

  my @out = run_pvm('conf');

  my $in_hl=0;
  for my $l (@out) {
    $_=$l;
    s/^pvm>\s*//;
    s/^\s*//;
    next if $_ eq '';
    next if $_ eq 'quit';
    next if m/pvmd (already|still) running/;
    next if m/^Console:/;
    if (m/HOST\s*DTID\s*ARCH\s*SPEED\s*DSIG/) {
      $in_hl = 1;
      next;
    }
    unless ($in_hl) {
      $info = (defined $info ? $info."\n" : '') . $_;
      next;
    }

    # right, so we've got a host line
    my ($host, $dtid, $arch, $speed, $dsig) = split /\s+/;

    next unless (defined $host and defined $dtid and defined $arch
		 and defined $speed and defined $dsig);

    # is it already in @ohosts?
    my @mh = grep { defined $_ and $_->has_name($host) } @ohosts;
    my $h;
    if (scalar(@mh) > 0) {
      $h = $mh[0];
      # get the canonical name.
      #
      # We don't need this to be conditional, but it makes the debug
      # output easier to read.
      my $oname=$h->pvmname();
      if ($oname ne $host) {
        _debug("Setting PVM hostname of", $h->descname(), "to \"$host\" from PVM conf");
        $h->pvmname($host);
      }
    } else {
      # we don't know anything about this host, but let's create a
      # dummy object for it.  It doesn't matter too much, as we'll
      # only be using it to remove at the end anyway.
      $h = new CFX5::Parallel::Host ( 'DUMMY', $host );
      #$h = $host;
    }

    push @hosts, $h;
  }

  if (!$in_hl) {
    _error("Cannot get current PVM configuration: error calling PVM or unknown table format:\n" . 
           (join('', map { "  $_\n" } @out))
          );
    return (undef);
  }

  $info='' unless defined $info;

  for my $h (@hosts) {
    pvm_dbg("got info for ".$h->name());
  }

  return ($info, @hosts);
}

=head2 mstat

  $status = CFX5::Parallel::Pvm::mstat($host);

Gets the status of the given host. The return value will be C<'ok'> if
the host is correctly in the environment, or some other error otherwise.
If the PVM daemon cannot be contacted, or another error is encountered,
the return is C<'Error running mstat'>.

=cut

sub mstat {
  my $host = shift;
  my $name=$host->pvmname();

  # PVM on NT makes all hosts lowercase?
  #$name=lc($name) if $Config{windows_nt};

  my @stati = map { s/^\s*$name\s+//i; s/\s*$//; $_ }
              grep /^\s*$name\s/i, 
              map { s/^pvm>\s*// ; $_ }
              (run_pvm("mstat $name"));

  pvm_dbg("$name: ", ($stati[0] || '(error)'));

  return $stati[0] || 'Error running mstat';
}

=head2 host_ok

  if (host_ok($host)) {
    # it's in already
  }

Returns TRUE if the host is correctly set up in PVM, or FALSE
otherwise.  This is done using the C<conf> command, rather than mstat,
to cope with differing cases of host names.  See also C<mstat>.

=cut

sub host_ok {
  my $host=shift;

  my $name=$host->pvmname();

  # if it's there, we need to know what name PVM gives it.  The conf
  # call will do that.
  my (undef, @confhosts)=conf($host);

  # having done that, we don't need to call mstat, we can just see if
  # we got our host back!
  for my $h (@confhosts) {
    # string comparison of objects, because we are actually looking
    # for the *same* object being returned as we passed in.
    if ($h eq $host) {
      _debug("Host $name is OK: found in conf table from PVM");
      return 1;
    }
  }

  _debug("Host $name is BAD: not found in conf table from PVM");
  '';
}

=head2 add

  CFX5::Parallel::Pvm::add($host);

Given a host (as a C<CFX5::Parallel::Host object), add it to the PVM
environment. Return value TRUE or FALSE, errors are signalled using
C<_error>. If a host is already part of the environment a message is
printed using C<_info>, but this is not considered an error.

=cut

sub add {
  my $host = shift;
  my $name=$host->pvmname();

  # PVM on NT makes all hosts lowercase?
  #$name=lc($name) if $Config{windows_nt};

  if (host_ok($host)) {
    #_info "Host $name is already in the PVM environment, not adding";
    return 1;
  }

  # OK, we've got to add it
  my @out=run_pvm("add $name");
  my @rv;
  my $in_hl=0;
  for (@out) {
    s/^pvm>\s*//;
    s/^\s*//;
    s/\s*$//;
    if (m/HOST\s+DTID/) {
      $in_hl=1;
      next;
    }
    next unless $in_hl;
    push @rv, $_ if m/^$name\s+[A-Za-z0-9]/;
  }

  if (scalar(@rv) == 0 or !$in_hl) {
    _error("Unable to find host table in output from PVM daemon:\n\t", join("\n\t", @out),
           "\nError adding host $name.");
    return 0;
  }

  if (host_ok($host)) {
    _debug("Found host $name in conf table from PVM, must have been successful");
    return 1;
  }

  # something went wrong.  See if we can read the pvml file, that
  # often has useful extra info
  my @errs;
  {
    my $tmpdir=$Config{TEMP} || $Config{TMP} || $Config{TMPDIR} || '/tmp';
    my $f=join_file($tmpdir, "pvml." . $>);
    if (-f $f) {
      cfx5_require('CFX5::FileOps');
      my $cont=CFX5::FileOps::get_file_contents($f);
      if (defined $cont) {
        push @errs, '', "Contents of $f:\n  " . join("\n  ", split(/\r?\n\r?/, $cont)), "\n";
      } else {
        push @errs, '', "Error reading local error file $f: $!";
      }
    }
  }

  map { s/^$name\s+//; $_ } @rv;
  if (@rv == 1 and $rv[0] =~ m"^Can\'t start pvmd") {
    # can't start the daemon.  First off, make sure the user hasn't
    # disabled rsh, as in that case it probably won't work!
    if ( $host->disable_remote_checks() ) {
      _error("Unable to start the PVM daemon on host", $host->descname().".  Remote checks have been explicitly disabled for this host, but a working $Config{CFX5RSH} connection is required for PVM to function correctly.  It may also indicate that the PVM daemon is already running on this host, or that it left files in /tmp on this host because it did not exit cleanly last time it was run.", @errs);
    }
    else {
      # we check to see if the executable (we think) we're trying to
      # run exists.  If not, the problem is easily diagnosed.
      my $pvmd=$host->fill_in_exec($host->pvmd_path());
      my $havex=$host->check_for_executable($pvmd);
      if (defined $havex and not $havex) {
        _error("Unable to start the PVM daemon on host", $host->descname().", probably because the daemon executable does not exist at the expected location $pvmd.  This may also indicate that the PVM daemon is already running on that host, or that it left files in /tmp on that host because it did not exit cleanly last time it was run.", @errs);
      } else {
        _error("Unable to start the PVM daemon on host", $host->descname().".  This may indicate that the PVM daemon is already running on that host, or that it left files in /tmp on that host because it did not exit cleanly last time it was run.", @errs);
      }
    }
  } else {
    _error("Unable to add host", $host->descname(), "to the PVM environment:\n",
	   join(" ", @rv), @errs);
  }
  return 0;
}

=head2 ps

  @procs = CFX5::Parallel::Pvm::ps($host);

Gets the list of processes running on the given host and returns it as
a list of process names. The flag field, etc, are ignored; see the
(yet to be written) function C<psl> to get all this information.

If no processes are running on the specified host, or another error
occurs (such as the named host not being present in the PVM
environment), the return is an empty list; if there is an error
contacting the daemon, the return value will be the empty list and an
error signalled via C<_error>. Callers should use the C<mstat>
function to verify the existence of the host before interrogating its
process table.

B<Note>: The F<hoster> process, used by Windows NT machines to fire
off slave processes, is explicitly I<excluded> by this function, so it
can be used to give a useful count of the significant processes on a
machine. This is done by removing any line matching the regular
expression
  [\\/]hoster\.exe$

=cut

sub ps {
  my $host = shift;
  my $name=$host->pvmname();

  my @out = grep !m/pvmd already running|^\s*$/,
            map { s/^pvm> // ; $_ }
            (run_pvm("ps -n$name"));

  unless (defined ($out[0])) {
    _error("Unknown error communicating with PVM daemon");
    return undef;
  }

  # @out now contains a possible error string, followed by a possible
  # process table, followed by some junk:
  #
  #                        HOST      TID   FLAG 0x COMMAND
  #                         asm    40002       4/c e:\home\cfx5test\tools\pvm3.4\lib\win32\..\../bin/WIN32/hoster.exe
  #                         asm    40008       4/c -           
  #    quit
  #    Console: exit handler called
  #    pvmd still running.
  # or
  #    unknown host orion
  #                        HOST      TID   FLAG 0x COMMAND
  #    quit
  #    Console: exit handler called
  #    pvmd still running.
  #

  # newer PVM prints the "ps -nhost" back again ...
  if ($out[0] =~ m!\s*ps -n$name\s*$!) {
    shift @out;
  }

  # now, do we have an error?
  if ($out[0] =~ m/^[^ ]/) {
    # yes; we can't return it, so just don't return anything
    _error("Unable to parse output from ps(); full output is:\n" . join("\n", @out, ''));
    return ();
  }

  # so we should have the table header line ...
  unless ($out[0] =~ m/\s+HOST\s+TID\s+FLAG\s+0x\s+COMMAND/) {
    _error("Unexpected output from PVM daemon, expecting process table header, got\n\t$out[0]");
    return undef;
  }

  # find out where the commands are
  my $cmdcol = index($out[0], "COMMAND");
  shift @out;

  # get the full list of commands
  @out = grep !m![\\/]hoster.exe$!,
         map { substr($_, $cmdcol) }
         grep /^\s/,
         @out;

  _debug "Processes on", $host->descname().":";
  for my $p (@out) {
    _debug " * $p";
  }

  return (@out);
}

=head2 delete

  CFX5::Parallel::Pvm::delete($host);

Remove the specified host from the PVM environment. Return value TRUE or
FALSE, errors are signalled using C<_error>. If a host is not part of
the environment, this is considered an error.

=cut

sub delete {
  my $host = shift;
  my $name=$host->pvmname();

  my $stat = mstat($host);
  if ($stat ne 'ok') {
    _error "Cannot remove host", $host->descname().": host is not in the PVM environment";
    return 0;
  }

  my @out=run_pvm("delete $name");
  my @rv;
  my $in_hl=0;
  for (@out) {
    s/^pvm>\s*//;
    s/^\s*//;
    s/\s*$//;
    if (m/HOST\s+STATUS/) {
      $in_hl=1;
      next;
    }
    next unless $in_hl;
    push @rv, $_ if m/^$name\s+[A-Za-z]/;
  }

  if (scalar(@rv) == 0 or !$in_hl) {
    _error("Unexpected output from PVM daemon:\n\t", join("\n\t", @out),
           "\nUnable to remove host", $host->descname.".");
    return 0;
  }

  map { s/^$name\s+//; $_ } @rv;

  if (join(" ",@rv) eq 'deleted') {
    _debug "Successfully deleted", $host->descname;
    return 1;
  }
  
  _error("Unable to delete host", $host->descname(), " from the PVM environment:\n",
         join(" ", @rv));
  return 0;
}

=head2 halt

  CFX5::Parallel::Pvm::halt();

Shuts down the PVM virtual machine, on the master and all slaves.

=cut

sub halt {
  my @out = run_pvm('halt', 'ignore errors');

  @out = grep !/(pvmd already running\.|trace \*|pvm> *| *)$/, @out;
  if (@out) {
    _error("Unable to shut down PVM environment:\n\t" . '[' . join("]\n\t[",@out) . ']');
    return 0;
  }

  return 1;
}

=head2 shutdown_pvm

Performs a nice shutdown of PVM on the list of hosts specified.  This
tries to shut down any unused daemons without stopping any other
parallel runs which might be using the same daemons.

=cut

sub _dbg_host_list {
  my $prefix = shift;
  my @hl=@_;
  for my $h (@hl) {
    _debug "$prefix", $h->name();
  }
}

sub shutdown_pvm {
  my @hosts=@_;

  my $ownhost = $Config{CFX_FULLHOST};
  my $ownhost_s = $Config{CFX_HOST};
  unless (defined $ownhost and defined $ownhost_s) {
    _error("Unable to determine local host name");
    return 0;
  }

  my ($info);

  # among other things, this reorders the host list according to the PVM
  # list
  ($info, @hosts) = CFX5::Parallel::Pvm::conf(@hosts);

  _dbg_host_list "Before:", @hosts;

  # make sure we can find the local host in the host list
  my $ownh;
  ($ownh) = (grep { $_->is_local() } @hosts);
  unless (defined $ownh) {
    _error("Cannot locate current host in host list!");
    return 0;
  }

  # list of remaining hosts
  my @hlist=@hosts;

  #
  # Loop over all added hosts (not the master)
  # --> delete all hosts which have no assigned processes
  # --> do nothing for own hostname
  #
  for my $s (@hlist[1 .. $#hlist]) {
    next if $s->is_local();
    my @procs = CFX5::Parallel::Pvm::ps($s);
    next unless (scalar(@procs) == 0);
    _info("Host", $s->descname(), "has no remaining processes, removing.");
    CFX5::Parallel::Pvm::delete($s);
    # this deletes this host from @hlist, but not @hosts.
    undef $s;
  }

  # remove the hosts we undefined in the list above
  @hlist = map { defined $_ ? ($_) : () } @hlist;

  _dbg_host_list "After removing empty slaves:", @hlist;

  #
  # Check remaining number of hosts:
  # - master host
  # - own host (if different from master)
  # - hosts which have assigned processes
  #
  if ($hosts[0]->is_local()) {
    #
    # Own host = master
    # --> halt PVM if master has no assigned processes and is the only
    #     host in the list
    #
    if (scalar(@hlist)==1) {
      my $h = shift @hlist;
      my @procs = CFX5::Parallel::Pvm::ps($h);
      if (scalar(@procs) == 0){
        _info("Local host", $h->descname(), "has no remaining processes, halting PVM.");
        CFX5::Parallel::Pvm::halt($h);
      }
    } else {
      # list them
      _info("Hosts", (map { $_->descname() } @hlist), "have active processes, not halting PVM.");
    }
  } elsif (scalar(@hlist) == 2) {
    #
    # Own host != master 
    # --> NRHOST=2 (only master and own host involved)
    #     --> check own host for assigned processes
    #     --> check master host for assigned processes
    #
    my $mh = shift @hlist;
    my $ownprocs=CFX5::Parallel::Pvm::ps($ownh);
    my $mastprocs=CFX5::Parallel::Pvm::ps($mh);

    if ($ownprocs == 0 and $mastprocs != 0) {
      # can't stop master, so just kill our own host
      _info("Host", $ownh->descname(), "has no remaining processes, removing.");
      CFX5::Parallel::Pvm::delete($ownh);
    } elsif ($ownprocs == 0 and $mastprocs == 0) {
      # can stop master, so don't worry about local host
      _info("No remaining processes, halting PVM.");
      CFX5::Parallel::Pvm::halt($mh);
    }
  } elsif (scalar(@hlist) > 2) {
    #
    # Own host != master 
    # --> NRHOST>2 (master, own and other hosts involved)
    #     --> check own host for assigned processes
    #
    my @procs = CFX5::Parallel::Pvm::ps($ownh);
    if (scalar(@procs) == 0) {
      _info("Host", $ownh->descname(), "has no remaining processes, removing.");
      CFX5::Parallel::Pvm::delete($ownh);
    }
  }

  _dbg_host_list "After:", @hlist;

  # Remove the temporary hosts file, we are finished with it now even if 
  # the daemon is still alive
  unlink($Config{PVM_HOSTS_FILE});

  return 1;
}

1;
