3 # Script to extract files from Debian packages
4 # Copyright 2004 Frank Lichtenheld
6 # based on a shell script which was
7 # Copyright 2003 Noel Köthe
8 # Copyright 2004 Martin Schulze <joey@debian.org>
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.
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.
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
28 use lib "$FindBin::Bin/../lib";
29 use lib "$FindBin::Bin";
32 use File::Temp qw( tempdir );
38 use Parse::DebControl;
39 use Parse::DebianChangelog;
41 use Fcntl qw(:DEFAULT :flock);
45 use constant PKGPOOL => 1;
46 use constant DIGESTPOOL => 2;
48 my $PROGNAME = 'extract_files';
52 my $directory = cwd()."/pool";
55 my $target = cwd()."/extracted_files";
57 my $configdir = cwd()."/etc";
58 my ( $verbose, $version, $help, $debug, $force, $use_dump );
61 'verbose|v' => \$verbose,
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,
75 my (%src_packages, %bin_packages, %cache);
80 already_extracted => 0,
85 Getopt::Long::config('no_getopt_compat', 'no_auto_abbrev');
87 GetOptions(%opthash) or do_error( "couldn't parse commandline parameters" );
90 $directory =~ s,/+$,,o;
92 $TEMPDIR = tempdir( 'pdo_extract_file.XXXXXX',
93 DIR => $workdir, CLEANUP => 1 );
95 $TEMPDIR = tempdir( 'pdo_extract_file.XXXXXX',
99 ##################################################
103 die "$PROGNAME: FATAL: @_\n";
108 warn "$PROGNAME: WARNING: @_\n";
109 if (++$no_warnings > $MAXWARN) {
110 do_error( "too many warnings ($MAXWARN)" );
116 print "$PROGNAME: INFO: @_\n";
122 print "$PROGNAME: DEBUG: @_\n";
130 $$log .= localtime().": @_\n";
133 ##################################################
134 # PACKAGE HANDLING (UNPACKING/CLEANUP)
137 my ( $dscname, $log ) = @_;
139 chdir( $TEMPDIR ) or do_error( "couldn't change working directory to $TEMPDIR" );
141 add_log( $log, "dpkg-source -sn -x $dscname" );
143 my $out = qx/dpkg-source -sn -x "$dscname" 2>&1/;
144 my ($dir) = ($out =~ /(\S+)$/mo);
146 add_log( $log, "dpkg-source output: ", $out );
149 # system("dpkg-source", "-x", $dscname ) == 0
151 # do_warning( "couldn't unpack $dscname" );
152 # add_log( $log, "couldn't unpack $dscname" );
160 my ( $pkgname, $debname, $log ) = @_;
162 add_log( $log, "unpacking binary package $pkgname" );
164 mkdir( "$TEMPDIR/$pkgname" ) or do {
165 do_warning( "couldn't create directory $TEMPDIR/$pkgname" );
166 add_log( $log, "couldn't create directory $TEMPDIR/$pkgname" );
170 add_log( $log, "dpkg-deb --extract $debname $TEMPDIR/$pkgname" );
172 system("dpkg-deb", "--extract", $debname, "$TEMPDIR/$pkgname" ) == 0
174 do_warning( "couldn't unpack $debname" );
175 add_log( $log, "couldn't unpack $debname" );
182 sub unpack_allbinpkg {
183 my ($pkg_data, $log) = @_;
187 foreach my $pkg (@{$pkg_data->{bins}}) {
188 next if $already_seen{$pkg->{bin_name}}; # some assumptions about sane version numbers included
190 unpack_binpkg($pkg->{bin_name}, $pkg->{deb}, $log );
192 $already_seen{$pkg->{bin_name}}++;
199 foreach my $pkg (keys %{$pkg_data->{bin_list}}) {
200 # rmtree should do that itself, but there seems to be a bug somewhere
201 system( "chmod", "-R", "u+rwx", "$TEMPDIR/$pkg" );
202 rmtree( "$TEMPDIR/$pkg" );
206 ##################################################
209 sub pkg_pool_directory {
212 my $name = $pkg_data->{src_name};
213 my $version = $pkg_data->{src_version};
214 my $dscname = $pkg_data->{dsc};
218 # I would prefer $name_$version but lets be backward compatible
219 # in case someone depends on the naming
220 if ($name =~ /^(lib.)/o) {
221 # $dir .= "$1/$name/${name}_$version";
222 $dir .= "$1/$name/".basename($dscname, '.dsc');
224 # $dir .= substr($name,0,1)."/$name/${name}_$version";
225 $dir .= substr($name,0,1)."/$name/".basename($dscname, '.dsc');
232 my ($pkg_data, $config_data, $log) = @_;
234 if ($config_data->{structure} == PKGPOOL) {
235 my $dir = "$target/".pkg_pool_directory( $pkg_data );
236 if (!$force && -d $dir && -f "$dir/log") {
237 (system( "touch", "$dir/log" ) == 0)
238 or do_warning( "touch of $dir/log failed" );
244 } elsif ($config_data->{structure} == DIGESTPOOL) {
245 die "UNIMPLEMENTED!";
247 do_error( "unknown pool structure $config_data->{structure}" );
252 my ($dir, $log) = @_;
254 open my $logfh, ">$dir/log" or do_error( "couldn't open log file $dir/log.\n$log" );
255 flock $logfh, LOCK_EX or do_error( "couldn't lock log file $dir/log" );;
259 close $logfh or do_warning( "couldn't close log file $dir/log" );
262 ##################################################
265 sub extract_copyright_to_pkgpool {
266 my ($pkg_data, $config_data, $log, $source_dir, $target_dir) = @_;
268 add_log( $log, "copy copyright file from source package" );
270 my $src_tgt = "$target_dir/copyright";
271 copy( "$source_dir/debian/copyright", $src_tgt )
272 or add_log( $log, "seems to have failed: $!" );
274 foreach my $bin_pkg (keys %{$pkg_data->{bin_list}}) {
276 my $usd = "$TEMPDIR/$bin_pkg/usr/share/doc/$bin_pkg";
277 my $cpy = "$usd/copyright";
278 my $tgt = "$target_dir/$bin_pkg.copyright";
281 add_log( $log, "copy copyright file from binary package $bin_pkg" );
283 or add_log( $log, "seems to have failed: $!" );
285 add_log( $log, "copyright file $cpy is symlink, I can't handle that" );
287 add_log( $log, "doc directory $usd is symlink" );
288 my $link = readlink($usd) or add_log( $log, "readlink $usd failed" );
289 if ($link && $link =~ m,^(?:\./)?(\S+)/?$,o) { # do a little sanity check
291 if ($pkg_data->{bin_list}{$pkg2}) {
292 add_log( $log, "symlink points to $pkg2, make symlink to copyright file" );
293 (system("ln", "-s", "$pkg2.copyright", $tgt ) == 0)
294 or add_log( $log, "symlink creation failed" );
296 add_log( $log, "symlink points to $pkg2, don't know what to do with that" );
299 add_log( $log, "link seems fishy, not using" );
303 unless (-e $tgt || -l $tgt) { # if it is a link, we can't be sure that the target package was already processed
304 add_log( $log, "copyright file $tgt still doesn't exist" );
306 add_log( $log, "copyright file of the source package exists, make symlink" );
307 (system("ln", "-s", "copyright", $tgt ) == 0)
308 or add_log( $log, "symlink generation failed" );
310 add_log( $log, "give up on $bin_pkg" );
311 (system( "touch", "$tgt.ERROR" ) == 0)
312 or add_log( $log, "even the touch of $tgt.ERROR failed :(" );
318 unless (-e $src_tgt) {
319 add_log( $log, "copyright file $src_tgt still doesn't exist" );
320 # take one of the binary packages, prefering one that has
321 # the same name as the source package
322 foreach my $bin_pkg (($pkg_data->{src_name},
323 keys %{$pkg_data->{bin_list}})) {
324 if (-e "$target_dir/$bin_pkg.copyright") {
325 add_log( $log, "copyright file $target_dir/$bin_pkg.copyright seems like a good guess to me, make a symlink" );
326 (system("ln", "-s", "$bin_pkg.copyright", $src_tgt ) == 0)
328 add_log( $log, "symlink generation failed" );
334 unless (-e $src_tgt) {
335 add_log( $log, "give up" );
336 (system( "touch", "$src_tgt.ERROR" ) == 0) or
337 add_log( $log, "even the touch of $src_tgt.ERROR failed :(" );
342 sub extract_changelog_to_pkgpool {
343 my ($pkg_data, $config_data, $log, $source_dir, $target_dir) = @_;
345 add_log( $log, "copy changelog file from source package" );
347 my $src_changelog = copy( "$source_dir/debian/changelog",
348 "$target_dir/changelog.txt" );
350 if ($src_changelog) {
351 add_log( $log, "changelog file sucessfully copied" );
353 add_log( $log, "seems to have failed: $!" );
356 add_log( $log, "create enhanced HTML version" );
357 my $chg = Parse::DebianChangelog->init;
358 my $parsed = $chg->parse( { infile => "$source_dir/debian/changelog" } );
360 $chg->html( { outfile => "$target_dir/changelog.html",
361 template => "$configdir/tmpl/default.tmpl" } );
362 add_log( $log, scalar $chg->get_parse_errors )
363 if $chg->get_parse_errors;
365 do_warning( $chg->get_error );
366 add_log( $log, $chg->get_error );
370 sub manage_current_link {
371 my ($pkg_data, $config_data, $log, $source_dir, $target_dir) = @_;
373 my $parent_dir = dirname($target_dir);
374 my $dirname = basename($target_dir);
375 my $current_link = "$parent_dir/current";
376 add_log( $log, "parent_dir=$parent_dir; dirname=$dirname" );
377 unless (-l $current_link) {
378 add_log( $log, "create new current link" );
379 (chdir( $parent_dir ) and
380 not system( 'ln', '-s', $dirname, 'current' )) or
381 add_log( $log, "creating new current link failed: $!" );
383 my $old_target = readlink( $current_link );
384 (my $old_version = $old_target) =~ s/^[^_]*_//o;
385 if (version_cmp( $pkg_data->{src_version},
388 "old_version=$old_version; overwriting current link" );
389 (chdir( $parent_dir ) and
390 unlink( 'current' ) and
391 not system( 'ln', '-s', $dirname, 'current' )) or
392 add_log( $log, "overwriting current link failed: $!" );
395 "old_version=$old_version; not touching current link" );
401 my ($pkg_data, $config_data) = @_;
404 add_log( \$log, "process source package $pkg_data->{src_name} ($pkg_data->{src_version})" );
406 unless (to_update( $pkg_data, $config_data, \$log )) {
407 $stats{already_extracted}++;
408 do_debug( "source package $pkg_data->{src_name} ($pkg_data->{src_version}) doesn't need extracting" );
412 if (my $source_dir = unpack_srcpkg( $pkg_data->{dsc}, \$log )) {
414 $source_dir = "$TEMPDIR/$source_dir";
416 unpack_allbinpkg($pkg_data, \$log);
418 my $target_dir = "$target/".pkg_pool_directory($pkg_data);
419 add_log( \$log, "source_dir=$source_dir; target_dir=$target_dir" );
421 mkpath( $target_dir );
423 if ($config_data->{structure} == PKGPOOL) {
424 extract_copyright_to_pkgpool( $pkg_data, $config_data, \$log,
425 $source_dir, $target_dir );
426 extract_changelog_to_pkgpool( $pkg_data, $config_data, \$log,
427 $source_dir, $target_dir );
428 manage_current_link( $pkg_data, $config_data, \$log,
429 $source_dir, $target_dir );
430 } elsif ($config_data->{structure} == DIGESTPOOL) {
431 die "UNIMPLEMENTED!";
433 do_error( "unknown pool structure $config_data->{structure}" );
436 # rmtree should do that itself, but there seems to be a bug somewhere
437 system( "chmod", "-R", "u+rwx", "$source_dir" );
438 rmtree( $source_dir );
439 cleanup_binpkg($pkg_data);
440 write_log( $target_dir, $log );
444 sub extract_from_all {
445 my ( $src_packages ) = @_;
447 unless (-d $target) {
448 mkpath( $target ) or do_error( "couldn't create target directory" );
451 # TODO: make configurable
453 structure => PKGPOOL,
456 do_info( scalar(keys(%$src_packages))." source packages to process" );
457 foreach my $p (keys %$src_packages) {
458 foreach my $v (keys %{$src_packages->{$p}}) {
459 extract_files( $src_packages->{$p}{$v}, \%config );
464 ##################################################
465 # COLLECTING INFORMATION
467 sub merge_src_bin_packages {
468 my ( $src_packages, $bin_packages ) = @_;
470 foreach my $p (keys %$bin_packages) { # packages
471 foreach my $v (keys %{$bin_packages->{$p}}) { # versions
472 foreach my $a (keys %{$bin_packages->{$p}{$v}}) { # architectures
473 my %bin_data = %{$bin_packages->{$p}{$v}{$a}};
475 if (exists $src_packages->{$bin_data{bin_src}}{$bin_data{bin_src_version}}) {
476 $src_packages->{$bin_data{bin_src}}{$bin_data{bin_src_version}}{bins} ||= [];
477 push @{$src_packages->{$bin_data{bin_src}}{$bin_data{bin_src_version}}{bins}}, \%bin_data;
478 $src_packages->{$bin_data{bin_src}}{$bin_data{bin_src_version}}{bin_list}{$p}++;
484 return $src_packages;
488 my ( $dscname ) = @_;
490 my $parser = Parse::DebControl->new();
491 my ( $raw_data, $pkg_data );
493 my $dsccontent = $cache{$dscname};
494 unless ($dsccontent) {
495 open my $dscfh, "<", $dscname or do {
496 do_warning( "reading file $dscname failed" );
503 if (/^-----BEGIN PGP SIGNED MESSAGE/o) {
504 while (<$dscfh> =~ /\S/) {}; # skip Hash: line and similar
507 if (/^-----BEGIN PGP SIGNATURE/o) {
513 $cache{$dscname} = $dsccontent;
517 (my $begin = substr($dsccontent,0,20)) =~ s/\n/\\n/go;
518 do_debug( "CACHE HIT: $dscname ($begin)" );
522 unless ( $raw_data = $parser->parse_mem( $dsccontent,
523 { discardCase => 1 } ) ) {
524 do_warning( "parsing file $dscname failed.\n$dsccontent" );
528 my $no_chunks = @$raw_data;
529 if ($no_chunks != 1) {
530 do_warning( "expected exactly one chunk in .dsc file, got $no_chunks" );
535 src_name => $raw_data->[0]{source},
536 src_version => $raw_data->[0]{version},
540 unless( $pkg_data->{src_name} && defined($pkg_data->{src_version})
541 && $pkg_data->{dsc} ) {
543 do_error( "something fishy happened.\n", Dumper( $pkg_data ) );
546 do_debug( "found source package $pkg_data->{src_name}, version $pkg_data->{src_version}" );
553 my ( $debname ) = @_;
555 my $parser = Parse::DebControl->new();
556 my ( $raw_data, $pkg_data );
558 if ($cache{$debname}) {
561 (my $begin = substr($cache{$debname},0,20)) =~ s/\n/\\n/go;
562 do_debug( "CACHE HIT: $debname ($begin)" );
565 $cache{$debname} ||= qx/dpkg-deb --info "$debname" control/;
566 my $control = $cache{$debname};
568 unless ( $raw_data = $parser->parse_mem( $control,
569 { discardCase => 1 } ) ) {
570 do_warning( "parsing control information <<$control>> of file $debname failed" );
574 my $no_chunks = @$raw_data;
575 if ($no_chunks != 1) {
576 do_warning( "expected exactly one chunk in .deb control information, got $no_chunks" );
581 bin_name => $raw_data->[0]{package},
582 bin_version => $raw_data->[0]{version},
583 bin_arch => $raw_data->[0]{architecture},
584 bin_src => $raw_data->[0]{source} || $raw_data->[0]{package},,
585 bin_src_version => $raw_data->[0]{version},
589 if ($pkg_data->{bin_src} =~ /^([\w.+-]+)\s*\(\s*=\s*([^\s\)])\s*\)\s*$/) {
590 $pkg_data->{bin_src} = $1;
591 $pkg_data->{bin_src_version} = $2;
594 do_debug( "found binary package $pkg_data->{bin_name}, version $pkg_data->{bin_version}, architecture $pkg_data->{bin_arch}" );
601 my ( $debname ) = @_;
603 do_debug( "processing deb file $debname" );
605 my $pkg_data = read_deb( $debname );
606 return unless $pkg_data;
608 if (exists $bin_packages{$pkg_data->{bin_name}}{$pkg_data->{bin_version}}{$pkg_data->{bin_arch}}) {
609 do_warning( "duplicated package $pkg_data->{bin_name}, version {$pkg_data->{bin_version}{$pkg_data->{bin_arch}}" );
612 $bin_packages{$pkg_data->{bin_name}}{$pkg_data->{bin_version}}{$pkg_data->{bin_arch}} = $pkg_data;
617 my ( $dscname ) = @_;
619 do_debug( "processing dsc file $dscname" );
621 my $pkg_data = read_dsc( $dscname );
622 return unless $pkg_data;
624 if (exists $src_packages{$pkg_data->{src_name}}{$pkg_data->{src_version}}) {
625 do_warning( "duplicated package $pkg_data->{src_name}, version {$pkg_data->{src_version}" );
628 $src_packages{$pkg_data->{src_name}}{$pkg_data->{src_version}} = $pkg_data;
635 do_debug( "processing directory $dir" );
637 opendir my $dh, $dir or do_error( "couldn't open directory $dir" );
638 while( my $entry = readdir $dh ) {
640 next if $entry =~ /^\.\.?$/o;
642 my $fullname = "$dir/$entry";
644 read_sub( $fullname ) if -d $fullname;
645 collect_dsc( $fullname ) if -f _ && ( $fullname =~ /\.dsc$/o );
646 collect_deb( $fullname ) if -f _ && ( $fullname =~ /\..?deb$/o );
648 closedir $dh or do_warning( "couldn't close directory $dir" );
651 ##################################################
654 do_info( "Using working directory $TEMPDIR" );
656 do_info( "load information from dump file" );
657 open DUMP, '<', $dumpfile
658 or do_error( "couldn't open dump file $dumpfile: $!" );
659 my $info = join "", <DUMP>;
661 close DUMP or do_warning( "couldn't close dump file: $!" );
663 do_info( "collect information (in $directory)" );
665 tie %cache, 'DB_File', $cachefile, O_CREAT|O_RDWR, 0640
666 or die "E: tie with file $cachefile failed: $!";
668 read_sub( $directory );
669 #FIXME: "untie attempted while 1 inner references still exist"
670 # untie %cache if tied %cache;
671 do_info( "postprocess collected information" );
672 merge_src_bin_packages( \%src_packages, \%bin_packages );
674 do_info( "dump backup of collected information" );
675 open DUMP, '>', $dumpfile
676 or do_error( "couldn't open dump file $dumpfile: $!" );
677 print DUMP Data::Dumper->Dump( [ \%src_packages ],
678 [ '*src_packages' ] );
679 close DUMP or do_warning( "couldn't close dump file: $!" );
682 do_info( "begin extracting files" );
683 extract_from_all( \%src_packages );
686 Source Packages: $stats{src_pkgs}
687 Cached Info: $stats{src_cache}
688 Already Extracted: $stats{already_extracted}
689 Binary Packages: $stats{bin_pkgs}
690 Cached Info: $stats{bin_cache}