File Coverage

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

linestmtbrancondsubtimecode
1package App::Project::Doctor::Check::License;
2
3
3
3
3
3
4181
3
46
use strict;
4
3
3
3
3
5
3
83
use warnings;
5
3
3
3
3
7
3
10
use autodie qw(:all);
6
7
3
3
3
3
6547
3
14
use parent -norequire, 'App::Project::Doctor::Check::Base';
8
9
3
3
3
3
109
3
102
use Carp qw(croak carp);
10
3
3
3
3
7
1
963
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
192
sub name        { 'Licensing' }
25
1
1
2
sub description { 'A LICENSE file is present and agrees with the META declaration.' }
26
2
2
3
sub can_fix     { 0 }
27
2
2
4
sub order       { 45 }
28
29sub check {
30
7
7
36
        my ($self, $ctx) = @_;
31
7
50
10
        croak 'check requires an App::Project::Doctor::Context' unless ref $ctx;
32
33
7
5
        my @findings;
34
35        # 1. LICENSE file must exist (accept both spellings).
36
7
100
100
13
        my $lic_file = $ctx->has_file('LICENSE')  ? 'LICENSE'
37                     : $ctx->has_file('LICENCE')  ? 'LICENCE'
38                     : undef;
39
40
7
100
12
        unless ($lic_file) {
41
2
4
                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
7
28
8
27
        my ($meta_file) = grep { $ctx->has_file($_) } qw(META.json META.yml MYMETA.json MYMETA.yml);
50
7
100
100
19
        if ($lic_file && $meta_file) {
51
3
4
                my $meta_id = _meta_license_id($ctx->abs_path($meta_file));
52
3
50
33
51
                if ($meta_id && $meta_id ne 'unknown') {
53
3
7
                        my $pattern = $LICENSE_KEYWORD{$meta_id};
54
3
50
13
                        if ($pattern) {
55
3
7
                                my $content = $ctx->slurp($lic_file);
56
3
100
30
                                unless ($content =~ $pattern) {
57
2
5
                                        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
7
100
7
        unless (@findings) {
67
3
100
5
                push @findings, _f(
68                        severity => 'pass',
69                        message  => "LICENSE file present"
70                                  . ($meta_file ? ' and consistent with META.' : '.'),
71                );
72        }
73
74
7
20
        return @findings;
75}
76
77sub _f {
78
7
7
17
        require App::Project::Doctor::Finding;
79
7
18
        return App::Project::Doctor::Finding->new(check_name => 'Licensing', @_);
80}
81
82sub _meta_license_id {
83
4
4
1336
        my $path = shift;
84
4
9
        require CPAN::Meta;
85
4
4
3
21
        my $meta = eval { CPAN::Meta->load_file($path) };
86
4
100
67
2152
        return undef if $@ || !$meta;
87        # CPAN::Meta->license must be called in list context; it croaks in scalar context.
88
3
7
        my ($lic) = $meta->license;
89
3
21
        return $lic;
90}
91
921;
93