bin/extract_files

   1 #!/usr/bin/perl
   2 #
   3 # Script to extract files from Debian packages
   4 # Copyright 2004-2007 Frank Lichtenheld <frank@lichtenheld.de>
   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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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 ( $pkgname, $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 $pkgname+source"  );
 142
 143     system("dpkg-source", "-sn", "-x", $dscname, "$pkgname+source" ) == 0
 144         or do {
 145             do_warning( "couldn't unpack $dscname: $!" );
 146             add_log( $log, "couldn't unpack $dscname: $!" );
 147             return;
 148         };
 149
 150     return "$pkgname+source";
 151 }
 152
 153 sub unpack_binpkg {
 154     my ( $pkgname, $debname, $log ) = @_;
 155
 156     add_log( $log, "unpacking binary package $pkgname" );
 157
 158     mkdir( "$TEMPDIR/$pkgname" ) or do {
 159         do_warning( "couldn't create directory $TEMPDIR/$pkgname" );
 160         add_log( $log, "couldn't create directory $TEMPDIR/$pkgname" );
 161         return;
 162     };
 163
 164     add_log( $log, "dpkg-deb --extract $debname $TEMPDIR/$pkgname" );
 165
 166     system("dpkg-deb", "--extract", $debname, "$TEMPDIR/$pkgname" ) == 0
 167         or do {
 168             do_warning( "couldn't unpack $debname" );
 169             add_log( $log, "couldn't unpack $debname" );
 170             return;
 171         };
 172
 173     return 1;
 174 }
 175
 176 sub unpack_allbinpkg {
 177     my ($pkg_data, $log) = @_;
 178
 179     my %already_seen;
 180
 181     foreach my $pkg (@{$pkg_data->{bins}}) {
 182         next if $already_seen{$pkg->{bin_name}}; # some assumptions about sane version numbers included
 183
 184         unpack_binpkg($pkg->{bin_name}, $pkg->{deb}, $log );
 185
 186         $already_seen{$pkg->{bin_name}}++;
 187     }
 188 }
 189
 190 sub cleanup_binpkg {
 191     my ($pkg_data) = @_;
 192
 193     foreach my $pkg (keys %{$pkg_data->{bin_list}}) {
 194         # rmtree should do that itself, but there seems to be a bug somewhere
 195         system( "chmod", "-R", "u+rwx", "$TEMPDIR/$pkg" );
 196         rmtree( "$TEMPDIR/$pkg" );
 197     }
 198 }
 199
 200 ##################################################
 201 # POOL HANDLING
 202
 203 sub pkg_pool_directory {
 204     my ($pkg_data) = @_;
 205
 206     my $name = $pkg_data->{src_name};
 207     my $version = $pkg_data->{src_version};
 208     my $dscname = $pkg_data->{dsc};
 209
 210     my $dir = "";
 211
 212 # I would prefer $name_$version but lets be backward compatible
 213 # in case someone depends on the naming
 214     if ($name =~ /^(lib.)/o) {
 215 #       $dir .= "$1/$name/${name}_$version";
 216         $dir .= "$1/$name/".basename($dscname, '.dsc');
 217     } else {
 218 #       $dir .= substr($name,0,1)."/$name/${name}_$version";
 219         $dir .= substr($name,0,1)."/$name/".basename($dscname, '.dsc');
 220     }
 221
 222     return $dir;
 223 }
 224
 225 sub to_update {
 226     my ($pkg_data, $config_data, $log) = @_;
 227
 228     if ($config_data->{structure} == PKGPOOL) {
 229         my $dir = "$target/".pkg_pool_directory( $pkg_data );
 230         if (!$force && -d $dir && -f "$dir/log") {
 231             (system( "touch", "$dir/log" ) == 0)
 232                 or do_warning( "touch of $dir/log failed" );
 233             return 0;
 234         } else {
 235             rmtree( $dir );
 236             return 1;
 237         }
 238     } elsif ($config_data->{structure} == DIGESTPOOL) {
 239         die "UNIMPLEMENTED!";
 240     } else {
 241         do_error( "unknown pool structure $config_data->{structure}" );
 242     }
 243 }
 244
 245 sub write_log ($$) {
 246     my ($dir, $log) = @_;
 247
 248     open my $logfh, ">$dir/log" or do_error( "couldn't open log file $dir/log.\n$log" );
 249     flock $logfh, LOCK_EX or do_error( "couldn't lock log file $dir/log" );;
 250
 251     print $logfh $log;
 252
 253     close $logfh or do_warning( "couldn't close log file $dir/log" );
 254 }
 255
 256 ##################################################
 257 # EXTRACTION
 258
 259 sub extract_copyright_to_pkgpool {
 260     my ($pkg_data, $config_data, $log, $source_dir, $target_dir) = @_;
 261
 262     add_log( $log, "copy copyright file from source package" );
 263
 264     my $src_tgt = "$target_dir/copyright";
 265     copy( "$source_dir/debian/copyright", $src_tgt )
 266         or add_log( $log, "seems to have failed: $!" );
 267
 268     foreach my $bin_pkg (keys %{$pkg_data->{bin_list}}) {
 269
 270         my $usd = "$TEMPDIR/$bin_pkg/usr/share/doc/$bin_pkg";
 271         my $cpy = "$usd/copyright";
 272         my $tgt = "$target_dir/$bin_pkg.copyright";
 273
 274         if (-f $cpy) {
 275             add_log( $log, "copy copyright file from binary package $bin_pkg" );
 276             copy( $cpy, $tgt )
 277                 or add_log( $log, "seems to have failed: $!" );
 278         } elsif (-l $cpy ) {
 279             add_log( $log, "copyright file $cpy is symlink, I can't handle that" );
 280         } elsif (-l $usd) {
 281             add_log( $log, "doc directory $usd is symlink" );
 282             my $link = readlink($usd) or add_log( $log, "readlink $usd failed" );
 283             if ($link && $link =~ m,^(?:\./)?(\S+)/?$,o) { # do a little sanity check
 284                 my $pkg2 = $1;
 285                 if ($pkg_data->{bin_list}{$pkg2}) {
 286                     add_log( $log, "symlink points to $pkg2, make symlink to copyright file" );
 287                     (system("ln", "-s", "$pkg2.copyright", $tgt ) == 0)
 288                         or add_log( $log, "symlink creation failed" );
 289                 } else {
 290                     add_log( $log, "symlink points to $pkg2, don't know what to do with that" );
 291                 }
 292             } else {
 293                 add_log( $log, "link seems fishy, not using" );
 294             }
 295         }
 296
 297         unless (-e $tgt || -l $tgt) { # if it is a link, we can't be sure that the target package was already processed
 298             add_log( $log, "copyright file $tgt still doesn't exist" );
 299             if (-e $src_tgt) {
 300                 add_log( $log, "copyright file of the source package exists, make symlink" );
 301                 (system("ln", "-s", "copyright", $tgt ) == 0)
 302                     or add_log( $log, "symlink generation failed" );
 303             } else {
 304                 add_log( $log, "give up on $bin_pkg" );
 305                 (system( "touch", "$tgt.ERROR" ) == 0)
 306                     or add_log( $log, "even the touch of $tgt.ERROR failed :(" );
 307             }
 308         }
 309
 310     } #foreach $bin_pkg
 311
 312     unless (-e $src_tgt) {
 313         add_log( $log, "copyright file $src_tgt still doesn't exist" );
 314         # take one of the binary packages, prefering one that has
 315         # the same name as the source package
 316         foreach my $bin_pkg (($pkg_data->{src_name},
 317                               keys %{$pkg_data->{bin_list}})) {
 318             if (-e "$target_dir/$bin_pkg.copyright") {
 319                 add_log( $log, "copyright file $target_dir/$bin_pkg.copyright seems like a good guess to me, make a symlink" );
 320                 (system("ln", "-s", "$bin_pkg.copyright", $src_tgt ) == 0)
 321                     or do {
 322                         add_log( $log, "symlink generation failed" );
 323                         next;
 324                     };
 325                 last;
 326             }
 327         }
 328         unless (-e $src_tgt) {
 329             add_log( $log, "give up" );
 330             (system( "touch", "$src_tgt.ERROR" ) == 0) or
 331                 add_log( $log, "even the touch of $src_tgt.ERROR failed :(" );
 332         }
 333     }
 334 }
 335
 336 sub extract_changelog_to_pkgpool {
 337     my ($pkg_data, $config_data, $log, $source_dir, $target_dir) = @_;
 338
 339     add_log( $log, "copy changelog file from source package" );
 340
 341     my $src_changelog = copy( "$source_dir/debian/changelog",
 342                               "$target_dir/changelog.txt" );
 343
 344     if ($src_changelog) {
 345         add_log( $log, "changelog file sucessfully copied" );
 346     } else {
 347         add_log( $log, "seems to have failed: $!" );
 348     }
 349
 350     add_log( $log, "create enhanced HTML version" );
 351     my $chg = Parse::DebianChangelog->init;
 352     my $parsed = $chg->parse( { infile => "$source_dir/debian/changelog" } );
 353     if ($parsed) {
 354         $chg->html( { outfile => "$target_dir/changelog.html",
 355                       template => "$configdir/tmpl/default.tmpl" } );
 356         add_log( $log, scalar $chg->get_parse_errors )
 357             if $chg->get_parse_errors;
 358     } else {
 359         do_warning( $chg->get_error );
 360         add_log( $log, $chg->get_error );
 361     }
 362 }
 363
 364 sub manage_current_link {
 365     my ($pkg_data, $config_data, $log, $source_dir, $target_dir) = @_;
 366
 367     my $parent_dir = dirname($target_dir);
 368     my $dirname = basename($target_dir);
 369     my $current_link = "$parent_dir/current";
 370     add_log( $log, "parent_dir=$parent_dir; dirname=$dirname" );
 371     unless (-l $current_link) {
 372         add_log( $log, "create new current link" );
 373         (chdir( $parent_dir ) and
 374          not system( 'ln', '-s', $dirname, 'current' )) or
 375          add_log( $log, "creating new current link failed: $!" );
 376     } else {
 377         my $old_target = readlink( $current_link );
 378         (my $old_version = $old_target) =~ s/^[^_]*_//o;
 379         if (version_cmp( $pkg_data->{src_version},
 380                          $old_version) > 0) {
 381             add_log( $log,
 382                      "old_version=$old_version; overwriting current link" );
 383             (chdir( $parent_dir ) and
 384              unlink( 'current' ) and
 385              not system( 'ln', '-s', $dirname, 'current' )) or
 386              add_log( $log, "overwriting current link failed: $!" );
 387         } else {
 388             add_log( $log,
 389                      "old_version=$old_version; not touching current link" );
 390         }
 391     }
 392 }
 393
 394 sub extract_files {
 395     my ($pkg_data, $config_data) = @_;
 396     my $log = "";
 397
 398     add_log( \$log, "process source package $pkg_data->{src_name} ($pkg_data->{src_version})" );
 399
 400     unless (to_update( $pkg_data, $config_data, \$log )) {
 401         $stats{already_extracted}++;
 402         do_debug( "source package $pkg_data->{src_name} ($pkg_data->{src_version}) doesn't need extracting" );
 403         return;
 404     }
 405
 406     if (my $source_dir = unpack_srcpkg( $pkg_data->{src_name}, $pkg_data->{dsc}, \$log )) {
 407
 408         $source_dir = "$TEMPDIR/$source_dir";
 409
 410         unpack_allbinpkg($pkg_data, \$log);
 411
 412         my $target_dir = "$target/".pkg_pool_directory($pkg_data);
 413         add_log( \$log, "source_dir=$source_dir; target_dir=$target_dir" );
 414
 415         mkpath( $target_dir );
 416
 417         if ($config_data->{structure} == PKGPOOL) {
 418             extract_copyright_to_pkgpool( $pkg_data, $config_data, \$log,
 419                                           $source_dir, $target_dir );
 420             extract_changelog_to_pkgpool( $pkg_data, $config_data, \$log,
 421                                           $source_dir, $target_dir );
 422             manage_current_link( $pkg_data, $config_data, \$log,
 423                                  $source_dir, $target_dir );
 424         } elsif ($config_data->{structure} == DIGESTPOOL) {
 425             die "UNIMPLEMENTED!";
 426         } else {
 427             do_error( "unknown pool structure $config_data->{structure}" );
 428         }
 429
 430         # rmtree should do that itself, but there seems to be a bug somewhere
 431         system( "chmod", "-R", "u+rwx", "$source_dir" );
 432         rmtree( $source_dir );
 433         cleanup_binpkg($pkg_data);
 434         write_log( $target_dir, $log );
 435     }
 436 }
 437
 438 sub extract_from_all {
 439     my ( $src_packages ) = @_;
 440
 441     unless (-d $target) {
 442         mkpath( $target ) or do_error( "couldn't create target directory" );
 443     }
 444
 445     # TODO: make configurable
 446     my %config = (
 447                   structure => PKGPOOL,
 448                   );
 449
 450     do_info( scalar(keys(%$src_packages))." source packages to process" );
 451     foreach my $p (keys %$src_packages) {
 452         foreach my $v (keys %{$src_packages->{$p}}) {
 453             extract_files( $src_packages->{$p}{$v}, \%config );
 454         }
 455     }
 456 }
 457
 458 ##################################################
 459 # COLLECTING INFORMATION
 460
 461 sub merge_src_bin_packages {
 462     my ( $src_packages, $bin_packages ) = @_;
 463
 464     foreach my $p (keys %$bin_packages) { # packages
 465         foreach my $v (keys %{$bin_packages->{$p}}) { # versions
 466             foreach my $a (keys %{$bin_packages->{$p}{$v}}) { # architectures
 467                 my %bin_data = %{$bin_packages->{$p}{$v}{$a}};
 468
 469                 if (exists $src_packages->{$bin_data{bin_src}}{$bin_data{bin_src_version}}) {
 470                     $src_packages->{$bin_data{bin_src}}{$bin_data{bin_src_version}}{bins} ||= [];
 471                     push @{$src_packages->{$bin_data{bin_src}}{$bin_data{bin_src_version}}{bins}}, \%bin_data;
 472                     $src_packages->{$bin_data{bin_src}}{$bin_data{bin_src_version}}{bin_list}{$p}++;
 473                 }
 474             }
 475         }
 476     }
 477
 478     return $src_packages;
 479 }
 480
 481 sub read_dsc {
 482     my ( $dscname ) = @_;
 483
 484     my $parser = Parse::DebControl->new();
 485     my ( $raw_data, $pkg_data );
 486
 487     my $dsccontent = $cache{$dscname};
 488     unless ($dsccontent) {
 489         open my $dscfh, "<", $dscname or do {
 490             do_warning( "reading file $dscname failed" );
 491             return;
 492         };
 493
 494         $dsccontent = "";
 495         while (<$dscfh>) {
 496             next if /^\#/o;
 497             if (/^-----BEGIN PGP SIGNED MESSAGE/o) {
 498                 while (<$dscfh> =~ /\S/) {}; # skip Hash: line and similar
 499                 next;
 500             }
 501             if (/^-----BEGIN PGP SIGNATURE/o) {
 502                 last; # stop reading
 503             }
 504             $dsccontent .= $_;
 505         }
 506
 507         $cache{$dscname} = $dsccontent;
 508     } else {
 509         $stats{src_cache}++;
 510         if ($debug) {
 511             (my $begin = substr($dsccontent,0,20)) =~ s/\n/\\n/go;
 512             do_debug( "CACHE HIT: $dscname ($begin)" );
 513         }
 514     }
 515
 516     unless ( $raw_data = $parser->parse_mem( $dsccontent,
 517                                              { discardCase => 1 } ) ) {
 518         do_warning( "parsing file $dscname failed.\n$dsccontent" );
 519         return;
 520     }
 521
 522     my $no_chunks = @$raw_data;
 523     if ($no_chunks != 1) {
 524         do_warning( "expected exactly one chunk in .dsc file, got $no_chunks" );
 525         return;
 526     }
 527
 528     $pkg_data = {
 529         src_name => $raw_data->[0]{source},
 530         src_version => $raw_data->[0]{version},
 531         dsc => $dscname,
 532     };
 533
 534     unless( $pkg_data->{src_name} && defined($pkg_data->{src_version})
 535         && $pkg_data->{dsc} ) {
 536         use Data::Dumper;
 537         do_error( "something fishy happened.\n", Dumper( $pkg_data ) );
 538     }
 539
 540     do_debug( "found source package $pkg_data->{src_name}, version $pkg_data->{src_version}" );
 541     $stats{src_pkgs}++;
 542
 543     return $pkg_data;
 544 }
 545
 546 sub read_deb {
 547     my ( $debname ) = @_;
 548
 549     my $parser = Parse::DebControl->new();
 550     my ( $raw_data, $pkg_data );
 551
 552     if ($cache{$debname}) {
 553         $stats{bin_cache}++;
 554         if ($debug) {
 555             (my $begin = substr($cache{$debname},0,20)) =~ s/\n/\\n/go;
 556             do_debug( "CACHE HIT: $debname ($begin)" );
 557         }
 558     }
 559     $cache{$debname} ||= qx/dpkg-deb --info "$debname" control/;
 560     my $control = $cache{$debname};
 561
 562     unless ( $raw_data = $parser->parse_mem( $control,
 563                                              { discardCase => 1 } ) ) {
 564         do_warning( "parsing control information <<$control>> of file $debname failed" );
 565         return;
 566     }
 567
 568     my $no_chunks = @$raw_data;
 569     if ($no_chunks != 1) {
 570         do_warning( "expected exactly one chunk in .deb control information, got $no_chunks" );
 571         return;
 572     }
 573
 574     $pkg_data = {
 575         bin_name => $raw_data->[0]{package},
 576         bin_version => $raw_data->[0]{version},
 577         bin_arch => $raw_data->[0]{architecture},
 578         bin_src => $raw_data->[0]{source} || $raw_data->[0]{package},,
 579         bin_src_version => $raw_data->[0]{version},
 580         deb => $debname,
 581     };
 582
 583     if ($pkg_data->{bin_src} =~ /^([\w.+-]+)\s*\(\s*=\s*([^\s\)])\s*\)\s*$/) {
 584         $pkg_data->{bin_src} = $1;
 585         $pkg_data->{bin_src_version} = $2;
 586     }
 587
 588     do_debug( "found binary package $pkg_data->{bin_name}, version $pkg_data->{bin_version}, architecture $pkg_data->{bin_arch}" );
 589     $stats{bin_pkgs}++;
 590
 591     return $pkg_data;
 592 }
 593
 594 sub collect_deb {
 595     my ( $debname ) = @_;
 596
 597     do_debug( "processing deb file $debname" );
 598
 599     my $pkg_data = read_deb( $debname );
 600     return unless $pkg_data;
 601
 602     if (exists $bin_packages{$pkg_data->{bin_name}}{$pkg_data->{bin_version}}{$pkg_data->{bin_arch}}) {
 603         do_warning( "duplicated package $pkg_data->{bin_name}, version {$pkg_data->{bin_version}{$pkg_data->{bin_arch}}" );
 604         return;
 605     } else {
 606         $bin_packages{$pkg_data->{bin_name}}{$pkg_data->{bin_version}}{$pkg_data->{bin_arch}} = $pkg_data;
 607     }
 608 }
 609
 610 sub collect_dsc {
 611     my ( $dscname ) = @_;
 612
 613     do_debug( "processing dsc file $dscname" );
 614
 615     my $pkg_data = read_dsc( $dscname );
 616     return unless $pkg_data;
 617
 618     if (exists $src_packages{$pkg_data->{src_name}}{$pkg_data->{src_version}}) {
 619         do_warning( "duplicated package $pkg_data->{src_name}, version {$pkg_data->{src_version}" );
 620         return;
 621     } else {
 622         $src_packages{$pkg_data->{src_name}}{$pkg_data->{src_version}} = $pkg_data;
 623     }
 624 }
 625
 626 sub read_sub {
 627     my ( $dir ) = @_;
 628
 629     do_debug( "processing directory $dir" );
 630
 631     opendir my $dh, $dir or do_error( "couldn't open directory $dir" );
 632     while( my $entry = readdir $dh ) {
 633         chomp $entry;
 634         next if $entry =~ /^\.\.?$/o;
 635
 636         my $fullname = "$dir/$entry";
 637
 638         read_sub( $fullname ) if -d $fullname;
 639         collect_dsc( $fullname ) if -f _ && ( $fullname =~ /\.dsc$/o );
 640         collect_deb( $fullname ) if -f _ && ( $fullname =~ /\..?deb$/o );
 641     }
 642     closedir $dh or do_warning( "couldn't close directory $dir" );
 643 }
 644
 645 ##################################################
 646 # MAIN PROGRAM
 647
 648 do_info( "Using working directory $TEMPDIR" );
 649 if ($use_dump) {
 650     do_info( "load information from dump file" );
 651     open DUMP, '<', $dumpfile
 652         or do_error( "couldn't open dump file $dumpfile: $!" );
 653     my $info = join "", <DUMP>;
 654     eval $info;
 655     close DUMP or do_warning( "couldn't close dump file: $!" );
 656 } else {
 657     do_info( "collect information (in $directory)" );
 658     if ($cachefile) {
 659         tie %cache, 'DB_File', $cachefile, O_CREAT|O_RDWR, 0640
 660             or die "E: tie with file $cachefile failed: $!";
 661     }
 662     read_sub( $directory );
 663 #FIXME: "untie attempted while 1 inner references still exist"
 664 #    untie %cache if tied %cache;
 665     do_info( "postprocess collected information" );
 666     merge_src_bin_packages( \%src_packages, \%bin_packages );
 667     if ($dumpfile) {
 668         do_info( "dump backup of collected information" );
 669         open DUMP, '>', $dumpfile
 670             or do_error( "couldn't open dump file $dumpfile: $!" );
 671         print DUMP Data::Dumper->Dump( [ \%src_packages ],
 672                                        [ '*src_packages' ] );
 673         close DUMP or do_warning( "couldn't close dump file: $!" );
 674     }
 675 }
 676 do_info( "begin extracting files" );
 677 extract_from_all( \%src_packages );
 678 do_info( <<STATS );
 679 Statistics:
 680  Source Packages:   $stats{src_pkgs}
 681  Cached Info:       $stats{src_cache}
 682  Already Extracted: $stats{already_extracted}
 683  Binary Packages:   $stats{bin_pkgs}
 684  Cached Info:       $stats{bin_cache}
 685 STATS