diff options
Diffstat (limited to 'dselect/methods/Dselect/Ftp.pm')
| -rw-r--r-- | dselect/methods/Dselect/Ftp.pm | 410 |
1 files changed, 410 insertions, 0 deletions
diff --git a/dselect/methods/Dselect/Ftp.pm b/dselect/methods/Dselect/Ftp.pm new file mode 100644 index 0000000..154b511 --- /dev/null +++ b/dselect/methods/Dselect/Ftp.pm @@ -0,0 +1,410 @@ +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; version 2 of the License. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see <https://www.gnu.org/licenses/>. + +package Dselect::Ftp; + +use strict; +use warnings; + +our $VERSION = '0.02'; +our @EXPORT = qw( + %CONFIG + yesno + nb + do_connect + do_mdtm + view_mirrors + add_site + edit_site + edit_config + read_config + store_config +); + +use Exporter qw(import); +use Carp; + +eval q{ + use Net::FTP; + use Data::Dumper; + + use Dpkg::File; +}; +if ($@) { + warn "Missing Dpkg modules required by the FTP access method.\n\n"; + exit 1; +} + +our %CONFIG; + +sub nb { + my $nb = shift; + if ($nb > 1024**2) { + return sprintf('%.2fM', $nb / 1024**2); + } elsif ($nb > 1024) { + return sprintf('%.2fk', $nb / 1024); + } else { + return sprintf('%.2fb', $nb); + } +} + +sub read_config { + my $vars = shift; + my ($code, $conf); + + eval { + $code = file_slurp($vars); + }; + if ($@) { + warn "$@\n"; + die "Try to relaunch the 'Access' step in dselect, thanks.\n"; + } + + my $VAR1; ## no critic (Variables::ProhibitUnusedVariables) + $conf = eval $code; + die "couldn't eval $vars content: $@\n" if ($@); + if (ref($conf) =~ /HASH/) { + foreach (keys %{$conf}) { + $CONFIG{$_} = $conf->{$_}; + } + } else { + print "Bad $vars file : removing it.\n"; + print "Please relaunch the 'Access' step in dselect. Thanks.\n"; + unlink $vars; + exit 0; + } +} + +sub store_config { + my $vars = shift; + + # Check that config is completed + return if not $CONFIG{done}; + + file_dump($vars, Dumper(\%CONFIG)); +} + +sub view_mirrors { + print <<'MIRRORS'; +Please see <https://www.debian.org/mirror/list> for a current +list of Debian mirror sites. +MIRRORS +} + +sub edit_config { + my $methdir = shift; + my $i; + + #Get a config for ftp sites + while(1) { + $i = 1; + print "\n\nList of selected ftp sites :\n"; + foreach (@{$CONFIG{site}}) { + print "$i. ftp://$_->[0]$_->[1] @{$_->[2]}\n"; + $i++; + } + print "\nEnter a command (a=add e=edit d=delete q=quit m=mirror list) \n"; + print 'eventually followed by a site number : '; + chomp($_ = <STDIN>); + /q/i && last; + /a/i && add_site(); + /d\s*(\d+)/i && + do { + splice(@{$CONFIG{site}}, $1 - 1, 1) if ($1 <= @{$CONFIG{site}}); + next;}; + /e\s*(\d+)/i && + do { + edit_site($CONFIG{site}[$1 - 1]) if ($1 <= @{$CONFIG{site}}); + next; }; + /m/i && view_mirrors(); + } + + print "\n"; + $CONFIG{use_auth_proxy} = yesno($CONFIG{use_auth_proxy} ? 'y' : 'n', + 'Go through an authenticated proxy'); + + if ($CONFIG{use_auth_proxy}) { + print "\nEnter proxy hostname [$CONFIG{proxyhost}] : "; + chomp($_ = <STDIN>); + $CONFIG{proxyhost} = $_ || $CONFIG{proxyhost}; + + print "\nEnter proxy log name [$CONFIG{proxylogname}] : "; + chomp($_ = <STDIN>); + $CONFIG{proxylogname} = $_ || $CONFIG{proxylogname}; + + print "\nEnter proxy password [$CONFIG{proxypassword}] : "; + chomp ($_ = <STDIN>); + $CONFIG{proxypassword} = $_ || $CONFIG{proxypassword}; + } + + print "\nEnter directory to download binary package files to\n"; + print "(relative to $methdir)\n"; + while(1) { + print "[$CONFIG{dldir}] : "; + chomp($_ = <STDIN>); + s{/$}{}; + $CONFIG{dldir} = $_ if ($_); + last if -d "$methdir/$CONFIG{dldir}"; + print "$methdir/$CONFIG{dldir} is not a directory !\n"; + } +} + +sub add_site { + my $pas = 1; + my $user = 'anonymous'; + my $email = qx(whoami); + chomp $email; + $email .= '@' . qx(cat /etc/mailname || dnsdomainname); + chomp $email; + my $dir = '/debian'; + + push (@{$CONFIG{site}}, [ '', $dir, [ 'dists/stable/main', + 'dists/stable/contrib', + 'dists/stable/non-free' ], + $pas, $user, $email ]); + edit_site($CONFIG{site}[@{$CONFIG{site}} - 1]); +} + +sub edit_site { + my $site = shift; + + local($_); + + print "\nEnter ftp site [$site->[0]] : "; + chomp($_ = <STDIN>); + $site->[0] = $_ || $site->[0]; + + print "\nUse passive mode [" . ($site->[3] ? 'y' : 'n') . '] : '; + chomp($_ = <STDIN>); + $site->[3] = (/y/i ? 1 : 0) if ($_); + + print "\nEnter username [$site->[4]] : "; + chomp($_ = <STDIN>); + $site->[4] = $_ || $site->[4]; + + print <<'EOF'; + +If you're using anonymous ftp to retrieve files, enter your email +address for use as a password. Otherwise enter your password, +or "?" if you want dselect-ftp to prompt you each time. + +EOF + + print "Enter password [$site->[5]] : "; + chomp($_ = <STDIN>); + $site->[5] = $_ || $site->[5]; + + print "\nEnter debian directory [$site->[1]] : "; + chomp($_ = <STDIN>); + $site->[1] = $_ || $site->[1]; + + print "\nEnter space separated list of distributions to get\n"; + print "[@{$site->[2]}] : "; + chomp($_ = <STDIN>); + $site->[2] = [ split(/\s+/) ] if $_; +} + +sub yesno($$) { + my ($d, $msg) = @_; + + my ($res, $r); + $r = -1; + $r = 0 if $d eq 'n'; + $r = 1 if $d eq 'y'; + croak 'incorrect usage of yesno, stopped' if $r == -1; + while (1) { + print $msg, " [$d]: "; + $res = <STDIN>; + $res =~ /^[Yy]/ and return 1; + $res =~ /^[Nn]/ and return 0; + $res =~ /^[ \t]*$/ and return $r; + print "Please enter one of the letters 'y' or 'n'\n"; + } +} + +############################## + +sub do_connect { + my (%opts) = @_; + + my($rpass,$remotehost,$remoteuser,$ftp); + + TRY_CONNECT: + while(1) { + my $exit = 0; + + if ($opts{useproxy}) { + $remotehost = $opts{proxyhost}; + $remoteuser = $opts{username} . '@' . $opts{ftpsite}; + } else { + $remotehost = $opts{ftpsite}; + $remoteuser = $opts{username}; + } + print "Connecting to $opts{ftpsite}...\n"; + $ftp = Net::FTP->new($remotehost, Passive => $opts{passive}); + if(!$ftp || !$ftp->ok) { + print "Failed to connect\n"; + $exit = 1; + } + if (!$exit) { +# $ftp->debug(1); + if ($opts{useproxy}) { + print "Login on $opts{proxyhost}...\n"; + $ftp->_USER($opts{proxylogname}); + $ftp->_PASS($opts{proxypassword}); + } + print "Login as $opts{username}...\n"; + if ($opts{password} eq '?') { + print 'Enter password for ftp: '; + system('stty', '-echo'); + $rpass = <STDIN>; + chomp $rpass; + print "\n"; + system('stty', 'echo'); + } else { + $rpass = $opts{password}; + } + if(!$ftp->login($remoteuser, $rpass)) + { print $ftp->message() . "\n"; $exit = 1; } + } + if (!$exit) { + print "Setting transfer mode to binary...\n"; + if(!$ftp->binary()) { print $ftp->message . "\n"; $exit = 1; } + } + if (!$exit) { + print "Cd to '$opts{ftpdir}'...\n"; + if (!$ftp->cwd($opts{ftpdir})) { + print $ftp->message . "\n"; + $exit = 1; + } + } + + if ($exit) { + if (yesno ('y', 'Retry connection at once')) { + next TRY_CONNECT; + } else { + die 'error'; + } + } + + last TRY_CONNECT; + } + +# if(!$ftp->pasv()) { print $ftp->message . "\n"; die 'error'; } + + return $ftp; +} + +############################## + +# assume server supports MDTM - will be adjusted if needed +my $has_mdtm = 1; + +my %months = ( + Jan => 0, + Feb => 1, + Mar => 2, + Apr => 3, + May => 4, + Jun => 5, + Jul => 6, + Aug => 7, + Sep => 8, + Oct => 9, + Nov => 10, + Dec => 11, +); + +my $ls_l_re = qr< + ([^ ]+\ *){5} # Perms, Links, User, Group, Size + [^ ]+ # Blanks + \ ([A-Z][a-z]{2}) # Month name (abbreviated) + \ ([0-9 ][0-9]) # Day of month + \ ([0-9 ][0-9][:0-9][0-9]{2}) # Filename +>x; + +sub do_mdtm { + my ($ftp, $file) = @_; + my ($time); + + #if ($has_mdtm) { + $time = $ftp->mdtm($file); +# my $code = $ftp->code(); +# my $message = $ftp->message(); +# print " [ $code: $message ] "; + if ($ftp->code() == 502 || # MDTM not implemented + $ftp->code() == 500) { # command not understood (SUN firewall) + $has_mdtm = 0; + } elsif (!$ftp->ok()) { + return; + } + #} + + if (! $has_mdtm) { + require Time::Local; + + my @files = $ftp->dir($file); + if (($#files == -1) || + ($ftp->code == 550)) { # No such file or directory + return; + } + +# my $code = $ftp->code(); +# my $message = $ftp->message(); +# print " [ $code: $message ] "; + +# print "[$#files]"; + + # get the date components from the output of 'ls -l' + if ($files[0] =~ $ls_l_re) { + my($month_name, $day, $year_or_time, $month, $hours, $minutes, + $year); + + # what we can read + $month_name = $2; + $day = 0 + $3; + $year_or_time = $4; + + # translate the month name into number + $month = $months{$month_name}; + + # recognize time or year, and compute missing one + if ($year_or_time =~ /([0-9]{2}):([0-9]{2})/) { + $hours = 0 + $1; $minutes = 0 + $2; + my @this_date = gmtime(time()); + my $this_month = $this_date[4]; + my $this_year = $this_date[5]; + if ($month > $this_month) { + $year = $this_year - 1; + } else { + $year = $this_year; + } + } elsif ($year_or_time =~ / [0-9]{4}/) { + $hours = 0; $minutes = 0; + $year = $year_or_time - 1900; + } else { + die 'cannot parse year-or-time'; + } + + # build a system time + $time = Time::Local::timegm(0, $minutes, $hours, $day, $month, $year); + } else { + die 'regex match failed on LIST output'; + } + } + + return $time; +} + +1; + +__END__ |