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
|
|
16
|
use strict; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
76
|
|
6
|
3
|
|
|
3
|
|
12
|
use warnings; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
66
|
|
7
|
3
|
|
|
3
|
|
12
|
no warnings 'uninitialized'; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
90
|
|
8
|
|
|
|
|
|
|
|
9
|
3
|
|
|
3
|
|
13
|
use Carp; |
|
3
|
|
|
|
|
14
|
|
|
3
|
|
|
|
|
205
|
|
10
|
|
|
|
|
|
|
|
11
|
3
|
|
|
|
|
5
|
use constant HAS_QUADS => do { |
12
|
3
|
|
|
|
|
6
|
local $@; |
13
|
3
|
|
|
|
|
18
|
local $SIG{__DIE__}; |
14
|
3
|
|
|
3
|
|
25
|
no warnings; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
125
|
|
15
|
3
|
|
|
|
|
226
|
eval q{ |
16
|
|
|
|
|
|
|
pack(Q => 0x1122334455667788) eq "\x11\x22\x33\x44\x55\x66\x77\x88" |
17
|
|
|
|
|
|
|
} |
18
|
3
|
|
|
3
|
|
24
|
}; |
|
3
|
|
|
|
|
5
|
|
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__ |