3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 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 */
51 if (GIMME_V == G_SCALAR)
62 if (PL_op->op_private & OPpLVAL_INTRO)
63 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
65 if (PL_op->op_flags & OPf_REF) {
69 if (GIMME == G_SCALAR)
70 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
75 if (gimme == G_ARRAY) {
76 const I32 maxarg = AvFILL((AV*)TARG) + 1;
78 if (SvMAGICAL(TARG)) {
80 for (i=0; i < (U32)maxarg; i++) {
81 SV ** const svp = av_fetch((AV*)TARG, i, FALSE);
82 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
86 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
90 else if (gimme == G_SCALAR) {
91 SV* const sv = sv_newmortal();
92 const I32 maxarg = AvFILL((AV*)TARG) + 1;
105 if (PL_op->op_private & OPpLVAL_INTRO)
106 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
107 if (PL_op->op_flags & OPf_REF)
110 if (GIMME == G_SCALAR)
111 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
115 if (gimme == G_ARRAY) {
118 else if (gimme == G_SCALAR) {
119 SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
133 tryAMAGICunDEREF(to_gv);
136 if (SvTYPE(sv) == SVt_PVIO) {
137 GV * const gv = (GV*) sv_newmortal();
138 gv_init(gv, 0, "", 0, 0);
139 GvIOp(gv) = (IO *)sv;
140 (void)SvREFCNT_inc(sv);
143 else if (SvTYPE(sv) != SVt_PVGV)
144 DIE(aTHX_ "Not a GLOB reference");
147 if (SvTYPE(sv) != SVt_PVGV) {
148 if (SvGMAGICAL(sv)) {
153 if (!SvOK(sv) && sv != &PL_sv_undef) {
154 /* If this is a 'my' scalar and flag is set then vivify
158 Perl_croak(aTHX_ PL_no_modify);
159 if (PL_op->op_private & OPpDEREF) {
161 if (cUNOP->op_targ) {
163 SV *namesv = PAD_SV(cUNOP->op_targ);
164 const char *name = SvPV(namesv, len);
165 gv = (GV*)NEWSV(0,0);
166 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
169 const char *name = CopSTASHPV(PL_curcop);
172 if (SvTYPE(sv) < SVt_RV)
173 sv_upgrade(sv, SVt_RV);
174 if (SvPVX_const(sv)) {
179 SvRV_set(sv, (SV*)gv);
184 if (PL_op->op_flags & OPf_REF ||
185 PL_op->op_private & HINT_STRICT_REFS)
186 DIE(aTHX_ PL_no_usym, "a symbol");
187 if (ckWARN(WARN_UNINITIALIZED))
191 if ((PL_op->op_flags & OPf_SPECIAL) &&
192 !(PL_op->op_flags & OPf_MOD))
194 SV * const temp = (SV*)gv_fetchsv(sv, FALSE, SVt_PVGV);
196 && (!is_gv_magical_sv(sv,0)
197 || !(sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV)))) {
203 if (PL_op->op_private & HINT_STRICT_REFS)
204 DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
205 sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV);
209 if (PL_op->op_private & OPpLVAL_INTRO)
210 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
222 tryAMAGICunDEREF(to_sv);
225 switch (SvTYPE(sv)) {
229 DIE(aTHX_ "Not a SCALAR reference");
235 if (SvTYPE(gv) != SVt_PVGV) {
236 if (SvGMAGICAL(sv)) {
242 if (PL_op->op_flags & OPf_REF ||
243 PL_op->op_private & HINT_STRICT_REFS)
244 DIE(aTHX_ PL_no_usym, "a SCALAR");
245 if (ckWARN(WARN_UNINITIALIZED))
249 if ((PL_op->op_flags & OPf_SPECIAL) &&
250 !(PL_op->op_flags & OPf_MOD))
252 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PV);
254 && (!is_gv_magical_sv(sv, 0)
255 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV))))
261 if (PL_op->op_private & HINT_STRICT_REFS)
262 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
263 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV);
268 if (PL_op->op_flags & OPf_MOD) {
269 if (PL_op->op_private & OPpLVAL_INTRO) {
270 if (cUNOP->op_first->op_type == OP_NULL)
271 sv = save_scalar((GV*)TOPs);
273 sv = save_scalar(gv);
275 Perl_croak(aTHX_ PL_no_localize_ref);
277 else if (PL_op->op_private & OPpDEREF)
278 vivify_ref(sv, PL_op->op_private & OPpDEREF);
287 AV * const av = (AV*)TOPs;
288 SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
291 sv_upgrade(*sv, SVt_PVMG);
292 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
300 dSP; dTARGET; dPOPss;
302 if (PL_op->op_flags & OPf_MOD || LVRET) {
303 if (SvTYPE(TARG) < SVt_PVLV) {
304 sv_upgrade(TARG, SVt_PVLV);
305 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
309 if (LvTARG(TARG) != sv) {
311 SvREFCNT_dec(LvTARG(TARG));
312 LvTARG(TARG) = SvREFCNT_inc(sv);
314 PUSHs(TARG); /* no SvSETMAGIC */
318 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
319 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
320 if (mg && mg->mg_len >= 0) {
324 PUSHi(i + PL_curcop->cop_arybase);
338 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
339 /* (But not in defined().) */
340 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
343 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
344 if ((PL_op->op_private & OPpLVAL_INTRO)) {
345 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
348 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
352 cv = (CV*)&PL_sv_undef;
366 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
367 const char *s = SvPVX_const(TOPs);
368 if (strnEQ(s, "CORE::", 6)) {
369 const int code = keyword(s + 6, SvCUR(TOPs) - 6);
370 if (code < 0) { /* Overridable. */
371 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
372 int i = 0, n = 0, seen_question = 0;
374 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
376 if (code == -KEY_chop || code == -KEY_chomp
377 || code == -KEY_exec || code == -KEY_system)
379 while (i < MAXO) { /* The slow way. */
380 if (strEQ(s + 6, PL_op_name[i])
381 || strEQ(s + 6, PL_op_desc[i]))
387 goto nonesuch; /* Should not happen... */
389 oa = PL_opargs[i] >> OASHIFT;
391 if (oa & OA_OPTIONAL && !seen_question) {
395 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
396 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
397 /* But globs are already references (kinda) */
398 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
402 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
406 ret = sv_2mortal(newSVpvn(str, n - 1));
408 else if (code) /* Non-Overridable */
410 else { /* None such */
412 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
416 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
418 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
427 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
429 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
445 if (GIMME != G_ARRAY) {
449 *MARK = &PL_sv_undef;
450 *MARK = refto(*MARK);
454 EXTEND_MORTAL(SP - MARK);
456 *MARK = refto(*MARK);
461 S_refto(pTHX_ SV *sv)
465 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
468 if (!(sv = LvTARG(sv)))
471 (void)SvREFCNT_inc(sv);
473 else if (SvTYPE(sv) == SVt_PVAV) {
474 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
477 (void)SvREFCNT_inc(sv);
479 else if (SvPADTMP(sv) && !IS_PADGV(sv))
483 (void)SvREFCNT_inc(sv);
486 sv_upgrade(rv, SVt_RV);
496 SV * const sv = POPs;
501 if (!sv || !SvROK(sv))
504 pv = sv_reftype(SvRV(sv),TRUE);
505 PUSHp(pv, strlen(pv));
515 stash = CopSTASH(PL_curcop);
517 SV * const ssv = POPs;
521 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
522 Perl_croak(aTHX_ "Attempt to bless into a reference");
523 ptr = SvPV_const(ssv,len);
524 if (len == 0 && ckWARN(WARN_MISC))
525 Perl_warner(aTHX_ packWARN(WARN_MISC),
526 "Explicit blessing to '' (assuming package main)");
527 stash = gv_stashpvn(ptr, len, TRUE);
530 (void)sv_bless(TOPs, stash);
539 const char * const elem = SvPV_nolen_const(sv);
540 GV * const gv = (GV*)POPs;
541 SV * tmpRef = Nullsv;
545 /* elem will always be NUL terminated. */
546 const char * const second_letter = elem + 1;
549 if (strEQ(second_letter, "RRAY"))
550 tmpRef = (SV*)GvAV(gv);
553 if (strEQ(second_letter, "ODE"))
554 tmpRef = (SV*)GvCVu(gv);
557 if (strEQ(second_letter, "ILEHANDLE")) {
558 /* finally deprecated in 5.8.0 */
559 deprecate("*glob{FILEHANDLE}");
560 tmpRef = (SV*)GvIOp(gv);
563 if (strEQ(second_letter, "ORMAT"))
564 tmpRef = (SV*)GvFORM(gv);
567 if (strEQ(second_letter, "LOB"))
571 if (strEQ(second_letter, "ASH"))
572 tmpRef = (SV*)GvHV(gv);
575 if (*second_letter == 'O' && !elem[2])
576 tmpRef = (SV*)GvIOp(gv);
579 if (strEQ(second_letter, "AME"))
580 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
583 if (strEQ(second_letter, "ACKAGE")) {
584 const HEK *hek = HvNAME_HEK(GvSTASH(gv));
585 sv = hek ? newSVhek(hek) : newSVpvn("__ANON__", 8);
589 if (strEQ(second_letter, "CALAR"))
604 /* Pattern matching */
609 register unsigned char *s;
612 register I32 *sfirst;
616 if (sv == PL_lastscream) {
622 SvSCREAM_off(PL_lastscream);
623 SvREFCNT_dec(PL_lastscream);
625 PL_lastscream = SvREFCNT_inc(sv);
628 s = (unsigned char*)(SvPV(sv, len));
632 if (pos > PL_maxscream) {
633 if (PL_maxscream < 0) {
634 PL_maxscream = pos + 80;
635 Newx(PL_screamfirst, 256, I32);
636 Newx(PL_screamnext, PL_maxscream, I32);
639 PL_maxscream = pos + pos / 4;
640 Renew(PL_screamnext, PL_maxscream, I32);
644 sfirst = PL_screamfirst;
645 snext = PL_screamnext;
647 if (!sfirst || !snext)
648 DIE(aTHX_ "do_study: out of memory");
650 for (ch = 256; ch; --ch)
655 register const I32 ch = s[pos];
657 snext[pos] = sfirst[ch] - pos;
664 /* piggyback on m//g magic */
665 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
674 if (PL_op->op_flags & OPf_STACKED)
676 else if (PL_op->op_private & OPpTARGET_MY)
682 TARG = sv_newmortal();
687 /* Lvalue operators. */
699 dSP; dMARK; dTARGET; dORIGMARK;
701 do_chop(TARG, *++MARK);
710 SETi(do_chomp(TOPs));
717 register I32 count = 0;
720 count += do_chomp(POPs);
728 register SV* const sv = POPs;
730 if (!sv || !SvANY(sv))
732 switch (SvTYPE(sv)) {
734 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
735 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
739 if (HvARRAY(sv) || SvGMAGICAL(sv)
740 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
744 if (CvROOT(sv) || CvXSUB(sv))
760 if (!PL_op->op_private) {
769 SV_CHECK_THINKFIRST_COW_DROP(sv);
771 switch (SvTYPE(sv)) {
781 if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
782 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
783 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
787 /* let user-undef'd sub keep its identity */
788 GV* gv = CvGV((CV*)sv);
795 SvSetMagicSV(sv, &PL_sv_undef);
800 GvGP(sv) = gp_ref(gp);
801 GvSV(sv) = NEWSV(72,0);
802 GvLINE(sv) = CopLINE(PL_curcop);
808 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
810 SvPV_set(sv, Nullch);
823 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
824 DIE(aTHX_ PL_no_modify);
825 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
826 && SvIVX(TOPs) != IV_MIN)
828 SvIV_set(TOPs, SvIVX(TOPs) - 1);
829 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
840 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
841 DIE(aTHX_ PL_no_modify);
842 sv_setsv(TARG, TOPs);
843 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
844 && SvIVX(TOPs) != IV_MAX)
846 SvIV_set(TOPs, SvIVX(TOPs) + 1);
847 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
852 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
862 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
863 DIE(aTHX_ PL_no_modify);
864 sv_setsv(TARG, TOPs);
865 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
866 && SvIVX(TOPs) != IV_MIN)
868 SvIV_set(TOPs, SvIVX(TOPs) - 1);
869 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
878 /* Ordinary operators. */
883 #ifdef PERL_PRESERVE_IVUV
886 tryAMAGICbin(pow,opASSIGN);
887 #ifdef PERL_PRESERVE_IVUV
888 /* For integer to integer power, we do the calculation by hand wherever
889 we're sure it is safe; otherwise we call pow() and try to convert to
890 integer afterwards. */
903 const IV iv = SvIVX(TOPs);
907 goto float_it; /* Can't do negative powers this way. */
911 baseuok = SvUOK(TOPm1s);
913 baseuv = SvUVX(TOPm1s);
915 const IV iv = SvIVX(TOPm1s);
918 baseuok = TRUE; /* effectively it's a UV now */
920 baseuv = -iv; /* abs, baseuok == false records sign */
923 /* now we have integer ** positive integer. */
926 /* foo & (foo - 1) is zero only for a power of 2. */
927 if (!(baseuv & (baseuv - 1))) {
928 /* We are raising power-of-2 to a positive integer.
929 The logic here will work for any base (even non-integer
930 bases) but it can be less accurate than
931 pow (base,power) or exp (power * log (base)) when the
932 intermediate values start to spill out of the mantissa.
933 With powers of 2 we know this can't happen.
934 And powers of 2 are the favourite thing for perl
935 programmers to notice ** not doing what they mean. */
937 NV base = baseuok ? baseuv : -(NV)baseuv;
942 while (power >>= 1) {
953 register unsigned int highbit = 8 * sizeof(UV);
954 register unsigned int diff = 8 * sizeof(UV);
957 if (baseuv >> highbit) {
961 /* we now have baseuv < 2 ** highbit */
962 if (power * highbit <= 8 * sizeof(UV)) {
963 /* result will definitely fit in UV, so use UV math
964 on same algorithm as above */
965 register UV result = 1;
966 register UV base = baseuv;
967 const bool odd_power = (bool)(power & 1);
971 while (power >>= 1) {
978 if (baseuok || !odd_power)
979 /* answer is positive */
981 else if (result <= (UV)IV_MAX)
982 /* answer negative, fits in IV */
984 else if (result == (UV)IV_MIN)
985 /* 2's complement assumption: special case IV_MIN */
988 /* answer negative, doesn't fit */
1000 SETn( Perl_pow( left, right) );
1001 #ifdef PERL_PRESERVE_IVUV
1011 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1012 #ifdef PERL_PRESERVE_IVUV
1015 /* Unless the left argument is integer in range we are going to have to
1016 use NV maths. Hence only attempt to coerce the right argument if
1017 we know the left is integer. */
1018 /* Left operand is defined, so is it IV? */
1019 SvIV_please(TOPm1s);
1020 if (SvIOK(TOPm1s)) {
1021 bool auvok = SvUOK(TOPm1s);
1022 bool buvok = SvUOK(TOPs);
1023 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1024 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1031 alow = SvUVX(TOPm1s);
1033 const IV aiv = SvIVX(TOPm1s);
1036 auvok = TRUE; /* effectively it's a UV now */
1038 alow = -aiv; /* abs, auvok == false records sign */
1044 const IV biv = SvIVX(TOPs);
1047 buvok = TRUE; /* effectively it's a UV now */
1049 blow = -biv; /* abs, buvok == false records sign */
1053 /* If this does sign extension on unsigned it's time for plan B */
1054 ahigh = alow >> (4 * sizeof (UV));
1056 bhigh = blow >> (4 * sizeof (UV));
1058 if (ahigh && bhigh) {
1059 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1060 which is overflow. Drop to NVs below. */
1061 } else if (!ahigh && !bhigh) {
1062 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1063 so the unsigned multiply cannot overflow. */
1064 UV product = alow * blow;
1065 if (auvok == buvok) {
1066 /* -ve * -ve or +ve * +ve gives a +ve result. */
1070 } else if (product <= (UV)IV_MIN) {
1071 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1072 /* -ve result, which could overflow an IV */
1074 SETi( -(IV)product );
1076 } /* else drop to NVs below. */
1078 /* One operand is large, 1 small */
1081 /* swap the operands */
1083 bhigh = blow; /* bhigh now the temp var for the swap */
1087 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1088 multiplies can't overflow. shift can, add can, -ve can. */
1089 product_middle = ahigh * blow;
1090 if (!(product_middle & topmask)) {
1091 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1093 product_middle <<= (4 * sizeof (UV));
1094 product_low = alow * blow;
1096 /* as for pp_add, UV + something mustn't get smaller.
1097 IIRC ANSI mandates this wrapping *behaviour* for
1098 unsigned whatever the actual representation*/
1099 product_low += product_middle;
1100 if (product_low >= product_middle) {
1101 /* didn't overflow */
1102 if (auvok == buvok) {
1103 /* -ve * -ve or +ve * +ve gives a +ve result. */
1105 SETu( product_low );
1107 } else if (product_low <= (UV)IV_MIN) {
1108 /* 2s complement assumption again */
1109 /* -ve result, which could overflow an IV */
1111 SETi( -(IV)product_low );
1113 } /* else drop to NVs below. */
1115 } /* product_middle too large */
1116 } /* ahigh && bhigh */
1117 } /* SvIOK(TOPm1s) */
1122 SETn( left * right );
1129 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1130 /* Only try to do UV divide first
1131 if ((SLOPPYDIVIDE is true) or
1132 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1134 The assumption is that it is better to use floating point divide
1135 whenever possible, only doing integer divide first if we can't be sure.
1136 If NV_PRESERVES_UV is true then we know at compile time that no UV
1137 can be too large to preserve, so don't need to compile the code to
1138 test the size of UVs. */
1141 # define PERL_TRY_UV_DIVIDE
1142 /* ensure that 20./5. == 4. */
1144 # ifdef PERL_PRESERVE_IVUV
1145 # ifndef NV_PRESERVES_UV
1146 # define PERL_TRY_UV_DIVIDE
1151 #ifdef PERL_TRY_UV_DIVIDE
1154 SvIV_please(TOPm1s);
1155 if (SvIOK(TOPm1s)) {
1156 bool left_non_neg = SvUOK(TOPm1s);
1157 bool right_non_neg = SvUOK(TOPs);
1161 if (right_non_neg) {
1162 right = SvUVX(TOPs);
1165 const IV biv = SvIVX(TOPs);
1168 right_non_neg = TRUE; /* effectively it's a UV now */
1174 /* historically undef()/0 gives a "Use of uninitialized value"
1175 warning before dieing, hence this test goes here.
1176 If it were immediately before the second SvIV_please, then
1177 DIE() would be invoked before left was even inspected, so
1178 no inpsection would give no warning. */
1180 DIE(aTHX_ "Illegal division by zero");
1183 left = SvUVX(TOPm1s);
1186 const IV aiv = SvIVX(TOPm1s);
1189 left_non_neg = TRUE; /* effectively it's a UV now */
1198 /* For sloppy divide we always attempt integer division. */
1200 /* Otherwise we only attempt it if either or both operands
1201 would not be preserved by an NV. If both fit in NVs
1202 we fall through to the NV divide code below. However,
1203 as left >= right to ensure integer result here, we know that
1204 we can skip the test on the right operand - right big
1205 enough not to be preserved can't get here unless left is
1208 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1211 /* Integer division can't overflow, but it can be imprecise. */
1212 const UV result = left / right;
1213 if (result * right == left) {
1214 SP--; /* result is valid */
1215 if (left_non_neg == right_non_neg) {
1216 /* signs identical, result is positive. */
1220 /* 2s complement assumption */
1221 if (result <= (UV)IV_MIN)
1222 SETi( -(IV)result );
1224 /* It's exact but too negative for IV. */
1225 SETn( -(NV)result );
1228 } /* tried integer divide but it was not an integer result */
1229 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1230 } /* left wasn't SvIOK */
1231 } /* right wasn't SvIOK */
1232 #endif /* PERL_TRY_UV_DIVIDE */
1236 DIE(aTHX_ "Illegal division by zero");
1237 PUSHn( left / right );
1244 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1248 bool left_neg = FALSE;
1249 bool right_neg = FALSE;
1250 bool use_double = FALSE;
1251 bool dright_valid = FALSE;
1257 right_neg = !SvUOK(TOPs);
1259 right = SvUVX(POPs);
1261 const IV biv = SvIVX(POPs);
1264 right_neg = FALSE; /* effectively it's a UV now */
1272 right_neg = dright < 0;
1275 if (dright < UV_MAX_P1) {
1276 right = U_V(dright);
1277 dright_valid = TRUE; /* In case we need to use double below. */
1283 /* At this point use_double is only true if right is out of range for
1284 a UV. In range NV has been rounded down to nearest UV and
1285 use_double false. */
1287 if (!use_double && SvIOK(TOPs)) {
1289 left_neg = !SvUOK(TOPs);
1293 IV aiv = SvIVX(POPs);
1296 left_neg = FALSE; /* effectively it's a UV now */
1305 left_neg = dleft < 0;
1309 /* This should be exactly the 5.6 behaviour - if left and right are
1310 both in range for UV then use U_V() rather than floor. */
1312 if (dleft < UV_MAX_P1) {
1313 /* right was in range, so is dleft, so use UVs not double.
1317 /* left is out of range for UV, right was in range, so promote
1318 right (back) to double. */
1320 /* The +0.5 is used in 5.6 even though it is not strictly
1321 consistent with the implicit +0 floor in the U_V()
1322 inside the #if 1. */
1323 dleft = Perl_floor(dleft + 0.5);
1326 dright = Perl_floor(dright + 0.5);
1336 DIE(aTHX_ "Illegal modulus zero");
1338 dans = Perl_fmod(dleft, dright);
1339 if ((left_neg != right_neg) && dans)
1340 dans = dright - dans;
1343 sv_setnv(TARG, dans);
1349 DIE(aTHX_ "Illegal modulus zero");
1352 if ((left_neg != right_neg) && ans)
1355 /* XXX may warn: unary minus operator applied to unsigned type */
1356 /* could change -foo to be (~foo)+1 instead */
1357 if (ans <= ~((UV)IV_MAX)+1)
1358 sv_setiv(TARG, ~ans+1);
1360 sv_setnv(TARG, -(NV)ans);
1363 sv_setuv(TARG, ans);
1372 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1379 const UV uv = SvUV(sv);
1381 count = IV_MAX; /* The best we can do? */
1392 else if (SvNOKp(sv)) {
1393 const NV nv = SvNV(sv);
1401 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1403 I32 items = SP - MARK;
1405 static const char oom_list_extend[] =
1406 "Out of memory during list extend";
1408 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 */
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 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 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 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1618 const IV shift = POPi;
1619 if (PL_op->op_private & HINT_INTEGER) {
1633 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1635 const IV shift = POPi;
1636 if (PL_op->op_private & HINT_INTEGER) {
1650 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)));
1718 SETs(boolSV(TOPn < value));
1725 dSP; tryAMAGICbinSET(gt,0);
1726 #ifdef PERL_PRESERVE_IVUV
1729 SvIV_please(TOPm1s);
1730 if (SvIOK(TOPm1s)) {
1731 bool auvok = SvUOK(TOPm1s);
1732 bool buvok = SvUOK(TOPs);
1734 if (!auvok && !buvok) { /* ## IV > IV ## */
1735 const IV aiv = SvIVX(TOPm1s);
1736 const IV biv = SvIVX(TOPs);
1739 SETs(boolSV(aiv > biv));
1742 if (auvok && buvok) { /* ## UV > UV ## */
1743 const UV auv = SvUVX(TOPm1s);
1744 const UV buv = SvUVX(TOPs);
1747 SETs(boolSV(auv > buv));
1750 if (auvok) { /* ## UV > IV ## */
1752 const IV biv = SvIVX(TOPs);
1756 /* As (a) is a UV, it's >=0, so it must be > */
1761 SETs(boolSV(auv > (UV)biv));
1764 { /* ## IV > UV ## */
1765 const IV aiv = SvIVX(TOPm1s);
1769 /* As (b) is a UV, it's >=0, so it cannot be > */
1776 SETs(boolSV((UV)aiv > buv));
1782 #ifndef NV_PRESERVES_UV
1783 #ifdef PERL_PRESERVE_IVUV
1786 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1788 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1794 SETs(boolSV(TOPn > value));
1801 dSP; tryAMAGICbinSET(le,0);
1802 #ifdef PERL_PRESERVE_IVUV
1805 SvIV_please(TOPm1s);
1806 if (SvIOK(TOPm1s)) {
1807 bool auvok = SvUOK(TOPm1s);
1808 bool buvok = SvUOK(TOPs);
1810 if (!auvok && !buvok) { /* ## IV <= IV ## */
1811 const IV aiv = SvIVX(TOPm1s);
1812 const IV biv = SvIVX(TOPs);
1815 SETs(boolSV(aiv <= biv));
1818 if (auvok && buvok) { /* ## UV <= UV ## */
1819 UV auv = SvUVX(TOPm1s);
1820 UV buv = SvUVX(TOPs);
1823 SETs(boolSV(auv <= buv));
1826 if (auvok) { /* ## UV <= IV ## */
1828 const IV biv = SvIVX(TOPs);
1832 /* As (a) is a UV, it's >=0, so a cannot be <= */
1837 SETs(boolSV(auv <= (UV)biv));
1840 { /* ## IV <= UV ## */
1841 const IV aiv = SvIVX(TOPm1s);
1845 /* As (b) is a UV, it's >=0, so a must be <= */
1852 SETs(boolSV((UV)aiv <= buv));
1858 #ifndef NV_PRESERVES_UV
1859 #ifdef PERL_PRESERVE_IVUV
1862 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1864 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1870 SETs(boolSV(TOPn <= value));
1877 dSP; tryAMAGICbinSET(ge,0);
1878 #ifdef PERL_PRESERVE_IVUV
1881 SvIV_please(TOPm1s);
1882 if (SvIOK(TOPm1s)) {
1883 bool auvok = SvUOK(TOPm1s);
1884 bool buvok = SvUOK(TOPs);
1886 if (!auvok && !buvok) { /* ## IV >= IV ## */
1887 const IV aiv = SvIVX(TOPm1s);
1888 const IV biv = SvIVX(TOPs);
1891 SETs(boolSV(aiv >= biv));
1894 if (auvok && buvok) { /* ## UV >= UV ## */
1895 const UV auv = SvUVX(TOPm1s);
1896 const UV buv = SvUVX(TOPs);
1899 SETs(boolSV(auv >= buv));
1902 if (auvok) { /* ## UV >= IV ## */
1904 const IV biv = SvIVX(TOPs);
1908 /* As (a) is a UV, it's >=0, so it must be >= */
1913 SETs(boolSV(auv >= (UV)biv));
1916 { /* ## IV >= UV ## */
1917 const IV aiv = SvIVX(TOPm1s);
1921 /* As (b) is a UV, it's >=0, so a cannot be >= */
1928 SETs(boolSV((UV)aiv >= buv));
1934 #ifndef NV_PRESERVES_UV
1935 #ifdef PERL_PRESERVE_IVUV
1938 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1940 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1946 SETs(boolSV(TOPn >= value));
1953 dSP; tryAMAGICbinSET(ne,0);
1954 #ifndef NV_PRESERVES_UV
1955 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1957 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1961 #ifdef PERL_PRESERVE_IVUV
1964 SvIV_please(TOPm1s);
1965 if (SvIOK(TOPm1s)) {
1966 bool auvok = SvUOK(TOPm1s);
1967 bool buvok = SvUOK(TOPs);
1969 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1970 /* Casting IV to UV before comparison isn't going to matter
1971 on 2s complement. On 1s complement or sign&magnitude
1972 (if we have any of them) it could make negative zero
1973 differ from normal zero. As I understand it. (Need to
1974 check - is negative zero implementation defined behaviour
1976 const UV buv = SvUVX(POPs);
1977 const UV auv = SvUVX(TOPs);
1979 SETs(boolSV(auv != buv));
1982 { /* ## Mixed IV,UV ## */
1986 /* != is commutative so swap if needed (save code) */
1988 /* swap. top of stack (b) is the iv */
1992 /* As (a) is a UV, it's >0, so it cannot be == */
2001 /* As (b) is a UV, it's >0, so it cannot be == */
2005 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2007 SETs(boolSV((UV)iv != uv));
2015 SETs(boolSV(TOPn != value));
2022 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2023 #ifndef NV_PRESERVES_UV
2024 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2025 UV right = PTR2UV(SvRV(POPs));
2026 UV left = PTR2UV(SvRV(TOPs));
2027 SETi((left > right) - (left < right));
2031 #ifdef PERL_PRESERVE_IVUV
2032 /* Fortunately it seems NaN isn't IOK */
2035 SvIV_please(TOPm1s);
2036 if (SvIOK(TOPm1s)) {
2037 const bool leftuvok = SvUOK(TOPm1s);
2038 const bool rightuvok = SvUOK(TOPs);
2040 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2041 const IV leftiv = SvIVX(TOPm1s);
2042 const IV rightiv = SvIVX(TOPs);
2044 if (leftiv > rightiv)
2046 else if (leftiv < rightiv)
2050 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2051 const UV leftuv = SvUVX(TOPm1s);
2052 const UV rightuv = SvUVX(TOPs);
2054 if (leftuv > rightuv)
2056 else if (leftuv < rightuv)
2060 } else if (leftuvok) { /* ## UV <=> IV ## */
2061 const IV rightiv = SvIVX(TOPs);
2063 /* As (a) is a UV, it's >=0, so it cannot be < */
2066 const UV leftuv = SvUVX(TOPm1s);
2067 if (leftuv > (UV)rightiv) {
2069 } else if (leftuv < (UV)rightiv) {
2075 } else { /* ## IV <=> UV ## */
2076 const IV leftiv = SvIVX(TOPm1s);
2078 /* As (b) is a UV, it's >=0, so it must be < */
2081 const UV rightuv = SvUVX(TOPs);
2082 if ((UV)leftiv > rightuv) {
2084 } else if ((UV)leftiv < rightuv) {
2102 if (Perl_isnan(left) || Perl_isnan(right)) {
2106 value = (left > right) - (left < right);
2110 else if (left < right)
2112 else if (left > right)
2126 dSP; tryAMAGICbinSET(slt,0);
2129 const int cmp = (IN_LOCALE_RUNTIME
2130 ? sv_cmp_locale(left, right)
2131 : sv_cmp(left, right));
2132 SETs(boolSV(cmp < 0));
2139 dSP; tryAMAGICbinSET(sgt,0);
2142 const int cmp = (IN_LOCALE_RUNTIME
2143 ? sv_cmp_locale(left, right)
2144 : sv_cmp(left, right));
2145 SETs(boolSV(cmp > 0));
2152 dSP; tryAMAGICbinSET(sle,0);
2155 const int cmp = (IN_LOCALE_RUNTIME
2156 ? sv_cmp_locale(left, right)
2157 : sv_cmp(left, right));
2158 SETs(boolSV(cmp <= 0));
2165 dSP; tryAMAGICbinSET(sge,0);
2168 const int cmp = (IN_LOCALE_RUNTIME
2169 ? sv_cmp_locale(left, right)
2170 : sv_cmp(left, right));
2171 SETs(boolSV(cmp >= 0));
2178 dSP; tryAMAGICbinSET(seq,0);
2181 SETs(boolSV(sv_eq(left, right)));
2188 dSP; tryAMAGICbinSET(sne,0);
2191 SETs(boolSV(!sv_eq(left, right)));
2198 dSP; dTARGET; tryAMAGICbin(scmp,0);
2201 const int cmp = (IN_LOCALE_RUNTIME
2202 ? sv_cmp_locale(left, right)
2203 : sv_cmp(left, right));
2211 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2216 if (SvNIOKp(left) || SvNIOKp(right)) {
2217 if (PL_op->op_private & HINT_INTEGER) {
2218 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2222 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2227 do_vop(PL_op->op_type, TARG, left, right);
2236 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2241 if (SvNIOKp(left) || SvNIOKp(right)) {
2242 if (PL_op->op_private & HINT_INTEGER) {
2243 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2247 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2252 do_vop(PL_op->op_type, TARG, left, right);
2261 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2266 if (SvNIOKp(left) || SvNIOKp(right)) {
2267 if (PL_op->op_private & HINT_INTEGER) {
2268 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2272 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2277 do_vop(PL_op->op_type, TARG, left, right);
2286 dSP; dTARGET; tryAMAGICun(neg);
2289 const int flags = SvFLAGS(sv);
2291 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2292 /* It's publicly an integer, or privately an integer-not-float */
2295 if (SvIVX(sv) == IV_MIN) {
2296 /* 2s complement assumption. */
2297 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2300 else if (SvUVX(sv) <= IV_MAX) {
2305 else if (SvIVX(sv) != IV_MIN) {
2309 #ifdef PERL_PRESERVE_IVUV
2318 else if (SvPOKp(sv)) {
2320 const char *s = SvPV_const(sv, len);
2321 if (isIDFIRST(*s)) {
2322 sv_setpvn(TARG, "-", 1);
2325 else if (*s == '+' || *s == '-') {
2327 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2329 else if (DO_UTF8(sv)) {
2332 goto oops_its_an_int;
2334 sv_setnv(TARG, -SvNV(sv));
2336 sv_setpvn(TARG, "-", 1);
2343 goto oops_its_an_int;
2344 sv_setnv(TARG, -SvNV(sv));
2356 dSP; tryAMAGICunSET(not);
2357 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2363 dSP; dTARGET; tryAMAGICun(compl);
2368 if (PL_op->op_private & HINT_INTEGER) {
2369 const IV i = ~SvIV_nomg(sv);
2373 const UV u = ~SvUV_nomg(sv);
2382 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2383 sv_setsv_nomg(TARG, sv);
2384 tmps = (U8*)SvPV_force(TARG, len);
2387 /* Calculate exact length, let's not estimate. */
2396 while (tmps < send) {
2397 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2398 tmps += UTF8SKIP(tmps);
2399 targlen += UNISKIP(~c);
2405 /* Now rewind strings and write them. */
2409 Newxz(result, targlen + 1, U8);
2410 while (tmps < send) {
2411 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2412 tmps += UTF8SKIP(tmps);
2413 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2417 sv_setpvn(TARG, (char*)result, targlen);
2421 Newxz(result, nchar + 1, U8);
2422 while (tmps < send) {
2423 const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2424 tmps += UTF8SKIP(tmps);
2429 sv_setpvn(TARG, (char*)result, nchar);
2438 register long *tmpl;
2439 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2442 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2447 for ( ; anum > 0; anum--, tmps++)
2456 /* integer versions of some of the above */
2460 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2463 SETi( left * right );
2470 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2474 DIE(aTHX_ "Illegal division by zero");
2475 value = POPi / value;
2484 /* This is the vanilla old i_modulo. */
2485 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2489 DIE(aTHX_ "Illegal modulus zero");
2490 SETi( left % right );
2495 #if defined(__GLIBC__) && IVSIZE == 8
2499 /* This is the i_modulo with the workaround for the _moddi3 bug
2500 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2501 * See below for pp_i_modulo. */
2502 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2506 DIE(aTHX_ "Illegal modulus zero");
2507 SETi( left % PERL_ABS(right) );
2515 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2519 DIE(aTHX_ "Illegal modulus zero");
2520 /* The assumption is to use hereafter the old vanilla version... */
2522 PL_ppaddr[OP_I_MODULO] =
2524 /* .. but if we have glibc, we might have a buggy _moddi3
2525 * (at least glicb 2.2.5 is known to have this bug), in other
2526 * words our integer modulus with negative quad as the second
2527 * argument might be broken. Test for this and re-patch the
2528 * opcode dispatch table if that is the case, remembering to
2529 * also apply the workaround so that this first round works
2530 * right, too. See [perl #9402] for more information. */
2531 #if defined(__GLIBC__) && IVSIZE == 8
2535 /* Cannot do this check with inlined IV constants since
2536 * that seems to work correctly even with the buggy glibc. */
2538 /* Yikes, we have the bug.
2539 * Patch in the workaround version. */
2541 PL_ppaddr[OP_I_MODULO] =
2542 &Perl_pp_i_modulo_1;
2543 /* Make certain we work right this time, too. */
2544 right = PERL_ABS(right);
2548 SETi( left % right );
2555 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2558 SETi( left + right );
2565 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2568 SETi( left - right );
2575 dSP; tryAMAGICbinSET(lt,0);
2578 SETs(boolSV(left < right));
2585 dSP; tryAMAGICbinSET(gt,0);
2588 SETs(boolSV(left > right));
2595 dSP; tryAMAGICbinSET(le,0);
2598 SETs(boolSV(left <= right));
2605 dSP; tryAMAGICbinSET(ge,0);
2608 SETs(boolSV(left >= right));
2615 dSP; tryAMAGICbinSET(eq,0);
2618 SETs(boolSV(left == right));
2625 dSP; tryAMAGICbinSET(ne,0);
2628 SETs(boolSV(left != right));
2635 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2642 else if (left < right)
2653 dSP; dTARGET; tryAMAGICun(neg);
2658 /* High falutin' math. */
2662 dSP; dTARGET; tryAMAGICbin(atan2,0);
2665 SETn(Perl_atan2(left, right));
2672 dSP; dTARGET; tryAMAGICun(sin);
2674 const NV value = POPn;
2675 XPUSHn(Perl_sin(value));
2682 dSP; dTARGET; tryAMAGICun(cos);
2684 const NV value = POPn;
2685 XPUSHn(Perl_cos(value));
2690 /* Support Configure command-line overrides for rand() functions.
2691 After 5.005, perhaps we should replace this by Configure support
2692 for drand48(), random(), or rand(). For 5.005, though, maintain
2693 compatibility by calling rand() but allow the user to override it.
2694 See INSTALL for details. --Andy Dougherty 15 July 1998
2696 /* Now it's after 5.005, and Configure supports drand48() and random(),
2697 in addition to rand(). So the overrides should not be needed any more.
2698 --Jarkko Hietaniemi 27 September 1998
2701 #ifndef HAS_DRAND48_PROTO
2702 extern double drand48 (void);
2715 if (!PL_srand_called) {
2716 (void)seedDrand01((Rand_seed_t)seed());
2717 PL_srand_called = TRUE;
2732 (void)seedDrand01((Rand_seed_t)anum);
2733 PL_srand_called = TRUE;
2740 dSP; dTARGET; tryAMAGICun(exp);
2744 value = Perl_exp(value);
2752 dSP; dTARGET; tryAMAGICun(log);
2754 const NV value = POPn;
2756 SET_NUMERIC_STANDARD();
2757 DIE(aTHX_ "Can't take log of %"NVgf, value);
2759 XPUSHn(Perl_log(value));
2766 dSP; dTARGET; tryAMAGICun(sqrt);
2768 const NV value = POPn;
2770 SET_NUMERIC_STANDARD();
2771 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2773 XPUSHn(Perl_sqrt(value));
2780 dSP; dTARGET; tryAMAGICun(int);
2782 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2783 /* XXX it's arguable that compiler casting to IV might be subtly
2784 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2785 else preferring IV has introduced a subtle behaviour change bug. OTOH
2786 relying on floating point to be accurate is a bug. */
2790 else if (SvIOK(TOPs)) {
2797 const NV value = TOPn;
2799 if (value < (NV)UV_MAX + 0.5) {
2802 SETn(Perl_floor(value));
2806 if (value > (NV)IV_MIN - 0.5) {
2809 SETn(Perl_ceil(value));
2819 dSP; dTARGET; tryAMAGICun(abs);
2821 /* This will cache the NV value if string isn't actually integer */
2826 else if (SvIOK(TOPs)) {
2827 /* IVX is precise */
2829 SETu(TOPu); /* force it to be numeric only */
2837 /* 2s complement assumption. Also, not really needed as
2838 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2844 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 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2876 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2889 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2893 SV* const sv = POPs;
2895 tmps = (SvPV_const(sv, len));
2897 /* If Unicode, try to downgrade
2898 * If not possible, croak. */
2899 SV* const tsv = sv_2mortal(newSVsv(sv));
2902 sv_utf8_downgrade(tsv, FALSE);
2903 tmps = SvPV_const(tsv, len);
2905 while (*tmps && len && isSPACE(*tmps))
2910 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2911 else if (*tmps == 'b')
2912 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2914 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2916 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2933 SETi(sv_len_utf8(sv));
2949 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2951 const I32 arybase = PL_curcop->cop_arybase;
2953 const char *repl = 0;
2955 const int num_args = PL_op->op_private & 7;
2956 bool repl_need_utf8_upgrade = FALSE;
2957 bool repl_is_utf8 = FALSE;
2959 SvTAINTED_off(TARG); /* decontaminate */
2960 SvUTF8_off(TARG); /* decontaminate */
2964 repl = SvPV_const(repl_sv, repl_len);
2965 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2975 sv_utf8_upgrade(sv);
2977 else if (DO_UTF8(sv))
2978 repl_need_utf8_upgrade = TRUE;
2980 tmps = SvPV_const(sv, curlen);
2982 utf8_curlen = sv_len_utf8(sv);
2983 if (utf8_curlen == curlen)
2986 curlen = utf8_curlen;
2991 if (pos >= arybase) {
3009 else if (len >= 0) {
3011 if (rem > (I32)curlen)
3026 Perl_croak(aTHX_ "substr outside of string");
3027 if (ckWARN(WARN_SUBSTR))
3028 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3032 const I32 upos = pos;
3033 const I32 urem = rem;
3035 sv_pos_u2b(sv, &pos, &rem);
3037 /* we either return a PV or an LV. If the TARG hasn't been used
3038 * before, or is of that type, reuse it; otherwise use a mortal
3039 * instead. Note that LVs can have an extended lifetime, so also
3040 * dont reuse if refcount > 1 (bug #20933) */
3041 if (SvTYPE(TARG) > SVt_NULL) {
3042 if ( (SvTYPE(TARG) == SVt_PVLV)
3043 ? (!lvalue || SvREFCNT(TARG) > 1)
3046 TARG = sv_newmortal();
3050 sv_setpvn(TARG, tmps, rem);
3051 #ifdef USE_LOCALE_COLLATE
3052 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3057 SV* repl_sv_copy = NULL;
3059 if (repl_need_utf8_upgrade) {
3060 repl_sv_copy = newSVsv(repl_sv);
3061 sv_utf8_upgrade(repl_sv_copy);
3062 repl = SvPV_const(repl_sv_copy, repl_len);
3063 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3065 sv_insert(sv, pos, rem, repl, repl_len);
3069 SvREFCNT_dec(repl_sv_copy);
3071 else if (lvalue) { /* it's an lvalue! */
3072 if (!SvGMAGICAL(sv)) {
3074 SvPV_force_nolen(sv);
3075 if (ckWARN(WARN_SUBSTR))
3076 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3077 "Attempt to use reference as lvalue in substr");
3079 if (SvOK(sv)) /* is it defined ? */
3080 (void)SvPOK_only_UTF8(sv);
3082 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3085 if (SvTYPE(TARG) < SVt_PVLV) {
3086 sv_upgrade(TARG, SVt_PVLV);
3087 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3093 if (LvTARG(TARG) != sv) {
3095 SvREFCNT_dec(LvTARG(TARG));
3096 LvTARG(TARG) = SvREFCNT_inc(sv);
3098 LvTARGOFF(TARG) = upos;
3099 LvTARGLEN(TARG) = urem;
3103 PUSHs(TARG); /* avoid SvSETMAGIC here */
3110 register const IV size = POPi;
3111 register const IV offset = POPi;
3112 register SV * const src = POPs;
3113 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3115 SvTAINTED_off(TARG); /* decontaminate */
3116 if (lvalue) { /* it's an lvalue! */
3117 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3118 TARG = sv_newmortal();
3119 if (SvTYPE(TARG) < SVt_PVLV) {
3120 sv_upgrade(TARG, SVt_PVLV);
3121 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3124 if (LvTARG(TARG) != src) {
3126 SvREFCNT_dec(LvTARG(TARG));
3127 LvTARG(TARG) = SvREFCNT_inc(src);
3129 LvTARGOFF(TARG) = offset;
3130 LvTARGLEN(TARG) = size;
3133 sv_setuv(TARG, do_vecget(src, offset, size));
3149 const I32 arybase = PL_curcop->cop_arybase;
3156 offset = POPi - arybase;
3159 big_utf8 = DO_UTF8(big);
3160 little_utf8 = DO_UTF8(little);
3161 if (big_utf8 ^ little_utf8) {
3162 /* One needs to be upgraded. */
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);
3181 if (big_utf8 && offset > 0)
3182 sv_pos_u2b(big, &offset, 0);
3183 tmps = SvPV_const(big, biglen);
3186 else if (offset > (I32)biglen)
3188 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3189 (unsigned char*)tmps + biglen, little, 0)))
3192 retval = tmps2 - tmps;
3193 if (retval > 0 && big_utf8)
3194 sv_pos_b2u(big, &retval);
3197 PUSHi(retval + arybase);
3213 const I32 arybase = PL_curcop->cop_arybase;
3221 big_utf8 = DO_UTF8(big);
3222 little_utf8 = DO_UTF8(little);
3223 if (big_utf8 ^ little_utf8) {
3224 /* One needs to be upgraded. */
3225 SV * const bytes = little_utf8 ? big : little;
3227 const char *p = SvPV_const(bytes, len);
3229 temp = newSVpvn(p, len);
3232 sv_recode_to_utf8(temp, PL_encoding);
3234 sv_utf8_upgrade(temp);
3243 tmps2 = SvPV_const(little, llen);
3244 tmps = SvPV_const(big, blen);
3249 if (offset > 0 && big_utf8)
3250 sv_pos_u2b(big, &offset, 0);
3251 offset = offset - arybase + llen;
3255 else if (offset > (I32)blen)
3257 if (!(tmps2 = rninstr(tmps, tmps + offset,
3258 tmps2, tmps2 + llen)))
3261 retval = tmps2 - tmps;
3262 if (retval > 0 && big_utf8)
3263 sv_pos_b2u(big, &retval);
3266 PUSHi(retval + arybase);
3272 dSP; dMARK; dORIGMARK; dTARGET;
3273 do_sprintf(TARG, SP-MARK, MARK+1);
3274 TAINT_IF(SvTAINTED(TARG));
3275 if (DO_UTF8(*(MARK+1)))
3287 const U8 *s = (U8*)SvPV_const(argsv, len);
3290 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3291 tmpsv = sv_2mortal(newSVsv(argsv));
3292 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3296 XPUSHu(DO_UTF8(argsv) ?
3297 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3309 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3311 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3313 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3315 (void) POPs; /* Ignore the argument value. */
3316 value = UNICODE_REPLACEMENT;
3322 SvUPGRADE(TARG,SVt_PV);
3324 if (value > 255 && !IN_BYTES) {
3325 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3326 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3327 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3329 (void)SvPOK_only(TARG);
3338 *tmps++ = (char)value;
3340 (void)SvPOK_only(TARG);
3341 if (PL_encoding && !IN_BYTES) {
3342 sv_recode_to_utf8(TARG, PL_encoding);
3344 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3345 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3349 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3350 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3365 const char *tmps = SvPV_const(left, len);
3367 if (DO_UTF8(left)) {
3368 /* If Unicode, try to downgrade.
3369 * If not possible, croak.
3370 * Yes, we made this up. */
3371 SV* const tsv = sv_2mortal(newSVsv(left));
3374 sv_utf8_downgrade(tsv, FALSE);
3375 tmps = SvPV_const(tsv, len);
3377 # ifdef USE_ITHREADS
3379 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3380 /* This should be threadsafe because in ithreads there is only
3381 * one thread per interpreter. If this would not be true,
3382 * we would need a mutex to protect this malloc. */
3383 PL_reentrant_buffer->_crypt_struct_buffer =
3384 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3385 #if defined(__GLIBC__) || defined(__EMX__)
3386 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3387 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3388 /* work around glibc-2.2.5 bug */
3389 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3393 # endif /* HAS_CRYPT_R */
3394 # endif /* USE_ITHREADS */
3396 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3398 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3404 "The crypt() function is unimplemented due to excessive paranoia.");
3417 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3418 UTF8_IS_START(*s)) {
3419 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3423 utf8_to_uvchr(s, &ulen);
3424 toTITLE_utf8(s, tmpbuf, &tculen);
3425 utf8_to_uvchr(tmpbuf, 0);
3427 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3429 /* slen is the byte length of the whole SV.
3430 * ulen is the byte length of the original Unicode character
3431 * stored as UTF-8 at s.
3432 * tculen is the byte length of the freshly titlecased
3433 * Unicode character stored as UTF-8 at tmpbuf.
3434 * We first set the result to be the titlecased character,
3435 * and then append the rest of the SV data. */
3436 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3438 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3443 s = (U8*)SvPV_force_nomg(sv, slen);
3444 Copy(tmpbuf, s, tculen, U8);
3449 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3451 SvUTF8_off(TARG); /* decontaminate */
3452 sv_setsv_nomg(TARG, sv);
3456 s1 = (U8*)SvPV_force_nomg(sv, slen);
3458 if (IN_LOCALE_RUNTIME) {
3461 *s1 = toUPPER_LC(*s1);
3480 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3481 UTF8_IS_START(*s)) {
3483 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3487 toLOWER_utf8(s, tmpbuf, &ulen);
3488 uv = utf8_to_uvchr(tmpbuf, 0);
3489 tend = uvchr_to_utf8(tmpbuf, uv);
3491 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3493 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3495 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3500 s = (U8*)SvPV_force_nomg(sv, slen);
3501 Copy(tmpbuf, s, ulen, U8);
3506 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3508 SvUTF8_off(TARG); /* decontaminate */
3509 sv_setsv_nomg(TARG, sv);
3513 s1 = (U8*)SvPV_force_nomg(sv, slen);
3515 if (IN_LOCALE_RUNTIME) {
3518 *s1 = toLOWER_LC(*s1);
3541 U8 tmpbuf[UTF8_MAXBYTES+1];
3543 s = (const U8*)SvPV_nomg_const(sv,len);
3545 SvUTF8_off(TARG); /* decontaminate */
3546 sv_setpvn(TARG, "", 0);
3550 STRLEN min = len + 1;
3552 SvUPGRADE(TARG, SVt_PV);
3554 (void)SvPOK_only(TARG);
3555 d = (U8*)SvPVX(TARG);
3558 STRLEN u = UTF8SKIP(s);
3560 toUPPER_utf8(s, tmpbuf, &ulen);
3561 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3562 /* If the eventually required minimum size outgrows
3563 * the available space, we need to grow. */
3564 UV o = d - (U8*)SvPVX_const(TARG);
3566 /* If someone uppercases one million U+03B0s we
3567 * SvGROW() one million times. Or we could try
3568 * guessing how much to allocate without allocating
3569 * too much. Such is life. */
3571 d = (U8*)SvPVX(TARG) + o;
3573 Copy(tmpbuf, d, ulen, U8);
3579 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3585 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3587 SvUTF8_off(TARG); /* decontaminate */
3588 sv_setsv_nomg(TARG, sv);
3592 s = (U8*)SvPV_force_nomg(sv, len);
3594 register const U8 *send = s + len;
3596 if (IN_LOCALE_RUNTIME) {
3599 for (; s < send; s++)
3600 *s = toUPPER_LC(*s);
3603 for (; s < send; s++)
3625 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3627 s = (const U8*)SvPV_nomg_const(sv,len);
3629 SvUTF8_off(TARG); /* decontaminate */
3630 sv_setpvn(TARG, "", 0);
3634 STRLEN min = len + 1;
3636 SvUPGRADE(TARG, SVt_PV);
3638 (void)SvPOK_only(TARG);
3639 d = (U8*)SvPVX(TARG);
3642 const STRLEN u = UTF8SKIP(s);
3643 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3645 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3646 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3648 * Now if the sigma is NOT followed by
3649 * /$ignorable_sequence$cased_letter/;
3650 * and it IS preceded by
3651 * /$cased_letter$ignorable_sequence/;
3652 * where $ignorable_sequence is
3653 * [\x{2010}\x{AD}\p{Mn}]*
3654 * and $cased_letter is
3655 * [\p{Ll}\p{Lo}\p{Lt}]
3656 * then it should be mapped to 0x03C2,
3657 * (GREEK SMALL LETTER FINAL SIGMA),
3658 * instead of staying 0x03A3.
3659 * "should be": in other words,
3660 * this is not implemented yet.
3661 * See lib/unicore/SpecialCasing.txt.
3664 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3665 /* If the eventually required minimum size outgrows
3666 * the available space, we need to grow. */
3667 UV o = d - (U8*)SvPVX_const(TARG);
3669 /* If someone lowercases one million U+0130s we
3670 * SvGROW() one million times. Or we could try
3671 * guessing how much to allocate without allocating.
3672 * too much. Such is life. */
3674 d = (U8*)SvPVX(TARG) + o;
3676 Copy(tmpbuf, d, ulen, U8);
3682 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3688 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3690 SvUTF8_off(TARG); /* decontaminate */
3691 sv_setsv_nomg(TARG, sv);
3696 s = (U8*)SvPV_force_nomg(sv, len);
3698 register const U8 * const send = s + len;
3700 if (IN_LOCALE_RUNTIME) {
3703 for (; s < send; s++)
3704 *s = toLOWER_LC(*s);
3707 for (; s < send; s++)
3719 SV * const sv = TOPs;
3721 register const char *s = SvPV_const(sv,len);
3723 SvUTF8_off(TARG); /* decontaminate */
3726 SvUPGRADE(TARG, SVt_PV);
3727 SvGROW(TARG, (len * 2) + 1);
3731 if (UTF8_IS_CONTINUED(*s)) {
3732 STRLEN ulen = UTF8SKIP(s);
3756 SvCUR_set(TARG, d - SvPVX_const(TARG));
3757 (void)SvPOK_only_UTF8(TARG);
3760 sv_setpvn(TARG, s, len);
3762 if (SvSMAGICAL(TARG))
3771 dSP; dMARK; dORIGMARK;
3772 register AV* const av = (AV*)POPs;
3773 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3775 if (SvTYPE(av) == SVt_PVAV) {
3776 const I32 arybase = PL_curcop->cop_arybase;
3777 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3780 for (svp = MARK + 1; svp <= SP; svp++) {
3781 const I32 elem = SvIVx(*svp);
3785 if (max > AvMAX(av))
3788 while (++MARK <= SP) {
3790 I32 elem = SvIVx(*MARK);
3794 svp = av_fetch(av, elem, lval);
3796 if (!svp || *svp == &PL_sv_undef)
3797 DIE(aTHX_ PL_no_aelem, elem);
3798 if (PL_op->op_private & OPpLVAL_INTRO)
3799 save_aelem(av, elem, svp);
3801 *MARK = svp ? *svp : &PL_sv_undef;
3804 if (GIMME != G_ARRAY) {
3806 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3812 /* Associative arrays. */
3817 HV * const hash = (HV*)POPs;
3819 const I32 gimme = GIMME_V;
3822 /* might clobber stack_sp */
3823 entry = hv_iternext(hash);
3828 SV* const sv = hv_iterkeysv(entry);
3829 PUSHs(sv); /* won't clobber stack_sp */
3830 if (gimme == G_ARRAY) {
3833 /* might clobber stack_sp */
3834 val = hv_iterval(hash, entry);
3839 else if (gimme == G_SCALAR)
3848 const I32 gimme = GIMME_V;
3849 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3851 if (PL_op->op_private & OPpSLICE) {
3853 HV * const hv = (HV*)POPs;
3854 const U32 hvtype = SvTYPE(hv);
3855 if (hvtype == SVt_PVHV) { /* hash element */
3856 while (++MARK <= SP) {
3857 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3858 *MARK = sv ? sv : &PL_sv_undef;
3861 else if (hvtype == SVt_PVAV) { /* array element */
3862 if (PL_op->op_flags & OPf_SPECIAL) {
3863 while (++MARK <= SP) {
3864 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3865 *MARK = sv ? sv : &PL_sv_undef;
3870 DIE(aTHX_ "Not a HASH reference");
3873 else if (gimme == G_SCALAR) {
3878 *++MARK = &PL_sv_undef;
3884 HV * const hv = (HV*)POPs;
3886 if (SvTYPE(hv) == SVt_PVHV)
3887 sv = hv_delete_ent(hv, keysv, discard, 0);
3888 else if (SvTYPE(hv) == SVt_PVAV) {
3889 if (PL_op->op_flags & OPf_SPECIAL)
3890 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3892 DIE(aTHX_ "panic: avhv_delete no longer supported");
3895 DIE(aTHX_ "Not a HASH reference");
3910 if (PL_op->op_private & OPpEXISTS_SUB) {
3913 CV * const cv = sv_2cv(sv, &hv, &gv, FALSE);
3916 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3922 if (SvTYPE(hv) == SVt_PVHV) {
3923 if (hv_exists_ent(hv, tmpsv, 0))
3926 else if (SvTYPE(hv) == SVt_PVAV) {
3927 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3928 if (av_exists((AV*)hv, SvIV(tmpsv)))
3933 DIE(aTHX_ "Not a HASH reference");
3940 dSP; dMARK; dORIGMARK;
3941 register HV * const hv = (HV*)POPs;
3942 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3943 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3944 bool other_magic = FALSE;
3950 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3951 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3952 /* Try to preserve the existenceness of a tied hash
3953 * element by using EXISTS and DELETE if possible.
3954 * Fallback to FETCH and STORE otherwise */
3955 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3956 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3957 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3960 while (++MARK <= SP) {
3961 SV * const keysv = *MARK;
3964 bool preeminent = FALSE;
3967 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3968 hv_exists_ent(hv, keysv, 0);
3971 he = hv_fetch_ent(hv, keysv, lval, 0);
3972 svp = he ? &HeVAL(he) : 0;
3975 if (!svp || *svp == &PL_sv_undef) {
3976 DIE(aTHX_ PL_no_helem_sv, keysv);
3980 save_helem(hv, keysv, svp);
3983 const char *key = SvPV_const(keysv, keylen);
3984 SAVEDELETE(hv, savepvn(key,keylen), keylen);
3988 *MARK = svp ? *svp : &PL_sv_undef;
3990 if (GIMME != G_ARRAY) {
3992 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3998 /* List operators. */
4003 if (GIMME != G_ARRAY) {
4005 *MARK = *SP; /* unwanted list, return last item */
4007 *MARK = &PL_sv_undef;
4016 SV ** const lastrelem = PL_stack_sp;
4017 SV ** const lastlelem = PL_stack_base + POPMARK;
4018 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4019 register SV ** const firstrelem = lastlelem + 1;
4020 const I32 arybase = PL_curcop->cop_arybase;
4021 I32 is_something_there = PL_op->op_flags & OPf_MOD;
4023 register const I32 max = lastrelem - lastlelem;
4024 register SV **lelem;
4026 if (GIMME != G_ARRAY) {
4027 I32 ix = SvIVx(*lastlelem);
4032 if (ix < 0 || ix >= max)
4033 *firstlelem = &PL_sv_undef;
4035 *firstlelem = firstrelem[ix];
4041 SP = firstlelem - 1;
4045 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4046 I32 ix = SvIVx(*lelem);
4051 if (ix < 0 || ix >= max)
4052 *lelem = &PL_sv_undef;
4054 is_something_there = TRUE;
4055 if (!(*lelem = firstrelem[ix]))
4056 *lelem = &PL_sv_undef;
4059 if (is_something_there)
4062 SP = firstlelem - 1;
4068 dSP; dMARK; dORIGMARK;
4069 const I32 items = SP - MARK;
4070 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
4071 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4078 dSP; dMARK; dORIGMARK;
4079 HV* const hv = (HV*)sv_2mortal((SV*)newHV());
4082 SV * const key = *++MARK;
4083 SV * const val = NEWSV(46, 0);
4085 sv_setsv(val, *++MARK);
4086 else if (ckWARN(WARN_MISC))
4087 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4088 (void)hv_store_ent(hv,key,val,0);
4097 dVAR; dSP; dMARK; dORIGMARK;
4098 register AV *ary = (AV*)*++MARK;
4102 register I32 offset;
4103 register I32 length;
4108 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4111 *MARK-- = SvTIED_obj((SV*)ary, mg);
4115 call_method("SPLICE",GIMME_V);
4124 offset = i = SvIVx(*MARK);
4126 offset += AvFILLp(ary) + 1;
4128 offset -= PL_curcop->cop_arybase;
4130 DIE(aTHX_ PL_no_aelem, i);
4132 length = SvIVx(*MARK++);
4134 length += AvFILLp(ary) - offset + 1;
4140 length = AvMAX(ary) + 1; /* close enough to infinity */
4144 length = AvMAX(ary) + 1;
4146 if (offset > AvFILLp(ary) + 1) {
4147 if (ckWARN(WARN_MISC))
4148 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4149 offset = AvFILLp(ary) + 1;
4151 after = AvFILLp(ary) + 1 - (offset + length);
4152 if (after < 0) { /* not that much array */
4153 length += after; /* offset+length now in array */
4159 /* At this point, MARK .. SP-1 is our new LIST */
4162 diff = newlen - length;
4163 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4166 /* make new elements SVs now: avoid problems if they're from the array */
4167 for (dst = MARK, i = newlen; i; i--) {
4168 SV * const h = *dst;
4169 *dst++ = newSVsv(h);
4172 if (diff < 0) { /* shrinking the area */
4174 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4175 Copy(MARK, tmparyval, newlen, SV*);
4178 MARK = ORIGMARK + 1;
4179 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4180 MEXTEND(MARK, length);
4181 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4183 EXTEND_MORTAL(length);
4184 for (i = length, dst = MARK; i; i--) {
4185 sv_2mortal(*dst); /* free them eventualy */
4192 *MARK = AvARRAY(ary)[offset+length-1];
4195 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4196 SvREFCNT_dec(*dst++); /* free them now */
4199 AvFILLp(ary) += diff;
4201 /* pull up or down? */
4203 if (offset < after) { /* easier to pull up */
4204 if (offset) { /* esp. if nothing to pull */
4205 src = &AvARRAY(ary)[offset-1];
4206 dst = src - diff; /* diff is negative */
4207 for (i = offset; i > 0; i--) /* can't trust Copy */
4211 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4215 if (after) { /* anything to pull down? */
4216 src = AvARRAY(ary) + offset + length;
4217 dst = src + diff; /* diff is negative */
4218 Move(src, dst, after, SV*);
4220 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4221 /* avoid later double free */
4225 dst[--i] = &PL_sv_undef;
4228 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4229 Safefree(tmparyval);
4232 else { /* no, expanding (or same) */
4234 Newx(tmparyval, length, SV*); /* so remember deletion */
4235 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4238 if (diff > 0) { /* expanding */
4240 /* push up or down? */
4242 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4246 Move(src, dst, offset, SV*);
4248 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4250 AvFILLp(ary) += diff;
4253 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4254 av_extend(ary, AvFILLp(ary) + diff);
4255 AvFILLp(ary) += diff;
4258 dst = AvARRAY(ary) + AvFILLp(ary);
4260 for (i = after; i; i--) {
4268 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4271 MARK = ORIGMARK + 1;
4272 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4274 Copy(tmparyval, MARK, length, SV*);
4276 EXTEND_MORTAL(length);
4277 for (i = length, dst = MARK; i; i--) {
4278 sv_2mortal(*dst); /* free them eventualy */
4282 Safefree(tmparyval);
4286 else if (length--) {
4287 *MARK = tmparyval[length];
4290 while (length-- > 0)
4291 SvREFCNT_dec(tmparyval[length]);
4293 Safefree(tmparyval);
4296 *MARK = &PL_sv_undef;
4304 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4305 register AV *ary = (AV*)*++MARK;
4306 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4309 *MARK-- = SvTIED_obj((SV*)ary, mg);
4313 call_method("PUSH",G_SCALAR|G_DISCARD);
4317 PUSHi( AvFILL(ary) + 1 );
4320 for (++MARK; MARK <= SP; MARK++) {
4321 SV * const sv = NEWSV(51, 0);
4323 sv_setsv(sv, *MARK);
4324 av_store(ary, AvFILLp(ary)+1, sv);
4327 PUSHi( AvFILLp(ary) + 1 );
4335 AV * const av = (AV*)POPs;
4336 SV * const sv = av_pop(av);
4338 (void)sv_2mortal(sv);
4346 AV * const av = (AV*)POPs;
4347 SV * const sv = av_shift(av);
4352 (void)sv_2mortal(sv);
4359 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4360 register AV *ary = (AV*)*++MARK;
4361 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4364 *MARK-- = SvTIED_obj((SV*)ary, mg);
4368 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4374 av_unshift(ary, SP - MARK);
4376 SV * const sv = newSVsv(*++MARK);
4377 (void)av_store(ary, i++, sv);
4381 PUSHi( AvFILL(ary) + 1 );
4388 SV ** const oldsp = SP;
4390 if (GIMME == G_ARRAY) {
4393 register SV * const tmp = *MARK;
4397 /* safe as long as stack cannot get extended in the above */
4402 register char *down;
4408 SvUTF8_off(TARG); /* decontaminate */
4410 do_join(TARG, &PL_sv_no, MARK, SP);
4412 sv_setsv(TARG, (SP > MARK)
4414 : (padoff_du = find_rundefsvoffset(),
4415 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4416 ? DEFSV : PAD_SVl(padoff_du)));
4417 up = SvPV_force(TARG, len);
4419 if (DO_UTF8(TARG)) { /* first reverse each character */
4420 U8* s = (U8*)SvPVX(TARG);
4421 const U8* send = (U8*)(s + len);
4423 if (UTF8_IS_INVARIANT(*s)) {
4428 if (!utf8_to_uvchr(s, 0))
4432 down = (char*)(s - 1);
4433 /* reverse this character */
4437 *down-- = (char)tmp;
4443 down = SvPVX(TARG) + len - 1;
4447 *down-- = (char)tmp;
4449 (void)SvPOK_only_UTF8(TARG);
4461 register IV limit = POPi; /* note, negative is forever */
4462 SV * const sv = POPs;
4464 register const char *s = SvPV_const(sv, len);
4465 const bool do_utf8 = DO_UTF8(sv);
4466 const char *strend = s + len;
4468 register REGEXP *rx;
4470 register const char *m;
4472 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4473 I32 maxiters = slen + 10;
4475 const I32 origlimit = limit;
4478 const I32 gimme = GIMME_V;
4479 const I32 oldsave = PL_savestack_ix;
4480 I32 make_mortal = 1;
4482 MAGIC *mg = (MAGIC *) NULL;
4485 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4490 DIE(aTHX_ "panic: pp_split");
4493 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4494 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4496 RX_MATCH_UTF8_set(rx, do_utf8);
4498 if (pm->op_pmreplroot) {
4500 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4502 ary = GvAVn((GV*)pm->op_pmreplroot);
4505 else if (gimme != G_ARRAY)
4506 ary = GvAVn(PL_defgv);
4509 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4515 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4517 XPUSHs(SvTIED_obj((SV*)ary, mg));
4524 for (i = AvFILLp(ary); i >= 0; i--)
4525 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4527 /* temporarily switch stacks */
4528 SAVESWITCHSTACK(PL_curstack, ary);
4532 base = SP - PL_stack_base;
4534 if (pm->op_pmflags & PMf_SKIPWHITE) {
4535 if (pm->op_pmflags & PMf_LOCALE) {
4536 while (isSPACE_LC(*s))
4544 if (pm->op_pmflags & PMf_MULTILINE) {
4549 limit = maxiters + 2;
4550 if (pm->op_pmflags & PMf_WHITE) {
4553 while (m < strend &&
4554 !((pm->op_pmflags & PMf_LOCALE)
4555 ? isSPACE_LC(*m) : isSPACE(*m)))
4560 dstr = newSVpvn(s, m-s);
4564 (void)SvUTF8_on(dstr);
4568 while (s < strend &&
4569 ((pm->op_pmflags & PMf_LOCALE)
4570 ? isSPACE_LC(*s) : isSPACE(*s)))
4574 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4576 for (m = s; m < strend && *m != '\n'; m++)
4581 dstr = newSVpvn(s, m-s);
4585 (void)SvUTF8_on(dstr);
4590 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4591 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4592 && (rx->reganch & ROPT_CHECK_ALL)
4593 && !(rx->reganch & ROPT_ANCH)) {
4594 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4595 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4598 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4599 const char c = *SvPV_nolen_const(csv);
4601 for (m = s; m < strend && *m != c; m++)
4605 dstr = newSVpvn(s, m-s);
4609 (void)SvUTF8_on(dstr);
4611 /* The rx->minlen is in characters but we want to step
4612 * s ahead by bytes. */
4614 s = (char*)utf8_hop((U8*)m, len);
4616 s = m + len; /* Fake \n at the end */
4620 while (s < strend && --limit &&
4621 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4622 csv, multiline ? FBMrf_MULTILINE : 0)) )
4624 dstr = newSVpvn(s, m-s);
4628 (void)SvUTF8_on(dstr);
4630 /* The rx->minlen is in characters but we want to step
4631 * s ahead by bytes. */
4633 s = (char*)utf8_hop((U8*)m, len);
4635 s = m + len; /* Fake \n at the end */
4640 maxiters += slen * rx->nparens;
4641 while (s < strend && --limit)
4645 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4648 if (rex_return == 0)
4650 TAINT_IF(RX_MATCH_TAINTED(rx));
4651 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4656 strend = s + (strend - m);
4658 m = rx->startp[0] + orig;
4659 dstr = newSVpvn(s, m-s);
4663 (void)SvUTF8_on(dstr);
4667 for (i = 1; i <= (I32)rx->nparens; i++) {
4668 s = rx->startp[i] + orig;
4669 m = rx->endp[i] + orig;
4671 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4672 parens that didn't match -- they should be set to
4673 undef, not the empty string */
4674 if (m >= orig && s >= orig) {
4675 dstr = newSVpvn(s, m-s);
4678 dstr = &PL_sv_undef; /* undef, not "" */
4682 (void)SvUTF8_on(dstr);
4686 s = rx->endp[0] + orig;
4690 iters = (SP - PL_stack_base) - base;
4691 if (iters > maxiters)
4692 DIE(aTHX_ "Split loop");
4694 /* keep field after final delim? */
4695 if (s < strend || (iters && origlimit)) {
4696 const STRLEN l = strend - s;
4697 dstr = newSVpvn(s, l);
4701 (void)SvUTF8_on(dstr);
4705 else if (!origlimit) {
4706 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4707 if (TOPs && !make_mortal)
4710 *SP-- = &PL_sv_undef;
4715 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4719 if (SvSMAGICAL(ary)) {
4724 if (gimme == G_ARRAY) {
4726 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4734 call_method("PUSH",G_SCALAR|G_DISCARD);
4737 if (gimme == G_ARRAY) {
4739 /* EXTEND should not be needed - we just popped them */
4741 for (i=0; i < iters; i++) {
4742 SV **svp = av_fetch(ary, i, FALSE);
4743 PUSHs((svp) ? *svp : &PL_sv_undef);
4750 if (gimme == G_ARRAY)
4765 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4766 || SvTYPE(retsv) == SVt_PVCV) {
4767 retsv = refto(retsv);
4774 PP(unimplemented_op)
4776 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
4782 * c-indentation-style: bsd
4784 * indent-tabs-mode: t
4787 * ex: set ts=8 sts=4 sw=4 noet: