File Coverage

blib/lib/Net/SFTP.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

# $Id: SFTP.pm,v 1.35 2005/10/05 06:19:36 dbrobins Exp $

package Net::SFTP;
use strict;

use Net::SFTP::Constants qw( :fxp :flags :status :att SSH2_FILEXFER_VERSION );
use Net::SFTP::Util qw( fx2txt );
use Net::SFTP::Attributes;
use Net::SFTP::Buffer;
use Net::SSH::Perl::Constants qw( :msg2 );
use Net::SSH::Perl 1.24;

use Carp qw( carp croak );

use vars qw( $VERSION );
$VERSION = '0.10';

use constant COPY_SIZE => 8192;

sub new {
    my $class = shift;
    my $sftp = bless { }, $class;
    $sftp->{host} = shift;
    $sftp->init(@_);
}

# call the warning handler with the object and message
sub warn {
    my ($sftp,$msg,$status) = @_;
    $msg .= ': '.fx2txt($status) if defined $status;
    $sftp->{status} = $status || SSH2_FX_OK;
    $sftp->{warn_h}->($sftp,$msg);
}

# returns last SSH error, or SSH2_FX_OK (only useful after failure)
sub status {
    my $sftp = shift;
    my $status = $sftp->{status};
    wantarray ? ($status,fx2txt($status)) : $status
}

# returns the new object
sub init {
    my $sftp = shift;
    my %param = @_;
    $sftp->{debug} = delete $param{debug};
    $sftp->{status} = SSH2_FX_OK;

    $param{ssh_args} ||= [];
    $param{ssh_args} = [%{$param{ssh_args}}]
     if UNIVERSAL::isa($param{ssh_args},'HASH');

    $param{warn} = 1 if not defined $param{warn};   # default
    $sftp->{warn_h} = delete $param{warn} || sub {};  # false => ignore
    $sftp->{warn_h} = sub { carp $_[1] }  # true  => emit warning
     if $sftp->{warn_h} and not ref $sftp->{warn_h};

    $sftp->{_msg_id} = 0;

    my $ssh = Net::SSH::Perl->new($sftp->{host}, protocol => 2,
        debug => $sftp->{debug}, @{ $param{ssh_args} });
    $ssh->login($param{user}, $param{password}, 'supress_shell');
    $sftp->{ssh} = $ssh;

    my $channel = $sftp->_open_channel;
    $sftp->{channel} = $channel;

    $sftp->do_init;

    $sftp;
}

# returns the new channel object
sub _open_channel {
    my $sftp = shift;
    my $ssh = $sftp->{ssh};

    my $channel = $ssh->_session_channel;
    $channel->open;

    $channel->register_handler(SSH2_MSG_CHANNEL_OPEN_CONFIRMATION, sub {
        my($c, $packet) = @_;
        $c->{ssh}->debug("Sending subsystem: sftp");
        my $r_packet = $c->request_start("subsystem", 1);
        $r_packet->put_str("sftp");
        $r_packet->send;
    });

    my $subsystem_reply = sub {
        my($c, $packet) = @_;
        my $id = $packet->get_int32;
        if ($packet->type == SSH2_MSG_CHANNEL_FAILURE) {
            $c->{ssh}->fatal_disconnect("Request for " .
                "subsystem 'sftp' failed on channel '$id'");
        }
        $c->{ssh}->break_client_loop;
    };

    my $cmgr = $ssh->channel_mgr;
    $cmgr->register_handler(SSH2_MSG_CHANNEL_FAILURE, $subsystem_reply);
    $cmgr->register_handler(SSH2_MSG_CHANNEL_SUCCESS, $subsystem_reply);

    $sftp->{incoming} = Net::SFTP::Buffer->new;
    my $incoming = $sftp->{incoming};
    $channel->register_handler("_output_buffer", sub {
        my($c, $buffer) = @_;
        $incoming->append($buffer->bytes);
        $c->{ssh}->break_client_loop;
    });

    ## Get channel confirmation, etc. Break once we get a response
    ## to subsystem execution.
    $ssh->client_loop;

    $channel;
}

