diff options
Diffstat (limited to 'dselect/methods/ftp/update.pl')
| -rwxr-xr-x | dselect/methods/ftp/update.pl | 250 |
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..30b79a7 --- /dev/null +++ b/dselect/methods/ftp/update.pl @@ -0,0 +1,250 @@ +#!/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 <https://www.gnu.org/licenses/>. + +use strict; +use warnings; + +eval q{ + pop @INC if $INC[-1] eq '.'; + + 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::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; |