mirror of https://gitee.com/openkylin/lintian.git
303 lines
6.3 KiB
Perl
303 lines
6.3 KiB
Perl
# Copyright (C) 2011 Niels Thykier <niels@thykier.net>
|
|
# Copyright (C) 2019-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.
|
|
|
|
package Lintian::Processable;
|
|
|
|
use v5.20;
|
|
use warnings;
|
|
use utf8;
|
|
use warnings::register;
|
|
|
|
use Const::Fast;
|
|
use File::Basename;
|
|
use Path::Tiny;
|
|
|
|
use Moo::Role;
|
|
use MooX::Aliases;
|
|
use namespace::clean;
|
|
|
|
const my $EMPTY => q{};
|
|
const my $COLON => q{:};
|
|
const my $SLASH => q{/};
|
|
const my $UNDERSCORE => q{_};
|
|
const my $EVIL_CHARACTERS => qr{[/&|;\$"'<>]};
|
|
|
|
=encoding utf-8
|
|
|
|
=head1 NAME
|
|
|
|
Lintian::Processable -- An (abstract) object that Lintian can process
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use Lintian::Processable;
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Instances of this perl class are objects that Lintian can process (e.g.
|
|
deb files). Multiple objects can then be combined into
|
|
L<groups|Lintian::Group>, which Lintian will process
|
|
together.
|
|
|
|
=head1 INSTANCE METHODS
|
|
|
|
=over 4
|
|
|
|
=item name
|
|
|
|
Returns the name of the package.
|
|
|
|
=item type
|
|
|
|
Returns the type of package (e.g. binary, source, udeb ...)
|
|
|
|
=item hints
|
|
|
|
=item $proc->version
|
|
|
|
Returns the version of the package.
|
|
|
|
=item $proc->path
|
|
|
|
Returns the path to the packaged version of actual package. This path
|
|
is used in case the data needs to be extracted from the package.
|
|
|
|
=item basename
|
|
|
|
Returns the basename of the package path.
|
|
|
|
=item $proc->architecture
|
|
|
|
Returns the architecture(s) of the package. May return multiple values
|
|
from changes processables. For source processables it is "source".
|
|
|
|
=item $proc->source_name
|
|
|
|
Returns the name of the source package.
|
|
|
|
=item $proc->source_version
|
|
|
|
Returns the version of the source package.
|
|
|
|
=item $proc->tainted
|
|
|
|
Returns a truth value if one or more fields in this Processable is
|
|
tainted. On a best effort basis tainted fields will be sanitized
|
|
to less dangerous (but possibly invalid) values.
|
|
|
|
=item fields
|
|
|
|
Lintian::Deb822::Section with primary field values.
|
|
|
|
=item $proc->pooldir
|
|
|
|
Returns a reference to lab this Processable is in.
|
|
|
|
=item $proc->basedir
|
|
|
|
Returns the base directory of this package inside the lab.
|
|
|
|
=cut
|
|
|
|
has path => (
|
|
is => 'rw',
|
|
default => $EMPTY,
|
|
trigger => sub {
|
|
my ($self, $path) = @_;
|
|
|
|
my $basename = basename($path);
|
|
$self->basename($basename);
|
|
}
|
|
);
|
|
has basename => (is => 'rw', default => $EMPTY);
|
|
has type => (is => 'rw', default => $EMPTY);
|
|
|
|
has hints => (is => 'rw', default => sub { [] });
|
|
|
|
has architecture => (
|
|
is => 'rw',
|
|
coerce => sub {
|
|
my ($value) = @_;
|
|
return clean_field($value);
|
|
},
|
|
default => $EMPTY
|
|
);
|
|
has name => (
|
|
is => 'rw',
|
|
coerce => sub {
|
|
my ($value) = @_;
|
|
return clean_field($value);
|
|
},
|
|
default => $EMPTY
|
|
);
|
|
has source_name => (
|
|
is => 'rw',
|
|
coerce => sub {
|
|
my ($value) = @_;
|
|
return clean_field($value);
|
|
},
|
|
default => $EMPTY
|
|
);
|
|
has source_version =>(
|
|
is => 'rw',
|
|
coerce => sub {
|
|
my ($value) = @_;
|
|
return clean_field($value);
|
|
},
|
|
default => $EMPTY
|
|
);
|
|
has version => (
|
|
is => 'rw',
|
|
coerce => sub {
|
|
my ($value) = @_;
|
|
return clean_field($value);
|
|
},
|
|
default => $EMPTY
|
|
);
|
|
|
|
has tainted => (is => 'rw', default => 0);
|
|
|
|
has fields => (is => 'rw', default => sub { Lintian::Deb822::Section->new; });
|
|
|
|
has pooldir => (is => 'rw', default => $EMPTY);
|
|
has basedir => (
|
|
is => 'rw',
|
|
lazy => 1,
|
|
trigger => sub {
|
|
my ($self, $folder) = @_;
|
|
|
|
return
|
|
unless length $folder;
|
|
|
|
# create directory
|
|
path($folder)->mkpath
|
|
unless -e $folder;
|
|
},
|
|
default => sub {
|
|
my ($self) = @_;
|
|
|
|
my $path
|
|
= $self->source_name
|
|
. $SLASH
|
|
. $self->name
|
|
. $UNDERSCORE
|
|
. $self->version;
|
|
$path .= $UNDERSCORE . $self->architecture
|
|
unless $self->type eq 'source';
|
|
$path .= $UNDERSCORE . $self->type;
|
|
|
|
# architectures can contain spaces in changes files
|
|
$path =~ s/\s/-/g;
|
|
|
|
# colon can be a path separator
|
|
$path =~ s/:/_/g;
|
|
|
|
my $basedir = $self->pooldir . "/$path";
|
|
|
|
return $basedir;
|
|
}
|
|
);
|
|
|
|
=item C<identifier>
|
|
|
|
Produces an identifier for this processable. The identifier is
|
|
based on the type, name, version and architecture of the package.
|
|
|
|
=cut
|
|
|
|
sub identifier {
|
|
my ($self) = @_;
|
|
|
|
my $id = $self->type . $COLON . $self->name . $UNDERSCORE . $self->version;
|
|
|
|
# add architecture unless it is source
|
|
$id .= $UNDERSCORE . $self->architecture
|
|
unless $self->type eq 'source';
|
|
|
|
$id =~ s/\s+/_/g;
|
|
|
|
return $id;
|
|
}
|
|
|
|
=item clean_field
|
|
|
|
Cleans a field of evil characters to prevent traversal or worse.
|
|
|
|
=cut
|
|
|
|
sub clean_field {
|
|
my ($value) = @_;
|
|
|
|
# make sure none of the fields can cause traversal
|
|
my $clean = $value;
|
|
$clean =~ s/${$EVIL_CHARACTERS}/_/g;
|
|
|
|
return $clean;
|
|
}
|
|
|
|
=item guess_name
|
|
|
|
=cut
|
|
|
|
sub guess_name {
|
|
my ($self, $path) = @_;
|
|
|
|
my $guess = path($path)->basename;
|
|
|
|
# drop extension, to catch fields-general-missing.deb
|
|
$guess =~ s/\.[^.]*$//;
|
|
|
|
# drop everything after the first underscore, if any
|
|
$guess =~ s/_.*$//;
|
|
|
|
# 'path/lintian_2.5.2_amd64.changes' became 'lintian'
|
|
return $guess;
|
|
}
|
|
|
|
=back
|
|
|
|
=head1 AUTHOR
|
|
|
|
Originally written by Niels Thykier <niels@thykier.net> for Lintian.
|
|
Substantial portions written by Russ Allbery <rra@debian.org> for Lintian.
|
|
|
|
=head1 SEE ALSO
|
|
|
|
lintian(1)
|
|
|
|
L<Lintian::Processable::Installable>
|
|
|
|
L<Lintian::Processable::Buildinfo>
|
|
|
|
L<Lintian::Processable::Changes>
|
|
|
|
L<Lintian::Processable::Source>
|
|
|
|
L<Lintian::Group>
|
|
|
|
=cut
|
|
|
|
1;
|
|
|
|
# Local Variables:
|
|
# indent-tabs-mode: nil
|
|
# cperl-indent-level: 4
|
|
# End:
|
|
# vim: syntax=perl sw=4 sts=4 sr et
|