Remove Perl_pmflag() from the public API, and mark it as deprecated.

regcomp.c stopped using it before 5.10, leaving only toke.c. The only code on
CPAN that uses it is copies of regcomp.c. Replace it with a static function,
with a cleaner interface.

11 files changed, 95 insertions, 20 deletions

diff --git a/MANIFEST b/MANIFEST
index 4f685b80c6..44b1bdea78 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -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
diff --git a/embed.fnc b/embed.fnc
index d107614d26..3d072823b2 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -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)
diff --git a/embed.h b/embed.h
index 58e36ee994..8012c5e9c3 100644
--- a/embed.h
+++ b/embed.h
@@ -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 = ();
+    }
+}
diff --git a/perl.h b/perl.h
index c4521aa156..9f80c5b4c3 100644
--- a/perl.h
+++ b/perl.h
@@ -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
diff --git a/proto.h b/proto.h
index f4769a310e..6888848405 100644
--- a/proto.h
+++ b/proto.h
@@ -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)
diff --git a/toke.c b/toke.c
index 8c019c510d..61ac8aef1d 100644
--- a/toke.c
+++ b/toke.c
@@ -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;
     }