#!/usr/bin/perl
#
# Script to extract files from Debian packages
-# Copyright 2004 Frank Lichtenheld
+# Copyright 2004-2007 Frank Lichtenheld <frank@lichtenheld.de>
#
# based on a shell script which was
# Copyright 2003 Noel Köthe
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
-# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
use strict;
use warnings;
'help' => \$help,
);
-my (%src_packages, %bin_packages, %cache, %stats);
+my (%src_packages, %bin_packages, %cache);
+
+my %stats = (
+ src_pkgs => 0,
+ src_cache => 0,
+ already_extracted => 0,
+ bin_pkgs => 0,
+ bin_cache => 0,
+ );
Getopt::Long::config('no_getopt_compat', 'no_auto_abbrev');
$$log .= localtime().": @_\n";
}
+sub touch {
+ my $filename = shift;
+ sysopen(H, $filename, O_WRONLY|O_NONBLOCK|O_CREAT) or return undef;
+ close(H);
+ return 1;
+}
+
##################################################
# PACKAGE HANDLING (UNPACKING/CLEANUP)
sub unpack_srcpkg {
- my ( $dscname, $log ) = @_;
+ my ( $pkgname, $dscname, $log ) = @_;
chdir( $TEMPDIR ) or do_error( "couldn't change working directory to $TEMPDIR" );
- add_log( $log, "dpkg-source -sn -x $dscname" );
-
- my $out = qx/dpkg-source -sn -x "$dscname" 2>&1/;
- my ($dir) = ($out =~ /(\S+)$/mo);
-
- add_log( $log, "dpkg-source output: ", $out );
+ add_log( $log, "dpkg-source -sn -x $dscname $pkgname+source" );
-#Bug#246802
-# system("dpkg-source", "-x", $dscname ) == 0
-# or do {
-# do_warning( "couldn't unpack $dscname" );
-# add_log( $log, "couldn't unpack $dscname" );
-# return;
-# };
+ system("dpkg-source", "-sn", "-x", $dscname, "$pkgname+source" ) == 0
+ or do {
+ do_warning( "couldn't unpack $dscname: $!" );
+ add_log( $log, "couldn't unpack $dscname: $!" );
+ return;
+ };
- return $dir;
+ return "$pkgname+source";
}
sub unpack_binpkg {
if ($config_data->{structure} == PKGPOOL) {
my $dir = "$target/".pkg_pool_directory( $pkg_data );
- if (!$force && -d $dir && -f "$dir/log") {
- (system( "touch", "$dir/log" ) == 0)
+ if (!$force && -f "$dir/log") {
+ (utime(undef,undef,"$dir/log") == 1)
or do_warning( "touch of $dir/log failed" );
return 0;
} else {
my $pkg2 = $1;
if ($pkg_data->{bin_list}{$pkg2}) {
add_log( $log, "symlink points to $pkg2, make symlink to copyright file" );
- (system("ln", "-s", "$pkg2.copyright", $tgt ) == 0)
+ (symlink( "$pkg2.copyright", $tgt ) == 1 )
or add_log( $log, "symlink creation failed" );
} else {
add_log( $log, "symlink points to $pkg2, don't know what to do with that" );
add_log( $log, "copyright file $tgt still doesn't exist" );
if (-e $src_tgt) {
add_log( $log, "copyright file of the source package exists, make symlink" );
- (system("ln", "-s", "copyright", $tgt ) == 0)
+ (symlink( "copyright", $tgt ) == 1 )
or add_log( $log, "symlink generation failed" );
} else {
add_log( $log, "give up on $bin_pkg" );
- (system( "touch", "$tgt.ERROR" ) == 0)
+ touch("$tgt.ERROR")
or add_log( $log, "even the touch of $tgt.ERROR failed :(" );
}
}
keys %{$pkg_data->{bin_list}})) {
if (-e "$target_dir/$bin_pkg.copyright") {
add_log( $log, "copyright file $target_dir/$bin_pkg.copyright seems like a good guess to me, make a symlink" );
- (system("ln", "-s", "$bin_pkg.copyright", $src_tgt ) == 0)
+ (symlink( "$bin_pkg.copyright", $src_tgt ) == 1 )
or do {
add_log( $log, "symlink generation failed" );
next;
}
unless (-e $src_tgt) {
add_log( $log, "give up" );
- (system( "touch", "$src_tgt.ERROR" ) == 0) or
+ touch("$src_tgt.ERROR") or
add_log( $log, "even the touch of $src_tgt.ERROR failed :(" );
}
}
unless (-l $current_link) {
add_log( $log, "create new current link" );
(chdir( $parent_dir ) and
- not system( 'ln', '-s', $dirname, 'current' )) or
+ (symlink( $dirname, 'current' ) == 1 )) or
add_log( $log, "creating new current link failed: $!" );
} else {
my $old_target = readlink( $current_link );
"old_version=$old_version; overwriting current link" );
(chdir( $parent_dir ) and
unlink( 'current' ) and
- not system( 'ln', '-s', $dirname, 'current' )) or
+ (symlink( $dirname, 'current' ) == 1 )) or
add_log( $log, "overwriting current link failed: $!" );
} else {
add_log( $log,
return;
}
- if (my $source_dir = unpack_srcpkg( $pkg_data->{dsc}, \$log )) {
+ if (my $source_dir = unpack_srcpkg( $pkg_data->{src_name}, $pkg_data->{dsc}, \$log )) {
$source_dir = "$TEMPDIR/$source_dir";
dsc => $dscname,
};
- unless( $pkg_data->{src_name} && $pkg_data->{src_version}
+ unless( $pkg_data->{src_name} && defined($pkg_data->{src_version})
&& $pkg_data->{dsc} ) {
use Data::Dumper;
do_error( "something fishy happened.\n", Dumper( $pkg_data ) );
}
}
$cache{$debname} ||= qx/dpkg-deb --info "$debname" control/;
+ unless ( $cache{$debname} ) {
+ do_warning( "extracting control information of file $debname failed" );
+ return;
+ }
my $control = $cache{$debname};
unless ( $raw_data = $parser->parse_mem( $control,