parse prototypes as Quote::Literal

Author: wchristian

Changes

@@ -1,6 +1,9 @@
 Revision history for Perl extension PPI
 
 {{$NEXT}}
+	Summary:
+	- Parse prototypes as literal quotes, enables parens and newlines in protos
+
 	Details:
 	- Wrapped most Document->new calls in tests with automatic checks
 

lib/PPI/Token/Prototype.pm

@@ -51,24 +51,7 @@ use PPI::Token ();
 
 our $VERSION = '1.277';
 
-our @ISA = "PPI::Token";
-
-sub __TOKENIZER__on_char {
-	my $class = shift;
-	my $t     = shift;
-
-	# Suck in until we find the closing paren (or the end of line)
-	pos $t->{line} = $t->{line_cursor};
-	die "regex should always match" if $t->{line} !~ m/\G(.*?\n?(?:\)|$))/gc;
-	$t->{token}->{content} .= $1;
-	$t->{line_cursor} += length $1;
-
-	# Shortcut if end of line
-	return 0 unless $1 =~ /\)$/;
-
-	# Found the closing paren
-	$t->_finalize_token->__TOKENIZER__on_char( $t );
-}
+our @ISA = "PPI::Token::Quote::Literal";
 
 =pod
 

lib/PPI/Token/Quote/Literal.pm

@@ -47,8 +47,9 @@ our @ISA = qw{
 sub string {
 	my $self     = shift;
 	my @sections = $self->_sections;
-	my $str      = $sections[0];
-	substr( $self->{content}, $str->{position}, $str->{size} );	
+	return unless    #
+	  my $str = $sections[0];
+	substr( $self->{content}, $str->{position}, $str->{size} );
 }
 
 

lib/PPI/Token/_QuoteEngine/Full.pm

@@ -43,6 +43,9 @@ my %QUOTES = (
 	# used yet, since I'm not sure on the context differences between
 	# this and the trinary operator, but it's here for completeness.
 	'?'   => { operator => undef, braced => 0,     separator => '?',   _sections => 1, modifiers => 1 },
+
+	# parse prototypes as a literal quote
+	'('   => { operator => undef, braced => 1,     separator => undef, _sections => 1, },
 );
 
 
@@ -70,9 +73,8 @@ sub new {
 	$self->{modifiers} = {} if $self->{modifiers};
 
 	# Handle the special < base
-	if ( $init eq '<' ) {
-		$self->{sections}->[0] = Clone::clone( $SECTIONS{'<'} );
-	}
+	$self->{sections}[0] = Clone::clone $SECTIONS{'<'} if $init eq '<';
+	$self->{sections}[0] = Clone::clone $SECTIONS{'('} if $init eq '(';
 
 	$self;
 }

t/ppi_token_prototype.t

@@ -4,7 +4,7 @@
 
 use lib 't/lib';
 use PPI::Test::pragmas;
-use Test::More tests => 104 + ( $ENV{AUTHOR_TESTING} ? 1 : 0 );
+use Test::More tests => 120 + ( $ENV{AUTHOR_TESTING} ? 1 : 0 );
 
 use PPI ();
 use Helper 'safe_new';
@@ -34,7 +34,10 @@ PARSING: {
 	## invalid chars in prototype
 	check_w_subs \@sub_patterns, '(!-=|)', '(!-=|)', '!-=|';
 	## perl refuses to compile this
-	check_w_subs \@sub_patterns, '(()', '(()', '(';
+	check_w_subs \@sub_patterns, '(()', '(()', '(', 1;
+	check_w_subs \@sub_patterns, '((a))', '((a))', '(a)';
+	check_w_subs \@sub_patterns,    #
+	  "(\n(\na\n)\n)", "(\n(\na\n)\n)", "(a)";
 }
 
 sub check_w_subs {
@@ -46,7 +49,7 @@ sub check_w_subs {
 sub check {
 	local $Test::Builder::Level = $Test::Builder::Level + 1;
 	my ( $name, $block, $code_prototype, $expected_content,
-		$expected_prototype )
+		$expected_prototype, $tail )
 	  = @_;
 	my $desc = my $code = "$name$code_prototype$block";
 	$desc =~ s/\n/\\n/g;
@@ -60,9 +63,10 @@ sub check {
 		$all_prototypes = [] if !ref $all_prototypes;
 		is scalar(@$all_prototypes), 1, "got exactly one prototype";
 		my $prototype_obj = $all_prototypes->[0];
-		is $prototype_obj, $expected_content,
+		is $prototype_obj, $expected_content . ( $tail ? $block : "" ),
 		  "prototype object content matches";
-		is $prototype_obj->prototype, $expected_prototype,
+		is $prototype_obj->prototype,
+		  $expected_prototype . ( $tail ? ")$block" : "" ),
 		  "prototype characters match";
 	};
 	return;

t/ppi_token_quote_literal.t

@@ -4,32 +4,33 @@
 
 use lib 't/lib';
 use PPI::Test::pragmas;
-use Test::More tests => 20 + ( $ENV{AUTHOR_TESTING} ? 1 : 0 );
+use Test::More tests => 23 + ( $ENV{AUTHOR_TESTING} ? 1 : 0 );
 use B qw( perlstring );
 
 use PPI ();
 use Helper 'safe_new';
 
-
 STRING: {
-	my $Document = safe_new \"print q{foo}, q!bar!, q <foo>;";
+	my $Document = safe_new \"print q{foo}, q!bar!, q <foo>, q((foo));";
 	my $literal = $Document->find('Token::Quote::Literal');
-	is( scalar(@$literal), 3, '->find returns three objects' );
+	is( scalar(@$literal), 4, '->find returns three objects' );
 	isa_ok( $literal->[0], 'PPI::Token::Quote::Literal' );
 	isa_ok( $literal->[1], 'PPI::Token::Quote::Literal' );
 	isa_ok( $literal->[2], 'PPI::Token::Quote::Literal' );
-	is( $literal->[0]->string, 'foo', '->string returns as expected' );
-	is( $literal->[1]->string, 'bar', '->string returns as expected' );
-	is( $literal->[2]->string, 'foo', '->string returns as expected' );
+	isa_ok( $literal->[3], 'PPI::Token::Quote::Literal' );
+	is( $literal->[0]->string, 'foo',   '->string returns as expected' );
+	is( $literal->[1]->string, 'bar',   '->string returns as expected' );
+	is( $literal->[2]->string, 'foo',   '->string returns as expected' );
+	is( $literal->[3]->string, '(foo)', '->string returns as expected' );
 }
 
-
 LITERAL: {
-	my $Document = safe_new \"print q{foo}, q!bar!, q <foo>;";
+	my $Document = safe_new \"print q{foo}, q!bar!, q <foo>, q((foo));";
 	my $literal = $Document->find('Token::Quote::Literal');
-	is( $literal->[0]->literal, 'foo', '->literal returns as expected' );
-	is( $literal->[1]->literal, 'bar', '->literal returns as expected' );
-	is( $literal->[2]->literal, 'foo', '->literal returns as expected' );
+	is( $literal->[0]->literal, 'foo',   '->literal returns as expected' );
+	is( $literal->[1]->literal, 'bar',   '->literal returns as expected' );
+	is( $literal->[2]->literal, 'foo',   '->literal returns as expected' );
+	is( $literal->[3]->literal, '(foo)', '->literal returns as expected' );
 }
 
 test_statement(