dselect/methods/ftp/install.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 use File::Path qw(make_path remove_tree);
  24 use File::Basename;
  25
  26 eval q{
  27     use File::Find;
  28     use Data::Dumper;
  29
  30     use Dpkg::File;
  31 };
  32 if ($@) {
  33     warn "Missing Dpkg modules required by the FTP access method.\n\n";
  34     exit 1;
  35 }
  36
  37 use Dselect::Method;
  38 use Dselect::Method::Ftp;
  39
  40 my $ftp;
  41
  42 # exit value
  43 my $exit = 0;
  44
  45 # deal with arguments
  46 my $vardir = $ARGV[0];
  47 my $method = $ARGV[1];
  48 my $option = $ARGV[2];
  49
  50 if ($option eq 'manual') {
  51   print "manual mode not supported yet\n";
  52   exit 1;
  53 }
  54 #print "vardir: $vardir, method: $method, option: $option\n";
  55
  56 my $methdir = "$vardir/methods/ftp";
  57
  58 # get info from control file
  59 read_config("$methdir/vars");
  60
  61 chdir "$methdir";
  62 make_path("$methdir/$CONFIG{dldir}", { mode => 0755 });
  63
  64
  65 #Read md5sums already calculated
  66 my %md5sums;
  67 if (-f "$methdir/md5sums") {
  68   my $code = file_slurp("$methdir/md5sums");
  69   my $VAR1; ## no critic (Variables::ProhibitUnusedVariables)
  70   my $res = eval $code;
  71   if ($@) {
  72     die "couldn't eval $methdir/md5sums content: $@\n";
  73   }
  74   if (ref($res)) { %md5sums = %{$res} }
  75 }
  76
  77 # Get a stanza.
  78 # returns a ref to a hash containing flds->fld contents
  79 # white space from the ends of lines is removed and newlines added
  80 # (no trailing newline).
  81 # die's if something unexpected happens
  82 sub get_stanza {
  83     my $fh = shift;
  84     my %flds;
  85     my $fld;
  86     while (<$fh>) {
  87         if (length != 0) {
  88             FLDLOOP: while (1) {
  89                 if ( /^(\S+):\s*(.*)\s*$/ ) {
  90                     $fld = lc($1);
  91                     $flds{$fld} = $2;
  92                     while (<$fh>) {
  93                         if (length == 0) {
  94                             return %flds;
  95                         } elsif ( /^(\s.*)$/ ) {
  96                             $flds{$fld} = $flds{$fld} . "\n" . $1;
  97                         } else {
  98                             next FLDLOOP;
  99                         }
 100                     }
 101                     return %flds;
 102                 } else {
 103                     die "expected a start of field line, but got:\n$_";
 104                 }
 105             }
 106         }
 107     }
 108     return %flds;
 109 }
 110
 111 # process status file
 112 # create curpkgs hash with version (no version implies not currently installed)
 113 # of packages we want
 114 print "Processing status file...\n";
 115 my %curpkgs;
 116 sub procstatus {
 117     my (%flds, $fld);
 118     open(my $status_fh, '<', "$vardir/status") or
 119         die 'Could not open status file';
 120     while (%flds = get_stanza($status_fh), %flds) {
 121         if($flds{'status'} =~ /^install ok/) {
 122             my $cs = (split(/ /, $flds{'status'}))[2];
 123             if (($cs eq 'not-installed') ||
 124                 ($cs eq 'half-installed') ||
 125                 ($cs eq 'config-files')) {
 126                 $curpkgs{$flds{'package'}} = '';
 127             } else {
 128                 $curpkgs{$flds{'package'}} = $flds{'version'};
 129             }
 130         }
 131     }
 132     close($status_fh);
 133 }
 134 procstatus();
 135
 136 sub dcmpvers {
 137     my($a, $p, $b) = @_;
 138     my ($r);
 139     $r = system('dpkg', '--compare-versions', "$a", "$p", "$b");
 140     $r = $r/256;
 141     if ($r == 0) {
 142         return 1;
 143     } elsif ($r == 1) {
 144         return 0;
 145     }
 146     die "dpkg --compare-versions $a $p $b - failed with $r";
 147 }
 148
 149 # process package files, looking for packages to install
 150 # create a hash of these packages pkgname => version, filenames...
 151 # filename => md5sum, size
 152 # for all packages
 153 my %pkgs;
 154 my %pkgfiles;
 155 sub procpkgfile {
 156     my $fn = shift;
 157     my $site = shift;
 158     my $dist = shift;
 159     my (@files, @sizes, @md5sums, $pkg, $ver, $nfs, $fld);
 160     my(%flds);
 161     open(my $pkgfile_fh, '<', $fn) or die "could not open package file $fn";
 162     while (%flds = get_stanza($pkgfile_fh), %flds) {
 163         $pkg = $flds{'package'};
 164         $ver = $curpkgs{$pkg};
 165         @files = split(/[\s\n]+/, $flds{'filename'});
 166         @sizes = split(/[\s\n]+/, $flds{'size'});
 167         @md5sums = split(/[\s\n]+/, $flds{'md5sum'});
 168         if (defined($ver) && (($ver eq '') || dcmpvers($ver, 'lt', $flds{'version'}))) {
 169             $pkgs{$pkg} = [ $flds{'version'}, [ @files ], $site ];
 170             $curpkgs{$pkg} = $flds{'version'};
 171         }
 172         $nfs = scalar(@files);
 173         if(($nfs != scalar(@sizes)) || ($nfs != scalar(@md5sums)) ) {
 174             print "Different number of filenames, sizes and md5sums for $flds{'package'}\n";
 175         } else {
 176             my $i = 0;
 177             foreach my $fl (@files) {
 178                 $pkgfiles{$fl} = [ $md5sums[$i], $sizes[$i], $site, $dist ];
 179                 $i++;
 180             }
 181         }
 182     }
 183     close $pkgfile_fh or die "cannot close package file $fn: $!\n";
 184 }
 185
 186 print "\nProcessing Package files...\n";
 187 my ($i, $j);
 188 $i = 0;
 189 foreach my $site (@{$CONFIG{site}}) {
 190   $j = 0;
 191   foreach my $dist (@{$site->[2]}) {
 192     my $fn = $dist;
 193     $fn =~ tr#/#_#;
 194     $fn = "Packages.$site->[0].$fn";
 195     if (-f $fn) {
 196         print " $site->[0] $dist...\n";
 197         procpkgfile($fn,$i,$j);
 198     } else {
 199         print "Could not find packages file for $site->[0] $dist distribution (re-run Update)\n"
 200     }
 201     $j++;
 202   }
 203   $i++;
 204 }
 205
 206 my $dldir = $CONFIG{dldir};
 207 # md5sum
 208 sub md5sum {
 209     my $fn = shift;
 210     my $m = qx(md5sum $fn);
 211     $m = (split(' ', $m))[0];
 212     $md5sums{"$dldir/$fn"} = $m;
 213     return $m;
 214 }
 215
 216 # construct list of files to get
 217 # hash of filenames => size of downloaded part
 218 # query user for each partial file
 219 print "\nConstructing list of files to get...\n";
 220 my %downloads;
 221 my ($dir, @info, @files, $csize, $size);
 222 my $totsize = 0;
 223 foreach my $pkg (keys(%pkgs)) {
 224     @files = @{$pkgs{$pkg}[1]};
 225     foreach my $fn (@files) {
 226         #Look for a partial file
 227         if (-f "$dldir/$fn.partial") {
 228           rename "$dldir/$fn.partial", "$dldir/$fn";
 229         }
 230         $dir = dirname($fn);
 231         if(! -d "$dldir/$dir") {
 232             make_path("$dldir/$dir", { mode => 0755 });
 233         }
 234         @info = @{$pkgfiles{$fn}};
 235         $csize = int($info[1]/1024)+1;
 236         if(-f "$dldir/$fn") {
 237             $size = -s "$dldir/$fn";
 238             if($info[1] > $size) {
 239                 # partial download
 240                 if (yesno('y', "continue file: $fn (" . nb($size) . '/' .
 241                                nb($info[1]) . ')')) {
 242                     $downloads{$fn} = $size;
 243                     $totsize += $csize - int($size/1024);
 244                 } else {
 245                     $downloads{$fn} = 0;
 246                     $totsize += $csize;
 247                 }
 248             } else {
 249                 # check md5sum
 250                 if (! exists $md5sums{"$dldir/$fn"}) {
 251                   $md5sums{"$dldir/$fn"} = md5sum("$dldir/$fn");
 252                 }
 253                 if ($md5sums{"$dldir/$fn"} eq $info[0]) {
 254                     print "already got: $fn\n";
 255                 } else {
 256                     print "corrupted: $fn\n";
 257                     $downloads{$fn} = 0;
 258                 }
 259             }
 260         } else {
 261             my $ffn = $fn;
 262             $ffn =~ s/binary-[^\/]+/.../;
 263             print 'want: ' .
 264                   $CONFIG{site}[$pkgfiles{$fn}[2]][0] . " $ffn (${csize}k)\n";
 265             $downloads{$fn} = 0;
 266             $totsize += $csize;
 267         }
 268     }
 269 }
 270
 271 my $avsp = qx(df -Pk $dldir| awk '{ print \$4}' | tail -n 1);
 272 chomp $avsp;
 273
 274 print "\nApproximate total space required: ${totsize}k\n";
 275 print "Available space in $dldir: ${avsp}k\n";
 276
 277 #$avsp = qx(df -k $::dldir| paste -s | awk '{ print \$11});
 278 #chomp $avsp;
 279
 280 if($totsize == 0) {
 281     print 'Nothing to get.';
 282 } else {
 283     if($totsize > $avsp) {
 284         print "Space required is greater than available space,\n";
 285         print "you will need to select which items to get.\n";
 286     }
 287 # ask user which files to get
 288     if (($totsize > $avsp) ||
 289         yesno('n', 'Do you want to select the files to get')) {
 290         $totsize = 0;
 291         my @files = sort(keys(%downloads));
 292         my $def = 'y';
 293         foreach my $fn (@files) {
 294             my @info = @{$pkgfiles{$fn}};
 295             my $csize = int($info[1] / 1024) + 1;
 296             my $rsize = int(($info[1] - $downloads{$fn}) / 1024) + 1;
 297             if ($rsize + $totsize > $avsp) {
 298                 print "no room for: $fn\n";
 299                 delete $downloads{$fn};
 300             } elsif (yesno($def, $downloads{$fn}
 301                            ? "download: $fn ${rsize}k/${csize}k (total = ${totsize}k)"
 302                            : "download: $fn ${rsize}k (total = ${totsize}k)")) {
 303                 $def = 'y';
 304                 $totsize += $rsize;
 305             } else {
 306                 $def = 'n';
 307                 delete $downloads{$fn};
 308             }
 309         }
 310     }
 311 }
 312
 313 sub download {
 314  my $i = 0;
 315
 316  foreach my $site (@{$CONFIG{site}}) {
 317     my @getfiles = grep { $pkgfiles{$_}[2] == $i } keys %downloads;
 318     my @pre_dist = (); # Directory to add before $fn
 319
 320     #Scan distributions for looking at "(../)+/dir/dir"
 321     my ($n,$cp);
 322     $cp = -1;
 323     foreach (@{$site->[2]}) {
 324       $cp++;
 325       $pre_dist[$cp] = '';
 326       $n = (s{\.\./}{../}g);
 327       next if (! $n);
 328       if (m<^((?:\.\./){$n}(?:[^/]+/){$n})>) {
 329         $pre_dist[$cp] = $1;
 330       }
 331     }
 332
 333     if (! @getfiles) { $i++; next; }
 334
 335     $ftp = do_connect(ftpsite => $site->[0],
 336                       ftpdir => $site->[1],
 337                       passive => $site->[3],
 338                       username =>  $site->[4],
 339                       password => $site->[5],
 340                       useproxy => $CONFIG{use_auth_proxy},
 341                       proxyhost => $CONFIG{proxyhost},
 342                       proxylogname => $CONFIG{proxylogname},
 343                       proxypassword => $CONFIG{proxypassword});
 344
 345     local $SIG{INT} = sub { die "Interrupted !\n"; };
 346
 347     my ($rsize, $res, $pre);
 348     foreach my $fn (@getfiles) {
 349         $pre = $pre_dist[$pkgfiles{$fn}[3]] || '';
 350         if ($downloads{$fn}) {
 351             $rsize = ${pkgfiles{$fn}}[1] - $downloads{$fn};
 352             print "getting: $pre$fn (" . nb($rsize) . '/' .
 353                   nb($pkgfiles{$fn}[1]) . ")\n";
 354         } else {
 355             print "getting: $pre$fn (". nb($pkgfiles{$fn}[1]) . ")\n";
 356         }
 357         $res = $ftp->get("$pre$fn", "$dldir/$fn", $downloads{$fn});
 358         if(! $res) {
 359             my $r = $ftp->code();
 360             print $ftp->message() . "\n";
 361             if (!($r == 550 || $r == 450)) {
 362                 return 1;
 363             } else {
 364               #Try to find another file or this package
 365               print "Looking for another version of the package...\n";
 366               my ($dir, $package) = ($fn =~ m{^(.*)/([^/]+)_[^/]+.deb$});
 367               my $list = $ftp->ls("$pre$dir");
 368               if ($ftp->ok() && ref($list)) {
 369                 foreach my $file (@{$list}) {
 370                   if ($file =~ m/($dir\/\Q$package\E_[^\/]+.deb)/i) {
 371                     print "Package found : $file\n";
 372                     print "getting: $file (size not known)\n";
 373                     $res = $ftp->get($file, "$dldir/$1");
 374                     if (! $res) {
 375                       $r = $ftp->code();
 376                       print $ftp->message() . "\n";
 377                       return 1 if ($r != 550 and $r != 450);
 378                     }
 379                   }
 380                 }
 381               }
 382             }
 383         }
 384         # fully got, remove it from list in case we have to re-download
 385         delete $downloads{$fn};
 386     }
 387     $ftp->quit();
 388     $i++;
 389  }
 390  return 0;
 391 }
 392
 393 # download stuff (protect from ^C)
 394 if($totsize != 0) {
 395     if (yesno('y', "\nDo you want to download the required files")) {
 396       DOWNLOAD_TRY: while (1) {
 397           print "Downloading files... use ^C to stop\n";
 398           eval {
 399               if ((download() == 1) &&
 400                   yesno('y', "\nDo you want to retry downloading at once")) {
 401                   next DOWNLOAD_TRY;
 402               }
 403           };
 404           if($@ =~ /Interrupted|Timeout/i ) {
 405               # close the FTP connection if needed
 406               if ((ref($ftp) =~ /Net::FTP/) and ($@ =~ /Interrupted/i)) {
 407                 $ftp->abort();
 408                 $ftp->quit();
 409                 undef $ftp;
 410               }
 411               print "FTP ERROR\n";
 412               if (yesno('y', "\nDo you want to retry downloading at once")) {
 413                   # get the first $fn that foreach would give:
 414                   # this is the one that got interrupted.
 415                 my $fn;
 416                 MY_ITER: foreach my $ffn (keys(%downloads)) {
 417                     $fn = $ffn;
 418                     last MY_ITER;
 419                 }
 420                 my $size = -s "$dldir/$fn";
 421                 # partial download
 422                 if (yesno('y', "continue file: $fn (at $size)")) {
 423                     $downloads{$fn} = $size;
 424                 } else {
 425                     $downloads{$fn} = 0;
 426                 }
 427                 next DOWNLOAD_TRY;
 428               } else {
 429                 $exit = 1;
 430                 last DOWNLOAD_TRY;
 431               }
 432           } elsif ($@) {
 433              print "An error occurred ($@) : stopping download\n";
 434           }
 435           last DOWNLOAD_TRY;
 436       }
 437     }
 438 }
 439
 440 # remove duplicate packages (keep latest versions)
 441 # move half downloaded files out of the way
 442 # delete corrupted files
 443 print "\nProcessing downloaded files...(for corrupt/old/partial)\n";
 444 my %vers; # package => version
 445 my %files; # package-version => files...
 446
 447 # check a deb or split deb file
 448 # return 1 if it a deb file, 2 if it is a split deb file
 449 # else 0
 450 sub chkdeb {
 451     my ($fn) = @_;
 452     # check to see if it is a .deb file
 453     if (!system "dpkg-deb --info $fn >/dev/null 2>&1 && dpkg-deb --contents $fn >/dev/null 2>&1") {
 454         return 1;
 455     } elsif (!system "dpkg-split --info $fn >/dev/null 2>&1") {
 456         return 2;
 457     }
 458     return 0;
 459 }
 460 sub getdebinfo {
 461     my ($fn) = @_;
 462     my $type = chkdeb($fn);
 463     my ($pkg, $ver);
 464     if($type == 1) {
 465         open(my $pkgfile_fh, '-|', "dpkg-deb --field $fn")
 466             or die "cannot create pipe for 'dpkg-deb --field $fn'";
 467         my %fields = get_stanza($pkgfile_fh);
 468         close($pkgfile_fh);
 469         $pkg = $fields{'package'};
 470         $ver = $fields{'version'};
 471         return $pkg, $ver;
 472     } elsif ( $type == 2) {
 473         open(my $pkgfile_fh, '-|', "dpkg-split --info $fn")
 474             or die "cannot create pipe for 'dpkg-split --info $fn'";
 475         while (<$pkgfile_fh>) {
 476             /Part of package:\s*(\S+)/ and $pkg = $1;
 477             /\.\.\. version:\s*(\S+)/ and $ver = $1;
 478         }
 479         close($pkgfile_fh);
 480         return $pkg, $ver;
 481     }
 482     print "could not figure out type of $fn\n";
 483     return $pkg, $ver;
 484 }
 485
 486 # process deb file to make sure we only keep latest versions
 487 sub prcdeb {
 488     my ($dir, $fn) = @_;
 489     my ($pkg, $ver) = getdebinfo($fn);
 490     if(!defined($pkg) || !defined($ver)) {
 491         print "could not get package info from file\n";
 492         return 0;
 493     }
 494     if($vers{$pkg}) {
 495         if (dcmpvers($vers{$pkg}, 'eq', $ver)) {
 496             $files{$pkg . $ver} = [ $files{$pkg . $ver }, "$dir/$fn" ];
 497         } elsif (dcmpvers($vers{$pkg}, 'gt', $ver)) {
 498             print "old version\n";
 499             unlink $fn;
 500         } else { # else $ver is gt current version
 501             foreach my $c (@{$files{$pkg . $vers{$pkg}}}) {
 502                 print "replaces: $c\n";
 503                 unlink "$vardir/methods/ftp/$dldir/$c";
 504             }
 505             $vers{$pkg} = $ver;
 506             $files{$pkg . $ver} = [ "$dir/$fn" ];
 507         }
 508     } else {
 509         $vers{$pkg} = $ver;
 510         $files{$pkg . $ver} = [ "$dir/$fn" ];
 511     }
 512 }
 513
 514 sub prcfile {
 515     my ($fn) = $_;
 516     if (-f $fn and $fn ne '.') {
 517         my $dir = '.';
 518         if (length($File::Find::dir) > length($dldir)) {
 519             $dir = substr($File::Find::dir, length($dldir)+1);
 520         }
 521         print "$dir/$fn\n";
 522         if(defined($pkgfiles{"$dir/$fn"})) {
 523             my @info = @{$pkgfiles{"$dir/$fn"}};
 524             my $size = -s $fn;
 525             if($size == 0) {
 526                 print "zero length file\n";
 527                 unlink $fn;
 528             } elsif($size < $info[1]) {
 529                 print "partial file\n";
 530                 rename $fn, "$fn.partial";
 531             } elsif(( (exists $md5sums{"$dldir/$fn"})
 532                       and ($md5sums{"$dldir/$fn"} ne $info[0]) )
 533                      or
 534                     (md5sum($fn) ne $info[0])) {
 535                 print "corrupt file\n";
 536                 unlink $fn;
 537             } else {
 538                 prcdeb($dir, $fn);
 539             }
 540         } elsif($fn =~ /.deb$/) {
 541             if(chkdeb($fn)) {
 542                 prcdeb($dir, $fn);
 543             } else {
 544                 print "corrupt file\n";
 545                 unlink $fn;
 546             }
 547         } else {
 548             print "non-debian file\n";
 549         }
 550     }
 551 }
 552 find(\&prcfile, "$dldir/");
 553
 554 # install .debs
 555 if (yesno('y', "\nDo you want to install the files fetched")) {
 556     print "Installing files...\n";
 557     #Installing pre-dependent package before !
 558     my (@flds, $package, @filename, $r);
 559     while (@flds = qx(dpkg --predep-package), $? == 0) {
 560       foreach my $field (@flds) {
 561         $field =~ s/\s*\n//;
 562         $package = $field if $field =~ s/^Package: //i;
 563         @filename = split / +/, $field if $field =~ s/^Filename: //i;
 564       }
 565       @filename = map { "$dldir/$_" } @filename;
 566       next if (! @filename);
 567       $r = system('dpkg', '-iB', '--', @filename);
 568       if ($r) { print "DPKG ERROR\n"; $exit = 1; }
 569     }
 570     #Installing other packages after
 571     $r = system('dpkg', '-iGREOB', $dldir);
 572     if($r) {
 573         print "DPKG ERROR\n";
 574         $exit = 1;
 575     }
 576 }
 577
 578 sub removeinstalled {
 579     my $fn = $_;
 580     if (-f $fn and $fn ne '.') {
 581         my $dir = '.';
 582         if (length($File::Find::dir) > length($dldir)) {
 583             $dir = substr($File::Find::dir, length($dldir)+1);
 584         }
 585         if($fn =~ /.deb$/) {
 586             my($pkg, $ver) = getdebinfo($fn);
 587             if(!defined($pkg) || !defined($ver)) {
 588                 print "Could not get info for: $dir/$fn\n";
 589             } elsif ($curpkgs{$pkg} and dcmpvers($ver, 'le', $curpkgs{$pkg})) {
 590                 print "deleting: $dir/$fn\n";
 591                 unlink $fn;
 592             } else {
 593                 print "leaving: $dir/$fn\n";
 594             }
 595         } else {
 596             print "non-debian: $dir/$fn\n";
 597         }
 598     }
 599 }
 600
 601 # remove .debs that have been installed (query user)
 602 # first need to reprocess status file
 603 if (yesno('y', "\nDo you wish to delete the installed package (.deb) files?")) {
 604     print "Removing installed files...\n";
 605     %curpkgs = ();
 606     procstatus();
 607     find(\&removeinstalled, "$dldir/");
 608 }
 609
 610 # remove whole ./debian directory if user wants to
 611 if (yesno('n', "\nDo you want to remove $dldir directory?")) {
 612     remove_tree($dldir);
 613 }
 614
 615 #Store useful md5sums
 616 foreach my $file (keys %md5sums) {
 617   next if -f $file;
 618   delete $md5sums{$file};
 619 }
 620 file_dump("$methdir/md5sums", Dumper(\%md5sums));
 621
 622 exit $exit;