The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Net::SSH::Any::SCP::Base;

use strict;
use warnings;
use Carp;
our @CARP_NOT = qw(Net::SSH::Any);

use Net::SSH::Any::Constants qw(SSHA_SCP_ERROR);
use Net::SSH::Any::Util qw($debug _debug _debugf _debug_hexdump
                           _first_defined _inc_numbered _gen_wanted
                           _scp_escape_name _scp_unescape_name);

sub _new {
    my ($class, $any, $opts) = @_;
    my $self = { any         => $any,
                 log         => delete($opts->{log}),
                 wanted      => _gen_wanted(delete @{$opts}{qw(wanted not_wanted)}),
                 double_dash => _first_defined(delete($opts->{double_dash}), 1),
                 scp_cmd     => _first_defined(delete($opts->{remote_scp_cmd}), $any->{remote_cmd}{scp}, 'scp'),
                 actions     => [],
                 error_count => 0,
                 aborted     => 0,
                 last_error  => undef };
    bless $self, $class;
}

sub _or_set_error { shift->{any}->_or_set_error(@_) }

sub _read_line {
    my $self = shift;
    my $dpipe = shift;
    $debug and $debug & 4096 and _debug("$self->_read_line($dpipe)...");
    for ($_[0]) {
        $_ = '';
        $dpipe->sysread($_, 1) or return;
        if ($_ ne "\x00") {
            while (1) {
                unless ($dpipe->sysread($_, 1, length $_)) {
                    $self->_or_set_error(SSHA_SCP_ERROR, 'broken dpipe');
                    return;
                }
                last if /\x0A$/;
            }
        }
        $debug and $debug & 4096 and _debug_hexdump("line read", $_);
        return length $_;
    }
}

sub _read_response {
    my ($self, $dpipe) = @_;
    if ($self->_read_line($dpipe, my $buf)) {
	$buf eq "\x00" and return 0;
	$buf =~ /^([\x01\x02])(.*)$/ and return(wantarray ? (ord($1), $2) : ord($1));
	$debug and $debug & 4096 and _debug_hexdump "failed to read response", $buf;
        $self->_or_set_error(SSHA_SCP_ERROR, "SCP protocol error");
    }
    else {
        $self->_or_set_error(SSHA_SCP_ERROR, "broken dpipe");
    }
    wantarray ? (2, $self->{any}->error) : 2
}

sub _push_action {
    my ($self, %a) = @_;
    push @{$self->{actions}}, \%a;
    unless (defined $a{path}) {
        # We don't use File::Spec here because we didn't know what
        # the remote file system path separator may be.
        # TODO: allow to change how paths are joined from some setting.
        $a{path} = ( $a{name} =~ m|/|
                     ? $a{name}
                     : join('/', map $_->{name}, @{$self->{actions}}) );
    }
    defined $self->{$_} and $a{$_} = $self->{$_} for qw(mtime atime);
    push @{$self->{log}}, \%a if $self->{log};
    \%a;
}

sub _pop_action {
    my ($g, $type, $may_be_undef) = @_;
    my $action = pop @{$g->{actions}};
    unless ($action) {
        $may_be_undef and return;
        croak "internal error: _pop_action called but action stack is empty!";
    }
    if (defined $type) {
        $action->{type} eq $type or
            croak "internal error: $type action expected at top of the queue but $action->{type} found";
    }
    $action
}

sub _set_error {
    my ($self, $action, $origin, $error) = @_;
    unless (defined ($action->{error})) {
        $action->{error} = $error;
        $action->{error_origin} = $origin;
        $self->{error_count}++;
    }
    return
}

sub set_local_error {
    my ($self, $action, $error) = @_;
    $error = $! unless defined $error;
    $self->{last_error} = $error;
    $self->_set_error($action, 'local', $error);
}

sub last_error {
    my $self = shift;
    my $error = $self->{last_error};
    (defined $error ? $error : 'unknown error')
}

sub abort {
    my $self = shift;
    $self->_or_set_error(SSHA_SCP_ERROR, @_) if @_;
    $self->{aborted} = 1;
}

sub set_remote_error {
    my ($self, $action, $error) = @_;
    $self->_set_error($action, 'remote', $error);
}

sub _check_wanted {
    my ($self, $action) = @_;
    if (my $wanted = $self->{wanted}) {
	unless ($wanted->($action)) {
	    $debug and $debug & 4096 and
		_debugf("%s->set_not_wanted, %s", $self, $action->{path});
	    $action->{not_wanted} = 1;
	    return;
	}
    }
    1;
}

1;