| #!/usr/bin/perl |
| # -*-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 has been distributed under the terms of the GNU GPL. |
| |
| 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; |