File Coverage

blib/lib/Perl/Critic/Document.pm
Criterion Covered Total %
statement 262 299 87.6
branch 86 130 66.1
condition 39 57 68.4
subroutine 50 53 94.3
pod 21 21 100.0
total 458 560 81.7


line stmt bran cond sub pod time code
1             package Perl::Critic::Document;
2              
3 40     40   4513 use 5.010001;
  40         172  
4 40     40   273 use strict;
  40         126  
  40         915  
5 40     40   253 use warnings;
  40         111  
  40         1328  
6              
7 40     40   271 use Carp qw< confess >;
  40         176  
  40         2462  
8              
9 40     40   322 use List::Util qw< reduce >;
  40         122  
  40         2931  
10 40     40   340 use Scalar::Util qw< blessed refaddr weaken >;
  40         124  
  40         2683  
11 40     40   298 use version;
  40         125  
  40         399  
12              
13 40     40   4537 use PPI::Document;
  40         120955  
  40         1586  
14 40     40   301 use PPI::Document::File;
  40         127  
  40         2300  
15 40     40   21098 use PPIx::Utilities::Node qw< split_ppi_node_by_namespace >;
  40         107306  
  40         833  
16              
17 40     40   20058 use Perl::Critic::Annotation;
  40         174  
  40         1676  
18 40     40   16585 use Perl::Critic::Exception::Parse qw< throw_parse >;
  40         146  
  40         818  
19 40     40   2446 use Perl::Critic::Utils qw< :booleans :characters hashify shebang_line >;
  40         122  
  40         1862  
20              
21 40     40   9871 use PPIx::Regexp 0.010 qw< >;
  40         1332  
  40         121590  
