File Coverage

blib/lib/PM/Packages.pm

Criterion	Covered	Total	%
statement	36	37	97.3
branch	21	26	80.7
condition	2	3	66.6
subroutine	4	4	100.0
pod	0	1	0.0
total	63	71	88.7

package PM::Packages;

use 5.00405;
use strict;

our $VERSION = '0.01';

our @EXPORT_OK = qw( pm_packages );
our @EXPORT = @EXPORT_OK;

use Exporter qw( import );

sub pm_packages
{
    my( $pmfile ) = @_;
    my @ret;

    open my $fh, "<", "$pmfile" or return;

    local $/ = "\n";
    my $inpod = 0;
  PLINE: while (<$fh>) {
        chomp;
        my($pline) = $_;
        $inpod = $pline =~ /^=(?!cut)/ ? 1 :
            $pline =~ /^=cut/ ? 0 : $inpod;
        next if $inpod;
        next if substr($pline,0,4) eq "=cut";

        $pline =~ s/\#.*//;
        next if $pline =~ /^\s*$/;
        if ($pline =~ /^__(?:END|DATA)__\b/
            and $pmfile !~ /\.PL$/   # PL files may well have code after __DATA__
            ){
            last PLINE;
        }

        my $pkg;
        my $strict_version;

        if (
            $pline =~ m{
                      (.*)
                      (?
                      \bpackage\s+
                      ([\w\:\']+)
                      \s*
                      (?: $ | [\}\;] | \{ | \s+($version::STRICT) )
                    }x) {
            $pkg = $2;
            $strict_version = $3;
            if ($pkg eq "DB"){
                # XXX if pumpkin and perl make him comaintainer! I
                # think I always made the pumpkins comaint on DB
                # without further ado (?)
                next PLINE;
            }
        }

        if ($pkg) {
            # Found something

            # from package
            $pkg =~ s/\'/::/;
            # next PLINE unless $pkg =~ /^[A-Za-z]/;
            next PLINE unless $pkg =~ /\w$/;
            next PLINE if $pkg eq "main";
            # Perl::Critic::Policy::TestingAndDebugging::ProhibitShebangWarningsArg
            # database for modid in mods, package in packages, package in perms
            # alter table mods modify modid varchar(128) binary NOT NULL default '';
            # alter table packages modify package varchar(128) binary NOT NULL default '';
            next PLINE if length($pkg) > 128;
            push @ret, $pkg;
        }
    }

    $fh->close;
    return @ret;
}


1;
__END__