[SCM] Debian package checker branch, master, updated. 2.5.10-175-gddc8f94
The following commit has been merged in the master branch:
commit ddc8f94adc51bc1f02cd2954f7bfeed7aed967b4
Author: Niels Thykier <niels@thykier.net>
Date: Wed Sep 26 10:55:14 2012 +0200
coll/index: Use find to generate source index
Make coll/index depend on unpacked and use find to generate the index
of the unpacked source package. This gives an accurate view of what
is in unpacked (particular the debian/ is now always present).
The previous indexing method has been moved to a new collection
src-orig-index, which only concerns itself with creating an index of
what is the "orig" tarballs.
Signed-off-by: Niels Thykier <niels@thykier.net>
diff --git a/collection/index b/collection/index
index 0abe2ae..ff08b4c 100755
--- a/collection/index
+++ b/collection/index
@@ -29,7 +29,6 @@ use warnings;
# import perl libraries
use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Cwd();
-use File::Spec;
use Lintian::Command qw(spawn reap);
use Lintian::Processable::Package;
use Lintian::Util qw(fail get_dsc_info);
@@ -47,156 +46,20 @@ unlink "$dir/index-errors" or fail "Could not unlink index-errors: $!"
if ($type ne 'source') {
index_deb();
} else {
- index_src();
+ chdir "$dir/unpacked"
+ or fail "chdir $dir/unpacked: $!";
+ spawn ({ fail => 'error', out => "$dir/index.gz" },
+ ['find', '(', '-type', 'l',
+ # If symlink
+ '-printf', '%M 0/0 %s %AY-%Am-%Ad %AH:%AM %p -> %l\n', '-true',
+ # else symlink
+ ')', '-o', '-printf', '%M 0/0 %s %AY-%Am-%Ad %AH:%AM %p\n'],
+ # Sort and compress
+ '|', ['sort', '-k', '6'], '|', ['gzip', '-9c']);
}
exit 0;
-# returns all (orig) tarballs.
-sub gather_tarballs {
- my $file = Cwd::realpath ("$dir/dsc");
- my $data;
- my $version;
- my @tarballs;
- my $base;
- my $baserev;
- my $proc;
- fail "Cannot resolve \"dsc\" link for $pkg or it does not point to a file." unless $file and -e $file;
- # Use Lintian::Processable::Package to determine source and version as handles missing fields
- # for us to some extend.
- $proc = Lintian::Processable::Package->new ($file, 'source');
- $data = get_dsc_info($file) or fail "Could not parse dsc file for $pkg.\n";
- # Version handling is based on Dpkg::Version::parseversion.
- $version = $proc->pkg_src_version;
- if ($version =~ /:/) {
- $version =~ s/^(?:\d+):(.+)/$1/ or fail("bad version number '$version'");
- }
- $baserev = $proc->pkg_src . '_' . $version;
- $version =~ s/(.+)-(.*)$/$1/;
- $base = $proc->pkg_src . '_' . $version;
- for my $fs (split(/\n/,$data->{'files'})) {
- $fs =~ s/^\s*//;
- next if $fs eq '';
- my @t = split(/\s+/o,$fs);
- next if ($t[2] =~ m,/,);
- # Look for $pkg_$version.orig(-$comp)?.tar.$ext (non-native)
- # or $pkg_$version.tar.$ext (native)
- # - This deliberately does not look for the debian packaging
- # even when this would be a tarball.
- if ($t[2] =~ /^(?:\Q$base\E\.orig(?:-(.*))?|\Q$baserev\E)\.tar\.(?:gz|bz2|lzma|xz)$/) {
- push @tarballs, [$t[2], $1//''];
- }
- }
- fail('could not find the source tarball') unless @tarballs;
- return @tarballs;
-}
-
-# Creates an index for the source package
-sub index_src {
- my @tarballs = gather_tarballs();
- my @result;
- foreach my $tardata (@tarballs) {
- my ($tarball, $compname) = @$tardata;
- my @index;
- # Collect a list of the files in the source package. tar currently doesn't
- # automatically recognize LZMA / XZ, so we need to add the option where it's
- # needed. Change hard link status (h) to regular files and remove a leading
- # ./ prefix on filenames while we're reading the tar output. We intentionally
- # don't parallelize this job because we need to use the output below.
- my @tar_options = ('-tvf');
- my $last = '';
- my $collect;
- if ($tarball =~ /\.(lzma|xz)\z/) {
- unshift(@tar_options, "--$1");
- }
- $collect = sub {
- my @lines = map { split "\n" } @_;
- if ($last ne '') {
- $lines[0] = $last . $lines[0];
- }
- if ($_[-1] !~ /\n\z/) {
- $last = pop @lines;
- } else {
- $last = '';
- }
- for my $line (@lines) {
- $line =~ s/^h/-/;
- if ($line and $line !~ m,^(?:\S+\s+){5}\./$,) {
- push(@index, $line . "\n");
- }
- }
- }; # End $collect = sub;
- spawn({ fail => 'never', out => $collect, err_append => "$dir/index-errors" },
- ['tar', @tar_options, "$dir/$tarball"]);
- if ($last) {
- fail("tar output (for $tarball from $pkg) does not end in a newline");
- }
- # We now need to see if all files in the tarball have a common prefix. If so,
- # we're going to strip that prefix off each file name. We also remove lines
- # that consist solely of the prefix.
- my $prefix;
- for my $line (@index) {
- my ($filename) = ($line =~ /^(?:\S+\s+){5}(.*)/);
- $filename =~ s,^\./+,,o;
- my ($dirname) = ($filename =~ m,^([^/]+),);
- if (defined($dirname) and $dirname eq $filename and not $line =~ m/^d/o) {
- $prefix = '';
- } elsif (defined $dirname) {
- if (not defined $prefix) {
- $prefix = $dirname;
- } elsif ($dirname ne $prefix) {
- $prefix = '';
- }
- } else {
- $prefix = '';
- }
- }
- # Ensure $prefix is defined - this may appear to be redundant, but
- # no tarballs are present (happens if you wget rather than dget
- # the .dsc file >.>)
- $prefix //= '';
-
- # If there is a common prefix and it is $compname, then we use that
- # because that is where they will be extracted by unpacked.
- if ($prefix ne $compname) {
- # If there is a common prefix and it is not $compname
- # then strip the prefix and add $compname (if any)
- if ($prefix) {
- @index = map {
- if (m,^((?:\S+\s+){5})(?:\./)?\Q$prefix\E(?:/+(.*+)?|\Z),){
- my ($data, $file) = ($1, $2);
- if ($file && $file !~ m,^(?:/++)?\Z,o){
- $file = "$compname/$file" if $compname;
- "$data$file\n";
- } else {
- ();
- }
- } else {
- ();
- }
- } @index;
- my $filename = 'source-prefix';
- $filename .= "-$compname" if $compname;
- open PREFIX, '>', "$dir/$filename"
- or fail "opening $filename for $pkg: $!";
- print PREFIX "$prefix\n";
- close PREFIX or fail "closing $filename for $pkg: $!";
- } elsif ($compname) {
- # Prefix with the compname (because that is where they will be
- # unpacked to.
- @index = map { s,^((?:\S++\s++){5})(?:\./)?\Q$prefix\E(?:/+)?,$1$compname/, } @index;
- }
- }
- push @result, @index;
- }
- # Now that we have the file names we want, write them out sorted to the index
- # file.
- spawn({ fail => 'error', out => "$dir/index.gz" },
- sub { print @result }, '|', ['sort', '-k', '6'],
- '|', ['gzip', '--best', '-c']);
- return 1;
-}
-
# Creates an index for binary packages
sub index_deb {
my (@jobs, $job);
diff --git a/collection/index.desc b/collection/index.desc
index bd0de5f..1f16abb 100644
--- a/collection/index.desc
+++ b/collection/index.desc
@@ -1,5 +1,6 @@
Collector-Script: index
Info: This script create an index file of the contents of a package.
Type: source, binary, udeb
+Needs-Info: unpacked
Version: 3
diff --git a/collection/index b/collection/src-orig-index
old mode 100755
new mode 100644
similarity index 63%
copy from collection/index
copy to collection/src-orig-index
index 0abe2ae..08b585a
--- a/collection/index
+++ b/collection/src-orig-index
@@ -1,11 +1,7 @@
#!/usr/bin/perl
-# unpack-binpkg-l1 -- lintian unpack script (binary packages level 1)
#
-# syntax: unpack-binpkg-l1 <base-dir> <deb-file>
-#
-# Note that <deb-file> must be specified with absolute path.
-
-# Copyright (C) 1998 Christian Schwarz
+# Copyright (C) 2012 Niels Thykier
+# Based on coll/index which is: Copyright (C) 1998 Christian Schwarz
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
@@ -29,56 +25,60 @@ use warnings;
# import perl libraries
use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Cwd();
-use File::Spec;
-use Lintian::Command qw(spawn reap);
+use Lintian::Collect;
+use Lintian::Command qw(spawn);
use Lintian::Processable::Package;
-use Lintian::Util qw(fail get_dsc_info);
+use Lintian::Util qw(fail);
-($#ARGV == 2) or fail 'syntax: index <pkg> <type> <dir>';
+($#ARGV == 2) or fail 'syntax: src-orig-index <pkg> <type> <dir>';
my ($pkg, $type, $dir) = @ARGV;
+my $info = Lintian::Collect->new ($pkg, $type, $dir);
-unlink "$dir/index" or fail "Could not unlink index: $!"
- if -e "$dir/index";
-unlink "$dir/index.gz" or fail "Could not unlink index.gz: $!"
- if -e "$dir/index.gz";
-unlink "$dir/index-errors" or fail "Could not unlink index-errors: $!"
- if -e "$dir/index-errors";
+if ( -f "$dir/orig-index.gz" ) {
+ unlink "$dir/orig-index.gz"
+ or fail "unlink orig-index.gz for $pkg failed: $!"
+}
-if ($type ne 'source') {
- index_deb();
-} else {
- index_src();
+# Nothing to do for native packages where the two indices are
+# identical.
+if ($info->native) {
+ link "$dir/index.gz", "$dir/orig-index.gz"
+ or fail "link index.gz orig-index.gz: $!";
+ exit 0
}
+index_orig ($info);
+
exit 0;
+
# returns all (orig) tarballs.
sub gather_tarballs {
+ my ($info) = @_;
my $file = Cwd::realpath ("$dir/dsc");
- my $data;
my $version;
my @tarballs;
my $base;
my $baserev;
my $proc;
- fail "Cannot resolve \"dsc\" link for $pkg or it does not point to a file." unless $file and -e $file;
+ fail "Cannot resolve \"dsc\" link for $pkg or it does not point to a file."
+ unless $file and -e $file;
# Use Lintian::Processable::Package to determine source and version as handles missing fields
# for us to some extend.
$proc = Lintian::Processable::Package->new ($file, 'source');
- $data = get_dsc_info($file) or fail "Could not parse dsc file for $pkg.\n";
# Version handling is based on Dpkg::Version::parseversion.
$version = $proc->pkg_src_version;
if ($version =~ /:/) {
- $version =~ s/^(?:\d+):(.+)/$1/ or fail("bad version number '$version'");
+ $version =~ s/^(?:\d+):(.+)/$1/ or fail "bad version number '$version'";
}
$baserev = $proc->pkg_src . '_' . $version;
- $version =~ s/(.+)-(.*)$/$1/;
+ $version =~ s/(.+)-(?:.*)$/$1/;
$base = $proc->pkg_src . '_' . $version;
- for my $fs (split(/\n/,$data->{'files'})) {
+ for my $fs (split /\n/, $info->field ('files', '')) {
$fs =~ s/^\s*//;
next if $fs eq '';
- my @t = split(/\s+/o,$fs);
- next if ($t[2] =~ m,/,);
+ my @t = split /\s+/o, $fs;
+ next if $t[2] =~ m,/,;
# Look for $pkg_$version.orig(-$comp)?.tar.$ext (non-native)
# or $pkg_$version.tar.$ext (native)
# - This deliberately does not look for the debian packaging
@@ -87,13 +87,14 @@ sub gather_tarballs {
push @tarballs, [$t[2], $1//''];
}
}
- fail('could not find the source tarball') unless @tarballs;
+ fail 'could not find the source tarball' unless @tarballs;
return @tarballs;
}
-# Creates an index for the source package
-sub index_src {
- my @tarballs = gather_tarballs();
+# Creates an index of the orig tarballs the source package
+sub index_orig {
+ my ($info) = @_;
+ my @tarballs = gather_tarballs ($info);
my @result;
foreach my $tardata (@tarballs) {
my ($tarball, $compname) = @$tardata;
@@ -107,7 +108,7 @@ sub index_src {
my $last = '';
my $collect;
if ($tarball =~ /\.(lzma|xz)\z/) {
- unshift(@tar_options, "--$1");
+ unshift @tar_options, "--$1";
}
$collect = sub {
my @lines = map { split "\n" } @_;
@@ -122,14 +123,14 @@ sub index_src {
for my $line (@lines) {
$line =~ s/^h/-/;
if ($line and $line !~ m,^(?:\S+\s+){5}\./$,) {
- push(@index, $line . "\n");
+ push @index, $line . "\n";
}
}
}; # End $collect = sub;
- spawn({ fail => 'never', out => $collect, err_append => "$dir/index-errors" },
+ spawn ({ fail => 'never', out => $collect, err_append => "$dir/orig-index-errors" },
['tar', @tar_options, "$dir/$tarball"]);
if ($last) {
- fail("tar output (for $tarball from $pkg) does not end in a newline");
+ fail "tar output (for $tarball from $pkg) does not end in a newline";
}
# We now need to see if all files in the tarball have a common prefix. If so,
# we're going to strip that prefix off each file name. We also remove lines
@@ -139,7 +140,7 @@ sub index_src {
my ($filename) = ($line =~ /^(?:\S+\s+){5}(.*)/);
$filename =~ s,^\./+,,o;
my ($dirname) = ($filename =~ m,^([^/]+),);
- if (defined($dirname) and $dirname eq $filename and not $line =~ m/^d/o) {
+ if (defined $dirname and $dirname eq $filename and not $line =~ m/^d/o) {
$prefix = '';
} elsif (defined $dirname) {
if (not defined $prefix) {
@@ -175,12 +176,6 @@ sub index_src {
();
}
} @index;
- my $filename = 'source-prefix';
- $filename .= "-$compname" if $compname;
- open PREFIX, '>', "$dir/$filename"
- or fail "opening $filename for $pkg: $!";
- print PREFIX "$prefix\n";
- close PREFIX or fail "closing $filename for $pkg: $!";
} elsif ($compname) {
# Prefix with the compname (because that is where they will be
# unpacked to.
@@ -191,54 +186,8 @@ sub index_src {
}
# Now that we have the file names we want, write them out sorted to the index
# file.
- spawn({ fail => 'error', out => "$dir/index.gz" },
+ spawn ({ fail => 'error', out => "$dir/orig-index.gz" },
sub { print @result }, '|', ['sort', '-k', '6'],
'|', ['gzip', '--best', '-c']);
return 1;
}
-
-# Creates an index for binary packages
-sub index_deb {
- my (@jobs, $job);
-
- foreach my $file (qw(index index-errors index-owner-id)) {
- unlink "$dir/$file" or fail "$file: $!" if -f "$dir/$file";
- }
-
- $job = { fail => 'error',
- out => "$dir/index.gz",
- err => "$dir/index-errors" };
- push @jobs, $job;
- # (replaces dpkg-deb -c)
- # create index file for package
- spawn($job,
- ['dpkg-deb', '--fsys-tarfile', "$dir/deb" ],
- '|', ['tar', 'tfv', '-'],
- '|', ['sed', '-e', 's/^h/-/'],
- '|', ['sort', '-k', '6'],
- '|', ['gzip', '--best', '-c'], '&');
-
- $job = { fail => 'error',
- out => "$dir/index-owner-id.gz",
- err => '/dev/null' };
- push @jobs, $job;
- # (replaces dpkg-deb -c)
- # create index file for package with owner IDs instead of names
- spawn($job,
- ['dpkg-deb', '--fsys-tarfile', "$dir/deb" ],
- '|', ['tar', '--numeric-owner', '-tvf', '-'],
- '|', ['sed', '-e', 's/^h/-/'],
- '|', ['sort', '-k', '6'],
- '|', ['gzip', '--best', '-c'], '&');
-
- reap(@jobs);
- undef @jobs;
-
- return 1;
-}
-
-# Local Variables:
-# indent-tabs-mode: nil
-# cperl-indent-level: 4
-# End:
-# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/collection/src-orig-index.desc b/collection/src-orig-index.desc
new file mode 100644
index 0000000..9b1d114
--- /dev/null
+++ b/collection/src-orig-index.desc
@@ -0,0 +1,7 @@
+Collector-Script: src-orig-index
+Info: This script create an index file of the contents of the orig tarballs.
+Type: source
+Needs-Info: index
+Version: 1
+
+
diff --git a/lib/Lintian/Collect/Package.pm b/lib/Lintian/Collect/Package.pm
index 20e0258..df8022f 100644
--- a/lib/Lintian/Collect/Package.pm
+++ b/lib/Lintian/Collect/Package.pm
@@ -160,16 +160,14 @@ sub file_info {
=item index (FILE)
Returns a L<path object|Lintian::Path> to FILE in the package. FILE
-must be relative to the root of the control.tar.gz and must be without
-leading slash (or "./"). If FILE is not in the package, it returns
-C<undef>.
+must be relative to the root of the unpacked package and must be
+without leading slash (or "./"). If FILE is not in the package, it
+returns C<undef>.
To get a list of entries in the package, see L</sorted_index>. To
actually access the underlying file (e.g. the contents), use
L</unpacked ([FILE])>.
-Caveat: Not
-
=cut
# sub index Needs-Info index
@@ -178,7 +176,7 @@ sub index {
return $self->_fetch_index_data('index', 'index', 'index-owner-id', $file);
}
-=item sorted_control_index
+=item sorted_index
Returns a sorted array of file names listed in the package. The names
will not have a leading slash (or "./") and can be passed to
diff --git a/lib/Lintian/Collect/Source.pm b/lib/Lintian/Collect/Source.pm
index 592a45d..4cc9c01 100644
--- a/lib/Lintian/Collect/Source.pm
+++ b/lib/Lintian/Collect/Source.pm
@@ -248,6 +248,50 @@ sub source_field {
return $self->{source_field};
}
+=item orig_index (FILE)
+
+Like L</index> except orig_index is based on the "orig tarballs" of
+the source packages.
+
+For native packages L</index> and L</orig_index> are generally
+identical.
+
+NB: If sorted_index includes a debian packaging, it is was
+contained in upstream part of the source package (or the package is
+native).
+
+=cut
+
+# sub orig_index Needs-Info src-orig-index
+sub orig_index {
+ my ($self, $file) = @_;
+ return $self->_fetch_index_data ('orig-index', 'src-orig-index', undef, $file);
+}
+
+=item sorted_orig_index
+
+Like L<sorted_index|Lintian::Collect/sorted_index> except
+sorted_orig_index is based on the "orig tarballs" of the source
+packages.
+
+For native packages L<sorted_index|Lintian::Collect/sorted_index> and
+L</sorted_orig_index> are generally identical.
+
+NB: If sorted_orig_index includes a debian packaging, it is was
+contained in upstream part of the source package (or the package is
+native).
+
+=cut
+
+# sub sorted_orig_index Needs-Info :orig_index
+sub sorted_orig_index {
+ my ($self) = @_;
+ # orig_index does all our work for us, so call it if
+ # sorted_orig_index has not been created yet.
+ $self->orig_index ('') unless exists $self->{'sorted_orig-index'};
+ return @{ $self->{'sorted_orig-index'} };
+}
+
=item binary_field (PACKAGE[, FIELD[, DEFAULT]])
Returns the content of the field FIELD for the binary package PACKAGE
@@ -510,15 +554,39 @@ For the general documentation of this method, please refer to the
documenation of it in
L<Lintian::Collect::Package|Lintian::Collect::Package/index (FILE)>.
-The index of a source package is not very well defined for source
-packages and this is reflected in the behaviour of this method and
-sorted_index as well. In general all files in the "upstream
-tarball(s)" are covered by this method and sorted_index.
+The index of a source package is not very well defined for non-native
+source packages. This method gives the index of the "unpacked"
+package (with 3.0 (quilt), this implies patches have been applied).
+
+If you want the index of what is listed in the upstream orig tarballs,
+then there is L</orig_index>.
+
+For native packages, the two indices are generally the same as they
+only have one tarball and their debian packaging is included in that
+tarball.
+
+IMPLEMENTATION DETAIL/CAVEAT: Lintian currently (2.5.11) generates
+this by running "find(1)" after unpacking the the source package.
+This has three consequnces.
+
+First it means that (original) owner/group data is lost; Lintian
+inserts "root/root" here. This is usually not a problem as
+owner/group information for source packages do not really follow any
+standards.
+
+Secondly, permissions are modified by A) umask and B) laboratory
+set{g,u}id bits (the laboratory on lintian.d.o has setgid). This is
+*not* corrected/altered. Note Lintian (usually) breaks if any of the
+"user" bits are set in the umask, so that part of the permission bit
+I<should> be reliable.
+
+Again, this shouldn't be a problem as permissions in source packages
+are usually not important. Though if accuracy is needed here,
+L</orig_index> may used instead (assuming it has the file in
+question).
-For non-native packages, this means that the packaging is generally
-not available via these methods. Though if upstream has its own
-packages files, these may be listed even if they are not available
-via unpacked as is the case for 3.0 (quilt) packages.
+Third, hardlinking information is lost and no attempt has been made
+to restore it.
=cut
diff --git a/t/scripts/unpack-level.t b/t/scripts/unpack-level.t
index a684eb0..7660c65 100755
--- a/t/scripts/unpack-level.t
+++ b/t/scripts/unpack-level.t
@@ -31,7 +31,7 @@ my @l2refs = (
qr|->unpacked|,
qr<unpacked/>,
qr<unpacked-errors>,
- qr<chdir\s*\(\s*["'](?:\$dir/)?unpacked/?['"]\s*\)>,
+ qr<chdir\s*\(?\s*["'](?:\$dir/)?unpacked/?['"]\s*\)?>,
);
# For each desc file, load the first stanza of the file and check that if
--
Debian package checker
Reply to: