# $Id: /mirror/coderepos/lang/perl/Script-Remote/trunk/lib/Script/Remote.pm 57706 2008-06-05T02:27:20.427194Z daisuke  $

package Script::Remote;
use Moose;
use Moose::Util::TypeConstraints;
use Path::Class::File;

our $DEFAULT_SSH;

class_type 'Path::Class::File';
coerce 'Path::Class::File'
    => from 'Str'
        => via { Path::Class::File->new($_) }
;

has 'hostname' => (
    is => 'rw',
    isa => 'Str',
    required => 1
);

has 'username' => (
    is => 'rw',
    isa => 'Str',
    required => 1,
    default => (getpwuid($>))[0]
);

has 'perl' => (
    is => 'rw',
    isa => 'Path::Class::File',
    coerce => 1,
    required => 1,
    default => $^X
);

has 'no_wait' => (
    is => 'rw',
    isa => 'Bool',
    default => 0
);

has 'ssh' => (
    is => 'rw',
    isa => 'Path::Class::File',
    coerce => 1,
    required => 1,
    default => sub {
        $DEFAULT_SSH ||= __find_cmd("ssh", [ split(/:/, $ENV{PATH}) ]);
    }
);

has 'script' => (
    is => 'rw',
    isa => 'Path::Class::File',
    coerce => 1,
    required => 1,
);

has 'pid' => (
    is => 'rw',
    isa => 'Int'
);

has 'child_out' => (
    is => 'rw'
);

has 'ssh_args' => (
    is => 'rw',
    isa => 'ArrayRef',
    auto_deref => 1,
    default => sub { +[] },
);

no Moose;

use Data::Dump ();
use IPC::Open2 qw(open2);
use POSIX ();

my $MYSELF = '';
open(my $fh, __FILE__);
while (<$fh>) {
    $MYSELF .= $_;
    last if /^"END OF PACKAGE";/
}

our $VERSION = '0.00001';

sub __find_cmd
{
    my ($name, $paths) = @_;

    foreach my $path (@$paths) {
        my $fqpath = Path::Class::File->new($path, $name);
        if (-x $fqpath) {
            return $fqpath;
        }
    }
    return ();
}

sub run
{
    my $self = shift;

    my $text = $self->__wrapper_text(@_);

    my @extra = $self->ssh_args;
    my $cmd = join(' ', $self->ssh, '-l', $self->username, @extra, $self->hostname, $self->perl, '--' );

    local $SIG{CHLD} = sub {
        while ((my $child = waitpid(-1, &POSIX::WNOHANG)) > 0) {
            # nothing to do.
            if ($? != 0) {
                warn "child exited with status $?";
            }
        }
    };

    my ($child_out, $child_in);
    my $pid = open2( $child_out, $child_in, $cmd )  or die;

    $self->pid( $pid );
    $self->child_out( $child_out );

    print $child_in $text;
    close $child_in;

    if (! $self->no_wait) {
        $self->wait_child();
    }
}

sub wait_child
{
    my $self = shift;
    wait();

    if (my $fh = $self->child_out) {
        while (<$fh>) {
            print;
        }
    }
}

sub __wrapper_text
{
    my $self = shift;
    my %args = @_;
    my $data = $args{data} || '';
    my $variable = $args{variable} || 'DATA'; # choose one, damnit

    # Serialize this data, if necessary (you know the rules, no globs,
    # no XS stuff -- unless they know how to serialize/deserialize)
    if ($data) {
        $data = Data::Dump::dump($data);
    }

    my $script = $self->script;
    my $script_text = $script->slurp;
    my $date = scalar localtime;

    my $text = <<EOM;
#!env perl
# Automatically generated by Script::Remote $VERSION on $date
EOM

    # XXX - We may use this one of these days, but not now
    my $with_copy = 0;
    if ($with_copy) {
        $text .= <<EOM;
{ # A copy of Script::Remote that generated this script
$MYSELF
}
EOM
    }

    if ($data) {
        $text .= <<EOM;
# Serialized data section. Be careful with name conflicts
my \$$variable = $data;
EOM
    }

    $text .= <<EOM;
{
$script_text
}
EOM

# print $text;
    return $text;

}

"END OF PACKAGE";

__END__

=head1 NAME

Script::Remote - Exceute Your Scripts Over SSH (And Pass Data Along)

=head1 SYNOPSIS

  # CASE 1: Simple case
  # Write a script first (say, foo.pl)
  use strict;
  print "Hello, World!\n";

  # Elesewhere, in a different file
  use Script::Remote;
  my $remote = Script::Remote->new(
    script   => 'foo.pl',
    hostname => 'some.host.com',
  );
  $remote->run;

  #### CASE 2: With Data ####
  use strict;
  print "Hello, World from $config->{myname}\n";

  $remote->run(
    variable => 'config',
    data     => { myname => "Daisuke Maki" },
  );

=head1 DESCRIPTION

This is a stupid little hack that makes running scripts remotely a *bit*
easier. 

Please note that this is full of potential security gotchas.
We generate code on the fly. This is bad. We're basically doing a 
remote eval(), which is just bad bad bad. DO NOT USE THIS MODULE 
if you expect people with no or minimal knowledge about how this kind of
distributed system hacks work. 

Having said that, for tests, this could be handy. All you need is a 
ssh-enabled set of machines (you probably want public key auth, too),
and two scripts: the script you want to run remotely, and a script that will
drive those script(s).

To run a single script on a single remote machine, simply say:

  use Script::Remote;

  Script::Remote->new(
    script => 'foo.pl',
    hostname => 'my.host.name'
  )->run();

If you want to run the same script on multiple hosts, you need to tell
Script::Remote to not block on wait(), so you need to use the no_wait
parameter:

  my $script = 'foo.pl';
  my @scripts;
  my $data = ...; # some shared data
  foreach my $host (@hosts) {
    my $remote = Script::Remote->new(
      script => $script,
      hostname => $host,
      no_wait => 1,
    );
    $remote->run(data => $data);
    push @scripts, $remote;
  }

  $_->wait_child for @scripts;

=head1 METHODS

=head2 new

=over 4

=item script

The name of the script to execute

=item hostname

The hostname to ssh to

=item username

The username to use for ssh

=item no_wait

If true, the object will not block when run() is called. In that case
you should use wait_child() to wait for the child process to stop

=item perl

The full path to the remote perl executable. We use the *local machine's*
value of $^X by default.

=item ssh

An alternate path to your ssh binary. We attempt to find one by default,
but if we don't, you should be setting this or $Script::Remote::DEFAULT_SSH.

=item ssh_args

List of extra ssh command line arguments

=back 4

=head1 TODO

Decide what to do with the output from the ssh child. Currently we
simple dump everything to STDOUT (ideas, anybody?)

=head1 AUTHOR

Copyright (c) 2008 Daisuke Maki E<lt>daisuke@endeworks.jpE<gt>

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

See http://www.perl.com/perl/misc/Artistic.html

=cut