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.

diff --git a/MANIFEST b/MANIFEST
index 4f685b8..44b1bde 100644 (file)
--- 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 d107614..3d07282 100644 (file)
--- 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 58e36ee..8012c5e 100644 (file)
--- 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 c40e4b8..f80f3ea 100644 (file)
--- 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 18d6752..e8c36d7 100644 (file)
--- 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 (file)
index 0000000..269b6bc
--- /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 c4521aa..9f80c5b 100644 (file)
--- 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 fb8c855..b2a6522 100644 (file)
--- 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 22b30f8..3f0a78a 100644 (file)
--- 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 f4769a3..6888848 100644 (file)
--- 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 8c019c5..61ac8ae 100644 (file)
--- 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;
     }