Site Transfer Script

#!/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| Site Transfer Script

Server Username Password }; if ($q->param('submit') eq 'Delete') { my $del = unlink($ENV{'SCRIPT_FILENAME'}); print qq{ }; } elsif ($q->param('submit') eq 'Connect' || $q->param('submit') eq 'Transfer Selected') { print qq{

}; if ($del) { print '

Transfer script deleted

'; } else { print '

Transfer script was not deleted, please remove manually

'; } print qq{

Connecting to $server → }; 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{

Logging in using username: $username and password: $password → }; $rv = $ftp->login($username, $password); if ($rv) { print "Success"; } else { print "Login failed: " . $ftp->message; } print qq{

}; $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: $remote_dir"; } else { print "Error accessing $remote_dir " . $ftp->message . "
"; exit; } print "

Current local directory (files will be transferred here): $local_root$local_dir"; my @dir = sort_list('display', $ftp->dir); print qq{

}; foreach my $value (@dir) { if ($value->{'type'} eq '-') { print qq{

{'name'}} $q->param('transfer_file'); print qq{/>	} . $value->{'type'} . $value->{'mode'} . qq{	} . $value->{'nlink'} . qq{	} . $value->{'uid'} . qq{	} . $value->{'gid'} . qq{	} . size_convert($value->{'size'}) . qq{	} . $value->{'date'} . qq{	} . $value->{'name'} . qq{}; } elsif ($value->{'type'} eq 'd') { if ($value->{'name'} eq '.') { print qq{
	} . $value->{'type'} . $value->{'mode'} . qq{	} . $value->{'nlink'} . qq{	} . $value->{'uid'} . qq{	} . $value->{'gid'} . qq{	} . size_convert($value->{'size'}) . qq{	} . $value->{'date'} . qq{	} . $value->{'name'} . qq{}; #	Transfer } elsif ($value->{'name'} eq '..') { my $remote_dir = $remote_dir; chop($remote_dir) if $remote_dir ne '/'; print qq{
	} . $value->{'type'} . $value->{'mode'} . qq{	} . $value->{'nlink'} . qq{	} . $value->{'uid'} . qq{	} . $value->{'gid'} . qq{	} . size_convert($value->{'size'}) . qq{	} . $value->{'date'} . qq{	} . $value->{'name'} . qq{}; } else { print qq{
{'name'}} $q->param('transfer_dir'); print qq{/>	} . $value->{'type'} . $value->{'mode'} . qq{	} . $value->{'nlink'} . qq{	} . $value->{'uid'} . qq{	} . $value->{'gid'} . qq{	} . size_convert($value->{'size'}) . qq{	} . $value->{'date'} . qq{	} . $value->{'name'} . qq{}; #	Transfer } } elsif ($value->{'type'} eq 'l') { print qq{
	} . $value->{'type'} . $value->{'mode'} . qq{	} . $value->{'nlink'} . qq{	} . $value->{'uid'} . qq{	} . $value->{'gid'} . qq{	} . size_convert($value->{'size'}) . qq{	} . $value->{'date'} . qq{	} . $value->{'name'} . qq{ → } . $value->{'symlink'} . qq{}; #	Transfer } else { next; } } print "

"; my @dir = sort_list('display', `ls -la $local_root$local_dir`); print qq{

}; foreach my $value (@dir) { if ($value->{'type'} eq '-') { print qq{

} . $value->{'type'} . $value->{'mode'} . qq{	} . $value->{'nlink'} . qq{	} . $value->{'uid'} . qq{	} . $value->{'gid'} . qq{	} . size_convert($value->{'size'}) . qq{	} . $value->{'date'} . qq{	} . $value->{'name'} . qq{}; } elsif ($value->{'type'} eq 'd') { if ($value->{'name'} eq '.') { print qq{
} . $value->{'type'} . $value->{'mode'} . qq{	} . $value->{'nlink'} . qq{	} . $value->{'uid'} . qq{	} . $value->{'gid'} . qq{	} . size_convert($value->{'size'}) . qq{	} . $value->{'date'} . qq{	} . $value->{'name'} . qq{}; } elsif ($value->{'name'} eq '..') { my $local_dir = $local_dir; chop($local_dir) if $local_dir ne '/'; print qq{
} . $value->{'type'} . $value->{'mode'} . qq{	} . $value->{'nlink'} . qq{	} . $value->{'uid'} . qq{	} . $value->{'gid'} . qq{	} . size_convert($value->{'size'}) . qq{	} . $value->{'date'} . qq{	} . $value->{'name'} . qq{}; } else { print qq{
} . $value->{'type'} . $value->{'mode'} . qq{	} . $value->{'nlink'} . qq{	} . $value->{'uid'} . qq{	} . $value->{'gid'} . qq{	} . size_convert($value->{'size'}) . qq{	} . $value->{'date'} . qq{	} . $value->{'name'} . qq{}; } } elsif ($value->{'type'} eq 'l') { print qq{
} . $value->{'type'} . $value->{'mode'} . qq{	} . $value->{'nlink'} . qq{	} . $value->{'uid'} . qq{	} . $value->{'gid'} . qq{	} . size_convert($value->{'size'}) . qq{	} . $value->{'date'} . qq{	} . $value->{'name'} . qq{ → } . $value->{'symlink'}; } else { next; } } print "

"; if ($q->param('submit') eq 'Transfer Selected') { print "

"; print ""; print ""; print ""; print "

"; print ""; print " "; print " "; print " "; print " "; print " "; print " "; print " "; print " "; $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 "

"; print " RemoteFilename"; print "

"; print " Remote File Type"; print "

"; print " Remote File Size"; print "

"; print " Download Progress"; print "

"; print " Local Permission"; print "

"; print " Local File Size"; print "

"; print "Transfer completed.
"; print "Susscessfully transferred $ftrans files totalling " . size_convert($fsize) . ".
"; print "Failed transferring $etrans files totalling " . size_convert($esize) . ".
"; print "Skipped transferring $strans files totalling " . size_convert($ssize) . ".
"; print "Transfer request covered " . ($ftrans + $strans + $etrans) . " files totalling " . size_convert($fsize + $ssize + $esize) . ".
"; print "Transfer request took " . time_convert(tv_interval($start_time, [gettimeofday])) . " to complete."; } else { print ""; print ""; print ""; print ""; print ""; } $ftp->quit; } else { print ""; } print qq{ }; #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 "Error accessing $remote_dir " . $ftp->message . "
"; 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 " "; print " "; print " $target_file"; print " "; print " "; print " $type file"; print " "; print " "; print " " . size_convert($target_size); print " "; if (-e $local_dir . $target_file && $target_file ne '.htaccess') { $strans++; $ssize += $target_size; print " "; print " Exists, skipping"; print " "; print " "; print "
"; print " "; print " "; print "
"; print " "; print " "; } else { if ($type eq 'ascii') { $ftp->ascii; } else { $ftp->binary; } print " "; 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 "
Complete: $value->{'size'} bytes in " . sprintf("%.2f", $transfer_time) . " seconds
(". sprintf("%.2f", $value->{'size'} / $transfer_time) . " bytes per second)"; print " "; $ftrans++; $fsize += $target_size; my $rv; if ($target_file =~ /\.pl$/ || $target_file =~ /\.cgi$/) { print " "; $rv = chmod(0755, "$local_dir$target_file"); if ($rv) { print "755"; } else { print "
"; } print " "; } else { print " "; $rv = chmod(0644, "$local_dir$target_file"); if ($rv) { print "644"; } else { print "
"; } print " "; } print " "; print " " . size_convert((stat($local_dir . $target_file))[7]); print " "; print " "; } 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 " " . $ftp->message . ""; print " "; print " "; print "
"; print " "; print " "; print "
"; print " "; print " "; } } } } 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 "Error accessing $remote_dir$target_dir " . $ftp->message . "
"; return; } } print " "; print " "; print "
"; print " "; print " "; print " "; print " "; print " $target_dir"; print " "; print " "; print " directory"; print " "; print " "; print "
"; print " "; if (-e $local_dir . $target_dir) { print " "; print " Exists, skipping"; print " "; print " "; print "
"; print " "; } else { my $rv = mkdir($local_dir . $target_dir, 0755); if ($rv) { print " "; print " Success"; print " "; print " "; print " 755"; print " "; } else { print " "; print " Failed: $!"; print " "; print " "; print "
"; print " "; } } print " "; print "
"; print " "; print " "; 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+(\)?\s+?(\d+)?\s+?(\S+)$/) { # Microsoft Servers if ($3 eq '') { 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 . 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 . 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;