File Coverage

blib/lib/Net/SFTP/Server/Buffer.pm

Criterion	Covered	Total	%
statement	26	121	21.4
branch	0	74	0.0
condition	0	19	0.0
subroutine	9	25	36.0
pod	0	16	0.0
total	35	255	13.7

package Net::SFTP::Server::Buffer;

use strict;
use warnings;
use Carp;

use Encode;
use Net::SFTP::Server::Constants qw(:filexfer);

require Exporter;
our @ISA = qw(Exporter);

our @EXPORT = qw( buf_shift_uint32
                  buf_shift_uint64
		  buf_shift_uint8
		  buf_shift_str
		  buf_shift_utf8
		  buf_shift_attrs

		  buf_push_uint32
                  buf_push_uint64
		  buf_push_uint8
		  buf_push_str
		  buf_push_utf8
		  buf_push_attrs
                  buf_push_name
		  buf_push_raw );

use constant HAS_QUADS => do {
    local $@;
    local $SIG{__DIE__};
    no warnings;
    eval q{
        pack(Q => 0x1122334455667788) eq "\x11\x22\x33\x44\x55\x66\x77\x88"
    }
};


sub buf_shift_uint8 { unpack C => substr($_[0], 0, 1, '') }

sub buf_shift_uint32 { unpack N => substr($_[0], 0, 4, '') }

sub buf_shift_uint64_quads { unpack Q => substr(${$_[0]}, 0, 8, '') }

sub buf_shift_uint64_no_quads {
    length $_[0] >= 8 or return;
    my ($big, $small) = unpack(NN => substr($_[0], 0, 8, ''));
    if ($big) {
	# too big for an integer, try to handle it as a float:
	my $high = $big * 4294967296;
	my $result = $high + $small;
	unless ($result - $high == $small) {
	    # too big event for a float, use a BigInt;
	    require Math::BigInt;
	    $result = Math::BigInt->new($big);
	    $result <<= 32;
	    $result += $small;
	}
	return $result;
    }
    return $small;
}

BEGIN {
    *buf_shift_uint64 = (HAS_QUADS
			 ? \&buf_shift_uint64_quads
			 : \&buf_shift_uint64_no_quads);
}

sub buf_shift_str {
    if (my ($len) = unpack N => substr($_[0], 0, 4, '')) {
	return substr($_[0], 0, $len, '')
	    if (length $_[0] >= $len);
    }
    ()
}

sub buf_shift_utf8 {
    if (my ($len) = unpack N => substr($_[0], 0, 4, '')) {
	return Encode::decode(utf8 => substr($_[0], 0, $len, ''))
	    if (length $_[0] >= $len);
    }
    ()
}

sub buf_shift_attrs {
    my %attrs;
    my ($flags) = buf_shift_uint32($_[0]) or return;
    if ($flags & SSH_FILEXFER_ATTR_SIZE) {
	($attrs{size}) = buf_shift_uint64($_[0]) or return;
    }
    if ($flags & SSH_FILEXFER_ATTR_UIDGID) {
	($attrs{uid}) = buf_shift_uint32($_[0]) or return;
	($attrs{gid}) = buf_shift_uint32($_[0]) or return;
    }
    if ($flags & SSH_FILEXFER_ATTR_PERMISSIONS) {
	($attrs{permissions}) = buf_shift_uint32($_[0]) or return;
    }
    if ($flags & SSH_FILEXFER_ATTR_ACMODTIME) {
	($attrs{atime}) = buf_shift_uint32($_[0]) or return;
	($attrs{mtime}) = buf_shift_uint32($_[0]) or return;
    }
    if ($flags & SSH_FILEXFER_ATTR_EXTENDED) {
	my ($count) = buf_shift_uint32($_[0]) or return;
	my @ext;
	for (1..(2*$count)) {
	    my ($str) = buf_shift_str($_[0]) or return;
	    push @ext, $str;
	}
	$attrs{extended} = \@ext;
    }
    \%attrs;
}

sub buf_push_uint8 { $_[0] .= pack(C => int $_[1]) }

sub buf_push_uint32 { $_[0] .= pack(N => int $_[1]) }

sub buf_push_uint64_quads { $_[0] .= pack(Q => int $_[1]) }

sub buf_push_uint64_no_quads {
    my $high = int ( $_[1] / 4294967296);
    $_[0] .= pack(NN => $high, int ($_[1] - $high * 4294967296));
}

BEGIN {
    *buf_push_uint64 = (HAS_QUADS
			? \&buf_push_uint64_quads
			: \&buf_push_uint64_no_quads);
}

sub buf_push_str  {
    utf8::downgrade($_[1]) or croak "unable to pack UTF8 data";
    $_[0] .= pack(N => length $_[1]);
    $_[0] .= $_[1];
}

sub buf_push_utf8 {
    my $octets = Encode::encode(utf8 => $_[1]);
    $_[0] .= pack(N => length $octets);
    $_[0] .= $octets;

}

sub buf_push_attrs {
    my $attrs = $_[1];
    my $b = '';
    my $flags;
    ref $attrs eq 'HASH' or croak "Internal error";
    if (%$attrs) {
	if (defined $attrs->{size}) {
	    $flags |= SSH_FILEXFER_ATTR_SIZE;
	    buf_push_uint64($b, $attrs->{size});
	}

	if (defined $attrs->{uid} and defined $attrs->{gid}) {
	    $flags |= SSH_FILEXFER_ATTR_UIDGID;
	    buf_push_uint32($b, $attrs->{uid});
	    buf_push_uint32($b, $attrs->{gid});
	}
	elsif (defined $attrs->{uid} or defined $attrs->{gid}) {
	    croak "Internal error: invalid attributes specification, uid and gid go together";
	}

	if (defined $attrs->{permissions}) {
	    $flags |= SSH_FILEXFER_ATTR_PERMISSIONS;
	    buf_push_uint32($b, $attrs->{permissions});
	}

	if (defined $attrs->{atime} and defined $attrs->{mtime}) {
	    $flags |= SSH_FILEXFER_ATTR_ACMODTIME;
	    buf_push_uint32($b, $attrs->{atime});
	    buf_push_uint32($b, $attrs->{mtime});
	}
	elsif (defined $attrs->{atime} or defined $attrs->{mtime}) {
	    croak "Internal error: invalid attributes specification, atime and mtime go together";
	}

	my $extended = $attrs->{extended};
	$flags |= SSH_FILEXFER_ATTR_EXTENDED if defined $extended;

	buf_push_uint32 $_[0], $flags;
	$_[0] .= $b;
	if (defined $extended) {
	    if (ref $extended eq 'HASH') {
		$extended = [%$extended];
	    }
	    if (ref $extended eq 'ARRAY') {
		@$extended & 1 and croak "Internal error: odd number of extension fields";
		buf_push_uint32($_[0], @$extended / 2);
		buf_push_str($_[0], $_) for @$extended;
	    }
	    else {
		croak "Internal error: extended field is not an ARRAY reference";
	    }
	}
    }
    else {
	# optimization for the common send-nothing
	buf_push_uint32($_[0], 0);
    }
}

sub buf_push_name {
    my $name = $_[1];
    ref $name eq 'HASH' or croak "Internal error: name is not a HASH ref";
    buf_push_str($_[0], $name->{filename} // '');
    buf_push_str($_[0], $name->{longname} // '');
    my $attrs = $name->{attrs};
    ($attrs and %$attrs) ? buf_push_attrs($_[0], $attrs) :  buf_push_uint32($_[0], 0);
}

sub buf_push_raw {
    utf8::downgrade($_[1]);
    $_[0] .= $_[1];
}



1;