App-SimpleBackuper

 view release on metacpan or  search on metacpan

local/lib/perl5/Net/SFTP/Foreign.pm  view on Meta::CPAN


    my $id = $sftp->_queue_new_msg(SSH2_FXP_WRITE, str => $rfid,
				  int64 => $offset, str => $_[3]);

    if ($sftp->_check_status_ok($id,
				SFTP_ERR_REMOTE_WRITE_FAILED,
				"Couldn't write to remote file")) {
	return 1;
    }
    return undef;
}

sub seek {
    (@_ >= 3 and @_ <= 4)
	or croak 'Usage: $sftp->seek($fh, $pos [, $whence])';

    my ($sftp, $rfh, $pos, $whence) = @_;
    $sftp->flush($rfh) or return undef;

    if (!$whence) {
        $rfh->_pos($pos)
    }
    elsif ($whence == 1) {
        $rfh->_inc_pos($pos)
    }
    elsif ($whence == 2) {
	my $a = $sftp->stat($rfh) or return undef;
        $rfh->_pos($pos + $a->size);
    }
    else {
	croak "invalid value for whence argument ('$whence')";
    }
    1;
}

sub tell {
    @_ == 2 or croak 'Usage: $sftp->tell($fh)';

    my ($sftp, $rfh) = @_;
    return $rfh->_pos + length ${$rfh->_bout};
}

sub eof {
    @_ == 2 or croak 'Usage: $sftp->eof($fh)';

    my ($sftp, $rfh) = @_;
    $sftp->_fill_read_cache($rfh, 1);
    return length(${$rfh->_bin}) == 0
}

sub _write {
    my ($sftp, $rfh, $off, $cb) = @_;

    $sftp->_clear_error_and_status;

    my $rfid = $sftp->_rfid($rfh);
    defined $rfid or return undef;

    my $qsize = $sftp->{_queue_size};

    my @msgid;
    my @written;
    my $written = 0;
    my $end;

    while (!$end or @msgid) {
	while (!$end and @msgid < $qsize) {
	    my $data = $cb->();
	    if (defined $data and length $data) {
		my $id = $sftp->_queue_new_msg(SSH2_FXP_WRITE, str => $rfid,
					      int64 => $off + $written, str => $data);
		push @written, $written;
		$written += length $data;
		push @msgid, $id;
	    }
	    else {
		$end = 1;
	    }
	}

	my $eid = shift @msgid;
	my $last = shift @written;
	unless ($sftp->_check_status_ok($eid,
					SFTP_ERR_REMOTE_WRITE_FAILED,
					"Couldn't write to remote file")) {

	    # discard responses to queued requests:
	    $sftp->_get_msg_by_id($_) for @msgid;
	    return $last;
	}
    }

    return $written;
}

sub write {
    @_ == 3 or croak 'Usage: $sftp->write($fh, $data)';

    my ($sftp, $rfh) = @_;
    $sftp->flush($rfh, 'in') or return undef;
    utf8::downgrade($_[2], 1) or croak "wide characters found in data";
    my $datalen = length $_[2];
    my $bout = $rfh->_bout;
    $$bout .= $_[2];
    my $len = length $$bout;

    if ($len >= $sftp->{_write_delay} or ($len and $sftp->{_autoflush} )) {
	$sftp->flush($rfh, 'out') or return undef;
    }

    return $datalen;
}

