dpkg/dselect/methods/ftp/update

#!/usr/bin/perl
#
# Copyright © 1996 Andy Guy <awpguy@acs.ucalgary.ca>
# 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; 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 <http://www.gnu.org/licenses/>.

use strict;
use warnings;

#use diagnostics;

use lib '/usr/lib/perl5/Debian';
use lib '/usr/share/perl5/Debian';

eval 'use Net::FTP;';
if ($@) {
    print STDERR "Please install the 'perl' package if you want to use the\n" .
                 "FTP access method of dselect.\n\n";
    exit 1;
}

use Dselect::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 == "") {
	    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=`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 ($_->[0], # Ftp server
                           $_->[4], # username
                           $_->[5], # password
                           $_->[1], # ftp dir
                           $_->[3], # passive
                           $config{'use_auth_proxy'},
                           $config{'proxyhost'},
                           $config{'proxylogname'},
                           $config{'proxypassword'});

    my @dists = @{$_->[2]};
    my $dist;
    PACKAGE:
    foreach $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 ($site->[0], # Ftp server
                           $site->[4], # username
                           $site->[5], # password
                           $site->[1], # ftp dir
                           $site->[3], # passive
                           $config{'use_auth_proxy'},
                           $config{'proxyhost'},
                           $config{'proxylogname'},
                           $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;
};

my $ans;

if ($packages_modified) {	# don't clear if nothing changed
    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 {
    my $file;

    foreach $file (@pkgfiles) {
	if(system ("dpkg", "--merge-avail", $file)) {
	    print "Dpkg merge available failed on $file";
	    $exit = 1;
	}
    }
}
exit $exit;