diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | embed.fnc | 2 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.pm | 4 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.xs | 10 | ||||
| -rw-r--r-- | ext/XS-APItest/t/pmflag.t | 41 | ||||
| -rw-r--r-- | perl.h | 8 | ||||
| -rw-r--r-- | pod/perl5112delta.pod | 8 | ||||
| -rw-r--r-- | pod/perldiag.pod | 7 | ||||
| -rw-r--r-- | proto.h | 3 | ||||
| -rw-r--r-- | toke.c | 29 |
11 files changed, 95 insertions, 20 deletions
@@ -3207,6 +3207,7 @@ ext/XS-APItest/t/exception.t XS::APItest extension ext/XS-APItest/t/hash.t XS::APItest: tests for hash related APIs ext/XS-APItest/t/my_cxt.t XS::APItest: test MY_CXT interface ext/XS-APItest/t/op.t XS::APItest: tests for OP related APIs +ext/XS-APItest/t/pmflag.t Test deprecation warning for Perl_pmflag() ext/XS-APItest/t/printf.t XS::APItest extension ext/XS-APItest/t/push.t XS::APItest extension ext/XS-APItest/t/rmagical.t XS::APItest extension @@ -800,7 +800,7 @@ Apd |void |packlist |NN SV *cat|NN const char *pat|NN const char *patend|NN SV #if defined(PERL_USES_PL_PIDSTATUS) && defined(PERL_IN_UTIL_C) s |void |pidgone |Pid_t pid|int status #endif -Ap |void |pmflag |NN U32* pmfl|int ch +DUXpo |void |pmflag |NN U32 *pmfl|int ch : Used in perly.y p |OP* |pmruntime |NN OP *o|NN OP *expr|bool isreg #if defined(PERL_IN_OP_C) || defined(PERL_DECL_PROT) @@ -695,7 +695,6 @@ #define pidgone S_pidgone #endif #endif -#define pmflag Perl_pmflag #ifdef PERL_CORE #define pmruntime Perl_pmruntime #endif @@ -3063,7 +3062,6 @@ #define pidgone(a,b) S_pidgone(aTHX_ a,b) #endif #endif -#define pmflag(a,b) Perl_pmflag(aTHX_ a,b) #ifdef PERL_CORE #define pmruntime(a,b,c) Perl_pmruntime(aTHX_ a,b,c) #endif diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index c40e4b8a4b..f80f3ea13e 100644 --- a/ext/XS-APItest/APItest.pm +++ b/ext/XS-APItest/APItest.pm @@ -23,10 +23,10 @@ our @EXPORT = qw( print_double print_int print_long my_cxt_getint my_cxt_getsv my_cxt_setint my_cxt_setsv sv_setsv_cow_hashkey_core sv_setsv_cow_hashkey_notcore rmagical_cast rmagical_flags - DPeek utf16_to_utf8 utf16_to_utf8_reversed + DPeek utf16_to_utf8 utf16_to_utf8_reversed pmflag ); -our $VERSION = '0.16'; +our $VERSION = '0.17'; use vars '$WARNINGS_ON_BOOTSTRAP'; use vars map "\$${_}_called_PP", qw(BEGIN UNITCHECK CHECK INIT END); diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 18d6752e8b..e8c36d7961 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -921,3 +921,13 @@ utf16_to_utf8 (sv, ...) SvPOK_on(dest); ST(0) = dest; XSRETURN(1); + +U32 +pmflag (flag, before = 0) + int flag + U32 before + CODE: + pmflag(&before, flag); + RETVAL = before; + OUTPUT: + RETVAL diff --git a/ext/XS-APItest/t/pmflag.t b/ext/XS-APItest/t/pmflag.t new file mode 100644 index 0000000000..269b6bc64b --- /dev/null +++ b/ext/XS-APItest/t/pmflag.t @@ -0,0 +1,41 @@ +#!perl +use strict; +use Test::More 'no_plan'; + +my @warnings; +$SIG{__WARN__} = sub { + push @warnings, "@_"; +}; + +use XS::APItest 'pmflag'; + +foreach (["\0", 0], + ['Q', 0], + ['c', 0x00004000], + ) { + my ($char, $val) = @$_; + my $ord = ord $char; + foreach my $before (0, 1) { + my $got = pmflag($ord, $before); + is($got, $before | $val, "Flag $ord, before $before"); + is(@warnings, 1); + like($warnings[0], + qr/^Perl_pmflag\(\) is deprecated, and will be removed from the XS API/); + @warnings = (); + + no warnings 'deprecated'; + + $got = pmflag($ord, $before); + is($got, $before | $val, "Flag $ord, before $before"); + is(@warnings, 0); + @warnings = (); + + use warnings; + $got = pmflag($ord, $before); + is($got, $before | $val, "Flag $ord, before $before"); + is(@warnings, 1); + like($warnings[0], + qr/^Perl_pmflag\(\) is deprecated, and will be removed from the XS API/); + @warnings = (); + } +} @@ -3179,6 +3179,14 @@ typedef pthread_key_t perl_key; # endif #endif +#if !defined(PERL_CORE) && !defined(PERL_NO_SHORT_NAMES) +# if defined(PERL_IMPLICIT_CONTEXT) +# define pmflag(a,b) Perl_pmflag(aTHX_ a,b) +# else +# define pmflag Perl_pmflag +# endif +#endif + #ifdef HASATTRIBUTE_DEPRECATED # define __attribute__deprecated__ __attribute__((deprecated)) #endif diff --git a/pod/perl5112delta.pod b/pod/perl5112delta.pod index fb8c8557af..b2a6522b02 100644 --- a/pod/perl5112delta.pod +++ b/pod/perl5112delta.pod @@ -167,13 +167,15 @@ XXX =head1 Changed Internals -XXX Changes which affect the interface available to C<XS> code go here. - =over 4 =item * -XXX +C<Perl_pmflag> has been removed from the public API. Calling it now generates +a deprecation warning, and it will be removed in a future release. Although +listed as part of the API, it was never documented, and only ever used in +F<toke.c>, and prior to 5.10, F<regcomp.c>. In core, it has been replaced by a +static function. =back diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 22b30f83a5..3f0a78a3fe 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -3280,6 +3280,13 @@ so it was not possible to set up some or all fixed-width byte-order conversion functions. This is only a problem when you're using the '<' or '>' modifiers in (un)pack templates. See L<perlfunc/pack>. +=item Perl_pmflag() is deprecated, and will be removed from the XS API + +(D deprecated) XS code called the C function C<Perl_pmflag>. This was part of +Perl's listed public API for extending or embedding the perl interpreter. It has +now been removed from the public API, and will be removed in a future release, +hence XS code should be re-written not to use it. + =item Perl %s required--this is only version %s, stopped (F) The module in question uses features of a version of Perl more @@ -2500,7 +2500,8 @@ PERL_CALLCONV void Perl_packlist(pTHX_ SV *cat, const char *pat, const char *pat #if defined(PERL_USES_PL_PIDSTATUS) && defined(PERL_IN_UTIL_C) STATIC void S_pidgone(pTHX_ Pid_t pid, int status); #endif -PERL_CALLCONV void Perl_pmflag(pTHX_ U32* pmfl, int ch) +PERL_CALLCONV void Perl_pmflag(pTHX_ U32 *pmfl, int ch) + __attribute__deprecated__ __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PMFLAG \ assert(pmfl) @@ -10932,21 +10932,28 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL return s; } +static U32 +S_pmflag(U32 pmfl, const char ch) { + switch (ch) { + CASE_STD_PMMOD_FLAGS_PARSE_SET(&pmfl); + case GLOBAL_PAT_MOD: pmfl |= PMf_GLOBAL; break; + case CONTINUE_PAT_MOD: pmfl |= PMf_CONTINUE; break; + case ONCE_PAT_MOD: pmfl |= PMf_KEEP; break; + case KEEPCOPY_PAT_MOD: pmfl |= PMf_KEEPCOPY; break; + } + return pmfl; +} + void Perl_pmflag(pTHX_ U32* pmfl, int ch) { PERL_ARGS_ASSERT_PMFLAG; - PERL_UNUSED_CONTEXT; + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), + "Perl_pmflag() is deprecated, and will be removed from the XS API"); + if (ch<256) { - const char c = (char)ch; - switch (c) { - CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl); - case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break; - case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break; - case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break; - case KEEPCOPY_PAT_MOD: *pmfl |= PMf_KEEPCOPY; break; - } + *pmfl = S_pmflag(*pmfl, (char)ch); } } @@ -11000,7 +11007,7 @@ S_scan_pat(pTHX_ char *start, I32 type) modstart = s; #endif while (*s && strchr(valid_flags, *s)) - pmflag(&pm->op_pmflags,*s++); + pm->op_pmflags = S_pmflag(pm->op_pmflags, *s++); #ifdef PERL_MAD if (PL_madskills && modstart != s) { SV* tmptoken = newSVpvn(modstart, s - modstart); @@ -11080,7 +11087,7 @@ S_scan_subst(pTHX_ char *start) es++; } else if (strchr(S_PAT_MODS, *s)) - pmflag(&pm->op_pmflags,*s++); + pm->op_pmflags = S_pmflag(pm->op_pmflags, *s++); else break; } |