3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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
13 * to discover, and no knowing what you'll find round a corner.
14 * And Elves, sir!' --Samwise Gamgee
16 * [p.225 of _The Lord of the Rings_, II/i: "Many Meetings"]
19 /* This file contains general pp ("push/pop") functions that execute the
20 * opcodes that make up a perl program. A typical pp function expects to
21 * find its arguments on the stack, and usually pushes its results onto
22 * the stack, hence the 'pp' terminology. Each OP structure contains
23 * a pointer to the relevant pp_foo() function.
33 /* XXX I can't imagine anyone who doesn't have this actually _needs_
34 it, since pid_t is an integral type.
37 #ifdef NEED_GETPID_PROTO
38 extern Pid_t getpid (void);
42 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
43 * This switches them over to IEEE.
45 #if defined(LIBM_LIB_VERSION)
46 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
49 /* variations on pp_null */
55 if (GIMME_V == G_SCALAR)
66 assert(SvTYPE(TARG) == SVt_PVAV);
67 if (PL_op->op_private & OPpLVAL_INTRO)
68 if (!(PL_op->op_private & OPpPAD_STATE))
69 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
71 if (PL_op->op_flags & OPf_REF) {
75 if (GIMME == G_SCALAR)
76 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
81 if (gimme == G_ARRAY) {
82 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
84 if (SvMAGICAL(TARG)) {
86 for (i=0; i < (U32)maxarg; i++) {
87 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
88 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
92 Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
96 else if (gimme == G_SCALAR) {
97 SV* const sv = sv_newmortal();
98 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
110 assert(SvTYPE(TARG) == SVt_PVHV);
112 if (PL_op->op_private & OPpLVAL_INTRO)
113 if (!(PL_op->op_private & OPpPAD_STATE))
114 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
115 if (PL_op->op_flags & OPf_REF)
118 if (GIMME == G_SCALAR)
119 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
123 if (gimme == G_ARRAY) {
126 else if (gimme == G_SCALAR) {
127 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
135 static const char S_no_symref_sv[] =
136 "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
142 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
145 sv = amagic_deref_call(sv, to_gv_amg);
149 if (SvTYPE(sv) == SVt_PVIO) {
150 GV * const gv = MUTABLE_GV(sv_newmortal());
151 gv_init(gv, 0, "", 0, 0);
152 GvIOp(gv) = MUTABLE_IO(sv);
153 SvREFCNT_inc_void_NN(sv);
156 else if (!isGV_with_GP(sv))
157 DIE(aTHX_ "Not a GLOB reference");
160 if (!isGV_with_GP(sv)) {
161 if (!SvOK(sv) && sv != &PL_sv_undef) {
162 /* If this is a 'my' scalar and flag is set then vivify
166 Perl_croak_no_modify(aTHX);
167 if (PL_op->op_private & OPpDEREF) {
169 if (cUNOP->op_targ) {
171 SV * const namesv = PAD_SV(cUNOP->op_targ);
172 const char * const name = SvPV(namesv, len);
173 gv = MUTABLE_GV(newSV(0));
174 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
177 const char * const name = CopSTASHPV(PL_curcop);
180 prepare_SV_for_RV(sv);
181 SvRV_set(sv, MUTABLE_SV(gv));
186 if (PL_op->op_flags & OPf_REF ||
187 PL_op->op_private & HINT_STRICT_REFS)
188 DIE(aTHX_ PL_no_usym, "a symbol");
189 if (ckWARN(WARN_UNINITIALIZED))
193 if ((PL_op->op_flags & OPf_SPECIAL) &&
194 !(PL_op->op_flags & OPf_MOD))
196 SV * const temp = MUTABLE_SV(gv_fetchsv(sv, 0, SVt_PVGV));
198 && (!is_gv_magical_sv(sv,0)
199 || !(sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD,
206 if (PL_op->op_private & HINT_STRICT_REFS)
207 DIE(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), "a symbol");
208 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
209 == OPpDONT_INIT_GV) {
210 /* We are the target of a coderef assignment. Return
211 the scalar unchanged, and let pp_sasssign deal with
215 sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD, SVt_PVGV));
217 /* FAKE globs in the symbol table cause weird bugs (#77810) */
218 if (sv) SvFAKE_off(sv);
221 if (PL_op->op_private & OPpLVAL_INTRO)
222 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
223 if (sv && SvFAKE(sv)) {
224 SV *newsv = sv_newmortal();
225 sv_setsv_flags(newsv, sv, 0);
233 /* Helper function for pp_rv2sv and pp_rv2av */
235 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
236 const svtype type, SV ***spp)
241 PERL_ARGS_ASSERT_SOFTREF2XV;
243 if (PL_op->op_private & HINT_STRICT_REFS) {
245 Perl_die(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), what);
247 Perl_die(aTHX_ PL_no_usym, what);
250 if (PL_op->op_flags & OPf_REF)
251 Perl_die(aTHX_ PL_no_usym, what);
252 if (ckWARN(WARN_UNINITIALIZED))
254 if (type != SVt_PV && GIMME_V == G_ARRAY) {
258 **spp = &PL_sv_undef;
261 if ((PL_op->op_flags & OPf_SPECIAL) &&
262 !(PL_op->op_flags & OPf_MOD))
264 gv = gv_fetchsv(sv, 0, type);
266 && (!is_gv_magical_sv(sv,0)
267 || !(gv = gv_fetchsv(sv, GV_ADD, type))))
269 **spp = &PL_sv_undef;
274 gv = gv_fetchsv(sv, GV_ADD, type);
284 if (!(PL_op->op_private & OPpDEREFed))
287 sv = amagic_deref_call(sv, to_sv_amg);
291 switch (SvTYPE(sv)) {
297 DIE(aTHX_ "Not a SCALAR reference");
304 if (!isGV_with_GP(gv)) {
305 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
311 if (PL_op->op_flags & OPf_MOD) {
312 if (PL_op->op_private & OPpLVAL_INTRO) {
313 if (cUNOP->op_first->op_type == OP_NULL)
314 sv = save_scalar(MUTABLE_GV(TOPs));
316 sv = save_scalar(gv);
318 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
320 else if (PL_op->op_private & OPpDEREF)
321 vivify_ref(sv, PL_op->op_private & OPpDEREF);
330 AV * const av = MUTABLE_AV(TOPs);
331 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
333 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
335 *sv = newSV_type(SVt_PVMG);
336 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
340 SETs(sv_2mortal(newSViv(
341 AvFILL(MUTABLE_AV(av)) + CopARYBASE_get(PL_curcop)
351 if (PL_op->op_flags & OPf_MOD || LVRET) {
352 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
353 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
355 LvTARG(ret) = SvREFCNT_inc_simple(sv);
356 PUSHs(ret); /* no SvSETMAGIC */
360 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
361 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
362 if (mg && mg->mg_len >= 0) {
367 PUSHi(i + CopARYBASE_get(PL_curcop));
380 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
382 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
385 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
386 /* (But not in defined().) */
388 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
391 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
392 if ((PL_op->op_private & OPpLVAL_INTRO)) {
393 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
396 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
399 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
403 cv = MUTABLE_CV(&PL_sv_undef);
404 SETs(MUTABLE_SV(cv));
414 SV *ret = &PL_sv_undef;
416 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
417 const char * s = SvPVX_const(TOPs);
418 if (strnEQ(s, "CORE::", 6)) {
419 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
420 if (code < 0) { /* Overridable. */
421 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
422 int i = 0, n = 0, seen_question = 0, defgv = 0;
424 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
426 if (code == -KEY_chop || code == -KEY_chomp
427 || code == -KEY_exec || code == -KEY_system)
429 if (code == -KEY_mkdir) {
430 ret = newSVpvs_flags("_;$", SVs_TEMP);
433 if (code == -KEY_keys || code == -KEY_values || code == -KEY_each) {
434 ret = newSVpvs_flags("+", SVs_TEMP);
437 if (code == -KEY_push || code == -KEY_unshift) {
438 ret = newSVpvs_flags("+@", SVs_TEMP);
441 if (code == -KEY_pop || code == -KEY_shift) {
442 ret = newSVpvs_flags(";+", SVs_TEMP);
445 if (code == -KEY_splice) {
446 ret = newSVpvs_flags("+;$$@", SVs_TEMP);
449 if (code == -KEY_tied || code == -KEY_untie) {
450 ret = newSVpvs_flags("\\[$@%*]", SVs_TEMP);
453 if (code == -KEY_tie) {
454 ret = newSVpvs_flags("\\[$@%*]$@", SVs_TEMP);
457 if (code == -KEY_readpipe) {
458 s = "CORE::backtick";
460 while (i < MAXO) { /* The slow way. */
461 if (strEQ(s + 6, PL_op_name[i])
462 || strEQ(s + 6, PL_op_desc[i]))
468 goto nonesuch; /* Should not happen... */
470 defgv = PL_opargs[i] & OA_DEFGV;
471 oa = PL_opargs[i] >> OASHIFT;
473 if (oa & OA_OPTIONAL && !seen_question && !defgv) {
477 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
478 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
479 /* But globs are already references (kinda) */
480 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
484 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
487 if (defgv && str[n - 1] == '$')
490 ret = newSVpvn_flags(str, n - 1, SVs_TEMP);
492 else if (code) /* Non-Overridable */
494 else { /* None such */
496 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
500 cv = sv_2cv(TOPs, &stash, &gv, 0);
502 ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
511 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
513 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
515 PUSHs(MUTABLE_SV(cv));
529 if (GIMME != G_ARRAY) {
533 *MARK = &PL_sv_undef;
534 *MARK = refto(*MARK);
538 EXTEND_MORTAL(SP - MARK);
540 *MARK = refto(*MARK);
545 S_refto(pTHX_ SV *sv)
550 PERL_ARGS_ASSERT_REFTO;
552 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
555 if (!(sv = LvTARG(sv)))
558 SvREFCNT_inc_void_NN(sv);
560 else if (SvTYPE(sv) == SVt_PVAV) {
561 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
562 av_reify(MUTABLE_AV(sv));
564 SvREFCNT_inc_void_NN(sv);
566 else if (SvPADTMP(sv) && !IS_PADGV(sv))
570 SvREFCNT_inc_void_NN(sv);
573 sv_upgrade(rv, SVt_IV);
583 SV * const sv = POPs;
588 if (!sv || !SvROK(sv))
591 pv = sv_reftype(SvRV(sv),TRUE);
592 PUSHp(pv, strlen(pv));
602 stash = CopSTASH(PL_curcop);
604 SV * const ssv = POPs;
608 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
609 Perl_croak(aTHX_ "Attempt to bless into a reference");
610 ptr = SvPV_const(ssv,len);
612 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
613 "Explicit blessing to '' (assuming package main)");
614 stash = gv_stashpvn(ptr, len, GV_ADD);
617 (void)sv_bless(TOPs, stash);
626 const char * const elem = SvPV_nolen_const(sv);
627 GV * const gv = MUTABLE_GV(POPs);
632 /* elem will always be NUL terminated. */
633 const char * const second_letter = elem + 1;
636 if (strEQ(second_letter, "RRAY"))
637 tmpRef = MUTABLE_SV(GvAV(gv));
640 if (strEQ(second_letter, "ODE"))
641 tmpRef = MUTABLE_SV(GvCVu(gv));
644 if (strEQ(second_letter, "ILEHANDLE")) {
645 /* finally deprecated in 5.8.0 */
646 deprecate("*glob{FILEHANDLE}");
647 tmpRef = MUTABLE_SV(GvIOp(gv));
650 if (strEQ(second_letter, "ORMAT"))
651 tmpRef = MUTABLE_SV(GvFORM(gv));
654 if (strEQ(second_letter, "LOB"))
655 tmpRef = MUTABLE_SV(gv);
658 if (strEQ(second_letter, "ASH"))
659 tmpRef = MUTABLE_SV(GvHV(gv));
662 if (*second_letter == 'O' && !elem[2])
663 tmpRef = MUTABLE_SV(GvIOp(gv));
666 if (strEQ(second_letter, "AME"))
667 sv = newSVhek(GvNAME_HEK(gv));
670 if (strEQ(second_letter, "ACKAGE")) {
671 const HV * const stash = GvSTASH(gv);
672 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
673 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
677 if (strEQ(second_letter, "CALAR"))
692 /* Pattern matching */
697 register unsigned char *s;
700 register I32 *sfirst;
704 if (sv == PL_lastscream) {
708 s = (unsigned char*)(SvPV(sv, len));
710 if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
711 /* No point in studying a zero length string, and not safe to study
712 anything that doesn't appear to be a simple scalar (and hence might
713 change between now and when the regexp engine runs without our set
714 magic ever running) such as a reference to an object with overloaded
720 SvSCREAM_off(PL_lastscream);
721 SvREFCNT_dec(PL_lastscream);
723 PL_lastscream = SvREFCNT_inc_simple(sv);
725 s = (unsigned char*)(SvPV(sv, len));
729 if (pos > PL_maxscream) {
730 if (PL_maxscream < 0) {
731 PL_maxscream = pos + 80;
732 Newx(PL_screamfirst, 256, I32);
733 Newx(PL_screamnext, PL_maxscream, I32);
736 PL_maxscream = pos + pos / 4;
737 Renew(PL_screamnext, PL_maxscream, I32);
741 sfirst = PL_screamfirst;
742 snext = PL_screamnext;
744 if (!sfirst || !snext)
745 DIE(aTHX_ "do_study: out of memory");
747 for (ch = 256; ch; --ch)
752 register const I32 ch = s[pos];
754 snext[pos] = sfirst[ch] - pos;
761 /* piggyback on m//g magic */
762 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
771 if (PL_op->op_flags & OPf_STACKED)
773 else if (PL_op->op_private & OPpTARGET_MY)
779 TARG = sv_newmortal();
780 if(PL_op->op_type == OP_TRANSR) {
781 SV * const newsv = newSVsv(sv);
785 else PUSHi(do_trans(sv));
789 /* Lvalue operators. */
801 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
803 do_chop(TARG, *++MARK);
812 SETi(do_chomp(TOPs));
818 dVAR; dSP; dMARK; dTARGET;
819 register I32 count = 0;
822 count += do_chomp(POPs);
832 if (!PL_op->op_private) {
841 SV_CHECK_THINKFIRST_COW_DROP(sv);
843 switch (SvTYPE(sv)) {
847 av_undef(MUTABLE_AV(sv));
850 hv_undef(MUTABLE_HV(sv));
853 if (cv_const_sv((const CV *)sv))
854 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
855 CvANON((const CV *)sv) ? "(anonymous)"
856 : GvENAME(CvGV((const CV *)sv)));
860 /* let user-undef'd sub keep its identity */
861 GV* const gv = CvGV((const CV *)sv);
862 cv_undef(MUTABLE_CV(sv));
863 CvGV_set(MUTABLE_CV(sv), gv);
868 SvSetMagicSV(sv, &PL_sv_undef);
871 else if (isGV_with_GP(sv)) {
875 /* undef *Pkg::meth_name ... */
877 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
878 && HvENAME_get(stash);
880 if((stash = GvHV((const GV *)sv))) {
881 if(HvENAME_get(stash))
882 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
886 gp_free(MUTABLE_GV(sv));
888 GvGP(sv) = gp_ref(gp);
890 GvLINE(sv) = CopLINE(PL_curcop);
891 GvEGV(sv) = MUTABLE_GV(sv);
895 mro_package_moved(NULL, stash, (const GV *)sv, NULL, 0);
897 /* undef *Foo::ISA */
898 if( strEQ(GvNAME((const GV *)sv), "ISA")
899 && (stash = GvSTASH((const GV *)sv))
900 && (method_changed || HvENAME(stash)) )
901 mro_isa_changed_in(stash);
902 else if(method_changed)
903 mro_method_changed_in(
904 GvSTASH((const GV *)sv)
911 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
926 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
927 Perl_croak_no_modify(aTHX);
928 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
929 && SvIVX(TOPs) != IV_MIN)
931 SvIV_set(TOPs, SvIVX(TOPs) - 1);
932 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
943 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
944 Perl_croak_no_modify(aTHX);
946 TARG = sv_newmortal();
947 sv_setsv(TARG, TOPs);
948 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
949 && SvIVX(TOPs) != IV_MAX)
951 SvIV_set(TOPs, SvIVX(TOPs) + 1);
952 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
957 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
967 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
968 Perl_croak_no_modify(aTHX);
970 TARG = sv_newmortal();
971 sv_setsv(TARG, TOPs);
972 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
973 && SvIVX(TOPs) != IV_MIN)
975 SvIV_set(TOPs, SvIVX(TOPs) - 1);
976 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
985 /* Ordinary operators. */
989 dVAR; dSP; dATARGET; SV *svl, *svr;
990 #ifdef PERL_PRESERVE_IVUV
993 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
996 #ifdef PERL_PRESERVE_IVUV
997 /* For integer to integer power, we do the calculation by hand wherever
998 we're sure it is safe; otherwise we call pow() and try to convert to
999 integer afterwards. */
1001 SvIV_please_nomg(svr);
1003 SvIV_please_nomg(svl);
1012 const IV iv = SvIVX(svr);
1016 goto float_it; /* Can't do negative powers this way. */
1020 baseuok = SvUOK(svl);
1022 baseuv = SvUVX(svl);
1024 const IV iv = SvIVX(svl);
1027 baseuok = TRUE; /* effectively it's a UV now */
1029 baseuv = -iv; /* abs, baseuok == false records sign */
1032 /* now we have integer ** positive integer. */
1035 /* foo & (foo - 1) is zero only for a power of 2. */
1036 if (!(baseuv & (baseuv - 1))) {
1037 /* We are raising power-of-2 to a positive integer.
1038 The logic here will work for any base (even non-integer
1039 bases) but it can be less accurate than
1040 pow (base,power) or exp (power * log (base)) when the
1041 intermediate values start to spill out of the mantissa.
1042 With powers of 2 we know this can't happen.
1043 And powers of 2 are the favourite thing for perl
1044 programmers to notice ** not doing what they mean. */
1046 NV base = baseuok ? baseuv : -(NV)baseuv;
1051 while (power >>= 1) {
1059 SvIV_please_nomg(svr);
1062 register unsigned int highbit = 8 * sizeof(UV);
1063 register unsigned int diff = 8 * sizeof(UV);
1064 while (diff >>= 1) {
1066 if (baseuv >> highbit) {
1070 /* we now have baseuv < 2 ** highbit */
1071 if (power * highbit <= 8 * sizeof(UV)) {
1072 /* result will definitely fit in UV, so use UV math
1073 on same algorithm as above */
1074 register UV result = 1;
1075 register UV base = baseuv;
1076 const bool odd_power = cBOOL(power & 1);
1080 while (power >>= 1) {
1087 if (baseuok || !odd_power)
1088 /* answer is positive */
1090 else if (result <= (UV)IV_MAX)
1091 /* answer negative, fits in IV */
1092 SETi( -(IV)result );
1093 else if (result == (UV)IV_MIN)
1094 /* 2's complement assumption: special case IV_MIN */
1097 /* answer negative, doesn't fit */
1098 SETn( -(NV)result );
1108 NV right = SvNV_nomg(svr);
1109 NV left = SvNV_nomg(svl);
1112 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1114 We are building perl with long double support and are on an AIX OS
1115 afflicted with a powl() function that wrongly returns NaNQ for any
1116 negative base. This was reported to IBM as PMR #23047-379 on
1117 03/06/2006. The problem exists in at least the following versions
1118 of AIX and the libm fileset, and no doubt others as well:
1120 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1121 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1122 AIX 5.2.0 bos.adt.libm 5.2.0.85
1124 So, until IBM fixes powl(), we provide the following workaround to
1125 handle the problem ourselves. Our logic is as follows: for
1126 negative bases (left), we use fmod(right, 2) to check if the
1127 exponent is an odd or even integer:
1129 - if odd, powl(left, right) == -powl(-left, right)
1130 - if even, powl(left, right) == powl(-left, right)
1132 If the exponent is not an integer, the result is rightly NaNQ, so
1133 we just return that (as NV_NAN).
1137 NV mod2 = Perl_fmod( right, 2.0 );
1138 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1139 SETn( -Perl_pow( -left, right) );
1140 } else if (mod2 == 0.0) { /* even integer */
1141 SETn( Perl_pow( -left, right) );
1142 } else { /* fractional power */
1146 SETn( Perl_pow( left, right) );
1149 SETn( Perl_pow( left, right) );
1150 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1152 #ifdef PERL_PRESERVE_IVUV
1154 SvIV_please_nomg(svr);
1162 dVAR; dSP; dATARGET; SV *svl, *svr;
1163 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1166 #ifdef PERL_PRESERVE_IVUV
1167 SvIV_please_nomg(svr);
1169 /* Unless the left argument is integer in range we are going to have to
1170 use NV maths. Hence only attempt to coerce the right argument if
1171 we know the left is integer. */
1172 /* Left operand is defined, so is it IV? */
1173 SvIV_please_nomg(svl);
1175 bool auvok = SvUOK(svl);
1176 bool buvok = SvUOK(svr);
1177 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1178 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1187 const IV aiv = SvIVX(svl);
1190 auvok = TRUE; /* effectively it's a UV now */
1192 alow = -aiv; /* abs, auvok == false records sign */
1198 const IV biv = SvIVX(svr);
1201 buvok = TRUE; /* effectively it's a UV now */
1203 blow = -biv; /* abs, buvok == false records sign */
1207 /* If this does sign extension on unsigned it's time for plan B */
1208 ahigh = alow >> (4 * sizeof (UV));
1210 bhigh = blow >> (4 * sizeof (UV));
1212 if (ahigh && bhigh) {
1214 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1215 which is overflow. Drop to NVs below. */
1216 } else if (!ahigh && !bhigh) {
1217 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1218 so the unsigned multiply cannot overflow. */
1219 const UV product = alow * blow;
1220 if (auvok == buvok) {
1221 /* -ve * -ve or +ve * +ve gives a +ve result. */
1225 } else if (product <= (UV)IV_MIN) {
1226 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1227 /* -ve result, which could overflow an IV */
1229 SETi( -(IV)product );
1231 } /* else drop to NVs below. */
1233 /* One operand is large, 1 small */
1236 /* swap the operands */
1238 bhigh = blow; /* bhigh now the temp var for the swap */
1242 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1243 multiplies can't overflow. shift can, add can, -ve can. */
1244 product_middle = ahigh * blow;
1245 if (!(product_middle & topmask)) {
1246 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1248 product_middle <<= (4 * sizeof (UV));
1249 product_low = alow * blow;
1251 /* as for pp_add, UV + something mustn't get smaller.
1252 IIRC ANSI mandates this wrapping *behaviour* for
1253 unsigned whatever the actual representation*/
1254 product_low += product_middle;
1255 if (product_low >= product_middle) {
1256 /* didn't overflow */
1257 if (auvok == buvok) {
1258 /* -ve * -ve or +ve * +ve gives a +ve result. */
1260 SETu( product_low );
1262 } else if (product_low <= (UV)IV_MIN) {
1263 /* 2s complement assumption again */
1264 /* -ve result, which could overflow an IV */
1266 SETi( -(IV)product_low );
1268 } /* else drop to NVs below. */
1270 } /* product_middle too large */
1271 } /* ahigh && bhigh */
1276 NV right = SvNV_nomg(svr);
1277 NV left = SvNV_nomg(svl);
1279 SETn( left * right );
1286 dVAR; dSP; dATARGET; SV *svl, *svr;
1287 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1290 /* Only try to do UV divide first
1291 if ((SLOPPYDIVIDE is true) or
1292 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1294 The assumption is that it is better to use floating point divide
1295 whenever possible, only doing integer divide first if we can't be sure.
1296 If NV_PRESERVES_UV is true then we know at compile time that no UV
1297 can be too large to preserve, so don't need to compile the code to
1298 test the size of UVs. */
1301 # define PERL_TRY_UV_DIVIDE
1302 /* ensure that 20./5. == 4. */
1304 # ifdef PERL_PRESERVE_IVUV
1305 # ifndef NV_PRESERVES_UV
1306 # define PERL_TRY_UV_DIVIDE
1311 #ifdef PERL_TRY_UV_DIVIDE
1312 SvIV_please_nomg(svr);
1314 SvIV_please_nomg(svl);
1316 bool left_non_neg = SvUOK(svl);
1317 bool right_non_neg = SvUOK(svr);
1321 if (right_non_neg) {
1325 const IV biv = SvIVX(svr);
1328 right_non_neg = TRUE; /* effectively it's a UV now */
1334 /* historically undef()/0 gives a "Use of uninitialized value"
1335 warning before dieing, hence this test goes here.
1336 If it were immediately before the second SvIV_please, then
1337 DIE() would be invoked before left was even inspected, so
1338 no inpsection would give no warning. */
1340 DIE(aTHX_ "Illegal division by zero");
1346 const IV aiv = SvIVX(svl);
1349 left_non_neg = TRUE; /* effectively it's a UV now */
1358 /* For sloppy divide we always attempt integer division. */
1360 /* Otherwise we only attempt it if either or both operands
1361 would not be preserved by an NV. If both fit in NVs
1362 we fall through to the NV divide code below. However,
1363 as left >= right to ensure integer result here, we know that
1364 we can skip the test on the right operand - right big
1365 enough not to be preserved can't get here unless left is
1368 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1371 /* Integer division can't overflow, but it can be imprecise. */
1372 const UV result = left / right;
1373 if (result * right == left) {
1374 SP--; /* result is valid */
1375 if (left_non_neg == right_non_neg) {
1376 /* signs identical, result is positive. */
1380 /* 2s complement assumption */
1381 if (result <= (UV)IV_MIN)
1382 SETi( -(IV)result );
1384 /* It's exact but too negative for IV. */
1385 SETn( -(NV)result );
1388 } /* tried integer divide but it was not an integer result */
1389 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1390 } /* left wasn't SvIOK */
1391 } /* right wasn't SvIOK */
1392 #endif /* PERL_TRY_UV_DIVIDE */
1394 NV right = SvNV_nomg(svr);
1395 NV left = SvNV_nomg(svl);
1396 (void)POPs;(void)POPs;
1397 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1398 if (! Perl_isnan(right) && right == 0.0)
1402 DIE(aTHX_ "Illegal division by zero");
1403 PUSHn( left / right );
1410 dVAR; dSP; dATARGET;
1411 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1415 bool left_neg = FALSE;
1416 bool right_neg = FALSE;
1417 bool use_double = FALSE;
1418 bool dright_valid = FALSE;
1421 SV * const svr = TOPs;
1422 SV * const svl = TOPm1s;
1423 SvIV_please_nomg(svr);
1425 right_neg = !SvUOK(svr);
1429 const IV biv = SvIVX(svr);
1432 right_neg = FALSE; /* effectively it's a UV now */
1439 dright = SvNV_nomg(svr);
1440 right_neg = dright < 0;
1443 if (dright < UV_MAX_P1) {
1444 right = U_V(dright);
1445 dright_valid = TRUE; /* In case we need to use double below. */
1451 /* At this point use_double is only true if right is out of range for
1452 a UV. In range NV has been rounded down to nearest UV and
1453 use_double false. */
1454 SvIV_please_nomg(svl);
1455 if (!use_double && SvIOK(svl)) {
1457 left_neg = !SvUOK(svl);
1461 const IV aiv = SvIVX(svl);
1464 left_neg = FALSE; /* effectively it's a UV now */
1472 dleft = SvNV_nomg(svl);
1473 left_neg = dleft < 0;
1477 /* This should be exactly the 5.6 behaviour - if left and right are
1478 both in range for UV then use U_V() rather than floor. */
1480 if (dleft < UV_MAX_P1) {
1481 /* right was in range, so is dleft, so use UVs not double.
1485 /* left is out of range for UV, right was in range, so promote
1486 right (back) to double. */
1488 /* The +0.5 is used in 5.6 even though it is not strictly
1489 consistent with the implicit +0 floor in the U_V()
1490 inside the #if 1. */
1491 dleft = Perl_floor(dleft + 0.5);
1494 dright = Perl_floor(dright + 0.5);
1505 DIE(aTHX_ "Illegal modulus zero");
1507 dans = Perl_fmod(dleft, dright);
1508 if ((left_neg != right_neg) && dans)
1509 dans = dright - dans;
1512 sv_setnv(TARG, dans);
1518 DIE(aTHX_ "Illegal modulus zero");
1521 if ((left_neg != right_neg) && ans)
1524 /* XXX may warn: unary minus operator applied to unsigned type */
1525 /* could change -foo to be (~foo)+1 instead */
1526 if (ans <= ~((UV)IV_MAX)+1)
1527 sv_setiv(TARG, ~ans+1);
1529 sv_setnv(TARG, -(NV)ans);
1532 sv_setuv(TARG, ans);
1541 dVAR; dSP; dATARGET;
1545 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1546 /* TODO: think of some way of doing list-repeat overloading ??? */
1551 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1557 const UV uv = SvUV_nomg(sv);
1559 count = IV_MAX; /* The best we can do? */
1563 const IV iv = SvIV_nomg(sv);
1570 else if (SvNOKp(sv)) {
1571 const NV nv = SvNV_nomg(sv);
1578 count = SvIV_nomg(sv);
1580 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1582 static const char oom_list_extend[] = "Out of memory during list extend";
1583 const I32 items = SP - MARK;
1584 const I32 max = items * count;
1586 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1587 /* Did the max computation overflow? */
1588 if (items > 0 && max > 0 && (max < items || max < count))
1589 Perl_croak(aTHX_ oom_list_extend);
1594 /* This code was intended to fix 20010809.028:
1597 for (($x =~ /./g) x 2) {
1598 print chop; # "abcdabcd" expected as output.
1601 * but that change (#11635) broke this code:
1603 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1605 * I can't think of a better fix that doesn't introduce
1606 * an efficiency hit by copying the SVs. The stack isn't
1607 * refcounted, and mortalisation obviously doesn't
1608 * Do The Right Thing when the stack has more than
1609 * one pointer to the same mortal value.
1613 *SP = sv_2mortal(newSVsv(*SP));
1623 repeatcpy((char*)(MARK + items), (char*)MARK,
1624 items * sizeof(const SV *), count - 1);
1627 else if (count <= 0)
1630 else { /* Note: mark already snarfed by pp_list */
1631 SV * const tmpstr = POPs;
1634 static const char oom_string_extend[] =
1635 "Out of memory during string extend";
1638 sv_setsv_nomg(TARG, tmpstr);
1639 SvPV_force_nomg(TARG, len);
1640 isutf = DO_UTF8(TARG);
1645 const STRLEN max = (UV)count * len;
1646 if (len > MEM_SIZE_MAX / count)
1647 Perl_croak(aTHX_ oom_string_extend);
1648 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1649 SvGROW(TARG, max + 1);
1650 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1651 SvCUR_set(TARG, SvCUR(TARG) * count);
1653 *SvEND(TARG) = '\0';
1656 (void)SvPOK_only_UTF8(TARG);
1658 (void)SvPOK_only(TARG);
1660 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1661 /* The parser saw this as a list repeat, and there
1662 are probably several items on the stack. But we're
1663 in scalar context, and there's no pp_list to save us
1664 now. So drop the rest of the items -- robin@kitsite.com
1676 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1677 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1680 useleft = USE_LEFT(svl);
1681 #ifdef PERL_PRESERVE_IVUV
1682 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1683 "bad things" happen if you rely on signed integers wrapping. */
1684 SvIV_please_nomg(svr);
1686 /* Unless the left argument is integer in range we are going to have to
1687 use NV maths. Hence only attempt to coerce the right argument if
1688 we know the left is integer. */
1689 register UV auv = 0;
1695 a_valid = auvok = 1;
1696 /* left operand is undef, treat as zero. */
1698 /* Left operand is defined, so is it IV? */
1699 SvIV_please_nomg(svl);
1701 if ((auvok = SvUOK(svl)))
1704 register const IV aiv = SvIVX(svl);
1707 auvok = 1; /* Now acting as a sign flag. */
1708 } else { /* 2s complement assumption for IV_MIN */
1716 bool result_good = 0;
1719 bool buvok = SvUOK(svr);
1724 register const IV biv = SvIVX(svr);
1731 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1732 else "IV" now, independent of how it came in.
1733 if a, b represents positive, A, B negative, a maps to -A etc
1738 all UV maths. negate result if A negative.
1739 subtract if signs same, add if signs differ. */
1741 if (auvok ^ buvok) {
1750 /* Must get smaller */
1755 if (result <= buv) {
1756 /* result really should be -(auv-buv). as its negation
1757 of true value, need to swap our result flag */
1769 if (result <= (UV)IV_MIN)
1770 SETi( -(IV)result );
1772 /* result valid, but out of range for IV. */
1773 SETn( -(NV)result );
1777 } /* Overflow, drop through to NVs. */
1782 NV value = SvNV_nomg(svr);
1786 /* left operand is undef, treat as zero - value */
1790 SETn( SvNV_nomg(svl) - value );
1797 dVAR; dSP; dATARGET; SV *svl, *svr;
1798 tryAMAGICbin_MG(lshift_amg, AMGf_assign);
1802 const IV shift = SvIV_nomg(svr);
1803 if (PL_op->op_private & HINT_INTEGER) {
1804 const IV i = SvIV_nomg(svl);
1808 const UV u = SvUV_nomg(svl);
1817 dVAR; dSP; dATARGET; SV *svl, *svr;
1818 tryAMAGICbin_MG(rshift_amg, AMGf_assign);
1822 const IV shift = SvIV_nomg(svr);
1823 if (PL_op->op_private & HINT_INTEGER) {
1824 const IV i = SvIV_nomg(svl);
1828 const UV u = SvUV_nomg(svl);
1838 tryAMAGICbin_MG(lt_amg, AMGf_set);
1839 #ifdef PERL_PRESERVE_IVUV
1840 SvIV_please_nomg(TOPs);
1842 SvIV_please_nomg(TOPm1s);
1843 if (SvIOK(TOPm1s)) {
1844 bool auvok = SvUOK(TOPm1s);
1845 bool buvok = SvUOK(TOPs);
1847 if (!auvok && !buvok) { /* ## IV < IV ## */
1848 const IV aiv = SvIVX(TOPm1s);
1849 const IV biv = SvIVX(TOPs);
1852 SETs(boolSV(aiv < biv));
1855 if (auvok && buvok) { /* ## UV < UV ## */
1856 const UV auv = SvUVX(TOPm1s);
1857 const UV buv = SvUVX(TOPs);
1860 SETs(boolSV(auv < buv));
1863 if (auvok) { /* ## UV < IV ## */
1865 const IV biv = SvIVX(TOPs);
1868 /* As (a) is a UV, it's >=0, so it cannot be < */
1873 SETs(boolSV(auv < (UV)biv));
1876 { /* ## IV < UV ## */
1877 const IV aiv = SvIVX(TOPm1s);
1881 /* As (b) is a UV, it's >=0, so it must be < */
1888 SETs(boolSV((UV)aiv < buv));
1894 #ifndef NV_PRESERVES_UV
1895 #ifdef PERL_PRESERVE_IVUV
1898 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1900 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1905 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1907 if (Perl_isnan(left) || Perl_isnan(right))
1909 SETs(boolSV(left < right));
1912 SETs(boolSV(SvNV_nomg(TOPs) < value));
1921 tryAMAGICbin_MG(gt_amg, AMGf_set);
1922 #ifdef PERL_PRESERVE_IVUV
1923 SvIV_please_nomg(TOPs);
1925 SvIV_please_nomg(TOPm1s);
1926 if (SvIOK(TOPm1s)) {
1927 bool auvok = SvUOK(TOPm1s);
1928 bool buvok = SvUOK(TOPs);
1930 if (!auvok && !buvok) { /* ## IV > IV ## */
1931 const IV aiv = SvIVX(TOPm1s);
1932 const IV biv = SvIVX(TOPs);
1935 SETs(boolSV(aiv > biv));
1938 if (auvok && buvok) { /* ## UV > UV ## */
1939 const UV auv = SvUVX(TOPm1s);
1940 const UV buv = SvUVX(TOPs);
1943 SETs(boolSV(auv > buv));
1946 if (auvok) { /* ## UV > IV ## */
1948 const IV biv = SvIVX(TOPs);
1952 /* As (a) is a UV, it's >=0, so it must be > */
1957 SETs(boolSV(auv > (UV)biv));
1960 { /* ## IV > UV ## */
1961 const IV aiv = SvIVX(TOPm1s);
1965 /* As (b) is a UV, it's >=0, so it cannot be > */
1972 SETs(boolSV((UV)aiv > buv));
1978 #ifndef NV_PRESERVES_UV
1979 #ifdef PERL_PRESERVE_IVUV
1982 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1984 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1989 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1991 if (Perl_isnan(left) || Perl_isnan(right))
1993 SETs(boolSV(left > right));
1996 SETs(boolSV(SvNV_nomg(TOPs) > value));
2005 tryAMAGICbin_MG(le_amg, AMGf_set);
2006 #ifdef PERL_PRESERVE_IVUV
2007 SvIV_please_nomg(TOPs);
2009 SvIV_please_nomg(TOPm1s);
2010 if (SvIOK(TOPm1s)) {
2011 bool auvok = SvUOK(TOPm1s);
2012 bool buvok = SvUOK(TOPs);
2014 if (!auvok && !buvok) { /* ## IV <= IV ## */
2015 const IV aiv = SvIVX(TOPm1s);
2016 const IV biv = SvIVX(TOPs);
2019 SETs(boolSV(aiv <= biv));
2022 if (auvok && buvok) { /* ## UV <= UV ## */
2023 UV auv = SvUVX(TOPm1s);
2024 UV buv = SvUVX(TOPs);
2027 SETs(boolSV(auv <= buv));
2030 if (auvok) { /* ## UV <= IV ## */
2032 const IV biv = SvIVX(TOPs);
2036 /* As (a) is a UV, it's >=0, so a cannot be <= */
2041 SETs(boolSV(auv <= (UV)biv));
2044 { /* ## IV <= UV ## */
2045 const IV aiv = SvIVX(TOPm1s);
2049 /* As (b) is a UV, it's >=0, so a must be <= */
2056 SETs(boolSV((UV)aiv <= buv));
2062 #ifndef NV_PRESERVES_UV
2063 #ifdef PERL_PRESERVE_IVUV
2066 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2068 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
2073 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2075 if (Perl_isnan(left) || Perl_isnan(right))
2077 SETs(boolSV(left <= right));
2080 SETs(boolSV(SvNV_nomg(TOPs) <= value));
2089 tryAMAGICbin_MG(ge_amg,AMGf_set);
2090 #ifdef PERL_PRESERVE_IVUV
2091 SvIV_please_nomg(TOPs);
2093 SvIV_please_nomg(TOPm1s);
2094 if (SvIOK(TOPm1s)) {
2095 bool auvok = SvUOK(TOPm1s);
2096 bool buvok = SvUOK(TOPs);
2098 if (!auvok && !buvok) { /* ## IV >= IV ## */
2099 const IV aiv = SvIVX(TOPm1s);
2100 const IV biv = SvIVX(TOPs);
2103 SETs(boolSV(aiv >= biv));
2106 if (auvok && buvok) { /* ## UV >= UV ## */
2107 const UV auv = SvUVX(TOPm1s);
2108 const UV buv = SvUVX(TOPs);
2111 SETs(boolSV(auv >= buv));
2114 if (auvok) { /* ## UV >= IV ## */
2116 const IV biv = SvIVX(TOPs);
2120 /* As (a) is a UV, it's >=0, so it must be >= */
2125 SETs(boolSV(auv >= (UV)biv));
2128 { /* ## IV >= UV ## */
2129 const IV aiv = SvIVX(TOPm1s);
2133 /* As (b) is a UV, it's >=0, so a cannot be >= */
2140 SETs(boolSV((UV)aiv >= buv));
2146 #ifndef NV_PRESERVES_UV
2147 #ifdef PERL_PRESERVE_IVUV
2150 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2152 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2157 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2159 if (Perl_isnan(left) || Perl_isnan(right))
2161 SETs(boolSV(left >= right));
2164 SETs(boolSV(SvNV_nomg(TOPs) >= value));
2173 tryAMAGICbin_MG(ne_amg,AMGf_set);
2174 #ifndef NV_PRESERVES_UV
2175 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2177 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2181 #ifdef PERL_PRESERVE_IVUV
2182 SvIV_please_nomg(TOPs);
2184 SvIV_please_nomg(TOPm1s);
2185 if (SvIOK(TOPm1s)) {
2186 const bool auvok = SvUOK(TOPm1s);
2187 const bool buvok = SvUOK(TOPs);
2189 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2190 /* Casting IV to UV before comparison isn't going to matter
2191 on 2s complement. On 1s complement or sign&magnitude
2192 (if we have any of them) it could make negative zero
2193 differ from normal zero. As I understand it. (Need to
2194 check - is negative zero implementation defined behaviour
2196 const UV buv = SvUVX(POPs);
2197 const UV auv = SvUVX(TOPs);
2199 SETs(boolSV(auv != buv));
2202 { /* ## Mixed IV,UV ## */
2206 /* != is commutative so swap if needed (save code) */
2208 /* swap. top of stack (b) is the iv */
2212 /* As (a) is a UV, it's >0, so it cannot be == */
2221 /* As (b) is a UV, it's >0, so it cannot be == */
2225 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2227 SETs(boolSV((UV)iv != uv));
2234 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2236 if (Perl_isnan(left) || Perl_isnan(right))
2238 SETs(boolSV(left != right));
2241 SETs(boolSV(SvNV_nomg(TOPs) != value));
2250 tryAMAGICbin_MG(ncmp_amg, 0);
2251 #ifndef NV_PRESERVES_UV
2252 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2253 const UV right = PTR2UV(SvRV(POPs));
2254 const UV left = PTR2UV(SvRV(TOPs));
2255 SETi((left > right) - (left < right));
2259 #ifdef PERL_PRESERVE_IVUV
2260 /* Fortunately it seems NaN isn't IOK */
2261 SvIV_please_nomg(TOPs);
2263 SvIV_please_nomg(TOPm1s);
2264 if (SvIOK(TOPm1s)) {
2265 const bool leftuvok = SvUOK(TOPm1s);
2266 const bool rightuvok = SvUOK(TOPs);
2268 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2269 const IV leftiv = SvIVX(TOPm1s);
2270 const IV rightiv = SvIVX(TOPs);
2272 if (leftiv > rightiv)
2274 else if (leftiv < rightiv)
2278 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2279 const UV leftuv = SvUVX(TOPm1s);
2280 const UV rightuv = SvUVX(TOPs);
2282 if (leftuv > rightuv)
2284 else if (leftuv < rightuv)
2288 } else if (leftuvok) { /* ## UV <=> IV ## */
2289 const IV rightiv = SvIVX(TOPs);
2291 /* As (a) is a UV, it's >=0, so it cannot be < */
2294 const UV leftuv = SvUVX(TOPm1s);
2295 if (leftuv > (UV)rightiv) {
2297 } else if (leftuv < (UV)rightiv) {
2303 } else { /* ## IV <=> UV ## */
2304 const IV leftiv = SvIVX(TOPm1s);
2306 /* As (b) is a UV, it's >=0, so it must be < */
2309 const UV rightuv = SvUVX(TOPs);
2310 if ((UV)leftiv > rightuv) {
2312 } else if ((UV)leftiv < rightuv) {
2330 if (Perl_isnan(left) || Perl_isnan(right)) {
2334 value = (left > right) - (left < right);
2338 else if (left < right)
2340 else if (left > right)
2356 int amg_type = sle_amg;
2360 switch (PL_op->op_type) {
2379 tryAMAGICbin_MG(amg_type, AMGf_set);
2382 const int cmp = (IN_LOCALE_RUNTIME
2383 ? sv_cmp_locale_flags(left, right, 0)
2384 : sv_cmp_flags(left, right, 0));
2385 SETs(boolSV(cmp * multiplier < rhs));
2393 tryAMAGICbin_MG(seq_amg, AMGf_set);
2396 SETs(boolSV(sv_eq_flags(left, right, 0)));
2404 tryAMAGICbin_MG(sne_amg, AMGf_set);
2407 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2415 tryAMAGICbin_MG(scmp_amg, 0);
2418 const int cmp = (IN_LOCALE_RUNTIME
2419 ? sv_cmp_locale_flags(left, right, 0)
2420 : sv_cmp_flags(left, right, 0));
2428 dVAR; dSP; dATARGET;
2429 tryAMAGICbin_MG(band_amg, AMGf_assign);
2432 if (SvNIOKp(left) || SvNIOKp(right)) {
2433 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2434 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2435 if (PL_op->op_private & HINT_INTEGER) {
2436 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2440 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2443 if (left_ro_nonnum) SvNIOK_off(left);
2444 if (right_ro_nonnum) SvNIOK_off(right);
2447 do_vop(PL_op->op_type, TARG, left, right);
2456 dVAR; dSP; dATARGET;
2457 const int op_type = PL_op->op_type;
2459 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2462 if (SvNIOKp(left) || SvNIOKp(right)) {
2463 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2464 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2465 if (PL_op->op_private & HINT_INTEGER) {
2466 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2467 const IV r = SvIV_nomg(right);
2468 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2472 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2473 const UV r = SvUV_nomg(right);
2474 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2477 if (left_ro_nonnum) SvNIOK_off(left);
2478 if (right_ro_nonnum) SvNIOK_off(right);
2481 do_vop(op_type, TARG, left, right);
2491 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2493 SV * const sv = TOPs;
2494 const int flags = SvFLAGS(sv);
2496 if( !SvNIOK( sv ) && looks_like_number( sv ) ){
2500 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2501 /* It's publicly an integer, or privately an integer-not-float */
2504 if (SvIVX(sv) == IV_MIN) {
2505 /* 2s complement assumption. */
2506 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2509 else if (SvUVX(sv) <= IV_MAX) {
2514 else if (SvIVX(sv) != IV_MIN) {
2518 #ifdef PERL_PRESERVE_IVUV
2526 SETn(-SvNV_nomg(sv));
2527 else if (SvPOKp(sv)) {
2529 const char * const s = SvPV_nomg_const(sv, len);
2530 if (isIDFIRST(*s)) {
2531 sv_setpvs(TARG, "-");
2534 else if (*s == '+' || *s == '-') {
2535 sv_setsv_nomg(TARG, sv);
2536 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2538 else if (DO_UTF8(sv)) {
2539 SvIV_please_nomg(sv);
2541 goto oops_its_an_int;
2543 sv_setnv(TARG, -SvNV_nomg(sv));
2545 sv_setpvs(TARG, "-");
2550 SvIV_please_nomg(sv);
2552 goto oops_its_an_int;
2553 sv_setnv(TARG, -SvNV_nomg(sv));
2558 SETn(-SvNV_nomg(sv));
2566 tryAMAGICun_MG(not_amg, AMGf_set);
2567 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2574 tryAMAGICun_MG(compl_amg, 0);
2578 if (PL_op->op_private & HINT_INTEGER) {
2579 const IV i = ~SvIV_nomg(sv);
2583 const UV u = ~SvUV_nomg(sv);
2592 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2593 sv_setsv_nomg(TARG, sv);
2594 tmps = (U8*)SvPV_force_nomg(TARG, len);
2597 /* Calculate exact length, let's not estimate. */
2602 U8 * const send = tmps + len;
2603 U8 * const origtmps = tmps;
2604 const UV utf8flags = UTF8_ALLOW_ANYUV;
2606 while (tmps < send) {
2607 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2609 targlen += UNISKIP(~c);
2615 /* Now rewind strings and write them. */
2622 Newx(result, targlen + 1, U8);
2624 while (tmps < send) {
2625 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2627 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2630 sv_usepvn_flags(TARG, (char*)result, targlen,
2631 SV_HAS_TRAILING_NUL);
2638 Newx(result, nchar + 1, U8);
2640 while (tmps < send) {
2641 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2646 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2654 register long *tmpl;
2655 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2658 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2663 for ( ; anum > 0; anum--, tmps++)
2671 /* integer versions of some of the above */
2675 dVAR; dSP; dATARGET;
2676 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2679 SETi( left * right );
2687 dVAR; dSP; dATARGET;
2688 tryAMAGICbin_MG(div_amg, AMGf_assign);
2691 IV value = SvIV_nomg(right);
2693 DIE(aTHX_ "Illegal division by zero");
2694 num = SvIV_nomg(left);
2696 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2700 value = num / value;
2706 #if defined(__GLIBC__) && IVSIZE == 8
2713 /* This is the vanilla old i_modulo. */
2714 dVAR; dSP; dATARGET;
2715 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2719 DIE(aTHX_ "Illegal modulus zero");
2720 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2724 SETi( left % right );
2729 #if defined(__GLIBC__) && IVSIZE == 8
2734 /* This is the i_modulo with the workaround for the _moddi3 bug
2735 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2736 * See below for pp_i_modulo. */
2737 dVAR; dSP; dATARGET;
2738 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2742 DIE(aTHX_ "Illegal modulus zero");
2743 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2747 SETi( left % PERL_ABS(right) );
2754 dVAR; dSP; dATARGET;
2755 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2759 DIE(aTHX_ "Illegal modulus zero");
2760 /* The assumption is to use hereafter the old vanilla version... */
2762 PL_ppaddr[OP_I_MODULO] =
2764 /* .. but if we have glibc, we might have a buggy _moddi3
2765 * (at least glicb 2.2.5 is known to have this bug), in other
2766 * words our integer modulus with negative quad as the second
2767 * argument might be broken. Test for this and re-patch the
2768 * opcode dispatch table if that is the case, remembering to
2769 * also apply the workaround so that this first round works
2770 * right, too. See [perl #9402] for more information. */
2774 /* Cannot do this check with inlined IV constants since
2775 * that seems to work correctly even with the buggy glibc. */
2777 /* Yikes, we have the bug.
2778 * Patch in the workaround version. */
2780 PL_ppaddr[OP_I_MODULO] =
2781 &Perl_pp_i_modulo_1;
2782 /* Make certain we work right this time, too. */
2783 right = PERL_ABS(right);
2786 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2790 SETi( left % right );
2798 dVAR; dSP; dATARGET;
2799 tryAMAGICbin_MG(add_amg, AMGf_assign);
2801 dPOPTOPiirl_ul_nomg;
2802 SETi( left + right );
2809 dVAR; dSP; dATARGET;
2810 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2812 dPOPTOPiirl_ul_nomg;
2813 SETi( left - right );
2821 tryAMAGICbin_MG(lt_amg, AMGf_set);
2824 SETs(boolSV(left < right));
2832 tryAMAGICbin_MG(gt_amg, AMGf_set);
2835 SETs(boolSV(left > right));
2843 tryAMAGICbin_MG(le_amg, AMGf_set);
2846 SETs(boolSV(left <= right));
2854 tryAMAGICbin_MG(ge_amg, AMGf_set);
2857 SETs(boolSV(left >= right));
2865 tryAMAGICbin_MG(eq_amg, AMGf_set);
2868 SETs(boolSV(left == right));
2876 tryAMAGICbin_MG(ne_amg, AMGf_set);
2879 SETs(boolSV(left != right));
2887 tryAMAGICbin_MG(ncmp_amg, 0);
2894 else if (left < right)
2906 tryAMAGICun_MG(neg_amg, 0);
2908 SV * const sv = TOPs;
2909 IV const i = SvIV_nomg(sv);
2915 /* High falutin' math. */
2920 tryAMAGICbin_MG(atan2_amg, 0);
2923 SETn(Perl_atan2(left, right));
2931 int amg_type = sin_amg;
2932 const char *neg_report = NULL;
2933 NV (*func)(NV) = Perl_sin;
2934 const int op_type = PL_op->op_type;
2951 amg_type = sqrt_amg;
2953 neg_report = "sqrt";
2958 tryAMAGICun_MG(amg_type, 0);
2960 SV * const arg = POPs;
2961 const NV value = SvNV_nomg(arg);
2963 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2964 SET_NUMERIC_STANDARD();
2965 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2968 XPUSHn(func(value));
2973 /* Support Configure command-line overrides for rand() functions.
2974 After 5.005, perhaps we should replace this by Configure support
2975 for drand48(), random(), or rand(). For 5.005, though, maintain
2976 compatibility by calling rand() but allow the user to override it.
2977 See INSTALL for details. --Andy Dougherty 15 July 1998
2979 /* Now it's after 5.005, and Configure supports drand48() and random(),
2980 in addition to rand(). So the overrides should not be needed any more.
2981 --Jarkko Hietaniemi 27 September 1998
2984 #ifndef HAS_DRAND48_PROTO
2985 extern double drand48 (void);
2998 if (!PL_srand_called) {
2999 (void)seedDrand01((Rand_seed_t)seed());
3000 PL_srand_called = TRUE;
3010 const UV anum = (MAXARG < 1) ? seed() : POPu;
3011 (void)seedDrand01((Rand_seed_t)anum);
3012 PL_srand_called = TRUE;
3016 /* Historically srand always returned true. We can avoid breaking
3018 sv_setpvs(TARG, "0 but true");
3027 tryAMAGICun_MG(int_amg, AMGf_numeric);
3029 SV * const sv = TOPs;
3030 const IV iv = SvIV_nomg(sv);
3031 /* XXX it's arguable that compiler casting to IV might be subtly
3032 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3033 else preferring IV has introduced a subtle behaviour change bug. OTOH
3034 relying on floating point to be accurate is a bug. */
3039 else if (SvIOK(sv)) {
3041 SETu(SvUV_nomg(sv));
3046 const NV value = SvNV_nomg(sv);
3048 if (value < (NV)UV_MAX + 0.5) {
3051 SETn(Perl_floor(value));
3055 if (value > (NV)IV_MIN - 0.5) {
3058 SETn(Perl_ceil(value));
3069 tryAMAGICun_MG(abs_amg, AMGf_numeric);
3071 SV * const sv = TOPs;
3072 /* This will cache the NV value if string isn't actually integer */
3073 const IV iv = SvIV_nomg(sv);
3078 else if (SvIOK(sv)) {
3079 /* IVX is precise */
3081 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
3089 /* 2s complement assumption. Also, not really needed as
3090 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3096 const NV value = SvNV_nomg(sv);
3110 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3114 SV* const sv = POPs;
3116 tmps = (SvPV_const(sv, len));
3118 /* If Unicode, try to downgrade
3119 * If not possible, croak. */
3120 SV* const tsv = sv_2mortal(newSVsv(sv));
3123 sv_utf8_downgrade(tsv, FALSE);
3124 tmps = SvPV_const(tsv, len);
3126 if (PL_op->op_type == OP_HEX)
3129 while (*tmps && len && isSPACE(*tmps))
3133 if (*tmps == 'x' || *tmps == 'X') {
3135 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3137 else if (*tmps == 'b' || *tmps == 'B')
3138 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3140 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3142 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3156 SV * const sv = TOPs;
3158 if (SvGAMAGIC(sv)) {
3159 /* For an overloaded or magic scalar, we can't know in advance if
3160 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3161 it likes to cache the length. Maybe that should be a documented
3166 = sv_2pv_flags(sv, &len,
3167 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3170 sv_setsv(TARG, &PL_sv_undef);
3173 else if (DO_UTF8(sv)) {
3174 SETi(utf8_length((U8*)p, (U8*)p + len));
3178 } else if (SvOK(sv)) {
3179 /* Neither magic nor overloaded. */
3181 SETi(sv_len_utf8(sv));
3185 sv_setsv_nomg(TARG, &PL_sv_undef);
3205 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3207 const IV arybase = CopARYBASE_get(PL_curcop);
3209 const char *repl = NULL;
3211 const int num_args = PL_op->op_private & 7;
3212 bool repl_need_utf8_upgrade = FALSE;
3213 bool repl_is_utf8 = FALSE;
3218 repl = SvPV_const(repl_sv, repl_len);
3219 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3222 len_iv = SvIV(len_sv);
3223 len_is_uv = SvIOK_UV(len_sv);
3226 pos1_iv = SvIV(pos_sv);
3227 pos1_is_uv = SvIOK_UV(pos_sv);
3233 sv_utf8_upgrade(sv);
3235 else if (DO_UTF8(sv))
3236 repl_need_utf8_upgrade = TRUE;
3238 tmps = SvPV_const(sv, curlen);
3240 utf8_curlen = sv_len_utf8(sv);
3241 if (utf8_curlen == curlen)
3244 curlen = utf8_curlen;
3249 if ( (pos1_is_uv && arybase < 0) || (pos1_iv >= arybase) ) { /* pos >= $[ */
3250 UV pos1_uv = pos1_iv-arybase;
3251 /* Overflow can occur when $[ < 0 */
3252 if (arybase < 0 && pos1_uv < (UV)pos1_iv)
3257 else if (pos1_is_uv ? (UV)pos1_iv > 0 : pos1_iv > 0) {
3258 goto bound_fail; /* $[=3; substr($_,2,...) */
3260 else { /* pos < $[ */
3261 if (pos1_iv == 0) { /* $[=1; substr($_,0,...) */
3266 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3271 if (pos1_is_uv || pos1_iv > 0) {
3272 if ((UV)pos1_iv > curlen)
3277 if (!len_is_uv && len_iv < 0) {
3278 pos2_iv = curlen + len_iv;
3280 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3283 } else { /* len_iv >= 0 */
3284 if (!pos1_is_uv && pos1_iv < 0) {
3285 pos2_iv = pos1_iv + len_iv;
3286 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3288 if ((UV)len_iv > curlen-(UV)pos1_iv)
3291 pos2_iv = pos1_iv+len_iv;
3301 if (!pos2_is_uv && pos2_iv < 0) {
3302 if (!pos1_is_uv && pos1_iv < 0)
3306 else if (!pos1_is_uv && pos1_iv < 0)
3309 if ((UV)pos2_iv < (UV)pos1_iv)
3311 if ((UV)pos2_iv > curlen)
3315 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3316 const STRLEN pos = (STRLEN)( (UV)pos1_iv );
3317 const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3318 STRLEN byte_len = len;
3319 STRLEN byte_pos = utf8_curlen
3320 ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3322 if (lvalue && !repl) {
3325 if (!SvGMAGICAL(sv)) {
3327 SvPV_force_nolen(sv);
3328 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3329 "Attempt to use reference as lvalue in substr");
3331 if (isGV_with_GP(sv))
3332 SvPV_force_nolen(sv);
3333 else if (SvOK(sv)) /* is it defined ? */
3334 (void)SvPOK_only_UTF8(sv);
3336 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3339 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3340 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3342 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3343 LvTARGOFF(ret) = pos;
3344 LvTARGLEN(ret) = len;
3347 PUSHs(ret); /* avoid SvSETMAGIC here */
3351 SvTAINTED_off(TARG); /* decontaminate */
3352 SvUTF8_off(TARG); /* decontaminate */
3355 sv_setpvn(TARG, tmps, byte_len);
3356 #ifdef USE_LOCALE_COLLATE
3357 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3363 SV* repl_sv_copy = NULL;
3365 if (repl_need_utf8_upgrade) {
3366 repl_sv_copy = newSVsv(repl_sv);
3367 sv_utf8_upgrade(repl_sv_copy);
3368 repl = SvPV_const(repl_sv_copy, repl_len);
3369 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3373 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3376 SvREFCNT_dec(repl_sv_copy);
3380 PUSHs(TARG); /* avoid SvSETMAGIC here */
3385 Perl_croak(aTHX_ "substr outside of string");
3386 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3393 register const IV size = POPi;
3394 register const IV offset = POPi;
3395 register SV * const src = POPs;
3396 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3399 if (lvalue) { /* it's an lvalue! */
3400 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3401 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3403 LvTARG(ret) = SvREFCNT_inc_simple(src);
3404 LvTARGOFF(ret) = offset;
3405 LvTARGLEN(ret) = size;
3409 SvTAINTED_off(TARG); /* decontaminate */
3413 sv_setuv(ret, do_vecget(src, offset, size));
3429 const char *little_p;
3430 const I32 arybase = CopARYBASE_get(PL_curcop);
3433 const bool is_index = PL_op->op_type == OP_INDEX;
3436 /* arybase is in characters, like offset, so combine prior to the
3437 UTF-8 to bytes calculation. */
3438 offset = POPi - arybase;
3442 big_p = SvPV_const(big, biglen);
3443 little_p = SvPV_const(little, llen);
3445 big_utf8 = DO_UTF8(big);
3446 little_utf8 = DO_UTF8(little);
3447 if (big_utf8 ^ little_utf8) {
3448 /* One needs to be upgraded. */
3449 if (little_utf8 && !PL_encoding) {
3450 /* Well, maybe instead we might be able to downgrade the small
3452 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3455 /* If the large string is ISO-8859-1, and it's not possible to
3456 convert the small string to ISO-8859-1, then there is no
3457 way that it could be found anywhere by index. */
3462 /* At this point, pv is a malloc()ed string. So donate it to temp
3463 to ensure it will get free()d */
3464 little = temp = newSV(0);
3465 sv_usepvn(temp, pv, llen);
3466 little_p = SvPVX(little);
3469 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3472 sv_recode_to_utf8(temp, PL_encoding);
3474 sv_utf8_upgrade(temp);
3479 big_p = SvPV_const(big, biglen);
3482 little_p = SvPV_const(little, llen);
3486 if (SvGAMAGIC(big)) {
3487 /* Life just becomes a lot easier if I use a temporary here.
3488 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3489 will trigger magic and overloading again, as will fbm_instr()
3491 big = newSVpvn_flags(big_p, biglen,
3492 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3495 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3496 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3497 warn on undef, and we've already triggered a warning with the
3498 SvPV_const some lines above. We can't remove that, as we need to
3499 call some SvPV to trigger overloading early and find out if the
3501 This is all getting to messy. The API isn't quite clean enough,
3502 because data access has side effects.
3504 little = newSVpvn_flags(little_p, llen,
3505 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3506 little_p = SvPVX(little);
3510 offset = is_index ? 0 : biglen;
3512 if (big_utf8 && offset > 0)
3513 sv_pos_u2b(big, &offset, 0);
3519 else if (offset > (I32)biglen)
3521 if (!(little_p = is_index
3522 ? fbm_instr((unsigned char*)big_p + offset,
3523 (unsigned char*)big_p + biglen, little, 0)
3524 : rninstr(big_p, big_p + offset,
3525 little_p, little_p + llen)))
3528 retval = little_p - big_p;
3529 if (retval > 0 && big_utf8)
3530 sv_pos_b2u(big, &retval);
3534 PUSHi(retval + arybase);
3540 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3541 if (SvTAINTED(MARK[1]))
3542 TAINT_PROPER("sprintf");
3543 SvTAINTED_off(TARG);
3544 do_sprintf(TARG, SP-MARK, MARK+1);
3545 TAINT_IF(SvTAINTED(TARG));
3557 const U8 *s = (U8*)SvPV_const(argsv, len);
3559 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3560 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3561 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3565 XPUSHu(DO_UTF8(argsv) ?
3566 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3578 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3580 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3582 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3584 (void) POPs; /* Ignore the argument value. */
3585 value = UNICODE_REPLACEMENT;
3591 SvUPGRADE(TARG,SVt_PV);
3593 if (value > 255 && !IN_BYTES) {
3594 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3595 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3596 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3598 (void)SvPOK_only(TARG);
3607 *tmps++ = (char)value;
3609 (void)SvPOK_only(TARG);
3611 if (PL_encoding && !IN_BYTES) {
3612 sv_recode_to_utf8(TARG, PL_encoding);
3614 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3615 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3619 *tmps++ = (char)value;
3635 const char *tmps = SvPV_const(left, len);
3637 if (DO_UTF8(left)) {
3638 /* If Unicode, try to downgrade.
3639 * If not possible, croak.
3640 * Yes, we made this up. */
3641 SV* const tsv = sv_2mortal(newSVsv(left));
3644 sv_utf8_downgrade(tsv, FALSE);
3645 tmps = SvPV_const(tsv, len);
3647 # ifdef USE_ITHREADS
3649 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3650 /* This should be threadsafe because in ithreads there is only
3651 * one thread per interpreter. If this would not be true,
3652 * we would need a mutex to protect this malloc. */
3653 PL_reentrant_buffer->_crypt_struct_buffer =
3654 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3655 #if defined(__GLIBC__) || defined(__EMX__)
3656 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3657 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3658 /* work around glibc-2.2.5 bug */
3659 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3663 # endif /* HAS_CRYPT_R */
3664 # endif /* USE_ITHREADS */
3666 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3668 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3674 "The crypt() function is unimplemented due to excessive paranoia.");
3678 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3679 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3681 /* Both the characters below can be stored in two UTF-8 bytes. In UTF-8 the max
3682 * character that 2 bytes can hold is U+07FF, and in UTF-EBCDIC it is U+03FF.
3683 * See http://www.unicode.org/unicode/reports/tr16 */
3684 #define LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS 0x0178 /* Also is title case */
3685 #define GREEK_CAPITAL_LETTER_MU 0x039C /* Upper and title case of MICRON */
3687 /* Below are several macros that generate code */
3688 /* Generates code to store a unicode codepoint c that is known to occupy
3689 * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */
3690 #define STORE_UNI_TO_UTF8_TWO_BYTE(p, c) \
3692 *(p) = UTF8_TWO_BYTE_HI(c); \
3693 *((p)+1) = UTF8_TWO_BYTE_LO(c); \
3696 /* Like STORE_UNI_TO_UTF8_TWO_BYTE, but advances p to point to the next
3697 * available byte after the two bytes */
3698 #define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
3700 *(p)++ = UTF8_TWO_BYTE_HI(c); \
3701 *((p)++) = UTF8_TWO_BYTE_LO(c); \
3704 /* Generates code to store the upper case of latin1 character l which is known
3705 * to have its upper case be non-latin1 into the two bytes p and p+1. There
3706 * are only two characters that fit this description, and this macro knows
3707 * about them, and that the upper case values fit into two UTF-8 or UTF-EBCDIC
3709 #define STORE_NON_LATIN1_UC(p, l) \
3711 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3712 STORE_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3713 } else { /* Must be the following letter */ \
3714 STORE_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3718 /* Like STORE_NON_LATIN1_UC, but advances p to point to the next available byte
3719 * after the character stored */
3720 #define CAT_NON_LATIN1_UC(p, l) \
3722 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3723 CAT_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3725 CAT_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3729 /* Generates code to add the two UTF-8 bytes (probably u) that are the upper
3730 * case of l into p and p+1. u must be the result of toUPPER_LATIN1_MOD(l),
3731 * and must require two bytes to store it. Advances p to point to the next
3732 * available position */
3733 #define CAT_TWO_BYTE_UNI_UPPER_MOD(p, l, u) \
3735 if ((u) != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3736 CAT_UNI_TO_UTF8_TWO_BYTE((p), (u)); /* not special, just save it */ \
3737 } else if (l == LATIN_SMALL_LETTER_SHARP_S) { \
3738 *(p)++ = 'S'; *(p)++ = 'S'; /* upper case is 'SS' */ \
3739 } else {/* else is one of the other two special cases */ \
3740 CAT_NON_LATIN1_UC((p), (l)); \
3746 /* Actually is both lcfirst() and ucfirst(). Only the first character
3747 * changes. This means that possibly we can change in-place, ie., just
3748 * take the source and change that one character and store it back, but not
3749 * if read-only etc, or if the length changes */
3754 STRLEN slen; /* slen is the byte length of the whole SV. */
3757 bool inplace; /* ? Convert first char only, in-place */
3758 bool doing_utf8 = FALSE; /* ? using utf8 */
3759 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3760 const int op_type = PL_op->op_type;
3763 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3764 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3765 * stored as UTF-8 at s. */
3766 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3767 * lowercased) character stored in tmpbuf. May be either
3768 * UTF-8 or not, but in either case is the number of bytes */
3772 s = (const U8*)SvPV_nomg_const(source, slen);
3774 if (ckWARN(WARN_UNINITIALIZED))
3775 report_uninit(source);
3780 /* We may be able to get away with changing only the first character, in
3781 * place, but not if read-only, etc. Later we may discover more reasons to
3782 * not convert in-place. */
3783 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3785 /* First calculate what the changed first character should be. This affects
3786 * whether we can just swap it out, leaving the rest of the string unchanged,
3787 * or even if have to convert the dest to UTF-8 when the source isn't */
3789 if (! slen) { /* If empty */
3790 need = 1; /* still need a trailing NUL */
3792 else if (DO_UTF8(source)) { /* Is the source utf8? */
3795 /* TODO: This is #ifdefd out because it has hard-coded the standard mappings,
3796 * and doesn't allow for the user to specify their own. When code is added to
3797 * detect if there is a user-defined mapping in force here, and if so to use
3798 * that, then the code below can be compiled. The detection would be a good
3799 * thing anyway, as currently the user-defined mappings only work on utf8
3800 * strings, and thus depend on the chosen internal storage method, which is a
3802 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3803 if (UTF8_IS_INVARIANT(*s)) {
3805 /* An invariant source character is either ASCII or, in EBCDIC, an
3806 * ASCII equivalent or a caseless C1 control. In both these cases,
3807 * the lower and upper cases of any character are also invariants
3808 * (and title case is the same as upper case). So it is safe to
3809 * use the simple case change macros which avoid the overhead of
3810 * the general functions. Note that if perl were to be extended to
3811 * do locale handling in UTF-8 strings, this wouldn't be true in,
3812 * for example, Lithuanian or Turkic. */
3813 *tmpbuf = (op_type == OP_LCFIRST) ? toLOWER(*s) : toUPPER(*s);
3817 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3820 /* Similarly, if the source character isn't invariant but is in the
3821 * latin1 range (or EBCDIC equivalent thereof), we have the case
3822 * changes compiled into perl, and can avoid the overhead of the
3823 * general functions. In this range, the characters are stored as
3824 * two UTF-8 bytes, and it so happens that any changed-case version
3825 * is also two bytes (in both ASCIIish and EBCDIC machines). */
3829 /* Convert the two source bytes to a single Unicode code point
3830 * value, change case and save for below */
3831 chr = UTF8_ACCUMULATE(*s, *(s+1));
3832 if (op_type == OP_LCFIRST) { /* lower casing is easy */
3833 U8 lower = toLOWER_LATIN1(chr);
3834 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, lower);
3836 else { /* ucfirst */
3837 U8 upper = toUPPER_LATIN1_MOD(chr);
3839 /* Most of the latin1 range characters are well-behaved. Their
3840 * title and upper cases are the same, and are also in the
3841 * latin1 range. The macro above returns their upper (hence
3842 * title) case, and all that need be done is to save the result
3843 * for below. However, several characters are problematic, and
3844 * have to be handled specially. The MOD in the macro name
3845 * above means that these tricky characters all get mapped to
3846 * the single character LATIN_SMALL_LETTER_Y_WITH_DIAERESIS.
3847 * This mapping saves some tests for the majority of the
3850 if (upper != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3852 /* Not tricky. Just save it. */
3853 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, upper);
3855 else if (chr == LATIN_SMALL_LETTER_SHARP_S) {
3857 /* This one is tricky because it is two characters long,
3858 * though the UTF-8 is still two bytes, so the stored
3859 * length doesn't change */
3860 *tmpbuf = 'S'; /* The UTF-8 is 'Ss' */
3861 *(tmpbuf + 1) = 's';
3865 /* The other two have their title and upper cases the same,
3866 * but are tricky because the changed-case characters
3867 * aren't in the latin1 range. They, however, do fit into
3868 * two UTF-8 bytes */
3869 STORE_NON_LATIN1_UC(tmpbuf, chr);
3874 #endif /* end of dont want to break user-defined casing */
3876 /* Here, can't short-cut the general case */
3878 utf8_to_uvchr(s, &ulen);
3879 if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
3880 else toLOWER_utf8(s, tmpbuf, &tculen);
3882 /* we can't do in-place if the length changes. */
3883 if (ulen != tculen) inplace = FALSE;
3884 need = slen + 1 - ulen + tculen;
3885 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3889 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3890 * latin1 is treated as caseless. Note that a locale takes
3892 tculen = 1; /* Most characters will require one byte, but this will
3893 * need to be overridden for the tricky ones */
3896 if (op_type == OP_LCFIRST) {
3898 /* lower case the first letter: no trickiness for any character */
3899 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3900 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3903 else if (IN_LOCALE_RUNTIME) {
3904 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3905 * have upper and title case different
3908 else if (! IN_UNI_8_BIT) {
3909 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3910 * on EBCDIC machines whatever the
3911 * native function does */
3913 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3914 *tmpbuf = toUPPER_LATIN1_MOD(*s);
3916 /* tmpbuf now has the correct title case for all latin1 characters
3917 * except for the several ones that have tricky handling. All
3918 * of these are mapped by the MOD to the letter below. */
3919 if (*tmpbuf == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3921 /* The length is going to change, with all three of these, so
3922 * can't replace just the first character */
3925 /* We use the original to distinguish between these tricky
3927 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3928 /* Two character title case 'Ss', but can remain non-UTF-8 */
3931 *(tmpbuf + 1) = 's'; /* Assert: length(tmpbuf) >= 2 */
3936 /* The other two tricky ones have their title case outside
3937 * latin1. It is the same as their upper case. */
3939 STORE_NON_LATIN1_UC(tmpbuf, *s);
3941 /* The UTF-8 and UTF-EBCDIC lengths of both these characters
3942 * and their upper cases is 2. */
3945 /* The entire result will have to be in UTF-8. Assume worst
3946 * case sizing in conversion. (all latin1 characters occupy
3947 * at most two bytes in utf8) */
3948 convert_source_to_utf8 = TRUE;
3949 need = slen * 2 + 1;
3951 } /* End of is one of the three special chars */
3952 } /* End of use Unicode (Latin1) semantics */
3953 } /* End of changing the case of the first character */
3955 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3956 * generate the result */
3959 /* We can convert in place. This means we change just the first
3960 * character without disturbing the rest; no need to grow */
3962 s = d = (U8*)SvPV_force_nomg(source, slen);
3968 /* Here, we can't convert in place; we earlier calculated how much
3969 * space we will need, so grow to accommodate that */
3970 SvUPGRADE(dest, SVt_PV);
3971 d = (U8*)SvGROW(dest, need);
3972 (void)SvPOK_only(dest);
3979 if (! convert_source_to_utf8) {
3981 /* Here both source and dest are in UTF-8, but have to create
3982 * the entire output. We initialize the result to be the
3983 * title/lower cased first character, and then append the rest
3985 sv_setpvn(dest, (char*)tmpbuf, tculen);
3987 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3991 const U8 *const send = s + slen;
3993 /* Here the dest needs to be in UTF-8, but the source isn't,
3994 * except we earlier UTF-8'd the first character of the source
3995 * into tmpbuf. First put that into dest, and then append the
3996 * rest of the source, converting it to UTF-8 as we go. */
3998 /* Assert tculen is 2 here because the only two characters that
3999 * get to this part of the code have 2-byte UTF-8 equivalents */
4001 *d++ = *(tmpbuf + 1);
4002 s++; /* We have just processed the 1st char */
4004 for (; s < send; s++) {
4005 d = uvchr_to_utf8(d, *s);
4008 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4012 else { /* in-place UTF-8. Just overwrite the first character */
4013 Copy(tmpbuf, d, tculen, U8);
4014 SvCUR_set(dest, need - 1);
4017 else { /* Neither source nor dest are in or need to be UTF-8 */
4019 if (IN_LOCALE_RUNTIME) {
4023 if (inplace) { /* in-place, only need to change the 1st char */
4026 else { /* Not in-place */
4028 /* Copy the case-changed character(s) from tmpbuf */
4029 Copy(tmpbuf, d, tculen, U8);
4030 d += tculen - 1; /* Code below expects d to point to final
4031 * character stored */
4034 else { /* empty source */
4035 /* See bug #39028: Don't taint if empty */
4039 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4040 * the destination to retain that flag */
4044 if (!inplace) { /* Finish the rest of the string, unchanged */
4045 /* This will copy the trailing NUL */
4046 Copy(s + 1, d + 1, slen, U8);
4047 SvCUR_set(dest, need - 1);
4054 /* There's so much setup/teardown code common between uc and lc, I wonder if
4055 it would be worth merging the two, and just having a switch outside each
4056 of the three tight loops. There is less and less commonality though */
4070 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4071 && SvTEMP(source) && !DO_UTF8(source)
4072 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
4074 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
4075 * make the loop tight, so we overwrite the source with the dest before
4076 * looking at it, and we need to look at the original source
4077 * afterwards. There would also need to be code added to handle
4078 * switching to not in-place in midstream if we run into characters
4079 * that change the length.
4082 s = d = (U8*)SvPV_force_nomg(source, len);
4089 /* The old implementation would copy source into TARG at this point.
4090 This had the side effect that if source was undef, TARG was now
4091 an undefined SV with PADTMP set, and they don't warn inside
4092 sv_2pv_flags(). However, we're now getting the PV direct from
4093 source, which doesn't have PADTMP set, so it would warn. Hence the
4097 s = (const U8*)SvPV_nomg_const(source, len);
4099 if (ckWARN(WARN_UNINITIALIZED))
4100 report_uninit(source);
4106 SvUPGRADE(dest, SVt_PV);
4107 d = (U8*)SvGROW(dest, min);
4108 (void)SvPOK_only(dest);
4113 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4114 to check DO_UTF8 again here. */
4116 if (DO_UTF8(source)) {
4117 const U8 *const send = s + len;
4118 U8 tmpbuf[UTF8_MAXBYTES+1];
4120 /* All occurrences of these are to be moved to follow any other marks.
4121 * This is context-dependent. We may not be passed enough context to
4122 * move the iota subscript beyond all of them, but we do the best we can
4123 * with what we're given. The result is always better than if we
4124 * hadn't done this. And, the problem would only arise if we are
4125 * passed a character without all its combining marks, which would be
4126 * the caller's mistake. The information this is based on comes from a
4127 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4128 * itself) and so can't be checked properly to see if it ever gets
4129 * revised. But the likelihood of it changing is remote */
4130 bool in_iota_subscript = FALSE;
4133 if (in_iota_subscript && ! is_utf8_mark(s)) {
4134 /* A non-mark. Time to output the iota subscript */
4135 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4136 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4138 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4139 in_iota_subscript = FALSE;
4143 /* See comments at the first instance in this file of this ifdef */
4144 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4146 /* If the UTF-8 character is invariant, then it is in the range
4147 * known by the standard macro; result is only one byte long */
4148 if (UTF8_IS_INVARIANT(*s)) {
4152 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4154 /* Likewise, if it fits in a byte, its case change is in our
4156 U8 orig = UTF8_ACCUMULATE(*s, *(s+1));
4157 U8 upper = toUPPER_LATIN1_MOD(orig);
4158 CAT_TWO_BYTE_UNI_UPPER_MOD(d, orig, upper);
4166 /* Otherwise, need the general UTF-8 case. Get the changed
4167 * case value and copy it to the output buffer */
4169 const STRLEN u = UTF8SKIP(s);
4172 const UV uv = toUPPER_utf8(s, tmpbuf, &ulen);
4173 if (uv == GREEK_CAPITAL_LETTER_IOTA
4174 && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4176 in_iota_subscript = TRUE;
4179 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4180 /* If the eventually required minimum size outgrows
4181 * the available space, we need to grow. */
4182 const UV o = d - (U8*)SvPVX_const(dest);
4184 /* If someone uppercases one million U+03B0s we
4185 * SvGROW() one million times. Or we could try
4186 * guessing how much to allocate without allocating too
4187 * much. Such is life. See corresponding comment in
4188 * lc code for another option */
4190 d = (U8*)SvPVX(dest) + o;
4192 Copy(tmpbuf, d, ulen, U8);
4198 if (in_iota_subscript) {
4199 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4203 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4205 else { /* Not UTF-8 */
4207 const U8 *const send = s + len;
4209 /* Use locale casing if in locale; regular style if not treating
4210 * latin1 as having case; otherwise the latin1 casing. Do the
4211 * whole thing in a tight loop, for speed, */
4212 if (IN_LOCALE_RUNTIME) {
4215 for (; s < send; d++, s++)
4216 *d = toUPPER_LC(*s);
4218 else if (! IN_UNI_8_BIT) {
4219 for (; s < send; d++, s++) {
4224 for (; s < send; d++, s++) {
4225 *d = toUPPER_LATIN1_MOD(*s);
4226 if (*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) continue;
4228 /* The mainstream case is the tight loop above. To avoid
4229 * extra tests in that, all three characters that require
4230 * special handling are mapped by the MOD to the one tested
4232 * Use the source to distinguish between the three cases */
4234 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4236 /* uc() of this requires 2 characters, but they are
4237 * ASCII. If not enough room, grow the string */
4238 if (SvLEN(dest) < ++min) {
4239 const UV o = d - (U8*)SvPVX_const(dest);
4241 d = (U8*)SvPVX(dest) + o;
4243 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4244 continue; /* Back to the tight loop; still in ASCII */
4247 /* The other two special handling characters have their
4248 * upper cases outside the latin1 range, hence need to be
4249 * in UTF-8, so the whole result needs to be in UTF-8. So,
4250 * here we are somewhere in the middle of processing a
4251 * non-UTF-8 string, and realize that we will have to convert
4252 * the whole thing to UTF-8. What to do? There are
4253 * several possibilities. The simplest to code is to
4254 * convert what we have so far, set a flag, and continue on
4255 * in the loop. The flag would be tested each time through
4256 * the loop, and if set, the next character would be
4257 * converted to UTF-8 and stored. But, I (khw) didn't want
4258 * to slow down the mainstream case at all for this fairly
4259 * rare case, so I didn't want to add a test that didn't
4260 * absolutely have to be there in the loop, besides the
4261 * possibility that it would get too complicated for
4262 * optimizers to deal with. Another possibility is to just
4263 * give up, convert the source to UTF-8, and restart the
4264 * function that way. Another possibility is to convert
4265 * both what has already been processed and what is yet to
4266 * come separately to UTF-8, then jump into the loop that
4267 * handles UTF-8. But the most efficient time-wise of the
4268 * ones I could think of is what follows, and turned out to
4269 * not require much extra code. */
4271 /* Convert what we have so far into UTF-8, telling the
4272 * function that we know it should be converted, and to
4273 * allow extra space for what we haven't processed yet.
4274 * Assume the worst case space requirements for converting
4275 * what we haven't processed so far: that it will require
4276 * two bytes for each remaining source character, plus the
4277 * NUL at the end. This may cause the string pointer to
4278 * move, so re-find it. */
4280 len = d - (U8*)SvPVX_const(dest);
4281 SvCUR_set(dest, len);
4282 len = sv_utf8_upgrade_flags_grow(dest,
4283 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4285 d = (U8*)SvPVX(dest) + len;
4287 /* And append the current character's upper case in UTF-8 */
4288 CAT_NON_LATIN1_UC(d, *s);
4290 /* Now process the remainder of the source, converting to
4291 * upper and UTF-8. If a resulting byte is invariant in
4292 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4293 * append it to the output. */
4296 for (; s < send; s++) {
4297 U8 upper = toUPPER_LATIN1_MOD(*s);
4298 if UTF8_IS_INVARIANT(upper) {
4302 CAT_TWO_BYTE_UNI_UPPER_MOD(d, *s, upper);
4306 /* Here have processed the whole source; no need to continue
4307 * with the outer loop. Each character has been converted
4308 * to upper case and converted to UTF-8 */
4311 } /* End of processing all latin1-style chars */
4312 } /* End of processing all chars */
4313 } /* End of source is not empty */
4315 if (source != dest) {
4316 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4317 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4319 } /* End of isn't utf8 */
4337 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4338 && SvTEMP(source) && !DO_UTF8(source)) {
4340 /* We can convert in place, as lowercasing anything in the latin1 range
4341 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4343 s = d = (U8*)SvPV_force_nomg(source, len);
4350 /* The old implementation would copy source into TARG at this point.
4351 This had the side effect that if source was undef, TARG was now
4352 an undefined SV with PADTMP set, and they don't warn inside
4353 sv_2pv_flags(). However, we're now getting the PV direct from
4354 source, which doesn't have PADTMP set, so it would warn. Hence the
4358 s = (const U8*)SvPV_nomg_const(source, len);
4360 if (ckWARN(WARN_UNINITIALIZED))
4361 report_uninit(source);
4367 SvUPGRADE(dest, SVt_PV);
4368 d = (U8*)SvGROW(dest, min);
4369 (void)SvPOK_only(dest);
4374 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4375 to check DO_UTF8 again here. */
4377 if (DO_UTF8(source)) {
4378 const U8 *const send = s + len;
4379 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4382 /* See comments at the first instance in this file of this ifdef */
4383 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4384 if (UTF8_IS_INVARIANT(*s)) {
4386 /* Invariant characters use the standard mappings compiled in.
4391 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4393 /* As do the ones in the Latin1 range */
4394 U8 lower = toLOWER_LATIN1(UTF8_ACCUMULATE(*s, *(s+1)));
4395 CAT_UNI_TO_UTF8_TWO_BYTE(d, lower);
4400 /* Here, is utf8 not in Latin-1 range, have to go out and get
4401 * the mappings from the tables. */
4403 const STRLEN u = UTF8SKIP(s);
4406 #ifndef CONTEXT_DEPENDENT_CASING
4407 toLOWER_utf8(s, tmpbuf, &ulen);
4409 /* This is ifdefd out because it needs more work and thought. It isn't clear
4410 * that we should do it.
4411 * A minor objection is that this is based on a hard-coded rule from the
4412 * Unicode standard, and may change, but this is not very likely at all.
4413 * mktables should check and warn if it does.
4414 * More importantly, if the sigma occurs at the end of the string, we don't
4415 * have enough context to know whether it is part of a larger string or going
4416 * to be or not. It may be that we are passed a subset of the context, via
4417 * a \U...\E, for example, and we could conceivably know the larger context if
4418 * code were changed to pass that in. But, if the string passed in is an
4419 * intermediate result, and the user concatenates two strings together
4420 * after we have made a final sigma, that would be wrong. If the final sigma
4421 * occurs in the middle of the string we are working on, then we know that it
4422 * should be a final sigma, but otherwise we can't be sure. */
4424 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
4426 /* If the lower case is a small sigma, it may be that we need
4427 * to change it to a final sigma. This happens at the end of
4428 * a word that contains more than just this character, and only
4429 * when we started with a capital sigma. */
4430 if (uv == UNICODE_GREEK_SMALL_LETTER_SIGMA &&
4431 s > send - len && /* Makes sure not the first letter */
4432 utf8_to_uvchr(s, 0) == UNICODE_GREEK_CAPITAL_LETTER_SIGMA
4435 /* We use the algorithm in:
4436 * http://www.unicode.org/versions/Unicode5.0.0/ch03.pdf (C
4437 * is a CAPITAL SIGMA): If C is preceded by a sequence
4438 * consisting of a cased letter and a case-ignorable
4439 * sequence, and C is not followed by a sequence consisting
4440 * of a case ignorable sequence and then a cased letter,
4441 * then when lowercasing C, C becomes a final sigma */
4443 /* To determine if this is the end of a word, need to peek
4444 * ahead. Look at the next character */
4445 const U8 *peek = s + u;
4447 /* Skip any case ignorable characters */
4448 while (peek < send && is_utf8_case_ignorable(peek)) {
4449 peek += UTF8SKIP(peek);
4452 /* If we reached the end of the string without finding any
4453 * non-case ignorable characters, or if the next such one
4454 * is not-cased, then we have met the conditions for it
4455 * being a final sigma with regards to peek ahead, and so
4456 * must do peek behind for the remaining conditions. (We
4457 * know there is stuff behind to look at since we tested
4458 * above that this isn't the first letter) */
4459 if (peek >= send || ! is_utf8_cased(peek)) {
4460 peek = utf8_hop(s, -1);
4462 /* Here are at the beginning of the first character
4463 * before the original upper case sigma. Keep backing
4464 * up, skipping any case ignorable characters */
4465 while (is_utf8_case_ignorable(peek)) {
4466 peek = utf8_hop(peek, -1);
4469 /* Here peek points to the first byte of the closest
4470 * non-case-ignorable character before the capital
4471 * sigma. If it is cased, then by the Unicode
4472 * algorithm, we should use a small final sigma instead
4473 * of what we have */
4474 if (is_utf8_cased(peek)) {
4475 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf,
4476 UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA);
4480 else { /* Not a context sensitive mapping */
4481 #endif /* End of commented out context sensitive */
4482 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4484 /* If the eventually required minimum size outgrows
4485 * the available space, we need to grow. */
4486 const UV o = d - (U8*)SvPVX_const(dest);
4488 /* If someone lowercases one million U+0130s we
4489 * SvGROW() one million times. Or we could try
4490 * guessing how much to allocate without allocating too
4491 * much. Such is life. Another option would be to
4492 * grow an extra byte or two more each time we need to
4493 * grow, which would cut down the million to 500K, with
4496 d = (U8*)SvPVX(dest) + o;
4498 #ifdef CONTEXT_DEPENDENT_CASING
4501 /* Copy the newly lowercased letter to the output buffer we're
4503 Copy(tmpbuf, d, ulen, U8);
4506 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4509 } /* End of looping through the source string */
4512 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4513 } else { /* Not utf8 */
4515 const U8 *const send = s + len;
4517 /* Use locale casing if in locale; regular style if not treating
4518 * latin1 as having case; otherwise the latin1 casing. Do the
4519 * whole thing in a tight loop, for speed, */
4520 if (IN_LOCALE_RUNTIME) {
4523 for (; s < send; d++, s++)
4524 *d = toLOWER_LC(*s);
4526 else if (! IN_UNI_8_BIT) {
4527 for (; s < send; d++, s++) {
4532 for (; s < send; d++, s++) {
4533 *d = toLOWER_LATIN1(*s);
4537 if (source != dest) {
4539 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4549 SV * const sv = TOPs;
4551 register const char *s = SvPV_const(sv,len);
4553 SvUTF8_off(TARG); /* decontaminate */
4556 SvUPGRADE(TARG, SVt_PV);
4557 SvGROW(TARG, (len * 2) + 1);
4561 if (UTF8_IS_CONTINUED(*s)) {
4562 STRLEN ulen = UTF8SKIP(s);
4586 SvCUR_set(TARG, d - SvPVX_const(TARG));
4587 (void)SvPOK_only_UTF8(TARG);
4590 sv_setpvn(TARG, s, len);
4599 dVAR; dSP; dMARK; dORIGMARK;
4600 register AV *const av = MUTABLE_AV(POPs);
4601 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4603 if (SvTYPE(av) == SVt_PVAV) {
4604 const I32 arybase = CopARYBASE_get(PL_curcop);
4605 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4606 bool can_preserve = FALSE;
4612 can_preserve = SvCANEXISTDELETE(av);
4615 if (lval && localizing) {
4618 for (svp = MARK + 1; svp <= SP; svp++) {
4619 const I32 elem = SvIV(*svp);
4623 if (max > AvMAX(av))
4627 while (++MARK <= SP) {
4629 I32 elem = SvIV(*MARK);
4630 bool preeminent = TRUE;
4634 if (localizing && can_preserve) {
4635 /* If we can determine whether the element exist,
4636 * Try to preserve the existenceness of a tied array
4637 * element by using EXISTS and DELETE if possible.
4638 * Fallback to FETCH and STORE otherwise. */
4639 preeminent = av_exists(av, elem);
4642 svp = av_fetch(av, elem, lval);
4644 if (!svp || *svp == &PL_sv_undef)
4645 DIE(aTHX_ PL_no_aelem, elem);
4648 save_aelem(av, elem, svp);
4650 SAVEADELETE(av, elem);
4653 *MARK = svp ? *svp : &PL_sv_undef;
4656 if (GIMME != G_ARRAY) {
4658 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4664 /* Smart dereferencing for keys, values and each */
4677 /* N.B.: AMG macros return sv if no overloading is found */
4678 SV *maybe_hv = AMG_CALLun(sv,to_hv);
4679 SV *maybe_av = AMG_CALLun(sv,to_av);
4680 if ( maybe_hv != sv && maybe_av != sv ) {
4681 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
4682 Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}",
4683 PL_op_desc[PL_op->op_type]
4688 else if ( maybe_av != sv ) {
4689 if ( SvTYPE(SvRV(sv)) == SVt_PVHV ) {
4690 /* @{} overload, but underlying reftype is HV */
4691 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
4692 Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as @{}",
4693 PL_op_desc[PL_op->op_type]
4699 else if ( maybe_hv != sv ) {
4700 if ( SvTYPE(SvRV(sv)) == SVt_PVAV ) {
4701 /* %{} overload, but underlying reftype is AV */
4702 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
4703 Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}",
4704 PL_op_desc[PL_op->op_type]
4714 if ( SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV ) {
4715 DIE(aTHX_ Perl_form(aTHX_ "Type of argument to %s must be hashref or arrayref",
4716 PL_op_desc[PL_op->op_type] ));
4719 /* Delegate to correct function for op type */
4721 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4722 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4725 return (SvTYPE(sv) == SVt_PVHV) ? Perl_pp_each(aTHX) : Perl_pp_aeach(aTHX);
4733 AV *array = MUTABLE_AV(POPs);
4734 const I32 gimme = GIMME_V;
4735 IV *iterp = Perl_av_iter_p(aTHX_ array);
4736 const IV current = (*iterp)++;
4738 if (current > av_len(array)) {
4740 if (gimme == G_SCALAR)
4747 mPUSHi(CopARYBASE_get(PL_curcop) + current);
4748 if (gimme == G_ARRAY) {
4749 SV **const element = av_fetch(array, current, 0);
4750 PUSHs(element ? *element : &PL_sv_undef);
4759 AV *array = MUTABLE_AV(POPs);
4760 const I32 gimme = GIMME_V;
4762 *Perl_av_iter_p(aTHX_ array) = 0;
4764 if (gimme == G_SCALAR) {
4766 PUSHi(av_len(array) + 1);
4768 else if (gimme == G_ARRAY) {
4769 IV n = Perl_av_len(aTHX_ array);
4770 IV i = CopARYBASE_get(PL_curcop);
4774 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4776 for (; i <= n; i++) {
4781 for (i = 0; i <= n; i++) {
4782 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4783 PUSHs(elem ? *elem : &PL_sv_undef);
4790 /* Associative arrays. */
4796 HV * hash = MUTABLE_HV(POPs);
4798 const I32 gimme = GIMME_V;
4801 /* might clobber stack_sp */
4802 entry = hv_iternext(hash);
4807 SV* const sv = hv_iterkeysv(entry);
4808 PUSHs(sv); /* won't clobber stack_sp */
4809 if (gimme == G_ARRAY) {
4812 /* might clobber stack_sp */
4813 val = hv_iterval(hash, entry);
4818 else if (gimme == G_SCALAR)
4825 S_do_delete_local(pTHX)
4829 const I32 gimme = GIMME_V;
4833 if (PL_op->op_private & OPpSLICE) {
4835 SV * const osv = POPs;
4836 const bool tied = SvRMAGICAL(osv)
4837 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4838 const bool can_preserve = SvCANEXISTDELETE(osv)
4839 || mg_find((const SV *)osv, PERL_MAGIC_env);
4840 const U32 type = SvTYPE(osv);
4841 if (type == SVt_PVHV) { /* hash element */
4842 HV * const hv = MUTABLE_HV(osv);
4843 while (++MARK <= SP) {
4844 SV * const keysv = *MARK;
4846 bool preeminent = TRUE;
4848 preeminent = hv_exists_ent(hv, keysv, 0);
4850 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4857 sv = hv_delete_ent(hv, keysv, 0, 0);
4858 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4861 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4863 *MARK = sv_mortalcopy(sv);
4869 SAVEHDELETE(hv, keysv);
4870 *MARK = &PL_sv_undef;
4874 else if (type == SVt_PVAV) { /* array element */
4875 if (PL_op->op_flags & OPf_SPECIAL) {
4876 AV * const av = MUTABLE_AV(osv);
4877 while (++MARK <= SP) {
4878 I32 idx = SvIV(*MARK);
4880 bool preeminent = TRUE;
4882 preeminent = av_exists(av, idx);
4884 SV **svp = av_fetch(av, idx, 1);
4891 sv = av_delete(av, idx, 0);
4892 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4895 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4897 *MARK = sv_mortalcopy(sv);
4903 SAVEADELETE(av, idx);
4904 *MARK = &PL_sv_undef;
4910 DIE(aTHX_ "Not a HASH reference");
4911 if (gimme == G_VOID)
4913 else if (gimme == G_SCALAR) {
4918 *++MARK = &PL_sv_undef;
4923 SV * const keysv = POPs;
4924 SV * const osv = POPs;
4925 const bool tied = SvRMAGICAL(osv)
4926 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4927 const bool can_preserve = SvCANEXISTDELETE(osv)
4928 || mg_find((const SV *)osv, PERL_MAGIC_env);
4929 const U32 type = SvTYPE(osv);
4931 if (type == SVt_PVHV) {
4932 HV * const hv = MUTABLE_HV(osv);
4933 bool preeminent = TRUE;
4935 preeminent = hv_exists_ent(hv, keysv, 0);
4937 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4944 sv = hv_delete_ent(hv, keysv, 0, 0);
4945 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4948 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4950 SV *nsv = sv_mortalcopy(sv);
4956 SAVEHDELETE(hv, keysv);
4958 else if (type == SVt_PVAV) {
4959 if (PL_op->op_flags & OPf_SPECIAL) {
4960 AV * const av = MUTABLE_AV(osv);
4961 I32 idx = SvIV(keysv);
4962 bool preeminent = TRUE;
4964 preeminent = av_exists(av, idx);
4966 SV **svp = av_fetch(av, idx, 1);
4973 sv = av_delete(av, idx, 0);
4974 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4977 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4979 SV *nsv = sv_mortalcopy(sv);
4985 SAVEADELETE(av, idx);
4988 DIE(aTHX_ "panic: avhv_delete no longer supported");
4991 DIE(aTHX_ "Not a HASH reference");
4994 if (gimme != G_VOID)
5008 if (PL_op->op_private & OPpLVAL_INTRO)
5009 return do_delete_local();
5012 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5014 if (PL_op->op_private & OPpSLICE) {
5016 HV * const hv = MUTABLE_HV(POPs);
5017 const U32 hvtype = SvTYPE(hv);
5018 if (hvtype == SVt_PVHV) { /* hash element */
5019 while (++MARK <= SP) {
5020 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
5021 *MARK = sv ? sv : &PL_sv_undef;
5024 else if (hvtype == SVt_PVAV) { /* array element */
5025 if (PL_op->op_flags & OPf_SPECIAL) {
5026 while (++MARK <= SP) {
5027 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
5028 *MARK = sv ? sv : &PL_sv_undef;
5033 DIE(aTHX_ "Not a HASH reference");
5036 else if (gimme == G_SCALAR) {
5041 *++MARK = &PL_sv_undef;
5047 HV * const hv = MUTABLE_HV(POPs);
5049 if (SvTYPE(hv) == SVt_PVHV)
5050 sv = hv_delete_ent(hv, keysv, discard, 0);
5051 else if (SvTYPE(hv) == SVt_PVAV) {
5052 if (PL_op->op_flags & OPf_SPECIAL)
5053 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5055 DIE(aTHX_ "panic: avhv_delete no longer supported");
5058 DIE(aTHX_ "Not a HASH reference");
5074 if (PL_op->op_private & OPpEXISTS_SUB) {
5076 SV * const sv = POPs;
5077 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5080 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5085 hv = MUTABLE_HV(POPs);
5086 if (SvTYPE(hv) == SVt_PVHV) {
5087 if (hv_exists_ent(hv, tmpsv, 0))
5090 else if (SvTYPE(hv) == SVt_PVAV) {
5091 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
5092 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5097 DIE(aTHX_ "Not a HASH reference");
5104 dVAR; dSP; dMARK; dORIGMARK;
5105 register HV * const hv = MUTABLE_HV(POPs);
5106 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5107 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5108 bool can_preserve = FALSE;
5114 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
5115 can_preserve = TRUE;
5118 while (++MARK <= SP) {
5119 SV * const keysv = *MARK;
5122 bool preeminent = TRUE;
5124 if (localizing && can_preserve) {
5125 /* If we can determine whether the element exist,
5126 * try to preserve the existenceness of a tied hash
5127 * element by using EXISTS and DELETE if possible.
5128 * Fallback to FETCH and STORE otherwise. */
5129 preeminent = hv_exists_ent(hv, keysv, 0);
5132 he = hv_fetch_ent(hv, keysv, lval, 0);
5133 svp = he ? &HeVAL(he) : NULL;
5136 if (!svp || *svp == &PL_sv_undef) {
5137 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5140 if (HvNAME_get(hv) && isGV(*svp))
5141 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5142 else if (preeminent)
5143 save_helem_flags(hv, keysv, svp,
5144 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5146 SAVEHDELETE(hv, keysv);
5149 *MARK = svp ? *svp : &PL_sv_undef;
5151 if (GIMME != G_ARRAY) {
5153 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5159 /* List operators. */
5164 if (GIMME != G_ARRAY) {
5166 *MARK = *SP; /* unwanted list, return last item */
5168 *MARK = &PL_sv_undef;
5178 SV ** const lastrelem = PL_stack_sp;
5179 SV ** const lastlelem = PL_stack_base + POPMARK;
5180 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5181 register SV ** const firstrelem = lastlelem + 1;
5182 const I32 arybase = CopARYBASE_get(PL_curcop);
5183 I32 is_something_there = FALSE;
5185 register const I32 max = lastrelem - lastlelem;
5186 register SV **lelem;
5188 if (GIMME != G_ARRAY) {
5189 I32 ix = SvIV(*lastlelem);
5194 if (ix < 0 || ix >= max)
5195 *firstlelem = &PL_sv_undef;
5197 *firstlelem = firstrelem[ix];
5203 SP = firstlelem - 1;
5207 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5208 I32 ix = SvIV(*lelem);
5213 if (ix < 0 || ix >= max)
5214 *lelem = &PL_sv_undef;
5216 is_something_there = TRUE;
5217 if (!(*lelem = firstrelem[ix]))
5218 *lelem = &PL_sv_undef;
5221 if (is_something_there)
5224 SP = firstlelem - 1;
5230 dVAR; dSP; dMARK; dORIGMARK;
5231 const I32 items = SP - MARK;
5232 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5233 SP = ORIGMARK; /* av_make() might realloc stack_sp */
5234 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5235 ? newRV_noinc(av) : av);
5241 dVAR; dSP; dMARK; dORIGMARK;
5242 HV* const hv = newHV();
5245 SV * const key = *++MARK;
5246 SV * const val = newSV(0);
5248 sv_setsv(val, *++MARK);
5250 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5251 (void)hv_store_ent(hv,key,val,0);
5254 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5255 ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
5261 dVAR; dSP; dMARK; dORIGMARK;
5262 register AV *ary = MUTABLE_AV(*++MARK);
5266 register I32 offset;
5267 register I32 length;
5271 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5274 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5277 ENTER_with_name("call_SPLICE");
5278 call_method("SPLICE",GIMME_V);
5279 LEAVE_with_name("call_SPLICE");
5287 offset = i = SvIV(*MARK);
5289 offset += AvFILLp(ary) + 1;
5291 offset -= CopARYBASE_get(PL_curcop);
5293 DIE(aTHX_ PL_no_aelem, i);
5295 length = SvIVx(*MARK++);
5297 length += AvFILLp(ary) - offset + 1;
5303 length = AvMAX(ary) + 1; /* close enough to infinity */
5307 length = AvMAX(ary) + 1;
5309 if (offset > AvFILLp(ary) + 1) {
5310 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5311 offset = AvFILLp(ary) + 1;
5313 after = AvFILLp(ary) + 1 - (offset + length);
5314 if (after < 0) { /* not that much array */
5315 length += after; /* offset+length now in array */
5321 /* At this point, MARK .. SP-1 is our new LIST */
5324 diff = newlen - length;
5325 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5328 /* make new elements SVs now: avoid problems if they're from the array */
5329 for (dst = MARK, i = newlen; i; i--) {
5330 SV * const h = *dst;
5331 *dst++ = newSVsv(h);
5334 if (diff < 0) { /* shrinking the area */
5335 SV **tmparyval = NULL;
5337 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5338 Copy(MARK, tmparyval, newlen, SV*);
5341 MARK = ORIGMARK + 1;
5342 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5343 MEXTEND(MARK, length);
5344 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
5346 EXTEND_MORTAL(length);
5347 for (i = length, dst = MARK; i; i--) {
5348 sv_2mortal(*dst); /* free them eventualy */
5355 *MARK = AvARRAY(ary)[offset+length-1];
5358 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5359 SvREFCNT_dec(*dst++); /* free them now */
5362 AvFILLp(ary) += diff;
5364 /* pull up or down? */
5366 if (offset < after) { /* easier to pull up */
5367 if (offset) { /* esp. if nothing to pull */
5368 src = &AvARRAY(ary)[offset-1];
5369 dst = src - diff; /* diff is negative */
5370 for (i = offset; i > 0; i--) /* can't trust Copy */
5374 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5378 if (after) { /* anything to pull down? */
5379 src = AvARRAY(ary) + offset + length;
5380 dst = src + diff; /* diff is negative */
5381 Move(src, dst, after, SV*);
5383 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5384 /* avoid later double free */
5388 dst[--i] = &PL_sv_undef;
5391 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5392 Safefree(tmparyval);
5395 else { /* no, expanding (or same) */
5396 SV** tmparyval = NULL;
5398 Newx(tmparyval, length, SV*); /* so remember deletion */
5399 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5402 if (diff > 0) { /* expanding */
5403 /* push up or down? */
5404 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5408 Move(src, dst, offset, SV*);
5410 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5412 AvFILLp(ary) += diff;
5415 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5416 av_extend(ary, AvFILLp(ary) + diff);
5417 AvFILLp(ary) += diff;
5420 dst = AvARRAY(ary) + AvFILLp(ary);
5422 for (i = after; i; i--) {
5430 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5433 MARK = ORIGMARK + 1;
5434 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5436 Copy(tmparyval, MARK, length, SV*);
5438 EXTEND_MORTAL(length);
5439 for (i = length, dst = MARK; i; i--) {
5440 sv_2mortal(*dst); /* free them eventualy */
5447 else if (length--) {
5448 *MARK = tmparyval[length];
5451 while (length-- > 0)
5452 SvREFCNT_dec(tmparyval[length]);
5456 *MARK = &PL_sv_undef;
5457 Safefree(tmparyval);
5461 mg_set(MUTABLE_SV(ary));
5469 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5470 register AV * const ary = MUTABLE_AV(*++MARK);
5471 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5474 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5477 ENTER_with_name("call_PUSH");
5478 call_method("PUSH",G_SCALAR|G_DISCARD);
5479 LEAVE_with_name("call_PUSH");
5483 PL_delaymagic = DM_DELAY;
5484 for (++MARK; MARK <= SP; MARK++) {
5485 SV * const sv = newSV(0);
5487 sv_setsv(sv, *MARK);
5488 av_store(ary, AvFILLp(ary)+1, sv);
5490 if (PL_delaymagic & DM_ARRAY_ISA)
5491 mg_set(MUTABLE_SV(ary));
5496 if (OP_GIMME(PL_op, 0) != G_VOID) {
5497 PUSHi( AvFILL(ary) + 1 );
5506 AV * const av = PL_op->op_flags & OPf_SPECIAL
5507 ? MUTABLE_AV(GvAV(PL_defgv)) : MUTABLE_AV(POPs);
5508 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5512 (void)sv_2mortal(sv);
5519 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5520 register AV *ary = MUTABLE_AV(*++MARK);
5521 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5524 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5527 ENTER_with_name("call_UNSHIFT");
5528 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5529 LEAVE_with_name("call_UNSHIFT");
5534 av_unshift(ary, SP - MARK);
5536 SV * const sv = newSVsv(*++MARK);
5537 (void)av_store(ary, i++, sv);
5541 if (OP_GIMME(PL_op, 0) != G_VOID) {
5542 PUSHi( AvFILL(ary) + 1 );
5551 if (GIMME == G_ARRAY) {
5552 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5556 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5557 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5558 av = MUTABLE_AV((*SP));
5559 /* In-place reversing only happens in void context for the array
5560 * assignment. We don't need to push anything on the stack. */
5563 if (SvMAGICAL(av)) {
5565 register SV *tmp = sv_newmortal();
5566 /* For SvCANEXISTDELETE */
5569 bool can_preserve = SvCANEXISTDELETE(av);
5571 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5572 register SV *begin, *end;
5575 if (!av_exists(av, i)) {
5576 if (av_exists(av, j)) {
5577 register SV *sv = av_delete(av, j, 0);
5578 begin = *av_fetch(av, i, TRUE);
5579 sv_setsv_mg(begin, sv);
5583 else if (!av_exists(av, j)) {
5584 register SV *sv = av_delete(av, i, 0);
5585 end = *av_fetch(av, j, TRUE);
5586 sv_setsv_mg(end, sv);
5591 begin = *av_fetch(av, i, TRUE);
5592 end = *av_fetch(av, j, TRUE);
5593 sv_setsv(tmp, begin);
5594 sv_setsv_mg(begin, end);
5595 sv_setsv_mg(end, tmp);
5599 SV **begin = AvARRAY(av);
5602 SV **end = begin + AvFILLp(av);
5604 while (begin < end) {
5605 register SV * const tmp = *begin;
5616 register SV * const tmp = *MARK;
5620 /* safe as long as stack cannot get extended in the above */
5626 register char *down;
5631 SvUTF8_off(TARG); /* decontaminate */
5633 do_join(TARG, &PL_sv_no, MARK, SP);
5635 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5636 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5637 report_uninit(TARG);
5640 up = SvPV_force(TARG, len);
5642 if (DO_UTF8(TARG)) { /* first reverse each character */
5643 U8* s = (U8*)SvPVX(TARG);
5644 const U8* send = (U8*)(s + len);
5646 if (UTF8_IS_INVARIANT(*s)) {
5651 if (!utf8_to_uvchr(s, 0))
5655 down = (char*)(s - 1);
5656 /* reverse this character */
5660 *down-- = (char)tmp;
5666 down = SvPVX(TARG) + len - 1;
5670 *down-- = (char)tmp;
5672 (void)SvPOK_only_UTF8(TARG);
5684 register IV limit = POPi; /* note, negative is forever */
5685 SV * const sv = POPs;
5687 register const char *s = SvPV_const(sv, len);
5688 const bool do_utf8 = DO_UTF8(sv);
5689 const char *strend = s + len;
5691 register REGEXP *rx;
5693 register const char *m;
5695 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
5696 I32 maxiters = slen + 10;
5697 I32 trailing_empty = 0;
5699 const I32 origlimit = limit;
5702 const I32 gimme = GIMME_V;
5704 const I32 oldsave = PL_savestack_ix;
5705 U32 make_mortal = SVs_TEMP;
5710 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5715 DIE(aTHX_ "panic: pp_split");
5718 TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
5719 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5721 RX_MATCH_UTF8_set(rx, do_utf8);
5724 if (pm->op_pmreplrootu.op_pmtargetoff) {
5725 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5728 if (pm->op_pmreplrootu.op_pmtargetgv) {
5729 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5734 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5740 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5742 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5749 for (i = AvFILLp(ary); i >= 0; i--)
5750 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5752 /* temporarily switch stacks */
5753 SAVESWITCHSTACK(PL_curstack, ary);
5757 base = SP - PL_stack_base;
5759 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5761 while (*s == ' ' || is_utf8_space((U8*)s))
5764 else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5765 while (isSPACE_LC(*s))
5773 if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
5777 gimme_scalar = gimme == G_SCALAR && !ary;
5780 limit = maxiters + 2;
5781 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5784 /* this one uses 'm' and is a negative test */
5786 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5787 const int t = UTF8SKIP(m);
5788 /* is_utf8_space returns FALSE for malform utf8 */
5794 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5795 while (m < strend && !isSPACE_LC(*m))
5798 while (m < strend && !isSPACE(*m))
5811 dstr = newSVpvn_flags(s, m-s,
5812 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5816 /* skip the whitespace found last */
5818 s = m + UTF8SKIP(m);
5822 /* this one uses 's' and is a positive test */
5824 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5826 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5827 while (s < strend && isSPACE_LC(*s))
5830 while (s < strend && isSPACE(*s))
5835 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5837 for (m = s; m < strend && *m != '\n'; m++)
5850 dstr = newSVpvn_flags(s, m-s,
5851 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5857 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5859 Pre-extend the stack, either the number of bytes or
5860 characters in the string or a limited amount, triggered by:
5862 my ($x, $y) = split //, $str;
5866 if (!gimme_scalar) {
5867 const U32 items = limit - 1;
5876 /* keep track of how many bytes we skip over */
5886 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5899 dstr = newSVpvn(s, 1);
5915 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5916 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5917 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5918 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5919 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5920 SV * const csv = CALLREG_INTUIT_STRING(rx);
5922 len = RX_MINLENRET(rx);
5923 if (len == 1 && !RX_UTF8(rx) && !tail) {
5924 const char c = *SvPV_nolen_const(csv);
5926 for (m = s; m < strend && *m != c; m++)
5937 dstr = newSVpvn_flags(s, m-s,
5938 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5941 /* The rx->minlen is in characters but we want to step
5942 * s ahead by bytes. */
5944 s = (char*)utf8_hop((U8*)m, len);
5946 s = m + len; /* Fake \n at the end */
5950 while (s < strend && --limit &&
5951 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5952 csv, multiline ? FBMrf_MULTILINE : 0)) )
5961 dstr = newSVpvn_flags(s, m-s,
5962 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5965 /* The rx->minlen is in characters but we want to step
5966 * s ahead by bytes. */
5968 s = (char*)utf8_hop((U8*)m, len);
5970 s = m + len; /* Fake \n at the end */
5975 maxiters += slen * RX_NPARENS(rx);
5976 while (s < strend && --limit)
5980 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
5983 if (rex_return == 0)
5985 TAINT_IF(RX_MATCH_TAINTED(rx));
5986 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
5989 orig = RX_SUBBEG(rx);
5991 strend = s + (strend - m);
5993 m = RX_OFFS(rx)[0].start + orig;
6002 dstr = newSVpvn_flags(s, m-s,
6003 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6006 if (RX_NPARENS(rx)) {
6008 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6009 s = RX_OFFS(rx)[i].start + orig;
6010 m = RX_OFFS(rx)[i].end + orig;
6012 /* japhy (07/27/01) -- the (m && s) test doesn't catch
6013 parens that didn't match -- they should be set to
6014 undef, not the empty string */
6022 if (m >= orig && s >= orig) {
6023 dstr = newSVpvn_flags(s, m-s,
6024 (do_utf8 ? SVf_UTF8 : 0)
6028 dstr = &PL_sv_undef; /* undef, not "" */
6034 s = RX_OFFS(rx)[0].end + orig;
6038 if (!gimme_scalar) {
6039 iters = (SP - PL_stack_base) - base;
6041 if (iters > maxiters)
6042 DIE(aTHX_ "Split loop");
6044 /* keep field after final delim? */
6045 if (s < strend || (iters && origlimit)) {
6046 if (!gimme_scalar) {
6047 const STRLEN l = strend - s;
6048 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6053 else if (!origlimit) {
6055 iters -= trailing_empty;
6057 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6058 if (TOPs && !make_mortal)
6060 *SP-- = &PL_sv_undef;
6067 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6071 if (SvSMAGICAL(ary)) {
6073 mg_set(MUTABLE_SV(ary));
6076 if (gimme == G_ARRAY) {
6078 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6085 ENTER_with_name("call_PUSH");
6086 call_method("PUSH",G_SCALAR|G_DISCARD);
6087 LEAVE_with_name("call_PUSH");
6089 if (gimme == G_ARRAY) {
6091 /* EXTEND should not be needed - we just popped them */
6093 for (i=0; i < iters; i++) {
6094 SV **svp = av_fetch(ary, i, FALSE);
6095 PUSHs((svp) ? *svp : &PL_sv_undef);
6102 if (gimme == G_ARRAY)
6114 SV *const sv = PAD_SVl(PL_op->op_targ);
6116 if (SvPADSTALE(sv)) {
6119 RETURNOP(cLOGOP->op_other);
6121 RETURNOP(cLOGOP->op_next);
6130 assert(SvTYPE(retsv) != SVt_PVCV);
6132 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
6133 retsv = refto(retsv);
6140 PP(unimplemented_op)
6143 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
6151 HV * const hv = (HV*)POPs;
6153 if (SvRMAGICAL(hv)) {
6154 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
6156 XPUSHs(magic_scalarpack(hv, mg));
6161 XPUSHs(boolSV(HvKEYS(hv) != 0));
6167 * c-indentation-style: bsd
6169 * indent-tabs-mode: t
6172 * ex: set ts=8 sts=4 sw=4 noet: