proof-of-concept for feature-tracking and perl sub signatures (see #273)

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

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

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               ();
 

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<support section|PPI/SUPPORT> in the main module.
+
+=head1 AUTHOR
+
+Adam Kennedy E<lt>adamk@cpan.orgE<gt>
+
+=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

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];

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;
+}