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

lib/PPI/Document.pm

@@ -128,17 +128,22 @@ In all cases, the document is considered to be "anonymous" and not tied back
 to where it was created from. Specifically, if you create a PPI::Document from
 a filename, the document will B<not> remember where it was created from.
 
+Returns a C<PPI::Document> object, or C<undef> if parsing fails.
+L<PPI::Exception> objects can also be thrown if there are parsing problems.
+
 The constructor also takes attribute flags.
 
-At this time, the only available attribute is the C<readonly> flag.
+=head3 readonly
 
-Setting C<readonly> to true will allow various systems to provide
-additional optimisations and caching. Note that because C<readonly> is an
-optimisation flag, it is off by default and you will need to explicitly
-enable it.
+Setting C<readonly> to true will allow various systems to provide additional
+optimisations and caching. Note that because C<readonly> is an optimisation
+flag, it is off by default and you will need to explicitly enable it.
 
-Returns a C<PPI::Document> object, or C<undef> if parsing fails.
-L<PPI::Exception> objects can also be thrown if there are parsing problems.
+=head3 feature_mods
+
+Setting feature_mods with a hashref allows defining perl parsing features to be
+enabled for the whole document. (e.g. when the code is assumed to be run as a
+oneliner)
 
 =cut
 
@@ -181,25 +186,25 @@ sub new {
 			my $document = $CACHE->get_document($file_contents);
 			return $class->_setattr( $document, %attr ) if $document;
 
-			$document = PPI::Lexer->lex_source( $$file_contents );
+			$document = PPI::Lexer->lex_source( $$file_contents, %attr );
 			if ( $document ) {
 				# Save in the cache
 				$CACHE->store_document( $document );
-				return $class->_setattr( $document, %attr );
+				return $document;
 			}
 		} else {
-			my $document = PPI::Lexer->lex_file( $source );
+			my $document = PPI::Lexer->lex_file( $source, %attr );
 			return $class->_setattr( $document, %attr ) if $document;
 		}
 
 	} elsif ( _SCALAR0($source) ) {
-		my $document = PPI::Lexer->lex_source( $$source );
-		return $class->_setattr( $document, %attr ) if $document;
+		my $document = PPI::Lexer->lex_source( $$source, %attr );
+		return $document if $document;
 
 	} elsif ( _ARRAY0($source) ) {
 		$source = join '', map { "$_\n" } @$source;
-		my $document = PPI::Lexer->lex_source( $source );
-		return $class->_setattr( $document, %attr ) if $document;
+		my $document = PPI::Lexer->lex_source( $source, %attr );
+		return $document if $document;
 
 	} else {
 		$class->_error("Unknown object or reference was passed to PPI::Document::new");
@@ -229,6 +234,7 @@ sub _setattr {
 	my ($class, $document, %attr) = @_;
 	$document->{readonly} = !! $attr{readonly};
 	$document->{filename} = $attr{filename};
+	$document->{feature_mods} = $attr{feature_mods};
 	return $document;
 }
 
@@ -344,6 +350,16 @@ sub tab_width {
 	$self->{tab_width} = shift;
 }
 
+=head2 feature_mods { feature_name => $enabled }
+
+=cut
+
+sub feature_mods {
+	my $self = shift;
+	return $self->{feature_mods} unless @_;
+	$self->{feature_mods} = shift;
+}
+
 =pod
 
 =head2 save

lib/PPI/Element.pm

@@ -467,9 +467,25 @@ 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 grep defined, map $_->feature_mods,
+	  @feature_mods;
 
-
+	return \%feature_mods;
+}
 
 #####################################################################
 # Manipulation

lib/PPI/Lexer.pm

@@ -143,6 +143,7 @@ sub lex_file {
 	unless ( defined $file ) {
 		return $self->_error("Did not pass a filename to PPI::Lexer::lex_file");
 	}
+	my %args = @_;
 
 	# Create the Tokenizer
 	my $Tokenizer = eval {
@@ -154,7 +155,7 @@ sub lex_file {
 		return $self->_error( $errstr );
 	}
 
-	$self->lex_tokenizer( $Tokenizer );
+	$self->lex_tokenizer( $Tokenizer, %args );
 }
 
 =pod
@@ -175,6 +176,7 @@ sub lex_source {
 	unless ( defined $source and not ref $source ) {
 		return $self->_error("Did not pass a string to PPI::Lexer::lex_source");
 	}
+	my %args = @_;
 
 	# Create the Tokenizer and hand off to the next method
 	my $Tokenizer = eval {
@@ -186,7 +188,7 @@ sub lex_source {
 		return $self->_error( $errstr );
 	}
 
-	$self->lex_tokenizer( $Tokenizer );
+	$self->lex_tokenizer( $Tokenizer, %args );
 }
 
 =pod
@@ -206,9 +208,11 @@ sub lex_tokenizer {
 	return $self->_error(
 		"Did not pass a PPI::Tokenizer object to PPI::Lexer::lex_tokenizer"
 	) unless $Tokenizer;
+	my %args = @_;
 
 	# Create the empty document
 	my $Document = PPI::Document->new;
+	ref($Document)->_setattr( $Document, %args ) if keys %args;
 
 	# Lex the token stream into the document
 	$self->{Tokenizer} = $Tokenizer;

lib/PPI/Statement/Include.pm

@@ -236,6 +236,38 @@ sub arguments {
 	return @args;
 }
 
+sub feature_mods {
+	my ($self) = @_;
+
+	my %known = ( signatures => 1 );
+
+	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} };
+	}
+
+	if ( $self->module eq "feature" ) {
+		my @features = grep $known{$_}, map $_->literal,
+		  map $_->isa("PPI::Structure::List") ? $_->children : $_,
+		  $self->arguments;
+		my $on_or_off = $self->type eq "use" ? 1 : 0;
+		return { map +( $_ => $on_or_off ), @features } if @features;
+	}
+
+	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

@@ -213,8 +213,21 @@ 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;
+		die "no parented element found" unless    #
+		  $closest_parented_token ||= $Document;
+		return 'Signature'
+		  if $closest_parented_token->presumed_features->{signatures};
 
 		# A normal subroutine declaration
 		my $p1 = $tokens[1];