File Coverage

bin/remperl

Criterion	Covered	Total	%
statement	138	154	89.6
branch	65	82	79.2
condition	22	37	59.4
subroutine	10	12	83.3
pod			n/a
total	235	285	82.4

#!/usr/bin/env perl
use v5.36;
use FindBin qw($Bin);
use lib "$Bin/../lib";

use Getopt::Long qw(GetOptions);
use Remote::Perl;

# Only load Pod::Usage if required because its dependencies load slowly.
sub pod2usage { require Pod::Usage; Pod::Usage::pod2usage(@_) }

# -- Option variables ----------------------------------------------------------

my $rsh                = 'ssh';
my $pipe_cmd           = 0;
my $window             = 65_536;
my $stdin_file         = undef;
my $stdin_str          = undef;
my $serve_modules      = 0;
my @inc_local;
my $tmpfile            = 0;
my $tmpfile_mode       = undef;
my $no_data_warn       = 0;
my $no_system_inc      = 0;
my $serve_restrict     = 0;
my @serve_allow;
my $help               = 0;
my $version            = 0;

# -- GetOptions spec (shared between parse_perl_opts and GetOptions) -----------

my @getopt_spec = (
    'rsh=s'                  => \$rsh,
    'pipe-cmd'               => \$pipe_cmd,
    'window-size=i'          => \$window,
    'stdin-file=s'           => \$stdin_file,
    'stdin-str=s'            => \$stdin_str,
    'serve-modules!'         => \$serve_modules,
    'inc-local=s@'           => \@inc_local,
    'no-system-inc'          => \$no_system_inc,
    'serve-restrict-paths'   => \$serve_restrict,
    'serve-allow=s@'         => \@serve_allow,
    'tmpfile!'               => \$tmpfile,
    'tmpfile-mode=s'         => \$tmpfile_mode,
    'no-data-warn'           => \$no_data_warn,
    'help'                   => \$help,
    'version'                => \$version,
);

# -- Perl-compatible short option parsing --------------------------------------

# Mirrors Perl's own option parsing rules for -e, -m, -M, -w, -h, -V.
# Processes @ARGV in-place before GetOptions runs.

sub use_spec_to_line($flag, $spec) {
    # '=' form: -m and -M are identical; use split like Perl does
    if ($spec =~ /^([^=]+)=(.+)$/) {
        return "use $1 split(/,/,q{$2});\n";
    }
    if ($flag eq 'm')      { return "use $spec ();\n" }
    if ($spec =~ /^-(.+)/) { return "no $1;\n" }
    return "use $spec;\n";
}

sub parse_perl_opts() {
    my @eval_code;
    my @use_specs;
    my $warnings = 0;
    my @new_argv;
    my @trailing;     # args after stop point (not seen by GetOptions)
    my $positionals = 0;

    # Long options that consume the next argv element as a value.
    # Derived from @getopt_spec: any key containing = or : takes an argument.
    my %long_val;
    for (my $i = 0; $i < @getopt_spec; $i += 2) {
        if ($getopt_spec[$i] =~ /[=:]/) {
            (my $name = $getopt_spec[$i]) =~ s/[=:!+].*//;
            $long_val{"--$name"} = 1;
        }
    }

    while (@ARGV) {
        my $arg = shift @ARGV;

        # -- stops all processing
        if ($arg eq '--') {
            push @trailing, @ARGV;
            last;
        }

        # Long options: pass through to GetOptions (with value if applicable)
        if ($arg =~ /^--/) {
            push @new_argv, $arg;
            # If --foo=bar, value is already embedded; otherwise consume next
            if ($arg !~ /=/ && $long_val{$arg} && @ARGV) {
                push @new_argv, shift @ARGV;
            }
            next;
        }

        # Not an option: positional argument
        if ($arg !~ /^-/) {
            push @new_argv, $arg;
            $positionals++;
            if ($positionals >= 2) {
                push @trailing, @ARGV;
                last;
            }
            next;
        }

        # Short option bundle: strip leading '-' and process char by char
        my $bundle = substr($arg, 1);
        while (length $bundle) {
            my $c = substr($bundle, 0, 1, '');

            if ($c eq 'w') {
                $warnings = 1;
            }
            elsif ($c eq 'h') {
                pod2usage(-verbose => 1, -exitstatus => 0);
            }
            elsif ($c eq 'V') {
                $version = 1;
            }
            elsif ($c eq 'e' || $c eq 'm' || $c eq 'M') {
                # Value-consuming: rest of bundle, or next argv element
                my $val;
                if (length $bundle) {
                    $val = $bundle;
                    $bundle = '';
                }
                else {
                    $val = shift @ARGV;
                    die "remperl: missing argument for -$c\n"
                        unless defined $val;
                }
                if ($c eq 'e') {
                    push @eval_code, $val;
                }
                else {
                    push @use_specs, [$c, $val];
                }
            }
            else {
                die "remperl: unrecognized switch: -$c\n";
            }
        }
    }

    @ARGV = @new_argv;
    return (\@eval_code, \@use_specs, $warnings, \@trailing);
}

