Adding upstream version 1.21.22.upstream/1.21.22upstream

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

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__