File Coverage

lib/Submodules.pm
Criterion Covered Total %
statement 91 93 97.8
branch 17 26 65.3
condition 5 9 55.5
subroutine 15 15 100.0
pod 1 4 25.0
total 129 147 87.7


line stmt bran cond sub pod time code
1             package Submodules;
2 2     2   60450 use strict;
  2         5  
  2         51  
3 2     2   8 use warnings;
  2         4  
  2         57  
4 2     2   793 use Submodules::Result ();
  2         7  
  2         57  
5 2     2   15 use File::Spec;
  2         4  
  2         66  
6 2     2   15 use File::Find qw();
  2         5  
  2         51  
7 2     2   13 use Carp;
  2         5  
  2         200  
8 2     2   25 use File::Basename;
  2         5  
  2         339  
9             our $VERSION = '1.0006';
10            
11             my $names;
12            
13             sub import {
14 2     2   28 my $self = shift;
15 2         6 my $pack = caller;
16 2         3 my $name = shift;
17 2 100       27 if (length $name) {
18 2     2   18 no strict 'refs';
  2         5  
  2         2807  
19 1 50       1 croak "Cannot export symbol '&${pack}::$name' because it's already defined" if defined &{"${pack}::$name"};
  1         9  
20 1         2 *{"${pack}::$name"} = \&submodules;
  1         5  
21 1         11 $names->{$pack} = $name;
22             }
23             }
24            
25             sub submodules (;*) {
26 2     2 0 549 my @caller = caller(0);
27 2         5 my $name = 'submodules';
28 2 50       10 if (exists $names->{$caller[0]}) {
29 2 50       9 $name = $names->{$caller[0]} if length $names->{$caller[0]};
30             }
31 2         5 my $usage = "Usage:\n $name name::space\n";
32 2 50       6 croak $usage if @_ > 1;
33 2 50       5 if (not defined wantarray) {
34 0         0 carp "Useless call of '$name' in void context";
35 0         0 return;
36             }
37 2         3 my $query = shift;
38 2 100       7 $query = $caller[0] unless defined $query;
39 2         67 my $self = {
40             list => [],
41             caller_abs => File::Spec->rel2abs($caller[1]),
42             query => $query,
43             seen_paths => {},
44             };
45 2         5 bless $self, __PACKAGE__;
46 2         11 my @members = split/(?:::|')/, $query;
47 2         3 my @inc;
48 2         5 for my $i (@INC) {
49 24         203 my $abs = File::Spec->rel2abs($i);
50 24 50       73 unless (exists $self->{seen_paths}->{$abs}) {
51 24         34 push @inc, $abs;
52 24         63 $self->{seen_paths}->{$abs} = 1;
53             }
54             }
55 2         4 for my $i (@inc) {
56 24         161 my $inc_dir = File::Spec->rel2abs($i);
57 24 100       793 if (-f (my $file = File::Spec->catfile($inc_dir, @members).'.pm')) {
58 4         10 $file = _get_abs_path($file);
59 4         9 my $caller = _get_abs_path($caller[1]);
60 4 50       18 $self->process_file($inc_dir, $file) unless $file eq $caller;
61             }
62 24 50 33     44 return $self->{list}->[0] if @{$self->{list}} and not wantarray;
  24         160  
63 24 100       686 if (-d (my $path = File::Spec->catfile($inc_dir, @members))) {
64 4         11 $self->process_path($inc_dir, $path);
65             }
66             }
67 2         3 @{$self->{list}};
  2         29  
68             };
69            
70             sub find {
71 1     1 1 28 my $self = shift;
72 1         23 goto &submodules;
73             }
74            
75             sub process_path {
76 4     4 0 5 my $self = shift;
77 4         5 my $path_abs = shift;
78 4         16 my $path = shift;
79             File::Find::find (
80             {
81             no_chdir => 1,
82             wanted => sub {
83 28     28   66 $self->process_file($path_abs, $File::Find::name)
84             },
85             },
86 4         301 $path,
87             );
88             }
89            
90             sub process_file {
91 32     32 0 38 my $self = shift;
92 32         34 my $path_abs = shift;
93 32         39 my $file = shift;
94 32 50 66     1318 return unless $file =~ /(\.pm)$/i and -f $file and my $extension = $1;
      66        
95 24         195 my $file_abs = File::Spec->rel2abs($file);
96 24         1475 my $file_rel = File::Spec->abs2rel($file_abs);
97 24         719 my $filename = basename $file_abs;
98 24         127 my @parts_path = File::Spec->splitdir($path_abs);
99 24         127 my @parts = File::Spec->splitdir($file_abs);
100 24         52 splice @parts, 0, scalar @parts_path;
101 24         52 $parts[$#parts] = substr $parts[$#parts], 0, - length $extension;
102 24         50 my $code_path = join '::', @parts;
103 24         46 my $perl_path = join('/', @parts).$extension;
104 24         33 my $name = $parts[$#parts];
105 24         117 push @{$self->{list}}, Submodules::Result->new (
106             Name => $name,
107             AbsPath => $file_abs,
108             RelPath => $file_rel,
109             Path => $perl_path,
110 24         28 Clobber => $self->{seen_paths}->{$name},
111             Module => $code_path,
112             );
113 24         588 $self->{seen_paths}->{$name} = $file_abs;
114             }
115            
116             sub _get_abs_path {
117 8     8   16 my $path = shift;
118 8         50 my @parts = File::Spec->splitdir($path);
119 8         57 my $file = File::Spec->catfile(@parts);
120 8         93 File::Spec->rel2abs($file);
121             }
122            
123             1;
124            
125             __END__