X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f4c975aa030b7ad74a7efda242fb8b771ea41c14..b668a55c36b8cfa7ba6bc08031430c1dd988cd4e:/pp.c diff --git a/pp.c b/pp.c index 6acfcdc..33eac60 100644 --- a/pp.c +++ b/pp.c @@ -31,22 +31,6 @@ #include "reentr.h" #include "regcharclass.h" -/* XXX I can't imagine anyone who doesn't have this actually _needs_ - it, since pid_t is an integral type. - --AD 2/20/1998 -*/ -#ifdef NEED_GETPID_PROTO -extern Pid_t getpid (void); -#endif - -/* - * Some BSDs and Cygwin default to POSIX math instead of IEEE. - * This switches them over to IEEE. - */ -#if defined(LIBM_LIB_VERSION) - _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_; -#endif - static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1; static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1; @@ -62,101 +46,7 @@ PP(pp_stub) /* Pushy stuff. */ -/* This is also called directly by pp_lvavref. */ -PP(pp_padav) -{ - dSP; dTARGET; - U8 gimme; - assert(SvTYPE(TARG) == SVt_PVAV); - if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO )) - if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) )) - SAVECLEARSV(PAD_SVl(PL_op->op_targ)); - EXTEND(SP, 1); - - if (PL_op->op_flags & OPf_REF) { - PUSHs(TARG); - RETURN; - } - else if (PL_op->op_private & OPpMAYBE_LVSUB) { - const I32 flags = is_lvalue_sub(); - if (flags && !(flags & OPpENTERSUB_INARGS)) { - if (GIMME_V == G_SCALAR) - /* diag_listed_as: Can't return %s to lvalue scalar context */ - Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); - PUSHs(TARG); - RETURN; - } - } - - gimme = GIMME_V; - if (gimme == G_ARRAY) { - /* XXX see also S_pushav in pp_hot.c */ - const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1; - EXTEND(SP, maxarg); - if (SvMAGICAL(TARG)) { - SSize_t i; - for (i=0; i < maxarg; i++) { - SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE); - SP[i+1] = (svp) ? *svp : &PL_sv_undef; - } - } - else { - SSize_t i; - for (i=0; i < maxarg; i++) { - SV * const sv = AvARRAY((const AV *)TARG)[i]; - SP[i+1] = sv ? sv : &PL_sv_undef; - } - } - SP += maxarg; - } - else if (gimme == G_SCALAR) { - SV* const sv = sv_newmortal(); - const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1; - sv_setiv(sv, maxarg); - PUSHs(sv); - } - RETURN; -} - -PP(pp_padhv) -{ - dSP; dTARGET; - U8 gimme; - - assert(SvTYPE(TARG) == SVt_PVHV); - XPUSHs(TARG); - if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO )) - if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) )) - SAVECLEARSV(PAD_SVl(PL_op->op_targ)); - if (PL_op->op_flags & OPf_REF) - RETURN; - else if (PL_op->op_private & OPpMAYBE_LVSUB) { - const I32 flags = is_lvalue_sub(); - if (flags && !(flags & OPpENTERSUB_INARGS)) { - if (GIMME_V == G_SCALAR) - /* diag_listed_as: Can't return %s to lvalue scalar context */ - Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); - RETURN; - } - } - - gimme = GIMME_V; - if (gimme == G_ARRAY) { - RETURNOP(Perl_do_kv(aTHX)); - } - else if ((PL_op->op_private & OPpTRUEBOOL - || ( PL_op->op_private & OPpMAYBE_TRUEBOOL - && block_gimme() == G_VOID )) - && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied)) - ) - SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : &PL_sv_zero); - else if (gimme == G_SCALAR) { - SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG)); - SETs(sv); - } - RETURN; -} PP(pp_padcv) { @@ -239,20 +129,18 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, */ if (vivify_sv && sv != &PL_sv_undef) { GV *gv; + HV *stash; if (SvREADONLY(sv)) Perl_croak_no_modify(); + gv = MUTABLE_GV(newSV(0)); + stash = CopSTASH(PL_curcop); + if (SvTYPE(stash) != SVt_PVHV) stash = NULL; if (cUNOP->op_targ) { SV * const namesv = PAD_SV(cUNOP->op_targ); - HV *stash = CopSTASH(PL_curcop); - if (SvTYPE(stash) != SVt_PVHV) stash = NULL; - gv = MUTABLE_GV(newSV(0)); gv_init_sv(gv, stash, namesv, 0); } else { - const char * const name = CopSTASHPV(PL_curcop); - gv = newGVgen_flags(name, - HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 ); - SvREFCNT_inc_simple_void_NN(gv); + gv_init_pv(gv, stash, "__ANONIO__", 0); } prepare_SV_for_RV(sv); SvRV_set(sv, MUTABLE_SV(gv)); @@ -440,11 +328,15 @@ PP(pp_pos) else { const MAGIC * const mg = mg_find_mglob(sv); if (mg && mg->mg_len != -1) { - dTARGET; STRLEN i = mg->mg_len; - if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv)) - i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN); - SETu(i); + if (PL_op->op_private & OPpTRUEBOOL) + SETs(i ? &PL_sv_yes : &PL_sv_zero); + else { + dTARGET; + if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv)) + i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN); + SETu(i); + } return NORMAL; } SETs(&PL_sv_undef); @@ -490,7 +382,7 @@ PP(pp_prototype) if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs)); if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) { const char * s = SvPVX_const(TOPs); - if (strnEQ(s, "CORE::", 6)) { + if (memBEGINs(s, SvCUR(TOPs), "CORE::")) { const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1); if (!code) DIE(aTHX_ "Can't find an opnumber for \"%" UTF8f "\"", @@ -575,6 +467,8 @@ S_refto(pTHX_ SV *sv) else if (SvPADTMP(sv)) { sv = newSVsv(sv); } + else if (UNLIKELY(SvSMAGICAL(sv) && mg_find(sv, PERL_MAGIC_nonelem))) + sv_unmagic(SvREFCNT_inc_simple_NN(sv), PERL_MAGIC_nonelem); else { SvTEMP_off(sv); SvREFCNT_inc_void_NN(sv); @@ -797,8 +691,8 @@ PP(pp_trans) PUSHs(newsv); } else { - I32 i = do_trans(sv); - mPUSHi(i); + Size_t i = do_trans(sv); + mPUSHi((UV)i); } RETURN; } @@ -1546,15 +1440,9 @@ PP(pp_divide) can be too large to preserve, so don't need to compile the code to test the size of UVs. */ -#ifdef SLOPPYDIVIDE +#if defined(SLOPPYDIVIDE) || (defined(PERL_PRESERVE_IVUV) && !defined(NV_PRESERVES_UV)) # define PERL_TRY_UV_DIVIDE /* ensure that 20./5. == 4. */ -#else -# ifdef PERL_PRESERVE_IVUV -# ifndef NV_PRESERVES_UV -# define PERL_TRY_UV_DIVIDE -# endif -# endif #endif #ifdef PERL_TRY_UV_DIVIDE @@ -1783,8 +1671,9 @@ PP(pp_repeat) IV count; SV *sv; bool infnan = FALSE; + const U8 gimme = GIMME_V; - if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { + if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { /* TODO: think of some way of doing list-repeat overloading ??? */ sv = POPs; SvGETMAGIC(sv); @@ -1848,7 +1737,7 @@ PP(pp_repeat) "Negative repeat count does nothing"); } - if (GIMME_V == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { + if (gimme == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { dMARK; const SSize_t items = SP - MARK; const U8 mod = PL_op->op_flags & OPf_MOD; @@ -2641,7 +2530,7 @@ S_scomplement(pTHX_ SV *targ, SV *sv) if (SvUTF8(TARG)) { if (len && ! utf8_to_bytes(tmps, &len)) { - Perl_croak(aTHX_ fatal_above_ff_msg, PL_op_desc[PL_op->op_type]); + Perl_croak(aTHX_ FATAL_ABOVE_FF_MSG, PL_op_desc[PL_op->op_type]); } SvCUR(TARG) = len; SvUTF8_off(TARG); @@ -3204,52 +3093,74 @@ PP(pp_oct) /* String stuff. */ + PP(pp_length) { dSP; dTARGET; SV * const sv = TOPs; U32 in_bytes = IN_BYTES; - /* simplest case shortcut */ - /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/ + /* Simplest case shortcut: + * set svflags to just the SVf_POK|SVs_GMG|SVf_UTF8 from the SV, + * with the SVf_UTF8 flag inverted if under 'use bytes' (HINT_BYTES + * set) + */ U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8); - STATIC_ASSERT_STMT(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26)); + + STATIC_ASSERT_STMT(SVf_UTF8 == (HINT_BYTES << 26)); SETs(TARG); - if(LIKELY(svflags == SVf_POK)) + if (LIKELY(svflags == SVf_POK)) goto simple_pv; - if(svflags & SVs_GMG) + + if (svflags & SVs_GMG) mg_get(sv); + if (SvOK(sv)) { - if (!IN_BYTES) /* reread to avoid using an C auto/register */ - sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv)); - else - { - STRLEN len; + STRLEN len; + if (!IN_BYTES) { /* reread to avoid using an C auto/register */ + if ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == SVf_POK) + goto simple_pv; + if ( SvPOK(sv) && (PL_op->op_private & OPpTRUEBOOL)) { + /* no need to convert from bytes to chars */ + len = SvCUR(sv); + goto return_bool; + } + len = sv_len_utf8_nomg(sv); + } + else { /* unrolled SvPV_nomg_const(sv,len) */ - if(SvPOK_nog(sv)){ - simple_pv: + if (SvPOK_nog(sv)) { + simple_pv: len = SvCUR(sv); - } else { + if (PL_op->op_private & OPpTRUEBOOL) { + return_bool: + SETs(len ? &PL_sv_yes : &PL_sv_zero); + return NORMAL; + } + } + else { (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN); } - sv_setiv(TARG, (IV)(len)); } - } else { + TARGi((IV)(len), 1); + } + else { if (!SvPADTMP(TARG)) { + /* OPpTARGET_MY: targ is var in '$lex = length()' */ sv_set_undef(TARG); - } else { /* TARG is on stack at this point and is overwriten by SETs. - This branch is the odd one out, so put TARG by default on - stack earlier to let local SP go out of liveness sooner */ + SvSETMAGIC(TARG); + } + else + /* TARG is on stack at this point and is overwriten by SETs. + * This branch is the odd one out, so put TARG by default on + * stack earlier to let local SP go out of liveness sooner */ SETs(&PL_sv_undef); - goto no_set_magic; - } } - SvSETMAGIC(TARG); - no_set_magic: return NORMAL; /* no putback, SP didn't move in this opcode */ } + /* Returns false if substring is completely outside original string. No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must always be true for an explicit 0. @@ -3552,7 +3463,7 @@ PP(pp_index) convert the small string to ISO-8859-1, then there is no way that it could be found anywhere by index. */ retval = -1; - goto fail; + goto push_result; } /* At this point, pv is a malloc()ed string. So donate it to temp @@ -3615,8 +3526,18 @@ PP(pp_index) retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN); } SvREFCNT_dec(temp); - fail: - PUSHi(retval); + + push_result: + /* OPpTRUEBOOL indicates an '== -1' has been optimised away */ + if (PL_op->op_private & OPpTRUEBOOL) { + PUSHs( ((retval != -1) ^ cBOOL(PL_op->op_private & OPpINDEX_BOOLNEG)) + ? &PL_sv_yes : &PL_sv_no); + if (PL_op->op_private & OPpTARGET_MY) + /* $lex = (index() == -1) */ + sv_setsv(TARG, TOPs); + } + else + PUSHi(retval); RETURN; } @@ -3732,8 +3653,12 @@ PP(pp_crypt) #if defined(__GLIBC__) || defined(__EMX__) if (PL_reentrant_buffer->_crypt_struct_buffer) { PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0; - /* work around glibc-2.2.5 bug */ +#if (defined(__GLIBC__) && __GLIBC__ == 2) && \ + (defined(__GLIBC_MINOR__) && __GLIBC_MINOR__ >= 2 && __GLIBC_MINOR__ < 4) + /* work around glibc-2.2.5 bug, has been fixed at some + * time in glibc-2.3.X */ PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0; +#endif } #endif } @@ -3791,6 +3716,14 @@ PP(pp_ucfirst) * not convert in-place. */ inplace = !SvREADONLY(source) && SvPADTMP(source); +#ifdef USE_LOCALE_CTYPE + + if (IN_LC_RUNTIME(LC_CTYPE)) { + _CHECK_AND_WARN_PROBLEMATIC_LOCALE; + } + +#endif + /* First calculate what the changed first character should be. This affects * whether we can just swap it out, leaving the rest of the string unchanged, * or even if have to convert the dest to UTF-8 when the source isn't */ @@ -3798,6 +3731,7 @@ PP(pp_ucfirst) if (! slen) { /* If empty */ need = 1; /* still need a trailing NUL */ ulen = 0; + *tmpbuf = '\0'; } else if (DO_UTF8(source)) { /* Is the source utf8? */ doing_utf8 = TRUE; @@ -3834,7 +3768,6 @@ PP(pp_ucfirst) /* lower case the first letter: no trickiness for any character */ #ifdef USE_LOCALE_CTYPE if (IN_LC_RUNTIME(LC_CTYPE)) { - _CHECK_AND_WARN_PROBLEMATIC_LOCALE; *tmpbuf = toLOWER_LC(*s); } else @@ -3852,7 +3785,6 @@ PP(pp_ucfirst) goto do_uni_rules; } - _CHECK_AND_WARN_PROBLEMATIC_LOCALE; *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any locales have upper and title case different */ @@ -4068,6 +4000,14 @@ PP(pp_uc) SETs(dest); } +#ifdef USE_LOCALE_CTYPE + + if (IN_LC_RUNTIME(LC_CTYPE)) { + _CHECK_AND_WARN_PROBLEMATIC_LOCALE; + } + +#endif + /* Overloaded values may have toggled the UTF-8 flag on source, so we need to check DO_UTF8 again here. */ @@ -4154,7 +4094,6 @@ PP(pp_uc) if (IN_UTF8_CTYPE_LOCALE) { goto do_uni_rules; } - _CHECK_AND_WARN_PROBLEMATIC_LOCALE; for (; s < send; d++, s++) *d = (U8) toUPPER_LC(*s); } @@ -4308,6 +4247,14 @@ PP(pp_lc) SETs(dest); } +#ifdef USE_LOCALE_CTYPE + + if (IN_LC_RUNTIME(LC_CTYPE)) { + _CHECK_AND_WARN_PROBLEMATIC_LOCALE; + } + +#endif + /* Overloaded values may have toggled the UTF-8 flag on source, so we need to check DO_UTF8 again here. */ @@ -4361,7 +4308,6 @@ PP(pp_lc) * whole thing in a tight loop, for speed, */ #ifdef USE_LOCALE_CTYPE if (IN_LC_RUNTIME(LC_CTYPE)) { - _CHECK_AND_WARN_PROBLEMATIC_LOCALE; for (; s < send; d++, s++) *d = toLOWER_LC(*s); } @@ -4525,6 +4471,15 @@ PP(pp_fc) SETs(dest); send = s + len; + +#ifdef USE_LOCALE_CTYPE + + if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */ + _CHECK_AND_WARN_PROBLEMATIC_LOCALE; + } + +#endif + if (DO_UTF8(source)) { /* UTF-8 flagged string. */ while (s < send) { const STRLEN u = UTF8SKIP(s); @@ -4549,7 +4504,6 @@ PP(pp_fc) if (IN_UTF8_CTYPE_LOCALE) { goto do_uni_folding; } - _CHECK_AND_WARN_PROBLEMATIC_LOCALE; for (; s < send; d++, s++) *d = (U8) toFOLD_LC(*s); } @@ -5111,7 +5065,7 @@ PP(pp_hslice) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); } if (localizing) { - if (HvNAME_get(hv) && isGV(*svp)) + if (HvNAME_get(hv) && isGV_or_RVCV(*svp)) save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL)); else if (preeminent) save_helem_flags(hv, keysv, svp, @@ -5186,9 +5140,11 @@ PP(pp_list) { I32 markidx = POPMARK; if (GIMME_V != G_ARRAY) { - SV **mark = PL_stack_base + markidx; + /* don't initialize mark here, EXTEND() may move the stack */ + SV **mark; dSP; EXTEND(SP, 1); /* in case no arguments, as in @empty */ + mark = PL_stack_base + markidx; if (++MARK <= SP) *MARK = *SP; /* unwanted list, return last item */ else @@ -5315,6 +5271,9 @@ PP(pp_splice) sp - mark); } + if (SvREADONLY(ary)) + Perl_croak_no_modify(); + SP++; if (++MARK < SP) { @@ -5685,13 +5644,16 @@ PP(pp_reverse) STRLEN len; SvUTF8_off(TARG); /* decontaminate */ - if (SP - MARK > 1) + if (SP - MARK > 1) { do_join(TARG, &PL_sv_no, MARK, SP); - else if (SP > MARK) + SP = MARK + 1; + SETs(TARG); + } else if (SP > MARK) { sv_setsv(TARG, *SP); - else { + SETs(TARG); + } else { sv_setsv(TARG, DEFSV); - EXTEND(SP, 1); + XPUSHs(TARG); } up = SvPV_force(TARG, len); @@ -5729,8 +5691,6 @@ PP(pp_reverse) } (void)SvPOK_only_UTF8(TARG); } - SP = MARK + 1; - SETTARG; } RETURN; } @@ -6414,6 +6374,19 @@ PP(pp_coreargs) RETURN; } +/* Implement CORE::keys(),values(),each(). + * + * We won't know until run-time whether the arg is an array or hash, + * so this op calls + * + * pp_keys/pp_values/pp_each + * or + * pp_akeys/pp_avalues/pp_aeach + * + * as appropriate (or whatever pp function actually implements the OP_FOO + * functionality for each FOO). + */ + PP(pp_avhvswitch) { dVAR; dSP;