view release on metacpan or  search on metacpan

t/lib/INA_CPAN_Check.pm  view on Meta::CPAN

# Every .pm and .t under $dir, recursively, as paths relative to nothing
# (they keep the $dir prefix they were found with).
sub _find_pm_t {
    my ($dir) = @_;
    local *_INA_DIR;
    opendir(_INA_DIR, $dir) or return ();
    my @entries = grep { !/^\./ } readdir(_INA_DIR);
    closedir _INA_DIR;
    my @found;
    for my $e (sort @entries) {
        my $path = "$dir/$e";
        if (-d $path) {
            push @found, _find_pm_t($path);
        }
        elsif ($e =~ /\.(?:pm|t)$/) {
            push @found, $path;
        }
    }
    return @found;
}

sub _manifest_files {
    my ($root) = @_;
    my @lines = _slurp_lines("$root/MANIFEST");
    my @files;
    for my $line (@lines) {
        $line =~ s/\r?\n$//;
        $line =~ s/\s*#.*$//;
        $line =~ s/^\s+|\s+$//g;
        push @files, $line if length $line;
    }
    return @files;
}

# The files that carry ina@CPAN hand-written code: lib/*.pm, every *.t,
# and eg/*.pl.  Driven by MANIFEST so that generated or vendored files
# outside it are never scanned.
sub _manifest_pm_and_t {
    my ($root) = @_;
    my @all   = _manifest_files($root);
    my @found = grep {
        ((/\.pm$/ && m{^lib/}) || /\.t$/ || m{^eg/.*\.pl$}) && -f "$root/$_"
    } @all;
    return @found if @found;
    # Fallback for a dist with no usable MANIFEST.
    my @fb;
    for my $dir ('lib', 't') {
        push @fb, _find_pm_t("$root/$dir") if -d "$root/$dir";
    }
    for my $p (@fb) {
        $p =~ s{^\Q$root\E/}{};
    }
    return @fb;
}

# MANIFEST entries that are text and therefore subject to the encoding
# checks.  Anything with a known binary extension is excluded.
sub _text_files {
    my ($root) = @_;
    return grep { !/\.(?:gz|tgz|zip|tar|bz2|png|jpe?g|gif|ico|pdf)$/i }
           _manifest_files($root);
}

# Find $pattern in $path, ignoring POD, __END__, comments, string literals
# and regex literals, so that a match is real code and not prose or data.
# Returns a list of { line => N, text => "..." }.
sub _scan_code {
    my ($path, $pattern) = @_;
    my $text = _slurp($path);
    return () unless $text ne '';
    $text =~ s/\n__END__\b.*\z//s;
    $text =~ s/^=[a-zA-Z].*?^=cut[ \t]*$//msg;
    my @hits;
    my $lineno = 0;
    for my $line (split /\n/, $text) {
        $lineno++;
        next if $line =~ /^\s*#/;
        my $clean = $line;
        $clean =~ s/'(?:[^'\\]|\\.)*'/''/g;
        $clean =~ s/"(?:[^"\\]|\\.)*"/""/g;
        $clean =~ s{(?:s|m|qr|split\s*/)[^/]*/[^/]*/[gimsex]*}{}g;
        $clean =~ s{/[^/]+/[gimsex]*}{}g;
        $clean =~ s/#.*$//;
        if ($clean =~ $pattern) {
            push @hits, { line => $lineno, text => $line };
        }
    }
    return @hits;
}

# Code with POD and __END__ removed, for whole-file pattern matching.
sub _code_only {
    my ($path) = @_;
    my $text = _slurp($path);
    $text =~ s/\n__END__\b.*\z//s;
    $text =~ s/^=[a-zA-Z].*?^=cut[ \t]*$//msg;
    return $text;
}

######################################################################
# Distribution and metadata utilities
######################################################################

sub _dist_name {
    my ($root) = @_;
    my $base = $root;
    $base =~ s{.*[/\\]}{};
    $base =~ s{-[\d.]+$}{};
    return $base;
}

# The primary module is the first MANIFEST entry (ina convention, as used
# by pmake.bat).  Deriving it from MANIFEST is robust regardless of the
# directory name or a trailing "/.." that rel2abs leaves in $root.
sub _primary_pm {
    my ($root) = @_;
    if (-f "$root/MANIFEST") {
        my @manifest = _manifest_files($root);
        if (@manifest && $manifest[0] =~ /\.pm$/ && -f "$root/$manifest[0]") {
            return "$root/$manifest[0]";