Adding upstream version 1.22.4.upstream/1.22.4

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

1 files changed, 250 insertions, 0 deletions

diff --git a/dselect/methods/ftp/update.pl b/dselect/methods/ftp/update.pl
new file mode 100755
index 0000000..8fcd7b1
--- /dev/null
+++ b/dselect/methods/ftp/update.pl
@@ -0,0 +1,250 @@
+#!/usr/bin/perl
+#
+# Copyright © 1996 Andy Guy <andy@cyteen.org>
+# Copyright © 1998 Martin Schulze <joey@infodrom.north.de>
+# Copyright © 1999, 2009 Raphaël Hertzog <hertzog@debian.org>
+#
+# 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; either version 2 of the License, or
+# (at your option) any later version.
+#
+# 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/>.
+
+use strict;
+use warnings;
+
+eval q{
+    use Dpkg; # Dummy import to require the presence of Dpkg::*.
+};
+if ($@) {
+    warn "Missing Dpkg modules required by the FTP access method.\n\n";
+    exit 1;
+}
+
+use Dselect::Method;
+use Dselect::Method::Ftp;
+
+# deal with arguments
+my $vardir = $ARGV[0];
+my $method = $ARGV[1];
+my $option = $ARGV[2];
+
+if ($option eq 'manual') {
+    print "Enter package file names or a blank line to finish\n";
+    while(1) {
+	print 'Enter package file name:';
+	my $fn = <STDIN>;
+	chomp $fn;
+	if ($fn eq '') {
+	    exit 0;
+	}
+	if ( -f $fn ) {
+	    system('dpkg', '--merge-avail', $fn);
+	} else {
+	    print "Could not find $fn, try again\n";
+	}
+    };
+};
+
+#print "vardir: $vardir, method: $method, option: $option\n";
+
+my $arch = qx(dpkg --print-architecture);
+$arch = 'i386' if $?;
+chomp $arch;
+my $exit = 0;
+
+# get info from control file
+read_config("$vardir/methods/ftp/vars");
+
+chdir "$vardir/methods/ftp";
+
+print "Getting Packages files...(stop with ^C)\n\n";
+
+my @pkgfiles;
+my $ftp;
+my $packages_modified = 0;
+
+sub download {
+foreach (@{$CONFIG{site}}) {
+   my $site = $_;
+
+        $ftp = do_connect(ftpsite => $_->[0],
+                          ftpdir => $_->[1],
+                          passive => $_->[3],
+                          username => $_->[4],
+                          password => $_->[5],
+                          useproxy => $CONFIG{use_auth_proxy},
+                          proxyhost => $CONFIG{proxyhost},
+                          proxylogname => $CONFIG{proxylogname},
+                          proxypassword => $CONFIG{proxypassword});
+
+    my @dists = @{$_->[2]};
+    PACKAGE:
+    foreach my $dist (@dists) {
+	my $dir = "$dist/binary-$arch";
+	my $must_get = 0;
+	my $newest_pack_date;
+
+	# check existing Packages on remote site
+	print "\nChecking for Packages file... ";
+	$newest_pack_date = do_mdtm ($ftp, "$dir/Packages.gz");
+	if (defined $newest_pack_date) {
+	    print "$dir/Packages.gz\n";
+	} else {
+	    $dir = "$dist";
+	    $newest_pack_date = do_mdtm ($ftp, "$dir/Packages.gz");
+	    if (defined $newest_pack_date) {
+		print "$dir/Packages.gz\n";
+	    } else {
+		print "Couldn't find Packages.gz in $dist/binary-$arch or $dist; ignoring.\n";
+		print "Your setup is probably wrong, check the distributions directories,\n";
+		print "and try with passive mode enabled/disabled (if you use a proxy/firewall)\n";
+		next PACKAGE;
+	    }
+	}
+
+	# we now have $dir set to point to an existing Packages.gz file
+
+	# check if we already have a Packages file (and get its date)
+	$dist =~ tr/\//_/;
+	my $file = "Packages.$site->[0].$dist";
+
+	# if not
+	if (! -f $file) {
+	    # must get one
+#	    print "No Packages here; must get it.\n";
+	    $must_get = 1;
+	} else {
+	    # else check last modification date
+            my @pack_stat = stat($file);
+	    if($newest_pack_date > $pack_stat[9]) {
+#		print "Packages has changed; must get it.\n";
+		$must_get = 1;
+	    } elsif ($newest_pack_date < $pack_stat[9]) {
+		print " Our file is newer than theirs; skipping.\n";
+	    } else {
+		print " Already up-to-date; skipping.\n";
+	    }
+	}
+
+	if ($must_get) {
+	    -f 'Packages.gz' and unlink 'Packages.gz';
+	    -f 'Packages' and unlink 'Packages';
+	    my $size = 0;
+
+	  TRY_GET_PACKAGES:
+	    while (1) {
+		if ($size) {
+		    print ' Continuing ';
+		} else {
+		    print ' Getting ';
+		}
+		print "Packages file from $dir...\n";
+		eval {
+		    if ($ftp->get("$dir/Packages.gz", 'Packages.gz', $size)) {
+			if (system('gunzip', 'Packages.gz')) {
+			    print "  Couldn't gunzip Packages.gz, stopped";
+			    die 'error';
+			}
+		    } else {
+			print "  Couldn't get Packages.gz from $dir !!! Stopped.";
+			die 'error';
+		    }
+		};
+		if ($@) {
+		    $size = -s 'Packages.gz';
+		    if (ref($ftp)) {
+		      $ftp->abort();
+		      $ftp->quit();
+		    };
+		    if (yesno ('y', "Transfer failed at $size: retry at once")) {
+                         $ftp = do_connect(ftpsite => $site->[0],
+                                           ftpdir => $site->[1],
+                                           passive => $site->[3],
+                                           username => $site->[4],
+                                           password => $site->[5],
+                                           useproxy => $CONFIG{use_auth_proxy},
+                                           proxyhost => $CONFIG{proxyhost},
+                                           proxylogname => $CONFIG{proxylogname},
+                                           proxypassword => $CONFIG{proxypassword});
+
+			if ($newest_pack_date != do_mdtm ($ftp, "$dir/Packages.gz")) {
+			    print ("Packages file has changed !\n");
+			    $size = 0;
+			}
+			next TRY_GET_PACKAGES;
+		    } else {
+			die 'error';
+		    }
+		}
+		last TRY_GET_PACKAGES;
+	    }
+
+	    if (!rename 'Packages', "Packages.$site->[0].$dist") {
+		print "  Couldn't rename Packages to Packages.$site->[0].$dist";
+		die 'error';
+	    } else {
+		# set local Packages file to same date as the one it mirrors
+		# to allow comparison to work.
+		utime $newest_pack_date, $newest_pack_date, "Packages.$site->[0].$dist";
+		$packages_modified = 1;
+	    }
+	}
+	push @pkgfiles, "Packages.$site->[0].$dist";
+    }
+    $ftp->quit();
+ }
+}
+
+eval {
+    local $SIG{INT} = sub {
+	die "interrupted!\n";
+    };
+    download();
+};
+if($@) {
+    $ftp->quit() if (ref($ftp));
+    if($@ =~ /timeout/i) {
+	print "FTP TIMEOUT\n";
+    } else {
+	print "FTP ERROR - $@\n";
+    }
+    $exit = 1;
+};
+
+# Don't clear if nothing changed.
+if ($packages_modified) {
+    print <<'EOM';
+
+It is a good idea to clear the available list of old packages.
+However if you have only downloaded a Package files from non-main
+distributions you might not want to do this.
+
+EOM
+    if (yesno ('y', 'Do you want to clear available list')) {
+	print "Clearing...\n";
+	if (system('dpkg', '--clear-avail')) {
+	    print 'dpkg --clear-avail failed.';
+	    die 'error';
+	}
+    }
+}
+
+if (!$packages_modified) {
+    print "No Packages files was updated.\n";
+} else {
+    foreach my $file (@pkgfiles) {
+	if (system('dpkg', '--merge-avail', $file)) {
+	    print "Dpkg merge available failed on $file";
+	    $exit = 1;
+	}
+    }
+}
+exit $exit;