my ($eval_codes, $use_specs, $warnings, $trailing) = parse_perl_opts();

# -- Long option parsing -------------------------------------------------------

GetOptions(@getopt_spec) or pod2usage(2);

# Re-append args that appeared after the stop point (2nd positional or --).
# These are script arguments and must not be processed by GetOptions.
push @ARGV, @$trailing;

pod2usage(-verbose => 1, -exitstatus => 0) if $help;

if ($version) {
    print "remperl $Remote::Perl::VERSION\n";
    exit 0;
}

# No arguments at all: show usage instead of a cryptic "missing host" error.
pod2usage(-verbose => 99, -sections => 'SYNOPSIS', -exitstatus => 0) unless @ARGV || @$eval_codes;

# -- Build the remote command --------------------------------------------------

my @cmd;
if ($pipe_cmd) {
    my $spec = shift @ARGV
        // die "remperl: --pipe-cmd requires a command argument\n";
    @cmd = ('sh', '-c', $spec);
}
else {
    my $host = shift @ARGV
        // die "remperl: missing host argument\n";
    @cmd = ($rsh, $host, 'perl');
}

# -- Source: file or -e --------------------------------------------------------

my $eval_code = @$eval_codes ? join("\n", @$eval_codes) : undef;

# Build preamble from -m/-M specs
my $preamble = '';
for my $spec (@$use_specs) {
    $preamble .= use_spec_to_line($spec->[0], $spec->[1]);
}

my $script;
if (!defined $eval_code) {
    die "remperl: -m/-M requires -e\n" if length $preamble;
    $script = shift @ARGV
        // die "remperl: missing script argument (or use -e CODE)\n";
}
else {
    $eval_code = $preamble . $eval_code if length $preamble;
}

# -- stdin ---------------------------------------------------------------------

die "remperl: --stdin-file and --stdin-str are mutually exclusive\n"
    if defined $stdin_file && defined $stdin_str;

my $stdin;
if (defined $stdin_str) {
    $stdin = $stdin_str;
}
elsif (defined $stdin_file) {
    open(my $fh, '<', $stdin_file)
        or die "remperl: cannot open '$stdin_file': $!\n";
    binmode($fh);
    $stdin = $fh;
}
else {
    $stdin = \*STDIN;
}

# -- Connect and run -----------------------------------------------------------

STDOUT->autoflush(1);

my @inc = $no_system_inc ? @inc_local : (@inc_local, @INC);

# -- Module serving path restriction -------------------------------------------

# --serve-allow implies --serve-restrict-paths
$serve_restrict = 1 if @serve_allow;

my $serve_filter;
if ($serve_restrict) {
    require Cwd;
    # Allowed dirs: explicit --serve-allow + implicit --inc-local
    my @allowed = grep { defined } map { Cwd::realpath($_) } (@serve_allow, @inc_local);
    $serve_filter = sub($path) {
        my $real = Cwd::realpath($path) // return 0;
        for my $dir (@allowed) {
            return 1 if index($real, "$dir/") == 0;
        }
        return 0;
    };
}

die "remperl: unknown --tmpfile-mode value '$tmpfile_mode'\n"
    if defined $tmpfile_mode && $tmpfile_mode !~ /^(auto|linux|perl|named|off)$/;

# --tmpfile-mode implies --tmpfile; --tmpfile alone means auto.
$tmpfile = 1 if defined $tmpfile_mode;
my $tmpfile_val = !$tmpfile                       ? 0
                : !defined($tmpfile_mode)         ? 'auto'
                : $tmpfile_mode eq 'off'          ? 0
                :                                   $tmpfile_mode;

my $r = Remote::Perl->new(
    cmd          => \@cmd,
    window       => $window,
    serve        => $serve_modules,
    inc          => \@inc,
    serve_filter => $serve_filter,
    tmpfile      => $tmpfile_val,
    data_warn    => ($no_data_warn ? 0 : 1),
);

# Forward signals through the protocol so the remote executor receives them
# regardless of transport (SSH, docker, etc.).
for my $sig (qw(INT TERM QUIT HUP)) {
    $SIG{$sig} = sub { eval { $r->send_signal($sig) } };
}

my @script_args = @ARGV;

my %run_opts = (
    on_stdout => sub { print STDOUT $_[0] },
    on_stderr => sub { print STDERR $_[0] },
    stdin     => $stdin,
    args      => \@script_args,
    warnings  => $warnings,
);

my ($rc, $msg) = defined($eval_code)
    ? $r->run_code($eval_code, %run_opts)
    : $r->run_file($script,   %run_opts);

print STDERR "remperl: $msg\n" if $rc && defined $msg && length $msg;

$r->disconnect;
exit($rc // 1);

__END__