bin/extract_files

   1 #!/usr/bin/perl
   2 #
   3 # Script to extract files from Debian packages
   4 # Copyright 2004 Frank Lichtenheld
   5 #
   6 # based on a shell script which was
   7 # Copyright 2003 Noel Köthe
   8 # Copyright 2004 Martin Schulze <joey@debian.org>
   9 #
  10 #    This program is free software; you can redistribute it and/or modify
  11 #    it under the terms of the GNU General Public License as published by
  12 #    the Free Software Foundation; either version 2 of the License, or
  13 #    (at your option) any later version.
  14 #
  15 #    This program is distributed in the hope that it will be useful,
  16 #    but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 #    GNU General Public License for more details.
  19 #
  20 #    You should have received a copy of the GNU General Public License
  21 #    along with this program; if not, write to the Free Software
  22 #    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  23
  24 use strict;
  25 use warnings;
  26
  27 use FindBin;
  28 use lib "$FindBin::Bin/../lib";
  29 use lib "$FindBin::Bin";
  30
  31 use Getopt::Long;
  32 use File::Temp qw( tempdir );
  33 use File::Path;
  34 use File::Copy;
  35 use File::Basename;
  36 #use Digest::SHA1;
  37 use Deb::Versions;
  38 use Parse::DebControl;
  39 use Parse::DebianChangelog;
  40 use Cwd;
  41 use Fcntl qw(:DEFAULT :flock);
  42 use Data::Dumper;
  43 use DB_File;
  44
  45 use constant PKGPOOL => 1;
  46 use constant DIGESTPOOL => 2;
  47
  48 my $PROGNAME = 'extract_files';
  49 my $MAXWARN = 100;
  50 my $TEMPDIR;
  51
  52 my $directory = cwd()."/pool";
  53 my $dumpfile = '';
  54 my $cachefile = '';
  55 my $target = cwd()."/extracted_files";
  56 my $workdir = '';
  57 my $configdir = cwd()."/etc";
  58 my ( $verbose, $version, $help, $debug, $force, $use_dump );
  59
  60 my %opthash = (
  61                'verbose|v' => \$verbose,
  62                'force|f' => \$force,
  63                'directory|d=s' => \$directory,
  64                'config|c=s' => \$configdir,
  65                'target|t=s' => \$target,
  66                'workdir|w=s' => \$workdir,
  67                'cachefile=s' => \$cachefile,
  68                'dumpfile=s' => \$dumpfile,
  69                'use_dump' => \$use_dump,
  70                'version' => \$version,
  71                'debug' => \$debug,
  72                'help' => \$help,
  73                );
  74
  75 my (%src_packages, %bin_packages, %cache);
  76
  77 my %stats = (
  78     src_pkgs => 0,
  79     src_cache => 0,
  80     already_extracted => 0,
  81     bin_pkgs => 0,
  82     bin_cache => 0,
  83     );
  84
  85 Getopt::Long::config('no_getopt_compat', 'no_auto_abbrev');
  86
  87 GetOptions(%opthash) or do_error( "couldn't parse commandline parameters" );
  88
  89 $verbose ||= $debug;
  90 $directory =~ s,/+$,,o;
  91 if ($workdir) {
  92     $TEMPDIR = tempdir( 'pdo_extract_file.XXXXXX',
  93                         DIR => $workdir, CLEANUP => 1 );
  94 } else {
  95     $TEMPDIR = tempdir( 'pdo_extract_file.XXXXXX',
  96                         CLEANUP => 1 );
  97 }
  98
  99 ##################################################
 100 # OUTPUT/LOGGING
 101
 102 sub do_error {
 103     die "$PROGNAME: FATAL: @_\n";
 104 }
 105
 106 my $no_warnings = 0;
 107 sub do_warning {
 108     warn "$PROGNAME: WARNING: @_\n";
 109     if (++$no_warnings > $MAXWARN) {
 110         do_error( "too many warnings ($MAXWARN)" );
 111     }
 112 }
 113
 114 sub do_info {
 115     if ($verbose) {
 116         print "$PROGNAME: INFO: @_\n";
 117     }
 118 }
 119
 120 sub do_debug {
 121     if ($debug) {
 122         print "$PROGNAME: DEBUG: @_\n";
 123     }
 124 }
 125
 126 sub add_log {
 127     my $log  = shift;
 128
 129     do_debug( @_ );
 130     $$log .= localtime().": @_\n";
 131 }
 132
 133 ##################################################
 134 # PACKAGE HANDLING (UNPACKING/CLEANUP)
 135
 136 sub unpack_srcpkg {
 137     my ( $dscname, $log ) = @_;
 138
 139     chdir( $TEMPDIR ) or do_error( "couldn't change working directory to $TEMPDIR" );
 140
 141     add_log( $log, "dpkg-source -sn -x $dscname"  );
 142
 143     my $out = qx/dpkg-source -sn -x "$dscname" 2>&1/;
 144     my ($dir) = ($out =~ /(\S+)$/mo);
 145
 146     add_log( $log, "dpkg-source output: ", $out );
 147
 148 #Bug#246802
 149 #    system("dpkg-source", "-x", $dscname ) == 0
 150 #       or do {
 151 #           do_warning( "couldn't unpack $dscname" );
 152 #           add_log( $log, "couldn't unpack $dscname" );
 153 #           return;
 154 #       };
 155
 156     return $dir;
 157 }
 158
 159 sub unpack_binpkg {
 160     my ( $pkgname, $debname, $log ) = @_;
 161
 162     add_log( $log, "unpacking binary package $pkgname" );
 163
 164     mkdir( "$TEMPDIR/$pkgname" ) or do {
 165         do_warning( "couldn't create directory $TEMPDIR/$pkgname" );
 166         add_log( $log, "couldn't create directory $TEMPDIR/$pkgname" );
 167         return;
 168     };
 169
 170     add_log( $log, "dpkg-deb --extract $debname $TEMPDIR/$pkgname" );
 171
 172     system("dpkg-deb", "--extract", $debname, "$TEMPDIR/$pkgname" ) == 0
 173         or do {
 174             do_warning( "couldn't unpack $debname" );
 175             add_log( $log, "couldn't unpack $debname" );
 176             return;
 177         };
 178
 179     return 1;
 180 }
 181
 182 sub unpack_allbinpkg {
 183     my ($pkg_data, $log) = @_;
 184
 185     my %already_seen;
 186
 187     foreach my $pkg (@{$pkg_data->{bins}}) {
 188         next if $already_seen{$pkg->{bin_name}}; # some assumptions about sane version numbers included
 189
 190         unpack_binpkg($pkg->{bin_name}, $pkg->{deb}, $log );
 191
 192         $already_seen{$pkg->{bin_name}}++;
 193     }
 194 }
 195
 196 sub cleanup_binpkg {
 197     my ($pkg_data) = @_;
 198
 199     foreach my $pkg (keys %{$pkg_data->{bin_list}}) {
 200         # rmtree should do that itself, but there seems to be a bug somewhere
 201         system( "chmod", "-R", "u+rwx", "$TEMPDIR/$pkg" );
 202         rmtree( "$TEMPDIR/$pkg" );
 203     }
 204 }
 205
 206 ##################################################
 207 # POOL HANDLING
 208
 209 sub pkg_pool_directory {
 210     my ($pkg_data) = @_;
 211
 212     my $name = $pkg_data->{src_name};
 213     my $version = $pkg_data->{src_version};
 214     my $dscname = $pkg_data->{dsc};
 215
 216     my $dir = "";
 217
 218 # I would prefer $name_$version but lets be backward compatible
 219 # in case someone depends on the naming
 220     if ($name =~ /^(lib.)/o) {
 221 #       $dir .= "$1/$name/${name}_$version";
 222         $dir .= "$1/$name/".basename($dscname, '.dsc');
 223     } else {
 224 #       $dir .= substr($name,0,1)."/$name/${name}_$version";
 225         $dir .= substr($name,0,1)."/$name/".basename($dscname, '.dsc');
 226     }
 227
 228     return $dir;
 229 }
 230
 231 sub to_update {
 232     my ($pkg_data, $config_data, $log) = @_;
 233
 234     if ($config_data->{structure} == PKGPOOL) {
 235         my $dir = "$target/".pkg_pool_directory( $pkg_data );
 236         if (!$force && -d $dir && -f "$dir/log") {
 237             (system( "touch", "$dir/log" ) == 0)
 238                 or do_warning( "touch of $dir/log failed" );
 239             return 0;
 240         } else {
 241             rmtree( $dir );
 242             return 1;
 243         }
 244     } elsif ($config_data->{structure} == DIGESTPOOL) {
 245         die "UNIMPLEMENTED!";
 246     } else {
 247         do_error( "unknown pool structure $config_data->{structure}" );
 248     }
 249 }
 250
 251 sub write_log ($$) {
 252     my ($dir, $log) = @_;
 253
 254     open my $logfh, ">$dir/log" or do_error( "couldn't open log file $dir/log.\n$log" );
 255     flock $logfh, LOCK_EX or do_error( "couldn't lock log file $dir/log" );;
 256
 257     print $logfh $log;
 258
 259     close $logfh or do_warning( "couldn't close log file $dir/log" );
 260 }
 261
 262 ##################################################
 263 # EXTRACTION
 264
 265 sub extract_copyright_to_pkgpool {
 266     my ($pkg_data, $config_data, $log, $source_dir, $target_dir) = @_;
 267
 268     add_log( $log, "copy copyright file from source package" );
 269
 270     my $src_tgt = "$target_dir/copyright";
 271     copy( "$source_dir/debian/copyright", $src_tgt )
 272         or add_log( $log, "seems to have failed: $!" );
 273
 274     foreach my $bin_pkg (keys %{$pkg_data->{bin_list}}) {
 275
 276         my $usd = "$TEMPDIR/$bin_pkg/usr/share/doc/$bin_pkg";
 277         my $cpy = "$usd/copyright";
 278         my $tgt = "$target_dir/$bin_pkg.copyright";
 279
 280         if (-f $cpy) {
 281             add_log( $log, "copy copyright file from binary package $bin_pkg" );
 282             copy( $cpy, $tgt )
 283                 or add_log( $log, "seems to have failed: $!" );
 284         } elsif (-l $cpy ) {
 285             add_log( $log, "copyright file $cpy is symlink, I can't handle that" );
 286         } elsif (-l $usd) {
 287             add_log( $log, "doc directory $usd is symlink" );
 288             my $link = readlink($usd) or add_log( $log, "readlink $usd failed" );
 289             if ($link && $link =~ m,^(?:\./)?(\S+)/?$,o) { # do a little sanity check
 290                 my $pkg2 = $1;
 291                 if ($pkg_data->{bin_list}{$pkg2}) {
 292                     add_log( $log, "symlink points to $pkg2, make symlink to copyright file" );
 293                     (system("ln", "-s", "$pkg2.copyright", $tgt ) == 0)
 294                         or add_log( $log, "symlink creation failed" );
 295                 } else {
 296                     add_log( $log, "symlink points to $pkg2, don't know what to do with that" );
 297                 }
 298             } else {
 299                 add_log( $log, "link seems fishy, not using" );
 300             }
 301         }
 302
 303         unless (-e $tgt || -l $tgt) { # if it is a link, we can't be sure that the target package was already processed
 304             add_log( $log, "copyright file $tgt still doesn't exist" );
 305             if (-e $src_tgt) {
 306                 add_log( $log, "copyright file of the source package exists, make symlink" );
 307                 (system("ln", "-s", "copyright", $tgt ) == 0)
 308                     or add_log( $log, "symlink generation failed" );
 309             } else {
 310                 add_log( $log, "give up on $bin_pkg" );
 311                 (system( "touch", "$tgt.ERROR" ) == 0)
 312                     or add_log( $log, "even the touch of $tgt.ERROR failed :(" );
 313             }
 314         }
 315
 316     } #foreach $bin_pkg
 317
 318     unless (-e $src_tgt) {
 319         add_log( $log, "copyright file $src_tgt still doesn't exist" );
 320         # take one of the binary packages, prefering one that has
 321         # the same name as the source package
 322         foreach my $bin_pkg (($pkg_data->{src_name},
 323                               keys %{$pkg_data->{bin_list}})) {
 324             if (-e "$target_dir/$bin_pkg.copyright") {
 325                 add_log( $log, "copyright file $target_dir/$bin_pkg.copyright seems like a good guess to me, make a symlink" );
 326                 (system("ln", "-s", "$bin_pkg.copyright", $src_tgt ) == 0)
 327                     or do {
 328                         add_log( $log, "symlink generation failed" );
 329                         next;
 330                     };
 331                 last;
 332             }
 333         }
 334         unless (-e $src_tgt) {
 335             add_log( $log, "give up" );
 336             (system( "touch", "$src_tgt.ERROR" ) == 0) or
 337                 add_log( $log, "even the touch of $src_tgt.ERROR failed :(" );
 338         }
 339     }
 340 }
 341
 342 sub extract_changelog_to_pkgpool {
 343     my ($pkg_data, $config_data, $log, $source_dir, $target_dir) = @_;
 344
 345     add_log( $log, "copy changelog file from source package" );
 346
 347     my $src_changelog = copy( "$source_dir/debian/changelog",
 348                               "$target_dir/changelog.txt" );
 349
 350     if ($src_changelog) {
 351         add_log( $log, "changelog file sucessfully copied" );
 352     } else {
 353         add_log( $log, "seems to have failed: $!" );
 354     }
 355
 356     add_log( $log, "create enhanced HTML version" );
 357     my $chg = Parse::DebianChangelog->init;
 358     my $parsed = $chg->parse( { infile => "$source_dir/debian/changelog" } );
 359     if ($parsed) {
 360         $chg->html( { outfile => "$target_dir/changelog.html",
 361                       template => "$configdir/tmpl/default.tmpl" } );
 362         add_log( $log, scalar $chg->get_parse_errors )
 363             if $chg->get_parse_errors;
 364     } else {
 365         do_warning( $chg->get_error );
 366         add_log( $log, $chg->get_error );
 367     }
 368 }
 369
 370 sub manage_current_link {
 371     my ($pkg_data, $config_data, $log, $source_dir, $target_dir) = @_;
 372
 373     my $parent_dir = dirname($target_dir);
 374     my $dirname = basename($target_dir);
 375     my $current_link = "$parent_dir/current";
 376     add_log( $log, "parent_dir=$parent_dir; dirname=$dirname" );
 377     unless (-l $current_link) {
 378         add_log( $log, "create new current link" );
 379         (chdir( $parent_dir ) and
 380          not system( 'ln', '-s', $dirname, 'current' )) or
 381          add_log( $log, "creating new current link failed: $!" );
 382     } else {
 383         my $old_target = readlink( $current_link );
 384         (my $old_version = $old_target) =~ s/^[^_]*_//o;
 385         if (version_cmp( $pkg_data->{src_version},
 386                          $old_version) > 0) {
 387             add_log( $log,
 388                      "old_version=$old_version; overwriting current link" );
 389             (chdir( $parent_dir ) and
 390              unlink( 'current' ) and
 391              not system( 'ln', '-s', $dirname, 'current' )) or
 392              add_log( $log, "overwriting current link failed: $!" );
 393         } else {
 394             add_log( $log,
 395                      "old_version=$old_version; not touching current link" );
 396         }
 397     }
 398 }
 399
 400 sub extract_files {
 401     my ($pkg_data, $config_data) = @_;
 402     my $log = "";
 403
 404     add_log( \$log, "process source package $pkg_data->{src_name} ($pkg_data->{src_version})" );
 405
 406     unless (to_update( $pkg_data, $config_data, \$log )) {
 407         $stats{already_extracted}++;
 408         do_debug( "source package $pkg_data->{src_name} ($pkg_data->{src_version}) doesn't need extracting" );
 409         return;
 410     }
 411
 412     if (my $source_dir = unpack_srcpkg( $pkg_data->{dsc}, \$log )) {
 413
 414         $source_dir = "$TEMPDIR/$source_dir";
 415
 416         unpack_allbinpkg($pkg_data, \$log);
 417
 418         my $target_dir = "$target/".pkg_pool_directory($pkg_data);
 419         add_log( \$log, "source_dir=$source_dir; target_dir=$target_dir" );
 420
 421         mkpath( $target_dir );
 422
 423         if ($config_data->{structure} == PKGPOOL) {
 424             extract_copyright_to_pkgpool( $pkg_data, $config_data, \$log,
 425                                           $source_dir, $target_dir );
 426             extract_changelog_to_pkgpool( $pkg_data, $config_data, \$log,
 427                                           $source_dir, $target_dir );
 428             manage_current_link( $pkg_data, $config_data, \$log,
 429                                  $source_dir, $target_dir );
 430         } elsif ($config_data->{structure} == DIGESTPOOL) {
 431             die "UNIMPLEMENTED!";
 432         } else {
 433             do_error( "unknown pool structure $config_data->{structure}" );
 434         }
 435
 436         # rmtree should do that itself, but there seems to be a bug somewhere
 437         system( "chmod", "-R", "u+rwx", "$source_dir" );
 438         rmtree( $source_dir );
 439         cleanup_binpkg($pkg_data);
 440         write_log( $target_dir, $log );
 441     }
 442 }
 443
 444 sub extract_from_all {
 445     my ( $src_packages ) = @_;
 446
 447     unless (-d $target) {
 448         mkpath( $target ) or do_error( "couldn't create target directory" );
 449     }
 450
 451     # TODO: make configurable
 452     my %config = (
 453                   structure => PKGPOOL,
 454                   );
 455
 456     do_info( scalar(keys(%$src_packages))." source packages to process" );
 457     foreach my $p (keys %$src_packages) {
 458         foreach my $v (keys %{$src_packages->{$p}}) {
 459             extract_files( $src_packages->{$p}{$v}, \%config );
 460         }
 461     }
 462 }
 463
 464 ##################################################
 465 # COLLECTING INFORMATION
 466
 467 sub merge_src_bin_packages {
 468     my ( $src_packages, $bin_packages ) = @_;
 469
 470     foreach my $p (keys %$bin_packages) { # packages
 471         foreach my $v (keys %{$bin_packages->{$p}}) { # versions
 472             foreach my $a (keys %{$bin_packages->{$p}{$v}}) { # architectures
 473                 my %bin_data = %{$bin_packages->{$p}{$v}{$a}};
 474
 475                 if (exists $src_packages->{$bin_data{bin_src}}{$bin_data{bin_src_version}}) {
 476                     $src_packages->{$bin_data{bin_src}}{$bin_data{bin_src_version}}{bins} ||= [];
 477                     push @{$src_packages->{$bin_data{bin_src}}{$bin_data{bin_src_version}}{bins}}, \%bin_data;
 478                     $src_packages->{$bin_data{bin_src}}{$bin_data{bin_src_version}}{bin_list}{$p}++;
 479                 }
 480             }
 481         }
 482     }
 483
 484     return $src_packages;
 485 }
 486
 487 sub read_dsc {
 488     my ( $dscname ) = @_;
 489
 490     my $parser = Parse::DebControl->new();
 491     my ( $raw_data, $pkg_data );
 492
 493     my $dsccontent = $cache{$dscname};
 494     unless ($dsccontent) {
 495         open my $dscfh, "<", $dscname or do {
 496             do_warning( "reading file $dscname failed" );
 497             return;
 498         };
 499
 500         $dsccontent = "";
 501         while (<$dscfh>) {
 502             next if /^\#/o;
 503             if (/^-----BEGIN PGP SIGNED MESSAGE/o) {
 504                 while (<$dscfh> =~ /\S/) {}; # skip Hash: line and similar
 505                 next;
 506             }
 507             if (/^-----BEGIN PGP SIGNATURE/o) {
 508                 last; # stop reading
 509             }
 510             $dsccontent .= $_;
 511         }
 512
 513         $cache{$dscname} = $dsccontent;
 514     } else {
 515         $stats{src_cache}++;
 516         if ($debug) {
 517             (my $begin = substr($dsccontent,0,20)) =~ s/\n/\\n/go;
 518             do_debug( "CACHE HIT: $dscname ($begin)" );
 519         }
 520     }
 521
 522     unless ( $raw_data = $parser->parse_mem( $dsccontent,
 523                                              { discardCase => 1 } ) ) {
 524         do_warning( "parsing file $dscname failed.\n$dsccontent" );
 525         return;
 526     }
 527
 528     my $no_chunks = @$raw_data;
 529     if ($no_chunks != 1) {
 530         do_warning( "expected exactly one chunk in .dsc file, got $no_chunks" );
 531         return;
 532     }
 533
 534     $pkg_data = {
 535         src_name => $raw_data->[0]{source},
 536         src_version => $raw_data->[0]{version},
 537         dsc => $dscname,
 538     };
 539
 540     unless( $pkg_data->{src_name} && defined($pkg_data->{src_version})
 541         && $pkg_data->{dsc} ) {
 542         use Data::Dumper;
 543         do_error( "something fishy happened.\n", Dumper( $pkg_data ) );
 544     }
 545
 546     do_debug( "found source package $pkg_data->{src_name}, version $pkg_data->{src_version}" );
 547     $stats{src_pkgs}++;
 548
 549     return $pkg_data;
 550 }
 551
 552 sub read_deb {
 553     my ( $debname ) = @_;
 554
 555     my $parser = Parse::DebControl->new();
 556     my ( $raw_data, $pkg_data );
 557
 558     if ($cache{$debname}) {
 559         $stats{bin_cache}++;
 560         if ($debug) {
 561             (my $begin = substr($cache{$debname},0,20)) =~ s/\n/\\n/go;
 562             do_debug( "CACHE HIT: $debname ($begin)" );
 563         }
 564     }
 565     $cache{$debname} ||= qx/dpkg-deb --info "$debname" control/;
 566     my $control = $cache{$debname};
 567
 568     unless ( $raw_data = $parser->parse_mem( $control,
 569                                              { discardCase => 1 } ) ) {
 570         do_warning( "parsing control information <<$control>> of file $debname failed" );
 571         return;
 572     }
 573
 574     my $no_chunks = @$raw_data;
 575     if ($no_chunks != 1) {
 576         do_warning( "expected exactly one chunk in .deb control information, got $no_chunks" );
 577         return;
 578     }
 579
 580     $pkg_data = {
 581         bin_name => $raw_data->[0]{package},
 582         bin_version => $raw_data->[0]{version},
 583         bin_arch => $raw_data->[0]{architecture},
 584         bin_src => $raw_data->[0]{source} || $raw_data->[0]{package},,
 585         bin_src_version => $raw_data->[0]{version},
 586         deb => $debname,
 587     };
 588
 589     if ($pkg_data->{bin_src} =~ /^([\w.+-]+)\s*\(\s*=\s*([^\s\)])\s*\)\s*$/) {
 590         $pkg_data->{bin_src} = $1;
 591         $pkg_data->{bin_src_version} = $2;
 592     }
 593
 594     do_debug( "found binary package $pkg_data->{bin_name}, version $pkg_data->{bin_version}, architecture $pkg_data->{bin_arch}" );
 595     $stats{bin_pkgs}++;
 596
 597     return $pkg_data;
 598 }
 599
 600 sub collect_deb {
 601     my ( $debname ) = @_;
 602
 603     do_debug( "processing deb file $debname" );
 604
 605     my $pkg_data = read_deb( $debname );
 606     return unless $pkg_data;
 607
 608     if (exists $bin_packages{$pkg_data->{bin_name}}{$pkg_data->{bin_version}}{$pkg_data->{bin_arch}}) {
 609         do_warning( "duplicated package $pkg_data->{bin_name}, version {$pkg_data->{bin_version}{$pkg_data->{bin_arch}}" );
 610         return;
 611     } else {
 612         $bin_packages{$pkg_data->{bin_name}}{$pkg_data->{bin_version}}{$pkg_data->{bin_arch}} = $pkg_data;
 613     }
 614 }
 615
 616 sub collect_dsc {
 617     my ( $dscname ) = @_;
 618
 619     do_debug( "processing dsc file $dscname" );
 620
 621     my $pkg_data = read_dsc( $dscname );
 622     return unless $pkg_data;
 623
 624     if (exists $src_packages{$pkg_data->{src_name}}{$pkg_data->{src_version}}) {
 625         do_warning( "duplicated package $pkg_data->{src_name}, version {$pkg_data->{src_version}" );
 626         return;
 627     } else {
 628         $src_packages{$pkg_data->{src_name}}{$pkg_data->{src_version}} = $pkg_data;
 629     }
 630 }
 631
 632 sub read_sub {
 633     my ( $dir ) = @_;
 634
 635     do_debug( "processing directory $dir" );
 636
 637     opendir my $dh, $dir or do_error( "couldn't open directory $dir" );
 638     while( my $entry = readdir $dh ) {
 639         chomp $entry;
 640         next if $entry =~ /^\.\.?$/o;
 641
 642         my $fullname = "$dir/$entry";
 643
 644         read_sub( $fullname ) if -d $fullname;
 645         collect_dsc( $fullname ) if -f _ && ( $fullname =~ /\.dsc$/o );
 646         collect_deb( $fullname ) if -f _ && ( $fullname =~ /\..?deb$/o );
 647     }
 648     closedir $dh or do_warning( "couldn't close directory $dir" );
 649 }
 650
 651 ##################################################
 652 # MAIN PROGRAM
 653
 654 do_info( "Using working directory $TEMPDIR" );
 655 if ($use_dump) {
 656     do_info( "load information from dump file" );
 657     open DUMP, '<', $dumpfile
 658         or do_error( "couldn't open dump file $dumpfile: $!" );
 659     my $info = join "", <DUMP>;
 660     eval $info;
 661     close DUMP or do_warning( "couldn't close dump file: $!" );
 662 } else {
 663     do_info( "collect information (in $directory)" );
 664     if ($cachefile) {
 665         tie %cache, 'DB_File', $cachefile, O_CREAT|O_RDWR, 0640
 666             or die "E: tie with file $cachefile failed: $!";
 667     }
 668     read_sub( $directory );
 669 #FIXME: "untie attempted while 1 inner references still exist"
 670 #    untie %cache if tied %cache;
 671     do_info( "postprocess collected information" );
 672     merge_src_bin_packages( \%src_packages, \%bin_packages );
 673     if ($dumpfile) {
 674         do_info( "dump backup of collected information" );
 675         open DUMP, '>', $dumpfile
 676             or do_error( "couldn't open dump file $dumpfile: $!" );
 677         print DUMP Data::Dumper->Dump( [ \%src_packages ],
 678                                        [ '*src_packages' ] );
 679         close DUMP or do_warning( "couldn't close dump file: $!" );
 680     }
 681 }
 682 do_info( "begin extracting files" );
 683 extract_from_all( \%src_packages );
 684 do_info( <<STATS );
 685 Statistics:
 686  Source Packages:   $stats{src_pkgs}
 687  Cached Info:       $stats{src_cache}
 688  Already Extracted: $stats{already_extracted}
 689  Binary Packages:   $stats{bin_pkgs}
 690  Cached Info:       $stats{bin_cache}
 691 STATS