path: root/bin/lint-dist

#!/usr/bin/env perl
use strict;
use warnings;
use 5.016;

use Archive::Tar;
use Getopt::Long;
use Parse::CPAN::Meta;
use Parse::CPAN::Packages::Fast;

my @checks = (
    [
        sub { 1 },
        sub { !$_[0]->has_file('META.json') },
        "No META.json file found, using META.yml"
    ],
    [
        sub { 1 },
        sub { !!grep { $_[0]->has_file($_) } qw(MYMETA.yml MYMETA.json) },
        "MYMETA found in dist"
    ],
    [
        sub { 1 },
        sub {
            my $main_module = 'lib/' . ($_[0]->name =~ s/-/\//gr) . '.pm';
            $_[0]->read_file($main_module) =~ /search\.cpan\.org/;
        },
        "module docs link to s.c.o"
    ],
    [
        sub { 1 },
        sub { !$_[0]->has_meta_2 },
        "not using META spec version 2"
    ],
    [
        sub { $_[0]->has_meta_2 },
        sub { !grep { $_ eq 'mit' } @{ $_[0]->meta->{license} } },
        "not using the MIT license"
    ],
    [
        sub { $_[0]->meta && !$_[0]->has_meta_2 },
        sub { $_[0]->meta->{license} ne 'mit' },
        "not using the MIT license"
    ],
    [
        sub { $_[0]->has_meta_2 },
        sub {
            ($_[0]->meta->{resources}{bugtracker}{web} // '') !~ /github\.com/
        },
        "not using github issues"
    ],
    [
        sub { $_[0]->meta && !$_[0]->has_meta_2 },
        sub {
            ($_[0]->meta->{resources}{bugtracker} // '') !~ /github\.com/
        },
        "not using github issues"
    ],
    [
        sub { $_[0]->has_meta_2 },
        sub {
            ($_[0]->meta->{resources}{repository}{url} // '') !~ /github\.com/
        },
        "repository not on github"
    ],
    [
        sub { $_[0]->meta && !$_[0]->has_meta_2 },
        sub {
            ($_[0]->meta->{resources}{repository} // '') !~ /github\.com/
        },
        "repository not on github"
    ],
    [
        sub { $_[0]->has_meta_2 },
        sub {
            my $url = ($_[0]->meta->{resources}{repository}{url} // '');
            my $dist_name = $_[0]->name;
            $url !~ /\/\L$dist_name\.git$/;
        },
        "repository named incorrectly"
    ],
    [
        sub { $_[0]->meta && !$_[0]->has_meta_2 },
        sub {
            my $url = ($_[0]->meta->{resources}{repository} // '');
            my $dist_name = $_[0]->name;
            $url !~ /\/\L$dist_name\.git$/;
        },
        "repository named incorrectly"
    ],
    [
        sub { $_[0]->meta },
        sub {
            my ($author) = grep { /Jesse Luehrs/ } @{ $_[0]->meta->{author} };
            $author && $author !~ /<doy\@tozt\.net>/
        },
        "using the wrong email address"
    ],
    [
        sub { $_[0]->meta },
        sub { !$_[0]->meta->{x_authority} },
        "no AUTHORITY info set"
    ],
    [
        sub { $_[0]->meta },
        sub { $_[0]->meta->{generated_by} !~ /Dist::Zilla/ },
        "not using Dist::Zilla"
    ],
    [
        sub { $_[0]->meta && $_[0]->meta->{generated_by} =~ /Dist::Zilla/ },
        sub {
            $_[0]->meta->{generated_by} !~
                /Dist::Zilla version .*, CPAN::Meta::Converter version .*/
        },
        "using ancient Dist::Zilla"
    ],
    [
        sub { 1 },
        sub { $_[0]->has_file('weaver.ini') },
        "still using weaver.ini"
    ],
    [
        sub { $_[0]->meta && $_[0]->meta->{x_Dist_Zilla} },
        sub {
            !grep { $_->{class} eq 'Dist::Zilla::Plugin::AutoPrereqs' }
                  @{ $_[0]->meta->{x_Dist_Zilla}{plugins} }
        },
        "not using [AutoPrereqs]"
    ],
    [
        sub { $_[0]->meta && $_[0]->meta->{x_Dist_Zilla} },
        sub {
            !grep { $_->{class} eq 'Dist::Zilla::Plugin::ContributorsFromGit' }
                  @{ $_[0]->meta->{x_Dist_Zilla}{plugins} }
        },
        "not using [ContributorsFromGit]"
    ],

    # TODO:
    # using @DOY? probably have to parse dist.ini to detect this
    # github description
    # number of github issues
    # number of rt.cpan tickets
    # kwalitee score
    # .travis.yml and .gitignore in the repository
    # travis configuration should show build.log on cpanm errors
    # tests should not have test numbers
    # scripts shouldn't use #!/usr/bin/env perl
);

package Dist::To::Lint {
    sub new {
        my $class = shift;
        my ($dist, $minicpan) = @_;

        my %args = (
            dist => $dist,
            lint => [],
        );

        if ($minicpan) {
            bless { %args, minicpan => $minicpan }, "Dist::To::Lint::Minicpan";
        }
        else {
            bless { %args }, "Dist::To::Lint::HTTPTiny";
        }
    }

    sub dist { shift->{dist} }
    sub name { shift->dist->dist }
    sub lint { @{ shift->{lint} } }
    sub add_lint {
        my $self = shift;
        push @{ $self->{lint} }, @_;
    }

    sub tarball_name {
        my $self = shift;

        die "tarball_name must be implemented in a subclass";
    }

    sub tar {
        my $self = shift;

        $self->{tar} //= Archive::Tar->new($self->tarball_name);
    }

    sub directory {
        my $self = shift;
        $self->{directory} //= ($self->tar->list_files)[0] =~ s/\/.*//r;
    }

    sub has_file {
        my $self = shift;
        $self->tar->contains_file(join('/', $self->directory, $_[0]));
    }

    sub read_file {
        my $self = shift;
        $self->tar->get_content(join('/', $self->directory, $_[0]));
    }

    sub meta {
        my $self = shift;
        $self->{meta} //= do {
            if ($self->has_file('META.json')) {
                Parse::CPAN::Meta->load_json_string(
                    $self->read_file('META.json')
                );
            }
            elsif ($self->has_file('META.yml')) {
                Parse::CPAN::Meta->load_yaml_string(
                    $self->read_file('META.yml')
                );
            }
            else {
                undef
            }
        };
    }

    sub has_meta_2 {
        my $self = shift;
        $self->meta && ($self->meta->{'meta-spec'}{version} // 0) >= 2
    }

    sub report {
        my $self = shift;

        say $self->name;
        say "=====================";

        if ($self->lint) {
            say for $self->lint;
        }
        else {
            say "No issues found";
        }
    }
}

package Dist::To::Lint::Minicpan {
    our @ISA = ('Dist::To::Lint');

    sub minicpan { shift->{minicpan} }

    sub tarball_name {
        my $self = shift;
        $self->{tarball_name} //=
            $self->minicpan . "/authors/id/" . $self->dist->pathname
    }
}

package Dist::To::Lint::HTTPTiny {
    our @ISA = ('Dist::To::Lint');

    sub tarball_name {
        my $self = shift;
        $self->{tarball_name} //= $self->_fetch_tarball;
    }

    sub _fetch_tarball {
        my $self = shift;

        require HTTP::Tiny;

        my $res = HTTP::Tiny->new->get(
            'http://cpan.metacpan.org/authors/id/' . $self->dist->pathname
        );
        die "Couldn't get distribution tarball"
            unless $res->{status} == 200;

        require File::Temp;
        my $fh = File::Temp->new;
        $fh->print($res->{content});
        $fh->seek(0, 0);
        $self->{_tar_fh} = $fh;

        return $fh->filename;
    }
}

my ($all, $minicpan);
my $cpanid = uc($ENV{USER});
GetOptions(
    'all'        => \$all,
    'minicpan=s' => \$minicpan,
    'cpanid'     => \$cpanid,
) or die;

my @dists = $all
    ? (get_all_dists_for($cpanid, $minicpan))
    : (get_info_for_dists(\@ARGV, $minicpan));

for my $dist (@dists) {
    lint_dist($dist, $minicpan);
    say '';
}

sub get_all_dists_for {
    my ($cpanid, $minicpan) = @_;

    return sort { fc($a->dist) cmp fc($b->dist) }
           grep { $_->dist ne 'perl' }
           grep { $_->cpanid eq $cpanid }
           _packages($minicpan)->latest_distributions;
}

sub get_info_for_dists {
    my ($dists, $minicpan) = @_;

    my $p = _packages($minicpan);

    return map {
        $p->latest_distribution($_)
            || die "Couldn't find $_ in the index"
    } @$dists;
}

sub _packages {
    my ($minicpan) = @_;

    my ($packages_file, $packages_fh);

    if ($minicpan) {
        $packages_file = "$minicpan/modules/02packages.details.txt.gz";
    }
    else {
        require HTTP::Tiny;
        my $res = HTTP::Tiny->new->get(
            'http://cpan.metacpan.org/modules/02packages.details.txt.gz'
        );
        die "Couldn't get package file" unless $res->{status} == 200;

        require File::Temp;
        $packages_fh = File::Temp->new;
        $packages_file = $packages_fh->filename;
        $packages_fh->print($res->{content});
    }

    return Parse::CPAN::Packages::Fast->new($packages_file);
}

sub lint_dist {
    my ($dist, $minicpan) = @_;

    my $to_lint = Dist::To::Lint->new($dist, $minicpan);

    for my $check (@checks) {
        next unless $check->[0]->($to_lint);
        if ($check->[1]->($to_lint)) {
            $to_lint->add_lint($check->[2]);
        }
    }

    $to_lint->report;
}