File Coverage

blib/lib/App/findeps.pm
Criterion Covered Total %
statement 95 133 71.4
branch 41 86 47.6
condition 18 55 32.7
subroutine 16 18 88.8
pod 0 5 0.0
total 170 297 57.2


line stmt bran cond sub pod time code
1             package App::findeps;
2              
3 2     2   2651 use strict;
  2         12  
  2         58  
4 2     2   10 use warnings;
  2         5  
  2         54  
5 2     2   10 use feature qw(state);
  2         3  
  2         293  
6              
7             our $VERSION = "0.12";
8              
9 2     2   13 use Carp qw(carp croak);
  2         12  
  2         168  
10 2     2   1080 use ExtUtils::Installed;
  2         241036  
  2         93  
11 2     2   16 use List::Util qw(first);
  2         5  
  2         197  
12              
13 2     2   7925 use Module::CoreList;
  2         300212  
  2         29  
14 2     2   3899 use Directory::Iterator;
  2         9208  
  2         4181  
15              
16             our $Upgrade = 0;
17             our $myLib = 'lib';
18             our $toCpanfile = 0;
19             my $RE = qr/\w+\.((?i:p[ml]|t|cgi|psgi))$/;
20             my $qr4name = qr/[a-zA-Z][a-zA-Z\d]+(?:::[a-zA-Z\d]+){0,}/;
21              
22             sub scanDir { # To Do
23 0   0 0 0 0 my $dir = shift || $myLib || 'lib';
24 0 0       0 die "$dir is not a directory" unless -d $dir;
25              
26 0         0 my @list = ();
27 0         0 my $list = Directory::Iterator->new($dir);
28 0         0 while ( $list->next ) {
29 0         0 my $file = $list->get;
30 0 0       0 next unless $file =~ /\.p[lm]$/;
31 0         0 scan( file => $file, list => \@list );
32             }
33 0         0 return @list;
34             }
35              
36             sub scan {
37 1     1 0 685 my %args = @_;
38 1         3 my %pairs;
39 1         3 while ( my $file = shift @{ $args{files} } ) {
  2         19  
40 1         15 $file =~ $RE;
41 1   33     9 my $ext = $1 || croak 'Unvalid extension was set';
42 1 50       61 open my $fh, '<', $file or die "Can't open < $file: $!";
43 1         41 while (<$fh>) {
44 9         24 chomp;
45 9 50       22 next unless defined $_;
46 9 50       27 last if /^__(?:END|DATA)__$/;
47 9         12 state( $pod, $here, $eval );
48 9 50 33     23 next if $pod and $_ ne '=cut';
49 9 50 33     26 next if $here and $_ ne $here;
50 9 50 33     81 if ( !$pod and /^=(\w+)/ ) {
    50 33        
51 0         0 $pod = $1;
52 0         0 next;
53             } elsif ( $pod and $_ eq '=cut' ) {
54 0         0 undef $pod;
55 0         0 next;
56             }
57 9 50 33     57 if ( !$here and my @catch = /(?:<<(['"])?(\w+)\1?){1,}/g ) {
    50 33        
58 0         0 $here = $catch[-1];
59 0         0 next;
60             } elsif ( $here and $_ eq $here ) {
61 0         0 undef $here;
62 0         0 next;
63             }
64 9 50       28 next if /^\s*#.*/;
65 9         22 s/\s+#.*$//;
66 9 50 33     60 if ( !$eval and /eval\s*(['"{])$/ ) {
    50 33        
    50 33        
67 0 0       0 $eval = $1 eq '{' ? '}' : $1;
68             } elsif ( $eval and /$eval(?:.*)?;$/ ) {
69 0         0 undef $eval;
70 0         0 next;
71             } elsif ( $eval and /\b(require|use)\s+($qr4name)/ ) {
72 0         0 warnIgnored( $2, $1, 'eval' );
73             }
74 9         13 state $if = 0;
75 9 50 33     48 if (/^\b(?:if|unless)\s*\(.*\)\s*{$/) {
    50 33        
    50          
76 0         0 $if++;
77             } elsif ( $if > 0 and /^\s*}$/ ) {
78 0         0 $if--;
79 0         0 next;
80             } elsif ( $if > 0 and /^\b(require|use)\s+($qr4name)/ ) {
81 0         0 warnIgnored( $2, $1, 'if' );
82             }
83 9 50 33     36 next if $eval or $if;
84 9         24 scan_line( \%pairs, $_ );
85             }
86 1         27 close $fh;
87             }
88 1         3 my $deps = {};
89 1         3 my @local = ();
90 1         12 my $list = Directory::Iterator->new($myLib);
91 1         730 while ( $list->next ) {
92 1         12 my $file = $list->get;
93 1 50       15 next unless $file =~ s/\.p[lm]$//;
94 1         9 $file =~ s|/|::|g;
95 1         54 push @local, $file;
96             }
97              
98 1         13 while ( my ( $name, $version ) = each %pairs ) {
99 2 50       6 next if !defined $name;
100 2 50       7 next if exists $deps->{$name};
101 2 50   2   14 next if first { $_ eq $name } @local;
  2         7  
102 2 50 66     23 $deps->{$name} = $version if !defined $version or $Upgrade or $toCpanfile;
      33        
103             }
104 1         18 return $deps;
105             }
106              
107             # subroutines #----#----#----#----#----#----#----#----#----#----#----#----#
108             my @pragmas = qw(
109             attributes autodie autouse
110             base bigint bignum bigrat blib bytes
111             charnames constant diagnostics encoding
112             feature fields filetest if integer less lib locale mro
113             open ops overload overloading parent re
114             sigtrap sort strict subs
115             threads threads::shared utf8 vars vmsish
116             warnings warnings::register
117             );
118              
119             sub scan_line {
120 9     9 0 16 my $pairs = shift;
121 9         21 local $_ = shift;
122 9         17 my @names = ();
123 9 50       21 return if /^\b(?:require|use)\s+5\.\d{3}_?\d{3};$/;
124 9 50 33     468 if (/use\s+(?:base|parent)\s+qw[\("']\s*((?:$qr4name\s*){1,})[\)"']/) {
    50          
    50          
    50          
    100          
    50          
    50          
125 0         0 push @names, split /\s+/, $1;
126             } elsif (/use\s+(?:base|parent|autouse)\s+(['"])?($qr4name)\1?/) {
127 0         0 $names[0] = $2;
128             } elsif (/eval\s*(['"{])\s*(require|use)\s+($qr4name).*(?:\1|})/) {
129 0         0 warnIgnored( $3, $2, 'eval' );
130             } elsif ( /(?:if|unless)\s+\(.*\)\s*\{.*require\s+($qr4name).*\}/
131             or /require\s+($qr4name)\s+(?:if|unless)\s+\(?.*\)?/ )
132             {
133 0         0 warnIgnored( $1, 'require', 'if' );
134             } elsif (/^\s*(?:require|use)\s+($qr4name)/) {
135 5         32 $names[0] = $1;
136             } elsif (m!^\s*require\s*(["'])((?:\./)?(?:\w+/){0,}$qr4name\.pm)\1!) {
137 0         0 $names[0] = _name($2);
138             } elsif (/^\s*(require|use)\s+(['"]?)(.*)\2/) {
139 0         0 my $name = $3;
140 0 0       0 my $exists = ( -e "$myLib/$name" ) ? 'exists' : "does not exist in $myLib";
141 0         0 warn "just detected but not listed: $name($exists) $1d\n";
142             }
143 9         27 for my $name (@names) {
144 5 50       14 next unless defined $name;
145 5 50       13 next if exists $pairs->{$name};
146 5 50       12 next if $name eq 'Plack::Builder';
147 5 100   167   36 next if first { $name eq $_ } @pragmas;
  167         205  
148 2 50 33     12 next if $Upgrade and Module::CoreList->is_core($name);
149 2         9 $pairs->{$name} = get_version($name);
150             }
151 9         79 return %$pairs;
152             }
153              
154             sub get_version {
155 2     2 0 5 my $name = shift;
156 2         19 my $installed = ExtUtils::Installed->new( skip_cwd => 1 );
157 2     62   492353 my $module = first { $_ eq $name } $installed->modules();
  62         392  
158 2         18 my $version = eval { $installed->version($module) };
  2         14  
159 2 100       2376 return "$version" if $version;
160 1 50   1   618 eval "use lib '$myLib'; require $name" or return undef;
  1         800  
  1         10  
  1         125  
161 0   0     0 return eval "no strict 'subs';\$${name}::VERSION" || 0;
162             }
163              
164             sub warnIgnored {
165 0     0 0 0 my $name = shift;
166 0         0 my $func = shift;
167 0         0 my $cmd = shift;
168 0 0       0 warn "$name is ${func}d inside of '$cmd'\n" unless Module::CoreList->is_core($name);
169             }
170              
171             sub _name {
172 1     1   21 my $str = shift;
173 1 50       8 $str =~ s!/!::!g if $str =~ /\.pm$/;
174 1         4 $str =~ s!^lib::!!;
175 1         6 $str =~ s!.pm$!!i;
176 1         3 $str =~ s!^auto::(.+)::.*!$1!;
177 1         3 return $str;
178             }
179              
180             1;
181              
182             __END__