22              
23             #-----------------------------------------------------------------------------
24              
25             our $VERSION = '1.146';
26              
27             #-----------------------------------------------------------------------------
28              
29             our $AUTOLOAD;
30             sub AUTOLOAD { ## no critic (ProhibitAutoloading,ArgUnpacking)
31 13939     13939   125819 my ( $function_name ) = $AUTOLOAD =~ m/ ([^:\']+) \z /xms;
32 13939 100       51777 return if $function_name eq 'DESTROY';
33 11156         19164 my $self = shift;
34 11156         44153 return $self->{_doc}->$function_name(@_);
35             }
36              
37             #-----------------------------------------------------------------------------
38              
39             sub new {
40 2780     2780 1 51525 my ($class, @args) = @_;
41              
42 2780         7087 my $self = bless {}, $class;
43              
44 2780         9742 $self->_init_common();
45 2780         8324 $self->_init_from_external_source(@args);
46              
47 2780         10184 return $self;
48             }
49              
50             #-----------------------------------------------------------------------------
51              
52             sub _new_for_parent_document {
53 4     4   9 my ($class, $ppi_document, $parent_document) = @_;
54              
55 4         7 my $self = bless {}, $class;
56              
57 4         11 $self->_init_common();
58              
59 4         8 $self->{_doc} = $ppi_document;
60 4         11 $self->{_is_module} = $parent_document->is_module();
61              
62 4         14 return $self;
63             }
64              
65             #-----------------------------------------------------------------------------
66              
67             sub _init_common {
68 2784     2784   5537 my ($self) = @_;
69              
70 2784         6783 $self->{_annotations} = [];
71 2784         6251 $self->{_suppressed_violations} = [];
72 2784         5247 $self->{_disabled_line_map} = {};
73              
74 2784         4705 return;
75             }
76              
77             #-----------------------------------------------------------------------------
78              
79             sub _init_from_external_source { ## no critic (Subroutines::RequireArgUnpacking)
80 2780     2780   5475 my $self = shift;
81 2780         4986 my %args;
82              
83 2780 50       6748 if (@_ == 1) {
84 0         0 warnings::warnif(
85             'deprecated',
86             'Perl::Critic::Document->new($source) deprecated, use Perl::Critic::Document->new(-source => $source) instead.' ## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars)
87             );
88 0         0 %args = ('-source' => shift);
89             } else {
90 2780         8888 %args = @_;
91             }
92              
93 2780         5760 my $source_code = $args{'-source'};
94              
95             # $source_code can be a file name, or a reference to a
96             # PPI::Document, or a reference to a scalar containing source
97             # code. In the last case, PPI handles the translation for us.
98              
99 2780 100       7041 my $ppi_document =
    100          
100             _is_ppi_doc($source_code)
101             ? $source_code
102             : ref $source_code
103             ? PPI::Document->new($source_code)
104             : PPI::Document::File->new($source_code);
105              
106             # Bail on error
107 2780 50       16776005 if (not defined $ppi_document) {
108 0         0 my $errstr = PPI::Document::errstr();
109 0 0       0 my $file = ref $source_code ? undef : $source_code;
110 0         0 throw_parse
111             message => qq<Can't parse code: $errstr>,
112             file_name => $file;
113             }
114              
115 2780         9495 $self->{_doc} = $ppi_document;
116 2780         20818 $self->index_locations();
117 2780         3687346 $self->_disable_shebang_fix();
118 2780         9133 $self->{_filename_override} = $args{'-filename-override'};
119 2780         9359 $self->{_is_module} = $self->_determine_is_module(\%args);
120              
121 2780         8677 return;
122             }
123              
124             #-----------------------------------------------------------------------------
125              
126             sub _is_ppi_doc {
127 2780     2780   5831 my ($ref) = @_;
128 2780   66     25166 return blessed($ref) && $ref->isa('PPI::Document');
129             }
130              
131             #-----------------------------------------------------------------------------
132              
133             sub ppi_document {
134 13     13 1 32 my ($self) = @_;
135 13         38 return $self->{_doc};
136             }
137              
138             #-----------------------------------------------------------------------------
139              
140             sub isa { ## no critic ( Subroutines::ProhibitBuiltinHomonyms )
141 21     21 1 1657 my ($self, @args) = @_;
142             return $self->SUPER::isa(@args)
143 21   66     216 || ( (ref $self) && $self->{_doc} && $self->{_doc}->isa(@args) );
144             }
145              
146             #-----------------------------------------------------------------------------
147              
148             sub find {
149 19402     19402 1 40453 my ($self, $wanted, @more_args) = @_;
150              
151             # This method can only find elements by their class names. For
152             # other types of searches, delegate to the PPI::Document
153 19402 100 100     115811 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
      100        
154 130         631 return $self->{_doc}->find($wanted, @more_args);
155             }
156              
157             # Build the class cache if it doesn't exist. This happens at most
158             # once per Perl::Critic::Document instance. %elements of will be
159             # populated as a side-effect of calling the $finder_sub coderef
160             # that is produced by the caching_finder() closure.
161 19272 100       46812 if ( !$self->{_elements_of} ) {
162              
163 2738         10717 my %cache = ( 'PPI::Document' => [ $self ] );
164              
165             # The cache refers to $self, and $self refers to the cache. This
166             # creates a circular reference that leaks memory (i.e. $self is not
167             # destroyed until execution is complete). By weakening the reference,
168             # we allow perl to collect the garbage properly.
169 2738         12246 weaken( $cache{'PPI::Document'}->[0] );
170              
171 2738         7565 my $finder_coderef = _caching_finder( \%cache );
172 2738         11851 $self->{_doc}->find( $finder_coderef );
173 2738         63520 $self->{_elements_of} = \%cache;
174             }
175              
176             # find() must return false-but-defined on fail
177 19272   100     91315 return $self->{_elements_of}->{$wanted} || q{};
178             }
179              
180             #-----------------------------------------------------------------------------
181              
182             sub find_first {
183 312     312 1 4706 my ($self, $wanted, @more_args) = @_;
184              
185             # This method can only find elements by their class names. For
186             # other types of searches, delegate to the PPI::Document
187 312 100 100     1701 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
      100        
188 198         853 return $self->{_doc}->find_first($wanted, @more_args);
189             }
190              
191 114         341 my $result = $self->find($wanted);
192 114 100       581 return $result ? $result->[0] : $result;
193             }
194              
195             #-----------------------------------------------------------------------------
196              
197             sub find_any {
198 4     4 1 2801 my ($self, $wanted, @more_args) = @_;
199              
200             # This method can only find elements by their class names. For
201             # other types of searches, delegate to the PPI::Document
202 4 100 100     32 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
      100        
203 3         20 return $self->{_doc}->find_any($wanted, @more_args);
204             }
205              
206 1         5 my $result = $self->find($wanted);
207 1 50       8 return $result ? 1 : $result;
208             }
209              
210             #-----------------------------------------------------------------------------
211              
212             sub namespaces {
213 2     2 1 539 my ($self) = @_;
214              
215 2         4 return keys %{ $self->_nodes_by_namespace() };
  2         6  
216             }
217              
218             #-----------------------------------------------------------------------------
219              
220             sub subdocuments_for_namespace {
221 0     0 1 0 my ($self, $namespace) = @_;
222              
223 0         0 my $subdocuments = $self->_nodes_by_namespace()->{$namespace};
224              
225 0 0       0 return $subdocuments ? @{$subdocuments} : ();
  0         0  
226             }
227              
228             #-----------------------------------------------------------------------------
229              
230             sub ppix_regexp_from_element {
231 354     354 1 792 my ( $self, $element ) = @_;
232              
233 354 50 33     2958 if ( blessed( $element ) && $element->isa( 'PPI::Element' ) ) {
234 354         909 my $addr = refaddr( $element );
235             return $self->{_ppix_regexp_from_element}{$addr}
236 354 50       1382 if exists $self->{_ppix_regexp_from_element}{$addr};
237 354         1086 return ( $self->{_ppix_regexp_from_element}{$addr} =
238             PPIx::Regexp->new( $element,
239             default_modifiers =>
240             $self->_find_use_re_modifiers_in_scope_from_element(
241             $element ),
242             ) );
243             } else {
244 0         0 return PPIx::Regexp->new( $element );
245             }
246             }
247              
248             sub _find_use_re_modifiers_in_scope_from_element {
249 354     354   637 my ( $self, $elem ) = @_;
250 354         514 my @found;
251 354 100       476 foreach my $use_re ( @{ $self->find( 'PPI::Statement::Include' ) || [] } )
  354         976  
252             {
253 23 100       109 're' eq $use_re->module()
254             or next;
255 15 100       497 $self->element_is_in_lexical_scope_after_statement_containing(
256             $elem, $use_re )
257             or next;
258 12 100       301 my $prefix = 'no' eq $use_re->type() ? q{-} : $EMPTY;
259             push @found,
260 12         53 map { "$prefix$_" }
261 48         155 grep { m{ \A / }smx }
262             map {
263 12 100       338 $_->isa( 'PPI::Token::Quote' ) ? $_->string() :
  48 100       1029  
264             $_->isa( 'PPI::Token::QuoteLike::Words' ) ? $_->literal() :
265             $_->content() }
266             $use_re->schildren();
267             }
268 354         2264 return \@found;
269             }
270              
271             #-----------------------------------------------------------------------------
272              
273             # This got hung on the Perl::Critic::Document, rather than living in
274             # Perl::Critic::Utils::PPI, because of the possibility that caching of scope
275             # objects would turn out to be desirable.
276              
277             sub element_is_in_lexical_scope_after_statement_containing {
278 15     15 1 40 my ( $self, $inner_elem, $outer_elem ) = @_;
279              
280             # If the outer element defines a scope, we're true if and only if
281             # the outer element contains the inner element, and the inner
282             # element is not somewhere that is hidden from the scope.
283 15 50       79 if ( $outer_elem->scope() ) {
284 0         0 return _inner_element_is_in_outer_scope_really(
285             $inner_elem, $outer_elem );
286             }
287              
288             # In the more general case:
289              
290             # The last element of the statement containing the outer element
291             # must be before the inner element. If not, we know we're false,
292             # without walking the parse tree.
293              
294 15 50       64 my $stmt = $outer_elem->statement()
295             or return;
296              
297 15         236 my $last_elem = $stmt;
298 15         66 while ( $last_elem->isa( 'PPI::Node' ) ) {
299 15 50       67 $last_elem = $last_elem->last_element()
300             or return;
301             }
302              
303 15 50       155 my $stmt_loc = $last_elem->location()
304             or return;
305              
306 15 50       265 my $inner_loc = $inner_elem->location()
307             or return;
308              
309 15 50       208 $stmt_loc->[0] > $inner_loc->[0]
310             and return;
311 15 50 33     57 $stmt_loc->[0] == $inner_loc->[0]
312             and $stmt_loc->[1] >= $inner_loc->[1]
313             and return;
314              
315             # Since we know the inner element is after the outer element, find
316             # the element that defines the scope of the statement that contains
317             # the outer element.
318              
319 15         32 my $parent = $stmt;
320 15         64 while ( ! $parent->scope() ) {
321             # Things appearing in the right-hand side of a
322             # PPI::Statement::Variable are not in-scope to its left-hand
323             # side. RESTRICTION -- this code does not handle truly
324             # pathological stuff like
325             # my ( $c, $d ) = qw{ e f };
326             # my ( $a, $b ) = my ( $c, $d ) = ( $c, $d );
327 15 50 33     53 _inner_is_defined_by_outer( $inner_elem, $parent )
328             and _location_is_in_right_hand_side_of_assignment(
329             $parent, $inner_elem )
330             and return;
331 15 50       57 $parent = $parent->parent()
332             or return;
333             }
334              
335             # We're true if and only if the scope of the outer element contains
336             # the inner element.
337              
338 15         175 return $inner_elem->descendant_of( $parent );
339              
340             }
341              
342             # Helper for element_is_in_lexical_scope_after_statement_containing().
343             # Return true if and only if $outer_elem is a statement that defines
344             # variables and $inner_elem is actually a variable defined in that
345             # statement.
346             sub _inner_is_defined_by_outer {
347 15     15   51 my ( $inner_elem, $outer_elem ) = @_;
348 15 50 33     128 $outer_elem->isa( 'PPI::Statement::Variable' )
349             and $inner_elem->isa( 'PPI::Token::Symbol' )
350             or return;
351 0         0 my %defines = hashify( $outer_elem->variables() );
352 0         0 return $defines{$inner_elem->symbol()};
353             }
354              
355             # Helper for element_is_in_lexical_scope_after_statement_containing().
356             # Given that the outer element defines a scope, there are still things
357             # that are lexically inside it but outside the scope. We return true if
358             # and only if the inner element is inside the outer element, but not
359             # inside one of the excluded elements. The cases handled so far:
360             # for ----- the list is not part of the scope
361             # foreach - the list is not part of the scope
362              
363             sub _inner_element_is_in_outer_scope_really {
364 0     0   0 my ( $inner_elem, $outer_elem ) = @_;
365 0 0       0 $outer_elem->scope()
366             or return;
367 0 0       0 $inner_elem->descendant_of( $outer_elem )
368             or return;
369 0 0       0 if ( $outer_elem->isa( 'PPI::Statement::Compound' ) ) {
370 0 0       0 my $first = $outer_elem->schild( 0 )
371             or return;
372 0 0       0 if ( { for => 1, foreach => 1 }->{ $first->content() } ) {
373 0         0 my $next = $first;
374 0         0 while ( $next = $next->snext_sibling() ) {
375 0 0       0 $next->isa( 'PPI::Structure::List' )
376             or next;
377 0         0 return ! $inner_elem->descendant_of( $next );
378             }
379             }
380             }
381 0         0 return $TRUE;
382             }
383              
384             # Helper for element_is_in_lexical_scope_after_statement_containing().
385             # Given and element that represents an assignment or assignment-ish
386             # statement, and a location, return true if the location is to the right
387             # of the equals sign, and false otherwise (including the case where
388             # there is no equals sign). Only the leftmost equals is considered. This
389             # is a restriction.
390             sub _location_is_in_right_hand_side_of_assignment {
391 0     0   0 my ( $elem, $inner_elem ) = @_;
392 0         0 my $inner_loc = $inner_elem->location();
393 0         0 my $kid = $elem->schild( 0 );
394 0         0 while ( $kid ) {
395 0 0 0     0 $kid->isa( 'PPI::Token::Operator' )
396             and q{=} eq $kid->content()
397             or next;
398 0         0 my $l = $kid->location();
399 0 0       0 $l->[0] > $inner_loc->[0]
400             and return;
401 0 0 0     0 $l->[0] == $inner_loc->[0]
402             and $l->[1] >= $inner_loc->[1]
403             and return;
404 0         0 return $inner_elem->descendant_of( $elem );
405             } continue {
406 0         0 $kid = $kid->snext_sibling();
407             }
408 0         0 return;
409             }
410              
411             #-----------------------------------------------------------------------------
412              
413             sub filename {
414 2872     2872 1 6467 my ($self) = @_;
415              
416 2872 100       8142 if (defined $self->{_filename_override}) {
417 2         16 return $self->{_filename_override};
418             }
419             else {
420 2870         6078 my $doc = $self->{_doc};
421 2870 50       15078 return $doc->can('filename') ? $doc->filename() : undef;
422             }
423             }
424              
425             #-----------------------------------------------------------------------------
426              
427             sub highest_explicit_perl_version {
428 234     234 1 556 my ($self) = @_;
429              
430             my $highest_explicit_perl_version =
431 234         538 $self->{_highest_explicit_perl_version};
432              
433 234 100       1107 if ( not exists $self->{_highest_explicit_perl_version} ) {
434 93         331 my $includes = $self->find( \&_is_a_version_statement );
435              
436 93 100       1334 if ($includes) {
437             # Note: this doesn't use List::Util::max() because that function
438             # doesn't use the overloaded ">=" etc of a version object. The
439             # reduce() style lets version.pm take care of all comparing.
440             #
441             # For reference, max() ends up looking at the string converted to
442             # an NV, or something like that. An underscore like "5.005_04"
443             # provokes a warning and is chopped off at "5.005" thus losing the
444             # minor part from the comparison.
445             #
446             # An underscore "5.005_04" is supposed to mean an alpha release
447             # and shouldn't be used in a perl version. But it's shown in
448             # perlfunc under "use" (as a number separator), and appears in
449             # several modules supplied with perl 5.10.0 (like version.pm
450             # itself!). At any rate if version.pm can understand it then
451             # that's enough for here.
452             $highest_explicit_perl_version =
453 4 100   4   107 reduce { $a >= $b ? $a : $b }
454 16         147 map { version->new( $_->version() ) }
455 12         64 @{$includes};
  12         37  
456             }
457             else {
458 81         165 $highest_explicit_perl_version = undef;
459             }
460              
461             $self->{_highest_explicit_perl_version} =
462 93         794 $highest_explicit_perl_version;
463             }
464              
465 234 100       770 return $highest_explicit_perl_version if $highest_explicit_perl_version;
466 222         612 return;
467             }
468              
469             #-----------------------------------------------------------------------------
470              
471             sub uses_module {
472 468     468 1 802 my ($self, $module_name) = @_;
473              
474 468         844 return exists $self->_modules_used()->{$module_name};
475             }
476              
477             #-----------------------------------------------------------------------------
478              
479             sub process_annotations {
480 2721     2721 1 5122 my ($self) = @_;
481              
482 2721         11345 my @annotations = Perl::Critic::Annotation->create_annotations($self);
483 2721         10190 $self->add_annotation(@annotations);
484 2721         7701 return $self;
485             }
486              
487             #-----------------------------------------------------------------------------
488              
489             sub line_is_disabled_for_policy {
490 3171     3171 1 7598 my ($self, $line, $policy) = @_;
491 3171   33     9074 my $policy_name = ref $policy || $policy;
492              
493             # HACK: These two policies are special. If they are active, they cannot be
494             # disabled by a "## no critic" annotation. Rather than create a general
495             # hook in Policy.pm for enabling this behavior, we chose to hack
496             # it here, since this isn't the kind of thing that most policies do.
497              
498 3171 100       6849 return 0 if $policy_name eq
499             'Perl::Critic::Policy::Miscellanea::ProhibitUnrestrictedNoCritic';
500 3158 50       6682 return 0 if $policy_name eq
501             'Perl::Critic::Policy::Miscellanea::ProhibitUselessNoCritic';
502              
503 3158 100       13194 return 1 if $self->{_disabled_line_map}->{$line}->{$policy_name};
504 3064 100       7140 return 1 if $self->{_disabled_line_map}->{$line}->{ALL};
505 3025         8068 return 0;
506             }
507              
508             #-----------------------------------------------------------------------------
509              
510             sub add_annotation {
511 2721     2721 1 6945 my ($self, @annotations) = @_;
512              
513             # Add annotation to our private map for quick lookup
514 2721         5960 for my $annotation (@annotations) {
515              
516 89         253 my ($start, $end) = $annotation->effective_range();
517 89 100       295 my @affected_policies = $annotation->disables_all_policies ?
518             qw(ALL) : $annotation->disabled_policies();
519              
520             # TODO: Find clever way to do this with hash slices
521 89         257 for my $line ($start .. $end) {
522 369         575 for my $policy (@affected_policies) {
523 1452         2958 $self->{_disabled_line_map}->{$line}->{$policy} = 1;
524             }
525             }
526             }
527              
528 2721         4848 push @{ $self->{_annotations} }, @annotations;
  2721         6332  
529 2721         5360 return $self;
530             }
531              
532             #-----------------------------------------------------------------------------
533              
534             sub annotations {
535 6     6 1 18 my ($self) = @_;
536 6         14 return @{ $self->{_annotations} };
  6         29  
537             }
538              
539             #-----------------------------------------------------------------------------
540              
541             sub add_suppressed_violation {
542 133     133 1 275 my ($self, $violation) = @_;
543 133         200 push @{$self->{_suppressed_violations}}, $violation;
  133         320  
544 133         252 return $self;
545             }
546              
547             #-----------------------------------------------------------------------------
548              
549             sub suppressed_violations {
550 1     1 1 2 my ($self) = @_;
551 1         3 return @{ $self->{_suppressed_violations} };
  1         14  
552             }
553              
554             #-----------------------------------------------------------------------------
555              
556             sub is_program {
557 37     37 1 105 my ($self) = @_;
558              
559 37         125 return not $self->is_module();
560             }
561              
562             #-----------------------------------------------------------------------------
563              
564             sub is_module {
565 247     247 1 486 my ($self) = @_;
566              
567 247         937 return $self->{_is_module};
568             }
569              
570             #-----------------------------------------------------------------------------
571             # PRIVATE functions & methods
572              
573             sub _is_a_version_statement {
574 5003     5003   47742 my (undef, $element) = @_;
575              
576 5003 100       15001 return 0 if not $element->isa('PPI::Statement::Include');
577 94 100       465 return 1 if $element->version();
578 78         2145 return 0;
579             }
580              
581             #-----------------------------------------------------------------------------
582              
583             sub _caching_finder {
584 2738     2738   4743 my $cache_ref = shift; # These vars will persist for the life
585 2738         4958 my %isa_cache = (); # of the code ref that this sub returns
586              
587              
588             # Gather up all the PPI elements and sort by @ISA. Note: if any
589             # instances used multiple inheritance, this implementation would
590             # lead to multiple copies of $element in the $elements_of lists.
591             # However, PPI::* doesn't do multiple inheritance, so we are safe
592              
593             return sub {
594 139354     139354   1472264 my (undef, $element) = @_;
595 139354         217559 my $classes = $isa_cache{ref $element};
596 139354 100       243478 if ( !$classes ) {
597 24674         48721 $classes = [ ref $element ];
598             # Use a C-style loop because we append to the classes array inside
599 24674         39188 for ( my $i = 0; $i < @{$classes}; $i++ ) { ## no critic(ProhibitCStyleForLoops)
  110282         196417  
600 40     40   433 no strict 'refs'; ## no critic(ProhibitNoStrict)
  40         137  
  40         32924  
601 85608         103676 push @{$classes}, @{"$classes->[$i]::ISA"};
  85608         109863  
  85608         280083  
602 85608   100     249008 $cache_ref->{$classes->[$i]} ||= [];
603             }
604 24674         44426 $isa_cache{$classes->[0]} = $classes;
605             }
606              
607 139354         173588 for my $class ( @{$classes} ) {
  139354         211246  
608 450698         539077 push @{$cache_ref->{$class}}, $element;
  450698         795971  
609             }
610              
611 139354         242054 return 0; # 0 tells find() to keep traversing, but not to store this $element
612 2738         16333 };
613             }
614              
615             #-----------------------------------------------------------------------------
616              
617             sub _disable_shebang_fix {
618 2780     2780   6253 my ($self) = @_;
619              
620             # When you install a program using ExtUtils::MakeMaker or Module::Build, it
621             # inserts some magical code into the top of the file (just after the
622             # shebang). This code allows people to call your program using a shell,
623             # like `sh my_script`. Unfortunately, this code causes several Policy
624             # violations, so we disable them as if they had "## no critic" annotations.
625              
626 2780   100     13235 my $first_stmnt = $self->schild(0) || return;
627              
628             # Different versions of MakeMaker and Build use slightly different shebang
629             # fixing strings. This matches most of the ones I've found in my own Perl
630             # distribution, but it may not be bullet-proof.
631              
632 2762         60835 my $fixin_rx = qr<^eval 'exec .* \$0 \$[{]1[+]"\$@"}'\s*[\r\n]\s*if.+;>ms; ## no critic (ExtendedFormatting)
633 2762 100       14307 if ( $first_stmnt =~ $fixin_rx ) {
634 1         47 my $line = $first_stmnt->location->[0];
635 1         32 $self->{_disabled_line_map}->{$line}->{ALL} = 1;
636 1         6 $self->{_disabled_line_map}->{$line + 1}->{ALL} = 1;
637             }
638              
639 2762         193857 return $self;
640             }
641              
642             #-----------------------------------------------------------------------------
643              
644             sub _determine_is_module {
645 2780     2780   6084 my ($self, $args) = @_;
646              
647 2780         9480 my $file_name = $self->filename();
648 2780 100 100     16630 if (
649             defined $file_name
650             and ref $args->{'-program-extensions'} eq 'ARRAY'
651             ) {
652 57         96 foreach my $ext ( @{ $args->{'-program-extensions'} } ) {
  57         156  
653 57 50       156 my $regex =
654             ref $ext eq 'Regexp'
655             ? $ext
656 0         0 : qr< @{ [ quotemeta $ext ] } \z >xms;
657              
658 57 50       327 return $FALSE if $file_name =~ m/$regex/smx;
659             }
660             }
661              
662 2780 100       11336 return $FALSE if shebang_line($self);
663 2766 100 100     8452 return $FALSE if defined $file_name && $file_name =~ m/ [.] PL \z /smx;
664              
665 2765         8046 return $TRUE;
666             }
667              
668             #-----------------------------------------------------------------------------
669              
670             sub _nodes_by_namespace {
671 2     2   5 my ($self) = @_;
672              
673 2         5 my $nodes = $self->{_nodes_by_namespace};
674              
675 2 50       6 return $nodes if $nodes;
676              
677 2         6 my $ppi_document = $self->ppi_document();
678 2 50       9 if (not $ppi_document) {
679 0         0 return $self->{_nodes_by_namespace} = {};
680             }
681              
682 2         10 my $raw_nodes_map = split_ppi_node_by_namespace($ppi_document);
683              
684 2         2194 my %wrapped_nodes;
685 2         4 while ( my ($namespace, $raw_nodes) = each %{$raw_nodes_map} ) {
  6         25  
686             $wrapped_nodes{$namespace} = [
687 4         9 map { __PACKAGE__->_new_for_parent_document($_, $self) }
688 4         6 @{$raw_nodes}
  4         10  
689             ];
690             }
691              
692 2         27 return $self->{_nodes_by_namespace} = \%wrapped_nodes;
693             }
694              
695             #-----------------------------------------------------------------------------
696              
697             # Note: must use exists on return value to determine membership because all
698             # the values are false, unlike the result of hashify().
699             sub _modules_used {
700 468     468   613 my ($self) = @_;
701              
702 468         659 my $mapping = $self->{_modules_used};
703              
704 468 100       1610 return $mapping if $mapping;
705              
706 40         123 my $includes = $self->find('PPI::Statement::Include');
707 40 100       136 if (not $includes) {
708 35         240 return $self->{_modules_used} = {};
709             }
710              
711 5         13 my %mapping;
712 5         12 for my $module (
713 5 50       156 grep { $_ } map { $_->module() || $_->pragma() } @{$includes}
  5         26  
  5         18  
714             ) {
715             # Significanly ess memory than $h{$k} => 1. Thanks Mr. Lembark.
716 5         20 $mapping{$module} = ();
717             }
718              
719 5         46 return $self->{_modules_used} = \%mapping;
720             }
721              
722             #-----------------------------------------------------------------------------
723              
724             1;
725              
726             __END__
727              
728             =pod
729              
730             =for stopwords pre-caches
731              
732             =head1 NAME
733              
734             Perl::Critic::Document - Caching wrapper around a PPI::Document.
735              
736              
737             =head1 SYNOPSIS
738              
739             use PPI::Document;
740             use Perl::Critic::Document;
741             my $doc = PPI::Document->new('Foo.pm');
742             $doc = Perl::Critic::Document->new(-source => $doc);
743             ## Then use the instance just like a PPI::Document
744              
745              
746             =head1 DESCRIPTION
747              
748             Perl::Critic does a lot of iterations over the PPI document tree via
749             the C<PPI::Document::find()> method. To save some time, this class
750             pre-caches a lot of the common C<find()> calls in a single traversal.
751             Then, on subsequent requests we return the cached data.
752              
753             This is implemented as a facade, where method calls are handed to the
754             stored C<PPI::Document> instance.
755              
756              
757             =head1 CAVEATS
758              
759             This facade does not implement the overloaded operators from
760             L<PPI::Document|PPI::Document> (that is, the C<use overload ...>
761             work). Therefore, users of this facade must not rely on that syntactic
762             sugar. So, for example, instead of C<my $source = "$doc";> you should
763             write C<< my $source = $doc->content(); >>
764              
765             Perhaps there is a CPAN module out there which implements a facade
766             better than we do here?
767              
768              
769             =head1 INTERFACE SUPPORT
770              
771             This is considered to be a public class. Any changes to its interface
772             will go through a deprecation cycle.
773              
774              
775             =head1 CONSTRUCTOR
776              
777             =over
778              
779             =item C<< new(-source => $source_code, '-filename-override' => $filename, '-program-extensions' => [program_extensions]) >>
780              
781             Create a new instance referencing a PPI::Document instance. The
782             C<$source_code> can be the name of a file, a reference to a scalar
783             containing actual source code, or a L<PPI::Document|PPI::Document> or
784             L<PPI::Document::File|PPI::Document::File>.
785              
786             In the event that C<$source_code> is a reference to a scalar containing actual
787             source code or a L<PPI::Document|PPI::Document>, the resulting
788             L<Perl::Critic::Document|Perl::Critic::Document> will not have a filename.
789             This may cause L<Perl::Critic::Document|Perl::Critic::Document> to incorrectly
790             classify the source code as a module or script. To avoid this problem, you
791             can optionally set the C<-filename-override> to force the
792             L<Perl::Critic::Document|Perl::Critic::Document> to have a particular
793             C<$filename>. Do not use this option if C<$source_code> is already the name
794             of a file, or is a reference to a L<PPI::Document::File|PPI::Document::File>.
795              
796             The '-program-extensions' argument is optional, and is a reference to a list
797             of strings and/or regular expressions. The strings will be made into regular
798             expressions matching the end of a file name, and any document whose file name
799             matches one of the regular expressions will be considered a program.
800              
801             If -program-extensions is not specified, or if it does not determine the
802             document type, the document will be considered to be a program if the source
803             has a shebang line or its file name (if any) matches C<< m/ [.] PL \z /smx >>.
804              
805             =back
806              
807             =head1 METHODS
808              
809             =over
810              
811             =item C<< ppi_document() >>
812              
813             Accessor for the wrapped PPI::Document instance. Note that altering
814             this instance in any way can cause unpredictable failures in
815             Perl::Critic's subsequent analysis because some caches may fall out of
816             date.
817              
818              
819             =item C<< find($wanted) >>
820              
821             =item C<< find_first($wanted) >>
822              
823             =item C<< find_any($wanted) >>
824              
825             Caching wrappers around the PPI methods. If C<$wanted> is a simple PPI class
826             name, then the cache is employed. Otherwise we forward the call to the
827             corresponding method of the C<PPI::Document> instance.
828              
829              
830             =item C<< namespaces() >>
831              
832             Returns a list of the namespaces (package names) in the document.
833              
834              
835             =item C<< subdocuments_for_namespace($namespace) >>
836              
837             Returns a list of sub-documents containing the elements in the given
838             namespace. For example, given that the current document is for the source
839              
840             foo();
841             package Foo;
842             package Bar;
843             package Foo;
844              
845             this method will return two L<Perl::Critic::Document|Perl::Critic::Document>s
846             for a parameter of C<"Foo">. For more, see
847             L<PPIx::Utilities::Node/split_ppi_node_by_namespace>.
848              
849              
850             =item C<< ppix_regexp_from_element($element) >>
851              
852             Caching wrapper around C<< PPIx::Regexp->new($element) >>. If
853             C<$element> is a C<PPI::Element> the cache is employed, otherwise it
854             just returns the results of C<< PPIx::Regexp->new() >>. In either case,
855             it returns C<undef> unless the argument is something that
856             L<PPIx::Regexp|PPIx::Regexp> actually understands.
857              
858             =item C<< element_is_in_lexical_scope_after_statement_containing( $inner, $outer ) >>
859              
860             Is the C<$inner> element in lexical scope after the statement containing
861             the C<$outer> element?
862              
863             In the case where C<$outer> is itself a scope-defining element, returns true
864             if C<$outer> contains C<$inner>. In any other case, C<$inner> must be
865             after the last element of the statement containing C<$outer>, and the
866             innermost scope for C<$outer> also contains C<$inner>.
867              
868             This is not the same as asking whether C<$inner> is visible from
869             C<$outer>.
870              
871              
872             =item C<< filename() >>
873              
874             Returns the filename for the source code if applicable
875             (PPI::Document::File) or C<undef> otherwise (PPI::Document).
876              
877              
878             =item C<< isa( $classname ) >>
879              
880             To be compatible with other modules that expect to get a
881             PPI::Document, the Perl::Critic::Document class masquerades as the
882             PPI::Document class.
883              
884              
885             =item C<< highest_explicit_perl_version() >>
886              
887             Returns a L<version|version> object for the highest Perl version
888             requirement declared in the document via a C<use> or C<require>
889             statement. Returns nothing if there is no version statement.
890              
891              
892             =item C<< uses_module($module_or_pragma_name) >>
893              
894             Answers whether there is a C<use>, C<require>, or C<no> of the given name in
895             this document. Note that there is no differentiation of modules vs. pragmata
896             here.
897              
898              
899             =item C<< process_annotations() >>
900              
901             Causes this Document to scan itself and mark which lines &
902             policies are disabled by the C<"## no critic"> annotations.
903              
904              
905             =item C<< line_is_disabled_for_policy($line, $policy_object) >>
906              
907             Returns true if the given C<$policy_object> or C<$policy_name> has
908             been disabled for at C<$line> in this Document. Otherwise, returns false.
909              
910              
911             =item C<< add_annotation( $annotation ) >>
912              
913             Adds an C<$annotation> object to this Document.
914              
915              
916             =item C<< annotations() >>
917              
918             Returns a list containing all the
919             L<Perl::Critic::Annotation|Perl::Critic::Annotation>s that
920             were found in this Document.
921              
922              
923             =item C<< add_suppressed_violation($violation) >>
924              
925             Informs this Document that a C<$violation> was found but not reported
926             because it fell on a line that had been suppressed by a C<"## no critic">
927             annotation. Returns C<$self>.
928              
929              
930             =item C<< suppressed_violations() >>
931              
932             Returns a list of references to all the
933             L<Perl::Critic::Violation|Perl::Critic::Violation>s
934             that were found in this Document but were suppressed.
935              
936              
937             =item C<< is_program() >>
938              
939             Returns whether this document is considered to be a program.
940              
941              
942             =item C<< is_module() >>
943              
944             Returns whether this document is considered to be a Perl module.
945              
946             =back
947              
948             =head1 AUTHOR
949              
950             Chris Dolan <cdolan@cpan.org>
951              
952             =head1 COPYRIGHT
953              
954             Copyright (c) 2006-2011 Chris Dolan.
955              
956             This program is free software; you can redistribute it and/or modify
957             it under the same terms as Perl itself. The full text of this license
958             can be found in the LICENSE file included with this module.
959              
960             =cut
961              
962             ##############################################################################
963             # Local Variables:
964             # mode: cperl
965             # cperl-indent-level: 4
966             # fill-column: 78
967             # indent-tabs-mode: nil
968             # c-indentation-style: bsd
969             # End:
970             # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :