diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.pm | 2 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.xs | 10 | ||||
| -rw-r--r-- | ext/XS-APItest/t/svcatpvf.t | 21 | ||||
| -rw-r--r-- | pod/perldiag.pod | 8 | ||||
| -rw-r--r-- | sv.c | 37 |
6 files changed, 68 insertions, 11 deletions
@@ -3963,6 +3963,7 @@ ext/XS-APItest/t/stmtsasexpr.t test recursive descent statement-sequence parsing ext/XS-APItest/t/stuff_modify_bug.t test for eval side-effecting source string ext/XS-APItest/t/stuff_svcur_bug.t test for a bug in lex_stuff_pvn ext/XS-APItest/t/subcall.t Test XSUB calls +ext/XS-APItest/t/svcatpvf.t Test sv_catpvf argument reordering ext/XS-APItest/t/svcat.t Test sv_catpvn ext/XS-APItest/t/sviscow.t Test SvIsCOW ext/XS-APItest/t/svpeek.t XS::APItest extension diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index 28d6beca27..93b3cb61d5 100644 --- a/ext/XS-APItest/APItest.pm +++ b/ext/XS-APItest/APItest.pm @@ -5,7 +5,7 @@ use strict; use warnings; use Carp; -our $VERSION = '0.73'; +our $VERSION = '0.74'; require XSLoader; diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index aef057238e..7a258deb25 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -3884,6 +3884,16 @@ test_newOP_CUSTOM() OUTPUT: RETVAL +void +test_sv_catpvf(SV *fmtsv) + PREINIT: + SV *sv; + char *fmt; + CODE: + fmt = SvPV_nolen(fmtsv); + sv = sv_2mortal(newSVpvn("", 0)); + sv_catpvf(sv, fmt, 5, 6, 7, 8); + MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest int diff --git a/ext/XS-APItest/t/svcatpvf.t b/ext/XS-APItest/t/svcatpvf.t new file mode 100644 index 0000000000..15348891bf --- /dev/null +++ b/ext/XS-APItest/t/svcatpvf.t @@ -0,0 +1,21 @@ +use strict; +use warnings; + +use Test::More tests => 4; + +use XS::APItest; + +my @cases = ( + [field => '%2$d'], + [precision => '%.*2$d'], + [vector => '%2$vd'], + [width => '%*2$d'], +); + +for my $case (@cases) { + my ($what, $format) = @$case; + my $got = eval { test_sv_catpvf($format); 1 }; + my $exn = $got ? undef : $@; + like($exn, qr/\b\QCannot yet reorder sv_catpvfn() arguments from va_list\E\b/, + "explicit $what index forbidden in va_list arguments"); +} diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 71bf1ec87a..0c4f19961b 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -662,6 +662,14 @@ keep a reference count on its arguments and cannot be made to do so. Such arrays are not even supposed to be accessible to Perl code, but are only used internally. +=item Cannot yet reorder sv_catpvfn() arguments from va_list + +(F) Some XS code tried to use C<sv_catpvfn()> or a related function with a +format string that specifies explicit indexes for some of the elements, and +using a C-style variable-argument list (a C<va_list>). This is not currently +supported. XS authors wanting to do this must instead construct a C array of +C<SV*> scalars containing the arguments. + =item Can only compress unsigned integers in pack (F) An argument to pack("w",...) was not an integer. The BER compressed @@ -9193,7 +9193,7 @@ Perl_newSVpvf_nocontext(const char *const pat, ...) =for apidoc newSVpvf Creates a new SV and initializes it with the string formatted like -C<sprintf>. +C<sv_catpvf>. =cut */ @@ -10490,8 +10490,10 @@ Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...) /* =for apidoc sv_catpvf -Processes its arguments like C<sprintf> and appends the formatted -output to an SV. If the appended data contains "wide" characters +Processes its arguments like C<sv_catpvfn>, and appends the formatted +output to an SV. As with C<sv_catpvfn> called with a non-null C-style +variable argument list, argument reordering is not supported. +If the appended data contains "wide" characters (including, but not limited to, SVs with a UTF-8 PV formatted with %s, and characters >255 formatted with %c), the original SV might get upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See @@ -10515,7 +10517,8 @@ Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...) /* =for apidoc sv_vcatpvf -Processes its arguments like C<vsprintf> and appends the formatted output +Processes its arguments like C<sv_catpvfn> called with a non-null C-style +variable argument list, and appends the formatted to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>. Usually used via its frontend C<sv_catpvf>. @@ -10669,8 +10672,13 @@ S_F0convert(NV nv, char *const endbuf, STRLEN *const len) =for apidoc sv_vcatpvfn_flags Processes its arguments like C<vsprintf> and appends the formatted output -to an SV. Uses an array of SVs if the C style variable argument list is -missing (NULL). When running with taint checks enabled, indicates via +to an SV. Uses an array of SVs if the C-style variable argument list is +missing (NULL). Argument reordering (using format specifiers like C<%2$d> +or C<%*2$d>) is supported only when using an array of SVs; using a C-style +C<va_list> argument list with a format string that uses argument reordering +will yield an exception. + +When running with taint checks enabled, indicates via C<maybe_tainted> if results are untrustworthy (often due to the use of locales). @@ -11337,6 +11345,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if ( (width = expect_number(&q)) ) { if (*q == '$') { + if (args) + Perl_croak_nocontext( + "Cannot yet reorder sv_catpvfn() arguments from va_list"); ++q; efix = width; used_explicit_ix = TRUE; @@ -11381,9 +11392,12 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (*q == '*') { q++; if ( (ewix = expect_number(&q)) ) { - if (*q++ == '$') + if (*q++ == '$') { + if (args) + Perl_croak_nocontext( + "Cannot yet reorder sv_catpvfn() arguments from va_list"); used_explicit_ix = TRUE; - else + } else goto unknown; } asterisk = TRUE; @@ -11450,9 +11464,12 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (*q == '*') { q++; if ( (epix = expect_number(&q)) ) { - if (*q++ == '$') + if (*q++ == '$') { + if (args) + Perl_croak_nocontext( + "Cannot yet reorder sv_catpvfn() arguments from va_list"); used_explicit_ix = TRUE; - else + } else goto unknown; } if (args) |