dselect/methods/ftp/update.pl

   1 #!/usr/bin/perl
   2 #
   3 # Copyright © 1996 Andy Guy <andy@cyteen.org>
   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; either version 2 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # This program is distributed in the hope that it will be useful,
  13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  19
  20 use strict;
  21 use warnings;
  22
  23 eval q{
  24     use Dpkg; # Dummy import to require the presence of Dpkg::*.
  25 };
  26 if ($@) {
  27     warn "Missing Dpkg modules required by the FTP access method.\n\n";
  28     exit 1;
  29 }
  30
  31 use Dselect::Method;
  32 use Dselect::Method::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    my $site = $_;
  77
  78         $ftp = do_connect(ftpsite => $_->[0],
  79                           ftpdir => $_->[1],
  80                           passive => $_->[3],
  81                           username => $_->[4],
  82                           password => $_->[5],
  83                           useproxy => $CONFIG{use_auth_proxy},
  84                           proxyhost => $CONFIG{proxyhost},
  85                           proxylogname => $CONFIG{proxylogname},
  86                           proxypassword => $CONFIG{proxypassword});
  87
  88     my @dists = @{$_->[2]};
  89     PACKAGE:
  90     foreach my $dist (@dists) {
  91         my $dir = "$dist/binary-$arch";
  92         my $must_get = 0;
  93         my $newest_pack_date;
  94
  95         # check existing Packages on remote site
  96         print "\nChecking for Packages file... ";
  97         $newest_pack_date = do_mdtm ($ftp, "$dir/Packages.gz");
  98         if (defined $newest_pack_date) {
  99             print "$dir/Packages.gz\n";
 100         } else {
 101             $dir = "$dist";
 102             $newest_pack_date = do_mdtm ($ftp, "$dir/Packages.gz");
 103             if (defined $newest_pack_date) {
 104                 print "$dir/Packages.gz\n";
 105             } else {
 106                 print "Couldn't find Packages.gz in $dist/binary-$arch or $dist; ignoring.\n";
 107                 print "Your setup is probably wrong, check the distributions directories,\n";
 108                 print "and try with passive mode enabled/disabled (if you use a proxy/firewall)\n";
 109                 next PACKAGE;
 110             }
 111         }
 112
 113         # we now have $dir set to point to an existing Packages.gz file
 114
 115         # check if we already have a Packages file (and get its date)
 116         $dist =~ tr/\//_/;
 117         my $file = "Packages.$site->[0].$dist";
 118
 119         # if not
 120         if (! -f $file) {
 121             # must get one
 122 #           print "No Packages here; must get it.\n";
 123             $must_get = 1;
 124         } else {
 125             # else check last modification date
 126             my @pack_stat = stat($file);
 127             if($newest_pack_date > $pack_stat[9]) {
 128 #               print "Packages has changed; must get it.\n";
 129                 $must_get = 1;
 130             } elsif ($newest_pack_date < $pack_stat[9]) {
 131                 print " Our file is newer than theirs; skipping.\n";
 132             } else {
 133                 print " Already up-to-date; skipping.\n";
 134             }
 135         }
 136
 137         if ($must_get) {
 138             -f 'Packages.gz' and unlink 'Packages.gz';
 139             -f 'Packages' and unlink 'Packages';
 140             my $size = 0;
 141
 142           TRY_GET_PACKAGES:
 143             while (1) {
 144                 if ($size) {
 145                     print ' Continuing ';
 146                 } else {
 147                     print ' Getting ';
 148                 }
 149                 print "Packages file from $dir...\n";
 150                 eval {
 151                     if ($ftp->get("$dir/Packages.gz", 'Packages.gz', $size)) {
 152                         if (system('gunzip', 'Packages.gz')) {
 153                             print "  Couldn't gunzip Packages.gz, stopped";
 154                             die 'error';
 155                         }
 156                     } else {
 157                         print "  Couldn't get Packages.gz from $dir !!! Stopped.";
 158                         die 'error';
 159                     }
 160                 };
 161                 if ($@) {
 162                     $size = -s 'Packages.gz';
 163                     if (ref($ftp)) {
 164                       $ftp->abort();
 165                       $ftp->quit();
 166                     };
 167                     if (yesno ('y', "Transfer failed at $size: retry at once")) {
 168                          $ftp = do_connect(ftpsite => $site->[0],
 169                                            ftpdir => $site->[1],
 170                                            passive => $site->[3],
 171                                            username => $site->[4],
 172                                            password => $site->[5],
 173                                            useproxy => $CONFIG{use_auth_proxy},
 174                                            proxyhost => $CONFIG{proxyhost},
 175                                            proxylogname => $CONFIG{proxylogname},
 176                                            proxypassword => $CONFIG{proxypassword});
 177
 178                         if ($newest_pack_date != do_mdtm ($ftp, "$dir/Packages.gz")) {
 179                             print ("Packages file has changed !\n");
 180                             $size = 0;
 181                         }
 182                         next TRY_GET_PACKAGES;
 183                     } else {
 184                         die 'error';
 185                     }
 186                 }
 187                 last TRY_GET_PACKAGES;
 188             }
 189
 190             if (!rename 'Packages', "Packages.$site->[0].$dist") {
 191                 print "  Couldn't rename Packages to Packages.$site->[0].$dist";
 192                 die 'error';
 193             } else {
 194                 # set local Packages file to same date as the one it mirrors
 195                 # to allow comparison to work.
 196                 utime $newest_pack_date, $newest_pack_date, "Packages.$site->[0].$dist";
 197                 $packages_modified = 1;
 198             }
 199         }
 200         push @pkgfiles, "Packages.$site->[0].$dist";
 201     }
 202     $ftp->quit();
 203  }
 204 }
 205
 206 eval {
 207     local $SIG{INT} = sub {
 208         die "interrupted!\n";
 209     };
 210     download();
 211 };
 212 if($@) {
 213     $ftp->quit() if (ref($ftp));
 214     if($@ =~ /timeout/i) {
 215         print "FTP TIMEOUT\n";
 216     } else {
 217         print "FTP ERROR - $@\n";
 218     }
 219     $exit = 1;
 220 };
 221
 222 # Don't clear if nothing changed.
 223 if ($packages_modified) {
 224     print <<'EOM';
 225
 226 It is a good idea to clear the available list of old packages.
 227 However if you have only downloaded a Package files from non-main
 228 distributions you might not want to do this.
 229
 230 EOM
 231     if (yesno ('y', 'Do you want to clear available list')) {
 232         print "Clearing...\n";
 233         if (system('dpkg', '--clear-avail')) {
 234             print 'dpkg --clear-avail failed.';
 235             die 'error';
 236         }
 237     }
 238 }
 239
 240 if (!$packages_modified) {
 241     print "No Packages files was updated.\n";
 242 } else {
 243     foreach my $file (@pkgfiles) {
 244         if (system('dpkg', '--merge-avail', $file)) {
 245             print "Dpkg merge available failed on $file";
 246             $exit = 1;
 247         }
 248     }
 249 }
 250 exit $exit;