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