sub flush {
    (@_ >= 2 and @_ <= 3)
	or croak 'Usage: $sftp->flush($fh [, $direction])';

    my ($sftp, $rfh, $dir) = @_;
    $dir ||= '';

    defined $sftp->_rfid($rfh) or return;

    if ($dir ne 'out') { # flush in!
	${$rfh->_bin} = '';
    }

    if ($dir ne 'in') { # flush out!
	my $bout = $rfh->_bout;
	my $len = length $$bout;
	if ($len) {
	    my $start;
	    my $append = $rfh->_flag('append');
	    if ($append) {
		my $attr = $sftp->stat($rfh)
		    or return undef;
		$start = $attr->size;
	    }
	    else {
		$start = $rfh->_pos;
		${$rfh->_bin} = '';
	    }
	    my $off = 0;
	    my $written = $sftp->_write($rfh, $start,
					sub {
					    my $data = substr($$bout, $off, $sftp->{_block_size});
					    $off += length $data;
					    $data;
					} );
	    $rfh->_inc_pos($written)
		unless $append;

	    $$bout = ''; # The full buffer is discarded even when some error happens.
	    $written == $len or return undef;
	}
    }
    1;
}

sub _fill_read_cache {
    my ($sftp, $rfh, $len) = @_;

    $sftp->_clear_error_and_status;

    $sftp->flush($rfh, 'out')
	or return undef;

    my $rfid = $sftp->_rfid($rfh);
    defined $rfid or return undef;

    my $bin = $rfh->_bin;

    if (defined $len) {
	return 1 if ($len < length $$bin);

	my $read_ahead = $sftp->{_read_ahead};
	$len = length($$bin) + $read_ahead
	    if $len - length($$bin) < $read_ahead;
    }

    my $pos = $rfh->_pos;

    my $qsize = $sftp->{_queue_size};
    my $bsize = $sftp->{_block_size};

    do {
        local $sftp->{_autodie};

        my @msgid;
        my $askoff = length $$bin;
        my $ensure_eof;

        while (!defined $len or length $$bin < $len) {
            while ((!defined $len or $askoff < $len) and @msgid < $qsize) {
                my $id = $sftp->_queue_new_msg(SSH2_FXP_READ, str=> $rfid,
                                               int64 => $pos + $askoff, int32 => $bsize);
                push @msgid, $id;
                $askoff += $bsize;
            }

            my $eid = shift @msgid;
            my $msg = $sftp->_get_msg_and_check(SSH2_FXP_DATA, $eid,
                                                SFTP_ERR_REMOTE_READ_FAILED,
                                                "Couldn't read from remote file")
                or last;

            my $data = $msg->get_str;
            $$bin .= $data;
            if (length $data < $bsize) {
                unless (defined $len) {
                    $ensure_eof = $sftp->_queue_new_msg(SSH2_FXP_READ, str=> $rfid,
                                                        int64 => $pos + length $$bin, int32 => 1);
                }
                last;
            }
        }

        $sftp->_get_msg_by_id($_) for @msgid;

        if ($ensure_eof and
            $sftp->_get_msg_and_check(SSH2_FXP_DATA, $ensure_eof,
                                      SFTP_ERR_REMOTE_READ_FAILED,
                                      "Couldn't read from remote file")) {

            $sftp->_set_error(SFTP_ERR_REMOTE_BLOCK_TOO_SMALL,
                              "Received block was too small");
        }

        if ($sftp->{_status} == SSH2_FX_EOF) {
            $sftp->_set_error;
            $sftp->_set_status if length $$bin
        }
    };

    $sftp->_ok_or_autodie and length $$bin;
}

sub read {
    @_ == 3 or croak 'Usage: $sftp->read($fh, $len)';

    my ($sftp, $rfh, $len) = @_;
    if ($sftp->_fill_read_cache($rfh, $len)) {
	my $bin = $rfh->_bin;
	my $data = substr($$bin, 0, $len, '');
	$rfh->_inc_pos(length $data);
	return $data;
    }
    return undef;
}