sub do_init {
    my $sftp = shift;
    my $ssh = $sftp->{ssh};

    $sftp->debug("Sending SSH2_FXP_INIT");
    my $msg = $sftp->new_msg(SSH2_FXP_INIT);
    $msg->put_int32(SSH2_FILEXFER_VERSION);
    $sftp->send_msg($msg);

    $msg = $sftp->get_msg;
    my $type = $msg->get_int8;
    if ($type != SSH2_FXP_VERSION) {
        croak "Invalid packet back from SSH2_FXP_INIT (type $type)";
    }
    my $version = $msg->get_int32;
    $sftp->debug("Remote version: $version");

    ## XXX Check for extensions.
}

sub debug {
    my $sftp = shift;
    if ($sftp->{debug}) {
        $sftp->{ssh}->debug("sftp: @_");
    }
}

## Server -> client methods.

# reads SSH2_FXP_STATUS packet and returns Net::SFTP::Attributes object or undef
sub get_attrs {
    my $sftp = shift;
    my($expected_id) = @_;
    my $msg = $sftp->get_msg;
    my $type = $msg->get_int8;
    my $id = $msg->get_int32;
    $sftp->debug("Received stat reply T:$type I:$id");
    croak "ID mismatch ($id != $expected_id)" unless $id == $expected_id;
    if ($type == SSH2_FXP_STATUS) {
        my $status = $msg->get_int32;
  $sftp->warn("Couldn't stat remote file",$status);
        return;
    }
    elsif ($type != SSH2_FXP_ATTRS) {
        croak "Expected SSH2_FXP_ATTRS packet, got $type";
    }
    $msg->get_attributes;
}

# reads SSH2_FXP_STATUS packet and returns SFTP status value
sub get_status {
    my $sftp = shift;
    my($expected_id) = @_;
    my $msg = $sftp->get_msg;
    my $type = $msg->get_int8;
    my $id = $msg->get_int32;

    croak "ID mismatch ($id != $expected_id)" unless $id == $expected_id;
    if ($type != SSH2_FXP_STATUS) {
        croak "Expected SSH2_FXP_STATUS packet, got $type";
    }

    $msg->get_int32;
}

# reads SSH2_FXP_HANDLE packet and returns handle, or undef on failure
sub get_handle {
    my $sftp = shift;
    my($expected_id) = @_;

    my $msg = $sftp->get_msg;
    my $type = $msg->get_int8;
    my $id = $msg->get_int32;

    croak "ID mismatch ($id != $expected_id)" unless $id == $expected_id;
    if ($type == SSH2_FXP_STATUS) {
        my $status = $msg->get_int32;
  $sftp->warn("Couldn't get handle",$status);
        return;
    }
    elsif ($type != SSH2_FXP_HANDLE) {
        croak "Expected SSH2_FXP_HANDLE packet, got $type";
    }

    $msg->get_str;
}

## Client -> server methods.

sub _send_str_request {
    my $sftp = shift;
    my($code, $str) = @_;
    my($msg, $id) = $sftp->new_msg_w_id($code);
    $msg->put_str($str);
    $sftp->send_msg($msg);
    $sftp->debug("Sent message T:$code I:$id");
    $id;
}

sub _send_str_attrs_request {
    my $sftp = shift;
    my($code, $str, $a) = @_;
    my($msg, $id) = $sftp->new_msg_w_id($code);
    $msg->put_str($str);
    $msg->put_attributes($a);
    $sftp->send_msg($msg);
    $sftp->debug("Sent message T:$code I:$id");
    $id;
}

sub _check_ok_status {
    my $status = $_[0]->get_status($_[1]);
    $_[0]->warn("Couldn't $_[2]",$status) unless $status == SSH2_FX_OK;
    $status;
}

## SSH2_FXP_OPEN (3)
# returns handle on success, undef on failure
sub do_open {
    my $sftp = shift;
    my($path, $flags, $a) = @_;
    $a ||= Net::SFTP::Attributes->new;
    my($msg, $id) = $sftp->new_msg_w_id(SSH2_FXP_OPEN);
    $msg->put_str($path);
    $msg->put_int32($flags);
    $msg->put_attributes($a);
    $sftp->send_msg($msg);
    $sftp->debug("Sent SSH2_FXP_OPEN I:$id P:$path");
    $sftp->get_handle($id);
}

## SSH2_FXP_READ (4)
# returns data on success, (undef,$status) on failure
sub do_read {
    my $sftp = shift;
    my($handle, $offset, $size) = @_;
    $size ||= COPY_SIZE;
    my($msg, $expected_id) = $sftp->new_msg_w_id(SSH2_FXP_READ);
    $msg->put_str($handle);
    $msg->put_int64(int $offset);
    $msg->put_int32($size);
    $sftp->send_msg($msg);
    $sftp->debug("Sent message SSH2_FXP_READ I:$expected_id O:$offset");
    $msg = $sftp->get_msg;
    my $type = $msg->get_int8;
    my $id = $msg->get_int32;
    $sftp->debug("Received reply T:$type I:$id");
    croak "ID mismatch ($id != $expected_id)" unless $id == $expected_id;
    if ($type == SSH2_FXP_STATUS) {
        my $status = $msg->get_int32;
        if ($status != SSH2_FX_EOF) {
      $sftp->warn("Couldn't read from remote file",$status);
            $sftp->do_close($handle);
        }
        return(undef, $status);
    }
    elsif ($type != SSH2_FXP_DATA) {
        croak "Expected SSH2_FXP_DATA packet, got $type";
    }
    $msg->get_str;
}

## SSH2_FXP_WRITE (6)
# returns status (SSH2_FX_OK on success)
sub do_write {
    my $sftp = shift;
    my($handle, $offset, $data) = @_;
    my($msg, $id) = $sftp->new_msg_w_id(SSH2_FXP_WRITE);
    $msg->put_str($handle);
    $msg->put_int64(int $offset);
    $msg->put_str($data);
    $sftp->send_msg($msg);
    $sftp->debug("Sent message SSH2_FXP_WRITE I:$id O:$offset");
    my $status = $sftp->_check_ok_status($id,'write to remote file');
    $sftp->do_close($handle) unless $status == SSH2_FX_OK;
    return $status;
}

## SSH2_FXP_LSTAT (7), SSH2_FXP_FSTAT (8), SSH2_FXP_STAT (17)
# these all return a Net::SFTP::Attributes object on success, undef on failure
sub do_lstat { $_[0]->_do_stat(SSH2_FXP_LSTAT, $_[1]) }
sub do_fstat { $_[0]->_do_stat(SSH2_FXP_FSTAT, $_[1]) }
sub do_stat  { $_[0]->_do_stat(SSH2_FXP_STAT , $_[1]) }
sub _do_stat {
    my $sftp = shift;
    my $id = $sftp->_send_str_request(@_);
    $sftp->get_attrs($id);
}

## SSH2_FXP_OPENDIR (11)
sub do_opendir {
    my $sftp = shift;
    my $id = $sftp->_send_str_request(SSH2_FXP_OPENDIR, @_);
    $sftp->get_handle($id);
}

## SSH2_FXP_CLOSE (4),   SSH2_FXP_REMOVE (13),
## SSH2_FXP_MKDIR (14),  SSH2_FXP_RMDIR (15),
## SSH2_FXP_SETSTAT (9), SSH2_FXP_FSETSTAT (10)
# all of these return a status (SSH2_FX_OK on success)
{
    no strict 'refs';
    *do_close    = _gen_simple_method(SSH2_FXP_CLOSE,  'close file');
    *do_remove   = _gen_simple_method(SSH2_FXP_REMOVE, 'delete file');
    *do_mkdir    = _gen_simple_method(SSH2_FXP_MKDIR,  'create directory');
    *do_rmdir    = _gen_simple_method(SSH2_FXP_RMDIR,  'remove directory');
    *do_setstat  = _gen_simple_method(SSH2_FXP_SETSTAT , 'setstat');
    *do_fsetstat = _gen_simple_method(SSH2_FXP_FSETSTAT , 'fsetstat');
}

sub _gen_simple_method {
    my($code, $msg) = @_;
    sub {
        my $sftp = shift;
        my $id = @_ > 1 ?
            $sftp->_send_str_attrs_request($code, @_) :
            $sftp->_send_str_request($code, @_);
        $sftp->_check_ok_status($id, $msg);
    };
}

## SSH2_FXP_REALPATH (16)
sub do_realpath {
    my $sftp = shift;
    my($path) = @_;
    my $expected_id = $sftp->_send_str_request(SSH2_FXP_REALPATH, $path);
    my $msg = $sftp->get_msg;
    my $type = $msg->get_int8;
    my $id = $msg->get_int32;
    croak "ID mismatch ($id != $expected_id)" unless $id == $expected_id;
    if ($type == SSH2_FXP_STATUS) {
        my $status = $msg->get_int32;
  $sftp->warn("Couldn't canonicalise $path",$status);
        return;
    }
    elsif ($type != SSH2_FXP_NAME) {
        croak "Expected SSH2_FXP_NAME packet, got $type";
    }
    my $count = $msg->get_int32;
    croak "Got multiple names ($count) from SSH2_FXP_REALPATH"
        unless $count == 1;
    $msg->get_str;   ## Filename.
}

## SSH2_FXP_RENAME (18)
sub do_rename {
    my $sftp = shift;
    my($old, $new) = @_;
    my($msg, $id) = $sftp->new_msg_w_id(SSH2_FXP_RENAME);
    $msg->put_str($old);
    $msg->put_str($new);
    $sftp->send_msg($msg);
    $sftp->debug("Sent message SSH2_FXP_RENAME '$old' => '$new'");
    $sftp->_check_ok_status($id, "rename '$old' to '$new'");
}

## High-level client -> server methods.

# always returns undef on failure
# if local filename is provided, returns '' on success, else file contents
sub get {
    my $sftp = shift;
    my($remote, $local, $cb) = @_;
    my $ssh = $sftp->{ssh};
    my $want = defined wantarray ? 1 : 0;

    my $a = $sftp->do_stat($remote) or return;
    my $handle = $sftp->do_open($remote, SSH2_FXF_READ);
    return unless defined $handle;

    local *FH;
    if ($local) {
        open FH, ">$local" or
         $sftp->do_close($handle), croak "Can't open $local: $!";
        binmode FH or
         $sftp->do_close($handle), croak "Can't binmode FH: $!";
    }

    my $offset = 0;
    my $ret = '';
    while (1) {
        my($data, $status) = $sftp->do_read($handle, $offset, COPY_SIZE);
        last if defined $status && $status == SSH2_FX_EOF;
        return unless $data;
        my $len = length($data);
        croak "Received more data than asked for $len > " . COPY_SIZE
            if $len > COPY_SIZE;
        $sftp->debug("In read loop, got $len offset $offset");
        $cb->($sftp, $data, $offset, $a->size) if defined $cb;
        if ($local) {
            print FH $data;
        }
        elsif ($want) {
            $ret .= $data;
        }
        $offset += $len;
    }
    $sftp->do_close($handle);

    if ($local) {
        close FH;
        my $flags = $a->flags;
        my $mode = $flags & SSH2_FILEXFER_ATTR_PERMISSIONS ?
            $a->perm & 0777 : 0666;
        chmod $mode, $local or croak "Can't chmod $local: $!";

        if ($flags & SSH2_FILEXFER_ATTR_ACMODTIME) {
            utime $a->atime, $a->mtime, $local or
                croak "Can't utime $local: $!";
        }
    }
    $ret;
}

