File Coverage

blib/lib/Net/SFTP/Foreign/Buffer.pm
Criterion Covered Total %
statement 21 120 17.5
branch 0 34 0.0
condition n/a
subroutine 6 31 19.3
pod 0 24 0.0
total 27 209 12.9


line stmt bran cond sub pod time code
1             package Net::SFTP::Foreign::Buffer;
2              
3             our $VERSION = '1.68_05';
4              
5 3     3   19 use strict;
  3         6  
  3         89  
6 3     3   15 use warnings;
  3         5  
  3         77  
7 3     3   14 no warnings 'uninitialized';
  3         4  
  3         98  
8              
9 3     3   17 use Carp;
  3         16  
  3         253  
10              
11 3         6 use constant HAS_QUADS => do {
12 3         7 local $@;
13 3         24 local $SIG{__DIE__};
14 3     3   29 no warnings;
  3         6  
  3         155  
15 3         278 eval q{
16             pack(Q => 0x1122334455667788) eq "\x11\x22\x33\x44\x55\x66\x77\x88"
17             }
18 3     3   18 };
  3         6  
19              
20             sub new {
21 0     0 0   my $class = shift;
22 0           my $data = '';
23 0 0         @_ and put(\$data, @_);
24 0           bless \$data, $class;
25             }
26              
27 0     0 0   sub make { bless \$_[1], $_[0] }
28              
29 0     0 0   sub bytes { ${$_[0]} }
  0            
30              
31             sub get_int8 {
32 0 0   0 0   length ${$_[0]} >=1 or return undef;
  0            
33 0           unpack(C => substr(${$_[0]}, 0, 1, ''));
  0            
34             }
35              
36             sub get_int16 {
37 0 0   0 0   length ${$_[0]} >=2 or return undef;
  0            
38 0           unpack(n => substr(${$_[0]}, 0, 2, ''));
  0            
39             }
40              
41             sub get_int32 {
42 0 0   0 0   length ${$_[0]} >=4 or return undef;
  0            
43 0           unpack(N => substr(${$_[0]}, 0, 4, ''));
  0            
44             }
45              
46             sub get_int32_untaint {
47 0     0 0   my ($v) = substr(${$_[0]}, 0, 4, '') =~ /(.*)/s;
  0            
48 0           get_int32(\$v);
49             }
50              
51             sub get_int64_quads {
52 0 0   0 0   length ${$_[0]} >= 8 or return undef;
  0            
53 0           unpack Q => substr(${$_[0]}, 0, 8, '')
  0            
54             }
55              
56             sub get_int64_no_quads {
57 0 0   0 0   length ${$_[0]} >= 8 or return undef;
  0            
58 0           my ($big, $small) = unpack(NN => substr(${$_[0]}, 0, 8, ''));
  0            
59 0 0         if ($big) {
60             # too big for an integer, try to handle it as a float:
61 0           my $high = $big * 4294967296;
62 0           my $result = $high + $small;
63 0 0         unless ($result - $high == $small) {
64             # too big event for a float, use a BigInt;
65 0           require Math::BigInt;
66 0           $result = Math::BigInt->new($big);
67 0           $result <<= 32;
68 0           $result += $small;
69             }
70 0           return $result;
71             }
72 0           return $small;
73             }
74              
75             *get_int64 = (HAS_QUADS ? \&get_int64_quads : \&get_int64_no_quads);
76              
77             sub get_int64_untaint {
78 0     0 0   my ($v) = substr(${$_[0]}, 0, 8, '') =~ /(.*)/s;
  0            
79 0           get_int64(\$v);
80             }
81              
82             sub get_str {
83 0     0 0   my $self = shift;
84 0 0         length $$self >=4 or return undef;
85 0           my $len = unpack(N => substr($$self, 0, 4, ''));
86 0 0         length $$self >=$len or return undef;
87 0           substr($$self, 0, $len, '');
88             }
89              
90             sub get_str_list {
91 0     0 0   my $self = shift;
92 0           my @a;
93 0 0         if (my $n = $self->get_int32) {
94 0           for (1..$n) {
95 0           my $str = $self->get_str;
96 0 0         last unless defined $str;
97 0           push @a, $str;
98             }
99             }
100 0           return @a;
101             }
102              
103 0     0 0   sub get_attributes { Net::SFTP::Foreign::Attributes->new_from_buffer($_[0]) }
104              
105              
106 0     0 0   sub skip_bytes { substr(${$_[0]}, 0, $_[1], '') }
  0            
