File Coverage

blib/lib/Module/CPANTS/Kwalitee/License.pm

Criterion	Covered	Total	%
statement	58	109	53.2
branch	21	52	40.3
condition	10	22	45.4
subroutine	12	17	70.5
pod	3	3	100.0
total	104	203	51.2

package Module::CPANTS::Kwalitee::License;
use warnings;
use strict;
use File::Spec::Functions qw(catfile);
use Software::LicenseUtils;

our $VERSION = '1.00';
$VERSION =~ s/_//; ## no critic

sub order { 100 }

##################################################################
# Analyse
##################################################################

sub analyse {
    my $class = shift;
    my $me = shift;
    my $distdir = $me->distdir;

    # check META.yml
    my $yaml = $me->d->{meta_yml};
    $me->d->{license} = '';
    if ($yaml) {
        if ($yaml->{license} and $yaml->{license} ne 'unknown') {
            $me->d->{license_from_yaml} = $yaml->{license};
            $me->d->{license} = $yaml->{license}.' defined in META.yml';
        }
    }
    # use "files_array" to exclude files listed in "no_index".
    my $files = $me->d->{files_array} || [];

    # check if there's a LICEN[CS]E file
    # (also accept LICENSE.txt etc; RT #114247)
    if (my ($file) = grep {$_ =~ /^(?:LICEN[CS]E|COPYING)\b/} @$files) {
        $me->d->{license} .= " defined in $file";
        $me->d->{external_license_file} = $file;
    }

    # check pod
    my %licenses;
    foreach my $file (grep { /\.p(m|od|l)$/ } sort @$files ) {
        my $path = catfile($distdir, $file);
        next unless -r $path; # skip if not readable
        open my $fh, '<', $path or next;
        my $in_pod = 0;
        my $pod = '';
        my $pod_head = '';
        my @possible_licenses;
        my @unknown_license_texts;
        my $uc_head;
        while(<$fh>) {
            my $first_four = substr($_, 0, 4);
            if ($first_four eq '=hea' && (($uc_head = uc $_) =~ /(?:LICEN[CS]E|LICEN[CS]ING|COPYRIGHT|LEGAL)/)) {
                $me->d->{license_in_pod} = 1;
                $me->d->{license} ||= "defined in POD ($file)";
                if ($in_pod) {
                    my @guessed = Software::LicenseUtils->guess_license_from_pod("=head1 LICENSE\n$pod\n\n=cut\n");
                    if (@guessed) {
                        push @possible_licenses, @guessed;
                    } else {
                        push @unknown_license_texts, "$pod_head$pod";
                    }
                }

                $in_pod = 1;
                $pod_head = $_;
                $pod = '';
            }
            elsif ($first_four eq '=hea' or $first_four eq '=cut') {
                if ($in_pod) {
                    my @guessed = Software::LicenseUtils->guess_license_from_pod("=head1 LICENSE\n$pod\n\n=cut\n");
                    if (@guessed) {
                        push @possible_licenses, @guessed;
                    } else {
                        push @unknown_license_texts, "$pod_head$pod";
                    }
                }
                $in_pod = 0;
                $pod = '';
            }
            elsif ($in_pod) {
                $pod .= $_;
            }
        }
        if ($pod) {
            my @guessed = Software::LicenseUtils->guess_license_from_pod("=head1 LICENSE\n$pod\n\n=cut\n");
            if (@guessed) {
                push @possible_licenses, @guessed;
            } else {
                push @unknown_license_texts, "$pod_head$pod";
            }
        }
        if (@possible_licenses) {
            @possible_licenses = map { s/^Software::License:://; $_ } @possible_licenses;
            push @{$licenses{$_} ||= []}, $file for @possible_licenses;
            $me->d->{files_hash}{$file}{license} = join ',', @possible_licenses;
        } else {
            $me->d->{unknown_license_texts}{$file} = join "\n", @unknown_license_texts if @unknown_license_texts;
        }
    }
    if (%licenses) {
        $me->d->{licenses} = \%licenses;
        my @possible_licenses = keys %licenses;
        if (@possible_licenses == 1) {
            my ($type) = @possible_licenses;
            $me->d->{license_type} = $type;
            $me->d->{license_file} = join ',', @{$licenses{$type}};
        }
    }

    return;
}

##################################################################
# Kwalitee Indicators
##################################################################

sub kwalitee_indicators{
    return [
        {
            name => 'meta_yml_has_license',
            error => q{This distribution does not have a license defined in META.yml.},
            remedy => q{Define the license if you are using in Build.PL. If you are using MakeMaker (Makefile.PL) you should upgrade to ExtUtils::MakeMaker version 6.31.},
            is_extra => 1,
            code => sub {
                my $d = shift;
                my $yaml = $d->{meta_yml};
                ($yaml->{license} and $yaml->{license} ne 'unknown') ? 1 : 0 },
            details => sub {
                my $d = shift;
                my $yaml = $d->{meta_yml};
                return "No META.yml." unless $yaml;
                return "No license was found in META.yml." unless $yaml->{license};
                return "Unknown license was found in META.yml.";
            },
        },
        {
            name => 'has_human_readable_license',
            error => q{This distribution does not have a license defined in the documentation or in a file called LICENSE},
            remedy => q{Add a section called "LICENSE" to the documentation, or add a file named LICENSE to the distribution.},
            code => sub {
                my $d = shift;
                return $d->{external_license_file} || $d->{license_in_pod} ? 1 : 0;
            },
            details => sub {
                my $d = shift;
                return "Neither LICENSE file nor LICENSE section in pod was found.";
            },
        },
        {
            name => 'has_separate_license_file',
            error => q{This distribution does not have a LICENSE or LICENCE file in its root directory.},
            remedy => q{This is not a critical issue. Currently mainly informative for the CPANTS authors. It might be removed later.},
            is_experimental => 1,
            code => sub { shift->{external_license_file} ? 1 : 0 },
            details => sub {
                my $d = shift;
                return "LICENSE file was found.";
            },
        },
        {
            name => 'has_license_in_source_file',
            error => q{Does not have license information in any of its source files},
            remedy => q{Add =head1 LICENSE and the text of the license to the main module in your code.},
            code => sub {
                my $d = shift;
                return $d->{license_in_pod} ? 1 : 0;
            },
            details => sub {
                my $d = shift;
                return "LICENSE section was not found in the pod.";
            },
        },
        {
            name => 'has_known_license_in_source_file',
            error => q{Does not have license information in any of its source files, or the information is not recognized by Software::License},
            remedy => q{Add =head1 LICENSE and/or the proper text of the well-known license to the main module in your code.},
            is_extra => 1,
            code => sub {
                my $d = shift;
                return 0 unless $d->{license_in_pod};
                my @files_with_licenses = grep {$d->{files_hash}{$_}{license}} keys %{$d->{files_hash}};
                return @files_with_licenses ? 1 : 0;
            },
            details => sub {
                my $d = shift;
                return "LICENSE section was not found in the pod, or the license information was not recognized by Software::License.";
            },
        },
    ];
}


q{Favourite record of the moment:
  Lili Allen - Allright, still};

__END__