~mdw / dpkg / blame
| Commit | Line | Data |
|---|---|---|
| 1479465f GJ |
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 ($site->[0], #$::ftpsite, | |
| 342 | $site->[4], #$::username, | |
| 343 | $site->[5], #$::password, | |
| 344 | $site->[1], #$::ftpdir, | |
| 345 | $site->[3], #$::passive, | |
| 346 | $CONFIG{use_auth_proxy}, | |
| 347 | $CONFIG{proxyhost}, | |
| 348 | $CONFIG{proxylogname}, | |
| 349 | $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; |