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             } else {
 301                 if(yesno($def, $downloads{$fn}
 302                          ? "download: $fn ${rsize}k/${csize}k (total = ${totsize}k)"
 303                          : "download: $fn ${rsize}k (total = ${totsize}k)")) {
 304                     $def = 'y';
 305                     $totsize += $rsize;
 306                 } else {
 307                     $def = 'n';
 308                     delete $downloads{$fn};
 309                 }
 310             }
 311         }
 312     }
 313 }
 314
 315 sub download() {
 316  my $i = 0;
 317
 318  foreach my $site (@{$CONFIG{site}}) {
 319     my @getfiles = grep { $pkgfiles{$_}[2] == $i } keys %downloads;
 320     my @pre_dist = (); # Directory to add before $fn
 321
 322     #Scan distributions for looking at "(../)+/dir/dir"
 323     my ($n,$cp);
 324     $cp = -1;
 325     foreach (@{$site->[2]}) {
 326       $cp++;
 327       $pre_dist[$cp] = '';
 328       $n = (s{\.\./}{../}g);
 329       next if (! $n);
 330       if (m<^((?:\.\./){$n}(?:[^/]+/){$n})>) {
 331         $pre_dist[$cp] = $1;
 332       }
 333     }
 334
 335     if (! @getfiles) { $i++; next; }
 336
 337     $ftp = do_connect(ftpsite => $site->[0],
 338                       ftpdir => $site->[1],
 339                       passive => $site->[3],
 340                       username =>  $site->[4],
 341                       password => $site->[5],
 342                       useproxy => $CONFIG{use_auth_proxy},
 343                       proxyhost => $CONFIG{proxyhost},
 344                       proxylogname => $CONFIG{proxylogname},
 345                       proxypassword => $CONFIG{proxypassword});
 346
 347     local $SIG{INT} = sub { die "Interrupted !\n"; };
 348
 349     my ($rsize, $res, $pre);
 350     foreach my $fn (@getfiles) {
 351         $pre = $pre_dist[$pkgfiles{$fn}[3]] || '';
 352         if ($downloads{$fn}) {
 353             $rsize = ${pkgfiles{$fn}}[1] - $downloads{$fn};
 354             print "getting: $pre$fn (" . nb($rsize) . '/' .
 355                   nb($pkgfiles{$fn}[1]) . ")\n";
 356         } else {
 357             print "getting: $pre$fn (". nb($pkgfiles{$fn}[1]) . ")\n";
 358         }
 359         $res = $ftp->get("$pre$fn", "$dldir/$fn", $downloads{$fn});
 360         if(! $res) {
 361             my $r = $ftp->code();
 362             print $ftp->message() . "\n";
 363             if (!($r == 550 || $r == 450)) {
 364                 return 1;
 365             } else {
 366               #Try to find another file or this package
 367               print "Looking for another version of the package...\n";
 368               my ($dir, $package) = ($fn =~ m{^(.*)/([^/]+)_[^/]+.deb$});
 369               my $list = $ftp->ls("$pre$dir");
 370               if ($ftp->ok() && ref($list)) {
 371                 foreach my $file (@{$list}) {
 372                   if ($file =~ m/($dir\/\Q$package\E_[^\/]+.deb)/i) {
 373                     print "Package found : $file\n";
 374                     print "getting: $file (size not known)\n";
 375                     $res = $ftp->get($file, "$dldir/$1");
 376                     if (! $res) {
 377                       $r = $ftp->code();
 378                       print $ftp->message() . "\n";
 379                       return 1 if ($r != 550 and $r != 450);
 380                     }
 381                   }
 382                 }
 383               }
 384             }
 385         }
 386         # fully got, remove it from list in case we have to re-download
 387         delete $downloads{$fn};
 388     }
 389     $ftp->quit();
 390     $i++;
 391  }
 392  return 0;
 393 }
 394
 395 # download stuff (protect from ^C)
 396 if($totsize != 0) {
 397     if (yesno('y', "\nDo you want to download the required files")) {
 398       DOWNLOAD_TRY: while (1) {
 399           print "Downloading files... use ^C to stop\n";
 400           eval {
 401               if ((download() == 1) &&
 402                   yesno('y', "\nDo you want to retry downloading at once")) {
 403                   next DOWNLOAD_TRY;
 404               }
 405           };
 406           if($@ =~ /Interrupted|Timeout/i ) {
 407               # close the FTP connection if needed
 408               if ((ref($ftp) =~ /Net::FTP/) and ($@ =~ /Interrupted/i)) {
 409                 $ftp->abort();
 410                 $ftp->quit();
 411                 undef $ftp;
 412               }
 413               print "FTP ERROR\n";
 414               if (yesno('y', "\nDo you want to retry downloading at once")) {
 415                   # get the first $fn that foreach would give:
 416                   # this is the one that got interrupted.
 417                 my $fn;
 418                 MY_ITER: foreach my $ffn (keys(%downloads)) {
 419                     $fn = $ffn;
 420                     last MY_ITER;
 421                 }
 422                 my $size = -s "$dldir/$fn";
 423                 # partial download
 424                 if (yesno('y', "continue file: $fn (at $size)")) {
 425                     $downloads{$fn} = $size;
 426                 } else {
 427                     $downloads{$fn} = 0;
 428                 }
 429                 next DOWNLOAD_TRY;
 430               } else {
 431                 $exit = 1;
 432                 last DOWNLOAD_TRY;
 433               }
 434           } elsif ($@) {
 435              print "An error occurred ($@) : stopping download\n";
 436           }
 437           last DOWNLOAD_TRY;
 438       }
 439     }
 440 }
 441
 442 # remove duplicate packages (keep latest versions)
 443 # move half downloaded files out of the way
 444 # delete corrupted files
 445 print "\nProcessing downloaded files...(for corrupt/old/partial)\n";
 446 my %vers; # package => version
 447 my %files; # package-version => files...
 448
 449 # check a deb or split deb file
 450 # return 1 if it a deb file, 2 if it is a split deb file
 451 # else 0
 452 sub chkdeb($) {
 453     my ($fn) = @_;
 454     # check to see if it is a .deb file
 455     if (!system "dpkg-deb --info $fn >/dev/null 2>&1 && dpkg-deb --contents $fn >/dev/null 2>&1") {
 456         return 1;
 457     } elsif (!system "dpkg-split --info $fn >/dev/null 2>&1") {
 458         return 2;
 459     }
 460     return 0;
 461 }
 462 sub getdebinfo($) {
 463     my ($fn) = @_;
 464     my $type = chkdeb($fn);
 465     my ($pkg, $ver);
 466     if($type == 1) {
 467         open(my $pkgfile_fh, '-|', "dpkg-deb --field $fn")
 468             or die "cannot create pipe for 'dpkg-deb --field $fn'";
 469         my %fields = get_stanza($pkgfile_fh);
 470         close($pkgfile_fh);
 471         $pkg = $fields{'package'};
 472         $ver = $fields{'version'};
 473         return $pkg, $ver;
 474     } elsif ( $type == 2) {
 475         open(my $pkgfile_fh, '-|', "dpkg-split --info $fn")
 476             or die "cannot create pipe for 'dpkg-split --info $fn'";
 477         while (<$pkgfile_fh>) {
 478             /Part of package:\s*(\S+)/ and $pkg = $1;
 479             /\.\.\. version:\s*(\S+)/ and $ver = $1;
 480         }
 481         close($pkgfile_fh);
 482         return $pkg, $ver;
 483     }
 484     print "could not figure out type of $fn\n";
 485     return $pkg, $ver;
 486 }
 487
 488 # process deb file to make sure we only keep latest versions
 489 sub prcdeb($$) {
 490     my ($dir, $fn) = @_;
 491     my ($pkg, $ver) = getdebinfo($fn);
 492     if(!defined($pkg) || !defined($ver)) {
 493         print "could not get package info from file\n";
 494         return 0;
 495     }
 496     if($vers{$pkg}) {
 497         if (dcmpvers($vers{$pkg}, 'eq', $ver)) {
 498             $files{$pkg . $ver} = [ $files{$pkg . $ver }, "$dir/$fn" ];
 499         } elsif (dcmpvers($vers{$pkg}, 'gt', $ver)) {
 500             print "old version\n";
 501             unlink $fn;
 502         } else { # else $ver is gt current version
 503             foreach my $c (@{$files{$pkg . $vers{$pkg}}}) {
 504                 print "replaces: $c\n";
 505                 unlink "$vardir/methods/ftp/$dldir/$c";
 506             }
 507             $vers{$pkg} = $ver;
 508             $files{$pkg . $ver} = [ "$dir/$fn" ];
 509         }
 510     } else {
 511         $vers{$pkg} = $ver;
 512         $files{$pkg . $ver} = [ "$dir/$fn" ];
 513     }
 514 }
 515
 516 sub prcfile() {
 517     my ($fn) = $_;
 518     if (-f $fn and $fn ne '.') {
 519         my $dir = '.';
 520         if (length($File::Find::dir) > length($dldir)) {
 521             $dir = substr($File::Find::dir, length($dldir)+1);
 522         }
 523         print "$dir/$fn\n";
 524         if(defined($pkgfiles{"$dir/$fn"})) {
 525             my @info = @{$pkgfiles{"$dir/$fn"}};
 526             my $size = -s $fn;
 527             if($size == 0) {
 528                 print "zero length file\n";
 529                 unlink $fn;
 530             } elsif($size < $info[1]) {
 531                 print "partial file\n";
 532                 rename $fn, "$fn.partial";
 533             } elsif(( (exists $md5sums{"$dldir/$fn"})
 534                       and ($md5sums{"$dldir/$fn"} ne $info[0]) )
 535                      or
 536                     (md5sum($fn) ne $info[0])) {
 537                 print "corrupt file\n";
 538                 unlink $fn;
 539             } else {
 540                 prcdeb($dir, $fn);
 541             }
 542         } elsif($fn =~ /.deb$/) {
 543             if(chkdeb($fn)) {
 544                 prcdeb($dir, $fn);
 545             } else {
 546                 print "corrupt file\n";
 547                 unlink $fn;
 548             }
 549         } else {
 550             print "non-debian file\n";
 551         }
 552     }
 553 }
 554 find(\&prcfile, "$dldir/");
 555
 556 # install .debs
 557 if (yesno('y', "\nDo you want to install the files fetched")) {
 558     print "Installing files...\n";
 559     #Installing pre-dependent package before !
 560     my (@flds, $package, @filename, $r);
 561     while (@flds = qx(dpkg --predep-package), $? == 0) {
 562       foreach my $field (@flds) {
 563         $field =~ s/\s*\n//;
 564         $package = $field if $field =~ s/^Package: //i;
 565         @filename = split / +/, $field if $field =~ s/^Filename: //i;
 566       }
 567       @filename = map { "$dldir/$_" } @filename;
 568       next if (! @filename);
 569       $r = system('dpkg', '-iB', '--', @filename);
 570       if ($r) { print "DPKG ERROR\n"; $exit = 1; }
 571     }
 572     #Installing other packages after
 573     $r = system('dpkg', '-iGREOB', $dldir);
 574     if($r) {
 575         print "DPKG ERROR\n";
 576         $exit = 1;
 577     }
 578 }
 579
 580 sub removeinstalled {
 581     my $fn = $_;
 582     if (-f $fn and $fn ne '.') {
 583         my $dir = '.';
 584         if (length($File::Find::dir) > length($dldir)) {
 585             $dir = substr($File::Find::dir, length($dldir)+1);
 586         }
 587         if($fn =~ /.deb$/) {
 588             my($pkg, $ver) = getdebinfo($fn);
 589             if(!defined($pkg) || !defined($ver)) {
 590                 print "Could not get info for: $dir/$fn\n";
 591             } else {
 592                 if ($curpkgs{$pkg} and dcmpvers($ver, 'le', $curpkgs{$pkg})) {
 593                     print "deleting: $dir/$fn\n";
 594                     unlink $fn;
 595                 } else {
 596                     print "leaving: $dir/$fn\n";
 597                 }
 598             }
 599         } else {
 600             print "non-debian: $dir/$fn\n";
 601         }
 602     }
 603 }
 604
 605 # remove .debs that have been installed (query user)
 606 # first need to reprocess status file
 607 if (yesno('y', "\nDo you wish to delete the installed package (.deb) files?")) {
 608     print "Removing installed files...\n";
 609     %curpkgs = ();
 610     procstatus();
 611     find(\&removeinstalled, "$dldir/");
 612 }
 613
 614 # remove whole ./debian directory if user wants to
 615 if (yesno('n', "\nDo you want to remove $dldir directory?")) {
 616     remove_tree($dldir);
 617 }
 618
 619 #Store useful md5sums
 620 foreach my $file (keys %md5sums) {
 621   next if -f $file;
 622   delete $md5sums{$file};
 623 }
 624 file_dump("$methdir/md5sums", Dumper(\%md5sums));
 625
 626 exit $exit;