File Coverage

blib/lib/Perl/ToPerl6/Utils/PPI.pm
Criterion Covered Total %
statement 89 182 48.9
branch 41 152 26.9
condition 12 45 26.6
subroutine 18 32 56.2
pod 5 23 21.7
total 165 434 38.0


line stmt bran cond sub pod time code
1             package Perl::ToPerl6::Utils::PPI;
2              
3 31     31   112822 use 5.006001;
  31         71  
4 31     31   136 use strict;
  31         41  
  31         568  
5 31     31   114 use warnings;
  31         32  
  31         738  
6              
7 31     31   567 use Readonly;
  31         2595  
  31         1479  
8              
9 31     31   138 use Scalar::Util qw< blessed readonly looks_like_number >;
  31         41  
  31         1653  
10              
11 31     31   127 use Exporter 'import';
  31         60  
  31         74780  
12              
13             our $VERSION = '0.03';
14              
15             #-----------------------------------------------------------------------------
16              
17             our @EXPORT_OK = qw(
18             dscanf
19              
20             is_ppi_expression_or_generic_statement
21             is_ppi_generic_statement
22             is_ppi_statement_subclass
23             is_ppi_simple_statement
24             is_ppi_constant_element
25              
26             is_package_boundary
27              
28             is_module_name
29             is_version_number
30             is_pragma
31              
32             is_ppi_token_word
33             is_ppi_token_operator
34             is_ppi_statement
35             is_ppi_statement_compound
36              
37             is_ppi_token_quotelike_words_like
38              
39             set_string
40              
41             make_ppi_structure_list
42             make_ppi_structure_block
43             );
44              
45             our %EXPORT_TAGS = (
46             all => \@EXPORT_OK,
47             );
48              
49             #-----------------------------------------------------------------------------
50             #
51             # List the conversion possibilities separately, for now.
52             # I don't think there's much call for fancy modifiers, but I'll keep it in mind.
53              
54             my @conversions = sort { length($b) <=> length($a) } (
55             'd', 'bd', 'od', 'xd', # Decimals
56             'f', 'ef', 'ff', # Floating-point numbers
57             'o', # Operator
58             'r', 'mr', 'sr', 'tr', # Regular expressions
59             's', 'ds', 'ls', 'ss', 'is', # Strings
60             'v', 'av', 'gv', 'hv', 'sv', # Variables
61             'L', # List
62             'P', # Generic PPI token
63             'W', # Word
64             );
65             my $conversions_re = join '|', @conversions;
66             my %conversion_type = (
67             d => 'PPI::Token::Number',
68             bd => 'PPI::Token::Number::Binary',
69             od => 'PPI::Token::Number::Octal',
70             xd => 'PPI::Token::Number::Hex',
71             f => 'PPI::Token::Number::Float',
72             ef => 'PPI::Token::Number::Exp',
73             o => 'PPI::Token::Operator',
74             r => 'PPI::Token::Regexp',
75             mr => 'PPI::Token::Regexp::Match',
76             sr => 'PPI::Token::Regexp::Substitute',
77             tr => 'PPI::Token::Regexp::Transliterate',
78             s => 'PPI::Token::Quote::Single',
79             ds => 'PPI::Token::Quote::Double',
80             is => 'PPI::Token::Quote::Interpolate',
81             ls => 'PPI::Token::Quote::Literal',
82             ss => 'PPI::Token::Quote::Single',
83             v => 'PPI::Token::Symbol',
84             av => 'PPI::Token::Symbol', # Must be smarter later.
85             gv => 'PPI::Token::Symbol',
86             hv => 'PPI::Token::Symbol',
87             sv => 'PPI::Token::Symbol',
88             L => 'PPI::Structure::List',
89             W => 'PPI::Token::Word',
90             );
91              
92             sub _retokenize {
93 127     127   286 my (@token) = @_;
94              
95             # Regroup the '%%', '%v' and modified conversions.
96             #
97 127         125 my @final_token;
98 127         353 for ( my $i = 0; $i < @token; $i++ ) {
99 643         637 my $v = $token[$i];
100              
101             # If the token is a '%', then look ahead.
102             # If '%' is next, just tack it on to the existing '%' leaving '%%'.
103             # Otherwise, add whatever modifiers we can find from the next, and
104             # move on.
105             # Failing that, report that we've found a missing modifier.
106             #
107 643 100       877 if ( $v eq '%' ) {
108 251 50       1968 if ( $token[$i+1] eq '%' ) {
    100          
109 0         0 push @final_token, $v . $token[$i+1];
110 0         0 $i++;
111             }
112             elsif ( $token[$i+1] =~ s< ^ ($conversions_re) ><>x ) {
113 250         449 my $conversion = $1;
114 250 50       460 if ( $conversion eq 'P' ) {
115 0         0 $token[$i+1] =~ s< ^ \{ ([^\}]+) \} ><>x;
116 0         0 my $name = $1;
117 0 0       0 $name = 'PPI::' . $name unless $name =~ m< ^ PPI\:: >x;
118 0         0 $conversion .= $name;
119             }
120 250         451 push @final_token, $v . $conversion;
121 250 50       945 $i++ if $token[$i+1] eq '';
122             }
123             else {
124 1         10 die "Unknown conversion '" . $token[$i+1] . "'";
125             }
126             }
127             else {
128 392         898 push @final_token, $v;
129             }
130             }
131 126         752 return @final_token;
132             }
133              
134             sub dscanf {
135 127     127 1 6794 my ($format, $options) = @_;
136 127         1058 my @token = grep { $_ ne '' } split / ( \s+ | \% ) /x, $format;
  1151         1853  
137 127         321 @token = _retokenize( @token );
138              
139 126         185 my @to_find;
140 126         190 for my $token ( @token ) {
141 638 100       1716 next if $token =~ m< ^ \s+ $ >x;
142              
143 382 50       1233 if ( $token eq '%%' ) {
    100          
144 0         0 push @to_find, {
145             type => 'PPI::Token::Operator',
146             content => '%'
147             };
148             }
149             elsif ( $token =~ s< ^ \% ><>x ) {
150 250 50       421 if ( exists $conversion_type{$token} ) {
    0          
151             push @to_find, {
152 250         706 type => $conversion_type{$token}
153             };
154             }
155             elsif ( $token =~ s< ^ P (.+) $ ><>x ) {
156 0         0 push @to_find, {
157             type => $1
158             };
159             }
160             else {
161 0         0 die "Shouldn't happen, but a token type '$token' got here that we don't recognize, bailing.";
162             }
163             }
164             else {
165 132 50       618 if ( looks_like_number( $token ) ) {
    100          
166 0         0 push @to_find, {
167             type => 'PPI::Token::Number',
168             content => $token
169             };
170             }
171             elsif ( $token =~ / [^\w] /x ) {
172 3         6 push @to_find, {
173             type => 'PPI::Token::Operator',
174             content => $token
175             };
176             }
177             else {
178 129         561 push @to_find, {
179             type => 'PPI::Token::Word',
180             content => $token
181             };
182             }
183             }
184             }
185              
186             return sub {
187 148     148   348 my $elem = $_[1];
188              
189 148         200 for my $match ( @to_find ) {
190 155 100       1330 return 0 unless $elem->isa( $match->{type} );
191             return 0 if $match->{content} and
192 36 100 100     142 $elem->content ne $match->{content};
193 9         44 $elem = $elem->snext_sibling;
194             }
195 2         39 return 1;
196 126         777 };
197             }
198              
199             #-----------------------------------------------------------------------------
200              
201             sub is_ppi_token_word {
202 313     313 0 1714 my ($elem, %map) = @_;
203             $elem and
204             $elem->isa('PPI::Token::Word') and
205 313 100 100     3166 exists $map{$elem->content};
206             }
207              
208             #-----------------------------------------------------------------------------
209              
210             sub is_ppi_token_operator {
211 61     61 0 533 my ($elem, %map) = @_;
212             $elem and
213             $elem->isa('PPI::Token::Operator') and
214 61 100 66     749 exists $map{$elem->content};
215             }
216              
217             #-----------------------------------------------------------------------------
218              
219             sub is_ppi_statement {
220 0     0 0 0 my ($elem, %map) = @_;
221             $elem and
222             $elem->isa('PPI::Statement') and
223 0 0 0     0 exists $map{$elem->first_element->content};
224             }
225              
226             #-----------------------------------------------------------------------------
227              
228             sub is_ppi_statement_compound {
229 248     248 0 518 my ($elem, %map) = @_;
230             $elem and
231             $elem->isa('PPI::Statement::Compound') and
232 248 50 33     2421 exists $map{$elem->first_element->content};
233             }
234              
235             #-----------------------------------------------------------------------------
236              
237             sub is_ppi_token_quotelike_words_like {
238 15     15 0 17 my ($elem, $qr) = @_;
239 15 50 33     96 $elem and
240             $elem->isa('PPI::Token::QuoteLike::Words') and
241             $elem->content =~ $qr
242             }
243              
244             #-----------------------------------------------------------------------------
245              
246             sub is_module_name {
247 1     1 0 7 my $element = shift;
248              
249 1 50       7 return if not $element;
250              
251 1 50       11 return unless $element->isa('PPI::Token::Word');
252 1         6 my $content = $element->content;
253              
254 1 50       10 return if looks_like_number($content);
255 1 50       5 return if $content =~ /^v\d+/;
256              
257 1         22 return 1;
258             }
259              
260             #-----------------------------------------------------------------------------
261              
262             sub is_version_number {
263 1     1 0 8 my $element = shift;
264              
265 1 50       7 return if not $element;
266              
267 1 0 33     7 return unless $element->isa('PPI::Token::Word') or
      33        
268             $element->isa('PPI::Token::Number::Version') or
269             $element->isa('PPI::Token::Number::Float');
270 1         5 my $content = $element->content;
271              
272 1 50       11 return 1 if looks_like_number($content);
273 1 50       6 return 1 if $content =~ /^v\d+/;
274              
275 1         9 return;
276             }
277              
278             #-----------------------------------------------------------------------------
279              
280             sub is_pragma {
281 2     2 0 11 my $element = shift;
282              
283 2 50       13 return if not $element;
284              
285 2 50       11 return unless $element->isa('PPI::Token::Word');
286 2         8 my $content = $element->content;
287              
288 2         49 my %pragma = (
289             strict => 1,
290             warnings => 1,
291             autodie => 1,
292             base => 1,
293             parent => 1,
294             bigint => 1,
295             bignum => 1,
296             bigrat => 1,
297             constant => 1,
298             mro => 1,
299             encoding => 1,
300             integer => 1,
301             lib => 1,
302             mro => 1,
303             utf8 => 1,
304             vars => 1,
305             );
306              
307 2 50       16 return 1 if exists $pragma{$content};
308              
309 2         26 return;
310             }
311              
312             #-----------------------------------------------------------------------------
313              
314             sub set_string {
315 0     0 0 0 my ($elem, $string) = @_;
316 0 0       0 $string = '' unless $string;
317              
318 0         0 my $content = $elem->content;
319 0 0       0 if ($content =~ m/ ^ ['"] /x ) {
    0          
    0          
    0          
    0          
320 0         0 substr($content, 1, -1) = $string;
321             }
322             elsif ($content =~ m/^qq ./ ) {
323 0         0 substr($content, 4, -1) = $string;
324             }
325             elsif ($content =~ m/^qq./ ) {
326 0         0 substr($content, 3, -1) = $string;
327             }
328             elsif ($content =~ m/^q ./ ) {
329 0         0 substr($content, 3, -1) = $string;
330             }
331             elsif ($content =~ m/^q./ ) {
332 0         0 substr($content, 2, -1) = $string;
333             }
334             else {
335 0         0 die "Unknown string delimiters! >$content<\n";
336             }
337 0         0 $elem->set_content( $content );
338             }
339              
340             #-----------------------------------------------------------------------------
341              
342             sub make_ppi_structure_block {
343 0     0 0 0 my $new_list = PPI::Structure::Block->new(
344             PPI::Token::Structure->new('{'),
345             );
346 0         0 $new_list->{finish} = PPI::Token::Structure->new('}');
347              
348 0         0 return $new_list;
349             }
350              
351             #-----------------------------------------------------------------------------
352              
353             sub make_ppi_structure_list {
354 3     3 0 13 my $new_list = PPI::Structure::List->new(
355             PPI::Token::Structure->new('('),
356             );
357 3         92 $new_list->{finish} = PPI::Token::Structure->new(')');
358              
359 3         81 return $new_list;
360             }
361              
362             #-----------------------------------------------------------------------------
363              
364             sub is_ppi_generic_statement {
365 0     0 1 0 my $element = shift;
366              
367 0         0 my $element_class = blessed($element);
368              
369 0 0       0 return if not $element_class;
370 0 0       0 return if not $element->isa('PPI::Statement');
371              
372 0         0 return $element_class eq 'PPI::Statement';
373             }
374              
375             #-----------------------------------------------------------------------------
376              
377             sub is_ppi_statement_subclass {
378 0     0 1 0 my $element = shift;
379              
380 0         0 my $element_class = blessed($element);
381              
382 0 0       0 return if not $element_class;
383 0 0       0 return if not $element->isa('PPI::Statement');
384              
385 0         0 return $element_class ne 'PPI::Statement';
386             }
387              
388             #-----------------------------------------------------------------------------
389              
390             # Can not use hashify() here because Perl::Critic::Utils already depends on
391             # this module.
392             Readonly::Hash my %SIMPLE_STATEMENT_CLASS => map { $_ => 1 } qw<
393             PPI::Statement
394             PPI::Statement::Break
395             PPI::Statement::Include
396             PPI::Statement::Null
397             PPI::Statement::Package
398             PPI::Statement::Variable
399             >;
400              
401             sub is_ppi_simple_statement {
402 0 0   0 1 0 my $element = shift or return;
403              
404 0 0       0 my $element_class = blessed( $element ) or return;
405              
406 0         0 return $SIMPLE_STATEMENT_CLASS{ $element_class };
407             }
408              
409             #-----------------------------------------------------------------------------
410              
411             sub is_ppi_constant_element {
412 0 0   0 0 0 my $element = shift or return;
413              
414 0 0       0 blessed( $element ) or return;
415              
416             # TODO implement here documents once PPI::Token::HereDoc grows the
417             # necessary PPI::Token::Quote interface.
418             return
419 0   0     0 $element->isa( 'PPI::Token::Number' )
420             || $element->isa( 'PPI::Token::Quote::Literal' )
421             || $element->isa( 'PPI::Token::Quote::Single' )
422             || $element->isa( 'PPI::Token::QuoteLike::Words' )
423             || (
424             $element->isa( 'PPI::Token::Quote::Double' )
425             || $element->isa( 'PPI::Token::Quote::Interpolate' ) )
426             && $element->string() !~ m< (?: \A | [^\\] ) (?: \\\\)* [\$\@] >smx
427             ;
428             }
429              
430             #-----------------------------------------------------------------------------
431              
432             sub is_package_boundary {
433 0     0 0 0 my ($elem) = @_;
434 0 0       0 return unless $elem;
435 0 0       0 return 1 if $elem->isa('PPI::Statement::Package');
436 0 0       0 return 1 if $elem->isa('PPI::Statement::End');
437 0 0       0 return 1 if $elem->isa('PPI::Statement::Data');
438 0 0       0 return 1 if $elem->isa('PPI::Token::Separator');
439 0         0 return;
440             }
441              
442             #-----------------------------------------------------------------------------
443              
444             sub is_subroutine_declaration {
445 0     0 0 0 my $element = shift;
446              
447 0 0       0 return if not $element;
448              
449 0 0       0 return 1 if $element->isa('PPI::Statement::Sub');
450              
451 0 0       0 if ( is_ppi_generic_statement($element) ) {
452 0         0 my $first_element = $element->first_element();
453              
454 0 0 0     0 return 1 if
      0        
455             $first_element
456             and $first_element->isa('PPI::Token::Word')
457             and $first_element->content() eq 'sub';
458             }
459              
460 0         0 return;
461             }
462              
463             #-----------------------------------------------------------------------------
464              
465             sub is_in_subroutine {
466 0     0 0 0 my ($element) = @_;
467              
468 0 0       0 return if not $element;
469 0 0       0 return 1 if is_subroutine_declaration($element);
470              
471 0         0 while ( $element = $element->parent() ) {
472 0 0       0 return 1 if is_subroutine_declaration($element);
473             }
474              
475 0         0 return;
476             }
477              
478             #-----------------------------------------------------------------------------
479              
480             sub get_constant_name_element_from_declaring_statement {
481 0     0 0 0 my ($element) = @_;
482              
483 0         0 warnings::warnif(
484             'deprecated',
485             'Perl::Critic::Utils::PPI::get_constant_name_element_from_declaring_statement() is deprecated. Use PPIx::Utilities::Statement::get_constant_name_elements_from_declaring_statement() instead.',
486             );
487              
488 0 0       0 return if not $element;
489 0 0       0 return if not $element->isa('PPI::Statement');
490              
491 0 0 0     0 if ( $element->isa('PPI::Statement::Include') ) {
    0          
492 0         0 my $pragma;
493 0 0 0     0 if ( $pragma = $element->pragma() and $pragma eq 'constant' ) {
494 0         0 return _constant_name_from_constant_pragma($element);
495             }
496             }
497             elsif (
498             is_ppi_generic_statement($element)
499             and $element->schild(0)->content() =~ m< \A Readonly \b >xms
500             ) {
501 0         0 return $element->schild(2);
502             }
503              
504 0         0 return;
505             }
506              
507             sub _constant_name_from_constant_pragma {
508 0     0   0 my ($include) = @_;
509              
510 0 0       0 my @arguments = $include->arguments() or return;
511              
512 0         0 my $follower = $arguments[0];
513 0 0       0 return if not defined $follower;
514              
515 0         0 return $follower;
516             }
517              
518             #-----------------------------------------------------------------------------
519              
520             sub get_next_element_in_same_simple_statement {
521 0 0   0 0 0 my $element = shift or return;
522              
523 0   0     0 while ( $element and (
      0        
524             not is_ppi_simple_statement( $element )
525             or $element->parent()
526             and $element->parent()->isa( 'PPI::Structure::List' ) ) ) {
527 0         0 my $next;
528 0 0       0 $next = $element->snext_sibling() and return $next;
529 0         0 $element = $element->parent();
530             }
531 0         0 return;
532              
533             }
534              
535             #-----------------------------------------------------------------------------
536              
537             sub get_previous_module_used_on_same_line {
538 0 0   0 0 0 my $element = shift or return;
539              
540 0 0       0 my ( $line ) = @{ $element->location() || []};
  0         0  
541              
542 0         0 while (not is_ppi_simple_statement( $element )) {
543 0 0       0 $element = $element->parent() or return;
544             }
545              
546 0         0 while ( $element = $element->sprevious_sibling() ) {
547 0 0       0 ( @{ $element->location() || []} )[0] == $line or return;
  0 0       0  
548 0 0       0 $element->isa( 'PPI::Statement::Include' )
549             and return $element->schild( 1 );
550             }
551              
552 0         0 return;
553             }
554              
555             #-----------------------------------------------------------------------------
556              
557             sub is_ppi_expression_or_generic_statement {
558 4     4 1 5 my $element = shift;
559              
560 4 50       131 return if not $element;
561 4 50       20 return if not $element->isa('PPI::Statement');
562 4 100       20 return 1 if $element->isa('PPI::Statement::Expression');
563              
564 2         11 my $element_class = blessed($element);
565              
566 2 50       7 return if not $element_class;
567 2         9 return $element_class eq 'PPI::Statement';
568             }
569             #-----------------------------------------------------------------------------
570              
571             1;
572              
573             __END__
574              
575             =pod
576              
577             =for stopwords
578              
579             =head1 NAME
580              
581             Perl::ToPerl6::Utils::PPI - Utility functions for dealing with PPI objects.
582              
583              
584             =head1 DESCRIPTION
585              
586             Provides classification of L<PPI::Elements|PPI::Elements>.
587              
588              
589             =head1 INTERFACE SUPPORT
590              
591             This is considered to be a public module. Any changes to its
592             interface will go through a deprecation cycle.
593              
594              
595             =head1 IMPORTABLE SUBS
596              
597             =over
598              
599             =item C<dscanf( $format_string, {options=>1} )>
600              
601             'a' -
602             'b' -
603             'c' -
604             'd' - Specify an integer in an arbitrary base.
605             If you want integers in a base other than decimal, add a modifier:
606             'bd' - Binary integer
607             'od' - Octal integer
608             'xd' - Hexadecimal integer
609             'e' -
610             'f' - Specify a floating-point number.
611             If you want floating-point numbers in exponential notation, add
612             a modifier:
613             'ef' - Exponential number
614             'g' -
615             'h' -
616             'i' -
617             'j' -
618             'k' -
619             'l' -
620             'm' -
621             'n' -
622             'o' -
623             'p' -
624             'q' -
625             'r' - Specify a regular expression.
626             Note that this will match C</foo/>, C<s/foo/bar/>, C<y/a-m/n-z/>.
627             If you want to match a specific regex type, then preface 'r' with:
628             'mr' - Matching regular expression
629             'sr' - Substitution regular expression
630             'tr' - Transliterating regular expression
631             's' - Specify a quoted string.
632             This will match both C<'foo'> and C<qq qfooq> by default.
633             If you want to match a specific string type, then preface 's' with:
634             'ds' - Double-quoted string
635             'ls' - Literal string type
636             'ss' - Single-quoted string
637             'is' - Interpolated string
638             't' -
639             'u' -
640             'v' - Specify a Perl variable.
641             If you want a specific type of variable, add one of these modifiers:
642             'av' - Array variable
643             'gv' - GLOB variable
644             'hv' - Hash variable
645             'sv' - Scalar variable
646             'w' -
647             'x' -
648             'y' -
649             'z' -
650              
651             'A' -
652             'B' -
653             'C' -
654             'D' -
655             'E' -
656             'F' -
657             'G' -
658             'H' -
659             'I' -
660             'J' -
661             'K' -
662             'L' - A list.
663             'M' -
664             'N' -
665             'O' -
666             'P' - An explicit L<PPI> node type, C<'%P{Token::Word}'> for instance.
667             You can prefix this with C<'PPI::'> but it's considered redundant.
668             'Q' -
669             'R' -
670             'S' -
671             'T' -
672             'U' -
673             'V' -
674             'W' -
675             'X' -
676             'Y' -
677             'Z' -
678              
679             =item C<is_ppi_expression_or_generic_statement( $element )>
680              
681             Answers whether the parameter is an expression or an undifferentiated
682             statement. I.e. the parameter either is a
683             L<PPI::Statement::Expression|PPI::Statement::Expression> or the class
684             of the parameter is L<PPI::Statement|PPI::Statement> and not one of
685             its subclasses other than C<Expression>.
686              
687              
688             =item C<is_ppi_generic_statement( $element )>
689              
690             Answers whether the parameter is an undifferentiated statement, i.e.
691             the parameter is a L<PPI::Statement|PPI::Statement> but not one of its
692             subclasses.
693              
694              
695             =item C<is_ppi_statement_subclass( $element )>
696              
697             Answers whether the parameter is a specialized statement, i.e. the
698             parameter is a L<PPI::Statement|PPI::Statement> but the class of the
699             parameter is not L<PPI::Statement|PPI::Statement>.
700              
701              
702             =item C<is_ppi_simple_statement( $element )>
703              
704             Answers whether the parameter represents a simple statement, i.e. whether the
705             parameter is a L<PPI::Statement|PPI::Statement>,
706             L<PPI::Statement::Break|PPI::Statement::Break>,
707             L<PPI::Statement::Include|PPI::Statement::Include>,
708             L<PPI::Statement::Null|PPI::Statement::Null>,
709             L<PPI::Statement::Package|PPI::Statement::Package>, or
710             L<PPI::Statement::Variable|PPI::Statement::Variable>.
711              
712             =back
713              
714             =head1 AUTHOR
715              
716             Jeffrey Goff <drforr@pobox.com>
717              
718             =head1 AUTHOR EMERITUS
719              
720             Elliot Shank <perl@galumph.com>
721              
722              
723             =head1 COPYRIGHT
724              
725             Copyright (c) 2007-2011 Elliot Shank.
726              
727             This program is free software; you can redistribute it and/or modify
728             it under the same terms as Perl itself. The full text of this license
729             can be found in the LICENSE file included with this module.
730              
731             =cut
732              
733             # Local Variables:
734             # mode: cperl
735             # cperl-indent-level: 4
736             # fill-column: 78
737             # indent-tabs-mode: nil
738             # c-indentation-style: bsd
739             # End:
740             # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :