From 2647863031762b1897841364c638c3727bc043f1 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Mon, 6 Sep 2021 11:53:29 +1000 Subject: ParseXS: always XSprePUSH when producing an output list The late XSprePUSH with a non-PUSHx() RETVAL was causing the stack and accesses to ST(n) to be out of sync. If generated RETVAL code does write directly to ST(n) (as much does), doesn't generate a push and we're generating output list code, adjust SP to match to keep things in sync. Also test that the original example case that worked, continues to work. Fixes #19054 --- dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm | 22 ++++++++++------ dist/ExtUtils-ParseXS/t/002-more.t | 8 +++++- dist/ExtUtils-ParseXS/t/XSMore.xs | 36 +++++++++++++++++++++++++++ 3 files changed, 57 insertions(+), 9 deletions(-) diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm index d2205acd5a..cc10ff9465 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm @@ -690,10 +690,17 @@ EOF do_push => undef, } ) for grep $self->{in_out}->{$_} =~ /OUT$/, sort keys %{ $self->{in_out} }; - my $prepush_done; + my $c = @{ $outlist_ref }; + if ($c) { + my $ext = $c; + ++$ext if $self->{gotRETVAL} || $wantRETVAL; + print "\tXSprePUSH;"; + print "\tEXTEND(SP,$ext);\n"; + } # all OUTPUT done, so now push the return value on the stack if ($self->{gotRETVAL} && $self->{RETVAL_code}) { print "\t$self->{RETVAL_code}\n"; + print "\t++SP;\n" if $c; } elsif ($self->{gotRETVAL} || $wantRETVAL) { my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} ); @@ -708,8 +715,9 @@ EOF ); if (not $trgt->{with_size} and $trgt->{type} eq 'p') { # sv_setpv # PUSHp corresponds to sv_setpvn. Treat sv_setpv directly - print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; - $prepush_done = 1; + print "\tsv_setpv(TARG, $what);\n"; + print "\tXSprePUSH;\n" unless $c; + print "\tPUSHTARG;\n"; } else { my $tsize = $trgt->{what_size}; @@ -718,8 +726,8 @@ EOF qq("$tsize"), {var => $var, type => $self->{ret_type}} ); - print "\tXSprePUSH; PUSH$trgt->{type}($what$tsize);\n"; - $prepush_done = 1; + print "\tXSprePUSH;\n" unless $c; + print "\tPUSH$trgt->{type}($what$tsize);\n"; } } else { @@ -731,14 +739,12 @@ EOF do_setmagic => 0, do_push => undef, } ); + print "\t++SP;\n" if $c; } } $xsreturn = 1 if $self->{ret_type} ne "void"; my $num = $xsreturn; - my $c = @{ $outlist_ref }; - print "\tXSprePUSH;" if $c and not $prepush_done; - print "\tEXTEND(SP,$c);\n" if $c; $xsreturn += $c; $self->generate_output( { type => $self->{var_types}->{$_}, diff --git a/dist/ExtUtils-ParseXS/t/002-more.t b/dist/ExtUtils-ParseXS/t/002-more.t index 3ea89c2583..c8cc7bf97c 100644 --- a/dist/ExtUtils-ParseXS/t/002-more.t +++ b/dist/ExtUtils-ParseXS/t/002-more.t @@ -9,7 +9,7 @@ use ExtUtils::CBuilder; use attributes; use overload; -plan tests => 30; +plan tests => 32; my ($source_file, $obj_file, $lib_file); @@ -91,6 +91,12 @@ SKIP: { is_deeply [XSMore::outlist()], [ord('a'), ord('b')], 'the OUTLIST keyword'; + is_deeply [XSMore::outlist_bool("a", "b")], [ !0, "ab" ], + "OUTLIST with a bool RETVAL"; + + is_deeply [XSMore::outlist_int("c", "d")], [ 11, "cd" ], + "OUTLIST with an int RETVAL"; + # eval so compile-time sees any prototype is_deeply [ eval 'XSMore::outlist()' ], [ord('a'), ord('b')], 'OUTLIST prototypes'; diff --git a/dist/ExtUtils-ParseXS/t/XSMore.xs b/dist/ExtUtils-ParseXS/t/XSMore.xs index 21ad41df89..f8413f43bd 100644 --- a/dist/ExtUtils-ParseXS/t/XSMore.xs +++ b/dist/ExtUtils-ParseXS/t/XSMore.xs @@ -38,6 +38,36 @@ outlist(int* a, int* b){ *b = 'b'; } +STATIC bool +outlist_bool(const char *a, const char *b, char **c) +{ + dTHX; + STRLEN lena = strlen(a); + STRLEN lenb = strlen(b); + STRLEN lenc = lena + lenb; + Newx(*c, lenc+1, char); + strcpy(*c, a); + strcat(*c, b); + SAVEFREEPV(*c); + + return TRUE; +} + +STATIC int +outlist_int(const char *a, const char *b, char **c) +{ + dTHX; + STRLEN lena = strlen(a); + STRLEN lenb = strlen(b); + STRLEN lenc = lena + lenb; + Newx(*c, lenc+1, char); + strcpy(*c, a); + strcat(*c, b); + SAVEFREEPV(*c); + + return 11; +} + STATIC int len(const char* const s, int const l){ PERL_UNUSED_ARG(s); @@ -201,6 +231,12 @@ CLEANUP: void outlist(OUTLIST int a, OUTLIST int b) +bool +outlist_bool(const char *a, const char *b, OUTLIST char *c) + +int +outlist_int(const char *a, const char *b, OUTLIST char *c) + int len(char* s, int length(s)) -- cgit v1.2.1 From 42510d5ab1dca0720ccf23ac6156d1d54aa971b5 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Mon, 6 Sep 2021 14:13:36 +1000 Subject: bump $ExtUtils::ParseXS::VERSION --- dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm | 2 +- dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Constants.pm | 2 +- dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm | 2 +- dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Eval.pm | 2 +- dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm | 2 +- dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps.pm | 2 +- dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Cmd.pm | 2 +- dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/InputMap.pm | 2 +- dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/OutputMap.pm | 2 +- dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Type.pm | 2 +- 10 files changed, 10 insertions(+), 10 deletions(-) diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm index cc10ff9465..f4edf959f9 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm @@ -11,7 +11,7 @@ use Symbol; our $VERSION; BEGIN { - $VERSION = '3.43'; + $VERSION = '3.44'; require ExtUtils::ParseXS::Constants; ExtUtils::ParseXS::Constants->VERSION($VERSION); require ExtUtils::ParseXS::CountLines; ExtUtils::ParseXS::CountLines->VERSION($VERSION); require ExtUtils::ParseXS::Utilities; ExtUtils::ParseXS::Utilities->VERSION($VERSION); diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Constants.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Constants.pm index d7668c4733..5b73795d03 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Constants.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Constants.pm @@ -3,7 +3,7 @@ use strict; use warnings; use Symbol; -our $VERSION = '3.43'; +our $VERSION = '3.44'; =head1 NAME diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm index c592621e03..a5b71f6b9f 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/CountLines.pm @@ -1,7 +1,7 @@ package ExtUtils::ParseXS::CountLines; use strict; -our $VERSION = '3.43'; +our $VERSION = '3.44'; our $SECTION_END_MARKER; diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Eval.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Eval.pm index c509531d2f..8a3bd00dee 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Eval.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Eval.pm @@ -2,7 +2,7 @@ package ExtUtils::ParseXS::Eval; use strict; use warnings; -our $VERSION = '3.43'; +our $VERSION = '3.44'; =head1 NAME diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm index 6cc8a0e408..574031d157 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Utilities.pm @@ -5,7 +5,7 @@ use Exporter; use File::Spec; use ExtUtils::ParseXS::Constants (); -our $VERSION = '3.43'; +our $VERSION = '3.44'; our (@ISA, @EXPORT_OK); @ISA = qw(Exporter); diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps.pm index 62a2b1b606..c6d5430ff7 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps.pm @@ -2,7 +2,7 @@ package ExtUtils::Typemaps; use 5.006001; use strict; use warnings; -our $VERSION = '3.43'; +our $VERSION = '3.44'; require ExtUtils::ParseXS; require ExtUtils::ParseXS::Constants; diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Cmd.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Cmd.pm index 5bddcc0569..3c4b4e519c 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Cmd.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Cmd.pm @@ -2,7 +2,7 @@ package ExtUtils::Typemaps::Cmd; use 5.006001; use strict; use warnings; -our $VERSION = '3.43'; +our $VERSION = '3.44'; use ExtUtils::Typemaps; diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/InputMap.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/InputMap.pm index fd2efc878d..102fc9ebfc 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/InputMap.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/InputMap.pm @@ -2,7 +2,7 @@ package ExtUtils::Typemaps::InputMap; use 5.006001; use strict; use warnings; -our $VERSION = '3.43'; +our $VERSION = '3.44'; =head1 NAME diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/OutputMap.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/OutputMap.pm index d4210c5576..f9b5a86035 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/OutputMap.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/OutputMap.pm @@ -2,7 +2,7 @@ package ExtUtils::Typemaps::OutputMap; use 5.006001; use strict; use warnings; -our $VERSION = '3.43'; +our $VERSION = '3.44'; =head1 NAME diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Type.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Type.pm index 36d575339c..1a78c17ef9 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Type.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/Type.pm @@ -4,7 +4,7 @@ use strict; use warnings; require ExtUtils::Typemaps; -our $VERSION = '3.43'; +our $VERSION = '3.44'; =head1 NAME -- cgit v1.2.1 From f0abb35079fb598ed88ef367d405fdd698a736d6 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Mon, 6 Sep 2021 14:29:45 +1000 Subject: test and fix using T_SV as an OUTPUT parameter --- ext/XS-Typemap/Typemap.pm | 1 + ext/XS-Typemap/Typemap.xs | 7 +++++++ ext/XS-Typemap/t/Typemap.t | 6 +++++- lib/ExtUtils/typemap | 2 +- 4 files changed, 14 insertions(+), 2 deletions(-) diff --git a/ext/XS-Typemap/Typemap.pm b/ext/XS-Typemap/Typemap.pm index 9f838b44cb..721b476c06 100644 --- a/ext/XS-Typemap/Typemap.pm +++ b/ext/XS-Typemap/Typemap.pm @@ -38,6 +38,7 @@ our $VERSION = '0.18'; our @EXPORT = (qw/ T_SV + T_SV_output T_SVREF T_SVREF_REFCOUNT_FIXED T_AVREF diff --git a/ext/XS-Typemap/Typemap.xs b/ext/XS-Typemap/Typemap.xs index 397052d1cb..14417da3be 100644 --- a/ext/XS-Typemap/Typemap.xs +++ b/ext/XS-Typemap/Typemap.xs @@ -267,6 +267,13 @@ T_SV( sv ) OUTPUT: RETVAL +void +T_SV_output(sv) + SV *sv + CODE: + sv = sv_2mortal(newSVpvn("test", 4)); + OUTPUT: + sv ## T_SVREF diff --git a/ext/XS-Typemap/t/Typemap.t b/ext/XS-Typemap/t/Typemap.t index 3e56b573d6..7422e6c5bd 100644 --- a/ext/XS-Typemap/t/Typemap.t +++ b/ext/XS-Typemap/t/Typemap.t @@ -6,7 +6,7 @@ BEGIN { } } -use Test::More tests => 156; +use Test::More tests => 158; use strict; #catch WARN_INTERNAL type errors, and anything else unexpected @@ -33,6 +33,10 @@ note("T_SV"); my $sv = "Testing T_SV"; is( T_SV($sv), $sv); +# T_SV with output +is_deeply([ T_SV_output($sv) ], [], "T_SV_output: no return value"); +is($sv, "test", "T_SV_output: output written to"); + # T_SVREF - reference to Scalar note("T_SVREF"); $sv .= "REF"; diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap index 8aa1e12135..adac80fd1c 100644 --- a/lib/ExtUtils/typemap +++ b/lib/ExtUtils/typemap @@ -315,7 +315,7 @@ T_OUT ############################################################################# OUTPUT T_SV - $arg = $var; + ${ "$var" eq "RETVAL" ? \"$arg = $var;" : \"sv_setsv_mg($arg, $var);" } T_SVREF $arg = newRV((SV*)$var); T_SVREF_REFCOUNT_FIXED -- cgit v1.2.1 From 6c168fa48629feec620455099a41f5a9dbf63d3b Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Mon, 6 Sep 2021 14:29:56 +1000 Subject: bump $XS::Typemap::VERSION --- ext/XS-Typemap/Typemap.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ext/XS-Typemap/Typemap.pm b/ext/XS-Typemap/Typemap.pm index 721b476c06..49cebddd65 100644 --- a/ext/XS-Typemap/Typemap.pm +++ b/ext/XS-Typemap/Typemap.pm @@ -34,7 +34,7 @@ to the test script. use parent qw/ Exporter /; require XSLoader; -our $VERSION = '0.18'; +our $VERSION = '0.19'; our @EXPORT = (qw/ T_SV -- cgit v1.2.1 From ade1dcccb274812424b79cdbce70a7110d5285a7 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Mon, 6 Sep 2021 14:50:48 +1000 Subject: test and fix using T_SVREF_REFCOUNT as an output parameter --- ext/XS-Typemap/Typemap.pm | 1 + ext/XS-Typemap/Typemap.xs | 5 +++++ ext/XS-Typemap/t/Typemap.t | 10 +++++++++- lib/ExtUtils/typemap | 2 +- 4 files changed, 16 insertions(+), 2 deletions(-) diff --git a/ext/XS-Typemap/Typemap.pm b/ext/XS-Typemap/Typemap.pm index 49cebddd65..c1b5505e8a 100644 --- a/ext/XS-Typemap/Typemap.pm +++ b/ext/XS-Typemap/Typemap.pm @@ -41,6 +41,7 @@ our @EXPORT = (qw/ T_SV_output T_SVREF T_SVREF_REFCOUNT_FIXED + T_SVREF_REFCOUNT_FIXED_output T_AVREF T_AVREF_REFCOUNT_FIXED T_HVREF diff --git a/ext/XS-Typemap/Typemap.xs b/ext/XS-Typemap/Typemap.xs index 14417da3be..d0703be2e5 100644 --- a/ext/XS-Typemap/Typemap.xs +++ b/ext/XS-Typemap/Typemap.xs @@ -297,6 +297,11 @@ T_SVREF_REFCOUNT_FIXED( svref ) OUTPUT: RETVAL +void +T_SVREF_REFCOUNT_FIXED_output( OUT svref ) + SVREF_FIXED svref + CODE: + svref = newSVpvn("test", 4); ## T_AVREF diff --git a/ext/XS-Typemap/t/Typemap.t b/ext/XS-Typemap/t/Typemap.t index 7422e6c5bd..835b35caf0 100644 --- a/ext/XS-Typemap/t/Typemap.t +++ b/ext/XS-Typemap/t/Typemap.t @@ -6,7 +6,7 @@ BEGIN { } } -use Test::More tests => 158; +use Test::More tests => 161; use strict; #catch WARN_INTERNAL type errors, and anything else unexpected @@ -55,6 +55,14 @@ is( ${ T_SVREF_REFCOUNT_FIXED($svref) }, $$svref ); eval { T_SVREF_REFCOUNT_FIXED( "fail - not ref" ) }; ok( $@ ); +# output only +SKIP:{ + my $svr; + is_deeply([ T_SVREF_REFCOUNT_FIXED_output($svr) ], [ ], "call with non-ref lvalue, no return value"); + ok(ref $svr, "output parameter now a reference") + or skip "Not a reference", 1; + is($$svr, "test", "reference to correct value"); +} # T_AVREF - reference to a perl Array note("T_AVREF"); diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap index adac80fd1c..0c943ef73f 100644 --- a/lib/ExtUtils/typemap +++ b/lib/ExtUtils/typemap @@ -319,7 +319,7 @@ T_SV T_SVREF $arg = newRV((SV*)$var); T_SVREF_REFCOUNT_FIXED - $arg = newRV_noinc((SV*)$var); + ${ "$var" eq "RETVAL" ? \"$arg = newRV_noinc((SV*)$var);" : \"sv_setrv_noinc($arg, (SV*)$var);" } T_AVREF $arg = newRV((SV*)$var); T_AVREF_REFCOUNT_FIXED -- cgit v1.2.1 From 83b243fa48968f4349136fe6943f0c21313b217e Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Mon, 6 Sep 2021 15:09:49 +1000 Subject: test and fix using T_HVREF_REFCOUNT as an output parameter --- ext/XS-Typemap/Typemap.pm | 1 + ext/XS-Typemap/Typemap.xs | 6 ++++++ ext/XS-Typemap/t/Typemap.t | 10 +++++++++- lib/ExtUtils/typemap | 2 +- 4 files changed, 17 insertions(+), 2 deletions(-) diff --git a/ext/XS-Typemap/Typemap.pm b/ext/XS-Typemap/Typemap.pm index c1b5505e8a..d6e86da86a 100644 --- a/ext/XS-Typemap/Typemap.pm +++ b/ext/XS-Typemap/Typemap.pm @@ -46,6 +46,7 @@ our @EXPORT = (qw/ T_AVREF_REFCOUNT_FIXED T_HVREF T_HVREF_REFCOUNT_FIXED + T_HVREF_REFCOUNT_FIXED_output T_CVREF T_CVREF_REFCOUNT_FIXED T_SYSRET_fail T_SYSRET_pass diff --git a/ext/XS-Typemap/Typemap.xs b/ext/XS-Typemap/Typemap.xs index d0703be2e5..353e04fb45 100644 --- a/ext/XS-Typemap/Typemap.xs +++ b/ext/XS-Typemap/Typemap.xs @@ -348,6 +348,12 @@ T_HVREF_REFCOUNT_FIXED( hv ) OUTPUT: RETVAL +void +T_HVREF_REFCOUNT_FIXED_output( OUT hvref) + HV_FIXED *hvref; + CODE: + hvref = newHV(); + hv_stores(hvref, "test", newSVpvs("value")); ## T_CVREF diff --git a/ext/XS-Typemap/t/Typemap.t b/ext/XS-Typemap/t/Typemap.t index 835b35caf0..33f4e45306 100644 --- a/ext/XS-Typemap/t/Typemap.t +++ b/ext/XS-Typemap/t/Typemap.t @@ -6,7 +6,7 @@ BEGIN { } } -use Test::More tests => 161; +use Test::More tests => 164; use strict; #catch WARN_INTERNAL type errors, and anything else unexpected @@ -96,6 +96,14 @@ is( T_HVREF_REFCOUNT_FIXED(\%hash), \%hash); eval { T_HVREF_REFCOUNT_FIXED( \@array ) }; ok( $@ ); +# output only +SKIP:{ + my $hvr; + is_deeply([ T_HVREF_REFCOUNT_FIXED_output($hvr) ], [ ], "call with non-ref lvalue, no return value"); + ok(ref $hvr, "output parameter now a reference") + or skip "Not a reference", 1; + is($hvr->{test}, "value", "has expected key"); +} # T_CVREF - reference to perl subroutine note("T_CVREF"); diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap index 0c943ef73f..4cedca4025 100644 --- a/lib/ExtUtils/typemap +++ b/lib/ExtUtils/typemap @@ -327,7 +327,7 @@ T_AVREF_REFCOUNT_FIXED T_HVREF $arg = newRV((SV*)$var); T_HVREF_REFCOUNT_FIXED - $arg = newRV_noinc((SV*)$var); + ${ "$var" eq "RETVAL" ? \"$arg = newRV_noinc((SV*)$var);" : \"sv_setrv_noinc($arg, (SV*)$var);" } T_CVREF $arg = newRV((SV*)$var); T_CVREF_REFCOUNT_FIXED -- cgit v1.2.1 From b61667640189f6de8d03dd67faf4f19915834bb4 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Mon, 6 Sep 2021 15:21:06 +1000 Subject: test and fix using T_AVREF_REFCOUNT as an output parameter --- ext/XS-Typemap/Typemap.pm | 1 + ext/XS-Typemap/Typemap.xs | 6 ++++++ ext/XS-Typemap/t/Typemap.t | 10 +++++++++- lib/ExtUtils/typemap | 2 +- 4 files changed, 17 insertions(+), 2 deletions(-) diff --git a/ext/XS-Typemap/Typemap.pm b/ext/XS-Typemap/Typemap.pm index d6e86da86a..8d2fde9a71 100644 --- a/ext/XS-Typemap/Typemap.pm +++ b/ext/XS-Typemap/Typemap.pm @@ -44,6 +44,7 @@ our @EXPORT = (qw/ T_SVREF_REFCOUNT_FIXED_output T_AVREF T_AVREF_REFCOUNT_FIXED + T_AVREF_REFCOUNT_FIXED_output T_HVREF T_HVREF_REFCOUNT_FIXED T_HVREF_REFCOUNT_FIXED_output diff --git a/ext/XS-Typemap/Typemap.xs b/ext/XS-Typemap/Typemap.xs index 353e04fb45..ed6f9d67b5 100644 --- a/ext/XS-Typemap/Typemap.xs +++ b/ext/XS-Typemap/Typemap.xs @@ -325,6 +325,12 @@ T_AVREF_REFCOUNT_FIXED( av ) OUTPUT: RETVAL +void +T_AVREF_REFCOUNT_FIXED_output( OUT avref) + AV_FIXED *avref; + CODE: + avref = newAV(); + av_push(avref, newSVpvs("test")); ## T_HVREF diff --git a/ext/XS-Typemap/t/Typemap.t b/ext/XS-Typemap/t/Typemap.t index 33f4e45306..dade5a01f6 100644 --- a/ext/XS-Typemap/t/Typemap.t +++ b/ext/XS-Typemap/t/Typemap.t @@ -6,7 +6,7 @@ BEGIN { } } -use Test::More tests => 164; +use Test::More tests => 167; use strict; #catch WARN_INTERNAL type errors, and anything else unexpected @@ -79,6 +79,14 @@ is( T_AVREF_REFCOUNT_FIXED(\@array), \@array); eval { T_AVREF_REFCOUNT_FIXED( \$sv ) }; ok( $@ ); +# output only +SKIP:{ + my $avr; + is_deeply([ T_AVREF_REFCOUNT_FIXED_output($avr) ], [ ], "call with non-ref lvalue, no return value"); + ok(ref $avr, "output parameter now a reference") + or skip "Not a reference", 1; + is_deeply($avr, [ "test" ], "has expected entry"); +} # T_HVREF - reference to a perl Hash note("T_HVREF"); diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap index 4cedca4025..239514b785 100644 --- a/lib/ExtUtils/typemap +++ b/lib/ExtUtils/typemap @@ -323,7 +323,7 @@ T_SVREF_REFCOUNT_FIXED T_AVREF $arg = newRV((SV*)$var); T_AVREF_REFCOUNT_FIXED - $arg = newRV_noinc((SV*)$var); + ${ "$var" eq "RETVAL" ? \"$arg = newRV_noinc((SV*)$var);" : \"sv_setrv_noinc($arg, (SV*)$var);" } T_HVREF $arg = newRV((SV*)$var); T_HVREF_REFCOUNT_FIXED -- cgit v1.2.1 From 2adc92a0e8937b18cd278515281fd462a5edf08e Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Mon, 6 Sep 2021 15:33:19 +1000 Subject: test and fix using T_CVREF_REFCOUNT as an output parameter --- ext/XS-Typemap/Typemap.pm | 1 + ext/XS-Typemap/Typemap.xs | 6 ++++++ ext/XS-Typemap/t/Typemap.t | 10 +++++++++- lib/ExtUtils/typemap | 2 +- 4 files changed, 17 insertions(+), 2 deletions(-) diff --git a/ext/XS-Typemap/Typemap.pm b/ext/XS-Typemap/Typemap.pm index 8d2fde9a71..3a4ee1cc3c 100644 --- a/ext/XS-Typemap/Typemap.pm +++ b/ext/XS-Typemap/Typemap.pm @@ -50,6 +50,7 @@ our @EXPORT = (qw/ T_HVREF_REFCOUNT_FIXED_output T_CVREF T_CVREF_REFCOUNT_FIXED + T_CVREF_REFCOUNT_FIXED_output T_SYSRET_fail T_SYSRET_pass T_UV T_IV diff --git a/ext/XS-Typemap/Typemap.xs b/ext/XS-Typemap/Typemap.xs index ed6f9d67b5..9250e3e110 100644 --- a/ext/XS-Typemap/Typemap.xs +++ b/ext/XS-Typemap/Typemap.xs @@ -383,6 +383,12 @@ T_CVREF_REFCOUNT_FIXED( cv ) OUTPUT: RETVAL +void +T_CVREF_REFCOUNT_FIXED_output( OUT cvref) + CV_FIXED *cvref; + CODE: + cvref = get_cv("XSLoader::load", 0); + SvREFCNT_inc(cvref); ## T_SYSRET diff --git a/ext/XS-Typemap/t/Typemap.t b/ext/XS-Typemap/t/Typemap.t index dade5a01f6..93a67bf031 100644 --- a/ext/XS-Typemap/t/Typemap.t +++ b/ext/XS-Typemap/t/Typemap.t @@ -6,7 +6,7 @@ BEGIN { } } -use Test::More tests => 167; +use Test::More tests => 170; use strict; #catch WARN_INTERNAL type errors, and anything else unexpected @@ -126,6 +126,14 @@ is( T_CVREF_REFCOUNT_FIXED($sub), $sub ); eval { T_CVREF_REFCOUNT_FIXED( \@array ) }; ok( $@ ); +# output only +SKIP:{ + my $cvr; + is_deeply([ T_CVREF_REFCOUNT_FIXED_output($cvr) ], [ ], "call with non-ref lvalue, no return value"); + ok(ref $cvr, "output parameter now a reference") + or skip "Not a reference", 1; + is($cvr, \&XSLoader::load, "ref to expected sub"); +} # T_SYSRET - system return values note("T_SYSRET"); diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap index 239514b785..a07e83f901 100644 --- a/lib/ExtUtils/typemap +++ b/lib/ExtUtils/typemap @@ -331,7 +331,7 @@ T_HVREF_REFCOUNT_FIXED T_CVREF $arg = newRV((SV*)$var); T_CVREF_REFCOUNT_FIXED - $arg = newRV_noinc((SV*)$var); + ${ "$var" eq "RETVAL" ? \"$arg = newRV_noinc((SV*)$var);" : \"sv_setrv_noinc($arg, (SV*)$var);" } T_IV sv_setiv($arg, (IV)$var); T_UV -- cgit v1.2.1 From f572f0830b491cf42d95232aa4755d9106e0e3f1 Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Thu, 9 Sep 2021 11:04:05 +1000 Subject: ParseXS: rename $c to $outlist_count $c could be a count, but a count of what? clarify it. --- dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm index f4edf959f9..c3e8220e32 100644 --- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm +++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm @@ -690,9 +690,9 @@ EOF do_push => undef, } ) for grep $self->{in_out}->{$_} =~ /OUT$/, sort keys %{ $self->{in_out} }; - my $c = @{ $outlist_ref }; - if ($c) { - my $ext = $c; + my $outlist_count = @{ $outlist_ref }; + if ($outlist_count) { + my $ext = $outlist_count; ++$ext if $self->{gotRETVAL} || $wantRETVAL; print "\tXSprePUSH;"; print "\tEXTEND(SP,$ext);\n"; @@ -700,7 +700,7 @@ EOF # all OUTPUT done, so now push the return value on the stack if ($self->{gotRETVAL} && $self->{RETVAL_code}) { print "\t$self->{RETVAL_code}\n"; - print "\t++SP;\n" if $c; + print "\t++SP;\n" if $outlist_count; } elsif ($self->{gotRETVAL} || $wantRETVAL) { my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} ); @@ -716,7 +716,7 @@ EOF if (not $trgt->{with_size} and $trgt->{type} eq 'p') { # sv_setpv # PUSHp corresponds to sv_setpvn. Treat sv_setpv directly print "\tsv_setpv(TARG, $what);\n"; - print "\tXSprePUSH;\n" unless $c; + print "\tXSprePUSH;\n" unless $outlist_count; print "\tPUSHTARG;\n"; } else { @@ -726,7 +726,7 @@ EOF qq("$tsize"), {var => $var, type => $self->{ret_type}} ); - print "\tXSprePUSH;\n" unless $c; + print "\tXSprePUSH;\n" unless $outlist_count; print "\tPUSH$trgt->{type}($what$tsize);\n"; } } @@ -739,13 +739,13 @@ EOF do_setmagic => 0, do_push => undef, } ); - print "\t++SP;\n" if $c; + print "\t++SP;\n" if $outlist_count; } } $xsreturn = 1 if $self->{ret_type} ne "void"; my $num = $xsreturn; - $xsreturn += $c; + $xsreturn += $outlist_count; $self->generate_output( { type => $self->{var_types}->{$_}, num => $num++, -- cgit v1.2.1