/usr/share/perl5/Config/Model/Dpkg/Copyright/License.pm is in libconfig-model-dpkg-perl 2.090.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 | package Config::Model::Dpkg::Copyright::License;
use 5.20.0;
use Mouse;
extends qw/Config::Model::HashId/;
use feature qw/postderef signatures/;
no warnings qw/experimental::postderef experimental::signatures/;
use Scalar::Util qw/weaken/;
# checkUnused license is a idx check, not a content check
sub BUILD ($self, @args) {
$self->SUPER::BUILD(@args);
weaken($self);
$self-> add_check_content( sub { $self->check_unused_licenses(@_);} )
}
sub check_idx {
my $self = shift;
my %args = @_ > 1 ? @_ : ( index => $_[0] );
my $idx = $args{index};
my $silent = $args{silent} || 0;
my $check = $args{check} || 'yes';
my $apply_fix = $args{fix} // $check eq 'fix' ? 1 : 0;
my $has_error = $self->SUPER::check_idx(%args);
return $has_error if $self->instance->initial_load;
# not called after initial load if idx os not modified... is that a global check ?
my $unused_licenses = $self->_get_unused_licenses($idx);
if ($check eq 'yes' and $unused_licenses->{$idx}) {
if ($apply_fix) {
say "Deleting unused $idx license" unless $silent;
$self->delete($idx);
}
else {
$self->{warning_hash}{$idx} //= [];
my $warn = "License $idx is not used in Files: section";;
$self->inc_fixes;
push $self->{warning_hash}{$idx}->@*, $warn;
warn "$warn\n" unless $silent;
}
}
return $has_error;
}
# TODO: move global check from Copyright to here ?
sub _get_unused_licenses ($self, @licenses) {
my @to_check = scalar @licenses ? @licenses : $self->fetch_all_indexes;
my %unused = map { $_ => 1 } @to_check;
foreach my $path ($self->grab('- Files')->fetch_all_indexes) {
my $lic = $self->grab(qq!- Files:"$path" License!);
next if $lic->fetch_element_value("full_license"); # no need of a global License
my $names = $lic->fetch_element_value(name => "short_name", check => "no") ;
next unless $names; # may be undef when user is filling values
my @sub_licenses = split /[,\s]+(or|and)[,\s]+/,$names;
map { delete $unused{$_}; } @sub_licenses;
}
return \%unused;
}
sub check_unused_licenses ($self,$error, $warn, $fix = 0, $silent = 0) {
if ($fix) {
return $self->prune_unused_licenses($silent);
}
my @unused = sort keys $self->_get_unused_licenses()->%*;
return unless @unused;
my $msg = "Unused license: @unused";
push $warn->@*, $msg;
}
sub prune_unused_licenses ($self, $silent = 0) {
my @unused = sort keys $self->_get_unused_licenses()->%*;
return unless @unused;
say "Deleting unused license: @unused" unless $silent;
foreach my $lic (@unused) {
$self->delete("$lic");
}
}
1;
|