107              
108             sub skip_str {
109 0     0 0   my $self = shift;
110 0           my $len = $self->get_int32;
111 0           substr($$self, 0, $len, '');
112             }
113              
114 0     0 0   sub put_int8 { ${$_[0]} .= pack(C => $_[1]) }
  0            
115              
116 0     0 0   sub put_int32 { ${$_[0]} .= pack(N => $_[1]) }
  0            
117              
118 0     0 0   sub put_int64_quads { ${$_[0]} .= pack(Q => $_[1]) }
  0            
119              
120             sub put_int64_no_quads {
121 0 0   0 0   if ($_[1] >= 4294967296) {
122 0           my $high = int ( $_[1] / 4294967296);
123 0           my $low = int ($_[1] - $high * 4294967296);
124 0           ${$_[0]} .= pack(NN => $high, $low)
  0            
125             }
126             else {
127 0           ${$_[0]} .= pack(NN => 0, $_[1])
  0            
128             }
129             }
130              
131             *put_int64 = (HAS_QUADS ? \&put_int64_quads : \&put_int64_no_quads);
132              
133             sub put_str {
134 0 0   0 0   utf8::downgrade($_[1]) or croak "UTF8 data reached the SFTP buffer";
135 0           ${$_[0]} .= pack(N => length($_[1])) . $_[1]
  0            
136             }
137              
138 0     0 0   sub put_char { ${$_[0]} .= $_[1] }
  0            
139              
140             sub _attrs_as_buffer {
141 0     0     my $attrs = shift;
142 0           my $ref = ref $attrs;
143 0 0         Net::SFTP::Foreign::Attributes->isa($ref)
144             or croak("Object of class Net::SFTP::Foreign::Attributes "
145             . "expected, $ref found");
146 0           $attrs->as_buffer;
147             }
148              
149 0     0 0   sub put_attributes { ${$_[0]} .= ${_attrs_as_buffer $_[1]} }
  0            
  0            
150              
151             my %unpack = ( int8 => \&get_int8,
152             int32 => \&get_int32,
153             int64 => \&get_int64,
154             str => \&get_str,
155             attr => \&get_attributtes );
156              
157             sub get {
158 0     0 0   my $buf = shift;
159 0           map { $unpack{$_}->($buf) } @_;
  0            
160             }
161              
162             my %pack = ( int8 => sub { pack C => $_[0] },
163             int32 => sub { pack N => $_[0] },
164             int64 => sub {
165             if (HAS_QUADS) {
166             return pack(Q => $_[0])
167             }
168             else {
169             if ($_[0] >= 4294967296) {
170             my $high = int ( $_[0] / 4294967296);
171             my $low = int ($_[0] - $high * 4294967296);
172             return pack(NN => $high, $low)
173             }
174             else {
175             return pack(NN => 0, $_[0])
176             }
177             }
178             },
179             str => sub { pack(N => length($_[0])), $_[0] },
180             char => sub { $_[0] },
181             attr => sub { ${_attrs_as_buffer $_[0]} } );
182              
183             sub put {
184 0     0 0   my $buf =shift;
185 0 0         @_ & 1 and croak "bad number of arguments for put (@_)";
186 0           my @parts;
187 0           while (@_) {
188 0           my $type = shift;
189 0           my $value = shift;
190 0 0         my $packer = $pack{$type} or Carp::confess("internal error: bad packing type '$type'");
191 0           push @parts, $packer->($value)
192             }
193 0           $$buf.=join('', @parts);
194             }
195              
196             1;
197             __END__