3
3
4
4
package Text::PerlPP ;
5
5
6
- our $VERSION = ' 0.3.3_1 ' ;
6
+ our $VERSION = ' 0.4.0 ' ;
7
7
8
8
use 5.010001;
9
9
use strict;
@@ -13,6 +13,7 @@ use Getopt::Long 2.5 qw(GetOptionsFromArray);
13
13
use Pod::Usage;
14
14
15
15
# === Constants ===========================================================
16
+
16
17
use constant true => !!1;
17
18
use constant false => !!0;
18
19
@@ -48,8 +49,10 @@ use constant OBMODE_SYSTEM => 6; # an external command being run
48
49
49
50
# Layout of the output-buffer stack.
50
51
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
52
54
use constant OB_CONTENTS => 1;
55
+ use constant OB_STARTLINE => 2;
53
56
54
57
# === Globals =============================================================
55
58
@@ -73,12 +76,13 @@ my %Defs_repl_text = (); # Replacement text for -D names
73
76
our %Sets = (); # Command-line -s arguments
74
77
75
78
# 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]
77
81
78
82
# Debugging info
79
83
my @OBModeNames = qw( plain capture code echo command comment) ;
80
84
81
- # === Code ============= ===================================================
85
+ # === Internal routines ===================================================
82
86
83
87
# An alias for print(). This is used so that you can find print statements
84
88
# in the generated script by searching for "print".
@@ -95,16 +99,18 @@ sub AddPostprocessor {
95
99
push ( @Postprocessors , shift );
96
100
}
97
101
102
+ # --- Output buffers ----------------------------------------------
103
+
98
104
# Open an output buffer. Default mode is literal text.
99
105
sub StartOB {
100
- my $mode = OBMODE_PLAIN;
106
+ my $mode = shift // OBMODE_PLAIN;
107
+ my $lineno = shift // 1;
101
108
102
- $mode = shift if @_ ;
103
109
if ( scalar @OutputBuffers == 0 ) {
104
110
$| = 1; # flush contents of STDOUT
105
111
open ( $RootSTDOUT , " >&STDOUT" ) or die $! ; # dup filehandle
106
112
}
107
- unshift ( @OutputBuffers , [ $mode , " " ] );
113
+ unshift ( @OutputBuffers , [ $mode , " " , $lineno ] );
108
114
close ( STDOUT ); # must be closed before redirecting it to a variable
109
115
open ( STDOUT , " >>" , \$OutputBuffers [ OB_TOP ]-> [ OB_CONTENTS ] ) or die $! ;
110
116
$| = 1; # do not use output buffering
@@ -145,10 +151,18 @@ sub ReadAndEmptyOB {
145
151
return $s ;
146
152
} # ReadAndEmptyOB()
147
153
154
+ # Accessors
155
+
156
+ sub GetStartLineOfOB {
157
+ return $OutputBuffers [ OB_TOP ]-> [ OB_STARTLINE ];
158
+ }
159
+
148
160
sub GetModeOfOB {
149
161
return $OutputBuffers [ OB_TOP ]-> [ OB_MODE ];
150
162
}
151
163
164
+ # --- String manipulation -----------------------------------------
165
+
152
166
sub DQuoteString { # wrap $_[0] in double-quotes, escaped properly
153
167
# Not currently used by PerlPP, but provided for use by scripts.
154
168
# TODO? inject into the generated script?
@@ -184,6 +198,8 @@ sub PrepareString {
184
198
return QuoteString( $s );
185
199
}
186
200
201
+ # --- Script-accessible commands ----------------------------------
202
+
187
203
sub ExecuteCommand {
188
204
my $cmd = shift ;
189
205
my $fn ;
@@ -308,39 +324,60 @@ sub ShellOut { # Run an external command
308
324
emit $block ;
309
325
} # ShellOut()
310
326
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
+
311
338
sub OnOpening {
312
339
# takes the rest of the string, beginning right after the ? of the tag_open
313
340
# returns (withinTag, string still to be processed)
314
341
315
- my $after = shift ;
342
+ my ($after , $lineno ) = @_ ;
343
+
316
344
my $plain ;
317
345
my $plainMode ;
318
346
my $insetMode = OBMODE_CODE;
319
347
320
348
$plainMode = GetModeOfOB();
321
349
$plain = EndOB(); # plain text already seen
350
+
322
351
if ( $after =~ / ^"/ && $plainMode == OBMODE_CAPTURE ) {
323
352
emit PrepareString( $plain );
324
353
# we are still buffering the inset contents,
325
354
# so we do not have to start it again
326
355
} else {
356
+
327
357
if ( $after =~ / ^=/ ) {
328
358
$insetMode = OBMODE_ECHO;
359
+
329
360
} elsif ( $after =~ / ^:/ ) {
330
361
$insetMode = OBMODE_COMMAND;
362
+
331
363
} elsif ( $after =~ / ^#/ ) {
332
364
$insetMode = OBMODE_COMMENT;
365
+
333
366
} elsif ( $after =~ m { ^\/ } ) {
334
367
$plain .= " \n " ; # newline after what we've already seen
335
368
# OBMODE_CODE
369
+
336
370
} elsif ( $after =~ / ^(?:\s |$) / ) {
337
371
# OBMODE_CODE
372
+
338
373
} elsif ( $after =~ / ^!/ ) {
339
374
$insetMode = OBMODE_SYSTEM;
375
+
340
376
} elsif ( $after =~ / ^"/ ) {
341
377
die " Unexpected end of capturing" ;
378
+
342
379
} else {
343
- StartOB( $plainMode ); # skip non-PerlPP insets
380
+ StartOB( $plainMode , $lineno ); # skip non-PerlPP insets
344
381
emit $plain . TAG_OPEN;
345
382
return ( false, $after );
346
383
# Here $after is the entire rest of the input, so it is as if
@@ -349,40 +386,58 @@ sub OnOpening {
349
386
350
387
if ( $plainMode == OBMODE_CAPTURE ) {
351
388
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
353
390
} else {
354
391
emit " print " . PrepareString( $plain ) . " ;\n " ;
355
392
}
356
- StartOB( $insetMode ); # contents of the inset
393
+
394
+ StartOB( $insetMode , $lineno ); # contents of the inset
357
395
}
358
396
return ( true, " " ) unless $after ;
359
397
return ( true, substr ( $after , 1 ) );
360
398
} # OnOpening()
361
399
362
400
sub OnClosing {
363
- my $inside ;
364
- my $insetMode ;
401
+ my $end_lineno = shift // 0;
402
+ my $fname = shift // " <unknown filename>" ;
403
+
365
404
my $nextMode = OBMODE_PLAIN;
366
405
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
+
369
410
if ( $inside =~ / "$ / ) {
370
- StartOB( $insetMode ); # restore contents of the inset
411
+ StartOB( $insetMode , $end_lineno ); # restore contents of the inset
371
412
emit substr ( $inside , 0, -1 );
372
413
$nextMode = OBMODE_CAPTURE;
414
+
373
415
} else {
374
416
if ( $insetMode == OBMODE_ECHO ) {
417
+ emit_pound_line $fname , $start_lineno ;
375
418
emit " print ${inside} ;\n " ; # don't wrap in (), trailing semicolon
419
+ emit_pound_line $fname , $end_lineno ;
420
+
376
421
} elsif ( $insetMode == OBMODE_COMMAND ) {
377
422
ExecuteCommand( $inside );
423
+
378
424
} 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
+
380
428
} elsif ( $insetMode == OBMODE_CODE ) {
429
+ emit_pound_line $fname , $start_lineno ;
381
430
emit " $inside \n " ; # \n so you can put comments in your perl code
431
+ emit_pound_line $fname , $end_lineno ;
432
+
382
433
} elsif ( $insetMode == OBMODE_SYSTEM ) {
434
+ emit_pound_line $fname , $start_lineno ;
383
435
ShellOut( $inside );
436
+ emit_pound_line $fname , $end_lineno ;
437
+
384
438
} else {
385
439
emit $inside ;
440
+
386
441
}
387
442
388
443
if ( GetModeOfOB() == OBMODE_CAPTURE ) { # if the inset is wrapped
@@ -393,14 +448,12 @@ sub OnClosing {
393
448
StartOB( $nextMode ); # plain text
394
449
} # OnClosing()
395
450
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 ---------------------------------------------
401
452
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()
404
457
405
458
# Process the contents of a single file
406
459
sub RunPerlPPOnFileContents {
@@ -411,7 +464,7 @@ sub RunPerlPPOnFileContents {
411
464
my $withinTag = false;
412
465
my $lastPrep ;
413
466
414
- # my $lineno=1; # approximated by the number of newlines we see
467
+ my $lineno =1; # approximated by the number of newlines we see
415
468
416
469
$lastPrep = $#Preprocessors ;
417
470
StartOB(); # plain text
@@ -421,9 +474,9 @@ sub RunPerlPPOnFileContents {
421
474
if ( $withinTag ) {
422
475
if ( $$contents_ref =~ CLOSING_RE ) {
423
476
emit $1 ;
477
+ $lineno += num_newlines($1 );
424
478
$$contents_ref = $2 ;
425
- # $lineno += ( () = ($1 . TAG_CLOSE) =~ /\n/g );
426
- OnClosing();
479
+ OnClosing( $lineno , $fname );
427
480
# that could have been a command, which added new preprocessors
428
481
# but we don't want to run previously executed preps the second time
429
482
while ( $lastPrep < $#Preprocessors ) {
@@ -436,10 +489,9 @@ sub RunPerlPPOnFileContents {
436
489
} else { # look for the next opening tag. $1 is before; $2 is after.
437
490
if ( $$contents_ref =~ OPENING_RE ) {
438
491
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 );
441
494
if ( $withinTag ) {
442
- # emit_pound_line $fname, $lineno if(GetModeOfOB() == OBMODE_CODE);
443
495
goto OPENING; # $$contents_ref is the rest of the string
444
496
}
445
497
}
@@ -553,6 +605,7 @@ my %CMDLINE_OPTS = (
553
605
# lowercase before upper, although the code does not require that order.
554
606
555
607
DEBUG => [' d' ,' |E|debug' , false],
608
+ DEBUG_LINENOS => [' Elines' ,' ' ,false], # if true, don't add #line markers
556
609
DEFS => [' D' ,' |define:s%' ], # In %D, and text substitution
557
610
EVAL => [' e' ,' |eval=s' , ' ' ],
558
611
# -h and --help reserved
@@ -622,6 +675,7 @@ sub parse_command_line {
622
675
} # parse_command_line()
623
676
624
677
# === Main ================================================================
678
+
625
679
sub Main {
626
680
my $lrArgv = shift // [];
627
681
parse_command_line $lrArgv , \%Opts ;
@@ -642,6 +696,12 @@ sub Main {
642
696
# $Package is not the whole name, so can start with a number.
643
697
644
698
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
645
705
emit " package PPP_${Package} ;\n use 5.010001;\n use strict;\n use warnings;\n " ;
646
706
emit " use constant { true => !!1, false => !!0 };\n " ;
647
707
@@ -743,6 +803,7 @@ sub Main {
743
803
} # Main()
744
804
745
805
1;
806
+ __END__
746
807
# ### Documentation #######################################################
747
808
748
809
=pod
0 commit comments