]> git.deb.at Git - deb/packages.git/blob - extract_files
2d4dbdcd4ab64e1f90d0d0a052aa46f826760419
[deb/packages.git] / 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