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)
67 if (PL_op->op_private & OPpLVAL_INTRO)
68 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
70 if (PL_op->op_flags & OPf_REF) {
74 if (GIMME == G_SCALAR)
75 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
80 if (gimme == G_ARRAY) {
81 const I32 maxarg = AvFILL((AV*)TARG) + 1;
83 if (SvMAGICAL(TARG)) {
85 for (i=0; i < (U32)maxarg; i++) {
86 SV ** const svp = av_fetch((AV*)TARG, i, FALSE);
87 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
91 Copy(AvARRAY((AV*)TARG), SP+1, maxarg, SV*);
95 else if (gimme == G_SCALAR) {
96 SV* const sv = sv_newmortal();
97 const I32 maxarg = AvFILL((AV*)TARG) + 1;
110 if (PL_op->op_private & OPpLVAL_INTRO)
111 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
112 if (PL_op->op_flags & OPf_REF)
115 if (GIMME == G_SCALAR)
116 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
120 if (gimme == G_ARRAY) {
123 else if (gimme == G_SCALAR) {
124 SV* const sv = Perl_hv_scalar(aTHX_ (HV*)TARG);
138 tryAMAGICunDEREF(to_gv);
141 if (SvTYPE(sv) == SVt_PVIO) {
142 GV * const gv = (GV*) sv_newmortal();
143 gv_init(gv, 0, "", 0, 0);
144 GvIOp(gv) = (IO *)sv;
145 (void)SvREFCNT_inc(sv);
148 else if (SvTYPE(sv) != SVt_PVGV)
149 DIE(aTHX_ "Not a GLOB reference");
152 if (SvTYPE(sv) != SVt_PVGV) {
153 if (SvGMAGICAL(sv)) {
158 if (!SvOK(sv) && sv != &PL_sv_undef) {
159 /* If this is a 'my' scalar and flag is set then vivify
163 Perl_croak(aTHX_ PL_no_modify);
164 if (PL_op->op_private & OPpDEREF) {
166 if (cUNOP->op_targ) {
168 SV *namesv = PAD_SV(cUNOP->op_targ);
169 const char *name = SvPV(namesv, len);
170 gv = (GV*)NEWSV(0,0);
171 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
174 const char *name = CopSTASHPV(PL_curcop);
177 if (SvTYPE(sv) < SVt_RV)
178 sv_upgrade(sv, SVt_RV);
179 if (SvPVX_const(sv)) {
184 SvRV_set(sv, (SV*)gv);
189 if (PL_op->op_flags & OPf_REF ||
190 PL_op->op_private & HINT_STRICT_REFS)
191 DIE(aTHX_ PL_no_usym, "a symbol");
192 if (ckWARN(WARN_UNINITIALIZED))
196 if ((PL_op->op_flags & OPf_SPECIAL) &&
197 !(PL_op->op_flags & OPf_MOD))
199 SV * const temp = (SV*)gv_fetchsv(sv, FALSE, SVt_PVGV);
201 && (!is_gv_magical_sv(sv,0)
202 || !(sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV)))) {
208 if (PL_op->op_private & HINT_STRICT_REFS)
209 DIE(aTHX_ PL_no_symref_sv, sv, "a symbol");
210 sv = (SV*)gv_fetchsv(sv, TRUE, SVt_PVGV);
214 if (PL_op->op_private & OPpLVAL_INTRO)
215 save_gp((GV*)sv, !(PL_op->op_flags & OPf_SPECIAL));
227 tryAMAGICunDEREF(to_sv);
230 switch (SvTYPE(sv)) {
234 DIE(aTHX_ "Not a SCALAR reference");
240 if (SvTYPE(gv) != SVt_PVGV) {
241 if (SvGMAGICAL(sv)) {
247 if (PL_op->op_flags & OPf_REF ||
248 PL_op->op_private & HINT_STRICT_REFS)
249 DIE(aTHX_ PL_no_usym, "a SCALAR");
250 if (ckWARN(WARN_UNINITIALIZED))
254 if ((PL_op->op_flags & OPf_SPECIAL) &&
255 !(PL_op->op_flags & OPf_MOD))
257 gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PV);
259 && (!is_gv_magical_sv(sv, 0)
260 || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV))))
266 if (PL_op->op_private & HINT_STRICT_REFS)
267 DIE(aTHX_ PL_no_symref_sv, sv, "a SCALAR");
268 gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PV);
273 if (PL_op->op_flags & OPf_MOD) {
274 if (PL_op->op_private & OPpLVAL_INTRO) {
275 if (cUNOP->op_first->op_type == OP_NULL)
276 sv = save_scalar((GV*)TOPs);
278 sv = save_scalar(gv);
280 Perl_croak(aTHX_ PL_no_localize_ref);
282 else if (PL_op->op_private & OPpDEREF)
283 vivify_ref(sv, PL_op->op_private & OPpDEREF);
292 AV * const av = (AV*)TOPs;
293 SV ** const sv = Perl_av_arylen_p(aTHX_ (AV*)av);
296 sv_upgrade(*sv, SVt_PVMG);
297 sv_magic(*sv, (SV*)av, PERL_MAGIC_arylen, Nullch, 0);
305 dSP; dTARGET; dPOPss;
307 if (PL_op->op_flags & OPf_MOD || LVRET) {
308 if (SvTYPE(TARG) < SVt_PVLV) {
309 sv_upgrade(TARG, SVt_PVLV);
310 sv_magic(TARG, Nullsv, PERL_MAGIC_pos, Nullch, 0);
314 if (LvTARG(TARG) != sv) {
316 SvREFCNT_dec(LvTARG(TARG));
317 LvTARG(TARG) = SvREFCNT_inc(sv);
319 PUSHs(TARG); /* no SvSETMAGIC */
323 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
324 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
325 if (mg && mg->mg_len >= 0) {
329 PUSHi(i + PL_curcop->cop_arybase);
343 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
344 /* (But not in defined().) */
345 CV *cv = sv_2cv(TOPs, &stash, &gv, !(PL_op->op_flags & OPf_SPECIAL));
348 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
349 if ((PL_op->op_private & OPpLVAL_INTRO)) {
350 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
353 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
357 cv = (CV*)&PL_sv_undef;
371 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
372 const char *s = SvPVX_const(TOPs);
373 if (strnEQ(s, "CORE::", 6)) {
374 const int code = keyword(s + 6, SvCUR(TOPs) - 6);
375 if (code < 0) { /* Overridable. */
376 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
377 int i = 0, n = 0, seen_question = 0;
379 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
381 if (code == -KEY_chop || code == -KEY_chomp
382 || code == -KEY_exec || code == -KEY_system)
384 while (i < MAXO) { /* The slow way. */
385 if (strEQ(s + 6, PL_op_name[i])
386 || strEQ(s + 6, PL_op_desc[i]))
392 goto nonesuch; /* Should not happen... */
394 oa = PL_opargs[i] >> OASHIFT;
396 if (oa & OA_OPTIONAL && !seen_question) {
400 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
401 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
402 /* But globs are already references (kinda) */
403 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
407 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
411 ret = sv_2mortal(newSVpvn(str, n - 1));
413 else if (code) /* Non-Overridable */
415 else { /* None such */
417 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
421 cv = sv_2cv(TOPs, &stash, &gv, FALSE);
423 ret = sv_2mortal(newSVpvn(SvPVX_const(cv), SvCUR(cv)));
432 CV* cv = (CV*)PAD_SV(PL_op->op_targ);
434 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
450 if (GIMME != G_ARRAY) {
454 *MARK = &PL_sv_undef;
455 *MARK = refto(*MARK);
459 EXTEND_MORTAL(SP - MARK);
461 *MARK = refto(*MARK);
466 S_refto(pTHX_ SV *sv)
470 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
473 if (!(sv = LvTARG(sv)))
476 (void)SvREFCNT_inc(sv);
478 else if (SvTYPE(sv) == SVt_PVAV) {
479 if (!AvREAL((AV*)sv) && AvREIFY((AV*)sv))
482 (void)SvREFCNT_inc(sv);
484 else if (SvPADTMP(sv) && !IS_PADGV(sv))
488 (void)SvREFCNT_inc(sv);
491 sv_upgrade(rv, SVt_RV);
501 SV * const sv = POPs;
506 if (!sv || !SvROK(sv))
509 pv = sv_reftype(SvRV(sv),TRUE);
510 PUSHp(pv, strlen(pv));
520 stash = CopSTASH(PL_curcop);
522 SV * const ssv = POPs;
526 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
527 Perl_croak(aTHX_ "Attempt to bless into a reference");
528 ptr = SvPV_const(ssv,len);
529 if (len == 0 && ckWARN(WARN_MISC))
530 Perl_warner(aTHX_ packWARN(WARN_MISC),
531 "Explicit blessing to '' (assuming package main)");
532 stash = gv_stashpvn(ptr, len, TRUE);
535 (void)sv_bless(TOPs, stash);
544 const char * const elem = SvPV_nolen_const(sv);
545 GV * const gv = (GV*)POPs;
546 SV * tmpRef = Nullsv;
550 /* elem will always be NUL terminated. */
551 const char * const second_letter = elem + 1;
554 if (strEQ(second_letter, "RRAY"))
555 tmpRef = (SV*)GvAV(gv);
558 if (strEQ(second_letter, "ODE"))
559 tmpRef = (SV*)GvCVu(gv);
562 if (strEQ(second_letter, "ILEHANDLE")) {
563 /* finally deprecated in 5.8.0 */
564 deprecate("*glob{FILEHANDLE}");
565 tmpRef = (SV*)GvIOp(gv);
568 if (strEQ(second_letter, "ORMAT"))
569 tmpRef = (SV*)GvFORM(gv);
572 if (strEQ(second_letter, "LOB"))
576 if (strEQ(second_letter, "ASH"))
577 tmpRef = (SV*)GvHV(gv);
580 if (*second_letter == 'O' && !elem[2])
581 tmpRef = (SV*)GvIOp(gv);
584 if (strEQ(second_letter, "AME"))
585 sv = newSVpvn(GvNAME(gv), GvNAMELEN(gv));
588 if (strEQ(second_letter, "ACKAGE")) {
589 const HEK *hek = HvNAME_HEK(GvSTASH(gv));
590 sv = hek ? newSVhek(hek) : newSVpvn("__ANON__", 8);
594 if (strEQ(second_letter, "CALAR"))
609 /* Pattern matching */
614 register unsigned char *s;
617 register I32 *sfirst;
621 if (sv == PL_lastscream) {
627 SvSCREAM_off(PL_lastscream);
628 SvREFCNT_dec(PL_lastscream);
630 PL_lastscream = SvREFCNT_inc(sv);
633 s = (unsigned char*)(SvPV(sv, len));
637 if (pos > PL_maxscream) {
638 if (PL_maxscream < 0) {
639 PL_maxscream = pos + 80;
640 Newx(PL_screamfirst, 256, I32);
641 Newx(PL_screamnext, PL_maxscream, I32);
644 PL_maxscream = pos + pos / 4;
645 Renew(PL_screamnext, PL_maxscream, I32);
649 sfirst = PL_screamfirst;
650 snext = PL_screamnext;
652 if (!sfirst || !snext)
653 DIE(aTHX_ "do_study: out of memory");
655 for (ch = 256; ch; --ch)
660 register const I32 ch = s[pos];
662 snext[pos] = sfirst[ch] - pos;
669 /* piggyback on m//g magic */
670 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
679 if (PL_op->op_flags & OPf_STACKED)
681 else if (PL_op->op_private & OPpTARGET_MY)
687 TARG = sv_newmortal();
692 /* Lvalue operators. */
704 dSP; dMARK; dTARGET; dORIGMARK;
706 do_chop(TARG, *++MARK);
715 SETi(do_chomp(TOPs));
722 register I32 count = 0;
725 count += do_chomp(POPs);
733 register SV* const sv = POPs;
735 if (!sv || !SvANY(sv))
737 switch (SvTYPE(sv)) {
739 if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
740 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
744 if (HvARRAY(sv) || SvGMAGICAL(sv)
745 || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
749 if (CvROOT(sv) || CvXSUB(sv))
765 if (!PL_op->op_private) {
774 SV_CHECK_THINKFIRST_COW_DROP(sv);
776 switch (SvTYPE(sv)) {
786 if (cv_const_sv((CV*)sv) && ckWARN(WARN_MISC))
787 Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
788 CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
792 /* let user-undef'd sub keep its identity */
793 GV* gv = CvGV((CV*)sv);
800 SvSetMagicSV(sv, &PL_sv_undef);
805 GvGP(sv) = gp_ref(gp);
806 GvSV(sv) = NEWSV(72,0);
807 GvLINE(sv) = CopLINE(PL_curcop);
813 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
815 SvPV_set(sv, Nullch);
828 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
829 DIE(aTHX_ PL_no_modify);
830 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
831 && SvIVX(TOPs) != IV_MIN)
833 SvIV_set(TOPs, SvIVX(TOPs) - 1);
834 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
845 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
846 DIE(aTHX_ PL_no_modify);
847 sv_setsv(TARG, TOPs);
848 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
849 && SvIVX(TOPs) != IV_MAX)
851 SvIV_set(TOPs, SvIVX(TOPs) + 1);
852 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
857 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
867 if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
868 DIE(aTHX_ PL_no_modify);
869 sv_setsv(TARG, TOPs);
870 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
871 && SvIVX(TOPs) != IV_MIN)
873 SvIV_set(TOPs, SvIVX(TOPs) - 1);
874 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
883 /* Ordinary operators. */
888 #ifdef PERL_PRESERVE_IVUV
891 tryAMAGICbin(pow,opASSIGN);
892 #ifdef PERL_PRESERVE_IVUV
893 /* For integer to integer power, we do the calculation by hand wherever
894 we're sure it is safe; otherwise we call pow() and try to convert to
895 integer afterwards. */
908 const IV iv = SvIVX(TOPs);
912 goto float_it; /* Can't do negative powers this way. */
916 baseuok = SvUOK(TOPm1s);
918 baseuv = SvUVX(TOPm1s);
920 const IV iv = SvIVX(TOPm1s);
923 baseuok = TRUE; /* effectively it's a UV now */
925 baseuv = -iv; /* abs, baseuok == false records sign */
928 /* now we have integer ** positive integer. */
931 /* foo & (foo - 1) is zero only for a power of 2. */
932 if (!(baseuv & (baseuv - 1))) {
933 /* We are raising power-of-2 to a positive integer.
934 The logic here will work for any base (even non-integer
935 bases) but it can be less accurate than
936 pow (base,power) or exp (power * log (base)) when the
937 intermediate values start to spill out of the mantissa.
938 With powers of 2 we know this can't happen.
939 And powers of 2 are the favourite thing for perl
940 programmers to notice ** not doing what they mean. */
942 NV base = baseuok ? baseuv : -(NV)baseuv;
947 while (power >>= 1) {
958 register unsigned int highbit = 8 * sizeof(UV);
959 register unsigned int diff = 8 * sizeof(UV);
962 if (baseuv >> highbit) {
966 /* we now have baseuv < 2 ** highbit */
967 if (power * highbit <= 8 * sizeof(UV)) {
968 /* result will definitely fit in UV, so use UV math
969 on same algorithm as above */
970 register UV result = 1;
971 register UV base = baseuv;
972 const bool odd_power = (bool)(power & 1);
976 while (power >>= 1) {
983 if (baseuok || !odd_power)
984 /* answer is positive */
986 else if (result <= (UV)IV_MAX)
987 /* answer negative, fits in IV */
989 else if (result == (UV)IV_MIN)
990 /* 2's complement assumption: special case IV_MIN */
993 /* answer negative, doesn't fit */
1005 SETn( Perl_pow( left, right) );
1006 #ifdef PERL_PRESERVE_IVUV
1016 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
1017 #ifdef PERL_PRESERVE_IVUV
1020 /* Unless the left argument is integer in range we are going to have to
1021 use NV maths. Hence only attempt to coerce the right argument if
1022 we know the left is integer. */
1023 /* Left operand is defined, so is it IV? */
1024 SvIV_please(TOPm1s);
1025 if (SvIOK(TOPm1s)) {
1026 bool auvok = SvUOK(TOPm1s);
1027 bool buvok = SvUOK(TOPs);
1028 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1029 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1036 alow = SvUVX(TOPm1s);
1038 const IV aiv = SvIVX(TOPm1s);
1041 auvok = TRUE; /* effectively it's a UV now */
1043 alow = -aiv; /* abs, auvok == false records sign */
1049 const IV biv = SvIVX(TOPs);
1052 buvok = TRUE; /* effectively it's a UV now */
1054 blow = -biv; /* abs, buvok == false records sign */
1058 /* If this does sign extension on unsigned it's time for plan B */
1059 ahigh = alow >> (4 * sizeof (UV));
1061 bhigh = blow >> (4 * sizeof (UV));
1063 if (ahigh && bhigh) {
1064 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1065 which is overflow. Drop to NVs below. */
1066 } else if (!ahigh && !bhigh) {
1067 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1068 so the unsigned multiply cannot overflow. */
1069 UV product = alow * blow;
1070 if (auvok == buvok) {
1071 /* -ve * -ve or +ve * +ve gives a +ve result. */
1075 } else if (product <= (UV)IV_MIN) {
1076 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1077 /* -ve result, which could overflow an IV */
1079 SETi( -(IV)product );
1081 } /* else drop to NVs below. */
1083 /* One operand is large, 1 small */
1086 /* swap the operands */
1088 bhigh = blow; /* bhigh now the temp var for the swap */
1092 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1093 multiplies can't overflow. shift can, add can, -ve can. */
1094 product_middle = ahigh * blow;
1095 if (!(product_middle & topmask)) {
1096 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1098 product_middle <<= (4 * sizeof (UV));
1099 product_low = alow * blow;
1101 /* as for pp_add, UV + something mustn't get smaller.
1102 IIRC ANSI mandates this wrapping *behaviour* for
1103 unsigned whatever the actual representation*/
1104 product_low += product_middle;
1105 if (product_low >= product_middle) {
1106 /* didn't overflow */
1107 if (auvok == buvok) {
1108 /* -ve * -ve or +ve * +ve gives a +ve result. */
1110 SETu( product_low );
1112 } else if (product_low <= (UV)IV_MIN) {
1113 /* 2s complement assumption again */
1114 /* -ve result, which could overflow an IV */
1116 SETi( -(IV)product_low );
1118 } /* else drop to NVs below. */
1120 } /* product_middle too large */
1121 } /* ahigh && bhigh */
1122 } /* SvIOK(TOPm1s) */
1127 SETn( left * right );
1134 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
1135 /* Only try to do UV divide first
1136 if ((SLOPPYDIVIDE is true) or
1137 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1139 The assumption is that it is better to use floating point divide
1140 whenever possible, only doing integer divide first if we can't be sure.
1141 If NV_PRESERVES_UV is true then we know at compile time that no UV
1142 can be too large to preserve, so don't need to compile the code to
1143 test the size of UVs. */
1146 # define PERL_TRY_UV_DIVIDE
1147 /* ensure that 20./5. == 4. */
1149 # ifdef PERL_PRESERVE_IVUV
1150 # ifndef NV_PRESERVES_UV
1151 # define PERL_TRY_UV_DIVIDE
1156 #ifdef PERL_TRY_UV_DIVIDE
1159 SvIV_please(TOPm1s);
1160 if (SvIOK(TOPm1s)) {
1161 bool left_non_neg = SvUOK(TOPm1s);
1162 bool right_non_neg = SvUOK(TOPs);
1166 if (right_non_neg) {
1167 right = SvUVX(TOPs);
1170 const IV biv = SvIVX(TOPs);
1173 right_non_neg = TRUE; /* effectively it's a UV now */
1179 /* historically undef()/0 gives a "Use of uninitialized value"
1180 warning before dieing, hence this test goes here.
1181 If it were immediately before the second SvIV_please, then
1182 DIE() would be invoked before left was even inspected, so
1183 no inpsection would give no warning. */
1185 DIE(aTHX_ "Illegal division by zero");
1188 left = SvUVX(TOPm1s);
1191 const IV aiv = SvIVX(TOPm1s);
1194 left_non_neg = TRUE; /* effectively it's a UV now */
1203 /* For sloppy divide we always attempt integer division. */
1205 /* Otherwise we only attempt it if either or both operands
1206 would not be preserved by an NV. If both fit in NVs
1207 we fall through to the NV divide code below. However,
1208 as left >= right to ensure integer result here, we know that
1209 we can skip the test on the right operand - right big
1210 enough not to be preserved can't get here unless left is
1213 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1216 /* Integer division can't overflow, but it can be imprecise. */
1217 const UV result = left / right;
1218 if (result * right == left) {
1219 SP--; /* result is valid */
1220 if (left_non_neg == right_non_neg) {
1221 /* signs identical, result is positive. */
1225 /* 2s complement assumption */
1226 if (result <= (UV)IV_MIN)
1227 SETi( -(IV)result );
1229 /* It's exact but too negative for IV. */
1230 SETn( -(NV)result );
1233 } /* tried integer divide but it was not an integer result */
1234 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1235 } /* left wasn't SvIOK */
1236 } /* right wasn't SvIOK */
1237 #endif /* PERL_TRY_UV_DIVIDE */
1241 DIE(aTHX_ "Illegal division by zero");
1242 PUSHn( left / right );
1249 dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
1253 bool left_neg = FALSE;
1254 bool right_neg = FALSE;
1255 bool use_double = FALSE;
1256 bool dright_valid = FALSE;
1262 right_neg = !SvUOK(TOPs);
1264 right = SvUVX(POPs);
1266 const IV biv = SvIVX(POPs);
1269 right_neg = FALSE; /* effectively it's a UV now */
1277 right_neg = dright < 0;
1280 if (dright < UV_MAX_P1) {
1281 right = U_V(dright);
1282 dright_valid = TRUE; /* In case we need to use double below. */
1288 /* At this point use_double is only true if right is out of range for
1289 a UV. In range NV has been rounded down to nearest UV and
1290 use_double false. */
1292 if (!use_double && SvIOK(TOPs)) {
1294 left_neg = !SvUOK(TOPs);
1298 IV aiv = SvIVX(POPs);
1301 left_neg = FALSE; /* effectively it's a UV now */
1310 left_neg = dleft < 0;
1314 /* This should be exactly the 5.6 behaviour - if left and right are
1315 both in range for UV then use U_V() rather than floor. */
1317 if (dleft < UV_MAX_P1) {
1318 /* right was in range, so is dleft, so use UVs not double.
1322 /* left is out of range for UV, right was in range, so promote
1323 right (back) to double. */
1325 /* The +0.5 is used in 5.6 even though it is not strictly
1326 consistent with the implicit +0 floor in the U_V()
1327 inside the #if 1. */
1328 dleft = Perl_floor(dleft + 0.5);
1331 dright = Perl_floor(dright + 0.5);
1341 DIE(aTHX_ "Illegal modulus zero");
1343 dans = Perl_fmod(dleft, dright);
1344 if ((left_neg != right_neg) && dans)
1345 dans = dright - dans;
1348 sv_setnv(TARG, dans);
1354 DIE(aTHX_ "Illegal modulus zero");
1357 if ((left_neg != right_neg) && ans)
1360 /* XXX may warn: unary minus operator applied to unsigned type */
1361 /* could change -foo to be (~foo)+1 instead */
1362 if (ans <= ~((UV)IV_MAX)+1)
1363 sv_setiv(TARG, ~ans+1);
1365 sv_setnv(TARG, -(NV)ans);
1368 sv_setuv(TARG, ans);
1377 dSP; dATARGET; tryAMAGICbin(repeat,opASSIGN);
1384 const UV uv = SvUV(sv);
1386 count = IV_MAX; /* The best we can do? */
1397 else if (SvNOKp(sv)) {
1398 const NV nv = SvNV(sv);
1406 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1408 I32 items = SP - MARK;
1410 static const char oom_list_extend[] =
1411 "Out of memory during list extend";
1413 max = items * count;
1414 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1415 /* Did the max computation overflow? */
1416 if (items > 0 && max > 0 && (max < items || max < count))
1417 Perl_croak(aTHX_ oom_list_extend);
1422 /* This code was intended to fix 20010809.028:
1425 for (($x =~ /./g) x 2) {
1426 print chop; # "abcdabcd" expected as output.
1429 * but that change (#11635) broke this code:
1431 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1433 * I can't think of a better fix that doesn't introduce
1434 * an efficiency hit by copying the SVs. The stack isn't
1435 * refcounted, and mortalisation obviously doesn't
1436 * Do The Right Thing when the stack has more than
1437 * one pointer to the same mortal value.
1441 *SP = sv_2mortal(newSVsv(*SP));
1451 repeatcpy((char*)(MARK + items), (char*)MARK,
1452 items * sizeof(SV*), count - 1);
1455 else if (count <= 0)
1458 else { /* Note: mark already snarfed by pp_list */
1462 static const char oom_string_extend[] =
1463 "Out of memory during string extend";
1465 SvSetSV(TARG, tmpstr);
1466 SvPV_force(TARG, len);
1467 isutf = DO_UTF8(TARG);
1472 STRLEN max = (UV)count * len;
1473 if (len > ((MEM_SIZE)~0)/count)
1474 Perl_croak(aTHX_ oom_string_extend);
1475 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1476 SvGROW(TARG, max + 1);
1477 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1478 SvCUR_set(TARG, SvCUR(TARG) * count);
1480 *SvEND(TARG) = '\0';
1483 (void)SvPOK_only_UTF8(TARG);
1485 (void)SvPOK_only(TARG);
1487 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1488 /* The parser saw this as a list repeat, and there
1489 are probably several items on the stack. But we're
1490 in scalar context, and there's no pp_list to save us
1491 now. So drop the rest of the items -- robin@kitsite.com
1504 dSP; dATARGET; bool useleft; tryAMAGICbin(subtr,opASSIGN);
1505 useleft = USE_LEFT(TOPm1s);
1506 #ifdef PERL_PRESERVE_IVUV
1507 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1508 "bad things" happen if you rely on signed integers wrapping. */
1511 /* Unless the left argument is integer in range we are going to have to
1512 use NV maths. Hence only attempt to coerce the right argument if
1513 we know the left is integer. */
1514 register UV auv = 0;
1520 a_valid = auvok = 1;
1521 /* left operand is undef, treat as zero. */
1523 /* Left operand is defined, so is it IV? */
1524 SvIV_please(TOPm1s);
1525 if (SvIOK(TOPm1s)) {
1526 if ((auvok = SvUOK(TOPm1s)))
1527 auv = SvUVX(TOPm1s);
1529 register const IV aiv = SvIVX(TOPm1s);
1532 auvok = 1; /* Now acting as a sign flag. */
1533 } else { /* 2s complement assumption for IV_MIN */
1541 bool result_good = 0;
1544 bool buvok = SvUOK(TOPs);
1549 register const IV biv = SvIVX(TOPs);
1556 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1557 else "IV" now, independent of how it came in.
1558 if a, b represents positive, A, B negative, a maps to -A etc
1563 all UV maths. negate result if A negative.
1564 subtract if signs same, add if signs differ. */
1566 if (auvok ^ buvok) {
1575 /* Must get smaller */
1580 if (result <= buv) {
1581 /* result really should be -(auv-buv). as its negation
1582 of true value, need to swap our result flag */
1594 if (result <= (UV)IV_MIN)
1595 SETi( -(IV)result );
1597 /* result valid, but out of range for IV. */
1598 SETn( -(NV)result );
1602 } /* Overflow, drop through to NVs. */
1606 useleft = USE_LEFT(TOPm1s);
1610 /* left operand is undef, treat as zero - value */
1614 SETn( TOPn - value );
1621 dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
1623 const IV shift = POPi;
1624 if (PL_op->op_private & HINT_INTEGER) {
1638 dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
1640 const IV shift = POPi;
1641 if (PL_op->op_private & HINT_INTEGER) {
1655 dSP; tryAMAGICbinSET(lt,0);
1656 #ifdef PERL_PRESERVE_IVUV
1659 SvIV_please(TOPm1s);
1660 if (SvIOK(TOPm1s)) {
1661 bool auvok = SvUOK(TOPm1s);
1662 bool buvok = SvUOK(TOPs);
1664 if (!auvok && !buvok) { /* ## IV < IV ## */
1665 const IV aiv = SvIVX(TOPm1s);
1666 const IV biv = SvIVX(TOPs);
1669 SETs(boolSV(aiv < biv));
1672 if (auvok && buvok) { /* ## UV < UV ## */
1673 const UV auv = SvUVX(TOPm1s);
1674 const UV buv = SvUVX(TOPs);
1677 SETs(boolSV(auv < buv));
1680 if (auvok) { /* ## UV < IV ## */
1682 const IV biv = SvIVX(TOPs);
1685 /* As (a) is a UV, it's >=0, so it cannot be < */
1690 SETs(boolSV(auv < (UV)biv));
1693 { /* ## IV < UV ## */
1694 const IV aiv = SvIVX(TOPm1s);
1698 /* As (b) is a UV, it's >=0, so it must be < */
1705 SETs(boolSV((UV)aiv < buv));
1711 #ifndef NV_PRESERVES_UV
1712 #ifdef PERL_PRESERVE_IVUV
1715 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1717 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1723 SETs(boolSV(TOPn < value));
1730 dSP; tryAMAGICbinSET(gt,0);
1731 #ifdef PERL_PRESERVE_IVUV
1734 SvIV_please(TOPm1s);
1735 if (SvIOK(TOPm1s)) {
1736 bool auvok = SvUOK(TOPm1s);
1737 bool buvok = SvUOK(TOPs);
1739 if (!auvok && !buvok) { /* ## IV > IV ## */
1740 const IV aiv = SvIVX(TOPm1s);
1741 const IV biv = SvIVX(TOPs);
1744 SETs(boolSV(aiv > biv));
1747 if (auvok && buvok) { /* ## UV > UV ## */
1748 const UV auv = SvUVX(TOPm1s);
1749 const UV buv = SvUVX(TOPs);
1752 SETs(boolSV(auv > buv));
1755 if (auvok) { /* ## UV > IV ## */
1757 const IV biv = SvIVX(TOPs);
1761 /* As (a) is a UV, it's >=0, so it must be > */
1766 SETs(boolSV(auv > (UV)biv));
1769 { /* ## IV > UV ## */
1770 const IV aiv = SvIVX(TOPm1s);
1774 /* As (b) is a UV, it's >=0, so it cannot be > */
1781 SETs(boolSV((UV)aiv > buv));
1787 #ifndef NV_PRESERVES_UV
1788 #ifdef PERL_PRESERVE_IVUV
1791 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1793 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1799 SETs(boolSV(TOPn > value));
1806 dSP; tryAMAGICbinSET(le,0);
1807 #ifdef PERL_PRESERVE_IVUV
1810 SvIV_please(TOPm1s);
1811 if (SvIOK(TOPm1s)) {
1812 bool auvok = SvUOK(TOPm1s);
1813 bool buvok = SvUOK(TOPs);
1815 if (!auvok && !buvok) { /* ## IV <= IV ## */
1816 const IV aiv = SvIVX(TOPm1s);
1817 const IV biv = SvIVX(TOPs);
1820 SETs(boolSV(aiv <= biv));
1823 if (auvok && buvok) { /* ## UV <= UV ## */
1824 UV auv = SvUVX(TOPm1s);
1825 UV buv = SvUVX(TOPs);
1828 SETs(boolSV(auv <= buv));
1831 if (auvok) { /* ## UV <= IV ## */
1833 const IV biv = SvIVX(TOPs);
1837 /* As (a) is a UV, it's >=0, so a cannot be <= */
1842 SETs(boolSV(auv <= (UV)biv));
1845 { /* ## IV <= UV ## */
1846 const IV aiv = SvIVX(TOPm1s);
1850 /* As (b) is a UV, it's >=0, so a must be <= */
1857 SETs(boolSV((UV)aiv <= buv));
1863 #ifndef NV_PRESERVES_UV
1864 #ifdef PERL_PRESERVE_IVUV
1867 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1869 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
1875 SETs(boolSV(TOPn <= value));
1882 dSP; tryAMAGICbinSET(ge,0);
1883 #ifdef PERL_PRESERVE_IVUV
1886 SvIV_please(TOPm1s);
1887 if (SvIOK(TOPm1s)) {
1888 bool auvok = SvUOK(TOPm1s);
1889 bool buvok = SvUOK(TOPs);
1891 if (!auvok && !buvok) { /* ## IV >= IV ## */
1892 const IV aiv = SvIVX(TOPm1s);
1893 const IV biv = SvIVX(TOPs);
1896 SETs(boolSV(aiv >= biv));
1899 if (auvok && buvok) { /* ## UV >= UV ## */
1900 const UV auv = SvUVX(TOPm1s);
1901 const UV buv = SvUVX(TOPs);
1904 SETs(boolSV(auv >= buv));
1907 if (auvok) { /* ## UV >= IV ## */
1909 const IV biv = SvIVX(TOPs);
1913 /* As (a) is a UV, it's >=0, so it must be >= */
1918 SETs(boolSV(auv >= (UV)biv));
1921 { /* ## IV >= UV ## */
1922 const IV aiv = SvIVX(TOPm1s);
1926 /* As (b) is a UV, it's >=0, so a cannot be >= */
1933 SETs(boolSV((UV)aiv >= buv));
1939 #ifndef NV_PRESERVES_UV
1940 #ifdef PERL_PRESERVE_IVUV
1943 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1945 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
1951 SETs(boolSV(TOPn >= value));
1958 dSP; tryAMAGICbinSET(ne,0);
1959 #ifndef NV_PRESERVES_UV
1960 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1962 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
1966 #ifdef PERL_PRESERVE_IVUV
1969 SvIV_please(TOPm1s);
1970 if (SvIOK(TOPm1s)) {
1971 bool auvok = SvUOK(TOPm1s);
1972 bool buvok = SvUOK(TOPs);
1974 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
1975 /* Casting IV to UV before comparison isn't going to matter
1976 on 2s complement. On 1s complement or sign&magnitude
1977 (if we have any of them) it could make negative zero
1978 differ from normal zero. As I understand it. (Need to
1979 check - is negative zero implementation defined behaviour
1981 const UV buv = SvUVX(POPs);
1982 const UV auv = SvUVX(TOPs);
1984 SETs(boolSV(auv != buv));
1987 { /* ## Mixed IV,UV ## */
1991 /* != is commutative so swap if needed (save code) */
1993 /* swap. top of stack (b) is the iv */
1997 /* As (a) is a UV, it's >0, so it cannot be == */
2006 /* As (b) is a UV, it's >0, so it cannot be == */
2010 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2012 SETs(boolSV((UV)iv != uv));
2020 SETs(boolSV(TOPn != value));
2027 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2028 #ifndef NV_PRESERVES_UV
2029 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2030 UV right = PTR2UV(SvRV(POPs));
2031 UV left = PTR2UV(SvRV(TOPs));
2032 SETi((left > right) - (left < right));
2036 #ifdef PERL_PRESERVE_IVUV
2037 /* Fortunately it seems NaN isn't IOK */
2040 SvIV_please(TOPm1s);
2041 if (SvIOK(TOPm1s)) {
2042 const bool leftuvok = SvUOK(TOPm1s);
2043 const bool rightuvok = SvUOK(TOPs);
2045 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2046 const IV leftiv = SvIVX(TOPm1s);
2047 const IV rightiv = SvIVX(TOPs);
2049 if (leftiv > rightiv)
2051 else if (leftiv < rightiv)
2055 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2056 const UV leftuv = SvUVX(TOPm1s);
2057 const UV rightuv = SvUVX(TOPs);
2059 if (leftuv > rightuv)
2061 else if (leftuv < rightuv)
2065 } else if (leftuvok) { /* ## UV <=> IV ## */
2066 const IV rightiv = SvIVX(TOPs);
2068 /* As (a) is a UV, it's >=0, so it cannot be < */
2071 const UV leftuv = SvUVX(TOPm1s);
2072 if (leftuv > (UV)rightiv) {
2074 } else if (leftuv < (UV)rightiv) {
2080 } else { /* ## IV <=> UV ## */
2081 const IV leftiv = SvIVX(TOPm1s);
2083 /* As (b) is a UV, it's >=0, so it must be < */
2086 const UV rightuv = SvUVX(TOPs);
2087 if ((UV)leftiv > rightuv) {
2089 } else if ((UV)leftiv < rightuv) {
2107 if (Perl_isnan(left) || Perl_isnan(right)) {
2111 value = (left > right) - (left < right);
2115 else if (left < right)
2117 else if (left > right)
2131 dSP; tryAMAGICbinSET(slt,0);
2134 const int cmp = (IN_LOCALE_RUNTIME
2135 ? sv_cmp_locale(left, right)
2136 : sv_cmp(left, right));
2137 SETs(boolSV(cmp < 0));
2144 dSP; tryAMAGICbinSET(sgt,0);
2147 const int cmp = (IN_LOCALE_RUNTIME
2148 ? sv_cmp_locale(left, right)
2149 : sv_cmp(left, right));
2150 SETs(boolSV(cmp > 0));
2157 dSP; tryAMAGICbinSET(sle,0);
2160 const int cmp = (IN_LOCALE_RUNTIME
2161 ? sv_cmp_locale(left, right)
2162 : sv_cmp(left, right));
2163 SETs(boolSV(cmp <= 0));
2170 dSP; tryAMAGICbinSET(sge,0);
2173 const int cmp = (IN_LOCALE_RUNTIME
2174 ? sv_cmp_locale(left, right)
2175 : sv_cmp(left, right));
2176 SETs(boolSV(cmp >= 0));
2183 dSP; tryAMAGICbinSET(seq,0);
2186 SETs(boolSV(sv_eq(left, right)));
2193 dSP; tryAMAGICbinSET(sne,0);
2196 SETs(boolSV(!sv_eq(left, right)));
2203 dSP; dTARGET; tryAMAGICbin(scmp,0);
2206 const int cmp = (IN_LOCALE_RUNTIME
2207 ? sv_cmp_locale(left, right)
2208 : sv_cmp(left, right));
2216 dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
2221 if (SvNIOKp(left) || SvNIOKp(right)) {
2222 if (PL_op->op_private & HINT_INTEGER) {
2223 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2227 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2232 do_vop(PL_op->op_type, TARG, left, right);
2241 dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
2246 if (SvNIOKp(left) || SvNIOKp(right)) {
2247 if (PL_op->op_private & HINT_INTEGER) {
2248 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
2252 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
2257 do_vop(PL_op->op_type, TARG, left, right);
2266 dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
2271 if (SvNIOKp(left) || SvNIOKp(right)) {
2272 if (PL_op->op_private & HINT_INTEGER) {
2273 const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
2277 const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
2282 do_vop(PL_op->op_type, TARG, left, right);
2291 dSP; dTARGET; tryAMAGICun(neg);
2294 const int flags = SvFLAGS(sv);
2296 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2297 /* It's publicly an integer, or privately an integer-not-float */
2300 if (SvIVX(sv) == IV_MIN) {
2301 /* 2s complement assumption. */
2302 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2305 else if (SvUVX(sv) <= IV_MAX) {
2310 else if (SvIVX(sv) != IV_MIN) {
2314 #ifdef PERL_PRESERVE_IVUV
2323 else if (SvPOKp(sv)) {
2325 const char *s = SvPV_const(sv, len);
2326 if (isIDFIRST(*s)) {
2327 sv_setpvn(TARG, "-", 1);
2330 else if (*s == '+' || *s == '-') {
2332 *SvPV_force(TARG, len) = *s == '-' ? '+' : '-';
2334 else if (DO_UTF8(sv)) {
2337 goto oops_its_an_int;
2339 sv_setnv(TARG, -SvNV(sv));
2341 sv_setpvn(TARG, "-", 1);
2348 goto oops_its_an_int;
2349 sv_setnv(TARG, -SvNV(sv));
2361 dSP; tryAMAGICunSET(not);
2362 *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
2368 dSP; dTARGET; tryAMAGICun(compl);
2373 if (PL_op->op_private & HINT_INTEGER) {
2374 const IV i = ~SvIV_nomg(sv);
2378 const UV u = ~SvUV_nomg(sv);
2387 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2388 sv_setsv_nomg(TARG, sv);
2389 tmps = (U8*)SvPV_force(TARG, len);
2392 /* Calculate exact length, let's not estimate. */
2401 while (tmps < send) {
2402 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2403 tmps += UTF8SKIP(tmps);
2404 targlen += UNISKIP(~c);
2410 /* Now rewind strings and write them. */
2414 Newxz(result, targlen + 1, U8);
2415 while (tmps < send) {
2416 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
2417 tmps += UTF8SKIP(tmps);
2418 result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
2422 sv_setpvn(TARG, (char*)result, targlen);
2426 Newxz(result, nchar + 1, U8);
2427 while (tmps < send) {
2428 const U8 c = (U8)utf8n_to_uvchr(tmps, 0, &l, UTF8_ALLOW_ANY);
2429 tmps += UTF8SKIP(tmps);
2434 sv_setpvn(TARG, (char*)result, nchar);
2443 register long *tmpl;
2444 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2447 for ( ; anum >= sizeof(long); anum -= sizeof(long), tmpl++)
2452 for ( ; anum > 0; anum--, tmps++)
2461 /* integer versions of some of the above */
2465 dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
2468 SETi( left * right );
2475 dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
2479 DIE(aTHX_ "Illegal division by zero");
2480 value = POPi / value;
2489 /* This is the vanilla old i_modulo. */
2490 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2494 DIE(aTHX_ "Illegal modulus zero");
2495 SETi( left % right );
2500 #if defined(__GLIBC__) && IVSIZE == 8
2504 /* This is the i_modulo with the workaround for the _moddi3 bug
2505 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2506 * See below for pp_i_modulo. */
2507 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2511 DIE(aTHX_ "Illegal modulus zero");
2512 SETi( left % PERL_ABS(right) );
2520 dVAR; dSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
2524 DIE(aTHX_ "Illegal modulus zero");
2525 /* The assumption is to use hereafter the old vanilla version... */
2527 PL_ppaddr[OP_I_MODULO] =
2529 /* .. but if we have glibc, we might have a buggy _moddi3
2530 * (at least glicb 2.2.5 is known to have this bug), in other
2531 * words our integer modulus with negative quad as the second
2532 * argument might be broken. Test for this and re-patch the
2533 * opcode dispatch table if that is the case, remembering to
2534 * also apply the workaround so that this first round works
2535 * right, too. See [perl #9402] for more information. */
2536 #if defined(__GLIBC__) && IVSIZE == 8
2540 /* Cannot do this check with inlined IV constants since
2541 * that seems to work correctly even with the buggy glibc. */
2543 /* Yikes, we have the bug.
2544 * Patch in the workaround version. */
2546 PL_ppaddr[OP_I_MODULO] =
2547 &Perl_pp_i_modulo_1;
2548 /* Make certain we work right this time, too. */
2549 right = PERL_ABS(right);
2553 SETi( left % right );
2560 dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
2563 SETi( left + right );
2570 dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
2573 SETi( left - right );
2580 dSP; tryAMAGICbinSET(lt,0);
2583 SETs(boolSV(left < right));
2590 dSP; tryAMAGICbinSET(gt,0);
2593 SETs(boolSV(left > right));
2600 dSP; tryAMAGICbinSET(le,0);
2603 SETs(boolSV(left <= right));
2610 dSP; tryAMAGICbinSET(ge,0);
2613 SETs(boolSV(left >= right));
2620 dSP; tryAMAGICbinSET(eq,0);
2623 SETs(boolSV(left == right));
2630 dSP; tryAMAGICbinSET(ne,0);
2633 SETs(boolSV(left != right));
2640 dSP; dTARGET; tryAMAGICbin(ncmp,0);
2647 else if (left < right)
2658 dSP; dTARGET; tryAMAGICun(neg);
2663 /* High falutin' math. */
2667 dSP; dTARGET; tryAMAGICbin(atan2,0);
2670 SETn(Perl_atan2(left, right));
2677 dSP; dTARGET; tryAMAGICun(sin);
2679 const NV value = POPn;
2680 XPUSHn(Perl_sin(value));
2687 dSP; dTARGET; tryAMAGICun(cos);
2689 const NV value = POPn;
2690 XPUSHn(Perl_cos(value));
2695 /* Support Configure command-line overrides for rand() functions.
2696 After 5.005, perhaps we should replace this by Configure support
2697 for drand48(), random(), or rand(). For 5.005, though, maintain
2698 compatibility by calling rand() but allow the user to override it.
2699 See INSTALL for details. --Andy Dougherty 15 July 1998
2701 /* Now it's after 5.005, and Configure supports drand48() and random(),
2702 in addition to rand(). So the overrides should not be needed any more.
2703 --Jarkko Hietaniemi 27 September 1998
2706 #ifndef HAS_DRAND48_PROTO
2707 extern double drand48 (void);
2720 if (!PL_srand_called) {
2721 (void)seedDrand01((Rand_seed_t)seed());
2722 PL_srand_called = TRUE;
2737 (void)seedDrand01((Rand_seed_t)anum);
2738 PL_srand_called = TRUE;
2745 dSP; dTARGET; tryAMAGICun(exp);
2749 value = Perl_exp(value);
2757 dSP; dTARGET; tryAMAGICun(log);
2759 const NV value = POPn;
2761 SET_NUMERIC_STANDARD();
2762 DIE(aTHX_ "Can't take log of %"NVgf, value);
2764 XPUSHn(Perl_log(value));
2771 dSP; dTARGET; tryAMAGICun(sqrt);
2773 const NV value = POPn;
2775 SET_NUMERIC_STANDARD();
2776 DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
2778 XPUSHn(Perl_sqrt(value));
2785 dSP; dTARGET; tryAMAGICun(int);
2787 const IV iv = TOPi; /* attempt to convert to IV if possible. */
2788 /* XXX it's arguable that compiler casting to IV might be subtly
2789 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2790 else preferring IV has introduced a subtle behaviour change bug. OTOH
2791 relying on floating point to be accurate is a bug. */
2795 else if (SvIOK(TOPs)) {
2802 const NV value = TOPn;
2804 if (value < (NV)UV_MAX + 0.5) {
2807 SETn(Perl_floor(value));
2811 if (value > (NV)IV_MIN - 0.5) {
2814 SETn(Perl_ceil(value));
2824 dSP; dTARGET; tryAMAGICun(abs);
2826 /* This will cache the NV value if string isn't actually integer */
2831 else if (SvIOK(TOPs)) {
2832 /* IVX is precise */
2834 SETu(TOPu); /* force it to be numeric only */
2842 /* 2s complement assumption. Also, not really needed as
2843 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2849 const NV value = TOPn;
2864 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2868 SV* const sv = POPs;
2870 tmps = (SvPV_const(sv, len));
2872 /* If Unicode, try to downgrade
2873 * If not possible, croak. */
2874 SV* const tsv = sv_2mortal(newSVsv(sv));
2877 sv_utf8_downgrade(tsv, FALSE);
2878 tmps = SvPV_const(tsv, len);
2880 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2881 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2894 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2898 SV* const sv = POPs;
2900 tmps = (SvPV_const(sv, len));
2902 /* If Unicode, try to downgrade
2903 * If not possible, croak. */
2904 SV* const tsv = sv_2mortal(newSVsv(sv));
2907 sv_utf8_downgrade(tsv, FALSE);
2908 tmps = SvPV_const(tsv, len);
2910 while (*tmps && len && isSPACE(*tmps))
2915 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2916 else if (*tmps == 'b')
2917 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2919 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2921 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2938 SETi(sv_len_utf8(sv));
2954 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2956 const I32 arybase = PL_curcop->cop_arybase;
2958 const char *repl = 0;
2960 const int num_args = PL_op->op_private & 7;
2961 bool repl_need_utf8_upgrade = FALSE;
2962 bool repl_is_utf8 = FALSE;
2964 SvTAINTED_off(TARG); /* decontaminate */
2965 SvUTF8_off(TARG); /* decontaminate */
2969 repl = SvPV_const(repl_sv, repl_len);
2970 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
2980 sv_utf8_upgrade(sv);
2982 else if (DO_UTF8(sv))
2983 repl_need_utf8_upgrade = TRUE;
2985 tmps = SvPV_const(sv, curlen);
2987 utf8_curlen = sv_len_utf8(sv);
2988 if (utf8_curlen == curlen)
2991 curlen = utf8_curlen;
2996 if (pos >= arybase) {
3014 else if (len >= 0) {
3016 if (rem > (I32)curlen)
3031 Perl_croak(aTHX_ "substr outside of string");
3032 if (ckWARN(WARN_SUBSTR))
3033 Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3037 const I32 upos = pos;
3038 const I32 urem = rem;
3040 sv_pos_u2b(sv, &pos, &rem);
3042 /* we either return a PV or an LV. If the TARG hasn't been used
3043 * before, or is of that type, reuse it; otherwise use a mortal
3044 * instead. Note that LVs can have an extended lifetime, so also
3045 * dont reuse if refcount > 1 (bug #20933) */
3046 if (SvTYPE(TARG) > SVt_NULL) {
3047 if ( (SvTYPE(TARG) == SVt_PVLV)
3048 ? (!lvalue || SvREFCNT(TARG) > 1)
3051 TARG = sv_newmortal();
3055 sv_setpvn(TARG, tmps, rem);
3056 #ifdef USE_LOCALE_COLLATE
3057 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3062 SV* repl_sv_copy = NULL;
3064 if (repl_need_utf8_upgrade) {
3065 repl_sv_copy = newSVsv(repl_sv);
3066 sv_utf8_upgrade(repl_sv_copy);
3067 repl = SvPV_const(repl_sv_copy, repl_len);
3068 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3070 sv_insert(sv, pos, rem, repl, repl_len);
3074 SvREFCNT_dec(repl_sv_copy);
3076 else if (lvalue) { /* it's an lvalue! */
3077 if (!SvGMAGICAL(sv)) {
3079 SvPV_force_nolen(sv);
3080 if (ckWARN(WARN_SUBSTR))
3081 Perl_warner(aTHX_ packWARN(WARN_SUBSTR),
3082 "Attempt to use reference as lvalue in substr");
3084 if (SvOK(sv)) /* is it defined ? */
3085 (void)SvPOK_only_UTF8(sv);
3087 sv_setpvn(sv,"",0); /* avoid lexical reincarnation */
3090 if (SvTYPE(TARG) < SVt_PVLV) {
3091 sv_upgrade(TARG, SVt_PVLV);
3092 sv_magic(TARG, Nullsv, PERL_MAGIC_substr, Nullch, 0);
3098 if (LvTARG(TARG) != sv) {
3100 SvREFCNT_dec(LvTARG(TARG));
3101 LvTARG(TARG) = SvREFCNT_inc(sv);
3103 LvTARGOFF(TARG) = upos;
3104 LvTARGLEN(TARG) = urem;
3108 PUSHs(TARG); /* avoid SvSETMAGIC here */
3115 register const IV size = POPi;
3116 register const IV offset = POPi;
3117 register SV * const src = POPs;
3118 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3120 SvTAINTED_off(TARG); /* decontaminate */
3121 if (lvalue) { /* it's an lvalue! */
3122 if (SvREFCNT(TARG) > 1) /* don't share the TARG (#20933) */
3123 TARG = sv_newmortal();
3124 if (SvTYPE(TARG) < SVt_PVLV) {
3125 sv_upgrade(TARG, SVt_PVLV);
3126 sv_magic(TARG, Nullsv, PERL_MAGIC_vec, Nullch, 0);
3129 if (LvTARG(TARG) != src) {
3131 SvREFCNT_dec(LvTARG(TARG));
3132 LvTARG(TARG) = SvREFCNT_inc(src);
3134 LvTARGOFF(TARG) = offset;
3135 LvTARGLEN(TARG) = size;
3138 sv_setuv(TARG, do_vecget(src, offset, size));
3154 const I32 arybase = PL_curcop->cop_arybase;
3161 offset = POPi - arybase;
3164 big_utf8 = DO_UTF8(big);
3165 little_utf8 = DO_UTF8(little);
3166 if (big_utf8 ^ little_utf8) {
3167 /* One needs to be upgraded. */
3168 SV * const bytes = little_utf8 ? big : little;
3170 const char * const p = SvPV_const(bytes, len);
3172 temp = newSVpvn(p, len);
3175 sv_recode_to_utf8(temp, PL_encoding);
3177 sv_utf8_upgrade(temp);
3186 if (big_utf8 && offset > 0)
3187 sv_pos_u2b(big, &offset, 0);
3188 tmps = SvPV_const(big, biglen);
3191 else if (offset > (I32)biglen)
3193 if (!(tmps2 = fbm_instr((unsigned char*)tmps + offset,
3194 (unsigned char*)tmps + biglen, little, 0)))
3197 retval = tmps2 - tmps;
3198 if (retval > 0 && big_utf8)
3199 sv_pos_b2u(big, &retval);
3202 PUSHi(retval + arybase);
3218 const I32 arybase = PL_curcop->cop_arybase;
3226 big_utf8 = DO_UTF8(big);
3227 little_utf8 = DO_UTF8(little);
3228 if (big_utf8 ^ little_utf8) {
3229 /* One needs to be upgraded. */
3230 SV * const bytes = little_utf8 ? big : little;
3232 const char *p = SvPV_const(bytes, len);
3234 temp = newSVpvn(p, len);
3237 sv_recode_to_utf8(temp, PL_encoding);
3239 sv_utf8_upgrade(temp);
3248 tmps2 = SvPV_const(little, llen);
3249 tmps = SvPV_const(big, blen);
3254 if (offset > 0 && big_utf8)
3255 sv_pos_u2b(big, &offset, 0);
3256 offset = offset - arybase + llen;
3260 else if (offset > (I32)blen)
3262 if (!(tmps2 = rninstr(tmps, tmps + offset,
3263 tmps2, tmps2 + llen)))
3266 retval = tmps2 - tmps;
3267 if (retval > 0 && big_utf8)
3268 sv_pos_b2u(big, &retval);
3271 PUSHi(retval + arybase);
3277 dSP; dMARK; dORIGMARK; dTARGET;
3278 do_sprintf(TARG, SP-MARK, MARK+1);
3279 TAINT_IF(SvTAINTED(TARG));
3280 if (DO_UTF8(*(MARK+1)))
3292 const U8 *s = (U8*)SvPV_const(argsv, len);
3295 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3296 tmpsv = sv_2mortal(newSVsv(argsv));
3297 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3301 XPUSHu(DO_UTF8(argsv) ?
3302 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3314 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3316 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3318 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3320 (void) POPs; /* Ignore the argument value. */
3321 value = UNICODE_REPLACEMENT;
3327 SvUPGRADE(TARG,SVt_PV);
3329 if (value > 255 && !IN_BYTES) {
3330 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3331 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3332 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3334 (void)SvPOK_only(TARG);
3343 *tmps++ = (char)value;
3345 (void)SvPOK_only(TARG);
3346 if (PL_encoding && !IN_BYTES) {
3347 sv_recode_to_utf8(TARG, PL_encoding);
3349 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3350 memEQ(tmps, "\xef\xbf\xbd\0", 4)) {
3354 *tmps++ = (U8)UTF8_EIGHT_BIT_HI(value);
3355 *tmps++ = (U8)UTF8_EIGHT_BIT_LO(value);
3370 const char *tmps = SvPV_const(left, len);
3372 if (DO_UTF8(left)) {
3373 /* If Unicode, try to downgrade.
3374 * If not possible, croak.
3375 * Yes, we made this up. */
3376 SV* const tsv = sv_2mortal(newSVsv(left));
3379 sv_utf8_downgrade(tsv, FALSE);
3380 tmps = SvPV_const(tsv, len);
3382 # ifdef USE_ITHREADS
3384 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3385 /* This should be threadsafe because in ithreads there is only
3386 * one thread per interpreter. If this would not be true,
3387 * we would need a mutex to protect this malloc. */
3388 PL_reentrant_buffer->_crypt_struct_buffer =
3389 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3390 #if defined(__GLIBC__) || defined(__EMX__)
3391 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3392 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3393 /* work around glibc-2.2.5 bug */
3394 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3398 # endif /* HAS_CRYPT_R */
3399 # endif /* USE_ITHREADS */
3401 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3403 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3409 "The crypt() function is unimplemented due to excessive paranoia.");
3422 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3423 UTF8_IS_START(*s)) {
3424 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3428 utf8_to_uvchr(s, &ulen);
3429 toTITLE_utf8(s, tmpbuf, &tculen);
3430 utf8_to_uvchr(tmpbuf, 0);
3432 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3434 /* slen is the byte length of the whole SV.
3435 * ulen is the byte length of the original Unicode character
3436 * stored as UTF-8 at s.
3437 * tculen is the byte length of the freshly titlecased
3438 * Unicode character stored as UTF-8 at tmpbuf.
3439 * We first set the result to be the titlecased character,
3440 * and then append the rest of the SV data. */
3441 sv_setpvn(TARG, (char*)tmpbuf, tculen);
3443 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3448 s = (U8*)SvPV_force_nomg(sv, slen);
3449 Copy(tmpbuf, s, tculen, U8);
3454 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3456 SvUTF8_off(TARG); /* decontaminate */
3457 sv_setsv_nomg(TARG, sv);
3461 s1 = (U8*)SvPV_force_nomg(sv, slen);
3463 if (IN_LOCALE_RUNTIME) {
3466 *s1 = toUPPER_LC(*s1);
3485 (s = (const U8*)SvPV_nomg_const(sv, slen)) && slen &&
3486 UTF8_IS_START(*s)) {
3488 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3492 toLOWER_utf8(s, tmpbuf, &ulen);
3493 uv = utf8_to_uvchr(tmpbuf, 0);
3494 tend = uvchr_to_utf8(tmpbuf, uv);
3496 if (!SvPADTMP(sv) || (STRLEN)(tend - tmpbuf) != ulen || SvREADONLY(sv)) {
3498 sv_setpvn(TARG, (char*)tmpbuf, tend - tmpbuf);
3500 sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
3505 s = (U8*)SvPV_force_nomg(sv, slen);
3506 Copy(tmpbuf, s, ulen, U8);
3511 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3513 SvUTF8_off(TARG); /* decontaminate */
3514 sv_setsv_nomg(TARG, sv);
3518 s1 = (U8*)SvPV_force_nomg(sv, slen);
3520 if (IN_LOCALE_RUNTIME) {
3523 *s1 = toLOWER_LC(*s1);
3546 U8 tmpbuf[UTF8_MAXBYTES+1];
3548 s = (const U8*)SvPV_nomg_const(sv,len);
3550 SvUTF8_off(TARG); /* decontaminate */
3551 sv_setpvn(TARG, "", 0);
3555 STRLEN min = len + 1;
3557 SvUPGRADE(TARG, SVt_PV);
3559 (void)SvPOK_only(TARG);
3560 d = (U8*)SvPVX(TARG);
3563 STRLEN u = UTF8SKIP(s);
3565 toUPPER_utf8(s, tmpbuf, &ulen);
3566 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3567 /* If the eventually required minimum size outgrows
3568 * the available space, we need to grow. */
3569 UV o = d - (U8*)SvPVX_const(TARG);
3571 /* If someone uppercases one million U+03B0s we
3572 * SvGROW() one million times. Or we could try
3573 * guessing how much to allocate without allocating
3574 * too much. Such is life. */
3576 d = (U8*)SvPVX(TARG) + o;
3578 Copy(tmpbuf, d, ulen, U8);
3584 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3590 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3592 SvUTF8_off(TARG); /* decontaminate */
3593 sv_setsv_nomg(TARG, sv);
3597 s = (U8*)SvPV_force_nomg(sv, len);
3599 register const U8 *send = s + len;
3601 if (IN_LOCALE_RUNTIME) {
3604 for (; s < send; s++)
3605 *s = toUPPER_LC(*s);
3608 for (; s < send; s++)
3630 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3632 s = (const U8*)SvPV_nomg_const(sv,len);
3634 SvUTF8_off(TARG); /* decontaminate */
3635 sv_setpvn(TARG, "", 0);
3639 STRLEN min = len + 1;
3641 SvUPGRADE(TARG, SVt_PV);
3643 (void)SvPOK_only(TARG);
3644 d = (U8*)SvPVX(TARG);
3647 const STRLEN u = UTF8SKIP(s);
3648 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
3650 #define GREEK_CAPITAL_LETTER_SIGMA 0x03A3 /* Unicode U+03A3 */
3651 if (uv == GREEK_CAPITAL_LETTER_SIGMA) {
3653 * Now if the sigma is NOT followed by
3654 * /$ignorable_sequence$cased_letter/;
3655 * and it IS preceded by
3656 * /$cased_letter$ignorable_sequence/;
3657 * where $ignorable_sequence is
3658 * [\x{2010}\x{AD}\p{Mn}]*
3659 * and $cased_letter is
3660 * [\p{Ll}\p{Lo}\p{Lt}]
3661 * then it should be mapped to 0x03C2,
3662 * (GREEK SMALL LETTER FINAL SIGMA),
3663 * instead of staying 0x03A3.
3664 * "should be": in other words,
3665 * this is not implemented yet.
3666 * See lib/unicore/SpecialCasing.txt.
3669 if (ulen > u && (SvLEN(TARG) < (min += ulen - u))) {
3670 /* If the eventually required minimum size outgrows
3671 * the available space, we need to grow. */
3672 UV o = d - (U8*)SvPVX_const(TARG);
3674 /* If someone lowercases one million U+0130s we
3675 * SvGROW() one million times. Or we could try
3676 * guessing how much to allocate without allocating.
3677 * too much. Such is life. */
3679 d = (U8*)SvPVX(TARG) + o;
3681 Copy(tmpbuf, d, ulen, U8);
3687 SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
3693 if (!SvPADTMP(sv) || SvREADONLY(sv)) {
3695 SvUTF8_off(TARG); /* decontaminate */
3696 sv_setsv_nomg(TARG, sv);
3701 s = (U8*)SvPV_force_nomg(sv, len);
3703 register const U8 * const send = s + len;
3705 if (IN_LOCALE_RUNTIME) {
3708 for (; s < send; s++)
3709 *s = toLOWER_LC(*s);
3712 for (; s < send; s++)
3724 SV * const sv = TOPs;
3726 register const char *s = SvPV_const(sv,len);
3728 SvUTF8_off(TARG); /* decontaminate */
3731 SvUPGRADE(TARG, SVt_PV);
3732 SvGROW(TARG, (len * 2) + 1);
3736 if (UTF8_IS_CONTINUED(*s)) {
3737 STRLEN ulen = UTF8SKIP(s);
3761 SvCUR_set(TARG, d - SvPVX_const(TARG));
3762 (void)SvPOK_only_UTF8(TARG);
3765 sv_setpvn(TARG, s, len);
3767 if (SvSMAGICAL(TARG))
3776 dSP; dMARK; dORIGMARK;
3777 register AV* const av = (AV*)POPs;
3778 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3780 if (SvTYPE(av) == SVt_PVAV) {
3781 const I32 arybase = PL_curcop->cop_arybase;
3782 if (lval && PL_op->op_private & OPpLVAL_INTRO) {
3785 for (svp = MARK + 1; svp <= SP; svp++) {
3786 const I32 elem = SvIVx(*svp);
3790 if (max > AvMAX(av))
3793 while (++MARK <= SP) {
3795 I32 elem = SvIVx(*MARK);
3799 svp = av_fetch(av, elem, lval);
3801 if (!svp || *svp == &PL_sv_undef)
3802 DIE(aTHX_ PL_no_aelem, elem);
3803 if (PL_op->op_private & OPpLVAL_INTRO)
3804 save_aelem(av, elem, svp);
3806 *MARK = svp ? *svp : &PL_sv_undef;
3809 if (GIMME != G_ARRAY) {
3811 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
3817 /* Associative arrays. */
3822 HV * const hash = (HV*)POPs;
3824 const I32 gimme = GIMME_V;
3827 /* might clobber stack_sp */
3828 entry = hv_iternext(hash);
3833 SV* const sv = hv_iterkeysv(entry);
3834 PUSHs(sv); /* won't clobber stack_sp */
3835 if (gimme == G_ARRAY) {
3838 /* might clobber stack_sp */
3839 val = hv_iterval(hash, entry);
3844 else if (gimme == G_SCALAR)
3863 const I32 gimme = GIMME_V;
3864 const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
3866 if (PL_op->op_private & OPpSLICE) {
3868 HV * const hv = (HV*)POPs;
3869 const U32 hvtype = SvTYPE(hv);
3870 if (hvtype == SVt_PVHV) { /* hash element */
3871 while (++MARK <= SP) {
3872 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
3873 *MARK = sv ? sv : &PL_sv_undef;
3876 else if (hvtype == SVt_PVAV) { /* array element */
3877 if (PL_op->op_flags & OPf_SPECIAL) {
3878 while (++MARK <= SP) {
3879 SV * const sv = av_delete((AV*)hv, SvIV(*MARK), discard);
3880 *MARK = sv ? sv : &PL_sv_undef;
3885 DIE(aTHX_ "Not a HASH reference");
3888 else if (gimme == G_SCALAR) {
3893 *++MARK = &PL_sv_undef;
3899 HV * const hv = (HV*)POPs;
3901 if (SvTYPE(hv) == SVt_PVHV)
3902 sv = hv_delete_ent(hv, keysv, discard, 0);
3903 else if (SvTYPE(hv) == SVt_PVAV) {
3904 if (PL_op->op_flags & OPf_SPECIAL)
3905 sv = av_delete((AV*)hv, SvIV(keysv), discard);
3907 DIE(aTHX_ "panic: avhv_delete no longer supported");
3910 DIE(aTHX_ "Not a HASH reference");
3925 if (PL_op->op_private & OPpEXISTS_SUB) {
3928 CV * const cv = sv_2cv(sv, &hv, &gv, FALSE);
3931 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
3937 if (SvTYPE(hv) == SVt_PVHV) {
3938 if (hv_exists_ent(hv, tmpsv, 0))
3941 else if (SvTYPE(hv) == SVt_PVAV) {
3942 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
3943 if (av_exists((AV*)hv, SvIV(tmpsv)))
3948 DIE(aTHX_ "Not a HASH reference");
3955 dSP; dMARK; dORIGMARK;
3956 register HV * const hv = (HV*)POPs;
3957 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
3958 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
3959 bool other_magic = FALSE;
3965 other_magic = mg_find((SV*)hv, PERL_MAGIC_env) ||
3966 ((mg = mg_find((SV*)hv, PERL_MAGIC_tied))
3967 /* Try to preserve the existenceness of a tied hash
3968 * element by using EXISTS and DELETE if possible.
3969 * Fallback to FETCH and STORE otherwise */
3970 && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
3971 && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
3972 && gv_fetchmethod_autoload(stash, "DELETE", TRUE));
3975 while (++MARK <= SP) {
3976 SV * const keysv = *MARK;
3979 bool preeminent = FALSE;
3982 preeminent = SvRMAGICAL(hv) && !other_magic ? 1 :
3983 hv_exists_ent(hv, keysv, 0);
3986 he = hv_fetch_ent(hv, keysv, lval, 0);
3987 svp = he ? &HeVAL(he) : 0;
3990 if (!svp || *svp == &PL_sv_undef) {
3991 DIE(aTHX_ PL_no_helem_sv, keysv);
3995 save_helem(hv, keysv, svp);
3998 const char *key = SvPV_const(keysv, keylen);
3999 SAVEDELETE(hv, savepvn(key,keylen), keylen);
4003 *MARK = svp ? *svp : &PL_sv_undef;
4005 if (GIMME != G_ARRAY) {
4007 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4013 /* List operators. */
4018 if (GIMME != G_ARRAY) {
4020 *MARK = *SP; /* unwanted list, return last item */
4022 *MARK = &PL_sv_undef;
4031 SV ** const lastrelem = PL_stack_sp;
4032 SV ** const lastlelem = PL_stack_base + POPMARK;
4033 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4034 register SV ** const firstrelem = lastlelem + 1;
4035 const I32 arybase = PL_curcop->cop_arybase;
4036 I32 is_something_there = PL_op->op_flags & OPf_MOD;
4038 register const I32 max = lastrelem - lastlelem;
4039 register SV **lelem;
4041 if (GIMME != G_ARRAY) {
4042 I32 ix = SvIVx(*lastlelem);
4047 if (ix < 0 || ix >= max)
4048 *firstlelem = &PL_sv_undef;
4050 *firstlelem = firstrelem[ix];
4056 SP = firstlelem - 1;
4060 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4061 I32 ix = SvIVx(*lelem);
4066 if (ix < 0 || ix >= max)
4067 *lelem = &PL_sv_undef;
4069 is_something_there = TRUE;
4070 if (!(*lelem = firstrelem[ix]))
4071 *lelem = &PL_sv_undef;
4074 if (is_something_there)
4077 SP = firstlelem - 1;
4083 dSP; dMARK; dORIGMARK;
4084 const I32 items = SP - MARK;
4085 SV * const av = sv_2mortal((SV*)av_make(items, MARK+1));
4086 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4093 dSP; dMARK; dORIGMARK;
4094 HV* const hv = (HV*)sv_2mortal((SV*)newHV());
4097 SV * const key = *++MARK;
4098 SV * const val = NEWSV(46, 0);
4100 sv_setsv(val, *++MARK);
4101 else if (ckWARN(WARN_MISC))
4102 Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4103 (void)hv_store_ent(hv,key,val,0);
4112 dVAR; dSP; dMARK; dORIGMARK;
4113 register AV *ary = (AV*)*++MARK;
4117 register I32 offset;
4118 register I32 length;
4123 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4126 *MARK-- = SvTIED_obj((SV*)ary, mg);
4130 call_method("SPLICE",GIMME_V);
4139 offset = i = SvIVx(*MARK);
4141 offset += AvFILLp(ary) + 1;
4143 offset -= PL_curcop->cop_arybase;
4145 DIE(aTHX_ PL_no_aelem, i);
4147 length = SvIVx(*MARK++);
4149 length += AvFILLp(ary) - offset + 1;
4155 length = AvMAX(ary) + 1; /* close enough to infinity */
4159 length = AvMAX(ary) + 1;
4161 if (offset > AvFILLp(ary) + 1) {
4162 if (ckWARN(WARN_MISC))
4163 Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4164 offset = AvFILLp(ary) + 1;
4166 after = AvFILLp(ary) + 1 - (offset + length);
4167 if (after < 0) { /* not that much array */
4168 length += after; /* offset+length now in array */
4174 /* At this point, MARK .. SP-1 is our new LIST */
4177 diff = newlen - length;
4178 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4181 /* make new elements SVs now: avoid problems if they're from the array */
4182 for (dst = MARK, i = newlen; i; i--) {
4183 SV * const h = *dst;
4184 *dst++ = newSVsv(h);
4187 if (diff < 0) { /* shrinking the area */
4189 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4190 Copy(MARK, tmparyval, newlen, SV*);
4193 MARK = ORIGMARK + 1;
4194 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4195 MEXTEND(MARK, length);
4196 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4198 EXTEND_MORTAL(length);
4199 for (i = length, dst = MARK; i; i--) {
4200 sv_2mortal(*dst); /* free them eventualy */
4207 *MARK = AvARRAY(ary)[offset+length-1];
4210 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4211 SvREFCNT_dec(*dst++); /* free them now */
4214 AvFILLp(ary) += diff;
4216 /* pull up or down? */
4218 if (offset < after) { /* easier to pull up */
4219 if (offset) { /* esp. if nothing to pull */
4220 src = &AvARRAY(ary)[offset-1];
4221 dst = src - diff; /* diff is negative */
4222 for (i = offset; i > 0; i--) /* can't trust Copy */
4226 SvPV_set(ary, (char*)(AvARRAY(ary) - diff)); /* diff is negative */
4230 if (after) { /* anything to pull down? */
4231 src = AvARRAY(ary) + offset + length;
4232 dst = src + diff; /* diff is negative */
4233 Move(src, dst, after, SV*);
4235 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4236 /* avoid later double free */
4240 dst[--i] = &PL_sv_undef;
4243 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4244 Safefree(tmparyval);
4247 else { /* no, expanding (or same) */
4249 Newx(tmparyval, length, SV*); /* so remember deletion */
4250 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4253 if (diff > 0) { /* expanding */
4255 /* push up or down? */
4257 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4261 Move(src, dst, offset, SV*);
4263 SvPV_set(ary, (char*)(AvARRAY(ary) - diff));/* diff is positive */
4265 AvFILLp(ary) += diff;
4268 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4269 av_extend(ary, AvFILLp(ary) + diff);
4270 AvFILLp(ary) += diff;
4273 dst = AvARRAY(ary) + AvFILLp(ary);
4275 for (i = after; i; i--) {
4283 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4286 MARK = ORIGMARK + 1;
4287 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4289 Copy(tmparyval, MARK, length, SV*);
4291 EXTEND_MORTAL(length);
4292 for (i = length, dst = MARK; i; i--) {
4293 sv_2mortal(*dst); /* free them eventualy */
4297 Safefree(tmparyval);
4301 else if (length--) {
4302 *MARK = tmparyval[length];
4305 while (length-- > 0)
4306 SvREFCNT_dec(tmparyval[length]);
4308 Safefree(tmparyval);
4311 *MARK = &PL_sv_undef;
4319 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4320 register AV *ary = (AV*)*++MARK;
4321 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4324 *MARK-- = SvTIED_obj((SV*)ary, mg);
4328 call_method("PUSH",G_SCALAR|G_DISCARD);
4332 PUSHi( AvFILL(ary) + 1 );
4335 for (++MARK; MARK <= SP; MARK++) {
4336 SV * const sv = NEWSV(51, 0);
4338 sv_setsv(sv, *MARK);
4339 av_store(ary, AvFILLp(ary)+1, sv);
4342 PUSHi( AvFILLp(ary) + 1 );
4350 AV * const av = (AV*)POPs;
4351 SV * const sv = av_pop(av);
4353 (void)sv_2mortal(sv);
4361 AV * const av = (AV*)POPs;
4362 SV * const sv = av_shift(av);
4367 (void)sv_2mortal(sv);
4374 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4375 register AV *ary = (AV*)*++MARK;
4376 const MAGIC * const mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied);
4379 *MARK-- = SvTIED_obj((SV*)ary, mg);
4383 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4389 av_unshift(ary, SP - MARK);
4391 SV * const sv = newSVsv(*++MARK);
4392 (void)av_store(ary, i++, sv);
4396 PUSHi( AvFILL(ary) + 1 );
4403 SV ** const oldsp = SP;
4405 if (GIMME == G_ARRAY) {
4408 register SV * const tmp = *MARK;
4412 /* safe as long as stack cannot get extended in the above */
4417 register char *down;
4423 SvUTF8_off(TARG); /* decontaminate */
4425 do_join(TARG, &PL_sv_no, MARK, SP);
4427 sv_setsv(TARG, (SP > MARK)
4429 : (padoff_du = find_rundefsvoffset(),
4430 (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
4431 ? DEFSV : PAD_SVl(padoff_du)));
4432 up = SvPV_force(TARG, len);
4434 if (DO_UTF8(TARG)) { /* first reverse each character */
4435 U8* s = (U8*)SvPVX(TARG);
4436 const U8* send = (U8*)(s + len);
4438 if (UTF8_IS_INVARIANT(*s)) {
4443 if (!utf8_to_uvchr(s, 0))
4447 down = (char*)(s - 1);
4448 /* reverse this character */
4452 *down-- = (char)tmp;
4458 down = SvPVX(TARG) + len - 1;
4462 *down-- = (char)tmp;
4464 (void)SvPOK_only_UTF8(TARG);
4476 register IV limit = POPi; /* note, negative is forever */
4477 SV * const sv = POPs;
4479 register const char *s = SvPV_const(sv, len);
4480 const bool do_utf8 = DO_UTF8(sv);
4481 const char *strend = s + len;
4483 register REGEXP *rx;
4485 register const char *m;
4487 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (strend - s);
4488 I32 maxiters = slen + 10;
4490 const I32 origlimit = limit;
4493 const I32 gimme = GIMME_V;
4494 const I32 oldsave = PL_savestack_ix;
4495 I32 make_mortal = 1;
4497 MAGIC *mg = (MAGIC *) NULL;
4500 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
4505 DIE(aTHX_ "panic: pp_split");
4508 TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
4509 (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
4511 RX_MATCH_UTF8_set(rx, do_utf8);
4513 if (pm->op_pmreplroot) {
4515 ary = GvAVn((GV*)PAD_SVl(INT2PTR(PADOFFSET, pm->op_pmreplroot)));
4517 ary = GvAVn((GV*)pm->op_pmreplroot);
4520 else if (gimme != G_ARRAY)
4521 ary = GvAVn(PL_defgv);
4524 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
4530 if ((mg = SvTIED_mg((SV*)ary, PERL_MAGIC_tied))) {
4532 XPUSHs(SvTIED_obj((SV*)ary, mg));
4539 for (i = AvFILLp(ary); i >= 0; i--)
4540 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
4542 /* temporarily switch stacks */
4543 SAVESWITCHSTACK(PL_curstack, ary);
4547 base = SP - PL_stack_base;
4549 if (pm->op_pmflags & PMf_SKIPWHITE) {
4550 if (pm->op_pmflags & PMf_LOCALE) {
4551 while (isSPACE_LC(*s))
4559 if (pm->op_pmflags & PMf_MULTILINE) {
4564 limit = maxiters + 2;
4565 if (pm->op_pmflags & PMf_WHITE) {
4568 while (m < strend &&
4569 !((pm->op_pmflags & PMf_LOCALE)
4570 ? isSPACE_LC(*m) : isSPACE(*m)))
4575 dstr = newSVpvn(s, m-s);
4579 (void)SvUTF8_on(dstr);
4583 while (s < strend &&
4584 ((pm->op_pmflags & PMf_LOCALE)
4585 ? isSPACE_LC(*s) : isSPACE(*s)))
4589 else if (rx->precomp[0] == '^' && rx->precomp[1] == '\0') {
4591 for (m = s; m < strend && *m != '\n'; m++)
4596 dstr = newSVpvn(s, m-s);
4600 (void)SvUTF8_on(dstr);
4605 else if (do_utf8 == ((rx->reganch & ROPT_UTF8) != 0) &&
4606 (rx->reganch & RE_USE_INTUIT) && !rx->nparens
4607 && (rx->reganch & ROPT_CHECK_ALL)
4608 && !(rx->reganch & ROPT_ANCH)) {
4609 const int tail = (rx->reganch & RE_INTUIT_TAIL);
4610 SV * const csv = CALLREG_INTUIT_STRING(aTHX_ rx);
4613 if (len == 1 && !(rx->reganch & ROPT_UTF8) && !tail) {
4614 const char c = *SvPV_nolen_const(csv);
4616 for (m = s; m < strend && *m != c; m++)
4620 dstr = newSVpvn(s, m-s);
4624 (void)SvUTF8_on(dstr);
4626 /* The rx->minlen is in characters but we want to step
4627 * s ahead by bytes. */
4629 s = (char*)utf8_hop((U8*)m, len);
4631 s = m + len; /* Fake \n at the end */
4635 while (s < strend && --limit &&
4636 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
4637 csv, multiline ? FBMrf_MULTILINE : 0)) )
4639 dstr = newSVpvn(s, m-s);
4643 (void)SvUTF8_on(dstr);
4645 /* The rx->minlen is in characters but we want to step
4646 * s ahead by bytes. */
4648 s = (char*)utf8_hop((U8*)m, len);
4650 s = m + len; /* Fake \n at the end */
4655 maxiters += slen * rx->nparens;
4656 while (s < strend && --limit)
4660 rex_return = CALLREGEXEC(aTHX_ rx, (char*)s, (char*)strend, (char*)orig, 1 ,
4663 if (rex_return == 0)
4665 TAINT_IF(RX_MATCH_TAINTED(rx));
4666 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
4671 strend = s + (strend - m);
4673 m = rx->startp[0] + orig;
4674 dstr = newSVpvn(s, m-s);
4678 (void)SvUTF8_on(dstr);
4682 for (i = 1; i <= (I32)rx->nparens; i++) {
4683 s = rx->startp[i] + orig;
4684 m = rx->endp[i] + orig;
4686 /* japhy (07/27/01) -- the (m && s) test doesn't catch
4687 parens that didn't match -- they should be set to
4688 undef, not the empty string */
4689 if (m >= orig && s >= orig) {
4690 dstr = newSVpvn(s, m-s);
4693 dstr = &PL_sv_undef; /* undef, not "" */
4697 (void)SvUTF8_on(dstr);
4701 s = rx->endp[0] + orig;
4705 iters = (SP - PL_stack_base) - base;
4706 if (iters > maxiters)
4707 DIE(aTHX_ "Split loop");
4709 /* keep field after final delim? */
4710 if (s < strend || (iters && origlimit)) {
4711 const STRLEN l = strend - s;
4712 dstr = newSVpvn(s, l);
4716 (void)SvUTF8_on(dstr);
4720 else if (!origlimit) {
4721 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
4722 if (TOPs && !make_mortal)
4725 *SP-- = &PL_sv_undef;
4730 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
4734 if (SvSMAGICAL(ary)) {
4739 if (gimme == G_ARRAY) {
4741 Copy(AvARRAY(ary), SP + 1, iters, SV*);
4749 call_method("PUSH",G_SCALAR|G_DISCARD);
4752 if (gimme == G_ARRAY) {
4754 /* EXTEND should not be needed - we just popped them */
4756 for (i=0; i < iters; i++) {
4757 SV **svp = av_fetch(ary, i, FALSE);
4758 PUSHs((svp) ? *svp : &PL_sv_undef);
4765 if (gimme == G_ARRAY)
4780 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
4781 || SvTYPE(retsv) == SVt_PVCV) {
4782 retsv = refto(retsv);
4790 * c-indentation-style: bsd
4792 * indent-tabs-mode: t
4795 * ex: set ts=8 sts=4 sw=4 noet: