libnet-sftp-foreign-perl-1.86+dfsg.orig/0000755000175000017500000000000012726554465017202 5ustar salvisalvilibnet-sftp-foreign-perl-1.86+dfsg.orig/META.yml0000644000175000017500000000137712726520616020452 0ustar salvisalvi--- abstract: 'Secure File Transfer Protocol client' author: - 'Salvador Fandino ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150005' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Net-SFTP-Foreign no_index: directory: - t - inc requires: Scalar::Util: '0' Test::More: '0' Time::HiRes: '0' resources: bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Net-SFTP-Foreign repository: http://github.com/salva/p5-Net-SFTP-Foreign version: '1.86' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' libnet-sftp-foreign-perl-1.86+dfsg.orig/samples/0000755000175000017500000000000012726520616020635 5ustar salvisalvilibnet-sftp-foreign-perl-1.86+dfsg.orig/samples/psftp0000755000175000017500000001660312516370257021726 0ustar salvisalvi#!/usr/bin/perl # This script has not being updated and still uses the Net::SFTP API # available from the adapter module Net::SFTP::Foreign::Compat. use strict; use warnings; use Net::SFTP::Foreign::Compat; use Getopt::Long; my %opts; Getopt::Long::Configure('no_ignore_case'); GetOptions(\%opts, "C", "v"); my($host) = @ARGV; die "usage: psftp [options] hostname\n" unless $host; my %args = (more => []); $args{debug} = 1 if $opts{v}; push @{ $args{more} }, '-C' if $opts{C}; print "Connecting to $host...\n"; my $sftp = Net::SFTP::Foreign::Compat->new($host, %args); my $shell = Net::SFTP::Foreign::Shell->new($sftp); $shell->shell; package Net::SFTP::Foreign::Shell; use strict; use File::Basename; use File::Spec::Functions qw( catdir catfile ); use Text::ParseWords qw( shellwords ); use Term::ReadLine; use Net::SFTP::Foreign::Constants qw( SSH2_FILEXFER_ATTR_PERMISSIONS SSH2_FILEXFER_VERSION ); use Net::SFTP::Foreign::Attributes::Compat; sub new { my $class = shift; my $sftp = shift; my $shell = bless { sftp => $sftp }, $class; $shell->init(@_); } sub shell { my $shell = shift; my $term = Term::ReadLine->new('Perl SFTP'); my $odef = select STDERR; $| = 1; select STDOUT; $| = 1; select $odef; $shell->process_pwd; while () { last unless defined ($_ = $term->readline("sftp> ")); s/^\s+//; next if /^$/; $_ = 'h' if /^\s*\?/; my @line; if (/^(?:q(?:uit)?|byte|exit)$/i) { last; } elsif (/./) { @line = shellwords($_); next unless @line; } my $cmd = "process_" . shift @line; eval { $shell->$cmd(@line); }; $shell->mywarn($@) if $@; } } sub pwd { $_[0]->{pwd} } sub init { my $shell = shift; my $sftp = $shell->{sftp}; my %param = @_; $shell->{pwd} = $param{Pwd}; unless ($shell->{pwd}) { $shell->{pwd} = $sftp->do_realpath("."); } $shell; } use vars qw( $AUTOLOAD ); sub AUTOLOAD { my($cmd) = $AUTOLOAD; return if $cmd =~ /DESTROY/; my $shell = shift; $cmd =~ s/.*::process_//; $shell->mywarn("Unknown command '$cmd'. Type '?' for help."); } sub make_absolute { my($piece, $pwd) = @_; $piece =~ m!^/! ? $piece : catdir($pwd, $piece); } sub process_h { my($shell, @arg) = @_; $shell->mywarn("usage: h"), return if @arg; print q{Available commands: cd path Change remote directory to 'path' h,? Display this help text get remote-path [local-path] Download file 'remote-path' ls [path] Display remote directory listing mkdir path Create remote directory put local-path [remote-path] Upload file 'local-path' pwd Display remote working directory q[uit],exit Quit the psftp shell rename old-path new-path Rename remote file rmdir path Remove remote directory 'path' rm path Remove remote file 'path' version Display SFTP version } } sub process_get { my($shell, @arg) = @_; my $sftp = $shell->{sftp}; $shell->mywarn("usage: get remote [local]"), return unless @arg; $arg[0] = make_absolute($arg[0], $shell->{pwd}); $arg[1] = basename($arg[0]) unless $arg[1]; print "Downloading $arg[0] to $arg[1]\n"; $shell->{sftp}->get($arg[0], $arg[1]); } sub process_put { my($shell, @arg) = @_; $shell->mywarn("usage: put local remote"), return unless @arg == 2; print "Uploading $arg[0] to $arg[1]\n"; $shell->{sftp}->put($arg[0], $arg[1]); } sub process_ls { my($shell, @arg) = @_; $shell->mywarn("usage: ls [path]"), return unless @arg < 2; $shell->{sftp}->ls($arg[0] || $shell->{pwd}, sub { print $_[0]->{longname}, "\n" }); } sub process_cd { my($shell, @arg) = @_; my $sftp = $shell->{sftp}; $shell->mywarn("usage: cd path"), return unless @arg == 1; my $path = make_absolute($arg[0], $shell->{pwd}); my $real = $sftp->do_realpath($path) or return; my $a = $sftp->do_stat($real) or return; $shell->mywarn("Can't change directory: Can't check target"), return if !($a->flags & SSH2_FILEXFER_ATTR_PERMISSIONS); $shell->{pwd} = $real; } sub process_mkdir { my($shell, @arg) = @_; $shell->mywarn("usage: mkdir path"), return unless @arg == 1; my $a = Net::SFTP::Foreign::Attributes::Compat->new; $a->flags( $a->flags | SSH2_FILEXFER_ATTR_PERMISSIONS ); $a->perm(0777); $shell->{sftp}->do_mkdir(make_absolute($arg[0], $shell->{pwd}), $a); } sub process_rmdir { my($shell, @arg) = @_; $shell->mywarn("usage: rmdir path"), return unless @arg == 1; $shell->{sftp}->do_rmdir(make_absolute($arg[0], $shell->{pwd})); } sub process_rename { my($shell, @arg) = @_; $shell->mywarn("usage: rename oldpath newpath"), return unless @arg == 2; $shell->{sftp}->do_rename(make_absolute($arg[0], $shell->{pwd}), make_absolute($arg[1], $shell->{pwd})); } sub process_rm { my($shell, @arg) = @_; $shell->mywarn("usage: rm path"), return unless @arg == 1; $shell->{sftp}->do_remove(make_absolute($arg[0], $shell->{pwd})); } sub process_pwd { print "Remote working directory: $_[0]->{pwd}\n" } sub process_version { print "SFTP protocol version ", SSH2_FILEXFER_VERSION, "\n"; } sub mywarn { my($shell, $what) = @_; print $what, "\n"; } __END__ =head1 NAME psftp - Perl secure file transfer client =head1 SYNOPSIS psftp [B<-v>] [B<-C>] I =head1 DESCRIPTION I is an interactive SFTP client written in Perl, using the I libraries. It is very similar in functionality to the I program that is part of both OpenSSH and ssh2. On startup, I logs into the specified I, then enters an interactive command mode. The supported list of commands is below in I. =head1 OPTIONS I supports the following options: =over 4 =item -C Enables compression. =item -v Enables debugging messages. =back =head1 INTERACTIVE COMMANDS In interactive mode, I understands a subset of the commands supported by I. Commands are case insensitive. =head2 cd I Change remote directory to I. =head2 exit / quit Quit sftp. =head2 get I [I] Retrieve the file I and store it in the local machine. If the local path name is not specified, it is given the same leaf name it has on the remote machine. Copies the remote file's full permission and access times, as well. =head2 h / ? Display help screen. =head2 ls [I] Display remote directory listing of either I or current working remote directory if I is unspecified. =head2 mkdir I Create remote directory specified by I. =head2 put I I Upload the file I and store it on the remote machine. Copies the local file's full permission and access times, as well. =head2 pwd Display remote working directory. =head2 rename I I Rename remote file from I to I. =head2 rmdir I Remove remote directory specified by I. =head2 rm I Remove remote file specified by I. =head2 version Show SFTP version. =head1 AUTHOR & COPYRIGHTS Please see the Net::SFTP::Foreign manpage for author, copyright, and license information. =cut libnet-sftp-foreign-perl-1.86+dfsg.orig/samples/passwd_conn.pl0000644000175000017500000000323112516370257023510 0ustar salvisalvi#!/usr/bin/perl # This sample is obsolete and should not be used as a reference. # # Current versions of Net::SFTP::Foreign support password # authentication as long as the IO::Pty module is installed: # # my $sftp = Net::SFTP::Foreign->new($host, # user => "me", # passwd => "quite-secret-passwd"); # $sftp->error and die "unable to connect ro $host"; # use strict; use warnings; use Expect; use Net::SFTP::Foreign; $| = 1; my $errstr = "unable to stablish SSH connection with remote host"; my $timeout = 60; @ARGV >= 3 or die <new; $conn->raw_pty(1); $conn->log_user(0); # spawn a new SSH process: $conn->spawn('/usr/bin/ssh', -l => $user, $host, -s => 'sftp') or die $errstr; # wait for the password prompt: $conn->expect($timeout, "Password:") or die "Password not requested as expected"; $conn->send("$passwd\n"); # SSH echoes the "\n" after the password, remove it from the stream: $conn->expect($timeout, "\n"); # and finally run SFTP over the ssh connection: my $sftp = Net::SFTP::Foreign->new(transport => $conn); $sftp->error and die "$errstr: " . $sftp->error; # and do whatever you want with it... for my $dir (@dir) { my $ls = $sftp->ls($dir); if ($ls) { print "$dir\n"; print " - $_->{filename}\n" for @$ls; print "\n"; } else { print STDERR "Unable to retrieve directory listing for '$dir': " . $sftp->error . "\n" } } libnet-sftp-foreign-perl-1.86+dfsg.orig/samples/sftp_tail.pl0000644000175000017500000000127012516370257023160 0ustar salvisalvi#!/usr/bin/perl use strict; use warnings; use Net::SFTP::Foreign; use Fcntl qw(SEEK_END); @ARGV == 1 or usage(); my ($host, $file) = $ARGV[0] =~ /([^:]+):(.+)/ or usage(); my $sftp = Net::SFTP::Foreign->new($host); $sftp->error and die "Unable to connect to remote host: ".$sftp->error."\n"; my $fh = $sftp->open($file) or die "Unable to open file $file: ".$sftp->error."\n"; # goto end of file seek($fh, 0, SEEK_END); my $sleep = 1; while (1) { while (<$fh>) { print; $sleep = 1; } print "### sleeping $sleep\n"; sleep $sleep; $sleep++ unless $sleep > 5; } sub usage { warn <new or die "tempfile failed"; my $sftp = Net::SFTP::Foreign->new($hostname, more => qw(-v), stderr_fh => $ssherr); if ($sftp->error) { print "sftp error: ".$sftp->error."\n"; seek($ssherr, 0, 0); while (<$ssherr>) { print " ssh error: $_"; } } close $ssherr; libnet-sftp-foreign-perl-1.86+dfsg.orig/samples/resume_put.pl0000644000175000017500000000361312516370257023366 0ustar salvisalvi#!/usr/bin/perl # # this script is used to test the resume feature of the put method # use strict; use warnings; @ARGV == 2 or die "Usage:\n resume_put.pl file_len gpg_id\n\n"; my ($len, $id) = @ARGV; use Net::SFTP::Foreign; my $base; our ($a, $b); use File::Slurp; sub reset_local { create_file(@_); } sub create_file { my ($len) = @_; $base = join '', map { chr rand 256 } 0..100000; open my $fh, '>', "local.txt"; binmode $fh; while ($len > 0) { print $fh substr $base, 0, $len; $len -= length $base } close $fh; unlink 'local.txt.gpg'; system 'gpg', '--encrypt', '--recipient', $id, 'local.txt'; read_file("local.txt.gpg", binmode => ':raw'); } open STDERR, ">", "Net-SFTP-Foreign.debug"; $Net::SFTP::Foreign::debug = 3+32+128+4096+16384; $| = 1; my $pwd = `pwd`; chomp $pwd; my $i = 1; eval { while (1) { my $s; my $content = create_file(1 + int rand $len); my $gpg_len = length $content; for (1..100) { my $remote = 1 + int rand length $content; print STDERR "\n\n############################## ${i}:$remote/$gpg_len ################################\n\n"; print " ${i}:$remote/$gpg_len"; $i++; $s //= Net::SFTP::Foreign->new('localhost'); $s->setcwd($pwd); write_file("remote.txt.gpg", {binmode => ':raw'}, substr($content, 0, $remote)); $s->put("local.txt.gpg", "remote.txt.gpg", resume => 1); if ($s->error) { print $s->error . "!"; undef $s; next; } my $rcontent = read_file("remote.txt.gpg", binary => ':raw'); unless ($content eq $rcontent and (stat "remote.txt.gpg")[7] == (stat "local.txt.gpg")[7]) { die "\ndifferent contents\n"; } } } }; if ($@) { print $@; die $@; } libnet-sftp-foreign-perl-1.86+dfsg.orig/MANIFEST0000644000175000017500000000145412726554465020337 0ustar salvisalviChanges debug.txt lib/Net/SFTP/Foreign.pm lib/Net/SFTP/Foreign/Attributes.pm lib/Net/SFTP/Foreign/Attributes/Compat.pm lib/Net/SFTP/Foreign/Buffer.pm lib/Net/SFTP/Foreign/Common.pm lib/Net/SFTP/Foreign/Compat.pm lib/Net/SFTP/Foreign/Constants.pm lib/Net/SFTP/Foreign/Helpers.pm lib/Net/SFTP/Foreign/Local.pm lib/Net/SFTP/Foreign/Backend/Unix.pm lib/Net/SFTP/Foreign/Backend/Windows.pm LICENSE Makefile.PL MANIFEST README samples/capture_stderr.pl samples/passwd_conn.pl samples/psftp samples/sftp_tail.pl samples/resume_put.pl t/1_run.t t/3_convert.t t/4_perl5_11.t t/5_join.t t/common.pm t/data.txd t/data.txu t/Net-SFTP-Foreign-Compat.t TODO META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) libnet-sftp-foreign-perl-1.86+dfsg.orig/Changes0000644000175000017500000010435612726520473020476 0ustar salvisalviRevision history for Net::SFTP::Foreign 1.86 Jun 10, 2016 - Some old perl versions doesn't like Errno constant subs being called without parents. Add them. 1.85 Jun 9, 2016 - "_mkpath_local" regression: it was now failing to create any directory at all (bug report by Douglas Wilson) 1.84_01 Jun 9, 2016 - Do not use "alarm", it doesn't play nicely with threads (bug report by Chris Denley, #rt112101). 1.83 Jun 9, 2016 - "_mkpath_local" was broken for relative directories (bug report by Douglas Wilson, #rt115174). - Look for "sftp-server" in some additional common places when testing the module (bug report by Kent Fredric). - In "get" method, disable "overwrite" by default when "append" is being used. - "append" feature on "get" was depending on unspecified behavior. 1.81 Dec 20, 2015 - Rereleased as stable. 1.80_01 Nov 10, 2015 - mkpath was using the wrong permissions and generating a warning (bug and solution by Boris Hartwig, #rt108658) 1.79 Oct 10, 2015 - some spell-cheking testing fixes (patch by E. Choroba) 1.78_07 Oct 6, 2015 - setcwd was broken in taint mode (bug report by Julian Bridle and E. Choroba) 1.78_06 Oct 1, 2015 - the auto resume feature in put method was broken (bug report and fix by Denis Shirokov) 1.78_05 Aug 17, 2015 - make autodisconnect on current pid/thread the default *** WARNING: this is a backward incompatible change!!! - check also the thread generation match before autodisconnecting (bug report by Harry Zhu) 1.78_04 May 14, 2015 - document test_d and test_e methods - avoid running tests in parallel (fixes #RT101936 reported by Karen Etheridge) - flush and close methods now check that the file handle is still open (bug reported by David Jack Wange Olrik, github/#5) 1.78_03 Dec 2, 2014 - rput handling of copy_perm was broken (bug report by Karsten Wagner Bang) - add support for perm option in rput method - document HP-UX password bug 1.78_02 Nov 4, 2014 - redo block size autodetection logic which should improve performance greatly in some cases (this is a dangerous change that could introduce regressions, report them!) - add support for new constructor option min_block_size - add support for check option into setcwd method (feature request by T. Linden) 1.78_01 Jun 14, 2014 - fix more POD errors - fix POD error (reported by Stefan Zwijsen) - require Time::HiRes on Makefile.PL as some distributions don't include it on the base perl distribution - fix doc misspelling (reported by Sándor Farkas) - add support for fsync method via fsync@openssh.com extension - add mkpath feature 1.77 Nov 5, 2013 - release as stable - fix misspellings in error messages 1.76_04 Oct 2, 2013 - fix 'Use of "goto" to jump into a construct is deprecated' warning (bug report by Brent Bates) - don't force permissions from rput when copy_perm is unset 1.76_03 Aug 26, 2013 - fix several spelling errors - add spell checking test - remove pod test from MANIFEST - ensure that pty is not destroyed before main object (bug report by Stephen Wylie) during global destruction 1.76_02 Apr 29, 2013 - remove warning happening when best_effort was set, specially visible from Compat module (bug report by emerlyn at PerlMonks) 1.76_01 Apr 26, 2013 - protect against callbacks setting $\ (bug report by Thomas Wadley) 1.75 Apr 2, 2013 - release as stable 1.74_07 Mar 21, 2013 - seek method was returning offset instead of success value (bug report by Paul Kolano). 1.74_06 Mar 12, 2013 - disconnect may kill some unrelated process when called repeatly (bug report by Douglas Wilson) - debug was clobbering $! 1.74_05 Feb 5, 2013 - error was not being set on timeouts (bug report by Kqfh Jjgrn) 1.74_04 Oct 25, 2012 - overwriting rename of a file over itself was broken (bug report by Mike Wilder) - stat and lstat path arguments is now optional and defaults to '.' (bug report by Paul Kolano) - fstat was broken - add git repository and bugtracker into meta files 1.74_03 Sep 21, 2012 - put_content was broken (bug report by Caleb Cushing) - document put_content method - add more tests 1.74_02 Jul 11, 2012 - rget was dieing when trying to copy remote symbolic links - add support for get method slow-start feature: when file size is unknown don't start asking for $queue_size packets as it slows down the transfer of small files, instead, starting from a queue size of one go gradually increasing it until the stated maximum is reached (bug report by David R. Wagner) - parse supported2 extension 1.74_01 - add support for password_prompt (feature request by Douglas Wilson) 1.73 May 11, 2012 - password authentication was broken on Solaris (maybe also on others) due to an incorrect waitpid call (bug report and solution by Douglas Wilson) - disconnect was dieing when used with autodie on (bug report by Douglas Wilson) 1.72_02 May 4, 2012 - add methods truncate, chmod, chown and utime - make setstat, stat and statvfs accept both a path and a remote file/dir handle as its first argument - deprecate fsetstat, fstat and fstatvfs - refactor remove and rmdir generation - add support for sparse file transfer - minor doc improvements 1.72_01 Mar 20, 2012 - add support for asks_for_username_at_login feature (feature request by Horea Gligan) - key_path now can accept an array 1.71 Mar 14, 2012 - release as stable - add support for vendor-id extension 1.70_10 Mar 2, 2012 - now perm and umask can be used together on get method calls - more cleanups for permission handling code on get method 1.70_09 Mar 2, 2012 - autodie was no working for chmod errors on get - get was unlinking the file when chmod failed even whith append or resume set - get was failing when chmod failed even if copy_perms was dissabled (bug report by Rich Anderson) - solve bad interaction between autodie, resume and append - best_effort wrapped methods were not failing ever - minor put method refactoring - save globals on destructor entry - better put method debugging 1.70_08 Feb 19, 2012 - queue_size defaults per backend were using the wrong key name and so being ignored. That was causing connections to stall on Windows with the default backend. 1.70_07 Feb 19, 2012 - put recovers from open calls failing due to the existence of a remote file with the wrong permissions - do not use accessors for status and error slots internally - test_d and test_e methods where broken when used with autodie, this bug may also affected rget, rput and other high level methods 1.70_06 Feb 13, 2012 - add put_content method - support perm option in mget, mput, rget and rput methods - better umask handling, now use an object to reset it at end of scope - improve debugging output 1.70_05 Feb 5, 2012 - on Compat::get $remote argument is optional - make Compat::(get|put) use best_effort by default - add support for best_effort feature 1.70_04 Jan 22, 2012 - check number of arguments passed to Compat methods 1.70_03 Dec 11, 2011 - remove uninitialized warning when using a custom transport (bug report by Kay-C. Baufeld) - several spelling corrections (patch contributed by Nicholas Bamber) 1.70_02 Dec 10, 2011 - syntax error, POSIX::WNOHANG was recognized as bareword in perl 5.8 1.70_01 Dec 9, 2011 - do not use Expect to handle password authentication but a hand-crafted method that uses IO::Pty directly - solve problem with connections stalling when using password authentication and the remote host was unreachable (bug report by Srini T) 1.69 Dec 9, 2011 - release as stable 1.68_08 Oct 11, 2011 - accept an array reference in ssh_cmd - use warnings::warnif to generate warnings - minor doc improvements and corrections - in case of sftp-server not found test were not skipped but failed 1.68_07 Oct 10, 2011 - password authentication was not working with the new IPC::Open3 replacement code (bug report by Srini T) - empty password handling was also broken - allow setting the backend on all the tests 1.68_06 Oct 9, 2011 - do not use the buggy IPC::Open3 under Unix/Linux. This is a mayor internal change, please report any connection problems that were not happening with previous versions of the module - allow testing Windows backend under Unix 1.68_05 Sep 27, 2011 - this version is more picky about incomplete responses to stat requests when copy_perms or copy_time are enabled (implicetly or explicitly) on get method - handle incomplete attributes in stat response inside get (bug report by Gus via the Perl Guru Forums). 1.68_04 Sep 7, 2011 - accept passing undef as second argument to put, get, rput, rget, mput and mget - catch invalid undefined arguments in several places - custom conversion usage was broken - add %DEFAULTS to Compat package for setting default options for Net::SFTP::Foreign methods called under the hood. 1.68_03 Aug 28, 2011 - atomic feature added to get, put and higher level methods using them - cleanup feature added to get and put - support for numbered feature added to rename - save final target name when a reference is passed as numbered option - refactor rput and rget handling of put, put_symlink, get and get_symlink options using hashes - remove operation inside put_symlink was clobbering error and status from previous symlink call - solve several minor bugs related to autodie handling - do not die from inside DESTROY methods when autodie is set - resume feature in get method was broken - refactor numbered logic inside _inc_numbered sub - refactor _gen_save_status_method using local 1.68_02 Jul 20, 2011 - make unix2dos clever so it doesn't convert CR+LF sequences into CR+CR+LF (bug report by Pavel Albertyan). 1.68_01 Jul 12, 2011 - add workaround for crippled versions of Scalar::Util - document overwrite and numbered options as accepted by the put method (reported by Paul Kolano) 1.67 Jul 4, 2011 - released as stable in order to solve critical bug: - solve regresion introduced in 1.63_05 that caused ssh to hang when trying to access the tty - pass password to plink via -pw and generate a warning when doing so - support for key_path constructor argument - support for autodie mode - docs misspelling errors corrected (reported by Michael Stevens) 1.66_01 Jun 3, 2011 - allow using regexp objects as patterns on glob and derived methods - some doc improvements 1.65 May 17, 2011 - die_on_error was broken 1.64 May 09, 2011 - release as stable - document the write_delay and read_ahead options - minor doc corrections 1.63_10 Apr 13, 2011 - workaround bug in perl 5.6 calling STORE in a tied filehandle - solve "not enough arguments for grep" when using an old version of Scalar::Util 1.63_09 Apr 12, 2011 - an error in the handler accessors was adding and useless wrapping layer 1.63_08 Jan 22, 2011 - bad method call inside mkpath corrected (bug report and solution by Adam Pingel) 1.63_07 Jan 20, 2011 - do not override PreferredAuthentication when explicitly set by the user (bug report and solution by Ave Wrigley) 1.63_06 Dec 10, 2010 - redirect_stderr_to_tty was redirecting to the wrong side of the tty (bug report by Russ Brewer) 1.63_05 Dec 6, 2010 - add support for hardlink@openssh.com extension - add die_on_error method - create a new process group for slave ssh process so that signals sent from the terminal are not propagated - better error messages 1.63_04 Nov 11, 2010 - workaround for IPC::Open3::open3 not working with tied file handles on Windows (bug report by Barnabas Bona) - several spelling corrections (contributed by Philippe Bruhat) 1.63_03 Nov 10, 2010 - On some OSs (i.e. AIX) reading/writing from non-blocking fds can result in EAGAIN even when select has indicated that data was available (bug report and patch by Bill Godfrey) 1.63_02 Nov 2, 2010 - Windows backend was not pipelining requests when called from put method 1.63_01 - support for Tectia client added (bug report by Russ Brewer) 1.62 Oct 5, 2010 - _catch_tainted_args was not being imported from helpers (bug report by rfbits at PerlMonks) 1.61 Sep 22, 2010 - remove some dead code introducing unneeded constraints that cause the Net::SSH2 backend to fail (bug report by Philippe Vouters) 1.60 Sep 20, 2010 - _ensure_list was not being imported from Helpers (bug report and solution by Jean-Benoît Baudens) 1.59 Sep 16, 2010 - kill ssh subprocess with KILL signal on Windows 1.58_08 Aug 22, 2010 - import _hexdump from Helpers.pm (bug report by Chuck Kozak) - call kill passing the signal name instead of using POSIX to get its number 1.58_07 Aug 2, 2010 - dump $! on failed sysreads and syswrites 1.58_06 Jul 12, 2010 - rput was broken under Windows (bug report by Brian E. Lozier) - do not use Fcntl S_IS* macro wrappers as S_ISLNK is not available under Windows - new FAQ about put failing because of forbidden setstat - minor doc improvements - use "kill $name" instead of using POSIX to get the signal number 1.58_05 Jun 7, 2010 - add support for stderr_discard also in Windows backend 1.58_04 Jun 7, 2010 - add support for stderr_discard 1.58_03 May 27, 2010 - even more debugging for put method and the resume feature 1.58_02 - add FAQ about strict host key checking - better debugging for put method 1.58_01 Apr 19, 2010 - add stderr redirection feature - minor doc corrections - add donating to OpenSSH entry in docs 1.57 Mar 14, 2010 - release as stable 1.56_09 Mar 11, 2010 - realpath feature was broken on find and ls methods (bug report by Paul Kolano) - taint checks on hashes were not reporting problems properly - minor doc corrections 1.56_08 Jan 5, 2010 - put'ting a tied file handle was generating some warnings (bug report and patch by Gavin Carr) 1.56_07 Dec 29, 2009 - new methods added: mget, mput, get_symlink, put_symlink - new numbered feature - some minor bugs corrected - glob can now also be used from Net::SFTP::Foreign::Local - some doc corrections and improvements - _call_on_error was not cleaning up under some conditions 1.56_06 Dec 14, 2009 - mkpath was broken, rewritten to not use the obsolete _normalize_path method (bug report by Peter Edwards). - add some tests for mkpath - introduce internal _clear_error_and_status method - completely remove _normalize_path - correct bug in _debug not printing sub name under some conditions 1.56_05 Dec 9, 2009 - add support for plugable backends ***THIS IS A MAYOR INTERNAL CHANGE THAT COULD INTRODUCE NEW BUGS*** 1.56_04 Dec 8, 2009 - remote file path joining sub rewritten (note: this could change the module behaviour in some corner cases) - new test file with path join operations - rput('.',...) was failing due to bad path joining for local filesystem (bug report by Aaron Paetznick). - accept keyboard-interactive authentication - some docs reorganization - add pointer to my wish list :-) 1.56_03 Nov 14, 2009 - use SIGTERM to kill children also on Windows - workaround Cygwin bug, fopen(..., a); ftell() does not return the size of the file 1.56_01 Oct 26, 2009 - pass PreferredAuthentication option to SSH process to force password authentication (bug and solution by Stewart Heckenberg) - use SIGTERM instead of SIGHUP to kill slave SSH process 1.55 Sep 9, 2009 - re-release as stable 1.54_03 Sep 4, 2009 - add debugging to _rel2abs 1.54_02 Aug 19, 2009 - add extra sanity check to setcwd method. It seems that some servers do not report an error when realpath is called on an inexistent file (bug report by Ben Szulc) - password authentication broken in AIX - some documentation corrections - more tests added 1.54_01 Jul 22, 2009 - yet another "Password not requested as expected" bug solved, $pty->close_slave was being called too soon (bug report by Tim Rayner) 1.53 Jul 6, 2009 - re-released as stable 1.52_12 Jul 2, 2009 - also if using password authentication, detect when the remote host key doesn't match the key stored in know_hosts and abort the connection (bug report by Ryan Niebur). - if using password authentication, detect when the target host key has not been accepted yet (bug report by Ryan Niebur) - work around for IPC::Open3 feature missing in old versions of that module that caused password authentication to fail under 5.6.x perls (bug report by Vetrivel). - find method would not follow links passed as arguments to the method or others found when ordered mode was selected (bug report by Paul Kolano) - detect bad passwords and other password authentication improvements - sample scripts added - atomic_rename was returning the wrong error code/string - Perl 5.11 changes the EOF call interface for tied file handles - attributes flags slot was incorrectly set on new_from_buffer - get/put_int64 optimization - add calling function name to debug output - add debug hexdumps for sysreads and syswrites - optimize some common ls usages to reduce CPU utilization - implement pipelining for ls command - ls bug, wanted was being called with the wrong arguments - add timestamps to debugging output - ensure that attribute arguments are of class Net::SFTP::Foreign::Attributes (feature request by Todd Rinaldo) - put_attributes was broken - move _hexdump to Helpers package - debug subsystem cleanup 1.51 Apr 7, 2009 - "get" corrupted the fetched files if $\ was non empty (bug report and solution by Dagfinn Ilmari Mannsaker) - increment default packet and queue size 1.50 Mar 18, 2009 - rel2abs was not collapsing duplicated slashes when joining paths, generating paths as '//home' that have an unexpected meaning under Windows (bug report and solution by Erik Weidel) 1.49 Mar 17, 2009 - use utf8::downgrade to handle data with may have its utf8 flag set (bug report by Jamie Lahowetz, solution by ikegami) - emulate SSH2_FXF_APPEND mode not supported by OpenSSH SFTP server - open flags documented - minor documentation corrections - follow_links option from find method was broken (bug report by Paul Kolano) - spurious debugging message removed from statvfs - put and get now accept a file handle instead of a file name for the local file (feature request by David Morel) - add support for append option in put and get - put and get documentation reorganized - improve write caching behavior, '_write_delay' is used to control the write buffer size (feature request by David Morel) 1.47 Feb 13, 2009 - add support for per object dirty cleanup flag required by proper Net::OpenSSH integration - add support for old SSH1 1.46 Dec 18, 2008 - release as stable version - improve synopsis documentation - commercial support offering note added 1.45 Nov 11, 2008 - reduce localized scope for $SIG{__DIE__} and $@ (bug report by David Serrano and David Riosalido) - workaround incomplete unicode support in perl 5.6.x - new FAQ entry about how to completely disable passwd authentication - add support for OpenSSH protocol extensions statvfs, fstatvfs and posix-rename. - add overwrite feature to rename method - new fs_encoding feature added ***this is a mayor internal change that could introduce new bugs*** - when parsing status msgs, the string was not being converted to utf8 - croak when utf8 data is written to remote files in any way. - binmode ssh_in and ssh_out - some minor documentation corrections - add support for mkpath (feature requested by Mark Murphy) - add support for late_set_attr (bug report by Oliver Dunbar) - add support for extended file attributes (bug report by Oliver Dunbar) - add support for the autodisconnect feature (bug report by Jared Watkins). - add support for multiprocess debugging 1.44 Oct 9, 2008 - put was using block sizes 4 times bigger than requested, bug introduced in 1.41 (reported by Hussain Syed). 1.43 Sep 8, 2008 - readline was slurping the full file contents (bug report by Sylvain Cousineau). 1.42 Jul 17, 2008 - experimental support for resuming file transfers - some typos fixed - TODO added 1.41 Jul 16, 2008 - add support for on the fly data conversions including dos2unix and unix2dos - copy_perm => 0 was being ignored in several methods (bug report by Dave Tauzell) 1.40 Jun 24, 2008 - work around for servers that do not include the mandatory error message on SSH_FXP_STATUS responses (bug report by Hugh Lampert). 1.39 Jun 23, 2008 - suppress warning on mod_perl environments (bug and solution reported by Eric Rybski). 1.38 May 20, 2008 - add experimental support for plink command - on get, don't change file size passed to callback - on get, survive stat failure for servers with stat/readdir disabled (bug reported by Hussain Syed) - default open mode set to read - add support for block_size and queue_size constructor arguments - limit usage of Expect and PTYs to authentication phase (bug reported by Tom Warkentin) - honour copy_perm option in put method (bug report by Bruce Harold) - copy_perms option renamed to copy_perm for consistency (copy_perms still supported) - glob optimization - typo in Net::SFTP::Foreign::Common::_set_errno was not setting $! correctly (bug report by Rafael Kitover) - add debugging support to _do_io and _set_(status|error) 1.36 Apr 18, 2008 - forbid usage of Net::SFTP::Foreign methods from Compat module (bug reported by Fred Zellinger) - document the password and passphrase constructor options. 1.35 Feb 8, 2008 - put method was failing for binary files under Windows because binmode was not set on the local filehandler (bug report and patch by Patrick Frazer). 1.34 Jan 8, 2008 - document rput. It said it was not implemented (bug report by Paul Kolano). - put method was failing for binary files under Windows because binmode was not set on the local filehandler (bug report and patch by Patrick Frazer). 1.33 Jan 6, 2008 - rremove was not removing dirs (bug report by Paul Kolano). - require perl >= 5.6 - add support for open/close and DESTROY debugging 1.32 Dec 8, 2007 - add new question to FAQ - document password and passphrase options (though, not completely). - somo minor documentation changes - on testing look for sftp-server on libexec dirs - and delete temporal files 1.31 Oct 8, 2007 - remove Win32::Socketpair loading, it is not used anymore - improve debugging - do not croak when invalid data from the other side appears 1.30 Aug 23, 2007 - add support for realpath option to ls method - add support for realpath and names_only to glob method - improve _set_status and _set_error methods - add support for password authentication and for keys with passphrases 1.29 Aug 14, 2007 - add support for names_only option to ls and find methods - make ls and find methods default to '.' - DESTROY was also messing with $? and $! values (bug reported by Dave Haywood) - better usage checking for several methods - add support for cwd (experimental) - symlink docs corrected - several other doc corrections 1.28 - argument checking in rename was wrong (reported by Greg Howard) - disable DIE custom handlers when using eval 1.27 Jul 7, 2007 - catch insecure $ENV{PATH} under taint mode (bug reported by jmarshll). 1.26 Jul 5, 2007 - my email was missing from the docs - make it work under taint checking (experimental feature). - work around bug in dualvar under taint checking 1.25 Jun 19, 2007 - remove some obsolete tests not working on 5.9.x 1.24 Jun 18, 2007 - DESTROY was messing up $@ (bug reported by Kai Grossjohann) - set $SIG{PIPE} handler inside _do_io to catch IO errors - don't execute external command when transport option is used on constructor 1.23 May 23, 2007 - release as stable! - some doc improvements 0.90_22 Apr 29, 2007 - experimental Windows support added 0.90_21 Apr 25, 2007 - some documentation improvements - check that ctor 'more' arguments are not joined - eliminate "Password" prompt on passwd_auth sample (solution suggested by Fletch on PerlMonks) 0.90_20 Apr 20, 2007 - add support for "transport" options on the constructor that allows to use password authentication and keys protected by a passphrase - add password authentication sample 0.90_19 Apr 5, 2007 - add abort method (feature requested by Jamie Lahowetz) 0.90_18 Mar 23, 2007 - fallback to dirty cleanup if ssh process doesn't exit cleanly in 8 seconds (bug reported by Brandon Schendel). 0.90_17 Mar 21, 2007 - add support for dont_save flag in get method, required for Compat module (bug reported by Jamie Lahowetz). 0.90_16 Mar 18, 2007 - new tests added - mkdir, rmdir, remove, setstat, fsetstat and _close methods argument parsing was wrong (bug #25101 reported by funkonaut) - wrong detection of Sort::Key corrected - debug mode was broken - network errors do not die anymore, documented 0.90_15 Dec 19 2006 - messages were not being queued on get method and so, performance was very bad (reported by "sched" via Perlmonks). - Auto reduce block size on get method. 0.90_14 Nov 8 2006 - FAQ section added on the module documentation - Net::SFTP supplant was not working, corrected 0.90_13 Sep 22 2006 - fchmod is not available everywhere, don't use it (bug and solution reported by Andre Tomt). 0.90_12 Aug 21 2006 - syntax error on Net::SFTP::Foreign::Compat corrected (reported by Hans Schligtenhorst). - supplant was misspelled - correct some dependency problems on Compat. - add test for Compat. 0.90_11 Jun 30 2006 - don't croak from connect on runtime errors - workaround bug in IPC::Open3 that leaves two processes running 0.90_10 May 17 2006 - 0 is a valid sftp handler. 0.90_09 Apr 25 2006 - bug on _do_io method corrected 0.90_08 Apr 24 2006 - bug for copy_perms => 0 corrected (reported by Erik Johansen). - usage checks added to most commands. 0.90_07 Apr 23 2006 - don't use pack for quads on little-endian systems (bug reported by Mogens Hafsjold) 0.90_06 Feb 24 2006 - implement rput - use Win32::Socketpair on Windows - implement API for local fs in Local - move common functions to Common and Helpers packages 0.90_05 Feb 23 2006 - convert remote file handle strings to tied file handles - most methods changed to mimic perl buil-ins - attach file position to file handles. 0.90_04 Feb 22 2006 - remove bug in get that could left remote file handles open - new methods readlink, symlink, rremove, rget. 0.90_03 Feb 21 2006 - minor corrections to the docs - new methods glob and join implemented. 0.90_02 Feb 20 2006 - added new method find - ls method expanded with callback - contructor rewritten - better docs for Constants package - Compat module updated - several corrections on the docs 0.90_01 Feb 16 2006 - almost full rewrite exposing new much improved and incompatible API!!! -------------------------------------------------------------------------- 0.57 Nov 29 2005 - check sysread return value when reading from pipe (bug report and patch submited by Mina Naguib). 0.56 Nov 14 2005 - correct bug on open2_cmd option 0.55 Oct 24 2005 - kill ssh process when done (bug reported by Alf Carlsson). 0.54 Sep 07 2005 - add support for transferring files bigger than 4GB 0.53 May 03 2005 - link to SFTP draft actualised 0.52 May 03 2005 - some typos corrected on the docs. 0.51 May 03 2005 - Net::SFTP::Foreign::Buffer reimplemented from scratch. It doesn't depend on Net::SSH::Perl::Buffer anymore. - use foreign 'ssh' to open connections. 0.50 May 02 2005 - Net::SFTP::Foreign FORKED !!! -------------------------------------------------------------------------- Previous revision history for Net::SFTP 0.09 2005.01.16 - New co-maintainer, David Robins (DBROBINS). - Adds a 'warn' argument to the constructor to allow supression or redirection of warnings. - Allows the 'ssh_args' constructor argument to be either a hash ref or an array ref. - Adds a 'status' method which returns the last SSH2_FX_* status value, or (status value, text) in list context (only useful after last failure). - Adds brief summary comments to some methods. - Returns failure if the remote open fails for 'get' (previous code ignored it); also moves the remote open before the local open so that we don't create empty local files if the remote file can't be opened. - Changes 'ls' to return an array reference in scalar context. - Documents: the fact that we die on protocol/local errors; the new option and method; changes to 'get'/'put' (formerly 'put' didn't return anything useful, and 'get's actual return values are the same, just better documented). - Adds a comprehensive remote test, but to use it one has to manually go in and configure a server a certain way, so it defaults to skipping everything; I'm including it as a base since there are currently no remote tests at all. 0.08 2003.12.12 - Net::SFTP::Buffer was passing an invalid option when loading Net::SSH::Perl::Buffer. - Add SUPPORT section to the docs. 0.07 2003.11.14 - Require Net::SSH::Perl 1.24, which also includes circular reference fixes. 0.06 2003.11.14 - New maintainer, Dave Rolsky. - Fixed a circular reference which caused connections to be held open indefinitely in a persistent environment like mod_perl. This uses weak references, so Perl 5.6.0+ is now required. This work was funded by Kineticode, Inc. - Added a LICENSE file. 0.05 2001.05.24 - Added help ('h' or '?') command to psftp. Moved all shell functionality into Net::SFTP::Shell. - Net::SFTP::Util needed to 'use Exporter'. 0.04 2001.05.16 - Fixed bug in put method when running fsetstat command; it was trying to set the UID/GID on the remote file, which was giving a permission denied message. Should not try to set UID/GID, so had to adjust flags. - Added eg/psftp, a working SFTP shell. - Moved READ and WRITE commands into their own methods (do_read and do_write, respectively). - Changed semantics of get method. Returning the contents of the remote file is no longer connected to whether a local file is passed as an argument; it is instead based on the calling context of 'get'. Updated docs to reflect this. 0.03 2001.05.15 - Documentation for all extra classes: Attributes, Buffer, Constants, and Util. - Documentation for command methods in Net::SFTP. - Added binmode when reading/writing from local files. - Added methods for all remaining commands in SFTP protocol version 3 (eg. remove, rmdir, mkdir, realpath, etc.). - Added callbacks to get and put, eg. for status messages, etc. - Fixed typo in Net::SFTP::Buffer::get_int64 that was breaking reading 64-bit ints. 0.02 2001.05.14 - Fixed bug with SSH2 server not sending one message per packet, ie. multiple packets have to be retrieved to make up one SFTP message. This would show up as a "Message length too long" error. Thanks to Matt Good for the spot. - Fixed bug with OpenSSH and SSH2 SFTP servers where after a certain amount of bytes the connection would hang. This was a bug in Net::SSH::Perl (channel window sizes) that is fixed in version 1.13. 0.01 2001.05.13 - original version; created by h2xs 1.19 libnet-sftp-foreign-perl-1.86+dfsg.orig/README0000644000175000017500000000205212726306517020052 0ustar salvisalviNet::SFTP::Foreign =================== Net::SFTP::Foreign implements an SFTP client in Perl using the native SSH client application to establish the connection to the remote host. PREREQUISITES An external SSH2 client reachable from your PATH. Perl modules: Test::More (mandatory) File::Which (optional, only for testing) Sort::Key (optional, for better performance) IO::Pty and its dependencies (optional, only required if password authentication is going to be used) If the sftp-server command is available it will be used to perform some tests, but it is not mandatory. INSTALLATION To install this module type the following: perl Makefile.PL make make test make install COPYRIGHT AND LICENCE Copyright (c) 2005-2016 by Salvador Fandino Copyright (c) 2001 Benjamin Trott, Copyright (c) 2003 David Rolsky. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may have available. libnet-sftp-foreign-perl-1.86+dfsg.orig/debug.txt0000644000175000017500000000101112516370257021012 0ustar salvisalvi 1 - message queueing/dequeuing 2 - remote file/dir open/close 4 - DESTROY and disconnect calls 8 - hexdumps of incomming packets 16 - hexdumps of outgoing packets 32 - _do_io, _conn_lost 64 - _set_error, _set_status 128 - on the fly transformations 256 - add timestamp and process id 512 - 1024 - hexdump of sysreads 2048 - hexdump of syswrites 4096 - _rel2abs 8192 - mkpath 16384 - put method 32768 - recursive methods 65536 - password login 131072 - private backend libnet-sftp-foreign-perl-1.86+dfsg.orig/TODO0000644000175000017500000000200512516370257017657 0ustar salvisalvi TODO ==== - audit fatal error handling, currently fatal errors can dissapear under best_effort and other similar conditions - port to OpenVMS - add support for later protocol versions - add support for encodings - add support for process filters on put/get operations - implement save_status methods as a wrapper like best_effort - reimplement autodie in a saner way - allow per-method enabling/disabling autodie DONE ==== - add support for capture_stderr option in constructor - add support for new extension methods available from late OpenSSH SFTP server (http://www.sfr-fresh.com/unix/misc/openssh-5.1.tar.gz:a/ssh/PROTOCOL) - add support for unix2dos and dos2unix transformations on the fly for get and put. - add support for restarting transfers in put, get and derived methods. - improve password login, remove Expect dependency and try to backport as much as possible fron Net::OpenSSH - detect unknown host key checking - make setstat failures optionally non fatal inside put method (relaxed) libnet-sftp-foreign-perl-1.86+dfsg.orig/lib/0000755000175000017500000000000012726520616017737 5ustar salvisalvilibnet-sftp-foreign-perl-1.86+dfsg.orig/lib/Net/0000755000175000017500000000000012726520616020465 5ustar salvisalvilibnet-sftp-foreign-perl-1.86+dfsg.orig/lib/Net/SFTP/0000755000175000017500000000000012726520616021241 5ustar salvisalvilibnet-sftp-foreign-perl-1.86+dfsg.orig/lib/Net/SFTP/Foreign.pm0000644000175000017500000052204312726520507023175 0ustar salvisalvipackage Net::SFTP::Foreign; our $VERSION = '1.86'; use strict; use warnings; use warnings::register; use Carp qw(carp croak); use Symbol (); use Errno (); use Fcntl; use File::Spec (); use Time::HiRes (); use POSIX (); BEGIN { if ($] >= 5.008) { require Encode; } else { # Work around for incomplete Unicode handling in perl 5.6.x require bytes; bytes->import(); *Encode::encode = sub { $_[1] }; *Encode::decode = sub { $_[1] }; *utf8::downgrade = sub { 1 }; } } # we make $Net::SFTP::Foreign::Helpers::debug an alias for # $Net::SFTP::Foreign::debug so that the user can set it without # knowing anything about the Helpers package! our $debug; BEGIN { *Net::SFTP::Foreign::Helpers::debug = \$debug }; use Net::SFTP::Foreign::Helpers qw(_is_reg _is_lnk _is_dir _debug _sort_entries _gen_wanted _gen_converter _hexdump _ensure_list _catch_tainted_args _file_part _umask_save_and_set _untaint); use Net::SFTP::Foreign::Constants qw( :fxp :flags :att :status :error SSH2_FILEXFER_VERSION ); use Net::SFTP::Foreign::Attributes; use Net::SFTP::Foreign::Buffer; require Net::SFTP::Foreign::Common; our @ISA = qw(Net::SFTP::Foreign::Common); our $dirty_cleanup; my $windows; BEGIN { $windows = $^O =~ /Win(?:32|64)/; if ($^O =~ /solaris/i) { $dirty_cleanup = 1 unless defined $dirty_cleanup; } } my $thread_generation = 1; sub CLONE { $thread_generation++ } sub _deprecated { if (warnings::enabled('deprecated') and warnings::enabled(__PACKAGE__)) { Carp::carp(join('', @_)); } } sub _next_msg_id { shift->{_msg_id}++ } use constant _empty_attributes => Net::SFTP::Foreign::Attributes->new; sub _queue_new_msg { my $sftp = shift; my $code = shift; my $id = $sftp->_next_msg_id; my $msg = Net::SFTP::Foreign::Buffer->new(int8 => $code, int32 => $id, @_); $sftp->_queue_msg($msg); return $id; } sub _queue_msg { my ($sftp, $buf) = @_; my $bytes = $buf->bytes; my $len = length $bytes; if ($debug and $debug & 1) { $sftp->{_queued}++; _debug(sprintf("queueing msg len: %i, code:%i, id:%i ... [$sftp->{_queued}]", $len, unpack(CN => $bytes))); $debug & 16 and _hexdump(pack('N', length($bytes)) . $bytes); } $sftp->{_bout} .= pack('N', length($bytes)); $sftp->{_bout} .= $bytes; } sub _do_io { $_[0]->{_backend}->_do_io(@_) } sub _conn_lost { my ($sftp, $status, $err, @str) = @_; $debug and $debug & 32 and _debug("_conn_lost"); $sftp->{_status} or $sftp->_set_status(defined $status ? $status : SSH2_FX_CONNECTION_LOST); $sftp->{_error} or $sftp->_set_error((defined $err ? $err : SFTP_ERR_CONNECTION_BROKEN), (@str ? @str : "Connection to remote server is broken")); undef $sftp->{_connected}; } sub _conn_failed { my $sftp = shift; $sftp->_conn_lost(SSH2_FX_NO_CONNECTION, SFTP_ERR_CONNECTION_BROKEN, @_) unless $sftp->{_error}; } sub _get_msg { my $sftp = shift; $debug and $debug & 1 and _debug("waiting for message... [$sftp->{_queued}]"); unless ($sftp->_do_io($sftp->{_timeout})) { $sftp->_conn_lost(undef, undef, "Connection to remote server stalled"); return undef; } my $bin = \$sftp->{_bin}; my $len = unpack N => substr($$bin, 0, 4, ''); my $msg = Net::SFTP::Foreign::Buffer->make(substr($$bin, 0, $len, '')); if ($debug and $debug & 1) { $sftp->{_queued}--; my ($code, $id, $status) = unpack( CNN => $$msg); $id = '-' if $code == SSH2_FXP_VERSION; $status = '-' unless $code == SSH2_FXP_STATUS; _debug(sprintf("got it!, len:%i, code:%i, id:%s, status: %s", $len, $code, $id, $status)); $debug & 8 and _hexdump($$msg); } return $msg; } sub _croak_bad_options { if (@_) { my $s = (@_ > 1 ? 's' : ''); croak "Invalid option$s '" . CORE::join("', '", @_) . "' or bad combination of options"; } } sub _fs_encode { my ($sftp, $path) = @_; Encode::encode($sftp->{_fs_encoding}, $path); } sub _fs_decode { my ($sftp, $path) = @_; Encode::decode($sftp->{_fs_encoding}, $path); } sub new { ${^TAINT} and &_catch_tainted_args; my $class = shift; unshift @_, 'host' if @_ & 1; my %opts = @_; my $sftp = { _msg_id => 0, _bout => '', _bin => '', _connected => 1, _queued => 0, _error => 0, _status => 0 }; bless $sftp, $class; if ($debug) { _debug "This is Net::SFTP::Foreign $Net::SFTP::Foreign::VERSION"; _debug "Loaded from $INC{'Net/SFTP/Foreign.pm'}"; _debug "Running on Perl $^V for $^O"; _debug "debug set to $debug"; _debug "~0 is " . ~0; } $sftp->_clear_error_and_status; my $backend = delete $opts{backend}; unless (ref $backend) { $backend = ($windows ? 'Windows' : 'Unix') unless (defined $backend); $backend =~ /^\w+$/ or croak "Bad backend name $backend"; my $backend_class = "Net::SFTP::Foreign::Backend::$backend"; eval "require $backend_class; 1" or croak "Unable to load backend $backend: $@"; $backend = $backend_class->_new($sftp, \%opts); } $sftp->{_backend} = $backend; if ($debug) { my $class = ref($backend) || $backend; no strict 'refs'; my $version = ${$class .'::VERSION'} || 0; _debug "Using backend $class $version"; } my %defs = $backend->_defaults; $sftp->{_autodie} = delete $opts{autodie}; $sftp->{_block_size} = delete $opts{block_size} || $defs{block_size} || 32*1024; $sftp->{_min_block_size} = delete $opts{min_block_size} || $defs{min_block_size} || 512; $sftp->{_queue_size} = delete $opts{queue_size} || $defs{queue_size} || 32; $sftp->{_read_ahead} = $defs{read_ahead} || $sftp->{_block_size} * 4; $sftp->{_write_delay} = $defs{write_delay} || $sftp->{_block_size} * 8; $sftp->{_autoflush} = delete $opts{autoflush}; $sftp->{_late_set_perm} = delete $opts{late_set_perm}; $sftp->{_dirty_cleanup} = delete $opts{dirty_cleanup}; $sftp->{_timeout} = delete $opts{timeout}; defined $sftp->{_timeout} and $sftp->{_timeout} <= 0 and croak "invalid timeout"; $sftp->{_fs_encoding} = delete $opts{fs_encoding}; if (defined $sftp->{_fs_encoding}) { $] < 5.008 and carp "fs_encoding feature is not supported in this perl version $]"; } else { $sftp->{_fs_encoding} = 'utf8'; } $sftp->autodisconnect(delete $opts{autodisconnect}); $backend->_init_transport($sftp, \%opts); %opts and _croak_bad_options(keys %opts); $sftp->_init unless $sftp->{_error}; $backend->_after_init($sftp); $sftp } sub autodisconnect { my ($sftp, $ad) = @_; if (not defined $ad or $ad == 2) { $debug and $debug & 4 and _debug "setting disconnecting pid to $$ and thread to $thread_generation"; $sftp->{_disconnect_by_pid} = $$; $sftp->{_disconnect_by_thread} = $thread_generation; } else { delete $sftp->{_disconnect_by_thread}; if ($ad == 0) { $sftp->{_disconnect_by_pid} = -1; } elsif ($ad == 1) { delete $sftp->{_disconnect_by_pid}; } else { croak "bad value '$ad' for autodisconnect"; } } 1; } sub disconnect { my $sftp = shift; my $pid = delete $sftp->{pid}; $debug and $debug & 4 and _debug("$sftp->disconnect called (ssh pid: ".($pid||'').")"); local $sftp->{_autodie}; $sftp->_conn_lost; if (defined $pid) { close $sftp->{ssh_out} if (defined $sftp->{ssh_out} and not $sftp->{_ssh_out_is_not_dupped}); close $sftp->{ssh_in} if defined $sftp->{ssh_in}; if ($windows) { kill KILL => $pid and waitpid($pid, 0); $debug and $debug & 4 and _debug "process $pid reaped"; } else { my $dirty = ( defined $sftp->{_dirty_cleanup} ? $sftp->{_dirty_cleanup} : $dirty_cleanup ); if ($dirty or not defined $dirty) { $debug and $debug & 4 and _debug("starting dirty cleanup of process $pid"); OUT: for my $sig (($dirty ? () : 0), qw(TERM TERM KILL KILL)) { $debug and $debug & 4 and _debug("killing process $pid with signal $sig"); $sig and kill $sig, $pid; local ($@, $SIG{__DIE__}, $SIG{__WARN__}); my $deadline = Time::HiRes::time + 8; my $dt = 0.01; while (Time::HiRes::time < $deadline) { my $wpr = waitpid($pid, POSIX::WNOHANG()); $debug and $debug & 4 and _debug("waitpid returned ", $wpr); last OUT if $wpr or $! == Errno::ECHILD(); Time::HiRes::sleep($dt); $dt *= 1.2; } } } else { while (1) { last if waitpid($pid, 0) > 0; if ($! != Errno::EINTR()) { warn "internal error: unexpected error in waitpid($pid): $!" if $! != Errno::ECHILD(); last; } } } $debug and $debug & 4 and _debug "process $pid reaped"; } } close $sftp->{_pty} if defined $sftp->{_pty}; 1 } sub DESTROY { local ($?, $!, $@); my $sftp = shift; my $dbpid = $sftp->{_disconnect_by_pid}; my $dbthread = $sftp->{_disconnect_by_thread}; $debug and $debug & 4 and _debug("$sftp->DESTROY called (current pid: $$, disconnect_by_pid: " . ($dbpid || '') . "), current thread generation: $thread_generation, disconnect_by_thread: " . ($dbthread || '') . ")"); if (!defined $dbpid or ($dbpid == $$ and $dbthread == $thread_generation)) { $sftp->disconnect } else { $debug and $debug & 4 and _debug "skipping disconnection because pid and/or thread generation don't match"; } } sub _init { my $sftp = shift; $sftp->_queue_msg( Net::SFTP::Foreign::Buffer->new(int8 => SSH2_FXP_INIT, int32 => SSH2_FILEXFER_VERSION)); if (my $msg = $sftp->_get_msg) { my $type = $msg->get_int8; if ($type == SSH2_FXP_VERSION) { my $version = $msg->get_int32; $sftp->{server_version} = $version; $sftp->{server_extensions} = {}; while (length $$msg) { my $key = $msg->get_str; my $value = $msg->get_str; $sftp->{server_extensions}{$key} = $value; if ($key eq 'vendor-id') { my $vid = Net::SFTP::Foreign::Buffer->make("$value"); $sftp->{_ext__vendor_id} = [ Encode::decode(utf8 => $vid->get_str), Encode::decode(utf8 => $vid->get_str), Encode::decode(utf8 => $vid->get_str), $vid->get_int64 ]; } elsif ($key eq 'supported2') { my $s2 = Net::SFTP::Foreign::Buffer->make("$value"); $sftp->{_ext__supported2} = [ $s2->get_int32, $s2->get_int32, $s2->get_int32, $s2->get_int32, $s2->get_int32, $s2->get_int16, $s2->get_int16, [map Encode::decode(utf8 => $_), $s2->get_str_list], [map Encode::decode(utf8 => $_), $s2->get_str_list] ]; } } return $version; } $sftp->_conn_lost(SSH2_FX_BAD_MESSAGE, SFTP_ERR_REMOTE_BAD_MESSAGE, "bad packet type, expecting SSH2_FXP_VERSION, got $type"); } elsif ($sftp->{_status} == SSH2_FX_CONNECTION_LOST and $sftp->{_password_authentication} and $sftp->{_password_sent}) { $sftp->_set_error(SFTP_ERR_PASSWORD_AUTHENTICATION_FAILED, "Password authentication failed or connection lost"); } return undef; } sub server_extensions { %{shift->{server_extensions}} } sub _check_extension { my ($sftp, $name, $version, $error, $errstr) = @_; my $ext = $sftp->{server_extensions}{$name}; return 1 if (defined $ext and $ext == $version); $sftp->_set_status(SSH2_FX_OP_UNSUPPORTED); $sftp->_set_error($error, "$errstr: extended operation not supported by server"); return undef; } # helper methods: sub _get_msg_and_check { my ($sftp, $etype, $eid, $err, $errstr) = @_; my $msg = $sftp->_get_msg; if ($msg) { my $type = $msg->get_int8; my $id = $msg->get_int32; $sftp->_clear_error_and_status; if ($id != $eid) { $sftp->_conn_lost(SSH2_FX_BAD_MESSAGE, SFTP_ERR_REMOTE_BAD_MESSAGE, $errstr, "bad packet sequence, expected $eid, got $id"); return undef; } if ($type != $etype) { if ($type == SSH2_FXP_STATUS) { my $code = $msg->get_int32; my $str = Encode::decode(utf8 => $msg->get_str); my $status = $sftp->_set_status($code, (defined $str ? $str : ())); $sftp->_set_error($err, $errstr, $status); } else { $sftp->_conn_lost(SSH2_FX_BAD_MESSAGE, SFTP_ERR_REMOTE_BAD_MESSAGE, $errstr, "bad packet type, expected $etype packet, got $type"); } return undef; } } $msg; } # reads SSH2_FXP_HANDLE packet and returns handle, or undef on failure sub _get_handle { my ($sftp, $eid, $error, $errstr) = @_; if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_HANDLE, $eid, $error, $errstr)) { return $msg->get_str; } return undef; } sub _rid { my ($sftp, $rfh) = @_; my $rid = $rfh->_rid; unless (defined $rid) { $sftp->_set_error(SFTP_ERR_REMOTE_ACCESING_CLOSED_FILE, "Couldn't access a file that has been previosly closed"); } $rid } sub _rfid { $_[1]->_check_is_file; &_rid; } sub _rdid { $_[1]->_check_is_dir; &_rid; } sub _queue_rid_request { my ($sftp, $code, $fh, $attrs) = @_; my $rid = $sftp->_rid($fh); return undef unless defined $rid; $sftp->_queue_new_msg($code, str => $rid, (defined $attrs ? (attr => $attrs) : ())); } sub _queue_rfid_request { $_[2]->_check_is_file; &_queue_rid_request; } sub _queue_rdid_request { $_[2]->_check_is_dir; &_queue_rid_request; } sub _queue_str_request { my($sftp, $code, $str, $attrs) = @_; $sftp->_queue_new_msg($code, str => $str, (defined $attrs ? (attr => $attrs) : ())); } sub _check_status_ok { my ($sftp, $eid, $error, $errstr) = @_; if (defined $eid) { if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_STATUS, $eid, $error, $errstr)) { my $status = $sftp->_set_status($msg->get_int32, $msg->get_str); return 1 if $status == SSH2_FX_OK; $sftp->_set_error($error, $errstr, $status); } } return undef; } sub setcwd { ${^TAINT} and &_catch_tainted_args; my ($sftp, $cwd, %opts) = @_; $sftp->_clear_error_and_status; my $check = delete $opts{check}; $check = 1 unless defined $check; %opts and _croak_bad_options(keys %opts); if (defined $cwd) { if ($check) { $cwd = $sftp->realpath($cwd); return undef unless defined $cwd; _untaint($cwd); my $a = $sftp->stat($cwd) or return undef; unless (_is_dir($a->perm)) { $sftp->_set_error(SFTP_ERR_REMOTE_BAD_OBJECT, "Remote object '$cwd' is not a directory"); return undef; } } else { $cwd = $sftp->_rel2abs($cwd); } return $sftp->{cwd} = $cwd; } else { delete $sftp->{cwd}; return $sftp->cwd if defined wantarray; } } sub cwd { @_ == 1 or croak 'Usage: $sftp->cwd()'; my $sftp = shift; return defined $sftp->{cwd} ? $sftp->{cwd} : $sftp->realpath(''); } ## SSH2_FXP_OPEN (3) # returns handle on success, undef on failure sub open { (@_ >= 2 and @_ <= 4) or croak 'Usage: $sftp->open($path [, $flags [, $attrs]])'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $path, $flags, $a) = @_; $path = $sftp->_rel2abs($path); defined $flags or $flags = SSH2_FXF_READ; defined $a or $a = Net::SFTP::Foreign::Attributes->new; my $id = $sftp->_queue_new_msg(SSH2_FXP_OPEN, str => $sftp->_fs_encode($path), int32 => $flags, attr => $a); my $rid = $sftp->_get_handle($id, SFTP_ERR_REMOTE_OPEN_FAILED, "Couldn't open remote file '$path'"); if ($debug and $debug & 2) { if (defined $rid) { _debug("new remote file '$path' open, rid:"); _hexdump($rid); } else { _debug("open failed: $sftp->{_status}"); } } defined $rid or return undef; my $fh = Net::SFTP::Foreign::FileHandle->_new_from_rid($sftp, $rid); $fh->_flag(append => 1) if ($flags & SSH2_FXF_APPEND); $fh; } sub _open_mkpath { my ($sftp, $filename, $mkpath, $flags, $attrs) = @_; $flags = ($flags || 0) | SSH2_FXF_WRITE|SSH2_FXF_CREAT; my $fh = do { local $sftp->{_autodie}; $sftp->open($filename, $flags, $attrs); }; unless ($fh) { if ($mkpath and $sftp->status == SSH2_FX_NO_SUCH_FILE) { my $da = $attrs->clone; $da->set_perm(($da->perm || 0) | 0700); $sftp->mkpath($filename, $da, 1) or return; $fh = $sftp->open($filename, $flags, $attrs); } else { $sftp->_ok_or_autodie; } } $fh; } ## SSH2_FXP_OPENDIR (11) sub opendir { @_ == 2 or croak 'Usage: $sftp->opendir($path)'; ${^TAINT} and &_catch_tainted_args; my $sftp = shift; my $path = shift; $path = $sftp->_rel2abs($path); my $id = $sftp->_queue_str_request(SSH2_FXP_OPENDIR, $sftp->_fs_encode($path), @_); my $rid = $sftp->_get_handle($id, SFTP_ERR_REMOTE_OPENDIR_FAILED, "Couldn't open remote dir '$path'"); if ($debug and $debug & 2) { _debug("new remote dir '$path' open, rid:"); _hexdump($rid); } defined $rid or return undef; Net::SFTP::Foreign::DirHandle->_new_from_rid($sftp, $rid, 0) } ## SSH2_FXP_READ (4) # returns data on success undef on failure sub sftpread { (@_ >= 3 and @_ <= 4) or croak 'Usage: $sftp->sftpread($fh, $offset [, $size])'; my ($sftp, $rfh, $offset, $size) = @_; unless ($size) { return '' if defined $size; $size = $sftp->{_block_size}; } my $rfid = $sftp->_rfid($rfh); defined $rfid or return undef; my $id = $sftp->_queue_new_msg(SSH2_FXP_READ, str=> $rfid, int64 => $offset, int32 => $size); if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_DATA, $id, SFTP_ERR_REMOTE_READ_FAILED, "Couldn't read from remote file")) { return $msg->get_str; } return undef; } ## SSH2_FXP_WRITE (6) # returns true on success, undef on failure sub sftpwrite { @_ == 4 or croak 'Usage: $sftp->sftpwrite($fh, $offset, $data)'; my ($sftp, $rfh, $offset) = @_; my $rfid = $sftp->_rfid($rfh); defined $rfid or return undef; utf8::downgrade($_[3], 1) or croak "wide characters found in data"; 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 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; $sftp->flush($rfh, 'out') if ($len >= $sftp->{_write_delay} or ($len and $sftp->{_autoflush} )); 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; substr($$bout, 0, $written, ''); $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}; my @msgid; my $askoff = length $$bin; my $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) { $eof = $sftp->_queue_new_msg(SSH2_FXP_READ, str=> $rfid, int64 => $pos + length $$bin, int32 => 1); } last; } } $sftp->_get_msg for @msgid; if ($eof) { $sftp->_get_msg_and_check(SSH2_FXP_DATA, $eof, SFTP_ERR_REMOTE_BLOCK_TOO_SMALL, "received block was too small") } if ($sftp->{_status} == SSH2_FX_EOF and length $$bin) { $sftp->_clear_error_and_status; } return $sftp->{_error} ? undef : 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 = ''; return $line; } } } sub readline { (@_ >= 2 and @_ <= 3) or croak 'Usage: $sftp->readline($fh [, $sep])'; my ($sftp, $rfh, $sep) = @_; $sep = "\n" if @_ < 3; if (!defined $sep or $sep eq '') { $sftp->_fill_read_cache($rfh); $sftp->{_error} and return undef; my $bin = $rfh->_bin; my $line = $$bin; $rfh->_inc_pos(length $line); $$bin = ''; return $line; } if (wantarray) { my @lines; while (defined (my $line = $sftp->_readline($rfh, $sep))) { push @lines, $line; } return @lines; } return $sftp->_readline($rfh, $sep); } sub getc { @_ == 2 or croak 'Usage: $sftp->getc($fh)'; my ($sftp, $rfh) = @_; $sftp->_fill_read_cache($rfh, 1); my $bin = $rfh->_bin; if (length $bin) { $rfh->_inc_pos(1); return substr $$bin, 0, 1, ''; } return undef; } ## SSH2_FXP_LSTAT (7), SSH2_FXP_FSTAT (8), SSH2_FXP_STAT (17) # these all return a Net::SFTP::Foreign::Attributes object on success, undef on failure sub lstat { @_ <= 2 or croak 'Usage: $sftp->lstat($path)'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $path) = @_; $path = '.' unless defined $path; $path = $sftp->_rel2abs($path); my $id = $sftp->_queue_str_request(SSH2_FXP_LSTAT, $sftp->_fs_encode($path)); if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_ATTRS, $id, SFTP_ERR_REMOTE_LSTAT_FAILED, "Couldn't stat remote link")) { return $msg->get_attributes; } return undef; } sub stat { @_ <= 2 or croak 'Usage: $sftp->stat($path_or_fh)'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $pofh) = @_; $pofh = '.' unless defined $pofh; my $id = $sftp->_queue_new_msg( (ref $pofh and UNIVERSAL::isa($pofh, 'Net::SFTP::Foreign::FileHandle')) ? ( SSH2_FXP_FSTAT, str => $sftp->_rid($pofh)) : ( SSH2_FXP_STAT, str => $sftp->_fs_encode($sftp->_rel2abs($pofh))) ); if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_ATTRS, $id, SFTP_ERR_REMOTE_STAT_FAILED, "Couldn't stat remote file")) { return $msg->get_attributes; } return undef; } sub fstat { _deprecated "fstat is deprecated and will be removed on the upcoming 2.xx series, " . "stat method accepts now both file handlers and paths"; goto &stat; } ## SSH2_FXP_RMDIR (15), SSH2_FXP_REMOVE (13) # these return true on success, undef on failure sub _gen_remove_method { my($name, $code, $error, $errstr) = @_; my $sub = sub { @_ == 2 or croak "Usage: \$sftp->$name(\$path)"; ${^TAINT} and &_catch_tainted_args; my ($sftp, $path) = @_; $path = $sftp->_rel2abs($path); my $id = $sftp->_queue_str_request($code, $sftp->_fs_encode($path)); $sftp->_check_status_ok($id, $error, $errstr); }; no strict 'refs'; *$name = $sub; } _gen_remove_method(remove => SSH2_FXP_REMOVE, SFTP_ERR_REMOTE_REMOVE_FAILED, "Couldn't delete remote file"); _gen_remove_method(rmdir => SSH2_FXP_RMDIR, SFTP_ERR_REMOTE_RMDIR_FAILED, "Couldn't remove remote directory"); ## SSH2_FXP_MKDIR (14), SSH2_FXP_SETSTAT (9) # these return true on success, undef on failure sub mkdir { (@_ >= 2 and @_ <= 3) or croak 'Usage: $sftp->mkdir($path [, $attrs])'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $path, $attrs) = @_; $attrs = _empty_attributes unless defined $attrs; $path = $sftp->_rel2abs($path); my $id = $sftp->_queue_str_request(SSH2_FXP_MKDIR, $sftp->_fs_encode($path), $attrs); $sftp->_check_status_ok($id, SFTP_ERR_REMOTE_MKDIR_FAILED, "Couldn't create remote directory"); } sub join { my $sftp = shift; my $a = '.'; while (@_) { my $b = shift; if (defined $b) { $b =~ s|^(?:\./+)+||; if (length $b and $b ne '.') { if ($b !~ m|^/| and $a ne '.' ) { $a = ($a =~ m|/$| ? "$a$b" : "$a/$b"); } else { $a = $b } $a =~ s|(?:/+\.)+/?$|/|; $a =~ s|(?<=[^/])/+$||; $a = '.' unless length $a; } } } $a; } sub _rel2abs { my ($sftp, $path) = @_; my $old = $path; my $cwd = $sftp->{cwd}; $path = $sftp->join($sftp->{cwd}, $path); $debug and $debug & 4096 and _debug("'$old' --> '$path'"); return $path } sub mkpath { (@_ >= 2 and @_ <= 4) or croak 'Usage: $sftp->mkpath($path [, $attrs [, $parent]])'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $path, $attrs, $parent) = @_; $sftp->_clear_error_and_status; my $first = !$parent; # skips file name $path =~ s{^(/*)}{}; my $start = $1; $path =~ s{/+$}{}; my @path; while (1) { if ($first) { $first = 0 } else { $path =~ s{/*[^/]*$}{} } my $p = "$start$path"; $debug and $debug & 8192 and _debug "checking $p"; if ($sftp->test_d($p)) { $debug and $debug & 8192 and _debug "$p is a dir"; last; } unless (length $path) { $sftp->_set_error(SFTP_ERR_REMOTE_MKDIR_FAILED, "Unable to make path, bad root"); return undef; } unshift @path, $p; } for my $p (@path) { $debug and $debug & 8192 and _debug "mkdir $p"; if ($p =~ m{^(?:.*/)?\.{1,2}$} or $p =~ m{/$}) { $debug and $debug & 8192 and _debug "$p is a symbolic dir, skipping"; unless ($sftp->test_d($p)) { $debug and $debug & 8192 and _debug "symbolic dir $p can not be checked"; $sftp->{_error} or $sftp->_set_error(SFTP_ERR_REMOTE_MKDIR_FAILED, "Unable to make path, bad name"); return undef; } } else { $sftp->mkdir($p, $attrs) or return undef; } } 1; } sub _mkpath_local { my ($sftp, $path, $perm, $parent) = @_; # When parent is set, the last path part is removed and the parent # directory of the path given created. my @parts = File::Spec->splitdir($path); $debug and $debug & 32768 and _debug "_mkpath_local($path, $perm, ".($parent||0).")"; if ($parent) { pop @parts while @parts and not length $parts[-1]; unless (@parts) { $sftp->_set_error(SFTP_ERR_LOCAL_MKDIR_FAILED, "mkpath failed, top dir reached"); return; } pop @parts; } my @tail; while (@parts) { my $target = File::Spec->catdir(@parts); if (-e $target) { unless (-d $target) { $sftp->_set_error(SFTP_ERR_LOCAL_BAD_OBJECT, "Local file '$target' is not a directory"); return; } last } unshift @tail, pop @parts; } while (@tail) { push @parts, shift @tail; my $target = File::Spec->catdir(@parts); $debug and $debug and 32768 and _debug "creating local directory '$target'"; unless (CORE::mkdir $target, $perm) { unless (do { local $!; -d $target}) { $sftp->_set_error(SFTP_ERR_LOCAL_MKDIR_FAILED, "mkdir '$target' failed", $!); return; } } } $debug and $debug & 32768 and _debug "_mkpath_local succeeded"; return 1; } sub setstat { @_ == 3 or croak 'Usage: $sftp->setstat($path_or_fh, $attrs)'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $pofh, $attrs) = @_; my $id = $sftp->_queue_new_msg( ( (ref $pofh and UNIVERSAL::isa($pofh, 'Net::SFTP::Foreign::FileHandle') ) ? ( SSH2_FXP_FSETSTAT, str => $sftp->_rid($pofh) ) : ( SSH2_FXP_SETSTAT, str => $sftp->_fs_encode($sftp->_rel2abs($pofh)) ) ), attr => $attrs ); return $sftp->_check_status_ok($id, SFTP_ERR_REMOTE_SETSTAT_FAILED, "Couldn't setstat remote file"); } ## SSH2_FXP_CLOSE (4), SSH2_FXP_FSETSTAT (10) # these return true on success, undef on failure sub fsetstat { _deprecated "fsetstat is deprecated and will be removed on the upcoming 2.xx series, " . "setstat method accepts now both file handlers and paths"; goto &setstat; } sub _gen_setstat_shortcut { my ($name, $rid_type, $attrs_flag, @arg_types) = @_; my $nargs = 2 + @arg_types; my $usage = ("\$sftp->$name(" . CORE::join(', ', '$path_or_fh', map "arg$_", 1..@arg_types) . ')'); my $rid_method = ($rid_type eq 'file' ? '_rfid' : $rid_type eq 'dir' ? '_rdid' : $rid_type eq 'any' ? '_rid' : croak "bad rid type $rid_type"); my $sub = sub { @_ == $nargs or croak $usage; my $sftp = shift; my $pofh = shift; my $id = $sftp->_queue_new_msg( ( (ref $pofh and UNIVERSAL::isa($pofh, 'Net::SFTP::Foreign::FileHandle') ) ? ( SSH2_FXP_FSETSTAT, str => $sftp->$rid_method($pofh) ) : ( SSH2_FXP_SETSTAT, str => $sftp->_fs_encode($sftp->_rel2abs($pofh)) ) ), int32 => $attrs_flag, map { $arg_types[$_] => $_[$_] } 0..$#arg_types ); $sftp->_check_status_ok($id, SFTP_ERR_REMOTE_SETSTAT_FAILED, "Couldn't setstat remote file ($name)"); }; no strict 'refs'; *$name = $sub; } _gen_setstat_shortcut(truncate => 'file', SSH2_FILEXFER_ATTR_SIZE, 'int64'); _gen_setstat_shortcut(chown => 'any' , SSH2_FILEXFER_ATTR_UIDGID, 'int32', 'int32'); _gen_setstat_shortcut(chmod => 'any' , SSH2_FILEXFER_ATTR_PERMISSIONS, 'int32'); _gen_setstat_shortcut(utime => 'any' , SSH2_FILEXFER_ATTR_ACMODTIME, 'int32', 'int32'); sub _close { @_ == 2 or croak 'Usage: $sftp->close($fh, $attrs)'; my $sftp = shift; my $id = $sftp->_queue_rid_request(SSH2_FXP_CLOSE, @_); defined $id or return undef; my $ok = $sftp->_check_status_ok($id, SFTP_ERR_REMOTE_CLOSE_FAILED, "Couldn't close remote file"); if ($debug and $debug & 2) { _debug sprintf("closing file handle, return: %s, rid:", (defined $ok ? $ok : '-')); _hexdump($sftp->_rid($_[0])); } return $ok; } sub close { @_ == 2 or croak 'Usage: $sftp->close($fh)'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $rfh) = @_; # defined $sftp->_rfid($rfh) or return undef; # ^--- commented out because flush already checks it is an open file $sftp->flush($rfh) or return undef; if ($sftp->_close($rfh)) { $rfh->_close; return 1 } undef } sub closedir { @_ == 2 or croak 'Usage: $sftp->closedir($dh)'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $rdh) = @_; $rdh->_check_is_dir; if ($sftp->_close($rdh)) { $rdh->_close; return 1; } undef } sub readdir { @_ == 2 or croak 'Usage: $sftp->readdir($dh)'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $rdh) = @_; my $rdid = $sftp->_rdid($rdh); defined $rdid or return undef; my $cache = $rdh->_cache; while (!@$cache or wantarray) { my $id = $sftp->_queue_str_request(SSH2_FXP_READDIR, $rdid); if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_NAME, $id, SFTP_ERR_REMOTE_READDIR_FAILED, "Couldn't read remote directory" )) { my $count = $msg->get_int32 or last; for (1..$count) { push @$cache, { filename => $sftp->_fs_decode($msg->get_str), longname => $sftp->_fs_decode($msg->get_str), a => $msg->get_attributes }; } } else { $sftp->_set_error if $sftp->{_status} == SSH2_FX_EOF; last; } } if (wantarray) { my $old = $cache; $cache = []; return @$old; } shift @$cache; } sub _readdir { my ($sftp, $rdh); if (wantarray) { my $line = $sftp->readdir($rdh); if (defined $line) { return $line->{filename}; } } else { return map { $_->{filename} } $sftp->readdir($rdh); } } sub _gen_getpath_method { my ($code, $error, $name) = @_; return sub { @_ == 2 or croak 'Usage: $sftp->some_method($path)'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $path) = @_; $path = $sftp->_rel2abs($path); my $id = $sftp->_queue_str_request($code, $sftp->_fs_encode($path)); if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_NAME, $id, $error, "Couldn't get $name for remote '$path'")) { $msg->get_int32 > 0 and return $sftp->_fs_decode($msg->get_str); $sftp->_set_error($error, "Couldn't get $name for remote '$path', no names on reply") } return undef; }; } ## SSH2_FXP_REALPATH (16) ## SSH2_FXP_READLINK (19) # return path on success, undef on failure *realpath = _gen_getpath_method(SSH2_FXP_REALPATH, SFTP_ERR_REMOTE_REALPATH_FAILED, "realpath"); *readlink = _gen_getpath_method(SSH2_FXP_READLINK, SFTP_ERR_REMOTE_READLINK_FAILED, "link target"); ## SSH2_FXP_RENAME (18) # true on success, undef on failure sub _rename { my ($sftp, $old, $new) = @_; $old = $sftp->_rel2abs($old); $new = $sftp->_rel2abs($new); my $id = $sftp->_queue_new_msg(SSH2_FXP_RENAME, str => $sftp->_fs_encode($old), str => $sftp->_fs_encode($new)); $sftp->_check_status_ok($id, SFTP_ERR_REMOTE_RENAME_FAILED, "Couldn't rename remote file '$old' to '$new'"); } sub rename { (@_ & 1) or croak 'Usage: $sftp->rename($old, $new, %opts)'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $old, $new, %opts) = @_; my $overwrite = delete $opts{overwrite}; my $numbered = delete $opts{numbered}; croak "'overwrite' and 'numbered' options can not be used together" if ($overwrite and $numbered); %opts and _croak_bad_options(keys %opts); if ($overwrite) { $sftp->atomic_rename($old, $new) and return 1; $sftp->{_status} != SSH2_FX_OP_UNSUPPORTED and return undef; } for (1) { local $sftp->{_autodie}; # we are optimistic here and try to rename it without testing # if a file of the same name already exists first if (!$sftp->_rename($old, $new) and $sftp->{_status} == SSH2_FX_FAILURE) { if ($numbered and $sftp->test_e($new)) { _inc_numbered($new); redo; } elsif ($overwrite) { my $rp_old = $sftp->realpath($old); my $rp_new = $sftp->realpath($new); if (defined $rp_old and defined $rp_new and $rp_old eq $rp_new) { $sftp->_clear_error_and_status; } elsif ($sftp->remove($new)) { $overwrite = 0; redo; } } } } $sftp->_ok_or_autodie; } sub atomic_rename { @_ == 3 or croak 'Usage: $sftp->atomic_rename($old, $new)'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $old, $new) = @_; $sftp->_check_extension('posix-rename@openssh.com' => 1, SFTP_ERR_REMOTE_RENAME_FAILED, "atomic rename failed") or return undef; $old = $sftp->_rel2abs($old); $new = $sftp->_rel2abs($new); my $id = $sftp->_queue_new_msg(SSH2_FXP_EXTENDED, str => 'posix-rename@openssh.com', str => $sftp->_fs_encode($old), str => $sftp->_fs_encode($new)); $sftp->_check_status_ok($id, SFTP_ERR_REMOTE_RENAME_FAILED, "Couldn't rename remote file '$old' to '$new'"); } ## SSH2_FXP_SYMLINK (20) # true on success, undef on failure sub symlink { @_ == 3 or croak 'Usage: $sftp->symlink($sl, $target)'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $sl, $target) = @_; $sl = $sftp->_rel2abs($sl); my $id = $sftp->_queue_new_msg(SSH2_FXP_SYMLINK, str => $sftp->_fs_encode($target), str => $sftp->_fs_encode($sl)); $sftp->_check_status_ok($id, SFTP_ERR_REMOTE_SYMLINK_FAILED, "Couldn't create symlink '$sl' pointing to '$target'"); } sub hardlink { @_ == 3 or croak 'Usage: $sftp->hardlink($hl, $target)'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $hl, $target) = @_; $sftp->_check_extension('hardlink@openssh.com' => 1, SFTP_ERR_REMOTE_HARDLINK_FAILED, "hardlink failed") or return undef; $hl = $sftp->_rel2abs($hl); $target = $sftp->_rel2abs($target); my $id = $sftp->_queue_new_msg(SSH2_FXP_EXTENDED, str => 'hardlink@openssh.com', str => $sftp->_fs_encode($target), str => $sftp->_fs_encode($hl)); $sftp->_check_status_ok($id, SFTP_ERR_REMOTE_HARDLINK_FAILED, "Couldn't create hardlink '$hl' pointing to '$target'"); } sub _gen_save_status_method { my $method = shift; sub { my $sftp = shift; local ($sftp->{_error}, $sftp->{_status}) if $sftp->{_error}; $sftp->$method(@_); } } *_close_save_status = _gen_save_status_method('close'); *_closedir_save_status = _gen_save_status_method('closedir'); *_remove_save_status = _gen_save_status_method('remove'); sub _inc_numbered { $_[0] =~ s{^(.*)\((\d+)\)((?:\.[^\.]*)?)$}{"$1(" . ($2+1) . ")$3"}e or $_[0] =~ s{((?:\.[^\.]*)?)$}{(1)$1}; $debug and $debug & 128 and _debug("numbering to: $_[0]"); } ## High-level client -> server methods. sub abort { my $sftp = shift; $sftp->_set_error(SFTP_ERR_ABORTED, ($@ ? $_[0] : "Aborted")); } # returns true on success, undef on failure sub get { @_ >= 2 or croak 'Usage: $sftp->get($remote, $local, %opts)'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $remote, $local, %opts) = @_; defined $remote or croak "remote file path is undefined"; $sftp->_clear_error_and_status; $remote = $sftp->_rel2abs($remote); $local = _file_part($remote) unless defined $local; my $local_is_fh = (ref $local and $local->isa('GLOB')); my $cb = delete $opts{callback}; my $umask = delete $opts{umask}; my $perm = delete $opts{perm}; my $copy_perm = delete $opts{exists $opts{copy_perm} ? 'copy_perm' : 'copy_perms'}; my $copy_time = delete $opts{copy_time}; my $overwrite = delete $opts{overwrite}; my $resume = delete $opts{resume}; my $append = delete $opts{append}; my $block_size = delete $opts{block_size} || $sftp->{_block_size}; my $queue_size = delete $opts{queue_size} || $sftp->{_queue_size}; my $dont_save = delete $opts{dont_save}; my $conversion = delete $opts{conversion}; my $numbered = delete $opts{numbered}; my $cleanup = delete $opts{cleanup}; my $atomic = delete $opts{atomic}; my $best_effort = delete $opts{best_effort}; my $mkpath = delete $opts{mkpath}; croak "'perm' and 'copy_perm' options can not be used simultaneously" if (defined $perm and defined $copy_perm); croak "'numbered' can not be used with 'overwrite', 'resume' or 'append'" if ($numbered and ($overwrite or $resume or $append)); if ($resume or $append) { $resume and $append and croak "'resume' and 'append' options can not be used simultaneously"; $atomic and croak "'atomic' can not be used with 'resume' or 'append'"; $overwrite and croak "'overwrite' can not be used with 'resume' or 'append'"; } if ($local_is_fh) { my $tail = 'option can not be used when target is a file handle'; $resume and croak "'resume' $tail"; $overwrite and croak "'overwrite' $tail"; $numbered and croak "'numbered' $tail"; $dont_save and croak "'dont_save' $tail"; $atomic and croak "'croak' $tail"; } %opts and _croak_bad_options(keys %opts); if ($resume and $conversion) { carp "resume option is useless when data conversion has also been requested"; undef $resume; } $overwrite = 1 unless (defined $overwrite or $local_is_fh or $numbered or $append); $copy_perm = 1 unless (defined $perm or defined $copy_perm or $local_is_fh); $copy_time = 1 unless (defined $copy_time or $local_is_fh); $mkpath = 1 unless defined $mkpath; $cleanup = ($atomic || $numbered) unless defined $cleanup; my $a = do { local $sftp->{_autodie}; $sftp->stat($remote); }; my ($rperm, $size, $atime, $mtime) = ($a ? ($a->perm, $a->size, $a->atime, $a->mtime) : ()); $size = -1 unless defined $size; if ($copy_time and not defined $atime) { if ($best_effort) { undef $copy_time; } else { $sftp->_ok_or_autodie and $sftp->_set_error(SFTP_ERR_REMOTE_STAT_FAILED, "Not enough information on stat, amtime not included"); return undef; } } $umask = (defined $perm ? 0 : umask) unless defined $umask; if ($copy_perm) { if (defined $rperm) { $perm = $rperm; } elsif ($best_effort) { undef $copy_perm } else { $sftp->_ok_or_autodie and $sftp->_set_error(SFTP_ERR_REMOTE_STAT_FAILED, "Not enough information on stat, mode not included"); return undef } } $perm &= ~$umask if defined $perm; $sftp->_clear_error_and_status; if ($resume and $resume eq 'auto') { undef $resume; if (defined $mtime) { if (my @lstat = CORE::stat $local) { $resume = ($mtime <= $lstat[9]); } } } my ($atomic_numbered, $atomic_local, $atomic_cleanup); my ($rfh, $fh); my $askoff = 0; my $lstart = 0; if ($dont_save) { $rfh = $sftp->open($remote, SSH2_FXF_READ); defined $rfh or return undef; } else { unless ($local_is_fh or $overwrite or $append or $resume or $numbered) { if (-e $local) { $sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS, "local file $local already exists"); return undef } } if ($atomic) { $atomic_local = $local; $local .= sprintf("(%d).tmp", rand(10000)); $atomic_numbered = $numbered; $numbered = 1; $debug and $debug & 128 and _debug("temporal local file name: $local"); } if ($resume) { if (CORE::open $fh, '+<', $local) { binmode $fh; CORE::seek($fh, 0, 2); $askoff = CORE::tell $fh; if ($askoff < 0) { # something is going really wrong here, fall # back to non-resuming mode... $askoff = 0; undef $fh; } else { if ($size >=0 and $askoff > $size) { $sftp->_set_error(SFTP_ERR_LOCAL_BIGGER_THAN_REMOTE, "Couldn't resume transfer, local file is bigger than remote"); return undef; } $size == $askoff and return 1; } } } # 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 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; } } if ($atomic) { if (!$overwrite) { while (1) { # performing a non-overwriting atomic rename is # quite burdensome: first, link is tried, if that # fails, non-overwriting is favoured over # atomicity and an empty file is used to lock the # path before atempting an overwriting rename. if (link $local, $atomic_local) { unlink $local; last; } my $err = $!; unless (-e $atomic_local) { if (sysopen my $lock, $atomic_local, Fcntl::O_CREAT|Fcntl::O_EXCL|Fcntl::O_WRONLY, 0600) { $atomic_cleanup = 1; goto OVERWRITE; } $err = $!; unless (-e $atomic_local) { $sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED, "Can't open $local", $err); goto CLEANUP; } } unless ($numbered) { $sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS, "local file $atomic_local already exists"); goto CLEANUP; } _inc_numbered($atomic_local); } } else { OVERWRITE: unless (CORE::rename $local, $atomic_local) { $sftp->_set_error(SFTP_ERR_LOCAL_RENAME_FAILED, "Unable to rename temporal file to its final position '$atomic_local'", $!); goto CLEANUP; } } $$atomic_numbered = $local if ref $atomic_numbered; } } CLEANUP: if ($cleanup and $sftp->{_error}) { unlink $local; unlink $atomic_local if $atomic_cleanup; } }; # autodie flag is restored here! $sftp->_ok_or_autodie; } # return file contents on success, undef on failure sub get_content { @_ == 2 or croak 'Usage: $sftp->get_content($remote)'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $name) = @_; $name = $sftp->_rel2abs($name); my @data; my $rfh = $sftp->open($name) or return undef; scalar $sftp->readline($rfh, undef); } sub put { @_ >= 2 or croak 'Usage: $sftp->put($local, $remote, %opts)'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $local, $remote, %opts) = @_; defined $local or croak "local file path is undefined"; $sftp->_clear_error_and_status; my $local_is_fh = (ref $local and $local->isa('GLOB')); unless (defined $remote) { $local_is_fh and croak "unable to infer remote file name when a file handler is passed as local"; $remote = (File::Spec->splitpath($local))[2]; } $remote = $sftp->_rel2abs($remote); my $cb = delete $opts{callback}; my $umask = delete $opts{umask}; my $perm = delete $opts{perm}; my $copy_perm = delete $opts{copy_perm}; $copy_perm = delete $opts{copy_perms} unless defined $copy_perm; my $copy_time = delete $opts{copy_time}; my $overwrite = delete $opts{overwrite}; my $resume = delete $opts{resume}; my $append = delete $opts{append}; my $block_size = delete $opts{block_size} || $sftp->{_block_size}; my $queue_size = delete $opts{queue_size} || $sftp->{_queue_size}; my $conversion = delete $opts{conversion}; my $late_set_perm = delete $opts{late_set_perm}; my $numbered = delete $opts{numbered}; my $atomic = delete $opts{atomic}; my $cleanup = delete $opts{cleanup}; my $best_effort = delete $opts{best_effort}; my $sparse = delete $opts{sparse}; my $mkpath = delete $opts{mkpath}; croak "'perm' and 'umask' options can not be used simultaneously" if (defined $perm and defined $umask); croak "'perm' and 'copy_perm' options can not be used simultaneously" if (defined $perm and $copy_perm); croak "'resume' and 'append' options can not be used simultaneously" if ($resume and $append); croak "'resume' and 'overwrite' options can not be used simultaneously" if ($resume and $overwrite); croak "'numbered' can not be used with 'overwrite', 'resume' or 'append'" if ($numbered and ($overwrite or $resume or $append)); croak "'atomic' can not be used with 'resume' or 'append'" if ($atomic and ($resume or $append)); %opts and _croak_bad_options(keys %opts); $overwrite = 1 unless (defined $overwrite or $numbered); $copy_perm = 1 unless (defined $perm or defined $copy_perm or $local_is_fh); $copy_time = 1 unless (defined $copy_time or $local_is_fh); $late_set_perm = $sftp->{_late_set_perm} unless defined $late_set_perm; $cleanup = ($atomic || $numbered) unless defined $cleanup; $mkpath = 1 unless defined $mkpath; my $neg_umask; if (defined $perm) { $neg_umask = $perm; } else { $umask = umask unless defined $umask; $neg_umask = 0777 & ~$umask; } my ($fh, $lmode, $lsize, $latime, $lmtime); if ($local_is_fh) { $fh = $local; # we don't set binmode for the passed file handle on purpose } else { unless (CORE::open $fh, '<', $local) { $sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED, "Unable to open local file '$local'", $!); return undef; } binmode $fh; } { # as $fh can come from the outside, it may be a tied object # lacking support for some methods, so we call them wrapped # inside eval blocks local ($@, $SIG{__DIE__}, $SIG{__WARN__}); if ((undef, undef, $lmode, undef, undef, undef, undef, $lsize, $latime, $lmtime) = eval { no warnings; # Calling stat on a tied handler # generates a warning because the op is # not supported by the tie API. CORE::stat $fh; } ) { $debug and $debug & 16384 and _debug "local file size is " . (defined $lsize ? $lsize : ''); # $fh can point at some place inside the file, not just at the # begining if ($local_is_fh and defined $lsize) { my $tell = eval { CORE::tell $fh }; $lsize -= $tell if $tell and $tell > 0; } } elsif ($copy_perm or $copy_time) { $sftp->_set_error(SFTP_ERR_LOCAL_STAT_FAILED, "Couldn't stat local file '$local'", $!); return undef; } elsif ($resume and $resume eq 'auto') { $debug and $debug & 16384 and _debug "not resuming because stat'ing the local file failed"; undef $resume } } $perm = $lmode & $neg_umask if $copy_perm; my $attrs = Net::SFTP::Foreign::Attributes->new; $attrs->set_perm($perm) if defined $perm; my $rfh; my $writeoff = 0; my $converter = _gen_converter $conversion; my $converted_input = ''; my $rattrs; if ($resume or $append) { $rattrs = do { local $sftp->{_autodie}; $sftp->stat($remote); }; if ($rattrs) { if ($resume and $resume eq 'auto' and $rattrs->mtime <= $lmtime) { $debug and $debug & 16384 and _debug "not resuming because local file is newer, r: ".$rattrs->mtime." l: $lmtime"; undef $resume; } else { $writeoff = $rattrs->size; $debug and $debug & 16384 and _debug "resuming from $writeoff"; } } else { if ($append) { $sftp->{_status} == SSH2_FX_NO_SUCH_FILE or $sftp->_ok_or_autodie or return undef; # no such file, no append undef $append; } $sftp->_clear_error_and_status; } } my ($atomic_numbered, $atomic_remote); if ($writeoff) { # one of $resume or $append is set if ($resume) { $debug and $debug & 16384 and _debug "resuming file transfer from $writeoff"; if ($converter) { # as size could change, we have to read and convert # data until we reach the given position on the local # file: my $off = 0; my $eof_t; while (1) { my $len = length $converted_input; my $delta = $writeoff - $off; if ($delta <= $len) { $debug and $debug & 16384 and _debug "discarding $delta converted bytes"; substr $converted_input, 0, $delta, ''; last; } else { $off += $len; if ($eof_t) { $sftp->_set_error(SFTP_ERR_REMOTE_BIGGER_THAN_LOCAL, "Couldn't resume transfer, remote file is bigger than local"); return undef; } my $read = CORE::read($fh, $converted_input, $block_size * 4); unless (defined $read) { $sftp->_set_error(SFTP_ERR_LOCAL_READ_ERROR, "Couldn't read from local file '$local' to the resume point $writeoff", $!); return undef; } $lsize += $converter->($converted_input) if defined $lsize; utf8::downgrade($converted_input, 1) or croak "converter introduced wide characters in data"; $read or $eof_t = 1; } } } elsif ($local_is_fh) { # as some PerlIO layer could be installed on the $fh, # just seeking to the resume position will not be # enough. We have to read and discard data until the # desired offset is reached my $off = $writeoff; while ($off) { my $read = CORE::read($fh, my($buf), ($off < 16384 ? $off : 16384)); if ($read) { $debug and $debug & 16384 and _debug "discarding $read bytes"; $off -= $read; } else { $sftp->_set_error(defined $read ? ( SFTP_ERR_REMOTE_BIGGER_THAN_LOCAL, "Couldn't resume transfer, remote file is bigger than local") : ( SFTP_ERR_LOCAL_READ_ERROR, "Couldn't read from local file handler '$local' to the resume point $writeoff", $!)); } } } else { if (defined $lsize and $writeoff > $lsize) { $sftp->_set_error(SFTP_ERR_REMOTE_BIGGER_THAN_LOCAL, "Couldn't resume transfer, remote file is bigger than local"); return undef; } unless (CORE::seek($fh, $writeoff, 0)) { $sftp->_set_error(SFTP_ERR_LOCAL_SEEK_FAILED, "seek operation on local file failed: $!"); return undef; } } if (defined $lsize and $writeoff == $lsize) { if (defined $perm and $rattrs->perm != $perm) { # FIXME: do copy_time here if required return $sftp->_best_effort($best_effort, setstat => $remote, $attrs); } return 1; } } $rfh = $sftp->open($remote, SSH2_FXF_WRITE) or return undef; } else { if ($atomic) { # check that does not exist a file of the same name that # would block the rename operation at the end if (!($numbered or $overwrite) and $sftp->test_e($remote)) { $sftp->_set_status(SSH2_FX_FAILURE); $sftp->_set_error(SFTP_ERR_REMOTE_ALREADY_EXISTS, "Remote file '$remote' already exists"); return undef; } $atomic_remote = $remote; $remote .= sprintf("(%d).tmp", rand(10000)); $atomic_numbered = $numbered; $numbered = 1; $debug and $debug & 128 and _debug("temporal remote file name: $remote"); } local $sftp->{_autodie}; if ($numbered) { 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 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, %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 ||= 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; if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_NAME, $id, SFTP_ERR_REMOTE_READDIR_FAILED, "Couldn't read directory '$dir'" )) { 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; } else { $sftp->_set_error if $sftp->{_status} == SSH2_FX_EOF; $sftp->_get_msg for @msgid; last; } } $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); } } } } ); _sort_entries(\@dirs); while (@dirs) { my $e = pop @dirs; if (!$wanted or $wanted->($sftp, $e)) { if ($sftp->rmdir($e->{filename})) { $count++; } else { $sftp->_call_on_error($on_error, $e); } } } return $count; } sub get_symlink { @_ >= 3 or croak 'Usage: $sftp->get_symlink($remote, $local, %opts)'; my ($sftp, $remote, $local, %opts) = @_; my $overwrite = delete $opts{overwrite}; my $numbered = delete $opts{numbered}; croak "'overwrite' and 'numbered' can not be used together" if ($overwrite and $numbered); %opts and _croak_bad_options(keys %opts); $overwrite = 1 unless (defined $overwrite or $numbered); my $a = $sftp->lstat($remote) or return undef; unless (_is_lnk($a->perm)) { $sftp->_set_error(SFTP_ERR_REMOTE_BAD_OBJECT, "Remote object '$remote' is not a symlink"); return undef; } my $link = $sftp->readlink($remote) or return undef; # TODO: this is too weak, may contain race conditions. if ($numbered) { _inc_numbered($local) while -e $local; } elsif (-e $local) { if ($overwrite) { unlink $local; } else { $sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS, "local file $local already exists"); return undef } } unless (eval { CORE::symlink $link, $local }) { $sftp->_set_error(SFTP_ERR_LOCAL_SYMLINK_FAILED, "creation of symlink '$local' failed", $!); return undef; } $$numbered = $local if ref $numbered; 1; } sub put_symlink { @_ >= 3 or croak 'Usage: $sftp->put_symlink($local, $remote, %opts)'; my ($sftp, $local, $remote, %opts) = @_; my $overwrite = delete $opts{overwrite}; my $numbered = delete $opts{numbered}; croak "'overwrite' and 'numbered' can not be used together" if ($overwrite and $numbered); %opts and _croak_bad_options(keys %opts); $overwrite = 1 unless (defined $overwrite or $numbered); my $perm = (CORE::lstat $local)[2]; unless (defined $perm) { $sftp->_set_error(SFTP_ERR_LOCAL_STAT_FAILED, "Couldn't stat local file '$local'", $!); return undef; } unless (_is_lnk($perm)) { $sftp->_set_error(SFTP_ERR_LOCAL_BAD_OBJECT, "Local file $local is not a symlink"); return undef; } my $target = readlink $local; unless (defined $target) { $sftp->_set_error(SFTP_ERR_LOCAL_READLINK_FAILED, "Couldn't read link '$local'", $!); return undef; } while (1) { local $sftp->{_autodie}; $sftp->symlink($remote, $target); if ($sftp->{_error} and $sftp->{_status} == SSH2_FX_FAILURE) { if ($numbered and $sftp->test_e($remote)) { _inc_numbered($remote); redo; } elsif ($overwrite and $sftp->_remove_save_status($remote)) { $overwrite = 0; redo; } } last } $$numbered = $remote if ref $numbered; $sftp->_ok_or_autodie; } sub rget { @_ >= 2 or croak 'Usage: $sftp->rget($remote, $local, %opts)'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $remote, $local, %opts) = @_; defined $remote or croak "remote file path is undefined"; $local = File::Spec->curdir unless defined $local; # my $cb = delete $opts{callback}; my $umask = delete $opts{umask}; my $copy_perm = delete $opts{exists $opts{copy_perm} ? 'copy_perm' : 'copy_perms'}; my $copy_time = delete $opts{copy_time}; my $newer_only = delete $opts{newer_only}; my $on_error = delete $opts{on_error}; local $sftp->{_autodie} if $on_error; my $ignore_links = delete $opts{ignore_links}; my $mkpath = delete $opts{mkpath}; # my $relative_links = delete $opts{relative_links}; my $wanted = _gen_wanted( delete $opts{wanted}, delete $opts{no_wanted} ); my %get_opts = (map { $_ => delete $opts{$_} } qw(block_size queue_size overwrite conversion resume numbered atomic best_effort)); if ($get_opts{resume} and $get_opts{conversion}) { carp "resume option is useless when data conversion has also been requested"; delete $get_opts{resume}; } my %get_symlink_opts = (map { $_ => $get_opts{$_} } qw(overwrite numbered)); %opts and _croak_bad_options(keys %opts); $remote = $sftp->join($remote, './'); my $qremote = quotemeta $remote; my $reremote = qr/^$qremote(.*)$/i; my $save = _umask_save_and_set $umask; $copy_perm = 1 unless defined $copy_perm; $copy_time = 1 unless defined $copy_time; $mkpath = 1 unless defined $mkpath; my $count = 0; $sftp->find( [$remote], descend => sub { my $e = $_[1]; # print "descend: $e->{filename}\n"; if (!$wanted or $wanted->($sftp, $e)) { my $fn = $e->{filename}; if ($fn =~ $reremote) { my $lpath = File::Spec->catdir($local, $1); ($lpath) = $lpath =~ /(.*)/ if ${^TAINT}; if (-d $lpath) { $sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS, "directory '$lpath' already exists"); $sftp->_call_on_error($on_error, $e); return 1; } else { my $perm = ($copy_perm ? $e->{a}->perm & 0777 : 0777); if (CORE::mkdir($lpath, $perm) or ($mkpath and $sftp->_mkpath_local($lpath, $perm))) { $count++; return 1; } $sftp->_set_error(SFTP_ERR_LOCAL_MKDIR_FAILED, "mkdir '$lpath' failed", $!); } } else { $sftp->_set_error(SFTP_ERR_REMOTE_BAD_PATH, "bad remote path '$fn'"); } $sftp->_call_on_error($on_error, $e); } return undef; }, wanted => sub { my $e = $_[1]; # print "file fn:$e->{filename}, a:$e->{a}\n"; unless (_is_dir($e->{a}->perm)) { if (!$wanted or $wanted->($sftp, $e)) { my $fn = $e->{filename}; if ($fn =~ $reremote) { my $lpath = File::Spec->catfile($local, $1); ($lpath) = $lpath =~ /(.*)/ if ${^TAINT}; if (_is_lnk($e->{a}->perm) and !$ignore_links) { if ($sftp->get_symlink($fn, $lpath, # copy_time => $copy_time, %get_symlink_opts)) { $count++; return undef; } } elsif (_is_reg($e->{a}->perm)) { if ($newer_only and -e $lpath and (CORE::stat _)[9] >= $e->{a}->mtime) { $sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS, "newer local file '$lpath' already exists"); } else { if ($sftp->get($fn, $lpath, copy_perm => $copy_perm, copy_time => $copy_time, %get_opts)) { $count++; return undef; } } } else { $sftp->_set_error(SFTP_ERR_REMOTE_BAD_OBJECT, ( $ignore_links ? "remote file '$fn' is not regular file or directory" : "remote file '$fn' is not regular file, directory or link")); } } else { $sftp->_set_error(SFTP_ERR_REMOTE_BAD_PATH, "bad remote path '$fn'"); } $sftp->_call_on_error($on_error, $e); } } return undef; } ); return $count; } sub rput { @_ >= 2 or croak 'Usage: $sftp->rput($local, $remote, %opts)'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $local, $remote, %opts) = @_; defined $local or croak "local path is undefined"; $remote = '.' unless defined $remote; # my $cb = delete $opts{callback}; my $umask = delete $opts{umask}; my $perm = delete $opts{perm}; my $copy_perm = delete $opts{exists $opts{copy_perm} ? 'copy_perm' : 'copy_perms'}; my $copy_time = delete $opts{copy_time}; my $newer_only = delete $opts{newer_only}; my $on_error = delete $opts{on_error}; local $sftp->{_autodie} if $on_error; my $ignore_links = delete $opts{ignore_links}; my $mkpath = delete $opts{mkpath}; my $wanted = _gen_wanted( delete $opts{wanted}, delete $opts{no_wanted} ); my %put_opts = (map { $_ => delete $opts{$_} } qw(block_size queue_size overwrite conversion resume numbered late_set_perm atomic best_effort sparse)); my %put_symlink_opts = (map { $_ => $put_opts{$_} } qw(overwrite numbered)); croak "'perm' and 'umask' options can not be used simultaneously" if (defined $perm and defined $umask); croak "'perm' and 'copy_perm' options can not be used simultaneously" if (defined $perm and $copy_perm); %opts and _croak_bad_options(keys %opts); require Net::SFTP::Foreign::Local; my $lfs = Net::SFTP::Foreign::Local->new; $local = $lfs->join($local, './'); my $relocal; if ($local =~ m|^\./?$|) { $relocal = qr/^(.*)$/; } else { my $qlocal = quotemeta $local; $relocal = qr/^$qlocal(.*)$/i; } $copy_perm = 1 unless defined $copy_perm; $copy_time = 1 unless defined $copy_time; $mkpath = 1 unless defined $mkpath; my $mask; if (defined $perm) { $mask = $perm & 0777; } else { $umask = umask unless defined $umask; $mask = 0777 & ~$umask; } if ($on_error) { my $on_error1 = $on_error; $on_error = sub { my $lfs = shift; $sftp->_copy_error($lfs); $sftp->_call_on_error($on_error1, @_); } } my $count = 0; $lfs->find( [$local], descend => sub { my $e = $_[1]; # print "descend: $e->{filename}\n"; if (!$wanted or $wanted->($lfs, $e)) { my $fn = $e->{filename}; $debug and $debug & 32768 and _debug "rput handling $fn"; if ($fn =~ $relocal) { my $rpath = $sftp->join($remote, File::Spec->splitdir($1)); $debug and $debug & 32768 and _debug "rpath: $rpath"; my $a = Net::SFTP::Foreign::Attributes->new; if (defined $perm) { $a->set_perm($mask | 0300); } elsif ($copy_perm) { $a->set_perm($e->{a}->perm & $mask); } if ($sftp->mkdir($rpath, $a)) { $count++; return 1; } if ($mkpath and $sftp->status == SSH2_FX_NO_SUCH_FILE) { $sftp->_clear_error_and_status; if ($sftp->mkpath($rpath, $a)) { $count++; return 1; } } $lfs->_copy_error($sftp); if ($sftp->test_d($rpath)) { $lfs->_set_error(SFTP_ERR_REMOTE_ALREADY_EXISTS, "Remote directory '$rpath' already exists"); $lfs->_call_on_error($on_error, $e); return 1; } } else { $lfs->_set_error(SFTP_ERR_LOCAL_BAD_PATH, "Bad local path '$fn'"); } $lfs->_call_on_error($on_error, $e); } return undef; }, wanted => sub { my $e = $_[1]; # print "file fn:$e->{filename}, a:$e->{a}\n"; unless (_is_dir($e->{a}->perm)) { if (!$wanted or $wanted->($lfs, $e)) { my $fn = $e->{filename}; $debug and $debug & 32768 and _debug "rput handling $fn"; if ($fn =~ $relocal) { my (undef, $d, $f) = File::Spec->splitpath($1); my $rpath = $sftp->join($remote, File::Spec->splitdir($d), $f); if (_is_lnk($e->{a}->perm) and !$ignore_links) { if ($sftp->put_symlink($fn, $rpath, %put_symlink_opts)) { $count++; return undef; } $lfs->_copy_error($sftp); } elsif (_is_reg($e->{a}->perm)) { my $ra; if ( $newer_only and $ra = $sftp->stat($rpath) and $ra->mtime >= $e->{a}->mtime) { $lfs->_set_error(SFTP_ERR_REMOTE_ALREADY_EXISTS, "Newer remote file '$rpath' already exists"); } else { if ($sftp->put($fn, $rpath, ( defined($perm) ? (perm => $perm) : $copy_perm ? (perm => $e->{a}->perm & $mask) : (copy_perm => 0, umask => $umask) ), copy_time => $copy_time, %put_opts)) { $count++; return undef; } $lfs->_copy_error($sftp); } } else { $lfs->_set_error(SFTP_ERR_LOCAL_BAD_OBJECT, ( $ignore_links ? "Local file '$fn' is not regular file or directory" : "Local file '$fn' is not regular file, directory or link")); } } else { $lfs->_set_error(SFTP_ERR_LOCAL_BAD_PATH, "Bad local path '$fn'"); } $lfs->_call_on_error($on_error, $e); } } return undef; } ); return $count; } sub mget { @_ >= 2 or croak 'Usage: $sftp->mget($remote, $localdir, %opts)'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $remote, $localdir, %opts) = @_; defined $remote or croak "remote pattern is undefined"; my $on_error = $opts{on_error}; local $sftp->{_autodie} if $on_error; my $ignore_links = delete $opts{ignore_links}; my %glob_opts = (map { $_ => delete $opts{$_} } qw(on_error follow_links ignore_case wanted no_wanted strict_leading_dot)); my %get_symlink_opts = (map { $_ => $opts{$_} } qw(overwrite numbered)); my %get_opts = (map { $_ => delete $opts{$_} } qw(umask perm copy_perm copy_time block_size queue_size overwrite conversion resume numbered atomic best_effort mkpath)); %opts and _croak_bad_options(keys %opts); my @remote = map $sftp->glob($_, %glob_opts), _ensure_list $remote; my $count = 0; require File::Spec; for my $e (@remote) { my $perm = $e->{a}->perm; if (_is_dir($perm)) { $sftp->_set_error(SFTP_ERR_REMOTE_BAD_OBJECT, "Remote object '$e->{filename}' is a directory"); } else { my $fn = $e->{filename}; my ($local) = $fn =~ m{([^\\/]*)$}; $local = File::Spec->catfile($localdir, $local) if defined $localdir; if (_is_lnk($perm)) { next if $ignore_links; $sftp->get_symlink($fn, $local, %get_symlink_opts); } else { $sftp->get($fn, $local, %get_opts); } } $count++ unless $sftp->{_error}; $sftp->_call_on_error($on_error, $e); } $count; } sub mput { @_ >= 2 or croak 'Usage: $sftp->mput($local, $remotedir, %opts)'; my ($sftp, $local, $remotedir, %opts) = @_; defined $local or die "local pattern is undefined"; my $on_error = $opts{on_error}; local $sftp->{_autodie} if $on_error; my $ignore_links = delete $opts{ignore_links}; my %glob_opts = (map { $_ => delete $opts{$_} } qw(on_error follow_links ignore_case wanted no_wanted strict_leading_dot)); my %put_symlink_opts = (map { $_ => $opts{$_} } qw(overwrite numbered)); my %put_opts = (map { $_ => delete $opts{$_} } qw(umask perm copy_perm copy_time block_size queue_size overwrite conversion resume numbered late_set_perm atomic best_effort sparse mkpath)); %opts and _croak_bad_options(keys %opts); require Net::SFTP::Foreign::Local; my $lfs = Net::SFTP::Foreign::Local->new; my @local = map $lfs->glob($_, %glob_opts), _ensure_list $local; my $count = 0; require File::Spec; for my $e (@local) { my $perm = $e->{a}->perm; if (_is_dir($perm)) { $sftp->_set_error(SFTP_ERR_REMOTE_BAD_OBJECT, "Remote object '$e->{filename}' is a directory"); } else { my $fn = $e->{filename}; my $remote = (File::Spec->splitpath($fn))[2]; $remote = $sftp->join($remotedir, $remote) if defined $remotedir; if (_is_lnk($perm)) { next if $ignore_links; $sftp->put_symlink($fn, $remote, %put_symlink_opts); } else { $sftp->put($fn, $remote, %put_opts); } } $count++ unless $sftp->{_error}; $sftp->_call_on_error($on_error, $e); } $count; } sub fsync { @_ == 2 or croak 'Usage: $sftp->fsync($fh)'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $fh) = @_; $sftp->flush($fh, "out"); $sftp->_check_extension('fsync@openssh.com' => 1, SFTP_ERR_REMOTE_FSYNC_FAILED, "fsync failed, not implemented") or return undef; my $id = $sftp->_queue_new_msg(SSH2_FXP_EXTENDED, str => 'fsync@openssh.com', str => $sftp->_rid($fh)); if ($sftp->_check_status_ok($id, SFTP_ERR_REMOTE_FSYNC_FAILED, "Couldn't fsync remote file")) { return 1; } return undef; } sub statvfs { @_ == 2 or croak 'Usage: $sftp->statvfs($path_or_fh)'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $pofh) = @_; my ($extension, $arg) = ( (ref $pofh and UNIVERSAL::isa($pofh, 'Net::SFTP::Foreign::FileHandle')) ? ('fstatvfs@openssh.com', $sftp->_rid($pofh) ) : ('statvfs@openssh.com' , $sftp->_fs_encode($sftp->_rel2abs($pofh)) ) ); $sftp->_check_extension($extension => 2, SFTP_ERR_REMOTE_STATVFS_FAILED, "statvfs failed, not implemented") or return undef; my $id = $sftp->_queue_new_msg(SSH2_FXP_EXTENDED, str => $extension, str => $arg); if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_EXTENDED_REPLY, $id, SFTP_ERR_REMOTE_STATVFS_FAILED, "Couldn't stat remote file system")) { my %statvfs = map { $_ => $msg->get_int64 } qw(bsize frsize blocks bfree bavail files ffree favail fsid flag namemax); return \%statvfs; } return undef; } sub fstatvfs { _deprecated "fstatvfs is deprecated and will be removed on the upcoming 2.xx series, " . "statvfs method accepts now both file handlers and paths"; goto &statvfs; } package Net::SFTP::Foreign::Handle; use Tie::Handle; our @ISA = qw(Tie::Handle); our @CARP_NOT = qw(Net::SFTP::Foreign Tie::Handle); my $gen_accessor = sub { my $ix = shift; sub { my $st = *{shift()}{ARRAY}; if (@_) { $st->[$ix] = shift; } else { $st->[$ix] } } }; my $gen_proxy_method = sub { my $method = shift; sub { my $self = $_[0]; $self->_check or return undef; my $sftp = $self->_sftp; if (wantarray) { my @ret = $sftp->$method(@_); $sftp->_set_errno unless @ret; return @ret; } else { my $ret = $sftp->$method(@_); $sftp->_set_errno unless defined $ret; return $ret; } } }; my $gen_not_supported = sub { sub { $! = Errno::ENOTSUP(); undef } }; sub TIEHANDLE { return shift } # sub UNTIE {} sub _new_from_rid { my $class = shift; my $sftp = shift; my $rid = shift; my $flags = shift || 0; my $self = Symbol::gensym; bless $self, $class; *$self = [ $sftp, $rid, 0, $flags, @_]; tie *$self, $self; $self; } sub _close { my $self = shift; @{*{$self}{ARRAY}} = (); } sub _check { return 1 if defined(*{shift()}{ARRAY}[0]); $! = Errno::EBADF(); undef; } sub FILENO { my $self = shift; $self->_check or return undef; my $hrid = unpack 'H*' => $self->_rid; "-1:sftp(0x$hrid)" } sub _sftp { *{shift()}{ARRAY}[0] } sub _rid { *{shift()}{ARRAY}[1] } * _pos = $gen_accessor->(2); sub _inc_pos { my ($self, $inc) = @_; *{shift()}{ARRAY}[2] += $inc; } my %flag_bit = (append => 0x1); sub _flag { my $st = *{shift()}{ARRAY}; my $fn = shift; my $flag = $flag_bit{$fn}; Carp::croak("unknown flag $fn") unless defined $flag; if (@_) { if (shift) { $st->[3] |= $flag; } else { $st->[3] &= ~$flag; } } $st->[3] & $flag ? 1 : 0 } sub _check_is_file { Carp::croak("expecting remote file handler, got directory handler"); } sub _check_is_dir { Carp::croak("expecting remote directory handler, got file handler"); } my $autoloaded; sub AUTOLOAD { my $self = shift; our $AUTOLOAD; if ($autoloaded) { my $class = ref $self || $self; Carp::croak qq|Can't locate object method "$AUTOLOAD" via package "$class|; } else { $autoloaded = 1; require IO::File; require IO::Dir; my ($method) = $AUTOLOAD =~ /^.*::(.*)$/; $self->$method(@_); } } package Net::SFTP::Foreign::FileHandle; our @ISA = qw(Net::SFTP::Foreign::Handle IO::File); sub _new_from_rid { my $class = shift; my $sftp = shift; my $rid = shift; my $flags = shift; my $self = $class->SUPER::_new_from_rid($sftp, $rid, $flags, '', ''); } sub _check_is_file {} sub _bin { \(*{shift()}{ARRAY}[4]) } sub _bout { \(*{shift()}{ARRAY}[5]) } sub WRITE { my ($self, undef, $length, $offset) = @_; $self->_check or return undef; $offset = 0 unless defined $offset; $offset = length $_[1] + $offset if $offset < 0; $length = length $_[1] unless defined $length; my $sftp = $self->_sftp; my $ret = $sftp->write($self, substr($_[1], $offset, $length)); $sftp->_set_errno unless defined $ret; $ret; } sub READ { my ($self, undef, $len, $offset) = @_; $self->_check or return undef; $_[1] = '' unless defined $_[1]; $offset ||= 0; if ($offset > length $_[1]) { $_[1] .= "\0" x ($offset - length $_[1]) } if ($len == 0) { substr($_[1], $offset) = ''; return 0; } my $sftp = $self->_sftp; $sftp->_fill_read_cache($self, $len); my $bin = $self->_bin; if (length $$bin) { my $data = substr($$bin, 0, $len, ''); $self->_inc_pos($len); substr($_[1], $offset) = $data; return length $data; } return 0 if $sftp->{_status} == $sftp->SSH2_FX_EOF; $sftp->_set_errno; undef; } sub EOF { my $self = $_[0]; $self->_check or return undef; my $sftp = $self->_sftp; my $ret = $sftp->eof($self); $sftp->_set_errno unless defined $ret; $ret; } *GETC = $gen_proxy_method->('getc'); *TELL = $gen_proxy_method->('tell'); *SEEK = $gen_proxy_method->('seek'); *CLOSE = $gen_proxy_method->('close'); my $readline = $gen_proxy_method->('readline'); sub READLINE { $readline->($_[0], $/) } sub OPEN { shift->CLOSE; undef; } sub DESTROY { local ($@, $!, $?); my $self = shift; my $sftp = $self->_sftp; $debug and $debug & 4 and Net::SFTP::Foreign::_debug("$self->DESTROY called (sftp: ".($sftp||'').")"); if ($self->_check and $sftp) { local $sftp->{_autodie}; $sftp->_close_save_status($self) } } package Net::SFTP::Foreign::DirHandle; our @ISA = qw(Net::SFTP::Foreign::Handle IO::Dir); sub _new_from_rid { my $class = shift; my $sftp = shift; my $rid = shift; my $flags = shift; my $self = $class->SUPER::_new_from_rid($sftp, $rid, $flags, []); } sub _check_is_dir {} sub _cache { *{shift()}{ARRAY}[4] } *CLOSEDIR = $gen_proxy_method->('closedir'); *READDIR = $gen_proxy_method->('_readdir'); sub OPENDIR { shift->CLOSEDIR; undef; } *REWINDDIR = $gen_not_supported->(); *TELLDIR = $gen_not_supported->(); *SEEKDIR = $gen_not_supported->(); sub DESTROY { local ($@, $!, $?); my $self = shift; my $sftp = $self->_sftp; $debug and $debug & 4 and Net::SFTP::Foreign::_debug("$self->DESTROY called (sftp: ".($sftp||'').")"); if ($self->_check and $sftp) { local $sftp->{_autodie}; $sftp->_closedir_save_status($self) } } 1; __END__ =head1 NAME Net::SFTP::Foreign - SSH File Transfer Protocol client =head1 SYNOPSIS use Net::SFTP::Foreign; my $sftp = Net::SFTP::Foreign->new($host); $sftp->die_on_error("Unable to establish SFTP connection"); $sftp->setcwd($path) or die "unable to change cwd: " . $sftp->error; $sftp->get("foo", "bar") or die "get failed: " . $sftp->error; $sftp->put("bar", "baz") or die "put failed: " . $sftp->error; =head1 DESCRIPTION SFTP stands for SSH File Transfer Protocol and is a method of transferring files between machines over a secure, encrypted connection (as opposed to regular FTP, which functions over an insecure connection). The security in SFTP comes through its integration with SSH, which provides an encrypted transport layer over which the SFTP commands are executed. Net::SFTP::Foreign is a Perl client for the SFTP version 3 as defined in the SSH File Transfer Protocol IETF draft, which can be found at L (also included on this package distribution, on the C directory). Net::SFTP::Foreign uses any compatible C command installed on the system (for instance, OpenSSH C) to establish the secure connection to the remote server. A wrapper module L is also provided for compatibility with L. =head2 Net::SFTP::Foreign Vs. Net::SFTP Vs. Net::SSH2::SFTP Why should I prefer Net::SFTP::Foreign over L? Well, both modules have their pros and cons: Net::SFTP::Foreign does not require a bunch of additional modules and external libraries to work, just the OpenBSD SSH client (or any other client compatible enough). I trust OpenSSH SSH client more than L, there are lots of paranoid people ensuring that OpenSSH doesn't have security holes!!! If you have an SSH infrastructure already deployed, by using the same binary SSH client, Net::SFTP::Foreign ensures a seamless integration within your environment (configuration files, keys, etc.). Net::SFTP::Foreign is much faster transferring files, specially over networks with high (relative) latency. Net::SFTP::Foreign provides several high level methods not available from Net::SFTP as for instance C, C, C, C, C, C, C. On the other hand, using the external command means an additional process being launched and running, depending on your OS this could eat more resources than the in process pure perl implementation provided by L. L is a module wrapping libssh2, an SSH version 2 client library written in C. It is a very active project that aims to replace L. Unfortunately, libssh2 SFTP functionality (available in Perl via L) is rather limited and its performance very poor. Later versions of Net::SFTP::Foreign can use L as the transport layer via the backend module L. =head2 Error handling The method C<$sftp-Eerror> can be used to check for errors after every method call. For instance: $sftp = Net::SFTP::Foreign->new($host); $sftp->error and die "unable to connect to remote host: " . $sftp->error; Also, the L method provides a handy shortcut for the last line: $sftp = Net::SFTP::Foreign->new($host); $sftp->die_on_error("unable to connect to remote host"); The C method can also be used to get the value for the last SFTP status response, but that is only useful when calling low level methods mapping to single SFTP primitives. In any case, it should be considered an implementation detail of the module usable only for troubleshooting and error reporting. =head2 autodie mode When the C mode is set at construction time, non-recoverable errors are automatically promoted to exceptions. For instance: $sftp = Net::SFTP::Foreign->new($host, autodie => 1); my $ls = $sftp->ls("/bar"); # dies as: "Couldn't open remote dir '/bar': No such file" =head3 Error handling in non-recursive methods Most of the non-recursive methods available from this package return undef on failure and a true value or the requested data on success. For instance: $sftp->get($from, $to) or die "get failed!"; =head3 Error handling in recursive methods Recursive methods (i.e. C, C, C, C) do not stop on errors but just skip the affected files and directories and keep going. After a call to a recursive method, the error indicator is only set when an unrecoverable error is found (i.e. a connection lost). For instance, this code doesn't work as expected: $sftp->rremove($dir); $sftp->error and die "rremove failed"; # this is wrong!!! This does: my $errors; $sftp->rremove($dir, on_error => sub { $errors++}); $errors and die "rremove failed"; The C mode is disabled when an C handler is passed to methods accepting it: my $sftp = Net::SFTP::Foreign->new($host, autodie => 1); # prints "foo!" and does not die: $sftp->find("/sdfjkalshfl", # nonexistent directory on_error => sub { print "foo!\n" }); # dies: $sftp->find("/sdfjkalshfl"); =head2 API The methods available from this module are described below. Don't forget to read also the FAQ and BUGS sections at the end of this document! =over 4 =item Net::SFTP::Foreign->new($host, %args) =item Net::SFTP::Foreign->new(%args) Opens a new SFTP connection with a remote host C<$host>, and returns a Net::SFTP::Foreign object representing that open connection. An explicit check for errors should be included always after the constructor call: my $sftp = Net::SFTP::Foreign->new(...); $sftp->die_on_error("SSH connection failed"); The optional arguments accepted are as follows: =over 4 =item host =E $hostname remote host name =item user =E $username username to log in to the remote server. This should be your SSH login, and can be empty, in which case the username is drawn from the user executing the process. =item port =E $portnumber port number where the remote SSH server is listening =item ssh1 =E 1 use old SSH1 approach for starting the remote SFTP server. =item more =E [@more_ssh_args] additional args passed to C command. For debugging purposes you can run C in verbose mode passing it the C<-v> option: my $sftp = Net::SFTP::Foreign->new($host, more => '-v'); Note that this option expects a single command argument or a reference to an array of arguments. For instance: more => '-v' # right more => ['-v'] # right more => "-c $cipher" # wrong!!! more => [-c => $cipher] # right =item timeout =E $seconds when this parameter is set, the connection is dropped if no data arrives on the SSH socket for the given time while waiting for some command to complete. When the timeout expires, the current method is aborted and the SFTP connection becomes invalid. Note that the given value is used internally to time out low level operations. The high level operations available through the API may take longer to expire (sometimes up to 4 times longer). The C backend used by default when the operating system is MS Windows (though, not under Cygwin perl), does not support timeouts. To overcome this limitation you can switch to the C backend or use L that provides its own backend supporting timeouts. =item fs_encoding =E $encoding Version 3 of the SFTP protocol (the one supported by this module) knows nothing about the character encoding used on the remote filesystem to represent file and directory names. This option allows one to select the encoding used in the remote machine. The default value is C. For instance: $sftp = Net::SFTP::Foreign->new('user@host', fs_encoding => 'latin1'); will convert any path name passed to any method in this package to its C representation before sending it to the remote side. Note that this option will not affect file contents in any way. This feature is not supported in perl 5.6 due to incomplete Unicode support in the interpreter. =item key_path =E $filename =item key_path =E \@filenames asks C to use the key(s) in the given file(s) for authentication. =item password =E $password Logs into the remote host using password authentication with the given password. Password authentication is only available if the module L is installed. Note also, that on Windows this module is only available when running the Cygwin port of Perl. =item asks_for_username_at_login =E 0|'auto'|1 During the interactive authentication dialog, most SSH servers only ask for the user password as the login name is passed inside the SSH protocol. But under some uncommon servers or configurations it is possible that a username is also requested. When this flag is set to C<1>, the username will be send unconditionally at the first remote prompt and then the password at the second. When it is set to C the module will use some heuristics in order to determine if it is being asked for an username. When set to C<0>, the username will never be sent during the authentication dialog. This is the default. =item password_prompt => $regex_or_str The module expects the password prompt from the remote server to end in a colon or a question mark. This seems to cover correctly 99% of real life cases. Otherwise this option can be used to handle the exceptional cases. For instance: $sftp = Net::SFTP::Foreign->new($host, password => $password, password_prompt => qr/\bpassword>\s*$/); Note that your script will hang at the login phase if the wrong prompt is used. =item passphrase =E $passphrase Logs into the remote server using a passphrase protected private key. Requires also the module L. =item expect_log_user =E $bool This feature is obsolete as Expect is not used anymore to handle password authentication. =item ssh_cmd =E $sshcmd =item ssh_cmd =E \@sshcmd name of the external SSH client. By default C is used. For instance: $sftp = Net::SFTP::Foreign->new($host, ssh_cmd => 'plink'); When an array reference is used, its elements are inserted at the beginning of the system call. That allows one, for instance, to connect to the target host through some SSH proxy: $sftp = Net::SFTP::Foreign->new($host, ssh_cmd => qw(ssh -l user proxy.server ssh)); But note that the module will not handle password authentication for those proxies. =item ssh_cmd_interface =E 'plink' or 'ssh' or 'tectia' declares the command line interface that the SSH client used to connect to the remote host understands. Currently C, C and C are supported. This option would be rarely required as the module infers the interface from the SSH command name. =item transport =E $fh =item transport =E [$in_fh, $out_fh] =item transport =E [$in_fh, $out_fh, $pid] allows one to use an already open pipe or socket as the transport for the SFTP protocol. It can be (ab)used to make this module work with password authentication or with keys requiring a passphrase. C is the file handler used to read data from the remote server, C is the file handler used to write data. On some systems, when using a pipe as the transport, closing it, does not cause the process at the other side to exit. The additional C<$pid> argument can be used to instruct this module to kill that process if it doesn't exit by itself. =item open2_cmd =E [@cmd] =item open2_cmd =E $cmd; allows one to completely redefine how C is called. Its arguments are passed to L to open a pipe to the remote server. =item stderr_fh =E $fh redirects the output sent to stderr by the SSH subprocess to the given file handle. It can be used to suppress banners: open my $ssherr, '>', '/dev/null' or die "unable to open /dev/null"; my $sftp = Net::SFTP::Foreign->new($host, stderr_fh => $ssherr); Or to send SSH stderr to a file in order to capture errors for later analysis: my $ssherr = File::Temp->new or die "File::Temp->new failed"; my $sftp = Net::SFTP::Foreign->new($hostname, more => ['-v'], stderr_fh => $ssherr); if ($sftp->error) { print "sftp error: ".$sftp->error."\n"; seek($ssherr, 0, 0); while (<$ssherr>) { print "captured stderr: $_"; } } =item stderr_discard =E 1 redirects stderr to /dev/null =item block_size =E $default_block_size =item queue_size =E $default_queue_size default C and C used for read and write operations (see the C or C documentation). =item autoflush =E $bool by default, and for performance reasons, write operations are cached, and only when the write buffer becomes big enough is the data written to the remote file. Setting this flag makes the write operations immediate. =item write_delay =E $bytes This option determines how many bytes are buffered before the real SFTP write operation is performed. =item read_ahead =E $bytes On read operations this option determines how many bytes to read in advance so that later read operations can be fulfilled from the buffer. Using a high value will increase the performance of the module for a sequential reads access pattern but degrade it for a short random reads access pattern. It can also cause synchronization problems if the file is concurrently modified by other parties (L can be used to discard all the data inside the read buffer on demand). The default value is set dynamically considering some runtime parameters and given options, though it tends to favor the sequential read access pattern. =item autodisconnect =E $ad by default, the SSH connection is closed from the DESTROY method when the object goes out of scope on the process and thread where it was created. This option allows one to customize this behaviour. The acceptable values for C<$ad> are: =over 4 =item '0' Never try to disconnect this object when exiting from any process. On most operating systems, the SSH process will exit when the last process connected to it ends, but this is not guaranteed. You can always call the C method explicitly to end the connection at the right time from the right place. =item '1' Disconnect on exit from any thread or process. =item '2' Disconnect on exit from the current process/thread only. This is the default. =back See also the C and C methods. =item late_set_perm =E $bool See the FAQ below. =item dirty_cleanup =E $bool Sets the C flag in a per object basis (see the BUGS section). =item backend => $backend From version 1.57 Net::SFTP::Foreign supports plugable backends in order to allow other ways to communicate with the remote server in addition to the default I. Custom backends may change the set of options supported by the C method. =item autodie => $bool Enables the autodie mode that will cause the module to die when any error is found (a la L). =back =item $sftp-Eerror Returns the error code from the last executed command. The value returned is similar to C<$!>, when used as a string it yields the corresponding error string. See L for a list of possible error codes and how to import them on your scripts. =item $sftp-Edie_on_error($msg) Convenience method: $sftp->die_on_error("Something bad happened"); # is a shortcut for... $sftp->error and die "Something bad happened: " . $sftp->error; =item $sftp-Estatus Returns the code from the last SSH2_FXP_STATUS response. It is also a dualvar that yields the status string when used as a string. Usually C<$sftp-Eerror> should be checked first to see if there was any error and then C<$sftp-Estatus> to find out its low level cause. =item $sftp-Ecwd Returns the remote current working directory. When a relative remote path is passed to any of the methods on this package, this directory is used to compose the absolute path. =item $sftp-Esetcwd($dir, %opts) Changes the remote current working directory. The remote directory should exist, otherwise the call fails. Returns the new remote current working directory or undef on failure. Passing C as the C<$dir> argument resets the cwd to the server default which is usually the user home but not always. The method accepts the following options: =over 4 =item check => 0 By default the given target directory is checked against the remote server to ensure that it actually exists and that it is a directory. Some servers may fail to honor those requests even for valid directories (i.e. when the directory has the hidden flag set). This option allows one to disable those checks and just sets the cwd to the given value blindly. =back =item $sftp-Eget($remote, $local, %options) XCopies remote file C<$remote> to local $local. By default file attributes are also copied (permissions, atime and mtime). For instance: $sftp->get('/var/log/messages', /tmp/messages') or die "file transfer failed: " . $sftp->error; A file handle can also be used as the local target. In that case, the remote file contents are retrieved and written to the given file handle. Note also that the handle is not closed when the transmission finish. open F, '| gzip -c > /tmp/foo' or die ...; $sftp->get("/etc/passwd", \*F) or die "get failed: " . $sftp->error; close F or die ...; Accepted options (not all combinations are possible): =over 4 =item copy_time =E $bool determines if access and modification time attributes have to be copied from remote file. Default is to copy them. =item copy_perm =E $bool determines if permission attributes have to be copied from remote file. Default is to copy them after applying the local process umask. =item umask =E $umask allows one to select the umask to apply when setting the permissions of the copied file. Default is to use the umask for the current process or C<0> if the C option is also used. =item perm =E $perm sets the permission mask of the file to be $perm, remote permissions are ignored. =item resume =E 1 | 'auto' resumes an interrupted transfer. If the C value is given, the transfer will be resumed only when the local file is newer than the remote one. C transfers can not be resumed when a data conversion is in place. =item append =E 1 appends the contents of the remote file at the end of the local one instead of overwriting it. If the local file does not exist a new one is created. =item overwrite =E 0 setting this option to zero cancels the transfer when a local file of the same name already exists. =item numbered =E 1 modifies the local file name inserting a sequence number when required in order to avoid overwriting local files. For instance: for (1..2) { $sftp->get("data.txt", "data.txt", numbered => 1); } will copy the remote file as C the first time and as C the second one. If a scalar reference is passed as the numbered value, the final target will be stored in the value pointed by the reference. For instance: my $target; $sftp->get("data.txt", "data.txt", numbered => \$target); say "file was saved as $target" unless $sftp->error =item atomic =E 1 The remote file contents are transferred into a temporal file that once the copy completes is renamed to the target destination. If not-overwrite of remote files is also requested, an empty file may appear at the target destination before the rename operation is performed. This is due to limitations of some operating/file systems. =item mkpath =E 0 By default the method creates any non-existent parent directory for the given target path. That feature can be disabled setting this flag to 0. =item cleanup =E 1 If the transfer fails, remove the incomplete file. This option is set to by default when there is not possible to resume the transfer afterwards (i.e., when using `atomic` or `numbered` options). =item best_effort =E 1 Ignore minor errors as setting time or permissions. =item conversion =E $conversion on the fly data conversion of the file contents can be performed with this option. See L below. =item callback =E $callback C<$callback> is a reference to a subroutine that will be called after every iteration of the download process. The callback function will receive as arguments: the current Net::SFTP::Foreign object; the data read from the remote file; the offset from the beginning of the file in bytes; and the total size of the file in bytes. This mechanism can be used to provide status messages, download progress meters, etc.: sub callback { my($sftp, $data, $offset, $size) = @_; print "Read $offset / $size bytes\r"; } The C method can be called from inside the callback to abort the transfer: sub callback { my($sftp, $data, $offset, $size) = @_; if (want_to_abort_transfer()) { $sftp->abort("You wanted to abort the transfer"); } } The callback will be called one last time with an empty data argument to indicate the end of the file transfer. The size argument can change between different calls as data is transferred (for instance, when on-the-fly data conversion is being performed or when the size of the file can not be retrieved with the C SFTP command before the data transfer starts). =item block_size =E $bytes size of the blocks the file is being split on for transfer. Incrementing this value can improve performance but most servers limit the maximum size. =item queue_size =E $size read and write requests are pipelined in order to maximize transfer throughput. This option allows one to set the maximum number of requests that can be concurrently waiting for a server response. =back =item $sftp-Eget_content($remote) Returns the content of the remote file. =item $sftp-Eget_symlink($remote, $local, %opts) copies a symlink from the remote server to the local file system The accepted options are C and C. They have the same effect as for the C method. =item $sftp-Eput($local, $remote, %opts) Uploads a file C<$local> from the local host to the remote host saving it as C<$remote>. By default file attributes are also copied. For instance: $sftp->put("test.txt", "test.txt") or die "put failed: " . $sftp->error; A file handle can also be passed in the C<$local> argument. In that case, data is read from there and stored in the remote file. UTF8 data is not supported unless a custom converter callback is used to transform it to bytes. The method will croak if it encounters any data in perl internal UTF8 format. Note also that the handle is not closed when the transmission finish. Example: binmode STDIN; $sftp->put(\*STDIN, "stdin.dat") or die "put failed"; close STDIN; This method accepts several options: =over 4 =item copy_time =E $bool determines if access and modification time attributes have to be copied from remote file. Default is to copy them. =item copy_perm =E $bool determines if permission attributes have to be copied from remote file. Default is to copy them after applying the local process umask. =item umask =E $umask allows one to select the umask to apply when setting the permissions of the copied file. Default is to use the umask for the current process. =item perm =E $perm sets the permission mask of the file to be $perm, umask and local permissions are ignored. =item overwrite =E 0 by default C will overwrite any pre-existent file with the same name at the remote side. Setting this flag to zero will make the method fail in that case. =item numbered =E 1 when set, a sequence number is added to the remote file name in order to avoid overwriting pre-existent files. Off by default. =item append =E 1 appends the local file at the end of the remote file instead of overwriting it. If the remote file does not exist a new one is created. Off by default. =item resume =E 1 | 'auto' resumes an interrupted transfer. If the C value is given, the transfer will be resumed only when the remote file is newer than the local one. =item sparse =E 1 Blocks that are all zeros are skipped possibly creating an sparse file on the remote host. =item mkpath =E 0 By default the method creates any non-existent parent directory for the given target path. That feature can be disabled setting this flag to 0. =item atomic =E 1 The local file contents are transferred into a temporal file that once the copy completes is renamed to the target destination. This operation relies on the SSH server to perform an overwriting/non-overwriting atomic rename operation free of race conditions. OpenSSH server does it correctly on top of Linux/UNIX native file systems (i.e. ext[234]>, ffs or zfs) but has problems on file systems not supporting hard links (i.e. FAT) or on operating systems with broken POSIX semantics as Windows. =item cleanup =E 1 If the transfer fails, attempts to remove the incomplete file. Cleanup may fail (for example, if the SSH connection gets broken). This option is set by default when the transfer is not resumable (i.e., when using `atomic` or `numbered` options). =item best_effort =E 1 Ignore minor errors, as setting time and permissions on the remote file. =item conversion =E $conversion on the fly data conversion of the file contents can be performed with this option. See L below. =item callback =E $callback C<$callback> is a reference to a subroutine that will be called after every iteration of the upload process. The callback function will receive as arguments: the current Net::SFTP::Foreign object; the data that is going to be written to the remote file; the offset from the beginning of the file in bytes; and the total size of the file in bytes. The callback will be called one last time with an empty data argument to indicate the end of the file transfer. The size argument can change between calls as data is transferred (for instance, when on the fly data conversion is being performed). This mechanism can be used to provide status messages, download progress meters, etc. The C method can be called from inside the callback to abort the transfer. =item block_size =E $bytes size of the blocks the file is being split on for transfer. Incrementing this value can improve performance but some servers limit its size and if this limit is overpassed the command will fail. =item queue_size =E $size read and write requests are pipelined in order to maximize transfer throughput. This option allows one to set the maximum number of requests that can be concurrently waiting for a server response. =item late_set_perm =E $bool See the FAQ below. =back =item $sftp-Eput_content($bytes, $remote, %opts) Creates (or overwrites) a remote file whose content is the passed data. =item $sftp-Eput_symlink($local, $remote, %opts) Copies a local symlink to the remote host. The accepted options are C and C. =item $sftp-Eabort() =item $sftp-Eabort($msg) This method, when called from inside a callback sub, causes the current transfer to be aborted The error state is set to SFTP_ERR_ABORTED and the optional $msg argument is used as its textual value. =item $sftp-Els($remote, %opts) Fetches a listing of the remote directory C<$remote>. If C<$remote> is not given, the current remote working directory is listed. Returns a reference to a list of entries. Every entry is a reference to a hash with three keys: C, the name of the entry; C, an entry in a "long" listing like C; and C, a L object containing file atime, mtime, permissions and size. my $ls = $sftp->ls('/home/foo') or die "unable to retrieve directory: ".$sftp->error; print "$_->{filename}\n" for (@$ls); The options accepted by this method are as follows (note that usage of some of them can degrade the method performance when reading large directories): =over 4 =item wanted =E qr/.../ Only elements whose name matches the given regular expression are included on the listing. =item wanted =E sub {...} Only elements for which the callback returns a true value are included on the listing. The callback is called with two arguments: the C<$sftp> object and the current entry (a hash reference as described before). For instance: use Fcntl ':mode'; my $files = $sftp->ls ( '/home/hommer', wanted => sub { my $entry = $_[1]; S_ISREG($entry->{a}->perm) } ) or die "ls failed: ".$sftp->error; =item no_wanted =E qr/.../ =item no_wanted =E sub {...} those options have the opposite result to their C counterparts: my $no_hidden = $sftp->ls( '/home/homer', no_wanted => qr/^\./ ) or die "ls failed"; When both C and C rules are used, the C rule is applied first and then the C one (order is important if the callbacks have side effects, experiment!). =item ordered =E 1 the list of entries is ordered by filename. =item follow_links =E 1 by default, the attributes on the listing correspond to a C operation, setting this option causes the method to perform C requests instead. C attributes will still appear for links pointing to non existent places. =item atomic_readdir =E 1 reading a directory is not an atomic SFTP operation and the protocol draft does not define what happens if C requests and write operations (for instance C or C) affecting the same directory are intermixed. This flag ensures that no callback call (C, C) is performed in the middle of reading a directory and has to be set if any of the callbacks can modify the file system. =item realpath =E 1 for every file object, performs a realpath operation and populates the C entry. =item names_only =E 1 makes the method return a simple array containing the file names from the remote directory only. For instance, these two sentences are equivalent: my @ls1 = @{ $sftp->ls('.', names_only => 1) }; my @ls2 = map { $_->{filename} } @{$sftp->ls('.')}; =back =item $sftp-Efind($path, %opts) =item $sftp-Efind(\@paths, %opts) XDoes a recursive search over the given directory C<$path> (or directories C<@path>) and returns a list of the entries found or the total number of them on scalar context. Every entry is a reference to a hash with two keys: C, the full path of the entry; and C, a L object containing file atime, mtime, permissions and size. This method tries to recover and continue under error conditions. The options accepted: =over 4 =item on_error =E sub { ... } the callback is called when some error is detected, two arguments are passed: the C<$sftp> object and the entry that was being processed when the error happened. For instance: my @find = $sftp->find( '/', on_error => sub { my ($sftp, $e) = @_; print STDERR "error processing $e->{filename}: " . $sftp->error; } ); =item realpath =E 1 calls method C for every entry, the result is stored under the key C. This option slows down the process as a new remote query is performed for every entry, specially on networks with high latency. =item follow_links =E 1 By default symbolic links are not resolved and appear as that on the final listing. This option causes then to be resolved and substituted by the target file system object. Dangling links are ignored, though they generate a call to the C callback when stat fails on them. Following symbolic links can introduce loops on the search. Infinite loops are detected and broken but files can still appear repeated on the final listing under different names unless the option C is also active. =item ordered =E 1 By default, the file system is searched in an implementation dependent order (actually optimized for low memory consumption). If this option is included, the file system is searched in a deep-first, sorted by filename fashion. =item wanted =E qr/.../ =item wanted =E sub { ... } =item no_wanted =E qr/.../ =item no_wanted =E sub { ... } These options have the same effect as on the C method, allowing to filter out unwanted entries (note that filename keys contain B here). The callbacks can also be used to perform some action instead of creating the full listing of entries in memory (that could use huge amounts of RAM for big file trees): $sftp->find($src_dir, wanted => sub { my $fn = $_[1]->{filename} print "$fn\n" if $fn =~ /\.p[ml]$/; return undef # so it is discarded }); =item descend =E qr/.../ =item descend =E sub { ... } =item no_descend =E qr/.../ =item no_descend =E sub { ... } These options, similar to the C ones, allow one to prune the search, discarding full subdirectories. For instance: use Fcntl ':mode'; my @files = $sftp->find( '.', no_descend => qr/\.svn$/, wanted => sub { S_ISREG($_[1]->{a}->perm) } ); C and C rules are unrelated. A directory discarded by a C rule will still be recursively searched unless it is also discarded on a C rule and vice versa. =item atomic_readdir =E 1 see C method documentation. =item names_only =E 1 makes the method return a list with the names of the files only (see C method documentation). equivalent: my $ls1 = $sftp->ls('.', names_only => 1); =back =item $sftp-Eglob($pattern, %opts) Xperforms a remote glob and returns the list of matching entries in the same format as the L method. This method tries to recover and continue under error conditions. The given pattern can be a UNIX style pattern (see L) or a Regexp object (i.e C). In the later case, only files on the current working directory will be matched against the Regexp. Accepted options: =over 4 =item ignore_case =E 1 by default the matching over the file system is carried out in a case sensitive fashion, this flag changes it to be case insensitive. This flag is ignored when a Regexp object is used as the pattern. =item strict_leading_dot =E 0 by default, a dot character at the beginning of a file or directory name is not matched by wildcards (C<*> or C). Setting this flags to a false value changes this behaviour. This flag is ignored when a Regexp object is used as the pattern. =item follow_links =E 1 =item ordered =E 1 =item names_only =E 1 =item realpath =E 1 =item on_error =E sub { ... } =item wanted =E ... =item no_wanted =E ... these options perform as on the C method. =back Some usage samples: my $files = $sftp->glob("*/lib"); my $files = $sftp->glob("/var/log/dmesg.*.gz"); $sftp->set_cwd("/var/log"); my $files = $sftp->glob(qr/^dmesg\.[\d+]\.gz$/); my $files = $sftp->glob("*/*.pdf", strict_leading_dot => 0); =item $sftp-Erget($remote, $local, %opts) Recursively copies the contents of remote directory C<$remote> to local directory C<$local>. Returns the total number of elements (files, directories and symbolic links) successfully copied. This method tries to recover and continue when some error happens. The options accepted are: =over 4 =item umask =E $umask use umask C<$umask> to set permissions on the files and directories created. =item copy_perm =E $bool; if set to a true value, file and directory permissions are copied to the remote server (after applying the umask). On by default. =item copy_time =E $bool; if set to a true value, file atime and mtime are copied from the remote server. By default it is on. =item overwrite =E $bool if set to a true value, when a local file with the same name already exists it is overwritten. On by default. =item numbered =E $bool when required, adds a sequence number to local file names in order to avoid overwriting pre-existent remote files. Off by default. =item newer_only =E $bool if set to a true value, when a local file with the same name already exists it is overwritten only if the remote file is newer. =item ignore_links =E $bool if set to a true value, symbolic links are not copied. =item on_error =E sub { ... } the passed sub is called when some error happens. It is called with two arguments, the C<$sftp> object and the entry causing the error. =item wanted =E ... =item no_wanted =E ... This option allows one to select which files and directories have to be copied. See also C method docs. If a directory is discarded all of its contents are also discarded (as it is not possible to copy child files without creating the directory first!). =item atomic =E 1 =item block_size =E $block_size =item queue_size =E $queue_size =item conversion =E $conversion =item resume =E $resume =item best_effort =E $best_effort See C method docs. =back =item $sftp-Erput($local, $remote, %opts) Recursively copies the contents of local directory C<$local> to remote directory C<$remote>. This method tries to recover and continue when some error happens. Accepted options are: =over 4 =item umask =E $umask use umask C<$umask> to set permissions on the files and directories created. =item copy_perm =E $bool; if set to a true value, file and directory permissions are copied to the remote server (after applying the umask). On by default. =item copy_time =E $bool; if set to a true value, file atime and mtime are copied to the remote server. On by default. =item perm =E $perm Sets the permission of the copied files to $perm. For directories the value C<$perm|0300> is used. Note that when this option is used, umask and local permissions are ignored. =item overwrite =E $bool if set to a true value, when a remote file with the same name already exists it is overwritten. On by default. =item newer_only =E $bool if set to a true value, when a remote file with the same name already exists it is overwritten only if the local file is newer. =item ignore_links =E $bool if set to a true value, symbolic links are not copied =item on_error =E sub { ... } the passed sub is called when some error happens. It is called with two arguments, the C<$sftp> object and the entry causing the error. =item wanted =E ... =item no_wanted =E ... This option allows one to select which files and directories have to be copied. See also C method docs. If a directory is discarded all of its contents are also discarded (as it is not possible to copy child files without creating the directory first!). =item atomic =E 1 =item block_size =E $block_size =item queue_size =E $queue_size =item conversion =E $conversion =item resume =E $resume =item best_effort =E $best_effort =item late_set_perm =E $bool see C method docs. =back =item $sftp-Erremove($dir, %opts) =item $sftp-Erremove(\@dirs, %opts) recursively remove directory $dir (or directories @dirs) and its contents. Returns the number of elements successfully removed. This method tries to recover and continue when some error happens. The options accepted are: =over 4 =item on_error =E sub { ... } This callback is called when some error is occurs. The arguments passed are the C<$sftp> object and the current entry (a hash containing the file object details, see C docs for more information). =item wanted =E ... =item no_wanted =E ... Allows one to select which file system objects have to be deleted. =back =item $sftp-Emget($remote, $localdir, %opts) =item $sftp-Emget(\@remote, $localdir, %opts) Xexpands the wildcards on C<$remote> or C<@remote> and retrieves all the matching files. For instance: $sftp->mget(['/etc/hostname.*', '/etc/init.d/*'], '/tmp'); The method accepts all the options valid for L and for L (except those that do not make sense :-) C<$localdir> is optional and defaults to the process current working directory (C). Files are saved with the same name they have in the remote server excluding the directory parts. Note that name collisions are not detected. For instance: $sftp->mget(["foo/file.txt", "bar/file.txt"], "/tmp") will transfer the first file to "/tmp/file.txt" and later overwrite it with the second one. The C option can be used to avoid this issue. =item $sftp-Emput($local, $remotedir, %opts) =item $sftp-Emput(\@local, $remotedir, %opts) similar to L but works in the opposite direction transferring files from the local side to the remote one. =item $sftp-Ejoin(@paths) returns the given path fragments joined in one path (currently the remote file system is expected to be UNIX like). =item $sftp-Eopen($path, $flags [, $attrs ]) Sends the C command to open a remote file C<$path>, and returns an open handle on success. On failure returns C. The returned value is a tied handle (see L) that can be used to access the remote file both with the methods available from this module and with perl built-ins. For instance: # reading from the remote file my $fh1 = $sftp->open("/etc/passwd") or die $sftp->error; while (<$fh1>) { ... } # writing to the remote file use Net::SFTP::Foreign::Constants qw(:flags); my $fh2 = $sftp->open("/foo/bar", SSH2_FXF_WRITE|SSH2_FXF_CREAT) or die $sftp->error; print $fh2 "printing on the remote file\n"; $sftp->write($fh2, "writing more"); The C<$flags> bitmap determines how to open the remote file as defined in the SFTP protocol draft (the following constants can be imported from L): =over 4 =item SSH2_FXF_READ Open the file for reading. It is the default mode. =item SSH2_FXF_WRITE Open the file for writing. If both this and C are specified, the file is opened for both reading and writing. =item SSH2_FXF_APPEND Force all writes to append data at the end of the file. As OpenSSH SFTP server implementation ignores this flag, the module emulates it (I will appreciate receiving feedback about the inter-operation of this module with other server implementations when this flag is used). =item SSH2_FXF_CREAT If this flag is specified, then a new file will be created if one does not already exist. =item SSH2_FXF_TRUNC Forces an existing file with the same name to be truncated to zero length when creating a file. C must also be specified if this flag is used. =item SSH2_FXF_EXCL Causes the request to fail if the named file already exists. C must also be specified if this flag is used. =back When creating a new remote file, C<$attrs> allows one to set its initial attributes. C<$attrs> has to be an object of class L. =item $sftp-Eclose($handle) Closes the remote file handle C<$handle>. Files are automatically closed on the handle C method when not done explicitly. Returns true on success and undef on failure. =item $sftp-Eread($handle, $length) reads C<$length> bytes from an open file handle C<$handle>. On success returns the data read from the remote file and undef on failure (including EOF). =item $sftp-Ewrite($handle, $data) writes C<$data> to the remote file C<$handle>. Returns the number of bytes written or undef on failure. =item $sftp-Ereadline($handle) =item $sftp-Ereadline($handle, $sep) in scalar context reads and returns the next line from the remote file. In list context, it returns all the lines from the current position to the end of the file. By default "\n" is used as the separator between lines, but a different one can be used passing it as the second method argument. If the empty string is used, it returns all the data from the current position to the end of the file as one line. =item $sftp-Egetc($handle) returns the next character from the file. =item $sftp-Eseek($handle, $pos, $whence) sets the current position for the remote file handle C<$handle>. If C<$whence> is 0, the position is set relative to the beginning of the file; if C<$whence> is 1, position is relative to current position and if $<$whence> is 2, position is relative to the end of the file. returns a trues value on success, undef on failure. =item $sftp-Etell($fh) returns the current position for the remote file handle C<$handle>. =item $sftp-Eeof($fh) reports whether the remote file handler points at the end of the file. =item $sftp-Eflush($fh) Xwrites to the remote file any pending data and discards the read cache. Note that this operation just sends data cached locally to the remote server. You may like to call C (when supported) afterwards to ensure that data is actually flushed to disc. =item $sftp-Efsync($fh) On servers supporting the C extension, this method calls L on the remote side, which usually flushes buffered changes to disk. =item $sftp-Esftpread($handle, $offset, $length) low level method that sends a SSH2_FXP_READ request to read from an open file handle C<$handle>, C<$length> bytes starting at C<$offset>. Returns the data read on success and undef on failure. Some servers (for instance OpenSSH SFTP server) limit the size of the read requests and so the length of data returned can be smaller than requested. =item $sftp-Esftpwrite($handle, $offset, $data) low level method that sends a C request to write to an open file handle C<$handle>, starting at C<$offset>, and where the data to be written is in C<$data>. Returns true on success and undef on failure. =item $sftp-Eopendir($path) Sends a C 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. =item $sftp-Eclosedir($handle) closes the remote directory handle C<$handle>. Directory handles are closed from their C method when not done explicitly. Return true on success, undef on failure. =item $sftp-Ereaddir($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, C and C. The C value contains a L object describing the entry. Returns undef on error or when no more entries exist on the directory. =item $sftp-Estat($path_or_fh) performs a C on the remote file and returns a L object with the result values. Both paths and open remote file handles can be passed to this method. Returns undef on failure. =item $sftp-Efstat($handle) this method is deprecated. =item $sftp-Elstat($path) this method is similar to C method but stats a symbolic link instead of the file the symbolic links points to. =item $sftp-Esetstat($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-Efsetstat($handle, $attrs) this method is deprecated. =item $sftp-Etruncate($path_or_fh, $size) =item $sftp-Echown($path_or_fh, $uid, $gid) =item $sftp-Echmod($path_or_fh, $perm) =item $sftp-Eutime($path_or_fh, $atime, $mtime) Shortcuts around C method. =item $sftp-Eremove($path) Sends a C command to remove the remote file C<$path>. Returns a true value on success and undef on failure. =item $sftp-Emkdir($path, $attrs) Sends a C command to create a remote directory C<$path> whose attributes are initialized to C<$attrs> (a L object). Returns a true value on success and undef on failure. The C<$attrs> argument is optional. =item $sftp-Emkpath($path, $attrs, $parent) This method is similar to C 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-Ermdir($path) Sends a C command to remove a remote directory C<$path>. Returns a true value on success and undef on failure. =item $sftp-Erealpath($path) Sends a C 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 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-Erename($old, $new, %opts) Sends a C command to rename C<$old> to C<$new>. Returns a true value on success and undef on failure. Accepted options are: =over 4 =item overwrite => $bool By default, the rename operation fails when a file C<$new> already exists. When this options is set, any previous existent file is deleted first (the C operation will be used if available). Note than under some conditions the target file could be deleted and afterwards the rename operation fail. =back =item $sftp-Eatomic_rename($old, $new) Renames a file using the C extension when available. Unlike the C method, it overwrites any previous C<$new> file. =item $sftp-Ereadlink($path) Sends a C command to read the path where the symbolic link is pointing. Returns the target path on success and undef on failure. =item $sftp-Esymlink($sl, $target) Sends a C command to create a new symbolic link C<$sl> pointing to C<$target>. C<$target> is stored as-is, without any path expansion taken place on it. Use C to normalize it: $sftp->symlink("foo.lnk" => $sftp->realpath("../bar")) =item $sftp-Ehardlink($hl, $target) Creates a hardlink on the server. This command requires support for the 'hardlink@openssh.com' extension on the server (available in OpenSSH from version 5.7). =item $sftp-Estatvfs($path) =item $sftp-Efstatvfs($fh) On servers supporting C and C extensions respectively, these methods return a hash reference with information about the file system where the file named C<$path> or the open file C<$fh> resides. The hash entries are: bsize => file system block size frsize => fundamental fs block size blocks => number of blocks (unit f_frsize) bfree => free blocks in file system bavail => free blocks for non-root files => total file inodes ffree => free file inodes favail => free file inodes for to non-root fsid => file system id flag => bit mask of f_flag values namemax => maximum filename length The values of the f_flag bit mask are as follows: SSH2_FXE_STATVFS_ST_RDONLY => read-only SSH2_FXE_STATVFS_ST_NOSUID => no setuid =item $sftp->test_d($path) Checks whether the given path corresponds to a directory. =item $sftp->test_e($path) Checks whether a file system object (file, directory, etc.) exists at the given path. =item $sftp-Edisconnect Closes the SSH connection to the remote host. From this point the object becomes mostly useless. Usually, this method should not be called explicitly, but implicitly from the DESTROY method when the object goes out of scope. See also the documentation for the C constructor argument. =item $sftp-Eautodisconnect($ad) Sets the C behaviour. See also the documentation for the C constructor argument. The values accepted here are the same as there. =back =head2 On the fly data conversion Some of the methods on this module allow one to perform on the fly data conversion via the C option that accepts the following values: =over 4 =item conversion =E 'dos2unix' Converts CR+LF line endings (as commonly used under MS-DOS) to LF (UNIX). =item conversion =E 'unix2dos' Converts LF line endings (UNIX) to CR+LF (DOS). =item conversion =E sub { CONVERT $_[0] } When a callback is given, it is invoked repeatedly as chunks of data become available. It has to change C<$_[0]> in place in order to perform the conversion. Also, the subroutine is called one last time with and empty data string to indicate that the transfer has finished, so that intermediate buffers can be flushed. Note that when writing conversion subroutines, special care has to be taken to handle sequences crossing chunk borders. =back The data conversion is always performed before any other callback subroutine is called. See the Wikipedia entry on line endings L or the article Understanding Newlines by Xavier Noria (L) for details about the different conventions. =head1 FAQ =over 4 =item Closing the connection: B: How do I close the connection to the remote server? B: let the C<$sftp> object go out of scope or just undefine it: undef $sftp; =item Using Net::SFTP::Foreign from a cron script: B: I wrote a script for performing sftp file transfers that works beautifully from the command line. However when I try to run the same script from cron it fails with a broken pipe error: open2: exec of ssh -l user some.location.com -s sftp failed at Net/SFTP/Foreign.pm line 67 B: C is not on your cron PATH. The remedy is either to add the location of the C application to your cron PATH or to use the C option of the C method to hardcode the location of C inside your script, for instance: my $ssh = Net::SFTP::Foreign->new($host, ssh_cmd => '/usr/local/ssh/bin/ssh'); =item C constructor option expects an array reference: B: I'm trying to pass in the private key file using the -i option, but it keep saying it couldn't find the key. What I'm doing wrong? B: The C argument on the constructor expects a single option or a reference to an array of options. It will not split an string containing several options. Arguments to SSH options have to be also passed as different entries on the array: my $sftp = Net::SFTP::Foreign->new($host, more => [qw(-i /home/foo/.ssh/id_dsa)]); Note also that latest versions of Net::SFTP::Foreign support the C argument: my $sftp = Net::SFTP::Foreign->new($host, key_path => '/home/foo/.ssh/id_dsa'); =item Plink and password authentication B: Why password authentication is not supported for the plink SSH client? B: A bug in plink breaks it. Newer versions of Net::SFTP::Foreign pass the password to C using its C<-pw> option. As this feature is not completely secure a warning is generated. It can be silenced (though, don't do it without understanding why it is there, please!) as follows: no warnings 'Net::SFTP::Foreign'; my $sftp = Net::SFTP::Foreign->new('foo@bar', ssh_cmd => 'plink', password => $password); $sftp->die_on_error; =item Plink B: What is C? B: Plink is a command line tool distributed with the L SSH client. Very popular between MS Windows users, it is also available for Linux and other UNIX now. =item Put method fails B: put fails with the following error: Couldn't setstat remote file: The requested operation cannot be performed because there is a file transfer in progress. B: Try passing the C option to the put method: $sftp->put($local, $remote, late_set_perm => 1) or die "unable to transfer file: " . $sftp->error; Some servers do not support the C operation on open file handles. Setting this flag allows one to delay that operation until the file has been completely transferred and the remote file handle closed. Also, send me a bug report containing a dump of your $sftp object so I can add code for your particular server software to activate the work-around automatically. =item Put method fails even with late_set_perm set B: I added C 1> to the put call, but we are still receiving the error C. B: Some servers forbid the SFTP C operation used by the C method for replicating the file permissions and time-stamps on the remote side. As a work around you can just disable the feature: $sftp->put($local_file, $remote_file, copy_perm => 0, copy_time => 0); =item Disable password authentication completely B: When we try to open a session and the key either doesn't exist or is invalid, the child SSH hangs waiting for a password to be entered. Is there a way to make this fail back to the Perl program to be handled? B: Disable anything but public key SSH authentication calling the new method as follows: $sftp = Net::SFTP::Foreign->new($host, more => [qw(-o PreferredAuthentications=publickey)]) See L for the details. =item Understanding C<$attr-Eperm> bits B: How can I know if a directory entry is a (directory|link|file|...)? B: Use the C functions from L. For instance: use Fcntl qw(S_ISDIR); my $ls = $sftp->ls or die $sftp->error; for my $entry (@$ls) { if (S_ISDIR($entry->{a}->perm)) { print "$entry->{filename} is a directory\n"; } } =item Host key checking B: Connecting to a remote server with password authentication fails with the following error: The authenticity of the target host can not be established, connect from the command line first B: That probably means that the public key from the remote server is not stored in the C<~/.ssh/known_hosts> file. Run an SSH Connection from the command line as the same user as the script and answer C when asked to confirm the key supplied. Example: $ ssh pluto /bin/true The authenticity of host 'pluto (172.25.1.4)' can't be established. RSA key fingerprint is 41:b1:a7:86:d2:a9:7b:b0:7f:a1:00:b7:26:51:76:52. Are you sure you want to continue connecting (yes/no)? yes Your SSH client may also support some flag to disable this check, but doing it can ruin the security of the SSH protocol so I advise against its usage. Example: # Warning: don't do that unless you fully understand # its security implications!!! $sftp = Net::SFTP::Foreign->new($host, more => [-o => 'StrictHostKeyChecking no'], ...); =back =head1 BUGS These are the currently known bugs: =over 4 =item - Doesn't work on VMS: The problem is related to L not working on VMS. Patches are welcome! =item - Dirty cleanup: On some operating systems, closing the pipes used to communicate with the slave SSH process does not terminate it and a work around has to be applied. If you find that your scripts hung when the $sftp object gets out of scope, try setting C<$Net::SFTP::Foreign::dirty_cleanup> to a true value and also send me a report including the value of C<$^O> on your machine and the OpenSSH version. From version 0.90_18 upwards, a dirty cleanup is performed anyway when the SSH process does not terminate by itself in 8 seconds or less. =item - Reversed symlink arguments: This package uses the non-conforming OpenSSH argument order for the SSH_FXP_SYMLINK command that seems to be the de facto standard. When interacting with SFTP servers that follow the SFTP specification, the C method will interpret its arguments in reverse order. =item - IPC::Open3 bugs on Windows On Windows the IPC::Open3 module is used to spawn the slave SSH process. That module has several nasty bugs (related to STDIN, STDOUT and STDERR being closed or not being assigned to file descriptors 0, 1 and 2 respectively) that will cause the connection to fail. Specifically this is known to happen under mod_perl/mod_perl2. =item - Password authentication on HP-UX For some unknown reason, it seems that when using the module on HP-UX, number signs (C<#>) in password need to be escaped (C<\#>). For instance: my $password = "foo#2014"; $password =~ s/#/\\#/g if $running_in_hp_ux; my $ssh = Net::OpenSSH->new($host, user => $user, password => $password); I don't have access to an HP-UX machine, and so far nobody using it has been able to explain this behaviour. Patches welcome! =item - Taint mode and data coming through SFTP When the module finds it is being used from a script started in taint mode, on every method call it checks all the arguments passed and dies if any of them is tainted. Also, any data coming through the SFTP connection is marked as tainted. That generates an internal conflict for those methods that under the hood query the remote server multiple times, using data from responses to previous queries (tainted) to build new ones (die!). I don't think a generic solution could be applied to this issue while honoring the taint-mode spirit (and erring on the safe side), so my plan is to fix that in a case by case manner. So, please report any issue you find with taint mode! =back Also, the following features should be considered experimental: - support for Tectia server - numbered feature - autodie mode - best_effort feature =head1 SUPPORT To report bugs, send me and email or use the CPAN bug tracking system at L. =head2 Commercial support Commercial support, professional services and custom software development around this module are available through my current company. Drop me an email with a rough description of your requirements and we will get back to you ASAP. =head2 My wishlist If you like this module and you're feeling generous, take a look at my Amazon Wish List: L Also consider contributing to the OpenSSH project this module builds upon: L. =head1 SEE ALSO Information about the constants used on this module is available from L. Information about attribute objects is available from L. General information about SSH and the OpenSSH implementation is available from the OpenSSH web site at L and from the L and L manual pages. Net::SFTP::Foreign integrates nicely with my other module L. L allows one to run Net::SFTP::Foreign on top of L (nowadays, this combination is probably the best option under Windows). Modules offering similar functionality available from CPAN are L and L. L allows one to run tests against a remote SFTP server. L. =head1 COPYRIGHT Copyright (c) 2005-2016 Salvador FandiEo (sfandino@yahoo.com). Copyright (c) 2001 Benjamin Trott, Copyright (c) 2003 David Rolsky. _glob_to_regex method based on code (c) 2002 Richard Clamp. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut libnet-sftp-foreign-perl-1.86+dfsg.orig/lib/Net/SFTP/Foreign/0000755000175000017500000000000012726520616022632 5ustar salvisalvilibnet-sftp-foreign-perl-1.86+dfsg.orig/lib/Net/SFTP/Foreign/Backend/0000755000175000017500000000000012726520616024161 5ustar salvisalvilibnet-sftp-foreign-perl-1.86+dfsg.orig/lib/Net/SFTP/Foreign/Backend/Unix.pm0000644000175000017500000004105012516370257025443 0ustar salvisalvipackage Net::SFTP::Foreign::Backend::Unix; our $VERSION = '1.76_03'; use strict; use warnings; use Carp; our @CARP_NOT = qw(Net::SFTP::Foreign); use Fcntl qw(O_NONBLOCK F_SETFL F_GETFL); use POSIX (); use Net::SFTP::Foreign::Helpers qw(_tcroak _ensure_list _debug _hexdump $debug); use Net::SFTP::Foreign::Constants qw(SSH2_FX_BAD_MESSAGE SFTP_ERR_REMOTE_BAD_MESSAGE); use Time::HiRes qw(sleep time); sub _new { shift } sub _defaults { ( queue_size => 32 ) } sub _init_transport_streams { my (undef, $sftp) = @_; for my $dir (qw(ssh_in ssh_out)) { binmode $sftp->{$dir}; my $flags = fcntl($sftp->{$dir}, F_GETFL, 0); fcntl($sftp->{$dir}, F_SETFL, $flags | O_NONBLOCK); } } sub _open_dev_null { my $sftp = shift; my $dev_null; unless (open $dev_null, '>', "/dev/null") { $sftp->_conn_failed("Unable to redirect stderr to /dev/null"); return; } $dev_null } sub _fileno_dup_over { my ($good_fn, $fh) = @_; if (defined $fh) { my @keep_open; my $fn = fileno $fh; for (1..5) { $fn >= $good_fn and return $fn; $fn = POSIX::dup($fn); push @keep_open, $fn; } POSIX::_exit(255); } undef; } sub _open4 { my $backend = shift; my $sftp = shift; my ($dad_in, $dad_out, $child_in, $child_out); unless (pipe ($dad_in, $child_out) and pipe ($child_in, $dad_out)) { $sftp->_conn_failed("Unable to created pipes: $!"); return; } my $pid = fork; unless ($pid) { unless (defined $pid) { $sftp->_conn_failed("Unable to fork new process: $!"); return; } close ($dad_in); close ($dad_out); shift; shift; my $child_err = shift; my $pty = shift; $pty->make_slave_controlling_terminal if defined $pty; my $child_err_fno = eval { no warnings; fileno($child_err ? $child_err : *STDERR) }; my $child_err_safe; # passed handler may be tied, so we # duplicate it in order to get a plain OS # handler. if (defined $child_err_fno and $child_err_fno >= 0) { open $child_err_safe, ">&=$child_err_fno" or POSIX::_exit(1); } else { open $child_err_safe, ">/dev/null" or POSIX::_exit(1); } my $child_in_fno = _fileno_dup_over(0 => $child_in ); my $child_out_fno = _fileno_dup_over(1 => $child_out ); my $child_err_safe_fno = _fileno_dup_over(2 => $child_err_safe); unless (($child_in_fno == 0 or POSIX::dup2($child_in_fno, 0)) and ($child_out_fno == 1 or POSIX::dup2($child_out_fno, 1)) and ($child_err_safe_fno == 2 or POSIX::dup2($child_err_safe_fno, 2))) { POSIX::_exit(1); } do { exec @_ }; POSIX::_exit(1); } close $child_in; close $child_out; $_[0] = $dad_in; $_[1] = $dad_out; $pid; } sub _init_transport { my ($backend, $sftp, $opts) = @_; my $transport = delete $opts->{transport}; if (defined $transport) { if (ref $transport eq 'ARRAY') { @{$sftp}{qw(ssh_in ssh_out pid)} = @$transport; } else { $sftp->{ssh_in} = $sftp->{ssh_out} = $transport; $sftp->{_ssh_out_is_not_dupped} = 1; } } else { my $user = delete $opts->{user}; my $pass = delete $opts->{passphrase}; my $ask_for_username_at_login; my $pass_is_passphrase; my $password_prompt; if (defined $pass) { $pass_is_passphrase = 1; } else { $pass = delete $opts->{password}; if (defined $pass) { $sftp->{_password_authentication} = 1; $password_prompt = $sftp->{_password_prompt} = delete $opts->{password_prompt}; if (defined $password_prompt) { unless (ref $password_prompt eq 'Regexp') { $password_prompt = quotemeta $password_prompt; $password_prompt = qr/$password_prompt\s*$/i; } } $ask_for_username_at_login = $sftp->{_ask_for_username_at_login} = ( delete($opts->{ask_for_username_at_login}) || delete($opts->{asks_for_username_at_login}) ); if ($ask_for_username_at_login) { croak "ask_for_username_at_login set but user was not given" unless defined $user; croak "ask_for_username_at_login can not be used with a custom password prompt" if defined $password_prompt; } } } delete $opts->{expect_log_user}; # backward compatibility, not used anymore my $stderr_discard = delete $opts->{stderr_discard}; my $stderr_fh = ($stderr_discard ? undef : delete $opts->{stderr_fh}); my $open2_cmd = delete $opts->{open2_cmd}; my $ssh_cmd_interface = delete $opts->{ssh_cmd_interface}; my @open2_cmd; if (defined $open2_cmd) { @open2_cmd = _ensure_list($open2_cmd); } else { my $host = delete $opts->{host}; defined $host or croak "sftp target host not defined"; my $key_path = delete $opts->{key_path}; my $ssh_cmd = delete $opts->{ssh_cmd}; $ssh_cmd = 'ssh' unless defined $ssh_cmd; @open2_cmd = _ensure_list $ssh_cmd; unless (defined $ssh_cmd_interface) { $ssh_cmd_interface = ( "@open2_cmd" =~ /\bplink\b/i ? 'plink' : "@open2_cmd" =~ /\bsshg3\b/i ? 'tectia' : 'ssh' ); } my $port = delete $opts->{port}; my $ssh1 = delete $opts->{ssh1}; my $more = delete $opts->{more}; defined $more and !ref($more) and $more =~ /^-\w\s+\S/ and warnings::warnif("Net::SFTP::Foreign", "'more' argument looks like it should be split first"); my @more = _ensure_list $more; my @preferred_authentications; if (defined $key_path) { push @preferred_authentications, 'publickey'; push @open2_cmd, map { -i => $_ } _ensure_list $key_path; } if ($ssh_cmd_interface eq 'plink') { push @open2_cmd, -P => $port if defined $port; if (defined $pass and !$pass_is_passphrase) { warnings::warnif("Net::SFTP::Foreign", "using insecure password authentication with plink"); push @open2_cmd, -pw => $pass; undef $pass; } } elsif ($ssh_cmd_interface eq 'ssh') { push @open2_cmd, -p => $port if defined $port; if (defined $pass and !$pass_is_passphrase) { push @open2_cmd, -o => 'NumberOfPasswordPrompts=1'; push @preferred_authentications, ('keyboard-interactive', 'password'); } if (@preferred_authentications and not grep { $more[$_] eq '-o' and $more[$_ + 1] =~ /^PreferredAuthentications\W/ } 0..$#more-1) { push @open2_cmd, -o => 'PreferredAuthentications=' . join(',', @preferred_authentications); } } elsif ($ssh_cmd_interface eq 'tectia') { } else { die "Unsupported ssh_cmd_interface '$ssh_cmd_interface'"; } push @open2_cmd, -l => $user if defined $user; push @open2_cmd, @more; push @open2_cmd, $host; push @open2_cmd, ($ssh1 ? "/usr/lib/sftp-server" : -s => 'sftp'); } my $redirect_stderr_to_tty = ( defined $pass and ( delete $opts->{redirect_stderr_to_tty} or $ssh_cmd_interface eq 'tectia' ) ); $redirect_stderr_to_tty and ($stderr_discard or $stderr_fh) and croak "stderr_discard or stderr_fh can not be used together with password/passphrase " . "authentication when Tectia client is used"; $debug and $debug & 1 and _debug "ssh cmd: @open2_cmd\n"; %$opts and return; # Net::SFTP::Foreign will find the # unhandled options and croak if (${^TAINT} and Scalar::Util::tainted($ENV{PATH})) { _tcroak('Insecure $ENV{PATH}') } if ($stderr_discard) { $stderr_fh = $backend->_open_dev_null($sftp) or return; } if (defined $pass) { # user has requested to use a password or a passphrase for # authentication we use IO::Pty to handle that eval { require IO::Pty; 1 } or croak "password authentication not available, IO::Pty is not installed or failed to load: $@"; local ($ENV{SSH_ASKPASS}, $ENV{SSH_AUTH_SOCK}) if $pass_is_passphrase; my $name = $pass_is_passphrase ? 'Passphrase' : 'Password'; my $child; my $pty = IO::Pty->new; $redirect_stderr_to_tty and $stderr_fh = $pty->slave; $child = $backend->_open4($sftp, $sftp->{ssh_in}, $sftp->{ssh_out}, $stderr_fh, $pty, @open2_cmd); unless (defined $child) { $sftp->_conn_failed("Bad ssh command", $!); return; } $sftp->{pid} = $child; open my $pty_dup, '+>&', $pty; # store pty as a file handler instead of a object in # order to save it from being destroyed too early # during global destruction $sftp->{_pty} = $pty_dup; $debug and $debug & 65536 and _debug "starting password authentication"; my $rv = ''; vec($rv, fileno($pty), 1) = 1; my $buffer = ''; my $at = 0; my $password_sent; my $start_time = time; while(1) { if (defined $sftp->{_timeout}) { $debug and $debug & 65536 and _debug "checking timeout, max: $sftp->{_timeout}, ellapsed: " . (time - $start_time); if (time - $start_time > $sftp->{_timeout}) { $sftp->_conn_failed("login procedure timed out"); return; } } if (waitpid($child, POSIX::WNOHANG()) > 0) { undef $sftp->{pid}; my $err = $? >> 8; $sftp->_conn_failed("SSH slave exited unexpectedly with error code $err"); return; } $debug and $debug & 65536 and _debug "waiting for data from the pty to become available"; my $rv1 = $rv; select($rv1, undef, undef, 1) > 0 or next; if (my $bytes = sysread($pty, $buffer, 4096, length $buffer)) { if ($debug and $debug & 65536) { _debug "$bytes bytes readed from pty:"; _hexdump substr($buffer, -$bytes); } if ($buffer =~ /^The authenticity of host/mi or $buffer =~ /^Warning: the \S+ host key for/mi) { $sftp->_conn_failed("the authenticity of the target host can't be established, " . "the remote host public key is probably not present on the " . "'~/.ssh/known_hosts' file"); return; } if ($password_sent) { $debug and $debug & 65536 and _debug "looking for password ok"; last if substr($buffer, $at) =~ /\n$/; } else { $debug and $debug & 65536 and _debug "looking for user/password prompt"; my $re = ( defined $password_prompt ? $password_prompt : qr/(user|name|login)?[:?]\s*$/i ); $debug and $debug & 65536 and _debug "matching against $re"; if (substr($buffer, $at) =~ $re) { if ($ask_for_username_at_login and ($ask_for_username_at_login ne 'auto' or defined $1)) { $debug and $debug & 65536 and _debug "sending username"; print $pty "$user\n"; undef $ask_for_username_at_login; } else { $debug and $debug & 65536 and _debug "sending password"; print $pty "$pass\n"; $password_sent = 1; } $at = length $buffer; } } } else { $debug and $debug & 65536 and _debug "no data available from pty, delaying until next read"; sleep 0.1; } } $debug and $debug & 65536 and _debug "password authentication done"; $pty->close_slave(); } else { $sftp->{pid} = $backend->_open4($sftp, $sftp->{ssh_in}, $sftp->{ssh_out}, $stderr_fh, undef, @open2_cmd); unless (defined $sftp->{pid}) { $sftp->_conn_failed("Bad ssh command", $!); return; } } } $backend->_init_transport_streams($sftp); } sub _after_init { my ($backend, $sftp) = @_; if ($sftp->{pid} and not $sftp->error) { # do not propagate signals sent from the terminal to the # slave SSH: local ($@, $!); eval { setpgrp($sftp->{pid}, 0) }; } } sub _do_io { my (undef, $sftp, $timeout) = @_; $debug and $debug & 32 and _debug(sprintf "_do_io connected: %s", $sftp->{_connected} || 0); return undef unless $sftp->{_connected}; my $fnoout = fileno $sftp->{ssh_out}; my $fnoin = fileno $sftp->{ssh_in}; my ($rv, $wv) = ('', ''); vec($rv, $fnoin, 1) = 1; vec($wv, $fnoout, 1) = 1; my $bin = \$sftp->{_bin}; my $bout = \$sftp->{_bout}; local $SIG{PIPE} = 'IGNORE'; my $len; while (1) { my $lbin = length $$bin; if (defined $len) { return 1 if $lbin >= $len; } elsif ($lbin >= 4) { $len = 4 + unpack N => $$bin; if ($len > 256 * 1024) { $sftp->_set_status(SSH2_FX_BAD_MESSAGE); $sftp->_set_error(SFTP_ERR_REMOTE_BAD_MESSAGE, "bad remote message received"); return undef; } return 1 if $lbin >= $len; } my $rv1 = $rv; my $wv1 = length($$bout) ? $wv : ''; $debug and $debug & 32 and _debug("_do_io select(-,-,-, ". (defined $timeout ? $timeout : 'undef') .")"); my $n = select($rv1, $wv1, undef, $timeout); if ($n > 0) { if (vec($wv1, $fnoout, 1)) { my $written = syswrite($sftp->{ssh_out}, $$bout, 64 * 1024); if ($debug and $debug & 32) { _debug (sprintf "_do_io write queue: %d, syswrite: %s, max: %d, \$!: %s", length $$bout, (defined $written ? $written : 'undef'), 64 * 1024, $!); $debug & 2048 and $written and _hexdump(substr($$bout, 0, $written)); } if ($written) { substr($$bout, 0, $written, ''); } elsif ($! != Errno::EAGAIN() and $! != Errno::EINTR()) { $sftp->_conn_lost; return undef; } } if (vec($rv1, $fnoin, 1)) { my $read = sysread($sftp->{ssh_in}, $$bin, 64 * 1024, length($$bin)); if ($debug and $debug & 32) { _debug (sprintf "_do_io read sysread: %s, total read: %d, \$!: %s", (defined $read ? $read : 'undef'), length $$bin, $!); $debug & 1024 and $read and _hexdump(substr($$bin, -$read)); } if (!$read and $! != Errno::EAGAIN() and $! != Errno::EINTR()) { $sftp->_conn_lost; return undef; } } } else { $debug and $debug & 32 and _debug "_do_io select failed: $!"; next if ($n < 0 and ($! == Errno::EINTR() or $! == Errno::EAGAIN())); return undef; } } } 1; libnet-sftp-foreign-perl-1.86+dfsg.orig/lib/Net/SFTP/Foreign/Backend/Windows.pm0000644000175000017500000000531712516370257026160 0ustar salvisalvipackage Net::SFTP::Foreign::Backend::Windows; our $VERSION = '1.70_08'; use strict; use warnings; use Carp; our @CARP_NOT = qw(Net::SFTP::Foreign); use IPC::Open3; use POSIX (); use Net::SFTP::Foreign::Helpers; use Net::SFTP::Foreign::Constants qw(SSH2_FX_BAD_MESSAGE SFTP_ERR_REMOTE_BAD_MESSAGE); require Net::SFTP::Foreign::Backend::Unix; our @ISA = qw(Net::SFTP::Foreign::Backend::Unix); sub _defaults { ( queue_size => 16 ) } sub _init_transport_streams { my ($backend, $sftp) = @_; binmode $sftp->{ssh_in}; binmode $sftp->{ssh_out}; } sub _open_dev_null { my $sftp = shift; my $dev_null; unless (open $dev_null, '>', 'NUL:') { $sftp->_conn_failed("Unable to redirect stderr for slave SSH process to NUL: $!"); return; } $dev_null } sub _open4 { my $backend = shift; my $sftp = shift; defined $_[3] and croak "setting child PTY is not supported on Windows"; my $fno = eval { defined $_[2] ? fileno $_[2] : fileno *STDERR }; unless (defined $fno and $fno >= 0) { $sftp->_conn_failed("STDERR or stderr_fh is not a real file handle: " . (length $@ ? $@ : $!)); return; } local *SSHERR; unless (open(SSHERR, ">>&=", $fno)) { $sftp->_conn_failed("Unable to duplicate stderr redirection file handle: $!"); return undef; } goto NOTIE unless tied *STDERR; local *STDERR; unless (open STDERR, ">&=2") { $sftp->_conn_failed("Unable to reattach STDERR to fd 2: $!"); return; } NOTIE: local ($@, $SIG{__DIE__}, $SIG{__WARN__}); my $ppid = $$; my $pid = eval { open3(@_[1,0], ">&SSHERR", @_[4..$#_]) }; $ppid == $$ or POSIX::_exit(-1); $pid; } sub _after_init {} sub _sysreadn { my ($sftp, $n) = @_; my $bin = \$sftp->{_bin}; while (1) { my $len = length $$bin; return 1 if $len >= $n; my $read = sysread($sftp->{ssh_in}, $$bin, $n - $len, $len); unless ($read) { $sftp->_conn_lost; return undef; } } return $n; } sub _do_io { my ($backend, $sftp, $timeout) = @_; return undef unless $sftp->{_connected}; my $bin = \$sftp->{_bin}; my $bout = \$sftp->{_bout}; while (length $$bout) { my $written = syswrite($sftp->{ssh_out}, $$bout, 20480); unless ($written) { $sftp->_conn_lost; return undef; } substr($$bout, 0, $written, ""); } defined $timeout and $timeout <= 0 and return; _sysreadn($sftp, 4) or return undef; my $len = 4 + unpack N => $$bin; if ($len > 256 * 1024) { $sftp->_set_status(SSH2_FX_BAD_MESSAGE); $sftp->_set_error(SFTP_ERR_REMOTE_BAD_MESSAGE, "bad remote message received"); return undef; } _sysreadn($sftp, $len); } 1; libnet-sftp-foreign-perl-1.86+dfsg.orig/lib/Net/SFTP/Foreign/Attributes/0000755000175000017500000000000012726520616024760 5ustar salvisalvilibnet-sftp-foreign-perl-1.86+dfsg.orig/lib/Net/SFTP/Foreign/Attributes/Compat.pm0000644000175000017500000000222512516370257026543 0ustar salvisalvipackage Net::SFTP::Foreign::Attributes::Compat; our $VERSION = '0.01'; use strict; use warnings; use Net::SFTP::Foreign::Attributes; our @ISA = qw(Net::SFTP::Foreign::Attributes); my @fields = qw( flags size uid gid perm atime mtime ); for my $f (@fields) { no strict 'refs'; *$f = sub { @_ > 1 ? $_[0]->{$f} = $_[1] : $_[0]->{$f} || 0 } } sub new { my ($class, %param) = @_; my $a = $class->SUPER::new(); if (my $stat = $param{Stat}) { $a->set_size($stat->[7]); $a->set_ugid($stat->[4], $stat->[5]); $a->set_perm($stat->[2]); $a->set_amtime($stat->[8], $stat->[9]); } $a; } 1; __END__ =head1 NAME Net::SFTP::Foreign::Attributes::Compat - adapter for Net::SFTP::Attributes compatibility =head1 SYNOPSIS use Net::SFTP::Foreign::Attributes::Compat; my $attrs = Net::SFTP::Foreign::Attributes->new(Stat => [ stat "foo" ]); my $size = $attrs->size; =head1 DESCRIPTION This module provides a wrapper for L exposing an API compatible to L. =head1 AUTHOR & COPYRIGHTS Please see the Net::SFTP::Foreign manpage for author, copyright, and license information. =cut libnet-sftp-foreign-perl-1.86+dfsg.orig/lib/Net/SFTP/Foreign/Buffer.pm0000644000175000017500000001133012516370257024400 0ustar salvisalvipackage Net::SFTP::Foreign::Buffer; our $VERSION = '1.68_05'; use strict; use warnings; no warnings 'uninitialized'; use Carp; use constant HAS_QUADS => do { local $@; local $SIG{__DIE__}; no warnings; eval q{ pack(Q => 0x1122334455667788) eq "\x11\x22\x33\x44\x55\x66\x77\x88" } }; sub new { my $class = shift; my $data = ''; @_ and put(\$data, @_); bless \$data, $class; } sub make { bless \$_[1], $_[0] } sub bytes { ${$_[0]} } sub get_int8 { length ${$_[0]} >=1 or return undef; unpack(C => substr(${$_[0]}, 0, 1, '')); } sub get_int16 { length ${$_[0]} >=2 or return undef; unpack(n => substr(${$_[0]}, 0, 2, '')); } sub get_int32 { length ${$_[0]} >=4 or return undef; unpack(N => substr(${$_[0]}, 0, 4, '')); } sub get_int32_untaint { my ($v) = substr(${$_[0]}, 0, 4, '') =~ /(.*)/s; get_int32(\$v); } sub get_int64_quads { length ${$_[0]} >= 8 or return undef; unpack Q => substr(${$_[0]}, 0, 8, '') } sub get_int64_no_quads { length ${$_[0]} >= 8 or return undef; my ($big, $small) = unpack(NN => substr(${$_[0]}, 0, 8, '')); if ($big) { # too big for an integer, try to handle it as a float: my $high = $big * 4294967296; my $result = $high + $small; unless ($result - $high == $small) { # too big event for a float, use a BigInt; require Math::BigInt; $result = Math::BigInt->new($big); $result <<= 32; $result += $small; } return $result; } return $small; } *get_int64 = (HAS_QUADS ? \&get_int64_quads : \&get_int64_no_quads); sub get_int64_untaint { my ($v) = substr(${$_[0]}, 0, 8, '') =~ /(.*)/s; get_int64(\$v); } sub get_str { my $self = shift; length $$self >=4 or return undef; my $len = unpack(N => substr($$self, 0, 4, '')); length $$self >=$len or return undef; substr($$self, 0, $len, ''); } sub get_str_list { my $self = shift; my @a; if (my $n = $self->get_int32) { for (1..$n) { my $str = $self->get_str; last unless defined $str; push @a, $str; } } return @a; } sub get_attributes { Net::SFTP::Foreign::Attributes->new_from_buffer($_[0]) } sub skip_bytes { substr(${$_[0]}, 0, $_[1], '') } sub skip_str { my $self = shift; my $len = $self->get_int32; substr($$self, 0, $len, ''); } sub put_int8 { ${$_[0]} .= pack(C => $_[1]) } sub put_int32 { ${$_[0]} .= pack(N => $_[1]) } sub put_int64_quads { ${$_[0]} .= pack(Q => $_[1]) } sub put_int64_no_quads { if ($_[1] >= 4294967296) { my $high = int ( $_[1] / 4294967296); my $low = int ($_[1] - $high * 4294967296); ${$_[0]} .= pack(NN => $high, $low) } else { ${$_[0]} .= pack(NN => 0, $_[1]) } } *put_int64 = (HAS_QUADS ? \&put_int64_quads : \&put_int64_no_quads); sub put_str { utf8::downgrade($_[1]) or croak "UTF8 data reached the SFTP buffer"; ${$_[0]} .= pack(N => length($_[1])) . $_[1] } sub put_char { ${$_[0]} .= $_[1] } sub _attrs_as_buffer { my $attrs = shift; my $ref = ref $attrs; Net::SFTP::Foreign::Attributes->isa($ref) or croak("Object of class Net::SFTP::Foreign::Attributes " . "expected, $ref found"); $attrs->as_buffer; } sub put_attributes { ${$_[0]} .= ${_attrs_as_buffer $_[1]} } my %unpack = ( int8 => \&get_int8, int32 => \&get_int32, int64 => \&get_int64, str => \&get_str, attr => \&get_attributtes ); sub get { my $buf = shift; map { $unpack{$_}->($buf) } @_; } my %pack = ( int8 => sub { pack C => $_[0] }, int32 => sub { pack N => $_[0] }, int64 => sub { if (HAS_QUADS) { return pack(Q => $_[0]) } else { if ($_[0] >= 4294967296) { my $high = int ( $_[0] / 4294967296); my $low = int ($_[0] - $high * 4294967296); return pack(NN => $high, $low) } else { return pack(NN => 0, $_[0]) } } }, str => sub { pack(N => length($_[0])), $_[0] }, char => sub { $_[0] }, attr => sub { ${_attrs_as_buffer $_[0]} } ); sub put { my $buf =shift; @_ & 1 and croak "bad number of arguments for put (@_)"; my @parts; while (@_) { my $type = shift; my $value = shift; my $packer = $pack{$type} or Carp::confess("internal error: bad packing type '$type'"); push @parts, $packer->($value) } $$buf.=join('', @parts); } 1; __END__ =head1 NAME Net::SFTP::Foreign::Buffer - Read/write buffer class =head1 SYNOPSIS use Net::SFTP::Foreign::Buffer; my $buffer = Net::SFTP::Foreign::Buffer->new; =head1 DESCRIPTION I provides read/write buffer functionality for SFTP. =head1 AUTHOR & COPYRIGHTS Please see the Net::SFTP::Foreign manpage for author, copyright, and license information. =cut libnet-sftp-foreign-perl-1.86+dfsg.orig/lib/Net/SFTP/Foreign/Compat.pm0000644000175000017500000001566212516370257024426 0ustar salvisalvipackage Net::SFTP::Foreign::Compat; our $VERSION = '1.70_05'; use warnings; use strict; use Carp; require Net::SFTP::Foreign; require Net::SFTP::Foreign::Constants; require Net::SFTP::Foreign::Attributes::Compat; our @ISA = qw(Net::SFTP::Foreign); my $supplant; sub import { for my $arg (@_[1..$#_]) { if ($arg eq ':supplant') { # print STDERR "suplanting Net::SFTP...\n"; if (!$supplant) { $supplant = 1; @Net::SFTP::ISA = qw(Net::SFTP::Foreign::Compat); @Net::SFTP::Attributes::ISA = qw(Net::SFTP::Foreign::Attributes::Compat); @Net::SFTP::Constant::ISA = qw(Net::SFTP::Foreign::Constants); $INC{q(Net/SFTP.pm)} = $INC{q(Net/SFTP/Foreign/Compat.pm)}; $INC{q(Net/SFTP/Attributes.pm)} = $INC{q(Net/SFTP/Foreign/Compat.pm)}; $INC{q(Net/SFTP/Constants.pm)} = $INC{q(Net/SFTP/Foreign/Compat.pm)}; } } else { croak "invalid import tag '$arg'" } } } our %DEFAULTS = ( put => [best_effort => 1], get => [best_effort => 1], ls => [], new => [] ); BEGIN { my @forbidden = qw( setcwd cwd open opendir sftpread sftpwrite seek tell eof write flush read getc lstat stat fstat remove rmdir mkdir setstat fsetstat close closedir readdir realpath readlink rename symlink abort get_content join glob rremove rget rput error die_on_error ); for my $method (@forbidden) { my $super = "SUPER::$method"; no strict 'refs'; *{$method} = sub { unless (index((caller)[0], "Net::SFTP::Foreign") == 0) { croak "Method '$method' is not available from " . __PACKAGE__ . ", use the real Net::SFTP::Foreign if you want it!"; } shift->$super(@_); }; } } sub new { my ($class, $host, %opts) = @_; my $warn; if (exists $opts{warn}) { $warn = delete($opts{warn}) || sub {}; } else { $warn = sub { warn(CORE::join '', @_, "\n") }; } my $sftp = $class->SUPER::new($host, @{$DEFAULTS{new}}, %opts); $sftp->{_compat_warn} = $warn; return $sftp; } sub _warn { my $sftp = shift; if (my $w = $sftp->{_compat_warn}) { $w->(@_); } } sub _warn_error { my $sftp = shift; if (my $e = $sftp->SUPER::error) { $sftp->_warn($e); } } sub status { my $status = shift->SUPER::status; return wantarray ? ($status + 0, "$status") : $status + 0; } sub get { croak '$Usage: $sftp->get($local, $remote, $cb)' if @_ < 2 or @_ > 4; my ($sftp, $remote, $local, $cb) = @_; my $save = defined(wantarray); my @content; my @cb; if (defined $cb or $save) { @cb = ( callback => sub { my ($sftp, $data, $off, $size) = @_; $cb->($sftp, $data, $off, $size) if $cb; push @content, $data if $save }); } $sftp->SUPER::get($remote, $local, @{$DEFAULTS{get}}, dont_save => !defined($local), @cb) or return undef; if ($save) { return CORE::join('', @content); } } sub put { croak '$Usage: $sftp->put($local, $remote, $cb)' if @_ < 3 or @_ > 4; my ($sftp, $local, $remote, $cb) = @_; $sftp->SUPER::put($local, $remote, @{$DEFAULTS{put}}, callback => $cb); $sftp->_warn_error; !$sftp->SUPER::error; } sub ls { croak '$Usage: $sftp->ls($path, $cb)' if @_ < 2 or @_ > 3; my ($sftp, $path, $cb) = @_; if ($cb) { $sftp->SUPER::ls($path, @{$DEFAULTS{ls}}, wanted => sub { _rebless_attrs($_[1]->{a}); $cb->($_[1]); 0 } ); return (); } else { if (my $ls = $sftp->SUPER::ls($path, @{$DEFAULTS{ls}})) { _rebless_attrs($_->{a}) for @$ls; return @$ls; } return () } } sub do_open { shift->SUPER::open(@_) } sub do_opendir { shift->SUPER::opendir(@_) } sub do_realpath { shift->SUPER::realpath(@_) } sub do_read { my $sftp = shift; my $read = $sftp->SUPER::sftpread(@_); $sftp->_warn_error; if (wantarray) { return ($read, $sftp->status); } else { return $read } } sub _gen_do_and_status { my $method = "SUPER::" . shift; return sub { my $sftp = shift; $sftp->$method(@_); $sftp->_warn_error; $sftp->status; } } *do_write = _gen_do_and_status('sftpwrite'); *do_close = _gen_do_and_status('close'); *do_setstat = _gen_do_and_status('setstat'); *do_fsetstat = _gen_do_and_status('setstat'); *do_remove = _gen_do_and_status('remove'); *do_rename = _gen_do_and_status('rename'); *do_mkdir = _gen_do_and_status('mkdir'); *do_rmdir = _gen_do_and_status('rmdir'); sub _rebless_attrs { my $a = shift; if ($a) { bless $a, ( $supplant ? "Net::SFTP::Attributes" : "Net::SFTP::Foreign::Attributes::Compat" ); } $a; } sub _gen_do_stat { my $name = shift; my $method = "SUPER::$name"; return sub { croak '$Usage: $sftp->'.$name.'($local, $remote, $cb)' if @_ != 2; my $sftp = shift; if (my $a = $sftp->$method(@_)) { return _rebless_attrs($a); } else { $sftp->_warn_error; return undef; } } } *do_lstat = _gen_do_stat('lstat'); *do_fstat = _gen_do_stat('fstat'); *do_stat = _gen_do_stat('stat'); 1; __END__ =head1 NAME Net::SFTP::Foreign::Compat - Adapter for Net::SFTP compatibility =head1 SYNOPSIS use Net::SFTP::Foreign::Compat; my $sftp = Net::SFTP::Foreign::Compat->new($host); $sftp->get("foo", "bar"); $sftp->put("bar", "baz"); use Net::SFTP::Foreign::Compat ':supplant'; my $sftp = Net::SFTP->new($host); =head1 DESCRIPTION This package is a wrapper around L that provides an API (mostly) compatible with that of L. Methods on this package are identical to those in L except that L objects have to be used instead of L. If the C<:supplant> tag is used, this module installs also wrappers on the C and L packages so no other parts of the program have to modified in order to move from Net::SFTP to Net::SFTP::Foreign. =head2 Setting defaults The hash C<%Net::SFTP::Foreign::DEFAULTS> can be used to set default values for L methods called under the hood and otherwise not accessible through the Net::SFTP API. The entries currently supported are: =over =item new => \@opts extra options passed to Net::SFTP::Foreign constructor. =item get => \@opts extra options passed to Net::SFTP::Foreign::get method. =item put => \@opts extra options passed to Net::SFTP::Foreign::put method. =item ls => \@opts extra options passed to Net::SFTP::Foreign::ls method. =back =head1 COPYRIGHT Copyright (c) 2006-2008, 2011 Salvador FandiEo All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut libnet-sftp-foreign-perl-1.86+dfsg.orig/lib/Net/SFTP/Foreign/Helpers.pm0000644000175000017500000001652612726306517024606 0ustar salvisalvipackage Net::SFTP::Foreign::Helpers; our $VERSION = '1.74_06'; use strict; use warnings; use Carp qw(croak carp); our @CARP_NOT = qw(Net::SFTP::Foreign); use Scalar::Util qw(tainted); require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw( _sort_entries _gen_wanted _ensure_list _catch_tainted_args _debug _gen_converter _hexdump $debug ); our @EXPORT_OK = qw( _is_lnk _is_dir _is_reg _do_nothing _glob_to_regex _file_part _umask_save_and_set _tcroak _untaint ); our $debug; BEGIN { eval "use Time::HiRes 'time'" if ($debug and $debug & 256) } sub _debug { local ($\, $!); my $caller = ''; if ( $debug & 8192) { $caller = (caller 1)[3]; $caller =~ s/[\w:]*:://; $caller .= ': '; } my $line = join(' ', map { defined $_ ? $_ : '' } @_); if ($debug & 256) { my $ts = sprintf("%010.5f", time); print STDERR "#$$ $ts $caller $line\n"; } else { print STDERR "# $caller $line\n"; } } sub _hexdump { local ($\, $!); no warnings qw(uninitialized); my $data = shift; while ($data =~ /(.{1,32})/smg) { my $line=$1; my @c= (( map { sprintf "%02x",$_ } unpack('C*', $line)), ((" ") x 32))[0..31]; $line=~s/(.)/ my $c=$1; unpack("c",$c)>=32 ? $c : '.' /egms; local $\; print STDERR join(" ", @c, '|', $line), "\n"; } } sub _do_nothing {} { my $has_sk; sub _has_sk { unless (defined $has_sk) { local $@; local $SIG{__DIE__}; eval { require Sort::Key }; $has_sk = ($@ eq ''); } return $has_sk; } } sub _sort_entries { my $e = shift; if (_has_sk) { &Sort::Key::keysort_inplace(sub { $_->{filename} }, $e); } else { @$e = sort { $a->{filename} cmp $b->{filename} } @$e; } } sub _gen_wanted { my ($ow, $onw) = my ($w, $nw) = @_; if (ref $w eq 'Regexp') { $w = sub { $_[1]->{filename} =~ $ow } } if (ref $nw eq 'Regexp') { $nw = sub { $_[1]->{filename} !~ $onw } } elsif (defined $nw) { $nw = sub { !&$onw }; } if (defined $w and defined $nw) { return sub { &$nw and &$w } } return $w || $nw; } sub _ensure_list { my $l = shift; return () unless defined $l; local $@; local $SIG{__DIE__}; local $SIG{__WARN__}; no warnings; (eval { @$l; 1 } ? @$l : $l); } sub _glob_to_regex { my ($glob, $strict_leading_dot, $ignore_case) = @_; my ($regex, $in_curlies, $escaping); my $wildcards = 0; my $first_byte = 1; while ($glob =~ /\G(.)/g) { my $char = $1; # print "char: $char\n"; if ($char eq '\\') { $escaping = 1; } else { if ($first_byte) { if ($strict_leading_dot) { $regex .= '(?=[^\.])' unless $char eq '.'; } $first_byte = 0; } if ($char eq '/') { $first_byte = 1; } if ($escaping) { $regex .= quotemeta $char; } else { $wildcards++; if ($char eq '*') { $regex .= ".*"; } elsif ($char eq '?') { $regex .= '.' } elsif ($char eq '{') { $regex .= '(?:(?:'; ++$in_curlies; } elsif ($char eq '}') { $regex .= "))"; --$in_curlies; $in_curlies < 0 and croak "invalid glob pattern"; } elsif ($char eq ',' && $in_curlies) { $regex .= ")|(?:"; } elsif ($char eq '[') { if ($glob =~ /\G((?:\\.|[^\]])+)\]/g) { $regex .= "[$1]" } else { croak "invalid glob pattern"; } } else { $wildcards--; $regex .= quotemeta $char; } } $escaping = 0; } } croak "invalid glob pattern" if $in_curlies; my $re = $ignore_case ? qr/^$regex$/i : qr/^$regex$/; wantarray ? ($re, ($wildcards > 0 ? 1 : undef)) : $re } sub _tcroak { if (${^TAINT} > 0) { push @_, " while running with -T switch"; goto &croak; } if (${^TAINT} < 0) { push @_, " while running with -t switch"; goto &carp; } } sub _catch_tainted_args { my $i; for (@_) { next unless $i++; if (tainted($_)) { my (undef, undef, undef, $subn) = caller 1; my $msg = ( $subn =~ /::([a-z]\w*)$/ ? "Insecure argument '$_' on '$1' method call" : "Insecure argument '$_' on method call" ); _tcroak($msg); } elsif (ref($_)) { for (grep tainted($_), do { local ($@, $SIG{__DIE__}); eval { values %$_ }}) { my (undef, undef, undef, $subn) = caller 1; my $msg = ( $subn =~ /::([a-z]\w*)$/ ? "Insecure argument on '$1' method call" : "Insecure argument on method call" ); _tcroak($msg); } } } } sub _gen_dos2unix { my $unix2dos = shift; my $name = ($unix2dos ? 'unix2dos' : 'dos2unix'); my $previous; my $done; sub { $done and die "Internal error: bad calling sequence for $name transformation"; my $adjustment = 0; for (@_) { if ($debug and $debug & 128) { _debug ("before $name: previous: $previous, data follows..."); _hexdump($_); } if (length) { if ($previous) { $adjustment++; $_ = "\x0d$_"; } $adjustment -= $previous = s/\x0d\z//s; if ($unix2dos) { $adjustment += s/(?($_[0]); length($_[0]) - $before; } } else { croak "unsupported conversion argument" } } elsif ($conversion eq 'dos2unix') { return _gen_dos2unix(0); } elsif ($conversion eq 'unix2dos') { return _gen_dos2unix(1); } else { croak "unknown conversion '$conversion'"; } } sub _is_lnk { (0120000 & shift) == 0120000 } sub _is_dir { (0040000 & shift) == 0040000 } sub _is_reg { (0100000 & shift) == 0100000 } sub _file_part { my $path = shift; $path =~ m{([^/]*)$} or croak "unable to get file part from path '$path'"; $1; } sub _untaint { if (${^TAINT}) { for (@_) { defined or next; ($_) = /(.*)/s } } } sub _umask_save_and_set { my $umask = shift; if (defined $umask) { my $old = umask $umask; return bless \$old, 'Net::SFTP::Foreign::Helpers::umask_saver'; } () } sub Net::SFTP::Foreign::Helpers::umask_saver::DESTROY { umask ${$_[0]} } 1; libnet-sftp-foreign-perl-1.86+dfsg.orig/lib/Net/SFTP/Foreign/Attributes.pm0000644000175000017500000002004012516370257025313 0ustar salvisalvipackage Net::SFTP::Foreign::Attributes; our $VERSION = '1.68_05'; use strict; use warnings; use Carp; use Net::SFTP::Foreign::Constants qw( :att ); use Net::SFTP::Foreign::Buffer; sub new { my $class = shift; return bless { flags => 0}, $class; } sub new_from_stat { if (@_ > 1) { my ($class, undef, undef, $mode, undef, $uid, $gid, undef, $size, $atime, $mtime) = @_; my $self = $class->new; $self->set_perm($mode); $self->set_ugid($uid, $gid); $self->set_size($size); $self->set_amtime($atime, $mtime); return $self; } return undef; } sub new_from_buffer { my ($class, $buf) = @_; my $self = $class->new; my $flags = $self->{flags} = $buf->get_int32_untaint; if ($flags & SSH2_FILEXFER_ATTR_SIZE) { $self->{size} = $buf->get_int64_untaint; } if ($flags & SSH2_FILEXFER_ATTR_UIDGID) { $self->{uid} = $buf->get_int32_untaint; $self->{gid} = $buf->get_int32_untaint; } if ($flags & SSH2_FILEXFER_ATTR_PERMISSIONS) { $self->{perm} = $buf->get_int32_untaint; } if ($flags & SSH2_FILEXFER_ATTR_ACMODTIME) { $self->{atime} = $buf->get_int32_untaint; $self->{mtime} = $buf->get_int32_untaint; } if ($flags & SSH2_FILEXFER_ATTR_EXTENDED) { my $n = $buf->get_int32; $n >= 0 and $n <= 10000 or return undef; my @pairs = map $buf->get_str, 1..2*$n; $self->{extended} = \@pairs; } $self; } sub skip_from_buffer { my ($class, $buf) = @_; my $flags = $buf->get_int32; if ($flags == ( SSH2_FILEXFER_ATTR_SIZE | SSH2_FILEXFER_ATTR_UIDGID | SSH2_FILEXFER_ATTR_PERMISSIONS | SSH2_FILEXFER_ATTR_ACMODTIME )) { $buf->skip_bytes(28); } else { my $len = 0; $len += 8 if $flags & SSH2_FILEXFER_ATTR_SIZE; $len += 8 if $flags & SSH2_FILEXFER_ATTR_UIDGID; $len += 4 if $flags & SSH2_FILEXFER_ATTR_PERMISSIONS; $len += 8 if $flags & SSH2_FILEXFER_ATTR_ACMODTIME; $buf->skip_bytes($len); if ($flags & SSH2_FILEXFER_ATTR_EXTENDED) { my $n = $buf->get_int32; $buf->skip_str, $buf->skip_str for (1..$n); } } } sub as_buffer { my $a = shift; my $buf = Net::SFTP::Foreign::Buffer->new(int32 => $a->{flags}); if ($a->{flags} & SSH2_FILEXFER_ATTR_SIZE) { $buf->put_int64(int $a->{size}); } if ($a->{flags} & SSH2_FILEXFER_ATTR_UIDGID) { $buf->put(int32 => $a->{uid}, int32 => $a->{gid}); } if ($a->{flags} & SSH2_FILEXFER_ATTR_PERMISSIONS) { $buf->put_int32($a->{perm}); } if ($a->{flags} & SSH2_FILEXFER_ATTR_ACMODTIME) { $buf->put(int32 => $a->{atime}, int32 => $a->{mtime}); } if ($a->{flags} & SSH2_FILEXFER_ATTR_EXTENDED) { my $pairs = $a->{extended}; $buf->put_int32(int(@$pairs / 2)); $buf->put_str($_) for @$pairs; } $buf; } sub flags { shift->{flags} } sub size { shift->{size} } sub set_size { my ($self, $size) = @_; if (defined $size) { $self->{flags} |= SSH2_FILEXFER_ATTR_SIZE; $self->{size} = $size; } else { $self->{flags} &= ~SSH2_FILEXFER_ATTR_SIZE; delete $self->{size} } } sub uid { shift->{uid} } sub gid { shift->{gid} } sub set_ugid { my ($self, $uid, $gid) = @_; if (defined $uid and defined $gid) { $self->{flags} |= SSH2_FILEXFER_ATTR_UIDGID; $self->{uid} = $uid; $self->{gid} = $gid; } elsif (!defined $uid and !defined $gid) { $self->{flags} &= ~SSH2_FILEXFER_ATTR_UIDGID; delete $self->{uid}; delete $self->{gid}; } else { croak "wrong arguments for set_ugid" } } sub perm { shift->{perm} } sub set_perm { my ($self, $perm) = @_; if (defined $perm) { $self->{flags} |= SSH2_FILEXFER_ATTR_PERMISSIONS; $self->{perm} = $perm; } else { $self->{flags} &= ~SSH2_FILEXFER_ATTR_PERMISSIONS; delete $self->{perm} } } sub atime { shift->{atime} } sub mtime { shift->{mtime} } sub set_amtime { my ($self, $atime, $mtime) = @_; if (defined $atime and defined $mtime) { $self->{flags} |= SSH2_FILEXFER_ATTR_ACMODTIME; $self->{atime} = $atime; $self->{mtime} = $mtime; } elsif (!defined $atime and !defined $mtime) { $self->{flags} &= ~SSH2_FILEXFER_ATTR_ACMODTIME; delete $self->{atime}; delete $self->{mtime}; } else { croak "wrong arguments for set_amtime" } } sub extended { @{shift->{extended} || [] } } sub set_extended { my $self = shift; @_ & 1 and croak "odd number of arguments passed to set_extended"; if (@_) { $self->{flags} |= SSH2_FILEXFER_ATTR_EXTENDED; $self->{extended} = [@_]; } else { $self->{flags} &= ~SSH2_FILEXFER_ATTR_EXTENDED; delete $self->{extended}; } } sub append_extended { my $self = shift; @_ & 1 and croak "odd number of arguments passed to append_extended"; my $pairs = $self->{extended}; if (@$pairs) { push @$pairs, @_; } else { $self->set_extended(@_); } } sub clone { my $self = shift; my $clone = { %$self }; bless $clone, ref $self; $clone; } 1; __END__ =head1 NAME Net::SFTP::Foreign::Attributes - File/directory attribute container =head1 SYNOPSIS use Net::SFTP::Foreign; my $a1 = Net::SFTP::Foreign::Attributes->new(); $a1->set_size($size); $a1->set_ugid($uid, $gid); my $a2 = $sftp->stat($file) or die "remote stat command failed: ".$sftp->status; my $size = $a2->size; my $mtime = $a2->mtime; =head1 DESCRIPTION I encapsulates file/directory attributes for I. It also provides serialization and deserialization methods to encode/decode attributes into I objects. =head1 USAGE =over 4 =item Net::SFTP::Foreign::Attributes-Enew() Returns a new C object. =item Net::SFTP::Foreign::Attributes-Enew_from_buffer($buffer) Creates a new attributes object and populates it with information read from C<$buffer>. =item $attrs-Eas_buffer Serializes the I object I<$attrs> into a buffer object. =item $attrs-Eflags returns the value of the flags field. =item $attrs-Esize returns the values of the size field or undef if it is not set. =item $attrs-Euid returns the value of the uid field or undef if it is not set. =item $attrs-Egid returns the value of the gid field or undef if it is not set. =item $attrs-Eperm returns the value of the permissions field or undef if it is not set. See also L for instructions on how to process the returned value with the L module. For instance, the following code checks if some attributes object corresponds to a directory: use Fcntl qw(S_ISDIR); ... if (S_ISDIR($attr->perm)) { # it is a directory! } =item $attrs-Eatime returns the value of the atime field or undef if it is not set. =item $attrs-Emtime returns the value of the mtime field or undef if it is not set. =item %extended = $attr-Eextended returns the vendor-dependent extended attributes =item $attrs-Eset_size($size) sets the value of the size field, or if $size is undef removes the field. The flags field is adjusted accordingly. =item $attrs-Eset_perm($perm) sets the value of the permissions field or removes it if the value is undefined. The flags field is also adjusted. =item $attr-Eset_ugid($uid, $gid) sets the values of the uid and gid fields, or removes them if they are undefined values. The flags field is adjusted. This pair of fields can not be set separately because they share the same bit on the flags field and so both have to be set or not. =item $attr-Eset_amtime($atime, $mtime) sets the values of the atime and mtime fields or remove them if they are undefined values. The flags field is also adjusted. =item $attr-Eset_extended(%extended) sets the vendor-dependent extended attributes =item $attr-Eappend_extended(%more_extended) adds more pairs to the list of vendor-dependent extended attributes =back =head1 COPYRIGHT Copyright (c) 2006-2008 Salvador FandiEo. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut libnet-sftp-foreign-perl-1.86+dfsg.orig/lib/Net/SFTP/Foreign/Local.pm0000644000175000017500000000567312516370257024236 0ustar salvisalvipackage Net::SFTP::Foreign::Local; our $VERSION = '1.57'; use strict; use warnings; use Carp; use File::Spec; use Net::SFTP::Foreign::Attributes; use Net::SFTP::Foreign::Constants qw(:error); use Net::SFTP::Foreign::Helpers qw(_sort_entries _gen_wanted _do_nothing); require Net::SFTP::Foreign::Common; our @ISA = qw(Net::SFTP::Foreign::Common); sub new { my $class = shift; my $self = { status => 0, error => 0 }; bless $self, $class; } sub realpath { $! = 0; File::Spec->rel2abs($_[1]) } sub stat { $! = 0; my $a = Net::SFTP::Foreign::Attributes->new_from_stat(CORE::stat($_[1])); unless ($a) { $_[0]->_set_error(SFTP_ERR_LOCAL_STAT_FAILED, "Couldn't stat local file '$_[1]'", $!); } $a } sub lstat { $! = 0; my $a = Net::SFTP::Foreign::Attributes->new_from_stat(CORE::lstat($_[1])); unless ($a) { $_[0]->_set_error(SFTP_ERR_LOCAL_STAT_FAILED, "Couldn't stat local file '$_[1]'", $!); } $a } sub readlink { $! = 0; my $target = readlink $_[1]; unless (defined $target) { $_[0]->_set_error(SFTP_ERR_LOCAL_READLINK_FAILED, "Couldn't read link '$_[1]'", $!); } $target } sub join { shift; my $path = File::Spec->join(@_); $path = File::Spec->canonpath($path); # print 'lfs->join("'.join('", "', @_)."\") => $path\n"; $path } sub ls { my ($self, $dir, %opts) = @_; my $ordered = delete $opts{ordered}; my $follow_links = delete $opts{follow_links}; my $atomic_readdir = delete $opts{atomic_readdir}; my $wanted = delete $opts{_wanted} || _gen_wanted(delete $opts{wanted}, delete $opts{no_wanted}); %opts and croak "invalid option(s) '".CORE::join("', '", keys %opts)."'"; $! = 0; opendir(my $ldh, $dir) or return undef; my @dir; while (defined(my $part = readdir $ldh)) { my $fn = File::Spec->join($dir, $part); my $a = $self->lstat($fn); if ($a and $follow_links and S_ISLNK($a->perm)) { if (my $fa = $self->stat($fn)) { $a = $fa; } else { $! = 0; } } my $entry = { filename => $part, a => $a }; if ($atomic_readdir or !$wanted or $wanted->($self, $entry)) { push @dir, $entry; } } if ($atomic_readdir and $wanted) { @dir = grep { $wanted->($self, $_) } @dir; } _sort_entries(\@dir) if $ordered; return \@dir; } 1; __END__ =head1 NAME Net::SFTP::Foreign::Local - access local file system through Net::SFTP::Foreign API. =head1 SYNOPSIS my $localfs = Net::SFTP::Foreign::Local->new; my @find = $localfs->find('.', no_wanted => qr/(?:\/|^).svn/); =head1 DESCRIPTION This module is a partial implementation of the L interface for the local filesystem. The methods currently implemented are: C, C, C and C. =head1 COPYRIGHT Copyright (c) 2006 Salvador FandiEo. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut libnet-sftp-foreign-perl-1.86+dfsg.orig/lib/Net/SFTP/Foreign/Common.pm0000644000175000017500000003143512516370257024427 0ustar salvisalvipackage Net::SFTP::Foreign::Common; our $VERSION = '1.76_02'; use strict; use warnings; use Carp; BEGIN { # Some versions of Scalar::Util are crippled require Scalar::Util; eval { Scalar::Util->import(qw(dualvar tainted)); 1 } or do { *tainted = sub { croak "The version of Scalar::Util installed on your system " . "does not provide 'tainted'" }; *dualvar = sub { $_[0] }; }; } use Net::SFTP::Foreign::Helpers qw(_gen_wanted _ensure_list _debug _glob_to_regex _is_lnk _is_dir $debug); use Net::SFTP::Foreign::Constants qw(:status); my %status_str = ( SSH2_FX_OK, "OK", SSH2_FX_EOF, "End of file", SSH2_FX_NO_SUCH_FILE, "No such file or directory", SSH2_FX_PERMISSION_DENIED, "Permission denied", SSH2_FX_FAILURE, "Failure", SSH2_FX_BAD_MESSAGE, "Bad message", SSH2_FX_NO_CONNECTION, "No connection", SSH2_FX_CONNECTION_LOST, "Connection lost", SSH2_FX_OP_UNSUPPORTED, "Operation unsupported" ); our $debug; sub _set_status { my $sftp = shift; my $code = shift; if ($code) { my $str; if (@_) { $str = join ': ', @_; ($str) = $str =~ /(.*)/ if (${^TAINT} && tainted $str); } unless (defined $str and length $str) { $str = $status_str{$code} || "Unknown status ($code)"; } $debug and $debug & 64 and _debug("_set_status code: $code, str: $str"); return $sftp->{_status} = dualvar($code, $str); } else { return $sftp->{_status} = 0; } } sub status { shift->{_status} } sub _set_error { my $sftp = shift; my $code = shift; if ($code) { my $str; if (@_) { $str = join ': ', @_; ($str) = $str =~ /(.*)/ if (${^TAINT} && tainted $str); } else { $str = $code ? "Unknown error $code" : "OK"; } $debug and $debug & 64 and _debug("_set_err code: $code, str: $str"); my $error = $sftp->{_error} = dualvar $code, $str; # FIXME: use a better approach to determine when some error is fatal croak $error if $sftp->{_autodie}; } elsif ($sftp->{_error}) { # FIXME: use a better approach to determine when some error is fatal if ($sftp->{_error} != Net::SFTP::Foreign::Constants::SFTP_ERR_CONNECTION_BROKEN()) { $sftp->{_error} = 0; } } return $sftp->{_error} } sub _clear_error_and_status { my $sftp = shift; $sftp->_set_error; $sftp->_set_status; } sub _copy_error { my ($sftp, $other) = @_; unless ($sftp->{_error} and $sftp->{_error} == Net::SFTP::Foreign::Constants::SFTP_ERR_CONNECTION_BROKEN()) { $sftp->{_error} = $other->{_error}; } } sub error { shift->{_error} } sub die_on_error { my $sftp = shift; $sftp->{_error} and croak(@_ ? "@_: $sftp->{_error}" : $sftp->{_error}); } sub _ok_or_autodie { my $sftp = shift; return 1 unless $sftp->{_error}; $sftp->{_autodie} and croak $sftp->{_error}; undef; } sub _set_errno { my $sftp = shift; if ($sftp->{_error}) { my $status = $sftp->{_status} + 0; my $error = $sftp->{_error} + 0; if ($status == SSH2_FX_EOF) { return; } elsif ($status == SSH2_FX_NO_SUCH_FILE) { $! = Errno::ENOENT(); } elsif ($status == SSH2_FX_PERMISSION_DENIED) { $! = Errno::EACCES(); } elsif ($status == SSH2_FX_BAD_MESSAGE) { $! = Errno::EBADMSG(); } elsif ($status == SSH2_FX_OP_UNSUPPORTED) { $! = Errno::ENOTSUP() } elsif ($status) { $! = Errno::EIO() } } } sub _best_effort { my $sftp = shift; my $best_effort = shift; my $method = shift; local ($sftp->{_error}, $sftp->{_autodie}) if $best_effort; $sftp->$method(@_); return (($best_effort or not $sftp->{_error}) ? 1 : undef); } sub _call_on_error { my ($sftp, $on_error, $entry) = @_; $on_error and $sftp->error and $on_error->($sftp, $entry); $sftp->_clear_error_and_status; } # this method code is a little convoluted because we are trying to # keep in memory as few entries as possible!!! sub find { @_ >= 1 or croak 'Usage: $sftp->find($remote_dirs, %opts)'; my $self = shift; my %opts = @_ & 1 ? ('dirs', @_) : @_; $self->_clear_error_and_status; my $dirs = delete $opts{dirs}; my $follow_links = delete $opts{follow_links}; my $on_error = delete $opts{on_error}; local $self->{_autodie} if $on_error; my $realpath = delete $opts{realpath}; my $ordered = delete $opts{ordered}; my $names_only = delete $opts{names_only}; my $atomic_readdir = delete $opts{atomic_readdir}; my $wanted = _gen_wanted( delete $opts{wanted}, delete $opts{no_wanted} ); my $descend = _gen_wanted( delete $opts{descend}, delete $opts{no_descend} ); %opts and croak "invalid option(s) '".CORE::join("', '", keys %opts)."'"; $dirs = '.' unless defined $dirs; my $wantarray = wantarray; my (@res, $res); my %done; my %rpdone; # used to detect cycles my @dirs = _ensure_list $dirs; my @queue = map { { filename => $_ } } ($ordered ? sort @dirs : @dirs); # we use a clousure instead of an auxiliary method to have access # to the state: my $task = sub { my $entry = shift; my $fn = $entry->{filename}; for (1) { my $follow = ($follow_links and _is_lnk($entry->{a}->perm)); if ($follow or $realpath) { unless (defined $entry->{realpath}) { my $rp = $entry->{realpath} = $self->realpath($fn); next unless (defined $rp and not $rpdone{$rp}++); } } if ($follow) { my $a = $self->stat($fn); if (defined $a) { $entry->{a} = $a; # we queue it for reprocessing as it could be a directory unshift @queue, $entry; } next; } if (!$wanted or $wanted->($self, $entry)) { if ($wantarray) { push @res, ( $names_only ? ( exists $entry->{realpath} ? $entry->{realpath} : $entry->{filename} ) : $entry ) } else { $res++; } } } continue { $self->_call_on_error($on_error, $entry) } }; my $try; while (@queue) { no warnings 'uninitialized'; $try = shift @queue; my $fn = $try->{filename}; my $a = $try->{a} ||= $self->lstat($fn) or next; next if (_is_dir($a->perm) and $done{$fn}++); $task->($try); if (_is_dir($a->perm)) { if (!$descend or $descend->($self, $try)) { if ($ordered or $atomic_readdir) { my $ls = $self->ls( $fn, ordered => $ordered, _wanted => sub { my $child = $_[1]->{filename}; if ($child !~ /^\.\.?$/) { $_[1]->{filename} = $self->join($fn, $child); return 1; } undef; }) or next; unshift @queue, @$ls; } else { $self->ls( $fn, _wanted => sub { my $entry = $_[1]; my $child = $entry->{filename}; if ($child !~ /^\.\.?$/) { $entry->{filename} = $self->join($fn, $child); if (_is_dir($entry->{a}->perm)) { push @queue, $entry; } else { $task->($entry); } } undef } ) or next; } } } } continue { $self->_call_on_error($on_error, $try) } return wantarray ? @res : $res; } sub glob { @_ >= 2 or croak 'Usage: $sftp->glob($pattern, %opts)'; ${^TAINT} and &_catch_tainted_args; my ($sftp, $glob, %opts) = @_; return () if $glob eq ''; my $on_error = delete $opts{on_error}; local $sftp->{_autodie} if $on_error; my $follow_links = delete $opts{follow_links}; my $ignore_case = delete $opts{ignore_case}; my $names_only = delete $opts{names_only}; my $realpath = delete $opts{realpath}; my $ordered = delete $opts{ordered}; my $wanted = _gen_wanted( delete $opts{wanted}, delete $opts{no_wanted}); my $strict_leading_dot = delete $opts{strict_leading_dot}; $strict_leading_dot = 1 unless defined $strict_leading_dot; %opts and _croak_bad_options(keys %opts); my $wantarray = wantarray; my (@parts, $top); if (ref $glob eq 'Regexp') { @parts = ($glob); $top = '.'; } else { @parts = ($glob =~ m{\G/*([^/]+)}g); push @parts, '.' unless @parts; $top = ( $glob =~ m|^/| ? '/' : '.'); } my @res = ( {filename => $top} ); my $res = 0; while (@parts and @res) { my @parents = @res; @res = (); my $part = shift @parts; my ($re, $has_wildcards); if (ref $part eq 'Regexp') { $re = $part; $has_wildcards = 1; } else { ($re, $has_wildcards) = _glob_to_regex($part, $strict_leading_dot, $ignore_case); } for my $parent (@parents) { my $pfn = $parent->{filename}; if ($has_wildcards) { $sftp->ls( $pfn, ordered => $ordered, _wanted => sub { my $e = $_[1]; if ($e->{filename} =~ $re) { my $fn = $e->{filename} = $sftp->join($pfn, $e->{filename}); if ( (@parts or $follow_links) and _is_lnk($e->{a}->perm) ) { if (my $a = $sftp->stat($fn)) { $e->{a} = $a; } else { $on_error and $sftp->_call_on_error($on_error, $e); return undef; } } if (@parts) { push @res, $e if _is_dir($e->{a}->perm) } elsif (!$wanted or $wanted->($sftp, $e)) { if ($wantarray) { if ($realpath) { my $rp = $e->{realpath} = $sftp->realpath($e->{filename}); unless (defined $rp) { $on_error and $sftp->_call_on_error($on_error, $e); return undef; } } push @res, ($names_only ? ($realpath ? $e->{realpath} : $e->{filename} ) : $e); } $res++; } } return undef } ) or ($on_error and $sftp->_call_on_error($on_error, $parent)); } else { my $fn = $sftp->join($pfn, $part); my $method = ((@parts or $follow_links) ? 'stat' : 'lstat'); if (my $a = $sftp->$method($fn)) { my $e = { filename => $fn, a => $a }; if (@parts) { push @res, $e if _is_dir($a->{perm}) } elsif (!$wanted or $wanted->($sftp, $e)) { if ($wantarray) { if ($realpath) { my $rp = $fn = $e->{realpath} = $sftp->realpath($fn); unless (defined $rp) { $on_error and $sftp->_call_on_error($on_error, $e); next; } } push @res, ($names_only ? $fn : $e) } $res++; } } } } } return wantarray ? @res : $res; } sub test_d { my ($sftp, $name) = @_; { local $sftp->{_autodie}; my $a = $sftp->stat($name); return _is_dir($a->perm) if $a; } if ($sftp->{_status} == SSH2_FX_NO_SUCH_FILE) { $sftp->_clear_error_and_status; return undef; } $sftp->_ok_or_autodie; } sub test_e { my ($sftp, $name) = @_; { local $sftp->{_autodie}; $sftp->stat($name) and return 1; } if ($sftp->{_status} == SSH2_FX_NO_SUCH_FILE) { $sftp->_clear_error_and_status; return undef; } $sftp->_ok_or_autodie; } 1; libnet-sftp-foreign-perl-1.86+dfsg.orig/lib/Net/SFTP/Foreign/Constants.pm0000644000175000017500000001776512516370257025165 0ustar salvisalvipackage Net::SFTP::Foreign::Constants; our $VERSION = '1.63_05'; use strict; use warnings; use Carp; require Exporter; our @ISA = qw(Exporter); our (@EXPORT_OK, %EXPORT_TAGS); BEGIN { my %constants = ( SSH2_FXP_INIT => 1, SSH2_FXP_VERSION => 2, SSH2_FXP_OPEN => 3, SSH2_FXP_CLOSE => 4, SSH2_FXP_READ => 5, SSH2_FXP_WRITE => 6, SSH2_FXP_LSTAT => 7, SSH2_FXP_FSTAT => 8, SSH2_FXP_SETSTAT => 9, SSH2_FXP_FSETSTAT => 10, SSH2_FXP_OPENDIR => 11, SSH2_FXP_READDIR => 12, SSH2_FXP_REMOVE => 13, SSH2_FXP_MKDIR => 14, SSH2_FXP_RMDIR => 15, SSH2_FXP_REALPATH => 16, SSH2_FXP_STAT => 17, SSH2_FXP_RENAME => 18, SSH2_FXP_READLINK => 19, SSH2_FXP_SYMLINK => 20, SSH2_FXP_STATUS => 101, SSH2_FXP_HANDLE => 102, SSH2_FXP_DATA => 103, SSH2_FXP_NAME => 104, SSH2_FXP_ATTRS => 105, SSH2_FXP_EXTENDED => 200, SSH2_FXP_EXTENDED_REPLY => 201, SSH2_FXF_READ => 0x01, SSH2_FXF_WRITE => 0x02, SSH2_FXF_APPEND => 0x04, SSH2_FXF_CREAT => 0x08, SSH2_FXF_TRUNC => 0x10, SSH2_FXF_EXCL => 0x20, SSH2_FX_OK => 0, SSH2_FX_EOF => 1, SSH2_FX_NO_SUCH_FILE => 2, SSH2_FX_PERMISSION_DENIED => 3, SSH2_FX_FAILURE => 4, SSH2_FX_BAD_MESSAGE => 5, SSH2_FX_NO_CONNECTION => 6, SSH2_FX_CONNECTION_LOST => 7, SSH2_FX_OP_UNSUPPORTED => 8, SSH2_FILEXFER_ATTR_SIZE => 0x01, SSH2_FILEXFER_ATTR_UIDGID => 0x02, SSH2_FILEXFER_ATTR_PERMISSIONS => 0x04, SSH2_FILEXFER_ATTR_ACMODTIME => 0x08, SSH2_FILEXFER_ATTR_EXTENDED => 0x80000000, SSH2_FILEXFER_VERSION => 3, SSH2_FXE_STATVFS_ST_READONLY => 0x1, SSH2_FXE_STATVFS_ST_NOSUID => 0x2, SFTP_ERR_REMOTE_STAT_FAILED => 1, SFTP_ERR_REMOTE_OPEN_FAILED => 2, SFTP_ERR_LOCAL_ALREADY_EXISTS => 3, # SFTP_ERR_LOCAL_OPEN_FAILED => 4, SFTP_ERR_LOCAL_OPEN_FAILED => 26, SFTP_ERR_REMOTE_READ_FAILED => 5, SFTP_ERR_REMOTE_BLOCK_TOO_SMALL => 6, SFTP_ERR_LOCAL_WRITE_FAILED => 7, SFTP_ERR_REMOTE_BAD_PERMISSIONS => 8, SFTP_ERR_LOCAL_CHMOD_FAILED => 9, SFTP_ERR_REMOTE_BAD_TIME => 10, SFTP_ERR_LOCAL_UTIME_FAILED => 11, SFTP_ERR_REMOTE_BAD_MESSAGE => 13, SFTP_ERR_REMOTE_REALPATH_FAILED => 14, SFTP_ERR_REMOTE_OPENDIR_FAILED => 15, SFTP_ERR_REMOTE_WRITE_FAILED => 16, SFTP_ERR_REMOTE_RENAME_FAILED => 17, SFTP_ERR_REMOTE_LSTAT_FAILED => 18, SFTP_ERR_REMOTE_FSTAT_FAILED => 19, SFTP_ERR_REMOTE_CLOSE_FAILED => 20, SFTP_ERR_REMOTE_REMOVE_FAILED => 21, SFTP_ERR_REMOTE_MKDIR_FAILED => 22, SFTP_ERR_REMOTE_RMDIR_FAILED => 23, SFTP_ERR_REMOTE_SETSTAT_FAILED => 24, SFTP_ERR_REMOTE_FSETSTAT_FAILED => 25, SFTP_ERR_LOCAL_STAT_FAILED => 27, SFTP_ERR_LOCAL_READ_ERROR => 28, SFTP_ERR_REMOTE_READDIR_FAILED => 29, SFTP_ERR_REMOTE_READLINK_FAILED => 30, SFTP_ERR_REMOTE_SYMLINK_FAILED => 31, SFTP_ERR_REMOTE_BAD_PATH => 32, SFTP_ERR_LOCAL_MKDIR_FAILED => 33, SFTP_ERR_LOCAL_SYMLINK_FAILED => 34, SFTP_ERR_REMOTE_BAD_OBJECT => 35, SFTP_ERR_REMOTE_ACCESING_CLOSED_FILE => 36, SFTP_ERR_CONNECTION_BROKEN => 37, SFTP_ERR_LOCAL_GENERIC_ERROR => 38, SFTP_ERR_LOCAL_READLINK_FAILED => 39, SFTP_ERR_LOCAL_BAD_PATH => 40, SFTP_ERR_LOCAL_BAD_OBJECT => 41, SFTP_ERR_REMOTE_ALREADY_EXISTS => 42, # SFTP_ERR_BAD_SSH_BINARY => 43, SFTP_ERR_ABORTED => 44, SFTP_ERR_REMOTE_BIGGER_THAN_LOCAL => 45, SFTP_ERR_LOCAL_BIGGER_THAN_REMOTE => 46, SFTP_ERR_LOCAL_SEEK_FAILED => 47, SFTP_ERR_REMOTE_STATVFS_FAILED => 48, SFTP_ERR_REMOTE_FSTATVFS_FAILED => 49, SFTP_ERR_PASSWORD_AUTHENTICATION_FAILED => 50, SFTP_ERR_REMOTE_HARDLINK_FAILED => 51, SFTP_ERR_LOCAL_RENAME_FAILED => 52, SFTP_ERR_REMOTE_FSYNC_FAILED => 53, ); for my $key (keys %constants) { no strict 'refs'; my $value = $constants{$key}; *{$key} = sub () { $value } } @EXPORT_OK = keys %constants; my %etagre = qw( fxp SSH2_FXP_ flags SSH2_FXF_ att SSH2_FILEXFER_ATTR status SSH2_FX_ error SFTP_ERR_ ext SSH2_FXE_); for my $key (keys %etagre) { my $re = qr/^$etagre{$key}/; $EXPORT_TAGS{$key} = [grep $_=~$re, @EXPORT_OK]; } } 1; __END__ =head1 NAME Net::SFTP::Foreign::Constants - Constant definitions for Net::SFTP::Foreign =head1 SYNOPSIS use Net::SFTP::Foreign::Constants qw(:tag SSH2_FILEXFER_VERSION); print "Protocol version is ", SSH2_FILEXFER_VERSION; =head1 DESCRIPTION Net::SFTP::Foreign::Constants provides a list of exportable SFTP constants: for SFTP messages and commands, for file-open flags, for status messages, etc. Constants can be exported individually, or in sets identified by tag names. Net::SFTP::Foreign::Constants provides values for all of the constants listed in the SFTP protocol version 3 draft; the only thing to note is that the constants are listed with the prefix C instead of C. So, for example, to import the constant for the file-open command, you would write: use Net::SFTP::Foreign::Constants qw( SSH2_FXP_OPEN ); =head1 TAGS As mentioned above, constants can either be imported individually or in sets grouped by tag names. The tag names are: =over 4 =item :fxp Imports all of the C constants: these are the constants used in the messaging protocol. =item :flags Imports all of the C constants: these are constants used as flags sent to the server when opening files. =item :att Imports all of the C constants: these are the constants used to construct the flag in the serialized attributes. The flag describes what types of file attributes are listed in the buffer. =item :status Imports all of the C constants: these are constants returned from a server C message and indicate the status of a particular operation. =item :error Imports all the C constants used to represent high level errors: C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C, C and C. Note: these constants are not defined on the SFTP draft. =item :ext Import all the C constants: there are the constants defined for usage with SFTP extensions. Currently, these are supported: C, C. =back There is one constant that does not fit into any of the tag sets: C, which holds the value of the SFTP protocol implemented by L. =head1 AUTHOR & COPYRIGHTS Please see the L manpage for author, copyright, and license information. =cut libnet-sftp-foreign-perl-1.86+dfsg.orig/t/0000755000175000017500000000000012726520616017434 5ustar salvisalvilibnet-sftp-foreign-perl-1.86+dfsg.orig/t/common.pm0000644000175000017500000000704212726312403021256 0ustar salvisalviuse strict; use warnings; use File::Spec; use Test::More; use Fcntl (); select STDERR; $|=1; select STDOUT; $ENV{PATH} = '/usr/bin:/bin' if ${^TAINT}; # tests don't work in parallel flock DATA, Fcntl::LOCK_EX(); sub is_windows { $^O =~ /MSWin32/i } sub sftp_server { my ($sscmd, @ssh, $ssname); if(is_windows) { $ssname = 'sftp-server.exe'; my $pf; eval { require Win32; $pf = Win32::GetFolderPath(Win32::CSIDL_PROGRAM_FILES()); }; $pf = "C:/Program Files/" unless defined $pf; @ssh = ("$pf/openssh/bin/ssh.exe", "$pf/openssh/usr/bin/ssh.exe", "$pf/bin/ssh.exe", "$pf/usr/bin/ssh.exe"); } else { $ssname = 'sftp-server'; @ssh = qw( /usr/bin/ssh /usr/local/bin/ssh /usr/local/openssh/bin/ssh /opt/openssh/bin/ssh /opt/ssh/bin/ssh ); } if (eval {require File::Which; 1}) { unshift @ssh, File::Which::where('ssh'); } elsif ($^O !~ /MSWin32/i) { chomp(my $ssh = `which ssh`); unshift @ssh, $ssh if (!$? and $ssh); } SEARCH: for (@ssh) { my ($vol, $dir) = File::Spec->splitpath($_); my $up = File::Spec->rel2abs(File::Spec->catpath($vol, $dir, File::Spec->updir)); for ( File::Spec->catfile($vol, $dir, $ssname), File::Spec->catfile($up, 'lib', $ssname), File::Spec->catfile($up, 'lib64', $ssname), File::Spec->catfile($up, 'libexec', $ssname), File::Spec->catfile($up, 'sbin', $ssname), File::Spec->catfile($up, 'lib', 'openssh', $ssname), File::Spec->catfile($up, 'lib64', 'openssh', $ssname), File::Spec->catfile($up, 'lib', 'misc', $ssname), File::Spec->catfile($up, 'lib64', 'misc', $ssname), File::Spec->catfile($up, 'usr', 'lib', $ssname), File::Spec->catfile($up, 'usr', 'lib64', $ssname), File::Spec->catfile($up, 'usr', 'libexec', $ssname), File::Spec->catfile($up, 'usr', 'sbin', $ssname) ) { if (-x $_) { $sscmd = $_; last SEARCH; } } } return $sscmd; } sub filediff { my ($a, $b) = @_; open my $fa, "<", $a or do { diag "unable to open file $a"; return; }; open my $fb, "<", $b or do { diag "unable to open file $b"; return; }; binmode $fa; binmode $fb; while (1) { my $la = read($fa, my $da, 2048); my $lb = read($fb, my $db, 2048); return 1 unless (defined $la and defined $lb); return 1 if $la != $lb; return 0 if $la == 0; return 1 if $la ne $lb; } } sub mktestfile { my ($fn, $count, $data) = @_; open DL, '>', $fn or die "unable to create test data file $fn"; print DL $data for (1..$count); close DL; } sub new_args { my $host = $ENV{NET_SFTP_FOREIGN_TESTING_HOST}; # = 'localhost'; my $backend = $ENV{NET_SFTP_FOREIGN_TESTING_BACKEND}; my @diag; my @args = (timeout => 20); if (defined $backend) { push @args, backend => $backend; push @diag, "using $backend backend"; } if (defined $host) { push @diag, "connecting to host $host"; push @args, host => $host; } else { my $ss_cmd = sftp_server; defined $ss_cmd or plan skip_all => 'sftp-server not found'; push @diag, "sftp-server found at $ss_cmd"; push @args, open2_cmd => $ss_cmd; } diag join(", ", @diag) if @diag; @args; } sub dump_error { my $sftp = shift; if (my $error = $sftp->error) { my $status = $sftp->status || 0; diag sprintf("SFTP error: %s [%d], status: %s [%d]", $error, $error, $status, $status); } } 1; __DATA__ libnet-sftp-foreign-perl-1.86+dfsg.orig/t/1_run.t0000644000175000017500000003004212726312555020645 0ustar salvisalvi#!/usr/bin/perl use strict; use warnings; use Test::More; # $Net::SFTP::Foreign::debug = -1; use lib "./t"; use common; use File::Spec; use Cwd qw(getcwd); my $salva = eval "no warnings; getlogin eq 'salva'"; plan skip_all => "tests not supported on inferior OS" if (is_windows and not $salva); my @new_args = new_args; plan tests => 939; use_ok('Net::SFTP::Foreign'); use Net::SFTP::Foreign::Constants qw(:flags SFTP_ERR_CONNECTION_BROKEN); $SIG{ALRM} = sub { print STDERR "# timeout expired: your computer is too slow or some test is not finishing\n"; exit 1; }; # don't set the alarm if we are being debugged! alarm 300 unless exists ${DB::}{sub}; my $sftp = eval { Net::SFTP::Foreign->new(@new_args) }; diag($@) if $@; ok (defined $sftp, "creating object"); my $lcwd = File::Spec->rel2abs('t'); my $rcwd = $sftp->realpath($lcwd); ok (defined $rcwd, "realpath"); my @data = ; ok ($sftp->setcwd("."), "setcwd"); ok (!$sftp->setcwd("miauu"), "setcwd to non existant dir"); ok ($sftp->stat("t/1_run.t"), "check that the file exists"); ok (!$sftp->setcwd("t/1_run.t"), "setcwd to file"); ok ($sftp->setcwd(), "setcwd reset"); for my $setcwd (0, 1) { my $orcwd = $rcwd; if ($setcwd) { $sftp->setcwd($orcwd); $rcwd = '.'; } # print STDERR "cwd: $sftp->{cwd}\n"; my $dlfn = File::Spec->catfile($lcwd, 'data.l'); my $dlfn1 = File::Spec->catfile($lcwd, 'data1.l'); my $drfn = File::Spec->catfile($rcwd, 'data.r'); my $drfn_l = File::Spec->catfile($lcwd, 'data.r'); my $drfn1 = "$drfn.1"; my $drfn1_l = "$drfn_l.1"; my $drdir_l = File::Spec->catdir($lcwd, 'testdir'); my $drdir = File::Spec->catdir($rcwd, 'testdir'); for my $i (1..8) { local $\ = ($i == 4 ? "-bad-" : undef); mktestfile($dlfn, $i * 4000, "this is just testing data... foo bar doz wahtever... "); ok ($sftp->put($dlfn, $drfn1), "put - $i"); diag ($sftp->error) if $sftp->error; ok(!filediff($dlfn, $drfn1_l), "put - file content - $i"); unlink $drfn_l; ok (open(F, '<', $dlfn), "put fh - open - $i"); ok ($sftp->put(\*F, $drfn1), "put fh - $i"); diag ($sftp->error) if $sftp->error; ok (close(F), "put fh - close - $i"); ok(!filediff($dlfn, $drfn1_l), "put fh - file content - $i"); unlink $drfn_l; ok($sftp->rename($drfn1, $drfn), "rename - $i"); diag ($sftp->error) if $sftp->error; ok($sftp->rename($drfn, $drfn, overwrite => 1)); diag ($sftp->error) if $sftp->error; mktestfile($drfn1_l, $i, "blah, blah, blah..."); ok(!$sftp->rename($drfn, $drfn1), "rename no overwrite - $i"); ok($sftp->rename($drfn, $drfn1, overwrite => 1), "rename force overwrite - $i"); diag ($sftp->error) if $sftp->error; ok($sftp->rename($drfn1, $drfn), "rename again - $i"); diag ($sftp->error) if $sftp->error; ok (my $attr = $sftp->stat($drfn), "stat - $i"); is ($attr->size, (stat($dlfn))[7], "stat - size - $i"); ok (!$sftp->put($dlfn, $drfn, overwrite => 0), "no overwrite - $i"); is (int $sftp->error, Net::SFTP::Foreign::Constants::SFTP_ERR_REMOTE_OPEN_FAILED(), "no overwrite - error - $i"); ok ($sftp->get($drfn, $dlfn1), "get - $i"); diag ($sftp->error) if $sftp->error; ok(!filediff($drfn_l, $dlfn1), "get - file content - $i"); unlink $dlfn1; my $dir = sprintf "data%03d", int(rand 1000); my $dlfn2 = File::Spec->catfile($lcwd, $dir, 'data.l'); ok ($sftp->get($drfn, $dlfn2), "get - mkpath local - $i"); diag ($sftp->error) if $sftp->error; ok(!filediff($drfn_l, $dlfn2), "get - mkpath local - file content - $i"); ok(unlink($dlfn2), "remove file"); ok(rmdir(File::Spec->catfile($lcwd, $dir)), "remove dir"); ok ($sftp->get($drfn, File::Spec->rel2abs($dlfn2)), "get - mkpath local - abs - $i"); diag ($sftp->error) if $sftp->error; ok(!filediff($drfn_l, $dlfn2), "get - mkpath local - abs - file content - $i"); ok(unlink($dlfn2), "remove file"); ok(rmdir(File::Spec->catfile($lcwd, $dir)), "remove dir"); my $c = 0; ok ($sftp->get($drfn, $dlfn1, conversion => sub { $c = 1 } ), "get with conversion - $i"); diag ($sftp->error) if $sftp->error; ok(!filediff($drfn_l, $dlfn1), "get with conversion - file content - $i"); ok($c, "get with conversion - conversion done - $i"); unlink $dlfn1; ok (open(F, '>', $dlfn1), "get fh - open - $i"); ok ($sftp->get($drfn, \*F), "get fh - $i"); diag ($sftp->error) if $sftp->error; ok (close(F), "get fh - close - $i"); ok(!filediff($drfn_l, $dlfn1), "get fh - file content - $i"); unlink $dlfn1; unlink $drfn_l; unlink $dlfn; } # mkdir and rmdir rmdir $drdir_l; ok($sftp->mkdir($drdir), "mkdir 1"); ok((-d $drdir_l), "mkdir 2"); ok($sftp->rmdir($drdir), "rmdir 1"); ok(!(-d $drdir_l), "rmdir 2"); ok($sftp->mkpath("$drdir/./foo"), "mkpath 1"); ok((-d "$drdir_l/foo"), "mkpath 2"); ok($sftp->rmdir("$drdir/foo"), "rmdir 3"); ok(!(-d "$drdir_l/foo"), "rmdir 4"); ok($sftp->mkpath("$drdir/foo"), "mkpath 3"); ok((-d "$drdir_l/foo"), "mkpath 4"); ok($sftp->rmdir("$drdir/foo"), "rmdir 5"); ok($sftp->rmdir($drdir), "rmdir 6"); ok(!(-d $drdir_l), "rmdir 7"); my $attr = Net::SFTP::Foreign::Attributes->new; $attr->set_perm(0700); ok($sftp->mkdir($drdir, $attr), "mkdir 3"); ok((-d $drdir_l), "mkdir 4"); my @stat = stat $drdir_l; is($stat[2] & 0777, 0700, "mkdir 5"); $attr->set_perm(0770); ok($sftp->setstat($drdir, $attr), "setstat 1"); @stat = stat $drdir_l; is($stat[2] & 0777, 0770, "setstat 2"); ok($sftp->rmdir($drdir), "rmdir 3"); ok(!(-d $drdir_l), "rmdir 4"); # reconnect $sftp = eval { Net::SFTP::Foreign->new(@new_args) }; diag($@) if $@; dump_error($sftp); ok (defined $sftp, "creating object 2"); # print STDERR "setcwd=$setcwd ($rcwd=$rcwd)\n"; if ($setcwd) { $sftp->setcwd($orcwd); } my $fh = $sftp->open($drfn, SSH2_FXF_CREAT|SSH2_FXF_WRITE); dump_error($sftp); ok ($fh, "open write file"); print $fh $_ for @data; ok((print $fh @data, @data, @data, @data), "write to file 2"); print $fh $_ for @data; ok((print $fh @data, @data, @data, @data), "write to file 2"); ok (close $fh); my @all = (@data) x 10; $fh = $sftp->open($drfn); dump_error($sftp); ok($fh, "open read file"); my @read = <$fh>; # our ($a, $b); # D("@read", "@all") and diag "got: $a\nexp: $b\n\n"; is("@read", "@all", "readline list context"); ok(close($fh), "close file"); $fh = $sftp->open($drfn); dump_error($sftp); ok($fh, "open read file 2"); @read = (); while (<$fh>) { push @read, $_; } is("@read", "@all", "readline scalar context"); ok(close($fh), "close file"); $fh = $sftp->open($drfn, SSH2_FXF_CREAT|SSH2_FXF_WRITE); dump_error($sftp); ok ($fh, "open write file"); my $all = join('', ((@all) x 10)); my $cp = $all; while (length $all) { $sftp->write($fh, substr($all, 0, 1 + int(rand 64000), '')); } ok (close($fh), "close write file"); my $ctn = $sftp->get_content($drfn); is($ctn, $cp, "get_content"); unlink $drfn_l; $sftp->put_content($cp, $drfn); $fh = $sftp->open($drfn); dump_error($sftp); ok($fh, "open read file 3"); ok(!$sftp->eof($fh), "not at eof"); while (1) { my $data = $sftp->read($fh, 1 + int(rand 64000)); last unless defined $data; $all .= $data; } is($all, $cp, "write and read chunks"); ok(eof($fh), "at eof"); for my $pos (0, 1000, 0, 234, 4500, 1025) { my $d1; seek($fh, $pos, 0); is(tell($fh), $pos, "seek & tell"); is(read($fh, my $data, $pos), $pos, "read"); is($d1 = $sftp->sftpread($fh, $pos, $pos), $data, "sftpread"); # D($d1, $data) and diag "got: $a\nexp: $b\n\n"; my $pos1 = $pos + length $data; for my $off (0, -1000, 234, 4500, -200, 1025) { next unless $pos1 + $off >= 0; $pos1 += $off; ok(seek($fh, $off, 1), "seek - 2"); is(tell($fh), $pos1, "tell"); # if $pos1 > 2000; is(read($fh, $data, $pos), $pos, "read - 2 ($pos1, $pos)"); is($d1 = $sftp->sftpread($fh, $pos1, $pos), $data, "sftpread - 2 ($pos1, $pos)"); # D($d1, $data) and diag "got: $a\nexp: $b\n\n"; $pos1 += length $data; } } # D($ctn, $all, -10, 30) and diag "got: $a\nexp: $b\n\n"; ok(seek($fh, 0, 0), 'seek - 3'); is(tell($fh), 0, 'tell - 3'); my $line = readline $fh; my $wfh = $sftp->open($drfn, SSH2_FXF_WRITE); ok($wfh, "open write file 3"); ok ($sftp->sftpwrite($wfh, length $line, "HELLO\n"), "sftpwrite"); $sftp->flush($fh); is (scalar getc($fh), 'H', "getc"); is (scalar readline($fh), "ELLO\n", "readline"); ok(close($wfh), "close"); ok(seek($fh, -2000, 2), 'seek'); @all = readline $fh; { local $/; undef $/; ok(seek($fh, -2000, 2), 'seek'); my $all = readline $fh; is ($all, join('', @all), "read to end of file"); is (length $all, 2000, "seek"); } opendir DIR, $lcwd; my @ld = sort grep !/^\./, readdir DIR; closedir DIR; # SKIP: { # skip "tied directory handles not available on this perl", 3 # unless eval "use 5.9.4; 1"; # # my $rd = $sftp->opendir($rcwd); # ok($rd, "open remote dir"); # # my @rd = sort grep !/^\./, readdir $rd; # is("@rd", "@ld", "readdir array"); # # ok (closedir($rd), "close dir"); # #}; # print STDERR "cwd: $sftp->{cwd}\n"; my $rd = $sftp->opendir($rcwd); ok($rd, "open remote dir 2 - $rcwd"); my @rd = sort grep !/^\./, (map { $_->{filename} } $sftp->readdir($rd)); is("@rd", "@ld", "readdir array 1 - $rcwd"); ok($sftp->closedir($rd), "close dir 2"); my @ls = sort map { $_->{filename} } @{$sftp->ls($rcwd, no_wanted => qr|^\.|)}; is ("@ls", "@ld", "ls"); my @rp = sort map { $_->{realpath} } @{$sftp->ls($rcwd, realpath => 1, no_wanted => qr|^\.|)}; ok(!grep(!-e $_, @rp), "ls realpath"); my @ld1 = sort('t', @ld); my @uns = $sftp->find($rcwd, wanted => sub { $_[1]->{filename} !~ m|^(?:.*/)?\.[^/]*$| }, descend => sub { $_[1]->{filename} eq $rcwd } ); push @uns, { filename => 't' } if $setcwd; my @find = sort map { $_->{filename} =~ m|(?:.*/)?(.*)$| && $1 } @uns; local $" = '|'; is ("@find", "@ld1", "find 1"); @ld1 = @ld; unshift @ld1, 't' unless $setcwd; @find = map { m|(?:.*/)?(.*)$|; $1 } $sftp->find( $rcwd, names_only => 1, ordered => 1, no_wanted => qr|^(?:.*/)?\.[^/]*$|, no_descend => qr|^(?:.*/)?\.svn$|); is ("@find", "@ld1", "find 2"); my @a = glob "$lcwd/*"; is ($sftp->glob("$rcwd/*"), scalar @a, "glob"); unlink $drfn_l; alarm 0; ok (1, "end"); } $sftp = eval { Net::SFTP::Foreign->new(@new_args, autodie => 1) }; ok($sftp, "new with autodie"); eval { $sftp->disconnect }; is($@, '', "don't die from disconnect"); is($sftp->error + 0, SFTP_ERR_CONNECTION_BROKEN + 0, "right error after disconnect"); __DATA__ Os Pinos. ¿Qué din os rumorosos na costa verdecente ao raio transparente do prácido luar? ¿Qué din as altas copas de escuro arume arpado co seu ben compasado monótono fungar? Do teu verdor cinguido e de benignos astros confín dos verdes castros e valeroso chan, non des a esquecemento da inxuria o rudo encono; desperta do teu sono fogar de Breogán. Os bos e xenerosos a nosa voz entenden e con arroubo atenden o noso ronco son, mais sóo os iñorantes e féridos e duros, imbéciles e escuros non nos entenden, non. Os tempos son chegados dos bardos das edades que as vosas vaguedades cumprido fin terán; pois, donde quer, xigante a nosa voz pregoa a redenzón da boa nazón de Breogán. - Eduardo Pondal libnet-sftp-foreign-perl-1.86+dfsg.orig/t/data.txd0000644000175000017500000000571512726311773021100 0ustar salvisalvi# ~/.bashrc: executed by bash(1) for non-login shells. # see /usr/share/doc/bash/examples/startup-files (in the package bash-doc) # for examples # If not running interactively, don't do anything [ -z "$PS1" ] && return # don't put duplicate lines in the history. See bash(1) for more options export HISTCONTROL=ignoredups # ... and ignore same sucessive entries. export HISTCONTROL=ignoreboth # check the window size after each command and, if necessary, # update the values of LINES and COLUMNS. shopt -s checkwinsize # make less more friendly for non-text input files, see lesspipe(1) [ -x /usr/bin/lesspipe ] && eval "$(lesspipe)" # set variable identifying the chroot you work in (used in the prompt below) if [ -z "$debian_chroot" ] && [ -r /etc/debian_chroot ]; then debian_chroot=$(cat /etc/debian_chroot) fi # set a fancy prompt (non-color, unless we know we "want" color) case "$TERM" in xterm-color) color_prompt=yes;; esac # uncomment for a colored prompt, if the terminal has the capability; turned # off by default to not distract the user: the focus in a terminal window # should be on the output of commands, not on the prompt #force_colored_prompt=yes if [ -n "$force_color_prompt" ]; then if [ -x /usr/bin/tput ] && tput setaf 1 >&/dev/null; then # We have color support; assume it's compliant with Ecma-48 # (ISO/IEC-6429). (Lack of such support is extremely rare, and such # a case would tend to support setf rather than setaf.) color_prompt=yes else color_prompt= fi fi if [ "$color_prompt" = yes ]; then PS1='${debian_chroot:+($debian_chroot)}\[\033[01;32m\]\u@\h\[\033[00m\]:\[\033[01;34m\]\w\[\033[00m\]\$ ' else PS1='${debian_chroot:+($debian_chroot)}\u@\h:\w\$ ' fi unset color_prompt force_color_prompt # If this is an xterm set the title to user@host:dir case "$TERM" in xterm*|rxvt*) PROMPT_COMMAND='echo -ne "\033]0;${USER}@${HOSTNAME}: ${PWD/$HOME/~}\007"' ;; *) ;; esac # Alias definitions. # You may want to put all your additions into a separate file like # ~/.bash_aliases, instead of adding them here directly. # See /usr/share/doc/bash-doc/examples in the bash-doc package. #if [ -f ~/.bash_aliases ]; then # . ~/.bash_aliases #fi # enable color support of ls and also add handy aliases if [ "$TERM" != "dumb" ] && [ -x /usr/bin/dircolors ]; then eval "`dircolors -b`" alias ls='ls --color=auto' #alias dir='ls --color=auto --format=vertical' #alias vdir='ls --color=auto --format=long' #alias grep='grep --color=auto' #alias fgrep='fgrep --color=auto' #alias egrep='egrep --color=auto' fi # some more ls aliases #alias ll='ls -l' #alias la='ls -A' #alias l='ls -CF' # enable programmable completion features (you don't need to enable # this, if it's already enabled in /etc/bash.bashrc and /etc/profile # sources /etc/bash.bashrc). if [ -f /etc/bash_completion ]; then . /etc/bash_completion fi libnet-sftp-foreign-perl-1.86+dfsg.orig/t/Net-SFTP-Foreign-Compat.t0000644000175000017500000000032212516370257023727 0ustar salvisalvi use Test::More tests => 3; BEGIN { use_ok('Net::SFTP::Foreign::Compat', ':supplant') }; BEGIN { use_ok('Net::SFTP') }; ok (UNIVERSAL::isa('Net::SFTP', 'Net::SFTP::Foreign::Compat'), "inheritance is wrong");libnet-sftp-foreign-perl-1.86+dfsg.orig/t/3_convert.t0000644000175000017500000000757712516370257021544 0ustar salvisalvi#!/usr/bin/perl use strict; use warnings; use Test::More; # $Net::SFTP::Foreign::debug = 17 + 64; use lib "./t"; use common; use File::Spec; use Cwd qw(getcwd); plan skip_all => "tests not supported on inferior OS" if (is_windows and eval "no warnings; getlogin ne 'salva'"); my @new_args = new_args; plan tests => 223; use_ok('Net::SFTP::Foreign'); use Net::SFTP::Foreign::Constants qw(:flags); $SIG{ALRM} = sub { print STDERR "# timeout expired: your computer is too slow or some test is not finishing\n"; exit 1; }; # don't set the alarm if we are being debugged! alarm 300 unless exists ${DB::}{sub}; chdir 't'; my $lcwd = File::Spec->rel2abs('.'); for my $bs (7, 8, 9, 20, 1024, 4096) { my $sftp = eval { Net::SFTP::Foreign->new(@new_args, block_size => $bs) }; diag($@) if $@; ok (defined $sftp, "creating object"); unless (defined $sftp) { diag "unable to create Net::SFTP::Foreign object, aborting tests"; exit 1; } ok (!$sftp->error, "sftp object created ok - $bs"); diag ($sftp->error) if $sftp->error; my $rcwd = $sftp->realpath($lcwd); ok ($sftp->setcwd($rcwd), "setcwd"); diag ($sftp->error) if $sftp->error; ok($sftp->get('data.txu', 'copied.txd', conversion => 'unix2dos'), "get unix2dos - $bs"); diag ($sftp->error) if $sftp->error; ok(!filediff('data.txd', 'copied.txd'), "get conversion unix2dos ok - $bs"); unlink 'copied.txd'; ok($sftp->get('data.txd', 'copied.txd', conversion => 'unix2dos'), "get unix2dos when already in dos format - $bs"); diag ($sftp->error) if $sftp->error; ok(!filediff('data.txd', 'copied.txd'), "get conversion unix2dos when already is dos format ok - $bs"); unlink 'copied.txd'; ok($sftp->get('data.txd', 'copied.txu', conversion => 'dos2unix'), "get dos2unix - $bs"); diag ($sftp->error) if $sftp->error; ok(!filediff('data.txu', 'copied.txu'), "get conversion dos2unix ok - $bs"); unlink 'copied.txu'; ok($sftp->put('data.txu', 'copied.txd', conversion => 'unix2dos'), "put unix2dos - $bs"); diag ($sftp->error) if $sftp->error; ok(!filediff('data.txd', 'copied.txd'), "put conversion unix2dos ok - $bs"); # unlink 'copied.txd'; ok($sftp->put('data.txd', 'copied.txu', conversion => 'dos2unix'), "put dos2unix - $bs"); diag ($sftp->error) if $sftp->error; ok(!filediff('data.txu', 'copied.txu'), "put conversion dos2unix ok - $bs"); # unlink 'copied.txu'; for my $r (1..3) { my $trunc = int (2500 * rand); truncate 'copied.txd', $trunc; ok($sftp->put('data.txu', 'copied.txd', conversion => 'unix2dos', resume => 1), "put unix2dos with resume - $bs, $r") or diag $sftp->error; ok(!filediff('data.txd', 'copied.txd'), "put conversion unix2dos with resume ok - $bs, $r") or diag "truncation position: $trunc"; truncate 'copied.txu', $trunc; ok($sftp->put('data.txd', 'copied.txu', conversion => 'dos2unix', resume => 1), "put dos2unix with resume - $bs, $r") or diag $sftp->error; ok(!filediff('data.txu', 'copied.txu'), "put conversion dos2unix with resume ok - $bs, $r") or diag "truncation position: $trunc"; truncate 'copied.txd', $trunc; ok($sftp->put('data.txd', 'copied.txd', resume => 1), "put with resume - $bs, $r") or diag $sftp->error; ok(!filediff('data.txd', 'copied.txd'), "put with resume ok - $bs, $r") or diag "truncation position: $trunc"; truncate 'copied.txd', $trunc; ok($sftp->get('data.txd', 'copied.txd', resume => 1), "get with resume - $bs, $r") or diag $sftp->error; ok(!filediff('data.txd', 'copied.txd'), "get with resume ok - $bs, $r, $trunc") # or exit 1; or diag "truncation position: $trunc"; } unlink 'copied.txu'; unlink 'copied.txd'; } libnet-sftp-foreign-perl-1.86+dfsg.orig/t/4_perl5_11.t0000644000175000017500000000066012516370257021377 0ustar salvisalvi#!/usr/bin/perl use strict; use warnings; use Test::More; use lib "./t"; use common; plan skip_all => "tests not supported on inferior OS" if (is_windows and eval "no warnings; getlogin ne 'salva'"); my @new_args = new_args; plan tests => 2; use Net::SFTP::Foreign; my $sftp = Net::SFTP::Foreign->new(@new_args); my $fn = File::Spec->rel2abs('t/data.txd'); ok(my $fh = $sftp->open($fn), "open"); ok (!eof($fh), "eof"); libnet-sftp-foreign-perl-1.86+dfsg.orig/t/data.txu0000644000175000017500000000556012726311776021122 0ustar salvisalvi# ~/.bashrc: executed by bash(1) for non-login shells. # see /usr/share/doc/bash/examples/startup-files (in the package bash-doc) # for examples # If not running interactively, don't do anything [ -z "$PS1" ] && return # don't put duplicate lines in the history. See bash(1) for more options export HISTCONTROL=ignoredups # ... and ignore same sucessive entries. export HISTCONTROL=ignoreboth # check the window size after each command and, if necessary, # update the values of LINES and COLUMNS. shopt -s checkwinsize # make less more friendly for non-text input files, see lesspipe(1) [ -x /usr/bin/lesspipe ] && eval "$(lesspipe)" # set variable identifying the chroot you work in (used in the prompt below) if [ -z "$debian_chroot" ] && [ -r /etc/debian_chroot ]; then debian_chroot=$(cat /etc/debian_chroot) fi # set a fancy prompt (non-color, unless we know we "want" color) case "$TERM" in xterm-color) color_prompt=yes;; esac # uncomment for a colored prompt, if the terminal has the capability; turned # off by default to not distract the user: the focus in a terminal window # should be on the output of commands, not on the prompt #force_colored_prompt=yes if [ -n "$force_color_prompt" ]; then if [ -x /usr/bin/tput ] && tput setaf 1 >&/dev/null; then # We have color support; assume it's compliant with Ecma-48 # (ISO/IEC-6429). (Lack of such support is extremely rare, and such # a case would tend to support setf rather than setaf.) color_prompt=yes else color_prompt= fi fi if [ "$color_prompt" = yes ]; then PS1='${debian_chroot:+($debian_chroot)}\[\033[01;32m\]\u@\h\[\033[00m\]:\[\033[01;34m\]\w\[\033[00m\]\$ ' else PS1='${debian_chroot:+($debian_chroot)}\u@\h:\w\$ ' fi unset color_prompt force_color_prompt # If this is an xterm set the title to user@host:dir case "$TERM" in xterm*|rxvt*) PROMPT_COMMAND='echo -ne "\033]0;${USER}@${HOSTNAME}: ${PWD/$HOME/~}\007"' ;; *) ;; esac # Alias definitions. # You may want to put all your additions into a separate file like # ~/.bash_aliases, instead of adding them here directly. # See /usr/share/doc/bash-doc/examples in the bash-doc package. #if [ -f ~/.bash_aliases ]; then # . ~/.bash_aliases #fi # enable color support of ls and also add handy aliases if [ "$TERM" != "dumb" ] && [ -x /usr/bin/dircolors ]; then eval "`dircolors -b`" alias ls='ls --color=auto' #alias dir='ls --color=auto --format=vertical' #alias vdir='ls --color=auto --format=long' #alias grep='grep --color=auto' #alias fgrep='fgrep --color=auto' #alias egrep='egrep --color=auto' fi # some more ls aliases #alias ll='ls -l' #alias la='ls -A' #alias l='ls -CF' # enable programmable completion features (you don't need to enable # this, if it's already enabled in /etc/bash.bashrc and /etc/profile # sources /etc/bash.bashrc). if [ -f /etc/bash_completion ]; then . /etc/bash_completion fi libnet-sftp-foreign-perl-1.86+dfsg.orig/t/5_join.t0000644000175000017500000000136112516370257021006 0ustar salvisalvi#!/usr/bin/perl use strict; use warnings; use Test::More; use Net::SFTP::Foreign; plan tests => 17; my $s = 'Net::SFTP::Foreign'; is($s->join('/', '.'), '/'); is($s->join('/.', '.'), '/'); is($s->join('/./', '.'), '/'); is($s->join('/./.', '.'), '/'); is($s->join('/.', '././.'), '/'); is($s->join('.', '/./'), '/'); is($s->join('./', '././'), '.'); is($s->join('./.', '././'), '.'); is($s->join('./.', '././.'), '.'); is($s->join('foo', '/./'), '/'); is($s->join('foo', '././'), 'foo'); is($s->join('./foo/.', '././'), 'foo'); is($s->join('./foo/./bar/.', '././'), 'foo/./bar'); is($s->join('//foo', 'bar'), '//foo/bar'); is($s->join('//foo', '/bar'), '/bar'); is($s->join('//foo', '//bar'), '//bar'); is($s->join('/foo', './bar/.'), '/foo/bar'); libnet-sftp-foreign-perl-1.86+dfsg.orig/Makefile.PL0000644000175000017500000000123312516370257021143 0ustar salvisalvi require 5.006; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Net::SFTP::Foreign', VERSION_FROM => 'lib/Net/SFTP/Foreign.pm', AUTHOR => 'Salvador Fandino ', ABSTRACT => 'Secure File Transfer Protocol client', PREREQ_PM => { 'Test::More' => 0, 'Scalar::Util' => 0, 'Time::HiRes' => 0 }, META_MERGE => { resources => { repository => 'http://github.com/salva/p5-Net-SFTP-Foreign', bugtracker => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Net-SFTP-Foreign' } } ); libnet-sftp-foreign-perl-1.86+dfsg.orig/LICENSE0000644000175000017500000005010112516370257020174 0ustar salvisalviTerms of Perl itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --------------------------------------------------------------------------- The General Public License (GPL) Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS --------------------------------------------------------------------------- The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End libnet-sftp-foreign-perl-1.86+dfsg.orig/META.json0000644000175000017500000000235312726520616020615 0ustar salvisalvi{ "abstract" : "Secure File Transfer Protocol client", "author" : [ "Salvador Fandino " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150005", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Net-SFTP-Foreign", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Scalar::Util" : "0", "Test::More" : "0", "Time::HiRes" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Net-SFTP-Foreign" }, "repository" : { "url" : "http://github.com/salva/p5-Net-SFTP-Foreign" } }, "version" : "1.86", "x_serialization_backend" : "JSON::PP version 2.27300" }