[SCM] Debian package checker branch, lab-refactor, updated. 2.5.3-151-g2eec10a
The following commit has been merged in the lab-refactor branch:
commit 9b5fd3da19d6a910a6d857b2ea88c1c2da1a56a4
Author: Niels Thykier <niels@thykier.net>
Date: Thu Oct 27 16:41:26 2011 +0200
harness: Use Lintian::Lab for purging/cleaning the lab
Signed-off-by: Niels Thykier <niels@thykier.net>
diff --git a/lib/Lintian/Lab/Util.pm b/lib/Lintian/Lab/Util.pm
new file mode 100644
index 0000000..3386c60
--- /dev/null
+++ b/lib/Lintian/Lab/Util.pm
@@ -0,0 +1,121 @@
+package Lintian::Lab::Util;
+
+use strict;
+use warnings;
+
+use Carp qw(croak);
+
+use Lintian::Lab::Manifest;
+use Util ();
+
+# local_mirror_manifests ($mirdir, $dists, $areas, $archs)
+#
+# Returns a list of manifests that represents what is on the local mirror
+# at $mirdir. 3 manifests will be returned, one for "source", one for "binary"
+# and one for "udeb" packages. They are populated based on the "Sources" and
+# "Packages" files.
+#
+# $mirdir - the path to the local mirror
+# $dists - listref of dists to consider (i.e. ['unstable'])
+# $areas - listref of areas to consider (i.e. ['main', 'contrib', 'non-free'])
+# $archs - listref of archs to consider (i.e. ['i386', 'amd64'])
+#
+sub local_mirror_manifests {
+ my ($mirdir, $dists, $areas, $archs) = @_;
+ my $srcman = Lintian::Lab::Manifest->new ('source');
+ my $binman = Lintian::Lab::Manifest->new ('binary');
+ my $udebman = Lintian::Lab::Manifest->new ('udeb');
+ foreach my $dist (@$dists) {
+ foreach my $area (@$areas) {
+ my $srcs = "$mirdir/dists/$dist/$area/source/Sources";
+ my $srcfd = _open_data_file ($srcs);
+ my $srcsub = sub { _parse_srcs_pg ($srcman, $mirdir, $area, @_) };
+ # Binaries have a "per arch" file.
+ foreach my $arch (@$archs) {
+ my $pkgs = "$mirdir/dists/$dist/$area/binary-$arch/Packages";
+ my $upkgs = "$mirdir/dists/$dist/$area/debian-installer/" .
+ "binary-$arch/Packages";
+ my $pkgfd = _open_data_file ($pkgs);
+ my $binsub = sub { _parse_pkgs_pg ($binman, $mirdir, $area, @_) };
+ my $upkgfd = _open_data_file ($upkgs);
+ my $udebsub = sub { _parse_pkgs_pg ($udebman, $mirdir, $area, @_) };
+ Util::_parse_dpkg_control_iterative ($binsub, $pkgfd);
+ Util::_parse_dpkg_control_iterative ($udebsub, $upkgfd);
+ close $pkgfd;
+ close $upkgfd;
+ }
+ }
+ }
+ return ($srcman, $binman, $udebman);
+}
+
+# _open_data_file ($file)
+#
+# Opens $file if it exists, otherwise it tries common extensions (i.e. .gz) and opens
+# that instead. It may pipe the file through a external decompressor, so the returned
+# file descriptor cannot be assumed to be a file.
+#
+# If $file does not exists and no common extensions are found, this croaks.
+sub _open_data_file {
+ my ($file) = @_;
+ if (-e $file) {
+ open my $fd, '<', $file or croak "opening $file: $!";
+ return $fd;
+ }
+ foreach my $com (['gz', ['gzip', '-dc']] ){
+ my ($ext, $cmd) = @$com;
+ if ( -e "$file.$ext") {
+ open my $c, '-|', @$cmd, "$file.$ext" or croak "running @$cmd $file.$ext";
+ return $c;
+ }
+ }
+ croak "Cannot find $file";
+}
+
+# Helper for local_mirror_manifests - it parses a paragraph from Packages file
+sub _parse_pkgs_pg {
+ my ($manifest, $mirdir, $area, $data) = @_;
+ unless ($data->{'source'}) {
+ $data->{'source'} = $data->{'package'};
+ } elsif ($data->{'source'} =~ /^([-+\.\w]+)\s+\((.+)\)$/) {
+ $data->{'source'} = $1;
+ $data->{'source-version'} = $2;
+ } else {
+ $data->{'source-version'} = $data->{'version'};
+ }
+ unless (defined $data->{'source-version'}) {
+ $data->{'source-version'} = $data->{'version'};
+ }
+ $data->{'file'} = $mirdir . '/' . $data->{'filename'};
+ $data->{'area'} = $area;
+ # $manifest strips redundant fields for us. But for clarity and to
+ # avoid "hard to debug" cases $manifest renames the fields, we explicitly
+ # remove the "filename" field.
+ delete $data->{'filename'};
+
+ $manifest->set ($data);
+}
+
+# Helper for local_mirror_manifests - it parses a paragraph from Sources file
+sub _parse_srcs_pg {
+ my ($manifest, $mirdir, $area, $data) = @_;
+ my $dir = $data->{'directory'}//'';
+ $dir .= '/' if $dir;
+ foreach my $f (split m/\n/, $data->{'files'}) {
+ $f =~ s/^\s++//o;
+ next unless $f && $f =~ m/\.dsc$/;
+ my (undef, undef, $file) = split m/\s++/, $f;
+ # $dir should end with a slash if it is non-empty.
+ $data->{'file'} = $mirdir . "/$dir" . $file;
+ last;
+ }
+ $data->{'area'} = $area;
+ # Rename a field :)
+ $data->{'source'} = $data->{'package'};
+
+ # $manifest strips redundant fields for us.
+ $manifest->set ($data);
+}
+
+1;
+
diff --git a/reporting/harness b/reporting/harness
index 064871f..ef970f5 100755
--- a/reporting/harness
+++ b/reporting/harness
@@ -66,6 +66,8 @@ unshift @INC, "$LINTIAN_ROOT/lib";
require Read_pkglists;
import Read_pkglists;
require Util;
+require Lintian::Lab;
+require Lintian::Lab::Manifest;
# turn file buffering off
$| = 1;
@@ -101,22 +103,12 @@ if ($LINTIAN_GPG_CHECK) {
unless(-f $LINTIAN_BIN_DIR . '/gpg');
}
-if ($opt_c) { # purge the old packages
- system("rm -rf $LINTIAN_LAB/binary") == 0 || die "$!";
- system("mkdir -m 2775 $LINTIAN_LAB/binary") == 0 || die "$!";
- system("rm -rf $LINTIAN_LAB/udeb") == 0 || die "$!";
- system("mkdir -m 2775 $LINTIAN_LAB/udeb") == 0 || die "$!";
- system("rm -rf $LINTIAN_LAB/source") == 0 || die "$!";
- system("mkdir -m 2775 $LINTIAN_LAB/source") == 0 || die "$!";
- system("rm -f $LINTIAN_LAB/info/*") == 0 || die "$!";
-}
+my $LAB = Lintian::Lab ($LINTIAN_LAB);
-unless ($opt_r) {
- # make lintian update its packages files and save output
- run("$lintian_cmd -v --setup-lab >$changes_file")
- or Die('cannot run lintian --setup-lab');
- Log('');
-}
+# purge the old packages
+$LAB->delete_lab if $opt_c;
+
+$LAB->create_lab ({ 'mode' => 02775}) unless $LAB->lab_exists;
unless ($opt_f || $opt_c) {
unless ($opt_r) {
@@ -128,6 +120,26 @@ unless ($opt_f || $opt_c) {
}
}
+unless ($opt_r) {
+ my @manifests = local_mirror_manifests ($LINTIAN_ARCHIVEDIR, [_trim_split ($LINTIAN_DIST)],
+ [_trim_split ($LINTIAN_AREA)], [_trim_split ($LINTIAN_ARCH)]);
+ my @diffs = $LAB->generate_diff (@manifests);
+
+ # Remove old/stale packages from the lab
+
+ foreach my $diff (@diffs) {
+ my $type = $diff->type;
+ foreach my $removed (@{ $diff->removed }) {
+ my @keys = @$removed;
+ my $entry = $LAB->get_package ($type, @keys);
+ if ($entry) {
+ $entry->delete_lab_entry;
+ }
+ }
+ }
+}
+
+
if ($opt_f) { # check all packages
Log('Running Lintian over all packages...');
my $cmd = "$lintian_cmd -I -E --pedantic -v -a --show-overrides -U changelog-file >$lintian_log 2>&1";
@@ -301,6 +313,124 @@ sub Die {
exit 1;
}
+sub _trim_split {
+ my ($val) = @_;
+ return () unless $val;
+ $val =~ s/^\s++//o;
+ $val =~ s/\s++$//o;
+ return split m/\s*+,\s*+/o, $val;
+}
+
+# local_mirror_manifests ($mirdir, $dists, $areas, $archs)
+#
+# Returns a list of manifests that represents what is on the local mirror
+# at $mirdir. 3 manifests will be returned, one for "source", one for "binary"
+# and one for "udeb" packages. They are populated based on the "Sources" and
+# "Packages" files.
+#
+# $mirdir - the path to the local mirror
+# $dists - listref of dists to consider (i.e. ['unstable'])
+# $areas - listref of areas to consider (i.e. ['main', 'contrib', 'non-free'])
+# $archs - listref of archs to consider (i.e. ['i386', 'amd64'])
+#
+sub local_mirror_manifests {
+ my ($mirdir, $dists, $areas, $archs) = @_;
+ my $srcman = Lintian::Lab::Manifest->new ('source');
+ my $binman = Lintian::Lab::Manifest->new ('binary');
+ my $udebman = Lintian::Lab::Manifest->new ('udeb');
+ foreach my $dist (@$dists) {
+ foreach my $area (@$areas) {
+ my $srcs = "$mirdir/dists/$dist/$area/source/Sources";
+ my $srcfd = _open_data_file ($srcs);
+ my $srcsub = sub { _parse_srcs_pg ($srcman, $mirdir, $area, @_) };
+ # Binaries have a "per arch" file.
+ foreach my $arch (@$archs) {
+ my $pkgs = "$mirdir/dists/$dist/$area/binary-$arch/Packages";
+ my $upkgs = "$mirdir/dists/$dist/$area/debian-installer/" .
+ "binary-$arch/Packages";
+ my $pkgfd = _open_data_file ($pkgs);
+ my $binsub = sub { _parse_pkgs_pg ($binman, $mirdir, $area, @_) };
+ my $upkgfd = _open_data_file ($upkgs);
+ my $udebsub = sub { _parse_pkgs_pg ($udebman, $mirdir, $area, @_) };
+ Util::_parse_dpkg_control_iterative ($binsub, $pkgfd);
+ Util::_parse_dpkg_control_iterative ($udebsub, $upkgfd);
+ close $pkgfd;
+ close $upkgfd;
+ }
+ }
+ }
+ return ($srcman, $binman, $udebman);
+}
+
+# _open_data_file ($file)
+#
+# Opens $file if it exists, otherwise it tries common extensions (i.e. .gz) and opens
+# that instead. It may pipe the file through a external decompressor, so the returned
+# file descriptor cannot be assumed to be a file.
+#
+# If $file does not exists and no common extensions are found, this dies. It may also
+# die if it finds a file, but is unable to open it.
+sub _open_data_file {
+ my ($file) = @_;
+ if (-e $file) {
+ open my $fd, '<', $file or Die "opening $file: $!";
+ return $fd;
+ }
+ foreach my $com (['gz', ['gzip', '-dc']] ){
+ my ($ext, $cmd) = @$com;
+ if ( -e "$file.$ext") {
+ open my $c, '-|', @$cmd, "$file.$ext" or Die "running @$cmd $file.$ext";
+ return $c;
+ }
+ }
+ Die "Cannot find $file";
+}
+
+# Helper for local_mirror_manifests - it parses a paragraph from Packages file
+sub _parse_pkgs_pg {
+ my ($manifest, $mirdir, $area, $data) = @_;
+ unless ($data->{'source'}) {
+ $data->{'source'} = $data->{'package'};
+ } elsif ($data->{'source'} =~ /^([-+\.\w]+)\s+\((.+)\)$/) {
+ $data->{'source'} = $1;
+ $data->{'source-version'} = $2;
+ } else {
+ $data->{'source-version'} = $data->{'version'};
+ }
+ unless (defined $data->{'source-version'}) {
+ $data->{'source-version'} = $data->{'version'};
+ }
+ $data->{'file'} = $mirdir . '/' . $data->{'filename'};
+ $data->{'area'} = $area;
+ # $manifest strips redundant fields for us. But for clarity and to
+ # avoid "hard to debug" cases $manifest renames the fields, we explicitly
+ # remove the "filename" field.
+ delete $data->{'filename'};
+
+ $manifest->set ($data);
+}
+
+# Helper for local_mirror_manifests - it parses a paragraph from Sources file
+sub _parse_srcs_pg {
+ my ($manifest, $mirdir, $area, $data) = @_;
+ my $dir = $data->{'directory'}//'';
+ $dir .= '/' if $dir;
+ foreach my $f (split m/\n/, $data->{'files'}) {
+ $f =~ s/^\s++//o;
+ next unless $f && $f =~ m/\.dsc$/;
+ my (undef, undef, $file) = split m/\s++/, $f;
+ # $dir should end with a slash if it is non-empty.
+ $data->{'file'} = $mirdir . "/$dir" . $file;
+ last;
+ }
+ $data->{'area'} = $area;
+ # Rename a field :)
+ $data->{'source'} = $data->{'package'};
+
+ # $manifest strips redundant fields for us.
+ $manifest->set ($data);
+}
+
# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
--
Debian package checker
Reply to: