Malin/LP-MSH-Scanner
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
LP-MSH-Scanner/transfer.pl
Malin 03b3cccfe1 Upload files to ''
2016-09-22 09:47:08 +02:00

1975 lines
48 KiB
Prolog
Raw Blame History

#!/usr/bin/perl
use Time::HiRes qw(gettimeofday tv_interval);
$| = 1;
#my $log = substr($ENV{'SCRIPT_FILENAME'}, 0, rindex($ENV{'SCRIPT_FILENAME'}, '/public_html/')) . "/log.txt";
#open(STDERR, ">>$log");
use CGI;
use CGI::Carp qw(fatalsToBrowser);
use Net::FTP;
my $q = new CGI;
my ($ftp,$local_dir,$start_time);
my ($ftrans,$fsize,$strans,$ssize,$etrans,$esize) = 0;
my $server = url_unescape($q->param('server'));
my $username = url_unescape($q->param('username'));
my $password = url_unescape($q->param('password'));
my $remote_dir = url_unescape($q->param('remote_dir'));
my @ascii = qw(asa asp aspx c cpp cgi css hqx htaccess htm html inc ini js jsp log php php3 pl pm ps py rb shar shtm shtml sql tex txt url uu xml xsl);
my $local_root = substr($ENV{'SCRIPT_FILENAME'}, 0, rindex($ENV{'SCRIPT_FILENAME'}, '/public_html/'));
my $local_dir = url_unescape($q->param('local_dir'));
if ($local_dir !~ /\/$/) {
$local_dir = "$local_dir/";
}
print "Content-type: text/html\n\n";
print qq|
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html>
<head>
<title>Site Transfer Script</title>
<style type="text/css">
a:link {
text-decoration: none;
}
a:visited {
text-decoration: none;
}
a:hover {
text-decoration: none;
}
a:active {
text-decoration: none;
}
</style>
</head>
<body>
<form method="get" action="transfer.pl">
<label for="server">Server</label><input type="text" name="server" size=40 value="| . $server . qq{" />
<label for="username">Username</label><input type="text" name="username" value="} . $username . qq{" />
<label for="password">Password</label><input type="text" name="password" value="} . $password . qq{" />
<input type="submit" name="submit" value="Connect" />
<input type="submit" name="submit" value="Delete" />
};
if ($q->param('submit') eq 'Delete') {
my $del = unlink($ENV{'SCRIPT_FILENAME'});
print qq{
<table>
<tr>
<td>
};
if ($del) {
print '<p>Transfer script deleted</p>';
}
else {
print '<p>Transfer script was not deleted, please remove manually</p>';
}
print qq{
</td>
</tr>
};
}
elsif ($q->param('submit') eq 'Connect' || $q->param('submit') eq 'Transfer Selected') {
print qq{
<table border=0 cellpadding=0 cellspacing=0 width="100%">
<tr>
<td>
Connecting to <font color="maroon">$server</font> &rarr;
};
my $rv = $ftp = Net::FTP->new($server, Debug => 0, Hash => \*STDOUT, Passive => 1, Timeout => 60);
if ($rv) {
print "Success";
}
else {
print "Connection failed: $@";
exit;
}
print qq{
<tr>
<td>
Logging in using username: <font color="maroon">$username</font> and password: <font color="maroon">$password</font> &rarr;
};
$rv = $ftp->login($username, $password);
if ($rv) {
print "Success";
}
else {
print "Login failed: " . $ftp->message;
}
print qq{
</table>
<br />
<table border=1 cellpadding=0 cellspacing=0 width="100%">
<tr>
<td>
};
$remote_dir = $ftp->pwd if !$remote_dir;
if (defined($remote_dir) && $remote_dir !~ /\/$/) {
$remote_dir = "$remote_dir/";
}
my $rv = $ftp->cwd($remote_dir);
if ($rv){
print "Current remote directory: <font color=\"blue\">$remote_dir</font>";
}
else {
print "<font color=\"red\">Error accessing</font> <font color=\"blue\">$remote_dir</font> <font color=\"red\">" . $ftp->message . "</font><br />";
exit;
}
print "<td>Current local directory (files will be transferred here): <font color=\"blue\">$local_root$local_dir</font>";
my @dir = sort_list('display', $ftp->dir);
print qq{
<tr>
<td valign="top">
<table border=0 cellpadding=0 cellspacing=0 width="100%">
};
foreach my $value (@dir) {
if ($value->{'type'} eq '-') {
print qq{
<tr>
<td><input type="checkbox" name="transfer_file" value="} . url_escape($value->{'name'} . '=|=' . $value->{'size'}) . qq{" };
print "checked=\"checked\" " if grep {(split(/=|=/, url_unescape($_)))[0] eq $value->{'name'}} $q->param('transfer_file');
print qq{/>
<td>} . $value->{'type'} . $value->{'mode'} . qq{
<td>} . $value->{'nlink'} . qq{
<td>} . $value->{'uid'} . qq{
<td>} . $value->{'gid'} . qq{
<td>} . size_convert($value->{'size'}) . qq{
<td>} . $value->{'date'} . qq{
<td><font color="green">} . $value->{'name'} . qq{</font>};
}
elsif ($value->{'type'} eq 'd') {
if ($value->{'name'} eq '.') {
print qq{
<tr>
<td></td>
<td>} . $value->{'type'} . $value->{'mode'} . qq{
<td>} . $value->{'nlink'} . qq{
<td>} . $value->{'uid'} . qq{
<td>} . $value->{'gid'} . qq{
<td>} . size_convert($value->{'size'}) . qq{
<td>} . $value->{'date'} . qq{
<td><a href="transfer.pl?server=} . url_escape($server) . qq{&amp;username=} . url_escape($username) . qq{&amp;password=} . url_escape($password) . qq{&amp;remote_dir=} . url_escape($remote_dir) . qq{&amp;local_dir=} . url_escape($local_dir) . qq{&amp;submit=Connect">} . $value->{'name'} . qq{</a>};
#<td><a href="transfer.pl?server=} . url_escape($server) . qq{&amp;username=} . url_escape($username) . qq{&amp;password=} . url_escape($password) . qq{&amp;remote_dir=} . url_escape($remote_dir) . qq{&amp;local_dir=} . url_escape($local_dir) . qq{&amp;submit=Connect&transfer=1">Transfer</a>
}
elsif ($value->{'name'} eq '..') {
my $remote_dir = $remote_dir;
chop($remote_dir) if $remote_dir ne '/';
print qq{
<tr>
<td></td>
<td>} . $value->{'type'} . $value->{'mode'} . qq{
<td>} . $value->{'nlink'} . qq{
<td>} . $value->{'uid'} . qq{
<td>} . $value->{'gid'} . qq{
<td>} . size_convert($value->{'size'}) . qq{
<td>} . $value->{'date'} . qq{
<td><a href="transfer.pl?server=} . url_escape($server) . qq{&amp;username=} . url_escape($username) . qq{&amp;password=} . url_escape($password) . qq{&amp;remote_dir=} . url_escape(substr($remote_dir, 0, rindex($remote_dir, '/'))) . qq{&amp;local_dir=} . url_escape($local_dir) . qq{&amp;submit=Connect">} . $value->{'name'} . qq{</a>};
}
else {
print qq{
<tr>
<td><input type="checkbox" name="transfer_dir" value="} . $value->{'name'} . qq{" };
print "checked=\"checked\" " if grep {(split(/=|=/, url_unescape($_)))[0] eq $value->{'name'}} $q->param('transfer_dir');
print qq{/>
<td>} . $value->{'type'} . $value->{'mode'} . qq{
<td>} . $value->{'nlink'} . qq{
<td>} . $value->{'uid'} . qq{
<td>} . $value->{'gid'} . qq{
<td>} . size_convert($value->{'size'}) . qq{
<td>} . $value->{'date'} . qq{
<td><a href="transfer.pl?server=} . url_escape($server) . qq{&amp;username=} . url_escape($username) . qq{&amp;password=} . url_escape($password) . qq{&amp;remote_dir=} . url_escape($remote_dir . $value->{'name'}) . qq{&amp;local_dir=} . url_escape($local_dir) . qq{&amp;submit=Connect">} . $value->{'name'} . qq{</a>};
#<td><a href="transfer.pl?server=} . url_escape($server) . qq{&amp;username=} . url_escape($username) . qq{&amp;password=} . url_escape($password) . qq{&amp;remote_dir=} . url_escape($remote_dir . $value->{'name'}) . qq{&amp;local_dir=} . url_escape($local_dir) . qq{&amp;submit=Connect&transfer=1">Transfer</a>
}
}
elsif ($value->{'type'} eq 'l') {
print qq{
<tr>
<td><input type="checkbox" name="transfer_dir" value="} . $value->{'name'} . qq{" />
<td>} . $value->{'type'} . $value->{'mode'} . qq{
<td>} . $value->{'nlink'} . qq{
<td>} . $value->{'uid'} . qq{
<td>} . $value->{'gid'} . qq{
<td>} . size_convert($value->{'size'}) . qq{
<td>} . $value->{'date'} . qq{
<td><a href="transfer.pl?server=} . url_escape($server) . qq{&amp;username=} . url_escape($username) . qq{&amp;password=} . url_escape($password) . qq{&amp;remote_dir=} . url_escape($remote_dir . $value->{'name'}) . qq{&amp;local_dir=} . url_escape($local_dir) . qq{&amp;submit=Connect">} . $value->{'name'} . qq{</a> &rarr; } . $value->{'symlink'} . qq{};
#<td><a href="transfer.pl?server=} . url_escape($server) . qq{&amp;username=} . url_escape($username) . qq{&amp;password=} . url_escape($password) . qq{&amp;remote_dir=} . url_escape($remote_dir . $value->{'name'}) . qq{&amp;local_dir=} . url_escape($local_dir) . qq{&amp;submit=Connect&transfer=1">Transfer</a>
}
else {
next;
}
}
print "</table>";
my @dir = sort_list('display', `ls -la $local_root$local_dir`);
print qq{
<td valign="top">
<table border=0 cellpadding=0 cellspacing=0 width="100%">
};
foreach my $value (@dir) {
if ($value->{'type'} eq '-') {
print qq{
<tr>
<td>} . $value->{'type'} . $value->{'mode'} . qq{
<td>} . $value->{'nlink'} . qq{
<td>} . $value->{'uid'} . qq{
<td>} . $value->{'gid'} . qq{
<td>} . size_convert($value->{'size'}) . qq{
<td>} . $value->{'date'} . qq{
<td><font color="green">} . $value->{'name'} . qq{</font>};
}
elsif ($value->{'type'} eq 'd') {
if ($value->{'name'} eq '.') {
print qq{
<tr>
<td>} . $value->{'type'} . $value->{'mode'} . qq{
<td>} . $value->{'nlink'} . qq{
<td>} . $value->{'uid'} . qq{
<td>} . $value->{'gid'} . qq{
<td>} . size_convert($value->{'size'}) . qq{
<td>} . $value->{'date'} . qq{
<td><a href="transfer.pl?server=} . url_escape($server) . qq{&amp;username=} . url_escape($username) . qq{&amp;password=} . url_escape($password) . qq{&amp;remote_dir=} . url_escape($remote_dir) . qq{&amp;local_dir=} . url_escape($local_dir) . qq{&amp;submit=Connect">} . $value->{'name'} . qq{</a>};
}
elsif ($value->{'name'} eq '..') {
my $local_dir = $local_dir;
chop($local_dir) if $local_dir ne '/';
print qq{
<tr>
<td>} . $value->{'type'} . $value->{'mode'} . qq{
<td>} . $value->{'nlink'} . qq{
<td>} . $value->{'uid'} . qq{
<td>} . $value->{'gid'} . qq{
<td>} . size_convert($value->{'size'}) . qq{
<td>} . $value->{'date'} . qq{
<td><a href="transfer.pl?server=} . url_escape($server) . qq{&amp;username=} . url_escape($username) . qq{&amp;password=} . url_escape($password) . qq{&amp;remote_dir=} . url_escape($remote_dir) . qq{&amp;local_dir=} . url_escape(substr($local_dir, 0, rindex($local_dir, '/'))) . qq{&amp;submit=Connect">} . $value->{'name'} . qq{</a>};
}
else {
print qq{
<tr>
<td>} . $value->{'type'} . $value->{'mode'} . qq{
<td>} . $value->{'nlink'} . qq{
<td>} . $value->{'uid'} . qq{
<td>} . $value->{'gid'} . qq{
<td>} . size_convert($value->{'size'}) . qq{
<td>} . $value->{'date'} . qq{
<td><a href="transfer.pl?server=} . url_escape($server) . qq{&amp;username=} . url_escape($username) . qq{&amp;password=} . url_escape($password) . qq{&amp;remote_dir=} . url_escape($remote_dir) . qq{&amp;local_dir=} . url_escape($local_dir . $value->{'name'}) . qq{&amp;submit=Connect">} . $value->{'name'} . qq{</a>};
}
}
elsif ($value->{'type'} eq 'l') {
print qq{
<tr>
<td>} . $value->{'type'} . $value->{'mode'} . qq{
<td>} . $value->{'nlink'} . qq{
<td>} . $value->{'uid'} . qq{
<td>} . $value->{'gid'} . qq{
<td>} . size_convert($value->{'size'}) . qq{
<td>} . $value->{'date'} . qq{
<td><a href="transfer.pl?server=} . url_escape($server) . qq{&amp;username=} . url_escape($username) . qq{&amp;password=} . url_escape($password) . qq{&amp;remote_dir=} . url_escape($remote_dir) . qq{&amp;local_dir=} . url_escape($local_dir . $value->{'name'}) . qq{&amp;submit=Connect">} . $value->{'name'} . qq{</a> &rarr; } . $value->{'symlink'};
}
else {
next;
}
}
print "</table>";
if ($q->param('submit') eq 'Transfer Selected') {
print "</table>";
print "<input type=\"submit\" name=\"submit\" value=\"Transfer Selected\" />";
print "<input type=\"hidden\" name=\"remote_dir\" value=\"" . url_escape($remote_dir) . "\" />";
print "<input type=\"hidden\" name=\"local_dir\" value=\"" . url_escape($local_dir) . "\" />";
print "</form>";
print "<table border=1 cellpadding=0 cellspacing=0 width=\"100%\">";
print " <tr>";
print " <td>";
print " RemoteFilename";
print " </td>";
print " <td>";
print " Remote File Type";
print " </td>";
print " <td>";
print " Remote File Size";
print " </td>";
print " <td>";
print " Download Progress";
print " </td>";
print " <td>";
print " Local Permission";
print " </td>";
print " <td>";
print " Local File Size";
print " </td>";
print " </tr>";
$start_time = [gettimeofday];
my @files_to_transfer = $q->param('transfer_file');
my @dirs_to_transfer = $q->param('transfer_dir');
foreach my $target_file (@files_to_transfer) {
$target_file = url_unescape($target_file);
my ($target_name, $target_size) = split(/=\|=/, $target_file);
transfer_file($remote_dir, $local_root . $local_dir, $target_name, $target_size);
}
foreach my $target_dir (@dirs_to_transfer) {
transfer_dir($remote_dir, $local_root . $local_dir, $target_dir);
}
print "</table><br />";
print "Transfer completed.<br />";
print "Susscessfully transferred $ftrans files totalling " . size_convert($fsize) . ".<br />";
print "Failed transferring $etrans files totalling " . size_convert($esize) . ".<br />";
print "Skipped transferring $strans files totalling " . size_convert($ssize) . ".<br />";
print "Transfer request covered " . ($ftrans + $strans + $etrans) . " files totalling " . size_convert($fsize + $ssize + $esize) . ".<br />";
print "Transfer request took " . time_convert(tv_interval($start_time, [gettimeofday])) . " to complete.";
}
else {
print "</table>";
print "<input type=\"submit\" name=\"submit\" value=\"Transfer Selected\" />";
print "<input type=\"hidden\" name=\"remote_dir\" value=\"" . url_escape($remote_dir) . "\" />";
print "<input type=\"hidden\" name=\"local_dir\" value=\"" . url_escape($local_dir) . "\" />";
print "</form>";
}
$ftp->quit;
}
else {
print "</form>";
}
print qq{
</body>
</html>
};
#close(STDERR);
sub transfer_file {
my $remote_dir = shift;
my $local_dir = shift;
my $target_file = shift;
my $target_size = shift;
my $rv = $ftp->cwd($remote_dir);
if (! $rv) {
if ($ftp->message =~ /connection closed/i || $ftp->message =~ /timeout/i) {
$ftp = Net::FTP->new($server, Debug => 0, Hash => \*STDOUT, Passive => 1, Timeout => 60);
$ftp->login($username, $password);
$ftp->cwd($remote_dir);
}
else {
print "<font color=\"red\">Error accessing</font> <font color=\"blue\">$remote_dir</font> <font color=\"red\">" . $ftp->message . "</font><br />";
return;
}
}
if ($local_dir !~ /\/$/) {
$local_dir = "$local_dir/";
}
if ($remote_dir !~ /\/$/) {
$remote_dir = "$remote_dir/";
}
my $rv;
my $type = 'binary';
foreach my $asc (@ascii) {
if ($target_file =~ /\.$asc$/) {
$type = 'ascii';
last;
}
}
print " <tr>";
print " <td>";
print " <font color=\"green\">$target_file</font>";
print " </td>";
print " <td>";
print " $type file";
print " </td>";
print " <td>";
print " " . size_convert($target_size);
print " </td>";
if (-e $local_dir . $target_file && $target_file ne '.htaccess') {
$strans++;
$ssize += $target_size;
print " <td>";
print " Exists, skipping";
print " </td>";
print " <td>";
print " <br />";
print " </td>";
print " <td>";
print " <br />";
print " </td>";
print " </tr>";
}
else {
if ($type eq 'ascii') {
$ftp->ascii;
}
else {
$ftp->binary;
}
print " <td>";
my $bytes_out = tell(*STDOUT);
my $start_transfer = [gettimeofday];
$ftp->hash(\*STDOUT, 2048);
my $rv = $ftp->get($target_file, $local_dir . $target_file);
if ($rv) {
if ((tell(*STDOUT) - $bytes_out) == 1) {
print "#";
}
my $transfer_time = tv_interval($start_transfer, [gettimeofday]) || 1;
# print " <br />Complete: $value->{'size'} bytes in " . sprintf("%.2f", $transfer_time) . " seconds<br />(". sprintf("%.2f", $value->{'size'} / $transfer_time) . " bytes per second)";
print " </td>";
$ftrans++;
$fsize += $target_size;
my $rv;
if ($target_file =~ /\.pl$/ || $target_file =~ /\.cgi$/) {
print " <td>";
$rv = chmod(0755, "$local_dir$target_file");
if ($rv) {
print "755";
}
else {
print "<br />";
}
print " </td>";
}
else {
print " <td>";
$rv = chmod(0644, "$local_dir$target_file");
if ($rv) {
print "644";
}
else {
print "<br />";
}
print " </td>";
}
print " <td>";
print " " . size_convert((stat($local_dir . $target_file))[7]);
print " </td>";
print " </tr>";
}
else {
if (!$ftp->message || $ftp->message =~ /connection closed/i || $ftp->message =~ /timeout/i) {
transfer_file($remote_dir, $local_dir, $target_file, $target_size);
}
else {
$etrans++;
$esize += $target_size;
print " <font color=\"red\">" . $ftp->message . "</font>";
print " </td>";
print " <td>";
print " <br />";
print " </td>";
print " <td>";
print " <br />";
print " </td>";
print " </tr>";
}
}
}
}
sub transfer_dir {
my $remote_dir = shift;
my $local_dir = shift;
my $target_dir = shift;
return if $target_dir eq '.' || $target_dir eq '..';
if ($local_dir !~ /\/$/) {
$local_dir = "$local_dir/";
}
if ($remote_dir !~ /\/$/) {
$remote_dir = "$remote_dir/";
}
my $rv = $ftp->cwd($remote_dir . $target_dir);
if (! $rv) {
if ($ftp->message =~ /connection closed/i || $ftp->message =~ /timeout/i) {
$ftp = Net::FTP->new($server, Debug => 0, Hash => \*STDOUT, Passive => 1, Timeout => 60);
$ftp->login($username, $password);
$ftp->cwd($remote_dir . $target_dir);
}
else {
print "<font color=\"red\">Error accessing</font> <font color=\"blue\">$remote_dir$target_dir</font> <font color=\"red\">" . $ftp->message . "</font><br />";
return;
}
}
print " <tr>";
print " <td colspan=\"6\">";
print " <br />";
print " </td>";
print " </tr>";
print " <tr>";
print " <td>";
print " <font color=\"blue\">$target_dir</font>";
print " </td>";
print " <td>";
print " directory";
print " </td>";
print " <td>";
print " <br />";
print " </td>";
if (-e $local_dir . $target_dir) {
print " <td>";
print " Exists, skipping";
print " </td>";
print " <td>";
print " <br />";
print " </td>";
}
else {
my $rv = mkdir($local_dir . $target_dir, 0755);
if ($rv) {
print " <td>";
print " Success";
print " </td>";
print " <td>";
print " 755";
print " </td>";
}
else {
print " <td>";
print " Failed: $!";
print " </td>";
print " <td>";
print " <br />";
print " </td>";
}
}
print " <td>";
print " <br />";
print " </td>";
print " </tr>";
my @dir = sort_list('transfer', $ftp->dir);
while (@dir) {
$value = shift(@dir);
if ($value->{'type'} eq '-') {
transfer_file($remote_dir . $target_dir, $local_dir . $target_dir, $value->{'name'}, $value->{'size'});
}
elsif ($value->{'type'} eq 'd' && $value->{'name'} !~ /^\.\.?/) {
transfer_dir($remote_dir . $target_dir, $local_dir . $target_dir, $value->{'name'});
}
elsif ($value->{'type'} eq 'l' && $value->{'name'} !~ /^\.\.?/) {
transfer_dir($remote_dir . $target_dir, $local_dir . $target_dir, $value->{'name'});
}
}
}
sub size_convert {
my $size = shift;
if ($size > 1073741824) {
$size = sprintf("%.2f", $size / 1073741824) . " GB";
}
elsif ($size > 1048576) {
$size = sprintf("%.2f", $size / 1048576) . " MB";
}
elsif ($size > 1024) {
$size = sprintf("%.2f", $size / 1024) . " KB";
}
else {
if ($size) {
$size .= " bytes";
}
else {
$size = "0 bytes";
}
}
return $size
}
sub sort_list {
my $format = shift;
my @list = @_;
my (@dir, @sym, @file, @unh, @sort);
my ($current, $parent) = 0;
foreach my $value (@list) {
if ($value =~ /^(\S{1})(\S+)\s+(\d+)\s+(\S+)\s+(\S+)\s+(\d+)\s+(\w+\s+\w+\s+\S+)\s+(.+?)\s*(?:->\s*(.+))?$/) { # Linux servers
if ($1 eq '-') {
push (@file, {'type' => $1, 'mode' => $2, 'nlink' => $3, 'uid' => $4, 'gid' => $5, 'size' => $6, 'date' => $7, 'name' => $8, 'symlink' => $9});
}
elsif ($1 eq 'd') {
push (@dir, {'type' => $1, 'mode' => $2, 'nlink' => $3, 'uid' => $4, 'gid' => $5, 'size' => $6, 'date' => $7, 'name' => $8, 'symlink' => $9});
if ($8 eq '.') {
$current = 1;
}
if ($8 eq '..') {
$parent = 1;
}
}
elsif ($1 eq 'l') {
push (@sym, {'type' => $1, 'mode' => $2, 'nlink' => $3, 'uid' => $4, 'gid' => $5, 'size' => $6, 'date' => $7, 'name' => $8, 'symlink' => $9});
}
}
elsif ($value =~ /^(\d{2}-\d{2}-\d{2})\s+(\S+)\s+(\<DIR\>)?\s+?(\d+)?\s+?(\S+)$/) { # Microsoft Servers
if ($3 eq '<DIR>') {
push (@dir, {'type' => 'd', 'mode' => '', 'nlink' => '', 'uid' => '', 'gid' => '', 'size' => $4, 'date' => "$1 $2", 'name' => $5, 'symlink' => ''});
}
else {
push (@file, {'type' => '-', 'mode' => '', 'nlink' => '', 'uid' => '', 'gid' => '', 'size' => $4, 'date' => "$1 $2", 'name' => $5, 'symlink' => ''});
}
}
else {
push (@unh, $value);
}
}
if ((@file || @dir || @sym) && !$current) {
push(@dir, {'type' => 'd', 'mode' => '?', 'nlink' => '?', 'uid' => '?', 'gid' => '?', 'size' => '?', 'date' => '?', 'name' => '.', 'symlink' => ''});
}
if ((@file || @dir || @sym) && !$parent) {
push(@dir, {'type' => 'd', 'mode' => '?', 'nlink' => '?', 'uid' => '?', 'gid' => '?', 'size' => '?', 'date' => '?', 'name' => '..', 'symlink' => ''});
}
@file = sort {$a->{'name'} cmp $b->{'name'}} @file;
@dir = sort {$a->{'name'} cmp $b->{'name'}} @dir;
@sym = sort {$a->{'name'} cmp $b->{'name'}} @sym;
if ($format eq 'display') {
@sort = (@dir, @sym, @file);
}
elsif ($format eq 'transfer') {
@sort = (@file, @dir, @sym);
}
return @sort, @unh;
}
sub time_convert {
my $time = shift;
my ($hour, $minute, $second);
my @ret;
if ($time >= 3600) {
if (int($time / 3600) == 1) {
$hour = int($time / 3600) . ' hour';
}
elsif (int($time / 3600)) {
$hour = int($time / 3600) . ' hours';
}
if ($hour) {
push (@ret, $hour);
}
$time -= $hour * 3600;
}
if ($time >= 60) {
if (int($time / 60) == 1) {
$minute = int($time / 60) . ' minute';
}
elsif (int($time / 60)) {
$minute = int($time / 60) . ' minutes';
}
if ($minute) {
push (@ret, $minute);
}
$time -= $minute * 60;
}
if ($time < 60) {
$time = int($time);
if ($time == 1) {
$second = $time . ' second';
}
elsif ($time) {
$second = $time . ' seconds';
}
else {
$second = '0 seconds';
}
if ($second) {
push (@ret, $second);
}
}
return join(', ', @ret);
}
sub url_escape {
my $url = shift;
$url =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/eg;
return $url;
}
sub url_unescape {
my $url = shift;
$url =~ s/\%([a-fA-F0-9]{2})/pack("C", hex($1))/eg;
return $url;
}
# Net::FTP.pm
#
# Copyright (c) 1995-2004 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Documentation (at end) improved 1996 by Nathan Torkington <gnat@frii.com>.
package Net::FTP;
require 5.001;
use strict;
use vars qw(@ISA $VERSION);
use Carp;
use Socket 1.3;
use IO::Socket;
use Time::Local;
use Net::Cmd;
use Net::Config;
use Fcntl qw(O_WRONLY O_RDONLY O_APPEND O_CREAT O_TRUNC);
# use AutoLoader qw(AUTOLOAD);
$VERSION = "2.75";
@ISA = qw(Exporter Net::Cmd IO::Socket::INET);
# Someday I will "use constant", when I am not bothered to much about
# compatability with older releases of perl
use vars qw($TELNET_IAC $TELNET_IP $TELNET_DM);
($TELNET_IAC,$TELNET_IP,$TELNET_DM) = (255,244,242);
# Name is too long for AutoLoad, it clashes with pasv_xfer
sub pasv_xfer_unique {
my($sftp,$sfile,$dftp,$dfile) = @_;
$sftp->pasv_xfer($sfile,$dftp,$dfile,1);
}
BEGIN {
# make a constant so code is fast'ish
my $is_os390 = $^O eq 'os390';
*trEBCDIC = sub () { $is_os390 }
}
1;
# Having problems with AutoLoader
#__END__
sub new
{
my $pkg = shift;
my ($peer,%arg);
if (@_ % 2) {
$peer = shift ;
%arg = @_;
} else {
%arg = @_;
$peer=delete $arg{Host};
}
my $host = $peer;
my $fire = undef;
my $fire_type = undef;
if(exists($arg{Firewall}) || Net::Config->requires_firewall($peer))
{
$fire = $arg{Firewall}
|| $ENV{FTP_FIREWALL}
|| $NetConfig{ftp_firewall}
|| undef;
if(defined $fire)
{
$peer = $fire;
delete $arg{Port};
$fire_type = $arg{FirewallType}
|| $ENV{FTP_FIREWALL_TYPE}
|| $NetConfig{firewall_type}
|| undef;
}
}
my $ftp = $pkg->SUPER::new(PeerAddr => $peer,
PeerPort => $arg{Port} || 'ftp(21)',
LocalAddr => $arg{'LocalAddr'},
Proto => 'tcp',
Timeout => defined $arg{Timeout}
? $arg{Timeout}
: 120
) or return undef;
${*$ftp}{'net_ftp_host'} = $host; # Remote hostname
${*$ftp}{'net_ftp_type'} = 'A'; # ASCII/binary/etc mode
${*$ftp}{'net_ftp_blksize'} = abs($arg{'BlockSize'} || 10240);
${*$ftp}{'net_ftp_localaddr'} = $arg{'LocalAddr'};
${*$ftp}{'net_ftp_firewall'} = $fire
if(defined $fire);
${*$ftp}{'net_ftp_firewall_type'} = $fire_type
if(defined $fire_type);
${*$ftp}{'net_ftp_passive'} = int
exists $arg{Passive}
? $arg{Passive}
: exists $ENV{FTP_PASSIVE}
? $ENV{FTP_PASSIVE}
: defined $fire
? $NetConfig{ftp_ext_passive}
: $NetConfig{ftp_int_passive}; # Whew! :-)
$ftp->hash(exists $arg{Hash} ? $arg{Hash} : 0, 10240);
$ftp->autoflush(1);
$ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef);
unless ($ftp->response() == CMD_OK)
{
$ftp->close();
$@ = $ftp->message;
undef $ftp;
}
$ftp;
}
##
## User interface methods
##
sub host {
my $me = shift;
${*$me}{'net_ftp_host'};
}
sub hash {
my $ftp = shift; # self
my($h,$b) = @_;
unless($h) {
delete ${*$ftp}{'net_ftp_hash'};
return [\*STDERR,0];
}
($h,$b) = (ref($h)? $h : \*STDOUT, $b || 10240);
select((select($h), $|=1)[0]);
$b = 512 if $b < 512;
${*$ftp}{'net_ftp_hash'} = [$h, $b];
}
sub quit
{
my $ftp = shift;
$ftp->_QUIT;
$ftp->close;
}
sub DESTROY {}
sub ascii { shift->type('A',@_); }
sub binary { shift->type('I',@_); }
sub ebcdic
{
carp "TYPE E is unsupported, shall default to I";
shift->type('E',@_);
}
sub byte
{
carp "TYPE L is unsupported, shall default to I";
shift->type('L',@_);
}
# Allow the user to send a command directly, BE CAREFUL !!
sub quot
{
my $ftp = shift;
my $cmd = shift;
$ftp->command( uc $cmd, @_);
$ftp->response();
}
sub site
{
my $ftp = shift;
$ftp->command("SITE", @_);
$ftp->response();
}
sub mdtm
{
my $ftp = shift;
my $file = shift;
# Server Y2K bug workaround
#
# sigh; some idiotic FTP servers use ("19%d",tm.tm_year) instead of
# ("%d",tm.tm_year+1900). This results in an extra digit in the
# string returned. To account for this we allow an optional extra
# digit in the year. Then if the first two digits are 19 we use the
# remainder, otherwise we subtract 1900 from the whole year.
$ftp->_MDTM($file) && $ftp->message =~ /((\d\d)(\d\d\d?))(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
? timegm($8,$7,$6,$5,$4-1,$2 eq '19' ? $3 : ($1-1900))
: undef;
}
sub size {
my $ftp = shift;
my $file = shift;
my $io;
if($ftp->supported("SIZE")) {
return $ftp->_SIZE($file)
? ($ftp->message =~ /(\d+)\s*(bytes?\s*)?$/)[0]
: undef;
}
elsif($ftp->supported("STAT")) {
my @msg;
return undef
unless $ftp->_STAT($file) && (@msg = $ftp->message) == 3;
my $line;
foreach $line (@msg) {
return (split(/\s+/,$line))[4]
if $line =~ /^[-rwxSsTt]{10}/
}
}
else {
my @files = $ftp->dir($file);
if(@files) {
return (split(/\s+/,$1))[4]
if $files[0] =~ /^([-rwxSsTt]{10}.*)$/;
}
}
undef;
}
sub login {
my($ftp,$user,$pass,$acct) = @_;
my($ok,$ruser,$fwtype);
unless (defined $user) {
require Net::Netrc;
my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'});
($user,$pass,$acct) = $rc->lpa()
if ($rc);
}
$user ||= "anonymous";
$ruser = $user;
$fwtype = ${*$ftp}{'net_ftp_firewall_type'}
|| $NetConfig{'ftp_firewall_type'}
|| 0;
if ($fwtype && defined ${*$ftp}{'net_ftp_firewall'}) {
if ($fwtype == 1 || $fwtype == 7) {
$user .= '@' . ${*$ftp}{'net_ftp_host'};
}
else {
require Net::Netrc;
my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
my($fwuser,$fwpass,$fwacct) = $rc ? $rc->lpa() : ();
if ($fwtype == 5) {
$user = join('@',$user,$fwuser,${*$ftp}{'net_ftp_host'});
$pass = $pass . '@' . $fwpass;
}
else {
if ($fwtype == 2) {
$user .= '@' . ${*$ftp}{'net_ftp_host'};
}
elsif ($fwtype == 6) {
$fwuser .= '@' . ${*$ftp}{'net_ftp_host'};
}
$ok = $ftp->_USER($fwuser);
return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
$ok = $ftp->_PASS($fwpass || "");
return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
$ok = $ftp->_ACCT($fwacct)
if defined($fwacct);
if ($fwtype == 3) {
$ok = $ftp->command("SITE",${*$ftp}{'net_ftp_host'})->response;
}
elsif ($fwtype == 4) {
$ok = $ftp->command("OPEN",${*$ftp}{'net_ftp_host'})->response;
}
return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
}
}
}
$ok = $ftp->_USER($user);
# Some dumb firewalls don't prefix the connection messages
$ok = $ftp->response()
if ($ok == CMD_OK && $ftp->code == 220 && $user =~ /\@/);
if ($ok == CMD_MORE) {
unless(defined $pass) {
require Net::Netrc;
my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}, $ruser);
($ruser,$pass,$acct) = $rc->lpa()
if ($rc);
$pass = '-anonymous@'
if (!defined $pass && (!defined($ruser) || $ruser =~ /^anonymous/o));
}
$ok = $ftp->_PASS($pass || "");
}
$ok = $ftp->_ACCT($acct)
if (defined($acct) && ($ok == CMD_MORE || $ok == CMD_OK));
if ($fwtype == 7 && $ok == CMD_OK && defined ${*$ftp}{'net_ftp_firewall'}) {
my($f,$auth,$resp) = _auth_id($ftp);
$ftp->authorize($auth,$resp) if defined($resp);
}
$ok == CMD_OK;
}
sub account
{
@_ == 2 or croak 'usage: $ftp->account( ACCT )';
my $ftp = shift;
my $acct = shift;
$ftp->_ACCT($acct) == CMD_OK;
}
sub _auth_id {
my($ftp,$auth,$resp) = @_;
unless(defined $resp)
{
require Net::Netrc;
$auth ||= eval { (getpwuid($>))[0] } || $ENV{NAME};
my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth)
|| Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
($auth,$resp) = $rc->lpa()
if ($rc);
}
($ftp,$auth,$resp);
}
sub authorize
{
@_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])';
my($ftp,$auth,$resp) = &_auth_id;
my $ok = $ftp->_AUTH($auth || "");
$ok = $ftp->_RESP($resp || "")
if ($ok == CMD_MORE);
$ok == CMD_OK;
}
sub rename
{
@_ == 3 or croak 'usage: $ftp->rename(FROM, TO)';
my($ftp,$from,$to) = @_;
$ftp->_RNFR($from)
&& $ftp->_RNTO($to);
}
sub type
{
my $ftp = shift;
my $type = shift;
my $oldval = ${*$ftp}{'net_ftp_type'};
return $oldval
unless (defined $type);
return undef
unless ($ftp->_TYPE($type,@_));
${*$ftp}{'net_ftp_type'} = join(" ",$type,@_);
$oldval;
}
sub alloc
{
my $ftp = shift;
my $size = shift;
my $oldval = ${*$ftp}{'net_ftp_allo'};
return $oldval
unless (defined $size);
return undef
unless ($ftp->_ALLO($size,@_));
${*$ftp}{'net_ftp_allo'} = join(" ",$size,@_);
$oldval;
}
sub abort
{
my $ftp = shift;
send($ftp,pack("CCC", $TELNET_IAC, $TELNET_IP, $TELNET_IAC),MSG_OOB);
$ftp->command(pack("C",$TELNET_DM) . "ABOR");
${*$ftp}{'net_ftp_dataconn'}->close()
if defined ${*$ftp}{'net_ftp_dataconn'};
$ftp->response();
$ftp->status == CMD_OK;
}
sub get
{
my($ftp,$remote,$local,$where) = @_;
my($loc,$len,$buf,$resp,$data);
local *FD;
my $localfd = ref($local) || ref(\$local) eq "GLOB";
($local = $remote) =~ s#^.*/##
unless(defined $local);
croak("Bad remote filename '$remote'\n")
if $remote =~ /[\r\n]/s;
${*$ftp}{'net_ftp_rest'} = $where if defined $where;
my $rest = ${*$ftp}{'net_ftp_rest'};
delete ${*$ftp}{'net_ftp_port'};
delete ${*$ftp}{'net_ftp_pasv'};
$data = $ftp->retr($remote) or
return undef;
if($localfd)
{
$loc = $local;
}
else
{
$loc = \*FD;
unless(sysopen($loc, $local, O_CREAT | O_WRONLY | ($rest ? O_APPEND : O_TRUNC)))
{
carp "Cannot open Local file $local: $!\n";
$data->abort;
return undef;
}
}
if($ftp->type eq 'I' && !binmode($loc))
{
carp "Cannot binmode Local file $local: $!\n";
$data->abort;
close($loc) unless $localfd;
return undef;
}
$buf = '';
my($count,$hashh,$hashb,$ref) = (0);
($hashh,$hashb) = @$ref
if($ref = ${*$ftp}{'net_ftp_hash'});
my $blksize = ${*$ftp}{'net_ftp_blksize'};
local $\; # Just in case
while(1)
{
last unless $len = $data->read($buf,$blksize);
if (trEBCDIC && $ftp->type ne 'I')
{
$buf = $ftp->toebcdic($buf);
$len = length($buf);
}
if($hashh) {
$count += $len;
print $hashh "# " x (int($count / $hashb));
$count %= $hashb;
}
unless(print $loc $buf)
{
carp "Cannot write to Local file $local: $!\n";
$data->abort;
close($loc)
unless $localfd;
return undef;
}
}
print $hashh "\n" if $hashh;
unless ($localfd)
{
unless (close($loc))
{
carp "Cannot close file $local (perhaps disk space) $!\n";
return undef;
}
}
unless ($data->close()) # implied $ftp->response
{
carp "Unable to close datastream";
return undef;
}
return $local;
}
sub cwd
{
@_ == 1 || @_ == 2 or croak 'usage: $ftp->cwd( [ DIR ] )';
my($ftp,$dir) = @_;
$dir = "/" unless defined($dir) && $dir =~ /\S/;
$dir eq ".."
? $ftp->_CDUP()
: $ftp->_CWD($dir);
}
sub cdup
{
@_ == 1 or croak 'usage: $ftp->cdup()';
$_[0]->_CDUP;
}
sub pwd
{
@_ == 1 || croak 'usage: $ftp->pwd()';
my $ftp = shift;
$ftp->_PWD();
$ftp->_extract_path;
}
# rmdir( $ftp, $dir, [ $recurse ] )
#
# Removes $dir on remote host via FTP.
# $ftp is handle for remote host
#
# If $recurse is TRUE, the directory and deleted recursively.
# This means all of its contents and subdirectories.
#
# Initial version contributed by Dinkum Software
#
sub rmdir
{
@_ == 2 || @_ == 3 or croak('usage: $ftp->rmdir( DIR [, RECURSE ] )');
# Pick off the args
my ($ftp, $dir, $recurse) = @_ ;
my $ok;
return $ok
if $ok = $ftp->_RMD( $dir ) or !$recurse;
# Try to delete the contents
# Get a list of all the files in the directory
my @filelist = grep { !/^\.{1,2}$/ } $ftp->ls($dir);
return undef
unless @filelist; # failed, it is probably not a directory
# Go thru and delete each file or the directory
my $file;
foreach $file (map { m,/, ? $_ : "$dir/$_" } @filelist)
{
next # successfully deleted the file
if $ftp->delete($file);
# Failed to delete it, assume its a directory
# Recurse and ignore errors, the final rmdir() will
# fail on any errors here
return $ok
unless $ok = $ftp->rmdir($file, 1) ;
}
# Directory should be empty
# Try to remove the directory again
# Pass results directly to caller
# If any of the prior deletes failed, this
# rmdir() will fail because directory is not empty
return $ftp->_RMD($dir) ;
}
sub restart
{
@_ == 2 || croak 'usage: $ftp->restart( BYTE_OFFSET )';
my($ftp,$where) = @_;
${*$ftp}{'net_ftp_rest'} = $where;
return undef;
}
sub mkdir
{
@_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )';
my($ftp,$dir,$recurse) = @_;
$ftp->_MKD($dir) || $recurse or
return undef;
my $path = $dir;
unless($ftp->ok)
{
my @path = split(m#(?=/+)#, $dir);
$path = "";
while(@path)
{
$path .= shift @path;
$ftp->_MKD($path);
$path = $ftp->_extract_path($path);
}
# If the creation of the last element was not successful, see if we
# can cd to it, if so then return path
unless($ftp->ok)
{
my($status,$message) = ($ftp->status,$ftp->message);
my $pwd = $ftp->pwd;
if($pwd && $ftp->cwd($dir))
{
$path = $dir;
$ftp->cwd($pwd);
}
else
{
undef $path;
}
$ftp->set_status($status,$message);
}
}
$path;
}
sub delete
{
@_ == 2 || croak 'usage: $ftp->delete( FILENAME )';
$_[0]->_DELE($_[1]);
}
sub put { shift->_store_cmd("stor",@_) }
sub put_unique { shift->_store_cmd("stou",@_) }
sub append { shift->_store_cmd("appe",@_) }
sub nlst { shift->_data_cmd("NLST",@_) }
sub list { shift->_data_cmd("LIST",@_) }
sub retr { shift->_data_cmd("RETR",@_) }
sub stor { shift->_data_cmd("STOR",@_) }
sub stou { shift->_data_cmd("STOU",@_) }
sub appe { shift->_data_cmd("APPE",@_) }
sub _store_cmd
{
my($ftp,$cmd,$local,$remote) = @_;
my($loc,$sock,$len,$buf);
local *FD;
my $localfd = ref($local) || ref(\$local) eq "GLOB";
unless(defined $remote)
{
croak 'Must specify remote filename with stream input'
if $localfd;
require File::Basename;
$remote = File::Basename::basename($local);
}
if( defined ${*$ftp}{'net_ftp_allo'} )
{
delete ${*$ftp}{'net_ftp_allo'};
} else
{
# if the user hasn't already invoked the alloc method since the last
# _store_cmd call, figure out if the local file is a regular file(not
# a pipe, or device) and if so get the file size from stat, and send
# an ALLO command before sending the STOR, STOU, or APPE command.
my $size = do { local $^W; -f $local && -s _ }; # no ALLO if sending data from a pipe
$ftp->_ALLO($size) if $size;
}
croak("Bad remote filename '$remote'\n")
if $remote =~ /[\r\n]/s;
if($localfd)
{
$loc = $local;
}
else
{
$loc = \*FD;
unless(sysopen($loc, $local, O_RDONLY))
{
carp "Cannot open Local file $local: $!\n";
return undef;
}
}
if($ftp->type eq 'I' && !binmode($loc))
{
carp "Cannot binmode Local file $local: $!\n";
return undef;
}
delete ${*$ftp}{'net_ftp_port'};
delete ${*$ftp}{'net_ftp_pasv'};
$sock = $ftp->_data_cmd($cmd, $remote) or
return undef;
$remote = ($ftp->message =~ /FILE:\s*(.*)/)[0]
if 'STOU' eq uc $cmd;
my $blksize = ${*$ftp}{'net_ftp_blksize'};
my($count,$hashh,$hashb,$ref) = (0);
($hashh,$hashb) = @$ref
if($ref = ${*$ftp}{'net_ftp_hash'});
while(1)
{
last unless $len = read($loc,$buf="",$blksize);
if (trEBCDIC && $ftp->type ne 'I')
{
$buf = $ftp->toascii($buf);
$len = length($buf);
}
if($hashh) {
$count += $len;
print $hashh "# " x (int($count / $hashb));
$count %= $hashb;
}
my $wlen;
unless(defined($wlen = $sock->write($buf,$len)) && $wlen == $len)
{
$sock->abort;
close($loc)
unless $localfd;
print $hashh "\n" if $hashh;
return undef;
}
}
print $hashh "\n" if $hashh;
close($loc)
unless $localfd;
$sock->close() or
return undef;
if ('STOU' eq uc $cmd and $ftp->message =~ m/unique\s+file\s*name\s*:\s*(.*)\)|"(.*)"/)
{
require File::Basename;
$remote = File::Basename::basename($+)
}
return $remote;
}
sub port
{
@_ == 1 || @_ == 2 or croak 'usage: $ftp->port([PORT])';
my($ftp,$port) = @_;
my $ok;
delete ${*$ftp}{'net_ftp_intern_port'};
unless(defined $port)
{
# create a Listen socket at same address as the command socket
${*$ftp}{'net_ftp_listen'} ||= IO::Socket::INET->new(Listen => 5,
Proto => 'tcp',
Timeout => $ftp->timeout,
LocalAddr => $ftp->sockhost,
);
my $listen = ${*$ftp}{'net_ftp_listen'};
my($myport, @myaddr) = ($listen->sockport, split(/\./,$listen->sockhost));
$port = join(',', @myaddr, $myport >> 8, $myport & 0xff);
${*$ftp}{'net_ftp_intern_port'} = 1;
}
$ok = $ftp->_PORT($port);
${*$ftp}{'net_ftp_port'} = $port;
$ok;
}
sub ls { shift->_list_cmd("NLST",@_); }
sub dir { shift->_list_cmd("LIST",@_); }
sub pasv
{
@_ == 1 or croak 'usage: $ftp->pasv()';
my $ftp = shift;
delete ${*$ftp}{'net_ftp_intern_port'};
$ftp->_PASV && $ftp->message =~ /(\d+(,\d+)+)/
? ${*$ftp}{'net_ftp_pasv'} = $1
: undef;
}
sub unique_name
{
my $ftp = shift;
${*$ftp}{'net_ftp_unique'} || undef;
}
sub supported {
@_ == 2 or croak 'usage: $ftp->supported( CMD )';
my $ftp = shift;
my $cmd = uc shift;
my $hash = ${*$ftp}{'net_ftp_supported'} ||= {};
return $hash->{$cmd}
if exists $hash->{$cmd};
return $hash->{$cmd} = 0
unless $ftp->_HELP($cmd);
my $text = $ftp->message;
if($text =~ /following\s+commands/i) {
$text =~ s/^.*\n//;
while($text =~ /(\*?)(\w+)(\*?)/sg) {
$hash->{"\U$2"} = !length("$1$3");
}
}
else {
$hash->{$cmd} = $text !~ /unimplemented/i;
}
$hash->{$cmd} ||= 0;
}
##
## Deprecated methods
##
sub lsl
{
carp "Use of Net::FTP::lsl deprecated, use 'dir'"
if $^W;
goto &dir;
}
sub authorise
{
carp "Use of Net::FTP::authorise deprecated, use 'authorize'"
if $^W;
goto &authorize;
}
##
## Private methods
##
sub _extract_path
{
my($ftp, $path) = @_;
# This tries to work both with and without the quote doubling
# convention (RFC 959 requires it, but the first 3 servers I checked
# didn't implement it). It will fail on a server which uses a quote in
# the message which isn't a part of or surrounding the path.
$ftp->ok &&
$ftp->message =~ /(?:^|\s)\"(.*)\"(?:$|\s)/ &&
($path = $1) =~ s/\"\"/\"/g;
$path;
}
##
## Communication methods
##
sub _dataconn
{
my $ftp = shift;
my $data = undef;
my $pkg = "Net::FTP::" . $ftp->type;
eval "require " . $pkg;
$pkg =~ s/ /_/g;
delete ${*$ftp}{'net_ftp_dataconn'};
if(defined ${*$ftp}{'net_ftp_pasv'})
{
my @port = map { 0+$_ } split(/,/,${*$ftp}{'net_ftp_pasv'});
$data = $pkg->new(PeerAddr => join(".",@port[0..3]),
PeerPort => $port[4] * 256 + $port[5],
LocalAddr => ${*$ftp}{'net_ftp_localaddr'},
Proto => 'tcp'
);
}
elsif(defined ${*$ftp}{'net_ftp_listen'})
{
$data = ${*$ftp}{'net_ftp_listen'}->accept($pkg);
close(delete ${*$ftp}{'net_ftp_listen'});
}
if($data)
{
${*$data} = "";
$data->timeout($ftp->timeout);
${*$ftp}{'net_ftp_dataconn'} = $data;
${*$data}{'net_ftp_cmd'} = $ftp;
${*$data}{'net_ftp_blksize'} = ${*$ftp}{'net_ftp_blksize'};
}
$data;
}
sub _list_cmd
{
my $ftp = shift;
my $cmd = uc shift;
delete ${*$ftp}{'net_ftp_port'};
delete ${*$ftp}{'net_ftp_pasv'};
my $data = $ftp->_data_cmd($cmd,@_);
return
unless(defined $data);
require Net::FTP::A;
bless $data, "Net::FTP::A"; # Force ASCII mode
my $databuf = '';
my $buf = '';
my $blksize = ${*$ftp}{'net_ftp_blksize'};
while($data->read($databuf,$blksize)) {
$buf .= $databuf;
}
my $list = [ split(/\n/,$buf) ];
$data->close();
if (trEBCDIC)
{
for (@$list) { $_ = $ftp->toebcdic($_) }
}
wantarray ? @{$list}
: $list;
}
sub _data_cmd
{
my $ftp = shift;
my $cmd = uc shift;
my $ok = 1;
my $where = delete ${*$ftp}{'net_ftp_rest'} || 0;
my $arg;
for $arg (@_) {
croak("Bad argument '$arg'\n")
if $arg =~ /[\r\n]/s;
}
if(${*$ftp}{'net_ftp_passive'} &&
!defined ${*$ftp}{'net_ftp_pasv'} &&
!defined ${*$ftp}{'net_ftp_port'})
{
my $data = undef;
$ok = defined $ftp->pasv;
$ok = $ftp->_REST($where)
if $ok && $where;
if($ok)
{
$ftp->command($cmd,@_);
$data = $ftp->_dataconn();
$ok = CMD_INFO == $ftp->response();
if($ok)
{
$data->reading
if $data && $cmd =~ /RETR|LIST|NLST/;
return $data
}
$data->_close
if $data;
}
return undef;
}
$ok = $ftp->port
unless (defined ${*$ftp}{'net_ftp_port'} ||
defined ${*$ftp}{'net_ftp_pasv'});
$ok = $ftp->_REST($where)
if $ok && $where;
return undef
unless $ok;
$ftp->command($cmd,@_);
return 1
if(defined ${*$ftp}{'net_ftp_pasv'});
$ok = CMD_INFO == $ftp->response();
return $ok
unless exists ${*$ftp}{'net_ftp_intern_port'};
if($ok) {
my $data = $ftp->_dataconn();
$data->reading
if $data && $cmd =~ /RETR|LIST|NLST/;
return $data;
}
close(delete ${*$ftp}{'net_ftp_listen'});
return undef;
}
##
## Over-ride methods (Net::Cmd)
##
sub debug_text { $_[2] =~ /^(pass|resp|acct)/i ? "$1 ....\n" : $_[2]; }
sub command
{
my $ftp = shift;
delete ${*$ftp}{'net_ftp_port'};
$ftp->SUPER::command(@_);
}
sub response
{
my $ftp = shift;
my $code = $ftp->SUPER::response();
delete ${*$ftp}{'net_ftp_pasv'}
if ($code != CMD_MORE && $code != CMD_INFO);
$code;
}
sub parse_response
{
return ($1, $2 eq "-")
if $_[1] =~ s/^(\d\d\d)(.?)//o;
my $ftp = shift;
# Darn MS FTP server is a load of CRAP !!!!
return ()
unless ${*$ftp}{'net_cmd_code'} + 0;
(${*$ftp}{'net_cmd_code'},1);
}
##
## Allow 2 servers to talk directly
##
sub pasv_xfer {
my($sftp,$sfile,$dftp,$dfile,$unique) = @_;
($dfile = $sfile) =~ s#.*/##
unless(defined $dfile);
my $port = $sftp->pasv or
return undef;
$dftp->port($port) or
return undef;
return undef
unless($unique ? $dftp->stou($dfile) : $dftp->stor($dfile));
unless($sftp->retr($sfile) && $sftp->response == CMD_INFO) {
$sftp->retr($sfile);
$dftp->abort;
$dftp->response();
return undef;
}
$dftp->pasv_wait($sftp);
}
sub pasv_wait
{
@_ == 2 or croak 'usage: $ftp->pasv_wait(NON_PASV_FTP)';
my($ftp, $non_pasv) = @_;
my($file,$rin,$rout);
vec($rin='',fileno($ftp),1) = 1;
select($rout=$rin, undef, undef, undef);
$ftp->response();
$non_pasv->response();
return undef
unless $ftp->ok() && $non_pasv->ok();
return $1
if $ftp->message =~ /unique file name:\s*(\S*)\s*\)/;
return $1
if $non_pasv->message =~ /unique file name:\s*(\S*)\s*\)/;
return 1;
}
sub cmd { shift->command(@_)->response() }
########################################
#
# RFC959 commands
#
sub _ABOR { shift->command("ABOR")->response() == CMD_OK }
sub _ALLO { shift->command("ALLO",@_)->response() == CMD_OK}
sub _CDUP { shift->command("CDUP")->response() == CMD_OK }
sub _NOOP { shift->command("NOOP")->response() == CMD_OK }
sub _PASV { shift->command("PASV")->response() == CMD_OK }
sub _QUIT { shift->command("QUIT")->response() == CMD_OK }
sub _DELE { shift->command("DELE",@_)->response() == CMD_OK }
sub _CWD { shift->command("CWD", @_)->response() == CMD_OK }
sub _PORT { shift->command("PORT",@_)->response() == CMD_OK }
sub _RMD { shift->command("RMD", @_)->response() == CMD_OK }
sub _MKD { shift->command("MKD", @_)->response() == CMD_OK }
sub _PWD { shift->command("PWD", @_)->response() == CMD_OK }
sub _TYPE { shift->command("TYPE",@_)->response() == CMD_OK }
sub _RNTO { shift->command("RNTO",@_)->response() == CMD_OK }
sub _RESP { shift->command("RESP",@_)->response() == CMD_OK }
sub _MDTM { shift->command("MDTM",@_)->response() == CMD_OK }
sub _SIZE { shift->command("SIZE",@_)->response() == CMD_OK }
sub _HELP { shift->command("HELP",@_)->response() == CMD_OK }
sub _STAT { shift->command("STAT",@_)->response() == CMD_OK }
sub _APPE { shift->command("APPE",@_)->response() == CMD_INFO }
sub _LIST { shift->command("LIST",@_)->response() == CMD_INFO }
sub _NLST { shift->command("NLST",@_)->response() == CMD_INFO }
sub _RETR { shift->command("RETR",@_)->response() == CMD_INFO }
sub _STOR { shift->command("STOR",@_)->response() == CMD_INFO }
sub _STOU { shift->command("STOU",@_)->response() == CMD_INFO }
sub _RNFR { shift->command("RNFR",@_)->response() == CMD_MORE }
sub _REST { shift->command("REST",@_)->response() == CMD_MORE }
sub _USER { shift->command("user",@_)->response() } # A certain brain dead firewall :-)
sub _PASS { shift->command("PASS",@_)->response() }
sub _ACCT { shift->command("ACCT",@_)->response() }
sub _AUTH { shift->command("AUTH",@_)->response() }
sub _SMNT { shift->unsupported(@_) }
sub _MODE { shift->unsupported(@_) }
sub _SYST { shift->unsupported(@_) }
sub _STRU { shift->unsupported(@_) }
sub _REIN { shift->unsupported(@_) }
1;
Reference in New Issue View Git Blame Copy Permalink