File Coverage

blib/lib/Tangerine.pm
Criterion Covered Total %
statement 91 92 98.9
branch 32 44 72.7
condition 16 43 37.2
subroutine 18 18 100.0
pod 5 7 71.4
total 162 204 79.4


line stmt bran cond sub pod time code
1             package Tangerine;
2             $Tangerine::VERSION = '0.23';
3             # ABSTRACT: Examine perl files and report dependency metadata
4 16     16   193135 use 5.010;
  16         40  
5 16     16   49 use strict;
  16         16  
  16         246  
6 16     16   50 use warnings;
  16         16  
  16         341  
7 16     16   7807 use utf8;
  16         119  
  16         55  
8 16     16   7069 use PPI;
  16         1415858  
  16         524  
9 16     16   102 use Scalar::Util qw(blessed);
  16         18  
  16         606  
10 16     16   5053 use Tangerine::Hook;
  16         28  
  16         339  
11 16     16   5105 use Tangerine::Occurence;
  16         30  
  16         400  
12 16     16   60 use Tangerine::Utils qw(any accessor addoccurence none);
  16         14  
  16         13788  
13              
14             sub new {
15 15     15 1 124 my $class = shift;
16 15         46 my %args = @_;
17             bless {
18             _file => $args{file},
19 15   50     231 _mode => $args{mode} // 'all',
20             _hooks => {
21             package => [ qw/package/ ],
22             compile => [ qw/use list prefixedlist if inline moduleload
23             moduleruntime mooselike testrequires tests xxx/ ],
24             runtime => [ qw/require/ ],
25             },
26             _package => {},
27             _compile => {},
28             _runtime => {},
29             }, $class
30             }
31              
32 30     30 0 88 sub file { accessor _file => @_ }
33 227     227 0 341 sub mode { accessor _mode => @_ }
34              
35 5     5 1 905 sub package { accessor _package => @_ }
36 488     488 1 39262 sub compile { accessor _compile => @_ }
37 177     177 1 9766 sub runtime { accessor _runtime => @_ }
38             # For pre-0.15 compatibility
39             *provides = \&package;
40             *requires = \&runtime;
41             *uses = \&compile;
42              
43             sub run {
44 15     15 1 63 my $self = shift;
45 15 50       35 return 0 unless -r $self->file;
46 15 50       49 $self->mode('all')
47             unless $self->mode =~
48             /^(a(ll)?|p(ackage|rov)?|compile|d(ep)?|r(untime|eq)?|u(se)?)$/;
49 15         36 my $document = PPI::Document->new($self->file, readonly => 1);
50 15 50       79772 return 0 unless $document;
51 15 50       88 my $statements = $document->find('Statement') or return 1;
52 15         20874 my @hooks;
53 15         57 for my $type (qw(package compile runtime)) {
54 45         53 for my $hname (@{$self->{_hooks}->{$type}}) {
  45         118  
55 195         279 my $hook = "Tangerine::hook::$hname";
56 195 50       8354 if (eval "require $hook; 1") {
57 195         1434 push @hooks, $hook->new(type => $type);
58             } else {
59 0         0 warn "Couldn't load the tangerine hook `${hname}'!";
60             }
61             }
62             }
63             @hooks = grep {
64 15 50 0     35 if ($self->mode =~ /^a/o ||
  195   33     225  
      0        
      0        
      0        
      0        
65             $_->type eq 'package' && $self->mode =~ /^p/o ||
66             $_->type eq 'compile' && $self->mode =~ /^[cdu]/o ||
67             $_->type eq 'runtime' && $self->mode =~ /^[dr]/o) {
68 195         671 $_
69             }
70             } @hooks;
71 15         30 my $children;
72             my $forcetype;
73 15         39 STATEMENT: for my $statement (@$statements) {
74 159   100     599 $children //= [ $statement->schildren ];
75 159 100 100     1805 if ($children->[1] &&
      66        
76             ($children->[1] eq ',' || $children->[1] eq '=>')) {
77 17         209 undef $children;
78             next STATEMENT
79 17         30 }
80 142         2368 for my $hook (@hooks) {
81 1894 100       3319 if (my $data = $hook->run($children)) {
82 190         329 my $modules = $data->modules;
83 190 50   176   763 undef %$modules if any { $_ eq '->' } keys %$modules;
  176         280  
84 190         423 for my $k (keys %$modules) {
85 176 100 66     1008 if ($k !~ m/^[a-z_][a-z0-9_]*(?:::[a-z0-9_]+)*(?:::)?$/io ||
86             $k =~ m/^__[A-Z]+__$/o) {
87 8         9 delete $modules->{$k};
88             next
89 8         9 }
90 168 100       298 if (my ($class) = ($k =~ /^(.+)::$/o)) {
91             $modules->{$class} = $modules->{$k}
92 1 50       4 unless exists $modules->{$class};
93 1         2 delete $modules->{$k};
94 1         1 $k = $class
95             }
96 168         460 $modules->{$k}->line($statement->line_number);
97             }
98 190   66     612 my $type = $forcetype // $hook->type;
99 190 100       412 if ($type eq 'package') {
    100          
    50          
100 1         5 $self->package(addoccurence($self->package, $modules));
101             } elsif ($type eq 'compile') {
102 138         220 $self->compile(addoccurence($self->compile, $modules));
103             } elsif ($type eq 'runtime') {
104 51         85 $self->runtime(addoccurence($self->runtime, $modules));
105             }
106 190 100       145 if (@{$data->hooks}) {
  190         307  
107 17         17 for my $newhook (@{$data->hooks}) {
  17         29  
108 17 50 33     43 next if ($newhook->type eq 'package') && ($self->mode =~ /^[dcru]/o);
109 17 50 33     28 next if ($newhook->type eq 'runtime') && ($self->mode =~ /^[pcu]/o);
110 17 50 33     31 next if ($newhook->type eq 'compile') && ($self->mode =~ /^[pr]/o);
111             push @hooks, $newhook
112             if none {
113 232 100   232   687 blessed($newhook) eq blessed($_) &&
114             $newhook->type eq $_->type
115 17 100       74 } @hooks;
116             }
117             }
118 190 100       130 if (@{$data->children}) {
  190         277  
119 22         29 $children = $data->children;
120 22         37 $forcetype = $data->type;
121 22         79 redo STATEMENT;
122             }
123             }
124             }
125 120         193 undef $children,
126             undef $forcetype;
127             }
128 15         576 1;
129             }
130              
131             1;
132              
133             __END__