sub put {
    my $sftp = shift;
    my($local, $remote, $cb) = @_;
    my $ssh = $sftp->{ssh};

    my @stat = stat $local or croak "Can't stat local $local: $!";
    my $size = $stat[7];
    my $a = Net::SFTP::Attributes->new(Stat => \@stat);
    my $flags = $a->flags;
    $flags &= ~SSH2_FILEXFER_ATTR_SIZE;
    $flags &= ~SSH2_FILEXFER_ATTR_UIDGID;
    $a->flags($flags);
    $a->perm( $a->perm & 0777 );

    local *FH;
    open FH, $local or croak "Can't open local file $local: $!";
    binmode FH or croak "Can't binmode FH: $!";

    my $handle = $sftp->do_open($remote, SSH2_FXF_WRITE | SSH2_FXF_CREAT |
     SSH2_FXF_TRUNC, $a);  # check status for info
    return unless defined $handle;

    my $offset = 0;
    while (1) {
        my($len, $data, $msg, $id);
        $len = read FH, $data, COPY_SIZE;
        last unless $len;
        $cb->($sftp, $data, $offset, $size) if defined $cb;
        my $status = $sftp->do_write($handle, $offset, $data);
        if ($status != SSH2_FX_OK) {
            close FH;
            return;
        }
        $sftp->debug("In write loop, got $len offset $offset");
        $offset += $len;
    }

    close FH or $sftp->warn("Can't close local file $local: $!");

    # ignore failures here, the transmission is the important part
    $sftp->do_fsetstat($handle, $a);
    $sftp->do_close($handle);
    return 1;
}

# returns ()/undef on error, directory list/reference to same otherwise
sub ls {
    my $sftp = shift;
    my($remote, $code) = @_;
    my @dir;
    my $handle = $sftp->do_opendir($remote);
    return unless defined $handle;

    while (1) {
        my $expected_id = $sftp->_send_str_request(SSH2_FXP_READDIR, $handle);
        my $msg = $sftp->get_msg;
        my $type = $msg->get_int8;
        my $id = $msg->get_int32;
        $sftp->debug("Received reply T:$type I:$id");

        croak "ID mismatch ($id != $expected_id)" unless $id == $expected_id;
        if ($type == SSH2_FXP_STATUS) {
            my $status = $msg->get_int32;
            $sftp->debug("Received SSH2_FXP_STATUS $status");
            if ($status == SSH2_FX_EOF) {
                last;
            }
            else {
    $sftp->warn("Couldn't read directory",$status);
                $sftp->do_close($handle);
                return;
            }
        }
        elsif ($type != SSH2_FXP_NAME) {
            croak "Expected SSH2_FXP_NAME packet, got $type";
        }

        my $count = $msg->get_int32;
        last unless $count;
        $sftp->debug("Received $count SSH2_FXP_NAME responses");
        for my $i (0..$count-1) {
            my $fname = $msg->get_str;
            my $lname = $msg->get_str;
            my $a = $msg->get_attributes;
            my $rec = {
                filename => $fname,
                longname => $lname,
                a        => $a,
            };
            if ($code && ref($code) eq "CODE") {
                $code->($rec);
            }
            else {
                push @dir, $rec;
            }
        }
    }
    $sftp->do_close($handle);
    wantarray ? @dir : \@dir;
}

## Messaging methods--messages are essentially sub-packets.

sub msg_id { $_[0]->{_msg_id}++ }

sub new_msg {
    my $sftp = shift;
    my($code) = @_;
    my $msg = Net::SFTP::Buffer->new;
    $msg->put_int8($code);
    $msg;
}

sub new_msg_w_id {
    my $sftp = shift;
    my($code, $sid) = @_;
    my $msg = $sftp->new_msg($code);
    my $id = defined $sid ? $sid : $sftp->msg_id;
    $msg->put_int32($id);
    ($msg, $id);
}

sub send_msg {
    my $sftp = shift;
    my($buf) = @_;
    my $b = Net::SFTP::Buffer->new;
    $b->put_int32($buf->length);
    $b->append($buf->bytes);
    $sftp->{channel}->send_data($b->bytes);
}

sub get_msg {
    my $sftp = shift;
    my $buf = $sftp->{incoming};
    my $len;
    unless ($buf->length > 4) {
        $sftp->{ssh}->client_loop;
        croak "Connection closed" unless $buf->length > 4;
        $len = unpack "N", $buf->bytes(0, 4, '');
        croak "Received message too long $len" if $len > 256 * 1024;
        while ($buf->length < $len) {
            $sftp->{ssh}->client_loop;
        }
    }
    my $b = Net::SFTP::Buffer->new;
    $b->append( $buf->bytes(0, $len, '') );
    $b;
}

1;
__END__