sub _readline {
    my ($sftp, $rfh, $sep) = @_;

    $sep = "\n" if @_ < 3;

    my $sl = length $sep;

    my $bin = $rfh->_bin;
    my $last = 0;

    while(1) {
	my $ix = index $$bin, $sep, $last + 1 - $sl ;
	if ($ix >= 0) {
	    $ix += $sl;
	    $rfh->_inc_pos($ix);
	    return substr($$bin, 0, $ix, '');
	}

	$last = length $$bin;
	$sftp->_fill_read_cache($rfh, length($$bin) + 1);

	unless (length $$bin > $last) {
	    $sftp->{_error}
		and return undef;

	    my $line = $$bin;
	    $rfh->_inc_pos(length $line);
	    $$bin = '';

local/lib/perl5/Net/SFTP/Foreign.pm  view on Meta::CPAN

            }
        }

        # we open the remote file so late in order to skip it when
        # resuming an already completed transfer:
        $rfh = $sftp->open($remote, SSH2_FXF_READ);
        defined $rfh or return undef;

	unless (defined $fh) {
	    if ($local_is_fh) {
		$fh = $local;
		local ($@, $SIG{__DIE__}, $SIG{__WARN__});
		eval { $lstart = CORE::tell($fh) };
		$lstart = 0 unless ($lstart and $lstart > 0);
	    }
	    else {
                my $flags = Fcntl::O_CREAT|Fcntl::O_WRONLY;
                $flags |= Fcntl::O_APPEND if $append;
                $flags |= Fcntl::O_EXCL if ($numbered or (!$overwrite and !$append));
                unlink $local if $overwrite;
                my $open_perm = (defined $perm ? $perm : 0666);
                my $save = _umask_save_and_set($umask);
                $sftp->_mkpath_local($local, $open_perm|0700, 1) if $mkpath;
                while (1) {
                    sysopen ($fh, $local, $flags, $open_perm) and last;
                    unless ($numbered and -e $local) {
                        $sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED,
                                          "Can't open $local", $!);
                        return undef;
                    }
                    _inc_numbered($local);
                }
                $$numbered = $local if ref $numbered;
		binmode $fh;
		$lstart = sysseek($fh, 0, 2) if $append;
	    }
	}

	if (defined $perm) {
            my $error;
	    do {
                local ($@, $SIG{__DIE__}, $SIG{__WARN__});
                unless (eval { CORE::chmod($perm, $local) > 0 }) {
                    $error = ($@ ? $@ : $!);
                }
            };
	    if ($error and !$best_effort) {
                unlink $local unless $resume or $append;
		$sftp->_set_error(SFTP_ERR_LOCAL_CHMOD_FAILED,
				  "Can't chmod $local", $error);
		return undef
	    }
	}
    }

    my $converter = _gen_converter $conversion;

    my $rfid = $sftp->_rfid($rfh);
    defined $rfid or die "internal error: rfid not defined";

    my @msgid;
    my @askoff;
    my $loff = $askoff;
    my $adjustment = 0;
    local $\;

    my $slow_start = ($size == -1 ? $queue_size - 1 : 0);

    my $safe_block_size = $sftp->{_min_block_size} >= $block_size;

    do {
        # Disable autodie here in order to do not leave unhandled
        # responses queued on the connection in case of failure.
        local $sftp->{_autodie};

        # Again, once this point is reached, all code paths should end
        # through the CLEANUP block.

        while (1) {
            # request a new block if queue is not full
            while (!@msgid or ( ($size == -1 or $size + $block_size > $askoff)   and
                                @msgid < $queue_size - $slow_start and
                                $safe_block_size ) ) {
                my $id = $sftp->_queue_new_msg(SSH2_FXP_READ, str=> $rfid,
                                               int64 => $askoff, int32 => $block_size);
                push @msgid, $id;
                push @askoff, $askoff;
                $askoff += $block_size;
            }

            $slow_start-- if $slow_start;

            my $eid = shift @msgid;
            my $roff = shift @askoff;

            my $msg = $sftp->_get_msg_and_check(SSH2_FXP_DATA, $eid,
                                                SFTP_ERR_REMOTE_READ_FAILED,
                                                "Couldn't read from remote file");

            unless ($msg) {
                $sftp->_set_error if $sftp->{_status} == SSH2_FX_EOF;
                last;
            }

            my $data = $msg->get_str;
            my $len = length $data;

            if ($roff != $loff or !$len) {
                $sftp->_set_error(SFTP_ERR_REMOTE_BLOCK_TOO_SMALL,
                                  "remote packet received is too small" );
                last;
            }

            $loff += $len;
            unless ($safe_block_size) {
                if ($len > $sftp->{_min_block_size}) {
                    $sftp->{min_block_size} = $len;
                    if ($len < $block_size) {
                        # auto-adjust block size
                        $block_size = $len;
                        $askoff = $loff;
                    }
                }
                $safe_block_size = 1;
            }

            my $adjustment_before = $adjustment;
            $adjustment += $converter->($data) if $converter;

            if (length($data) and defined $cb) {
                # $size = $loff if ($loff > $size and $size != -1);
                local $\;
                $cb->($sftp, $data,
                      $lstart + $roff + $adjustment_before,
                      $lstart + $size + $adjustment);

                last if $sftp->{_error};
            }

            if (length($data) and !$dont_save) {
                unless (print $fh $data) {
                    $sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
                                      "unable to write data to local file $local", $!);
                    last;
                }
            }
        }

        $sftp->_get_msg_by_id($_) for @msgid;

        goto CLEANUP if $sftp->{_error};

        # if a converter is in place, and aditional call has to be
        # performed in order to flush any pending buffered data
        if ($converter) {
            my $data = '';
            my $adjustment_before = $adjustment;
            $adjustment += $converter->($data);

            if (length($data) and defined $cb) {
                # $size = $loff if ($loff > $size and $size != -1);
                local $\;
                $cb->($sftp, $data, $askoff + $adjustment_before, $size + $adjustment);
                goto CLEANUP if $sftp->{_error};
            }

            if (length($data) and !$dont_save) {
                unless (print $fh $data) {
                    $sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
                                      "unable to write data to local file $local", $!);
                    goto CLEANUP;
                }
            }
        }

        # we call the callback one last time with an empty string;
        if (defined $cb) {
            my $data = '';
            do {
                local $\;
                $cb->($sftp, $data, $askoff + $adjustment, $size + $adjustment);
            };
            return undef if $sftp->{_error};
            if (length($data) and !$dont_save) {
                unless (print $fh $data) {
                    $sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
                                      "unable to write data to local file $local", $!);
                    goto CLEANUP;
                }
            }
        }

        unless ($dont_save) {
            unless ($local_is_fh or CORE::close $fh) {
                $sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
                                  "unable to write data to local file $local", $!);
                goto CLEANUP;
            }

            # we can be running on taint mode, so some checks are
            # performed to untaint data from the remote side.

            if ($copy_time) {
                unless (utime($atime, $mtime, $local) or $best_effort) {
                    $sftp->_set_error(SFTP_ERR_LOCAL_UTIME_FAILED,
                                      "Can't utime $local", $!);
                    goto CLEANUP;
                }
            }

