File Coverage

blib/lib/Net/SSH/Any/_Base.pm

Criterion	Covered	Total	%
statement	27	226	11.9
branch	0	118	0.0
condition	0	70	0.0
subroutine	9	38	23.6
pod	0	2	0.0
total	36	454	7.9

package Net::SSH::Any::_Base;

use strict;
use warnings;
use Carp;

use File::Spec;
use Scalar::Util ();
use Encode ();

use Net::SSH::Any::Constants qw(SSHA_BACKEND_ERROR SSHA_LOCAL_IO_ERROR SSHA_UNIMPLEMENTED_ERROR SSHA_ENCODING_ERROR);
use Net::SSH::Any::Util;
our @CARP_NOT = qw(Net::SSH::Any::Util);

sub _new {
    my ($class, $opts) = @_;
    my $os = delete $opts->{os};

    my (%remote_cmd, %local_cmd, %remote_extra_args, %local_extra_args);
    for (keys %$opts) {
        /^remote_(.*)_cmd$/ and $remote_cmd{$1} = $opts->{$_};
        /^local_(.*)_cmd$/ and $local_cmd{$1} = $opts->{$_};
        /^remote_(.*)_extra_args$/ and $remote_extra_args{$1} = $opts->{$_};
        /^local_(.*)_extra_args$/ and $local_extra_args{$1} = $opts->{$_};
    }

    my $self = { os => $os,
                 error => 0,
                 error_prefix => [],
                 backend_log => [],
                 remote_cmd => \%remote_cmd,
                 local_cmd => \%local_cmd,
                 remote_extra_args => \%remote_extra_args,
                 local_extra_args => \%local_extra_args,
               };

    my $encoding = $self->{encoding} = delete $opts->{encoding} // 'utf8';
    $self->{stream_encoding} = delete $opts->{stream_encoding} // $encoding;
    $self->{argument_encoding} = delete $opts->{argument_encoding} // $encoding;

    bless $self, $class;
    $self;
}

sub _log_error_and_reset_backend {
    my $self = shift;
    push @{$self->{backend_log}}, "$self->{backend}: [".($self->{error}+0)."] $self->{error}";
    $self->{error} = 0;
    delete $self->{backend};
    delete $self->{backend_module};
    ()
}

sub _load_backend_module {
    my ($self, $class, $backend, $required_version) = @_;
    $backend =~ /^\w+$/ or croak "Bad backend name '$backend' for class '$class'";
    $self->{backend} = $backend;
    my $module = $self->{backend_module} = "${class}::Backend::${backend}";

    local ($@, $SIG{__DIE__});
    my $ok = eval <
no strict;
no warnings;
require $module;
1;
EOE
    if ($ok) {
        if ($required_version) {
            if ($module->can('_backend_api_version')) {
                my $version = $module->_backend_api_version;
                if ($version >= $required_version) {
                    return 1;
                }
                else {
                    $self->_set_error(SSHA_BACKEND_ERROR,
                                     "backend API version $version is too old ($required_version required)");
                }
            }
            else {
                $self->_set_error(SSHA_BACKEND_ERROR, 'method _backend_api_version missing');
            }
        }
        else {
            return 1;
        }
    }
    else {
        $self->_set_error(SSHA_BACKEND_ERROR, "unable to load module '$module'", $@);
    }

    $self->_log_error_and_reset_backend;
    ()
}

sub error { shift->{error} }

sub die_on_error {
    my $self = shift;
    $self->{error} and croak(join(': ', @_, "$self->{error}"));
    1;
}

sub _set_error {
    my $self = shift;
    my $code = shift || 0;
    my @msg = grep { defined && length } @_;
    @msg = "Unknown error $code" unless @msg;
    my $error = $self->{error} = ( $code
                                  ? Scalar::Util::dualvar($code, join(': ', @{$self->{error_prefix}}, @msg))
                                  : 0 );
    $debug and $debug & 1 and _debug "set_error($code - $error)";
    return $error
}

sub _or_set_error {
    my $self = shift;
    $self->{error} or $self->_set_error(@_);
}

sub _or_check_error_after_eval {
    if ($@) {
        my ($any, $code) = @_;
        unless ($any->{error}) {
            my $err = $@;
            $err =~ s/(.*) at .* line \d+.$/$1/;
            $any->_set_error($code, $err);
        }
        return 0;
    }
    1
}

sub _open_file {
    my ($self, $def_mode, $name_or_args) = @_;
    my ($mode, @args) = (ref $name_or_args
			 ? @$name_or_args
			 : ($def_mode, $name_or_args));
    if (open my $fh, $mode, @args) {
        return $fh;
    }
    $self->_set_error(SSHA_LOCAL_IO_ERROR, "Unable to open file '@args': $!");
    return undef;
}

my %loaded;
sub _load_module {
    my ($self, $module) = @_;
    $loaded{$module} ||= eval "require $module; 1" and return 1;
    $self->_set_error(SSHA_UNIMPLEMENTED_ERROR, "Unable to load perl module $module");
    return;
}

sub _load_os {
    my $self = shift;
    my $os = $self->{os} //= ($^O =~ /^mswin/i ? 'MSWin' : 'POSIX');
    my $os_module = "Net::SSH::Any::OS::$os";
    $self->_load_module($os_module) or return;
    $self->{os_module} = $os_module;
}

sub _find_cmd_by_friend {
    my ($any, $name, $friend) = @_;
    if (defined $friend) {
        my $up = File::Spec->updir;
        my ($drive, $dir) = File::Spec->splitpath($friend);
        my $base = File::Spec->catpath($drive, $dir);
        for my $path (File::Spec->join($base, $name),
                      map File::Spec->join($base, $up, $_, $name), qw(bin sbin libexec) ) {
            my $cmd = $any->_os_validate_cmd($path);
            return $cmd if defined $cmd;
        }
    }
    ()
}

sub _find_cmd_in_path {
    my ($any, $name) = @_;
    for my $path (File::Spec->path) {
        my $cmd = $any->_os_validate_cmd(File::Spec->join($path, $name));
        return $cmd if defined $cmd;
    }
    ()
}

sub _find_cmd {
    my ($any, $name, $friend, $app, $default) = @_;
    my $safe_name = $name;
    $safe_name =~ s/\W/_/g;
    return ( $any->{local_cmd}{$safe_name}             //
             $any->_find_cmd_by_friend($name, $friend) //
             $any->_find_cmd_in_path($name)            //
             $any->_find_helper_cmd($name)             //
             $any->_os_find_cmd_by_app($name, $app)    //
             $any->_os_validate_cmd($default)          //
             $name );
}

sub _find_helper_cmd {
    my ($any, $name) = @_;
    $debug and $debug & 1024 and _debug "looking for helper $name";
    my $module = my $last = $any->{backend_module} // return;
    $last =~ s/.*::// or return;
    $module =~ s{::}{/}g;
    $debug and $debug & 1024 and _debug "module as \$INC key is ", $module, ".pm";
    my $file_pm = $INC{"$module.pm"} // return;
    my ($drive, $dir) = File::Spec->splitpath(File::Spec->rel2abs($file_pm));
    my $path = File::Spec->catpath($drive, $dir, $last, 'Helpers', $name);
    $any->_os_validate_cmd($path);
}

sub _find_local_extra_args {
    my ($any, $name, $opts, @default) = @_;
    my $safe_name = $name;
    $safe_name =~ s/\W/_/g;
    my $extra = ( $opts->{"local_${safe_name}_extra_args"} //
                  $any->{local_extra_args}{$safe_name} //
                  \@default );
    [_array_or_scalar_to_list $extra]
}

my %posix_shell = map { $_ => 1 } qw(POSIX bash sh ksh ash dash pdksh mksh lksh zsh fizsh posh);

sub _new_quoter {
    my ($any, $shell) = @_;
    if ($posix_shell{$shell}) {
	$any->_load_module('Net::SSH::Any::POSIXShellQuoter') or return;
	return 'Net::SSH::Any::POSIXShellQuoter';
    }
    else {
	$any->_load_module('Net::OpenSSH::ShellQuoter') or return;
	return Net::OpenSSH::ShellQuoter->quoter($shell);
    }
}

sub _quoter {
    my ($any, $shell) = @_;
    defined $shell or croak "shell argument is undef";
    return $any->_new_quoter($shell);
}

sub _quote_args {
    my $any = shift;
    my $opts = shift;
    ref $opts eq 'HASH' or die "internal error";
    my $quote = delete $opts->{quote_args};
    my $glob_quoting = delete $opts->{glob_quoting};
    my $argument_encoding =  $any->_delete_argument_encoding($opts);
    $quote = (@_ > 1) unless defined $quote;

    my @quoted;
    if ($quote) {
	my $shell = delete $opts->{remote_shell} // delete $opts->{shell};
	my $quoter = $any->_quoter($shell) or return;
	my $quote_method = ($glob_quoting ? 'quote_glob' : 'quote');

        # foo   => $quoter
        # \foo  => $quoter_glob
        # \\foo => no quoting at all and disable extended quoting as it is not safe
        for (@_) {
            if (ref $_) {
                if (ref $_ eq 'SCALAR') {
                    push @quoted, $quoter->quote_glob($$_);
                }
                elsif (ref $_ eq 'REF' and ref $$_ eq 'SCALAR') {
                    push @quoted, $$$_;
                }
                else {
                    croak "invalid reference in remote command argument list"
                }
            }
            else {
                push @quoted, $quoter->$quote_method($_);
            }
        }
    }
    else {
        croak "reference found in argument list when argument quoting is disabled" if (grep ref, @_);
        @quoted = @_;
    }
    $any->_encode_args($argument_encoding, @quoted);
    $debug and $debug & 1024 and _debug("command+args: @quoted");
    wantarray ? @quoted : join(" ", @quoted);
}

sub _delete_argument_encoding {
    my ($any, $opts) = @_;
    _first_defined(delete $opts->{argument_encoding},
                   delete $opts->{encoding},
                   $any->{argument_encoding})
}

sub _delete_stream_encoding {
    my ($any, $opts) = @_;
    _first_defined(delete $opts->{stream_encoding},
                   $opts->{encoding},
                   $any->{stream_encoding})
}

sub _find_encoding {
    my ($any, $encoding, $data) = @_;
    my $enc = Encode::find_encoding($encoding)
        or $any->_or_set_error(SSHA_ENCODING_ERROR, "bad encoding '$encoding'");
    return $enc
}

sub _encode_data {
    my $any = shift;
    my $encoding = shift;
    if (@_) {
        my $enc = $any->_find_encoding($encoding) or return;
        local $any->{error_prefix} = [@{$any->{error_prefix}}, "data encoding failed"];
        local ($@, $SIG{__DIE__});
        eval { defined and $_ = $enc->encode($_, Encode::FB_CROAK()) for @_ };
        $any->_or_check_error_after_eval(SSHA_ENCODING_ERROR) or return;
    }
    1
}

sub _decode_data {
    my $any = shift;
    my $encoding = shift;
    my $enc = $any->_find_encoding($encoding) or return;
    if (@_) {
        local ($@, $SIG{__DIE__});
        eval { defined and $_ = $enc->decode($_, Encode::FB_CROAK()) for @_ };
        $any->_or_check_error_after_eval(SSHA_ENCODING_ERROR) or return;
    }
    1;
}

sub _encode_args {
    if (@_ > 2) {
        my $any = shift;
        my $encoding = shift;
        local $any->{error_prefix} = [@{$any->{error_prefix}}, "argument encoding failed"];
        if (my $enc = $any->_find_encoding($encoding)) {
            $any->_encode_data($enc, @_);
        }
        return !$any->{_error};
    }
    1;
}

# transparently delegate method calls to backend and os packages:
sub AUTOLOAD {
    our $AUTOLOAD;
    my ($name) = $AUTOLOAD =~ /([^:]*)$/;
    my $sub;
    no strict 'refs';
    if (my ($os_name) = $name =~ /^_os_(.*)/) {
        $sub = sub {
            my $os = $_[0]->{os_module} //= $_[0]->_load_os or return;
            my $method = $os->can($os_name)
                or croak "method '$os_name' not defined in OS '$os'";
            goto &$method;
        };
    }
    else {
        $sub = sub {
            my $module = $_[0]->{backend_module} or return;
            my $method = $module->can($name)
                or croak "method '$name' not defined in backend '$module'";
            goto &$method;
        };
    }
    *{$AUTOLOAD} = $sub;
    goto &$sub;
}

sub DESTROY {
    my $self = shift;
    my $module = $self->{backend_module};
    if (defined $module) {
        my $sub = $module->can('DESTROY');
        $sub->($self) if $sub;
    }
}

1;