From 4fedb8934c65e0139bf5d2a99ef7bab4fbd4c0f4 Mon Sep 17 00:00:00 2001 From: Christian Walde Date: Tue, 19 Jul 2022 13:26:12 +0200 Subject: [PATCH] proof-of-concept for feature-tracking and perl sub signatures (see #273) --- lib/PPI/Element.pm | 17 +++++++- lib/PPI/Statement/Include.pm | 24 ++++++++++ lib/PPI/Token.pm | 1 + lib/PPI/Token/Signature.pm | 55 +++++++++++++++++++++++ lib/PPI/Token/Whitespace.pm | 16 ++++++- t/feature_tracking.t | 85 ++++++++++++++++++++++++++++++++++++ 6 files changed, 195 insertions(+), 3 deletions(-) create mode 100644 lib/PPI/Token/Signature.pm create mode 100644 t/feature_tracking.t diff --git a/lib/PPI/Element.pm b/lib/PPI/Element.pm index 2ee74d53..36c6e1f3 100644 --- a/lib/PPI/Element.pm +++ b/lib/PPI/Element.pm @@ -467,9 +467,24 @@ sub previous_token { } } +sub presumed_features { + my ($self) = @_; + + my @feature_mods; + my $walker = $self; + while ($walker) { + my $sib_walk = $walker; + while ($sib_walk) { + push @feature_mods, $sib_walk if $sib_walk->can("feature_mods"); + $sib_walk = $sib_walk->sprevious_sibling; + } + $walker = $walker->parent; + } + my %feature_mods = map %{$_}, reverse map $_->feature_mods, @feature_mods; - + return \%feature_mods; +} ##################################################################### # Manipulation diff --git a/lib/PPI/Statement/Include.pm b/lib/PPI/Statement/Include.pm index ae8d3120..a8da6bbb 100644 --- a/lib/PPI/Statement/Include.pm +++ b/lib/PPI/Statement/Include.pm @@ -48,6 +48,8 @@ use strict; use PPI::Statement (); use PPI::Statement::Include::Perl6 (); +use feature (); + our $VERSION = '1.277'; our @ISA = "PPI::Statement"; @@ -236,6 +238,28 @@ sub arguments { return @args; } +sub feature_mods { + my ($self) = @_; + + return if $self->type eq "require"; + + if ( my $perl_version = $self->version ) { + ## crude proof of concept hack due to above + return { signatures => 1 } if $perl_version >= 5.035; + + # # tried using feature.pm here, but it is impossible to install + # # future versions of it, so e.g. a 5.20 install cannot know about + # # 5.36 features + # $perl_version = join ".", # + # ( split /\./, $perl_version )[0], + # 0 + ( split /\./, $perl_version )[1]; + # my $bundle = $feature::feature_bundle{$perl_version}; + # return { map +( $_ => 1 ), %{$bundle} }; + } + + return; +} + 1; =pod diff --git a/lib/PPI/Token.pm b/lib/PPI/Token.pm index e261fb18..41609116 100644 --- a/lib/PPI/Token.pm +++ b/lib/PPI/Token.pm @@ -70,6 +70,7 @@ use PPI::Token::Separator (); use PPI::Token::Data (); use PPI::Token::End (); use PPI::Token::Prototype (); +use PPI::Token::Signature (); use PPI::Token::Attribute (); use PPI::Token::Unknown (); diff --git a/lib/PPI/Token/Signature.pm b/lib/PPI/Token/Signature.pm new file mode 100644 index 00000000..0ecf8556 --- /dev/null +++ b/lib/PPI/Token/Signature.pm @@ -0,0 +1,55 @@ +package PPI::Token::Signature; + +=pod + +=head1 NAME + +PPI::Token::Signature - A subroutine signature descriptor + +=head1 INHERITANCE + + PPI::Token::Signature + isa PPI::Token::Prototype + isa PPI::Token + isa PPI::Element + +=head1 SYNOPSIS + + TODO: document + +=head1 DESCRIPTION + + TODO: document + +=cut + +use strict; +use PPI::Token::Prototype (); + +our $VERSION = '1.276'; + +our @ISA = "PPI::Token::Prototype"; + +1; + +=pod + +=head1 SUPPORT + +See the L in the main module. + +=head1 AUTHOR + +Adam Kennedy Eadamk@cpan.orgE + +=head1 COPYRIGHT + +Copyright 2001 - 2011 Adam Kennedy. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut diff --git a/lib/PPI/Token/Whitespace.pm b/lib/PPI/Token/Whitespace.pm index 2874b3da..21665424 100644 --- a/lib/PPI/Token/Whitespace.pm +++ b/lib/PPI/Token/Whitespace.pm @@ -212,8 +212,20 @@ sub __TOKENIZER__on_char { # 2. The one before that is the word 'sub'. # 3. The one before that is a 'structure' - # Get the three previous significant tokens - my @tokens = $t->_previous_significant_tokens(3); + # Get at least the three previous significant tokens, and extend the + # retrieval range to include at least one token that can walk the + # already generated tree. (i.e. has a parent) + my ( $tokens_to_get, @tokens ) = (3); + while ( !@tokens or ( $tokens[-1] and !$tokens[-1]->parent ) ) { + @tokens = $t->_previous_significant_tokens($tokens_to_get); + last if @tokens < $tokens_to_get; + $tokens_to_get++; + } + + my ($closest_parented_token) = grep $_->parent, @tokens; + return 'Signature' + if $closest_parented_token + and $closest_parented_token->presumed_features->{signatures}; # A normal subroutine declaration my $p1 = $tokens[1]; diff --git a/t/feature_tracking.t b/t/feature_tracking.t new file mode 100644 index 00000000..ffe8df58 --- /dev/null +++ b/t/feature_tracking.t @@ -0,0 +1,85 @@ +#!/usr/bin/perl + +use lib 't/lib'; +use PPI::Test::pragmas; +use Test::More tests => 1 + ( $ENV{AUTHOR_TESTING} ? 1 : 0 ); + +use B 'perlstring'; + +use PPI (); + +#use DB::Skip subs => [ +# qw( PPI::Document::new PPI::Lexer::lex_source PPI::Lexer::new +# PPI::Lexer::_clear PPI::Lexer::(eval) PPI::Lexer::X_TOKENIZER +# PPI::Tokenizer::new PPI::Lexer::lex_tokenizer PPI::Node::new ), +# qr/^PPI::Tokenizer::__ANON__.*237.*$/ +#]; + +sub test_document; + +FEATURE_TRACKING: { + test_document + <<'END_PERL', + sub meep(&$) {} + use 5.035; + sub marp($left, $right) {} +END_PERL + [ + 'PPI::Statement::Sub' => 'sub meep(&$) {}', + 'PPI::Token::Word' => 'sub', + 'PPI::Token::Word' => 'meep', + 'PPI::Token::Prototype' => '(&$)', + 'PPI::Structure::Block' => '{}', + 'PPI::Token::Structure' => '{', + 'PPI::Token::Structure' => '}', + 'PPI::Statement::Include' => 'use 5.035;', + 'PPI::Token::Word' => 'use', + 'PPI::Token::Number::Float' => '5.035', + 'PPI::Token::Structure' => ';', + 'PPI::Statement::Sub' => 'sub marp($left, $right) {}', + 'PPI::Token::Word' => 'sub', + 'PPI::Token::Word' => 'marp', + 'PPI::Token::Signature' => '($left, $right)', # !!!!!!!!!!!!!!!!!!!! + 'PPI::Structure::Block' => '{}', + 'PPI::Token::Structure' => '{', + 'PPI::Token::Structure' => '}', + ]; +} + +### TODO from ppi_token_unknown.t , deduplicate + +sub one_line_explain { + my ($data) = @_; + my @explain = explain $data; + s/\n//g for @explain; + return join "", @explain; +} + +sub main_level_line { + return "" if not $TODO; + my @outer_final; + my $level = 0; + while ( my @outer = caller( $level++ ) ) { + @outer_final = @outer; + } + return "l $outer_final[2] - "; +} + +sub test_document { + local $Test::Builder::Level = $Test::Builder::Level + 1; + my ( $code, $expected, $msg ) = @_; + $msg = perlstring $code if !defined $msg; + + my $d = PPI::Document->new( \$code ); + my $tokens = $d->find( sub { $_[1]->significant } ); + $tokens = [ map { ref($_), $_->content } @$tokens ]; + + my $ok = is_deeply( $tokens, $expected, main_level_line . $msg ); + if ( !$ok ) { + diag ">>> $code -- $msg\n"; + diag one_line_explain $tokens; + diag one_line_explain $expected; + } + + return; +}