[SCM] Debian package checker branch, master, updated. 2.5.1-65-g1e6fc43
The following commit has been merged in the master branch:
commit 1e6fc43224dce36ce732ca2b06595c396a769133
Author: Niels Thykier <niels@thykier.net>
Date: Sun Jul 10 18:36:11 2011 +0200
Refactored common parts into Lintian::Collect::Package
diff --git a/debian/changelog b/debian/changelog
index 960f34d..966dbc6 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -152,6 +152,9 @@ lintian (2.5.2) UNRELEASED; urgency=low
+ [NT] Symlink in all components of the source package when
creating the source entry in the lab. Also removed legacy
code for using the old unpack scripts.
+ * lib/Lintian/Collect/{Binary,Source}.pm:
+ + [NT] Refactored code from these files into the module
+ Lintian::Collect::Package.
* lib/Lintian/Collect/Package.pm:
+ [NT] New file. This serves as a base for Lintian::Collect
modules that can be unpacked.
diff --git a/lib/Lintian/Collect/Binary.pm b/lib/Lintian/Collect/Binary.pm
index 96e082a..019e9cd 100644
--- a/lib/Lintian/Collect/Binary.pm
+++ b/lib/Lintian/Collect/Binary.pm
@@ -65,108 +65,8 @@ sub changelog {
return $self->{changelog};
}
-# Returns the information from the indices
-# FIXME: should maybe return an object
-# sub index Needs-Info <>
-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};
-}
-
-# Returns sorted file index (eqv to sort keys %{$info->index}), except it is cached.
-# sub sorted_index Needs-Info <>
-sub sorted_index {
- my ($self) = @_;
- my $index;
- my @result;
- return $self->{sorted_index} if exists $self->{sorted_index};
- $index = $self->index();
- @result = sort keys %{$index};
- $self->{sorted_index} = \@result;
- return \@result;
-}
-
-# Returns the information from collect/file-info
-sub file_info {
- my ($self) = @_;
- return $self->{file_info} if exists $self->{file_info};
- my $base_dir = $self->base_dir();
- my %file_info;
- # sub file_info Needs-Info file-info
- open(my $idx, '<', "$base_dir/file-info")
- or fail("cannot open $base_dir/file-info: $!");
- while (<$idx>) {
- chomp;
-
- m/^(.+?)\x00\s+(.*)$/o
- or fail("an error in the file pkg is preventing lintian from checking this package: $_");
- my ($file, $info) = ($1,$2);
-
- $file =~ s,^\./,,o;
- $file =~ s,/+$,,o;
-
- $file_info{$file} = $info;
- }
- close $idx;
- $self->{file_info} = \%file_info;
-
- return $self->{file_info};
-}
-
-
-# Returns sorted file info (eqv to sort keys %{$info->file_info}),
-# except it is cached.
-# sub sorted_file_info Needs-Info <>
+# 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{
my ($self) = @_;
my $info;
diff --git a/lib/Lintian/Collect/Package.pm b/lib/Lintian/Collect/Package.pm
index bb9eda0..19f77a1 100644
--- a/lib/Lintian/Collect/Package.pm
+++ b/lib/Lintian/Collect/Package.pm
@@ -24,6 +24,7 @@ use warnings;
use base 'Lintian::Collect';
use Carp qw(croak);
+use Util qw(perm2oct);
# Returns the path to the dir where the package is unpacked
# or a file therein (see pod below)
@@ -46,6 +47,105 @@ sub unpacked {
return $unpacked;
}
+# Returns the information from collect/file-info
+sub file_info {
+ my ($self) = @_;
+ return $self->{file_info} if exists $self->{file_info};
+ my $base_dir = $self->base_dir();
+ my %file_info;
+ # sub file_info Needs-Info file-info
+ open(my $idx, '<', "$base_dir/file-info")
+ or fail("cannot open $base_dir/file-info: $!");
+ while (<$idx>) {
+ chomp;
+
+ m/^(.+?)\x00\s+(.*)$/o
+ or fail("an error in the file pkg is preventing lintian from checking this package: $_");
+ my ($file, $info) = ($1,$2);
+
+ $file =~ s,^\./,,o;
+ $file =~ s,/+$,,o;
+
+ $file_info{$file} = $info;
+ }
+ close $idx;
+ $self->{file_info} = \%file_info;
+
+ return $self->{file_info};
+}
+
+# Returns the information from the indices
+# FIXME: should maybe return an object
+# 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};
+}
+
+# Returns sorted file index (eqv to sort keys %{$info->index}), except it is cached.
+# sub sorted_index Needs-Info index
+sub sorted_index {
+ my ($self) = @_;
+ my $index;
+ my @result;
+ return $self->{sorted_index} if exists $self->{sorted_index};
+ $index = $self->index();
+ @result = sort keys %{$index};
+ $self->{sorted_index} = \@result;
+ return \@result;
+}
+
+
1;
@@ -120,6 +220,24 @@ The following code may be helpful in checking for path traversal:
Alternatively one can use Util::resolve_pkg_path.
+=item file_info
+
+Returns a hashref mapping file names to the output of file for that file.
+
+Note the file names do not have any leading "./" nor "/".
+
+=item index
+
+Returns a hashref to the index information (permissions, file type etc).
+
+Note the file names do not have any leading "./" nor "/".
+
+=item sorted_index
+
+Returns a sorted list of all files listed in index (or file_info hashref).
+
+It may contain an "empty" entry denoting the "root dir".
+
=back
=head1 AUTHOR
diff --git a/lib/Lintian/Collect/Source.pm b/lib/Lintian/Collect/Source.pm
index aa1923e..ab48a93 100644
--- a/lib/Lintian/Collect/Source.pm
+++ b/lib/Lintian/Collect/Source.pm
@@ -151,27 +151,6 @@ sub binary_relation {
return $self->{binary_relation}->{$field};
}
-# Returns the information from collect/file-info.
-sub file_info {
- my ($self) = @_;
- return $self->{file_info} if exists $self->{file_info};
-
- my %file_info;
- my $base_dir = $self->base_dir();
- # sub file_info Needs-Info file-info
- open(my $idx, '<', "$base_dir/file-info") or fail("cannot open file-info: $!");
- while (<$idx>) {
- chomp;
- m/^(.+?)\x00\s+(.*)$/o or fail("cannot parse file output: $_");
- my ($file, $info) = ($1,$2);
- $file =~ s,^\./,,o;
- $file =~ s,/+$,,o;
- $file_info{$file} = $info;
- }
- close $idx;
- $self->{file_info} = \%file_info;
- return $self->{file_info};
-}
# Return a Lintian::Relation object for the given build relationship
# field. In addition to all the normal build relationship fields, the
--
Debian package checker
Reply to: