Skip to content

Commit 88bb21a

Browse files
iabyniabyn
committed
ParseXS: fix CASE:
My recent merge commit v5.41.4-108-g9621dfa822 partially broke the CASE: functionality; although I didn't spot it at first since the ParseXS test suite only has a single CASE: test, and none of the XS code bundled with perl core makes use of it. The issue was that an XSUB with multiple CASEs has a single signature, but potentially multiple sets of INPUT and OUTPUT sections. For example: int foo(abc, def) CASE: X int abc; int def; CODE: RETVAL = abc + def; OUTPUT: RETVAL CASE: Y long abc; long def; CODE: RETVAL = abc - def; OUTPUT: RETVAL Once my merge commit made the data from INPUT and OUTPUT sections be used to update each Node::Param object (which has been derived from the signature entry) then this starts to fall apart. It only started failing the single CASE test in t/002-more.t once *this* branch made RETVAL an object (rather than it being special-cased). The fix in this commit is a bit of hack. Once all of the XSUB's signature has been parsed into a list of Node::Param objects, a copy of this list is taken and kept as the original. Then each time the body is parsed (typically once, but multiple times for bodies with CASE keywords) that original list is copied and becomes the current parameter list. The objects in that list are updated by INPUT and OUTPUT sections as usual. Then for the start of the next CASE, the next copying blows away all those updates. If and when ParseXS takes on more of an AST-like appearance (with, hypothetically, Node::INPUT, Node::OUTPUT etc objects) then this approach should be revisited. Note that this commit restores the CASE test in t/002-more.t which I temporarily disabled a few commits ago.
1 parent b826448 commit 88bb21a

File tree

5 files changed

+149
-13
lines changed

5 files changed

+149
-13
lines changed

‎dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm

Lines changed: 31 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -958,6 +958,16 @@ EOF
958958
# #if, #else, #endif etc within the XSUB should balance out.
959959
check_conditional_preprocessor_statements();
960960

961+
# Save a deep copy the params created from parsing the signature.
962+
# See the comments below starting "For each CASE" for details.
963+
964+
$self->{xsub_sig}{orig_params} = [];
965+
for (@{$self->{xsub_sig}{params}}) {
966+
my %h = %$_;
967+
bless \%h, 'ExtUtils::ParseXS::Node::Param';
968+
push @{$self->{xsub_sig}{orig_params}}, \%h;
969+
}
970+
961971
# ----------------------------------------------------------------
962972
# Each iteration of this loop will process 1 optional CASE: line,
963973
# followed by all the other blocks. In the absence of a CASE: line,
@@ -970,6 +980,27 @@ EOF
970980
# Note that each CASE: can precede multiple keyword blocks.
971981
$self->CASE_handler($_) if $self->check_keyword("CASE");
972982

983+
# For each CASE, start with a fresh set of params based on the
984+
# original parsing of the XSUB's signature. This is because each set
985+
# of INPUT/OUTPUT blocks associated with each CASE may update the
986+
# param objects in a different way.
987+
#
988+
# Note that $self->{xsub_sig}{names} provides a second set of
989+
# references to most of these param objects; so the object hashes
990+
# themselves must be preserved, and merely their contents emptied
991+
# and repopulated each time. Hence also why creating the orig_params
992+
# snapshot above must be a deep copy.
993+
#
994+
# XXX This is bit of a temporary hack.
995+
996+
for my $i (0.. @{$self->{xsub_sig}{orig_params}} - 1) {
997+
my $op = $self->{xsub_sig}{orig_params}[$i];
998+
my $p = $self->{xsub_sig}{params}[$i];
999+
%$p = ();
1000+
my @keys = sort keys %$op;
1001+
@$p{@keys} = @$op{@keys};
1002+
}
1003+
9731004
# ----------------------------------------------------------------
9741005
# Handle all the XSUB parts which generate declarations
9751006
# ----------------------------------------------------------------

‎dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Node.pm

Lines changed: 10 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -456,8 +456,17 @@ BEGIN {
456456

457457
our @FIELDS = (
458458
@ExtUtils::ParseXS::Node::FIELDS,
459+
'orig_params', # Array ref of Node::Param objects representing
460+
# the original (as parsed) parameters of this XSUB
461+
459462
'params', # Array ref of Node::Param objects representing
460-
# the parameters of this XSUB
463+
# the current parameters of this XSUB - this
464+
# is orig_params plus any updated fields from
465+
# processing INPUT and OUTPUT lines. Note that
466+
# with multiple CASE: blocks, there can be
467+
# multiple sets of INPUT and OUTPUT etc blocks.
468+
# params is reset to the contents of orig_params
469+
# after the start of each new CASE: block.
461470

462471
'names', # Hash ref mapping variable names to Node::Param
463472
# objects

‎dist/ExtUtils-ParseXS/t/001-basic.t

Lines changed: 102 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
#!/usr/bin/perl
22

33
use strict;
4-
use Test::More tests => 423;
4+
use Test::More tests => 435;
55
use Config;
66
use DynaLoader;
77
use ExtUtils::CBuilder;
@@ -104,7 +104,10 @@ sub test_many {
104104
# test diagnostics smaller.
105105
if ($out =~ /\S/) {
106106
$out =~ s/\A.*? (^\w+\(${prefix} .*? ^}).*\z/$1/xms
107-
or die "couldn't trim output for fn '$prefix'";
107+
or do {
108+
# print STDERR $out;
109+
die "$desc_prefix: couldn't trim output to only function starting '$prefix'\n";
110+
}
108111
}
109112

110113
my $err_tested;
@@ -2568,3 +2571,100 @@ EOF
25682571
25692572
test_many($preamble, 'XS_Foo_', \@test_fns);
25702573
}
2574+
2575+
{
2576+
# Test CASE: blocks
2577+
2578+
my $preamble = Q(<<'EOF');
2579+
|MODULE = Foo PACKAGE = Foo
2580+
|
2581+
|PROTOTYPES: DISABLE
2582+
|
2583+
EOF
2584+
2585+
my @test_fns = (
2586+
2587+
[
2588+
"CASE with dup INPUT and OUTPUT",
2589+
[ Q(<<'EOF') ],
2590+
|int
2591+
|foo(abc, def)
2592+
| CASE: X
2593+
| int abc;
2594+
| short def;
2595+
| CODE:
2596+
| RETVAL = abc + def;
2597+
| OUTPUT:
2598+
| RETVAL
2599+
|
2600+
| CASE: Y
2601+
| long abc;
2602+
| long def;
2603+
| CODE:
2604+
| RETVAL = abc - def;
2605+
| OUTPUT:
2606+
| RETVAL
2607+
EOF
2608+
[ 0, 0, qr/_usage\(cv,\s*"abc, def"\)/, "usage" ],
2609+
2610+
[ 0, 0, qr/
2611+
if \s* \(X\)
2612+
.*
2613+
int \s+ abc \s* = [^\n]* ST\(0\)
2614+
.*
2615+
else \s+ if \s* \(Y\)
2616+
/xs, "1st abc is int and ST(0)" ],
2617+
[ 0, 0, qr/
2618+
else \s+ if \s* \(Y\)
2619+
.*
2620+
long \s+ abc \s* = [^\n]* ST\(0\)
2621+
/xs, "2nd abc is long and ST(0)" ],
2622+
[ 0, 0, qr/
2623+
if \s* \(X\)
2624+
.*
2625+
short \s+ def \s* = [^\n]* ST\(1\)
2626+
.*
2627+
else \s+ if \s* \(Y\)
2628+
/xs, "1st def is short and ST(1)" ],
2629+
[ 0, 0, qr/
2630+
else \s+ if \s* \(Y\)
2631+
.*
2632+
long \s+ def \s* = [^\n]* ST\(1\)
2633+
/xs, "2nd def is long and ST(1)" ],
2634+
[ 0, 0, qr/
2635+
if \s* \(X\)
2636+
.*
2637+
int \s+ RETVAL;
2638+
.*
2639+
else \s+ if \s* \(Y\)
2640+
/xs, "1st RETVAL is int" ],
2641+
[ 0, 0, qr/
2642+
else \s+ if \s* \(Y\)
2643+
.*
2644+
int \s+ RETVAL;
2645+
.*
2646+
/xs, "2nd RETVAL is int" ],
2647+
2648+
[ 0, 0, qr/
2649+
if \s* \(X\)
2650+
.*
2651+
\QRETVAL = abc + def;\E
2652+
.*
2653+
else \s+ if \s* \(Y\)
2654+
/xs, "1st RETVAL assign" ],
2655+
[ 0, 0, qr/
2656+
else \s+ if \s* \(Y\)
2657+
.*
2658+
\QRETVAL = abc - def;\E
2659+
.*
2660+
/xs, "2nd RETVAL assign" ],
2661+
2662+
[ 0, 0, qr/\b\QXSRETURN(1)/, "ret 1" ],
2663+
[ 0, 1, qr/\bXSRETURN\b.*\bXSRETURN/s, "only a single XSRETURN" ],
2664+
],
2665+
2666+
2667+
);
2668+
2669+
test_many($preamble, 'XS_Foo_', \@test_fns);
2670+
}

‎dist/ExtUtils-ParseXS/t/002-more.t

Lines changed: 1 addition & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -76,9 +76,7 @@ SKIP: {
7676
is prototype(\&XSMore::attr_method), '$;@', 'ATTRS with prototype';
7777

7878
is XSMore::return_1(), 1, 'the CASE keyword (1)';
79-
# XXX tmp disable test
80-
#is XSMore::return_2(), 2, 'the CASE keyword (2)';
81-
pass('the CASE keyword (2)');
79+
is XSMore::return_2(), 2, 'the CASE keyword (2)';
8280
is prototype(\&XSMore::return_1), "", 'ALIAS with prototype (1)';
8381
is prototype(\&XSMore::return_2), "", 'ALIAS with prototype (2)';
8482

‎dist/ExtUtils-ParseXS/t/XSMore.xs

Lines changed: 5 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -197,13 +197,11 @@ CASE: ix == 1
197197
RETVAL = ix;
198198
OUTPUT:
199199
RETVAL
200-
# XXX temporarily disable test until multiplce CASE supported
201-
# XXX with RETVAL as a PARAM object
202-
# XXX CASE: ix == 2
203-
# XXX CODE:
204-
# XXX RETVAL = ix;
205-
# XXX OUTPUT:
206-
# XXX RETVAL
200+
CASE: ix == 2
201+
CODE:
202+
RETVAL = ix;
203+
OUTPUT:
204+
RETVAL
207205

208206
int
209207
arg_init(x)

0 commit comments

Comments
 (0)