This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
op.c: newCONSTSUB and newXS UTF8 cleanup.
authorBrian Fraser <fraserbn@gmail.com>
Wed, 6 Jul 2011 04:50:31 +0000 (01:50 -0300)
committerFather Chrysostomos <sprout@cpan.org>
Thu, 6 Oct 2011 20:01:05 +0000 (13:01 -0700)
newXS was merged into newXS_flags; added a line in the docs
recommeding using that instead.

newCONSTSUB got a _flags version, which generates the CV in
the right glob if passed the UTF-8 flag.

MANIFEST
embed.fnc
embed.h
ext/XS-APItest/APItest.xs
ext/XS-APItest/t/newCONSTSUB.t [new file with mode: 0644]
op.c
proto.h
t/uni/parser.t

index 50d5ac5..ab070a8 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3838,6 +3838,7 @@ ext/XS-APItest/t/Markers.pm       Helper for ./blockhooks.t
 ext/XS-APItest/t/multicall.t   XS::APItest: test MULTICALL macros
 ext/XS-APItest/t/my_cxt.t      XS::APItest: test MY_CXT interface
 ext/XS-APItest/t/my_exit.t     XS::APItest: test my_exit
+ext/XS-APItest/t/newCONSTSUB.t XS::APItest: test newCONSTSUB(_flags)
 ext/XS-APItest/t/Null.pm       Helper for ./blockhooks.t
 ext/XS-APItest/t/op_contextualize.t    test op_contextualize() API
 ext/XS-APItest/t/op_list.t     test OP list construction API
@@ -5242,7 +5243,7 @@ t/uni/latin2.t                    See if Unicode in latin2 works
 t/uni/lex_utf8.t               See if Unicode in lexer works
 t/uni/lower.t                  See if Unicode casing works
 t/uni/overload.t               See if Unicode overloading works
-t/uni/parser.t                 See if Unicode is handled correctly by the parser
+t/uni/parser.t                 See if Unicode in the parser works in edge cases.
 t/uni/sprintf.t                        See if Unicode sprintf works
 t/uni/tie.t                    See if Unicode tie works
 t/uni/title.t                  See if Unicode casing works
index cd484d3..cdb5f85 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -845,6 +845,7 @@ i   |bool   |aassign_common_vars    |NULLOK OP* o
 Apda   |OP*    |newASSIGNOP    |I32 flags|NULLOK OP* left|I32 optype|NULLOK OP* right
 Apda   |OP*    |newCONDOP      |I32 flags|NN OP* first|NULLOK OP* trueop|NULLOK OP* falseop
 Apd    |CV*    |newCONSTSUB    |NULLOK HV* stash|NULLOK const char* name|NULLOK SV* sv
+Apd    |CV*    |newCONSTSUB_flags      |NULLOK HV* stash|NULLOK const char* name|U32 flags|NULLOK SV* sv
 #ifdef PERL_MAD
 Ap     |OP*    |newFORM        |I32 floor|NULLOK OP* o|NULLOK OP* block
 #else
diff --git a/embed.h b/embed.h
index 72d464d..9f31a16 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define newBINOP(a,b,c,d)      Perl_newBINOP(aTHX_ a,b,c,d)
 #define newCONDOP(a,b,c,d)     Perl_newCONDOP(aTHX_ a,b,c,d)
 #define newCONSTSUB(a,b,c)     Perl_newCONSTSUB(aTHX_ a,b,c)
+#define newCONSTSUB_flags(a,b,c,d)     Perl_newCONSTSUB_flags(aTHX_ a,b,c,d)
 #define newCVREF(a,b)          Perl_newCVREF(aTHX_ a,b)
 #define newFOROP(a,b,c,d,e)    Perl_newFOROP(aTHX_ a,b,c,d,e)
 #define newGIVENOP(a,b,c)      Perl_newGIVENOP(aTHX_ a,b,c)
index 1af3674..b351343 100644 (file)
@@ -1840,6 +1840,27 @@ call_method(methname, flags, ...)
        PUSHs(sv_2mortal(newSViv(i)));
 
 void
+newCONSTSUB_type(stash, name, flags, type)
+    HV* stash
+    SV* name
+    I32 flags
+    int type
+    PREINIT:
+       CV* cv;
+    PPCODE:
+        switch (type) {
+           case 0:
+              cv = newCONSTSUB(stash, SvPV_nolen(name), NULL);
+               break;
+           case 1:
+               cv = newCONSTSUB_flags(stash, SvPV_nolen(name), flags | SvUTF8(name), NULL);
+               break;
+        }
+        EXTEND(SP, 2);
+        PUSHs( CvCONST(cv) ? &PL_sv_yes : &PL_sv_no );
+       PUSHs((SV*)CvGV(cv));
+
+void
 gv_init_type(namesv, multi, flags, type)
     SV* namesv
     int multi
diff --git a/ext/XS-APItest/t/newCONSTSUB.t b/ext/XS-APItest/t/newCONSTSUB.t
new file mode 100644 (file)
index 0000000..4a2edd6
--- /dev/null
@@ -0,0 +1,24 @@
+#!perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+use Test::More "no_plan";
+
+use XS::APItest;
+
+my ($const, $glob) = XS::APItest::newCONSTSUB_type(\%::, "sanity_check", 0, 0);
+
+ok $const;
+ok *{$glob}{CODE};
+
+($const, $glob) = XS::APItest::newCONSTSUB_type(\%::, "\x{30cb}", 0, 0);
+ok $const, "newCONSTSUB generates the constant,";
+ok *{$glob}{CODE}, "..and the glob,";
+ok !$::{"\x{30cb}"}, "...but not the right one";
+
+($const, $glob) = XS::APItest::newCONSTSUB_type(\%::, "\x{30cd}", 0, 1);
+ok $const, "newCONSTSUB_flags generates the constant,";
+ok *{$glob}{CODE}, "..and the glob,";
+ok $::{"\x{30cd}"}, "...the right one!";
diff --git a/op.c b/op.c
index d2cb4f0..2a58c28 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6430,6 +6430,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
     const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
     bool has_name;
+    bool name_is_utf8 = o ? (SvUTF8(cSVOPo->op_sv) ? 1 : 0) : 0;
 
     if (proto) {
        assert(proto->op_type == OP_CONST);
@@ -6568,7 +6569,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        }
        else {
            GvCV_set(gv, NULL);
-           cv = newCONSTSUB(NULL, name, const_sv);
+           cv = newCONSTSUB_flags(NULL, name, name_is_utf8 ? SVf_UTF8 : 0, const_sv);
        }
         mro_method_changed_in( /* sub Foo::Bar () { 123 } */
             (CvGV(cv) && GvSTASH(CvGV(cv)))
@@ -6729,9 +6730,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
                                          (long)CopLINE(PL_curcop));
            gv_efullname3(tmpstr, gv, NULL);
            (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
-                   SvCUR(tmpstr), sv, 0);
+                   SvUTF8(tmpstr) ? -SvCUR(tmpstr) : SvCUR(tmpstr), sv, 0);
            hv = GvHVn(db_postponed);
-           if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
+           if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -SvCUR(tmpstr) : SvCUR(tmpstr))) {
                CV * const pcv = GvCV(db_postponed);
                if (pcv) {
                    dSP;
@@ -6823,9 +6824,25 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
 /*
 =for apidoc newCONSTSUB
 
+See L</newCONSTSUB_flags>.
+
+=cut
+*/
+
+CV *
+Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
+{
+    return newCONSTSUB_flags(stash, name, 0, sv);
+}
+
+/*
+=for apidoc newCONSTSUB_flags
+
 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
 eligible for inlining at compile-time.
 
+Currently, the only useful value for C<flags> is SVf_UTF8.
+
 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
 which won't be called if used as a destructor, but will suppress the overhead
 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
@@ -6835,7 +6852,7 @@ compile time.)
 */
 
 CV *
-Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
+Perl_newCONSTSUB_flags(pTHX_ HV *stash, const char *name, U32 flags, SV *sv)
 {
     dVAR;
     CV* cv;
@@ -6873,7 +6890,7 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
        processor __FILE__ directive). But we need a dynamically allocated one,
        and we need it to get freed.  */
     cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
-                    XS_DYNAMIC_FILENAME);
+                    XS_DYNAMIC_FILENAME | flags);
     CvXSUBANY(cv).any_ptr = sv;
     CvCONST_on(cv);
 
@@ -6891,10 +6908,75 @@ Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
                 const char *const filename, const char *const proto,
                 U32 flags)
 {
-    CV *cv = newXS(name, subaddr, filename);
+    CV *cv;
 
     PERL_ARGS_ASSERT_NEWXS_FLAGS;
 
+    {
+        GV * const gv = gv_fetchpv(name ? name :
+                            (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
+                            GV_ADDMULTI | flags, SVt_PVCV);
+    
+        if (!subaddr)
+            Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
+    
+        if ((cv = (name ? GvCV(gv) : NULL))) {
+            if (GvCVGEN(gv)) {
+                /* just a cached method */
+                SvREFCNT_dec(cv);
+                cv = NULL;
+            }
+            else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
+                /* already defined (or promised) */
+                /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
+                if (ckWARN(WARN_REDEFINE)) {
+                    GV * const gvcv = CvGV(cv);
+                    if (gvcv) {
+                        HV * const stash = GvSTASH(gvcv);
+                        if (stash) {
+                            const char *redefined_name = HvNAME_get(stash);
+                            if ( strEQ(redefined_name,"autouse") ) {
+                                const line_t oldline = CopLINE(PL_curcop);
+                                if (PL_parser && PL_parser->copline != NOLINE)
+                                    CopLINE_set(PL_curcop, PL_parser->copline);
+                                Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+                                            CvCONST(cv) ? "Constant subroutine %s redefined"
+                                                        : "Subroutine %s redefined"
+                                            ,name);
+                                CopLINE_set(PL_curcop, oldline);
+                            }
+                        }
+                    }
+                }
+                SvREFCNT_dec(cv);
+                cv = NULL;
+            }
+        }
+    
+        if (cv)                                /* must reuse cv if autoloaded */
+            cv_undef(cv);
+        else {
+            cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+            if (name) {
+                GvCV_set(gv,cv);
+                GvCVGEN(gv) = 0;
+                mro_method_changed_in(GvSTASH(gv)); /* newXS */
+            }
+        }
+        if (!name)
+            CvANON_on(cv);
+        CvGV_set(cv, gv);
+        (void)gv_fetchfile(filename);
+        CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
+                                    an external constant string */
+        assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
+        CvISXSUB_on(cv);
+        CvXSUB(cv) = subaddr;
+    
+        if (name)
+            process_special_blocks(name, gv, cv);
+    }
+
     if (flags & XS_DYNAMIC_FILENAME) {
        CvFILE(cv) = savepv(filename);
        CvDYNFILE_on(cv);
@@ -6915,74 +6997,8 @@ static storage, as it is used directly as CvFILE(), without a copy being made.
 CV *
 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
 {
-    dVAR;
-    GV * const gv = gv_fetchpv(name ? name :
-                       (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
-                       GV_ADDMULTI, SVt_PVCV);
-    register CV *cv;
-
     PERL_ARGS_ASSERT_NEWXS;
-
-    if (!subaddr)
-       Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
-
-    if ((cv = (name ? GvCV(gv) : NULL))) {
-       if (GvCVGEN(gv)) {
-           /* just a cached method */
-           SvREFCNT_dec(cv);
-           cv = NULL;
-       }
-       else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
-           /* already defined (or promised) */
-           /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
-           if (ckWARN(WARN_REDEFINE)) {
-               GV * const gvcv = CvGV(cv);
-               if (gvcv) {
-                   HV * const stash = GvSTASH(gvcv);
-                   if (stash) {
-                       const char *redefined_name = HvNAME_get(stash);
-                       if ( strEQ(redefined_name,"autouse") ) {
-                           const line_t oldline = CopLINE(PL_curcop);
-                           if (PL_parser && PL_parser->copline != NOLINE)
-                               CopLINE_set(PL_curcop, PL_parser->copline);
-                           Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
-                                       CvCONST(cv) ? "Constant subroutine %s redefined"
-                                                   : "Subroutine %s redefined"
-                                       ,name);
-                           CopLINE_set(PL_curcop, oldline);
-                       }
-                   }
-               }
-           }
-           SvREFCNT_dec(cv);
-           cv = NULL;
-       }
-    }
-
-    if (cv)                            /* must reuse cv if autoloaded */
-       cv_undef(cv);
-    else {
-       cv = MUTABLE_CV(newSV_type(SVt_PVCV));
-       if (name) {
-           GvCV_set(gv,cv);
-           GvCVGEN(gv) = 0;
-            mro_method_changed_in(GvSTASH(gv)); /* newXS */
-       }
-    }
-    if (!name)
-       CvANON_on(cv);
-    CvGV_set(cv, gv);
-    (void)gv_fetchfile(filename);
-    CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
-                                  an external constant string */
-    assert(!CvDYNFILE(cv)); /* cv_undef should have turned it off */
-    CvISXSUB_on(cv);
-    CvXSUB(cv) = subaddr;
-
-    if (name)
-       process_special_blocks(name, gv, cv);
-
-    return cv;
+    return newXS_flags(name, subaddr, filename, NULL, 0);
 }
 
 #ifdef PERL_MAD
diff --git a/proto.h b/proto.h
index 8a4a73d..7fdfdcb 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -2528,6 +2528,7 @@ PERL_CALLCONV OP* Perl_newCONDOP(pTHX_ I32 flags, OP* first, OP* trueop, OP* fal
        assert(first)
 
 PERL_CALLCONV CV*      Perl_newCONSTSUB(pTHX_ HV* stash, const char* name, SV* sv);
+PERL_CALLCONV CV*      Perl_newCONSTSUB_flags(pTHX_ HV* stash, const char* name, U32 flags, SV* sv);
 PERL_CALLCONV OP*      Perl_newCVREF(pTHX_ I32 flags, OP* o)
                        __attribute__malloc__
                        __attribute__warn_unused_result__;
index fa6b290..70b95fb 100644 (file)
@@ -7,7 +7,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan (tests => 33);
+plan (tests => 35);
 
 use utf8;
 use open qw( :utf8 :std );
@@ -84,6 +84,11 @@ ok $::{"участники"}, "non-const sub declarations generate the right glo
 ok *{$::{"участники"}}{CODE};
 is *{$::{"участники"}}{CODE}->(), 1;
 
+sub 原 () { 1 }
+
+is grep({ $_ eq "\x{539f}"     } keys %::), 1, "Constant subs generate the right glob.";
+is grep({ $_ eq "\345\216\237" } keys %::), 0;
+
 TODO: {
     our $TODO = "our isn't clean in this branch";
     our $問 = 10;