File Coverage

blib/lib/Net/SFTP/Foreign.pm
Criterion Covered Total %
statement 94 1862 5.0
branch 13 1354 0.9
condition 7 721 0.9
subroutine 28 153 18.3
pod 48 49 97.9
total 190 4139 4.5


line stmt bran cond sub pod time code
1             package Net::SFTP::Foreign;
2              
3             our $VERSION = '1.93';
4              
5 3     3   132314 use strict;
  3         26  
  3         83  
6 3     3   13 use warnings;
  3         5  
  3         70  
7 3     3   14 use warnings::register;
  3         6  
  3         418  
8              
9 3     3   17 use Carp qw(carp croak);
  3         5  
  3         149  
10              
11 3     3   1451 use Symbol ();
  3         2108  
  3         61  
12 3     3   1225 use Errno ();
  3         3668  
  3         68  
13 3     3   16 use Fcntl;
  3         4  
  3         630  
14 3     3   30 use File::Spec ();
  3         4  
  3         57  
15 3     3   1481 use Time::HiRes ();
  3         3993  
  3         65  
16 3     3   1461 use POSIX ();
  3         17061  
  3         289  
17              
18             BEGIN {
19 3 50   3   17 if ($] >= 5.008) {
20 3         1554 require Encode;
21             }
22             else {
23             # Work around for incomplete Unicode handling in perl 5.6.x
24 0         0 require bytes;
25 0         0 bytes->import();
26 0         0 *Encode::encode = sub { $_[1] };
  0         0  
27 0         0 *Encode::decode = sub { $_[1] };
  0         0  
28 0         0 *utf8::downgrade = sub { 1 };
  0         0  
29             }
30             }
31              
32             # we make $Net::SFTP::Foreign::Helpers::debug an alias for
33             # $Net::SFTP::Foreign::debug so that the user can set it without
34             # knowing anything about the Helpers package!
35             our $debug;
36 3     3   28290 BEGIN { *Net::SFTP::Foreign::Helpers::debug = \$debug };
37 3         281 use Net::SFTP::Foreign::Helpers qw(_is_reg _is_lnk _is_dir _debug
38             _sort_entries _gen_wanted
39             _gen_converter _hexdump
40             _ensure_list _catch_tainted_args
41             _file_part _umask_save_and_set
42 3     3   1371 _untaint);
  3         7  
43 3         1426 use Net::SFTP::Foreign::Constants qw( :fxp :flags :att
44             :status :error
45 3     3   1315 SSH2_FILEXFER_VERSION );
  3         8  
46 3     3   1395 use Net::SFTP::Foreign::Attributes;
  3         7  
  3         84  
47 3     3   19 use Net::SFTP::Foreign::Buffer;
  3         6  
  3         288  
48             require Net::SFTP::Foreign::Common;
49             our @ISA = qw(Net::SFTP::Foreign::Common);
50              
51             our $dirty_cleanup;
52             my $windows;
53              
54             BEGIN {
55 3     3   16 $windows = $^O =~ /Win(?:32|64)/;
56              
57 3 50       316 if ($^O =~ /solaris/i) {
58 0 0       0 $dirty_cleanup = 1 unless defined $dirty_cleanup;
59             }
60             }
61              
62             my $thread_generation = 1;
63 0     0   0 sub CLONE { $thread_generation++ }
64              
65             sub _deprecated {
66 0 0 0 0   0 if (warnings::enabled('deprecated') and warnings::enabled(__PACKAGE__)) {
67 0         0 Carp::carp(join('', @_));
68             }
69             }
70              
71 0     0   0 sub _next_msg_id { shift->{_msg_id}++ }
72              
73 3     3   31 use constant _empty_attributes => Net::SFTP::Foreign::Attributes->new;
  3         8  
  3         12  
74              
75             sub _queue_new_msg {
76 0     0   0 my $sftp = shift;
77 0         0 my $code = shift;
78 0         0 my $id = $sftp->_next_msg_id;
79 0         0 $sftp->{incomming}{$id} = undef;
80 0         0 my $msg = Net::SFTP::Foreign::Buffer->new(int8 => $code, int32 => $id, @_);
81 0         0 $sftp->_queue_msg($msg);
82 0         0 return $id;
83             }
84              
85             sub _queue_msg {
86 0     0   0 my ($sftp, $buf) = @_;
87              
88 0         0 my $bytes = $buf->bytes;
89 0         0 my $len = length $bytes;
90              
91 0 0 0     0 if ($debug and $debug & 1) {
92 0         0 $sftp->{_queued}++;
93 0         0 _debug(sprintf("queueing msg len: %i, code:%i, id:%i ... [$sftp->{_queued}]",
94             $len, unpack(CN => $bytes)));
95              
96 0 0       0 $debug & 16 and _hexdump(pack('N', length($bytes)) . $bytes);
97             }
98              
99 0         0 $sftp->{_bout} .= pack('N', length($bytes));
100 0         0 $sftp->{_bout} .= $bytes;
101             }
102              
103              
104 0     0   0 sub _do_io { $_[0]->{_backend}->_do_io(@_) }
105              
106             sub _conn_lost {
107 0     0   0 my ($sftp, $status, $err, @str) = @_;
108              
109 0 0 0     0 $debug and $debug & 32 and _debug("_conn_lost");
110              
111             $sftp->{_status} or
112 0 0       0 $sftp->_set_status(defined $status ? $status : SSH2_FX_CONNECTION_LOST);
    0          
113              
114             $sftp->{_error} or
115 0 0       0 $sftp->_set_error((defined $err ? $err : SFTP_ERR_CONNECTION_BROKEN),
    0          
    0          
116             (@str ? @str : "Connection to remote server is broken"));
117              
118 0         0 undef $sftp->{_connected};
119             }
120              
121             sub _conn_failed {
122 0     0   0 my $sftp = shift;
123             $sftp->_conn_lost(SSH2_FX_NO_CONNECTION,
124             SFTP_ERR_CONNECTION_BROKEN,
125             @_)
126 0 0       0 unless $sftp->{_error};
127             }
128              
129             sub _get_msg {
130 0     0   0 my $sftp = shift;
131              
132 0 0 0     0 $debug and $debug & 1 and _debug("waiting for message... [$sftp->{_queued}]");
133              
134 0 0       0 unless ($sftp->_do_io($sftp->{_timeout})) {
135 0         0 $sftp->_conn_lost(undef, undef, "Connection to remote server stalled");
136 0         0 return undef;
137             }
138              
139 0         0 my $bin = \$sftp->{_bin};
140 0         0 my $len = unpack N => substr($$bin, 0, 4, '');
141 0         0 my $msg = Net::SFTP::Foreign::Buffer->make(substr($$bin, 0, $len, ''));
142              
143 0 0 0     0 if ($debug and $debug & 1) {
144 0         0 $sftp->{_queued}--;
145 0         0 my ($code, $id, $status) = unpack( CNN => $$msg);
146 0 0       0 $id = '-' if $code == SSH2_FXP_VERSION;
147 0 0       0 $status = '-' unless $code == SSH2_FXP_STATUS;
148 0         0 _debug(sprintf("got it!, len:%i, code:%i, id:%s, status: %s",
149             $len, $code, $id, $status));
150 0 0       0 $debug & 8 and _hexdump($$msg);
151             }
152              
153 0         0 return $msg;
154             }
155              
156             sub _croak_bad_options {
157 0 0   0   0 if (@_) {
158 0 0       0 my $s = (@_ > 1 ? 's' : '');
159 0         0 croak "Invalid option$s '" . CORE::join("', '", @_) . "' or bad combination of options";
160             }
161             }
162              
163             sub _fs_encode {
164 0     0   0 my ($sftp, $path) = @_;
165 0         0 Encode::encode($sftp->{_fs_encoding}, $path);
166             }
167              
168             sub _fs_decode {
169 0     0   0 my ($sftp, $path) = @_;
170 0         0 Encode::decode($sftp->{_fs_encoding}, $path);
171             }
172              
173             sub new {
174 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
175              
176 0         0 my $class = shift;
177 0 0       0 unshift @_, 'host' if @_ & 1;
178 0         0 my %opts = @_;
179              
180 0         0 my $sftp = { _msg_id => 0,
181             _bout => '',
182             _bin => '',
183             _connected => 1,
184             _queued => 0,
185             _error => 0,
186             _status => 0,
187             _incomming => {} };
188              
189 0         0 bless $sftp, $class;
190              
191 0 0       0 if ($debug) {
192 0         0 _debug "This is Net::SFTP::Foreign $Net::SFTP::Foreign::VERSION";
193 0         0 _debug "Loaded from $INC{'Net/SFTP/Foreign.pm'}";
194 0         0 _debug "Running on Perl $^V for $^O";
195 0         0 _debug "debug set to $debug";
196 0         0 _debug "~0 is " . ~0;
197             }
198              
199 0         0 $sftp->_clear_error_and_status;
200              
201 0         0 my $backend = delete $opts{backend};
202 0 0       0 unless (ref $backend) {
203 0 0       0 $backend = ($windows ? 'Windows' : 'Unix')
    0          
204             unless (defined $backend);
205 0 0       0 $backend =~ /^\w+$/
206             or croak "Bad backend name $backend";
207 0         0 my $backend_class = "Net::SFTP::Foreign::Backend::$backend";
208 0 0       0 eval "require $backend_class; 1"
209             or croak "Unable to load backend $backend: $@";
210 0         0 $backend = $backend_class->_new($sftp, \%opts);
211             }
212 0         0 $sftp->{_backend} = $backend;
213              
214 0 0       0 if ($debug) {
215 0   0     0 my $class = ref($backend) || $backend;
216 3     3   21 no strict 'refs';
  3         5  
  3         15411  
217 0   0     0 my $version = ${$class .'::VERSION'} || 0;
218 0         0 _debug "Using backend $class $version";
219             }
220              
221 0         0 my %defs = $backend->_defaults;
222              
223 0         0 $sftp->{_autodie} = delete $opts{autodie};
224 0   0     0 $sftp->{_block_size} = delete $opts{block_size} || $defs{block_size} || 32*1024;
225 0   0     0 $sftp->{_min_block_size} = delete $opts{min_block_size} || $defs{min_block_size} || 512;
226 0   0     0 $sftp->{_queue_size} = delete $opts{queue_size} || $defs{queue_size} || 32;
227 0   0     0 $sftp->{_read_ahead} = $defs{read_ahead} || $sftp->{_block_size} * 4;
228 0   0     0 $sftp->{_write_delay} = $defs{write_delay} || $sftp->{_block_size} * 8;
229 0         0 $sftp->{_autoflush} = delete $opts{autoflush};
230 0         0 $sftp->{_late_set_perm} = delete $opts{late_set_perm};
231 0         0 $sftp->{_dirty_cleanup} = delete $opts{dirty_cleanup};
232 0         0 $sftp->{_remote_has_volumes} = delete $opts{remote_has_volumes};
233              
234 0         0 $sftp->{_timeout} = delete $opts{timeout};
235 0 0 0     0 defined $sftp->{_timeout} and $sftp->{_timeout} <= 0 and croak "invalid timeout";
236              
237 0         0 $sftp->{_fs_encoding} = delete $opts{fs_encoding};
238 0 0       0 if (defined $sftp->{_fs_encoding}) {
239 0 0       0 $] < 5.008
240             and carp "fs_encoding feature is not supported in this perl version $]";
241             }
242             else {
243 0         0 $sftp->{_fs_encoding} = 'utf8';
244             }
245              
246 0         0 $sftp->autodisconnect(delete $opts{autodisconnect});
247              
248 0         0 $backend->_init_transport($sftp, \%opts);
249 0 0       0 %opts and _croak_bad_options(keys %opts);
250              
251 0 0       0 $sftp->_init unless $sftp->{_error};
252 0         0 $backend->_after_init($sftp);
253 0         0 $sftp
254             }
255              
256             sub autodisconnect {
257 0     0 1 0 my ($sftp, $ad) = @_;
258 0 0 0     0 if (not defined $ad or $ad == 2) {
259 0 0 0     0 $debug and $debug & 4 and _debug "setting disconnecting pid to $$ and thread to $thread_generation";
260 0         0 $sftp->{_disconnect_by_pid} = $$;
261 0         0 $sftp->{_disconnect_by_thread} = $thread_generation;
262             }
263             else {
264 0         0 delete $sftp->{_disconnect_by_thread};
265 0 0       0 if ($ad == 0) {
    0          
266 0         0 $sftp->{_disconnect_by_pid} = -1;
267             }
268             elsif ($ad == 1) {
269 0         0 delete $sftp->{_disconnect_by_pid};
270             }
271             else {
272 0         0 croak "bad value '$ad' for autodisconnect";
273             }
274             }
275 0         0 1;
276             }
277              
278             sub disconnect {
279 0     0 1 0 my $sftp = shift;
280 0         0 my $pid = delete $sftp->{pid};
281              
282 0 0 0     0 $debug and $debug & 4 and _debug("$sftp->disconnect called (ssh pid: ".($pid||'').")");
      0        
283              
284 0         0 local $sftp->{_autodie};
285 0         0 $sftp->_conn_lost;
286              
287 0 0       0 if (defined $pid) {
288 0 0 0     0 close $sftp->{ssh_out} if (defined $sftp->{ssh_out} and not $sftp->{_ssh_out_is_not_dupped});
289 0 0       0 close $sftp->{ssh_in} if defined $sftp->{ssh_in};
290 0 0       0 if ($windows) {
291 0 0       0 kill KILL => $pid
292             and waitpid($pid, 0);
293 0 0 0     0 $debug and $debug & 4 and _debug "process $pid reaped";
294             }
295             else {
296             my $dirty = ( defined $sftp->{_dirty_cleanup}
297             ? $sftp->{_dirty_cleanup}
298 0 0       0 : $dirty_cleanup );
299              
300 0 0 0     0 if ($dirty or not defined $dirty) {
301 0 0 0     0 $debug and $debug & 4 and _debug("starting dirty cleanup of process $pid");
302 0 0       0 OUT: for my $sig (($dirty ? () : 0), qw(TERM TERM KILL KILL)) {
303 0 0 0     0 $debug and $debug & 4 and _debug("killing process $pid with signal $sig");
304 0 0       0 $sig and kill $sig, $pid;
305              
306 0         0 local ($@, $SIG{__DIE__}, $SIG{__WARN__});
307 0         0 my $deadline = Time::HiRes::time + 8;
308 0         0 my $dt = 0.01;
309 0         0 while (Time::HiRes::time < $deadline) {
310 0         0 my $wpr = waitpid($pid, POSIX::WNOHANG());
311 0 0 0     0 $debug and $debug & 4 and _debug("waitpid returned ", $wpr);
312 0 0 0     0 last OUT if $wpr or $! == Errno::ECHILD();
313 0         0 Time::HiRes::sleep($dt);
314 0         0 $dt *= 1.2;
315             }
316             }
317             }
318             else {
319 0         0 while (1) {
320 0 0       0 last if waitpid($pid, 0) > 0;
321 0 0       0 if ($! != Errno::EINTR()) {
322 0 0       0 warn "internal error: unexpected error in waitpid($pid): $!"
323             if $! != Errno::ECHILD();
324 0         0 last;
325             }
326             }
327             }
328 0 0 0     0 $debug and $debug & 4 and _debug "process $pid reaped";
329             }
330             }
331 0 0       0 close $sftp->{_pty} if defined $sftp->{_pty};
332 0         0 1
333             }
334              
335             sub DESTROY {
336 0     0   0 local ($?, $!, $@);
337              
338 0         0 my $sftp = shift;
339 0         0 my $dbpid = $sftp->{_disconnect_by_pid};
340 0         0 my $dbthread = $sftp->{_disconnect_by_thread};
341              
342 0 0 0     0 $debug and $debug & 4 and _debug("$sftp->DESTROY called (current pid: $$, disconnect_by_pid: " .
      0        
      0        
343             ($dbpid || '') .
344             "), current thread generation: $thread_generation, disconnect_by_thread: " .
345             ($dbthread || '') . ")");
346              
347 0 0 0     0 if (!defined $dbpid or ($dbpid == $$ and $dbthread == $thread_generation)) {
      0        
348 0         0 $sftp->disconnect
349             }
350             else {
351 0 0 0     0 $debug and $debug & 4 and _debug "skipping disconnection because pid and/or thread generation don't match";
352             }
353             }
354              
355             sub _init {
356 0     0   0 my $sftp = shift;
357 0         0 $sftp->_queue_msg( Net::SFTP::Foreign::Buffer->new(int8 => SSH2_FXP_INIT,
358             int32 => SSH2_FILEXFER_VERSION));
359              
360 0 0 0     0 if (my $msg = $sftp->_get_msg) {
    0 0        
361 0         0 my $type = $msg->get_int8;
362 0 0       0 if ($type == SSH2_FXP_VERSION) {
363 0         0 my $version = $msg->get_int32;
364              
365 0         0 $sftp->{server_version} = $version;
366 0         0 $sftp->{server_extensions} = {};
367 0         0 while (length $$msg) {
368 0         0 my $key = $msg->get_str;
369 0         0 my $value = $msg->get_str;
370 0         0 $sftp->{server_extensions}{$key} = $value;
371              
372 0 0       0 if ($key eq 'vendor-id') {
    0          
373 0         0 my $vid = Net::SFTP::Foreign::Buffer->make("$value");
374 0         0 $sftp->{_ext__vendor_id} = [ Encode::decode(utf8 => $vid->get_str),
375             Encode::decode(utf8 => $vid->get_str),
376             Encode::decode(utf8 => $vid->get_str),
377             $vid->get_int64 ];
378             }
379             elsif ($key eq 'supported2') {
380 0         0 my $s2 = Net::SFTP::Foreign::Buffer->make("$value");
381 0         0 $sftp->{_ext__supported2} = [ $s2->get_int32,
382             $s2->get_int32,
383             $s2->get_int32,
384             $s2->get_int32,
385             $s2->get_int32,
386             $s2->get_int16,
387             $s2->get_int16,
388             [map Encode::decode(utf8 => $_), $s2->get_str_list],
389             [map Encode::decode(utf8 => $_), $s2->get_str_list] ];
390             }
391             }
392              
393 0         0 return $version;
394             }
395              
396 0         0 $sftp->_conn_lost(SSH2_FX_BAD_MESSAGE,
397             SFTP_ERR_REMOTE_BAD_MESSAGE,
398             "bad packet type, expecting SSH2_FXP_VERSION, got $type");
399             }
400             elsif ($sftp->{_status} == SSH2_FX_CONNECTION_LOST
401             and $sftp->{_password_authentication}
402             and $sftp->{_password_sent}) {
403 0         0 $sftp->_set_error(SFTP_ERR_PASSWORD_AUTHENTICATION_FAILED,
404             "Password authentication failed or connection lost");
405             }
406 0         0 return undef;
407             }
408              
409 0     0 0 0 sub server_extensions { %{shift->{server_extensions}} }
  0         0  
410              
411             sub _check_extension {
412 0     0   0 my ($sftp, $name, $version, $error, $errstr) = @_;
413 0         0 my $ext = $sftp->{server_extensions}{$name};
414 0 0 0     0 return 1 if (defined $ext and $ext == $version);
415              
416 0         0 $sftp->_set_status(SSH2_FX_OP_UNSUPPORTED);
417 0         0 $sftp->_set_error($error, "$errstr: extended operation not supported by server");
418 0         0 return undef;
419             }
420              
421             # helper methods:
422              
423             sub _get_msg_by_id {
424 0     0   0 my ($sftp, $eid) = @_;
425 0         0 while (1) {
426 0   0     0 my $msg = delete($sftp->{incomming}{$eid}) || $sftp->_get_msg || return undef;
427 0         0 my $id = unpack xN => $$msg;
428 0 0       0 return $msg if $id == $eid;
429 0 0       0 unless (exists $sftp->{incomming}{$id}) {
430 0         0 $sftp->_conn_lost(SSH2_FX_BAD_MESSAGE,
431             SFTP_ERR_REMOTE_BAD_MESSAGE,
432             $_[2], "bad packet sequence, expected $eid, got $id");
433 0         0 return undef;
434             }
435 0         0 $sftp->{incomming}{$id} = $msg
436             }
437             }
438              
439             sub _get_msg_and_check {
440 0     0   0 my ($sftp, $etype, $eid, $err, $errstr) = @_;
441 0         0 my $msg = $sftp->_get_msg_by_id($eid, $errstr);
442 0 0       0 if ($msg) {
443 0         0 my $type = $msg->get_int8;
444 0         0 $msg->get_int32; # discard id, it has already been checked at _get_msg_by_id
445              
446 0         0 $sftp->_clear_error_and_status;
447              
448 0 0       0 if ($type != $etype) {
449 0 0       0 if ($type == SSH2_FXP_STATUS) {
450 0         0 my $code = $msg->get_int32;
451 0         0 my $str = Encode::decode(utf8 => $msg->get_str);
452 0 0       0 my $status = $sftp->_set_status($code, (defined $str ? $str : ()));
453 0         0 $sftp->_set_error($err, $errstr, $status);
454             }
455             else {
456 0         0 $sftp->_conn_lost(SSH2_FX_BAD_MESSAGE,
457             SFTP_ERR_REMOTE_BAD_MESSAGE,
458             $errstr, "bad packet type, expected $etype packet, got $type");
459             }
460 0         0 return undef;
461             }
462             }
463 0         0 $msg;
464             }
465              
466             # reads SSH2_FXP_HANDLE packet and returns handle, or undef on failure
467             sub _get_handle {
468 0     0   0 my ($sftp, $eid, $error, $errstr) = @_;
469 0 0       0 if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_HANDLE, $eid,
470             $error, $errstr)) {
471 0         0 return $msg->get_str;
472             }
473 0         0 return undef;
474             }
475              
476             sub _rid {
477 0     0   0 my ($sftp, $rfh) = @_;
478 0         0 my $rid = $rfh->_rid;
479 0 0       0 unless (defined $rid) {
480 0         0 $sftp->_set_error(SFTP_ERR_REMOTE_ACCESING_CLOSED_FILE,
481             "Couldn't access a file that has been previosly closed");
482             }
483             $rid
484 0         0 }
485              
486             sub _rfid {
487 0     0   0 $_[1]->_check_is_file;
488 0         0 &_rid;
489             }
490              
491             sub _rdid {
492 0     0   0 $_[1]->_check_is_dir;
493 0         0 &_rid;
494             }
495              
496             sub _queue_rid_request {
497 0     0   0 my ($sftp, $code, $fh, $attrs) = @_;
498 0         0 my $rid = $sftp->_rid($fh);
499 0 0       0 return undef unless defined $rid;
500              
501 0 0       0 $sftp->_queue_new_msg($code, str => $rid,
502             (defined $attrs ? (attr => $attrs) : ()));
503             }
504              
505             sub _queue_rfid_request {
506 0     0   0 $_[2]->_check_is_file;
507 0         0 &_queue_rid_request;
508             }
509              
510             sub _queue_rdid_request {
511 0     0   0 $_[2]->_check_is_dir;
512 0         0 &_queue_rid_request;
513             }
514              
515             sub _queue_str_request {
516 0     0   0 my($sftp, $code, $str, $attrs) = @_;
517 0 0       0 $sftp->_queue_new_msg($code, str => $str,
518             (defined $attrs ? (attr => $attrs) : ()));
519             }
520              
521             sub _check_status_ok {
522 0     0   0 my ($sftp, $eid, $error, $errstr) = @_;
523 0 0       0 if (defined $eid) {
524 0 0       0 if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_STATUS, $eid,
525             $error, $errstr)) {
526 0         0 my $status = $sftp->_set_status($msg->get_int32, $msg->get_str);
527 0 0       0 return 1 if $status == SSH2_FX_OK;
528              
529 0         0 $sftp->_set_error($error, $errstr, $status);
530             }
531             }
532 0         0 return undef;
533             }
534              
535             sub setcwd {
536 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
537              
538 0         0 my ($sftp, $cwd, %opts) = @_;
539 0         0 $sftp->_clear_error_and_status;
540              
541 0         0 my $check = delete $opts{check};
542 0 0       0 $check = 1 unless defined $check;
543              
544 0 0       0 %opts and _croak_bad_options(keys %opts);
545              
546 0 0       0 if (defined $cwd) {
547 0 0       0 if ($check) {
548 0         0 $cwd = $sftp->realpath($cwd);
549 0 0       0 return undef unless defined $cwd;
550 0         0 _untaint($cwd);
551 0 0       0 my $a = $sftp->stat($cwd)
552             or return undef;
553 0 0       0 unless (_is_dir($a->perm)) {
554 0         0 $sftp->_set_error(SFTP_ERR_REMOTE_BAD_OBJECT,
555             "Remote object '$cwd' is not a directory");
556 0         0 return undef;
557             }
558             }
559             else {
560 0         0 $cwd = $sftp->_rel2abs($cwd);
561             }
562 0         0 return $sftp->{cwd} = $cwd;
563             }
564             else {
565 0         0 delete $sftp->{cwd};
566 0 0       0 return $sftp->cwd if defined wantarray;
567             }
568             }
569              
570             sub cwd {
571 0 0   0 1 0 @_ == 1 or croak 'Usage: $sftp->cwd()';
572              
573 0         0 my $sftp = shift;
574 0 0       0 return defined $sftp->{cwd} ? $sftp->{cwd} : $sftp->realpath('');
575             }
576              
577             ## SSH2_FXP_OPEN (3)
578             # returns handle on success, undef on failure
579             sub open {
580 0 0 0 0 1 0 (@_ >= 2 and @_ <= 4)
581             or croak 'Usage: $sftp->open($path [, $flags [, $attrs]])';
582 0 0       0 ${^TAINT} and &_catch_tainted_args;
583              
584 0         0 my ($sftp, $path, $flags, $a) = @_;
585 0         0 $path = $sftp->_rel2abs($path);
586 0 0       0 defined $flags or $flags = SSH2_FXF_READ;
587 0 0       0 defined $a or $a = Net::SFTP::Foreign::Attributes->new;
588 0         0 my $id = $sftp->_queue_new_msg(SSH2_FXP_OPEN,
589             str => $sftp->_fs_encode($path),
590             int32 => $flags, attr => $a);
591              
592 0         0 my $rid = $sftp->_get_handle($id,
593             SFTP_ERR_REMOTE_OPEN_FAILED,
594             "Couldn't open remote file '$path'");
595              
596 0 0 0     0 if ($debug and $debug & 2) {
597 0 0       0 if (defined $rid) {
598 0         0 _debug("new remote file '$path' open, rid:");
599 0         0 _hexdump($rid);
600             }
601             else {
602 0         0 _debug("open failed: $sftp->{_status}");
603             }
604             }
605              
606 0 0       0 defined $rid or return undef;
607              
608 0         0 my $fh = Net::SFTP::Foreign::FileHandle->_new_from_rid($sftp, $rid);
609 0 0       0 $fh->_flag(append => 1) if ($flags & SSH2_FXF_APPEND);
610              
611 0         0 $fh;
612             }
613              
614             sub _open_mkpath {
615 0     0   0 my ($sftp, $filename, $mkpath, $flags, $attrs) = @_;
616 0   0     0 $flags = ($flags || 0) | SSH2_FXF_WRITE|SSH2_FXF_CREAT;
617 0         0 my $fh = do {
618 0         0 local $sftp->{_autodie};
619 0         0 $sftp->open($filename, $flags, $attrs);
620             };
621 0 0       0 unless ($fh) {
622 0 0 0     0 if ($mkpath and $sftp->status == SSH2_FX_NO_SUCH_FILE) {
623 0         0 my $da = $attrs->clone;
624 0   0     0 $da->set_perm(($da->perm || 0) | 0700);
625 0 0       0 $sftp->mkpath($filename, $da, 1) or return;
626 0         0 $fh = $sftp->open($filename, $flags, $attrs);
627             }
628             else {
629 0         0 $sftp->_ok_or_autodie;
630             }
631             }
632 0         0 $fh;
633             }
634              
635             ## SSH2_FXP_OPENDIR (11)
636             sub opendir {
637 0 0   0 1 0 @_ <= 2 or croak 'Usage: $sftp->opendir($path)';
638 0 0       0 ${^TAINT} and &_catch_tainted_args;
639              
640 0         0 my $sftp = shift;
641 0         0 my $path = shift;
642 0 0       0 $path = '.' unless defined $path;
643 0         0 $path = $sftp->_rel2abs($path);
644 0         0 my $id = $sftp->_queue_str_request(SSH2_FXP_OPENDIR, $sftp->_fs_encode($path), @_);
645 0         0 my $rid = $sftp->_get_handle($id, SFTP_ERR_REMOTE_OPENDIR_FAILED,
646             "Couldn't open remote dir '$path'");
647              
648 0 0 0     0 if ($debug and $debug & 2) {
649 0         0 _debug("new remote dir '$path' open, rid:");
650 0         0 _hexdump($rid);
651             }
652              
653 0 0       0 defined $rid
654             or return undef;
655              
656 0         0 Net::SFTP::Foreign::DirHandle->_new_from_rid($sftp, $rid, 0)
657             }
658              
659             ## SSH2_FXP_READ (4)
660             # returns data on success undef on failure
661             sub sftpread {
662 0 0 0 0 1 0 (@_ >= 3 and @_ <= 4)
663             or croak 'Usage: $sftp->sftpread($fh, $offset [, $size])';
664              
665 0         0 my ($sftp, $rfh, $offset, $size) = @_;
666              
667 0 0       0 unless ($size) {
668 0 0       0 return '' if defined $size;
669 0         0 $size = $sftp->{_block_size};
670             }
671              
672 0         0 my $rfid = $sftp->_rfid($rfh);
673 0 0       0 defined $rfid or return undef;
674              
675 0         0 my $id = $sftp->_queue_new_msg(SSH2_FXP_READ, str=> $rfid,
676             int64 => $offset, int32 => $size);
677              
678 0 0       0 if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_DATA, $id,
679             SFTP_ERR_REMOTE_READ_FAILED,
680             "Couldn't read from remote file")) {
681 0         0 return $msg->get_str;
682             }
683 0         0 return undef;
684             }
685              
686             ## SSH2_FXP_WRITE (6)
687             # returns true on success, undef on failure
688             sub sftpwrite {
689 0 0   0 1 0 @_ == 4 or croak 'Usage: $sftp->sftpwrite($fh, $offset, $data)';
690              
691 0         0 my ($sftp, $rfh, $offset) = @_;
692 0         0 my $rfid = $sftp->_rfid($rfh);
693 0 0       0 defined $rfid or return undef;
694 0 0       0 utf8::downgrade($_[3], 1) or croak "wide characters found in data";
695              
696 0         0 my $id = $sftp->_queue_new_msg(SSH2_FXP_WRITE, str => $rfid,
697             int64 => $offset, str => $_[3]);
698              
699 0 0       0 if ($sftp->_check_status_ok($id,
700             SFTP_ERR_REMOTE_WRITE_FAILED,
701             "Couldn't write to remote file")) {
702 0         0 return 1;
703             }
704 0         0 return undef;
705             }
706              
707             sub seek {
708 0 0 0 0 1 0 (@_ >= 3 and @_ <= 4)
709             or croak 'Usage: $sftp->seek($fh, $pos [, $whence])';
710              
711 0         0 my ($sftp, $rfh, $pos, $whence) = @_;
712 0 0       0 $sftp->flush($rfh) or return undef;
713              
714 0 0       0 if (!$whence) {
    0          
    0          
715 0         0 $rfh->_pos($pos)
716             }
717             elsif ($whence == 1) {
718 0         0 $rfh->_inc_pos($pos)
719             }
720             elsif ($whence == 2) {
721 0 0       0 my $a = $sftp->stat($rfh) or return undef;
722 0         0 $rfh->_pos($pos + $a->size);
723             }
724             else {
725 0         0 croak "invalid value for whence argument ('$whence')";
726             }
727 0         0 1;
728             }
729              
730             sub tell {
731 0 0   0 1 0 @_ == 2 or croak 'Usage: $sftp->tell($fh)';
732              
733 0         0 my ($sftp, $rfh) = @_;
734 0         0 return $rfh->_pos + length ${$rfh->_bout};
  0         0  
735             }
736              
737             sub eof {
738 0 0   0 1 0 @_ == 2 or croak 'Usage: $sftp->eof($fh)';
739              
740 0         0 my ($sftp, $rfh) = @_;
741 0         0 $sftp->_fill_read_cache($rfh, 1);
742 0         0 return length(${$rfh->_bin}) == 0
  0         0  
743             }
744              
745             sub _write {
746 0     0   0 my ($sftp, $rfh, $off, $cb) = @_;
747              
748 0         0 $sftp->_clear_error_and_status;
749              
750 0         0 my $rfid = $sftp->_rfid($rfh);
751 0 0       0 defined $rfid or return undef;
752              
753 0         0 my $qsize = $sftp->{_queue_size};
754              
755 0         0 my @msgid;
756             my @written;
757 0         0 my $written = 0;
758 0         0 my $end;
759              
760 0   0     0 while (!$end or @msgid) {
761 0   0     0 while (!$end and @msgid < $qsize) {
762 0         0 my $data = $cb->();
763 0 0 0     0 if (defined $data and length $data) {
764 0         0 my $id = $sftp->_queue_new_msg(SSH2_FXP_WRITE, str => $rfid,
765             int64 => $off + $written, str => $data);
766 0         0 push @written, $written;
767 0         0 $written += length $data;
768 0         0 push @msgid, $id;
769             }
770             else {
771 0         0 $end = 1;
772             }
773             }
774              
775 0         0 my $eid = shift @msgid;
776 0         0 my $last = shift @written;
777 0 0       0 unless ($sftp->_check_status_ok($eid,
778             SFTP_ERR_REMOTE_WRITE_FAILED,
779             "Couldn't write to remote file")) {
780              
781             # discard responses to queued requests:
782 0         0 $sftp->_get_msg_by_id($_) for @msgid;
783 0         0 return $last;
784             }
785             }
786              
787 0         0 return $written;
788             }
789              
790             sub write {
791 0 0   0 1 0 @_ == 3 or croak 'Usage: $sftp->write($fh, $data)';
792              
793 0         0 my ($sftp, $rfh) = @_;
794 0 0       0 $sftp->flush($rfh, 'in') or return undef;
795 0 0       0 utf8::downgrade($_[2], 1) or croak "wide characters found in data";
796 0         0 my $datalen = length $_[2];
797 0         0 my $bout = $rfh->_bout;
798 0         0 $$bout .= $_[2];
799 0         0 my $len = length $$bout;
800              
801 0 0 0     0 if ($len >= $sftp->{_write_delay} or ($len and $sftp->{_autoflush} )) {
      0        
802 0 0       0 $sftp->flush($rfh, 'out') or return undef;
803             }
804              
805 0         0 return $datalen;
806             }
807              
808             sub flush {
809 0 0 0 0 1 0 (@_ >= 2 and @_ <= 3)
810             or croak 'Usage: $sftp->flush($fh [, $direction])';
811              
812 0         0 my ($sftp, $rfh, $dir) = @_;
813 0   0     0 $dir ||= '';
814              
815 0 0       0 defined $sftp->_rfid($rfh) or return;
816              
817 0 0       0 if ($dir ne 'out') { # flush in!
818 0         0 ${$rfh->_bin} = '';
  0         0  
819             }
820              
821 0 0       0 if ($dir ne 'in') { # flush out!
822 0         0 my $bout = $rfh->_bout;
823 0         0 my $len = length $$bout;
824 0 0       0 if ($len) {
825 0         0 my $start;
826 0         0 my $append = $rfh->_flag('append');
827 0 0       0 if ($append) {
828 0 0       0 my $attr = $sftp->stat($rfh)
829             or return undef;
830 0         0 $start = $attr->size;
831             }
832             else {
833 0         0 $start = $rfh->_pos;
834 0         0 ${$rfh->_bin} = '';
  0         0  
835             }
836 0         0 my $off = 0;
837             my $written = $sftp->_write($rfh, $start,
838             sub {
839 0     0   0 my $data = substr($$bout, $off, $sftp->{_block_size});
840 0         0 $off += length $data;
841 0         0 $data;
842 0         0 } );
843 0 0       0 $rfh->_inc_pos($written)
844             unless $append;
845              
846 0         0 $$bout = ''; # The full buffer is discarded even when some error happens.
847 0 0       0 $written == $len or return undef;
848             }
849             }
850 0         0 1;
851             }
852              
853             sub _fill_read_cache {
854 0     0   0 my ($sftp, $rfh, $len) = @_;
855              
856 0         0 $sftp->_clear_error_and_status;
857              
858 0 0       0 $sftp->flush($rfh, 'out')
859             or return undef;
860              
861 0         0 my $rfid = $sftp->_rfid($rfh);
862 0 0       0 defined $rfid or return undef;
863              
864 0         0 my $bin = $rfh->_bin;
865              
866 0 0       0 if (defined $len) {
867 0 0       0 return 1 if ($len < length $$bin);
868              
869 0         0 my $read_ahead = $sftp->{_read_ahead};
870 0 0       0 $len = length($$bin) + $read_ahead
871             if $len - length($$bin) < $read_ahead;
872             }
873              
874 0         0 my $pos = $rfh->_pos;
875              
876 0         0 my $qsize = $sftp->{_queue_size};
877 0         0 my $bsize = $sftp->{_block_size};
878              
879 0         0 do {
880 0         0 local $sftp->{_autodie};
881              
882 0         0 my @msgid;
883 0         0 my $askoff = length $$bin;
884 0         0 my $ensure_eof;
885              
886 0   0     0 while (!defined $len or length $$bin < $len) {
887 0   0     0 while ((!defined $len or $askoff < $len) and @msgid < $qsize) {
      0        
888 0         0 my $id = $sftp->_queue_new_msg(SSH2_FXP_READ, str=> $rfid,
889             int64 => $pos + $askoff, int32 => $bsize);
890 0         0 push @msgid, $id;
891 0         0 $askoff += $bsize;
892             }
893              
894 0         0 my $eid = shift @msgid;
895 0 0       0 my $msg = $sftp->_get_msg_and_check(SSH2_FXP_DATA, $eid,
896             SFTP_ERR_REMOTE_READ_FAILED,
897             "Couldn't read from remote file")
898             or last;
899              
900 0         0 my $data = $msg->get_str;
901 0         0 $$bin .= $data;
902 0 0       0 if (length $data < $bsize) {
903 0 0       0 unless (defined $len) {
904 0         0 $ensure_eof = $sftp->_queue_new_msg(SSH2_FXP_READ, str=> $rfid,
905             int64 => $pos + length $$bin, int32 => 1);
906             }
907 0         0 last;
908             }
909             }
910              
911 0         0 $sftp->_get_msg_by_id($_) for @msgid;
912              
913 0 0 0     0 if ($ensure_eof and
914             $sftp->_get_msg_and_check(SSH2_FXP_DATA, $ensure_eof,
915             SFTP_ERR_REMOTE_READ_FAILED,
916             "Couldn't read from remote file")) {
917              
918 0         0 $sftp->_set_error(SFTP_ERR_REMOTE_BLOCK_TOO_SMALL,
919             "Received block was too small");
920             }
921              
922 0 0       0 if ($sftp->{_status} == SSH2_FX_EOF) {
923 0         0 $sftp->_set_error;
924 0 0       0 $sftp->_set_status if length $$bin
925             }
926             };
927              
928 0 0       0 $sftp->_ok_or_autodie and length $$bin;
929             }
930              
931             sub read {
932 0 0   0 1 0 @_ == 3 or croak 'Usage: $sftp->read($fh, $len)';
933              
934 0         0 my ($sftp, $rfh, $len) = @_;
935 0 0       0 if ($sftp->_fill_read_cache($rfh, $len)) {
936 0         0 my $bin = $rfh->_bin;
937 0         0 my $data = substr($$bin, 0, $len, '');
938 0         0 $rfh->_inc_pos(length $data);
939 0         0 return $data;
940             }
941 0         0 return undef;
942             }
943              
944             sub _readline {
945 0     0   0 my ($sftp, $rfh, $sep) = @_;
946              
947 0 0       0 $sep = "\n" if @_ < 3;
948              
949 0         0 my $sl = length $sep;
950              
951 0         0 my $bin = $rfh->_bin;
952 0         0 my $last = 0;
953              
954 0         0 while(1) {
955 0         0 my $ix = index $$bin, $sep, $last + 1 - $sl ;
956 0 0       0 if ($ix >= 0) {
957 0         0 $ix += $sl;
958 0         0 $rfh->_inc_pos($ix);
959 0         0 return substr($$bin, 0, $ix, '');
960             }
961              
962 0         0 $last = length $$bin;
963 0         0 $sftp->_fill_read_cache($rfh, length($$bin) + 1);
964              
965 0 0       0 unless (length $$bin > $last) {
966             $sftp->{_error}
967 0 0       0 and return undef;
968              
969 0         0 my $line = $$bin;
970 0         0 $rfh->_inc_pos(length $line);
971 0         0 $$bin = '';
972 0 0       0 return (length $line ? $line : undef);
973             }
974             }
975             }
976              
977             sub readline {
978 0 0 0 0 1 0 (@_ >= 2 and @_ <= 3)
979             or croak 'Usage: $sftp->readline($fh [, $sep])';
980              
981 0         0 my ($sftp, $rfh, $sep) = @_;
982 0 0       0 $sep = "\n" if @_ < 3;
983 0 0 0     0 if (!defined $sep or $sep eq '') {
984 0         0 $sftp->_fill_read_cache($rfh);
985             $sftp->{_error}
986 0 0       0 and return undef;
987 0         0 my $bin = $rfh->_bin;
988 0         0 my $line = $$bin;
989 0         0 $rfh->_inc_pos(length $line);
990 0         0 $$bin = '';
991 0         0 return $line;
992             }
993 0 0       0 if (wantarray) {
994 0         0 my @lines;
995 0         0 while (defined (my $line = $sftp->_readline($rfh, $sep))) {
996 0         0 push @lines, $line;
997             }
998 0         0 return @lines;
999             }
1000 0         0 return $sftp->_readline($rfh, $sep);
1001             }
1002              
1003             sub getc {
1004 0 0   0 1 0 @_ == 2 or croak 'Usage: $sftp->getc($fh)';
1005              
1006 0         0 my ($sftp, $rfh) = @_;
1007              
1008 0         0 $sftp->_fill_read_cache($rfh, 1);
1009 0         0 my $bin = $rfh->_bin;
1010 0 0       0 if (length $bin) {
1011 0         0 $rfh->_inc_pos(1);
1012 0         0 return substr $$bin, 0, 1, '';
1013             }
1014 0         0 return undef;
1015             }
1016              
1017             ## SSH2_FXP_LSTAT (7), SSH2_FXP_FSTAT (8), SSH2_FXP_STAT (17)
1018             # these all return a Net::SFTP::Foreign::Attributes object on success, undef on failure
1019              
1020             sub lstat {
1021 0 0   0 1 0 @_ <= 2 or croak 'Usage: $sftp->lstat($path)';
1022 0 0       0 ${^TAINT} and &_catch_tainted_args;
1023              
1024 0         0 my ($sftp, $path) = @_;
1025 0 0       0 $path = '.' unless defined $path;
1026 0         0 $path = $sftp->_rel2abs($path);
1027 0         0 my $id = $sftp->_queue_str_request(SSH2_FXP_LSTAT, $sftp->_fs_encode($path));
1028 0 0       0 if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_ATTRS, $id,
1029             SFTP_ERR_REMOTE_LSTAT_FAILED, "Couldn't stat remote link")) {
1030 0         0 return $msg->get_attributes;
1031             }
1032 0         0 return undef;
1033             }
1034              
1035             sub stat {
1036 0 0   0 1 0 @_ <= 2 or croak 'Usage: $sftp->stat($path_or_fh)';
1037 0 0       0 ${^TAINT} and &_catch_tainted_args;
1038              
1039 0         0 my ($sftp, $pofh) = @_;
1040 0 0       0 $pofh = '.' unless defined $pofh;
1041 0 0 0     0 my $id = $sftp->_queue_new_msg( (ref $pofh and UNIVERSAL::isa($pofh, 'Net::SFTP::Foreign::FileHandle'))
1042             ? ( SSH2_FXP_FSTAT, str => $sftp->_rid($pofh))
1043             : ( SSH2_FXP_STAT, str => $sftp->_fs_encode($sftp->_rel2abs($pofh))) );
1044 0 0       0 if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_ATTRS, $id,
1045             SFTP_ERR_REMOTE_STAT_FAILED, "Couldn't stat remote file")) {
1046 0         0 return $msg->get_attributes;
1047             }
1048 0         0 return undef;
1049             }
1050              
1051             sub fstat {
1052 0     0 1 0 _deprecated "fstat is deprecated and will be removed on the upcoming 2.xx series, "
1053             . "stat method accepts now both file handlers and paths";
1054 0         0 goto &stat;
1055             }
1056              
1057             ## SSH2_FXP_RMDIR (15), SSH2_FXP_REMOVE (13)
1058             # these return true on success, undef on failure
1059              
1060             sub _gen_remove_method {
1061 6     6   19 my($name, $code, $error, $errstr) = @_;
1062             my $sub = sub {
1063 0 0   0   0 @_ == 2 or croak "Usage: \$sftp->$name(\$path)";
1064 0 0       0 ${^TAINT} and &_catch_tainted_args;
1065              
1066 0         0 my ($sftp, $path) = @_;
1067 0         0 $path = $sftp->_rel2abs($path);
1068 0         0 my $id = $sftp->_queue_str_request($code, $sftp->_fs_encode($path));
1069 0         0 $sftp->_check_status_ok($id, $error, $errstr);
1070 6         36 };
1071 3     3   26 no strict 'refs';
  3         6  
  3         4815  
1072 6         36 *$name = $sub;
1073             }
1074              
1075             _gen_remove_method(remove => SSH2_FXP_REMOVE,
1076             SFTP_ERR_REMOTE_REMOVE_FAILED, "Couldn't delete remote file");
1077             _gen_remove_method(rmdir => SSH2_FXP_RMDIR,
1078             SFTP_ERR_REMOTE_RMDIR_FAILED, "Couldn't remove remote directory");
1079              
1080             ## SSH2_FXP_MKDIR (14), SSH2_FXP_SETSTAT (9)
1081             # these return true on success, undef on failure
1082              
1083             sub mkdir {
1084 0 0 0 0 1 0 (@_ >= 2 and @_ <= 3)
1085             or croak 'Usage: $sftp->mkdir($path [, $attrs])';
1086 0 0       0 ${^TAINT} and &_catch_tainted_args;
1087              
1088 0         0 my ($sftp, $path, $attrs) = @_;
1089 0 0       0 $attrs = _empty_attributes unless defined $attrs;
1090 0         0 $path = $sftp->_rel2abs($path);
1091 0         0 my $id = $sftp->_queue_str_request(SSH2_FXP_MKDIR,
1092             $sftp->_fs_encode($path),
1093             $attrs);
1094 0         0 $sftp->_check_status_ok($id,
1095             SFTP_ERR_REMOTE_MKDIR_FAILED,
1096             "Couldn't create remote directory");
1097             }
1098              
1099             sub join {
1100 17     17 1 841 my $sftp = shift;
1101 17         24 my $vol = '';
1102 17         20 my $a = '.';
1103 17         37 while (@_) {
1104 34         43 my $b = shift;
1105 34 50       52 if (defined $b) {
1106 34 0 33     75 if (ref $sftp and # this method can also be used as a static one
      0        
1107             $sftp->{_remote_has_volumes} and $b =~ /^([a-z]\:)(.*)/i) {
1108 0         0 $vol = $1;
1109 0         0 $a = '.';
1110 0         0 $b = $2;
1111             }
1112 34         81 $b =~ s|^(?:\./+)+||;
1113 34 100 100     105 if (length $b and $b ne '.') {
1114 19 100 100     74 if ($b !~ m|^/| and $a ne '.' ) {
1115 2 50       7 $a = ($a =~ m|/$| ? "$a$b" : "$a/$b");
1116             }
1117             else {
1118 17         21 $a = $b
1119             }
1120 19         59 $a =~ s|(?:/+\.)+/?$|/|;
1121 19         44 $a =~ s|(?<=[^/])/+$||;
1122 19 50       43 $a = '.' unless length $a;
1123             }
1124             }
1125             }
1126 17         66 "$vol$a";
1127             }
1128              
1129             sub _rel2abs {
1130 0     0   0 my ($sftp, $path) = @_;
1131 0         0 my $old = $path;
1132 0         0 my $cwd = $sftp->{cwd};
1133 0         0 $path = $sftp->join($sftp->{cwd}, $path);
1134 0 0 0     0 $debug and $debug & 4096 and _debug("'$old' --> '$path'");
1135 0         0 return $path
1136             }
1137              
1138             sub mkpath {
1139 0 0 0 0 1 0 (@_ >= 2 and @_ <= 4)
1140             or croak 'Usage: $sftp->mkpath($path [, $attrs [, $parent]])';
1141 0 0       0 ${^TAINT} and &_catch_tainted_args;
1142              
1143 0         0 my ($sftp, $path, $attrs, $parent) = @_;
1144 0         0 $sftp->_clear_error_and_status;
1145 0         0 my $first = !$parent; # skips file name
1146 0         0 $path =~ s{^(/*)}{};
1147 0         0 my $start = $1;
1148 0         0 $path =~ s{/+$}{};
1149 0         0 my @path;
1150 0         0 while (1) {
1151 0 0       0 if ($first) {
1152 0         0 $first = 0
1153             }
1154             else {
1155 0         0 $path =~ s{/*[^/]*$}{}
1156             }
1157 0         0 my $p = "$start$path";
1158 0 0 0     0 $debug and $debug & 8192 and _debug "checking $p";
1159 0 0       0 if ($sftp->test_d($p)) {
1160 0 0 0     0 $debug and $debug & 8192 and _debug "$p is a dir";
1161 0         0 last;
1162             }
1163 0 0       0 unless (length $path) {
1164 0         0 $sftp->_set_error(SFTP_ERR_REMOTE_MKDIR_FAILED,
1165             "Unable to make path, bad root");
1166 0         0 return undef;
1167             }
1168 0         0 unshift @path, $p;
1169              
1170             }
1171 0         0 for my $p (@path) {
1172 0 0 0     0 $debug and $debug & 8192 and _debug "mkdir $p";
1173 0 0 0     0 if ($p =~ m{^(?:.*/)?\.{1,2}$} or $p =~ m{/$}) {
1174 0 0 0     0 $debug and $debug & 8192 and _debug "$p is a symbolic dir, skipping";
1175 0 0       0 unless ($sftp->test_d($p)) {
1176 0 0 0     0 $debug and $debug & 8192 and _debug "symbolic dir $p can not be checked";
1177             $sftp->{_error} or
1178 0 0       0 $sftp->_set_error(SFTP_ERR_REMOTE_MKDIR_FAILED,
1179             "Unable to make path, bad name");
1180 0         0 return undef;
1181             }
1182             }
1183             else {
1184 0 0       0 $sftp->mkdir($p, $attrs)
1185             or return undef;
1186             }
1187             }
1188 0         0 1;
1189             }
1190              
1191             sub _mkpath_local {
1192 0     0   0 my ($sftp, $path, $perm, $parent) = @_;
1193             # When parent is set, the last path part is removed and the parent
1194             # directory of the path given created.
1195              
1196 0         0 my @parts = File::Spec->splitdir($path);
1197 0 0 0     0 $debug and $debug & 32768 and _debug "_mkpath_local($path, $perm, ".($parent||0).")";
      0        
1198              
1199 0 0       0 if ($parent) {
1200 0   0     0 pop @parts while @parts and not length $parts[-1];
1201 0 0       0 unless (@parts) {
1202 0         0 $sftp->_set_error(SFTP_ERR_LOCAL_MKDIR_FAILED,
1203             "mkpath failed, top dir reached");
1204 0         0 return;
1205             }
1206 0         0 pop @parts;
1207             }
1208              
1209 0         0 my @tail;
1210 0         0 while (@parts) {
1211 0         0 my $target = File::Spec->catdir(@parts);
1212 0 0       0 if (-e $target) {
1213 0 0       0 unless (-d $target) {
1214 0         0 $sftp->_set_error(SFTP_ERR_LOCAL_BAD_OBJECT,
1215             "Local file '$target' is not a directory");
1216 0         0 return;
1217             }
1218             last
1219 0         0 }
1220 0         0 unshift @tail, pop @parts;
1221             }
1222 0         0 while (@tail) {
1223 0         0 push @parts, shift @tail;
1224 0         0 my $target = File::Spec->catdir(@parts);
1225 0 0 0     0 $debug and $debug and 32768 and _debug "creating local directory '$target'";
      0        
1226 0 0       0 unless (CORE::mkdir $target, $perm) {
1227 0 0       0 unless (do { local $!; -d $target}) {
  0         0  
  0         0  
1228 0         0 $sftp->_set_error(SFTP_ERR_LOCAL_MKDIR_FAILED,
1229             "mkdir '$target' failed", $!);
1230 0         0 return;
1231             }
1232             }
1233             }
1234 0 0 0     0 $debug and $debug & 32768 and _debug "_mkpath_local succeeded";
1235 0         0 return 1;
1236             }
1237              
1238             sub setstat {
1239 0 0   0 1 0 @_ == 3 or croak 'Usage: $sftp->setstat($path_or_fh, $attrs)';
1240 0 0       0 ${^TAINT} and &_catch_tainted_args;
1241              
1242 0         0 my ($sftp, $pofh, $attrs) = @_;
1243 0 0 0     0 my $id = $sftp->_queue_new_msg( ( (ref $pofh and UNIVERSAL::isa($pofh, 'Net::SFTP::Foreign::FileHandle') )
1244             ? ( SSH2_FXP_FSETSTAT, str => $sftp->_rid($pofh) )
1245             : ( SSH2_FXP_SETSTAT, str => $sftp->_fs_encode($sftp->_rel2abs($pofh)) ) ),
1246             attr => $attrs );
1247 0         0 return $sftp->_check_status_ok($id,
1248             SFTP_ERR_REMOTE_SETSTAT_FAILED,
1249             "Couldn't setstat remote file");
1250             }
1251              
1252             ## SSH2_FXP_CLOSE (4), SSH2_FXP_FSETSTAT (10)
1253             # these return true on success, undef on failure
1254              
1255             sub fsetstat {
1256 0     0 1 0 _deprecated "fsetstat is deprecated and will be removed on the upcoming 2.xx series, "
1257             . "setstat method accepts now both file handlers and paths";
1258 0         0 goto &setstat;
1259             }
1260              
1261             sub _gen_setstat_shortcut {
1262 12     12   31 my ($name, $rid_type, $attrs_flag, @arg_types) = @_;
1263 12         18 my $nargs = 2 + @arg_types;
1264 12         62 my $usage = ("\$sftp->$name("
1265             . CORE::join(', ', '$path_or_fh', map "arg$_", 1..@arg_types)
1266             . ')');
1267 12 50       42 my $rid_method = ($rid_type eq 'file' ? '_rfid' :
    50          
    100          
1268             $rid_type eq 'dir' ? '_rdid' :
1269             $rid_type eq 'any' ? '_rid' :
1270             croak "bad rid type $rid_type");
1271             my $sub = sub {
1272 0 0   0   0 @_ == $nargs or croak $usage;
1273 0         0 my $sftp = shift;
1274 0         0 my $pofh = shift;
1275             my $id = $sftp->_queue_new_msg( ( (ref $pofh and UNIVERSAL::isa($pofh, 'Net::SFTP::Foreign::FileHandle') )
1276             ? ( SSH2_FXP_FSETSTAT, str => $sftp->$rid_method($pofh) )
1277             : ( SSH2_FXP_SETSTAT, str => $sftp->_fs_encode($sftp->_rel2abs($pofh)) ) ),
1278             int32 => $attrs_flag,
1279 0 0 0     0 map { $arg_types[$_] => $_[$_] } 0..$#arg_types );
  0         0  
1280 0         0 $sftp->_check_status_ok($id,
1281             SFTP_ERR_REMOTE_SETSTAT_FAILED,
1282             "Couldn't setstat remote file ($name)");
1283 12         39 };
1284 3     3   24 no strict 'refs';
  3         5  
  3         12520  
1285 12         39 *$name = $sub;
1286             }
1287              
1288             _gen_setstat_shortcut(truncate => 'file', SSH2_FILEXFER_ATTR_SIZE, 'int64');
1289             _gen_setstat_shortcut(chown => 'any' , SSH2_FILEXFER_ATTR_UIDGID, 'int32', 'int32');
1290             _gen_setstat_shortcut(chmod => 'any' , SSH2_FILEXFER_ATTR_PERMISSIONS, 'int32');
1291             _gen_setstat_shortcut(utime => 'any' , SSH2_FILEXFER_ATTR_ACMODTIME, 'int32', 'int32');
1292              
1293             sub _close {
1294 0 0   0   0 @_ == 2 or croak 'Usage: $sftp->close($fh, $attrs)';
1295              
1296 0         0 my $sftp = shift;
1297 0         0 my $id = $sftp->_queue_rid_request(SSH2_FXP_CLOSE, @_);
1298 0 0       0 defined $id or return undef;
1299              
1300 0         0 my $ok = $sftp->_check_status_ok($id,
1301             SFTP_ERR_REMOTE_CLOSE_FAILED,
1302             "Couldn't close remote file");
1303              
1304 0 0 0     0 if ($debug and $debug & 2) {
1305 0 0       0 _debug sprintf("closing file handle, return: %s, rid:", (defined $ok ? $ok : '-'));
1306 0         0 _hexdump($sftp->_rid($_[0]));
1307             }
1308              
1309 0         0 return $ok;
1310             }
1311              
1312             sub close {
1313 0 0   0 1 0 @_ == 2 or croak 'Usage: $sftp->close($fh)';
1314 0 0       0 ${^TAINT} and &_catch_tainted_args;
1315              
1316 0         0 my ($sftp, $rfh) = @_;
1317             # defined $sftp->_rfid($rfh) or return undef;
1318             # ^--- commented out because flush already checks it is an open file
1319 0 0       0 $sftp->flush($rfh)
1320             or return undef;
1321              
1322 0 0       0 if ($sftp->_close($rfh)) {
1323 0         0 $rfh->_close;
1324 0         0 return 1
1325             }
1326             undef
1327 0         0 }
1328              
1329             sub closedir {
1330 0 0   0 1 0 @_ == 2 or croak 'Usage: $sftp->closedir($dh)';
1331 0 0       0 ${^TAINT} and &_catch_tainted_args;
1332              
1333 0         0 my ($sftp, $rdh) = @_;
1334 0         0 $rdh->_check_is_dir;
1335              
1336 0 0       0 if ($sftp->_close($rdh)) {
1337 0         0 $rdh->_close;
1338 0         0 return 1;
1339             }
1340             undef
1341 0         0 }
1342              
1343             sub readdir {
1344 0 0   0 1 0 @_ == 2 or croak 'Usage: $sftp->readdir($dh)';
1345 0 0       0 ${^TAINT} and &_catch_tainted_args;
1346              
1347 0         0 my ($sftp, $rdh) = @_;
1348              
1349 0         0 my $rdid = $sftp->_rdid($rdh);
1350 0 0       0 defined $rdid or return undef;
1351              
1352 0         0 my $cache = $rdh->_cache;
1353              
1354 0   0     0 while (!@$cache or wantarray) {
1355 0         0 my $id = $sftp->_queue_str_request(SSH2_FXP_READDIR, $rdid);
1356 0 0       0 if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_NAME, $id,
1357             SFTP_ERR_REMOTE_READDIR_FAILED,
1358             "Couldn't read remote directory" )) {
1359 0 0       0 my $count = $msg->get_int32 or last;
1360              
1361 0         0 for (1..$count) {
1362 0         0 push @$cache, { filename => $sftp->_fs_decode($msg->get_str),
1363             longname => $sftp->_fs_decode($msg->get_str),
1364             a => $msg->get_attributes };
1365             }
1366             }
1367             else {
1368 0 0       0 $sftp->_set_error if $sftp->{_status} == SSH2_FX_EOF;
1369 0         0 last;
1370             }
1371             }
1372              
1373 0 0       0 if (wantarray) {
1374 0         0 my $old = $cache;
1375 0         0 $cache = [];
1376 0         0 return @$old;
1377             }
1378 0         0 shift @$cache;
1379             }
1380              
1381             sub _readdir {
1382 0     0   0 my ($sftp, $rdh);
1383 0 0       0 if (wantarray) {
1384 0         0 my $line = $sftp->readdir($rdh);
1385 0 0       0 if (defined $line) {
1386 0         0 return $line->{filename};
1387             }
1388             }
1389             else {
1390 0         0 return map { $_->{filename} } $sftp->readdir($rdh);
  0         0  
1391             }
1392             }
1393              
1394             sub _gen_getpath_method {
1395 6     6   12 my ($code, $error, $name) = @_;
1396             return sub {
1397 0 0   0   0 @_ == 2 or croak 'Usage: $sftp->some_method($path)';
1398 0 0       0 ${^TAINT} and &_catch_tainted_args;
1399              
1400 0         0 my ($sftp, $path) = @_;
1401 0         0 $path = $sftp->_rel2abs($path);
1402 0         0 my $id = $sftp->_queue_str_request($code, $sftp->_fs_encode($path));
1403              
1404 0 0       0 if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_NAME, $id,
1405             $error,
1406             "Couldn't get $name for remote '$path'")) {
1407 0 0       0 $msg->get_int32 > 0
1408             and return $sftp->_fs_decode($msg->get_str);
1409              
1410 0         0 $sftp->_set_error($error,
1411             "Couldn't get $name for remote '$path', no names on reply")
1412             }
1413 0         0 return undef;
1414 6         35 };
1415             }
1416              
1417             ## SSH2_FXP_REALPATH (16)
1418             ## SSH2_FXP_READLINK (19)
1419             # return path on success, undef on failure
1420             *realpath = _gen_getpath_method(SSH2_FXP_REALPATH,
1421             SFTP_ERR_REMOTE_REALPATH_FAILED,
1422             "realpath");
1423             *readlink = _gen_getpath_method(SSH2_FXP_READLINK,
1424             SFTP_ERR_REMOTE_READLINK_FAILED,
1425             "link target");
1426              
1427             ## SSH2_FXP_RENAME (18)
1428             # true on success, undef on failure
1429              
1430             sub _rename {
1431 0     0   0 my ($sftp, $old, $new) = @_;
1432              
1433 0         0 $old = $sftp->_rel2abs($old);
1434 0         0 $new = $sftp->_rel2abs($new);
1435              
1436 0         0 my $id = $sftp->_queue_new_msg(SSH2_FXP_RENAME,
1437             str => $sftp->_fs_encode($old),
1438             str => $sftp->_fs_encode($new));
1439              
1440 0         0 $sftp->_check_status_ok($id, SFTP_ERR_REMOTE_RENAME_FAILED,
1441             "Couldn't rename remote file '$old' to '$new'");
1442             }
1443              
1444             sub rename {
1445 0 0   0 1 0 (@_ & 1) or croak 'Usage: $sftp->rename($old, $new, %opts)';
1446 0 0       0 ${^TAINT} and &_catch_tainted_args;
1447              
1448 0         0 my ($sftp, $old, $new, %opts) = @_;
1449              
1450 0         0 my $overwrite = delete $opts{overwrite};
1451 0         0 my $numbered = delete $opts{numbered};
1452 0 0 0     0 croak "'overwrite' and 'numbered' options can not be used together"
1453             if ($overwrite and $numbered);
1454 0 0       0 %opts and _croak_bad_options(keys %opts);
1455              
1456 0 0       0 if ($overwrite) {
1457 0 0       0 $sftp->atomic_rename($old, $new) and return 1;
1458 0 0       0 $sftp->{_status} != SSH2_FX_OP_UNSUPPORTED and return undef;
1459             }
1460              
1461 0         0 for (1) {
1462 0         0 local $sftp->{_autodie};
1463             # we are optimistic here and try to rename it without testing
1464             # if a file of the same name already exists first
1465 0 0 0     0 if (!$sftp->_rename($old, $new) and
1466             $sftp->{_status} == SSH2_FX_FAILURE) {
1467 0 0 0     0 if ($numbered and $sftp->test_e($new)) {
    0          
1468 0         0 _inc_numbered($new);
1469 0         0 redo;
1470             }
1471             elsif ($overwrite) {
1472 0         0 my $rp_old = $sftp->realpath($old);
1473 0         0 my $rp_new = $sftp->realpath($new);
1474 0 0 0     0 if (defined $rp_old and defined $rp_new and $rp_old eq $rp_new) {
    0 0        
1475 0         0 $sftp->_clear_error_and_status;
1476             }
1477             elsif ($sftp->remove($new)) {
1478 0         0 $overwrite = 0;
1479 0         0 redo;
1480             }
1481             }
1482             }
1483             }
1484 0         0 $sftp->_ok_or_autodie;
1485             }
1486              
1487             sub atomic_rename {
1488 0 0   0 1 0 @_ == 3 or croak 'Usage: $sftp->atomic_rename($old, $new)';
1489 0 0       0 ${^TAINT} and &_catch_tainted_args;
1490              
1491 0         0 my ($sftp, $old, $new) = @_;
1492              
1493 0 0       0 $sftp->_check_extension('posix-rename@openssh.com' => 1,
1494             SFTP_ERR_REMOTE_RENAME_FAILED,
1495             "atomic rename failed")
1496             or return undef;
1497              
1498 0         0 $old = $sftp->_rel2abs($old);
1499 0         0 $new = $sftp->_rel2abs($new);
1500              
1501 0         0 my $id = $sftp->_queue_new_msg(SSH2_FXP_EXTENDED,
1502             str => 'posix-rename@openssh.com',
1503             str => $sftp->_fs_encode($old),
1504             str => $sftp->_fs_encode($new));
1505              
1506 0         0 $sftp->_check_status_ok($id, SFTP_ERR_REMOTE_RENAME_FAILED,
1507             "Couldn't rename remote file '$old' to '$new'");
1508             }
1509              
1510             ## SSH2_FXP_SYMLINK (20)
1511             # true on success, undef on failure
1512             sub symlink {
1513 0 0   0 1 0 @_ == 3 or croak 'Usage: $sftp->symlink($sl, $target)';
1514 0 0       0 ${^TAINT} and &_catch_tainted_args;
1515              
1516 0         0 my ($sftp, $sl, $target) = @_;
1517 0         0 $sl = $sftp->_rel2abs($sl);
1518 0         0 my $id = $sftp->_queue_new_msg(SSH2_FXP_SYMLINK,
1519             str => $sftp->_fs_encode($target),
1520             str => $sftp->_fs_encode($sl));
1521              
1522 0         0 $sftp->_check_status_ok($id, SFTP_ERR_REMOTE_SYMLINK_FAILED,
1523             "Couldn't create symlink '$sl' pointing to '$target'");
1524             }
1525              
1526             sub hardlink {
1527 0 0   0 1 0 @_ == 3 or croak 'Usage: $sftp->hardlink($hl, $target)';
1528 0 0       0 ${^TAINT} and &_catch_tainted_args;
1529              
1530 0         0 my ($sftp, $hl, $target) = @_;
1531              
1532 0 0       0 $sftp->_check_extension('hardlink@openssh.com' => 1,
1533             SFTP_ERR_REMOTE_HARDLINK_FAILED,
1534             "hardlink failed")
1535             or return undef;
1536 0         0 $hl = $sftp->_rel2abs($hl);
1537 0         0 $target = $sftp->_rel2abs($target);
1538              
1539 0         0 my $id = $sftp->_queue_new_msg(SSH2_FXP_EXTENDED,
1540             str => 'hardlink@openssh.com',
1541             str => $sftp->_fs_encode($target),
1542             str => $sftp->_fs_encode($hl));
1543 0         0 $sftp->_check_status_ok($id, SFTP_ERR_REMOTE_HARDLINK_FAILED,
1544             "Couldn't create hardlink '$hl' pointing to '$target'");
1545             }
1546              
1547             sub _gen_save_status_method {
1548 9     9   26 my $method = shift;
1549             sub {
1550 0     0     my $sftp = shift;
1551 0 0         local ($sftp->{_error}, $sftp->{_status}) if $sftp->{_error};
1552 0           $sftp->$method(@_);
1553             }
1554 9         36 }
1555              
1556              
1557             *_close_save_status = _gen_save_status_method('close');
1558             *_closedir_save_status = _gen_save_status_method('closedir');
1559             *_remove_save_status = _gen_save_status_method('remove');
1560              
1561             sub _inc_numbered {
1562 0 0   0     $_[0] =~ s{^(.*)\((\d+)\)((?:\.[^\.]*)?)$}{"$1(" . ($2+1) . ")$3"}e or
  0            
1563             $_[0] =~ s{((?:\.[^\.]*)?)$}{(1)$1};
1564 0 0 0       $debug and $debug & 128 and _debug("numbering to: $_[0]");
1565             }
1566              
1567             ## High-level client -> server methods.
1568              
1569             sub abort {
1570 0     0 1   my $sftp = shift;
1571 0 0         $sftp->_set_error(SFTP_ERR_ABORTED, ($@ ? $_[0] : "Aborted"));
1572             }
1573              
1574             # returns true on success, undef on failure
1575             sub get {
1576 0 0   0 1   @_ >= 2 or croak 'Usage: $sftp->get($remote, $local, %opts)';
1577 0 0         ${^TAINT} and &_catch_tainted_args;
1578              
1579 0           my ($sftp, $remote, $local, %opts) = @_;
1580 0 0         defined $remote or croak "remote file path is undefined";
1581              
1582 0           $sftp->_clear_error_and_status;
1583              
1584 0           $remote = $sftp->_rel2abs($remote);
1585 0 0         $local = _file_part($remote) unless defined $local;
1586 0   0       my $local_is_fh = (ref $local and $local->isa('GLOB'));
1587              
1588 0           my $cb = delete $opts{callback};
1589 0           my $umask = delete $opts{umask};
1590 0           my $perm = delete $opts{perm};
1591 0 0         my $copy_perm = delete $opts{exists $opts{copy_perm} ? 'copy_perm' : 'copy_perms'};
1592 0           my $copy_time = delete $opts{copy_time};
1593 0           my $overwrite = delete $opts{overwrite};
1594 0           my $resume = delete $opts{resume};
1595 0           my $append = delete $opts{append};
1596 0   0       my $block_size = delete $opts{block_size} || $sftp->{_block_size};
1597 0   0       my $queue_size = delete $opts{queue_size} || $sftp->{_queue_size};
1598 0           my $dont_save = delete $opts{dont_save};
1599 0           my $conversion = delete $opts{conversion};
1600 0           my $numbered = delete $opts{numbered};
1601 0           my $cleanup = delete $opts{cleanup};
1602 0           my $atomic = delete $opts{atomic};
1603 0           my $best_effort = delete $opts{best_effort};
1604 0           my $mkpath = delete $opts{mkpath};
1605              
1606 0 0 0       croak "'perm' and 'copy_perm' options can not be used simultaneously"
1607             if (defined $perm and defined $copy_perm);
1608 0 0 0       croak "'numbered' can not be used with 'overwrite', 'resume' or 'append'"
      0        
1609             if ($numbered and ($overwrite or $resume or $append));
1610 0 0 0       if ($resume or $append) {
1611 0 0 0       $resume and $append and croak "'resume' and 'append' options can not be used simultaneously";
1612 0 0         $atomic and croak "'atomic' can not be used with 'resume' or 'append'";
1613 0 0         $overwrite and croak "'overwrite' can not be used with 'resume' or 'append'";
1614             }
1615              
1616 0 0         if ($local_is_fh) {
1617 0           my $tail = 'option can not be used when target is a file handle';
1618 0 0         $resume and croak "'resume' $tail";
1619 0 0         $overwrite and croak "'overwrite' $tail";
1620 0 0         $numbered and croak "'numbered' $tail";
1621 0 0         $dont_save and croak "'dont_save' $tail";
1622 0 0         $atomic and croak "'croak' $tail";
1623             }
1624 0 0         %opts and _croak_bad_options(keys %opts);
1625              
1626 0 0 0       if ($resume and $conversion) {
1627 0           carp "resume option is useless when data conversion has also been requested";
1628 0           undef $resume;
1629             }
1630              
1631 0 0 0       $overwrite = 1 unless (defined $overwrite or $local_is_fh or $numbered or $append);
      0        
      0        
1632 0 0 0       $copy_perm = 1 unless (defined $perm or defined $copy_perm or $local_is_fh);
      0        
1633 0 0 0       $copy_time = 1 unless (defined $copy_time or $local_is_fh);
1634 0 0         $mkpath = 1 unless defined $mkpath;
1635 0 0 0       $cleanup = ($atomic || $numbered) unless defined $cleanup;
1636              
1637 0           my $a = do {
1638 0           local $sftp->{_autodie};
1639 0           $sftp->stat($remote);
1640             };
1641 0 0         my ($rperm, $size, $atime, $mtime) = ($a ? ($a->perm, $a->size, $a->atime, $a->mtime) : ());
1642 0 0         $size = -1 unless defined $size;
1643              
1644 0 0 0       if ($copy_time and not defined $atime) {
1645 0 0         if ($best_effort) {
1646 0           undef $copy_time;
1647             }
1648             else {
1649 0 0         $sftp->_ok_or_autodie and $sftp->_set_error(SFTP_ERR_REMOTE_STAT_FAILED,
1650             "Not enough information on stat, amtime not included");
1651 0           return undef;
1652             }
1653             }
1654              
1655 0 0         $umask = (defined $perm ? 0 : umask) unless defined $umask;
    0          
1656 0 0         if ($copy_perm) {
1657 0 0         if (defined $rperm) {
    0          
1658 0           $perm = $rperm;
1659             }
1660             elsif ($best_effort) {
1661 0           undef $copy_perm
1662             }
1663             else {
1664 0 0         $sftp->_ok_or_autodie and $sftp->_set_error(SFTP_ERR_REMOTE_STAT_FAILED,
1665             "Not enough information on stat, mode not included");
1666             return undef
1667 0           }
1668             }
1669 0 0         $perm &= ~$umask if defined $perm;
1670              
1671 0           $sftp->_clear_error_and_status;
1672              
1673 0 0 0       if ($resume and $resume eq 'auto') {
1674 0           undef $resume;
1675 0 0         if (defined $mtime) {
1676 0 0         if (my @lstat = CORE::stat $local) {
1677 0           $resume = ($mtime <= $lstat[9]);
1678             }
1679             }
1680             }
1681              
1682 0           my ($atomic_numbered, $atomic_local, $atomic_cleanup);
1683              
1684 0           my ($rfh, $fh);
1685 0           my $askoff = 0;
1686 0           my $lstart = 0;
1687              
1688 0 0         if ($dont_save) {
1689 0           $rfh = $sftp->open($remote, SSH2_FXF_READ);
1690 0 0         defined $rfh or return undef;
1691             }
1692             else {
1693 0 0 0       unless ($local_is_fh or $overwrite or $append or $resume or $numbered) {
      0        
      0        
      0        
1694 0 0         if (-e $local) {
1695 0           $sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,
1696             "local file $local already exists");
1697             return undef
1698 0           }
1699             }
1700              
1701 0 0         if ($atomic) {
1702 0           $atomic_local = $local;
1703 0           $local .= sprintf("(%d).tmp", rand(10000));
1704 0           $atomic_numbered = $numbered;
1705 0           $numbered = 1;
1706 0 0 0       $debug and $debug & 128 and _debug("temporal local file name: $local");
1707             }
1708              
1709 0 0         if ($resume) {
1710 0 0         if (CORE::open $fh, '+<', $local) {
1711 0           binmode $fh;
1712 0           CORE::seek($fh, 0, 2);
1713 0           $askoff = CORE::tell $fh;
1714 0 0         if ($askoff < 0) {
1715             # something is going really wrong here, fall
1716             # back to non-resuming mode...
1717 0           $askoff = 0;
1718 0           undef $fh;
1719             }
1720             else {
1721 0 0 0       if ($size >=0 and $askoff > $size) {
1722 0           $sftp->_set_error(SFTP_ERR_LOCAL_BIGGER_THAN_REMOTE,
1723             "Couldn't resume transfer, local file is bigger than remote");
1724 0           return undef;
1725             }
1726 0 0         $size == $askoff and return 1;
1727             }
1728             }
1729             }
1730              
1731             # we open the remote file so late in order to skip it when
1732             # resuming an already completed transfer:
1733 0           $rfh = $sftp->open($remote, SSH2_FXF_READ);
1734 0 0         defined $rfh or return undef;
1735              
1736 0 0         unless (defined $fh) {
1737 0 0         if ($local_is_fh) {
1738 0           $fh = $local;
1739 0           local ($@, $SIG{__DIE__}, $SIG{__WARN__});
1740 0           eval { $lstart = CORE::tell($fh) };
  0            
1741 0 0 0       $lstart = 0 unless ($lstart and $lstart > 0);
1742             }
1743             else {
1744 0           my $flags = Fcntl::O_CREAT|Fcntl::O_WRONLY;
1745 0 0         $flags |= Fcntl::O_APPEND if $append;
1746 0 0 0       $flags |= Fcntl::O_EXCL if ($numbered or (!$overwrite and !$append));
      0        
1747 0 0         unlink $local if $overwrite;
1748 0 0         my $open_perm = (defined $perm ? $perm : 0666);
1749 0           my $save = _umask_save_and_set($umask);
1750 0 0         $sftp->_mkpath_local($local, $open_perm|0700, 1) if $mkpath;
1751 0           while (1) {
1752 0 0         sysopen ($fh, $local, $flags, $open_perm) and last;
1753 0 0 0       unless ($numbered and -e $local) {
1754 0           $sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED,
1755             "Can't open $local", $!);
1756 0           return undef;
1757             }
1758 0           _inc_numbered($local);
1759             }
1760 0 0         $$numbered = $local if ref $numbered;
1761 0           binmode $fh;
1762 0 0         $lstart = sysseek($fh, 0, 2) if $append;
1763             }
1764             }
1765              
1766 0 0         if (defined $perm) {
1767 0           my $error;
1768 0           do {
1769 0           local ($@, $SIG{__DIE__}, $SIG{__WARN__});
1770 0 0         unless (eval { CORE::chmod($perm, $local) > 0 }) {
  0            
1771 0 0         $error = ($@ ? $@ : $!);
1772             }
1773             };
1774 0 0 0       if ($error and !$best_effort) {
1775 0 0 0       unlink $local unless $resume or $append;
1776 0           $sftp->_set_error(SFTP_ERR_LOCAL_CHMOD_FAILED,
1777             "Can't chmod $local", $error);
1778             return undef
1779 0           }
1780             }
1781             }
1782              
1783 0           my $converter = _gen_converter $conversion;
1784              
1785 0           my $rfid = $sftp->_rfid($rfh);
1786 0 0         defined $rfid or die "internal error: rfid not defined";
1787              
1788 0           my @msgid;
1789             my @askoff;
1790 0           my $loff = $askoff;
1791 0           my $adjustment = 0;
1792 0           local $\;
1793              
1794 0 0         my $slow_start = ($size == -1 ? $queue_size - 1 : 0);
1795              
1796 0           my $safe_block_size = $sftp->{_min_block_size} >= $block_size;
1797              
1798 0           do {
1799             # Disable autodie here in order to do not leave unhandled
1800             # responses queued on the connection in case of failure.
1801 0           local $sftp->{_autodie};
1802              
1803             # Again, once this point is reached, all code paths should end
1804             # through the CLEANUP block.
1805              
1806 0           while (1) {
1807             # request a new block if queue is not full
1808 0   0       while (!@msgid or ( ($size == -1 or $size + $block_size > $askoff) and
      0        
      0        
      0        
1809             @msgid < $queue_size - $slow_start and
1810             $safe_block_size ) ) {
1811 0           my $id = $sftp->_queue_new_msg(SSH2_FXP_READ, str=> $rfid,
1812             int64 => $askoff, int32 => $block_size);
1813 0           push @msgid, $id;
1814 0           push @askoff, $askoff;
1815 0           $askoff += $block_size;
1816             }
1817              
1818 0 0         $slow_start-- if $slow_start;
1819              
1820 0           my $eid = shift @msgid;
1821 0           my $roff = shift @askoff;
1822              
1823 0           my $msg = $sftp->_get_msg_and_check(SSH2_FXP_DATA, $eid,
1824             SFTP_ERR_REMOTE_READ_FAILED,
1825             "Couldn't read from remote file");
1826              
1827 0 0         unless ($msg) {
1828 0 0         $sftp->_set_error if $sftp->{_status} == SSH2_FX_EOF;
1829 0           last;
1830             }
1831              
1832 0           my $data = $msg->get_str;
1833 0           my $len = length $data;
1834              
1835 0 0 0       if ($roff != $loff or !$len) {
1836 0           $sftp->_set_error(SFTP_ERR_REMOTE_BLOCK_TOO_SMALL,
1837             "remote packet received is too small" );
1838 0           last;
1839             }
1840              
1841 0           $loff += $len;
1842 0 0         unless ($safe_block_size) {
1843 0 0         if ($len > $sftp->{_min_block_size}) {
1844 0           $sftp->{min_block_size} = $len;
1845 0 0         if ($len < $block_size) {
1846             # auto-adjust block size
1847 0           $block_size = $len;
1848 0           $askoff = $loff;
1849             }
1850             }
1851 0           $safe_block_size = 1;
1852             }
1853              
1854 0           my $adjustment_before = $adjustment;
1855 0 0         $adjustment += $converter->($data) if $converter;
1856              
1857 0 0 0       if (length($data) and defined $cb) {
1858             # $size = $loff if ($loff > $size and $size != -1);
1859 0           local $\;
1860 0           $cb->($sftp, $data,
1861             $lstart + $roff + $adjustment_before,
1862             $lstart + $size + $adjustment);
1863              
1864 0 0         last if $sftp->{_error};
1865             }
1866              
1867 0 0 0       if (length($data) and !$dont_save) {
1868 0 0         unless (print $fh $data) {
1869 0           $sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
1870             "unable to write data to local file $local", $!);
1871 0           last;
1872             }
1873             }
1874             }
1875              
1876 0           $sftp->_get_msg_by_id($_) for @msgid;
1877              
1878 0 0         goto CLEANUP if $sftp->{_error};
1879              
1880             # if a converter is in place, and aditional call has to be
1881             # performed in order to flush any pending buffered data
1882 0 0         if ($converter) {
1883 0           my $data = '';
1884 0           my $adjustment_before = $adjustment;
1885 0           $adjustment += $converter->($data);
1886              
1887 0 0 0       if (length($data) and defined $cb) {
1888             # $size = $loff if ($loff > $size and $size != -1);
1889 0           local $\;
1890 0           $cb->($sftp, $data, $askoff + $adjustment_before, $size + $adjustment);
1891 0 0         goto CLEANUP if $sftp->{_error};
1892             }
1893              
1894 0 0 0       if (length($data) and !$dont_save) {
1895 0 0         unless (print $fh $data) {
1896 0           $sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
1897             "unable to write data to local file $local", $!);
1898 0           goto CLEANUP;
1899             }
1900             }
1901             }
1902              
1903             # we call the callback one last time with an empty string;
1904 0 0         if (defined $cb) {
1905 0           my $data = '';
1906 0           do {
1907 0           local $\;
1908 0           $cb->($sftp, $data, $askoff + $adjustment, $size + $adjustment);
1909             };
1910 0 0         return undef if $sftp->{_error};
1911 0 0 0       if (length($data) and !$dont_save) {
1912 0 0         unless (print $fh $data) {
1913 0           $sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
1914             "unable to write data to local file $local", $!);
1915 0           goto CLEANUP;
1916             }
1917             }
1918             }
1919              
1920 0 0         unless ($dont_save) {
1921 0 0 0       unless ($local_is_fh or CORE::close $fh) {
1922 0           $sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
1923             "unable to write data to local file $local", $!);
1924 0           goto CLEANUP;
1925             }
1926              
1927             # we can be running on taint mode, so some checks are
1928             # performed to untaint data from the remote side.
1929              
1930 0 0         if ($copy_time) {
1931 0 0 0       unless (utime($atime, $mtime, $local) or $best_effort) {
1932 0           $sftp->_set_error(SFTP_ERR_LOCAL_UTIME_FAILED,
1933             "Can't utime $local", $!);
1934 0           goto CLEANUP;
1935             }
1936             }
1937              
1938 0 0         if ($atomic) {
1939 0 0         if (!$overwrite) {
1940 0           while (1) {
1941             # performing a non-overwriting atomic rename is
1942             # quite burdensome: first, link is tried, if that
1943             # fails, non-overwriting is favoured over
1944             # atomicity and an empty file is used to lock the
1945             # path before atempting an overwriting rename.
1946 0 0         if (link $local, $atomic_local) {
1947 0           unlink $local;
1948 0           last;
1949             }
1950 0           my $err = $!;
1951 0 0         unless (-e $atomic_local) {
1952 0 0         if (sysopen my $lock, $atomic_local,
1953             Fcntl::O_CREAT|Fcntl::O_EXCL|Fcntl::O_WRONLY,
1954             0600) {
1955 0           $atomic_cleanup = 1;
1956 0           goto OVERWRITE;
1957             }
1958 0           $err = $!;
1959 0 0         unless (-e $atomic_local) {
1960 0           $sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED,
1961             "Can't open $local", $err);
1962 0           goto CLEANUP;
1963             }
1964             }
1965 0 0         unless ($numbered) {
1966 0           $sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,
1967             "local file $atomic_local already exists");
1968 0           goto CLEANUP;
1969             }
1970 0           _inc_numbered($atomic_local);
1971             }
1972             }
1973             else {
1974             OVERWRITE:
1975 0 0         unless (CORE::rename $local, $atomic_local) {
1976 0           $sftp->_set_error(SFTP_ERR_LOCAL_RENAME_FAILED,
1977             "Unable to rename temporal file to its final position '$atomic_local'", $!);
1978 0           goto CLEANUP;
1979             }
1980             }
1981 0 0         $$atomic_numbered = $local if ref $atomic_numbered;
1982             }
1983             }
1984             CLEANUP:
1985 0 0 0       if ($cleanup and $sftp->{_error}) {
1986 0           unlink $local;
1987 0 0         unlink $atomic_local if $atomic_cleanup;
1988             }
1989             }; # autodie flag is restored here!
1990              
1991 0           $sftp->_ok_or_autodie;
1992             }
1993              
1994             # return file contents on success, undef on failure
1995             sub get_content {
1996 0 0   0 1   @_ == 2 or croak 'Usage: $sftp->get_content($remote)';
1997 0 0         ${^TAINT} and &_catch_tainted_args;
1998              
1999 0           my ($sftp, $name) = @_;
2000             #$name = $sftp->_rel2abs($name);
2001 0           my @data;
2002              
2003 0 0         my $rfh = $sftp->open($name)
2004             or return undef;
2005              
2006 0           scalar $sftp->readline($rfh, undef);
2007             }
2008              
2009             sub put {
2010 0 0   0 1   @_ >= 2 or croak 'Usage: $sftp->put($local, $remote, %opts)';
2011 0 0         ${^TAINT} and &_catch_tainted_args;
2012              
2013 0           my ($sftp, $local, $remote, %opts) = @_;
2014 0 0         defined $local or croak "local file path is undefined";
2015              
2016 0           $sftp->_clear_error_and_status;
2017              
2018 0   0       my $local_is_fh = (ref $local and $local->isa('GLOB'));
2019 0 0         unless (defined $remote) {
2020 0 0         $local_is_fh and croak "unable to infer remote file name when a file handler is passed as local";
2021 0           $remote = (File::Spec->splitpath($local))[2];
2022             }
2023             # $remote = $sftp->_rel2abs($remote);
2024              
2025 0           my $cb = delete $opts{callback};
2026 0           my $umask = delete $opts{umask};
2027 0           my $perm = delete $opts{perm};
2028 0           my $copy_perm = delete $opts{copy_perm};
2029 0 0         $copy_perm = delete $opts{copy_perms} unless defined $copy_perm;
2030 0           my $copy_time = delete $opts{copy_time};
2031 0           my $overwrite = delete $opts{overwrite};
2032 0           my $resume = delete $opts{resume};
2033 0           my $append = delete $opts{append};
2034 0   0       my $block_size = delete $opts{block_size} || $sftp->{_block_size};
2035 0   0       my $queue_size = delete $opts{queue_size} || $sftp->{_queue_size};
2036 0           my $conversion = delete $opts{conversion};
2037 0           my $late_set_perm = delete $opts{late_set_perm};
2038 0           my $numbered = delete $opts{numbered};
2039 0           my $atomic = delete $opts{atomic};
2040 0           my $cleanup = delete $opts{cleanup};
2041 0           my $best_effort = delete $opts{best_effort};
2042 0           my $sparse = delete $opts{sparse};
2043 0           my $mkpath = delete $opts{mkpath};
2044              
2045 0 0 0       croak "'perm' and 'umask' options can not be used simultaneously"
2046             if (defined $perm and defined $umask);
2047 0 0 0       croak "'perm' and 'copy_perm' options can not be used simultaneously"
2048             if (defined $perm and $copy_perm);
2049 0 0 0       croak "'resume' and 'append' options can not be used simultaneously"
2050             if ($resume and $append);
2051 0 0 0       croak "'resume' and 'overwrite' options can not be used simultaneously"
2052             if ($resume and $overwrite);
2053 0 0 0       croak "'numbered' can not be used with 'overwrite', 'resume' or 'append'"
      0        
2054             if ($numbered and ($overwrite or $resume or $append));
2055 0 0 0       croak "'atomic' can not be used with 'resume' or 'append'"
      0        
2056             if ($atomic and ($resume or $append));
2057              
2058 0 0         %opts and _croak_bad_options(keys %opts);
2059              
2060 0 0 0       $overwrite = 1 unless (defined $overwrite or $numbered);
2061 0 0 0       $copy_perm = 1 unless (defined $perm or defined $copy_perm or $local_is_fh);
      0        
2062 0 0 0       $copy_time = 1 unless (defined $copy_time or $local_is_fh);
2063 0 0         $late_set_perm = $sftp->{_late_set_perm} unless defined $late_set_perm;
2064 0 0 0       $cleanup = ($atomic || $numbered) unless defined $cleanup;
2065 0 0         $mkpath = 1 unless defined $mkpath;
2066              
2067 0           my $neg_umask;
2068 0 0         if (defined $perm) {
2069 0           $neg_umask = $perm;
2070             }
2071             else {
2072 0 0         $umask = umask unless defined $umask;
2073 0           $neg_umask = 0777 & ~$umask;
2074             }
2075              
2076 0           my ($fh, $lmode, $lsize, $latime, $lmtime);
2077 0 0         if ($local_is_fh) {
2078 0           $fh = $local;
2079             # we don't set binmode for the passed file handle on purpose
2080             }
2081             else {
2082 0 0         unless (CORE::open $fh, '<', $local) {
2083 0           $sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED,
2084             "Unable to open local file '$local'", $!);
2085 0           return undef;
2086             }
2087 0           binmode $fh;
2088             }
2089              
2090             {
2091             # as $fh can come from the outside, it may be a tied object
2092             # lacking support for some methods, so we call them wrapped
2093             # inside eval blocks
2094 0           local ($@, $SIG{__DIE__}, $SIG{__WARN__});
  0            
2095 0 0 0       if ((undef, undef, $lmode, undef, undef,
    0 0        
    0          
2096             undef, undef, $lsize, $latime, $lmtime) =
2097             eval {
2098 3     3   62 no warnings; # Calling stat on a tied handler
  3         8  
  3         19163  
2099             # generates a warning because the op is
2100             # not supported by the tie API.
2101 0           CORE::stat $fh;
2102             }
2103             ) {
2104 0 0 0       $debug and $debug & 16384 and _debug "local file size is " . (defined $lsize ? $lsize : '');
    0          
2105              
2106             # $fh can point at some place inside the file, not just at the
2107             # begining
2108 0 0 0       if ($local_is_fh and defined $lsize) {
2109 0           my $tell = eval { CORE::tell $fh };
  0            
2110 0 0 0       $lsize -= $tell if $tell and $tell > 0;
2111             }
2112             }
2113             elsif ($copy_perm or $copy_time) {
2114 0           $sftp->_set_error(SFTP_ERR_LOCAL_STAT_FAILED,
2115             "Couldn't stat local file '$local'", $!);
2116 0           return undef;
2117             }
2118             elsif ($resume and $resume eq 'auto') {
2119 0 0 0       $debug and $debug & 16384 and _debug "not resuming because stat'ing the local file failed";
2120 0           undef $resume
2121             }
2122             }
2123              
2124 0 0         $perm = $lmode & $neg_umask if $copy_perm;
2125 0           my $attrs = Net::SFTP::Foreign::Attributes->new;
2126 0 0         $attrs->set_perm($perm) if defined $perm;
2127              
2128 0           my $rfh;
2129 0           my $writeoff = 0;
2130 0           my $converter = _gen_converter $conversion;
2131 0           my $converted_input = '';
2132 0           my $rattrs;
2133              
2134 0 0 0       if ($resume or $append) {
2135 0           $rattrs = do {
2136 0           local $sftp->{_autodie};
2137 0           $sftp->stat($remote);
2138             };
2139 0 0         if ($rattrs) {
2140 0 0 0       if ($resume and $resume eq 'auto' and $rattrs->mtime <= $lmtime) {
      0        
2141 0 0 0       $debug and $debug & 16384 and
2142             _debug "not resuming because local file is newer, r: ".$rattrs->mtime." l: $lmtime";
2143 0           undef $resume;
2144             }
2145             else {
2146 0           $writeoff = $rattrs->size;
2147 0 0 0       $debug and $debug & 16384 and _debug "resuming from $writeoff";
2148             }
2149             }
2150             else {
2151 0 0         if ($append) {
2152 0 0 0       $sftp->{_status} == SSH2_FX_NO_SUCH_FILE
2153             or $sftp->_ok_or_autodie or return undef;
2154             # no such file, no append
2155 0           undef $append;
2156             }
2157 0           $sftp->_clear_error_and_status;
2158             }
2159             }
2160              
2161 0           my ($atomic_numbered, $atomic_remote);
2162 0 0         if ($writeoff) {
2163             # one of $resume or $append is set
2164 0 0         if ($resume) {
2165 0 0 0       $debug and $debug & 16384 and _debug "resuming file transfer from $writeoff";
2166 0 0         if ($converter) {
    0          
2167             # as size could change, we have to read and convert
2168             # data until we reach the given position on the local
2169             # file:
2170 0           my $off = 0;
2171 0           my $eof_t;
2172 0           while (1) {
2173 0           my $len = length $converted_input;
2174 0           my $delta = $writeoff - $off;
2175 0 0         if ($delta <= $len) {
2176 0 0 0       $debug and $debug & 16384 and _debug "discarding $delta converted bytes";
2177 0           substr $converted_input, 0, $delta, '';
2178 0           last;
2179             }
2180             else {
2181 0           $off += $len;
2182 0 0         if ($eof_t) {
2183 0           $sftp->_set_error(SFTP_ERR_REMOTE_BIGGER_THAN_LOCAL,
2184             "Couldn't resume transfer, remote file is bigger than local");
2185 0           return undef;
2186             }
2187 0           my $read = CORE::read($fh, $converted_input, $block_size * 4);
2188 0 0         unless (defined $read) {
2189 0           $sftp->_set_error(SFTP_ERR_LOCAL_READ_ERROR,
2190             "Couldn't read from local file '$local' to the resume point $writeoff", $!);
2191 0           return undef;
2192             }
2193 0 0         $lsize += $converter->($converted_input) if defined $lsize;
2194 0 0         utf8::downgrade($converted_input, 1)
2195             or croak "converter introduced wide characters in data";
2196 0 0         $read or $eof_t = 1;
2197             }
2198             }
2199             }
2200             elsif ($local_is_fh) {
2201             # as some PerlIO layer could be installed on the $fh,
2202             # just seeking to the resume position will not be
2203             # enough. We have to read and discard data until the
2204             # desired offset is reached
2205 0           my $off = $writeoff;
2206 0           while ($off) {
2207 0 0         my $read = CORE::read($fh, my($buf), ($off < 16384 ? $off : 16384));
2208 0 0         if ($read) {
2209 0 0 0       $debug and $debug & 16384 and _debug "discarding $read bytes";
2210 0           $off -= $read;
2211             }
2212             else {
2213 0 0         $sftp->_set_error(defined $read
2214             ? ( SFTP_ERR_REMOTE_BIGGER_THAN_LOCAL,
2215             "Couldn't resume transfer, remote file is bigger than local")
2216             : ( SFTP_ERR_LOCAL_READ_ERROR,
2217             "Couldn't read from local file handler '$local' to the resume point $writeoff", $!));
2218             }
2219             }
2220             }
2221             else {
2222 0 0 0       if (defined $lsize and $writeoff > $lsize) {
2223 0           $sftp->_set_error(SFTP_ERR_REMOTE_BIGGER_THAN_LOCAL,
2224             "Couldn't resume transfer, remote file is bigger than local");
2225 0           return undef;
2226             }
2227 0 0         unless (CORE::seek($fh, $writeoff, 0)) {
2228 0           $sftp->_set_error(SFTP_ERR_LOCAL_SEEK_FAILED,
2229             "seek operation on local file failed: $!");
2230 0           return undef;
2231             }
2232             }
2233 0 0 0       if (defined $lsize and $writeoff == $lsize) {
2234 0 0 0       if (defined $perm and $rattrs->perm != $perm) {
2235             # FIXME: do copy_time here if required
2236 0           return $sftp->_best_effort($best_effort, setstat => $remote, $attrs);
2237             }
2238 0           return 1;
2239             }
2240             }
2241 0 0         $rfh = $sftp->open($remote, SSH2_FXF_WRITE)
2242             or return undef;
2243             }
2244             else {
2245 0 0         if ($atomic) {
2246             # check that does not exist a file of the same name that
2247             # would block the rename operation at the end
2248 0 0 0       if (!($numbered or $overwrite) and
      0        
2249             $sftp->test_e($remote)) {
2250 0           $sftp->_set_status(SSH2_FX_FAILURE);
2251 0           $sftp->_set_error(SFTP_ERR_REMOTE_ALREADY_EXISTS,
2252             "Remote file '$remote' already exists");
2253 0           return undef;
2254             }
2255 0           $atomic_remote = $remote;
2256 0           $remote .= sprintf("(%d).tmp", rand(10000));
2257 0           $atomic_numbered = $numbered;
2258 0           $numbered = 1;
2259 0 0 0       $debug and $debug & 128 and _debug("temporal remote file name: $remote");
2260             }
2261 0           local $sftp->{_autodie};
2262 0 0         if ($numbered) {
2263 0           while (1) {
2264 0           $rfh = $sftp->_open_mkpath($remote,
2265             $mkpath,
2266             SSH2_FXF_WRITE | SSH2_FXF_CREAT | SSH2_FXF_EXCL,
2267             $attrs);
2268             last if ($rfh or
2269 0 0 0       $sftp->{_status} != SSH2_FX_FAILURE or
      0        
2270             !$sftp->test_e($remote));
2271 0           _inc_numbered($remote);
2272             }
2273 0 0 0       $$numbered = $remote if $rfh and ref $numbered;
2274             }
2275             else {
2276             # open can fail due to a remote file with the wrong
2277             # permissions being already there. We are optimistic here,
2278             # first we try to open the remote file and if it fails due
2279             # to a permissions error then we remove it and try again.
2280 0           for my $rep (0, 1) {
2281 0 0         $rfh = $sftp->_open_mkpath($remote,
2282             $mkpath,
2283             SSH2_FXF_WRITE | SSH2_FXF_CREAT |
2284             ($overwrite ? SSH2_FXF_TRUNC : SSH2_FXF_EXCL),
2285             $attrs);
2286              
2287 0 0 0       last if $rfh or $rep or !$overwrite or $sftp->{_status} != SSH2_FX_PERMISSION_DENIED;
      0        
      0        
2288              
2289 0 0 0       $debug and $debug & 2 and _debug("retrying open after removing remote file");
2290 0           local ($sftp->{_status}, $sftp->{_error});
2291 0           $sftp->remove($remote);
2292             }
2293             }
2294             }
2295              
2296 0 0         $sftp->_ok_or_autodie or return undef;
2297             # Once this point is reached and for the remaining of the sub,
2298             # code should never return but jump into the CLEANUP block.
2299              
2300 0           my $last_block_was_zeros;
2301              
2302 0           do {
2303 0           local $sftp->{autodie};
2304              
2305             # In some SFTP server implementations, open does not set the
2306             # attributes for existent files so we do it again. The
2307             # $late_set_perm work around is for some servers that do not
2308             # support changing the permissions of open files
2309 0 0 0       if (defined $perm and !$late_set_perm) {
2310 0 0         $sftp->_best_effort($best_effort, setstat => $rfh, $attrs) or goto CLEANUP;
2311             }
2312              
2313 0           my $rfid = $sftp->_rfid($rfh);
2314 0 0         defined $rfid or die "internal error: rfid is undef";
2315              
2316             # In append mode we add the size of the remote file in
2317             # writeoff, if lsize is undef, we initialize it to $writeoff:
2318 0 0 0       $lsize += $writeoff if ($append or not defined $lsize);
2319              
2320             # when a converter is used, the EOF can become delayed by the
2321             # buffering introduced, we use $eof_t to account for that.
2322 0           my ($eof, $eof_t);
2323 0           my @msgid;
2324 0           OK: while (1) {
2325 0 0 0       if (!$eof and @msgid < $queue_size) {
2326 0           my ($data, $len);
2327 0 0         if ($converter) {
2328 0   0       while (!$eof_t and length $converted_input < $block_size) {
2329 0           my $read = CORE::read($fh, my $input, $block_size * 4);
2330 0 0         unless ($read) {
2331 0 0         unless (defined $read) {
2332 0           $sftp->_set_error(SFTP_ERR_LOCAL_READ_ERROR,
2333             "Couldn't read from local file '$local'", $!);
2334 0           last OK;
2335             }
2336 0           $eof_t = 1;
2337             }
2338              
2339             # note that the $converter is called a last time
2340             # with an empty string
2341 0           $lsize += $converter->($input);
2342 0 0         utf8::downgrade($input, 1)
2343             or croak "converter introduced wide characters in data";
2344 0           $converted_input .= $input;
2345             }
2346 0           $data = substr($converted_input, 0, $block_size, '');
2347 0           $len = length $data;
2348 0 0 0       $eof = 1 if ($eof_t and !$len);
2349             }
2350             else {
2351 0 0 0       $debug and $debug & 16384 and
2352             _debug "reading block at offset ".CORE::tell($fh)." block_size: $block_size";
2353              
2354 0           $len = CORE::read($fh, $data, $block_size);
2355              
2356 0 0         if ($len) {
2357 0 0 0       $debug and $debug & 16384 and _debug "block read, size: $len";
2358              
2359 0 0         utf8::downgrade($data, 1)
2360             or croak "wide characters unexpectedly read from file";
2361              
2362 0 0 0       $debug and $debug & 16384 and length $data != $len and
      0        
2363             _debug "read data changed size on downgrade to " . length($data);
2364             }
2365             else {
2366 0 0         unless (defined $len) {
2367 0           $sftp->_set_error(SFTP_ERR_LOCAL_READ_ERROR,
2368             "Couldn't read from local file '$local'", $!);
2369 0           last OK;
2370             }
2371 0           $eof = 1;
2372             }
2373             }
2374              
2375 0           my $nextoff = $writeoff + $len;
2376              
2377 0 0         if (defined $cb) {
2378 0 0         $lsize = $nextoff if $nextoff > $lsize;
2379 0           $cb->($sftp, $data, $writeoff, $lsize);
2380              
2381 0 0         last OK if $sftp->{_error};
2382              
2383 0 0         utf8::downgrade($data, 1) or croak "callback introduced wide characters in data";
2384              
2385 0           $len = length $data;
2386 0           $nextoff = $writeoff + $len;
2387             }
2388              
2389 0 0         if ($len) {
2390 0 0 0       if ($sparse and $data =~ /^\x{00}*$/s) {
2391 0           $last_block_was_zeros = 1;
2392 0 0 0       $debug and $debug & 16384 and _debug "skipping zeros block at offset $writeoff, length $len";
2393             }
2394             else {
2395 0 0 0       $debug and $debug & 16384 and _debug "writing block at offset $writeoff, length $len";
2396              
2397 0           my $id = $sftp->_queue_new_msg(SSH2_FXP_WRITE, str => $rfid,
2398             int64 => $writeoff, str => $data);
2399 0           push @msgid, $id;
2400 0           $last_block_was_zeros = 0;
2401             }
2402 0           $writeoff = $nextoff;
2403             }
2404             }
2405              
2406 0 0 0       last if ($eof and !@msgid);
2407              
2408 0 0 0       next unless ($eof
      0        
2409             or @msgid >= $queue_size
2410             or $sftp->_do_io(0));
2411              
2412 0           my $id = shift @msgid;
2413 0 0         unless ($sftp->_check_status_ok($id,
2414             SFTP_ERR_REMOTE_WRITE_FAILED,
2415             "Couldn't write to remote file")) {
2416 0           last OK;
2417             }
2418             }
2419              
2420 0 0         CORE::close $fh unless $local_is_fh;
2421              
2422 0           $sftp->_get_msg_by_id($_) for @msgid;
2423              
2424             $sftp->truncate($rfh, $writeoff)
2425 0 0 0       if $last_block_was_zeros and not $sftp->{_error};
2426              
2427 0           $sftp->_close_save_status($rfh);
2428              
2429 0 0         goto CLEANUP if $sftp->{_error};
2430              
2431             # set perm for servers that does not support setting
2432             # permissions on open files and also atime and mtime:
2433 0 0 0       if ($copy_time or ($late_set_perm and defined $perm)) {
      0        
2434 0 0 0       $attrs->set_perm unless $late_set_perm and defined $perm;
2435 0 0         $attrs->set_amtime($latime, $lmtime) if $copy_time;
2436 0 0         $sftp->_best_effort($best_effort, setstat => $remote, $attrs) or goto CLEANUP
2437             }
2438              
2439 0 0         if ($atomic) {
2440 0 0         $sftp->rename($remote, $atomic_remote,
2441             overwrite => $overwrite,
2442             numbered => $atomic_numbered) or goto CLEANUP;
2443             }
2444              
2445             CLEANUP:
2446 0 0 0       if ($cleanup and $sftp->{_error}) {
2447 0           warn "cleanup $remote";
2448 0           $sftp->_remove_save_status($remote);
2449             }
2450             };
2451 0           $sftp->_ok_or_autodie;
2452             }
2453              
2454             sub put_content {
2455 0 0   0 1   @_ >= 3 or croak 'Usage: $sftp->put_content($content, $remote, %opts)';
2456 0 0         ${^TAINT} and &_catch_tainted_args;
2457              
2458 0           my ($sftp, undef, $remote, %opts) = @_;
2459 0           my %put_opts = ( map { $_ => delete $opts{$_} }
  0            
2460             qw(perm umask block_size queue_size overwrite conversion resume
2461             numbered late_set_perm atomic best_effort mkpath));
2462 0 0         %opts and _croak_bad_options(keys %opts);
2463              
2464 0           my $fh;
2465 0 0         unless (CORE::open $fh, '<', \$_[1]) {
2466 0           $sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED, "Can't open scalar as file handle", $!);
2467 0           return undef;
2468             }
2469 0           $sftp->put($fh, $remote, %put_opts);
2470             }
2471              
2472             sub ls {
2473 0 0   0 1   @_ >= 1 or croak 'Usage: $sftp->ls($remote_dir, %opts)';
2474 0 0         ${^TAINT} and &_catch_tainted_args;
2475              
2476 0           my $sftp = shift;
2477 0 0         my %opts = @_ & 1 ? (dir => @_) : @_;
2478              
2479 0           my $dir = delete $opts{dir};
2480 0           my $ordered = delete $opts{ordered};
2481 0           my $follow_links = delete $opts{follow_links};
2482 0           my $atomic_readdir = delete $opts{atomic_readdir};
2483 0           my $names_only = delete $opts{names_only};
2484 0           my $realpath = delete $opts{realpath};
2485 0           my $queue_size = delete $opts{queue_size};
2486 0   0       my $cheap = ($names_only and !$realpath);
2487 0           my ($cheap_wanted, $wanted);
2488 0 0 0       if ($cheap and
      0        
2489             ref $opts{wanted} eq 'Regexp' and
2490             not defined $opts{no_wanted}) {
2491             $cheap_wanted = delete $opts{wanted}
2492 0           }
2493             else {
2494             $wanted = (delete $opts{_wanted} ||
2495             _gen_wanted(delete $opts{wanted},
2496 0   0       delete $opts{no_wanted}));
2497 0 0         undef $cheap if defined $wanted;
2498             }
2499              
2500 0 0         %opts and _croak_bad_options(keys %opts);
2501              
2502 0   0       my $delayed_wanted = ($atomic_readdir and $wanted);
2503 0 0 0       $queue_size = 1 if ($follow_links or $realpath or
      0        
      0        
2504             ($wanted and not $delayed_wanted));
2505 0   0       my $max_queue_size = $queue_size || $sftp->{_queue_size};
2506 0 0 0       $queue_size ||= ($max_queue_size < 2 ? $max_queue_size : 2);
2507              
2508 0 0         $dir = '.' unless defined $dir;
2509 0           $dir = $sftp->_rel2abs($dir);
2510              
2511 0           my $rdh = $sftp->opendir($dir);
2512 0 0         return unless defined $rdh;
2513              
2514 0           my $rdid = $sftp->_rdid($rdh);
2515 0 0         defined $rdid or return undef;
2516              
2517 0           my @dir;
2518             my @msgid;
2519              
2520 0           do {
2521 0           local $sftp->{_autodie};
2522 0           OK: while (1) {
2523 0           push @msgid, $sftp->_queue_str_request(SSH2_FXP_READDIR, $rdid)
2524             while (@msgid < $queue_size);
2525              
2526 0           my $id = shift @msgid;
2527 0 0         my $msg = $sftp->_get_msg_and_check(SSH2_FXP_NAME, $id,
2528             SFTP_ERR_REMOTE_READDIR_FAILED,
2529             "Couldn't read directory '$dir'" ) or last;
2530 0 0         my $count = $msg->get_int32 or last;
2531              
2532 0 0         if ($cheap) {
2533 0           for (1..$count) {
2534 0           my $fn = $sftp->_fs_decode($msg->get_str);
2535 0 0 0       push @dir, $fn if (!defined $cheap_wanted or $fn =~ $cheap_wanted);
2536 0           $msg->skip_str;
2537 0           Net::SFTP::Foreign::Attributes->skip_from_buffer($msg);
2538             }
2539             }
2540             else {
2541 0           for (1..$count) {
2542 0           my $fn = $sftp->_fs_decode($msg->get_str);
2543 0           my $ln = $sftp->_fs_decode($msg->get_str);
2544             # my $a = $msg->get_attributes;
2545 0           my $a = Net::SFTP::Foreign::Attributes->new_from_buffer($msg);
2546              
2547 0           my $entry = { filename => $fn,
2548             longname => $ln,
2549             a => $a };
2550              
2551 0 0 0       if ($follow_links and _is_lnk($a->perm)) {
2552              
2553 0 0         if ($a = $sftp->stat($sftp->join($dir, $fn))) {
2554 0           $entry->{a} = $a;
2555             }
2556             else {
2557 0           $sftp->_clear_error_and_status;
2558             }
2559             }
2560              
2561 0 0         if ($realpath) {
2562 0           my $rp = $sftp->realpath($sftp->join($dir, $fn));
2563 0 0         if (defined $rp) {
2564 0           $fn = $entry->{realpath} = $rp;
2565             }
2566             else {
2567 0           $sftp->_clear_error_and_status;
2568             }
2569             }
2570              
2571 0 0 0       if (!$wanted or $delayed_wanted or $wanted->($sftp, $entry)) {
      0        
2572 0 0 0       push @dir, (($names_only and !$delayed_wanted) ? $fn : $entry);
2573             }
2574             }
2575             }
2576 0 0         $queue_size++ if $queue_size < $max_queue_size;
2577             }
2578 0 0         $sftp->_set_error if $sftp->{_status} == SSH2_FX_EOF;
2579 0           $sftp->_get_msg_by_id($_) for @msgid;
2580 0 0         $sftp->_closedir_save_status($rdh) if $rdh;
2581             };
2582 0 0         unless ($sftp->{_error}) {
2583 0 0         if ($delayed_wanted) {
2584 0           @dir = grep { $wanted->($sftp, $_) } @dir;
  0            
2585 0 0         @dir = map { defined $_->{realpath}
2586             ? $_->{realpath}
2587 0 0         : $_->{filename} } @dir
2588             if $names_only;
2589             }
2590 0 0         if ($ordered) {
2591 0 0         if ($names_only) {
2592 0           @dir = sort @dir;
2593             }
2594             else {
2595 0           _sort_entries \@dir;
2596             }
2597             }
2598 0           return \@dir;
2599             }
2600 0 0         croak $sftp->{_error} if $sftp->{_autodie};
2601 0           return undef;
2602             }
2603              
2604             sub rremove {
2605 0 0   0 1   @_ >= 2 or croak 'Usage: $sftp->rremove($dirs, %opts)';
2606 0 0         ${^TAINT} and &_catch_tainted_args;
2607              
2608 0           my ($sftp, $dirs, %opts) = @_;
2609              
2610 0           my $on_error = delete $opts{on_error};
2611 0 0         local $sftp->{_autodie} if $on_error;
2612             my $wanted = _gen_wanted( delete $opts{wanted},
2613 0           delete $opts{no_wanted});
2614              
2615 0 0         %opts and _croak_bad_options(keys %opts);
2616              
2617 0           my $count = 0;
2618              
2619 0           my @dirs;
2620             $sftp->find( $dirs,
2621             on_error => $on_error,
2622             atomic_readdir => 1,
2623             wanted => sub {
2624 0     0     my $e = $_[1];
2625 0           my $fn = $e->{filename};
2626 0 0         if (_is_dir($e->{a}->perm)) {
2627 0           push @dirs, $e;
2628             }
2629             else {
2630 0 0 0       if (!$wanted or $wanted->($sftp, $e)) {
2631 0 0         if ($sftp->remove($fn)) {
2632 0           $count++;
2633             }
2634             else {
2635 0           $sftp->_call_on_error($on_error, $e);
2636             }
2637             }
2638             }
2639 0           } );
2640              
2641 0           _sort_entries(\@dirs);
2642              
2643 0           while (@dirs) {
2644 0           my $e = pop @dirs;
2645 0 0 0       if (!$wanted or $wanted->($sftp, $e)) {
2646 0 0         if ($sftp->rmdir($e->{filename})) {
2647 0           $count++;
2648             }
2649             else {
2650 0           $sftp->_call_on_error($on_error, $e);
2651             }
2652             }
2653             }
2654              
2655 0           return $count;
2656             }
2657              
2658             sub get_symlink {
2659 0 0   0 1   @_ >= 3 or croak 'Usage: $sftp->get_symlink($remote, $local, %opts)';
2660 0           my ($sftp, $remote, $local, %opts) = @_;
2661 0           my $overwrite = delete $opts{overwrite};
2662 0           my $numbered = delete $opts{numbered};
2663              
2664 0 0 0       croak "'overwrite' and 'numbered' can not be used together"
2665             if ($overwrite and $numbered);
2666 0 0         %opts and _croak_bad_options(keys %opts);
2667              
2668 0 0 0       $overwrite = 1 unless (defined $overwrite or $numbered);
2669              
2670 0 0         my $a = $sftp->lstat($remote) or return undef;
2671 0 0         unless (_is_lnk($a->perm)) {
2672 0           $sftp->_set_error(SFTP_ERR_REMOTE_BAD_OBJECT,
2673             "Remote object '$remote' is not a symlink");
2674 0           return undef;
2675             }
2676              
2677 0 0         my $link = $sftp->readlink($remote) or return undef;
2678              
2679             # TODO: this is too weak, may contain race conditions.
2680 0 0         if ($numbered) {
    0          
2681 0           _inc_numbered($local) while -e $local;
2682             }
2683             elsif (-e $local) {
2684 0 0         if ($overwrite) {
2685 0           unlink $local;
2686             }
2687             else {
2688 0           $sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,
2689             "local file $local already exists");
2690             return undef
2691 0           }
2692             }
2693              
2694 0 0         unless (eval { CORE::symlink $link, $local }) {
  0            
2695 0           $sftp->_set_error(SFTP_ERR_LOCAL_SYMLINK_FAILED,
2696             "creation of symlink '$local' failed", $!);
2697 0           return undef;
2698             }
2699 0 0         $$numbered = $local if ref $numbered;
2700              
2701 0           1;
2702             }
2703              
2704             sub put_symlink {
2705 0 0   0 1   @_ >= 3 or croak 'Usage: $sftp->put_symlink($local, $remote, %opts)';
2706 0           my ($sftp, $local, $remote, %opts) = @_;
2707 0           my $overwrite = delete $opts{overwrite};
2708 0           my $numbered = delete $opts{numbered};
2709              
2710 0 0 0       croak "'overwrite' and 'numbered' can not be used together"
2711             if ($overwrite and $numbered);
2712 0 0         %opts and _croak_bad_options(keys %opts);
2713              
2714 0 0 0       $overwrite = 1 unless (defined $overwrite or $numbered);
2715 0           my $perm = (CORE::lstat $local)[2];
2716 0 0         unless (defined $perm) {
2717 0           $sftp->_set_error(SFTP_ERR_LOCAL_STAT_FAILED,
2718             "Couldn't stat local file '$local'", $!);
2719 0           return undef;
2720             }
2721 0 0         unless (_is_lnk($perm)) {
2722 0           $sftp->_set_error(SFTP_ERR_LOCAL_BAD_OBJECT,
2723             "Local file $local is not a symlink");
2724 0           return undef;
2725             }
2726 0           my $target = readlink $local;
2727 0 0         unless (defined $target) {
2728 0           $sftp->_set_error(SFTP_ERR_LOCAL_READLINK_FAILED,
2729             "Couldn't read link '$local'", $!);
2730 0           return undef;
2731             }
2732              
2733 0           while (1) {
2734 0           local $sftp->{_autodie};
2735 0           $sftp->symlink($remote, $target);
2736 0 0 0       if ($sftp->{_error} and
2737             $sftp->{_status} == SSH2_FX_FAILURE) {
2738 0 0 0       if ($numbered and $sftp->test_e($remote)) {
    0 0        
2739 0           _inc_numbered($remote);
2740 0           redo;
2741             }
2742             elsif ($overwrite and $sftp->_remove_save_status($remote)) {
2743 0           $overwrite = 0;
2744 0           redo;
2745             }
2746             }
2747             last
2748 0           }
2749 0 0         $$numbered = $remote if ref $numbered;
2750 0           $sftp->_ok_or_autodie;
2751             }
2752              
2753             sub rget {
2754 0 0   0 1   @_ >= 2 or croak 'Usage: $sftp->rget($remote, $local, %opts)';
2755 0 0         ${^TAINT} and &_catch_tainted_args;
2756 0           my ($sftp, $remote, $local, %opts) = @_;
2757              
2758 0 0         defined $remote or croak "remote file path is undefined";
2759 0 0         $local = File::Spec->curdir unless defined $local;
2760              
2761             # my $cb = delete $opts{callback};
2762 0           my $umask = delete $opts{umask};
2763 0 0         my $copy_perm = delete $opts{exists $opts{copy_perm} ? 'copy_perm' : 'copy_perms'};
2764 0           my $copy_time = delete $opts{copy_time};
2765 0           my $newer_only = delete $opts{newer_only};
2766 0           my $on_error = delete $opts{on_error};
2767 0 0         local $sftp->{_autodie} if $on_error;
2768 0           my $ignore_links = delete $opts{ignore_links};
2769 0           my $mkpath = delete $opts{mkpath};
2770              
2771             # my $relative_links = delete $opts{relative_links};
2772              
2773             my $wanted = _gen_wanted( delete $opts{wanted},
2774 0           delete $opts{no_wanted} );
2775              
2776 0           my %get_opts = (map { $_ => delete $opts{$_} }
  0            
2777             qw(block_size queue_size overwrite conversion
2778             resume numbered atomic best_effort));
2779              
2780 0 0 0       if ($get_opts{resume} and $get_opts{conversion}) {
2781 0           carp "resume option is useless when data conversion has also been requested";
2782 0           delete $get_opts{resume};
2783             }
2784              
2785 0           my %get_symlink_opts = (map { $_ => $get_opts{$_} }
  0            
2786             qw(overwrite numbered));
2787              
2788 0 0         %opts and _croak_bad_options(keys %opts);
2789              
2790 0           $remote = $sftp->join($remote, './');
2791 0           my $qremote = quotemeta $remote;
2792 0           my $reremote = qr/^$qremote(.*)$/i;
2793              
2794 0           my $save = _umask_save_and_set $umask;
2795              
2796 0 0         $copy_perm = 1 unless defined $copy_perm;
2797 0 0         $copy_time = 1 unless defined $copy_time;
2798 0 0         $mkpath = 1 unless defined $mkpath;
2799              
2800 0           my $count = 0;
2801             $sftp->find( [$remote],
2802             descend => sub {
2803 0     0     my $e = $_[1];
2804             # print "descend: $e->{filename}\n";
2805 0 0 0       if (!$wanted or $wanted->($sftp, $e)) {
2806 0           my $fn = $e->{filename};
2807 0 0         if ($fn =~ $reremote) {
2808 0           my $lpath = File::Spec->catdir($local, $1);
2809 0 0         ($lpath) = $lpath =~ /(.*)/ if ${^TAINT};
2810 0 0         if (-d $lpath) {
2811 0           $sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,
2812             "directory '$lpath' already exists");
2813 0           $sftp->_call_on_error($on_error, $e);
2814 0           return 1;
2815             }
2816             else {
2817 0 0         my $perm = ($copy_perm ? $e->{a}->perm & 0777 : 0777);
2818 0 0 0       if (CORE::mkdir($lpath, $perm) or
      0        
2819             ($mkpath and $sftp->_mkpath_local($lpath, $perm))) {
2820 0           $count++;
2821 0           return 1;
2822             }
2823 0           $sftp->_set_error(SFTP_ERR_LOCAL_MKDIR_FAILED,
2824             "mkdir '$lpath' failed", $!);
2825             }
2826             }
2827             else {
2828 0           $sftp->_set_error(SFTP_ERR_REMOTE_BAD_PATH,
2829             "bad remote path '$fn'");
2830             }
2831 0           $sftp->_call_on_error($on_error, $e);
2832             }
2833 0           return undef;
2834             },
2835             wanted => sub {
2836 0     0     my $e = $_[1];
2837 0 0         unless (_is_dir($e->{a}->perm)) {
2838 0 0 0       if (!$wanted or $wanted->($sftp, $e)) {
2839 0           my $fn = $e->{filename};
2840 0 0         if ($fn =~ $reremote) {
2841 0 0         my $lpath = ((length $1) ? File::Spec->catfile($local, $1) : $local);
2842             # print "file fn:$e->{filename}, lpath:$lpath, re:$reremote\n";
2843 0 0         ($lpath) = $lpath =~ /(.*)/ if ${^TAINT};
2844 0 0 0       if (_is_lnk($e->{a}->perm) and !$ignore_links) {
    0          
2845 0 0         if ($sftp->get_symlink($fn, $lpath,
2846             # copy_time => $copy_time,
2847             %get_symlink_opts)) {
2848 0           $count++;
2849 0           return undef;
2850             }
2851             }
2852             elsif (_is_reg($e->{a}->perm)) {
2853 0 0 0       if ($newer_only and -e $lpath
      0        
2854             and (CORE::stat _)[9] >= $e->{a}->mtime) {
2855 0           $sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,
2856             "newer local file '$lpath' already exists");
2857             }
2858             else {
2859 0 0         if ($sftp->get($fn, $lpath,
2860             copy_perm => $copy_perm,
2861             copy_time => $copy_time,
2862             %get_opts)) {
2863 0           $count++;
2864 0           return undef;
2865             }
2866             }
2867             }
2868             else {
2869 0 0         $sftp->_set_error(SFTP_ERR_REMOTE_BAD_OBJECT,
2870             ( $ignore_links
2871             ? "remote file '$fn' is not regular file or directory"
2872             : "remote file '$fn' is not regular file, directory or link"));
2873             }
2874             }
2875             else {
2876 0           $sftp->_set_error(SFTP_ERR_REMOTE_BAD_PATH,
2877             "bad remote path '$fn'");
2878             }
2879 0           $sftp->_call_on_error($on_error, $e);
2880             }
2881             }
2882 0           return undef;
2883 0           } );
2884              
2885 0           return $count;
2886             }
2887              
2888             sub rput {
2889 0 0   0 1   @_ >= 2 or croak 'Usage: $sftp->rput($local, $remote, %opts)';
2890 0 0         ${^TAINT} and &_catch_tainted_args;
2891              
2892 0           my ($sftp, $local, $remote, %opts) = @_;
2893              
2894 0 0         defined $local or croak "local path is undefined";
2895 0 0         $remote = '.' unless defined $remote;
2896              
2897             # my $cb = delete $opts{callback};
2898 0           my $umask = delete $opts{umask};
2899 0           my $perm = delete $opts{perm};
2900 0 0         my $copy_perm = delete $opts{exists $opts{copy_perm} ? 'copy_perm' : 'copy_perms'};
2901 0           my $copy_time = delete $opts{copy_time};
2902              
2903 0           my $newer_only = delete $opts{newer_only};
2904 0           my $on_error = delete $opts{on_error};
2905 0 0         local $sftp->{_autodie} if $on_error;
2906 0           my $ignore_links = delete $opts{ignore_links};
2907 0           my $mkpath = delete $opts{mkpath};
2908              
2909             my $wanted = _gen_wanted( delete $opts{wanted},
2910 0           delete $opts{no_wanted} );
2911              
2912 0           my %put_opts = (map { $_ => delete $opts{$_} }
  0            
2913             qw(block_size queue_size overwrite
2914             conversion resume numbered
2915             late_set_perm atomic best_effort
2916             sparse));
2917              
2918 0           my %put_symlink_opts = (map { $_ => $put_opts{$_} }
  0            
2919             qw(overwrite numbered));
2920              
2921 0 0 0       croak "'perm' and 'umask' options can not be used simultaneously"
2922             if (defined $perm and defined $umask);
2923 0 0 0       croak "'perm' and 'copy_perm' options can not be used simultaneously"
2924             if (defined $perm and $copy_perm);
2925              
2926 0 0         %opts and _croak_bad_options(keys %opts);
2927              
2928 0           require Net::SFTP::Foreign::Local;
2929 0           my $lfs = Net::SFTP::Foreign::Local->new;
2930              
2931 0           $local = $lfs->join($local, './');
2932 0           my $relocal;
2933 0 0         if ($local =~ m|^\./?$|) {
2934 0           $relocal = qr/^(.*)$/;
2935             }
2936             else {
2937 0           my $qlocal = quotemeta $local;
2938 0           $relocal = qr/^$qlocal(.*)$/i;
2939             }
2940              
2941 0 0         $copy_perm = 1 unless defined $copy_perm;
2942 0 0         $copy_time = 1 unless defined $copy_time;
2943 0 0         $mkpath = 1 unless defined $mkpath;
2944              
2945 0           my $mask;
2946 0 0         if (defined $perm) {
2947 0           $mask = $perm & 0777;
2948             }
2949             else {
2950 0 0         $umask = umask unless defined $umask;
2951 0           $mask = 0777 & ~$umask;
2952             }
2953              
2954 0 0         if ($on_error) {
2955 0           my $on_error1 = $on_error;
2956             $on_error = sub {
2957 0     0     my $lfs = shift;
2958 0           $sftp->_copy_error($lfs);
2959 0           $sftp->_call_on_error($on_error1, @_);
2960             }
2961 0           }
2962              
2963 0           my $count = 0;
2964             $lfs->find( [$local],
2965             descend => sub {
2966 0     0     my $e = $_[1];
2967             # print "descend: $e->{filename}\n";
2968 0 0 0       if (!$wanted or $wanted->($lfs, $e)) {
2969 0           my $fn = $e->{filename};
2970 0 0 0       $debug and $debug & 32768 and _debug "rput handling $fn";
2971 0 0         if ($fn =~ $relocal) {
2972 0           my $rpath = $sftp->join($remote, File::Spec->splitdir($1));
2973 0 0 0       $debug and $debug & 32768 and _debug "rpath: $rpath";
2974 0           my $a = Net::SFTP::Foreign::Attributes->new;
2975 0 0         if (defined $perm) {
    0          
2976 0           $a->set_perm($mask | 0300);
2977             }
2978             elsif ($copy_perm) {
2979 0           $a->set_perm($e->{a}->perm & $mask);
2980             }
2981 0 0         if ($sftp->mkdir($rpath, $a)) {
2982 0           $count++;
2983 0           return 1;
2984             }
2985 0 0 0       if ($mkpath and
2986             $sftp->status == SSH2_FX_NO_SUCH_FILE) {
2987 0           $sftp->_clear_error_and_status;
2988 0 0         if ($sftp->mkpath($rpath, $a)) {
2989 0           $count++;
2990 0           return 1;
2991             }
2992             }
2993 0           $lfs->_copy_error($sftp);
2994 0 0         if ($sftp->test_d($rpath)) {
2995 0           $lfs->_set_error(SFTP_ERR_REMOTE_ALREADY_EXISTS,
2996             "Remote directory '$rpath' already exists");
2997 0           $lfs->_call_on_error($on_error, $e);
2998 0           return 1;
2999             }
3000             }
3001             else {
3002 0           $lfs->_set_error(SFTP_ERR_LOCAL_BAD_PATH,
3003             "Bad local path '$fn'");
3004             }
3005 0           $lfs->_call_on_error($on_error, $e);
3006             }
3007 0           return undef;
3008             },
3009             wanted => sub {
3010 0     0     my $e = $_[1];
3011             # print "file fn:$e->{filename}, a:$e->{a}\n";
3012 0 0         unless (_is_dir($e->{a}->perm)) {
3013 0 0 0       if (!$wanted or $wanted->($lfs, $e)) {
3014 0           my $fn = $e->{filename};
3015 0 0 0       $debug and $debug & 32768 and _debug "rput handling $fn";
3016 0 0         if ($fn =~ $relocal) {
3017 0           my (undef, $d, $f) = File::Spec->splitpath($1);
3018 0           my $rpath = $sftp->join($remote, File::Spec->splitdir($d), $f);
3019 0 0 0       if (_is_lnk($e->{a}->perm) and !$ignore_links) {
    0          
3020 0 0         if ($sftp->put_symlink($fn, $rpath,
3021             %put_symlink_opts)) {
3022 0           $count++;
3023 0           return undef;
3024             }
3025 0           $lfs->_copy_error($sftp);
3026             }
3027             elsif (_is_reg($e->{a}->perm)) {
3028 0           my $ra;
3029 0 0 0       if ( $newer_only and
      0        
3030             $ra = $sftp->stat($rpath) and
3031             $ra->mtime >= $e->{a}->mtime) {
3032 0           $lfs->_set_error(SFTP_ERR_REMOTE_ALREADY_EXISTS,
3033             "Newer remote file '$rpath' already exists");
3034             }
3035             else {
3036 0 0         if ($sftp->put($fn, $rpath,
    0          
    0          
3037             ( defined($perm) ? (perm => $perm)
3038             : $copy_perm ? (perm => $e->{a}->perm & $mask)
3039             : (copy_perm => 0, umask => $umask) ),
3040             copy_time => $copy_time,
3041             %put_opts)) {
3042 0           $count++;
3043 0           return undef;
3044             }
3045 0           $lfs->_copy_error($sftp);
3046             }
3047             }
3048             else {
3049 0 0         $lfs->_set_error(SFTP_ERR_LOCAL_BAD_OBJECT,
3050             ( $ignore_links
3051             ? "Local file '$fn' is not regular file or directory"
3052             : "Local file '$fn' is not regular file, directory or link"));
3053             }
3054             }
3055             else {
3056 0           $lfs->_set_error(SFTP_ERR_LOCAL_BAD_PATH,
3057             "Bad local path '$fn'");
3058             }
3059 0           $lfs->_call_on_error($on_error, $e);
3060             }
3061             }
3062 0           return undef;
3063 0           } );
3064              
3065 0           return $count;
3066             }
3067              
3068             sub mget {
3069 0 0   0 1   @_ >= 2 or croak 'Usage: $sftp->mget($remote, $localdir, %opts)';
3070 0 0         ${^TAINT} and &_catch_tainted_args;
3071              
3072 0           my ($sftp, $remote, $localdir, %opts) = @_;
3073              
3074 0 0         defined $remote or croak "remote pattern is undefined";
3075              
3076 0           my $on_error = $opts{on_error};
3077 0 0         local $sftp->{_autodie} if $on_error;
3078 0           my $ignore_links = delete $opts{ignore_links};
3079              
3080 0           my %glob_opts = (map { $_ => delete $opts{$_} }
  0            
3081             qw(on_error follow_links ignore_case
3082             wanted no_wanted strict_leading_dot));
3083              
3084 0           my %get_symlink_opts = (map { $_ => $opts{$_} }
  0            
3085             qw(overwrite numbered));
3086              
3087 0           my %get_opts = (map { $_ => delete $opts{$_} }
  0            
3088             qw(umask perm copy_perm copy_time block_size queue_size
3089             overwrite conversion resume numbered atomic best_effort mkpath));
3090              
3091 0 0         %opts and _croak_bad_options(keys %opts);
3092              
3093 0           my @remote = map $sftp->glob($_, %glob_opts), _ensure_list $remote;
3094              
3095 0           my $count = 0;
3096              
3097 0           require File::Spec;
3098 0           for my $e (@remote) {
3099 0           my $perm = $e->{a}->perm;
3100 0 0         if (_is_dir($perm)) {
3101 0           $sftp->_set_error(SFTP_ERR_REMOTE_BAD_OBJECT,
3102             "Remote object '$e->{filename}' is a directory");
3103             }
3104             else {
3105 0           my $fn = $e->{filename};
3106 0           my ($local) = $fn =~ m{([^\\/]*)$};
3107              
3108 0 0         $local = File::Spec->catfile($localdir, $local)
3109             if defined $localdir;
3110              
3111 0 0         if (_is_lnk($perm)) {
3112 0 0         next if $ignore_links;
3113 0           $sftp->get_symlink($fn, $local, %get_symlink_opts);
3114             }
3115             else {
3116 0           $sftp->get($fn, $local, %get_opts);
3117             }
3118             }
3119 0 0         $count++ unless $sftp->{_error};
3120 0           $sftp->_call_on_error($on_error, $e);
3121             }
3122 0           $count;
3123             }
3124              
3125             sub mput {
3126 0 0   0 1   @_ >= 2 or croak 'Usage: $sftp->mput($local, $remotedir, %opts)';
3127              
3128 0           my ($sftp, $local, $remotedir, %opts) = @_;
3129              
3130 0 0         defined $local or die "local pattern is undefined";
3131              
3132 0           my $on_error = $opts{on_error};
3133 0 0         local $sftp->{_autodie} if $on_error;
3134 0           my $ignore_links = delete $opts{ignore_links};
3135              
3136 0           my %glob_opts = (map { $_ => delete $opts{$_} }
  0            
3137             qw(on_error follow_links ignore_case
3138             wanted no_wanted strict_leading_dot));
3139 0           my %put_symlink_opts = (map { $_ => $opts{$_} }
  0            
3140             qw(overwrite numbered));
3141              
3142 0           my %put_opts = (map { $_ => delete $opts{$_} }
  0            
3143             qw(umask perm copy_perm copy_time block_size queue_size
3144             overwrite conversion resume numbered late_set_perm
3145             atomic best_effort sparse mkpath));
3146              
3147 0 0         %opts and _croak_bad_options(keys %opts);
3148              
3149 0           require Net::SFTP::Foreign::Local;
3150 0           my $lfs = Net::SFTP::Foreign::Local->new;
3151 0           my @local = map $lfs->glob($_, %glob_opts), _ensure_list $local;
3152              
3153 0           my $count = 0;
3154 0           require File::Spec;
3155 0           for my $e (@local) {
3156 0           my $perm = $e->{a}->perm;
3157 0 0         if (_is_dir($perm)) {
3158 0           $sftp->_set_error(SFTP_ERR_REMOTE_BAD_OBJECT,
3159             "Remote object '$e->{filename}' is a directory");
3160             }
3161             else {
3162 0           my $fn = $e->{filename};
3163 0           my $remote = (File::Spec->splitpath($fn))[2];
3164 0 0         $remote = $sftp->join($remotedir, $remote)
3165             if defined $remotedir;
3166              
3167 0 0         if (_is_lnk($perm)) {
3168 0 0         next if $ignore_links;
3169 0           $sftp->put_symlink($fn, $remote, %put_symlink_opts);
3170             }
3171             else {
3172 0           $sftp->put($fn, $remote, %put_opts);
3173             }
3174             }
3175 0 0         $count++ unless $sftp->{_error};
3176 0           $sftp->_call_on_error($on_error, $e);
3177             }
3178 0           $count;
3179             }
3180              
3181             sub fsync {
3182 0 0   0 1   @_ == 2 or croak 'Usage: $sftp->fsync($fh)';
3183 0 0         ${^TAINT} and &_catch_tainted_args;
3184              
3185 0           my ($sftp, $fh) = @_;
3186              
3187 0           $sftp->flush($fh, "out");
3188 0 0         $sftp->_check_extension('fsync@openssh.com' => 1,
3189             SFTP_ERR_REMOTE_FSYNC_FAILED,
3190             "fsync failed, not implemented")
3191             or return undef;
3192              
3193 0           my $id = $sftp->_queue_new_msg(SSH2_FXP_EXTENDED,
3194             str => 'fsync@openssh.com',
3195             str => $sftp->_rid($fh));
3196 0 0         if ($sftp->_check_status_ok($id,
3197             SFTP_ERR_REMOTE_FSYNC_FAILED,
3198             "Couldn't fsync remote file")) {
3199 0           return 1;
3200             }
3201 0           return undef;
3202             }
3203              
3204             sub statvfs {
3205 0 0   0 1   @_ == 2 or croak 'Usage: $sftp->statvfs($path_or_fh)';
3206 0 0         ${^TAINT} and &_catch_tainted_args;
3207              
3208 0           my ($sftp, $pofh) = @_;
3209 0 0 0       my ($extension, $arg) = ( (ref $pofh and UNIVERSAL::isa($pofh, 'Net::SFTP::Foreign::FileHandle'))
3210             ? ('fstatvfs@openssh.com', $sftp->_rid($pofh) )
3211             : ('statvfs@openssh.com' , $sftp->_fs_encode($sftp->_rel2abs($pofh)) ) );
3212              
3213 0 0         $sftp->_check_extension($extension => 2,
3214             SFTP_ERR_REMOTE_STATVFS_FAILED,
3215             "statvfs failed, not implemented")
3216             or return undef;
3217              
3218 0           my $id = $sftp->_queue_new_msg(SSH2_FXP_EXTENDED,
3219             str => $extension,
3220             str => $arg);
3221              
3222 0 0         if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_EXTENDED_REPLY, $id,
3223             SFTP_ERR_REMOTE_STATVFS_FAILED,
3224             "Couldn't stat remote file system")) {
3225 0           my %statvfs = map { $_ => $msg->get_int64 } qw(bsize frsize blocks
  0            
3226             bfree bavail files ffree
3227             favail fsid flag namemax);
3228 0           return \%statvfs;
3229             }
3230 0           return undef;
3231             }
3232              
3233             sub fstatvfs {
3234 0     0 1   _deprecated "fstatvfs is deprecated and will be removed on the upcoming 2.xx series, "
3235             . "statvfs method accepts now both file handlers and paths";
3236 0           goto &statvfs;
3237             }
3238              
3239             package Net::SFTP::Foreign::Handle;
3240              
3241 3     3   1663 use Tie::Handle;
  3         5144  
  3         5204  
3242             our @ISA = qw(Tie::Handle);
3243             our @CARP_NOT = qw(Net::SFTP::Foreign Tie::Handle);
3244              
3245             my $gen_accessor = sub {
3246             my $ix = shift;
3247             sub {
3248 0     0     my $st = *{shift()}{ARRAY};
  0            
3249 0 0         if (@_) {
3250 0           $st->[$ix] = shift;
3251             }
3252             else {
3253 0           $st->[$ix]
3254             }
3255             }
3256             };
3257              
3258             my $gen_proxy_method = sub {
3259             my $method = shift;
3260             sub {
3261 0     0     my $self = $_[0];
3262 0 0         $self->_check
3263             or return undef;
3264              
3265 0           my $sftp = $self->_sftp;
3266 0 0         if (wantarray) {
3267 0           my @ret = $sftp->$method(@_);
3268 0 0         $sftp->_set_errno unless @ret;
3269 0           return @ret;
3270             }
3271             else {
3272 0           my $ret = $sftp->$method(@_);
3273 0 0         $sftp->_set_errno unless defined $ret;
3274 0           return $ret;
3275             }
3276             }
3277             };
3278              
3279             my $gen_not_supported = sub {
3280             sub {
3281 0     0     $! = Errno::ENOTSUP();
3282             undef
3283 0           }
3284             };
3285              
3286 0     0     sub TIEHANDLE { return shift }
3287              
3288             # sub UNTIE {}
3289              
3290             sub _new_from_rid {
3291 0     0     my $class = shift;
3292 0           my $sftp = shift;
3293 0           my $rid = shift;
3294 0   0       my $flags = shift || 0;
3295              
3296 0           my $self = Symbol::gensym;
3297 0           bless $self, $class;
3298 0           *$self = [ $sftp, $rid, 0, $flags, @_];
3299 0           tie *$self, $self;
3300              
3301 0           $self;
3302             }
3303              
3304             sub _close {
3305 0     0     my $self = shift;
3306 0           @{*{$self}{ARRAY}} = ();
  0            
  0            
3307             }
3308              
3309             sub _check {
3310 0 0   0     return 1 if defined(*{shift()}{ARRAY}[0]);
  0            
3311 0           $! = Errno::EBADF();
3312 0           undef;
3313             }
3314              
3315             sub FILENO {
3316 0     0     my $self = shift;
3317 0 0         $self->_check
3318             or return undef;
3319              
3320 0           my $hrid = unpack 'H*' => $self->_rid;
3321 0           "-1:sftp(0x$hrid)"
3322             }
3323              
3324 0     0     sub _sftp { *{shift()}{ARRAY}[0] }
  0            
3325 0     0     sub _rid { *{shift()}{ARRAY}[1] }
  0            
3326              
3327             * _pos = $gen_accessor->(2);
3328              
3329             sub _inc_pos {
3330 0     0     my ($self, $inc) = @_;
3331 0           *{shift()}{ARRAY}[2] += $inc;
  0            
3332             }
3333              
3334              
3335             my %flag_bit = (append => 0x1);
3336              
3337             sub _flag {
3338 0     0     my $st = *{shift()}{ARRAY};
  0            
3339 0           my $fn = shift;
3340 0           my $flag = $flag_bit{$fn};
3341 0 0         Carp::croak("unknown flag $fn") unless defined $flag;
3342 0 0         if (@_) {
3343 0 0         if (shift) {
3344 0           $st->[3] |= $flag;
3345             }
3346             else {
3347 0           $st->[3] &= ~$flag;
3348             }
3349             }
3350 0 0         $st->[3] & $flag ? 1 : 0
3351             }
3352              
3353             sub _check_is_file {
3354 0     0     Carp::croak("expecting remote file handler, got directory handler");
3355             }
3356             sub _check_is_dir {
3357 0     0     Carp::croak("expecting remote directory handler, got file handler");
3358             }
3359              
3360             my $autoloaded;
3361             sub AUTOLOAD {
3362 0     0     my $self = shift;
3363 0           our $AUTOLOAD;
3364 0 0         if ($autoloaded) {
3365 0   0       my $class = ref $self || $self;
3366 0           Carp::croak qq|Can't locate object method "$AUTOLOAD" via package "$class|;
3367             }
3368             else {
3369 0           $autoloaded = 1;
3370 0           require IO::File;
3371 0           require IO::Dir;
3372 0           my ($method) = $AUTOLOAD =~ /^.*::(.*)$/;
3373 0           $self->$method(@_);
3374             }
3375             }
3376              
3377             package Net::SFTP::Foreign::FileHandle;
3378             our @ISA = qw(Net::SFTP::Foreign::Handle IO::File);
3379              
3380             sub _new_from_rid {
3381 0     0     my $class = shift;
3382 0           my $sftp = shift;
3383 0           my $rid = shift;
3384 0           my $flags = shift;
3385              
3386 0           my $self = $class->SUPER::_new_from_rid($sftp, $rid, $flags, '', '');
3387             }
3388              
3389       0     sub _check_is_file {}
3390              
3391 0     0     sub _bin { \(*{shift()}{ARRAY}[4]) }
  0            
3392 0     0     sub _bout { \(*{shift()}{ARRAY}[5]) }
  0            
3393              
3394             sub WRITE {
3395 0     0     my ($self, undef, $length, $offset) = @_;
3396 0 0         $self->_check
3397             or return undef;
3398              
3399 0 0         $offset = 0 unless defined $offset;
3400 0 0         $offset = length $_[1] + $offset if $offset < 0;
3401 0 0         $length = length $_[1] unless defined $length;
3402              
3403 0           my $sftp = $self->_sftp;
3404              
3405 0           my $ret = $sftp->write($self, substr($_[1], $offset, $length));
3406 0 0         $sftp->_set_errno unless defined $ret;
3407 0           $ret;
3408             }
3409              
3410             sub READ {
3411 0     0     my ($self, undef, $len, $offset) = @_;
3412 0 0         $self->_check
3413             or return undef;
3414              
3415 0 0         $_[1] = '' unless defined $_[1];
3416 0   0       $offset ||= 0;
3417 0 0         if ($offset > length $_[1]) {
3418 0           $_[1] .= "\0" x ($offset - length $_[1])
3419             }
3420              
3421 0 0         if ($len == 0) {
3422 0           substr($_[1], $offset) = '';
3423 0           return 0;
3424             }
3425              
3426 0           my $sftp = $self->_sftp;
3427 0           $sftp->_fill_read_cache($self, $len);
3428              
3429 0           my $bin = $self->_bin;
3430 0 0         if (length $$bin) {
3431 0           my $data = substr($$bin, 0, $len, '');
3432 0           $self->_inc_pos($len);
3433 0           substr($_[1], $offset) = $data;
3434 0           return length $data;
3435             }
3436 0 0         return 0 if $sftp->{_status} == $sftp->SSH2_FX_EOF;
3437 0           $sftp->_set_errno;
3438 0           undef;
3439             }
3440              
3441             sub EOF {
3442 0     0     my $self = $_[0];
3443 0 0         $self->_check or return undef;
3444 0           my $sftp = $self->_sftp;
3445 0           my $ret = $sftp->eof($self);
3446 0 0         $sftp->_set_errno unless defined $ret;
3447 0           $ret;
3448             }
3449              
3450             *GETC = $gen_proxy_method->('getc');
3451             *TELL = $gen_proxy_method->('tell');
3452             *SEEK = $gen_proxy_method->('seek');
3453             *CLOSE = $gen_proxy_method->('close');
3454              
3455             my $readline = $gen_proxy_method->('readline');
3456 0     0     sub READLINE { $readline->($_[0], $/) }
3457              
3458             sub OPEN {
3459 0     0     shift->CLOSE;
3460 0           undef;
3461             }
3462              
3463             sub DESTROY {
3464 0     0     local ($@, $!, $?);
3465 0           my $self = shift;
3466 0           my $sftp = $self->_sftp;
3467 0 0 0       $debug and $debug & 4 and Net::SFTP::Foreign::_debug("$self->DESTROY called (sftp: ".($sftp||'').")");
      0        
3468 0 0 0       if ($self->_check and $sftp) {
3469 0           local $sftp->{_autodie};
3470 0           $sftp->_close_save_status($self)
3471             }
3472             }
3473              
3474             package Net::SFTP::Foreign::DirHandle;
3475             our @ISA = qw(Net::SFTP::Foreign::Handle IO::Dir);
3476              
3477             sub _new_from_rid {
3478 0     0     my $class = shift;
3479 0           my $sftp = shift;
3480 0           my $rid = shift;
3481 0           my $flags = shift;
3482              
3483 0           my $self = $class->SUPER::_new_from_rid($sftp, $rid, $flags, []);
3484             }
3485              
3486              
3487       0     sub _check_is_dir {}
3488              
3489 0     0     sub _cache { *{shift()}{ARRAY}[4] }
  0            
3490              
3491             *CLOSEDIR = $gen_proxy_method->('closedir');
3492             *READDIR = $gen_proxy_method->('_readdir');
3493              
3494             sub OPENDIR {
3495 0     0     shift->CLOSEDIR;
3496 0           undef;
3497             }
3498              
3499             *REWINDDIR = $gen_not_supported->();
3500             *TELLDIR = $gen_not_supported->();
3501             *SEEKDIR = $gen_not_supported->();
3502              
3503             sub DESTROY {
3504 0     0     local ($@, $!, $?);
3505 0           my $self = shift;
3506 0           my $sftp = $self->_sftp;
3507              
3508 0 0 0       $debug and $debug & 4 and Net::SFTP::Foreign::_debug("$self->DESTROY called (sftp: ".($sftp||'').")");
      0        
3509              
3510 0 0 0       if ($self->_check and $sftp) {
3511 0           local $sftp->{_autodie};
3512 0           $sftp->_closedir_save_status($self)
3513             }
3514             }
3515              
3516             1;
3517             __END__