mirror of https://gitee.com/openkylin/lintian.git
370 lines
8.9 KiB
Perl
370 lines
8.9 KiB
Perl
# -*- perl -*-
|
|
# Lintian::Data::JoinedLines -- interface to query lists of keywords
|
|
|
|
# Copyright (C) 2008 Russ Allbery
|
|
# Copyright (C) 2017-2018 Chris Lamb <lamby@debian.org>
|
|
# 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, see <http://www.gnu.org/licenses/>.
|
|
|
|
package Lintian::Data::JoinedLines;
|
|
|
|
use v5.20;
|
|
use warnings;
|
|
use utf8;
|
|
|
|
use Carp qw(carp croak);
|
|
use Const::Fast;
|
|
use List::SomeUtils qw(any);
|
|
use Unicode::UTF8 qw(encode_utf8);
|
|
|
|
use Moo::Role;
|
|
use namespace::clean;
|
|
|
|
const my $EMPTY => q{};
|
|
const my $SLASH => q{/};
|
|
|
|
=head1 NAME
|
|
|
|
Lintian::Data::JoinedLines - Lintian interface to query lists of keywords
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
my $keyword;
|
|
my $list = Lintian::Data::JoinedLines->new('type');
|
|
if ($list->recognizes($keyword)) {
|
|
# do something ...
|
|
}
|
|
my $hash = Lintian::Data::JoinedLines->new('another-type', qr{\s++});
|
|
if ($hash->value($keyword) > 1) {
|
|
# do something ...
|
|
}
|
|
if ($list->value($keyword) > 1) {
|
|
# do something ...
|
|
}
|
|
my @keywords = $list->all;
|
|
if ($list->matches_any($keyword)) {
|
|
# do something ...
|
|
}
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Lintian::Data::JoinedLines provides a way of loading a list of keywords or key/value
|
|
pairs from a file in the Lintian root and then querying that list.
|
|
The lists are stored in the F<data> directory of the Lintian root and
|
|
consist of one keyword or key/value pair per line. Blank lines and
|
|
lines beginning with C<#> are ignored. Leading and trailing whitespace
|
|
is stripped.
|
|
|
|
If requested, the lines are split into key/value pairs with a given
|
|
separator regular expression. Otherwise, keywords are taken verbatim
|
|
as they are listed in the file and may include spaces.
|
|
|
|
This module allows lists such as menu sections, doc-base sections,
|
|
obsolete packages, package fields, and so forth to be stored in simple,
|
|
easily editable files.
|
|
|
|
NB: By default Lintian::Data::JoinedLines is lazy and defers loading of the data
|
|
file until it is actually needed.
|
|
|
|
=head2 Interface for the CODE argument
|
|
|
|
This section describes the interface between for the CODE argument
|
|
for the class method new.
|
|
|
|
The sub will be called once for each key/pair with three arguments,
|
|
KEY, VALUE and CURVALUE. The first two are the key/value pair parsed
|
|
from the data file and CURVALUE is current value associated with the
|
|
key. CURVALUE will be C<undef> the first time the sub is called with
|
|
that KEY argument.
|
|
|
|
The sub can then modify VALUE in some way and return the new value for
|
|
that KEY. If CURVALUE is not C<undef>, the sub may return C<undef> to
|
|
indicate that the current value should still be used. It is not
|
|
permissible for the sub to return C<undef> if CURVALUE is C<undef>.
|
|
|
|
Where Perl semantics allow it, the sub can modify CURVALUE and the
|
|
changes will be reflected in the result. As an example, if CURVALUE
|
|
is a hashref, new keys can be inserted etc.
|
|
|
|
=head1 INSTANCE METHODS
|
|
|
|
=over 4
|
|
|
|
=item dataset
|
|
|
|
=item C<keyorder>
|
|
|
|
=cut
|
|
|
|
has dataset => (
|
|
is => 'rw',
|
|
coerce => sub { my ($hashref) = @_; return ($hashref // {}); },
|
|
default => sub { {} }
|
|
);
|
|
|
|
has keyorder => (
|
|
is => 'rw',
|
|
coerce => sub { my ($arrayref) = @_; return ($arrayref // []); },
|
|
default => sub { [] }
|
|
);
|
|
|
|
=item all
|
|
|
|
Returns all keywords listed in the data file as a list in original order.
|
|
In a scalar context, returns the number of keywords.
|
|
|
|
=cut
|
|
|
|
sub all {
|
|
my ($self) = @_;
|
|
|
|
return @{$self->keyorder};
|
|
}
|
|
|
|
=item recognizes (KEY)
|
|
|
|
Returns true if KEY was listed in the data file represented by this
|
|
Lintian::Data::JoinedLines instance and false otherwise.
|
|
|
|
=cut
|
|
|
|
sub recognizes {
|
|
my ($self, $key) = @_;
|
|
|
|
return 0
|
|
unless length $key;
|
|
|
|
return 1
|
|
if exists $self->dataset->{$key};
|
|
|
|
return 0;
|
|
}
|
|
|
|
=item resembles (KEY)
|
|
|
|
Returns true if the data file contains a key that is a case-insensitive match
|
|
to KEY, and false otherwise.
|
|
|
|
=cut
|
|
|
|
sub resembles {
|
|
my ($self, $key) = @_;
|
|
|
|
return 0
|
|
unless length $key;
|
|
|
|
return 1
|
|
if $self->recognizes($key);
|
|
|
|
return 1
|
|
if any { m{^\Q$key\E$}i } keys %{$self->dataset};
|
|
|
|
return 0;
|
|
}
|
|
|
|
=item value (KEY)
|
|
|
|
Returns the value attached to KEY if it was listed in the data
|
|
file represented by this Lintian::Data::JoinedLines instance and the undefined value
|
|
otherwise.
|
|
|
|
=cut
|
|
|
|
sub value {
|
|
my ($self, $key) = @_;
|
|
|
|
return undef
|
|
unless length $key;
|
|
|
|
return $self->dataset->{$key};
|
|
}
|
|
|
|
=item matches_any(KEYWORD[, MODIFIERS])
|
|
|
|
Returns true if KEYWORD matches any regular expression listed in the
|
|
data file. The optional MODIFIERS serve as modifiers on all regexes.
|
|
|
|
=cut
|
|
|
|
sub matches_any {
|
|
my ($self, $wanted, $modifiers) = @_;
|
|
|
|
return 0
|
|
unless length $wanted;
|
|
|
|
$modifiers //= $EMPTY;
|
|
|
|
return 1
|
|
if any { $wanted =~ /(?$modifiers)$_/ } $self->all;
|
|
|
|
return 0;
|
|
}
|
|
|
|
=item load
|
|
|
|
=cut
|
|
|
|
sub load {
|
|
my ($self, $search_space, $our_vendor) = @_;
|
|
|
|
my @remaining_lineage = @{$search_space // []};
|
|
unless (@remaining_lineage) {
|
|
|
|
carp encode_utf8('Unknown data file: ' . $self->location);
|
|
return 0;
|
|
}
|
|
|
|
my $directory = shift @remaining_lineage;
|
|
|
|
my $path = $directory . $SLASH . $self->location;
|
|
|
|
return $self->load(\@remaining_lineage, $our_vendor)
|
|
unless -e $path;
|
|
|
|
open(my $fd, '<:utf8_strict', $path)
|
|
or die encode_utf8("Cannot open $path: $!");
|
|
|
|
my $position = 1;
|
|
while (my $line = <$fd>) {
|
|
|
|
# trim both ends
|
|
$line =~ s/^\s+|\s+$//g;
|
|
|
|
next
|
|
unless length $line;
|
|
|
|
next
|
|
if $line =~ m{^\#};
|
|
|
|
# a command
|
|
if ($line =~ s/^\@//) {
|
|
|
|
my ($directive, $value) = split(/\s+/, $line, 2);
|
|
if ($directive eq 'delete') {
|
|
|
|
croak encode_utf8(
|
|
"Missing key after \@delete in $path at line $position")
|
|
unless length $value;
|
|
|
|
@{$self->keyorder} = grep { $_ ne $value } @{$self->keyorder};
|
|
delete $self->dataset->{$value};
|
|
|
|
} elsif ($directive eq 'include-parent') {
|
|
|
|
$self->load(\@remaining_lineage, $our_vendor)
|
|
or croak encode_utf8("No ancestor data file for $path");
|
|
|
|
} elsif ($directive eq 'if-vendor-is'
|
|
|| $directive eq 'if-vendor-is-not') {
|
|
|
|
my ($specified_vendor, $remain) = split(/\s+/, $value, 2);
|
|
|
|
croak encode_utf8("Missing vendor name after \@$directive")
|
|
unless length $specified_vendor;
|
|
croak encode_utf8(
|
|
"Missing command after vendor name for \@$directive")
|
|
unless length $remain;
|
|
|
|
$our_vendor =~ s{/.*$}{};
|
|
|
|
next
|
|
if $directive eq 'if-vendor-is'
|
|
&& $our_vendor ne $specified_vendor;
|
|
|
|
next
|
|
if $directive eq 'if-vendor-is-not'
|
|
&& $our_vendor eq $specified_vendor;
|
|
|
|
$line = $remain;
|
|
redo;
|
|
|
|
} else {
|
|
croak encode_utf8(
|
|
"Unknown operation \@$directive in $path at line $position"
|
|
);
|
|
}
|
|
next;
|
|
}
|
|
|
|
my $key = $line;
|
|
my $remainder;
|
|
|
|
($key, $remainder) = split($self->separator, $line, 2)
|
|
if defined $self->separator;
|
|
|
|
# do not autovivify; 'exists' below
|
|
my $previous;
|
|
$previous = $self->dataset->{$key}
|
|
if exists $self->dataset->{$key};
|
|
|
|
my $value;
|
|
if ($self->can('consumer')) {
|
|
|
|
$value = $self->consumer($key, $remainder, $previous);
|
|
next
|
|
unless defined $value;
|
|
|
|
} else {
|
|
$value = $remainder;
|
|
}
|
|
|
|
push(@{$self->keyorder}, $key)
|
|
unless exists $self->dataset->{$key};
|
|
|
|
$self->dataset->{$key} = $value;
|
|
|
|
} continue {
|
|
++$position;
|
|
}
|
|
|
|
close $fd;
|
|
|
|
return 1;
|
|
}
|
|
|
|
=back
|
|
|
|
=head1 FILES
|
|
|
|
=over 4
|
|
|
|
=item LINTIAN_INCLUDE_DIR/data
|
|
|
|
The files loaded by this module must be located in this directory.
|
|
Relative paths containing a C</> are permitted, so files may be organized
|
|
in subdirectories in this directory.
|
|
|
|
Note that lintian supports multiple LINTIAN_INCLUDE_DIRs.
|
|
|
|
=back
|
|
|
|
=head1 AUTHOR
|
|
|
|
Originally written by Russ Allbery <rra@debian.org> for Lintian.
|
|
|
|
=head1 SEE ALSO
|
|
|
|
lintian(1), L<https://lintian.debian.org/manual/section-2.6.html>
|
|
|
|
=cut
|
|
|
|
1;
|
|
|
|
# Local Variables:
|
|
# indent-tabs-mode: nil
|
|
# cperl-indent-level: 4
|
|
# End:
|
|
# vim: syntax=perl sw=4 sts=4 sr et
|