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