chiark - git - mdw - dpkg/blob - dselect/methods/ftp/update.pl

   1 #!/usr/bin/perl
   2 #
   3 # Copyright © 1996 Andy Guy <awpguy@acs.ucalgary.ca>
   4 # Copyright © 1998 Martin Schulze <joey@infodrom.north.de>
   5 # Copyright © 1999, 2009 Raphaël Hertzog <hertzog@debian.org>
   6 #
   7 # This program is free software; you can redistribute it and/or modify
   8 # it under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; version 2 of the License.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  18
  19 use strict;
  20 use warnings;
  21
  22 eval q{
  23     pop @INC if $INC[-1] eq '.';
  24     use Net::FTP;
  25 };
  26 if ($@) {
  27     warn "Please install the 'perl' package if you want to use the\n" .
  28          "FTP access method of dselect.\n\n";
  29     exit 1;
  30 }
  31
  32 use Dselect::Ftp;
  33
  34 # deal with arguments
  35 my $vardir = $ARGV[0];
  36 my $method = $ARGV[1];
  37 my $option = $ARGV[2];
  38
  39 if ($option eq 'manual') {
  40     print "Enter package file names or a blank line to finish\n";
  41     while(1) {
  42         print 'Enter package file name:';
  43         my $fn = <STDIN>;
  44         chomp $fn;
  45         if ($fn eq '') {
  46             exit 0;
  47         }
  48         if ( -f $fn ) {
  49             system('dpkg', '--merge-avail', $fn);
  50         } else {
  51             print "Could not find $fn, try again\n";
  52         }
  53     };
  54 };
  55
  56 #print "vardir: $vardir, method: $method, option: $option\n";
  57
  58 my $arch = qx(dpkg --print-architecture);
  59 $arch='i386' if $?;
  60 chomp $arch;
  61 my $exit = 0;
  62
  63 # get info from control file
  64 read_config("$vardir/methods/ftp/vars");
  65
  66 chdir "$vardir/methods/ftp";
  67
  68 print "Getting Packages files...(stop with ^C)\n\n";
  69
  70 my @pkgfiles;
  71 my $ftp;
  72 my $packages_modified = 0;
  73
  74 sub download {
  75 foreach (@{$CONFIG{site}}) {
  76
  77    my $site = $_;
  78
  79         $ftp = do_connect ($_->[0], # Ftp server
  80                            $_->[4], # username
  81                            $_->[5], # password
  82                            $_->[1], # ftp dir
  83                            $_->[3], # passive
  84                            $CONFIG{use_auth_proxy},
  85                            $CONFIG{proxyhost},
  86                            $CONFIG{proxylogname},
  87                            $CONFIG{proxypassword});
  88
  89     my @dists = @{$_->[2]};
  90     PACKAGE:
  91     foreach my $dist (@dists) {
  92         my $dir = "$dist/binary-$arch";
  93         my $must_get = 0;
  94         my $newest_pack_date;
  95
  96         # check existing Packages on remote site
  97         print "\nChecking for Packages file... ";
  98         $newest_pack_date = do_mdtm ($ftp, "$dir/Packages.gz");
  99         if (defined $newest_pack_date) {
 100             print "$dir/Packages.gz\n";
 101         } else {
 102             $dir = "$dist";
 103             $newest_pack_date = do_mdtm ($ftp, "$dir/Packages.gz");
 104             if (defined $newest_pack_date) {
 105                 print "$dir/Packages.gz\n";
 106             } else {
 107                 print "Couldn't find Packages.gz in $dist/binary-$arch or $dist; ignoring.\n";
 108                 print "Your setup is probably wrong, check the distributions directories,\n";
 109                 print "and try with passive mode enabled/disabled (if you use a proxy/firewall)\n";
 110                 next PACKAGE;
 111             }
 112         }
 113
 114         # we now have $dir set to point to an existing Packages.gz file
 115
 116         # check if we already have a Packages file (and get its date)
 117         $dist =~ tr/\//_/;
 118         my $file = "Packages.$site->[0].$dist";
 119
 120         # if not
 121         if (! -f $file) {
 122             # must get one
 123 #           print "No Packages here; must get it.\n";
 124             $must_get = 1;
 125         } else {
 126             # else check last modification date
 127             my @pack_stat = stat($file);
 128             if($newest_pack_date > $pack_stat[9]) {
 129 #               print "Packages has changed; must get it.\n";
 130                 $must_get = 1;
 131             } elsif ($newest_pack_date < $pack_stat[9]) {
 132                 print " Our file is newer than theirs; skipping.\n";
 133             } else {
 134                 print " Already up-to-date; skipping.\n";
 135             }
 136         }
 137
 138         if ($must_get) {
 139             -f 'Packages.gz' and unlink 'Packages.gz';
 140             -f 'Packages' and unlink 'Packages';
 141             my $size = 0;
 142
 143           TRY_GET_PACKAGES:
 144             while (1) {
 145                 if ($size) {
 146                     print ' Continuing ';
 147                 } else {
 148                     print ' Getting ';
 149                 }
 150                 print "Packages file from $dir...\n";
 151                 eval {
 152                     if ($ftp->get("$dir/Packages.gz", 'Packages.gz', $size)) {
 153                         if (system('gunzip', 'Packages.gz')) {
 154                             print "  Couldn't gunzip Packages.gz, stopped";
 155                             die 'error';
 156                         }
 157                     } else {
 158                         print "  Couldn't get Packages.gz from $dir !!! Stopped.";
 159                         die 'error';
 160                     }
 161                 };
 162                 if ($@) {
 163                     $size = -s 'Packages.gz';
 164                     if (ref($ftp)) {
 165                       $ftp->abort();
 166                       $ftp->quit();
 167                     };
 168                     if (yesno ('y', "Transfer failed at $size: retry at once")) {
 169                          $ftp = do_connect ($site->[0], # Ftp server
 170                            $site->[4], # username
 171                            $site->[5], # password
 172                            $site->[1], # ftp dir
 173                            $site->[3], # passive
 174                            $CONFIG{use_auth_proxy},
 175                            $CONFIG{proxyhost},
 176                            $CONFIG{proxylogname},
 177                            $CONFIG{proxypassword});
 178
 179                         if ($newest_pack_date != do_mdtm ($ftp, "$dir/Packages.gz")) {
 180                             print ("Packages file has changed !\n");
 181                             $size = 0;
 182                         }
 183                         next TRY_GET_PACKAGES;
 184                     } else {
 185                         die 'error';
 186                     }
 187                 }
 188                 last TRY_GET_PACKAGES;
 189             }
 190
 191             if (!rename 'Packages', "Packages.$site->[0].$dist") {
 192                 print "  Couldn't rename Packages to Packages.$site->[0].$dist";
 193                 die 'error';
 194             } else {
 195                 # set local Packages file to same date as the one it mirrors
 196                 # to allow comparison to work.
 197                 utime $newest_pack_date, $newest_pack_date, "Packages.$site->[0].$dist";
 198                 $packages_modified = 1;
 199             }
 200         }
 201         push @pkgfiles, "Packages.$site->[0].$dist";
 202     }
 203     $ftp->quit();
 204  }
 205 }
 206
 207 eval {
 208     local $SIG{INT} = sub {
 209         die "interrupted!\n";
 210     };
 211     download();
 212 };
 213 if($@) {
 214     $ftp->quit() if (ref($ftp));
 215     if($@ =~ /timeout/i) {
 216         print "FTP TIMEOUT\n";
 217     } else {
 218         print "FTP ERROR - $@\n";
 219     }
 220     $exit = 1;
 221 };
 222
 223 # Don't clear if nothing changed.
 224 if ($packages_modified) {
 225     print <<'EOM';
 226
 227 It is a good idea to clear the available list of old packages.
 228 However if you have only downloaded a Package files from non-main
 229 distributions you might not want to do this.
 230
 231 EOM
 232     if (yesno ('y', 'Do you want to clear available list')) {
 233         print "Clearing...\n";
 234         if (system('dpkg', '--clear-avail')) {
 235             print 'dpkg --clear-avail failed.';
 236             die 'error';
 237         }
 238     }
 239 }
 240
 241 if (!$packages_modified) {
 242     print "No Packages files was updated.\n";
 243 } else {
 244     foreach my $file (@pkgfiles) {
 245         if (system('dpkg', '--merge-avail', $file)) {
 246             print "Dpkg merge available failed on $file";
 247             $exit = 1;
 248         }
 249     }
 250 }
 251 exit $exit;