local/lib/perl5/Net/SFTP/Foreign.pm  view on Meta::CPAN

            while (1) {
                $rfh = $sftp->_open_mkpath($remote,
                                          $mkpath,
                                          SSH2_FXF_WRITE | SSH2_FXF_CREAT | SSH2_FXF_EXCL,
                                          $attrs);
                last if ($rfh or
                         $sftp->{_status} != SSH2_FX_FAILURE or
                         !$sftp->test_e($remote));
                _inc_numbered($remote);
	    }
            $$numbered = $remote if $rfh and ref $numbered;
	}
        else {
            # open can fail due to a remote file with the wrong
            # permissions being already there. We are optimistic here,
            # first we try to open the remote file and if it fails due
            # to a permissions error then we remove it and try again.
            for my $rep (0, 1) {
                $rfh = $sftp->_open_mkpath($remote,
                                           $mkpath,
                                           SSH2_FXF_WRITE | SSH2_FXF_CREAT |
                                           ($overwrite ? SSH2_FXF_TRUNC : SSH2_FXF_EXCL),
                                           $attrs);

                last if $rfh or $rep or !$overwrite or $sftp->{_status} != SSH2_FX_PERMISSION_DENIED;

                $debug and $debug & 2 and _debug("retrying open after removing remote file");
                local ($sftp->{_status}, $sftp->{_error});
                $sftp->remove($remote);
            }
        }
    }

    $sftp->_ok_or_autodie or return undef;
    # Once this point is reached and for the remaining of the sub,
    # code should never return but jump into the CLEANUP block.

    my $last_block_was_zeros;

    do {
        local $sftp->{autodie};

        # In some SFTP server implementations, open does not set the
        # attributes for existent files so we do it again. The
        # $late_set_perm work around is for some servers that do not
        # support changing the permissions of open files
        if (defined $perm and !$late_set_perm) {
            $sftp->_best_effort($best_effort, setstat => $rfh, $attrs) or goto CLEANUP;
        }

        my $rfid = $sftp->_rfid($rfh);
        defined $rfid or die "internal error: rfid is undef";

        # In append mode we add the size of the remote file in
        # writeoff, if lsize is undef, we initialize it to $writeoff:
        $lsize += $writeoff if ($append or not defined $lsize);

        # when a converter is used, the EOF can become delayed by the
        # buffering introduced, we use $eof_t to account for that.
        my ($eof, $eof_t);
        my @msgid;
    OK: while (1) {
            if (!$eof and @msgid < $queue_size) {
                my ($data, $len);
                if ($converter) {
                    while (!$eof_t and length $converted_input < $block_size) {
                        my $read = CORE::read($fh, my $input, $block_size * 4);
                        unless ($read) {
                            unless (defined $read) {
                                $sftp->_set_error(SFTP_ERR_LOCAL_READ_ERROR,
                                                  "Couldn't read from local file '$local'", $!);
                                last OK;
                            }
                            $eof_t = 1;
                        }

                        # note that the $converter is called a last time
                        # with an empty string
                        $lsize += $converter->($input);
                        utf8::downgrade($input, 1)
                                or croak "converter introduced wide characters in data";
                        $converted_input .= $input;
                    }
                    $data = substr($converted_input, 0, $block_size, '');
                    $len = length $data;
                    $eof = 1 if ($eof_t and !$len);
                }
                else {
                    $debug and $debug & 16384 and
                        _debug "reading block at offset ".CORE::tell($fh)." block_size: $block_size";

                    $len = CORE::read($fh, $data, $block_size);

                    if ($len) {
                        $debug and $debug & 16384 and _debug "block read, size: $len";

                        utf8::downgrade($data, 1)
                                or croak "wide characters unexpectedly read from file";

                        $debug and $debug & 16384 and length $data != $len and
                            _debug "read data changed size on downgrade to " . length($data);
                    }
                    else {
                        unless (defined $len) {
                            $sftp->_set_error(SFTP_ERR_LOCAL_READ_ERROR,
                                              "Couldn't read from local file '$local'", $!);
                            last OK;
                        }
                        $eof = 1;
                    }
                }

                my $nextoff = $writeoff + $len;

                if (defined $cb) {
                    $lsize = $nextoff if $nextoff > $lsize;
                    $cb->($sftp, $data, $writeoff, $lsize);

                    last OK if $sftp->{_error};

                    utf8::downgrade($data, 1) or croak "callback introduced wide characters in data";

                    $len = length $data;
                    $nextoff = $writeoff + $len;
                }

                if ($len) {
                    if ($sparse and $data =~ /^\x{00}*$/s) {
                        $last_block_was_zeros = 1;
                        $debug and $debug & 16384 and _debug "skipping zeros block at offset $writeoff, length $len";
                    }
                    else {
                        $debug and $debug & 16384 and _debug "writing block at offset $writeoff, length $len";

                        my $id = $sftp->_queue_new_msg(SSH2_FXP_WRITE, str => $rfid,
                                                       int64 => $writeoff, str => $data);
                        push @msgid, $id;
                        $last_block_was_zeros = 0;
                    }
                    $writeoff = $nextoff;
                }
            }

            last if ($eof and !@msgid);

            next unless  ($eof
                          or @msgid >= $queue_size
                          or $sftp->_do_io(0));

            my $id = shift @msgid;
            unless ($sftp->_check_status_ok($id,
                                            SFTP_ERR_REMOTE_WRITE_FAILED,
                                            "Couldn't write to remote file")) {
                last OK;
            }
        }

        CORE::close $fh unless $local_is_fh;

        $sftp->_get_msg_by_id($_) for @msgid;

        $sftp->truncate($rfh, $writeoff)
            if $last_block_was_zeros and not $sftp->{_error};

        $sftp->_close_save_status($rfh);

        goto CLEANUP if $sftp->{_error};

        # set perm for servers that does not support setting
        # permissions on open files and also atime and mtime:
        if ($copy_time or ($late_set_perm and defined $perm)) {
            $attrs->set_perm unless $late_set_perm and defined $perm;
            $attrs->set_amtime($latime, $lmtime) if $copy_time;
            $sftp->_best_effort($best_effort, setstat => $remote, $attrs) or goto CLEANUP
        }

        if ($atomic) {
            $sftp->rename($remote, $atomic_remote,
                          overwrite => $overwrite,
                          numbered => $atomic_numbered) or goto CLEANUP;
        }

    CLEANUP:
        if ($cleanup and $sftp->{_error}) {
            warn "cleanup $remote";
            $sftp->_remove_save_status($remote);
        }
    };
    $sftp->_ok_or_autodie;
}

