3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "It's a big house this, and very peculiar. Always a bit more to discover,
13 * and no knowing what you'll find around a corner. And Elves, sir!" --Samwise
16 /* This file contains general pp ("push/pop") functions that execute the
17 * opcodes that make up a perl program. A typical pp function expects to
18 * find its arguments on the stack, and usually pushes its results onto
19 * the stack, hence the 'pp' terminology. Each OP structure contains
20 * a pointer to the relevant pp_foo() function.
30 /* XXX I can't imagine anyone who doesn't have this actually _needs_
31 it, since pid_t is an integral type.
34 #ifdef NEED_GETPID_PROTO
35 extern Pid_t getpid (void);
39 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
40 * This switches them over to IEEE.
42 #if defined(LIBM_LIB_VERSION)
43 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
46 /* variations on pp_null */
52 if (GIMME_V == G_SCALAR)
63 if (PL_op->op_private & OPpLVAL_INTRO)
64 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
66 if (PL_op->op_flags & OPf_REF) {
70 if (GIMME == G_SCALAR)
71 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
76 if (gimme == G_ARRAY) {
77 const I32 maxarg = AvFILL((AV*)TARG) + 1;
79 if (SvMAGICAL(TARG)) {
81 for (i=0; i < (U32)maxarg; i++) {
82 SV * const * const svp = av_fetch((AV*)TARG, i, FALSE);
83 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
87 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
91 else if (gimme == G_SCALAR) {
92 SV* const sv = sv_newmortal();
93 const I32 maxarg = AvFILL((AV*)TARG) + 1;
106 if (PL_op->op_private & OPpLVAL_INTRO)
107 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
108 if (PL_op->op_flags & OPf_REF)
111 if (GIMME == G_SCALAR)
112 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
116 if (gimme == G_ARRAY) {
119 else if (gimme == G_SCALAR) {
120 SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
134 tryAMAGICunDEREF(to_gv);
137 if (SvTYPE(sv) == SVt_PVIO) {
138 GV * const gv = (GV*) sv_newmortal();
139 gv_init(gv, 0, "", 0, 0);
140 GvIOp(gv) = (IO *)sv;
141 SvREFCNT_inc_void_NN(sv);
144 else if (SvTYPE(sv) != SVt_PVGV)
145 DIE(aTHX_ "Not a GLOB reference");
148 if (SvTYPE(sv) != SVt_PVGV) {
149 if (SvGMAGICAL(sv)) {
154 if (!SvOK(sv) && sv != &PL_sv_undef) {
155 /* If this is a 'my' scalar and flag is set then vivify
159 Perl_croak(aTHX_ PL_no_modify);
160 if (PL_op->op_private & OPpDEREF) {
162 if (cUNOP->op_targ) {
164 SV * const namesv = PAD_SV(cUNOP->op_targ);
165 const char * const name = SvPV(namesv, len);
167 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
170 const char * const name = CopSTASHPV(PL_curcop);
173 if (SvTYPE(sv) < SVt_RV)
174 sv_upgrade(sv, SVt_RV);
175 else if (SvPVX_const(sv)) {
180 SvRV_set(sv, (SV*)gv);
185 if (PL_op->op_flags & OPf_REF ||
186 PL_op->op_private & HINT_STRICT_REFS)
187 DIE(aTHX_ PL_no_usym, "a symbol");
188 if (ckWARN(WARN_UNINITIALIZED))
192 if ((PL_op->op_flags & OPf_SPECIAL) &&
193 !(PL_op->op_flags & OPf_MOD))
195 SV * const temp = (SV*)gv_fetchsv(sv, 0, SVt_PVGV);
197 && (!is_gv_magical_sv(sv,0)
198 || !(sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV)))) {
204 if (PL_op->op_private & HINT_STRICT_REFS)
205 DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
206 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
207 == OPpDONT_INIT_GV) {
208 /* We are the target of a coderef assignment. Return
209 the scalar unchanged, and let pp_sasssign deal with
213 sv = (SV*)gv_fetchsv(sv, GV_ADD, SVt_PVGV);
217 if (PL_op->op_private & OPpLVAL_INTRO)
218 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
230 tryAMAGICunDEREF(to_sv);
233 switch (SvTYPE(sv)) {
239 DIE(aTHX_ "Not a SCALAR reference");
245 if (SvTYPE(gv) != SVt_PVGV) {
246 if (SvGMAGICAL(sv)) {
251 if (PL_op->op_private & HINT_STRICT_REFS) {
253 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
255 DIE(aTHX_ PL_no_usym, "a SCALAR");
258 if (PL_op->op_flags & OPf_REF)
259 DIE(aTHX_ PL_no_usym, "a SCALAR");
260 if (ckWARN(WARN_UNINITIALIZED))
264 if ((PL_op->op_flags & OPf_SPECIAL) &&
265 !(PL_op->op_flags & OPf_MOD))
267 gv = (GV*)gv_fetchsv(sv, 0, SVt_PV);
269 && (!is_gv_magical_sv(sv, 0)
270 || !(gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV))))
276 gv = (GV*)gv_fetchsv(sv, GV_ADD, SVt_PV);
281 if (PL_op->op_flags & OPf_MOD) {
282 if (PL_op->op_private & OPpLVAL_INTRO) {
283 if (cUNOP->op_first->op_type == OP_NULL)
284 sv = save_scalar((GV*)TOPs);
286 sv = save_scalar(gv);
288 Perl_croak(aTHX_ PL_no_localize_ref);
290 else if (PL_op->op_private & OPpDEREF)
291 vivify_ref(sv, PL_op->op_private & OPpDEREF);
300 AV * const av = (AV*)TOPs;
301 SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
304 sv_upgrade(*sv, SVt_PVMG);
305 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, NULL, 0);
313 dVAR; dSP; dTARGET; dPOPss;
315 if (PL_op->op_flags & OPf_MOD || LVRET) {
316 if (SvTYPE(TARG) < SVt_PVLV) {
317 sv_upgrade(TARG, SVt_PVLV);
318 sv_magic(TARG, NULL, PERL_MAGIC_pos, NULL, 0);
322 if (LvTARG(TARG) != sv) {
324 SvREFCNT_dec(LvTARG(TARG));
325 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
327 PUSHs(TARG); /* no SvSETMAGIC */
331 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
332 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
333 if (mg && mg->mg_len >= 0) {
337 PUSHi(i + PL_curcop->cop_arybase);
350 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
352 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
355 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
356 /* (But not in defined().) */
358 CV *cv = sv_2cv(TOPs, &stash, &gv, flags);
361 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
362 if ((PL_op->op_private & OPpLVAL_INTRO)) {
363 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
366 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
369 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
373 cv = (CV*)&PL_sv_undef;
384 SV *ret = &PL_sv_undef;
386 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
387 const char * const s = SvPVX_const(TOPs);
388 if (strnEQ(s, "CORE::", 6)) {
389 const int code = keyword(s + 6, SvCUR(TOPs) - 6);
390 if (code < 0) { /* Overridable. */
391 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
392 int i = 0, n = 0, seen_question = 0;
394 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
396 if (code == -KEY_chop || code == -KEY_chomp
397 || code == -KEY_exec || code == -KEY_system)
399 while (i < MAXO) { /* The slow way. */
400 if (strEQ(s + 6, PL_op_name[i])
401 || strEQ(s + 6, PL_op_desc[i]))
407 goto nonesuch; /* Should not happen... */
409 oa = PL_opargs[i] >> OASHIFT;
411 if (oa & OA_OPTIONAL && !seen_question) {
415 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
416 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
417 /* But globs are already references (kinda) */
418 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
422 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
426 ret = sv_2mortal(newSVpvn(str, n - 1));
428 else if (code) /* Non-Overridable */
430 else { /* None such */
432 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
436 cv = sv_2cv(TOPs, &stash, &gv, 0);
438 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
447 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
449 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
465 if (GIMME != G_ARRAY) {
469 *MARK = &PL_sv_undef;
470 *MARK = refto(*MARK);
474 EXTEND_MORTAL(SP - MARK);
476 *MARK = refto(*MARK);
481 S_refto(pTHX_ SV *sv)
486 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
489 if (!(sv = LvTARG(sv)))
492 SvREFCNT_inc_void_NN(sv);
494 else if (SvTYPE(sv) == SVt_PVAV) {
495 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
498 SvREFCNT_inc_void_NN(sv);
500 else if (SvPADTMP(sv) && !IS_PADGV(sv))
504 SvREFCNT_inc_void_NN(sv);
507 sv_upgrade(rv, SVt_RV);
517 SV * const sv = POPs;
522 if (!sv || !SvROK(sv))
525 pv = sv_reftype(SvRV(sv),TRUE);
526 PUSHp(pv, strlen(pv));
536 stash = CopSTASH(PL_curcop);
538 SV * const ssv = POPs;
542 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
543 Perl_croak(aTHX_ "Attempt to bless into a reference");
544 ptr = SvPV_const(ssv,len);
545 if (len == 0 && ckWARN(WARN_MISC))
546 Perl_warner(aTHX_ packWARN(WARN_MISC),
547 "Explicit blessing to '' (assuming package main)");
548 stash = gv_stashpvn(ptr, len, TRUE);
551 (void)sv_bless(TOPs, stash);
560 const char * const elem = SvPV_nolen_const(sv);
561 GV * const gv = (GV*)POPs;
566 /* elem will always be NUL terminated. */
567 const char * const second_letter = elem + 1;
570 if (strEQ(second_letter, "RRAY"))
571 tmpRef = (SV*)GvAV(gv);
574 if (strEQ(second_letter, "ODE"))
575 tmpRef = (SV*)GvCVu(gv);
578 if (strEQ(second_letter, "ILEHANDLE")) {
579 /* finally deprecated in 5.8.0 */
580 deprecate("*glob{FILEHANDLE}");
581 tmpRef = (SV*)GvIOp(gv);
584 if (strEQ(second_letter, "ORMAT"))
585 tmpRef = (SV*)GvFORM(gv);
588 if (strEQ(second_letter, "LOB"))
592 if (strEQ(second_letter, "ASH"))
593 tmpRef = (SV*)GvHV(gv);
596 if (*second_letter == 'O' && !elem[2])
597 tmpRef = (SV*)GvIOp(gv);
600 if (strEQ(second_letter, "AME"))
601 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
604 if (strEQ(second_letter, "ACKAGE")) {
605 const HV * const stash = GvSTASH(gv);
606 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
607 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
611 if (strEQ(second_letter, "CALAR"))
626 /* Pattern matching */
631 register unsigned char *s;
634 register I32 *sfirst;
638 if (sv == PL_lastscream) {
642 s = (unsigned char*)(SvPV(sv, len));
644 if (pos <= 0 || !SvPOK(sv)) {
645 /* No point in studying a zero length string, and not safe to study
646 anything that doesn't appear to be a simple scalar (and hence might
647 change between now and when the regexp engine runs without our set
648 magic ever running) such as a reference to an object with overloaded
654 SvSCREAM_off(PL_lastscream);
655 SvREFCNT_dec(PL_lastscream);
657 PL_lastscream = SvREFCNT_inc_simple(sv);
659 s = (unsigned char*)(SvPV(sv, len));
663 if (pos > PL_maxscream) {
664 if (PL_maxscream < 0) {
665 PL_maxscream = pos + 80;
666 Newx(PL_screamfirst, 256, I32);
667 Newx(PL_screamnext, PL_maxscream, I32);
670 PL_maxscream = pos + pos / 4;
671 Renew(PL_screamnext, PL_maxscream, I32);
675 sfirst = PL_screamfirst;
676 snext = PL_screamnext;
678 if (!sfirst || !snext)
679 DIE(aTHX_ "do_study: out of memory");
681 for (ch = 256; ch; --ch)
686 register const I32 ch = s[pos];
688 snext[pos] = sfirst[ch] - pos;
695 /* piggyback on m//g magic */
696 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
705 if (PL_op->op_flags & OPf_STACKED)
707 else if (PL_op->op_private & OPpTARGET_MY)
713 TARG = sv_newmortal();
718 /* Lvalue operators. */
730 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
732 do_chop(TARG, *++MARK);
741 SETi(do_chomp(TOPs));
747 dVAR; dSP; dMARK; dTARGET;
748 register I32 count = 0;
751 count += do_chomp(POPs);
761 if (!PL_op->op_private) {
770 SV_CHECK_THINKFIRST_COW_DROP(sv);
772 switch (SvTYPE(sv)) {
782 if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
783 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
784 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
788 /* let user-undef'd sub keep its identity */
789 GV* const gv = CvGV((CV*)sv);
796 SvSetMagicSV(sv, &PL_sv_undef);
801 GvGP(sv) = gp_ref(gp);
803 GvLINE(sv) = CopLINE(PL_curcop);
809 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
824 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
825 DIE(aTHX_ PL_no_modify);
826 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
827 && SvIVX(TOPs) != IV_MIN)
829 SvIV_set(TOPs, SvIVX(TOPs) - 1);
830 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
841 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
842 DIE(aTHX_ PL_no_modify);
843 sv_setsv(TARG, TOPs);
844 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
845 && SvIVX(TOPs) != IV_MAX)
847 SvIV_set(TOPs, SvIVX(TOPs) + 1);
848 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
853 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
863 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
864 DIE(aTHX_ PL_no_modify);
865 sv_setsv(TARG, TOPs);
866 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
867 && SvIVX(TOPs) != IV_MIN)
869 SvIV_set(TOPs, SvIVX(TOPs) - 1);
870 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
879 /* Ordinary operators. */
884 #ifdef PERL_PRESERVE_IVUV
887 tryAMAGICbin(pow,opASSIGN);
888 #ifdef PERL_PRESERVE_IVUV
889 /* For integer to integer power, we do the calculation by hand wherever
890 we're sure it is safe; otherwise we call pow() and try to convert to
891 integer afterwards. */
904 const IV iv = SvIVX(TOPs);
908 goto float_it; /* Can't do negative powers this way. */
912 baseuok = SvUOK(TOPm1s);
914 baseuv = SvUVX(TOPm1s);
916 const IV iv = SvIVX(TOPm1s);
919 baseuok = TRUE; /* effectively it's a UV now */
921 baseuv = -iv; /* abs, baseuok == false records sign */
924 /* now we have integer ** positive integer. */
927 /* foo & (foo - 1) is zero only for a power of 2. */
928 if (!(baseuv & (baseuv - 1))) {
929 /* We are raising power-of-2 to a positive integer.
930 The logic here will work for any base (even non-integer
931 bases) but it can be less accurate than
932 pow (base,power) or exp (power * log (base)) when the
933 intermediate values start to spill out of the mantissa.
934 With powers of 2 we know this can't happen.
935 And powers of 2 are the favourite thing for perl
936 programmers to notice ** not doing what they mean. */
938 NV base = baseuok ? baseuv : -(NV)baseuv;
943 while (power >>= 1) {
954 register unsigned int highbit = 8 * sizeof(UV);
955 register unsigned int diff = 8 * sizeof(UV);
958 if (baseuv >> highbit) {
962 /* we now have baseuv < 2 ** highbit */
963 if (power * highbit <= 8 * sizeof(UV)) {
964 /* result will definitely fit in UV, so use UV math
965 on same algorithm as above */
966 register UV result = 1;
967 register UV base = baseuv;
968 const bool odd_power = (bool)(power & 1);
972 while (power >>= 1) {
979 if (baseuok || !odd_power)
980 /* answer is positive */
982 else if (result <= (UV)IV_MAX)
983 /* answer negative, fits in IV */
985 else if (result == (UV)IV_MIN)
986 /* 2's complement assumption: special case IV_MIN */
989 /* answer negative, doesn't fit */
1001 SETn( Perl_pow( left, right) );
1002 #ifdef PERL_PRESERVE_IVUV
1012 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1013 #ifdef PERL_PRESERVE_IVUV
1016 /* Unless the left argument is integer in range we are going to have to
1017 use NV maths. Hence only attempt to coerce the right argument if
1018 we know the left is integer. */
1019 /* Left operand is defined, so is it IV? */
1020 SvIV_please(TOPm1s);
1021 if (SvIOK(TOPm1s)) {
1022 bool auvok = SvUOK(TOPm1s);
1023 bool buvok = SvUOK(TOPs);
1024 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1025 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1032 alow = SvUVX(TOPm1s);
1034 const IV aiv = SvIVX(TOPm1s);
1037 auvok = TRUE; /* effectively it's a UV now */
1039 alow = -aiv; /* abs, auvok == false records sign */
1045 const IV biv = SvIVX(TOPs);
1048 buvok = TRUE; /* effectively it's a UV now */
1050 blow = -biv; /* abs, buvok == false records sign */
1054 /* If this does sign extension on unsigned it's time for plan B */
1055 ahigh = alow >> (4 * sizeof (UV));
1057 bhigh = blow >> (4 * sizeof (UV));
1059 if (ahigh && bhigh) {
1061 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1062 which is overflow. Drop to NVs below. */
1063 } else if (!ahigh && !bhigh) {
1064 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1065 so the unsigned multiply cannot overflow. */
1066 const UV product = alow * blow;
1067 if (auvok == buvok) {
1068 /* -ve * -ve or +ve * +ve gives a +ve result. */
1072 } else if (product <= (UV)IV_MIN) {
1073 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1074 /* -ve result, which could overflow an IV */
1076 SETi( -(IV)product );
1078 } /* else drop to NVs below. */
1080 /* One operand is large, 1 small */
1083 /* swap the operands */
1085 bhigh = blow; /* bhigh now the temp var for the swap */
1089 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1090 multiplies can't overflow. shift can, add can, -ve can. */
1091 product_middle = ahigh * blow;
1092 if (!(product_middle & topmask)) {
1093 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1095 product_middle <<= (4 * sizeof (UV));
1096 product_low = alow * blow;
1098 /* as for pp_add, UV + something mustn't get smaller.
1099 IIRC ANSI mandates this wrapping *behaviour* for
1100 unsigned whatever the actual representation*/
1101 product_low += product_middle;
1102 if (product_low >= product_middle) {
1103 /* didn't overflow */
1104 if (auvok == buvok) {
1105 /* -ve * -ve or +ve * +ve gives a +ve result. */
1107 SETu( product_low );
1109 } else if (product_low <= (UV)IV_MIN) {
1110 /* 2s complement assumption again */
1111 /* -ve result, which could overflow an IV */
1113 SETi( -(IV)product_low );
1115 } /* else drop to NVs below. */
1117 } /* product_middle too large */
1118 } /* ahigh && bhigh */
1119 } /* SvIOK(TOPm1s) */
1124 SETn( left * right );
1131 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1132 /* Only try to do UV divide first
1133 if ((SLOPPYDIVIDE is true) or
1134 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1136 The assumption is that it is better to use floating point divide
1137 whenever possible, only doing integer divide first if we can't be sure.
1138 If NV_PRESERVES_UV is true then we know at compile time that no UV
1139 can be too large to preserve, so don't need to compile the code to
1140 test the size of UVs. */
1143 # define PERL_TRY_UV_DIVIDE
1144 /* ensure that 20./5. == 4. */
1146 # ifdef PERL_PRESERVE_IVUV
1147 # ifndef NV_PRESERVES_UV
1148 # define PERL_TRY_UV_DIVIDE
1153 #ifdef PERL_TRY_UV_DIVIDE
1156 SvIV_please(TOPm1s);
1157 if (SvIOK(TOPm1s)) {
1158 bool left_non_neg = SvUOK(TOPm1s);
1159 bool right_non_neg = SvUOK(TOPs);
1163 if (right_non_neg) {
1164 right = SvUVX(TOPs);
1167 const IV biv = SvIVX(TOPs);
1170 right_non_neg = TRUE; /* effectively it's a UV now */
1176 /* historically undef()/0 gives a "Use of uninitialized value"
1177 warning before dieing, hence this test goes here.
1178 If it were immediately before the second SvIV_please, then
1179 DIE() would be invoked before left was even inspected, so
1180 no inpsection would give no warning. */
1182 DIE(aTHX_ "Illegal division by zero");
1185 left = SvUVX(TOPm1s);
1188 const IV aiv = SvIVX(TOPm1s);
1191 left_non_neg = TRUE; /* effectively it's a UV now */
1200 /* For sloppy divide we always attempt integer division. */
1202 /* Otherwise we only attempt it if either or both operands
1203 would not be preserved by an NV. If both fit in NVs
1204 we fall through to the NV divide code below. However,
1205 as left >= right to ensure integer result here, we know that
1206 we can skip the test on the right operand - right big
1207 enough not to be preserved can't get here unless left is
1210 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1213 /* Integer division can't overflow, but it can be imprecise. */
1214 const UV result = left / right;
1215 if (result * right == left) {
1216 SP--; /* result is valid */
1217 if (left_non_neg == right_non_neg) {
1218 /* signs identical, result is positive. */
1222 /* 2s complement assumption */
1223 if (result <= (UV)IV_MIN)
1224 SETi( -(IV)result );
1226 /* It's exact but too negative for IV. */
1227 SETn( -(NV)result );
1230 } /* tried integer divide but it was not an integer result */
1231 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1232 } /* left wasn't SvIOK */
1233 } /* right wasn't SvIOK */
1234 #endif /* PERL_TRY_UV_DIVIDE */
1238 DIE(aTHX_ "Illegal division by zero");
1239 PUSHn( left / right );
1246 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1250 bool left_neg = FALSE;
1251 bool right_neg = FALSE;
1252 bool use_double = FALSE;
1253 bool dright_valid = FALSE;
1259 right_neg = !SvUOK(TOPs);
1261 right = SvUVX(POPs);
1263 const IV biv = SvIVX(POPs);
1266 right_neg = FALSE; /* effectively it's a UV now */
1274 right_neg = dright < 0;
1277 if (dright < UV_MAX_P1) {
1278 right = U_V(dright);
1279 dright_valid = TRUE; /* In case we need to use double below. */
1285 /* At this point use_double is only true if right is out of range for
1286 a UV. In range NV has been rounded down to nearest UV and
1287 use_double false. */
1289 if (!use_double && SvIOK(TOPs)) {
1291 left_neg = !SvUOK(TOPs);
1295 const IV aiv = SvIVX(POPs);
1298 left_neg = FALSE; /* effectively it's a UV now */
1307 left_neg = dleft < 0;
1311 /* This should be exactly the 5.6 behaviour - if left and right are
1312 both in range for UV then use U_V() rather than floor. */
1314 if (dleft < UV_MAX_P1) {
1315 /* right was in range, so is dleft, so use UVs not double.
1319 /* left is out of range for UV, right was in range, so promote
1320 right (back) to double. */
1322 /* The +0.5 is used in 5.6 even though it is not strictly
1323 consistent with the implicit +0 floor in the U_V()
1324 inside the #if 1. */
1325 dleft = Perl_floor(dleft + 0.5);
1328 dright = Perl_floor(dright + 0.5);
1338 DIE(aTHX_ "Illegal modulus zero");
1340 dans = Perl_fmod(dleft, dright);
1341 if ((left_neg != right_neg) && dans)
1342 dans = dright - dans;
1345 sv_setnv(TARG, dans);
1351 DIE(aTHX_ "Illegal modulus zero");
1354 if ((left_neg != right_neg) && ans)
1357 /* XXX may warn: unary minus operator applied to unsigned type */
1358 /* could change -foo to be (~foo)+1 instead */
1359 if (ans <= ~((UV)IV_MAX)+1)
1360 sv_setiv(TARG, ~ans+1);
1362 sv_setnv(TARG, -(NV)ans);
1365 sv_setuv(TARG, ans);
1374 dVAR; dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1381 const UV uv = SvUV(sv);
1383 count = IV_MAX; /* The best we can do? */
1387 const IV iv = SvIV(sv);
1394 else if (SvNOKp(sv)) {
1395 const NV nv = SvNV(sv);
1403 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1405 static const char oom_list_extend[] = "Out of memory during list extend";
1406 const I32 items = SP - MARK;
1407 const I32 max = items * count;
1409 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1410 /* Did the max computation overflow? */
1411 if (items > 0 && max > 0 && (max < items || max < count))
1412 Perl_croak(aTHX_ oom_list_extend);
1417 /* This code was intended to fix 20010809.028:
1420 for (($x =~ /./g) x 2) {
1421 print chop; # "abcdabcd" expected as output.
1424 * but that change (#11635) broke this code:
1426 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1428 * I can't think of a better fix that doesn't introduce
1429 * an efficiency hit by copying the SVs. The stack isn't
1430 * refcounted, and mortalisation obviously doesn't
1431 * Do The Right Thing when the stack has more than
1432 * one pointer to the same mortal value.
1436 *SP = sv_2mortal(newSVsv(*SP));
1446 repeatcpy((char*)(MARK + items), (char*)MARK,
1447 items * sizeof(SV*), count - 1);
1450 else if (count <= 0)
1453 else { /* Note: mark already snarfed by pp_list */
1454 SV * const tmpstr = POPs;
1457 static const char oom_string_extend[] =
1458 "Out of memory during string extend";
1460 SvSetSV(TARG, tmpstr);
1461 SvPV_force(TARG, len);
1462 isutf = DO_UTF8(TARG);
1467 const STRLEN max = (UV)count * len;
1468 if (len > ((MEM_SIZE)~0)/count)
1469 Perl_croak(aTHX_ oom_string_extend);
1470 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1471 SvGROW(TARG, max + 1);
1472 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1473 SvCUR_set(TARG, SvCUR(TARG) * count);
1475 *SvEND(TARG) = '\0';
1478 (void)SvPOK_only_UTF8(TARG);
1480 (void)SvPOK_only(TARG);
1482 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1483 /* The parser saw this as a list repeat, and there
1484 are probably several items on the stack. But we're
1485 in scalar context, and there's no pp_list to save us
1486 now. So drop the rest of the items -- robin@kitsite.com
1499 dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1500 useleft = USE_LEFT(TOPm1s);
1501 #ifdef PERL_PRESERVE_IVUV
1502 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1503 "bad things" happen if you rely on signed integers wrapping. */
1506 /* Unless the left argument is integer in range we are going to have to
1507 use NV maths. Hence only attempt to coerce the right argument if
1508 we know the left is integer. */
1509 register UV auv = 0;
1515 a_valid = auvok = 1;
1516 /* left operand is undef, treat as zero. */
1518 /* Left operand is defined, so is it IV? */
1519 SvIV_please(TOPm1s);
1520 if (SvIOK(TOPm1s)) {
1521 if ((auvok = SvUOK(TOPm1s)))
1522 auv = SvUVX(TOPm1s);
1524 register const IV aiv = SvIVX(TOPm1s);
1527 auvok = 1; /* Now acting as a sign flag. */
1528 } else { /* 2s complement assumption for IV_MIN */
1536 bool result_good = 0;
1539 bool buvok = SvUOK(TOPs);
1544 register const IV biv = SvIVX(TOPs);
1551 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1552 else "IV" now, independent of how it came in.
1553 if a, b represents positive, A, B negative, a maps to -A etc
1558 all UV maths. negate result if A negative.
1559 subtract if signs same, add if signs differ. */
1561 if (auvok ^ buvok) {
1570 /* Must get smaller */
1575 if (result <= buv) {
1576 /* result really should be -(auv-buv). as its negation
1577 of true value, need to swap our result flag */
1589 if (result <= (UV)IV_MIN)
1590 SETi( -(IV)result );
1592 /* result valid, but out of range for IV. */
1593 SETn( -(NV)result );
1597 } /* Overflow, drop through to NVs. */
1601 useleft = USE_LEFT(TOPm1s);
1605 /* left operand is undef, treat as zero - value */
1609 SETn( TOPn - value );
1616 dVAR; dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1618 const IV shift = POPi;
1619 if (PL_op->op_private & HINT_INTEGER) {
1633 dVAR; dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1635 const IV shift = POPi;
1636 if (PL_op->op_private & HINT_INTEGER) {
1650 dVAR; dSP; tryAMAGICbinSET(lt,0);
1651 #ifdef PERL_PRESERVE_IVUV
1654 SvIV_please(TOPm1s);
1655 if (SvIOK(TOPm1s)) {
1656 bool auvok = SvUOK(TOPm1s);
1657 bool buvok = SvUOK(TOPs);
1659 if (!auvok && !buvok) { /* ## IV < IV ## */
1660 const IV aiv = SvIVX(TOPm1s);
1661 const IV biv = SvIVX(TOPs);
1664 SETs(boolSV(aiv < biv));
1667 if (auvok && buvok) { /* ## UV < UV ## */
1668 const UV auv = SvUVX(TOPm1s);
1669 const UV buv = SvUVX(TOPs);
1672 SETs(boolSV(auv < buv));
1675 if (auvok) { /* ## UV < IV ## */
1677 const IV biv = SvIVX(TOPs);
1680 /* As (a) is a UV, it's >=0, so it cannot be < */
1685 SETs(boolSV(auv < (UV)biv));
1688 { /* ## IV < UV ## */
1689 const IV aiv = SvIVX(TOPm1s);
1693 /* As (b) is a UV, it's >=0, so it must be < */
1700 SETs(boolSV((UV)aiv < buv));
1706 #ifndef NV_PRESERVES_UV
1707 #ifdef PERL_PRESERVE_IVUV
1710 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1712 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1717 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1719 if (Perl_isnan(left) || Perl_isnan(right))
1721 SETs(boolSV(left < right));
1724 SETs(boolSV(TOPn < value));
1732 dVAR; dSP; tryAMAGICbinSET(gt,0);
1733 #ifdef PERL_PRESERVE_IVUV
1736 SvIV_please(TOPm1s);
1737 if (SvIOK(TOPm1s)) {
1738 bool auvok = SvUOK(TOPm1s);
1739 bool buvok = SvUOK(TOPs);
1741 if (!auvok && !buvok) { /* ## IV > IV ## */
1742 const IV aiv = SvIVX(TOPm1s);
1743 const IV biv = SvIVX(TOPs);
1746 SETs(boolSV(aiv > biv));
1749 if (auvok && buvok) { /* ## UV > UV ## */
1750 const UV auv = SvUVX(TOPm1s);
1751 const UV buv = SvUVX(TOPs);
1754 SETs(boolSV(auv > buv));
1757 if (auvok) { /* ## UV > IV ## */
1759 const IV biv = SvIVX(TOPs);
1763 /* As (a) is a UV, it's >=0, so it must be > */
1768 SETs(boolSV(auv > (UV)biv));
1771 { /* ## IV > UV ## */
1772 const IV aiv = SvIVX(TOPm1s);
1776 /* As (b) is a UV, it's >=0, so it cannot be > */
1783 SETs(boolSV((UV)aiv > buv));
1789 #ifndef NV_PRESERVES_UV
1790 #ifdef PERL_PRESERVE_IVUV
1793 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1795 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1800 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1802 if (Perl_isnan(left) || Perl_isnan(right))
1804 SETs(boolSV(left > right));
1807 SETs(boolSV(TOPn > value));
1815 dVAR; dSP; tryAMAGICbinSET(le,0);
1816 #ifdef PERL_PRESERVE_IVUV
1819 SvIV_please(TOPm1s);
1820 if (SvIOK(TOPm1s)) {
1821 bool auvok = SvUOK(TOPm1s);
1822 bool buvok = SvUOK(TOPs);
1824 if (!auvok && !buvok) { /* ## IV <= IV ## */
1825 const IV aiv = SvIVX(TOPm1s);
1826 const IV biv = SvIVX(TOPs);
1829 SETs(boolSV(aiv <= biv));
1832 if (auvok && buvok) { /* ## UV <= UV ## */
1833 UV auv = SvUVX(TOPm1s);
1834 UV buv = SvUVX(TOPs);
1837 SETs(boolSV(auv <= buv));
1840 if (auvok) { /* ## UV <= IV ## */
1842 const IV biv = SvIVX(TOPs);
1846 /* As (a) is a UV, it's >=0, so a cannot be <= */
1851 SETs(boolSV(auv <= (UV)biv));
1854 { /* ## IV <= UV ## */
1855 const IV aiv = SvIVX(TOPm1s);
1859 /* As (b) is a UV, it's >=0, so a must be <= */
1866 SETs(boolSV((UV)aiv <= buv));
1872 #ifndef NV_PRESERVES_UV
1873 #ifdef PERL_PRESERVE_IVUV
1876 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1878 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1883 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1885 if (Perl_isnan(left) || Perl_isnan(right))
1887 SETs(boolSV(left <= right));
1890 SETs(boolSV(TOPn <= value));
1898 dVAR; dSP; tryAMAGICbinSET(ge,0);
1899 #ifdef PERL_PRESERVE_IVUV
1902 SvIV_please(TOPm1s);
1903 if (SvIOK(TOPm1s)) {
1904 bool auvok = SvUOK(TOPm1s);
1905 bool buvok = SvUOK(TOPs);
1907 if (!auvok && !buvok) { /* ## IV >= IV ## */
1908 const IV aiv = SvIVX(TOPm1s);
1909 const IV biv = SvIVX(TOPs);
1912 SETs(boolSV(aiv >= biv));
1915 if (auvok && buvok) { /* ## UV >= UV ## */
1916 const UV auv = SvUVX(TOPm1s);
1917 const UV buv = SvUVX(TOPs);
1920 SETs(boolSV(auv >= buv));
1923 if (auvok) { /* ## UV >= IV ## */
1925 const IV biv = SvIVX(TOPs);
1929 /* As (a) is a UV, it's >=0, so it must be >= */
1934 SETs(boolSV(auv >= (UV)biv));
1937 { /* ## IV >= UV ## */
1938 const IV aiv = SvIVX(TOPm1s);
1942 /* As (b) is a UV, it's >=0, so a cannot be >= */
1949 SETs(boolSV((UV)aiv >= buv));
1955 #ifndef NV_PRESERVES_UV
1956 #ifdef PERL_PRESERVE_IVUV
1959 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1961 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1966 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1968 if (Perl_isnan(left) || Perl_isnan(right))
1970 SETs(boolSV(left >= right));
1973 SETs(boolSV(TOPn >= value));
1981 dVAR; dSP; tryAMAGICbinSET(ne,0);
1982 #ifndef NV_PRESERVES_UV
1983 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1985 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1989 #ifdef PERL_PRESERVE_IVUV
1992 SvIV_please(TOPm1s);
1993 if (SvIOK(TOPm1s)) {
1994 const bool auvok = SvUOK(TOPm1s);
1995 const bool buvok = SvUOK(TOPs);
1997 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1998 /* Casting IV to UV before comparison isn't going to matter
1999 on 2s complement. On 1s complement or sign&magnitude
2000 (if we have any of them) it could make negative zero
2001 differ from normal zero. As I understand it. (Need to
2002 check - is negative zero implementation defined behaviour
2004 const UV buv = SvUVX(POPs);
2005 const UV auv = SvUVX(TOPs);
2007 SETs(boolSV(auv != buv));
2010 { /* ## Mixed IV,UV ## */
2014 /* != is commutative so swap if needed (save code) */
2016 /* swap. top of stack (b) is the iv */
2020 /* As (a) is a UV, it's >0, so it cannot be == */
2029 /* As (b) is a UV, it's >0, so it cannot be == */
2033 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2035 SETs(boolSV((UV)iv != uv));
2042 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2044 if (Perl_isnan(left) || Perl_isnan(right))
2046 SETs(boolSV(left != right));
2049 SETs(boolSV(TOPn != value));
2057 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2058 #ifndef NV_PRESERVES_UV
2059 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2060 const UV right = PTR2UV(SvRV(POPs));
2061 const UV left = PTR2UV(SvRV(TOPs));
2062 SETi((left > right) - (left < right));
2066 #ifdef PERL_PRESERVE_IVUV
2067 /* Fortunately it seems NaN isn't IOK */
2070 SvIV_please(TOPm1s);
2071 if (SvIOK(TOPm1s)) {
2072 const bool leftuvok = SvUOK(TOPm1s);
2073 const bool rightuvok = SvUOK(TOPs);
2075 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2076 const IV leftiv = SvIVX(TOPm1s);
2077 const IV rightiv = SvIVX(TOPs);
2079 if (leftiv > rightiv)
2081 else if (leftiv < rightiv)
2085 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2086 const UV leftuv = SvUVX(TOPm1s);
2087 const UV rightuv = SvUVX(TOPs);
2089 if (leftuv > rightuv)
2091 else if (leftuv < rightuv)
2095 } else if (leftuvok) { /* ## UV <=> IV ## */
2096 const IV rightiv = SvIVX(TOPs);
2098 /* As (a) is a UV, it's >=0, so it cannot be < */
2101 const UV leftuv = SvUVX(TOPm1s);
2102 if (leftuv > (UV)rightiv) {
2104 } else if (leftuv < (UV)rightiv) {
2110 } else { /* ## IV <=> UV ## */
2111 const IV leftiv = SvIVX(TOPm1s);
2113 /* As (b) is a UV, it's >=0, so it must be < */
2116 const UV rightuv = SvUVX(TOPs);
2117 if ((UV)leftiv > rightuv) {
2119 } else if ((UV)leftiv < rightuv) {
2137 if (Perl_isnan(left) || Perl_isnan(right)) {
2141 value = (left > right) - (left < right);
2145 else if (left < right)
2147 else if (left > right)
2163 int amg_type = sle_amg;
2167 switch (PL_op->op_type) {
2186 tryAMAGICbinSET_var(amg_type,0);
2189 const int cmp = (IN_LOCALE_RUNTIME
2190 ? sv_cmp_locale(left, right)
2191 : sv_cmp(left, right));
2192 SETs(boolSV(cmp * multiplier < rhs));
2199 dVAR; dSP; tryAMAGICbinSET(seq,0);
2202 SETs(boolSV(sv_eq(left, right)));
2209 dVAR; dSP; tryAMAGICbinSET(sne,0);
2212 SETs(boolSV(!sv_eq(left, right)));
2219 dVAR; dSP; dTARGET; tryAMAGICbin(scmp,0);
2222 const int cmp = (IN_LOCALE_RUNTIME
2223 ? sv_cmp_locale(left, right)
2224 : sv_cmp(left, right));
2232 dVAR; dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2237 if (SvNIOKp(left) || SvNIOKp(right)) {
2238 if (PL_op->op_private & HINT_INTEGER) {
2239 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2243 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2248 do_vop(PL_op->op_type, TARG, left, right);
2257 dVAR; dSP; dATARGET;
2258 const int op_type = PL_op->op_type;
2260 tryAMAGICbin_var((op_type == OP_BIT_OR ? bor_amg : bxor_amg), opASSIGN);
2265 if (SvNIOKp(left) || SvNIOKp(right)) {
2266 if (PL_op->op_private & HINT_INTEGER) {
2267 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2268 const IV r = SvIV_nomg(right);
2269 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2273 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2274 const UV r = SvUV_nomg(right);
2275 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2280 do_vop(op_type, TARG, left, right);
2289 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2292 const int flags = SvFLAGS(sv);
2294 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2295 /* It's publicly an integer, or privately an integer-not-float */
2298 if (SvIVX(sv) == IV_MIN) {
2299 /* 2s complement assumption. */
2300 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2303 else if (SvUVX(sv) <= IV_MAX) {
2308 else if (SvIVX(sv) != IV_MIN) {
2312 #ifdef PERL_PRESERVE_IVUV
2321 else if (SvPOKp(sv)) {
2323 const char * const s = SvPV_const(sv, len);
2324 if (isIDFIRST(*s)) {
2325 sv_setpvn(TARG, "-", 1);
2328 else if (*s == '+' || *s == '-') {
2330 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2332 else if (DO_UTF8(sv)) {
2335 goto oops_its_an_int;
2337 sv_setnv(TARG, -SvNV(sv));
2339 sv_setpvn(TARG, "-", 1);
2346 goto oops_its_an_int;
2347 sv_setnv(TARG, -SvNV(sv));
2359 dVAR; dSP; tryAMAGICunSET(not);
2360 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2366 dVAR; dSP; dTARGET; tryAMAGICun(compl);
2371 if (PL_op->op_private & HINT_INTEGER) {
2372 const IV i = ~SvIV_nomg(sv);
2376 const UV u = ~SvUV_nomg(sv);
2385 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2386 sv_setsv_nomg(TARG, sv);
2387 tmps = (U8*)SvPV_force(TARG, len);
2390 /* Calculate exact length, let's not estimate. */
2399 while (tmps < send) {
2400 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2401 tmps += UTF8SKIP(tmps);
2402 targlen += UNISKIP(~c);
2408 /* Now rewind strings and write them. */
2412 Newxz(result, targlen + 1, U8);
2413 while (tmps < send) {
2414 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2415 tmps += UTF8SKIP(tmps);
2416 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2420 sv_setpvn(TARG, (char*)result, targlen);
2424 Newxz(result, nchar + 1, U8);
2425 while (tmps < send) {
2426 const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2427 tmps += UTF8SKIP(tmps);
2432 sv_setpvn(TARG, (char*)result, nchar);
2441 register long *tmpl;
2442 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2445 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2450 for ( ; anum > 0; anum--, tmps++)
2459 /* integer versions of some of the above */
2463 dVAR; dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2466 SETi( left * right );
2474 dVAR; dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2478 DIE(aTHX_ "Illegal division by zero");
2481 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2485 value = num / value;
2494 /* This is the vanilla old i_modulo. */
2495 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2499 DIE(aTHX_ "Illegal modulus zero");
2500 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2504 SETi( left % right );
2509 #if defined(__GLIBC__) && IVSIZE == 8
2513 /* This is the i_modulo with the workaround for the _moddi3 bug
2514 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2515 * See below for pp_i_modulo. */
2516 dVAR; dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2520 DIE(aTHX_ "Illegal modulus zero");
2521 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2525 SETi( left % PERL_ABS(right) );
2533 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2537 DIE(aTHX_ "Illegal modulus zero");
2538 /* The assumption is to use hereafter the old vanilla version... */
2540 PL_ppaddr[OP_I_MODULO] =
2542 /* .. but if we have glibc, we might have a buggy _moddi3
2543 * (at least glicb 2.2.5 is known to have this bug), in other
2544 * words our integer modulus with negative quad as the second
2545 * argument might be broken. Test for this and re-patch the
2546 * opcode dispatch table if that is the case, remembering to
2547 * also apply the workaround so that this first round works
2548 * right, too. See [perl #9402] for more information. */
2549 #if defined(__GLIBC__) && IVSIZE == 8
2553 /* Cannot do this check with inlined IV constants since
2554 * that seems to work correctly even with the buggy glibc. */
2556 /* Yikes, we have the bug.
2557 * Patch in the workaround version. */
2559 PL_ppaddr[OP_I_MODULO] =
2560 &Perl_pp_i_modulo_1;
2561 /* Make certain we work right this time, too. */
2562 right = PERL_ABS(right);
2566 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2570 SETi( left % right );
2577 dVAR; dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2580 SETi( left + right );
2587 dVAR; dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2590 SETi( left - right );
2597 dVAR; dSP; tryAMAGICbinSET(lt,0);
2600 SETs(boolSV(left < right));
2607 dVAR; dSP; tryAMAGICbinSET(gt,0);
2610 SETs(boolSV(left > right));
2617 dVAR; dSP; tryAMAGICbinSET(le,0);
2620 SETs(boolSV(left <= right));
2627 dVAR; dSP; tryAMAGICbinSET(ge,0);
2630 SETs(boolSV(left >= right));
2637 dVAR; dSP; tryAMAGICbinSET(eq,0);
2640 SETs(boolSV(left == right));
2647 dVAR; dSP; tryAMAGICbinSET(ne,0);
2650 SETs(boolSV(left != right));
2657 dVAR; dSP; dTARGET; tryAMAGICbin(ncmp,0);
2664 else if (left < right)
2675 dVAR; dSP; dTARGET; tryAMAGICun(neg);
2680 /* High falutin' math. */
2684 dVAR; dSP; dTARGET; tryAMAGICbin(atan2,0);
2687 SETn(Perl_atan2(left, right));
2695 int amg_type = sin_amg;
2696 const char *neg_report = NULL;
2697 NV (*func)(NV) = Perl_sin;
2698 const int op_type = PL_op->op_type;
2715 amg_type = sqrt_amg;
2717 neg_report = "sqrt";
2721 tryAMAGICun_var(amg_type);
2723 const NV value = POPn;
2725 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2726 SET_NUMERIC_STANDARD();
2727 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2730 XPUSHn(func(value));
2735 /* Support Configure command-line overrides for rand() functions.
2736 After 5.005, perhaps we should replace this by Configure support
2737 for drand48(), random(), or rand(). For 5.005, though, maintain
2738 compatibility by calling rand() but allow the user to override it.
2739 See INSTALL for details. --Andy Dougherty 15 July 1998
2741 /* Now it's after 5.005, and Configure supports drand48() and random(),
2742 in addition to rand(). So the overrides should not be needed any more.
2743 --Jarkko Hietaniemi 27 September 1998
2746 #ifndef HAS_DRAND48_PROTO
2747 extern double drand48 (void);
2760 if (!PL_srand_called) {
2761 (void)seedDrand01((Rand_seed_t)seed());
2762 PL_srand_called = TRUE;
2772 const UV anum = (MAXARG < 1) ? seed() : POPu;
2773 (void)seedDrand01((Rand_seed_t)anum);
2774 PL_srand_called = TRUE;
2781 dVAR; dSP; dTARGET; tryAMAGICun(int);
2783 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2784 /* XXX it's arguable that compiler casting to IV might be subtly
2785 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2786 else preferring IV has introduced a subtle behaviour change bug. OTOH
2787 relying on floating point to be accurate is a bug. */
2791 else if (SvIOK(TOPs)) {
2798 const NV value = TOPn;
2800 if (value < (NV)UV_MAX + 0.5) {
2803 SETn(Perl_floor(value));
2807 if (value > (NV)IV_MIN - 0.5) {
2810 SETn(Perl_ceil(value));
2820 dVAR; dSP; dTARGET; tryAMAGICun(abs);
2822 /* This will cache the NV value if string isn't actually integer */
2827 else if (SvIOK(TOPs)) {
2828 /* IVX is precise */
2830 SETu(TOPu); /* force it to be numeric only */
2838 /* 2s complement assumption. Also, not really needed as
2839 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2845 const NV value = TOPn;
2859 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2863 SV* const sv = POPs;
2865 tmps = (SvPV_const(sv, len));
2867 /* If Unicode, try to downgrade
2868 * If not possible, croak. */
2869 SV* const tsv = sv_2mortal(newSVsv(sv));
2872 sv_utf8_downgrade(tsv, FALSE);
2873 tmps = SvPV_const(tsv, len);
2875 if (PL_op->op_type == OP_HEX)
2878 while (*tmps && len && isSPACE(*tmps))
2884 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2886 else if (*tmps == 'b')
2887 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2889 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2891 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2905 SV * const sv = TOPs;
2908 SETi(sv_len_utf8(sv));
2924 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2926 const I32 arybase = PL_curcop->cop_arybase;
2928 const char *repl = NULL;
2930 const int num_args = PL_op->op_private & 7;
2931 bool repl_need_utf8_upgrade = FALSE;
2932 bool repl_is_utf8 = FALSE;
2934 SvTAINTED_off(TARG); /* decontaminate */
2935 SvUTF8_off(TARG); /* decontaminate */
2939 repl = SvPV_const(repl_sv, repl_len);
2940 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2950 sv_utf8_upgrade(sv);
2952 else if (DO_UTF8(sv))
2953 repl_need_utf8_upgrade = TRUE;
2955 tmps = SvPV_const(sv, curlen);
2957 utf8_curlen = sv_len_utf8(sv);
2958 if (utf8_curlen == curlen)
2961 curlen = utf8_curlen;
2966 if (pos >= arybase) {
2984 else if (len >= 0) {
2986 if (rem > (I32)curlen)
3001 Perl_croak(aTHX_ "substr outside of string");
3002 if (ckWARN(WARN_SUBSTR))
3003 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3007 const I32 upos = pos;
3008 const I32 urem = rem;
3010 sv_pos_u2b(sv, &pos, &rem);
3012 /* we either return a PV or an LV. If the TARG hasn't been used
3013 * before, or is of that type, reuse it; otherwise use a mortal
3014 * instead. Note that LVs can have an extended lifetime, so also
3015 * dont reuse if refcount > 1 (bug #20933) */
3016 if (SvTYPE(TARG) > SVt_NULL) {
3017 if ( (SvTYPE(TARG) == SVt_PVLV)
3018 ? (!lvalue || SvREFCNT(TARG) > 1)
3021 TARG = sv_newmortal();
3025 sv_setpvn(TARG, tmps, rem);
3026 #ifdef USE_LOCALE_COLLATE
3027 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3032 SV* repl_sv_copy = NULL;
3034 if (repl_need_utf8_upgrade) {
3035 repl_sv_copy = newSVsv(repl_sv);
3036 sv_utf8_upgrade(repl_sv_copy);
3037 repl = SvPV_const(repl_sv_copy, repl_len);
3038 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3040 sv_insert(sv, pos, rem, repl, repl_len);
3044 SvREFCNT_dec(repl_sv_copy);
3046 else if (lvalue) { /* it's an lvalue! */
3047 if (!SvGMAGICAL(sv)) {
3049 SvPV_force_nolen(sv);
3050 if (ckWARN(WARN_SUBSTR))
3051 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3052 "Attempt to use reference as lvalue in substr");
3054 if (isGV_with_GP(sv))
3055 SvPV_force_nolen(sv);
3056 else if (SvOK(sv)) /* is it defined ? */
3057 (void)SvPOK_only_UTF8(sv);
3059 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3062 if (SvTYPE(TARG) < SVt_PVLV) {
3063 sv_upgrade(TARG, SVt_PVLV);
3064 sv_magic(TARG, NULL, PERL_MAGIC_substr, NULL, 0);
3070 if (LvTARG(TARG) != sv) {
3072 SvREFCNT_dec(LvTARG(TARG));
3073 LvTARG(TARG) = SvREFCNT_inc_simple(sv);
3075 LvTARGOFF(TARG) = upos;
3076 LvTARGLEN(TARG) = urem;
3080 PUSHs(TARG); /* avoid SvSETMAGIC here */
3087 register const IV size = POPi;
3088 register const IV offset = POPi;
3089 register SV * const src = POPs;
3090 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3092 SvTAINTED_off(TARG); /* decontaminate */
3093 if (lvalue) { /* it's an lvalue! */
3094 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3095 TARG = sv_newmortal();
3096 if (SvTYPE(TARG) < SVt_PVLV) {
3097 sv_upgrade(TARG, SVt_PVLV);
3098 sv_magic(TARG, NULL, PERL_MAGIC_vec, NULL, 0);
3101 if (LvTARG(TARG) != src) {
3103 SvREFCNT_dec(LvTARG(TARG));
3104 LvTARG(TARG) = SvREFCNT_inc_simple(src);
3106 LvTARGOFF(TARG) = offset;
3107 LvTARGLEN(TARG) = size;
3110 sv_setuv(TARG, do_vecget(src, offset, size));
3127 const I32 arybase = PL_curcop->cop_arybase;
3130 const bool is_index = PL_op->op_type == OP_INDEX;
3133 /* arybase is in characters, like offset, so combine prior to the
3134 UTF-8 to bytes calculation. */
3135 offset = POPi - arybase;
3139 big_utf8 = DO_UTF8(big);
3140 little_utf8 = DO_UTF8(little);
3141 if (big_utf8 ^ little_utf8) {
3142 /* One needs to be upgraded. */
3143 if (little_utf8 && !PL_encoding) {
3144 /* Well, maybe instead we might be able to downgrade the small
3147 const U8 * const little_pv = (U8*) SvPV_const(little, little_len);
3148 char * const pv = (char*)bytes_from_utf8(little_pv, &little_len,
3151 /* If the large string is ISO-8859-1, and it's not possible to
3152 convert the small string to ISO-8859-1, then there is no
3153 way that it could be found anywhere by index. */
3158 /* At this point, pv is a malloc()ed string. So donate it to temp
3159 to ensure it will get free()d */
3160 little = temp = newSV(0);
3161 sv_usepvn(temp, pv, little_len);
3163 SV * const bytes = little_utf8 ? big : little;
3165 const char * const p = SvPV_const(bytes, len);
3167 temp = newSVpvn(p, len);
3170 sv_recode_to_utf8(temp, PL_encoding);
3172 sv_utf8_upgrade(temp);
3182 /* Don't actually need the NULL initialisation, but it keeps gcc quiet. */
3183 tmps2 = is_index ? NULL : SvPV_const(little, llen);
3184 tmps = SvPV_const(big, biglen);
3187 offset = is_index ? 0 : biglen;
3189 if (big_utf8 && offset > 0)
3190 sv_pos_u2b(big, &offset, 0);
3195 else if (offset > (I32)biglen)
3197 if (!(tmps2 = is_index
3198 ? fbm_instr((unsigned char*)tmps + offset,
3199 (unsigned char*)tmps + biglen, little, 0)
3200 : rninstr(tmps, tmps + offset,
3201 tmps2, tmps2 + llen)))
3204 retval = tmps2 - tmps;
3205 if (retval > 0 && big_utf8)
3206 sv_pos_b2u(big, &retval);
3211 PUSHi(retval + arybase);
3217 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3218 do_sprintf(TARG, SP-MARK, MARK+1);
3219 TAINT_IF(SvTAINTED(TARG));
3230 const U8 *s = (U8*)SvPV_const(argsv, len);
3233 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3234 tmpsv = sv_2mortal(newSVsv(argsv));
3235 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3239 XPUSHu(DO_UTF8(argsv) ?
3240 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3252 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3254 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3256 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3258 (void) POPs; /* Ignore the argument value. */
3259 value = UNICODE_REPLACEMENT;
3265 SvUPGRADE(TARG,SVt_PV);
3267 if (value > 255 && !IN_BYTES) {
3268 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3269 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3270 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3272 (void)SvPOK_only(TARG);
3281 *tmps++ = (char)value;
3283 (void)SvPOK_only(TARG);
3284 if (PL_encoding && !IN_BYTES) {
3285 sv_recode_to_utf8(TARG, PL_encoding);
3287 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3288 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3292 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3293 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3308 const char *tmps = SvPV_const(left, len);
3310 if (DO_UTF8(left)) {
3311 /* If Unicode, try to downgrade.
3312 * If not possible, croak.
3313 * Yes, we made this up. */
3314 SV* const tsv = sv_2mortal(newSVsv(left));
3317 sv_utf8_downgrade(tsv, FALSE);
3318 tmps = SvPV_const(tsv, len);
3320 # ifdef USE_ITHREADS
3322 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3323 /* This should be threadsafe because in ithreads there is only
3324 * one thread per interpreter. If this would not be true,
3325 * we would need a mutex to protect this malloc. */
3326 PL_reentrant_buffer->_crypt_struct_buffer =
3327 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3328 #if defined(__GLIBC__) || defined(__EMX__)
3329 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3330 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3331 /* work around glibc-2.2.5 bug */
3332 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3336 # endif /* HAS_CRYPT_R */
3337 # endif /* USE_ITHREADS */
3339 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3341 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3347 "The crypt() function is unimplemented due to excessive paranoia.");
3358 const int op_type = PL_op->op_type;
3362 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3363 UTF8_IS_START(*s)) {
3364 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3368 utf8_to_uvchr(s, &ulen);
3369 if (op_type == OP_UCFIRST) {
3370 toTITLE_utf8(s, tmpbuf, &tculen);
3372 toLOWER_utf8(s, tmpbuf, &tculen);
3375 if (!SvPADTMP(sv) || SvREADONLY(sv) || ulen != tculen) {
3377 /* slen is the byte length of the whole SV.
3378 * ulen is the byte length of the original Unicode character
3379 * stored as UTF-8 at s.
3380 * tculen is the byte length of the freshly titlecased (or
3381 * lowercased) Unicode character stored as UTF-8 at tmpbuf.
3382 * We first set the result to be the titlecased (/lowercased)
3383 * character, and then append the rest of the SV data. */
3384 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3386 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3392 s = (U8*)SvPV_force_nomg(sv, slen);
3393 Copy(tmpbuf, s, tculen, U8);
3398 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3400 SvUTF8_off(TARG); /* decontaminate */
3401 sv_setsv_nomg(TARG, sv);
3405 s1 = (U8*)SvPV_force_nomg(sv, slen);
3407 if (IN_LOCALE_RUNTIME) {
3410 *s1 = (op_type == OP_UCFIRST)
3411 ? toUPPER_LC(*s1) : toLOWER_LC(*s1);
3414 *s1 = (op_type == OP_UCFIRST) ? toUPPER(*s1) : toLOWER(*s1);
3435 U8 tmpbuf[UTF8_MAXBYTES+1];
3437 s = (const U8*)SvPV_nomg_const(sv,len);
3439 SvUTF8_off(TARG); /* decontaminate */
3440 sv_setpvn(TARG, "", 0);
3445 STRLEN min = len + 1;
3447 SvUPGRADE(TARG, SVt_PV);
3449 (void)SvPOK_only(TARG);
3450 d = (U8*)SvPVX(TARG);
3453 STRLEN u = UTF8SKIP(s);
3455 toUPPER_utf8(s, tmpbuf, &ulen);
3456 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3457 /* If the eventually required minimum size outgrows
3458 * the available space, we need to grow. */
3459 const UV o = d - (U8*)SvPVX_const(TARG);
3461 /* If someone uppercases one million U+03B0s we
3462 * SvGROW() one million times. Or we could try
3463 * guessing how much to allocate without allocating
3464 * too much. Such is life. */
3466 d = (U8*)SvPVX(TARG) + o;
3468 Copy(tmpbuf, d, ulen, U8);
3474 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3481 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3483 SvUTF8_off(TARG); /* decontaminate */
3484 sv_setsv_nomg(TARG, sv);
3488 s = (U8*)SvPV_force_nomg(sv, len);
3490 register const U8 *send = s + len;
3492 if (IN_LOCALE_RUNTIME) {
3495 for (; s < send; s++)
3496 *s = toUPPER_LC(*s);
3499 for (; s < send; s++)
3522 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3524 s = (const U8*)SvPV_nomg_const(sv,len);
3526 SvUTF8_off(TARG); /* decontaminate */
3527 sv_setpvn(TARG, "", 0);
3532 STRLEN min = len + 1;
3534 SvUPGRADE(TARG, SVt_PV);
3536 (void)SvPOK_only(TARG);
3537 d = (U8*)SvPVX(TARG);
3540 const STRLEN u = UTF8SKIP(s);
3541 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3543 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3544 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3547 * Now if the sigma is NOT followed by
3548 * /$ignorable_sequence$cased_letter/;
3549 * and it IS preceded by
3550 * /$cased_letter$ignorable_sequence/;
3551 * where $ignorable_sequence is
3552 * [\x{2010}\x{AD}\p{Mn}]*
3553 * and $cased_letter is
3554 * [\p{Ll}\p{Lo}\p{Lt}]
3555 * then it should be mapped to 0x03C2,
3556 * (GREEK SMALL LETTER FINAL SIGMA),
3557 * instead of staying 0x03A3.
3558 * "should be": in other words,
3559 * this is not implemented yet.
3560 * See lib/unicore/SpecialCasing.txt.
3563 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3564 /* If the eventually required minimum size outgrows
3565 * the available space, we need to grow. */
3566 const UV o = d - (U8*)SvPVX_const(TARG);
3568 /* If someone lowercases one million U+0130s we
3569 * SvGROW() one million times. Or we could try
3570 * guessing how much to allocate without allocating.
3571 * too much. Such is life. */
3573 d = (U8*)SvPVX(TARG) + o;
3575 Copy(tmpbuf, d, ulen, U8);
3581 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3588 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3590 SvUTF8_off(TARG); /* decontaminate */
3591 sv_setsv_nomg(TARG, sv);
3596 s = (U8*)SvPV_force_nomg(sv, len);
3598 register const U8 * const send = s + len;
3600 if (IN_LOCALE_RUNTIME) {
3603 for (; s < send; s++)
3604 *s = toLOWER_LC(*s);
3607 for (; s < send; s++)
3619 SV * const sv = TOPs;
3621 register const char *s = SvPV_const(sv,len);
3623 SvUTF8_off(TARG); /* decontaminate */
3626 SvUPGRADE(TARG, SVt_PV);
3627 SvGROW(TARG, (len * 2) + 1);
3631 if (UTF8_IS_CONTINUED(*s)) {
3632 STRLEN ulen = UTF8SKIP(s);
3656 SvCUR_set(TARG, d - SvPVX_const(TARG));
3657 (void)SvPOK_only_UTF8(TARG);
3660 sv_setpvn(TARG, s, len);
3662 if (SvSMAGICAL(TARG))
3671 dVAR; dSP; dMARK; dORIGMARK;
3672 register AV* const av = (AV*)POPs;
3673 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3675 if (SvTYPE(av) == SVt_PVAV) {
3676 const I32 arybase = PL_curcop->cop_arybase;
3677 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3680 for (svp = MARK + 1; svp <= SP; svp++) {
3681 const I32 elem = SvIVx(*svp);
3685 if (max > AvMAX(av))
3688 while (++MARK <= SP) {
3690 I32 elem = SvIVx(*MARK);
3694 svp = av_fetch(av, elem, lval);
3696 if (!svp || *svp == &PL_sv_undef)
3697 DIE(aTHX_ PL_no_aelem, elem);
3698 if (PL_op->op_private & OPpLVAL_INTRO)
3699 save_aelem(av, elem, svp);
3701 *MARK = svp ? *svp : &PL_sv_undef;
3704 if (GIMME != G_ARRAY) {
3706 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3712 /* Associative arrays. */
3718 HV * const hash = (HV*)POPs;
3720 const I32 gimme = GIMME_V;
3723 /* might clobber stack_sp */
3724 entry = hv_iternext(hash);
3729 SV* const sv = hv_iterkeysv(entry);
3730 PUSHs(sv); /* won't clobber stack_sp */
3731 if (gimme == G_ARRAY) {
3734 /* might clobber stack_sp */
3735 val = hv_iterval(hash, entry);
3740 else if (gimme == G_SCALAR)
3750 const I32 gimme = GIMME_V;
3751 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3753 if (PL_op->op_private & OPpSLICE) {
3755 HV * const hv = (HV*)POPs;
3756 const U32 hvtype = SvTYPE(hv);
3757 if (hvtype == SVt_PVHV) { /* hash element */
3758 while (++MARK <= SP) {
3759 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3760 *MARK = sv ? sv : &PL_sv_undef;
3763 else if (hvtype == SVt_PVAV) { /* array element */
3764 if (PL_op->op_flags & OPf_SPECIAL) {
3765 while (++MARK <= SP) {
3766 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3767 *MARK = sv ? sv : &PL_sv_undef;
3772 DIE(aTHX_ "Not a HASH reference");
3775 else if (gimme == G_SCALAR) {
3780 *++MARK = &PL_sv_undef;
3786 HV * const hv = (HV*)POPs;
3788 if (SvTYPE(hv) == SVt_PVHV)
3789 sv = hv_delete_ent(hv, keysv, discard, 0);
3790 else if (SvTYPE(hv) == SVt_PVAV) {
3791 if (PL_op->op_flags & OPf_SPECIAL)
3792 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3794 DIE(aTHX_ "panic: avhv_delete no longer supported");
3797 DIE(aTHX_ "Not a HASH reference");
3813 if (PL_op->op_private & OPpEXISTS_SUB) {
3815 SV * const sv = POPs;
3816 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
3819 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3825 if (SvTYPE(hv) == SVt_PVHV) {
3826 if (hv_exists_ent(hv, tmpsv, 0))
3829 else if (SvTYPE(hv) == SVt_PVAV) {
3830 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3831 if (av_exists((AV*)hv, SvIV(tmpsv)))
3836 DIE(aTHX_ "Not a HASH reference");
3843 dVAR; dSP; dMARK; dORIGMARK;
3844 register HV * const hv = (HV*)POPs;
3845 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3846 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3847 bool other_magic = FALSE;
3853 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3854 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3855 /* Try to preserve the existenceness of a tied hash
3856 * element by using EXISTS and DELETE if possible.
3857 * Fallback to FETCH and STORE otherwise */
3858 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3859 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3860 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3863 while (++MARK <= SP) {
3864 SV * const keysv = *MARK;
3867 bool preeminent = FALSE;
3870 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3871 hv_exists_ent(hv, keysv, 0);
3874 he = hv_fetch_ent(hv, keysv, lval, 0);
3875 svp = he ? &HeVAL(he) : 0;
3878 if (!svp || *svp == &PL_sv_undef) {
3879 DIE(aTHX_ PL_no_helem_sv, keysv);
3882 if (HvNAME_get(hv) && isGV(*svp))
3883 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
3886 save_helem(hv, keysv, svp);
3889 const char *key = SvPV_const(keysv, keylen);
3890 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3895 *MARK = svp ? *svp : &PL_sv_undef;
3897 if (GIMME != G_ARRAY) {
3899 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3905 /* List operators. */
3910 if (GIMME != G_ARRAY) {
3912 *MARK = *SP; /* unwanted list, return last item */
3914 *MARK = &PL_sv_undef;
3924 SV ** const lastrelem = PL_stack_sp;
3925 SV ** const lastlelem = PL_stack_base + POPMARK;
3926 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
3927 register SV ** const firstrelem = lastlelem + 1;
3928 const I32 arybase = PL_curcop->cop_arybase;
3929 I32 is_something_there = PL_op->op_flags & OPf_MOD;
3931 register const I32 max = lastrelem - lastlelem;
3932 register SV **lelem;
3934 if (GIMME != G_ARRAY) {
3935 I32 ix = SvIVx(*lastlelem);
3940 if (ix < 0 || ix >= max)
3941 *firstlelem = &PL_sv_undef;
3943 *firstlelem = firstrelem[ix];
3949 SP = firstlelem - 1;
3953 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
3954 I32 ix = SvIVx(*lelem);
3959 if (ix < 0 || ix >= max)
3960 *lelem = &PL_sv_undef;
3962 is_something_there = TRUE;
3963 if (!(*lelem = firstrelem[ix]))
3964 *lelem = &PL_sv_undef;
3967 if (is_something_there)
3970 SP = firstlelem - 1;
3976 dVAR; dSP; dMARK; dORIGMARK;
3977 const I32 items = SP - MARK;
3978 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
3979 SP = ORIGMARK; /* av_make() might realloc stack_sp */
3986 dVAR; dSP; dMARK; dORIGMARK;
3987 HV* const hv = (HV*)sv_2mortal((SV*)newHV());
3990 SV * const key = *++MARK;
3991 SV * const val = newSV(0);
3993 sv_setsv(val, *++MARK);
3994 else if (ckWARN(WARN_MISC))
3995 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
3996 (void)hv_store_ent(hv,key,val,0);
4005 dVAR; dSP; dMARK; dORIGMARK;
4006 register AV *ary = (AV*)*++MARK;
4010 register I32 offset;
4011 register I32 length;
4015 SV **tmparyval = NULL;
4016 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4019 *MARK-- = SvTIED_obj((SV*)ary, mg);
4023 call_method("SPLICE",GIMME_V);
4032 offset = i = SvIVx(*MARK);
4034 offset += AvFILLp(ary) + 1;
4036 offset -= PL_curcop->cop_arybase;
4038 DIE(aTHX_ PL_no_aelem, i);
4040 length = SvIVx(*MARK++);
4042 length += AvFILLp(ary) - offset + 1;
4048 length = AvMAX(ary) + 1; /* close enough to infinity */
4052 length = AvMAX(ary) + 1;
4054 if (offset > AvFILLp(ary) + 1) {
4055 if (ckWARN(WARN_MISC))
4056 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4057 offset = AvFILLp(ary) + 1;
4059 after = AvFILLp(ary) + 1 - (offset + length);
4060 if (after < 0) { /* not that much array */
4061 length += after; /* offset+length now in array */
4067 /* At this point, MARK .. SP-1 is our new LIST */
4070 diff = newlen - length;
4071 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4074 /* make new elements SVs now: avoid problems if they're from the array */
4075 for (dst = MARK, i = newlen; i; i--) {
4076 SV * const h = *dst;
4077 *dst++ = newSVsv(h);
4080 if (diff < 0) { /* shrinking the area */
4082 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4083 Copy(MARK, tmparyval, newlen, SV*);
4086 MARK = ORIGMARK + 1;
4087 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4088 MEXTEND(MARK, length);
4089 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4091 EXTEND_MORTAL(length);
4092 for (i = length, dst = MARK; i; i--) {
4093 sv_2mortal(*dst); /* free them eventualy */
4100 *MARK = AvARRAY(ary)[offset+length-1];
4103 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4104 SvREFCNT_dec(*dst++); /* free them now */
4107 AvFILLp(ary) += diff;
4109 /* pull up or down? */
4111 if (offset < after) { /* easier to pull up */
4112 if (offset) { /* esp. if nothing to pull */
4113 src = &AvARRAY(ary)[offset-1];
4114 dst = src - diff; /* diff is negative */
4115 for (i = offset; i > 0; i--) /* can't trust Copy */
4119 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4123 if (after) { /* anything to pull down? */
4124 src = AvARRAY(ary) + offset + length;
4125 dst = src + diff; /* diff is negative */
4126 Move(src, dst, after, SV*);
4128 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4129 /* avoid later double free */
4133 dst[--i] = &PL_sv_undef;
4136 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4137 Safefree(tmparyval);
4140 else { /* no, expanding (or same) */
4142 Newx(tmparyval, length, SV*); /* so remember deletion */
4143 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4146 if (diff > 0) { /* expanding */
4148 /* push up or down? */
4150 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4154 Move(src, dst, offset, SV*);
4156 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4158 AvFILLp(ary) += diff;
4161 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4162 av_extend(ary, AvFILLp(ary) + diff);
4163 AvFILLp(ary) += diff;
4166 dst = AvARRAY(ary) + AvFILLp(ary);
4168 for (i = after; i; i--) {
4176 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4179 MARK = ORIGMARK + 1;
4180 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4182 Copy(tmparyval, MARK, length, SV*);
4184 EXTEND_MORTAL(length);
4185 for (i = length, dst = MARK; i; i--) {
4186 sv_2mortal(*dst); /* free them eventualy */
4190 Safefree(tmparyval);
4194 else if (length--) {
4195 *MARK = tmparyval[length];
4198 while (length-- > 0)
4199 SvREFCNT_dec(tmparyval[length]);
4201 Safefree(tmparyval);
4204 *MARK = &PL_sv_undef;
4212 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4213 register AV *ary = (AV*)*++MARK;
4214 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4217 *MARK-- = SvTIED_obj((SV*)ary, mg);
4221 call_method("PUSH",G_SCALAR|G_DISCARD);
4225 PUSHi( AvFILL(ary) + 1 );
4228 for (++MARK; MARK <= SP; MARK++) {
4229 SV * const sv = newSV(0);
4231 sv_setsv(sv, *MARK);
4232 av_store(ary, AvFILLp(ary)+1, sv);
4235 PUSHi( AvFILLp(ary) + 1 );
4244 AV * const av = (AV*)POPs;
4245 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4249 (void)sv_2mortal(sv);
4256 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4257 register AV *ary = (AV*)*++MARK;
4258 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4261 *MARK-- = SvTIED_obj((SV*)ary, mg);
4265 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4271 av_unshift(ary, SP - MARK);
4273 SV * const sv = newSVsv(*++MARK);
4274 (void)av_store(ary, i++, sv);
4278 PUSHi( AvFILL(ary) + 1 );
4285 SV ** const oldsp = SP;
4287 if (GIMME == G_ARRAY) {
4290 register SV * const tmp = *MARK;
4294 /* safe as long as stack cannot get extended in the above */
4299 register char *down;
4305 SvUTF8_off(TARG); /* decontaminate */
4307 do_join(TARG, &PL_sv_no, MARK, SP);
4309 sv_setsv(TARG, (SP > MARK)
4311 : (padoff_du = find_rundefsvoffset(),
4312 (padoff_du == NOT_IN_PAD
4313 || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
4314 ? DEFSV : PAD_SVl(padoff_du)));
4315 up = SvPV_force(TARG, len);
4317 if (DO_UTF8(TARG)) { /* first reverse each character */
4318 U8* s = (U8*)SvPVX(TARG);
4319 const U8* send = (U8*)(s + len);
4321 if (UTF8_IS_INVARIANT(*s)) {
4326 if (!utf8_to_uvchr(s, 0))
4330 down = (char*)(s - 1);
4331 /* reverse this character */
4335 *down-- = (char)tmp;
4341 down = SvPVX(TARG) + len - 1;
4345 *down-- = (char)tmp;
4347 (void)SvPOK_only_UTF8(TARG);
4359 register IV limit = POPi; /* note, negative is forever */
4360 SV * const sv = POPs;
4362 register const char *s = SvPV_const(sv, len);
4363 const bool do_utf8 = DO_UTF8(sv);
4364 const char *strend = s + len;
4366 register REGEXP *rx;
4368 register const char *m;
4370 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4371 I32 maxiters = slen + 10;
4373 const I32 origlimit = limit;
4376 const I32 gimme = GIMME_V;
4377 const I32 oldsave = PL_savestack_ix;
4378 I32 make_mortal = 1;
4383 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4388 DIE(aTHX_ "panic: pp_split");
4391 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4392 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4394 RX_MATCH_UTF8_set(rx, do_utf8);
4396 if (pm->op_pmreplroot) {
4398 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4400 ary = GvAVn((GV*)pm->op_pmreplroot);
4403 else if (gimme != G_ARRAY)
4404 ary = GvAVn(PL_defgv);
4407 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4413 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4415 XPUSHs(SvTIED_obj((SV*)ary, mg));
4422 for (i = AvFILLp(ary); i >= 0; i--)
4423 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4425 /* temporarily switch stacks */
4426 SAVESWITCHSTACK(PL_curstack, ary);
4430 base = SP - PL_stack_base;
4432 if (pm->op_pmflags & PMf_SKIPWHITE) {
4433 if (pm->op_pmflags & PMf_LOCALE) {
4434 while (isSPACE_LC(*s))
4442 if (pm->op_pmflags & PMf_MULTILINE) {
4447 limit = maxiters + 2;
4448 if (pm->op_pmflags & PMf_WHITE) {
4451 while (m < strend &&
4452 !((pm->op_pmflags & PMf_LOCALE)
4453 ? isSPACE_LC(*m) : isSPACE(*m)))
4458 dstr = newSVpvn(s, m-s);
4462 (void)SvUTF8_on(dstr);
4466 while (s < strend &&
4467 ((pm->op_pmflags & PMf_LOCALE)
4468 ? isSPACE_LC(*s) : isSPACE(*s)))
4472 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4474 for (m = s; m < strend && *m != '\n'; m++)
4479 dstr = newSVpvn(s, m-s);
4483 (void)SvUTF8_on(dstr);
4488 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4489 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4490 && (rx->reganch & ROPT_CHECK_ALL)
4491 && !(rx->reganch & ROPT_ANCH)) {
4492 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4493 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4496 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4497 const char c = *SvPV_nolen_const(csv);
4499 for (m = s; m < strend && *m != c; m++)
4503 dstr = newSVpvn(s, m-s);
4507 (void)SvUTF8_on(dstr);
4509 /* The rx->minlen is in characters but we want to step
4510 * s ahead by bytes. */
4512 s = (char*)utf8_hop((U8*)m, len);
4514 s = m + len; /* Fake \n at the end */
4518 while (s < strend && --limit &&
4519 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4520 csv, multiline ? FBMrf_MULTILINE : 0)) )
4522 dstr = newSVpvn(s, m-s);
4526 (void)SvUTF8_on(dstr);
4528 /* The rx->minlen is in characters but we want to step
4529 * s ahead by bytes. */
4531 s = (char*)utf8_hop((U8*)m, len);
4533 s = m + len; /* Fake \n at the end */
4538 maxiters += slen * rx->nparens;
4539 while (s < strend && --limit)
4543 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4546 if (rex_return == 0)
4548 TAINT_IF(RX_MATCH_TAINTED(rx));
4549 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4554 strend = s + (strend - m);
4556 m = rx->startp[0] + orig;
4557 dstr = newSVpvn(s, m-s);
4561 (void)SvUTF8_on(dstr);
4565 for (i = 1; i <= (I32)rx->nparens; i++) {
4566 s = rx->startp[i] + orig;
4567 m = rx->endp[i] + orig;
4569 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4570 parens that didn't match -- they should be set to
4571 undef, not the empty string */
4572 if (m >= orig && s >= orig) {
4573 dstr = newSVpvn(s, m-s);
4576 dstr = &PL_sv_undef; /* undef, not "" */
4580 (void)SvUTF8_on(dstr);
4584 s = rx->endp[0] + orig;
4588 iters = (SP - PL_stack_base) - base;
4589 if (iters > maxiters)
4590 DIE(aTHX_ "Split loop");
4592 /* keep field after final delim? */
4593 if (s < strend || (iters && origlimit)) {
4594 const STRLEN l = strend - s;
4595 dstr = newSVpvn(s, l);
4599 (void)SvUTF8_on(dstr);
4603 else if (!origlimit) {
4604 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4605 if (TOPs && !make_mortal)
4608 *SP-- = &PL_sv_undef;
4613 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4617 if (SvSMAGICAL(ary)) {
4622 if (gimme == G_ARRAY) {
4624 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4632 call_method("PUSH",G_SCALAR|G_DISCARD);
4635 if (gimme == G_ARRAY) {
4637 /* EXTEND should not be needed - we just popped them */
4639 for (i=0; i < iters; i++) {
4640 SV **svp = av_fetch(ary, i, FALSE);
4641 PUSHs((svp) ? *svp : &PL_sv_undef);
4648 if (gimme == G_ARRAY)
4664 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4665 || SvTYPE(retsv) == SVt_PVCV) {
4666 retsv = refto(retsv);
4673 PP(unimplemented_op)
4676 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4682 * c-indentation-style: bsd
4684 * indent-tabs-mode: t
4687 * ex: set ts=8 sts=4 sw=4 noet: