/* pp.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * "It's a big house this, and very peculiar. Always a bit more to discover, * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise */ /* This file contains general pp ("push/pop") functions that execute the * opcodes that make up a perl program. A typical pp function expects to * find its arguments on the stack, and usually pushes its results onto * the stack, hence the 'pp' terminology. Each OP structure contains * a pointer to the relevant pp_foo() function. */ #include "EXTERN.h" #define PERL_IN_PP_C #include "perl.h" #include "keywords.h" #include "reentr.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 /* variations on pp_null */ PP(pp_stub) 409803 { 409803 dSP; 409803 if (GIMME_V == G_SCALAR) 3810 XPUSHs(&PL_sv_undef); 409803 RETURN; } PP(pp_scalar) ###### { ###### return NORMAL; } /* Pushy stuff. */ PP(pp_padav) 5592586 { 5592586 dSP; dTARGET; 5592586 I32 gimme; 5592586 if (PL_op->op_private & OPpLVAL_INTRO) 1293095 SAVECLEARSV(PAD_SVl(PL_op->op_targ)); 5592586 EXTEND(SP, 1); 5592586 if (PL_op->op_flags & OPf_REF) { 3619434 PUSHs(TARG); 3619434 RETURN; 1973152 } else if (LVRET) { 2 if (GIMME == G_SCALAR) ###### Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); 2 PUSHs(TARG); 2 RETURN; } 1973150 gimme = GIMME_V; 1973150 if (gimme == G_ARRAY) { 990480 const I32 maxarg = AvFILL((AV*)TARG) + 1; 990480 EXTEND(SP, maxarg); 990480 if (SvMAGICAL(TARG)) { 3105 U32 i; 62972 for (i=0; i < (U32)maxarg; i++) { 59867 SV ** const svp = av_fetch((AV*)TARG, i, FALSE); 59867 SP[i+1] = (svp) ? *svp : &PL_sv_undef; } } else { 987375 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*); } 990480 SP += maxarg; } 982670 else if (gimme == G_SCALAR) { 755264 SV* const sv = sv_newmortal(); 755264 const I32 maxarg = AvFILL((AV*)TARG) + 1; 755264 sv_setiv(sv, maxarg); 755264 PUSHs(sv); } 1973150 RETURN; } PP(pp_padhv) 4249879 { 4249879 dSP; dTARGET; 4249879 I32 gimme; 4249879 XPUSHs(TARG); 4249879 if (PL_op->op_private & OPpLVAL_INTRO) 151124 SAVECLEARSV(PAD_SVl(PL_op->op_targ)); 4249879 if (PL_op->op_flags & OPf_REF) 4127312 RETURN; 122567 else if (LVRET) { 1 if (GIMME == G_SCALAR) ###### Perl_croak(aTHX_ "Can't return hash to lvalue scalar context"); 1 RETURN; } 122566 gimme = GIMME_V; 122566 if (gimme == G_ARRAY) { 40220 RETURNOP(do_kv()); } 82346 else if (gimme == G_SCALAR) { 17582 SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG); 17582 SETs(sv); } 82346 RETURN; } PP(pp_padany) ###### { ###### DIE(aTHX_ "NOT IMPL LINE %d",__LINE__); } /* Translations. */ PP(pp_rv2gv) 1052078 { 1052078 dSP; dTOPss; 1052078 if (SvROK(sv)) { wasref: 789363 tryAMAGICunDEREF(to_gv); 789363 sv = SvRV(sv); 789363 if (SvTYPE(sv) == SVt_PVIO) { 30389 GV * const gv = (GV*) sv_newmortal(); 30389 gv_init(gv, 0, "", 0, 0); 30389 GvIOp(gv) = (IO *)sv; 30389 (void)SvREFCNT_inc(sv); 30389 sv = (SV*) gv; } 758974 else if (SvTYPE(sv) != SVt_PVGV) 192 DIE(aTHX_ "Not a GLOB reference"); } else { 267652 if (SvTYPE(sv) != SVt_PVGV) { 147203 if (SvGMAGICAL(sv)) { 3 mg_get(sv); 3 if (SvROK(sv)) ###### goto wasref; } 147203 if (!SvOK(sv) && sv != &PL_sv_undef) { /* If this is a 'my' scalar and flag is set then vivify * NI-S 1999/05/07 */ 4954 if (SvREADONLY(sv)) 1 Perl_croak(aTHX_ PL_no_modify); 4953 if (PL_op->op_private & OPpDEREF) { 4937 GV *gv; 4937 if (cUNOP->op_targ) { 4929 STRLEN len; 4929 SV *namesv = PAD_SV(cUNOP->op_targ); 4929 const char *name = SvPV(namesv, len); 4929 gv = (GV*)NEWSV(0,0); 4929 gv_init(gv, CopSTASH(PL_curcop), name, len, 0); } else { 8 const char *name = CopSTASHPV(PL_curcop); 8 gv = newGVgen(name); } 4937 if (SvTYPE(sv) < SVt_RV) 419 sv_upgrade(sv, SVt_RV); 4937 if (SvPVX_const(sv)) { 1 SvPV_free(sv); 1 SvLEN_set(sv, 0); 1 SvCUR_set(sv, 0); } 4937 SvRV_set(sv, (SV*)gv); 4937 SvROK_on(sv); 4937 SvSETMAGIC(sv); ###### goto wasref; } 16 if (PL_op->op_flags & OPf_REF || PL_op->op_private & HINT_STRICT_REFS) 1 DIE(aTHX_ PL_no_usym, "a symbol"); 15 if (ckWARN(WARN_UNINITIALIZED)) 10 report_uninit(sv); 15 RETSETUNDEF; } 142249 if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { 32066 SV * const temp = (SV*)gv_fetchsv(sv, FALSE, SVt_PVGV); 32066 if (!temp && (!is_gv_magical_sv(sv,0) || !(sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV)))) { 148 RETSETUNDEF; } 31918 sv = temp; } else { 110183 if (PL_op->op_private & HINT_STRICT_REFS) ###### DIE(aTHX_ PL_no_symref_sv, sv, "a symbol"); 110183 sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV); } } } 1051721 if (PL_op->op_private & OPpLVAL_INTRO) 30480 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL)); 1051721 SETs(sv); 1051721 RETURN; } PP(pp_rv2sv) 2074096 { 2074096 GV *gv = Nullgv; 2074096 dSP; dTOPss; 2074096 if (SvROK(sv)) { wasref: 1003463 tryAMAGICunDEREF(to_sv); 1003463 sv = SvRV(sv); 1003463 switch (SvTYPE(sv)) { case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: ###### DIE(aTHX_ "Not a SCALAR reference"); } } else { 1070633 gv = (GV*)sv; 1070633 if (SvTYPE(gv) != SVt_PVGV) { 138019 if (SvGMAGICAL(sv)) { ###### mg_get(sv); ###### if (SvROK(sv)) ###### goto wasref; } 138019 if (!SvOK(sv)) { 7 if (PL_op->op_flags & OPf_REF || PL_op->op_private & HINT_STRICT_REFS) 1 DIE(aTHX_ PL_no_usym, "a SCALAR"); 6 if (ckWARN(WARN_UNINITIALIZED)) 4 report_uninit(sv); 6 RETSETUNDEF; } 138012 if ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD)) { 35729 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PV); 35729 if (!gv && (!is_gv_magical_sv(sv, 0) || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV)))) { 515 RETSETUNDEF; } } else { 102283 if (PL_op->op_private & HINT_STRICT_REFS) 19 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR"); 102264 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV); } } 1070092 sv = GvSVn(gv); } 2073555 if (PL_op->op_flags & OPf_MOD) { 1222408 if (PL_op->op_private & OPpLVAL_INTRO) { 12 if (cUNOP->op_first->op_type == OP_NULL) ###### sv = save_scalar((GV*)TOPs); 12 else if (gv) 5 sv = save_scalar(gv); else 7 Perl_croak(aTHX_ PL_no_localize_ref); } 1222396 else if (PL_op->op_private & OPpDEREF) 932576 vivify_ref(sv, PL_op->op_private & OPpDEREF); } 2073548 SETs(sv); 2073548 RETURN; } PP(pp_av2arylen) 384674 { 384674 dSP; 384674 AV * const av = (AV*)TOPs; 384674 SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av); 384674 if (!*sv) { 16154 *sv = NEWSV(0,0); 16154 sv_upgrade(*sv, SVt_PVMG); 16154 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0); } 384674 SETs(*sv); 384674 RETURN; } PP(pp_pos) 289813 { 289813 dSP; dTARGET; dPOPss; 289813 if (PL_op->op_flags & OPf_MOD || LVRET) { 201109 if (SvTYPE(TARG) < SVt_PVLV) { 557 sv_upgrade(TARG, SVt_PVLV); 557 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0); } 201109 LvTYPE(TARG) = '.'; 201109 if (LvTARG(TARG) != sv) { 40102 if (LvTARG(TARG)) 39545 SvREFCNT_dec(LvTARG(TARG)); 40102 LvTARG(TARG) = SvREFCNT_inc(sv); } 201109 PUSHs(TARG); /* no SvSETMAGIC */ 201109 RETURN; } else { 88704 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { 88517 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global); 88517 if (mg && mg->mg_len >= 0) { 88205 I32 i = mg->mg_len; 88205 if (DO_UTF8(sv)) 8424 sv_pos_b2u(sv, &i); 88205 PUSHi(i + PL_curcop->cop_arybase); 88205 RETURN; } } 499 RETPUSHUNDEF; } } PP(pp_rv2cv) 148087 { 148087 dSP; 148087 GV *gv; 148087 HV *stash; /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */ /* (But not in defined().) */ 148087 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL)); 148085 if (cv) { 99103 if (CvCLONE(cv)) ###### cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); 99103 if ((PL_op->op_private & OPpLVAL_INTRO)) { 7 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE))) 1 cv = GvCV(gv); 7 if (!CvLVALUE(cv)) 1 DIE(aTHX_ "Can't modify non-lvalue subroutine call"); } } else 48982 cv = (CV*)&PL_sv_undef; 148084 SETs((SV*)cv); 148084 RETURN; } PP(pp_prototype) 888 { 888 dSP; 888 CV *cv; 888 HV *stash; 888 GV *gv; 888 SV *ret; 888 ret = &PL_sv_undef; 888 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) { 776 const char *s = SvPVX_const(TOPs); 776 if (strnEQ(s, "CORE::", 6)) { 325 const int code = keyword(s + 6, SvCUR(TOPs) - 6); 325 if (code < 0) { /* Overridable. */ #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2) 253 int i = 0, n = 0, seen_question = 0; 253 I32 oa; 253 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */ 253 if (code == -KEY_chop || code == -KEY_chomp || code == -KEY_exec || code == -KEY_system) 247 goto set; 49615 while (i < MAXO) { /* The slow way. */ 49610 if (strEQ(s + 6, PL_op_name[i]) || strEQ(s + 6, PL_op_desc[i])) { 38 goto found; } 49368 i++; } 242 goto nonesuch; /* Should not happen... */ found: 242 oa = PL_opargs[i] >> OASHIFT; 592 while (oa) { 350 if (oa & OA_OPTIONAL && !seen_question) { 121 seen_question = 1; 121 str[n++] = ';'; } 350 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF /* But globs are already references (kinda) */ && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF ) { 51 str[n++] = '\\'; } 350 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)]; 350 oa = oa >> 4; } 242 str[n++] = '\0'; 242 ret = sv_2mortal(newSVpvn(str, n - 1)); } 72 else if (code) /* Non-Overridable */ 71 goto set; else { /* None such */ nonesuch: 6 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6); } } } 805 cv = sv_2cv(TOPs, &stash, &gv, FALSE); 805 if (cv && SvPOK(cv)) 446 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv))); set: 882 SETs(ret); 882 RETURN; } PP(pp_anoncode) 36580 { 36580 dSP; 36580 CV* cv = (CV*)PAD_SV(PL_op->op_targ); 36580 if (CvCLONE(cv)) 15387 cv = (CV*)sv_2mortal((SV*)cv_clone(cv)); 36580 EXTEND(SP,1); 36580 PUSHs((SV*)cv); 36580 RETURN; } PP(pp_srefgen) 2319777 { 2319777 dSP; 2319777 *SP = refto(*SP); 2319777 RETURN; } PP(pp_refgen) 573776 { 573776 dSP; dMARK; 573776 if (GIMME != G_ARRAY) { 366058 if (++MARK <= SP) 366058 *MARK = *SP; else ###### *MARK = &PL_sv_undef; 366058 *MARK = refto(*MARK); 366058 SP = MARK; 366058 RETURN; } 207718 EXTEND_MORTAL(SP - MARK); 415730 while (++MARK <= SP) 208012 *MARK = refto(*MARK); 207718 RETURN; } STATIC SV* S_refto(pTHX_ SV *sv) 2893848 { 2893848 SV* rv; 2893848 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { 3 if (LvTARGLEN(sv)) 3 vivify_defelem(sv); 3 if (!(sv = LvTARG(sv))) ###### sv = &PL_sv_undef; else 3 (void)SvREFCNT_inc(sv); } 2893845 else if (SvTYPE(sv) == SVt_PVAV) { 1467010 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv)) 73 av_reify((AV*)sv); 1467010 SvTEMP_off(sv); 1467010 (void)SvREFCNT_inc(sv); } 1426835 else if (SvPADTMP(sv) && !IS_PADGV(sv)) 7 sv = newSVsv(sv); else { 1426828 SvTEMP_off(sv); 1426828 (void)SvREFCNT_inc(sv); } 2893848 rv = sv_newmortal(); 2893848 sv_upgrade(rv, SVt_RV); 2893848 SvRV_set(rv, sv); 2893848 SvROK_on(rv); 2893848 return rv; } PP(pp_ref) 1004785 { 1004785 dSP; dTARGET; 1004785 const char *pv; 1004785 SV * const sv = POPs; 1004785 if (sv && SvGMAGICAL(sv)) 580 mg_get(sv); 1004785 if (!sv || !SvROK(sv)) 319179 RETPUSHNO; 685606 pv = sv_reftype(SvRV(sv),TRUE); 685606 PUSHp(pv, strlen(pv)); 685606 RETURN; } PP(pp_bless) 439777 { 439777 dSP; 439777 HV *stash; 439777 if (MAXARG == 1) 194779 stash = CopSTASH(PL_curcop); else { 244998 SV * const ssv = POPs; 244998 STRLEN len; 244998 const char *ptr; 244998 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv)) 1 Perl_croak(aTHX_ "Attempt to bless into a reference"); 244997 ptr = SvPV_const(ssv,len); 244997 if (ckWARN(WARN_MISC) && len == 0) 4 Perl_warner(aTHX_ packWARN(WARN_MISC), "Explicit blessing to '' (assuming package main)"); 244997 stash = gv_stashpvn(ptr, len, TRUE); } 439776 (void)sv_bless(TOPs, stash); 439775 RETURN; } PP(pp_gelem) 7076 { 7076 dSP; 7076 SV *sv = POPs; 7076 const char * const elem = SvPV_nolen_const(sv); 7076 GV * const gv = (GV*)POPs; 7076 SV * tmpRef = Nullsv; 7076 sv = Nullsv; 7076 if (elem) { /* elem will always be NUL terminated. */ 7076 const char * const second_letter = elem + 1; 7076 switch (*elem) { case 'A': 504 if (strEQ(second_letter, "RRAY")) 504 tmpRef = (SV*)GvAV(gv); 504 break; case 'C': 2119 if (strEQ(second_letter, "ODE")) 2119 tmpRef = (SV*)GvCVu(gv); 2119 break; case 'F': 6 if (strEQ(second_letter, "ILEHANDLE")) { /* finally deprecated in 5.8.0 */ 1 deprecate("*glob{FILEHANDLE}"); 1 tmpRef = (SV*)GvIOp(gv); } else 5 if (strEQ(second_letter, "ORMAT")) 5 tmpRef = (SV*)GvFORM(gv); 5 break; case 'G': 1 if (strEQ(second_letter, "LOB")) 1 tmpRef = (SV*)gv; 1 break; case 'H': 1215 if (strEQ(second_letter, "ASH")) 1215 tmpRef = (SV*)GvHV(gv); 1215 break; case 'I': 713 if (*second_letter == 'O' && !elem[2]) 713 tmpRef = (SV*)GvIOp(gv); 713 break; case 'N': 20 if (strEQ(second_letter, "AME")) 20 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv)); 20 break; case 'P': 6 if (strEQ(second_letter, "ACKAGE")) { 6 const HEK *hek = HvNAME_HEK(GvSTASH(gv)); 6 sv = hek ? newSVhek(hek) : newSVpvn("__ANON__", 8); } 6 break; case 'S': 2491 if (strEQ(second_letter, "CALAR")) 2491 tmpRef = GvSV(gv); break; } } 7076 if (tmpRef) 5593 sv = newRV(tmpRef); 7076 if (sv) 5619 sv_2mortal(sv); else 1457 sv = &PL_sv_undef; 7076 XPUSHs(sv); 7076 RETURN; } /* Pattern matching */ PP(pp_study) 4586 { 4586 dSP; dPOPss; 4586 register unsigned char *s; 4586 register I32 pos; 4586 register I32 ch; 4586 register I32 *sfirst; 4586 register I32 *snext; 4586 STRLEN len; 4586 if (sv == PL_lastscream) { 4 if (SvSCREAM(sv)) ###### RETPUSHYES; } else { 4582 if (PL_lastscream) { 4572 SvSCREAM_off(PL_lastscream); 4572 SvREFCNT_dec(PL_lastscream); } 4582 PL_lastscream = SvREFCNT_inc(sv); } 4586 s = (unsigned char*)(SvPV(sv, len)); 4586 pos = len; 4586 if (pos <= 0) 2 RETPUSHNO; 4584 if (pos > PL_maxscream) { 9 if (PL_maxscream < 0) { 9 PL_maxscream = pos + 80; 9 New(301, PL_screamfirst, 256, I32); 9 New(302, PL_screamnext, PL_maxscream, I32); } else { ###### PL_maxscream = pos + pos / 4; ###### Renew(PL_screamnext, PL_maxscream, I32); } } 4584 sfirst = PL_screamfirst; 4584 snext = PL_screamnext; 4584 if (!sfirst || !snext) ###### DIE(aTHX_ "do_study: out of memory"); 1178088 for (ch = 256; ch; --ch) 1173504 *sfirst++ = -1; 4584 sfirst -= 256; 82401 while (--pos >= 0) { 77817 register const I32 ch = s[pos]; 77817 if (sfirst[ch] >= 0) 13748 snext[pos] = sfirst[ch] - pos; else 64069 snext[pos] = -pos; 77817 sfirst[ch] = pos; } 4584 SvSCREAM_on(sv); /* piggyback on m//g magic */ 4584 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0); 4584 RETPUSHYES; } PP(pp_trans) 71445 { 71445 dSP; dTARG; 71445 SV *sv; 71445 if (PL_op->op_flags & OPf_STACKED) 61615 sv = POPs; 9830 else if (PL_op->op_private & OPpTARGET_MY) 2 sv = GETTARGET; else { 9828 sv = DEFSV; 9828 EXTEND(SP,1); } 71445 TARG = sv_newmortal(); 71445 PUSHi(do_trans(sv)); 71444 RETURN; } /* Lvalue operators. */ PP(pp_schop) 52286 { 52286 dSP; dTARGET; 52286 do_chop(TARG, TOPs); 52267 SETTARG; 52267 RETURN; } PP(pp_chop) 43 { 43 dSP; dMARK; dTARGET; dORIGMARK; 123 while (MARK < SP) 80 do_chop(TARG, *++MARK); 43 SP = ORIGMARK; 43 PUSHTARG; 43 RETURN; } PP(pp_schomp) 242890 { 242890 dSP; dTARGET; 242890 SETi(do_chomp(TOPs)); 242889 RETURN; } PP(pp_chomp) 1179 { 1179 dSP; dMARK; dTARGET; 1179 register I32 count = 0; 2442 while (SP > MARK) 1263 count += do_chomp(POPs); 1179 PUSHi(count); 1179 RETURN; } PP(pp_defined) 5101871 { 5101871 dSP; 5101871 register SV* const sv = POPs; 5101871 if (!sv || !SvANY(sv)) 894247 RETPUSHNO; 4207624 switch (SvTYPE(sv)) { case SVt_PVAV: 130 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) 42 RETPUSHYES; 38 break; case SVt_PVHV: 38 if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) 35 RETPUSHYES; 7911 break; case SVt_PVCV: 7911 if (CvROOT(sv) || CvXSUB(sv)) 7402 RETPUSHYES; 4199545 break; default: 4199545 if (SvGMAGICAL(sv)) 780686 mg_get(sv); 4199545 if (SvOK(sv)) 3141356 RETPUSHYES; } 1058789 RETPUSHNO; } PP(pp_undef) 416039 { 416039 dSP; 416039 SV *sv; 416039 if (!PL_op->op_private) { 393083 EXTEND(SP, 1); 393083 RETPUSHUNDEF; } 22956 sv = POPs; 22956 if (!sv) ###### RETPUSHUNDEF; 22956 SV_CHECK_THINKFIRST_COW_DROP(sv); 22955 switch (SvTYPE(sv)) { case SVt_NULL: 1640 break; case SVt_PVAV: 1640 av_undef((AV*)sv); 1640 break; case SVt_PVHV: 6526 hv_undef((HV*)sv); 6526 break; case SVt_PVCV: 689 if (ckWARN(WARN_MISC) && cv_const_sv((CV*)sv)) 3 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined", CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv))); /* FALL THROUGH */ case SVt_PVFM: { /* let user-undef'd sub keep its identity */ 689 GV* gv = CvGV((CV*)sv); 689 cv_undef((CV*)sv); 689 CvGV((CV*)sv) = gv; } 689 break; case SVt_PVGV: 9 if (SvFAKE(sv)) ###### SvSetMagicSV(sv, &PL_sv_undef); else { 9 GP *gp; 9 gp_free((GV*)sv); 9 Newz(602, gp, 1, GP); 9 GvGP(sv) = gp_ref(gp); 9 GvSV(sv) = NEWSV(72,0); 9 GvLINE(sv) = CopLINE(PL_curcop); 9 GvEGV(sv) = (GV*)sv; 9 GvMULTI_on(sv); } 9 break; default: 9633 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) { 1479 SvPV_free(sv); 1479 SvPV_set(sv, Nullch); 1479 SvLEN_set(sv, 0); } 9633 SvOK_off(sv); 9633 SvSETMAGIC(sv); } 22955 RETPUSHUNDEF; } PP(pp_predec) 337984 { 337984 dSP; 337984 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV) ###### DIE(aTHX_ PL_no_modify); 337984 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) { 327614 SvIV_set(TOPs, SvIVX(TOPs) - 1); 327614 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else 10370 sv_dec(TOPs); 337982 SvSETMAGIC(TOPs); 337982 return NORMAL; } PP(pp_postinc) 1799739 { 1799739 dSP; dTARGET; 1799739 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV) ###### DIE(aTHX_ PL_no_modify); 1799739 sv_setsv(TARG, TOPs); 1799739 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) { 211924 SvIV_set(TOPs, SvIVX(TOPs) + 1); 211924 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else 1587815 sv_inc(TOPs); 1799739 SvSETMAGIC(TOPs); /* special case for undef: see thread at 2003-03/msg00536.html in archive */ 1799739 if (!SvOK(TARG)) 260457 sv_setiv(TARG, 0); 1799739 SETs(TARG); 1799739 return NORMAL; } PP(pp_postdec) 60093 { 60093 dSP; dTARGET; 60093 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV) ###### DIE(aTHX_ PL_no_modify); 60093 sv_setsv(TARG, TOPs); 60093 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MIN) { 50565 SvIV_set(TOPs, SvIVX(TOPs) - 1); 50565 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else 9528 sv_dec(TOPs); 60093 SvSETMAGIC(TOPs); 60093 SETs(TARG); 60093 return NORMAL; } /* Ordinary operators. */ PP(pp_pow) 4921 { 4921 dSP; dATARGET; #ifdef PERL_PRESERVE_IVUV 4921 bool is_int = 0; #endif 4921 tryAMAGICbin(pow,opASSIGN); #ifdef PERL_PRESERVE_IVUV /* For integer to integer power, we do the calculation by hand wherever we're sure it is safe; otherwise we call pow() and try to convert to integer afterwards. */ { 4352 SvIV_please(TOPm1s); 4352 if (SvIOK(TOPm1s)) { 4312 bool baseuok = SvUOK(TOPm1s); 4312 UV baseuv; 4312 if (baseuok) { 1 baseuv = SvUVX(TOPm1s); } else { 4311 const IV iv = SvIVX(TOPm1s); 4311 if (iv >= 0) { 4208 baseuv = iv; 4208 baseuok = TRUE; /* effectively it's a UV now */ } else { 103 baseuv = -iv; /* abs, baseuok == false records sign */ } } 4312 SvIV_please(TOPs); 4312 if (SvIOK(TOPs)) { 4213 UV power; 4213 if (SvUOK(TOPs)) { ###### power = SvUVX(TOPs); } else { 4213 IV iv = SvIVX(TOPs); 4213 if (iv >= 0) { 4212 power = iv; } else { 4212 goto float_it; /* Can't do negative powers this way. */ } } /* now we have integer ** positive integer. */ 4212 is_int = 1; /* foo & (foo - 1) is zero only for a power of 2. */ 4212 if (!(baseuv & (baseuv - 1))) { /* We are raising power-of-2 to a positive integer. The logic here will work for any base (even non-integer bases) but it can be less accurate than pow (base,power) or exp (power * log (base)) when the intermediate values start to spill out of the mantissa. With powers of 2 we know this can't happen. And powers of 2 are the favourite thing for perl programmers to notice ** not doing what they mean. */ 4055 NV result = 1.0; 4055 NV base = baseuok ? baseuv : -(NV)baseuv; 4055 int n = 0; 33007 for (; power; base *= base, n++) { /* Do I look like I trust gcc with long longs here? Do I hell. */ 18381 const UV bit = (UV)1 << (UV)n; 18381 if (power & bit) { 10150 result *= base; /* Only bother to clear the bit if it is set. */ 10150 power -= bit; /* Avoid squaring base again if we're done. */ 10150 if (power == 0) break; } } 4055 SP--; 4055 SETn( result ); 4055 SvIV_please(TOPs); 4055 RETURN; } else { 157 register unsigned int highbit = 8 * sizeof(UV); 157 register unsigned int lowbit = 0; 157 register unsigned int diff; 157 bool odd_power = (bool)(power & 1); 942 while ((diff = (highbit - lowbit) >> 1)) { 785 if (baseuv & ~((1 << (lowbit + diff)) - 1)) 218 lowbit += diff; else 567 highbit -= diff; } /* we now have baseuv < 2 ** highbit */ 157 if (power * highbit <= 8 * sizeof(UV)) { /* result will definitely fit in UV, so use UV math on same algorithm as above */ 97 register UV result = 1; 97 register UV base = baseuv; 97 register int n = 0; 333 for (; power; base *= base, n++) { 187 register const UV bit = (UV)1 << (UV)n; 187 if (power & bit) { 121 result *= base; 121 power -= bit; 121 if (power == 0) break; } } 97 SP--; 97 if (baseuok || !odd_power) /* answer is positive */ 87 SETu( result ); 10 else if (result <= (UV)IV_MAX) /* answer negative, fits in IV */ 10 SETi( -(IV)result ); ###### else if (result == (UV)IV_MIN) /* 2's complement assumption: special case IV_MIN */ ###### SETi( IV_MIN ); else /* answer negative, doesn't fit */ ###### SETn( -(NV)result ); 97 RETURN; } } } } } float_it: #endif { 200 dPOPTOPnnrl; 200 SETn( Perl_pow( left, right) ); #ifdef PERL_PRESERVE_IVUV 200 if (is_int) 60 SvIV_please(TOPs); #endif 200 RETURN; } } PP(pp_multiply) 1227970 { 1227970 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); #ifdef PERL_PRESERVE_IVUV 1221751 SvIV_please(TOPs); 1221751 if (SvIOK(TOPs)) { /* Unless the left argument is integer in range we are going to have to use NV maths. Hence only attempt to coerce the right argument if we know the left is integer. */ /* Left operand is defined, so is it IV? */ 1165721 SvIV_please(TOPm1s); 1165721 if (SvIOK(TOPm1s)) { 1142030 bool auvok = SvUOK(TOPm1s); 1142030 bool buvok = SvUOK(TOPs); 1142030 const UV topmask = (~ (UV)0) << (4 * sizeof (UV)); 1142030 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV))); 1142030 UV alow; 1142030 UV ahigh; 1142030 UV blow; 1142030 UV bhigh; 1142030 if (auvok) { 27 alow = SvUVX(TOPm1s); } else { 1142003 const IV aiv = SvIVX(TOPm1s); 1142003 if (aiv >= 0) { 1137622 alow = aiv; 1137622 auvok = TRUE; /* effectively it's a UV now */ } else { 4381 alow = -aiv; /* abs, auvok == false records sign */ } } 1142030 if (buvok) { 124 blow = SvUVX(TOPs); } else { 1141906 const IV biv = SvIVX(TOPs); 1141906 if (biv >= 0) { 1141358 blow = biv; 1141358 buvok = TRUE; /* effectively it's a UV now */ } else { 548 blow = -biv; /* abs, buvok == false records sign */ } } /* If this does sign extension on unsigned it's time for plan B */ 1142030 ahigh = alow >> (4 * sizeof (UV)); 1142030 alow &= botmask; 1142030 bhigh = blow >> (4 * sizeof (UV)); 1142030 blow &= botmask; 1142030 if (ahigh && bhigh) { /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000 which is overflow. Drop to NVs below. */ 474067 } else if (!ahigh && !bhigh) { /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001 so the unsigned multiply cannot overflow. */ 114164 UV product = alow * blow; 114164 if (auvok == buvok) { /* -ve * -ve or +ve * +ve gives a +ve result. */ 110038 SP--; 110038 SETu( product ); 110038 RETURN; 4126 } else if (product <= (UV)IV_MIN) { /* 2s complement assumption that (UV)-IV_MIN is correct. */ /* -ve result, which could overflow an IV */ 4120 SP--; 4120 SETi( -(IV)product ); 4120 RETURN; } /* else drop to NVs below. */ } else { /* One operand is large, 1 small */ 359903 UV product_middle; 359903 if (bhigh) { /* swap the operands */ 260185 ahigh = bhigh; 260185 bhigh = blow; /* bhigh now the temp var for the swap */ 260185 blow = alow; 260185 alow = bhigh; } /* now, ((ahigh * blow) << half_UV_len) + (alow * blow) multiplies can't overflow. shift can, add can, -ve can. */ 359903 product_middle = ahigh * blow; 359903 if (!(product_middle & topmask)) { /* OK, (ahigh * blow) won't lose bits when we shift it. */ 257230 UV product_low; 257230 product_middle <<= (4 * sizeof (UV)); 257230 product_low = alow * blow; /* as for pp_add, UV + something mustn't get smaller. IIRC ANSI mandates this wrapping *behaviour* for unsigned whatever the actual representation*/ 257230 product_low += product_middle; 257230 if (product_low >= product_middle) { /* didn't overflow */ 255992 if (auvok == buvok) { /* -ve * -ve or +ve * +ve gives a +ve result. */ 255946 SP--; 255946 SETu( product_low ); 255946 RETURN; 46 } else if (product_low <= (UV)IV_MIN) { /* 2s complement assumption again */ /* -ve result, which could overflow an IV */ 24 SP--; 24 SETi( -(IV)product_low ); 24 RETURN; } /* else drop to NVs below. */ } } /* product_middle too large */ } /* ahigh && bhigh */ } /* SvIOK(TOPm1s) */ } /* SvIOK(TOPs) */ #endif { 851623 dPOPTOPnnrl; 851623 SETn( left * right ); 851623 RETURN; } } PP(pp_divide) 621314 { 621314 dSP; dATARGET; tryAMAGICbin(div,opASSIGN); /* Only try to do UV divide first if ((SLOPPYDIVIDE is true) or (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large to preserve)) The assumption is that it is better to use floating point divide whenever possible, only doing integer divide first if we can't be sure. If NV_PRESERVES_UV is true then we know at compile time that no UV can be too large to preserve, so don't need to compile the code to test the size of UVs. */ #ifdef SLOPPYDIVIDE # 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 SvIV_please(TOPs); if (SvIOK(TOPs)) { SvIV_please(TOPm1s); if (SvIOK(TOPm1s)) { bool left_non_neg = SvUOK(TOPm1s); bool right_non_neg = SvUOK(TOPs); UV left; UV right; if (right_non_neg) { right = SvUVX(TOPs); } else { const IV biv = SvIVX(TOPs); if (biv >= 0) { right = biv; right_non_neg = TRUE; /* effectively it's a UV now */ } else { right = -biv; } } /* historically undef()/0 gives a "Use of uninitialized value" warning before dieing, hence this test goes here. If it were immediately before the second SvIV_please, then DIE() would be invoked before left was even inspected, so no inpsection would give no warning. */ if (right == 0) DIE(aTHX_ "Illegal division by zero"); if (left_non_neg) { left = SvUVX(TOPm1s); } else { const IV aiv = SvIVX(TOPm1s); if (aiv >= 0) { left = aiv; left_non_neg = TRUE; /* effectively it's a UV now */ } else { left = -aiv; } } if (left >= right #ifdef SLOPPYDIVIDE /* For sloppy divide we always attempt integer division. */ #else /* Otherwise we only attempt it if either or both operands would not be preserved by an NV. If both fit in NVs we fall through to the NV divide code below. However, as left >= right to ensure integer result here, we know that we can skip the test on the right operand - right big enough not to be preserved can't get here unless left is also too big. */ && (left > ((UV)1 << NV_PRESERVES_UV_BITS)) #endif ) { /* Integer division can't overflow, but it can be imprecise. */ const UV result = left / right; if (result * right == left) { SP--; /* result is valid */ if (left_non_neg == right_non_neg) { /* signs identical, result is positive. */ SETu( result ); RETURN; } /* 2s complement assumption */ if (result <= (UV)IV_MIN) SETi( -(IV)result ); else { /* It's exact but too negative for IV. */ SETn( -(NV)result ); } RETURN; } /* tried integer divide but it was not an integer result */ } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */ } /* left wasn't SvIOK */ } /* right wasn't SvIOK */ #endif /* PERL_TRY_UV_DIVIDE */ { 619087 dPOPPOPnnrl; 619087 if (right == 0.0) 3 DIE(aTHX_ "Illegal division by zero"); 619084 PUSHn( left / right ); 619084 RETURN; } } PP(pp_modulo) 318298 { 318298 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { 317502 UV left = 0; 317502 UV right = 0; 317502 bool left_neg = FALSE; 317502 bool right_neg = FALSE; 317502 bool use_double = FALSE; 317502 bool dright_valid = FALSE; 317502 NV dright = 0.0; 317502 NV dleft = 0.0; 317502 SvIV_please(TOPs); 317502 if (SvIOK(TOPs)) { 279843 right_neg = !SvUOK(TOPs); 279843 if (!right_neg) { 2 right = SvUVX(POPs); } else { 279841 const IV biv = SvIVX(POPs); 279841 if (biv >= 0) { 279838 right = biv; 279838 right_neg = FALSE; /* effectively it's a UV now */ } else { 3 right = -biv; } } } else { 37659 dright = POPn; 37659 right_neg = dright < 0; 37659 if (right_neg) 2 dright = -dright; 37659 if (dright < UV_MAX_P1) { 1 right = U_V(dright); 1 dright_valid = TRUE; /* In case we need to use double below. */ } else { 37658 use_double = TRUE; } } /* At this point use_double is only true if right is out of range for a UV. In range NV has been rounded down to nearest UV and use_double false. */ 317502 SvIV_please(TOPs); 317502 if (!use_double && SvIOK(TOPs)) { 278179 if (SvIOK(TOPs)) { 278179 left_neg = !SvUOK(TOPs); 278179 if (!left_neg) { 89 left = SvUVX(POPs); } else { 278090 IV aiv = SvIVX(POPs); 278090 if (aiv >= 0) { 278088 left = aiv; 278088 left_neg = FALSE; /* effectively it's a UV now */ } else { 2 left = -aiv; } } } } else { 39323 dleft = POPn; 39323 left_neg = dleft < 0; 39323 if (left_neg) 2 dleft = -dleft; /* This should be exactly the 5.6 behaviour - if left and right are both in range for UV then use U_V() rather than floor. */ 39323 if (!use_double) { 1665 if (dleft < UV_MAX_P1) { /* right was in range, so is dleft, so use UVs not double. */ 4 left = U_V(dleft); } /* left is out of range for UV, right was in range, so promote right (back) to double. */ else { /* The +0.5 is used in 5.6 even though it is not strictly consistent with the implicit +0 floor in the U_V() inside the #if 1. */ 1661 dleft = Perl_floor(dleft + 0.5); 1661 use_double = TRUE; 1661 if (dright_valid) ###### dright = Perl_floor(dright + 0.5); else 1661 dright = right; } } } 317502 if (use_double) { 39319 NV dans; 39319 if (!dright) ###### DIE(aTHX_ "Illegal modulus zero"); 39319 dans = Perl_fmod(dleft, dright); 39319 if ((left_neg != right_neg) && dans) 2 dans = dright - dans; 39319 if (right_neg) 2 dans = -dans; 39319 sv_setnv(TARG, dans); } else { 278183 UV ans; 278183 if (!right) 1 DIE(aTHX_ "Illegal modulus zero"); 278182 ans = left % right; 278182 if ((left_neg != right_neg) && ans) 3 ans = right - ans; 278182 if (right_neg) { /* XXX may warn: unary minus operator applied to unsigned type */ /* could change -foo to be (~foo)+1 instead */ 3 if (ans <= ~((UV)IV_MAX)+1) 3 sv_setiv(TARG, ~ans+1); else ###### sv_setnv(TARG, -(NV)ans); } else 278179 sv_setuv(TARG, ans); } 317501 PUSHTARG; 317501 RETURN; } } PP(pp_repeat) 124811 { 124811 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN); { 124810 register IV count; 124810 dPOPss; 124810 if (SvGMAGICAL(sv)) 239 mg_get(sv); 124810 if (SvIOKp(sv)) { 111553 if (SvUOK(sv)) { ###### const UV uv = SvUV(sv); ###### if (uv > IV_MAX) ###### count = IV_MAX; /* The best we can do? */ else ###### count = uv; } else { 111553 IV iv = SvIV(sv); 111553 if (iv < 0) 5 count = 0; else 111548 count = iv; } } 13257 else if (SvNOKp(sv)) { 12475 const NV nv = SvNV(sv); 12475 if (nv < 0.0) ###### count = 0; else 12475 count = (IV)nv; } else 782 count = SvIVx(sv); 124810 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) { 5977 dMARK; 5977 I32 items = SP - MARK; 5977 I32 max; static const char oom_list_extend[] = 5977 "Out of memory during list extend"; 5977 max = items * count; 5977 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend); /* Did the max computation overflow? */ 5977 if (items > 0 && max > 0 && (max < items || max < count)) ###### Perl_croak(aTHX_ oom_list_extend); 5977 MEXTEND(MARK, max); 5977 if (count > 1) { 7224 while (SP > MARK) { #if 0 /* This code was intended to fix 20010809.028: $x = 'abcd'; for (($x =~ /./g) x 2) { print chop; # "abcdabcd" expected as output. } * but that change (#11635) broke this code: $x = [("foo")x2]; # only one "foo" ended up in the anonlist. * I can't think of a better fix that doesn't introduce * an efficiency hit by copying the SVs. The stack isn't * refcounted, and mortalisation obviously doesn't * Do The Right Thing when the stack has more than * one pointer to the same mortal value. * .robin. */ if (*SP) { *SP = sv_2mortal(newSVsv(*SP)); SvREADONLY_on(*SP); } #else 4456 if (*SP) 4456 SvTEMP_off((*SP)); #endif 4456 SP--; } 2768 MARK++; 2768 repeatcpy((char*)(MARK + items), (char*)MARK, items * sizeof(SV*), count - 1); 2768 SP += max; } 3209 else if (count <= 0) 129 SP -= items; } else { /* Note: mark already snarfed by pp_list */ 118833 SV *tmpstr = POPs; 118833 STRLEN len; 118833 bool isutf; static const char oom_string_extend[] = 118833 "Out of memory during string extend"; 118833 SvSetSV(TARG, tmpstr); 118833 SvPV_force(TARG, len); 118833 isutf = DO_UTF8(TARG); 118833 if (count != 1) { 109144 if (count < 1) 5404 SvCUR_set(TARG, 0); else { 103740 STRLEN max = (UV)count * len; 103740 if (len > ((MEM_SIZE)~0)/count) ###### Perl_croak(aTHX_ oom_string_extend); 103740 MEM_WRAP_CHECK_1(max, char, oom_string_extend); 103740 SvGROW(TARG, max + 1); 103740 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1); 103740 SvCUR_set(TARG, SvCUR(TARG) * count); } 109144 *SvEND(TARG) = '\0'; } 118833 if (isutf) 12 (void)SvPOK_only_UTF8(TARG); else 118821 (void)SvPOK_only(TARG); 118833 if (PL_op->op_private & OPpREPEAT_DOLIST) { /* The parser saw this as a list repeat, and there are probably several items on the stack. But we're in scalar context, and there's no pp_list to save us now. So drop the rest of the items -- robin@kitsite.com */ 5 dMARK; 5 SP = MARK; } 118833 PUSHTARG; } 124810 RETURN; } } PP(pp_subtract) 16632175 { 16632175 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN); 16629842 useleft = USE_LEFT(TOPm1s); #ifdef PERL_PRESERVE_IVUV /* See comments in pp_add (in pp_hot.c) about Overflow, and how "bad things" happen if you rely on signed integers wrapping. */ 16629842 SvIV_please(TOPs); 16629842 if (SvIOK(TOPs)) { /* Unless the left argument is integer in range we are going to have to use NV maths. Hence only attempt to coerce the right argument if we know the left is integer. */ 16255409 register UV auv = 0; 16255409 bool auvok = FALSE; 16255409 bool a_valid = 0; 16255409 if (!useleft) { 4 auv = 0; 4 a_valid = auvok = 1; /* left operand is undef, treat as zero. */ } else { /* Left operand is defined, so is it IV? */ 16255405 SvIV_please(TOPm1s); 16255405 if (SvIOK(TOPm1s)) { 16249653 if ((auvok = SvUOK(TOPm1s))) 7874 auv = SvUVX(TOPm1s); else { 16241779 register const IV aiv = SvIVX(TOPm1s); 16241779 if (aiv >= 0) { 16228949 auv = aiv; 16228949 auvok = 1; /* Now acting as a sign flag. */ } else { /* 2s complement assumption for IV_MIN */ 12830 auv = (UV)-aiv; } } 16249653 a_valid = 1; } } 16255409 if (a_valid) { 16249657 bool result_good = 0; 16249657 UV result; 16249657 register UV buv; 16249657 bool buvok = SvUOK(TOPs); 16249657 if (buvok) 7682 buv = SvUVX(TOPs); else { 16241975 register const IV biv = SvIVX(TOPs); 16241975 if (biv >= 0) { 16239841 buv = biv; 16239841 buvok = 1; } else 2134 buv = (UV)-biv; } /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, else "IV" now, independent of how it came in. if a, b represents positive, A, B negative, a maps to -A etc a - b => (a - b) A - b => -(a + b) a - B => (a + b) A - B => -(a - b) all UV maths. negate result if A negative. subtract if signs same, add if signs differ. */ 16249657 if (auvok ^ buvok) { /* Signs differ. */ 12086 result = auv + buv; 12086 if (result >= auv) 12085 result_good = 1; } else { /* Signs same */ 16237571 if (auv >= buv) { 16133186 result = auv - buv; /* Must get smaller */ 16133186 if (result <= auv) 16133186 result_good = 1; } else { 104385 result = buv - auv; 104385 if (result <= buv) { /* result really should be -(auv-buv). as its negation of true value, need to swap our result flag */ 104385 auvok = !auvok; 104385 result_good = 1; } } } 16249657 if (result_good) { 16249656 SP--; 16249656 if (auvok) 16134967 SETu( result ); else { /* Negate result */ 114689 if (result <= (UV)IV_MIN) 114682 SETi( -(IV)result ); else { /* result valid, but out of range for IV. */ 7 SETn( -(NV)result ); } } 16249656 RETURN; } /* Overflow, drop through to NVs. */ } } #endif 380186 useleft = USE_LEFT(TOPm1s); { 380186 dPOPnv; 380186 if (!useleft) { /* left operand is undef, treat as zero - value */ 3 SETn(-value); 3 RETURN; } 380183 SETn( TOPn - value ); 380183 RETURN; } } PP(pp_left_shift) 15069 { 15069 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN); { 15013 const IV shift = POPi; 15013 if (PL_op->op_private & HINT_INTEGER) { 5 IV i = TOPi; 5 SETi(i << shift); } else { 15008 UV u = TOPu; 15008 SETu(u << shift); } 15013 RETURN; } } PP(pp_right_shift) 25405 { 25405 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN); { 25344 const IV shift = POPi; 25344 if (PL_op->op_private & HINT_INTEGER) { 5 IV i = TOPi; 5 SETi(i >> shift); } else { 25339 UV u = TOPu; 25339 SETu(u >> shift); } 25343 RETURN; } } PP(pp_lt) 15370863 { 15370863 dSP; tryAMAGICbinSET(lt,0); #ifdef PERL_PRESERVE_IVUV 15370825 SvIV_please(TOPs); 15370825 if (SvIOK(TOPs)) { 15284112 SvIV_please(TOPm1s); 15284112 if (SvIOK(TOPm1s)) { 15260279 bool auvok = SvUOK(TOPm1s); 15260279 bool buvok = SvUOK(TOPs); 15260279 if (!auvok && !buvok) { /* ## IV < IV ## */ 15256923 const IV aiv = SvIVX(TOPm1s); 15256923 const IV biv = SvIVX(TOPs); 15256923 SP--; 15256923 SETs(boolSV(aiv < biv)); 15256923 RETURN; } 3356 if (auvok && buvok) { /* ## UV < UV ## */ 92 const UV auv = SvUVX(TOPm1s); 92 const UV buv = SvUVX(TOPs); 92 SP--; 92 SETs(boolSV(auv < buv)); 92 RETURN; } 3264 if (auvok) { /* ## UV < IV ## */ 1998 UV auv; 1998 const IV biv = SvIVX(TOPs); 1998 SP--; 1998 if (biv < 0) { /* As (a) is a UV, it's >=0, so it cannot be < */ 10 SETs(&PL_sv_no); 10 RETURN; } 1988 auv = SvUVX(TOPs); 1988 SETs(boolSV(auv < (UV)biv)); 1988 RETURN; } { /* ## IV < UV ## */ 1266 const IV aiv = SvIVX(TOPm1s); 1266 UV buv; 1266 if (aiv < 0) { /* As (b) is a UV, it's >=0, so it must be < */ 8 SP--; 8 SETs(&PL_sv_yes); 8 RETURN; } 1258 buv = SvUVX(TOPs); 1258 SP--; 1258 SETs(boolSV((UV)aiv < buv)); 1258 RETURN; } } } #endif #ifndef NV_PRESERVES_UV #ifdef PERL_PRESERVE_IVUV else #endif if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { SP--; SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s))); RETURN; } #endif { 110546 dPOPnv; 110546 SETs(boolSV(TOPn < value)); 110546 RETURN; } } PP(pp_gt) 1574568 { 1574568 dSP; tryAMAGICbinSET(gt,0); #ifdef PERL_PRESERVE_IVUV 1574521 SvIV_please(TOPs); 1574521 if (SvIOK(TOPs)) { 1440172 SvIV_please(TOPm1s); 1440172 if (SvIOK(TOPm1s)) { 1434282 bool auvok = SvUOK(TOPm1s); 1434282 bool buvok = SvUOK(TOPs); 1434282 if (!auvok && !buvok) { /* ## IV > IV ## */ 1433079 const IV aiv = SvIVX(TOPm1s); 1433079 const IV biv = SvIVX(TOPs); 1433079 SP--; 1433079 SETs(boolSV(aiv > biv)); 1433079 RETURN; } 1203 if (auvok && buvok) { /* ## UV > UV ## */ 26 const UV auv = SvUVX(TOPm1s); 26 const UV buv = SvUVX(TOPs); 26 SP--; 26 SETs(boolSV(auv > buv)); 26 RETURN; } 1177 if (auvok) { /* ## UV > IV ## */ 52 UV auv; 52 const IV biv = SvIVX(TOPs); 52 SP--; 52 if (biv < 0) { /* As (a) is a UV, it's >=0, so it must be > */ 8 SETs(&PL_sv_yes); 8 RETURN; } 44 auv = SvUVX(TOPs); 44 SETs(boolSV(auv > (UV)biv)); 44 RETURN; } { /* ## IV > UV ## */ 1125 const IV aiv = SvIVX(TOPm1s); 1125 UV buv; 1125 if (aiv < 0) { /* As (b) is a UV, it's >=0, so it cannot be > */ 9 SP--; 9 SETs(&PL_sv_no); 9 RETURN; } 1116 buv = SvUVX(TOPs); 1116 SP--; 1116 SETs(boolSV((UV)aiv > buv)); 1116 RETURN; } } } #endif #ifndef NV_PRESERVES_UV #ifdef PERL_PRESERVE_IVUV else #endif if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { SP--; SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s))); RETURN; } #endif { 140239 dPOPnv; 140239 SETs(boolSV(TOPn > value)); 140239 RETURN; } } PP(pp_le) 2039569 { 2039569 dSP; tryAMAGICbinSET(le,0); #ifdef PERL_PRESERVE_IVUV 2039550 SvIV_please(TOPs); 2039550 if (SvIOK(TOPs)) { 1833079 SvIV_please(TOPm1s); 1833079 if (SvIOK(TOPm1s)) { 1832961 bool auvok = SvUOK(TOPm1s); 1832961 bool buvok = SvUOK(TOPs); 1832961 if (!auvok && !buvok) { /* ## IV <= IV ## */ 1832851 const IV aiv = SvIVX(TOPm1s); 1832851 const IV biv = SvIVX(TOPs); 1832851 SP--; 1832851 SETs(boolSV(aiv <= biv)); 1832851 RETURN; } 110 if (auvok && buvok) { /* ## UV <= UV ## */ 10 UV auv = SvUVX(TOPm1s); 10 UV buv = SvUVX(TOPs); 10 SP--; 10 SETs(boolSV(auv <= buv)); 10 RETURN; } 100 if (auvok) { /* ## UV <= IV ## */ 42 UV auv; 42 const IV biv = SvIVX(TOPs); 42 SP--; 42 if (biv < 0) { /* As (a) is a UV, it's >=0, so a cannot be <= */ 8 SETs(&PL_sv_no); 8 RETURN; } 34 auv = SvUVX(TOPs); 34 SETs(boolSV(auv <= (UV)biv)); 34 RETURN; } { /* ## IV <= UV ## */ 58 const IV aiv = SvIVX(TOPm1s); 58 UV buv; 58 if (aiv < 0) { /* As (b) is a UV, it's >=0, so a must be <= */ 8 SP--; 8 SETs(&PL_sv_yes); 8 RETURN; } 50 buv = SvUVX(TOPs); 50 SP--; 50 SETs(boolSV((UV)aiv <= buv)); 50 RETURN; } } } #endif #ifndef NV_PRESERVES_UV #ifdef PERL_PRESERVE_IVUV else #endif if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { SP--; SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s))); RETURN; } #endif { 206589 dPOPnv; 206589 SETs(boolSV(TOPn <= value)); 206589 RETURN; } } PP(pp_ge) 2428266 { 2428266 dSP; tryAMAGICbinSET(ge,0); #ifdef PERL_PRESERVE_IVUV 2428232 SvIV_please(TOPs); 2428232 if (SvIOK(TOPs)) { 2421831 SvIV_please(TOPm1s); 2421831 if (SvIOK(TOPm1s)) { 2406236 bool auvok = SvUOK(TOPm1s); 2406236 bool buvok = SvUOK(TOPs); 2406236 if (!auvok && !buvok) { /* ## IV >= IV ## */ 2406113 const IV aiv = SvIVX(TOPm1s); 2406113 const IV biv = SvIVX(TOPs); 2406113 SP--; 2406113 SETs(boolSV(aiv >= biv)); 2406113 RETURN; } 123 if (auvok && buvok) { /* ## UV >= UV ## */ 10 const UV auv = SvUVX(TOPm1s); 10 const UV buv = SvUVX(TOPs); 10 SP--; 10 SETs(boolSV(auv >= buv)); 10 RETURN; } 113 if (auvok) { /* ## UV >= IV ## */ 65 UV auv; 65 const IV biv = SvIVX(TOPs); 65 SP--; 65 if (biv < 0) { /* As (a) is a UV, it's >=0, so it must be >= */ 8 SETs(&PL_sv_yes); 8 RETURN; } 57 auv = SvUVX(TOPs); 57 SETs(boolSV(auv >= (UV)biv)); 57 RETURN; } { /* ## IV >= UV ## */ 48 const IV aiv = SvIVX(TOPm1s); 48 UV buv; 48 if (aiv < 0) { /* As (b) is a UV, it's >=0, so a cannot be >= */ 8 SP--; 8 SETs(&PL_sv_no); 8 RETURN; } 40 buv = SvUVX(TOPs); 40 SP--; 40 SETs(boolSV((UV)aiv >= buv)); 40 RETURN; } } } #endif #ifndef NV_PRESERVES_UV #ifdef PERL_PRESERVE_IVUV else #endif if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { SP--; SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s))); RETURN; } #endif { 21996 dPOPnv; 21996 SETs(boolSV(TOPn >= value)); 21996 RETURN; } } PP(pp_ne) 840062 { 840062 dSP; tryAMAGICbinSET(ne,0); #ifndef NV_PRESERVES_UV if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { SP--; SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s))); RETURN; } #endif #ifdef PERL_PRESERVE_IVUV 840046 SvIV_please(TOPs); 840046 if (SvIOK(TOPs)) { 315923 SvIV_please(TOPm1s); 315923 if (SvIOK(TOPm1s)) { 315531 bool auvok = SvUOK(TOPm1s); 315531 bool buvok = SvUOK(TOPs); 315531 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */ /* Casting IV to UV before comparison isn't going to matter on 2s complement. On 1s complement or sign&magnitude (if we have any of them) it could make negative zero differ from normal zero. As I understand it. (Need to check - is negative zero implementation defined behaviour anyway?). NWC */ 315434 const UV buv = SvUVX(POPs); 315434 const UV auv = SvUVX(TOPs); 315434 SETs(boolSV(auv != buv)); 315434 RETURN; } { /* ## Mixed IV,UV ## */ 97 IV iv; 97 UV uv; /* != is commutative so swap if needed (save code) */ 97 if (auvok) { /* swap. top of stack (b) is the iv */ 34 iv = SvIVX(TOPs); 34 SP--; 34 if (iv < 0) { /* As (a) is a UV, it's >0, so it cannot be == */ 10 SETs(&PL_sv_yes); 10 RETURN; } 24 uv = SvUVX(TOPs); } else { 63 iv = SvIVX(TOPm1s); 63 SP--; 63 if (iv < 0) { /* As (b) is a UV, it's >0, so it cannot be == */ 8 SETs(&PL_sv_yes); 8 RETURN; } 55 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */ } 79 SETs(boolSV((UV)iv != uv)); 79 RETURN; } } } #endif { 524515 dPOPnv; 524515 SETs(boolSV(TOPn != value)); 524515 RETURN; } } PP(pp_ncmp) 1404221 { 1404221 dSP; dTARGET; tryAMAGICbin(ncmp,0); #ifndef NV_PRESERVES_UV if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { UV right = PTR2UV(SvRV(POPs)); UV left = PTR2UV(SvRV(TOPs)); SETi((left > right) - (left < right)); RETURN; } #endif #ifdef PERL_PRESERVE_IVUV /* Fortunately it seems NaN isn't IOK */ 1403782 SvIV_please(TOPs); 1403782 if (SvIOK(TOPs)) { 1403151 SvIV_please(TOPm1s); 1403151 if (SvIOK(TOPm1s)) { 1402915 const bool leftuvok = SvUOK(TOPm1s); 1402915 const bool rightuvok = SvUOK(TOPs); 1402915 I32 value; 1402915 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */ 1402635 const IV leftiv = SvIVX(TOPm1s); 1402635 const IV rightiv = SvIVX(TOPs); 1402635 if (leftiv > rightiv) 139430 value = 1; 1263205 else if (leftiv < rightiv) 372845 value = -1; else 890360 value = 0; 280 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */ 20 const UV leftuv = SvUVX(TOPm1s); 20 const UV rightuv = SvUVX(TOPs); 20 if (leftuv > rightuv) 5 value = 1; 15 else if (leftuv < rightuv) 5 value = -1; else 10 value = 0; 260 } else if (leftuvok) { /* ## UV <=> IV ## */ 180 const IV rightiv = SvIVX(TOPs); 180 if (rightiv < 0) { /* As (a) is a UV, it's >=0, so it cannot be < */ 16 value = 1; } else { 164 const UV leftuv = SvUVX(TOPm1s); 164 if (leftuv > (UV)rightiv) { 164 value = 1; ###### } else if (leftuv < (UV)rightiv) { ###### value = -1; } else { ###### value = 0; } } } else { /* ## IV <=> UV ## */ 80 const IV leftiv = SvIVX(TOPm1s); 80 if (leftiv < 0) { /* As (b) is a UV, it's >=0, so it must be < */ 16 value = -1; } else { 64 const UV rightuv = SvUVX(TOPs); 64 if ((UV)leftiv > rightuv) { ###### value = 1; 64 } else if ((UV)leftiv < rightuv) { 64 value = -1; } else { ###### value = 0; } } } 1402915 SP--; 1402915 SETi(value); 1402915 RETURN; } } #endif { 867 dPOPTOPnnrl; 867 I32 value; #ifdef Perl_isnan 867 if (Perl_isnan(left) || Perl_isnan(right)) { ###### SETs(&PL_sv_undef); ###### RETURN; } 867 value = (left > right) - (left < right); #else if (left == right) value = 0; else if (left < right) value = -1; else if (left > right) value = 1; else { SETs(&PL_sv_undef); RETURN; } #endif 867 SETi(value); 867 RETURN; } } PP(pp_slt) 2838 { 2838 dSP; tryAMAGICbinSET(slt,0); { 2831 dPOPTOPssrl; 2831 const int cmp = (IN_LOCALE_RUNTIME ? sv_cmp_locale(left, right) 2831 : sv_cmp(left, right)); 2831 SETs(boolSV(cmp < 0)); 2831 RETURN; } } PP(pp_sgt) 861 { 861 dSP; tryAMAGICbinSET(sgt,0); { 853 dPOPTOPssrl; 853 const int cmp = (IN_LOCALE_RUNTIME ? sv_cmp_locale(left, right) 853 : sv_cmp(left, right)); 853 SETs(boolSV(cmp > 0)); 853 RETURN; } } PP(pp_sle) 52469 { 52469 dSP; tryAMAGICbinSET(sle,0); { 52469 dPOPTOPssrl; 52469 const int cmp = (IN_LOCALE_RUNTIME ? sv_cmp_locale(left, right) 52469 : sv_cmp(left, right)); 52469 SETs(boolSV(cmp <= 0)); 52469 RETURN; } } PP(pp_sge) 6121 { 6121 dSP; tryAMAGICbinSET(sge,0); { 6121 dPOPTOPssrl; 6121 const int cmp = (IN_LOCALE_RUNTIME ? sv_cmp_locale(left, right) 6121 : sv_cmp(left, right)); 6121 SETs(boolSV(cmp >= 0)); 6121 RETURN; } } PP(pp_seq) 3579359 { 3579359 dSP; tryAMAGICbinSET(seq,0); { 3566863 dPOPTOPssrl; 3566863 SETs(boolSV(sv_eq(left, right))); 3566863 RETURN; } } PP(pp_sne) 235180 { 235180 dSP; tryAMAGICbinSET(sne,0); { 235171 dPOPTOPssrl; 235171 SETs(boolSV(!sv_eq(left, right))); 235171 RETURN; } } PP(pp_scmp) 1767764 { 1767764 dSP; dTARGET; tryAMAGICbin(scmp,0); { 1767753 dPOPTOPssrl; 1767753 const int cmp = (IN_LOCALE_RUNTIME ? sv_cmp_locale(left, right) 1767753 : sv_cmp(left, right)); 1767753 SETi( cmp ); 1767753 RETURN; } } PP(pp_bit_and) 460155 { 460155 dSP; dATARGET; tryAMAGICbin(band,opASSIGN); { 460012 dPOPTOPssrl; 460012 if (SvGMAGICAL(left)) mg_get(left); 460012 if (SvGMAGICAL(right)) mg_get(right); 460012 if (SvNIOKp(left) || SvNIOKp(right)) { 456076 if (PL_op->op_private & HINT_INTEGER) { 639 const IV i = SvIV_nomg(left) & SvIV_nomg(right); 639 SETi(i); } else { 455437 const UV u = SvUV_nomg(left) & SvUV_nomg(right); 455437 SETu(u); } } else { 3936 do_vop(PL_op->op_type, TARG, left, right); 3936 SETTARG; } 460012 RETURN; } } PP(pp_bit_xor) 26116 { 26116 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN); { 25914 dPOPTOPssrl; 25914 if (SvGMAGICAL(left)) mg_get(left); 25914 if (SvGMAGICAL(right)) mg_get(right); 25914 if (SvNIOKp(left) || SvNIOKp(right)) { 25851 if (PL_op->op_private & HINT_INTEGER) { 669 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right); 669 SETi(i); } else { 25182 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right); 25182 SETu(u); } } else { 63 do_vop(PL_op->op_type, TARG, left, right); 63 SETTARG; } 25914 RETURN; } } PP(pp_bit_or) 84360 { 84360 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN); { 84155 dPOPTOPssrl; 84155 if (SvGMAGICAL(left)) mg_get(left); 84155 if (SvGMAGICAL(right)) mg_get(right); 84155 if (SvNIOKp(left) || SvNIOKp(right)) { 53644 if (PL_op->op_private & HINT_INTEGER) { 669 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right); 669 SETi(i); } else { 52975 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right); 52975 SETu(u); } } else { 30511 do_vop(PL_op->op_type, TARG, left, right); 30511 SETTARG; } 84155 RETURN; } } PP(pp_negate) 1397792 { 1397792 dSP; dTARGET; tryAMAGICun(neg); { 1397681 dTOPss; 1397681 const int flags = SvFLAGS(sv); 1397681 if (SvGMAGICAL(sv)) ###### mg_get(sv); 1397681 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { /* It's publicly an integer, or privately an integer-not-float */ oops_its_an_int: 1354940 if (SvIsUV(sv)) { 111 if (SvIVX(sv) == IV_MIN) { /* 2s complement assumption. */ 78 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */ 78 RETURN; } 33 else if (SvUVX(sv) <= IV_MAX) { ###### SETi(-SvIVX(sv)); ###### RETURN; } } 1354829 else if (SvIVX(sv) != IV_MIN) { 1354829 SETi(-SvIVX(sv)); 1354829 RETURN; } #ifdef PERL_PRESERVE_IVUV else { ###### SETu((UV)IV_MIN); ###### RETURN; } #endif } 42778 if (SvNIOKp(sv)) 876 SETn(-SvNV(sv)); 41902 else if (SvPOKp(sv)) { 41897 STRLEN len; 41897 const char *s = SvPV_const(sv, len); 41897 if (isIDFIRST(*s)) { 41893 sv_setpvn(TARG, "-", 1); 41893 sv_catsv(TARG, sv); } 4 else if (*s == '+' || *s == '-') { ###### sv_setsv(TARG, sv); ###### *SvPV_force(TARG, len) = *s == '-' ? '+' : '-'; } 4 else if (DO_UTF8(sv)) { 2 SvIV_please(sv); 2 if (SvIOK(sv)) 2 goto oops_its_an_int; ###### if (SvNOK(sv)) ###### sv_setnv(TARG, -SvNV(sv)); else { ###### sv_setpvn(TARG, "-", 1); ###### sv_catsv(TARG, sv); } } else { 2 SvIV_please(sv); 2 if (SvIOK(sv)) 2 goto oops_its_an_int; ###### sv_setnv(TARG, -SvNV(sv)); } 41893 SETTARG; } else 5 SETn(-SvNV(sv)); } 42774 RETURN; } PP(pp_not) 2822664 { 2822664 dSP; tryAMAGICunSET(not); 2822659 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp)); 2822659 return NORMAL; } PP(pp_complement) 63607 { 63607 dSP; dTARGET; tryAMAGICun(compl); { 63584 dTOPss; 63584 if (SvGMAGICAL(sv)) 3 mg_get(sv); 63584 if (SvNIOKp(sv)) { 26551 if (PL_op->op_private & HINT_INTEGER) { 3 const IV i = ~SvIV_nomg(sv); 3 SETi(i); } else { 26548 const UV u = ~SvUV_nomg(sv); 26548 SETu(u); } } else { 37033 register U8 *tmps; 37033 register I32 anum; 37033 STRLEN len; 37033 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */ 37033 sv_setsv_nomg(TARG, sv); 37033 tmps = (U8*)SvPV_force(TARG, len); 37033 anum = len; 37033 if (SvUTF8(TARG)) { /* Calculate exact length, let's not estimate. */ 25198 STRLEN targlen = 0; 25198 U8 *result; 25198 U8 *send; 25198 STRLEN l; 25198 UV nchar = 0; 25198 UV nwide = 0; 25198 send = tmps + len; 61378 while (tmps < send) { 36180 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV); 36180 tmps += UTF8SKIP(tmps); 36180 targlen += UNISKIP(~c); 36180 nchar++; 36180 if (c > 0xff) 31315 nwide++; } /* Now rewind strings and write them. */ 25198 tmps -= len; 25198 if (nwide) { 25197 Newz(0, result, targlen + 1, U8); 61376 while (tmps < send) { 36179 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV); 36179 tmps += UTF8SKIP(tmps); 36179 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY); } 25197 *result = '\0'; 25197 result -= targlen; 25197 sv_setpvn(TARG, (char*)result, targlen); 25197 SvUTF8_on(TARG); } else { 1 Newz(0, result, nchar + 1, U8); 2 while (tmps < send) { 1 const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY); 1 tmps += UTF8SKIP(tmps); 1 *result++ = ~c; } 1 *result = '\0'; 1 result -= nchar; 1 sv_setpvn(TARG, (char*)result, nchar); 1 SvUTF8_off(TARG); } 25198 Safefree(result); 25198 SETs(TARG); 25198 RETURN; } #ifdef LIBERAL { 11835 register long *tmpl; 11835 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++) ###### *tmps = ~*tmps; 11835 tmpl = (long*)tmps; 63535 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++) 25850 *tmpl = ~*tmpl; 11835 tmps = (U8*)tmpl; } #endif 12689 for ( ; anum > 0; anum--, tmps++) 427 *tmps = ~*tmps; 11835 SETs(TARG); } 38386 RETURN; } } /* integer versions of some of the above */ PP(pp_i_multiply) 281 { 281 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN); { 281 dPOPTOPiirl; 281 SETi( left * right ); 281 RETURN; } } PP(pp_i_divide) 119 { 119 dSP; dATARGET; tryAMAGICbin(div,opASSIGN); { 119 dPOPiv; 119 if (value == 0) 1 DIE(aTHX_ "Illegal division by zero"); 118 value = POPi / value; 118 PUSHi( value ); 118 RETURN; } } STATIC PP(pp_i_modulo_0) 404 { /* This is the vanilla old i_modulo. */ 404 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { 404 dPOPTOPiirl; 404 if (!right) ###### DIE(aTHX_ "Illegal modulus zero"); 404 SETi( left % right ); 404 RETURN; } } #if defined(__GLIBC__) && IVSIZE == 8 STATIC PP(pp_i_modulo_1) { /* This is the i_modulo with the workaround for the _moddi3 bug * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround). * See below for pp_i_modulo. */ dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { dPOPTOPiirl; if (!right) DIE(aTHX_ "Illegal modulus zero"); SETi( left % PERL_ABS(right) ); RETURN; } } #endif PP(pp_i_modulo) 49 { 49 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); { 49 dPOPTOPiirl; 49 if (!right) 1 DIE(aTHX_ "Illegal modulus zero"); /* The assumption is to use hereafter the old vanilla version... */ 48 PL_op->op_ppaddr = PL_ppaddr[OP_I_MODULO] = Perl_pp_i_modulo_0; /* .. but if we have glibc, we might have a buggy _moddi3 * (at least glicb 2.2.5 is known to have this bug), in other * words our integer modulus with negative quad as the second * argument might be broken. Test for this and re-patch the * opcode dispatch table if that is the case, remembering to * also apply the workaround so that this first round works * right, too. See [perl #9402] for more information. */ #if defined(__GLIBC__) && IVSIZE == 8 { IV l = 3; IV r = -10; /* Cannot do this check with inlined IV constants since * that seems to work correctly even with the buggy glibc. */ if (l % r == -3) { /* Yikes, we have the bug. * Patch in the workaround version. */ PL_op->op_ppaddr = PL_ppaddr[OP_I_MODULO] = &Perl_pp_i_modulo_1; /* Make certain we work right this time, too. */ right = PERL_ABS(right); } } #endif 48 SETi( left % right ); 48 RETURN; } } PP(pp_i_add) 23114 { 23114 dSP; dATARGET; tryAMAGICbin(add,opASSIGN); { 23114 dPOPTOPiirl_ul; 23114 SETi( left + right ); 23114 RETURN; } } PP(pp_i_subtract) 2277 { 2277 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN); { 2277 dPOPTOPiirl_ul; 2277 SETi( left - right ); 2277 RETURN; } } PP(pp_i_lt) 3915 { 3915 dSP; tryAMAGICbinSET(lt,0); { 3915 dPOPTOPiirl; 3915 SETs(boolSV(left < right)); 3915 RETURN; } } PP(pp_i_gt) 790 { 790 dSP; tryAMAGICbinSET(gt,0); { 790 dPOPTOPiirl; 790 SETs(boolSV(left > right)); 790 RETURN; } } PP(pp_i_le) 206 { 206 dSP; tryAMAGICbinSET(le,0); { 206 dPOPTOPiirl; 206 SETs(boolSV(left <= right)); 206 RETURN; } } PP(pp_i_ge) 219 { 219 dSP; tryAMAGICbinSET(ge,0); { 219 dPOPTOPiirl; 219 SETs(boolSV(left >= right)); 219 RETURN; } } PP(pp_i_eq) 3687 { 3687 dSP; tryAMAGICbinSET(eq,0); { 3687 dPOPTOPiirl; 3687 SETs(boolSV(left == right)); 3687 RETURN; } } PP(pp_i_ne) 46 { 46 dSP; tryAMAGICbinSET(ne,0); { 46 dPOPTOPiirl; 46 SETs(boolSV(left != right)); 46 RETURN; } } PP(pp_i_ncmp) 5 { 5 dSP; dTARGET; tryAMAGICbin(ncmp,0); { 5 dPOPTOPiirl; 5 I32 value; 5 if (left > right) ###### value = 1; 5 else if (left < right) ###### value = -1; else 5 value = 0; 5 SETi(value); 5 RETURN; } } PP(pp_i_negate) 86 { 86 dSP; dTARGET; tryAMAGICun(neg); 86 SETi(-TOPi); 86 RETURN; } /* High falutin' math. */ PP(pp_atan2) 974 { 974 dSP; dTARGET; tryAMAGICbin(atan2,0); { 968 dPOPTOPnnrl; 968 SETn(Perl_atan2(left, right)); 968 RETURN; } } PP(pp_sin) 1570 { 1570 dSP; dTARGET; tryAMAGICun(sin); { 1506 const NV value = POPn; 1506 XPUSHn(Perl_sin(value)); 1506 RETURN; } } PP(pp_cos) 1537 { 1537 dSP; dTARGET; tryAMAGICun(cos); { 1473 const NV value = POPn; 1473 XPUSHn(Perl_cos(value)); 1473 RETURN; } } /* Support Configure command-line overrides for rand() functions. After 5.005, perhaps we should replace this by Configure support for drand48(), random(), or rand(). For 5.005, though, maintain compatibility by calling rand() but allow the user to override it. See INSTALL for details. --Andy Dougherty 15 July 1998 */ /* Now it's after 5.005, and Configure supports drand48() and random(), in addition to rand(). So the overrides should not be needed any more. --Jarkko Hietaniemi 27 September 1998 */ #ifndef HAS_DRAND48_PROTO extern double drand48 (void); #endif PP(pp_rand) 390198 { 390198 dSP; dTARGET; 390198 NV value; 390198 if (MAXARG < 1) 48367 value = 1.0; else 341831 value = POPn; 390198 if (value == 0.0) 1 value = 1.0; 390198 if (!PL_srand_called) { 35 (void)seedDrand01((Rand_seed_t)seed()); 35 PL_srand_called = TRUE; } 390198 value *= Drand01(); 390198 XPUSHn(value); 390198 RETURN; } PP(pp_srand) 21 { 21 dSP; 21 UV anum; 21 if (MAXARG < 1) 4 anum = seed(); else 17 anum = POPu; 21 (void)seedDrand01((Rand_seed_t)anum); 21 PL_srand_called = TRUE; 21 EXTEND(SP, 1); 21 RETPUSHYES; } PP(pp_exp) 1039 { 1039 dSP; dTARGET; tryAMAGICun(exp); { 959 NV value; 959 value = POPn; 959 value = Perl_exp(value); 959 XPUSHn(value); 959 RETURN; } } PP(pp_log) 860 { 860 dSP; dTARGET; tryAMAGICun(log); { 860 const NV value = POPn; 860 if (value <= 0.0) { 2 SET_NUMERIC_STANDARD(); 2 DIE(aTHX_ "Can't take log of %"NVgf, value); } 858 XPUSHn(Perl_log(value)); 858 RETURN; } } PP(pp_sqrt) 1320229 { 1320229 dSP; dTARGET; tryAMAGICun(sqrt); { 1320218 const NV value = POPn; 1320218 if (value < 0.0) { ###### SET_NUMERIC_STANDARD(); ###### DIE(aTHX_ "Can't take sqrt of %"NVgf, value); } 1320218 XPUSHn(Perl_sqrt(value)); 1320218 RETURN; } } PP(pp_int) 831612 { 831612 dSP; dTARGET; tryAMAGICun(int); { 831554 const IV iv = TOPi; /* attempt to convert to IV if possible. */ /* XXX it's arguable that compiler casting to IV might be subtly different from modf (for numbers inside (IV_MIN,UV_MAX)) in which else preferring IV has introduced a subtle behaviour change bug. OTOH relying on floating point to be accurate is a bug. */ 831554 if (!SvOK(TOPs)) 1 SETu(0); 831553 else if (SvIOK(TOPs)) { 210821 if (SvIsUV(TOPs)) { 62 const UV uv = TOPu; 62 SETu(uv); } else 210759 SETi(iv); } else { 620732 const NV value = TOPn; 620732 if (value >= 0.0) { 620223 if (value < (NV)UV_MAX + 0.5) { 619585 SETu(U_V(value)); } else { 638 SETn(Perl_floor(value)); } } else { 509 if (value > (NV)IV_MIN - 0.5) { 508 SETi(I_V(value)); } else { 1 SETn(Perl_ceil(value)); } } } } 831554 RETURN; } PP(pp_abs) 7520 { 7520 dSP; dTARGET; tryAMAGICun(abs); { /* This will cache the NV value if string isn't actually integer */ 6726 const IV iv = TOPi; 6726 if (!SvOK(TOPs)) 1 SETu(0); 6725 else if (SvIOK(TOPs)) { /* IVX is precise */ 6426 if (SvIsUV(TOPs)) { ###### SETu(TOPu); /* force it to be numeric only */ } else { 6426 if (iv >= 0) { 5725 SETi(iv); } else { 701 if (iv != IV_MIN) { 701 SETi(-iv); } else { /* 2s complement assumption. Also, not really needed as IV_MIN and -IV_MIN should both be %100...00 and NV-able */ ###### SETu(IV_MIN); } } } } else{ 299 const NV value = TOPn; 299 if (value < 0.0) 56 SETn(value); else 243 SETn(-value); } } 6726 RETURN; } PP(pp_hex) 1901780 { 1901780 dSP; dTARGET; 1901780 const char *tmps; 1901780 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; 1901780 STRLEN len; 1901780 NV result_nv; 1901780 UV result_uv; 1901780 SV* const sv = POPs; 1901780 tmps = (SvPV_const(sv, len)); 1901780 if (DO_UTF8(sv)) { /* If Unicode, try to downgrade * If not possible, croak. */ 499 SV* const tsv = sv_2mortal(newSVsv(sv)); 499 SvUTF8_on(tsv); 499 sv_utf8_downgrade(tsv, FALSE); 498 tmps = SvPV_const(tsv, len); } 1901779 result_uv = grok_hex (tmps, &len, &flags, &result_nv); 1901779 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) { 4 XPUSHn(result_nv); } else { 1901775 XPUSHu(result_uv); } 1901779 RETURN; } PP(pp_oct) 2965 { 2965 dSP; dTARGET; 2965 const char *tmps; 2965 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES; 2965 STRLEN len; 2965 NV result_nv; 2965 UV result_uv; 2965 SV* const sv = POPs; 2965 tmps = (SvPV_const(sv, len)); 2965 if (DO_UTF8(sv)) { /* If Unicode, try to downgrade * If not possible, croak. */ 1 SV* const tsv = sv_2mortal(newSVsv(sv)); 1 SvUTF8_on(tsv); 1 sv_utf8_downgrade(tsv, FALSE); ###### tmps = SvPV_const(tsv, len); } 3291 while (*tmps && len && isSPACE(*tmps)) 327 tmps++, len--; 2964 if (*tmps == '0') 2676 tmps++, len--; 2964 if (*tmps == 'x') 29 result_uv = grok_hex (tmps, &len, &flags, &result_nv); 2935 else if (*tmps == 'b') 1754 result_uv = grok_bin (tmps, &len, &flags, &result_nv); else 1181 result_uv = grok_oct (tmps, &len, &flags, &result_nv); 2964 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) { 23 XPUSHn(result_nv); } else { 2941 XPUSHu(result_uv); } 2964 RETURN; } /* String stuff. */ PP(pp_length) 4759384 { 4759384 dSP; dTARGET; 4759384 SV *sv = TOPs; 4759384 if (DO_UTF8(sv)) 45456 SETi(sv_len_utf8(sv)); else 4713928 SETi(sv_len(sv)); 4759384 RETURN; } PP(pp_substr) 4326917 { 4326917 dSP; dTARGET; 4326917 SV *sv; 4326917 I32 len = 0; 4326917 STRLEN curlen; 4326917 STRLEN utf8_curlen; 4326917 I32 pos; 4326917 I32 rem; 4326917 I32 fail; 4326917 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; 4326917 const char *tmps; 4326917 const I32 arybase = PL_curcop->cop_arybase; 4326917 SV *repl_sv = NULL; 4326917 const char *repl = 0; 4326917 STRLEN repl_len; 4326917 const int num_args = PL_op->op_private & 7; 4326917 bool repl_need_utf8_upgrade = FALSE; 4326917 bool repl_is_utf8 = FALSE; 4326917 SvTAINTED_off(TARG); /* decontaminate */ 4326917 SvUTF8_off(TARG); /* decontaminate */ 4326917 if (num_args > 2) { 2736248 if (num_args > 3) { 7971 repl_sv = POPs; 7971 repl = SvPV_const(repl_sv, repl_len); 7971 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv); } 2736248 len = POPi; } 4326917 pos = POPi; 4326917 sv = POPs; 4326917 PUTBACK; 4326917 if (repl_sv) { 7971 if (repl_is_utf8) { 13 if (!DO_UTF8(sv)) 6 sv_utf8_upgrade(sv); } 7958 else if (DO_UTF8(sv)) 145 repl_need_utf8_upgrade = TRUE; } 4326917 tmps = SvPV_const(sv, curlen); 4326917 if (DO_UTF8(sv)) { 4605 utf8_curlen = sv_len_utf8(sv); 4605 if (utf8_curlen == curlen) 36 utf8_curlen = 0; else 4569 curlen = utf8_curlen; } else 4322312 utf8_curlen = 0; 4326917 if (pos >= arybase) { 2772769 pos -= arybase; 2772769 rem = curlen-pos; 2772769 fail = rem; 2772769 if (num_args > 2) { 1319007 if (len < 0) { 2388 rem += len; 2388 if (rem < 0) 15 rem = 0; } 1316619 else if (rem > len) 1309786 rem = len; } } else { 1554148 pos += curlen; 1554148 if (num_args < 3) 136907 rem = curlen; 1417241 else if (len >= 0) { 1417223 rem = pos+len; 1417223 if (rem > (I32)curlen) 4 rem = curlen; } else { 18 rem = curlen+len; 18 if (rem < pos) 4 rem = pos; } 1554148 if (pos < 0) 2190 pos = 0; 1554148 fail = rem; 1554148 rem -= pos; } 4326917 if (fail < 0) { 41 if (lvalue || repl) 19 Perl_croak(aTHX_ "substr outside of string"); 22 if (ckWARN(WARN_SUBSTR)) 18 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); 22 RETPUSHUNDEF; } else { 4326876 const I32 upos = pos; 4326876 const I32 urem = rem; 4326876 if (utf8_curlen) 4569 sv_pos_u2b(sv, &pos, &rem); 4326876 tmps += pos; /* we either return a PV or an LV. If the TARG hasn't been used * before, or is of that type, reuse it; otherwise use a mortal * instead. Note that LVs can have an extended lifetime, so also * dont reuse if refcount > 1 (bug #20933) */ 4326876 if (SvTYPE(TARG) > SVt_NULL) { 4323324 if ( (SvTYPE(TARG) == SVt_PVLV) ? (!lvalue || SvREFCNT(TARG) > 1) : lvalue) { 1 TARG = sv_newmortal(); } } 4326876 sv_setpvn(TARG, tmps, rem); #ifdef USE_LOCALE_COLLATE 4326876 sv_unmagic(TARG, PERL_MAGIC_collxfrm); #endif 4326876 if (utf8_curlen) 4569 SvUTF8_on(TARG); 4326876 if (repl) { 7969 SV* repl_sv_copy = NULL; 7969 if (repl_need_utf8_upgrade) { 145 repl_sv_copy = newSVsv(repl_sv); 145 sv_utf8_upgrade(repl_sv_copy); 145 repl = SvPV_const(repl_sv_copy, repl_len); 145 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv); } 7969 sv_insert(sv, pos, rem, repl, repl_len); 7969 if (repl_is_utf8) 149 SvUTF8_on(sv); 7969 if (repl_sv_copy) 145 SvREFCNT_dec(repl_sv_copy); } 4318907 else if (lvalue) { /* it's an lvalue! */ 22839 if (!SvGMAGICAL(sv)) { 22819 if (SvROK(sv)) { 2 SvPV_force_nolen(sv); 2 if (ckWARN(WARN_SUBSTR)) 2 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "Attempt to use reference as lvalue in substr"); } 22819 if (SvOK(sv)) /* is it defined ? */ 22815 (void)SvPOK_only_UTF8(sv); else 4 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */ } 22839 if (SvTYPE(TARG) < SVt_PVLV) { 502 sv_upgrade(TARG, SVt_PVLV); 502 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0); } else 22337 SvOK_off(TARG); 22839 LvTYPE(TARG) = 'x'; 22839 if (LvTARG(TARG) != sv) { 19583 if (LvTARG(TARG)) 19081 SvREFCNT_dec(LvTARG(TARG)); 19583 LvTARG(TARG) = SvREFCNT_inc(sv); } 22839 LvTARGOFF(TARG) = upos; 22839 LvTARGLEN(TARG) = urem; } } 4326876 SPAGAIN; 4326876 PUSHs(TARG); /* avoid SvSETMAGIC here */ 4326876 RETURN; } PP(pp_vec) 2308098 { 2308098 dSP; dTARGET; 2308098 register const IV size = POPi; 2308098 register const IV offset = POPi; 2308098 register SV * const src = POPs; 2308098 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET; 2308098 SvTAINTED_off(TARG); /* decontaminate */ 2308098 if (lvalue) { /* it's an lvalue! */ 1937940 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */ 1 TARG = sv_newmortal(); 1937940 if (SvTYPE(TARG) < SVt_PVLV) { 9073 sv_upgrade(TARG, SVt_PVLV); 9073 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0); } 1937940 LvTYPE(TARG) = 'v'; 1937940 if (LvTARG(TARG) != src) { 224597 if (LvTARG(TARG)) 215524 SvREFCNT_dec(LvTARG(TARG)); 224597 LvTARG(TARG) = SvREFCNT_inc(src); } 1937940 LvTARGOFF(TARG) = offset; 1937940 LvTARGLEN(TARG) = size; } 2308098 sv_setuv(TARG, do_vecget(src, offset, size)); 2308093 PUSHs(TARG); 2308093 RETURN; } PP(pp_index) 636005 { 636005 dSP; dTARGET; 636005 SV *big; 636005 SV *little; 636005 SV *temp = Nullsv; 636005 I32 offset; 636005 I32 retval; 636005 const char *tmps; 636005 const char *tmps2; 636005 STRLEN biglen; 636005 const I32 arybase = PL_curcop->cop_arybase; 636005 int big_utf8; 636005 int little_utf8; 636005 if (MAXARG < 3) 322045 offset = 0; else 313960 offset = POPi - arybase; 636005 little = POPs; 636005 big = POPs; 636005 big_utf8 = DO_UTF8(big); 636005 little_utf8 = DO_UTF8(little); 636005 if (big_utf8 ^ little_utf8) { /* One needs to be upgraded. */ 19 SV * const bytes = little_utf8 ? big : little; 19 STRLEN len; 19 const char * const p = SvPV_const(bytes, len); 19 temp = newSVpvn(p, len); 19 if (PL_encoding) { ###### sv_recode_to_utf8(temp, PL_encoding); } else { 19 sv_utf8_upgrade(temp); } 19 if (little_utf8) { 2 big = temp; 2 big_utf8 = TRUE; } else { 17 little = temp; } } 636005 if (big_utf8 && offset > 0) 8 sv_pos_u2b(big, &offset, 0); 636005 tmps = SvPV_const(big, biglen); 636005 if (offset < 0) 1 offset = 0; 636004 else if (offset > (I32)biglen) 2 offset = biglen; 636005 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset, (unsigned char*)tmps + biglen, little, 0))) 173427 retval = -1; else 462578 retval = tmps2 - tmps; 636005 if (retval > 0 && big_utf8) 26 sv_pos_b2u(big, &retval); 636005 if (temp) 19 SvREFCNT_dec(temp); 636005 PUSHi(retval + arybase); 636005 RETURN; } PP(pp_rindex) 286 { 286 dSP; dTARGET; 286 SV *big; 286 SV *little; 286 SV *temp = Nullsv; 286 STRLEN blen; 286 STRLEN llen; 286 I32 offset; 286 I32 retval; 286 const char *tmps; 286 const char *tmps2; 286 const I32 arybase = PL_curcop->cop_arybase; 286 int big_utf8; 286 int little_utf8; 286 if (MAXARG >= 3) 154 offset = POPi; 286 little = POPs; 286 big = POPs; 286 big_utf8 = DO_UTF8(big); 286 little_utf8 = DO_UTF8(little); 286 if (big_utf8 ^ little_utf8) { /* One needs to be upgraded. */ 17 SV * const bytes = little_utf8 ? big : little; 17 STRLEN len; 17 const char *p = SvPV_const(bytes, len); 17 temp = newSVpvn(p, len); 17 if (PL_encoding) { ###### sv_recode_to_utf8(temp, PL_encoding); } else { 17 sv_utf8_upgrade(temp); } 17 if (little_utf8) { 2 big = temp; 2 big_utf8 = TRUE; } else { 15 little = temp; } } 286 tmps2 = SvPV_const(little, llen); 286 tmps = SvPV_const(big, blen); 286 if (MAXARG < 3) 132 offset = blen; else { 154 if (offset > 0 && big_utf8) 7 sv_pos_u2b(big, &offset, 0); 154 offset = offset - arybase + llen; } 286 if (offset < 0) ###### offset = 0; 286 else if (offset > (I32)blen) 3 offset = blen; 286 if (!(tmps2 = rninstr(tmps, tmps + offset, tmps2, tmps2 + llen))) 30 retval = -1; else 256 retval = tmps2 - tmps; 286 if (retval > 0 && big_utf8) 16 sv_pos_b2u(big, &retval); 286 if (temp) 17 SvREFCNT_dec(temp); 286 PUSHi(retval + arybase); 286 RETURN; } PP(pp_sprintf) 357264 { 357264 dSP; dMARK; dORIGMARK; dTARGET; 357264 do_sprintf(TARG, SP-MARK, MARK+1); 357264 TAINT_IF(SvTAINTED(TARG)); 357264 if (DO_UTF8(*(MARK+1))) 12 SvUTF8_on(TARG); 357264 SP = ORIGMARK; 357264 PUSHTARG; 357264 RETURN; } PP(pp_ord) 702891 { 702891 dSP; dTARGET; 702891 SV *argsv = POPs; 702891 STRLEN len; 702891 const U8 *s = (U8*)SvPV_const(argsv, len); 702891 SV *tmpsv; 702891 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) { 1 tmpsv = sv_2mortal(newSVsv(argsv)); 1 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding); 1 argsv = tmpsv; } XPUSHu(DO_UTF8(argsv) ? utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) : 702891 (*s & 0xff)); 702891 RETURN; } PP(pp_chr) 1563274 { 1563274 dSP; dTARGET; 1563274 char *tmps; 1563274 UV value; 1563274 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0) || (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) { 8 if (IN_BYTES) { 4 value = POPu; /* chr(-1) eq chr(0xff), etc. */ } else { 4 (void) POPs; /* Ignore the argument value. */ 4 value = UNICODE_REPLACEMENT; } } else { 1563266 value = POPu; } 1563274 SvUPGRADE(TARG,SVt_PV); 1563274 if (value > 255 && !IN_BYTES) { 818082 SvGROW(TARG, (STRLEN)UNISKIP(value)+1); 818082 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0); 818082 SvCUR_set(TARG, tmps - SvPVX_const(TARG)); 818082 *tmps = '\0'; 818082 (void)SvPOK_only(TARG); 818082 SvUTF8_on(TARG); 818082 XPUSHs(TARG); 818082 RETURN; } 745192 SvGROW(TARG,2); 745192 SvCUR_set(TARG, 1); 745192 tmps = SvPVX(TARG); 745192 *tmps++ = (char)value; 745192 *tmps = '\0'; 745192 (void)SvPOK_only(TARG); 745192 if (PL_encoding && !IN_BYTES) { 13 sv_recode_to_utf8(TARG, PL_encoding); 13 tmps = SvPVX(TARG); 13 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) || memEQ(tmps, "\xef\xbf\xbd\0", 4)) { 6 SvGROW(TARG, 3); 6 tmps = SvPVX(TARG); 6 SvCUR_set(TARG, 2); 6 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value); 6 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value); 6 *tmps = '\0'; 6 SvUTF8_on(TARG); } } 745192 XPUSHs(TARG); 745192 RETURN; } PP(pp_crypt) 8 { #ifdef HAS_CRYPT 8 dSP; dTARGET; 8 dPOPTOPssrl; 8 STRLEN len; 8 const char *tmps = SvPV_const(left, len); 8 if (DO_UTF8(left)) { /* If Unicode, try to downgrade. * If not possible, croak. * Yes, we made this up. */ 2 SV* const tsv = sv_2mortal(newSVsv(left)); 2 SvUTF8_on(tsv); 2 sv_utf8_downgrade(tsv, FALSE); 1 tmps = SvPV_const(tsv, len); } # ifdef USE_ITHREADS # ifdef HAS_CRYPT_R if (!PL_reentrant_buffer->_crypt_struct_buffer) { /* This should be threadsafe because in ithreads there is only * one thread per interpreter. If this would not be true, * we would need a mutex to protect this malloc. */ PL_reentrant_buffer->_crypt_struct_buffer = (struct crypt_data *)safemalloc(sizeof(struct crypt_data)); #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 */ PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0; } #endif } # endif /* HAS_CRYPT_R */ # endif /* USE_ITHREADS */ # ifdef FCRYPT sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right))); # else 7 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right))); # endif 7 SETs(TARG); 7 RETURN; #else DIE(aTHX_ "The crypt() function is unimplemented due to excessive paranoia."); #endif } PP(pp_ucfirst) 5720 { 5720 dSP; 5720 SV *sv = TOPs; 5720 const U8 *s; 5720 STRLEN slen; 5720 SvGETMAGIC(sv); 5720 if (DO_UTF8(sv) && (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen && UTF8_IS_START(*s)) { 936 U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; 936 STRLEN ulen; 936 STRLEN tculen; 936 utf8_to_uvchr(s, &ulen); 936 toTITLE_utf8(s, tmpbuf, &tculen); 936 utf8_to_uvchr(tmpbuf, 0); 936 if (!SvPADTMP(sv) || SvREADONLY(sv)) { 936 dTARGET; /* slen is the byte length of the whole SV. * ulen is the byte length of the original Unicode character * stored as UTF-8 at s. * tculen is the byte length of the freshly titlecased * Unicode character stored as UTF-8 at tmpbuf. * We first set the result to be the titlecased character, * and then append the rest of the SV data. */ 936 sv_setpvn(TARG, (char*)tmpbuf, tculen); 936 if (slen > ulen) 5 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); 936 SvUTF8_on(TARG); 936 SETs(TARG); } else { ###### s = (U8*)SvPV_force_nomg(sv, slen); ###### Copy(tmpbuf, s, tculen, U8); } } else { 4784 U8 *s1; 4784 if (!SvPADTMP(sv) || SvREADONLY(sv)) { 1417 dTARGET; 1417 SvUTF8_off(TARG); /* decontaminate */ 1417 sv_setsv_nomg(TARG, sv); 1417 sv = TARG; 1417 SETs(sv); } 4784 s1 = (U8*)SvPV_force_nomg(sv, slen); 4784 if (*s1) { 4780 if (IN_LOCALE_RUNTIME) { 3 TAINT; 3 SvTAINTED_on(sv); 3 *s1 = toUPPER_LC(*s1); } else 4777 *s1 = toUPPER(*s1); } } 5720 SvSETMAGIC(sv); 5720 RETURN; } PP(pp_lcfirst) 242 { 242 dSP; 242 SV *sv = TOPs; 242 const U8 *s; 242 STRLEN slen; 242 SvGETMAGIC(sv); 242 if (DO_UTF8(sv) && (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen && UTF8_IS_START(*s)) { 5 STRLEN ulen; 5 U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; 5 U8 *tend; 5 UV uv; 5 toLOWER_utf8(s, tmpbuf, &ulen); 5 uv = utf8_to_uvchr(tmpbuf, 0); 5 tend = uvchr_to_utf8(tmpbuf, uv); 5 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) { 5 dTARGET; 5 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf); 5 if (slen > ulen) 5 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen); 5 SvUTF8_on(TARG); 5 SETs(TARG); } else { ###### s = (U8*)SvPV_force_nomg(sv, slen); ###### Copy(tmpbuf, s, ulen, U8); } } else { 237 U8 *s1; 237 if (!SvPADTMP(sv) || SvREADONLY(sv)) { 237 dTARGET; 237 SvUTF8_off(TARG); /* decontaminate */ 237 sv_setsv_nomg(TARG, sv); 237 sv = TARG; 237 SETs(sv); } 237 s1 = (U8*)SvPV_force_nomg(sv, slen); 237 if (*s1) { 235 if (IN_LOCALE_RUNTIME) { 3 TAINT; 3 SvTAINTED_on(sv); 3 *s1 = toLOWER_LC(*s1); } else 232 *s1 = toLOWER(*s1); } } 242 SvSETMAGIC(sv); 242 RETURN; } PP(pp_uc) 950581 { 950581 dSP; 950581 SV *sv = TOPs; 950581 STRLEN len; 950581 SvGETMAGIC(sv); 950581 if (DO_UTF8(sv)) { 1059 dTARGET; 1059 STRLEN ulen; 1059 register U8 *d; 1059 const U8 *s; 1059 const U8 *send; 1059 U8 tmpbuf[UTF8_MAXBYTES+1]; 1059 s = (const U8*)SvPV_nomg_const(sv,len); 1059 if (!len) { ###### SvUTF8_off(TARG); /* decontaminate */ ###### sv_setpvn(TARG, "", 0); ###### SETs(TARG); } else { 1059 STRLEN min = len + 1; 1059 SvUPGRADE(TARG, SVt_PV); 1059 SvGROW(TARG, min); 1059 (void)SvPOK_only(TARG); 1059 d = (U8*)SvPVX(TARG); 1059 send = s + len; 2165 while (s < send) { 1106 STRLEN u = UTF8SKIP(s); 1106 toUPPER_utf8(s, tmpbuf, &ulen); 1106 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) { /* If the eventually required minimum size outgrows * the available space, we need to grow. */ 1 UV o = d - (U8*)SvPVX_const(TARG); /* If someone uppercases one million U+03B0s we * SvGROW() one million times. Or we could try * guessing how much to allocate without allocating * too much. Such is life. */ 1 SvGROW(TARG, min); 1 d = (U8*)SvPVX(TARG) + o; } 1106 Copy(tmpbuf, d, ulen, U8); 1106 d += ulen; 1106 s += u; } 1059 *d = '\0'; 1059 SvUTF8_on(TARG); 1059 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG)); 1059 SETs(TARG); } } else { 949522 U8 *s; 949522 if (!SvPADTMP(sv) || SvREADONLY(sv)) { 948085 dTARGET; 948085 SvUTF8_off(TARG); /* decontaminate */ 948085 sv_setsv_nomg(TARG, sv); 948085 sv = TARG; 948085 SETs(sv); } 949522 s = (U8*)SvPV_force_nomg(sv, len); 949522 if (len) { 949451 const register U8 *send = s + len; 949451 if (IN_LOCALE_RUNTIME) { 896071 TAINT; 896071 SvTAINTED_on(sv); 2688245 for (; s < send; s++) 896087 *s = toUPPER_LC(*s); } else { 829882 for (; s < send; s++) 388251 *s = toUPPER(*s); } } } 950581 SvSETMAGIC(sv); 950581 RETURN; } PP(pp_lc) 1097176 { 1097176 dSP; 1097176 SV *sv = TOPs; 1097176 STRLEN len; 1097176 SvGETMAGIC(sv); 1097176 if (DO_UTF8(sv)) { 1011 dTARGET; 1011 const U8 *s; 1011 STRLEN ulen; 1011 register U8 *d; 1011 const U8 *send; 1011 U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; 1011 s = (const U8*)SvPV_nomg_const(sv,len); 1011 if (!len) { ###### SvUTF8_off(TARG); /* decontaminate */ ###### sv_setpvn(TARG, "", 0); ###### SETs(TARG); } else { 1011 STRLEN min = len + 1; 1011 SvUPGRADE(TARG, SVt_PV); 1011 SvGROW(TARG, min); 1011 (void)SvPOK_only(TARG); 1011 d = (U8*)SvPVX(TARG); 1011 send = s + len; 2357 while (s < send) { 1346 const STRLEN u = UTF8SKIP(s); 1346 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen); #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */ 1346 if (uv == GREEK_CAPITAL_LETTER_SIGMA) { /* * Now if the sigma is NOT followed by * /$ignorable_sequence$cased_letter/; * and it IS preceded by * /$cased_letter$ignorable_sequence/; * where $ignorable_sequence is * [\x{2010}\x{AD}\p{Mn}]* * and $cased_letter is * [\p{Ll}\p{Lo}\p{Lt}] * then it should be mapped to 0x03C2, * (GREEK SMALL LETTER FINAL SIGMA), * instead of staying 0x03A3. * "should be": in other words, * this is not implemented yet. * See lib/unicore/SpecialCasing.txt. */ } 1346 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) { /* If the eventually required minimum size outgrows * the available space, we need to grow. */ ###### UV o = d - (U8*)SvPVX_const(TARG); /* If someone lowercases one million U+0130s we * SvGROW() one million times. Or we could try * guessing how much to allocate without allocating. * too much. Such is life. */ ###### SvGROW(TARG, min); ###### d = (U8*)SvPVX(TARG) + o; } 1346 Copy(tmpbuf, d, ulen, U8); 1346 d += ulen; 1346 s += u; } 1011 *d = '\0'; 1011 SvUTF8_on(TARG); 1011 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG)); 1011 SETs(TARG); } } else { 1096165 U8 *s; 1096165 if (!SvPADTMP(sv) || SvREADONLY(sv)) { 1095013 dTARGET; 1095013 SvUTF8_off(TARG); /* decontaminate */ 1095013 sv_setsv_nomg(TARG, sv); 1095013 sv = TARG; 1095013 SETs(sv); } 1096165 s = (U8*)SvPV_force_nomg(sv, len); 1096165 if (len) { 1095730 register const U8 * const send = s + len; 1095730 if (IN_LOCALE_RUNTIME) { 898170 TAINT; 898170 SvTAINTED_on(sv); 2699428 for (; s < send; s++) 900629 *s = toLOWER_LC(*s); } else { 4095216 for (; s < send; s++) 1948828 *s = toLOWER(*s); } } } 1097176 SvSETMAGIC(sv); 1097176 RETURN; } PP(pp_quotemeta) 6860 { 6860 dSP; dTARGET; 6860 SV * const sv = TOPs; 6860 STRLEN len; 6860 const register char *s = SvPV_const(sv,len); 6860 SvUTF8_off(TARG); /* decontaminate */ 6860 if (len) { 6746 register char *d; 6746 SvUPGRADE(TARG, SVt_PV); 6746 SvGROW(TARG, (len * 2) + 1); 6746 d = SvPVX(TARG); 6746 if (DO_UTF8(sv)) { 24 while (len) { 18 if (UTF8_IS_CONTINUED(*s)) { 10 STRLEN ulen = UTF8SKIP(s); 10 if (ulen > len) ###### ulen = len; 10 len -= ulen; 32 while (ulen--) 22 *d++ = *s++; } else { 8 if (!isALNUM(*s)) ###### *d++ = '\\'; 8 *d++ = *s++; 8 len--; } } 6 SvUTF8_on(TARG); } else { 130596 while (len--) { 123856 if (!isALNUM(*s)) 47602 *d++ = '\\'; 123856 *d++ = *s++; } } 6746 *d = '\0'; 6746 SvCUR_set(TARG, d - SvPVX_const(TARG)); 6746 (void)SvPOK_only_UTF8(TARG); } else 114 sv_setpvn(TARG, s, len); 6860 SETs(TARG); 6860 if (SvSMAGICAL(TARG)) ###### mg_set(TARG); 6860 RETURN; } /* Arrays. */ PP(pp_aslice) 45886 { 45886 dSP; dMARK; dORIGMARK; 45886 register AV* const av = (AV*)POPs; 45886 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); 45886 if (SvTYPE(av) == SVt_PVAV) { 45886 const I32 arybase = PL_curcop->cop_arybase; 45886 if (lval && PL_op->op_private & OPpLVAL_INTRO) { 1 register SV **svp; 1 I32 max = -1; 3 for (svp = MARK + 1; svp <= SP; svp++) { 2 const I32 elem = SvIVx(*svp); 2 if (elem > max) 2 max = elem; } 1 if (max > AvMAX(av)) 1 av_extend(av, max); } 230288 while (++MARK <= SP) { 184402 register SV **svp; 184402 I32 elem = SvIVx(*MARK); 184402 if (elem > 0) 85275 elem -= arybase; 184402 svp = av_fetch(av, elem, lval); 184402 if (lval) { 22670 if (!svp || *svp == &PL_sv_undef) ###### DIE(aTHX_ PL_no_aelem, elem); 22670 if (PL_op->op_private & OPpLVAL_INTRO) 2 save_aelem(av, elem, svp); } 184402 *MARK = svp ? *svp : &PL_sv_undef; } } 45886 if (GIMME != G_ARRAY) { 114 MARK = ORIGMARK; 114 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef; 114 SP = MARK; } 45886 RETURN; } /* Associative arrays. */ PP(pp_each) 50348 { 50348 dSP; 50348 HV * const hash = (HV*)POPs; 50348 HE *entry; 50348 const I32 gimme = GIMME_V; 50348 PUTBACK; /* might clobber stack_sp */ 50348 entry = hv_iternext(hash); 50348 SPAGAIN; 50348 EXTEND(SP, 2); 50348 if (entry) { 45206 SV* const sv = hv_iterkeysv(entry); 45206 PUSHs(sv); /* won't clobber stack_sp */ 45206 if (gimme == G_ARRAY) { 44054 SV *val; 44054 PUTBACK; /* might clobber stack_sp */ 44054 val = hv_iterval(hash, entry); 44054 SPAGAIN; 44054 PUSHs(val); } } 5142 else if (gimme == G_SCALAR) 940 RETPUSHUNDEF; 49408 RETURN; } PP(pp_values) 19001 { 19001 return do_kv(); } PP(pp_keys) 79373 { 79373 return do_kv(); } PP(pp_delete) 123569 { 123569 dSP; 123569 const I32 gimme = GIMME_V; 123569 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0; 123569 if (PL_op->op_private & OPpSLICE) { 1111 dMARK; dORIGMARK; 1111 HV * const hv = (HV*)POPs; 1111 const U32 hvtype = SvTYPE(hv); 1111 if (hvtype == SVt_PVHV) { /* hash element */ 4425 while (++MARK <= SP) { 3316 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0); 3316 *MARK = sv ? sv : &PL_sv_undef; } } 2 else if (hvtype == SVt_PVAV) { /* array element */ 2 if (PL_op->op_flags & OPf_SPECIAL) { 6 while (++MARK <= SP) { 4 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard); 4 *MARK = sv ? sv : &PL_sv_undef; } } } else ###### DIE(aTHX_ "Not a HASH reference"); 1111 if (discard) 1108 SP = ORIGMARK; 3 else if (gimme == G_SCALAR) { 1 MARK = ORIGMARK; 1 if (SP > MARK) ###### *++MARK = *SP; else 1 *++MARK = &PL_sv_undef; 1 SP = MARK; } } else { 122458 SV *keysv = POPs; 122458 HV * const hv = (HV*)POPs; 122458 SV *sv; 122458 if (SvTYPE(hv) == SVt_PVHV) 122429 sv = hv_delete_ent(hv, keysv, discard, 0); 29 else if (SvTYPE(hv) == SVt_PVAV) { 29 if (PL_op->op_flags & OPf_SPECIAL) 29 sv = av_delete((AV*)hv, SvIV(keysv), discard); else ###### DIE(aTHX_ "panic: avhv_delete no longer supported"); } else ###### DIE(aTHX_ "Not a HASH reference"); 122452 if (!sv) 115783 sv = &PL_sv_undef; 122452 if (!discard) 72992 PUSHs(sv); } 123563 RETURN; } PP(pp_exists) 966270 { 966270 dSP; 966270 SV *tmpsv; 966270 HV *hv; 966270 if (PL_op->op_private & OPpEXISTS_SUB) { 3776 GV *gv; 3776 SV *sv = POPs; 3776 CV * const cv = sv_2cv(sv, &hv, &gv, FALSE); 3776 if (cv) 1599 RETPUSHYES; 2177 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv)) ###### RETPUSHYES; 2177 RETPUSHNO; } 962494 tmpsv = POPs; 962494 hv = (HV*)POPs; 962494 if (SvTYPE(hv) == SVt_PVHV) { 962370 if (hv_exists_ent(hv, tmpsv, 0)) 687354 RETPUSHYES; } 124 else if (SvTYPE(hv) == SVt_PVAV) { 124 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */ 124 if (av_exists((AV*)hv, SvIV(tmpsv))) 101 RETPUSHYES; } } else { ###### DIE(aTHX_ "Not a HASH reference"); } 275039 RETPUSHNO; } PP(pp_hslice) 52303 { 52303 dSP; dMARK; dORIGMARK; 52303 register HV * const hv = (HV*)POPs; 52303 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET); 52303 const bool localizing = PL_op->op_private & OPpLVAL_INTRO; 52303 bool other_magic = FALSE; 52303 if (localizing) { 757 MAGIC *mg; 757 HV *stash; 757 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) || ((mg = mg_find((SV*)hv, PERL_MAGIC_tied)) /* Try to preserve the existenceness of a tied hash * element by using EXISTS and DELETE if possible. * Fallback to FETCH and STORE otherwise */ && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg)))) && gv_fetchmethod_autoload(stash, "EXISTS", TRUE) && gv_fetchmethod_autoload(stash, "DELETE", TRUE)); } 223364 while (++MARK <= SP) { 171061 SV * const keysv = *MARK; 171061 SV **svp; 171061 HE *he; 171061 bool preeminent = FALSE; 171061 if (localizing) { 1117 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 : hv_exists_ent(hv, keysv, 0); } 171061 he = hv_fetch_ent(hv, keysv, lval, 0); 171061 svp = he ? &HeVAL(he) : 0; 171061 if (lval) { 136197 if (!svp || *svp == &PL_sv_undef) { ###### DIE(aTHX_ PL_no_helem_sv, keysv); } 136197 if (localizing) { 1117 if (preeminent) 1107 save_helem(hv, keysv, svp); else { 10 STRLEN keylen; 10 const char *key = SvPV_const(keysv, keylen); 10 SAVEDELETE(hv, savepvn(key,keylen), keylen); } } } 171061 *MARK = svp ? *svp : &PL_sv_undef; } 52303 if (GIMME != G_ARRAY) { 588 MARK = ORIGMARK; 588 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef; 588 SP = MARK; } 52303 RETURN; } /* List operators. */ PP(pp_list) 1165678 { 1165678 dSP; dMARK; 1165678 if (GIMME != G_ARRAY) { 893807 if (++MARK <= SP) 891451 *MARK = *SP; /* unwanted list, return last item */ else 2356 *MARK = &PL_sv_undef; 893807 SP = MARK; } 1165678 RETURN; } PP(pp_lslice) 84224 { 84224 dSP; 84224 SV ** const lastrelem = PL_stack_sp; 84224 SV ** const lastlelem = PL_stack_base + POPMARK; 84224 SV ** const firstlelem = PL_stack_base + POPMARK + 1; 84224 register SV ** const firstrelem = lastlelem + 1; 84224 const I32 arybase = PL_curcop->cop_arybase; 84