[Date Prev][Date Next] [Thread Prev][Thread Next] [Date Index] [Thread Index]

[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: