File Coverage

blib/lib/Namespace/Subroutines.pm

Criterion	Covered	Total	%
statement	60	60	100.0
branch	14	20	70.0
condition	0	4	0.0
subroutine	9	9	100.0
pod	0	1	0.0
total	83	94	88.3

package Namespace::Subroutines;
use 5.010;
use strict;
use warnings;
use attributes;
use Carp       qw( carp );
use File::Find ();
use feature 'say';

our $VERSION = '0.01';

my %skip = (
    AUTOLOAD               => 1,
    BEGIN                  => 1,
    MODIFY_CODE_ATTRIBUTES => 1,
    FETCH_CODE_ATTRIBUTES  => 1,
);

sub find {
    my ( $ns, $cb ) = @_;

    # 'My::App::Controller' -> 'My/App/Controller'
    my $ns2 = $ns =~ s{::}{/}gr;

    my @modules;
    foreach my $path (@INC) {
        next unless -d $path;
        File::Find::find(
            sub {
                return unless /\.pm$/;
                my $name = $File::Find::name =~ s{$path/}{}r;
                return unless $name =~ /^$ns2/;
                push @modules, [ $name, $File::Find::name ];
            },
            $path
        );
    }

    foreach my $m (@modules) {
        my ( $modname, $path ) = @$m;

        # 'Data/Dumper.pm' -> qw(Data Dumper.pm)
        my @a = split( m{/}, $modname );
        pop @a;                             # qw(Data)
        my $namespace = join( '/', @a );    # 'Data'

        # 'My/App/Controller/Users.pm', 'My/App/Controller/Inventory.pm', etc.
        next             unless $namespace =~ /^$ns2/;
        require $modname unless defined $INC{$modname};

        my $module = $modname;              # 'My/App/Controller/Users.pm'
        $module =~ s{\.pm$}{};              # 'My/App/Controller/Users'
        $module =~ s{/}{::}g;               # 'My::App::Controller::Users'
        $module .= '::';                    # 'My::App::Controller::Users::'
        my $table = '%' . $module;          # '%My::App::Controller::Users::'

        ## no critic (BuiltinFunctions::ProhibitStringyEval)
        my @symbols     = split( m{\|}, eval "join('|', keys $table)" );
        my @subroutines = grep { defined &{ $module . $_ } } @symbols;
        my %subroutines;

        open my $fh, '<', $path or ( carp "unable to open $!" and next );
        while ( my $line = <$fh> ) {
            next unless $line =~ /^sub\s+(\w+)[\:\(\s]/;
            $subroutines{$1} = 1;
        }
        close $fh or ( carp "error closing $!" and next );

        # 'My::App::Controller::Users::' -> 'Users'
        $module =~ s{^$ns\::(.+)::$}{$1};

        foreach my $sub (@subroutines) {
            next if $skip{$sub};
            next unless $subroutines{$sub};
            my $name  = join( '::', $ns, $module, $sub );
            my $ref   = \&$name;
            my @attrs = attributes::get( \&$name );
            $cb->( [ split( /::/, $module ) ], $sub, $ref, \@attrs );
        }
    }
}

1;
__END__