File Coverage

File:blib/lib/App/Project/Doctor/Check/License.pm
Coverage:93.5%

linestmtbrancondsubtimecode
1package App::Project::Doctor::Check::License;
2
3
2
2
2
2
2374
3
26
use strict;
4
2
2
2
2
3
2
62
use warnings;
5
2
2
2
2
4
1
7
use autodie qw(:all);
6
7
2
2
2
2
4247
2
9
use parent -norequire, 'App::Project::Doctor::Check::Base';
8
9
2
2
2
2
65
2
66
use Carp qw(croak carp);
10
2
2
2
2
4
2
681
use Readonly;
11
12our $VERSION = '0.02';
13
14Readonly::Hash my %LICENSE_KEYWORD => (
15        perl_5   => qr/same terms as perl/i,
16        gpl_2    => qr/GNU GENERAL PUBLIC LICENSE\s+Version 2/si,
17        gpl_3    => qr/GNU GENERAL PUBLIC LICENSE\s+Version 3/si,
18        lgpl_2   => qr/GNU LESSER GENERAL PUBLIC LICENSE\s+Version 2/si,
19        mit      => qr/Permission is hereby granted, free of charge/i,
20        bsd      => qr/Redistribution and use in source and binary forms/i,
21        artistic => qr/The Artistic License/i,
22);
23
24
2
2
212
sub name        { 'Licensing' }
25
1
1
2
sub description { 'A LICENSE file is present and agrees with the META declaration.' }
26
2
2
5
sub can_fix     { 0 }
27
2
2
4
sub order       { 45 }
28
29sub check {
30
6
6
7
        my ($self, $ctx) = @_;
31
6
50
10
        croak 'check requires an App::Project::Doctor::Context' unless ref $ctx;
32
33
6
4
        my @findings;
34
35        # 1. LICENSE file must exist (accept both spellings).
36
6
100
100
9
        my $lic_file = $ctx->has_file('LICENSE')  ? 'LICENSE'
37                     : $ctx->has_file('LICENCE')  ? 'LICENCE'
38                     : undef;
39
40
6
100
11
        unless ($lic_file) {
41
2
6
                push @findings, _f(
42                        severity => 'error',
43                        message  => 'No LICENSE (or LICENCE) file found.',
44                        detail   => 'CPAN requires a license file for all distributions.',
45                );
46        }
47
48        # 2. Cross-check META license field when both exist.
49
6
24
6
22
        my ($meta_file) = grep { $ctx->has_file($_) } qw(META.json META.yml MYMETA.json MYMETA.yml);
50
6
100
100
16
        if ($lic_file && $meta_file) {
51
2
3
                my $meta_id = _meta_license_id($ctx->abs_path($meta_file));
52
2
50
33
11
                if ($meta_id && $meta_id ne 'unknown') {
53
2
5
                        my $pattern = $LICENSE_KEYWORD{$meta_id};
54
2
50
9
                        if ($pattern) {
55
2
2
                                my $content = $ctx->slurp($lic_file);
56
2
100
17
                                unless ($content =~ $pattern) {
57
1
3
                                        push @findings, _f(
58                                                severity => 'warning',
59                                                message  => "LICENSE content does not match declared license '$meta_id' in $meta_file.",
60                                        );
61                                }
62                        }
63                }
64        }
65
66
6
100
7
        unless (@findings) {
67
3
100
7
                push @findings, _f(
68                        severity => 'pass',
69                        message  => "LICENSE file present"
70                                  . ($meta_file ? ' and consistent with META.' : '.'),
71                );
72        }
73
74
6
14
        return @findings;
75}
76
77sub _f {
78
6
6
9
        require App::Project::Doctor::Finding;
79
6
17
        return App::Project::Doctor::Finding->new(check_name => 'Licensing', @_);
80}
81
82sub _meta_license_id {
83
3
3
1227
        my $path = shift;
84
3
7
        require CPAN::Meta;
85
3
3
3
7
        my $meta = eval { CPAN::Meta->load_file($path) };
86
3
100
67
165
        return undef if $@ || !$meta;
87
2
3
        return $meta->license;
88}
89
901;
91