File Coverage

blib/lib/Perl/ToPerl6/Annotation.pm
Criterion Covered Total %
statement 99 113 87.6
branch 26 38 68.4
condition 14 29 48.2
subroutine 17 19 89.4
pod 8 8 100.0
total 164 207 79.2


line stmt bran cond sub pod time code
1             package Perl::ToPerl6::Annotation;
2              
3 13     13   112459 use 5.006001;
  13         41  
4 13     13   57 use strict;
  13         21  
  13         263  
5 13     13   51 use warnings;
  13         21  
  13         373  
6              
7 13     13   54 use Carp qw(confess);
  13         16  
  13         791  
8 13     13   739 use English qw(-no_match_vars);
  13         3919  
  13         105  
9              
10 13     13   6029 use Perl::ToPerl6::TransformerFactory;
  13         27  
  13         118  
11 13     13   68 use Perl::ToPerl6::Utils qw(:characters hashify);
  13         22  
  13         807  
12 13     13   2933 use Readonly;
  13         25  
  13         16214  
13              
14             #-----------------------------------------------------------------------------
15              
16             our $VERSION = '0.03';
17              
18             Readonly::Scalar my $LAST_ELEMENT => -1;
19              
20             #=============================================================================
21             # CLASS methods
22              
23             sub create_annotations {
24 11     11 1 60 my ($class, $doc) = @_;
25              
26 11         22 my @annotations = ();
27 11   100     44 my $comment_elements_ref = $doc->find('PPI::Token::Comment') || return;
28 7         29 my $annotation_rx = qr{\A (?: [#]! .*? )? \s* [#][#] \s* no \s+ mogrify}xms;
29 7         11 for my $annotation_element ( grep { $_ =~ $annotation_rx } @{$comment_elements_ref} ) {
  22         155  
  7         16  
30 13         122 push @annotations, Perl::ToPerl6::Annotation->new( -element => $annotation_element);
31             }
32              
33 7         44 return @annotations;
34             }
35              
36             #-----------------------------------------------------------------------------
37              
38             sub new {
39 13     13 1 33 my ($class, @args) = @_;
40 13         29 my $self = bless {}, $class;
41 13         38 $self->_init(@args);
42 13         45 return $self;
43             }
44              
45             #=============================================================================
46             # OBJECT methods
47              
48             sub _init {
49 13     13   35 my ($self, %args) = @_;
50 13   33     56 my $annotation_element = $args{-element} || confess '-element argument is required';
51 13         33 $self->{_element} = $annotation_element;
52              
53 13         38 my %disabled_transformers = _parse_annotation( $annotation_element );
54 13 100       44 $self->{_disables_all_transformers} = %disabled_transformers ? 0 : 1;
55 13         29 $self->{_disabled_transformers} = \%disabled_transformers;
56              
57             # Grab surrounding nodes to determine the context.
58             # This determines whether the annotation applies to
59             # the current line or the block that follows.
60 13         50 my $annotation_line = $annotation_element->logical_line_number();
61 13         207 my $parent = $annotation_element->parent();
62 13 50       125 my $grandparent = $parent ? $parent->parent() : undef;
63              
64             # Handle case when it appears on the shebang line. In this
65             # situation, it only affects the first line, not the whole doc
66 13 50       58 if ( $annotation_element =~ m{\A [#]!}xms) {
67 0         0 $self->{_effective_range} = [$annotation_line, $annotation_line];
68 0         0 return $self;
69             }
70              
71             # Handle single-line usage on simple statements. In this
72             # situation, it only affects the line that it appears on.
73 13 100       83 if ( _is_single_line_annotation_on_simple_statement( $annotation_element )
74             ) {
75 1         3 $self->{_effective_range} = [$annotation_line, $annotation_line];
76 1         2 return $self;
77             }
78              
79             # Handle single-line usage on compound statements. In this
80             # situation -- um -- I'm not sure how this works, but it does.
81 12 100       469 if ( ref $parent eq 'PPI::Structure::Block' ) {
82 1 50 33     7 if ( ref $grandparent eq 'PPI::Statement::Compound'
83             || ref $grandparent eq 'PPI::Statement::Sub' ) {
84 1 50       20 if ( $parent->logical_line_number() == $annotation_line ) {
85 0         0 my $grandparent_line = $grandparent->logical_line_number();
86 0         0 $self->{_effective_range} = [$grandparent_line, $grandparent_line];
87 0         0 return $self;
88             }
89             }
90             }
91              
92              
93             # Handle multi-line usage. This is either a "no mogrify" ..
94             # "use mogrify" region or a block where "no mogrify" is in effect
95             # until the end of the scope. The start is the always the "no
96             # mogrify" which we already found. So now we have to search for the end.
97 12         64 my $end = $annotation_element;
98 12         44 my $use_mogrify = qr{\A \s* [#][#] \s* use \s+ mogrify}xms;
99              
100             SIB:
101 12         43 while ( my $esib = $end->next_sibling() ) {
102 24         473 $end = $esib; # keep track of last sibling encountered in this scope
103 24 100 66     209 last SIB if $esib->isa('PPI::Token::Comment') && $esib =~ $use_mogrify;
104             }
105              
106             # PPI parses __END__ as a PPI::Statement::End, and everything following is
107             # a child of that statement. That means if we encounter an __END__, we
108             # need to descend into it and continue the analysis.
109 12 100 66     216 if ( $end->isa( 'PPI::Statement::End' ) and my $kid = $end->child( 0 ) ) {
110 1         7 $end = $kid;
111             SIB:
112 1         5 while ( my $esib = $end->next_sibling() ) {
113 3         32 $end = $esib;
114 3 50 33     16 last SIB if $esib->isa( 'PPI::Token::Comment' ) &&
115             $esib->content() =~ $use_mogrify;
116             }
117             }
118              
119             # We either found an end or hit the end of the scope.
120 12         43 my $ending_line = $end->logical_line_number();
121 12         172 $self->{_effective_range} = [$annotation_line, $ending_line];
122 12         46 return $self;
123             }
124              
125             #-----------------------------------------------------------------------------
126              
127             sub element {
128 0     0 1 0 my ($self) = @_;
129 0         0 return $self->{_element};
130             }
131              
132             #-----------------------------------------------------------------------------
133              
134             sub effective_range {
135 12     12 1 19 my $self = shift;
136 12         17 return @{ $self->{_effective_range} };
  12         41  
137             }
138              
139             #-----------------------------------------------------------------------------
140              
141             sub disabled_transformers {
142 0     0 1 0 my $self = shift;
143 0         0 return keys %{ $self->{_disabled_transformers} };
  0         0  
144             }
145              
146             #-----------------------------------------------------------------------------
147              
148             sub disables_transformer {
149 8     8 1 16 my ($self, $transformer_name) = @_;
150 8 50       74 return 1 if $self->{_disabled_transformers}->{$transformer_name};
151 0 0       0 return 1 if $self->disables_all_transformers();
152 0         0 return 0;
153             }
154              
155             #-----------------------------------------------------------------------------
156              
157             sub disables_all_transformers {
158 12     12 1 16293 my ($self) = @_;
159 12         82 return $self->{_disables_all_transformers};
160             }
161              
162             #-----------------------------------------------------------------------------
163              
164             sub disables_line {
165 13     13 1 890 my ($self, $line_number) = @_;
166 13         35 my $effective_range = $self->{_effective_range};
167 13 50 33     147 return 1 if $line_number >= $effective_range->[0]
168             and $line_number <= $effective_range->[$LAST_ELEMENT];
169 0         0 return 0;
170             }
171              
172             #-----------------------------------------------------------------------------
173              
174             # Recognize a single-line annotation on a simple statement.
175             sub _is_single_line_annotation_on_simple_statement {
176 13     13   21 my ( $annotation_element ) = @_;
177 13         34 my $annotation_line = $annotation_element->logical_line_number();
178              
179             # If there is no sibling, we are clearly not a single-line annotation of
180             # any sort.
181 13 100       153 my $sib = $annotation_element->sprevious_sibling()
182             or return 0;
183              
184             # The easy case: the sibling (whatever it is) is on the same line as the
185             # annotation.
186 1 50       30 $sib->logical_line_number() == $annotation_line
187             and return 1;
188              
189             # If the sibling is a node, we may have an annotation on one line of a
190             # statement that was split over multiple lines. So we descend through the
191             # children, keeping the last significant child of each, until we bottom
192             # out. If the ultimate significant descendant is on the same line as the
193             # annotation, we accept the annotation as a single-line annotation.
194 1 50 33     25 if ( $sib->isa( 'PPI::Node' ) &&
195             $sib->logical_line_number() < $annotation_line
196             ) {
197 1         11 my $neighbor = $sib;
198 1   66     7 while ( $neighbor->isa( 'PPI::Node' )
199             and my $kid = $neighbor->schild( $LAST_ELEMENT ) ) {
200 1         16 $neighbor = $kid;
201             }
202 1 50 33     8 if ( $neighbor &&
203             $neighbor->logical_line_number() == $annotation_line
204             ) {
205 1         11 return 1;
206             }
207             }
208              
209             # We do not understand any other sort of single-line annotation. Accepting
210             # the annotation as such (if it is) is Someone Else's Problem.
211 0         0 return 0;
212             }
213              
214             #-----------------------------------------------------------------------------
215              
216             sub _parse_annotation {
217              
218 13     13   15 my ($annotation_element) = @_;
219              
220             #############################################################################
221             # This regex captures the list of Transformer name patterns that are to be
222             # disabled. It is generally assumed that the element has already been
223             # verified as a no-mogrify annotation. So if this regex does not match,
224             # then it implies that all Transformers are to be disabled.
225             #
226 13         40 my $no_mogrify = qr{\#\# \s* no \s+ mogrify \s* (?:qw)? [("'] ([\s\w:,]+) }xms;
227             # -------------------------- ------- ----- -----------
228             # | | | |
229             # "## no mogrify" with optional spaces | | |
230             # | | |
231             # Transformer list may be prefixed with "qw" | |
232             # | |
233             # Optional Transformer list must begin with one of these |
234             # |
235             # Capture entire Transformer list (with delimiters) here
236             #
237             #############################################################################
238              
239 13         23 my @disabled_transformer_names = ();
240 13 100       58 if ( my ($patterns_string) = $annotation_element =~ $no_mogrify ) {
241              
242             # Compose the specified modules into a regex alternation. Wrap each
243             # in a no-capturing group to permit "|" in the modules specification.
244              
245 11         150 my @transformer_name_patterns = grep { $_ ne $EMPTY }
  14         45  
246             split m{\s *[,\s] \s*}xms, $patterns_string;
247 11         25 my $re = join $PIPE, map {"(?:$_)"} @transformer_name_patterns;
  11         43  
248 11         42 my @site_transformer_names = Perl::ToPerl6::TransformerFactory::site_transformer_names();
249 11         36 @disabled_transformer_names = grep {m/$re/ixms} @site_transformer_names;
  418         894  
250              
251             # It is possible that the Transformer patterns listed in the annotation do not
252             # match any of the site transformer names. This could happen when running
253             # on a machine that does not have the same set of Transformers as the
254             # author.
255             # So we must return something here, otherwise all Transformers will be
256             # disabled. We probably need to add a mechanism to (optionally) warn
257             # about this, just to help the author avoid writing invalid Transformer names.
258              
259 11 100       57 if (not @disabled_transformer_names) {
260 2         8 @disabled_transformer_names = @transformer_name_patterns;
261             }
262             }
263              
264 13         66 return hashify(@disabled_transformer_names);
265             }
266              
267             #-----------------------------------------------------------------------------
268              
269             1;
270              
271             __END__
272              
273             =pod
274              
275             =head1 NAME
276              
277             Perl::ToPerl6::Annotation - A "## no mogrify" annotation in a document.
278              
279              
280             =head1 SYNOPSIS
281              
282             use Perl::ToPerl6::Annotation;
283             $annotation = Perl::ToPerl6::Annotation->new( -element => $no_mogrify_ppi_element );
284              
285             $bool = $annotation->disables_line( $number );
286             $bool = $annotation->disables_transformer( $transformer_object );
287             $bool = $annotation->disables_all_transformers();
288              
289             ($start, $end) = $annotation->effective_range();
290             @disabled_transformer_names = $annotation->disabled_transformers();
291              
292              
293             =head1 DESCRIPTION
294              
295             C<Perl::ToPerl6::Annotation> represents a single C<"## no mogrify">
296             annotation in a L<PPI:Document>. The Annotation takes care of parsing
297             the annotation and keeps track of which lines and Transformers it affects.
298             It is intended to encapsulate the details of the no-mogrify
299             annotations, and to provide a way for Transformer objects to interact with
300             the annotations (via a L<Perl::ToPerl6::Document|Perl::ToPerl6::Document>).
301              
302              
303             =head1 INTERFACE SUPPORT
304              
305             This is considered to be a non-public class. Its interface is subject
306             to change without notice.
307              
308              
309             =head1 CLASS METHODS
310              
311             =over
312              
313             =item create_annotations( -doc => $doc )
314              
315             Given a L<Perl::ToPerl6::Document|Perl::ToPerl6::Document>, finds all the C<"## no mogrify">
316             annotations and constructs a new C<Perl::ToPerl6::Annotation> for each
317             one and returns them. The order of the returned objects is not
318             defined. It is generally expected that clients will use this
319             interface rather than calling the C<Perl::ToPerl6::Annotation>
320             constructor directly.
321              
322              
323             =back
324              
325              
326             =head1 CONSTRUCTOR
327              
328             =over
329              
330             =item C<< new( -element => $ppi_annotation_element ) >>
331              
332             Returns a reference to a new Annotation object. The B<-element>
333             argument is required and should be a C<PPI::Token::Comment> that
334             conforms to the C<"## no mogrify"> syntax.
335              
336              
337             =back
338              
339              
340             =head1 METHODS
341              
342             =over
343              
344             =item C<< disables_line( $line ) >>
345              
346             Returns true if this Annotation disables C<$line> for any (or all)
347             Transformers.
348              
349              
350             =item C<< disables_transformer( $transformer_object ) >>
351              
352             =item C<< disables_transformer( $transformer_name ) >>
353              
354             Returns true if this Annotation disables C<$polciy_object> or
355             C<$transformer_name> at any (or all) lines.
356              
357              
358             =item C<< disables_all_transformers() >>
359              
360             Returns true if this Annotation disables all Transformers at any (or all)
361             lines. If this method returns true, C<disabled_transformers> will return
362             an empty list.
363              
364              
365             =item C<< effective_range() >>
366              
367             Returns a two-element list, representing the first and last line
368             numbers where this Annotation has effect.
369              
370              
371             =item C<< disabled_transformers() >>
372              
373             Returns a list of the names of the Transformers that are affected by this
374             Annotation. If this list is empty, then it means that all Transformers
375             are affected by this Annotation, and C<disables_all_transformers()> should
376             return true.
377              
378              
379             =item C<< element() >>
380              
381             Returns the L<PPI::Element|PPI::Element> where this annotation started. This is
382             typically an instance of L<PPI::Token::Comment|PPI::Token::Comment>.
383              
384              
385             =back
386              
387              
388             =head1 AUTHOR
389              
390             Jeffrey Ryan Thalhammer <jeff@imaginative-software.com>
391              
392              
393             =head1 COPYRIGHT
394              
395             Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved.
396              
397             This program is free software; you can redistribute it and/or modify
398             it under the same terms as Perl itself. The full text of this license
399             can be found in the LICENSE file included with this module.
400              
401             =cut
402              
403             ##############################################################################
404             # Local Variables:
405             # mode: cperl
406             # cperl-indent-level: 4
407             # fill-column: 78
408             # indent-tabs-mode: nil
409             # c-indentation-style: bsd
410             # End:
411             # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :