Skip to content

Commit 2471507

Browse files
author
Chris White
committed
Fixed parsing of test-case command lines
Also, more debugging output and TODO items.
1 parent 817a0df commit 2471507

File tree

3 files changed

+103
-70
lines changed

3 files changed

+103
-70
lines changed

‎lib/Text/PerlPP.pm‎

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -57,6 +57,10 @@ use constant OB_STARTLINE => 2;
5757

5858
# === Globals =============================================================
5959

60+
# TODO encapsulate all of these so state doesn't leak from one call to Main()
61+
# to another call to Main().
62+
# Also, add a variable to the PPP_* pointing to the encapsulated state.
63+
6064
# Internals
6165
my $Package = ''; # package name for the generated script
6266
my $PackageNum = 0; # make sure each run has a unique package name
@@ -656,6 +660,8 @@ sub parse_command_line {
656660
'usage|?', 'h|help', 'man', # options we handle here
657661
map { $_->[0] . ($_->[1]//'') } values %CMDLINE_OPTS, # options strs
658662
);
663+
664+
# --- TODO clean up the following.
659665
my $noexit_on_help =
660666
$hrOptsOut->{ $CMDLINE_OPTS{NOEXIT_ON_HELP}->[0] } // false;
661667

@@ -677,6 +683,7 @@ sub parse_command_line {
677683
pod2usage(-verbose => 1, -exitval => EXIT_PROC_ERR, %docs) if have('h');
678684
pod2usage(-verbose => 2, -exitval => EXIT_PROC_ERR, %docs) if have('man');
679685
}
686+
# ---
680687

681688
# Map the option names from GetOptions back to the internal names we use,
682689
# e.g., $hrOptsOut->{EVAL} from $hrOptsOut->{e}.
@@ -705,10 +712,14 @@ sub parse_command_line {
705712

706713
sub Main {
707714
my $lrArgv = shift // [];
715+
say STDERR "\n## -----------------\n## argv:\n",
716+
(Dumper($lrArgv) =~ s/^/## /mgr);
708717
unless(parse_command_line $lrArgv, \%Opts) {
709718
return EXIT_OK; # TODO report param err vs. proc err?
710719
}
711720

721+
say STDERR "## opts:\n", (Dumper(\%Opts) =~ s/^/## /mgr);
722+
712723
if($Opts{PRINT_VERSION}) {
713724
print "PerlPP version $Text::PerlPP::VERSION\n";
714725
if($Opts{PRINT_VERSION} > 1) {
@@ -785,6 +796,9 @@ sub Main {
785796
}
786797
keys %{$Opts{SETS}};
787798

799+
say STDERR "\n# Defs_RE: $Defs_RE";
800+
say STDERR "# Defs_repl_text:\n", (Dumper(\%Defs_repl_text)=~s/^/# /gmr);
801+
say STDERR "# Sets\n", (Dumper(\%Sets)=~s/^/# /gmr);
788802
# Make the copy for runtime
789803
emit "my %S = (\n";
790804
for my $defname (keys %{$Opts{SETS}}) {

‎t/03-cmdline.t‎

Lines changed: 71 additions & 64 deletions
Original file line numberDiff line numberDiff line change
@@ -1,103 +1,109 @@
1-
#!/usr/bin/env perl -W
1+
#!/usr/bin/env perl
22
# Tests of perlpp command-line options
33
use constant CMD => ($ENV{PERLPP_CMD} || 'perl -Iblib/lib blib/script/perlpp');
44
use rlib './lib';
55
use PerlPPTest;
66

7+
# Note: for all the L() calls, without a do{} around them, the line number
8+
# from caller() is the line number where `my @testcases` occurs.
9+
# TODO find out if there's a better way than do{L()}. Maybe an L that
10+
# takes a block that returns a list? That might or might not work ---
11+
# syntactically,
12+
# perl -MData::Dumper -E 'sub L :prototype(&) { my $func=shift; my @x = &$func(); say Dumper(\@x); }; L{1,2}'
13+
# does work, but I don't know if it would have the right caller.
14+
715
my @testcases=(
8-
# [$cmdline_options, $in (the script), $out_re (expected output),
16+
# [scalar filename/lineno (added by L()),
17+
# $cmdline_options, $in (the script), $out_re (expected output),
918
# $err_re (stderr output, if any)]
1019

1120
# version
12-
['-v','',qr/\bversion\b/],
13-
['--version','',qr/\bversion\b/],
21+
do{L('-v','',qr/\bversion\b/) },
22+
do{L('--version','',qr/\bversion\b/)},
1423

1524
# Debug output
16-
['-d','',qr/^package PPP_[0-9]*;/m],
17-
['-d', '<?= 2+2 ?>', qr{print\s+2\+2\s*;}],
18-
['--debug', '<?= 2+2 ?>', qr{print\s+2\+2\s*;}],
19-
['-E', '<?= 2+2 ?>', qr{print\s+2\+2\s*;}],
25+
L('-d','',qr/^package PPP_[0-9]*;/m),
26+
L('-d', '<?= 2+2 ?>', qr{print\s+2\+2\s*;}),
27+
L('--debug', '<?= 2+2 ?>', qr{print\s+2\+2\s*;}),
28+
L('-E', '<?= 2+2 ?>', qr{print\s+2\+2\s*;}),
2029

2130
# Usage
22-
['-h --z_noexit_on_help', '', qr/^Usage/],
23-
['--help --z_noexit_on_help', '', qr/^Usage/],
31+
L('-h --z_noexit_on_help', '', qr/^Usage/),
32+
L('--help --z_noexit_on_help', '', qr/^Usage/),
2433

2534
# Eval at start of file
26-
[['-e', 'my $foo=42;'],'<?= $foo ?>', qr/^42$/],
27-
# TODO RESUME HERE: break down the command line arguments since the
28-
# shell is no longer parsing them. (Note that they will have to be
29-
# re-quoted for use by the packed test.)
30-
['--eval \'my $foo=42;\'','<?= $foo ?>', qr/^42$/],
31-
['-d -e \'my $foo=42;\'','<?= $foo ?>', qr/^my \$foo=42;/m],
32-
['--debug --eval \'my $foo=42;\'','<?= $foo ?>', qr/^print\s+\$foo\s*;/m],
35+
L('-e \'my $foo=42;\'', '<?= $foo ?>', qr/^42$/),
36+
L('--eval \'my $foo=42;\'','<?= $foo ?>', qr/^42$/),
37+
L('-d -e \'my $foo=42;\'','<?= $foo ?>', qr/^my \$foo=42;/m),
38+
L('--debug --eval \'my $foo=42;\'','<?= $foo ?>', qr/^print\s+\$foo\s*;/m),
3339

3440
# Definitions: name formats
35-
['-Dfoo', '<? print "yes" if $D{foo}; ?>',qr/^yes$/],
36-
['-Dfoo42', '<? print "yes" if $D{foo42}; ?>',qr/^yes$/],
37-
['-Dfoo_42', '<? print "yes" if $D{foo_42}; ?>',qr/^yes$/],
38-
['-D_x', '<? print "yes" if $D{_x}; ?>',qr/^yes$/],
39-
['-D_1', '<? print "yes" if $D{_1}; ?>',qr/^yes$/],
41+
L('-Dfoo', '<? print "yes" if $D{foo}; ?>',qr/^yes$/),
42+
L('-Dfoo42', '<? print "yes" if $D{foo42}; ?>',qr/^yes$/),
43+
L('-Dfoo_42', '<? print "yes" if $D{foo_42}; ?>',qr/^yes$/),
44+
L('-D_x', '<? print "yes" if $D{_x}; ?>',qr/^yes$/),
45+
L('-D_1', '<? print "yes" if $D{_1}; ?>',qr/^yes$/),
4046

4147
# Definitions with --define
42-
['--define foo', '<? print "yes" if $D{foo}; ?>',qr/^yes$/],
43-
['--define foo=42 --define bar=127', '<?= $D{foo} * $D{bar} ?>',qr/^5334$/],
48+
L('--define foo', '<? print "yes" if $D{foo}; ?>',qr/^yes$/),
49+
L('--define foo=42 --define bar=127', '<?= $D{foo} * $D{bar} ?>',qr/^5334$/),
4450

4551
# Definitions: :define/:undef
46-
['','<?:define foo?><?:ifdef foo?>yes<?:else?>no<?:endif?>',qr/^yes$/],
47-
['','<?:define foo 42?><?:ifdef foo?>yes<?:else?>no<?:endif?>',qr/^yes$/],
48-
['','<?:define foo 42?><?= $D{foo} ?>',qr/^42$/],
49-
['','<?:define foo "a" . "b" ?><?= $D{foo} ?>',qr/^ab$/],
50-
['-Dfoo','<?:undef foo?><?:ifdef foo?>yes<?:else?>no<?:endif?>',qr/^no$/],
52+
L('','<?:define foo?><?:ifdef foo?>yes<?:else?>no<?:endif?>',qr/^yes$/),
53+
L('','<?:define foo 42?><?:ifdef foo?>yes<?:else?>no<?:endif?>',qr/^yes$/),
54+
L('','<?:define foo 42?><?= $D{foo} ?>',qr/^42$/),
55+
L('','<?:define foo "a" . "b" ?><?= $D{foo} ?>',qr/^ab$/),
56+
L('-Dfoo','<?:undef foo?><?:ifdef foo?>yes<?:else?>no<?:endif?>',qr/^no$/),
5157

5258
# Definitions: values
53-
['-Dfoo=41025.5', '<?= $D{foo} ?>',qr/^41025.5$/],
54-
['-D foo=2017', '<?= $D{foo} ?>',qr/^2017$/],
55-
['-D foo=\"blah\"', '<?= $D{foo} ?>',qr/^blah$/],
59+
L('-Dfoo=41025.5', '<?= $D{foo} ?>',qr/^41025.5$/),
60+
L('-D foo=2017', '<?= $D{foo} ?>',qr/^2017$/),
61+
L('-D foo=\"blah\"', '<?= $D{foo} ?>',qr/^blah$/),
5662
# Have to escape the double-quotes so perl sees it as a string
5763
# literal instead of a bareword.
58-
['-D foo=42 -D bar=127', '<?= $D{foo} * $D{bar} ?>',qr/^5334$/],
59-
['', '<? $D{x}="%D always exists even if empty"; ?><?= $D{x} ?>',
60-
qr/^%D always exists even if empty$/],
64+
L('-D foo=42 -D bar=127', '<?= $D{foo} * $D{bar} ?>',qr/^5334$/),
65+
L('', '<? $D{x}="%D always exists even if empty"; ?><?= $D{x} ?>',
66+
qr/^%D always exists even if empty$/),
6167

6268
# Textual substitution
63-
['-Dfoo=42','<? my $foo; ?>foo',qr/^42$/ ],
64-
['-Dfoo=\'"a phrase"\'','<? my $foo; ?>foo',qr/^a phrase$/ ],
65-
['-Dfoo=\"bar\"','_foo foo foobar barfoo',qr/^_foo bar foobar barfoo$/ ],
66-
['-Dfoo=\"bar\" --define barfoo','_foo foo foobar barfoo',
67-
qr/^_foo bar foobar barfoo$/ ],
69+
L('-Dfoo=42','<? my $foo; ?>foo',qr/^42$/ ),
70+
L('-Dfoo=\'"a phrase"\'','<? my $foo; ?>foo',qr/^a phrase$/ ),
71+
L('-Dfoo=\"bar\"','_foo foo foobar barfoo',qr/^_foo bar foobar barfoo$/ ),
72+
L('-Dfoo=\"bar\" --define barfoo','_foo foo foobar barfoo',
73+
qr/^_foo bar foobar barfoo$/ ),
6874

6975
# Sets, which do not textually substitute
70-
['-sfoo=42','<? my $foo; ?>foo',qr/^foo$/ ],
71-
['-sfoo=42','<? my $foo; ?><?= $S{foo} ?>',qr/^42$/ ],
72-
['--set foo=42','<? my $foo; ?>foo',qr/^foo$/ ],
73-
['--set foo=42','<? my $foo; ?><?= $S{foo} ?>',qr/^42$/ ],
76+
do{L('-E -sfoo=42','<? my $foo; ?>foo',qr/^foo$/ )},
77+
do{L('-sfoo=42','<? my $foo; ?><?= $S{foo} ?>',qr/^42$/ )},
78+
[__LINE__, '--set foo=42','<? my $foo; ?>foo',qr/^foo$/ ],
79+
do{L('--set foo=42','<? my $foo; ?><?= $S{foo} ?>',qr/^42$/ )},
7480

7581
# Conditionals
76-
['-Dfoo=42','<?:if foo==2?>yes<?:else?>no<?:endif?>',qr/^no$/ ],
77-
['-Dfoo=2','<?:if foo==2?>yes<?:else?>no<?:endif?>',qr/^yes$/ ],
78-
['-Dfoo','<?:if foo==2?>yes<?:else?>no<?:endif?>',qr/^no$/ ],
79-
['-Dfoo','<?:if foo==1?>yes<?:else?>no<?:endif?>',qr/^yes$/ ],
82+
L('-Dfoo=42','<?:if foo==2?>yes<?:else?>no<?:endif?>',qr/^no$/ ),
83+
L('-Dfoo=2','<?:if foo==2?>yes<?:else?>no<?:endif?>',qr/^yes$/ ),
84+
L('-Dfoo','<?:if foo==2?>yes<?:else?>no<?:endif?>',qr/^no$/ ),
85+
L('-Dfoo','<?:if foo==1?>yes<?:else?>no<?:endif?>',qr/^yes$/ ),
8086
# The default value is true, which compares equal to 1.
81-
['-Dfoo','<?:if foo?>yes<?:else?>no<?:endif?>',qr/^yes$/ ],
82-
['','<?:if foo?>yes<?:else?>no<?:endif?>',qr/^no$/ ],
83-
['','<?:if foo==2?>yes<?:else?>no<?:endif?>',qr/^no$/ ],
87+
L('-Dfoo','<?:if foo?>yes<?:else?>no<?:endif?>',qr/^yes$/ ),
88+
L('','<?:if foo?>yes<?:else?>no<?:endif?>',qr/^no$/ ),
89+
L('','<?:if foo==2?>yes<?:else?>no<?:endif?>',qr/^no$/ ),
8490
# For consistency, all :if tests evaluate to false if the
8591
# named variable is not defined.
8692

8793
# Undefining
88-
['-Dfoo','<?:undef foo?><?:if foo?>yes<?:else?>no<?:endif?>',qr/^no$/ ],
89-
94+
L('-Dfoo','<?:undef foo?><?:if foo?>yes<?:else?>no<?:endif?>',qr/^no$/ ),
95+
#
9096
# Three forms of elsif
91-
['', '<?:if foo eq "1" ?>yes<?:elif foo eq "x" ?>maybe<?:else?>no<?:endif?>', qr/^no$/],
92-
['', '<?:if foo eq "1" ?>yes<?:elsif foo eq "x" ?>maybe<?:else?>no<?:endif?>', qr/^no$/],
93-
['', '<?:if foo eq "1" ?>yes<?:elseif foo eq "x" ?>maybe<?:else?>no<?:endif?>', qr/^no$/],
97+
L('', '<?:if foo eq "1" ?>yes<?:elif foo eq "x" ?>maybe<?:else?>no<?:endif?>', qr/^no$/),
98+
L('', '<?:if foo eq "1" ?>yes<?:elsif foo eq "x" ?>maybe<?:else?>no<?:endif?>', qr/^no$/),
99+
L('', '<?:if foo eq "1" ?>yes<?:elseif foo eq "x" ?>maybe<?:else?>no<?:endif?>', qr/^no$/),
94100

95101
# elsif with definitions
96-
['-Dfoo', '<?:if foo eq "1" ?>yes<?:elsif foo eq "x" ?>maybe<?:else?>no<?:endif?>', qr/^yes$/],
97-
['-Dfoo=1', '<?:if foo eq "1" ?>yes<?:elsif foo eq "x" ?>maybe<?:else?>no<?:endif?>', qr/^yes$/],
102+
L('-Dfoo', '<?:if foo eq "1" ?>yes<?:elsif foo eq "x" ?>maybe<?:else?>no<?:endif?>', qr/^yes$/),
103+
L('-Dfoo=1', '<?:if foo eq "1" ?>yes<?:elsif foo eq "x" ?>maybe<?:else?>no<?:endif?>', qr/^yes$/),
98104
# Automatic conversion of numeric 1 to string in "eq" context
99-
['-Dfoo=\\"x\\"', '<?= $D{foo} . "\n" ?><?:if foo eq "1" ?>yes<?:elsif foo eq "x" ?>maybe<?:else?>no<?:endif?>', qr/^x\nmaybe$/],
100-
['-Dfoo=\\"y\\"', '<?:if foo eq "1" ?>yes<?:elsif foo eq "x" ?>maybe<?:else?>no<?:endif?>', qr/^no$/],
105+
L('-Dfoo=\\"x\\"', '<?= $D{foo} . "\n" ?><?:if foo eq "1" ?>yes<?:elsif foo eq "x" ?>maybe<?:else?>no<?:endif?>', qr/^x\nmaybe$/),
106+
L('-Dfoo=\\"y\\"', '<?:if foo eq "1" ?>yes<?:elsif foo eq "x" ?>maybe<?:else?>no<?:endif?>', qr/^no$/),
101107

102108
); #@testcases
103109

@@ -106,7 +112,7 @@ my @testcases=(
106112
my $testcount = 0;
107113

108114
for my $lrTest (@testcases) {
109-
my ($out_re, $err_re) = @$lrTest[2..3];
115+
my ($out_re, $err_re) = @$lrTest[3..4];
110116
++$testcount if defined $out_re;
111117
++$testcount if defined $err_re;
112118
}
@@ -115,20 +121,21 @@ plan tests => $testcount;
115121
diag "Running $testcount tests";
116122

117123
for my $lrTest (@testcases) {
118-
my ($opts, $testin, $out_re, $err_re) = @$lrTest;
124+
my ($where, $opts, $testin, $out_re, $err_re) = @$lrTest;
119125

120126
my ($out, $err);
127+
diag '=' x 70;
121128
diag $opts, " <<<'", $testin, "'\n";
122129
run_perlpp $opts, \$testin, \$out, \$err;
123130
#diag "Done running";
124131

125132
if(defined $out_re) {
126133
#diag "checking output";
127-
like($out, $out_re);
134+
like($out, $out_re, "stdout $where");
128135
}
129136
if(defined $err_re) {
130137
#diag "checking stderr";
131-
like($err, $err_re);
138+
like($err, $err_re, "stderr $where");
132139
}
133140
print STDERR "$err\n";
134141

‎t/lib/PerlPPTest.pm‎

Lines changed: 18 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -18,23 +18,35 @@ use Capture::Tiny 'capture';
1818
use Carp;
1919
use Config;
2020
use IPC::Run3;
21+
use Text::ParseWords qw(shellwords);
2122

23+
# Debugging aids
2224
use Data::Dumper;
25+
use Devel::StackTrace;
2326

24-
our @EXPORT = qw(run_perlpp);
27+
our @EXPORT = qw(run_perlpp L);
2528
our @EXPORT_OK = qw(get_perl_filename);
2629

30+
# L: given a list, return an array ref that includes that list, with the
31+
# caller's filename:line number at the front of the list
32+
sub L {
33+
my (undef, $filename, $line) = caller;
34+
say STDERR "\n## L trace:\n",
35+
(Devel::StackTrace->new->as_string() =~ s/^/##/mgr);
36+
return ["$filename:$line", @_];
37+
} #L
38+
2739
# run_perlpp: Run perlpp
2840
# Args: $lrArgs, $refStdin, $refStdout, $refStderr
2941
sub run_perlpp {
3042
my ($lrArgs, $refStdin, $refStdout, $refStderr) = @_;
3143
my $retval;
3244

33-
$lrArgs = [split(' ', $lrArgs)] if ref $lrArgs ne 'ARRAY';
34-
say STDERR "args: ", Dumper($lrArgs);
45+
$lrArgs = [shellwords($lrArgs)] if ref $lrArgs ne 'ARRAY';
46+
say STDERR "## args:\n", (Dumper($lrArgs) =~ s/^/##/mgr);
3547

3648
if($ENV{PERLPP_PERLOPTS}) {
37-
say STDERR "# running external perl";
49+
#say STDERR "# running external perl";
3850
$retval = run3(
3951
join(' ', get_perl_filename(), $ENV{PERLPP_PERLOPTS},
4052
@$lrArgs),
@@ -52,9 +64,9 @@ sub run_perlpp {
5264
eval {
5365
($$refStdout, $$refStderr, @result) = capture {
5466
# Thanks to http://www.perlmonks.org/bare/?node_id=289391 by Zaxo
55-
say STDERR "# running perlpp";
67+
#say STDERR "# running perlpp";
5668
my $result = Text::PerlPP::Main($lrArgs);
57-
say STDERR "# done running perlpp";
69+
#say STDERR "# done running perlpp";
5870
$result;
5971
};
6072
} or die "Capture failed: " . $@;

0 commit comments

Comments
 (0)