File Coverage

blib/lib/Module/List/More.pm
Criterion Covered Total %
statement 110 135 81.4
branch 65 98 66.3
condition 42 57 73.6
subroutine 6 6 100.0
pod 0 2 0.0
total 223 298 74.8


line stmt bran cond sub pod time code
1             package Module::List::More;
2              
3             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
4             our $DATE = '2020-09-22'; # DATE
5             our $DIST = 'Module-List-More'; # DIST
6             our $VERSION = '0.004009'; # VERSION
7              
8             #IFUNBUILT
9             # # use strict 'subs', 'vars';
10             # # use warnings;
11             #END IFUNBUILT
12              
13             my $has_globstar;
14              
15             # do our own exporting to start faster
16             sub import {
17 1     1   8 my $pkg = shift;
18 1         4 my $caller = caller;
19 1         3 for my $sym (@_) {
20 1 50       6 if ($sym eq 'list_modules') { *{"$caller\::$sym"} = \&{$sym} }
  1         1  
  1         86504  
  1         3  
21 0         0 else { die "$sym is not exported!" }
22             }
23             }
24              
25             sub list_modules($$) {
26 17     17 0 138086 my($prefix, $options) = @_;
27 17         71 my $trivial_syntax = $options->{trivial_syntax};
28 17         41 my($root_leaf_rx, $root_notleaf_rx);
29 17         0 my($notroot_leaf_rx, $notroot_notleaf_rx);
30 17 50       71 if($trivial_syntax) {
31 0         0 $root_leaf_rx = $notroot_leaf_rx = qr#:?(?:[^/:]+:)*[^/:]+:?#;
32 0         0 $root_notleaf_rx = $notroot_notleaf_rx =
33             qr#:?(?:[^/:]+:)*[^/:]+#;
34             } else {
35 17         78 $root_leaf_rx = $root_notleaf_rx = qr/[a-zA-Z_][0-9a-zA-Z_]*/;
36 17         42 $notroot_leaf_rx = $notroot_notleaf_rx = qr/[0-9a-zA-Z_]+/;
37             }
38              
39 17         27 my $recurse = $options->{recurse};
40              
41             # filter by wildcard. we cannot do this sooner because wildcard can be put
42             # at the end or at the beginning (e.g. '*::Path') so we still need
43 17         42 my $re_wildcard;
44 17 100       46 if ($options->{wildcard}) {
45 8         46 require String::Wildcard::Bash;
46 8         15 my $orig_prefix = $prefix;
47 8         28 my @prefix_parts = split /::/, $prefix;
48 8         14 $prefix = "";
49 8         11 my $has_wildcard;
50 8         37 while (defined(my $part = shift @prefix_parts)) {
51 8 50       30 if (String::Wildcard::Bash::contains_wildcard($part)) {
52 8         299 $has_wildcard++;
53             # XXX limit recurse level to scalar(@prefix_parts), or -1 if has_globstar
54 8 100       20 $recurse = 1 if @prefix_parts;
55 8         17 last;
56             } else {
57 0         0 $prefix .= "$part\::";
58             }
59             }
60 8 50       19 if ($has_wildcard) {
61 8         26 $re_wildcard = convert_wildcard_to_re($orig_prefix);
62             }
63 8 100       23 $recurse = 1 if $has_globstar;
64             }
65              
66 17 50 33     345 die "bad module name prefix `$prefix'"
67             unless $prefix =~ /\A(?:${root_notleaf_rx}::
68             (?:${notroot_notleaf_rx}::)*)?\z/x &&
69             $prefix !~ /(?:\A|[^:]::)\.\.?::/;
70              
71 17         37 my $list_modules = $options->{list_modules};
72 17         24 my $list_prefixes = $options->{list_prefixes};
73 17         28 my $list_pod = $options->{list_pod};
74 17         24 my $use_pod_dir = $options->{use_pod_dir};
75 17 50 66     57 return {} unless $list_modules || $list_prefixes || $list_pod;
      33        
76 17         25 my $return_path = $options->{return_path};
77 17         21 my $return_library_path = $options->{return_library_path};
78 17         28 my $return_version = $options->{return_version};
79 17         26 my $all = $options->{all};
80 17         47 my @prefixes = ($prefix);
81 17         52 my %seen_prefixes;
82             my %results;
83             my $_set_or_add_result = sub {
84 101     101   207 my ($key, $result_field, $val, $always_all) = @_;
85 101 100 100     261 if (!$result_field) {
    100          
86 49   100     204 $results{$key} ||= undef;
87             } elsif ($all || $always_all) {
88 25   100     118 $results{$key}{$result_field} ||= [];
89 25         34 push @{ $results{$key}{$result_field} }, $val;
  25         96  
90             } else {
91             $results{$key}{$result_field} = $val
92 27 100       110 unless exists $results{$key}{$result_field};
93             }
94 17         97 };
95 17         43 while(@prefixes) {
96 45         126 my $prefix = pop(@prefixes);
97 45         129 my @dir_suffix = split(/::/, $prefix);
98 45 100       105 my $module_rx =
99             $prefix eq "" ? $root_leaf_rx : $notroot_leaf_rx;
100 45         533 my $pm_rx = qr/\A($module_rx)\.pmc?\z/;
101 45         401 my $pod_rx = qr/\A($module_rx)\.pod\z/;
102 45 100       103 my $dir_rx =
103             $prefix eq "" ? $root_notleaf_rx : $notroot_notleaf_rx;
104 45         270 $dir_rx = qr/\A$dir_rx\z/;
105 45         111 foreach my $incdir (@INC) {
106 90         309 my $dir = join("/", $incdir, @dir_suffix);
107 90 100       2156 opendir(my $dh, $dir) or next;
108 62         945 while(defined(my $entry = readdir($dh))) {
109 261 100 100     3399 if(($list_modules && $entry =~ $pm_rx) ||
    100 33        
      66        
      100        
      100        
      100        
      100        
      66        
110             ($list_pod &&
111             $entry =~ $pod_rx)) {
112 60         178 my $key = $prefix.$1;
113 60 100 100     387 next if $re_wildcard && $key !~ $re_wildcard;
114 33         81 my $path = "$dir/$entry";
115 33         96 $_set_or_add_result->($key);
116 33 100       93 $_set_or_add_result->($key, 'module_path', $path) if $return_path;
117 33 100       76 $_set_or_add_result->($key, 'library_path', $incdir) if $return_library_path;
118 33 100       168 if ($return_version) {
119 3         17 require ExtUtils::MakeMaker;
120 3         30 my $v = MM->parse_version($path);
121 3 100       706 $v = undef if $v eq 'undef';
122 3         11 $_set_or_add_result->($key, 'module_version', $v);
123             }
124             } elsif(($list_prefixes || $recurse) &&
125             ($entry ne '.' && $entry ne '..') &&
126             $entry =~ $dir_rx &&
127             -d join("/", $dir,
128             $entry)) {
129 40         129 my $newmod = $prefix.$entry;
130 40         85 my $newpfx = $newmod."::";
131 40 50       85 next if exists $seen_prefixes{$newpfx};
132 40 100       78 if ($list_prefixes) {
133 16         43 $_set_or_add_result->($newpfx);
134 16 100       81 $_set_or_add_result->($newpfx, 'prefix_paths', "$dir/$entry/", 'always_add') if $return_path;
135 16 50       35 $_set_or_add_result->($newpfx, 'library_path', $incdir, 'always_add') if $return_library_path;
136             }
137 40 100       189 push @prefixes, $newpfx if $recurse;
138             }
139             }
140 62 50 33     970 next unless $list_pod && $use_pod_dir;
141 0         0 $dir = join("/", $dir, "pod");
142 0 0       0 opendir($dh, $dir) or next;
143 0         0 while(defined(my $entry = readdir($dh))) {
144 0 0       0 if($entry =~ $pod_rx) {
145 0         0 my $key = $prefix.$1;
146 0 0 0     0 next if $re_wildcard && $key !~ $re_wildcard;
147 0         0 $_set_or_add_result->($key);
148 0 0       0 $_set_or_add_result->($key, 'pod_path', "$dir/$entry") if $return_path;
149 0 0       0 $_set_or_add_result->($key, 'library_path', $incdir) if $return_library_path;
150             }
151             }
152             }
153             }
154              
155             # we cannot filter prefixes early with wildcard because we need to dig down
156             # first and that would've been prevented if we had a wildcard like *::Foo.
157 17 100 100     68 if ($list_prefixes && $re_wildcard) {
158 2         8 for my $k (keys %results) {
159 6 50       23 next unless $k =~ /::\z/;
160 6         22 (my $k_nocolon = $k) =~ s/::\z//;
161 6 100 100     46 delete $results{$k} unless $k =~ $re_wildcard || $k_nocolon =~ $re_wildcard;
162             }
163             }
164              
165 17         185 return \%results;
166             }
167              
168             sub convert_wildcard_to_re {
169 8     8 0 14 $has_globstar = 0;
170 8         19 my $re = _convert_wildcard_to_re(@_);
171 8         191 $re = qr/\A$re\z/;
172             #print "DEBUG: has_globstar=<$has_globstar>, re=$re\n";
173 8         23 $re;
174             }
175              
176             # modified from String::Wildcard::Bash 0.040's convert_wildcard_to_re
177             sub _convert_wildcard_to_re {
178 8 50   8   26 my $opts = ref $_[0] eq 'HASH' ? shift : {};
179 8         14 my $str = shift;
180              
181 8   50     34 my $opt_brace = $opts->{brace} // 1;
182              
183 8         16 my @res;
184             my $p;
185 8         62 while ($str =~ /$String::Wildcard::Bash::RE_WILDCARD_BASH/g) {
186 1     1   107661 my %m = %+;
  1         432  
  1         300  
  25         172  
187 25 50       121 if (defined($p = $m{bash_brace_content})) {
    100          
    50          
    100          
    50          
    50          
188             push @res, quotemeta($m{slashes_before_bash_brace}) if
189 0 0       0 $m{slashes_before_bash_brace};
190 0 0       0 if ($opt_brace) {
191 0         0 my @elems;
192 0         0 while ($p =~ /($String::Wildcard::Bash::re_bash_brace_element)(,|\z)/g) {
193 0         0 push @elems, $1;
194 0 0       0 last unless $2;
195             }
196             #use DD; dd \@elems;
197             push @res, "(?:", join("|", map {
198 0         0 convert_wildcard_to_re({
  0         0  
199             bash_brace => 0,
200             }, $_)} @elems), ")";
201             } else {
202 0         0 push @res, quotemeta($m{bash_brace});
203             }
204              
205             } elsif (defined($p = $m{bash_joker})) {
206 10 50       31 if ($p eq '?') {
    100          
    50          
207 0         0 push @res, '[^:]';
208             } elsif ($p eq '*') {
209 9         57 push @res, '[^:]*';
210             } elsif ($p eq '**') {
211 1         2 $has_globstar++;
212 1         9 push @res, '.*';
213             }
214              
215             } elsif (defined($p = $m{literal_brace_single_element})) {
216 0         0 push @res, quotemeta($p);
217             } elsif (defined($p = $m{bash_class})) {
218             # XXX no need to escape some characters?
219 4         41 push @res, $p;
220             } elsif (defined($p = $m{sql_joker})) {
221 0         0 push @res, quotemeta($p);
222             } elsif (defined($p = $m{literal})) {
223 11         75 push @res, quotemeta($p);
224             }
225             }
226              
227 8         35 join "", @res;
228             }
229              
230             1;
231             # ABSTRACT: Module::List, with more options
232              
233             __END__