Skip to content

Commit 323ebf9

Browse files
author
Chris White
committed
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 #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.
1 parent 6afdde6 commit 323ebf9

File tree

6 files changed

+143
-33
lines changed

6 files changed

+143
-33
lines changed

Makefile.PL

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -36,7 +36,7 @@ WriteMakefile(
3636
'Test::More' => '0',
3737
},
3838
PREREQ_PM => {
39-
'Getopt::Long' => '2.50', # Per issue #17
39+
'Getopt::Long' => '2.5', # Per issue #17
4040
'Pod::Usage' => '0',
4141
},
4242
dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },

bin/perlpp

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -59,6 +59,15 @@ script.
5959
Don't evaluate Perl code, just write the generated code to STDOUT.
6060
By analogy with the C<-E> option of gcc.
6161
62+
=item --Elines
63+
64+
In case of an error in the input, perlpp normally tries to report a
65+
file and line number close to the location of the error in the source file.
66+
However, the match isn't always perfect. If C<--Elines> is given, errors will
67+
be reported at the line number in the generated script. The generated
68+
script will still include C<## sync> markers showing you about where the input
69+
files/lines are, for ease of reference.
70+
6271
=item -k, --keep-going
6372
6473
Normally, errors in a C<!command> sequence will terminate further

lib/Text/PerlPP.pm

Lines changed: 91 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,7 @@
33

44
package Text::PerlPP;
55

6-
our $VERSION = '0.3.3_1';
6+
our $VERSION = '0.4.0';
77

88
use 5.010001;
99
use strict;
@@ -13,6 +13,7 @@ use Getopt::Long 2.5 qw(GetOptionsFromArray);
1313
use Pod::Usage;
1414

1515
# === Constants ===========================================================
16+
1617
use constant true => !!1;
1718
use constant false => !!0;
1819

@@ -48,8 +49,10 @@ use constant OBMODE_SYSTEM => 6; # an external command being run
4849

4950
# Layout of the output-buffer stack.
5051
use constant OB_TOP => 0; # top of the stack is [0]: use [un]shift
51-
use constant OB_MODE => 0; # each stack entry is a two-element array
52+
53+
use constant OB_MODE => 0; # indices of the stack entries
5254
use constant OB_CONTENTS => 1;
55+
use constant OB_STARTLINE => 2;
5356

5457
# === Globals =============================================================
5558

@@ -73,12 +76,13 @@ my %Defs_repl_text = (); # Replacement text for -D names
7376
our %Sets = (); # Command-line -s arguments
7477

7578
# Output-buffer stack
76-
my @OutputBuffers = (); # each entry is a two-element array
79+
my @OutputBuffers = ();
80+
# Each entry is an array of [mode, text, opening line number]
7781

7882
# Debugging info
7983
my @OBModeNames = qw(plain capture code echo command comment);
8084

81-
# === Code ================================================================
85+
# === Internal routines ===================================================
8286

8387
# An alias for print(). This is used so that you can find print statements
8488
# in the generated script by searching for "print".
@@ -95,16 +99,18 @@ sub AddPostprocessor {
9599
push( @Postprocessors, shift );
96100
}
97101

102+
# --- Output buffers ----------------------------------------------
103+
98104
# Open an output buffer. Default mode is literal text.
99105
sub StartOB {
100-
my $mode = OBMODE_PLAIN;
106+
my $mode = shift // OBMODE_PLAIN;
107+
my $lineno = shift // 1;
101108

102-
$mode = shift if @_;
103109
if ( scalar @OutputBuffers == 0 ) {
104110
$| = 1; # flush contents of STDOUT
105111
open( $RootSTDOUT, ">&STDOUT" ) or die $!; # dup filehandle
106112
}
107-
unshift( @OutputBuffers, [ $mode, "" ] );
113+
unshift( @OutputBuffers, [ $mode, "", $lineno ] );
108114
close( STDOUT ); # must be closed before redirecting it to a variable
109115
open( STDOUT, ">>", \$OutputBuffers[ OB_TOP ]->[ OB_CONTENTS ] ) or die $!;
110116
$| = 1; # do not use output buffering
@@ -145,10 +151,18 @@ sub ReadAndEmptyOB {
145151
return $s;
146152
} #ReadAndEmptyOB()
147153

154+
# Accessors
155+
156+
sub GetStartLineOfOB {
157+
return $OutputBuffers[ OB_TOP ]->[ OB_STARTLINE ];
158+
}
159+
148160
sub GetModeOfOB {
149161
return $OutputBuffers[ OB_TOP ]->[ OB_MODE ];
150162
}
151163

164+
# --- String manipulation -----------------------------------------
165+
152166
sub DQuoteString { # wrap $_[0] in double-quotes, escaped properly
153167
# Not currently used by PerlPP, but provided for use by scripts.
154168
# TODO? inject into the generated script?
@@ -184,6 +198,8 @@ sub PrepareString {
184198
return QuoteString( $s );
185199
}
186200

201+
# --- Script-accessible commands ----------------------------------
202+
187203
sub ExecuteCommand {
188204
my $cmd = shift;
189205
my $fn;
@@ -308,39 +324,60 @@ sub ShellOut { # Run an external command
308324
emit $block;
309325
} #ShellOut()
310326

327+
# --- Delimiter processing ----------------------------------------
328+
329+
# Print a "#line" line. Filename must not contain /"/.
330+
sub emit_pound_line {
331+
my ($fname, $lineno) = @_;
332+
$lineno = 0+$lineno;
333+
$fname = '' . $fname;
334+
335+
emit "\n#@{[ $Opts{DEBUG_LINENOS} ? '#sync' : 'line' ]} $lineno \"$fname\"\n";
336+
} #emit_pound_line()
337+
311338
sub OnOpening {
312339
# takes the rest of the string, beginning right after the ? of the tag_open
313340
# returns (withinTag, string still to be processed)
314341

315-
my $after = shift;
342+
my ($after, $lineno) = @_;
343+
316344
my $plain;
317345
my $plainMode;
318346
my $insetMode = OBMODE_CODE;
319347

320348
$plainMode = GetModeOfOB();
321349
$plain = EndOB(); # plain text already seen
350+
322351
if ( $after =~ /^"/ && $plainMode == OBMODE_CAPTURE ) {
323352
emit PrepareString( $plain );
324353
# we are still buffering the inset contents,
325354
# so we do not have to start it again
326355
} else {
356+
327357
if ( $after =~ /^=/ ) {
328358
$insetMode = OBMODE_ECHO;
359+
329360
} elsif ( $after =~ /^:/ ) {
330361
$insetMode = OBMODE_COMMAND;
362+
331363
} elsif ( $after =~ /^#/ ) {
332364
$insetMode = OBMODE_COMMENT;
365+
333366
} elsif ( $after =~ m{^\/} ) {
334367
$plain .= "\n"; # newline after what we've already seen
335368
# OBMODE_CODE
369+
336370
} elsif ( $after =~ /^(?:\s|$)/ ) {
337371
# OBMODE_CODE
372+
338373
} elsif ( $after =~ /^!/ ) {
339374
$insetMode = OBMODE_SYSTEM;
375+
340376
} elsif ( $after =~ /^"/ ) {
341377
die "Unexpected end of capturing";
378+
342379
} else {
343-
StartOB( $plainMode ); # skip non-PerlPP insets
380+
StartOB( $plainMode, $lineno ); # skip non-PerlPP insets
344381
emit $plain . TAG_OPEN;
345382
return ( false, $after );
346383
# Here $after is the entire rest of the input, so it is as if
@@ -349,40 +386,58 @@ sub OnOpening {
349386

350387
if ( $plainMode == OBMODE_CAPTURE ) {
351388
emit PrepareString( $plain ) . " . do { Text::PerlPP::StartOB(); ";
352-
StartOB( $plainMode ); # wrap the inset in a capturing mode
389+
StartOB( $plainMode, $lineno ); # wrap the inset in a capturing mode
353390
} else {
354391
emit "print " . PrepareString( $plain ) . ";\n";
355392
}
356-
StartOB( $insetMode ); # contents of the inset
393+
394+
StartOB( $insetMode, $lineno ); # contents of the inset
357395
}
358396
return ( true, "" ) unless $after;
359397
return ( true, substr( $after, 1 ) );
360398
} #OnOpening()
361399

362400
sub OnClosing {
363-
my $inside;
364-
my $insetMode;
401+
my $end_lineno = shift // 0;
402+
my $fname = shift // "<unknown filename>";
403+
365404
my $nextMode = OBMODE_PLAIN;
366405

367-
$insetMode = GetModeOfOB();
368-
$inside = EndOB(); # contents of the inset
406+
my $start_lineno = GetStartLineOfOB();
407+
my $insetMode = GetModeOfOB();
408+
my $inside = EndOB(); # contents of the inset
409+
369410
if ( $inside =~ /"$/ ) {
370-
StartOB( $insetMode ); # restore contents of the inset
411+
StartOB( $insetMode, $end_lineno ); # restore contents of the inset
371412
emit substr( $inside, 0, -1 );
372413
$nextMode = OBMODE_CAPTURE;
414+
373415
} else {
374416
if ( $insetMode == OBMODE_ECHO ) {
417+
emit_pound_line $fname, $start_lineno;
375418
emit "print ${inside};\n"; # don't wrap in (), trailing semicolon
419+
emit_pound_line $fname, $end_lineno;
420+
376421
} elsif ( $insetMode == OBMODE_COMMAND ) {
377422
ExecuteCommand( $inside );
423+
378424
} elsif ( $insetMode == OBMODE_COMMENT ) {
379-
# Ignore the contents - no operation
425+
# Ignore the contents - no operation. Do resync, though.
426+
emit_pound_line $fname, $end_lineno;
427+
380428
} elsif ( $insetMode == OBMODE_CODE ) {
429+
emit_pound_line $fname, $start_lineno;
381430
emit "$inside\n"; # \n so you can put comments in your perl code
431+
emit_pound_line $fname, $end_lineno;
432+
382433
} elsif ( $insetMode == OBMODE_SYSTEM ) {
434+
emit_pound_line $fname, $start_lineno;
383435
ShellOut( $inside );
436+
emit_pound_line $fname, $end_lineno;
437+
384438
} else {
385439
emit $inside;
440+
386441
}
387442

388443
if ( GetModeOfOB() == OBMODE_CAPTURE ) { # if the inset is wrapped
@@ -393,14 +448,12 @@ sub OnClosing {
393448
StartOB( $nextMode ); # plain text
394449
} #OnClosing()
395450

396-
# Print a "#line" line. Filename must not contain /"/.
397-
sub emit_pound_line {
398-
my ($fname, $lineno) = @_;
399-
$lineno = 0+$lineno;
400-
$fname = '' . $fname;
451+
# --- File processing ---------------------------------------------
401452

402-
emit "\n#line $lineno \"$fname\"\n";
403-
} #emit_pound_line
453+
# Count newlines in a string
454+
sub num_newlines {
455+
return scalar ( () = $_[0] =~ /\n/g );
456+
} #num_newlines()
404457

405458
# Process the contents of a single file
406459
sub RunPerlPPOnFileContents {
@@ -411,7 +464,7 @@ sub RunPerlPPOnFileContents {
411464
my $withinTag = false;
412465
my $lastPrep;
413466

414-
#my $lineno=1; # approximated by the number of newlines we see
467+
my $lineno=1; # approximated by the number of newlines we see
415468

416469
$lastPrep = $#Preprocessors;
417470
StartOB(); # plain text
@@ -421,9 +474,9 @@ sub RunPerlPPOnFileContents {
421474
if ( $withinTag ) {
422475
if ( $$contents_ref =~ CLOSING_RE ) {
423476
emit $1;
477+
$lineno += num_newlines($1);
424478
$$contents_ref = $2;
425-
#$lineno += ( () = ($1 . TAG_CLOSE) =~ /\n/g );
426-
OnClosing();
479+
OnClosing( $lineno, $fname );
427480
# that could have been a command, which added new preprocessors
428481
# but we don't want to run previously executed preps the second time
429482
while ( $lastPrep < $#Preprocessors ) {
@@ -436,10 +489,9 @@ sub RunPerlPPOnFileContents {
436489
} else { # look for the next opening tag. $1 is before; $2 is after.
437490
if ( $$contents_ref =~ OPENING_RE ) {
438491
emit $1;
439-
( $withinTag, $$contents_ref ) = OnOpening( $2 );
440-
#$lineno += ( () = ($1 . TAG_OPEN) =~ /\n/g );
492+
$lineno += num_newlines($1);
493+
( $withinTag, $$contents_ref ) = OnOpening( $2, $lineno );
441494
if ( $withinTag ) {
442-
#emit_pound_line $fname, $lineno if(GetModeOfOB() == OBMODE_CODE);
443495
goto OPENING; # $$contents_ref is the rest of the string
444496
}
445497
}
@@ -553,6 +605,7 @@ my %CMDLINE_OPTS = (
553605
# lowercase before upper, although the code does not require that order.
554606

555607
DEBUG => ['d','|E|debug', false],
608+
DEBUG_LINENOS => ['Elines','',false], # if true, don't add #line markers
556609
DEFS => ['D','|define:s%'], # In %D, and text substitution
557610
EVAL => ['e','|eval=s', ''],
558611
# -h and --help reserved
@@ -622,6 +675,7 @@ sub parse_command_line {
622675
} #parse_command_line()
623676

624677
# === Main ================================================================
678+
625679
sub Main {
626680
my $lrArgv = shift // [];
627681
parse_command_line $lrArgv, \%Opts;
@@ -642,6 +696,12 @@ sub Main {
642696
# $Package is not the whole name, so can start with a number.
643697

644698
StartOB(); # Output from here on will be included in the generated script
699+
700+
# Help the user know where to look
701+
say "#line 1 \"<script: rerun with -E to see text>\"" if($Opts{DEBUG_LINENOS});
702+
emit_pound_line '<package header>', 1;
703+
704+
# Open the package
645705
emit "package PPP_${Package};\nuse 5.010001;\nuse strict;\nuse warnings;\n";
646706
emit "use constant { true => !!1, false => !!0 };\n";
647707

@@ -743,6 +803,7 @@ sub Main {
743803
} #Main()
744804

745805
1;
806+
__END__
746807
# ### Documentation #######################################################
747808
748809
=pod

t/02-cmdline.t

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,7 @@ my @testcases=(
1515
['--version','',qr/\bversion\b/],
1616

1717
# Debug output
18-
['-d','',qr/^package PPP_;/],
18+
['-d','',qr/^package PPP_;/m],
1919
['-d', '<?= 2+2 ?>', qr{print\s+2\+2\s*;}],
2020
['--debug', '<?= 2+2 ?>', qr{print\s+2\+2\s*;}],
2121
['-E', '<?= 2+2 ?>', qr{print\s+2\+2\s*;}],

t/07-invalid.t

Lines changed: 27 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,8 @@ use warnings;
55
use Test::More;
66
use IPC::Run3;
77
use constant CMD => ($ENV{PERLPP_CMD} || 'perl -Iblib/lib blib/script/perlpp');
8+
(my $whereami = __FILE__) =~ s/07-invalid\.t$//;
9+
diag "perlpp command " . CMD . "; whereami $whereami.";
810

911
my ($out, $err);
1012

@@ -18,7 +20,25 @@ my @testcases=(
1820
['<? o@no!!! ?>'],
1921
); #@testcases
2022

21-
plan tests => scalar @testcases;
23+
# Tests of line numbers when there are errors in the input
24+
my @testcases2 =(
25+
# [error RE, perlpp options...]
26+
[qr/multiline\.txt/, $whereami . 'multiline.txt'],
27+
[qr/error.*line 12/, $whereami . 'multiline.txt'],
28+
[qr/Number found.*line 13/, $whereami . 'multiline.txt'],
29+
30+
# Tests with --Elines. Note: the specific line numbers here may need
31+
# to be changed if the internals of perlpp change. This is OK;
32+
# please just make sure to document the change and the reason in the
33+
# corresponding commit message.
34+
[qr/script.*-E/, '--Elines', $whereami . 'multiline.txt'],
35+
[qr/error.*line 47/, '--Elines', $whereami . 'multiline.txt'],
36+
[qr/Number found.*line 48/, '--Elines', $whereami . 'multiline.txt'],
37+
);
38+
39+
plan tests =>
40+
scalar @testcases +
41+
scalar @testcases2;
2242

2343
for my $lrTest (@testcases) {
2444
my ($testin, $err_re) = @$lrTest;
@@ -31,4 +51,10 @@ for my $lrTest (@testcases) {
3151

3252
} # foreach test
3353

54+
for my $lrTest (@testcases2) {
55+
my $err_re = shift @$lrTest;
56+
run3 join(' ', CMD, @$lrTest), \undef, \undef, \$err;
57+
like($err, $err_re);
58+
}
59+
3460
# vi: set ts=4 sts=0 sw=4 noet ai: #

0 commit comments

Comments
 (0)