"Fossies" - the Fresh Open Source Software Archive

Member "dpkg-1.19.7/dselect/methods/ftp/install.pl" (19 Apr 2019, 17200 Bytes) of package /linux/misc/dpkg_1.19.7.tar.xz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "install.pl" see the Fossies "Dox" file reference documentation.

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