diff options
| -rw-r--r-- | MANIFEST | 3 | ||||
| -rw-r--r-- | embed.fnc | 1 | ||||
| -rw-r--r-- | embed.h | 1 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.xs | 21 | ||||
| -rw-r--r-- | ext/XS-APItest/t/newCONSTSUB.t | 24 | ||||
| -rw-r--r-- | op.c | 162 | ||||
| -rw-r--r-- | proto.h | 1 | ||||
| -rw-r--r-- | t/uni/parser.t | 7 |
8 files changed, 145 insertions, 75 deletions
@@ -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 @@ -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 @@ -326,6 +326,7 @@ #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) diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 1af3674088..b3513439ac 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -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 index 0000000000..4a2edd62ab --- /dev/null +++ b/ext/XS-APItest/t/newCONSTSUB.t @@ -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!"; @@ -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 @@ -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__; diff --git a/t/uni/parser.t b/t/uni/parser.t index fa6b290f5d..70b95fb61f 100644 --- a/t/uni/parser.t +++ b/t/uni/parser.t @@ -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; |