...
 
Commits (37)
......@@ -20,12 +20,15 @@ use strict;
use warnings;
use autodie;
use IO::Async::Loop;
use List::MoreUtils qw(first_index none);
use Lintian::Command qw(safe_qx spawn);
use Lintian::Command qw(safe_qx);
use Lintian::Data;
use Lintian::Tags qw(tag);
use constant NEWLINE => qq{\n};
# The files that contain error messages from tar, which we'll check and issue
# tags for if they contain something unexpected, and their corresponding tags.
# - These files are created by bin-pkg-control, index and unpacked respectively
......@@ -44,10 +47,34 @@ sub run {
# Run ar t on the *.deb file. deb will be a symlink to it.
my $failed; # set to one when something is so bad that we can't continue
my $opts = {};
my $success = spawn($opts, ['ar', 't', $deb]);
if ($success) {
my @members = split("\n", ${ $opts->{out} });
my $loop = IO::Async::Loop->new;
my $future = $loop->new_future;
my @command = ('ar', 't', $deb);
my $stdout = EMPTY;
my $stderr = EMPTY;
$loop->open_process(
command => [@command],
stdout => { into => \$stdout },
stderr => { into => \$stderr },
on_finish => sub {
my ($self, $exitcode) = @_;
my $status = ($exitcode >> 8);
if ($status) {
$future->fail(
"Non-zero status $status from @comand");
return;
}
$future->done("Done with @command");
return;
});
$loop->await($future);
if ($future->is_done) {
my @members = split(NEWLINE, $stdout);
my $count = scalar(@members);
my ($ctrl_member, $data_member);
if ($count < 3) {
......@@ -170,11 +197,10 @@ sub run {
} else {
# unpack will probably fail so we'll never get here, but may as well be
# complete just in case.
my $error = ${ $opts->{err} };
$error =~ s/\n.*//s;
$error =~ s/^ar:\s*//;
$error =~ s/^deb:\s*//;
tag 'malformed-deb-archive', "ar error: $error";
$stderr =~ s/\n.*//s;
$stderr =~ s/^ar:\s*//;
$stderr =~ s/^deb:\s*//;
tag 'malformed-deb-archive', "ar error: $stderr";
}
# Check the debian-binary version number. We probably won't get
......
......@@ -23,15 +23,14 @@ use strict;
use warnings;
use autodie;
use Capture::Tiny qw(capture_merged);
use Capture::Tiny qw(capture_merged capture_stderr);
use Cwd qw(realpath);
use File::Temp();
use Try::Tiny;
use Lintian::Command qw(spawn);
use Lintian::Output qw(msg);
use Lintian::Tags qw(tag);
use Lintian::Util qw(clean_env copy_dir run_cmd);
use Lintian::Util qw(copy_dir clean_env);
use constant NEWLINE => qq{\n};
......@@ -167,22 +166,6 @@ sub run {
my $test_pot = "$tempdir/test.pot";
my $tempdir_templates = "${abs_tempdir}/templates";
my $d_templates = $debian_dir->resolve_path('templates');
my %msgcmp_opts = (
'out' => '/dev/null',
'err' => '/dev/null',
'fail' => 'never',
);
my @msgcmp = ('msgcmp', '--use-untranslated');
my %intltool_opts = (
'update-env-vars' => {
'INTLTOOL_EXTRACT' =>
'/usr/share/intltool-debian/intltool-extract',
# safety of $debian_po is implied by us having
# accessed two of its children by now.
'srcdir' => $debian_po_dir->fs_path,
},
'chdir' => $tempdir,
);
# Create our extra level
mkdir($tempdir);
......@@ -191,21 +174,36 @@ sub run {
copy_dir($d_templates->fs_path, $tempdir_templates)
if $d_templates;
# Generate a "test.pot" (in a tempdir)
my $error;
my ($output) = capture_merged {
my %save = %ENV;
my $cwd = Cwd::getcwd;
my $output = capture_merged {
try {
run_cmd(
\%intltool_opts,
$ENV{INTLTOOL_EXTRACT}
= '/usr/share/intltool-debian/intltool-extract';
# use of $debian_po is safe; we accessed two children by now.
$ENV{srcdir} = $debian_po_dir->fs_path;
chdir($tempdir);
# generate a "test.pot" in a tempdir
my @intltool = (
'/usr/share/intltool-debian/intltool-update',
'--gettext-package=test','--pot'
);
system(@intltool) == 0
or die "system @intltool failed: $?";
}
catch {
# catch any error
$error = $_;
}
finally {
# restore environment
%ENV = %save;
# restore working directory
chdir($cwd);
};
};
......@@ -218,13 +216,34 @@ sub run {
return;
}
# Compare our "test.pot" with the existing "templates.pot"
(
spawn(
\%msgcmp_opts,[@msgcmp, $test_pot, $templ_pot_path->fs_path])
and spawn(
\%msgcmp_opts,[@msgcmp, $templ_pot_path->fs_path, $test_pot])
) or tag 'newer-debconf-templates';
# throw away output on the following commands
$error = undef;
$output = capture_merged {
try {
# compare our "test.pot" with the existing "templates.pot"
my @testleft = (
'msgcmp', '--use-untranslated',
$test_pot, $templ_pot_path->fs_path
);
system(@testleft) == 0
or die "system @testleft failed: $?";
# is this not equivalent to the previous command? - FL
my @testright = (
'msgcmp', '--use-untranslated',
$templ_pot_path->fs_path, $test_pot
);
system(@testright) == 0
or die "system @testright failed: $?";
}
catch {
# catch any error
$error = $_;
};
};
tag 'newer-debconf-templates'
if length $error;
}
return unless $debian_po_dir;
......@@ -257,16 +276,32 @@ sub run {
}
tag 'unknown-encoding-in-po-file', $po_path
unless length($charset);
my $stats;
my %opts = (
'child_before_exec' => sub {
my $error;
my %save = %ENV;
my $stats = capture_stderr {
try {
clean_env(1);
},
'err' => \$stats,
);
spawn(\%opts,
['msgfmt', '-o', '/dev/null', '--statistics', $po_path->fs_path])
or tag 'invalid-po-file', $po_path;
my @msgfmt = (
'msgfmt', '-o', '/dev/null', '--statistics',
$po_path->fs_path
);
system(@msgfmt) == 0
or die "system @msgfmt failed: $?";
}
catch {
# catch any error
$error = $_;
}
finally {
# restore environment
%ENV = %save;
};
};
tag 'invalid-po-file', $po_path
if length $error;
if (!$full_translation && $stats =~ m/^\w+ \w+ \w+\.$/) {
$full_translation = 1;
}
......
......@@ -1365,16 +1365,24 @@ sub script_is_evil_and_wrong {
sub check_script_syntax {
my ($interpreter, $path) = @_;
my $fs_path = $path->fs_path;
my $pid = do_fork();
if ($pid == 0) {
open(STDOUT, '>', '/dev/null');
open(STDERR, '>&', \*STDOUT);
exec $interpreter, '-n', $fs_path
or internal_error("cannot exec $interpreter: $!");
} else {
waitpid $pid, 0;
}
return $?;
my $error;
my (undef, $stderr, $status) = capture {
try {
my @command = ($interpreter, '-n', $fs_path);
system(@command) == 0
or die "system @command failed: $?";
}
catch {
# catch any error
$error = $_;
};
};
print $stderr
if length $stderr;
return $status;
}
sub remove_comments {
......
......@@ -23,11 +23,11 @@ use strict;
use warnings;
use autodie;
use Capture::Tiny qw(capture);
use File::Temp;
use Lintian::Tags qw(tag);
use Lintian::Data;
use Lintian::Command qw(safe_qx);
my $SIGNING_KEY_FILENAMES = Lintian::Data->new('common/signing-key-filenames');
......@@ -59,16 +59,14 @@ sub run {
my $tempdir = File::Temp->newdir();
# get keys packets from gpg
my $opts = {'in' => '/dev/null', 'err' => '/dev/null'};
my $output = safe_qx(
$opts,
[
'gpg', '--homedir',
$tempdir, '--list-packets',
$key_locations{$key_name}]);
# error if key cannot be processed
unless ($opts->{success}) {
my ($output, $stderr, $status) = capture {
my @command = (
'gpg', '--homedir',$tempdir, '--list-packets',
$key_locations{$key_name});
system(@command);
};
if ($status) {
tag 'public-upstream-key-unusable', $key_name,
'cannot be processed';
next;
......
......@@ -2,6 +2,7 @@
# ar-info -- lintian collection script
#
# Copyright © 2009 Stéphane Glondu
# Copyright © 2019 Felix Lechner
#
# 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
......@@ -28,45 +29,52 @@ use warnings;
use autodie;
use lib "$ENV{LINTIAN_ROOT}/lib";
use FileHandle;
use Path::Tiny;
use Lintian::Collect;
use Lintian::Command qw(spawn);
use Lintian::Util qw(safe_qx_ioasync);
use constant EMPTY => q{};
use constant SPACE => q{ };
use constant COLON => q{:};
use constant NEWLINE => qq{\n};
sub collect {
my ($pkg, $type, $dir) = @_;
my $info;
if (-e "$dir/ar-info") {
unlink("$dir/ar-info");
}
my $basket = "$dir/ar-info";
# If we are asked to only remove the files stop right here
if ($type =~ m/^remove-/) {
return;
}
unlink($basket)
if -e $basket;
$info = Lintian::Collect->new($pkg, $type, $dir);
# stop here if we are only removing the files
return
if $type =~ m/^remove-/;
open(my $out_fd, '>', "$dir/ar-info");
$info = Lintian::Collect->new($pkg, $type, $dir);
chdir("$dir/unpacked");
my @archives;
foreach my $file ($info->sorted_index) {
next unless $file->is_regular_file && $file =~ m{ \. a \Z }xsm;
my $opts = { pipe_out => FileHandle->new, err => '/dev/null' };
spawn($opts, ['ar', 't', $file]);
print {$out_fd} "$file:";
while (defined($_ = readline($opts->{pipe_out}))) {
chomp;
print {$out_fd} " $_";
}
close($opts->{pipe_out});
print {$out_fd} "\n";
$opts->{harness}->finish;
# skip empty archives to avoid ar error message; happens in tests
next unless $file->size;
my $output = safe_qx_ioasync('ar', 't', $file);
my @contents = split(/\n/, $output);
my $line = $file . COLON;
$line .= SPACE . $_ for @contents;
push(@archives, $line);
}
close($out_fd);
my $string = EMPTY;
$string .= $_ . NEWLINE for @archives;
path($basket)->spew($string);
return;
}
......
#!/usr/bin/perl -w
# bin-pkg-control -- lintian collector script
# Copyright (C) 1998 Christian Schwarz
# Copyright © 1998 Christian Schwarz
# Copyright © 2019 Felix Lechner
#
# 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
......@@ -27,95 +28,170 @@ use strict;
use warnings;
use autodie;
use IO::Async::Loop;
use IO::Async::Process;
use Path::Tiny;
use constant ERROR_FILES => qw(control-index-errors control-errors);
use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Lintian::Command qw(spawn reap);
use Lintian::Util qw(internal_error pipe_tee run_cmd);
use Lintian::Util qw(sort_file_index gzip safe_qx_ioasync);
# read up to 40kB at a time. this happens to be 4096 "tar records"
# (with a block-size of 512 and a block factor of 20, which appear to
# be the defaults). when we do full reads and writes of READ_SIZE (the
# OS willing), the receiving end will never be with an incomplete
# record.
use constant READ_SIZE => 4096 * 20 * 512;
use constant EMPTY => q{};
use constant COLON => q{:};
use constant NEWLINE => qq{\n};
sub collect {
my ($pkg, $type, $dir) = @_;
my (@jobs, $job, $in_fd, @out_fds, $err);
my $controldir = "$dir/control";
path($controldir)->remove_tree
if -d $controldir;
for my $file ('control-index.gz', ERROR_FILES) {
my $path = "$dir/$file";
my $zipindexpath = "$dir/control-index.gz";
my $controlerrorspath = "$dir/control-errors";
my $indexerrorspath = "$dir/control-index-errors";
for my $path ($zipindexpath, $controlerrorspath, $indexerrorspath) {
unlink($path) if -e $path;
}
mkdir("$dir/control", 0777);
mkdir($controldir, 0777);
my $debpath = "$dir/deb";
return
unless -f $debpath;
my $loop = IO::Async::Loop->new;
# get control tarball from deb
my $deberror;
my $dpkgdeb = $loop->new_future;
my @debcommand = ('dpkg-deb', '--ctrl-tarfile', $debpath);
my $debprocess = IO::Async::Process->new(
command => [@debcommand],
stdout => { via => 'pipe_read' },
stderr => { into => \$deberror },
on_finish => sub {
my ($self, $exitcode) = @_;
my $status = ($exitcode >> 8);
if ($status) {
my $message= "Non-zero status $status from @debcommand";
$message .= COLON . NEWLINE . $deberror
if length $deberror;
$dpkgdeb->fail($message);
return;
}
$dpkgdeb->done("Done with @debcommand");
return;
});
# The following calls use knowledge of the .deb format for speed
# (replaces dpkg-deb -e)
# extract control files' tarball
$in_fd = FileHandle->new;
spawn(
{ fail => 'error', pipe_out => $in_fd },
['dpkg-deb', '--ctrl-tarfile', "$dir/deb"]);
$job = {
fail => 'error',
err => "$dir/control-errors",
pipe_in => FileHandle->new,
};
push(@out_fds, $job->{'pipe_in'});
push(@jobs, $job);
# extract the tarball's contents
spawn(
$job,
[
'tar', '--no-same-owner','--no-same-permissions', '-mxf',
'-', '-C',"$dir/control",
]);
$job = {
fail => 'error',
out => "$dir/control-index.gz",
err => "$dir/control-index-errors",
pipe_in => FileHandle->new,
};
push(@out_fds, $job->{'pipe_in'});
push(@jobs, $job);
my $extracterror;
my $extractor = $loop->new_future;
my @extractcommand = (
'tar', '--no-same-owner','--no-same-permissions', '-mxf',
'-', '-C', $controldir
);
my $extractprocess = IO::Async::Process->new(
command => [@extractcommand],
stdin => { via => 'pipe_write' },
stderr => { into => \$extracterror },
on_finish => sub {
my ($self, $exitcode) = @_;
my $status = ($exitcode >> 8);
if ($status) {
my $message = "Non-zero status $status from @extractcommand";
$message .= COLON . NEWLINE . $extracterror
if length $extracterror;
$extractor->fail($message);
return;
}
$extractor->done("Done with @extractcommand");
return;
});
# create index of control.tar.gz
spawn(
$job, ['tar', '-stvf', '-'],'|', ['sort', '-k', '6'],
'|', ['gzip', '-9nc'],
my $index;
my $indexerror;
my $indexer = $loop->new_future;
my @indexcommand = ('tar', '-stvf', '-');
my $indexprocess = IO::Async::Process->new(
command => [@indexcommand],
stdin => { via => 'pipe_write' },
stdout => { into => \$index },
stderr => { into => \$indexerror },
on_finish => sub {
my ($self, $exitcode) = @_;
my $status = ($exitcode >> 8);
if ($status) {
my $message = "Non-zero status $status from @indexcommand";
$message .= COLON . NEWLINE . $indexerror
if length $indexerror;
$indexer->fail($message);
return;
}
$indexer->done("Done with @indexcommand");
return;
});
$extractprocess->stdin->configure(write_len => READ_SIZE);
$indexprocess->stdin->configure(write_len => READ_SIZE);
$debprocess->stdout->configure(
read_len => READ_SIZE,
on_read => sub {
my ($stream, $buffref, $eof) = @_;
if (length $$buffref) {
$extractprocess->stdin->write($$buffref);
$indexprocess->stdin->write($$buffref);
$$buffref = EMPTY;
}
if ($eof) {
$extractprocess->stdin->close_when_empty;
$indexprocess->stdin->close_when_empty;
}
return 0;
},
);
$in_fd->blocking(1);
for my $out_pipe (@out_fds) {
$out_pipe->blocking(1);
}
eval {pipe_tee($in_fd, \@out_fds);};
$err = $@;
eval {
close($in_fd);
for my $fd (@out_fds) {
close($fd);
}
reap(@jobs);
undef(@jobs);
};
$err ||= $@;
if ($err) {
die $err;
}
$loop->add($debprocess);
$loop->add($indexprocess);
$loop->add($extractprocess);
# fix permissions
run_cmd('chmod', '-R', 'u+rX,o-w', "$dir/control");
my $composite = Future->needs_all($dpkgdeb, $extractor, $indexer);
# Remove empty error files...
for my $file (ERROR_FILES) {
my $path = "$dir/$file";
unlink($path) if -z $path;
}
# awaits, and dies on failure with message from failed constituent
$composite->get;
# not recording dpkg-deb errors anywhere
path($controlerrorspath)->append($extracterror)
if length $extracterror;
path($indexerrorspath)->append($indexerror)
if length $indexerror;
# sorts according to LC_ALL=C
$index = sort_file_index($index // EMPTY);
gzip($index, $zipindexpath);
# fix permissions
safe_qx_ioasync('chmod', '-R', 'u+rX,o-w', $controldir);
return;
}
......
#!/usr/bin/perl -w
# changelog-file -- lintian collector script
# Copyright (C) 1998 Richard Braakman
# Copyright © 1998 Richard Braakman
# Copyright © 2019 Felix Lechner
#
# 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
......@@ -28,50 +29,64 @@ use warnings;
use autodie;
use File::Copy qw(copy);
use List::MoreUtils qw(first_value);
use Path::Tiny;
use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Lintian::Util qw(internal_error gunzip_file is_ancestor_of);
use Lintian::Util qw(is_ancestor_of safe_qx_ioasync);
sub collect {
my ($pkg, $type, $dir) = @_;
unlink("$dir/changelog")
if -e "$dir/changelog" or -l "$dir/changelog";
my $changelogpath = "$dir/changelog";
unlink($changelogpath)
if -e $changelogpath || -l $changelogpath;
# Extract NEWS.Debian files as well, with similar precautions.
# Ignore any symlinks to other packages here; in that case, we
# just won't check the file.
unlink("$dir/NEWS.Debian")
if -l "$dir/NEWS.Debian"
my $newspath = "$dir/NEWS.Debian";
unlink($newspath)
if -l $newspath
or -e _;
# Pick the first of these files that exists.
my @changelogs = (
"$dir/unpacked/usr/share/doc/$pkg/changelog.Debian.gz",
"$dir/unpacked/usr/share/doc/$pkg/changelog.Debian",
"$dir/unpacked/usr/share/doc/$pkg/changelog.debian.gz",
"$dir/unpacked/usr/share/doc/$pkg/changelog.debian",
"$dir/unpacked/usr/share/doc/$pkg/changelog.gz",
"$dir/unpacked/usr/share/doc/$pkg/changelog",
);
my $unpackedpath = "$dir/unpacked";
my $packagepath = "$unpackedpath/usr/share/doc/$pkg";
my $chl;
# pretend we did not find anything if parent dir is outside package
return
if -d $packagepath
&& !is_ancestor_of($unpackedpath, $packagepath);
if (-d "$dir/unpacked/usr/share/doc/$pkg"
&& !is_ancestor_of("$dir/unpacked", "$dir/unpacked/usr/share/doc/$pkg")
) {
# If the parent dir is outside this package, pretend we didn't find
# anything.
return;
}
for (@changelogs) {
if (-l $_ || -f _) {
$chl = $_;
last;
my $packagenewspath = "$packagepath/NEWS.Debian.gz";
if (-f $packagenewspath) {
if (-l $packagenewspath) {
my $link = readlink($packagenewspath);
if ($link =~ /\.\./
|| ($link =~ m%/% && $link !~ m%^[^/]+(?:/+[^/]+)*\z%)) {
undef $packagenewspath;
}
}
if ($packagenewspath) {
my $contents = safe_qx_ioasync('gunzip', '-c', $packagenewspath);
path($newspath)->spew($contents);
}
}
# pick the first existing file
my @changelogfiles = (
'changelog.Debian.gz','changelog.Debian',
'changelog.debian.gz','changelog.debian',
'changelog.gz','changelog',
);
my @candidatepaths = map { "$packagepath/$_" } @changelogfiles;
my $packagechangelogpath = first_value { -l $_ || -f $_ } @candidatepaths;
return
unless defined $packagechangelogpath;
# If the changelog file we found was a symlink, we have to be
# careful. It could be a symlink to some file outside of the
# laboratory and we don't want to end up reading that file by
......@@ -79,14 +94,14 @@ sub collect {
# subdirectory we accept; anything else is replaced by an
# intentionally broken symlink so that checks can do the right
# thing.
if (defined($chl) && -l $chl) {
my $link = readlink($chl);
if (defined($packagechangelogpath) && -l $packagechangelogpath) {
my $link = readlink($packagechangelogpath);
if ($link =~ /\.\./
|| ($link =~ m%/% && $link !~ m%^[^/]+(?:/+[^/]+)*\z%)) {
symlink("$dir/file-is-in-another-package", "$dir/changelog");
undef $chl;
} elsif (!-f $chl) {
undef $chl;
symlink("$dir/file-is-in-another-package", $changelogpath);
undef $packagechangelogpath;
} elsif (!-f $packagechangelogpath) {
undef $packagechangelogpath;
}
}
......@@ -94,23 +109,26 @@ sub collect {
# treat it the same as if we didn't find a changelog and do nothing. If it
# was a symlink, copy the file, since otherwise the relative symlinks are
# going to break things.
if (not defined $chl) {
if (not defined $packagechangelogpath) {
# no changelog found
} elsif ($chl =~ /\.gz$/) {
gunzip_file($chl, "$dir/changelog");
} elsif (-f $chl && -l $chl) {
copy($chl, "$dir/changelog") or internal_error("cannot copy $chl: $!");
} elsif ($packagechangelogpath =~ /\.gz$/) {
my $contents = safe_qx_ioasync('gunzip', '-c', $packagechangelogpath);
path($changelogpath)->spew($contents);
} elsif (-f $packagechangelogpath && -l $packagechangelogpath) {
copy($packagechangelogpath, $changelogpath)
or die "cannot copy $packagechangelogpath: $!";
} else {
link($chl, "$dir/changelog");
link($packagechangelogpath, $changelogpath);
}
if ($chl && $chl !~ m/changelog\.debian/i) {
if ( $packagechangelogpath
&& $packagechangelogpath !~ m/changelog\.debian/i) {
# Either this is a native package OR a non-native package where the
# debian changelog is missing. checks/changelog is not too happy
# with the latter case, so check looks like a Debian changelog.
open(my $fd, '<', "$dir/changelog");
my @lines = path($changelogpath)->lines;
my $ok = 0;
while (my $line = <$fd>) {
for my $line (@lines) {
next if $line =~ m/^\s*+$/o;
# look for something like
# lintian (2.5.3) UNRELEASED; urgency=low
......@@ -120,23 +138,8 @@ sub collect {
}
last;
}
close($fd);
# Remove it if it not the Debian changelog.
unlink("$dir/changelog") unless $ok;
}
my $news = "$dir/unpacked/usr/share/doc/$pkg/NEWS.Debian.gz";
if (-f $news) {
if (-l $news) {
my $link = readlink($news);
if ($link =~ /\.\./
|| ($link =~ m%/% && $link !~ m%^[^/]+(?:/+[^/]+)*\z%)) {
undef $news;
}
}
if ($news) {
gunzip_file($news, "$dir/NEWS.Debian");
}
unlink($changelogpath) unless $ok;
}
return;
......
#!/usr/bin/perl -w
# copyright-file -- lintian collector script
# Copyright (C) 1998 Richard Braakman
# Copyright © 1998 Richard Braakman
# Copyright © 2019 Felix Lechner
#
# 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
......@@ -35,35 +36,33 @@ use File::Copy qw(copy);
sub collect {
my ($pkg, $type, $dir) = @_;
if (-e "$dir/copyright") {
unlink("$dir/copyright");
}
my $unpackedpath = "$dir/unpacked";
return unless -d $unpackedpath;
if (-d "$dir/unpacked/usr/share/doc/$pkg"
&& !is_ancestor_of("$dir/unpacked", "$dir/unpacked/usr/share/doc/$pkg")
) {
# if the parent dir is outside the package, just stop here before we
# do something we will regret.
return;
}
my $copyrightpath = "$dir/copyright";
unlink($copyrightpath)
if -e $copyrightpath;
my $packagepath = "$unpackedpath/usr/share/doc/$pkg";
return unless -d $packagepath;
# do not proceed if the parent dir is outside the package
return unless is_ancestor_of($unpackedpath, $packagepath);
my $file = "$dir/unpacked/usr/share/doc/$pkg/copyright";
my $packagecopyrightpath = "$packagepath/copyright";
# If copyright was a symlink, we need to make a copy of it. Just
# hardlinking to the symlink may leave a relative symlink into a
# directory we can't unpack. Be careful about what symlinks we
# allow, though.
if (-l $file) {
my $link = readlink($file);
# make copy if symlink; hardlink could dangle; also check link path
if (-l $packagecopyrightpath) {
my $link = readlink($packagecopyrightpath);
unless ($link =~ /\.\./
|| ($link =~ m%/% && $link !~ m%^[^/]+(?:/+[^/]+)*\z%)) {
copy($file, "$dir/copyright")
or internal_error("cannot copy $file: $!");
copy($packagecopyrightpath, $copyrightpath)
or internal_error("cannot copy $packagecopyrightpath: $!");
}
} elsif (-f $file) {
link($file, "$dir/copyright");
} elsif (-f "$file.gz") {
gunzip_file("$file.gz", "$dir/copyright");
} elsif (-f $packagecopyrightpath) {
link($packagecopyrightpath, $copyrightpath);
} elsif (-f "$packagecopyrightpath.gz") {
gunzip_file("$packagecopyrightpath.gz", $copyrightpath);
}
return;
......
#!/usr/bin/perl -w
# diffstat -- lintian collection script for source packages
# Copyright (C) 1998 Richard Braakman
# Copyright © 1998 Richard Braakman
# Copyright © 2019 Felix Lechner
#
# 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
......@@ -34,43 +35,70 @@ use warnings;
use autodie;
use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Lintian::Util qw(internal_error get_dsc_info gunzip_file);
use Path::Tiny;
use Lintian::Util qw(get_dsc_info safe_qx_ioasync);
use constant EMPTY => q{};
use constant NEWLINE => qq{\n};
sub collect {
my ($pkg, undef, $dir) = @_;
my $data;
my $ver;
-f "$dir/dsc"
or internal_error('diffstat invoked with wrong dir argument');
my $dscpath = "$dir/dsc";
die 'diffstat invoked with wrong dir argument'
unless -f $dscpath;
$data = get_dsc_info("$dir/dsc");
$ver = $data->{'version'};
my $data = get_dsc_info($dscpath);
my $ver = $data->{'version'};
unlink("$dir/debian-patch")
if -e "$dir/debian-patch"
or -l "$dir/debian-patch";
my $patchpath = "$dir/debian-patch";
unlink($patchpath)
if -e $patchpath
or -l $patchpath;
$ver =~ s/^\d://; #Remove epoch for this
my $diff_file = "$dir/${pkg}_${ver}.diff.gz";
return unless (-f $diff_file);
gunzip_file($diff_file, "$dir/debian-patch");
open(my $out, '>', "$dir/diffstat");
# diffstat is noisy on stderr if its stdout is not a tty.
# Shut it up by redirecting stderr to /dev/null.
open(STDERR, '>', '/dev/null');
open(my $in, '-|', 'diffstat', '-p1', "$dir/debian-patch");
# Copy all except last line to the STAT file
my $previous;
while (<$in>) {
print {$out} $previous if $previous;
$previous = $_;
}
close($out);
close($in);
my $diffpath = "$dir/${pkg}_${ver}.diff.gz";
return
unless -f $diffpath;
my $contents = safe_qx_ioasync('gunzip', '--stdout', $diffpath);
path($patchpath)->spew($contents);
my $loop = IO::Async::Loop->new;
my $future = $loop->new_future;
my @command = ('diffstat', '-p1', $patchpath);
$loop->run_child(
command => [@command],
on_finish => sub {
my ($pid, $exitcode, $stdout, $stderr) = @_;
my $status = ($exitcode >> 8);
if ($status) {
my $message = "Command @command exited with status $status";
$message .= ": $stderr" if length $stderr;
$future->fail($message);
return;
}
$future->done($stdout);
});
# will raise an exception when failed
my $diffstat = $future->get;
# remove the last line;
chomp $diffstat;
my @lines = split(/\n/, $diffstat);
pop @lines;
$diffstat = EMPTY;
$diffstat .= $_ . NEWLINE for @lines;
# copy all lines except the last
path("$dir/diffstat")->spew($diffstat);
return;
}
......
#!/usr/bin/perl -w
# file-info -- lintian collection script
# Copyright (C) 1998 Richard Braakman
# Copyright © 1998 Richard Braakman
# Copyright © 2019 Felix Lechner
#
# 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
......@@ -27,47 +28,161 @@ use strict;
use warnings;
use autodie;
use FileHandle;
use IO::Async::Loop;
use IO::Async::Process;
use Path::Tiny;
use Try::Tiny;
use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Lintian::Collect;
use Lintian::Command qw(spawn reap);
use Lintian::Util qw(locate_helper_tool);
use Lintian::Util qw(locate_helper_tool gzip safe_qx_ioasync);
my $helper = locate_helper_tool('coll/file-info-helper');
use constant EMPTY => q{};
use constant COLON => q{:};
use constant NEWLINE => qq{\n};
sub collect {
my ($pkg, $type, $dir) = @_;
my $info = Lintian::Collect->new($pkg, $type, $dir);
my $outfile = "$dir/file-info.gz";
chdir("$dir/unpacked");
if (-e $outfile) {
unlink($outfile);
}
my $loop = IO::Async::Loop->new;
chdir("$dir/unpacked");
my @generatecommand = (
'xargs', '--null','--no-run-if-empty', 'file',
'--no-pad', '--separator',EMPTY, '--print0','--'
);
my $generatedone = $loop->new_future;
my $generate = IO::Async::Process->new(
command => [@generatecommand],
stdin => { via => 'pipe_write' },
stdout => { via => 'pipe_read' },
on_finish => sub {
# ignore failures; file returns non-zero on parse errors
# output then contains "ERROR" messages but is still usable
$generatedone->done('Done with @generatecommand');
return;
});
my $helperpath = locate_helper_tool('coll/file-info-helper');
my $helperdone = $loop->new_future;
my $helpererrors;
my $helper = IO::Async::Process->new(
command => $helperpath,
stdin => { via => 'pipe_write' },
stdout => { via => 'pipe_read' },
stderr => { into => \$helpererrors },
on_finish => sub {
my ($self, $exitcode) = @_;
my $status = ($exitcode >> 8);
if ($status) {
my $message = "Command $helperpath exited with status $status";
$message .= COLON . NEWLINE . $helpererrors
if length $helpererrors;
$helperdone->fail($message);
return;
}
$helperdone->done('Done with $helperpath');
return;
});
my @compresscommand = ('gzip', '--best', '--no-name', '--stdout');
my $compressdone = $loop->new_future;
my $compresserrors;
my $compress = IO::Async::Process->new(
command => [@compresscommand],
stdin => { via => 'pipe_write' },
stdout => { via => 'pipe_read' },
stderr => { into => \$compresserrors },
on_finish => sub {
my ($self, $exitcode) = @_;
my $status = ($exitcode >> 8);
if ($status) {
my $message
= "Command @compresscommand exited with status $status";
$message .= COLON . NEWLINE . $compresserrors
if length $compresserrors;
$compressdone->fail($message);
return;
}
$compressdone->done('Done with @compresscommand');
return;
});
$generate->stdout->configure(
on_read => sub {
my ($stream, $buffref, $eof) = @_;
if (length $$buffref) {
$helper->stdin->write($$buffref);
$$buffref = EMPTY;
}
$helper->stdin->close_when_empty
if $eof;
return 0;
},
);
$helper->stdout->configure(
on_read => sub {
my ($stream, $buffref, $eof) = @_;
if (length $$buffref) {
$compress->stdin->write($$buffref);
$$buffref = EMPTY;
}
# We ignore failures from file because sometimes file returns a
# non-zero exit status when it can't parse a file. So far, the
# resulting output still appears to be usable (although will
# contain "ERROR" strings, which Lintian doesn't care about), and
# the only problem was the exit status.
my %opts = (
pipe_in => FileHandle->new,
out => $outfile,
fail => 'never'
$compress->stdin->close_when_empty
if $eof;
return 0;
},
);
spawn(\%opts,['xargs', '-0r', 'file', '-NF', '', '--print0', '--'],
'|', [$helper], '|', ['gzip', '-9nc']);
$opts{pipe_in}->blocking(1);
foreach my $file ($info->sorted_index) {
next unless $file->is_file;
printf {$opts{pipe_in}} "%s\0", $file;
my $resultspath = "$dir/file-info.gz";
open(my $fh, '>', $resultspath)
or die "Could not open file '$resultspath': $!";
$compress->stdout->configure(
on_read => sub {
my ($stream, $buffref, $eof) = @_;
if (length $$buffref) {
print {$fh} $$buffref;
$$buffref = EMPTY;
}
close($fh)
if $eof;
return 0;
},
);
$loop->add($generate);
$loop->add($helper);
$loop->add($compress);
foreach my $path ($info->sorted_index) {
next unless $path->is_file;
$generate->stdin->write("$path\0");
}
close($opts{pipe_in});
reap(\%opts);
$generate->stdin->close_when_empty;
Future->needs_all($generatedone, $helperdone, $compressdone)->get;
return;
}
......
#!/usr/bin/perl -w
# java-info -- lintian collection script
# Copyright (C) 2011 Vincent Fourmond
# Copyright © 2011 Vincent Fourmond
# Copyright © 2019 Felix Lechner
#
# 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,54 +30,34 @@ use autodie;
use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
use FileHandle;
use Path::Tiny;
use lib "$ENV{'LINTIAN_ROOT'}/lib/";
use Lintian::Collect;
use Lintian::Command qw(spawn reap);
use Lintian::Util qw(internal_error rstrip);
use Lintian::Util qw(internal_error rstrip gzip);
use constant EMPTY => q{};
use constant NEWLINE => qq{\n};
use constant SPACE => q{ };
use constant DASH => q{-};
sub collect {
my ($pkg, $type, $dir) = @_;
my $info = Lintian::Collect->new($pkg, $type, $dir);
unless (-d "$dir/unpacked/") {
internal_error('java-info called with the wrong dir argument');
}
my $info = Lintian::Collect->new($pkg, $type, $dir);
if (-f "$dir/java-info.gz") {
unlink("$dir/java-info.gz");
}
my $unpackedpath = "$dir/unpacked/";
die "Directory with unpacked data not found in java-info: $unpackedpath"
unless -d $unpackedpath;
chdir($unpackedpath);
# We lazily start the gzip process to avoid creating the java-info.gz
# file when there are no jar files in the package.
my %opts;
my $open_java_info = sub {
%opts = (
pipe_in => FileHandle->new,
out => "$dir/java-info.gz",
fail => 'error'
);
spawn(\%opts, ['gzip', '-9c']);
$opts{pipe_in}->blocking(1);
};
my $errorhandler = sub {
my ($err) = @_;
$err =~ s/\r?\n/ /g;
rstrip($err);
print {$opts{pipe_in}} "-- ERROR: $err\n";
};
my @lines;
foreach my $file ($info->sorted_index) {
chdir("$dir/unpacked");
next
unless $file->is_file;
# Without this Archive::Zip will emit errors to standard error for
# faulty zip files - but that is not what we want. AFAICT, it is
# the only way to get a textual error as well, so (ab)use it for
# this purpose while we are at it.
my $oldhandler = Archive::Zip::setErrorHandler($errorhandler);
FILE:
foreach my $file ($info->sorted_index) {
next unless $file->is_file;
my $filename = $file->name;
# Wheezy's version of file calls "jar files" for "Zip archive".
......@@ -87,70 +68,109 @@ sub collect {
| Zip [ ] archive
| JAR /xo;
if ($filename =~ m#\S+\.jar$#i) {
my $manifest;
my $azip = Archive::Zip->new;
$open_java_info->() unless %opts;
# This script needs unzip, there's no way around.
print {$opts{pipe_in}} "-- $filename\n";
$azip->read($filename) == AZ_OK or next FILE;
# First, the file list:
foreach my $member ($azip->members) {
my $name = $member->fileName;
my $jversion;
next if $member->isDirectory;
$manifest = $member if $name =~ m@^META-INF/MANIFEST.MF$@oi;
if ($name =~ m/\.class$/o) {
# Collect the Major version of the class file.
my ($contents, $zerr) = $member->contents;
next FILE unless $zerr == AZ_OK;
# Ensure we can read at least 8 bytes for the unpack.
next if length($contents) < 8;
# translation of the unpack
# NN NN NN NN, nn nn, nn nn - bytes read
# $magic , __ __, $major - variables
my ($magic, undef, $major) = unpack('Nnn', $contents);
$jversion = $major if $magic == 0xCAFEBABE;
}
$jversion //= '-';
print {$opts{pipe_in}} $name, ": $jversion\n";
push(@lines, parse_jar($filename))
if $filename =~ m#\S+\.jar$#i;
}
my $uncompressed = EMPTY;
$uncompressed .= $_ . NEWLINE for @lines;
return
unless length $uncompressed;
gzip($uncompressed, "$dir/java-info.gz");
return;
}
sub parse_jar {
my ($path) = @_;
my @lines;
# This script needs unzip, there's no way around.
push(@lines, "-- $path");
# Without this Archive::Zip will emit errors to standard error for
# faulty zip files - but that is not what we want. AFAICT, it is
# the only way to get a textual error as well, so (ab)use it for
# this purpose while we are at it.
my $errorhandler = sub {
my ($err) = @_;
$err =~ s/\r?\n/ /g;
rstrip($err);
push(@lines, "-- ERROR: $err");
};
my $oldhandler = Archive::Zip::setErrorHandler($errorhandler);
my $azip = Archive::Zip->new;
if($azip->read($path) == AZ_OK) {
# save manifest for the end
my $manifest;
# file list comes first
foreach my $member ($azip->members) {
my $name = $member->fileName;
next
if $member->isDirectory;
# store for later processing
$manifest = $member
if $name =~ m@^META-INF/MANIFEST.MF$@oi;
# add version if we can find it
my $jversion;
if ($name =~ m/\.class$/o) {
# Collect the Major version of the class file.
my ($contents, $zerr) = $member->contents;
last
unless $zerr == AZ_OK;
# Ensure we can read at least 8 bytes for the unpack.
next
unless length $contents >= 8;
# translation of the unpack
# NN NN NN NN, nn nn, nn nn - bytes read
# $magic , __ __, $major - variables
my ($magic, undef, $major) = unpack('Nnn', $contents);
$jversion = $major
if $magic == 0xCAFEBABE;
}
push(@lines, "$name: " . ($jversion // DASH));
}
if ($manifest) {
push(@lines, "-- MANIFEST: $path");
if ($manifest) {
print {$opts{pipe_in}} "-- MANIFEST: $filename\n";
my ($contents, $zerr) = $manifest->contents;
my ($contents, $zerr) = $manifest->contents;
next FILE unless $zerr == AZ_OK;
if ($zerr == AZ_OK) {
my $partial = EMPTY;
my $first = 1;
foreach my $line (split m/\n/, $contents) {
my @list = split(NEWLINE, $contents);
foreach my $line (@list) {
# remove DOS type line feeds
$line =~ s/\r//go;
if ($line =~ m/^(\S+:)\s*(.*)/o) {
print {$opts{pipe_in}} "\n" unless $first;
$first = 0;
print {$opts{pipe_in}} " $1 $2";
push(@lines, SPACE . SPACE . "$1 $2");
}
if ($line =~ m/^ /o) {
print {$opts{pipe_in}} substr $line, 1;
if ($line =~ m/^ (.*)/o) {
push(@lines, $1);
}
}
print {$opts{pipe_in}} "\n" unless $first;
}
}
}
Archive::Zip::setErrorHandler($oldhandler);