File Coverage

blib/lib/Dist/Zilla/Role/PPI.pm
Criterion Covered Total %
statement 41 46 89.1
branch 17 20 85.0
condition 5 6 83.3
subroutine 7 8 87.5
pod 3 3 100.0
total 73 83 87.9


line stmt bran cond sub pod time code
1             package Dist::Zilla::Role::PPI 6.030;
2             # ABSTRACT: a role for plugins which use PPI
3              
4 16     16   8607 use Moose::Role;
  16         51  
  16         134  
5              
6 16     16   87297 use Dist::Zilla::Pragmas;
  16         76  
  16         124  
7              
8 16     16   154 use Digest::MD5 qw(md5);
  16         46  
  16         1408  
9              
10 16     16   315 use namespace::autoclean;
  16         56  
  16         145  
11              
12             #pod =head1 DESCRIPTION
13             #pod
14             #pod This role provides some common utilities for plugins which use L<PPI>.
15             #pod
16             #pod =method ppi_document_for_file
17             #pod
18             #pod my $document = $self->ppi_document_for_file($file);
19             #pod
20             #pod Given a dzil file object (anything that does L<Dist::Zilla::Role::File>), this
21             #pod method returns a new L<PPI::Document> for that file's content.
22             #pod
23             #pod Internally, this method caches these documents. If multiple plugins want a
24             #pod document for the same file, this avoids reparsing it.
25             #pod
26             #pod =cut
27              
28             my %CACHE;
29              
30             sub ppi_document_for_file {
31 154     154 1 399 my ($self, $file) = @_;
32              
33 154         579 my $encoded_content = $file->encoded_content;
34              
35             # We cache on the MD5 checksum to detect if the document has been modified
36             # by some other plugin since it was last parsed, making our document invalid.
37 154         1153 my $md5 = md5($encoded_content);
38 154 100       1117 return $CACHE{$md5}->clone if $CACHE{$md5};
39              
40 65         247 my $content = $file->content;
41              
42 65         7201 require PPI::Document;
43 65 50       1069906 my $document = PPI::Document->new(\$content)
44             or Carp::croak(PPI::Document->errstr . ' while processing file ' . $file->name);
45              
46 65         306339 return ($CACHE{$md5} = $document)->clone;
47             }
48              
49             #pod =method save_ppi_document_to_file
50             #pod
51             #pod my $document = $self->save_ppi_document_to_file($document,$file);
52             #pod
53             #pod Given a L<PPI::Document> and a dzil file object (anything that does
54             #pod L<Dist::Zilla::Role::File>), this method saves the serialized document in the
55             #pod file.
56             #pod
57             #pod It also updates the internal PPI document cache with the new document.
58             #pod
59             #pod =cut
60              
61             sub save_ppi_document_to_file {
62 0     0 1 0 my ($self, $document, $file) = @_;
63              
64 0         0 my $new_content = $document->serialize;
65              
66 0         0 $file->content($new_content);
67              
68 0         0 my $encoded = $file->encoded_content;
69              
70 0         0 $CACHE{ md5($encoded) } = $document->clone;
71             }
72              
73             #pod =method document_assigns_to_variable
74             #pod
75             #pod if( $self->document_assigns_to_variable($document, '$FOO')) { ... }
76             #pod
77             #pod This method returns true if the document assigns to the given variable (the
78             #pod sigil must be included).
79             #pod
80             #pod =cut
81              
82             sub document_assigns_to_variable {
83 58     58 1 224 my ($self, $document, $variable) = @_;
84              
85 58         176 my $package_stmts = $document->find('PPI::Statement::Package');
86 58 50       46863 my @namespaces = map { $_->namespace } @{ $package_stmts || []};
  71         590  
  58         288  
87              
88 58         2048 my ($sigil, $varname) = ($variable =~ m'^([$@%*])(.+)$');
89              
90 58         136 my $package;
91             my $finder = sub {
92 1358     1358   13115 my $node = $_[1];
93              
94 1358 100 100     4939 if ($node->isa('PPI::Statement')
      66        
95             && !$node->isa('PPI::Statement::End')
96             && !$node->isa('PPI::Statement::Data')) {
97              
98 214 100       691 if ($node->isa('PPI::Statement::Variable')) {
99 24 100       106 return (grep { $_ eq $variable } $node->variables) ? 1 : undef;
  23         1416  
100             }
101              
102             return 1 if grep {
103 190 100       611 my $child = $_;
  731         2104  
104             $child->isa('PPI::Token::Symbol')
105             and grep {
106 731 100       2832 $child->canonical eq "${sigil}${_}::${varname}"
  15 100       92  
107             and $node->content =~ /\Q${sigil}${_}::${varname}\E.*=/
108             } @namespaces
109             } $node->children;
110             }
111 1331         2155 return 0; # not found
112 58         367 };
113              
114 58         261 my $rv = $document->find_any($finder);
115 58 50       901 Carp::croak($document->errstr) unless defined $rv;
116              
117 58         626 return $rv;
118             }
119              
120             1;
121              
122             __END__
123              
124             =pod
125              
126             =encoding UTF-8
127              
128             =head1 NAME
129              
130             Dist::Zilla::Role::PPI - a role for plugins which use PPI
131              
132             =head1 VERSION
133              
134             version 6.030
135              
136             =head1 DESCRIPTION
137              
138             This role provides some common utilities for plugins which use L<PPI>.
139              
140             =head1 PERL VERSION
141              
142             This module should work on any version of perl still receiving updates from
143             the Perl 5 Porters. This means it should work on any version of perl released
144             in the last two to three years. (That is, if the most recently released
145             version is v5.40, then this module should work on both v5.40 and v5.38.)
146              
147             Although it may work on older versions of perl, no guarantee is made that the
148             minimum required version will not be increased. The version may be increased
149             for any reason, and there is no promise that patches will be accepted to lower
150             the minimum required perl.
151              
152             =head1 METHODS
153              
154             =head2 ppi_document_for_file
155              
156             my $document = $self->ppi_document_for_file($file);
157              
158             Given a dzil file object (anything that does L<Dist::Zilla::Role::File>), this
159             method returns a new L<PPI::Document> for that file's content.
160              
161             Internally, this method caches these documents. If multiple plugins want a
162             document for the same file, this avoids reparsing it.
163              
164             =head2 save_ppi_document_to_file
165              
166             my $document = $self->save_ppi_document_to_file($document,$file);
167              
168             Given a L<PPI::Document> and a dzil file object (anything that does
169             L<Dist::Zilla::Role::File>), this method saves the serialized document in the
170             file.
171              
172             It also updates the internal PPI document cache with the new document.
173              
174             =head2 document_assigns_to_variable
175              
176             if( $self->document_assigns_to_variable($document, '$FOO')) { ... }
177              
178             This method returns true if the document assigns to the given variable (the
179             sigil must be included).
180              
181             =head1 AUTHOR
182              
183             Ricardo SIGNES 😏 <cpan@semiotic.systems>
184              
185             =head1 COPYRIGHT AND LICENSE
186              
187             This software is copyright (c) 2023 by Ricardo SIGNES.
188              
189             This is free software; you can redistribute it and/or modify it under
190             the same terms as the Perl 5 programming language system itself.
191              
192             =cut