[SCM] Debian package checker branch, master, updated. 2.5.1-64-g4e1f867
The following commit has been merged in the master branch:
commit 4e1f867e177378b2705042633017e7873dc36cef
Author: Niels Thykier <niels@thykier.net>
Date: Sun Jul 10 17:11:53 2011 +0200
Created Lintian::Collect::Package with unpacked method
Migrated existing checks to use the unpacked from the new module,
which is a base class of L::Collect:Binary and L::Collect::Source.
diff --git a/checks/cruft b/checks/cruft
index 1c32a07..70aec83 100644
--- a/checks/cruft
+++ b/checks/cruft
@@ -124,8 +124,8 @@ if ($format =~ /^\s*2\.0\s*\z/ or $format =~ /^\s*3\.0\s*\(quilt\)/) {
} elsif (not $info->native) {
check_diffstat('diffstat', \%warned);
}
-my $wanted = sub { find_cruft($pkg, $info, \%warned, $atdinbd, $ltinbd) };
-find($wanted, 'unpacked');
+my $wanted = sub { find_cruft($pkg, $info, $info->unpacked, \%warned, $atdinbd, $ltinbd) };
+find($wanted, $info->unpacked);
# Look for cruft based on file's results, but allow cruft in test directories
# where it may be part of a test suite.
@@ -279,8 +279,8 @@ sub check_debfiles {
# "source-contains" tag. The tag isn't entirely accurate, but it's better
# than creating yet a third set of tags, and this gets the severity right.
sub find_cruft {
- my ($pkg, $info, $warned, $atdinbd, $ltinbd) = @_;
- (my $name = $File::Find::name) =~ s,^(\./)?unpacked/,,;
+ my ($pkg, $info, $root, $warned, $atdinbd, $ltinbd) = @_;
+ (my $name = $File::Find::name) =~ s,^$root/,,;
# Ignore the .pc directory and its contents, created as part of the
# unpacking of a 3.0 (quilt) source package.
diff --git a/checks/debconf b/checks/debconf
index 8c4b6a0..c767ba0 100644
--- a/checks/debconf
+++ b/checks/debconf
@@ -513,7 +513,7 @@ if ($usespreinst) {
return 0 if ($pkg eq 'debconf') || ($type eq 'udeb');
foreach my $filename (sort keys %{$info->scripts}) {
- open(IN, '<', "unpacked/$filename") or fail("cannot open $filename: $!");
+ open(IN, '<', $info->unpacked($filename)) or fail("cannot open $filename: $!");
while (<IN>) {
s/#.*//; # Not perfect for Perl, but should be OK
if (m,/usr/share/debconf/confmodule, or
diff --git a/checks/files b/checks/files
index bd093f9..bdb552e 100644
--- a/checks/files
+++ b/checks/files
@@ -341,7 +341,7 @@ foreach my $file (@{$info->sorted_index}) {
}
#----------------- /etc/php5/conf.d
elsif ($file =~ m,^etc/php5/conf.d/.+\.ini$,) {
- open (PHPINI, '<', "unpacked/$file") or fail("cannot open .ini file: $!");
+ open (PHPINI, '<', $info->unpacked($file)) or fail("cannot open .ini file: $!");
while (<PHPINI>) {
next unless (m/^\s*#/);
tag 'obsolete-comments-style-in-php-ini', $file;
@@ -407,7 +407,8 @@ foreach my $file (@{$info->sorted_index}) {
if ($file =~ m,.gz$, and $index_info->{size} <= 276
and $index_info->{type} =~ m,^[-h],
and $info->file_info->{$file} =~ m/gzip compressed/) {
- unless (`gzip -dc unpacked/$file`) {
+ my $f = quotemeta($info->unpacked($file));
+ unless (`gzip -dc $f`) {
tag 'zero-byte-file-in-doc-directory', $file;
}
}
@@ -956,7 +957,7 @@ foreach my $file (@{$info->sorted_index}) {
# ---------------- embedded Feedparser library
if ($file =~ m,/feedparser\.py$, and $pkg ne 'python-feedparser') {
- open(FEEDPARSER, '<', "unpacked/$file") or fail("cannot open feedparser.py file: $!");
+ open(FEEDPARSER, '<', $info->unpacked($file)) or fail("cannot open feedparser.py file: $!");
while (<FEEDPARSER>) {
if (m,Universal feed parser,) {
tag 'embedded-feedparser-library', $file;
@@ -969,7 +970,7 @@ foreach my $file (@{$info->sorted_index}) {
# ---------------- embedded PEAR modules
foreach my $pearmodule (@pearmodules) {
if ($file =~ m,/$pearmodule->[0], and $pkg ne $pearmodule->[1]) {
- open (PEAR, '<', "unpacked/$file") or fail("cannot open PHP file: $!");
+ open (PEAR, '<', $info->unpacked($file)) or fail("cannot open PHP file: $!");
while (<PEAR>) {
if (m,/pear[/.],i) {
tag 'embedded-pear-module', $file;
diff --git a/checks/infofiles b/checks/infofiles
index bf2ecb9..ad71b68 100644
--- a/checks/infofiles
+++ b/checks/infofiles
@@ -91,11 +91,12 @@ foreach my $file (@{$info->sorted_index}) {
if (not defined $pid) {
fail("cannot fork: $!");
} elsif ($pid == 0) {
+ my $f = quotemeta($info->unpacked($file));
my %newenv = (LANG => 'C', PATH => $ENV{PATH},
LOCPATH => $ENV{LOCPATH});
undef %ENV;
%ENV = %newenv;
- exec "zcat \Qunpacked/$file\E 2>&1"
+ exec "zcat $f 2>&1"
or fail("cannot run zcat: $!");
}
local $_;
diff --git a/checks/manpages b/checks/manpages
index cbbc11b..39e3ba4 100644
--- a/checks/manpages
+++ b/checks/manpages
@@ -166,7 +166,8 @@ foreach my $file (@{$info->sorted_index}) {
}
}
} else { # not a symlink
- open (MANFILE, '-|', "zcat unpacked/\Q$file\E 2>/dev/null")
+ my $path = $info->unpacked($file);
+ open (MANFILE, '-|', "zcat \Q$path\E 2>/dev/null")
or fail("cannot open $file: $!");
my @manfile = ();
while (<MANFILE>) { push @manfile, $_; }
@@ -221,7 +222,7 @@ foreach my $file (@{$info->sorted_index}) {
LOCPATH => $ENV{LOCPATH});
undef %ENV;
%ENV = %newenv;
- exec "lexgrog unpacked/\Q$file\E 2>&1"
+ exec "lexgrog \Q$path\E 2>&1"
or fail("cannot run lexgrog: $!");
}
my $desc = <LEXGROG>;
@@ -242,10 +243,10 @@ foreach my $file (@{$info->sorted_index}) {
# processed properly. (Yes, there are man pages that include other
# pages with .so but aren't simple links; rbash, for instance.)
my $cmd;
- if ($file =~ m,^(.*)/(man\d/.*)$,) {
- $cmd = "cd unpacked/\Q$1\E && man --warnings -E UTF-8 -l \Q$2\E";
+ if ($path =~ m,^(.*)/(man\d/.*)$,) {
+ $cmd = "cd \Q$1\E && man --warnings -E UTF-8 -l \Q$2\E";
} else {
- $cmd = "man --warnings -E UTF-8 -l unpacked/\Q$file\E";
+ $cmd = "man --warnings -E UTF-8 -l \Q$path\E";
}
my $pid = open MANERRS, '-|';
if (not defined $pid) {
diff --git a/checks/menu-format b/checks/menu-format
index 9f82e15..718848e 100644
--- a/checks/menu-format
+++ b/checks/menu-format
@@ -625,13 +625,13 @@ sub VerifyLine {
or ($section =~ m:^(WindowManagers/Modules|FVWM Modules|Window Maker):));
if (exists($vals{'icon'})) {
- VerifyIcon($menufile, $fullname, $linecount, $vals{'icon'}, 32);
+ VerifyIcon($info, $menufile, $fullname, $linecount, $vals{'icon'}, 32);
}
if (exists($vals{'icon32x32'})) {
- VerifyIcon($menufile, $fullname, $linecount, $vals{'icon32x32'}, 32);
+ VerifyIcon($info, $menufile, $fullname, $linecount, $vals{'icon32x32'}, 32);
}
if (exists($vals{'icon16x16'})) {
- VerifyIcon($menufile, $fullname, $linecount, $vals{'icon16x16'}, 16);
+ VerifyIcon($info, $menufile, $fullname, $linecount, $vals{'icon16x16'}, 16);
}
# Check the needs tag.
@@ -686,7 +686,7 @@ sub VerifyLine {
sub VerifyIcon {
- my ($menufile, $fullname, $linecount, $icon, $size) = @_;
+ my ($info, $menufile, $fullname, $linecount, $icon, $size) = @_;
local *IN;
if ($icon eq 'none') {
@@ -702,9 +702,9 @@ sub VerifyIcon {
}
# Try the explicit location, and if that fails, try the standard path.
- my $iconfile = "unpacked/$icon";
+ my $iconfile = $info->unpacked($icon);
if (! -f $iconfile) {
- $iconfile = "unpacked/usr/share/pixmaps/$icon";
+ $iconfile = $info->unpacked("/usr/share/pixmaps/$icon");
}
if (! open (IN, '<', $iconfile)) {
@@ -743,7 +743,7 @@ parse_error:
sub VerifyDesktopFile {
my ($desktopfile, $file, $pkg, $info) = @_;
my %vals;
- open (DESKTOP, '<', "unpacked/$file")
+ open (DESKTOP, '<', $info->unpacked($file))
or fail("cannot open desktop file $file: $!");
my ($line, $saw_first, $warned_cr);
my @pending;
diff --git a/checks/scripts b/checks/scripts
index b2c05da..46e0954 100644
--- a/checks/scripts
+++ b/checks/scripts
@@ -340,6 +340,7 @@ my $all_parsed = Lintian::Relation->new($all_deps);
for my $filename (sort keys %{$info->scripts}) {
my $interpreter = $info->scripts->{$filename}->{interpreter};
my $calls_env = $info->scripts->{$filename}->{calls_env};
+ my $path;
$scripts{$filename} = 1;
my $in_docs = $filename =~ m,usr/share/doc/,;
@@ -397,17 +398,18 @@ for my $filename (sort keys %{$info->scripts}) {
and $filename !~ m,^etc/csh/login\.d/,)
and !$in_docs;
+ $path = $info->unpacked($filename);
# Syntax-check most shell scripts, but don't syntax-check scripts that end
# in .dpatch. bash -n doesn't stop checking at exit 0 and goes on to blow
# up on the patch itself.
if ($base =~ /^$known_shells_regex$/) {
if (-x $interpreter
- and ! script_is_evil_and_wrong("unpacked/$filename")
+ and ! script_is_evil_and_wrong($path)
and $filename !~ m,\.dpatch$,
# exclude some shells. zsh -n is broken, see #485885
and $base !~ m/^(z|t?c)sh$/) {
- if (check_script_syntax($interpreter, "unpacked/$filename")) {
+ if (check_script_syntax($interpreter, $path)) {
script_tag("shell-script-fails-syntax-check", $filename);
}
}
@@ -452,7 +454,7 @@ for my $filename (sort keys %{$info->scripts}) {
if ($filename =~ m,^etc/, and $base =~ /^$known_shells_regex$/) {
my ($saw_init, $saw_invoke);
local $.;
- open(FH, '<', 'unpacked/' . $filename);
+ open(FH, '<', $path);
while (<FH>) {
next if m,^\s*$,; # skip empty lines
next if m,^\s*\#,; # skip comment lines
diff --git a/checks/shared-libs b/checks/shared-libs
index ac32a5f..63914e7 100644
--- a/checks/shared-libs
+++ b/checks/shared-libs
@@ -163,8 +163,8 @@ for my $cur_file (@{$info->sorted_index}) {
tag 'sharedobject-in-library-directory-missing-soname', $cur_file;
} elsif ($cur_file =~ m/\.la$/ and not defined($cur_file_data->{link})) {
local $_;
- open(LAFILE, '<', "unpacked/$cur_file")
- or fail("Could not open unpacked/$cur_file for reading!");
+ open(LAFILE, '<', $info->unpacked($cur_file))
+ or fail("Could not open $cur_file for reading!");
while(<LAFILE>) {
next unless (m/^(libdir)='(.+?)'$/) or (m/^(dependency_libs)='(.+?)'$/);
my ($field, $value) = ($1, $2);
diff --git a/debian/changelog b/debian/changelog
index eee8714..960f34d 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -10,6 +10,9 @@ lintian (2.5.2) UNRELEASED; urgency=low
- calls-suidperl-directly
- suid-perl-script-but-no-perl-suid-dep
+ * checks/*:
+ + [NT] Migrated to use new methods in the Lintian::Collect
+ interfaces rather than accessing the Lab directly.
* checks/{cruft,fields}{,.desc}:
+ [NT] Relocated doc pkg not arch all tag; it was never
triggered since cruft was a source check and the tag
@@ -149,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/Package.pm:
+ + [NT] New file. This serves as a base for Lintian::Collect
+ modules that can be unpacked.
* lib/Lintian/Command.pm:
+ [NT] Added support for appending output to files without
truncating them first via the new out_append and
diff --git a/lib/Lintian/Collect/Binary.pm b/lib/Lintian/Collect/Binary.pm
index 39ad527..96e082a 100644
--- a/lib/Lintian/Collect/Binary.pm
+++ b/lib/Lintian/Collect/Binary.pm
@@ -21,7 +21,7 @@ package Lintian::Collect::Binary;
use strict;
use warnings;
-use base 'Lintian::Collect';
+use base 'Lintian::Collect::Package';
use Lintian::Relation;
use Carp qw(croak);
diff --git a/lib/Lintian/Collect/Package.pm b/lib/Lintian/Collect/Package.pm
new file mode 100644
index 0000000..bb9eda0
--- /dev/null
+++ b/lib/Lintian/Collect/Package.pm
@@ -0,0 +1,135 @@
+# -*- perl -*-
+# Lintian::Collect::Package -- interface to data collection for packages
+
+# Copyright (C) 2011 Niels Thykier
+#
+# 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 the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see <http://www.gnu.org/licenses/>.
+
+# This handles common things for things available in source and binary packages
+package Lintian::Collect::Package;
+
+use strict;
+use warnings;
+use base 'Lintian::Collect';
+
+use Carp qw(croak);
+
+# Returns the path to the dir where the package is unpacked
+# or a file therein (see pod below)
+# May croak if the package has not been unpacked.
+# sub unpacked Needs-Info unpacked
+sub unpacked {
+ my ($self, $file) = @_;
+ my $unpacked = $self->{unpacked};
+ if ( not defined $unpacked ) {
+ my $base_dir = $self->base_dir;
+ $unpacked = "$base_dir/unpacked";
+ croak "Unpacked not available" unless defined $unpacked && -d "$unpacked/";
+ $self->{unpacked} = $unpacked;
+ }
+ if ($file) {
+ # strip leading ./ - if that leaves something, return the path there
+ $file =~ s,^\.?/*+,,go;
+ return "$unpacked/$file" if $file;
+ }
+ return $unpacked;
+}
+
+
+1;
+
+=head1 NAME
+
+Lintian::Collect::Package - Lintian base interface to binary and source package data collection
+
+=head1 SYNOPSIS
+
+ my ($name, $type) = ('foobar', 'source');
+ my $collect = Lintian::Collect->new($name, $type);
+ my $file;
+ eval { $file = $collect->unpacked('/bin/ls'); };
+ if ( $file && -e $file ) {
+ # work with $file
+ ;
+ } elsif ($file) {
+ print "/bin/ls is not available in the Package\n";
+ } else {
+ print "Package has not been unpacked\n";
+ }
+
+=head1 DESCRIPTION
+
+Lintian::Collect::Package provides part of an interface to package
+data for source and binary packages. It implements data collection
+methods specific to all packages that can be unpacked (or can contain
+files)
+
+This module is in its infancy. Most of Lintian still reads all data from
+files in the laboratory whenever that data is needed and generates that
+data via collect scripts. The goal is to eventually access all data about
+source packages via this module so that the module can cache data where
+appropriate and possibly retire collect scripts in favor of caching that
+data in memory.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item unpacked([$name])
+
+Returns the path to the directory in which the package has been
+unpacked. If C<$name> is given, it will return the path to that
+specific file (or dir). The method will strip any leading "./" and
+"/" from C<$name>, but it will not check if C<$name> actually exists
+nor will it check for path traversals.
+ Caller is responsible for checking the sanity of the path passed to
+unpacked and verifying that the returned path points to the expected
+file.
+
+The path returned is not guaranteed to be inside the Lintian Lab as
+the package may have been unpacked outside the Lab (e.g. as
+optimization).
+
+The following code may be helpful in checking for path traversal:
+
+ use Cwd qw(realpath);
+
+ my $collect = ... ;
+ my $file = '../../../etc/passwd';
+ # Append slash to follow symlink if $collect->unpacked returns a symlink
+ my $uroot = realpath($collect->unpacked() . '/');
+ my $ufile = realpath($collect->unpacked($file));
+ if ($ufile =~ m,^$uroot,) {
+ # has not escaped $uroot
+ do_stuff($ufile);
+ } else {
+ # escaped $uroot
+ die "Possibly path traversal ($file)";
+ }
+
+Alternatively one can use Util::resolve_pkg_path.
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Niels Thykier <niels@thykier.net> for Lintian.
+
+=head1 SEE ALSO
+
+lintian(1), Lintian::Collect(3), Lintian::Collect::Binary(3),
+Lintian::Collect::Source(3)
+
+=cut
+
diff --git a/lib/Lintian/Collect/Source.pm b/lib/Lintian/Collect/Source.pm
index c2628f5..aa1923e 100644
--- a/lib/Lintian/Collect/Source.pm
+++ b/lib/Lintian/Collect/Source.pm
@@ -21,15 +21,13 @@ package Lintian::Collect::Source;
use strict;
use warnings;
-use base 'Lintian::Collect';
+use base 'Lintian::Collect::Package';
use Lintian::Relation;
use Parse::DebianChangelog;
use Util;
-our @ISA = qw(Lintian::Collect);
-
# Initialize a new source package collect object. Takes the package name,
# which is currently unused.
sub new {
@@ -41,7 +39,7 @@ sub new {
# Get the changelog file of a source package as a Parse::DebianChangelog
# object. Returns undef if the changelog file couldn't be found.
-# sub changelog Needs-Info <>
+# sub changelog Needs-Info debfiles
sub changelog {
my ($self) = @_;
return $self->{changelog} if exists $self->{changelog};
diff --git a/t/scripts/unpack-level.t b/t/scripts/unpack-level.t
index d117c79..8d215cc 100755
--- a/t/scripts/unpack-level.t
+++ b/t/scripts/unpack-level.t
@@ -28,6 +28,7 @@ our @DESCS = (<$ENV{LINTIAN_ROOT}/collection/*.desc>,
plan tests => scalar(@DESCS) * 2;
my @l2refs = (
+ qr|->unpacked|,
qr<unpacked/>,
qr<unpacked-errors>,
qr<chdir\s*\(\s*["']unpacked/?['"]\s*\)>,
--
Debian package checker
Reply to: