This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove Perl_pmflag() from the public API, and mark it as deprecated.
authorNicholas Clark <nick@ccl4.org>
Sun, 1 Nov 2009 16:43:22 +0000 (16:43 +0000)
committerNicholas Clark <nick@ccl4.org>
Sun, 1 Nov 2009 16:47:07 +0000 (16:47 +0000)
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.

MANIFEST
embed.fnc
embed.h
ext/XS-APItest/APItest.pm
ext/XS-APItest/APItest.xs
ext/XS-APItest/t/pmflag.t [new file with mode: 0644]
perl.h
pod/perl5112delta.pod
pod/perldiag.pod
proto.h
toke.c

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
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
 #define pidgone                        S_pidgone
 #endif
 #endif
-#define pmflag                 Perl_pmflag
 #ifdef PERL_CORE
 #define pmruntime              Perl_pmruntime
 #endif
 #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
index c40e4b8..f80f3ea 100644 (file)
@@ -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);
index 18d6752..e8c36d7 100644 (file)
@@ -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
@@ -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
index fb8c855..b2a6522 100644 (file)
@@ -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
 
index 22b30f8..3f0a78a 100644 (file)
@@ -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;
     }