[SCM] Debian package checker branch, master, updated. 2.5.1-126-g2ec3d17
The following commit has been merged in the master branch:
commit 2ec3d1770be953091688ddb1e58123cc0e6c4e3e
Author: Niels Thykier <niels@thykier.net>
Date: Mon Jul 18 14:59:33 2011 +0200
Migrated control-files to the new Collect control_index API
diff --git a/checks/control-files b/checks/control-files
index 9de63bf..8c2ac88 100644
--- a/checks/control-files
+++ b/checks/control-files
@@ -54,23 +54,19 @@ sub run {
my $pkg = shift;
my $type = shift;
+my $info = shift;
my %ctrl = $type eq 'udeb' ? %ctrl_udeb : %ctrl_deb;
my %ctrl_alt = $type eq 'udeb' ? %ctrl_deb : %ctrl_udeb;
# process control-index file
-open(IN, '<', 'control-index') or fail("cannot open control-index file: $!");
-while (<IN>) {
- chop;
-
- my ($perm,$owner,$size,$date,$time,$file) = split(' ', $_, 6);
+my $cindex = $info->control_index;
+foreach my $file (sort keys %$cindex) {
+ next unless $file;
+ my $cindex_info = $cindex->{$file};
+ my $owner;
my $operm;
- next if $file eq './';
-
- $file =~ s,^(\./),,;
- $file =~ s/ link to .*//;
- $file =~ s/ -> .*//;
next if $file eq './';
@@ -86,7 +82,7 @@ while (<IN>) {
}
# I'm not sure about the udeb case
- if ($type ne 'udeb' and $size == 0) {
+ if ($type ne 'udeb' and $cindex_info->{size} == 0) {
tag 'control-file-is-empty', $file;
}
@@ -95,7 +91,7 @@ while (<IN>) {
# this file isn't installed on the systems anyways)
next if $file eq 'control';
- $operm = perm2oct($perm);
+ $operm = $cindex_info->{operm};
# correct permissions?
unless ($operm == $ctrl{$file}) {
@@ -103,6 +99,8 @@ while (<IN>) {
sprintf('%s %04o != %04o',$file,$operm,$ctrl{$file});
}
+ $owner = $cindex_info->{owner} . '/' . $cindex_info->{group};
+
# correct owner?
unless ($owner eq 'root/root') {
tag 'control-file-has-bad-owner', "$file $owner != root/root";
diff --git a/lib/Lintian/Collect/Binary.pm b/lib/Lintian/Collect/Binary.pm
index 1065abb..1649727 100644
--- a/lib/Lintian/Collect/Binary.pm
+++ b/lib/Lintian/Collect/Binary.pm
@@ -74,6 +74,15 @@ sub control {
return $self->_fetch_extracted_dir('control', 'control', $file);
}
+# Like index except it returns the index for the control/metadata of
+# binary package.
+#
+# sub control_index Needs-Info bin-pkg-control
+sub control_index {
+ my ($self) = @_;
+ return $self->_fetch_index_data('control-index', 'control-index');
+}
+
# Returns sorted file info (eqv to sort keys %{$info->file_info'}), except it is cached.
# sub sorted_file_info Needs-Info file-info
sub sorted_file_info{
diff --git a/lib/Lintian/Collect/Package.pm b/lib/Lintian/Collect/Package.pm
index 1a0ae54..93f8095 100644
--- a/lib/Lintian/Collect/Package.pm
+++ b/lib/Lintian/Collect/Package.pm
@@ -67,57 +67,7 @@ sub file_info {
# sub index Needs-Info index
sub index {
my ($self) = @_;
- return $self->{index} if exists $self->{index};
- my $base_dir = $self->base_dir();
- my (%idx, %dir_counts);
- open my $idx, '<', "$base_dir/index"
- or fail("cannot open index file $base_dir/index: $!");
- open my $num_idx, '<', "$base_dir/index-owner-id"
- or fail("cannot open index file $base_dir/index-owner-id: $!");
- while (<$idx>) {
- chomp;
-
- my (%file, $perm, $owner, $name);
- ($perm,$owner,$file{size},$file{date},$file{time},$name) =
- split(' ', $_, 6);
- $file{operm} = perm2oct($perm);
- $file{type} = substr $perm, 0, 1;
-
- my $numeric = <$num_idx>;
- chomp $numeric;
- fail('cannot read index file index-owner-id') unless defined $numeric;
- my ($owner_id, $name_chk) = (split(' ', $numeric, 6))[1, 5];
- fail("mismatching contents of index files: $name $name_chk")
- if $name ne $name_chk;
-
- ($file{owner}, $file{group}) = split '/', $owner, 2;
- ($file{uid}, $file{gid}) = split '/', $owner_id, 2;
-
- $name =~ s,^\./,,;
- if ($name =~ s/ link to (.*)//) {
- $file{type} = 'h';
- $file{link} = $1;
- $file{link} =~ s,^\./,,;
- } elsif ($file{type} eq 'l') {
- ($name, $file{link}) = split ' -> ', $name, 2;
- }
- $file{name} = $name;
-
- # count directory contents:
- $dir_counts{$name} ||= 0 if $file{type} eq 'd';
- $dir_counts{$1} = ($dir_counts{$1} || 0) + 1
- if $name =~ m,^(.+/)[^/]+/?$,;
-
- $idx{$name} = \%file;
- }
- foreach my $file (keys %idx) {
- if ($dir_counts{$idx{$file}->{name}}) {
- $idx{$file}->{count} = $dir_counts{$idx{$file}->{name}};
- }
- }
- $self->{index} = \%idx;
-
- return $self->{index};
+ return $self->_fetch_index_data('index', 'index', 'index-owner-id');
}
# Returns sorted file index (eqv to sort keys %{$info->index}), except it is cached.
@@ -155,6 +105,69 @@ sub _fetch_extracted_dir {
return $dir;
}
+# Backing method for index and others; this is not a part of the API.
+# sub _fetch_index_data Needs-Info <>
+sub _fetch_index_data {
+ my ($self, $field, $index, $indexown) = @_;
+ return $self->{$field} if exists $self->{$index};
+ my $base_dir = $self->base_dir();
+ my (%idxh, %dir_counts);
+ my $num_idx;
+ open my $idx, '<', "$base_dir/$index"
+ or fail("cannot open index file $base_dir/$index: $!");
+ if ($indexown) {
+ open $num_idx, '<', "$base_dir/$indexown"
+ or fail("cannot open index file $base_dir/$indexown: $!");
+ }
+ while (<$idx>) {
+ chomp;
+
+ my (%file, $perm, $owner, $name);
+ ($perm,$owner,$file{size},$file{date},$file{time},$name) =
+ split(' ', $_, 6);
+ $file{operm} = perm2oct($perm);
+ $file{type} = substr $perm, 0, 1;
+
+ if ($num_idx) {
+ # If we have a "numeric owner" index file, read that as well
+ my $numeric = <$num_idx>;
+ chomp $numeric;
+ fail('cannot read index file $indexown') unless defined $numeric;
+ my ($owner_id, $name_chk) = (split(' ', $numeric, 6))[1, 5];
+ fail("mismatching contents of index files: $name $name_chk")
+ if $name ne $name_chk;
+ ($file{uid}, $file{gid}) = split '/', $owner_id, 2;
+ }
+
+ ($file{owner}, $file{group}) = split '/', $owner, 2;
+
+ $name =~ s,^\./,,;
+ if ($name =~ s/ link to (.*)//) {
+ $file{type} = 'h';
+ $file{link} = $1;
+ $file{link} =~ s,^\./,,;
+ } elsif ($file{type} eq 'l') {
+ ($name, $file{link}) = split ' -> ', $name, 2;
+ }
+ $file{name} = $name;
+
+ # count directory contents:
+ $dir_counts{$name} ||= 0 if $file{type} eq 'd';
+ $dir_counts{$1} = ($dir_counts{$1} || 0) + 1
+ if $name =~ m,^(.+/)[^/]+/?$,;
+
+ $idxh{$name} = \%file;
+ }
+ foreach my $file (keys %idxh) {
+ if ($dir_counts{$idxh{$file}->{name}}) {
+ $idxh{$file}->{count} = $dir_counts{$idxh{$file}->{name}};
+ }
+ }
+ $self->{$field} = \%idxh;
+ close $idx;
+ close $num_idx if $num_idx;
+ return $self->{$field};
+}
1;
--
Debian package checker
Reply to: