diff options
Diffstat (limited to 'bin/lintian')
| -rwxr-xr-x | bin/lintian | 1055 |
1 files changed, 1055 insertions, 0 deletions
diff --git a/bin/lintian b/bin/lintian new file mode 100755 index 0000000..4f44e6f --- /dev/null +++ b/bin/lintian @@ -0,0 +1,1055 @@ +#!/usr/bin/perl +# +# Lintian -- Debian package checker +# +# Copyright (C) 1998 Christian Schwarz and Richard Braakman +# Copyright (C) 2013 Niels Thykier +# Copyright (C) 2017-2019 Chris Lamb <lamby@debian.org> +# Copyright (C) 2020 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'; + +# substituted during package build +my $LINTIAN_VERSION; + +use Carp qw(croak confess verbose); +use Config::Tiny; +use Const::Fast; +use File::BaseDir qw(config_files); +use Getopt::Long (); +use IO::Interactive qw(is_interactive); +use List::Compare; +use List::SomeUtils qw(any none first_value); +use Path::Tiny; +use POSIX qw(:sys_wait_h); +use Syntax::Keyword::Try; +use Term::ReadKey; +use Unicode::UTF8 qw(encode_utf8 decode_utf8); + +use Lintian::Changelog; +use Lintian::IPC::Run3 qw(safe_qx); +use Lintian::Pool; +use Lintian::Processable::Installable; +use Lintian::Processable::Buildinfo; +use Lintian::Processable::Changes; +use Lintian::Processable::Source; +use Lintian::Profile; +use Lintian::Version qw(guess_version); + +const my $EMPTY => q{}; +const my $SPACE => q{ }; +const my $NEWLINE => qq{\n}; +const my $COMMA => q{,}; +const my $SLASH => q{/}; +const my $DOT => q{.}; +const my $DOUBLE_DOT => q{..}; +const my $PLUS => q{+}; +const my $EQUAL => q{=}; +const my $HYPHEN => q{-}; +const my $OPEN_PIPE => q{-|}; + +const my $DEFAULT_TAG_LIMIT => 4; +const my $DEFAULT_OUTPUT_WIDTH => 80; + +# place early, may need original environment to determine terminal blacklist +my $hyperlinks_capable = is_interactive; + +# Globally ignore SIGPIPE. We'd rather deal with error returns from write +# than randomly delivered signals. +$SIG{PIPE} = 'IGNORE'; + +my $TERMINAL_WIDTH; +($TERMINAL_WIDTH, undef, undef, undef) = GetTerminalSize() + if is_interactive; +$TERMINAL_WIDTH //= $DEFAULT_OUTPUT_WIDTH; + +my %PRESERVE_ENV = map { $_ => 1 } qw( + DEB_VENDOR + DEBRELEASE_DEBS_DIR + HOME + NO_COLOR + LANG + LC_ALL + LC_MESSAGES + PATH + TMPDIR + XDG_CACHE_HOME + XDG_CONFIG_DIRS + XDG_CONFIG_HOME + XDG_DATA_DIRS + XDG_DATA_HOME +); + +my @disallowed= grep { !exists $PRESERVE_ENV{$_} && !/^LINTIAN_/ } keys %ENV; + +delete $ENV{$_} for @disallowed; + +# PATH may be unset in some environments; use sane default +$ENV{PATH} //= '/bin:/usr/bin'; + +# needed for tar +$ENV{LC_ALL} = 'C'; +$ENV{TZ} = $EMPTY; + +$ENV{LINTIAN_BASE} = realpath(THISDIR . '/..') + // die encode_utf8('Cannot resolve LINTIAN_BASE'); + +$ENV{LINTIAN_VERSION} = $LINTIAN_VERSION // guess_version($ENV{LINTIAN_BASE}); +die encode_utf8('Unable to determine the version automatically!?') + unless length $ENV{LINTIAN_VERSION}; + +if (my $coverage_arg = $ENV{LINTIAN_COVERAGE}) { + my $p5opt = $ENV{PERL5OPT} // $EMPTY; + $p5opt .= $SPACE unless $p5opt eq $EMPTY; + $ENV{PERL5OPT} = "${p5opt} ${coverage_arg}"; +} + +my @getoptions = qw( + allow-root! + cfg=s + check|c + check-part|C=s@ + color=s + debug|d+ + default-display-level + display-experimental|E! + display-level|L=s@ + display-info|I + display-source=s@ + dont-check-part|X=s@ + exp-output:s + fail-on=s@ + ftp-master-rejects|F + help|h + hide-overrides + hyperlinks=s + ignore-lintian-env + include-dir=s@ + info|i! + jobs|j=i + no-cfg + no-override|o + no-tag-display-limit + output-width=i + packages-from-file=s + pedantic + perf-debug + print-version + profile=s + quiet|q + show-overrides! + status-log=s + suppress-tags=s@ + suppress-tags-from-file=s + tag-display-limit=i + tags|T=s@ + tags-from-file=s + user-dirs! + verbose|v + version|V +); + +my %command_line; + +Getopt::Long::Configure('default', 'bundling', + 'no_getopt_compat','no_auto_abbrev','permute'); + +Getopt::Long::GetOptions(\%command_line, @getoptions) + or die encode_utf8("error parsing options\n"); + +my @basenames = map { path($_)->basename } @ARGV; +$0 = join($SPACE, THISFILE, @basenames); + +if (exists $command_line{'version'}) { + say encode_utf8("Lintian v$ENV{LINTIAN_VERSION}"); + exit; +} + +if (exists $command_line{'print-version'}) { + say encode_utf8($ENV{LINTIAN_VERSION}); + exit; +} + +show_help() + if exists $command_line{help}; + +if (exists $command_line{'hide-overrides'}) { + $command_line{'show-overrides'} = 0; + warn encode_utf8( +"A future release will drop --hide-overrides; please use --no-show-overrides instead.\n" + ); +} + +if (exists $command_line{'no-tag-display-limit'}) { + $command_line{'tag-display-limit'} = 0; + warn encode_utf8( +"A future release will drop --no-tag-display-limit; please use '--tag-display-limit 0' instead.\n" + ); +} + +my $LINTIAN_CFG = $command_line{cfg}; + +$LINTIAN_CFG ||= $ENV{LINTIAN_CFG} + if length $ENV{LINTIAN_CFG} && -e $ENV{LINTIAN_CFG}; + +unless ($command_line{'no-user-dirs'}) { + + my @user_configs; + + # XDG user config + push(@user_configs, config_files('lintian/lintianrc')); + + # legacy per-user config + push(@user_configs, "$ENV{HOME}/.lintianrc") + if length $ENV{HOME}; + + # system wide user config + push(@user_configs, '/etc/lintianrc'); + + $LINTIAN_CFG ||= first_value { length && -e } @user_configs; +} + +$LINTIAN_CFG = $EMPTY + if $command_line{'no-cfg'}; + +my %config; + +# some environment variables can be set from the config file +my @ENV_FROM_CONFIG = qw( + TMPDIR +); + +if (length $LINTIAN_CFG) { + + # for keys appearing multiple times, now uses the last value + my $object = Config::Tiny->read($LINTIAN_CFG, 'utf8'); + my $error = Config::Tiny->errstr; + die encode_utf8( + "syntax error in configuration file $LINTIAN_CFG: $error\n") + if length $error; + + # used elsewhere to check for values already set + %config = %{$object->{_} // {}}; + + my @allowed = qw( + color + display-experimental + display-info + display-level + hyperlinks + info + jobs + LINTIAN_PROFILE + override + pedantic + profile + quiet + show-overrides + suppress-tags + suppress-tags-from-file + tag-display-limit + TMPDIR + verbose + ); + + my $knownlc + = List::Compare->new([keys %config], [@allowed, @ENV_FROM_CONFIG]); + my @unknown = $knownlc->get_Lonly; + die encode_utf8( + "Unknown setting in $LINTIAN_CFG: ". join($SPACE, @unknown). $NEWLINE) + if @unknown; +} + +# substitute home directory +s{\$HOME/}{$ENV{HOME}/}g for values %config; +s{\~/}{$ENV{HOME}/}g for values %config; + +# option inverted in config file +$config{'no-override'} = !$config{'no-override'} + if exists $config{'no-override'}; + +my @GETOPT_ARRAYS = qw( + display-level + suppress-tags +); + +# convert some strings to array references +for my $name (@GETOPT_ARRAYS) { + if (exists $config{$name}) { + $config{$name} = [$config{$name}]; + } else { + $config{$name} = []; + } +} + +# Translate boolean strings to "0" or "1"; ignore +# errors as not all values are (intended to be) +# booleans. +my $booleanlc + = List::Compare->new([keys %config], [qw(jobs tag-display-limit)]); +eval { $config{$_} = parse_boolean($config{$_}); }for $booleanlc->get_Lonly; + +# our defaults +my %selected = ( + 'check-part' => [], + 'color' => 'auto', + 'debug' => 0, + 'display-level' => [], + 'display-source' => [], + 'dont-check-part' => [], + 'fail-on' => [qw(error)], + 'include-dir' => [], + 'jobs' => default_jobs(), + 'output-width' => $TERMINAL_WIDTH, + 'tags' => [], + 'suppress-tags' => [], + 'user-dirs' => 1, + 'verbose' => 0, +); + +$selected{$_} = $config{$_} for keys %config; + +my @MUTUAL_OPTIONS = ( + [qw(verbose quiet)], + [qw(default-display-level display-level display-info pedantic)], +); + +# for precedence of command line +for my $exclusive (@MUTUAL_OPTIONS) { + + if (any { defined $command_line{$_} } @{$exclusive}) { + my @scalars = grep { ref $selected{$_} eq 'SCALAR' } @{$exclusive}; + delete $selected{$_} for @scalars; + + my @arrays = grep { ref $selected{$_} eq 'ARRAY' } @{$exclusive}; + $selected{$_} = [] for @arrays; + } +} + +$selected{$_} = $command_line{$_} for keys %command_line; + +@{$selected{'display-level'}} + = split(/\s*,\s*/, join($COMMA, @{$selected{'display-level'}})); + +my @display_level; + +push(@display_level,[$EQUAL, '>=', 'warning']) + if $selected{'default-display-level'}; + +push(@display_level, [$PLUS, '>=', 'info']) + if $selected{'display-info'}; + +push(@display_level, [$PLUS, $EQUAL, 'pedantic']) + if $selected{'pedantic'}; + +sub display_classificationtags { + push(@display_level, [$PLUS, $EQUAL, 'classification']); + return; +} + +for my $level (@{$selected{'display-level'}}) { + + my $operator; + if ($level =~ s/^([+=-])//) { + $operator = $1; + } + + my $relation; + if ($level =~ s/^([<>]=?|=)//) { + $relation = $1; + } + + my $severity = $level; + $operator //= $EQUAL; + $relation //= $EQUAL; + + push(@display_level, [$operator, $relation, $severity]); +} + +@{$selected{'display-source'}} + = split(/\s*,\s*/, join($COMMA, @{$selected{'display-source'}})); + +@{$selected{'check-part'}} + = split(/\s*,\s*/, join($COMMA, @{$selected{'check-part'}})); +@{$selected{'dont-check-part'}} + = split(/\s*,\s*/, join($COMMA, @{$selected{'dont-check-part'}})); + +@{$selected{tags}} = split(/\s*,\s*/, join($COMMA, @{$selected{tags}})); +@{$selected{'suppress-tags'}} + = split(/\s*,\s*/, join($COMMA, @{$selected{'suppress-tags'}})); + +if (length $selected{'tags-from-file'}) { + + my @lines = path($selected{'tags-from-file'})->lines_utf8; + for my $line (@lines) { + + # trim both ends + $line =~ s/^\s+|\s+$//g; + + next + unless length $line; + next + if $line =~ /^\#/; + + my @activate = split(/\s*,\s*/, $line); + push(@{$selected{tags}}, @activate); + } +} + +if (length $selected{'suppress-tags-from-file'}) { + + my @lines = path($selected{'suppress-tags-from-file'})->lines_utf8; + for my $line (@lines) { + + # trim both ends + $line =~ s/^\s+|\s+$//g; + + next + unless length $line; + next + if $line =~ /^\#/; + + my @suppress = split(/\s*,\s*/, $line); + push(@{$selected{'suppress-tags'}}, @suppress); + } +} + +my $exit_code = 0; + +# root permissions? +# check if effective UID is 0 +warn encode_utf8("running with root privileges is not recommended!\n") + if $> == 0 && !$selected{'allow-root'}; + +if ($selected{'ignore-lintian-env'}) { + delete($ENV{$_}) for grep { m/^LINTIAN_/ } keys %ENV; +} + +# option --all and packages specified at the same time? +if ($selected{'packages-from-file'} && $#ARGV+1 > 0) { + warn encode_utf8( +"option --packages-from-file cannot be mixed with package parameters!\n" + ); + warn encode_utf8("(will ignore --packages-from-file option)\n"); + + delete($selected{'packages-from-file'}); +} + +@{$selected{'fail-on'}} = split(/,/, join($COMMA, @{$selected{'fail-on'}})); +my @known_fail_on = qw( + error + warning + info + pedantic + experimental + override + none +); +my $fail_on_lc = List::Compare->new($selected{'fail-on'}, \@known_fail_on); +my @unknown_fail_on = $fail_on_lc->get_Lonly; +die encode_utf8("Unrecognized fail-on argument: @unknown_fail_on\n") + if @unknown_fail_on; + +if (any { $_ eq 'none' } @{$selected{'fail-on'}}) { + + die encode_utf8( +"Cannot combine 'none' with other conditions: @{$selected{'fail-on'}}\n" + )if @{$selected{'fail-on'}} > 1; + + $selected{'fail-on'} = []; +} + +# environment variables override settings in conf file, so load them now +# assuming they were not set by cmd-line options +for my $var (@ENV_FROM_CONFIG) { +# note $selected{$var} will usually always exists due to the call to GetOptions +# so we have to use "defined" here + $selected{$var} = $ENV{$var} if $ENV{$var} && !defined $selected{$var}; +} + +my %output + = map { split(/=/) } split(/,/, ($selected{'exp-output'} // $EMPTY)); +$selected{'output-format'} = lc($output{format} // 'ewi'); + +my $PROFILE = Lintian::Profile->new; + +# dies on error +$PROFILE->load( + $selected{profile}, + $selected{'include-dir'}, + !$command_line{'no-user-dirs'} +); +say {*STDERR} encode_utf8('Using profile ' . $PROFILE->name . $DOT) + if $selected{debug}; + +if ($selected{'ftp-master-rejects'}) { + say {*STDERR} + encode_utf8( + 'But only with tags enabled from the FTP Master Auto-Reject list.') + if $selected{debug}; + + my $rejection = $PROFILE->data->auto_rejection; + + my @certain = @{$rejection->certain}; + my @preventable = @{$rejection->preventable}; + + # disable all tags + $PROFILE->disable_tag($_) for $PROFILE->known_tags; + + # enable the ones they want + $PROFILE->enable_tag($_) for (@certain, @preventable); + + # no overrides allowed + $PROFILE->set_durable($_, 1) for @certain; + + # overrides okay + $PROFILE->set_durable($_, 0) for @preventable; +} + +my $envlc = List::Compare->new([keys %config], \@ENV_FROM_CONFIG); +my @from_file = $envlc->get_intersection; + +my @already = grep { defined $ENV{$_} } @from_file; +warn encode_utf8( + 'The environment overrides these settings in the configuration file: ' + . join($SPACE, @already) + . $NEWLINE) + if @already; + +my @not_yet = grep { !defined $ENV{$_} } @from_file; +if (@not_yet) { + say {*STDERR} + encode_utf8('Setting environment variables from configuration file: ' + . join($SPACE, @not_yet)) + if $selected{debug}; +} +$ENV{$_} = $config{$_} for @not_yet; + +die encode_utf8("The color value must be one of auto, always, or never.\n") + unless (any { $selected{color} eq $_ } qw(auto always never)); + +$selected{hyperlinks} //= 'off' + if $selected{color} eq 'never'; + +# change to 'on' after gcc's terminal blacklist was implemented here +$selected{hyperlinks} //= 'on'; + +die encode_utf8("The hyperlink value must be on or off\n") + unless any { $selected{hyperlinks} eq $_ } qw(on off); + +$selected{hyperlinks} = $hyperlinks_capable && $selected{hyperlinks} eq 'on'; + +if ($selected{color} eq 'always') { + $selected{color} = 1; +} elsif (exists $ENV{NO_COLOR}) { + $selected{color} = 0; +} elsif ($selected{color} eq 'auto' && is_interactive) { + $selected{color} = 1; +} else { + $selected{color} = 0; +} + +$selected{verbose} = 0 + if $selected{quiet}; + +if ($selected{verbose} || !is_interactive) { + $selected{'tag-display-limit'} //= 0; +} else { + $selected{'tag-display-limit'} //= $DEFAULT_TAG_LIMIT; +} + +if ($selected{debug}) { + $selected{verbose} = 1; + $ENV{LINTIAN_DEBUG} = $selected{debug}; + $SIG{__DIE__} = sub { + confess(map { encode_utf8($_) } @_); + }; +} + +# check for arguments +unless (@ARGV || $selected{'packages-from-file'}) { + + my $ok = 0; + # If debian/changelog exists, assume an implied + # "../<source>_<version>_<arch>.changes" (or + # "../<source>_<version>_source.changes"). + if (-e 'debian/changelog') { + my $file = _find_changes(); + push @ARGV, $file; + $ok = 1; + } + + show_help() + unless $ok; +} + +if ($selected{debug}) { + say {*STDERR} encode_utf8("Lintian v$ENV{LINTIAN_VERSION}"); + say {*STDERR} encode_utf8("Lintian root directory: $ENV{LINTIAN_BASE}"); + say {*STDERR} encode_utf8('Configuration file: '.($LINTIAN_CFG//'(none)')); +} + +if (defined $selected{LINTIAN_PROFILE}) { + warn encode_utf8( + "Please use 'profile' in config file; LINTIAN_PROFILE is obsolete.\n"); + $selected{profile} //= $selected{LINTIAN_PROFILE}; + delete $selected{LINTIAN_PROFILE}; +} + +# if tags are listed explicitly (--tags) then show them even if +# they are pedantic/experimental etc. However, for --check-part +# people explicitly have to pass the relevant options. + +if (@{$selected{'check-part'}} || @{$selected{tags}}) { + + $PROFILE->disable_tag($_) for $PROFILE->enabled_tags; + + if (@{$selected{tags}}) { + $selected{'display-experimental'} = 1; + + # discard current display level; get everything + @display_level + = ([$PLUS, '>=', 'pedantic'], [$PLUS, $EQUAL, 'classification']); + + $PROFILE->enable_tag($_) for @{$selected{tags}}; + + } else { + for my $check_name (@{$selected{'check-part'}}) { + if ($check_name eq 'all') { + my @tags = map { @{$PROFILE->tag_names_for_check->{$_} // []} } + $PROFILE->known_checks; + $PROFILE->enable_tag($_) for @tags; + next; + } + + die encode_utf8("Unrecognized check (via -C): $check_name\n") + unless exists $PROFILE->check_module_by_name->{$check_name}; + + $PROFILE->enable_tag($_) + for @{$PROFILE->tag_names_for_check->{$check_name} // []}; + } + } + +} elsif (@{$selected{'dont-check-part'}}) { + # we are disabling checks + for my $check_name (@{$selected{'dont-check-part'}}) { + + die encode_utf8("Unrecognized check (via -X): $check_name\n") + unless exists $PROFILE->check_module_by_name->{$check_name}; + + $PROFILE->disable_tag($_) + for @{$PROFILE->tag_names_for_check->{$check_name} // []}; + } +} + +# ignore --suppress-tags when used with --tags. +if (@{$selected{'suppress-tags'}} && !@{$selected{tags}}) { + $PROFILE->disable_tag($_) for @{$selected{'suppress-tags'}}; +} + +# initialize display level settings; dies on error +$PROFILE->display(@{$_}) for @display_level; + +my @subjects; +push(@subjects, @ARGV); + +if ($selected{'packages-from-file'}){ + my $fd = open_file_or_fd($selected{'packages-from-file'}, '<'); + + while (my $bytes = <$fd>) { + my $line = decode_utf8($bytes); + chomp $line; + + next + if $line =~ /^\s*$/; + + push(@subjects, $line); + } + + # close unless it is STDIN (else we will see a lot of warnings + # about STDIN being reopened as "output only") + close($fd) + unless fileno($fd) == fileno(STDIN); +} + +my $pool = Lintian::Pool->new; + +for my $subject (@subjects) { + die encode_utf8("$subject is not a readable file\n") unless -r $subject; + + # in ubuntu, automatic dbgsym packages end with .ddeb + die encode_utf8( +"bad package file name $subject (neither .deb, .udeb, .ddeb, .changes, .dsc or .buildinfo file)\n" + ) unless $subject =~ /\.(?:[u|d]?deb|dsc|changes|buildinfo)$/; + + try { + # create a new group + my $group = Lintian::Group->new; + $group->pooldir($pool->basedir); + $group->profile($PROFILE); + + my $processable = create_processable_from_file($subject); + $group->add_processable($processable); + + my $parent = path($subject)->parent->stringify; + + my @files; + + # pull in any additional files + @files = keys %{$processable->files} + if $processable->can('files'); + + for my $basename (@files) { + + # ignore traversal attempts + next + if $basename =~ m{/}; + + die encode_utf8("$parent/$basename does not exist, exiting\n") + unless -e "$parent/$basename"; + + # only care about some files; ddeb is ubuntu dbgsym + next + unless $basename =~ /\.[ud]?deb$/ + || $basename =~ /\.dsc$/ + || $basename =~ /\.buildinfo$/; + + my $additional = create_processable_from_file("$parent/$basename"); + $group->add_processable($additional); + } + + $pool->add_group($group); + + } catch { + warn encode_utf8("Skipping $subject: $@\n"); + $exit_code = 1; + } +} + +$pool->process($PROFILE, \$exit_code, \%selected); + +exit $exit_code; + +=item create_processable_from_file + +=cut + +sub create_processable_from_file { + my ($path) = @_; + + croak encode_utf8("Cannot resolve $path: $!") + unless -e $path; + + my $processable; + + if ($path =~ /\.dsc$/) { + $processable = Lintian::Processable::Source->new; + + } elsif ($path =~ /\.buildinfo$/) { + $processable = Lintian::Processable::Buildinfo->new; + + } elsif ($path =~ /\.d?deb$/) { + # in ubuntu, automatic dbgsym packages end with .ddeb + $processable = Lintian::Processable::Installable->new; + $processable->type('binary'); + + } elsif ($path =~ /\.udeb$/) { + $processable = Lintian::Processable::Installable->new; + $processable->type('udeb'); + + } elsif ($path =~ /\.changes$/) { + $processable = Lintian::Processable::Changes->new; + + } else { + croak encode_utf8("$path is not a known type of package"); + } + + $processable->init_from_file($path); + + return $processable; +} + +=item parse_boolean (STR) + +Attempt to parse STR as a boolean and return its value. +If STR is not a valid/recognised boolean, the sub will +invoke croak. + +The following values recognised (string checks are not +case sensitive): + +=over 4 + +=item The integer 0 is considered false + +=item Any non-zero integer is considered true + +=item "true", "y" and "yes" are considered true + +=item "false", "n" and "no" are considered false + +=back + +=cut + +sub parse_boolean { + my ($str) = @_; + + return $str == 0 ? 0 : 1 + if $str =~ /^-?\d++$/; + + $str = lc $str; + + return 1 + if $str eq 'true' || $str =~ m/^y(?:es)?$/; + + return 0 + if $str eq 'false' || $str =~ m/^no?$/; + + croak encode_utf8("'$str' is not a valid boolean value"); +} + +sub _find_changes { + # read bytes to side-step any encoding errors + my $contents = path('debian/changelog')->slurp; + my $changelog = Lintian::Changelog->new; + $changelog->parse($contents); + my @entries = @{$changelog->entries}; + my $latest = @entries ? $entries[0] : undef; + my ($source, $version); + my $changes; + my @archs; + my @dirs = ($DOUBLE_DOT, '../build-area', '/var/cache/pbuilder/result'); + + unshift(@dirs, $ENV{DEBRELEASE_DEBS_DIR}) + if exists $ENV{DEBRELEASE_DEBS_DIR}; + + if (not $latest) { + my @errors = @{$changelog->errors}; + if (@errors) { + warn encode_utf8("Cannot parse debian/changelog due to errors:\n"); + for my $error (@errors) { + warn encode_utf8("$error->[2] (line $error->[1])\n"); + } + } else { + warn encode_utf8("debian/changelog does not have any data?\n"); + } + exit 1; + } + $version = $latest->Version; + $source = $latest->Source; + unless (defined $version && defined $source) { + $version //= '<N/A>'; + $source //= '<N/A>'; + warn encode_utf8( + "Cannot determine source and version from debian/changelog:\n"); + warn encode_utf8("Source: $source\n"); + warn encode_utf8("Version: $source\n"); + exit 1; + } + # remove the epoch + $version =~ s/^\d+://; + if (exists $ENV{DEB_BUILD_ARCH}) { + push(@archs, decode_utf8($ENV{DEB_BUILD_ARCH})); + } else { + my $arch = decode_utf8(safe_qx('dpkg', '--print-architecture')); + chomp $arch; + push(@archs, $arch) if length $arch; + } + push(@archs, decode_utf8($ENV{DEB_HOST_ARCH})) + if exists $ENV{DEB_HOST_ARCH}; + # Maybe cross-built for something dpkg knows about... + my @command = qw{dpkg --print-foreign-architectures}; + open(my $foreign, $OPEN_PIPE, @command) + or die encode_utf8("Cannot open pipe to @command"); + + while (my $bytes = <$foreign>) { + my $line = decode_utf8($bytes); + chomp($line); + # Skip already attempted architectures (e.g. via DEB_BUILD_ARCH) + next + if any { $_ eq $line } @archs; + push(@archs, $line); + } + close($foreign); + push @archs, qw(multi all source); + for my $dir (@dirs) { + for my $arch (@archs) { + $changes = "$dir/${source}_${version}_${arch}.changes"; + return $changes if -e $changes; + } + } + + warn encode_utf8( +"Cannot find a changes file for ${source}/${version}. It would be named like:\n" + ); + + warn encode_utf8(" ${source}_${version}_${_}.changes\n") for @archs; + + warn encode_utf8(" in any of those places:\n"); + warn encode_utf8(" $_\n") for @dirs; + + exit 0; +} + +=item open_file_or_fd + +=cut + +# open_file_or_fd(TO_OPEN, MODE) +# +# Open a given file or FD based on TO_OPEN and MODE and returns the +# open handle. Will croak / throw a trappable error on failure. +# +# MODE can be one of "<" (read) or ">" (write). +# +# TO_OPEN is one of: +# * "-", alias of "&0" or "&1" depending on MODE +# * "&N", reads/writes to the file descriptor numbered N +# based on MODE. +# * "+FILE" (MODE eq '>' only), open FILE in append mode +# * "FILE", open FILE in read or write depending on MODE. +# Note that this will truncate the file if MODE +# is ">". +sub open_file_or_fd { + my ($to_open, $mode) = @_; + + my $fd; + # autodie trips this for some reasons (possibly fixed + # in v2.26) + no autodie qw(open); + if ($mode eq '<') { + if ($to_open eq $HYPHEN || $to_open eq '&0') { + $fd = \*STDIN; + } elsif ($to_open =~ m/^\&\d+$/) { + open($fd, '<&=', substr($to_open, 1)) + or die encode_utf8("fdopen $to_open for reading: $!\n"); + } else { + open($fd, '<', $to_open) + or die encode_utf8("open $to_open for reading: $!\n"); + } + + } elsif ($mode eq '>') { + if ($to_open eq $HYPHEN || $to_open eq '&1') { + $fd = \*STDOUT; + } elsif ($to_open =~ m/^\&\d+$/) { + open($fd, '>&=', substr($to_open, 1)) + or die encode_utf8("fdopen $to_open for writing: $!\n"); + } else { + $mode = ">$mode" if $to_open =~ s/^\+//; + open($fd, $mode, $to_open) + or + die encode_utf8("open $to_open for write/append ($mode): $!\n"); + } + + } else { + croak encode_utf8("Invalid mode '$mode' for open_file_or_fd"); + } + + return $fd; +} + +=item default_jobs + +=cut + +sub default_jobs { + + my $cpus = decode_utf8(safe_qx('nproc')); + + return 2 + unless $cpus =~ m/^\d+$/; + + # could be 2x + return $cpus + 1; +} + +sub show_help { + + say encode_utf8("Lintian v$ENV{LINTIAN_VERSION}"); + + my $message =<<"EOT"; +Syntax: lintian [action] [options] [--] [packages] ... +Actions: + -c, --check check packages (default action) + -C X, --check-part X check only certain aspects + -F, --ftp-master-rejects only check for automatic reject tags + -T X, --tags X only run checks needed for requested tags + --tags-from-file X like --tags, but read list from file + -X X, --dont-check-part X don't check certain aspects +General options: + -h, --help display this help text + --print-version print unadorned version number and exit + -q, --quiet suppress all informational messages + -v, --verbose verbose messages + -V, --version display Lintian version and exit +Behavior options: + --color never/always/auto disable, enable, or enable color for TTY + --hyperlinks on/off hyperlinks for TTY (when supported) + --default-display-level reset the display level to the default + --display-source X restrict displayed tags by source + -E, --display-experimental display "X:" tags (normally suppressed) + --no-display-experimental suppress "X:" tags + --fail-on error,warning,info,pedantic,experimental,override + define condition for exit status 2 (default: error) + -i, --info give detailed info about tags + -I, --display-info display "I:" tags (normally suppressed) + -L, --display-level display tags with the specified level + -o, --no-override ignore overrides + --output-width NUM set output width instead of probing terminal + --pedantic display "P:" tags (normally suppressed) + --profile X Use the profile X or use vendor X checks + --show-overrides output tags that have been overridden + --suppress-tags T,... don't show the specified tags + --suppress-tags-from-file X don't show the tags listed in file X + --tag-display-limit NUM Specify "tag per package" display limit + +Configuration options: + --cfg CONFIGFILE read CONFIGFILE for configuration + --no-cfg do not read any config files + --ignore-lintian-env ignore LINTIAN_* env variables + --include-dir DIR include checks, libraries (etc.) from DIR + -j NUM, --jobs NUM limit the number of parallel jobs to NUM + --[no-]user-dirs whether to use files from user directories + +Some options were omitted. Please check the manual page for the complete list. +EOT + + print encode_utf8($message); + + exit; +} + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et |