sub put_content {
    @_ >= 3 or croak 'Usage: $sftp->put_content($content, $remote, %opts)';
    ${^TAINT} and &_catch_tainted_args;

    my ($sftp, undef, $remote, %opts) = @_;
    my %put_opts = ( map { $_ => delete $opts{$_} }
                     qw(perm umask block_size queue_size overwrite conversion resume
                        numbered late_set_perm atomic best_effort mkpath));
    %opts and _croak_bad_options(keys %opts);

    my $fh;
    unless (CORE::open $fh, '<', \$_[1]) {
        $sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED, "Can't open scalar as file handle", $!);
        return undef;
    }
    $sftp->put($fh, $remote, %put_opts);
}

sub ls {
    @_ >= 1 or croak 'Usage: $sftp->ls($remote_dir, %opts)';
    ${^TAINT} and &_catch_tainted_args;

    my $sftp = shift;
    my %opts = @_ & 1 ? (dir => @_) : @_;

    my $dir = delete $opts{dir};
    my $ordered = delete $opts{ordered};
    my $follow_links = delete $opts{follow_links};
    my $atomic_readdir = delete $opts{atomic_readdir};
    my $names_only = delete $opts{names_only};
    my $realpath = delete $opts{realpath};
    my $queue_size = delete $opts{queue_size};
    my $cheap = ($names_only and !$realpath); 
    my ($cheap_wanted, $wanted);
    if ($cheap and
	ref $opts{wanted} eq 'Regexp' and 
	not defined $opts{no_wanted}) {
	$cheap_wanted = delete $opts{wanted}
    }
    else {
	$wanted = (delete $opts{_wanted} ||
		   _gen_wanted(delete $opts{wanted},
			       delete $opts{no_wanted}));
	undef $cheap if defined $wanted;
    }

    %opts and _croak_bad_options(keys %opts);

    my $delayed_wanted = ($atomic_readdir and $wanted);
    $queue_size = 1 if ($follow_links or $realpath or
			($wanted and not $delayed_wanted));
    my $max_queue_size = $queue_size || $sftp->{_queue_size};
    $queue_size ||= ($max_queue_size < 2 ? $max_queue_size : 2);

    $dir = '.' unless defined $dir;
    $dir = $sftp->_rel2abs($dir);

    my $rdh = $sftp->opendir($dir);
    return unless defined $rdh;

    my $rdid = $sftp->_rdid($rdh);
    defined $rdid or return undef;

    my @dir;
    my @msgid;

    do {
        local $sftp->{_autodie};
    OK: while (1) {
            push @msgid, $sftp->_queue_str_request(SSH2_FXP_READDIR, $rdid)
                while (@msgid < $queue_size);

            my $id = shift @msgid;
            my $msg = $sftp->_get_msg_and_check(SSH2_FXP_NAME, $id,
						SFTP_ERR_REMOTE_READDIR_FAILED,
						"Couldn't read directory '$dir'" ) or last;
	    my $count = $msg->get_int32 or last;

	    if ($cheap) {
		for (1..$count) {
		    my $fn = $sftp->_fs_decode($msg->get_str);
		    push @dir, $fn if (!defined $cheap_wanted or $fn =~ $cheap_wanted);
		    $msg->skip_str;
		    Net::SFTP::Foreign::Attributes->skip_from_buffer($msg);
		}
	    }
	    else {
		for (1..$count) {
		    my $fn = $sftp->_fs_decode($msg->get_str);
		    my $ln = $sftp->_fs_decode($msg->get_str);
		    # my $a = $msg->get_attributes;
		    my $a = Net::SFTP::Foreign::Attributes->new_from_buffer($msg);

		    my $entry =  { filename => $fn,
				   longname => $ln,
				   a => $a };

		    if ($follow_links and _is_lnk($a->perm)) {

			if ($a = $sftp->stat($sftp->join($dir, $fn))) {
			    $entry->{a} = $a;
			}
			else {
			    $sftp->_clear_error_and_status;
			}
		    }

		    if ($realpath) {
			my $rp = $sftp->realpath($sftp->join($dir, $fn));
			if (defined $rp) {
			    $fn = $entry->{realpath} = $rp;
			}
			else {
			    $sftp->_clear_error_and_status;
			}
		    }

		    if (!$wanted or $delayed_wanted or $wanted->($sftp, $entry)) {
			push @dir, (($names_only and !$delayed_wanted) ? $fn : $entry);
		    }
                }
	    }
	    $queue_size++ if $queue_size < $max_queue_size;
	}
	$sftp->_set_error if $sftp->{_status} == SSH2_FX_EOF;
	$sftp->_get_msg_by_id($_) for @msgid;
        $sftp->_closedir_save_status($rdh) if $rdh;
    };
    unless ($sftp->{_error}) {
	if ($delayed_wanted) {
	    @dir = grep { $wanted->($sftp, $_) } @dir;
	    @dir = map { defined $_->{realpath}
			 ? $_->{realpath}
			 : $_->{filename} } @dir
		if $names_only;
	}
        if ($ordered) {
            if ($names_only) {
                @dir = sort @dir;
            }
            else {
                _sort_entries \@dir;
            }
        }
	return \@dir;
    }
    croak $sftp->{_error} if $sftp->{_autodie};
    return undef;
}

