diff options
Diffstat (limited to '')
| -rw-r--r-- | private/TODO | 99 | ||||
| -rwxr-xr-x | private/auto-reject-diff | 166 | ||||
| -rwxr-xr-x | private/gen-po4a-conf | 10 | ||||
| -rwxr-xr-x | private/generate-html-docs | 115 | ||||
| -rwxr-xr-x | private/generate-tag-summary | 151 | ||||
| -rwxr-xr-x | private/hintadjust | 163 | ||||
| -rwxr-xr-x | private/hintdiff | 132 | ||||
| -rwxr-xr-x | private/hintextract | 119 | ||||
| -rwxr-xr-x | private/hintsort | 96 | ||||
| -rwxr-xr-x | private/latest-policy-version | 63 | ||||
| -rwxr-xr-x | private/post-release-version-bump | 15 | ||||
| -rwxr-xr-x | private/refresh-data | 130 | ||||
| -rwxr-xr-x | private/refresh-hwcap | 92 | ||||
| -rwxr-xr-x | private/refresh-perl-provides | 222 | ||||
| -rwxr-xr-x | private/refresh-virtual-packages-data | 147 | ||||
| -rwxr-xr-x | private/runtests | 972 | ||||
| -rwxr-xr-x | private/tag-stats | 109 |
17 files changed, 2801 insertions, 0 deletions
diff --git a/private/TODO b/private/TODO new file mode 100644 index 0000000..cb67a78 --- /dev/null +++ b/private/TODO @@ -0,0 +1,99 @@ +This is a collection of work to do in Lintian that isn't a bug fix or a +simple requested new check. Use the BTS for those since they're more +public and so that other people know things have already been requested. +This is intended for more internal use to track code restructurings, +infrastructure work, needed cleanups, or larger tasks. + +Tasks here are sorted roughly by the directory structure of Lintian where +that makes sense so that we don't just have one long list. Patches for +any of this is welcome, but please discuss on the mailing list first +before you do lots of work since the maintainers may have specific ways +they want it to be done. + +If someone is actively working on something, note their name in square +brackets at the beginning. If someone is noted, coordinate with them +before working on this. + +checks: + +- Move all static keyword lists into files in data. + +- Separate doc-base checks out of checks/menus (or, probably easier, + rename checks/menus to checks/doc-base and separate out the few bits + that are actually about menus). + +- Go through all tags and make sure that any that should have Policy + references have them, and more generally that appropriate references are + present. (Need some way to track this sort of regular tag maintenance.) + +- Check current tag severities against the results from lintian.d.o and + adjust. + +doc: + +- Either update doc/CREDITS based on the changelog file or archive it + somewhere and say that it's not going to be updated. + +- Update the Lintian manual: + + document visibility + + document other output formats + + document the reporting framework + + developer documentation of the test suite, submitting patches, etc. + +frontend: + +- Nearly everything in frontend/lintian that isn't command-line parsing is + really begging to be a module. Move code out of here and into modules + as part of rewriting the non-namespace modules in lib, such as Lab.pm + which should acquire more the laboratory handling from frontend/lintian, + and Checker.pm, which should acquire most of the smarts of the main + frontend/lintian checking loop. + +lib: + +- Finish documentation of Lintian::Output*. + +- Add collect function to return the sort of symlink information that's + currently gathered by checks/menus; we'll find other uses for it. + +- Provide a utility function to check a command as currently done in + checks/menu-format, after which we could split desktop checking and menu + checking into two separate check scripts. + +private: + +- Provide a general framework for updating metadata about the archive and + modify all of the private/refresh-* scripts to use it. Also set up + something in debian/rules that will run all of them and update data + accordingly which can be done routinely before every release. + +reporting: + +- Replace the template framework with template-toolkit. + +t: + +- Write new-style test cases for everything tested by the legacy test suite + and retire the "legacy" tests. + +- Go through t/tests/legacy-libbaz/debian/debian/rules and make sure + all TODO's are lintian-detected. + +- udebs are generally undertested right now and could use some general + tests, particularly for things that we don't care about with udebs but + do care about with regular packages. + +General: + +- Write a real parser for shell scripts that can at least tokenize them + half-way decently, do some basic analysis of whether code is conditional + or not, and provide reasonable answers to questions like "is this + command called in the script" without heinous regex matches. Replace + all the ugly, ad hoc script parsing code elsewhere in Lintian with that + parser. This is #629247. + +External: + +- Set up system for automatically filing bugs based on specific lintian + tags (the most reliable ones), with usertags to ensure the bugs aren't + repeatedly filed. diff --git a/private/auto-reject-diff b/private/auto-reject-diff new file mode 100755 index 0000000..bb87fec --- /dev/null +++ b/private/auto-reject-diff @@ -0,0 +1,166 @@ +#!/usr/bin/perl +# +# Copyright (C) 2021 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 +# 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, you can find it on the World Wide +# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +use v5.20; +use warnings; +use utf8; + +use Cwd qw(realpath); +use File::Basename qw(dirname); + +# neither Path::This nor lib::relative are in Debian +use constant THISFILE => realpath __FILE__; +use constant THISDIR => dirname realpath __FILE__; + +# use Lintian modules that belong to this program +use lib THISDIR . '/../lib'; + +use Const::Fast; +use List::Compare; +use List::Util qw(uniq); +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Archive; +use Lintian::Profile; + +const my $SPACE => q{ }; +const my $INDENT => $SPACE x 4; +const my $HYPHEN => q{-}; + +$ENV{LINTIAN_BASE} = realpath(THISDIR . '/..') + // die encode_utf8('Cannot resolve LINTIAN_BASE'); + +refresh_auto_reject_data(); + +# reload +my $profile = Lintian::Profile->new; +$profile->load; + +my $data = $profile->data; + +my @want_certain = @{$data->auto_rejection->certain}; +my @want_preventable = @{$data->auto_rejection->preventable}; + +# find all tags known to Lintian +my @known_tags = $profile->known_tags; +my %new_name; + +for my $tag_name (@known_tags) { + + my $tag = $profile->get_tag($tag_name); + + my @renamed_from = @{$tag->renamed_from}; + + my @taken = grep { exists $new_name{$_} } @renamed_from; + + say encode_utf8( +"Warning: Ignoring $_ as an alias for $new_name{$_} in favor of $tag_name." + )for @taken; + + $new_name{$_} = $tag_name for @renamed_from; +} + +my $old_certain_lc= List::Compare->new(\@want_certain, [keys %new_name]); +my $old_preventable_lc + = List::Compare->new(\@want_preventable, [keys %new_name]); + +my @old_certain_names = $old_certain_lc->get_intersection; +my @old_preventable_names = $old_preventable_lc->get_intersection; + +say encode_utf8('FTP Master uses those old tag names for auto-rejection:') + if @old_certain_names || @old_preventable_names; +say encode_utf8($INDENT . "- [certain] $_ => $new_name{$_}") + for @old_certain_names; +say encode_utf8($INDENT . "- [preventable] $_ => $new_name{$_}") + for @old_preventable_names; + +my $new_certain_lc + = List::Compare->new(\@want_certain, + [map { $new_name{$_} } @old_certain_names]); +my $new_preventable_lc + = List::Compare->new(\@want_preventable, + [map { $new_name{$_} } @old_preventable_names]); + +my @aware_certain_names = $new_certain_lc->get_intersection; +my @aware_preventable_names = $new_preventable_lc->get_intersection; + +say encode_utf8('They already know about those tags:') + if @aware_certain_names || @aware_preventable_names; +say encode_utf8($INDENT . "- [certain] $_") for @aware_certain_names; +say encode_utf8($INDENT . "- [preventable] $_") for @aware_preventable_names; + +my @unaware_certain_names = $new_certain_lc->get_Ronly; +my @unaware_preventable_names = $new_preventable_lc->get_Ronly; + +say encode_utf8('The following tags have to be added:') + if @unaware_certain_names || @unaware_preventable_names; +say encode_utf8($INDENT . "- [certain] $_") for @unaware_certain_names; +say encode_utf8($INDENT . "- [preventable] $_") for @unaware_preventable_names; + +# replace old names +@want_certain = uniq map { $new_name{$_} // $_ } @want_certain; +@want_preventable = uniq map { $new_name{$_} // $_ } @want_preventable; + +my $certain_lc = List::Compare->new(\@want_certain, \@known_tags); +my @unknown_certain = $certain_lc->get_Lonly; +my @certain = $certain_lc->get_intersection; + +my $preventable_lc = List::Compare->new(\@want_preventable, \@known_tags); +my @unknown_preventable = $preventable_lc->get_Lonly; +my @preventable = $preventable_lc->get_intersection; +my @unknown = (@unknown_certain, @unknown_preventable); + +say encode_utf8( + 'Warning, disregarding unknown tags for FTP Master Auto-Rejects:') + if @unknown; +say encode_utf8($INDENT . $HYPHEN . $SPACE . $_) for @unknown; + +say encode_utf8('Found ' + . scalar @certain + . ' certain and ' + . scalar @preventable + . ' preventable tags for FTP Master Auto-Rejects.'); + +exit 0; + +sub refresh_auto_reject_data { + + my $refresh_profile = Lintian::Profile->new; + $refresh_profile->load; + + my $refresh_data = $refresh_profile->data; + + my $archive = Lintian::Archive->new; + my $basedir = "$ENV{LINTIAN_BASE}/data"; + + # refresh data + $refresh_data->auto_rejection->refresh($archive, $basedir); + + undef $refresh_profile; + undef $refresh_data; + + return; +} + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/private/gen-po4a-conf b/private/gen-po4a-conf new file mode 100755 index 0000000..6d534f4 --- /dev/null +++ b/private/gen-po4a-conf @@ -0,0 +1,10 @@ +#!/bin/sh + +CFG="$1" +cp -f "$CFG".in "$CFG" +# Map a CHECK (e.g. python/depends or fields) to +# [type: lintian] checks/CHECK.desc \$lang:l10n/checks/CHECK_\$lang.desc +# +# sort is not strictly necessary, but it makes it easier to review. +find checks/ -name '*.desc' | LC_ALL=C.UTF-8 sort | \ + perl -ne 'chomp; $file = $_; s{^checks/(.+)\.desc$}{$1}; print "[type: lintian] $file \$lang:l10n/checks/${_}_\$lang.desc\n";' >> "$CFG"; diff --git a/private/generate-html-docs b/private/generate-html-docs new file mode 100755 index 0000000..5fed4b7 --- /dev/null +++ b/private/generate-html-docs @@ -0,0 +1,115 @@ +#!/usr/bin/perl + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use IPC::Run3; +use Pod::Simple::HTMLBatch; +use Unicode::UTF8 qw(encode_utf8); + +const my $EMPTY => q{}; + +my $destination = pop @ARGV; +my @input = @ARGV; + +push @input, './lib', './doc/tutorial' unless @input; +$destination //= './doc/api.html'; +my $lintian_version = guess_version(); + +if (!-d $destination) { + mkdir $destination + or die encode_utf8("could not create directory: $!"); +} + +my $convert = Pod::Simple::HTMLBatch->new; +$convert->html_render_class('My::Pod::Simple::XHTML'); +$convert->contents_page_start(header()); +# No footer - it contains a "current time" and is thus unreproducible +$convert->contents_page_end(q{}); +$convert->css_flurry(0); +$convert->batch_convert(\@input, $destination); + +print encode_utf8("HTML version available at $destination/index.html\n"); + +sub header { + + return <<"EOF"; +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" + "http://www.w3.org/TR/html4/loose.dtd"> +<html> +<head> + <title>Lintian (v$lintian_version) API doc</title> + <meta http-equiv="Content-Type" content="text/html; charset=UTF-8"> +</head> +<body class='contentspage'> +<h1>Lintian (v$lintian_version) API doc</h1> +<p><em>Note: </em>This API is not stable between releases.</p> +EOF +} + +sub guess_version { + my $version; + my $dist; + + my @dpkg_command = qw{dpkg-parsechangelog -c0}; + my $output; + + run3(\@dpkg_command, \undef, \$output); + my @lines = split(/\n/, $output); + + while (defined(my $line = shift @lines)) { + $version = $1 if $line =~ m{\A Version: \s*+ (\S++) \s* \Z}xsm; + $dist = $1 if $line =~ m{\A Distribution: \s*+ (\S++) \s* \Z}xsm; + } + + if ((not defined($dist) or $dist eq 'UNRELEASED') and -d '.git') { + + delete $ENV{'GITDIR'}; + + # For unreleased versions, git describe is probably a better + # choice when available. + my @command = qw(git describe); + my $guess; + run3(\@command, \undef, \$guess); + + chomp $guess; + $version = $guess + if $guess ne $EMPTY && $guess =~ m{\A \d+\. }xsm; + + # Ignore git being missing (or even failing to work) + # - the version being incorrect for non-release cases is + # not a major issue. + } + return $version; +} + +package My::Pod::Simple::XHTML; + +use strict; +use warnings; +use parent qw(Pod::Simple::XHTML); + +# Skip the version tag (incl. a date) to get reproducible output +sub version_tag_comment { + return q{}; +} + +sub batch_mode_page_object_init { + my ($self) = @_; + + $self->html_doctype( +'<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">' + ); + + $self->html_charset('UTF-8'); + + return; +} + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/private/generate-tag-summary b/private/generate-tag-summary new file mode 100755 index 0000000..d8c59b5 --- /dev/null +++ b/private/generate-tag-summary @@ -0,0 +1,151 @@ +#!/usr/bin/perl + +# Copyright (C) 2017, 2019 Chris Lamb <lamby@debian.org> + +use v5.20; +use warnings; +use utf8; + +use Cwd qw(realpath); +use File::Basename qw(dirname); +use Unicode::UTF8 qw(decode_utf8 encode_utf8); + +# neither Path::This nor lib::relative are in Debian +use constant THISFILE => realpath __FILE__; +use constant THISDIR => dirname realpath __FILE__; + +# use Lintian modules that belong to this program +use lib THISDIR . '/../lib'; + +use Const::Fast; +use Getopt::Long; +use IPC::Run3; + +use Lintian::IPC::Run3 qw(safe_qx); + +const my $PLUS => q{+}; +const my $WAIT_STATUS_SHIFT => 8; + +my (%added, %removed, %opt); + +my %opthash = ('in-place|i' => \$opt{'in-place'},); + +# init commandline parser +Getopt::Long::config('bundling', 'no_getopt_compat', 'no_auto_abbrev', + 'permute'); + +# process commandline options +Getopt::Long::GetOptions(%opthash) + or die encode_utf8("error parsing options\n"); + +my ($commit_range) = @ARGV; +if (not $commit_range) { + my $bytes = safe_qx(qw(git describe --abbrev=0)); + my $status = $? >> $WAIT_STATUS_SHIFT; + + die encode_utf8("git describe failed with code $status\n") + if $status; + + my $describe = $bytes; + chomp($describe); + + if (not $describe) { + die encode_utf8("git describe did not return anything.\n"); + } + $commit_range = "${describe}..HEAD"; + print encode_utf8("Assuming commit range to be: ${commit_range}\n"); +} + +my $output; +my @command =(qw{git diff}, $commit_range, qw{-- tags/*/*.tag}); +run3(\@command, \undef, \$output); + +my @lines = split(/\n/, $output); +while (defined(my $line = shift @lines)) { + + next + unless $line =~ m{ \A ([\+-]) Tag: \s*+ ([^ ]++) \s*+ \Z}xsm; + + my ($change, $tag) = ($1, $2); + if ($change eq $PLUS) { + $added{$tag} = 1; + } else { + $removed{$tag} = 1; + } +} + +for my $tag (keys(%added)) { + if (exists($removed{$tag})) { + # Added and removed? More likely, the tag was moved between + # two files. + delete($added{$tag}); + delete($removed{$tag}); + } +} + +if (not %added and not %removed) { + print {*STDERR} encode_utf8("No tags were added or removed\n"); +} + +if ($opt{'in-place'}) { + my $matched = 0; + + my $infile = 'debian/changelog'; + open(my $in_fd, '<:encoding(UTF-8)', $infile) + or die encode_utf8("Cannot open $infile"); + + my $outfile = 'debian/changelog.tmp'; + open(my $out_fd, '>', $outfile) + or die encode_utf8("Cannot open $outfile"); + + while (my $line = <$in_fd>) { + chomp $line; + if ($line =~ m/^ \* WIP\b/) { + emit_tag_summary($out_fd); + $matched++; + } else { + print {$out_fd} encode_utf8($line . "\n"); + } + } + close($out_fd); + close($in_fd); + if ($matched != 1) { + die encode_utf8( + "changelog did not match WIP placeholder exactly once\n"); + } + + rename($outfile, $infile) + or die encode_utf8("Cannot rename $outfile to $infile"); + + print encode_utf8("Updated $infile\n"); + +} else { + emit_tag_summary(\*STDOUT); +} + +sub emit_tag_summary { + my ($fd) = @_; + + if (%added or %removed) { + print {$fd} encode_utf8(" * Summary of tag changes:\n"); + } + if (%added) { + print {$fd} encode_utf8(" + Added:\n"); + for my $tag (sort(keys(%added))) { + print {$fd} encode_utf8(" - $tag\n"); + } + } + if (%removed) { + print {$fd} encode_utf8(" + Removed:\n"); + for my $tag (sort(keys(%removed))) { + print {$fd} encode_utf8(" - $tag\n"); + } + } + return; +} + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/private/hintadjust b/private/hintadjust new file mode 100755 index 0000000..66ce589 --- /dev/null +++ b/private/hintadjust @@ -0,0 +1,163 @@ +#!/usr/bin/perl + +# Copyright (C) 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 +# 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, you can find it on the World Wide +# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +# The harness for Lintian's test suite. For detailed information on +# the test suite layout and naming conventions, see t/tests/README. +# For more information about running tests, see +# doc/tutorial/Lintian/Tutorial/TestSuite.pod +# + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Cwd qw(realpath); +use File::Basename qw(dirname); + +# neither Path::This nor lib::relative are in Debian +use constant THISFILE => realpath __FILE__; +use constant THISDIR => dirname realpath __FILE__; + +# use Lintian modules that belong to this program +use lib THISDIR . '/../lib'; + +use Getopt::Long; +use IO::Interactive qw(is_interactive); +use IO::Prompt::Tiny qw(prompt); +use List::Util qw(all); +use Path::Tiny; +use Term::ANSIColor; +use Unicode::UTF8 qw(encode_utf8 decode_utf8); + +use Test::Lintian::Output::Universal qw(parse_line order); + +const my $EMPTY => q{}; +const my $NEWLINE => qq{\n}; +const my $PLUS => q{+}; + +# options +my $interactive; + +Getopt::Long::Configure; +unless ( + Getopt::Long::GetOptions( + 'i|interactive' => \$interactive, + 'help|h' => sub {usage(); exit;}, + ) +) { + usage(); + die; +} + +# check arguments and options +die encode_utf8("Please use -h for usage information.\n") + if scalar @ARGV != 2; + +# get arguments +my ($diffpath, $hintspath) = @ARGV; + +my @difflines = path($diffpath)->lines_utf8; +chomp @difflines; + +my @hintslines = path($hintspath)->lines_utf8; +chomp @hintslines; + +my $changed; + +foreach my $line (@difflines) { + my ($sign, $stripped) = $line =~ qr/^([+-])(.*)$/; + + die encode_utf8("$diffpath is not a hintdiff file") + unless length $sign && defined $stripped; + + if ($interactive) { + + my $command; + my $color; + + if ($sign eq $PLUS) { + $command = 'Add'; + $color = 'bold bright_white on_green'; + } else { + $command = 'Remove'; + $color = 'bold bright_white on_red'; + } + + my $colored = $stripped; + $colored = colored($stripped, $color) + if is_interactive; + + my $decision_bytes + = prompt(encode_utf8("$colored - $command (y/n/q)?")); + my $decision = decode_utf8($decision_bytes); + + exit + if $decision eq 'q' || $decision eq $EMPTY; + + next + unless $decision eq 'y'; + } + + if ($sign eq $PLUS) { + # say encode_utf8("Adding: $stripped"); + push(@hintslines, $stripped); + } else { + # say encode_utf8("Removing: $stripped"); + # remove the first match only + my $found = 0; + @hintslines = grep {$_ ne $stripped || $found++} @hintslines; + } + + $changed = 1; +} + +exit unless $changed; + +# also sort output into preferred order +my $joined = $EMPTY; +$joined .= $_ . $NEWLINE + for reverse sort { order($a) cmp order($b) } @hintslines; +path($hintspath)->spew_utf8($joined); + +exit; + +sub usage { + my $message =<<"END"; +Usage: $0 -i <hintdiff-file> <hints-file> + + --interactive, -i Apply <hintdiff-file> interactively + + Applies <hintdiff-file> to <hintsfile> so that the new file represents the + changes. Please use hintdiff to create the file with the changes. + + The hints are then sorted in the order preferred for universal hints. +END + + print encode_utf8($message); + + return; +} + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/private/hintdiff b/private/hintdiff new file mode 100755 index 0000000..dc05422 --- /dev/null +++ b/private/hintdiff @@ -0,0 +1,132 @@ +#!/usr/bin/perl + +# Copyright (C) 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 +# 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, you can find it on the World Wide +# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +# The harness for Lintian's test suite. For detailed information on +# the test suite layout and naming conventions, see t/tests/README. +# For more information about running tests, see +# doc/tutorial/Lintian/Tutorial/TestSuite.pod +# + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Cwd qw(realpath); +use File::Basename qw(dirname); + +# neither Path::This nor lib::relative are in Debian +use constant THISFILE => realpath __FILE__; +use constant THISDIR => dirname realpath __FILE__; + +# use Lintian modules that belong to this program +use lib THISDIR . '/../lib'; + +use Getopt::Long; +use IO::Interactive qw(is_interactive); +use List::Util qw(all); +use Path::Tiny; +use Term::ANSIColor qw(:constants); +use Text::Diff; +use Unicode::UTF8 qw(encode_utf8); + +use Test::Lintian::Output::Universal qw(order); + +const my $EMPTY => q{}; +const my $NEWLINE => qq{\n}; + +no warnings 'redefine'; + +sub Text::Diff::Unified::file_header { return $EMPTY; } +sub Text::Diff::Unified::hunk_header { return $EMPTY; } + +# options +Getopt::Long::Configure; +unless ( + Getopt::Long::GetOptions( + 'help|h' => sub {usage(); exit;}, + ) +) { + usage(); + die; +} + +# check arguments and options +die encode_utf8("Please use -h for usage information.\n") + if scalar @ARGV != 2; + +# get arguments +my ($expectedpath, $actualpath) = @ARGV; + +my @expected + = reverse sort { order($a) cmp order($b) } (path($expectedpath)->lines_utf8); +my @actual + = reverse sort { order($a) cmp order($b) }(path($actualpath)->lines_utf8); + +my $diff = diff(\@expected, \@actual, { CONTEXT => 0 }); + +my @lines = split(/$NEWLINE/, $diff); +chomp @lines; + +# sort before applying color +@lines = reverse sort @lines; + +# apply color when on a terminal +if (is_interactive) { + + my $green = GREEN; + my $red = RED; + my $reset = RESET; + + s/^(\+.*)$/$green$1$reset/ for @lines; + s/^(\-.*)$/$red$1$reset/ for @lines; +} + +print encode_utf8($_ . $NEWLINE) for @lines; + +exit; + +sub usage { + my $message =<<"END"; +Usage: $0 <expected-hint-file> <actual-hint-file> + + Print differences between the hint information in the two files. The files + must in a CSV format delimited by '|'. The easiest way to obtain such a + file is to use hintextract. + + The output is sorted lexigraphically in reverse order. If the arguments + are reversed, the new output can also be generated from the old one by + reversing the signs and sorting again in reverse order (under LC_ALL=C). + It only works with uncolored output. + + Returns with a zero exit code under normal conditions, even when the hints + do not match. +END + + print encode_utf8($message); + + return; +} + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/private/hintextract b/private/hintextract new file mode 100755 index 0000000..dae8518 --- /dev/null +++ b/private/hintextract @@ -0,0 +1,119 @@ +#!/usr/bin/perl + +# Copyright (C) 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 +# 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, you can find it on the World Wide +# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +# The harness for Lintian's test suite. For detailed information on +# the test suite layout and naming conventions, see t/tests/README. +# For more information about running tests, see +# doc/tutorial/Lintian/Tutorial/TestSuite.pod +# + +use v5.20; +use warnings; +use utf8; + +use Cwd qw(realpath); +use File::Basename qw(dirname); + +# neither Path::This nor lib::relative are in Debian +use constant THISFILE => realpath __FILE__; +use constant THISDIR => dirname realpath __FILE__; + +# use Lintian modules that belong to this program +use lib THISDIR . '/../lib'; + +use Getopt::Long; +use List::Util qw(all); +use Path::Tiny; +use Unicode::UTF8 qw(encode_utf8); + +use Test::Lintian::Output::EWI; + +# options +my $target_format; + +Getopt::Long::Configure; +unless ( + Getopt::Long::GetOptions( + 'f|format=s' => \$target_format, + 'help|h' => sub {usage(); exit;}, + ) +) { + usage(); + die; +} + +# check arguments and options +die encode_utf8("Please use -h for usage information.\n") + if scalar @ARGV < 1 || scalar @ARGV > 2; + +# get arguments +my ($inpath, $outpath) = @ARGV; + +die encode_utf8("File $inpath does not exist.\n") + unless -e $inpath; + +my $original_text = path($inpath)->slurp_utf8; +my $converted = to_universal($target_format, $original_text); + +if (defined $outpath) { + path($outpath)->spew_utf8($converted); +}else { + print encode_utf8($converted); +} + +exit; + +sub to_universal { + my ($format, $text) = @_; + + if ($format eq 'EWI') { + return Test::Lintian::Output::EWI::to_universal($text); + } + + die encode_utf8("Unknown format: $format\n"); +} + +sub usage { + my $message =<<"END"; +Usage: $0 -f <format> <in-file> <out-file> + + --format, -f <format> Format of Lintian output file <in-file> + + Extracts hint information from a variety of Lintian output formats. The + output format is a simplified EWI format without letter code. Other + notable differences are that the binary package type is always displayed. + + The hints are sorted in a reverse order, but with the package type pulled + to the front. That way package types are grouped. Source packages are at + the top. + + Prints to stdout when no <out-file> is given. +END + + print encode_utf8($message); + + return; +} + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/private/hintsort b/private/hintsort new file mode 100755 index 0000000..4392cc8 --- /dev/null +++ b/private/hintsort @@ -0,0 +1,96 @@ +#!/usr/bin/perl + +# Copyright (C) 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 +# 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, you can find it on the World Wide +# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +# The harness for Lintian's test suite. For detailed information on +# the test suite layout and naming conventions, see t/tests/README. +# For more information about running tests, see +# doc/tutorial/Lintian/Tutorial/TestSuite.pod +# + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Cwd qw(realpath); +use File::Basename qw(dirname); + +# neither Path::This nor lib::relative are in Debian +use constant THISFILE => realpath __FILE__; +use constant THISDIR => dirname realpath __FILE__; + +# use Lintian modules that belong to this program +use lib THISDIR . '/../lib'; + +use Getopt::Long; +use List::Util qw(all); +use Path::Tiny; +use Term::ANSIColor; +use Unicode::UTF8 qw(encode_utf8); + +use Test::Lintian::Output::Universal qw(parse_line order); + +const my $EMPTY => q{}; +const my $NEWLINE => qq{\n}; + +Getopt::Long::Configure; +unless ( + Getopt::Long::GetOptions( + 'help|h' => sub {usage(); exit;}, + ) +) { + usage(); + die; +} + +# check arguments and options +die encode_utf8("Please use -h for usage information.\n") + if scalar @ARGV != 1; + +# get arguments +my ($hintspath) = @ARGV; + +my @hintslines = path($hintspath)->lines_utf8; +chomp @hintslines; + +my $joined = $EMPTY; +$joined .= $_ . $NEWLINE + for reverse sort { order($a) cmp order($b) } @hintslines; + +path($hintspath)->spew_utf8($joined); + +exit; + +sub usage { + my $message =<<"END"; +Usage: $0 <hintfile> + Sorts hintfile in the order preferred for universal hints. +END + + print encode_utf8($message); + + return; +} + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/private/latest-policy-version b/private/latest-policy-version new file mode 100755 index 0000000..8143a45 --- /dev/null +++ b/private/latest-policy-version @@ -0,0 +1,63 @@ +#!/usr/bin/perl + +# Copyright (C) 2020 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 +# 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, you can find it on the World Wide +# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +# The package libconfig-model-dpkg-perl is the only known and intended +# user of this script. It was written in an attempt to further the +# resolution of Bug#968011 and Bug#968000 an will go away soon. + +# PLEASE DO NOT USE THIS SCRIPT. YOU ARE USING AN UNSUPPORTED FEATURE. + +use v5.20; +use warnings; +use utf8; + +use Cwd qw(realpath); +use File::Basename qw(dirname); +use Unicode::UTF8 qw(encode_utf8); + +# neither Path::This nor lib::relative are in Debian +use constant THISFILE => realpath __FILE__; +use constant THISDIR => dirname realpath __FILE__; + +# use Lintian modules that belong to this program +use lib THISDIR . '/../lib'; + +use Lintian::Profile; + +$ENV{LINTIAN_BASE} = realpath(THISDIR . '/..'); + +my $profile = Lintian::Profile->new; +$profile->load; + +my $releases = $profile->data->policy_releases; + +my $version = $releases->latest_version; +die encode_utf8('Could not get latest policy version.') + unless defined $version; + +say encode_utf8($version); + +exit; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/private/post-release-version-bump b/private/post-release-version-bump new file mode 100755 index 0000000..1f5556a --- /dev/null +++ b/private/post-release-version-bump @@ -0,0 +1,15 @@ +#!/bin/sh + +# Post-release version bump script. Not really lintian-specific, but needed here. + +set -e + +if head -1 debian/changelog | grep -Fq 'UNRELEASED' ; then + echo 'Most recent debian/changelog entry already sports an "UNRELEASED", doing nothing.' + exit 1; +fi + +dch --increment 'WIP (generated at release time: please do not add entries below.)' +sed -e '1 s/)/~git)/' -i debian/changelog +git add debian/changelog +git commit -m "Post-release version bump" -m "Gbp-Dch: Ignore" diff --git a/private/refresh-data b/private/refresh-data new file mode 100755 index 0000000..f9f95df --- /dev/null +++ b/private/refresh-data @@ -0,0 +1,130 @@ +#!/usr/bin/perl +# +# Copyright (C) 2008 by Raphael Geissert <atomo64@gmail.com> +# Copyright (C) 2017-2018 Chris Lamb <lamby@debian.org> +# Copyright (C) 2021 Felix Lechner +# +# This program is free software. It is distributed 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, you can find it on the World Wide +# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +use v5.20; +use warnings; +use utf8; + +use Cwd qw(realpath); +use File::Basename qw(dirname); + +# neither Path::This nor lib::relative are in Debian +use constant THISFILE => realpath __FILE__; +use constant THISDIR => dirname realpath __FILE__; + +# use Lintian modules that belong to this program +use lib THISDIR . '/../lib'; + +use Const::Fast; +use MCE::Loop; +use List::SomeUtils qw(true); +use Syntax::Keyword::Try; +use Unicode::UTF8 qw(encode_utf8); + +use Lintian::Archive; +use Lintian::Profile; + +const my $EMPTY => q{}; + +const my $REFRESH_SUCCESSFUL => 1; +const my $REFRESH_INCAPABLE => 0; +const my $REFRESH_FAILED => -1; + +$ENV{LINTIAN_BASE} = realpath(THISDIR . '/..') + // die encode_utf8('Cannot resolve LINTIAN_BASE'); + +my $basedir = "$ENV{LINTIAN_BASE}/data"; + +die encode_utf8("Basedir does not exist at $basedir\n") + unless -e $basedir; + +my $profile = Lintian::Profile->new; +$profile->load; + +my @data_sources = $profile->data->all_sources; + +my @selected; + +if (@ARGV) { + my $pattern = $ARGV[0]; + @selected = grep { $_->title =~ m{\Q$pattern\E}i } @data_sources; + +} else { + @selected = @data_sources; +} + +my $total = scalar @selected; + +say "Refreshing $total data sources."; + +MCE::Loop->init( + max_workers => 'auto', + chunk_size => 1 +); + +my $archive = Lintian::Archive->new; + +my @results = mce_loop { + my ($mce, $chunk_ref, $chunk_id) = @_; + + my $data_source = $_; + + my $title = $data_source->title; + my $counter = sprintf('%*d/%d', length($total), $chunk_id, $total); + + if (!$data_source->can('refresh')) { + + $mce->say(encode_utf8("[$counter] $title not implemented.")); + $mce->gather($REFRESH_INCAPABLE); + return; + } + + try { + $data_source->refresh($archive, $basedir); + + } catch { + $mce->say(encode_utf8("[$counter] $title had error: $@")); + $mce->gather($REFRESH_FAILED); + return; + } + + $mce->gather($REFRESH_SUCCESSFUL); + $mce->say(encode_utf8("[$counter] $title")); + +} +@selected; + +my $errors = true { $_ == $REFRESH_FAILED } @results; + +if ($errors) { + say $EMPTY; + warn encode_utf8( + "WARNING: $errors data source(s) failed to refresh (out of $total)."); +} + +exit; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/private/refresh-hwcap b/private/refresh-hwcap new file mode 100755 index 0000000..62668bc --- /dev/null +++ b/private/refresh-hwcap @@ -0,0 +1,92 @@ +#!/usr/bin/perl + +use v5.20; +use warnings; +use utf8; + +use IPC::Run3; +use POSIX qw(strftime); +use Unicode::UTF8 qw(encode_utf8); + +my $datadir = shift; +my $man = shift // '/usr/share/man/man8/ld.so.8.gz'; +my (%caps, @keeps); + +die encode_utf8("Usage: $0 path/to/lintian/data.\n") + unless $datadir; + +my @command = ('zcat', $man); +my $output; + +run3(\@command, \undef, \$output); +my @lines = split(/\n/, $output); + +while (defined(my $line = shift @lines)) { + next + unless $line =~ /^\.S[SH] HARDWARE CAPABILITIES/i; + last; +} + +while (defined(my $line = shift @lines)) { + next + unless $line =~ /^\.B/; + last; +} + +while (defined(my $line = shift @lines)) { + + last + if $line =~ /^\.S[SH] /; + next + if $line =~ /^\./; + + $caps{$_} = 1 for split(/,\s*/, $line); +} + +my $path = "$datadir/shared-libs/hwcap-dirs"; +my $date = strftime '%Y-%m-%d', gmtime; +open(my $orig, '<', $path) + or die encode_utf8("Cannot open $path"); + +while (my $line = <$orig>) { + chomp $line; + + next + unless $line =~ m/^#\s*Keep:\s*(.*\S)\s*$/; + + my $keep = $1; + push @keeps, $keep; + + foreach my $val (split /\s*,\s*/, $keep) { + $caps{$val} = 1; + } +} +close($orig); + +open(my $fp, '>', $path) + or die encode_utf8("Cannot open $path"); + +print {$fp} encode_utf8(<<"EOF"); +# List of all known hwcap. +# +# Last updated: $date +# Generated by $0 +# +# Lines to always be included: +EOF +foreach my $keep (@keeps) { + print {$fp} encode_utf8("# Keep: $keep\n"); +} + +print {$fp} encode_utf8("\n"); + +foreach (sort keys %caps) { + print {$fp} encode_utf8("$_\n"); +} +close($fp); + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/private/refresh-perl-provides b/private/refresh-perl-provides new file mode 100755 index 0000000..4d70eff --- /dev/null +++ b/private/refresh-perl-provides @@ -0,0 +1,222 @@ +#!/usr/bin/perl + +use v5.20; +use warnings; +use utf8; + +# Generate a list of packages that are provided by the Perl core packages +# and also packaged separately at a (hopefully) newer version. +# The list will have the package name and the upstream version of the +# corresponding module integrated in the currently installed Perl version. + +# Copyright (C) 2008 Niko Tyni +# +# 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/>. + +use Const::Fast; +use List::SomeUtils qw(none); +use Unicode::UTF8 qw(encode_utf8); + +# from /usr/share/doc/libapt-pkg-perl/examples/apt-cache +use AptPkg::Config '$_config'; +use AptPkg::System '$_system'; +use AptPkg::Cache; + +const my $EMPTY => q{}; +const my $LAST_ITEM => -1; + +(my $self = $0) =~ s{.*/}{}; + +# initialise the global config object with the default values and +# setup the $_system object +$_config->init; +$_system = $_config->system; + +# suppress cache building messages +$_config->{quiet} = 2; + +# set up the cache +my $cache = AptPkg::Cache->new; +# end from /usr/share/doc/libapt-pkg-perl/examples/apt-cache + +# special cases when libfoo-bar-perl => Foo::Bar doesn't work +my %module_name = ( + 'libio-compress-perl' => 'IO::Compress::Gzip', + 'libio-compress-zlib-perl' => 'IO::Compress::Gzip', +); + +# special cases for where the code gets the prefix wrong +my %manual_split + = ('libautodie-perl' => qr/\A (\d++\.) (\d{2}) (\d{2})? \Z/xsmo,); + +use Module::CoreList; +my $versioning = $_system->versioning; + +my $perl_version = $]; + +# Map 5.022002 into 5.22 +$perl_version =~ s/^(5)\.0*([1-9][0-9])\d+/$1.$2/; + +# we look at packages provided by these +my @core_packages = (qw(perl-base perl), "perl-modules-$perl_version"); + +# check we have a cache of Debian sid packages available +warn encode_utf8( + join(q{ }, + 'Warning: this list should only be updated on a system', + 'with an up to date APT cache of the Debian unstable distribution') + ) + if ( + none { + defined $_->{Origin} + && defined $_->{Archive} + && $_->{Origin} eq 'Debian' + && $_->{Archive} eq 'unstable'; + }@{$cache->files} + ); + +print encode_utf8(<<"EOF"); +# virtual packages provided by the Perl core packages that also have a +# separate binary package available +# +# the listed version is the one included in the Perl core +# +# regenerate by running +# debian/rules refresh-perl-provides +# in the lintian source tree +# +# last updated for PERL_VERSION=$] +EOF + +for my $pkg (@core_packages) { + my $cached_versions = $cache->{$pkg} + or + die encode_utf8("no such binary package found in the APT cache: $pkg"); + my $latest = bin_latest($cached_versions); + + for my $provides (@{$latest->{ProvidesList}}) { + my $name = $provides->{Name}; + # skip virtual-only packages + next if (!$cache->{$name}{VersionList}); + my $cpan_version = find_core_version($name); + + next if !$cpan_version; + + # the number of digits is a pain + # we use the current version in the Debian archive to determine + # how many we need + # the epoch is easier, we just copy it + + my ($epoch, $digits) = epoch_and_digits($name); + my $debian_version + = cpan_version_to_deb($name, $cpan_version, $epoch, $digits); + + next if !$debian_version; + + print encode_utf8("$name $debian_version\n"); + } +} + +# look up the CPAN version of a package in the core +sub find_core_version { + my $module = shift; + my $ret; + + return undef + if $module =~ /^perl(5|api)/; + + if (exists $module_name{$module}) { + $module = $module_name{$module}; + } else { + # mangle the package name into the module name + $module =~ s/^lib//; + $module =~ s/-perl$//; + $module =~ s/-/::/g; + } + + for (Module::CoreList->find_modules(qr/^\Q$module\E$/i, 0+$])) { + $ret = $Module::CoreList::version{0+$]}{$_}; + last; + } + + return $ret; +} + +sub cpan_version_to_deb { + my ($pkg, $cpan_version, $epoch, $digits) = @_; + $epoch ||= $EMPTY; + + # cpan_version + # digits + # result + # 1.15_02, 2 => 1.15.02 + # 1.15_02, 4 => 1.1502 + # 1.15_02, 0 => 1.15.02 + # + # 1.15_021, 2 => 1.15.021 + # 1.15_021, 4 => 1.1500.021 + # 1.15_021, 0 => 1.15.021 + # + # 1.15, 1 => 1.15 + # 1.15, 2 => 1.15 + # 1.15, 4 => 1.1500 + # 1.15, 0 => 1.15 + + # split 1.15_02 to (1, 15, 02) + my $regex = qr/^(\d+\.)(\d+)(?:_(\d+))?$/; + $regex = $manual_split{$pkg} if exists $manual_split{$pkg}; + my ($major, $prefix, $suffix) = ($cpan_version =~ $regex); + die encode_utf8("no match with $cpan_version?") if !$major; + + $suffix ||= $EMPTY; + if (length($suffix) + length($prefix) == $digits) { + $prefix .= $suffix; + $suffix = $EMPTY; + } + if (length($suffix) + length($prefix) < $digits) { + $prefix .= '0' while length($prefix) < $digits; + } + $suffix = ".$suffix" if $suffix ne $EMPTY; + return $epoch.$major.$prefix.$suffix; +} + +# Given a Debian binary package name, look up its latest version +# and return its epoch (including the colon) if available, and +# the number of digits in its decimal part +sub epoch_and_digits { + my $p = shift; + return (0, 0) if !exists $cache->{$p}; + return (0, 0) if !exists $cache->{$p}{VersionList}; # virtual package + my $latest = bin_latest($cache->{$p}); + my $v = $latest->{VerStr}; + $v =~ s/\+dfsg//; + my ($epoch, $major, $prefix, $suffix, $revision) + = ($v =~ /^(?:(\d+:))?((?:\d+\.))+(\d+)(?:_(\d+))?(-[^-]+)$/); + return ($epoch, length $prefix); +} + +sub bin_latest { + my $p = shift; + return (sort bin_byversion @{$p->{VersionList}})[$LAST_ITEM]; +} + +sub bin_byversion { + return $versioning->compare($a->{VerStr}, $b->{VerStr}); +} + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/private/refresh-virtual-packages-data b/private/refresh-virtual-packages-data new file mode 100755 index 0000000..d301373 --- /dev/null +++ b/private/refresh-virtual-packages-data @@ -0,0 +1,147 @@ +#!/bin/sh +# refresh-virtual-packages-data -- Refresh data about font packages in Debian + +# Copyright (C) 2008, 2009 Raphael Geissert <atomo64@gmail.com> +# Copyright (C) 2017 Chris Lamb <lamby@debian.org> +# +# This file 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 file 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 file. If not, see <http://www.gnu.org/licenses/>. + +set -e + +# Ensure the sort order is stable. +LC_ALL=C; export LC_ALL + +if [ -z "$1" ]; then + printf "Usage: %s <path-to-data> [<packages>]\n" "$(basename "$0")" + cat <<INFO + +If <packages> is specified, it should be the path to the Packages file +from the current unstable distribution. It will be used to find all +font files already packaged for Debian and update the list of known +font files and the packages that contain them. <path-to-data> should +be the path to the root of the Lintian data directory to update. + +If the Packages file is not specified, the script will download the +following files from a mirror. The mirror can be specified with the +DEB_MIRROR environment variable. If it is not set, the default is +http://deb.debian.org/debian. + +* main/binary-i386/Packages.gz + +Any necessary special parameters for wget can be set via the +environment variable WGET_ARGS. The default arguments are -nv. + +To set additional virtual packages to be added to the list as Keep entries +list them in the VIRTUAL_PACKAGES environment variable. + +INFO + exit +fi + +readonly lintian_data="$(readlink -f "$1")" +if [ -n "$2" ] ; then + packages="$(readlink -f "$2")" +fi + +[ -d "$lintian_data" ] || { + printf "%s is not a directory, aborting" "$lintian_data" >&2 + exit 1 +} + +readonly workdir="$(mktemp -d)" + +cleanup () { + [ ! -d "$workdir" ] || rm -rf "$workdir" +}; trap cleanup EXIT + +mirror="${DEB_MIRROR:=http://deb.debian.org/debian}" +WGET_ARGS="${WGET_ARGS:=-nv}" +wget() { + echo wget "$mirror"/"$1" + /usr/bin/wget $WGET_ARGS -O "$workdir/$(basename "$1")" "$mirror"/"$1" +} +mkdir -p "$lintian_data/fields" + +cat > "$workdir/virtual-packages" <<EOF +# The list of virtual packages in Debian that are provided by two or more +# packages. +# +# Packages that should be listed but are not found by this script can be +# listed in a special comment in this file. They will then be preserved when +# the list is regenerated. Such packages must be listed in a comment line +# staring with "Keep:". Multiple packages can be specified in the same line, +# separated by comma and/or white space. Multiple "Keep: " lines can be used +# as well. +# +# Last updated: $(date -u +'%Y-%m-%d') + +EOF + +[ -f "$lintian_data/fields/virtual-packages" ] && { + grep -E '^#\s*Keep:\s*.+$' "$lintian_data/fields/virtual-packages" \ + >> "$workdir/virtual-packages" || true +} +[ -z "$VIRTUAL_PACKAGES" ] || { + printf "# Keep: %s\n" "$VIRTUAL_PACKAGES" >> "$workdir/virtual-packages" +} + +echo >> "$workdir/virtual-packages" + +if [ -z "$packages" ] ; then + wget dists/sid/main/binary-i386/Packages.gz + packages="$workdir/Packages.gz" +fi + +case "$packages" in + *.gz) + CAT=zcat + ;; + *) + CAT=cat + ;; +esac + +# We have to repeat all the Keep packages twice, since we filter out any +# virtual packages that are only used once in the archive. +{ $CAT "$packages" + sed -rn 's/^#\s*Keep:\s*/Provides: /;T;s/([^,:])\s+([^,])/\1, \2/g;p' \ + "$workdir/virtual-packages" + sed -rn 's/^#\s*Keep:\s*/Provides: /;T;s/([^,:])\s+([^,])/\1, \2/g;p' \ + "$workdir/virtual-packages" +} | + perl -w -E 'my (%seen, %pkgs); + while (<>) { + chomp; + if (m/^Package:\s*(.+)$/) { + $pkgs{$1} = 1; + next; + } + next unless (s/^Provides:\s*//); + for my $pkg (split /\s*,\s*/) { + $seen{$pkg}++; + } + } + for my $pkg (keys %seen) { + print "$pkg\n" + unless ($seen{$pkg} == 1 or exists($pkgs{$pkg})); + }' \ + | sort -u >> "$workdir/virtual-packages" + +mv "$workdir/virtual-packages" "$lintian_data/fields/" + + +# Local Variables: +# indent-tabs-mode: nil +# End: +# vim: syntax=sh sw=4 sts=4 sr et diff --git a/private/runtests b/private/runtests new file mode 100755 index 0000000..0b27fd7 --- /dev/null +++ b/private/runtests @@ -0,0 +1,972 @@ +#!/usr/bin/perl + +# Copyright (C) 1998 Richard Braakman +# Copyright (C) 2008 Frank Lichtenheld +# Copyright (C) 2008, 2009 Russ Allbery +# Copyright (C) 2014 Niels Thykier +# Copyright (C) 2020 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 +# 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, you can find it on the World Wide +# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +# The harness for Lintian's test suite. For detailed information on +# the test suite layout and naming conventions, see t/tests/README. +# For more information about running tests, see +# doc/tutorial/Lintian/Tutorial/TestSuite.pod +# + +use v5.20; +use warnings; +use utf8; + +use Const::Fast; +use Cwd qw(realpath); +use File::Basename qw(dirname); + +# neither Path::This nor lib::relative are in Debian +use constant THISFILE => realpath __FILE__; +use constant THISDIR => dirname realpath __FILE__; + +# use Lintian modules that belong to this program +use lib THISDIR . '/../lib'; + +use Capture::Tiny qw(capture_merged); +use Cwd qw(getcwd); +use File::Copy; +use File::Find::Rule; +use File::Path qw(make_path); +use File::Spec::Functions qw(abs2rel rel2abs splitpath splitdir); +use File::stat; +use Getopt::Long; +use IPC::Run3; +use List::Compare; +use List::SomeUtils qw(any uniq); +use List::Util qw(max); +use IO::Interactive qw(is_interactive); +use IO::Prompt::Tiny qw(prompt); +use MCE::Loop; +use Path::Tiny; +use Syntax::Keyword::Try; +use TAP::Formatter::Console; +use TAP::Formatter::File; +use TAP::Harness; +use TAP::Parser::Aggregator; +use Term::ANSIColor; +use Time::Duration; +use Time::Moment; +use Time::Piece; +use Unicode::UTF8 qw(encode_utf8 decode_utf8); + +use Lintian::IPC::Run3 qw(safe_qx); + +use Test::Lintian::Build qw(build_subject); +use Test::Lintian::ConfigFile qw(read_config); +use Test::Lintian::Filter + qw(find_selected_scripts find_selected_lintian_testpaths); +use Test::Lintian::Helper + qw(rfc822date cache_dpkg_architecture_values get_latest_policy get_recommended_debhelper_version); +use Test::Lintian::Hooks qw(sed_hook sort_lines calibrate); +use Test::Lintian::Prepare qw(filleval prepare); +use Test::Lintian::Run qw(logged_runner); +use Test::ScriptAge qw(perl_modification_epoch our_modification_epoch); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $INDENT => $SPACE x 4; +const my $NEWLINE => qq{\n}; +const my $SLASH => q{/}; +const my $COMMA => q{,}; +const my $COLON => q{:}; +const my $ARROW => q{>>>}; +const my $YES => q{yes}; +const my $NO => q{no}; + +const my $WIDELY_READABLE => oct(22); + +# display output immediately +STDOUT->autoflush; + +# something changes the default handler, see Bug#974575 +$SIG{WINCH} = 'DEFAULT'; + +# see https://stackoverflow.com/a/60761593 +$SIG{CHLD} ||= 'DEFAULT'; +$SIG{HUP} ||= 'DEFAULT'; + +my $processing_start = Time::Moment->from_string(gmtime->datetime . 'Z'); + +# whitelist the environment we permit to avoid things that mess up +# tests, like CFLAGS, DH_OPTIONS, DH_COMPAT, DEB_HOST_ARCH +my %PRESERVE_ENV = map { $_ => 1 } qw( + LINTIAN_TEST_INSTALLED + PATH + TMPDIR +); + +my @disallowed = grep { !exists $PRESERVE_ENV{$_} } keys %ENV; + +delete $ENV{$_} for @disallowed; + +if (($ENV{LINTIAN_TEST_INSTALLED} // 'no') eq 'yes') { + + $ENV{LINTIAN_UNDER_TEST} = realpath('/usr/bin/lintian') + // die encode_utf8('Lintian is not installed'); + +} else { + $ENV{LINTIAN_UNDER_TEST} = realpath(THISDIR . '/../bin/lintian'); +} + +$ENV{LINTIAN_BASE}= realpath(dirname(dirname($ENV{LINTIAN_UNDER_TEST}))) + // die encode_utf8('Cannot resolve LINTIAN_BASE'); + +# options +my $coverage; +my $debug; +my $dump_logs = 1; +my $force_rebuild; +my $numjobs; +my $keep_going; +my $onlyrun; +my $outpath; +my $unattended; +my $verbose = 0; + +Getopt::Long::Configure('bundling'); +unless ( + Getopt::Long::GetOptions( + 'B|force-rebuild' => \$force_rebuild, + 'c|coverage:s' => \$coverage, + 'd|debug+' => \$debug, + 'j|jobs:i' => \$numjobs, + 'k|keep-going' => \$keep_going, + 'L|dump-logs!' => \$dump_logs, + 'o|onlyrun:s' => \$onlyrun, + 'u|unattended' => \$unattended, + 'v|verbose' => \$verbose, + 'w|work-dir:s' => \$outpath, + 'h|help' => sub {usage(); exit;}, + ) +) { + usage(); + die; +} + +# check number of arguments +die encode_utf8('Please use -h for usage information.') + if @ARGV > 1; + +# get arguments +my ($testset) = @ARGV; + +# default test set +$testset ||= 't'; + +# check test set directory +die encode_utf8("Cannot find testset directory $testset") + unless -d $testset; + +# make sure testset is an absolute path +$testset = rel2abs($testset); + +# calculate a default test work directory if none given +$outpath ||= dirname($testset) . '/debian/test-out'; + +# create test work directory unless it exists +make_path($outpath) + unless -e $outpath; + +# make sure test work path is a directory +die encode_utf8("Test work directory $outpath is not a directory") + unless -d $outpath; + +# make sure outpath is absolute +$outpath = rel2abs($outpath); + +my $ACTIVE_JOBS = 0; + +# get lintian modification date +my @lintianparts + = ('checks', 'commands', 'data','bin', 'profiles', 'vendors', 'lib/Lintian'); +my @lintianfiles + = map { File::Find::Rule->file->in("$ENV{'LINTIAN_BASE'}/$_") }@lintianparts; +push(@lintianfiles, Cwd::realpath($ENV{'LINTIAN_UNDER_TEST'})); +$ENV{'LINTIAN_EPOCH'} + = max(map { -e ? path($_)->stat->mtime : time } @lintianfiles); +say encode_utf8('Lintian modified on '. rfc822date($ENV{'LINTIAN_EPOCH'})); + +my $lintian_error; +my $bytes = capture_merged { + my @command = ($ENV{'LINTIAN_UNDER_TEST'}, '--version'); + system(@command) == 0 + or $lintian_error = "system @command failed: $?"; +}; +my $string = decode_utf8($bytes); +die encode_utf8($string . $lintian_error) + if length $lintian_error; + +chomp $string; +my ($version) = $string =~ qr/^\S+\s+v(.+)$/; +die encode_utf8('Cannot get Lintian version') unless length $version; +say encode_utf8("Version under test is $version."); + +say encode_utf8($EMPTY); + +# set environment for coverage +if (defined $coverage) { + # Only collect coverage for stuff that D::NYTProf and + # Test::Pod::Coverage cannot do for us. This makes cover use less + # RAM in the other end. + my @criteria = qw(statement branch condition path subroutine); + my $args= '-MDevel::Cover=-silent,1,+ignore,^(.*/)?t/scripts/.+'; + $args .= ',+ignore,/usr/bin/.*,+ignore,(.*/)?Dpkg'; + $args .= ',-coverage,' . join(',-coverage,', @criteria); + $args .= $COMMA . $coverage if $coverage ne $EMPTY; + $ENV{'LINTIAN_COVERAGE'} = $args; + + $ENV{'HARNESS_PERL_SWITCHES'} //= $EMPTY; + $ENV{'HARNESS_PERL_SWITCHES'} .= $SPACE . $args; +} + +# Devel::Cover + one cover_db + multiple processes is a recipe +# for corruptions. Force $numjobs to 1 if we are running under +# coverage. +$numjobs = 1 if exists $ENV{'LINTIAN_COVERAGE'}; + +# tie verbosity to debug +$verbose = 1 + $debug if $debug; + +# can be 0 without value ("-j") or undef if option was not specified at all +$numjobs ||= default_parallel(); +say encode_utf8("Running up to $numjobs tests concurrently") + if $numjobs > 1 && $verbose >= 2; + +$ENV{'DUMP_LOGS'} = $dump_logs//$NO ? $YES : $NO; + +# Disable translation support in dpkg as it is a considerable +# unnecessary overhead. +$ENV{'DPKG_NLS'} = 0; + +my $helperpath = "$testset/../private"; +if (-d $helperpath) { + my $helpers = rel2abs($helperpath) + // die encode_utf8("Cannot resolve $helperpath: $!"); + $ENV{'PATH'} = "$helpers:$ENV{'PATH'}"; +} + +# get architecture +cache_dpkg_architecture_values(); +say encode_utf8("Host architecture is $ENV{'DEB_HOST_ARCH'}."); + +# get latest policy version and date +($ENV{'POLICY_VERSION'}, $ENV{'POLICY_EPOCH'}) = get_latest_policy(); +say encode_utf8("Latest policy version is $ENV{'POLICY_VERSION'} from " + . rfc822date($ENV{'POLICY_EPOCH'})); + +# get current debhelper compat level; do not name DH_COMPAT; causes conflict +$ENV{'DEFAULT_DEBHELPER_COMPAT'} = get_recommended_debhelper_version(); +say encode_utf8( +"Using compat level $ENV{'DEFAULT_DEBHELPER_COMPAT'} as a default for packages built with debhelper." +); + +# get harness date, including templates, skeletons and whitelists +my @harnessparts + = ('bin', 't/defaults', 't/templates', 't/skeletons', 't/whitelists'); +my @harnessfiles + = map { File::Find::Rule->file->in("$ENV{'LINTIAN_BASE'}/$_") }@harnessparts; +my $harness_files_epoch + = max(map { -e ? path($_)->stat->mtime : time } @harnessfiles); +$ENV{'HARNESS_EPOCH'} + = max(our_modification_epoch, perl_modification_epoch, $harness_files_epoch); +say encode_utf8('Harness modified on '. rfc822date($ENV{'HARNESS_EPOCH'})); + +say encode_utf8($EMPTY); + +# print environment +my @vars = sort keys %ENV; +say encode_utf8('Environment:') if @vars; +for my $var (@vars) { say encode_utf8($INDENT . "$var=$ENV{$var}") } + +say encode_utf8($EMPTY); + +my $status = 0; + +my $formatter = TAP::Formatter::File->new( + { + errors => 1, + jobs => $numjobs, + } +); +$formatter = TAP::Formatter::Console->new( + { + errors => 1, + jobs => $numjobs, + color => 1, + } +) if is_interactive; + +my $harness = TAP::Harness->new( + { + formatter => $formatter, + jobs => $numjobs, + lib => ["$ENV{'LINTIAN_BASE'}/lib"], + } +); + +my $aggregator = TAP::Parser::Aggregator->new; +$aggregator->start; + +my @runscripts; +my $allscripts_path = "$testset/scripts"; + +# add selected scripts +push(@runscripts, find_selected_scripts($allscripts_path, $onlyrun)); + +# always add internal harness tests +my @requiredscripts; +@requiredscripts + = sort File::Find::Rule->file()->name('*.t')->in("$allscripts_path/harness") + unless length $onlyrun; +push(@runscripts, @requiredscripts); + +# remove any duplicates +@runscripts = uniq @runscripts; + +# make all paths relative +@runscripts = map { abs2rel($_) } @runscripts; + +say encode_utf8('Running selected and required Perl test scripts.'); +say encode_utf8($EMPTY); + +# run scripts through harness +$harness->aggregate_tests($aggregator, sort @runscripts); + +if (@runscripts && !$aggregator->all_passed && !$keep_going) { + $aggregator->stop; + $formatter->summary($aggregator); + exit 1; +} + +say encode_utf8($EMPTY); + +my @testpaths = find_selected_lintian_testpaths($testset, $onlyrun); + +my $recipe_root = "$testset/recipes"; + +# find test paths +my @recipes = map { path($_)->relative($recipe_root)->stringify }@testpaths; + +# prepare output directories +say encode_utf8( + 'Preparing the sources for '. scalar @recipes. ' test packages.') + if @recipes; + +# for filled templates +my $source_root = "$outpath/package-sources"; + +# for built test packages +my $build_root = "$outpath/packages"; + +# find build specifications +my @all_recipes = map { path($_)->parent->stringify } + sort File::Find::Rule->relative->name('build-spec')->in($recipe_root); + +my @source_paths + = map { path($_)->absolute($source_root)->stringify } @all_recipes; +my @build_paths + = map { path($_)->absolute($build_root)->stringify } @all_recipes; + +# remove obsolete package sources +my @found_sources = map { path($_)->parent->absolute->stringify; } + File::Find::Rule->file->name('fill-values')->in($source_root); +my $sourcelc = List::Compare->new(\@found_sources, \@source_paths); +my @obsolete_sources = $sourcelc->get_Lonly; +path($_)->remove_tree for @obsolete_sources; + +# remove obsolete built packages +my @found_builds = map { path($_)->parent->absolute->stringify; } + File::Find::Rule->file->name('source-files.sha1sums')->in($build_root); +my $packagelc= List::Compare->new(\@found_builds, \@build_paths); +my @obsolete_builds = $packagelc->get_Lonly; +path($_)->remove_tree for @obsolete_builds; + +# remove empty directories +for my $folder (@obsolete_sources, @obsolete_builds) { + my $candidate = path($folder)->parent; + while ($candidate->exists && !$candidate->children) { + rmdir $candidate->stringify; + $candidate = $candidate->parent; + } +} + +$ENV{PERL_PATH_TINY_NO_FLOCK} =1; + +$SIG{INT} = sub { MCE::Loop->finish; die encode_utf8("Caught a sigint $!") }; +my $mce_loop = MCE::Loop->init( + max_workers => $numjobs, + chunk_size => 1, + flush_stdout => 1, + flush_stderr => 1, +); + +my %failedprep = mce_loop { + my ($mce, $chunk_ref, $chunk_id) = @_; + + prepare_build($mce, $_); +} +@recipes; + +if (%failedprep) { + say encode_utf8($EMPTY); + say encode_utf8('Failed preparation tasks:'); + for my $recipe (sort keys %failedprep) { + say encode_utf8($EMPTY); + say encode_utf8($ARROW + . $SPACE + . path("$recipe_root/$recipe")->relative->stringify + . $COLON); + print encode_utf8($failedprep{$recipe}); + } + + MCE::Loop->finish; + exit 1; + +} else { + say encode_utf8('Package sources are ready.'); +} + +say encode_utf8($EMPTY); + +my %failedbuilds = mce_loop { + my ($mce, $chunk_ref, $chunk_id) = @_; + + build_package($mce, $_, $chunk_id, scalar @recipes); +} +@recipes; + +$SIG{INT} = 'DEFAULT'; +MCE::Loop->finish; + +if (%failedbuilds) { + say encode_utf8($EMPTY); + say encode_utf8('Failed build tasks:'); + for my $recipe (sort keys %failedbuilds) { + say encode_utf8($EMPTY); + say encode_utf8($ARROW + . $SPACE + . path("$recipe_root/$recipe")->relative->stringify + . $COLON); + print encode_utf8($failedbuilds{$recipe}); + } + + exit 1; +} else { + say encode_utf8('All test packages are up to date.'); +} + +say encode_utf8($EMPTY); + +my $build_end = Time::Moment->from_string(gmtime->datetime . 'Z'); +my $build_duration = duration($processing_start->delta_seconds($build_end)); +say encode_utf8("Building the test packages took $build_duration."); + +say encode_utf8($EMPTY); + +# for built test packages +my $buildroot = "$outpath/packages"; + +# for built test packages +my $evalroot = "$outpath/eval"; + +$SIG{INT} = sub { MCE::Loop->finish; die encode_utf8("Caught a sigint $!") }; + +mce_loop { + my ($mce, $chunk_ref, $chunk_id) = @_; + + prepare_test($mce, $_); +} +sort @testpaths; + +MCE::Loop->finish; + +$SIG{INT} = 'DEFAULT'; + +# remap paths from testset to outpath to get work directories +my @workpaths + = map { rel2abs(abs2rel($_, "$testset/recipes"), "$outpath/eval") } + @testpaths; + +# if ($platforms ne 'any') { +# my @wildcards = split(/$SPACE/, $platforms); +# my @matches= map { +# decode_utf8(qx{dpkg-architecture -a $ENV{'DEB_HOST_ARCH'} -i $_; echo -n \$?}) +# } @wildcards; +# unless (any { $_ == 0 } @matches) { +# say encode_utf8('Architecture mismatch'); +# return; +# } +# } + +# make all paths relative to current directory +@workpaths = map { path($_)->relative } @workpaths; + +# add the scripts in generated tests to be run +my @workscripts; +for my $path (@workpaths) { + + my @runners = File::Find::Rule->file->name('*.t')->in($path); + + die encode_utf8("No runner in $path") + unless scalar @runners; + die encode_utf8("More than one runner in $path") + if scalar @runners > 1; + + push(@workscripts, @runners); +} + +# run scripts through harness +$harness->aggregate_tests($aggregator, sort @workscripts); + +$aggregator->stop; +$formatter->summary($aggregator); + +say encode_utf8($EMPTY); + +my $test_end = Time::Moment->from_string(gmtime->datetime . 'Z'); +my $test_duration = duration($processing_start->delta_seconds($test_end)); +say encode_utf8("The test suite ran for $test_duration."); + +$status = 1 + unless $aggregator->all_passed; + +if (is_interactive && !$unattended) { + my @failed = $aggregator->failed; + say encode_utf8( + 'Offering to re-calibrate the hints expected in tests that failed.') + if @failed; + + my $accept_all; + + for my $scriptpath (@failed) { + my $workpath = dirname($scriptpath); + + my $descpath = "$workpath/desc"; + my $testcase = read_config($descpath); + + my $relative = abs2rel($workpath, $evalroot); + my $testpath = abs2rel(rel2abs($relative, "$testset/recipes")); + + say encode_utf8($EMPTY); + say encode_utf8( + 'Failed test: ' . colored($testpath, 'bold white on_blue')); + + my $match_strategy = $testcase->unfolded_value('Match-Strategy'); + + if ($match_strategy eq 'hints') { + + my $diffpath = "$workpath/hintdiff"; + next + unless -r $diffpath; + + my $diff = path($diffpath)->slurp_utf8; + print encode_utf8($diff); + + } elsif ($match_strategy eq 'literal') { + + my $actualpath = "$workpath/literal.actual.parsed"; + next + unless -r $actualpath; + my @command + = ('diff', '-uN', "$testpath/eval/literal", $actualpath); + say encode_utf8(join($SPACE, @command)); + system(@command); + + } else { + say encode_utf8( +"Do not know how to fix tests using matching strategy $match_strategy." + ); + next; + } + + unless ($accept_all) { + + my $decision_bytes = prompt( + encode_utf8( +'>>> Fix test (y), accept all (a), do not fix (n), quit (q/default)?' + ) + ); + my $decision = decode_utf8($decision_bytes); + + last + if $decision eq 'q' || $decision eq $EMPTY; + + next + unless $decision eq 'y' || $decision eq 'a'; + + $accept_all = 1 + if $decision eq 'a'; + } + + if ($match_strategy eq 'hints') { + + # create hints if needed; helps when writing new tests + my $hintspath = "$testpath/eval/hints"; + path($hintspath)->touch + unless -e $hintspath; + + my $diffpath = "$workpath/hintdiff"; + next + unless -r $diffpath; + + my @adjustargs = ($diffpath, $hintspath); + unshift(@adjustargs, '-i') + unless $accept_all; + + die encode_utf8("Cannot run hintadjust for $testpath") + if system('hintadjust', @adjustargs); + + # also copy the new hints to workpath; no need to rebuild + die encode_utf8("Cannot copy updated hints to $workpath") + if system('cp', $hintspath, "$workpath/hints"); + + } elsif ($match_strategy eq 'literal') { + + my $actualpath = "$workpath/literal.actual.parsed"; + next + unless -r $actualpath; + + die encode_utf8( + "Cannot copy to accept literal output for $testpath") + if system('cp', $actualpath, "$testpath/eval/literal"); + + } + } + + say encode_utf8($NEWLINE . 'Accepted all remaining hint changes.') + if $accept_all; + +} else { + my @crashed = $aggregator->parse_errors; + + say encode_utf8('Showing full logs for tests with parse errors.') + if @crashed; + + for my $absolutepath (@crashed) { + + my $scriptpath = abs2rel($absolutepath); + my $workpath = dirname($scriptpath); + my $logpath = "$workpath/log"; + + next + unless -e $logpath; + + say encode_utf8($EMPTY); + say encode_utf8("Log for test $scriptpath:"); + + my $log = path($logpath)->slurp_utf8; + print encode_utf8($log); + } +} + +# give a hint if not enough tests were run +unless (scalar @runscripts - scalar @requiredscripts + scalar @workscripts + || $onlyrun eq 'minimal:') { + quick_hint($onlyrun); + exit 1; +} + +say encode_utf8($EMPTY); + +exit $status; + +# program is done + +sub prepare_build { + my ($mce, $recipe) = @_; + + # label process + $0 = "Lintian prepare test: $recipe"; + + # destination + my $source_path = "$source_root/$recipe"; + + my $error; + + # capture output + my $log_bytes =capture_merged { + + try { + + # remove destination + path($source_path)->remove_tree + if -e $source_path; + + # prepare + prepare("$recipe_root/$recipe/build-spec", + $source_path, $testset, $force_rebuild); + + } catch { + # catch any error + $error = $@; + } + }; + + my $log = decode_utf8($log_bytes); + + # save log; + my $logfile = "$source_path.log"; + path($logfile)->spew_utf8($log) if $log; + + $mce->gather($recipe, $error) + if length $error; + + return; +} + +sub build_package { + my ($mce, $recipe, $position, $total) = @_; + + # set a predictable locale + $ENV{'LC_ALL'} = 'C'; + + # many tests create files via debian/rules + umask $WIDELY_READABLE; + + # get destination + my $source_path = "$source_root/$recipe"; + my $build_path = "$build_root/$recipe"; + + my $savedir = getcwd; + chdir $source_path + or die encode_utf8("Cannot change to directory $source_path"); + + my $sha1sums_bytes; + run3('find . -type f -print0 | sort -z | xargs -0 sha1sum', + \undef, \$sha1sums_bytes); + + chdir $savedir + or die encode_utf8("Cannot change to directory $savedir"); + + my $sha1sums = decode_utf8($sha1sums_bytes); + + my $checksum_path = "$build_path/source-files.sha1sums"; + if (-r $checksum_path) { + my $previous = path($checksum_path)->slurp_utf8; + + # only rebuild if needed + # also need to look for build subject + return + if $sha1sums eq $previous; + } + + $0 = "Lintian build test: $recipe [$position/$total]"; + say encode_utf8('Building in ' + . path($build_path)->relative->stringify + . " [$position/$total]"); + + path($build_path)->remove_tree + if -e $build_path; + path($build_path)->mkpath; + + # read dynamic file names + my $runfiles = "$source_path/files"; + my $files = read_config($runfiles); + + my $error; + + my $log_bytes = capture_merged { + + try { + # call runner + build_subject($source_path, $build_path); + + } catch { + # catch any error + $error = $@; + } + }; + + my $log = decode_utf8($log_bytes); + + # delete old runner log + my $betterlogpath= $build_path . $SLASH . $files->unfolded_value('Log'); + if (-e $betterlogpath) { + unlink $betterlogpath + or die encode_utf8("Cannot unlink $betterlogpath"); + } + + # move the early log for directory preparation to position of runner log + my $earlylogpath = "$source_path.log"; + move($earlylogpath, $betterlogpath) if -e $earlylogpath; + + # append runner log to population log + path($betterlogpath)->append_utf8($log) if length $log; + + # add error if there was one + path($betterlogpath)->append_utf8($error) if length $error; + + path($checksum_path)->spew_utf8($sha1sums) + unless length $error; + + $mce->gather(path($build_path)->relative->stringify, $error . $log) + if length $error; + + return; +} + +sub prepare_test { + my ($mce, $specpath) = @_; + + # label process + $0 = "Lintian prepare test: $specpath"; + + # calculate destination + my $relative = path($specpath)->relative("$testset/recipes"); + my $buildpath = $relative->absolute($buildroot)->stringify; + my $evalpath = $relative->absolute($evalroot)->relative->stringify; + + my $error; + + # capture output + my $log_bytes = capture_merged { + + try { + + # remove destination + path($evalpath)->remove_tree + if -e $evalpath; + + path($evalpath)->mkpath; + + # prepare + filleval("$specpath/eval", $evalpath, $testset); + + my $traversal = Cwd::realpath("$buildpath/subject"); + + if (length $traversal) { + die encode_utf8("Cannot link to subject in $buildpath") + if system("cd $evalpath; ln -s $traversal subject"); + } + + }catch { + # catch any error + $error = $@; + } + }; + + my $log = decode_utf8($log_bytes); + + # save log; + my $logfile = "$evalpath/log"; + path($logfile)->spew_utf8($log) if $log; + + # print something if there was an error + die encode_utf8( + ($log // $EMPTY) . "Preparation failed for $specpath: $error") + if $error; + + return $specpath; +} + +=item default_parallel + +=cut + +# Return the default number of parallelization to be used +sub default_parallel { + # check cpuinfo for the number of cores... + my $cpus = decode_utf8(safe_qx('nproc')); + if ($cpus =~ m/^\d+$/) { + # Running up to twice the number of cores usually gets the most out + # of the CPUs and disks but it might be too aggressive to be the + # default for -j. Only use <cores>+1 then. + return $cpus + 1; + } + + # No decent number of jobs? Just use 2 as a default + return 2; +} + +sub usage { + my $message =<<"END"; +Usage: $0 [options] [-j [<jobs>]] <testset-directory> + + --onlyrun Select only some tests for a quick check + --coverage Run Lintian under Devel::Cover (Warning: painfully slow) + -d Display additional debugging information + --dump-logs Print build log to STDOUT, if a build fails. + -j [<jobs>] Run up to <jobs> jobs in parallel. + If -j is passed without specifying <jobs>, the number + of jobs started is <nproc>+1. + -k Do not stop after one failed test + -v Be more verbose + --help, -h Print this help and exit + + The option --onlyrun causes runtests to only run tests that match + the particular selection. This parameter can be a list of selectors: + what:<which>[,<what:...>] + + * test:<testname> + - Run the named test. Please note that testnames may not be + unique, so it may run more than one test. + * script:(<script-name> || <dir-in-scripts-suite>) + - Run the named code quality script or all in the named directory. + E.g. "01-critic" will run all tests in "t/scripts/01-critic/". + * check:<check-name> + - Run all tests related to the given check. + * suite:<suite> + - Run all tests in the named suite. + * tag:<tag-name> + - Run any test that lists <tag-name> in "Test-For" or + "Test-Against". + +Test artifacts are cached in --work-dir [default: debian/test-out] and +will generally be reused to save time. To recreate the test packages, +run 'private/build-test-packages'. +END + + print encode_utf8($message); + + return; +} + +sub quick_hint { + my ($selection) = @_; + + my $message =<<"END"; + +No tests were selected by your filter: + + $selection + +To select your tests, please use an appropriate argument with a +selector like: + + 'suite:', 'test:', 'check:', 'tag:', or 'script:' + +You can also use 'minimal:', which runs only the tests that cannot +be turned off, such as the internal tests for the harness. +END + + print encode_utf8($message); + + return; +} + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et diff --git a/private/tag-stats b/private/tag-stats new file mode 100755 index 0000000..9aa6696 --- /dev/null +++ b/private/tag-stats @@ -0,0 +1,109 @@ +#!/usr/bin/perl + +# tag-stats - tag classification statistics +# +# This script displays statistics and data for tag classification based on +# Severity fields and their mapping to a E/W/I code. +# +# The verbose options (-v, -vv, -vvv) can be used to display a detailed list +# of which tags are assigned to each category. + +use v5.20; +use warnings; +use utf8; +use autodie qw(opendir closedir); + +use Const::Fast; +use Cwd qw(realpath); +use File::Basename qw(dirname); +use Unicode::UTF8 qw(encode_utf8); + +# neither Path::This nor lib::relative are in Debian +use constant THISFILE => realpath __FILE__; +use constant THISDIR => dirname realpath __FILE__; + +# use Lintian modules that belong to this program +use lib THISDIR . '/../lib'; + +use Lintian::Profile; +use Lintian::Tag; + +const my $SPACE => q{ }; +const my $INDENT => $SPACE x 4; +const my $EXTRA_VERBOSE => 3; + +$ENV{LINTIAN_BASE} = realpath(THISDIR . '/..') + // die encode_utf8('Cannot resolve LINTIAN_BASE'); + +my @severities = reverse qw(pedantic info warning error); +my @types = qw(E W I P); + +my %stats; +my $num_tags = 0; +my $num_ok = 0; +my $percent = 0; + +my $verbose = $ARGV[0] ? ($ARGV[0] =~ s/v/v/g) : 0; + +my $profile = Lintian::Profile->new; +$profile->load; + +for my $tag_name ($profile->known_tags) { + + my $tag = $profile->get_tag($tag_name); + + my $name = $tag->name; + my $severity = $tag->visibility; + my $code = $tag->code; + + $severity = 'unclassified' + unless length $severity; + + push(@{$stats{severity}{$severity}}, $name); + push(@{$stats{type}{severity}{$code}{$severity}}, $name); + + $num_tags++; +} + +print encode_utf8("Severity\n"); + +foreach my $s (@severities) { + my $tags = $stats{severity}{$s} // []; + print encode_utf8(" $s: " . @{$tags} . "\n"); + print encode_utf8($INDENT . join("\n ", sort @{$tags}) . "\n") + if $verbose >= $EXTRA_VERBOSE; +} + +foreach my $t (@types) { + print encode_utf8("\nType $t Severity\n"); + foreach my $s (@severities) { + if (my $tags = $stats{type}{severity}{$t}{$s}) { + print encode_utf8(" $s: " . @{$tags} . "\n"); + print encode_utf8($INDENT . join("\n ", sort @{$tags}) . "\n") + if $verbose >= 2; + } + } +} + +print encode_utf8("\nCollections\n"); +foreach my $s (@severities) { + if (my $needs = $stats{needs}{$s}) { + my $size = scalar keys %{$needs}; + my @list = sort keys %{$needs}; + print encode_utf8(" $s: $size\n"); + print encode_utf8($INDENT . join("\n ", @list) . "\n") + if $verbose >= 2; + } +} + +if ($verbose >= 1 and exists $stats{severity}{unclassified}) { + print encode_utf8("\nUnclassified tags\n"); + print encode_utf8( + $SPACE x 2 . join("\n ", @{$stats{severity}{unclassified}}) . "\n"); +} + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et |