EU::ParseXS: Fix targetable size detection

Adds new / vastly improved tests for 'targetable'.
Also improves targetable documentation.

2 files changed, 195 insertions, 9 deletions

diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/OutputMap.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/OutputMap.pm
index 6ae4e0e58b..918785c1ab 100644
--- a/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/OutputMap.pm
+++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/Typemaps/OutputMap.pm
@@ -95,16 +95,23 @@ sub cleaned_code {
 
 =head2 targetable
 
-This is an obscure optimization that used to live in C<ExtUtils::ParseXS>
-directly.
+This is an obscure but effective optimization that used to
+live in C<ExtUtils::ParseXS> directly. Not implementing it
+should never result in incorrect use of typemaps, just less
+efficient code.
 
 In a nutshell, this will check whether the output code
-involves calling C<set_iv>, C<set_uv>, C<set_nv>, C<set_pv> or C<set_pvn>
-to set the special C<$arg> placeholder to a new value
+involves calling C<sv_setiv>, C<sv_setuv>, C<sv_setnv>, C<sv_setpv> or
+C<sv_setpvn> to set the special C<$arg> placeholder to a new value
 B<AT THE END OF THE OUTPUT CODE>. If that is the case, the code is
 eligible for using the C<TARG>-related macros to optimize this.
 Thus the name of the method: C<targetable>.
 
+If this optimization is applicable, C<ExtUtils::ParseXS> will
+emit a C<dXSTARG;> definition at the start of the generate XSUB code,
+and type (see below) dependent code to set C<TARG> and push it on
+the stack at the end of the generated XSUB code.
+
 If the optimization can not be applied, this returns undef.
 If it can be applied, this method returns a hash reference containing
 the following information:
@@ -113,7 +120,7 @@ the following information:
   with_size: Bool indicating whether this is the sv_setpvn variant
   what:      The code that actually evaluates to the output scalar
   what_size: If "with_size", this has the string length (as code,
-             not constant)
+             not constant, including leading comma)
 
 =cut
 
@@ -128,7 +135,14 @@ sub targetable {
       |
       \( (??{ $bal }) \)
     )*
-  ]xo;
+  ]x;
+  my $bal_no_comma = qr[
+    (?:
+      (?>[^(),]+)
+      |
+      \( (??{ $bal }) \)
+    )+
+  ]x;
 
   # matches variations on (SV*)
   my $sv_cast = qr[
@@ -155,9 +169,9 @@ sub targetable {
         \s*
         \( \s*
           $sv_cast \$arg \s* , \s*
-          ( (??{ $bal }) )    # Set from
-        ( (??{ $size }) )?    # Possible sizeof set-from
-        \) \s* ; \s* $
+          ( $bal_no_comma )    # Set from
+          ( $size )?           # Possible sizeof set-from
+        \s* \) \s* ; \s* $
       ]xo
   );
 
diff --git a/dist/ExtUtils-ParseXS/t/517-t-targetable.t b/dist/ExtUtils-ParseXS/t/517-t-targetable.t
new file mode 100644
index 0000000000..1dc208d997
--- /dev/null
+++ b/dist/ExtUtils-ParseXS/t/517-t-targetable.t
@@ -0,0 +1,172 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+use Carp;
+use Cwd;
+use File::Spec;
+use File::Temp qw( tempdir );
+use Test::More;
+use lib qw( lib );
+use ExtUtils::Typemaps;
+
+my $output_expr_ref = {
+  'T_CALLBACK' => '	sv_setpvn($arg, $var.context.value().chp(),
+		$var.context.value().size());
+',
+  'T_OUT' => '	{
+	    GV *gv = newGVgen("$Package");
+	    if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
+		sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
+	    else
+		$arg = &PL_sv_undef;
+	}
+',
+  'T_REF_IV_PTR' => '	sv_setref_pv($arg, \\"${ntype}\\", (void*)$var);
+',
+  'T_U_LONG' => '	sv_setuv($arg, (UV)$var);
+',
+  'T_U_CHAR' => '	sv_setuv($arg, (UV)$var);
+',
+  'T_U_INT' => '	sv_setuv($arg, (UV)$var);
+',
+  'T_ARRAY' => '        {
+	    U32 ix_$var;
+	    EXTEND(SP,size_$var);
+	    for (ix_$var = 0; ix_$var < size_$var; ix_$var++) {
+		ST(ix_$var) = sv_newmortal();
+	DO_ARRAY_ELEM
+	    }
+        }
+',
+  'T_NV' => '	sv_setnv($arg, (NV)$var);
+',
+  'T_SHORT' => '	sv_setiv($arg, (IV)$var);
+',
+  'T_OPAQUE' => '	sv_setpvn($arg, (char *)&$var, sizeof($var));
+',
+  'T_PTROBJ' => '	sv_setref_pv($arg, \\"${ntype}\\", (void*)$var);
+',
+  'T_HVREF' => '	$arg = newRV((SV*)$var);
+',
+  'T_PACKEDARRAY' => '	XS_pack_$ntype($arg, $var, count_$ntype);
+',
+  'T_INT' => '	sv_setiv($arg, (IV)$var);
+',
+  'T_OPAQUEPTR' => '	sv_setpvn($arg, (char *)$var, sizeof(*$var));
+',
+  'T_BOOL' => '	$arg = boolSV($var);
+',
+  'T_REFREF' => '	NOT_IMPLEMENTED
+',
+  'T_REF_IV_REF' => '	sv_setref_pv($arg, \\"${ntype}\\", (void*)new $ntype($var));
+',
+  'T_STDIO' => '	{
+	    GV *gv = newGVgen("$Package");
+	    PerlIO *fp = PerlIO_importFILE($var,0);
+	    if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) )
+		sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
+	    else
+		$arg = &PL_sv_undef;
+	}
+',
+  'T_FLOAT' => '	sv_setnv($arg, (double)$var);
+',
+  'T_IN' => '	{
+	    GV *gv = newGVgen("$Package");
+	    if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) )
+		sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
+	    else
+		$arg = &PL_sv_undef;
+	}
+',
+  'T_PV' => '	sv_setpv((SV*)$arg, $var);
+',
+  'T_INOUT' => '	{
+	    GV *gv = newGVgen("$Package");
+	    if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) )
+		sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
+	    else
+		$arg = &PL_sv_undef;
+	}
+',
+  'T_CHAR' => '	sv_setpvn($arg, (char *)&$var, 1);
+',
+  'T_LONG' => '	sv_setiv($arg, (IV)$var);
+',
+  'T_DOUBLE' => '	sv_setnv($arg, (double)$var);
+',
+  'T_PTR' => '	sv_setiv($arg, PTR2IV($var));
+',
+  'T_AVREF' => '	$arg = newRV((SV*)$var);
+',
+  'T_SV' => '	$arg = $var;
+',
+  'T_ENUM' => '	sv_setiv($arg, (IV)$var);
+',
+  'T_REFOBJ' => '	NOT IMPLEMENTED
+',
+  'T_CVREF' => '	$arg = newRV((SV*)$var);
+',
+  'T_UV' => '	sv_setuv($arg, (UV)$var);
+',
+  'T_PACKED' => '	XS_pack_$ntype($arg, $var);
+',
+  'T_SYSRET' => '	if ($var != -1) {
+	    if ($var == 0)
+		sv_setpvn($arg, "0 but true", 10);
+	    else
+		sv_setiv($arg, (IV)$var);
+	}
+',
+  'T_IV' => '	sv_setiv($arg, (IV)$var);
+',
+  'T_PTRDESC' => '	sv_setref_pv($arg, \\"${ntype}\\", (void*)new\\U${type}_DESC\\E($var));
+',
+  'T_DATAUNIT' => '	sv_setpvn($arg, $var.chp(), $var.size());
+',
+  'T_U_SHORT' => '	sv_setuv($arg, (UV)$var);
+',
+  'T_SVREF' => '	$arg = newRV((SV*)$var);
+',
+  'T_PTRREF' => '	sv_setref_pv($arg, Nullch, (void*)$var);
+',
+};
+
+plan tests => scalar(keys %$output_expr_ref);
+
+my %results = (
+  T_UV        => { type => 'u', with_size => undef, what => '(UV)$var', what_size => undef },
+  T_IV        => { type => 'i', with_size => undef, what => '(IV)$var', what_size => undef },
+  T_NV        => { type => 'n', with_size => undef, what => '(NV)$var', what_size => undef },
+  T_FLOAT     => { type => 'n', with_size => undef, what => '(double)$var', what_size => undef },
+  T_PTR       => { type => 'i', with_size => undef, what => 'PTR2IV($var)', what_size => undef },
+  T_PV        => { type => 'p', with_size => undef, what => '$var', what_size => undef },
+  T_OPAQUE    => { type => 'p', with_size => 'n', what => '(char *)&$var', what_size => ', sizeof($var)' },
+  T_OPAQUEPTR => { type => 'p', with_size => 'n', what => '(char *)$var', what_size => ', sizeof(*$var)' },
+  T_CHAR      => { type => 'p', with_size => 'n', what => '(char *)&$var', what_size => ', 1' },
+  T_CALLBACK  => { type => 'p', with_size => 'n', what => '$var.context.value().chp()',
+                   what_size => ",\n		\$var.context.value().size()" }, # whitespace is significant here
+  T_DATAUNIT  => { type => 'p', with_size => 'n', what => '$var.chp()', what_size => ', $var.size()' },
+);
+
+$results{$_} = $results{T_UV} for qw(T_U_LONG T_U_INT T_U_CHAR T_U_SHORT);
+$results{$_} = $results{T_IV} for qw(T_LONG T_INT T_SHORT T_ENUM);
+$results{$_} = $results{T_FLOAT} for qw(T_DOUBLE);
+
+foreach my $xstype (sort keys %$output_expr_ref) {
+  my $om = ExtUtils::Typemaps::OutputMap->new(
+    xstype => $xstype,
+    code => $output_expr_ref->{$xstype}
+  );
+  my $targetable = $om->targetable;
+  if (not exists($results{$xstype})) {
+    ok(not(defined($targetable)), "$xstype not targetable")
+      or diag(join ", ", map {defined($_) ? $_ : "<undef>"} %$targetable);
+  }
+  else {
+    my $res = $results{$xstype};
+    is_deeply($targetable, $res, "$xstype targetable and has right output")
+      or diag(join ", ", map {defined($_) ? $_ : "<undef>"} %$targetable);
+  }
+}
+