File Coverage

blib/lib/GRID/Machine.pm

Criterion	Covered	Total	%
statement	63	665	9.4
branch	0	270	0.0
condition	0	182	0.0
subroutine	21	66	31.8
pod	21	31	67.7
total	105	1214	8.6

#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  Based on the idea of IPC::PerlSSH by Paul Evans, 2006,2007 -- [e-mail]
#  (C) Casiano Rodriguez-Leon 2007 -- [e-mail]

package GRID::Machine;
use strict;
use Scalar::Util qw(blessed reftype);
use List::Util qw(first);
use Module::Which;
use IPC::Open2();
use IPC::Open3();
use Carp;
use File::Spec;
use File::Temp;
use IO::File;
use base qw(Exporter);
use GRID::Machine::IOHandle;
use GRID::Machine::Process;
require POSIX;

require Cwd;
no Cwd;
our @EXPORT_OK = qw(is_operative read_modules qc slurp_file);

# We need to include the common shared perl library
use GRID::Machine::MakeAccessors; # Order is important. This must be the first!
use GRID::Machine::Message;
use GRID::Machine::Result;

our $VERSION = '0.127';

my %_taken_id;
{
  my $logic_id = 0;
  sub new_logic_id {
    $logic_id++ while $_taken_id{$logic_id};
    return $logic_id++;
  }
}

####################################################################
# Usage      : my $REMOTE_LIBRARY = read_modules(@Remote_modules);
# Purpose    : Concatenates the contents of the files associated with
#              the file descriptors
# Returns    : The string with the contents of all those files
# Throws     : exception if a module can not be found

sub read_modules {

  my $m = "";
  for my $descriptor (@_) {
    my %modules = %{which($descriptor)};

    for my $module (keys(%modules)) {
      my $path = which($module)->{$module}{path};

      unless (defined($path) and -r $path) {
        die "Can't find module $module\n";
      }

      $m .= "# source from: #line 1 \"$path\"\n";
      local $/ = undef;
      open my $FILE, "< $path";
        $m .= <$FILE>;
      close($FILE);
    }
  }

  return $m;
}

#  ssh [-1246AaCfgKkMNnqsTtVvXxY] [-b bind_address] [-c cipher_spec]
#                         [-D  [bind_address:]port] [-e escape_char]
#           [-F configfile] [-i identity_file] [-L  [bind_address:]port:host:hostport]
#           [-l login_name] [-m mac_spec]
#           [-O ctl_cmd] [-o option] [-p port] [-R  [bind_address:]port:host:hostport] i
#           [-S ctl_path] [-w tunnel:tunnel]
#           [user@]hostname [command]
#
sub find_host {
  my $command = shift;

  my %option;

  die "Error in GRID::Machine findhost. No command provided\n" unless $command;
  $command =~ s{^\s*
                   (\S+                                      # ssh
                       (?:\s+-[1246AaCfgKkMNnqsTtVvXxYy])*   # -6 -A -f ... options without arg
                   )
                 \s*
               }{}x;
  $option{ssh} = $1;
  while ($command =~ s{^\s*(-\w)\s+(\S*)}{}g) {
    $option{$1} = $2;
  }
  $command =~ s{^\s*([\w+.\@]+)}{};
  $option{host} = $1;
  return \%option;
}

# Inheritance: not considered
{ # closure for attributes

  my @legal = qw(
    cleanup
    command
    debug
    err
    host
    includes
    log
    logic_id
    perl
    perloptions
    prefix
    pushinc unshiftinc
    readfunc
    readpipe
    remotelibs
    report
    scp
    sendstdout
    ssh
    sshpipe
    sshoptions
    startdir startenv
    survive
    tmpdir
    uses
    wait
    writefunc
    writepipe
  );
  my %legal = map { $_ => 1 } @legal;

  GRID::Machine::MakeAccessors::make_accessors(@legal);

########################################################
  sub RemoteProgram {
    my ($USES,
        $REMOTE_LIBRARY,
        $class,
        $host,
        $log,
        $err,
        $logic_id,
        $startdir,
        $startenv,
        $pushinc,
        $unshiftinc,
        $sendstdout,
        $cleanup,
        $prefix,
        $portdebug,
        $report,
        $tmpdir,
       )
    = @_;

   return << "EOREMOTE";
#line 1 "$prefix/REMOTE.pm"
package GRID::Machine;
use strict;
use warnings;

$USES

$REMOTE_LIBRARY

my \$rperl = $class->new(
  host => '$host',
  log  => '$log',
  err  => '$err',
  logic_id => '$logic_id',
  clientpid => $$,
  startdir => '$startdir',
  startenv => $startenv,
  pushinc => [ qw{ @$pushinc } ],
  unshiftinc => [ qw{ @$unshiftinc } ],
  sendstdout => $sendstdout,
  cleanup => $cleanup,
  prefix  => '$prefix', # Where to install modules
  debug => $portdebug,
  report => q{$report},
  tmpdir => q{$tmpdir},
);
\$rperl->main();
__END__