File Coverage

blib/lib/Module/List/More.pm

Criterion	Covered	Total	%
statement	91	105	86.6
branch	52	76	68.4
condition	46	70	65.7
subroutine	3	3	100.0
pod	0	1	0.0
total	192	255	75.2

## no critic: TestingAndDebugging::RequireUseStrict
package Module::List::More;

#IFUNBUILT
# # use strict 'subs', 'vars';
# # use warnings;
#END IFUNBUILT

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2022-08-12'; # DATE
our $DIST = 'Module-List-More'; # DIST
our $VERSION = '0.004011'; # VERSION

# do our own exporting to start faster
sub import {
    my $pkg = shift;
    my $caller = caller;
    for my $sym (@_) {
        if ($sym eq 'list_modules') { *{"$caller\::$sym"} = \&{$sym} }
        else { die "$sym is not exported!" }
    }
}

sub list_modules($$) {
    my($prefix, $options) = @_;
    my $trivial_syntax = $options->{trivial_syntax};
    my($root_leaf_rx, $root_notleaf_rx);
    my($notroot_leaf_rx, $notroot_notleaf_rx);
    if($trivial_syntax) {
        $root_leaf_rx = $notroot_leaf_rx = qr#:?(?:[^/:]+:)*[^/:]+:?#;
        $root_notleaf_rx = $notroot_notleaf_rx =
            qr#:?(?:[^/:]+:)*[^/:]+#;
    } else {
        $root_leaf_rx = $root_notleaf_rx = qr/[a-zA-Z_][0-9a-zA-Z_]*/;
        $notroot_leaf_rx = $notroot_notleaf_rx = qr/[0-9a-zA-Z_]+/;
    }

    my $recurse = $options->{recurse};

    # filter by wildcard. we cannot do this sooner because wildcard can be put
    # at the end or at the beginning (e.g. '*::Path') so we still need
    my $re_wildcard;
    if ($options->{wildcard} || $options->{ls_mode}) {
        require String::Wildcard::Bash;
        my $orig_prefix = $prefix;
        #print "DEBUG: orig_prefix = <$orig_prefix>\n";
        my @prefix_parts = split /::/, $prefix;
        pop @prefix_parts if $options->{ls_mode} && @prefix_parts && $orig_prefix !~ /::\z/
            && !String::Wildcard::Bash::contains_wildcard($orig_prefix);
        $prefix = "";
        my $has_wildcard;
        while (defined(my $part = shift @prefix_parts)) {
            if (String::Wildcard::Bash::contains_wildcard($part)) {
                $has_wildcard++;
                # XXX limit recurse level to scalar(@prefix_parts), or -1 if has_globstar
                $recurse = 1 if @prefix_parts;
                last;
            } else {
                $prefix .= "$part\::";
            }
        }
        #print "DEBUG: has_wildcard = $has_wildcard\n";
        if ($options->{wildcard} && $has_wildcard) {
            $re_wildcard = String::Wildcard::Bash::convert_wildcard_to_re({path_separator=>':', dotglob=>1, globstar=>1}, $orig_prefix);
            $re_wildcard = qr/\A(?:$re_wildcard)\z/;
        } else {
            $re_wildcard = $orig_prefix =~ /::\z/ ? qr/\A\Q$orig_prefix\E/ : qr/\A\Q$orig_prefix\E(?:\z|::)/;
        }
        #print "DEBUG: re_wildcard = $re_wildcard\n";
        $recurse = 1 if String::Wildcard::Bash::contains_globstar_wildcard($orig_prefix);
        #print "DEBUG: recurse = $recurse\n";
    }
    #print "DEBUG: prefix = <$prefix>\n";

    die "bad module name prefix `$prefix'"
        unless $prefix =~ /\A(?:${root_notleaf_rx}::
                               (?:${notroot_notleaf_rx}::)*)?\z/x &&
                                   $prefix !~ /(?:\A|[^:]::)\.\.?::/;

    my $list_modules = $options->{list_modules};
    my $list_prefixes = $options->{list_prefixes};
    my $list_pod = $options->{list_pod};
    my $use_pod_dir = $options->{use_pod_dir};
    return {} unless $list_modules || $list_prefixes || $list_pod;
    my $return_path = $options->{return_path};
    my $return_library_path = $options->{return_library_path};
    my $return_version = $options->{return_version};
    my $all = $options->{all};
    my @prefixes = ($prefix);
    my %seen_prefixes;
    my %results;
    my $_set_or_add_result = sub {
        my ($key, $result_field, $val, $always_all) = @_;
        if (!$result_field) {
            $results{$key} ||= undef;
        } elsif ($all || $always_all) {
            $results{$key}{$result_field} ||= [];
            push @{ $results{$key}{$result_field} }, $val;
        } else {
            $results{$key}{$result_field} = $val
                unless exists $results{$key}{$result_field};
        }
    };
    #use DD; dd \@prefixes;
    while(@prefixes) {
        my $prefix = pop(@prefixes);
        my @dir_suffix = split(/::/, $prefix);
        my $module_rx =
            $prefix eq "" ? $root_leaf_rx : $notroot_leaf_rx;
        my $pm_rx = qr/\A($module_rx)\.pmc?\z/;
        my $pod_rx = qr/\A($module_rx)\.pod\z/;
        my $dir_rx =
            $prefix eq "" ? $root_notleaf_rx : $notroot_notleaf_rx;
        $dir_rx = qr/\A$dir_rx\z/;
        foreach my $incdir (@INC) {
            my $dir = join("/", $incdir, @dir_suffix);
            opendir(my $dh, $dir) or next;
            while(defined(my $entry = readdir($dh))) {
                if(($list_modules && $entry =~ $pm_rx) ||
                       ($list_pod &&
                        $entry =~ $pod_rx)) {
                    my $key = $prefix.$1;
                    #print "DEBUG: key=<$key>\n";
                    next if $re_wildcard && $key !~ $re_wildcard;
                    my $path = "$dir/$entry";
                    $_set_or_add_result->($key);
                    $_set_or_add_result->($key, 'module_path', $path) if $return_path;
                    $_set_or_add_result->($key, 'library_path', $incdir) if $return_library_path;
                    if ($return_version)      {
                        require ExtUtils::MakeMaker;
                        my $v = MM->parse_version($path);
                        $v = undef if $v eq 'undef';
                        $_set_or_add_result->($key, 'module_version', $v);
                    }
                } elsif(($list_prefixes || $recurse) &&
                            ($entry ne '.' && $entry ne '..') &&
                            $entry =~ $dir_rx &&
                            -d join("/", $dir,
                                    $entry)) {
                    my $newmod = $prefix.$entry;
                    my $newpfx = $newmod."::";
                    next if exists $seen_prefixes{$newpfx};
                    if ($list_prefixes) {
                        $_set_or_add_result->($newpfx);
                        $_set_or_add_result->($newpfx, 'prefix_paths', "$dir/$entry/", 'always_add') if $return_path;
                        $_set_or_add_result->($newpfx, 'library_path', $incdir, 'always_add') if $return_library_path;
                    }
                    push @prefixes, $newpfx if $recurse;
                }
            }
            next unless $list_pod && $use_pod_dir;
            $dir = join("/", $dir, "pod");
            opendir($dh, $dir) or next;
            while(defined(my $entry = readdir($dh))) {
                if($entry =~ $pod_rx) {
                    my $key = $prefix.$1;
                    next if $re_wildcard && $key !~ $re_wildcard;
                    $_set_or_add_result->($key);
                    $_set_or_add_result->($key, 'pod_path', "$dir/$entry") if $return_path;
                    $_set_or_add_result->($key, 'library_path', $incdir) if $return_library_path;
                }
            }
        }
    }

    # we cannot filter prefixes early with wildcard because we need to dig down
    # first and that would've been prevented if we had a wildcard like *::Foo.
    if ($list_prefixes && $re_wildcard) {
        for my $k (keys %results) {
            next unless $k =~ /::\z/;
            (my $k_nocolon = $k) =~ s/::\z//;
            delete $results{$k} unless $k =~ $re_wildcard || $k_nocolon =~ $re_wildcard;
        }
    }

    return \%results;
}

1;
# ABSTRACT: Module::List, with more options

__END__