Sync the line numbers with the input script

- By default, add `#line` directives to the generated script so that errors will be reported somewhere near the input file/line number. Closes interpreters#14. - New option `--Elines` to suppress that, so that you can look at the `-E` output and find exactly where the error is. - Bumped version number to 0.4.0.
cxw42 · May 15, 2018 · 323ebf9 · 323ebf9
1 parent 6afdde6
commit 323ebf9
Show file tree

Hide file tree

Showing 6 changed files with 143 additions and 33 deletions.
diff --git a/Makefile.PL b/Makefile.PL
@@ -36,7 +36,7 @@ WriteMakefile(
         'Test::More' => '0',
     },
     PREREQ_PM => {
-        'Getopt::Long'     => '2.50',   # Per issue #17
+        'Getopt::Long'     => '2.5',    # Per issue #17
         'Pod::Usage'       => '0',
     },
     dist  => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },

diff --git a/bin/perlpp b/bin/perlpp
@@ -59,6 +59,15 @@ script.
 Don't evaluate Perl code, just write the generated code to STDOUT.
 By analogy with the C<-E> option of gcc.
 
+=item --Elines
+
+In case of an error in the input, perlpp normally tries to report a
+file and line number close to the location of the error in the source file.
+However, the match isn't always perfect.  If C<--Elines> is given, errors will
+be reported at the line number in the generated script.  The generated
+script will still include C<## sync> markers showing you about where the input
+files/lines are, for ease of reference.
+
 =item -k, --keep-going
 
 Normally, errors in a C<!command> sequence will terminate further

diff --git a/lib/Text/PerlPP.pm b/lib/Text/PerlPP.pm
@@ -3,7 +3,7 @@
 
 package Text::PerlPP;
 
-our $VERSION = '0.3.3_1';
+our $VERSION = '0.4.0';
 
 use 5.010001;
 use strict;
@@ -13,6 +13,7 @@ use Getopt::Long 2.5 qw(GetOptionsFromArray);
 use Pod::Usage;
 
 # === Constants ===========================================================
+
 use constant true			=> !!1;
 use constant false			=> !!0;
 
@@ -48,8 +49,10 @@ use constant OBMODE_SYSTEM	=> 6;	# an external command being run
 
 # Layout of the output-buffer stack.
 use constant OB_TOP 		=> 0;	# top of the stack is [0]: use [un]shift
-use constant OB_MODE 		=> 0;	# each stack entry is a two-element array
+
+use constant OB_MODE 		=> 0;	# indices of the stack entries
 use constant OB_CONTENTS 	=> 1;
+use constant OB_STARTLINE	=> 2;
 
 # === Globals =============================================================
 
@@ -73,12 +76,13 @@ my %Defs_repl_text = ();	# Replacement text for -D names
 our %Sets = ();				# Command-line -s arguments
 
 # Output-buffer stack
-my @OutputBuffers = ();		# each entry is a two-element array
+my @OutputBuffers = ();
+	# Each entry is an array of [mode, text, opening line number]
 
 # Debugging info
 my @OBModeNames = qw(plain capture code echo command comment);
 
-# === Code ================================================================
+# === Internal routines ===================================================
 
 # An alias for print().  This is used so that you can find print statements
 # in the generated script by searching for "print".
@@ -95,16 +99,18 @@ sub AddPostprocessor {
 	push( @Postprocessors, shift );
 }
 
+# --- Output buffers ----------------------------------------------
+
 # Open an output buffer.  Default mode is literal text.
 sub StartOB {
-	my $mode = OBMODE_PLAIN;
+	my $mode = shift // OBMODE_PLAIN;
+	my $lineno = shift // 1;
 
-	$mode = shift if @_;
 	if ( scalar @OutputBuffers == 0 ) {
 		$| = 1;					# flush contents of STDOUT
 		open( $RootSTDOUT, ">&STDOUT" ) or die $!;		# dup filehandle
 	}
-	unshift( @OutputBuffers, [ $mode, "" ] );
+	unshift( @OutputBuffers, [ $mode, "", $lineno ] );
 	close( STDOUT );			# must be closed before redirecting it to a variable
 	open( STDOUT, ">>", \$OutputBuffers[ OB_TOP ]->[ OB_CONTENTS ] ) or die $!;
 	$| = 1;						# do not use output buffering
@@ -145,10 +151,18 @@ sub ReadAndEmptyOB {
 	return $s;
 } #ReadAndEmptyOB()
 
+# Accessors
+
+sub GetStartLineOfOB {
+	return $OutputBuffers[ OB_TOP ]->[ OB_STARTLINE ];
+}
+
 sub GetModeOfOB {
 	return $OutputBuffers[ OB_TOP ]->[ OB_MODE ];
 }
 
+# --- String manipulation -----------------------------------------
+
 sub DQuoteString {	# wrap $_[0] in double-quotes, escaped properly
 	# Not currently used by PerlPP, but provided for use by scripts.
 	# TODO? inject into the generated script?
@@ -184,6 +198,8 @@ sub PrepareString {
 	return QuoteString( $s );
 }
 
+# --- Script-accessible commands ----------------------------------
+
 sub ExecuteCommand {
 	my $cmd = shift;
 	my $fn;
@@ -308,39 +324,60 @@ sub ShellOut {		# Run an external command
 	emit $block;
 } #ShellOut()
 
+# --- Delimiter processing ----------------------------------------
+
+# Print a "#line" line.  Filename must not contain /"/.
+sub emit_pound_line {
+	my ($fname, $lineno) = @_;
+	$lineno = 0+$lineno;
+	$fname = '' . $fname;
+
+	emit "\n#@{[ $Opts{DEBUG_LINENOS} ? '#sync' : 'line' ]} $lineno \"$fname\"\n";
+} #emit_pound_line()
+
 sub OnOpening {
 	# takes the rest of the string, beginning right after the ? of the tag_open
 	# returns (withinTag, string still to be processed)
 
-	my $after = shift;
+	my ($after, $lineno) = @_;
+
 	my $plain;
 	my $plainMode;
 	my $insetMode = OBMODE_CODE;
 
 	$plainMode = GetModeOfOB();
 	$plain = EndOB();						# plain text already seen
+
 	if ( $after =~ /^"/ && $plainMode == OBMODE_CAPTURE ) {
 		emit PrepareString( $plain );
 		# we are still buffering the inset contents,
 		# so we do not have to start it again
 	} else {
+
 		if ( $after =~ /^=/ ) {
 			$insetMode = OBMODE_ECHO;
+
 		} elsif ( $after =~ /^:/ ) {
 			$insetMode = OBMODE_COMMAND;
+
 		} elsif ( $after =~ /^#/ ) {
 			$insetMode = OBMODE_COMMENT;
+
 		} elsif ( $after =~ m{^\/} ) {
 			$plain .= "\n";		# newline after what we've already seen
 			# OBMODE_CODE
+
 		} elsif ( $after =~ /^(?:\s|$)/ ) {
 			# OBMODE_CODE
+
 		} elsif ( $after =~ /^!/ ) {
 			$insetMode = OBMODE_SYSTEM;
+
 		} elsif ( $after =~ /^"/ ) {
 			die "Unexpected end of capturing";
+
 		} else {
-			StartOB( $plainMode );					# skip non-PerlPP insets
+			StartOB( $plainMode, $lineno );		# skip non-PerlPP insets
 			emit $plain . TAG_OPEN;
 			return ( false, $after );
 				# Here $after is the entire rest of the input, so it is as if
@@ -349,40 +386,58 @@ sub OnOpening {
 
 		if ( $plainMode == OBMODE_CAPTURE ) {
 			emit PrepareString( $plain ) . " . do { Text::PerlPP::StartOB(); ";
-			StartOB( $plainMode );					# wrap the inset in a capturing mode
+			StartOB( $plainMode, $lineno );		# wrap the inset in a capturing mode
 		} else {
 			emit "print " . PrepareString( $plain ) . ";\n";
 		}
-		StartOB( $insetMode );						# contents of the inset
+
+		StartOB( $insetMode, $lineno );			# contents of the inset
 	}
 	return ( true, "" ) unless $after;
 	return ( true, substr( $after, 1 ) );
 } #OnOpening()
 
 sub OnClosing {
-	my $inside;
-	my $insetMode;
+	my $end_lineno = shift // 0;
+	my $fname = shift // "<unknown filename>";
+
 	my $nextMode = OBMODE_PLAIN;
 
-	$insetMode = GetModeOfOB();
-	$inside = EndOB();								# contents of the inset
+	my $start_lineno = GetStartLineOfOB();
+	my $insetMode = GetModeOfOB();
+	my $inside = EndOB();								# contents of the inset
+
 	if ( $inside =~ /"$/ ) {
-		StartOB( $insetMode );						# restore contents of the inset
+		StartOB( $insetMode, $end_lineno );				# restore contents of the inset
 		emit substr( $inside, 0, -1 );
 		$nextMode = OBMODE_CAPTURE;
+
 	} else {
 		if ( $insetMode == OBMODE_ECHO ) {
+			emit_pound_line $fname, $start_lineno;
 			emit "print ${inside};\n";				# don't wrap in (), trailing semicolon
+			emit_pound_line $fname, $end_lineno;
+
 		} elsif ( $insetMode == OBMODE_COMMAND ) {
 			ExecuteCommand( $inside );
+
 		} elsif ( $insetMode == OBMODE_COMMENT ) {
-			# Ignore the contents - no operation
+			# Ignore the contents - no operation.  Do resync, though.
+			emit_pound_line $fname, $end_lineno;
+
 		} elsif ( $insetMode == OBMODE_CODE ) {
+			emit_pound_line $fname, $start_lineno;
 			emit "$inside\n";	# \n so you can put comments in your perl code
+			emit_pound_line $fname, $end_lineno;
+
 		} elsif ( $insetMode == OBMODE_SYSTEM ) {
+			emit_pound_line $fname, $start_lineno;
 			ShellOut( $inside );
+			emit_pound_line $fname, $end_lineno;
+
 		} else {
 			emit $inside;
+
 		}
 
 		if ( GetModeOfOB() == OBMODE_CAPTURE ) {		# if the inset is wrapped
@@ -393,14 +448,12 @@ sub OnClosing {
 	StartOB( $nextMode );							# plain text
 } #OnClosing()
 
-# Print a "#line" line.  Filename must not contain /"/.
-sub emit_pound_line {
-	my ($fname, $lineno) = @_;
-	$lineno = 0+$lineno;
-	$fname = '' . $fname;
+# --- File processing ---------------------------------------------
 
-	emit "\n#line $lineno \"$fname\"\n";
-} #emit_pound_line
+# Count newlines in a string
+sub num_newlines {
+	return scalar ( () = $_[0] =~ /\n/g );
+} #num_newlines()
 
 # Process the contents of a single file
 sub RunPerlPPOnFileContents {
@@ -411,7 +464,7 @@ sub RunPerlPPOnFileContents {
 	my $withinTag = false;
 	my $lastPrep;
 
-	#my $lineno=1;	# approximated by the number of newlines we see
+	my $lineno=1;	# approximated by the number of newlines we see
 
 	$lastPrep = $#Preprocessors;
 	StartOB();										# plain text
@@ -421,9 +474,9 @@ sub RunPerlPPOnFileContents {
 	if ( $withinTag ) {
 		if ( $$contents_ref =~ CLOSING_RE ) {
 			emit $1;
+			$lineno += num_newlines($1);
 			$$contents_ref = $2;
-			#$lineno += ( () = ($1 . TAG_CLOSE) =~ /\n/g );
-			OnClosing();
+			OnClosing( $lineno, $fname );
 			# that could have been a command, which added new preprocessors
 			# but we don't want to run previously executed preps the second time
 			while ( $lastPrep < $#Preprocessors ) {
@@ -436,10 +489,9 @@ sub RunPerlPPOnFileContents {
 	} else {	# look for the next opening tag.  $1 is before; $2 is after.
 		if ( $$contents_ref =~ OPENING_RE ) {
 			emit $1;
-			( $withinTag, $$contents_ref ) = OnOpening( $2 );
-			#$lineno += ( () = ($1 . TAG_OPEN) =~ /\n/g );
+			$lineno += num_newlines($1);
+			( $withinTag, $$contents_ref ) = OnOpening( $2, $lineno );
 			if ( $withinTag ) {
-				#emit_pound_line $fname, $lineno if(GetModeOfOB() == OBMODE_CODE);
 				goto OPENING;		# $$contents_ref is the rest of the string
 			}
 		}
@@ -553,6 +605,7 @@ my %CMDLINE_OPTS = (
 	# lowercase before upper, although the code does not require that order.
 
 	DEBUG => ['d','|E|debug', false],
+	DEBUG_LINENOS => ['Elines','',false],	# if true, don't add #line markers
 	DEFS => ['D','|define:s%'],		# In %D, and text substitution
 	EVAL => ['e','|eval=s', ''],
 	# -h and --help reserved
@@ -622,6 +675,7 @@ sub parse_command_line {
 } #parse_command_line()
 
 # === Main ================================================================
+
 sub Main {
 	my $lrArgv = shift // [];
 	parse_command_line $lrArgv, \%Opts;
@@ -642,6 +696,12 @@ sub Main {
 		# $Package is not the whole name, so can start with a number.
 
 	StartOB();	# Output from here on will be included in the generated script
+
+	# Help the user know where to look
+	say "#line 1 \"<script: rerun with -E to see text>\"" if($Opts{DEBUG_LINENOS});
+	emit_pound_line '<package header>', 1;
+
+	# Open the package
 	emit "package PPP_${Package};\nuse 5.010001;\nuse strict;\nuse warnings;\n";
 	emit "use constant { true => !!1, false => !!0 };\n";
 
@@ -743,6 +803,7 @@ sub Main {
 } #Main()
 
 1;
+__END__
 # ### Documentation #######################################################
 
 =pod

diff --git a/t/02-cmdline.t b/t/02-cmdline.t
@@ -15,7 +15,7 @@ my @testcases=(
 	['--version','',qr/\bversion\b/],
 
 	# Debug output
-	['-d','',qr/^package PPP_;/],
+	['-d','',qr/^package PPP_;/m],
 	['-d', '<?= 2+2 ?>', qr{print\s+2\+2\s*;}],
 	['--debug', '<?= 2+2 ?>', qr{print\s+2\+2\s*;}],
 	['-E', '<?= 2+2 ?>', qr{print\s+2\+2\s*;}],

diff --git a/t/07-invalid.t b/t/07-invalid.t
@@ -5,6 +5,8 @@ use warnings;
 use Test::More;
 use IPC::Run3;
 use constant CMD => ($ENV{PERLPP_CMD} || 'perl -Iblib/lib blib/script/perlpp');
+(my $whereami = __FILE__) =~ s/07-invalid\.t$//;
+diag "perlpp command " . CMD . "; whereami $whereami.";
 
 my ($out, $err);
 
@@ -18,7 +20,25 @@ my @testcases=(
 	['<? o@no!!! ?>'],
 ); #@testcases
 
-plan tests => scalar @testcases;
+# Tests of line numbers when there are errors in the input
+my @testcases2 =(
+	# [error RE, perlpp options...]
+	[qr/multiline\.txt/, $whereami . 'multiline.txt'],
+	[qr/error.*line 12/, $whereami . 'multiline.txt'],
+	[qr/Number found.*line 13/, $whereami . 'multiline.txt'],
+
+	# Tests with --Elines.  Note: the specific line numbers here may need
+	# to be changed if the internals of perlpp change.  This is OK;
+	# please just make sure to document the change and the reason in the
+	# corresponding commit message.
+	[qr/script.*-E/, '--Elines', $whereami . 'multiline.txt'],
+	[qr/error.*line 47/, '--Elines', $whereami . 'multiline.txt'],
+	[qr/Number found.*line 48/, '--Elines', $whereami . 'multiline.txt'],
+);
+
+plan tests =>
+	scalar @testcases +
+	scalar @testcases2;
 
 for my $lrTest (@testcases) {
 	my ($testin, $err_re) = @$lrTest;
@@ -31,4 +51,10 @@ for my $lrTest (@testcases) {
 
 } # foreach test
 
+for my $lrTest (@testcases2) {
+	my $err_re = shift @$lrTest;
+	run3 join(' ', CMD, @$lrTest), \undef, \undef, \$err;
+	like($err, $err_re);
+}
+
 # vi: set ts=4 sts=0 sw=4 noet ai: #