sub rremove {
    @_ >= 2 or croak 'Usage: $sftp->rremove($dirs, %opts)';
    ${^TAINT} and &_catch_tainted_args;

    my ($sftp, $dirs, %opts) = @_;

    my $on_error = delete $opts{on_error};
    local $sftp->{_autodie} if $on_error;
    my $wanted = _gen_wanted( delete $opts{wanted},
			      delete $opts{no_wanted});

    %opts and _croak_bad_options(keys %opts);

    my $count = 0;

    my @dirs;
    $sftp->find( $dirs,
		 on_error => $on_error,
		 atomic_readdir => 1,
		 wanted => sub {
		     my $e = $_[1];
		     my $fn = $e->{filename};
		     if (_is_dir($e->{a}->perm)) {
			 push @dirs, $e;
		     }
		     else {
			 if (!$wanted or $wanted->($sftp, $e)) {
			     if ($sftp->remove($fn)) {
				 $count++;
			     }
			     else {
				 $sftp->_call_on_error($on_error, $e);
			     }
			 }
		     }
		 } );

local/lib/perl5/Net/SFTP/Foreign.pm  view on Meta::CPAN

=item $sftp-E<gt>opendir($path)

Sends a C<SSH_FXP_OPENDIR> command to open the remote directory
C<$path>, and returns an open handle on success (unfortunately,
current versions of perl does not support directory operations via
tied handles, so it is not possible to use the returned handle as a
native one).

On failure returns C<undef>.

=item $sftp-E<gt>closedir($handle)

closes the remote directory handle C<$handle>.

Directory handles are closed from their C<DESTROY> method when not
done explicitly.

Return true on success, undef on failure.

=item $sftp-E<gt>readdir($handle)

returns the next entry from the remote directory C<$handle> (or all
the remaining entries when called in list context).

The return values are a hash with three keys: C<filename>, C<longname> and
C<a>. The C<a> value contains a L<Net::SFTP::Foreign::Attributes>
object describing the entry.

Returns undef on error or when no more entries exist on the directory.

=item $sftp-E<gt>stat($path_or_fh)

performs a C<stat> on the remote file and returns a
L<Net::SFTP::Foreign::Attributes> object with the result values. Both
paths and open remote file handles can be passed to this method.

Returns undef on failure.

=item $sftp-E<gt>fstat($handle)

this method is deprecated.

=item $sftp-E<gt>lstat($path)

this method is similar to C<stat> method but stats a symbolic link
instead of the file the symbolic links points to.

=item $sftp-E<gt>setstat($path_or_fh, $attrs)

sets file attributes on the remote file. Accepts both paths and open
remote file handles.

Returns true on success and undef on failure.

=item $sftp-E<gt>fsetstat($handle, $attrs)

this method is deprecated.

=item $sftp-E<gt>truncate($path_or_fh, $size)

=item $sftp-E<gt>chown($path_or_fh, $uid, $gid)

=item $sftp-E<gt>chmod($path_or_fh, $perm)

=item $sftp-E<gt>utime($path_or_fh, $atime, $mtime)

Shortcuts around C<setstat> method.

=item $sftp-E<gt>remove($path)

Sends a C<SSH_FXP_REMOVE> command to remove the remote file
C<$path>. Returns a true value on success and undef on failure.

=item $sftp-E<gt>mkdir($path, $attrs)

Sends a C<SSH_FXP_MKDIR> command to create a remote directory C<$path>
whose attributes are initialized to C<$attrs> (a
L<Net::SFTP::Foreign::Attributes> object).

Returns a true value on success and undef on failure.

The C<$attrs> argument is optional.

=item $sftp-E<gt>mkpath($path, $attrs, $parent)

This method is similar to C<mkdir> but also creates any non-existent
parent directories recursively.

When the optional argument C<$parent> has a true value, just the
parent directory of the given path (and its ancestors as required) is
created.

For instance:

  $sftp->mkpath("/tmp/work", undef, 1);
  my $fh = $sftp->open("/tmp/work/data.txt",
                       SSH2_FXF_WRITE|SSH2_FXF_CREAT);

=item $sftp-E<gt>rmdir($path)

Sends a C<SSH_FXP_RMDIR> command to remove a remote directory
C<$path>. Returns a true value on success and undef on failure.

=item $sftp-E<gt>realpath($path)

Sends a C<SSH_FXP_REALPATH> command to canonicalise C<$path>
to an absolute path. This can be useful for turning paths
containing C<'..'> into absolute paths.

Returns the absolute path on success, C<undef> on failure.

When the given path points to an nonexistent location, what one
gets back is server dependent. Some servers return a failure message
and others a canonical version of the path.

=item $sftp-E<gt>rename($old, $new, %opts)

Sends a C<SSH_FXP_RENAME> command to rename C<$old> to C<$new>.
Returns a true value on success and undef on failure.

Accepted options are:



( run in 0.483 second using v1.01-cache-2.11-cpan-ceb78f64989 )