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);
146 sv = amagic_deref_call(sv, to_gv_amg);
150 if (SvTYPE(sv) == SVt_PVIO) {
151 GV * const gv = MUTABLE_GV(sv_newmortal());
152 gv_init(gv, 0, "", 0, 0);
153 GvIOp(gv) = MUTABLE_IO(sv);
154 SvREFCNT_inc_void_NN(sv);
157 else if (!isGV_with_GP(sv))
158 DIE(aTHX_ "Not a GLOB reference");
161 if (!isGV_with_GP(sv)) {
162 if (!SvOK(sv) && sv != &PL_sv_undef) {
163 /* If this is a 'my' scalar and flag is set then vivify
167 Perl_croak_no_modify(aTHX);
168 if (PL_op->op_private & OPpDEREF) {
170 if (cUNOP->op_targ) {
172 SV * const namesv = PAD_SV(cUNOP->op_targ);
173 const char * const name = SvPV(namesv, len);
174 gv = MUTABLE_GV(newSV(0));
175 gv_init(gv, CopSTASH(PL_curcop), name, len, 0);
178 const char * const name = CopSTASHPV(PL_curcop);
181 prepare_SV_for_RV(sv);
182 SvRV_set(sv, MUTABLE_SV(gv));
187 if (PL_op->op_flags & OPf_REF ||
188 PL_op->op_private & HINT_STRICT_REFS)
189 DIE(aTHX_ PL_no_usym, "a symbol");
190 if (ckWARN(WARN_UNINITIALIZED))
194 if ((PL_op->op_flags & OPf_SPECIAL) &&
195 !(PL_op->op_flags & OPf_MOD))
197 SV * const temp = MUTABLE_SV(gv_fetchsv(sv, 0, SVt_PVGV));
199 && (!is_gv_magical_sv(sv,0)
200 || !(sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD,
207 if (PL_op->op_private & HINT_STRICT_REFS)
208 DIE(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), "a symbol");
209 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
210 == OPpDONT_INIT_GV) {
211 /* We are the target of a coderef assignment. Return
212 the scalar unchanged, and let pp_sasssign deal with
216 sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD, SVt_PVGV));
218 /* FAKE globs in the symbol table cause weird bugs (#77810) */
219 if (sv) SvFAKE_off(sv);
222 if (sv && SvFAKE(sv)) {
223 SV *newsv = sv_newmortal();
224 sv_setsv_flags(newsv, sv, 0);
228 if (PL_op->op_private & OPpLVAL_INTRO)
229 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
234 /* Helper function for pp_rv2sv and pp_rv2av */
236 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
237 const svtype type, SV ***spp)
242 PERL_ARGS_ASSERT_SOFTREF2XV;
244 if (PL_op->op_private & HINT_STRICT_REFS) {
246 Perl_die(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), what);
248 Perl_die(aTHX_ PL_no_usym, what);
251 if (PL_op->op_flags & OPf_REF)
252 Perl_die(aTHX_ PL_no_usym, what);
253 if (ckWARN(WARN_UNINITIALIZED))
255 if (type != SVt_PV && GIMME_V == G_ARRAY) {
259 **spp = &PL_sv_undef;
262 if ((PL_op->op_flags & OPf_SPECIAL) &&
263 !(PL_op->op_flags & OPf_MOD))
265 gv = gv_fetchsv(sv, 0, type);
267 && (!is_gv_magical_sv(sv,0)
268 || !(gv = gv_fetchsv(sv, GV_ADD, type))))
270 **spp = &PL_sv_undef;
275 gv = gv_fetchsv(sv, GV_ADD, type);
285 if (!(PL_op->op_private & OPpDEREFed))
289 sv = amagic_deref_call(sv, to_sv_amg);
294 switch (SvTYPE(sv)) {
300 DIE(aTHX_ "Not a SCALAR reference");
307 if (!isGV_with_GP(gv)) {
308 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
314 if (PL_op->op_flags & OPf_MOD) {
315 if (PL_op->op_private & OPpLVAL_INTRO) {
316 if (cUNOP->op_first->op_type == OP_NULL)
317 sv = save_scalar(MUTABLE_GV(TOPs));
319 sv = save_scalar(gv);
321 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
323 else if (PL_op->op_private & OPpDEREF)
324 vivify_ref(sv, PL_op->op_private & OPpDEREF);
333 AV * const av = MUTABLE_AV(TOPs);
334 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
336 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
338 *sv = newSV_type(SVt_PVMG);
339 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
343 SETs(sv_2mortal(newSViv(
344 AvFILL(MUTABLE_AV(av)) + CopARYBASE_get(PL_curcop)
354 if (PL_op->op_flags & OPf_MOD || LVRET) {
355 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
356 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
358 LvTARG(ret) = SvREFCNT_inc_simple(sv);
359 PUSHs(ret); /* no SvSETMAGIC */
363 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
364 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
365 if (mg && mg->mg_len >= 0) {
370 PUSHi(i + CopARYBASE_get(PL_curcop));
383 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
385 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
388 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
389 /* (But not in defined().) */
391 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
394 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
395 if ((PL_op->op_private & OPpLVAL_INTRO)) {
396 if (gv && GvCV(gv) == cv && (gv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), FALSE)))
399 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
402 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
406 cv = MUTABLE_CV(&PL_sv_undef);
407 SETs(MUTABLE_SV(cv));
417 SV *ret = &PL_sv_undef;
419 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
420 const char * s = SvPVX_const(TOPs);
421 if (strnEQ(s, "CORE::", 6)) {
422 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
423 if (code < 0) { /* Overridable. */
424 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
425 int i = 0, n = 0, seen_question = 0, defgv = 0;
427 char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
429 if (code == -KEY_chop || code == -KEY_chomp
430 || code == -KEY_exec || code == -KEY_system)
432 if (code == -KEY_mkdir) {
433 ret = newSVpvs_flags("_;$", SVs_TEMP);
436 if (code == -KEY_keys || code == -KEY_values || code == -KEY_each) {
437 ret = newSVpvs_flags("+", SVs_TEMP);
440 if (code == -KEY_push || code == -KEY_unshift) {
441 ret = newSVpvs_flags("+@", SVs_TEMP);
444 if (code == -KEY_pop || code == -KEY_shift) {
445 ret = newSVpvs_flags(";+", SVs_TEMP);
448 if (code == -KEY_splice) {
449 ret = newSVpvs_flags("+;$$@", SVs_TEMP);
452 if (code == -KEY_tied || code == -KEY_untie) {
453 ret = newSVpvs_flags("\\[$@%*]", SVs_TEMP);
456 if (code == -KEY_tie) {
457 ret = newSVpvs_flags("\\[$@%*]$@", SVs_TEMP);
460 if (code == -KEY_readpipe) {
461 s = "CORE::backtick";
463 while (i < MAXO) { /* The slow way. */
464 if (strEQ(s + 6, PL_op_name[i])
465 || strEQ(s + 6, PL_op_desc[i]))
471 goto nonesuch; /* Should not happen... */
473 defgv = PL_opargs[i] & OA_DEFGV;
474 oa = PL_opargs[i] >> OASHIFT;
476 if (oa & OA_OPTIONAL && !seen_question && !defgv) {
480 if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
481 && (oa & (OA_OPTIONAL - 1)) <= OA_SCALARREF
482 /* But globs are already references (kinda) */
483 && (oa & (OA_OPTIONAL - 1)) != OA_FILEREF
487 str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
490 if (defgv && str[n - 1] == '$')
493 ret = newSVpvn_flags(str, n - 1, SVs_TEMP);
495 else if (code) /* Non-Overridable */
497 else { /* None such */
499 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
503 cv = sv_2cv(TOPs, &stash, &gv, 0);
505 ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
514 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
516 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
518 PUSHs(MUTABLE_SV(cv));
532 if (GIMME != G_ARRAY) {
536 *MARK = &PL_sv_undef;
537 *MARK = refto(*MARK);
541 EXTEND_MORTAL(SP - MARK);
543 *MARK = refto(*MARK);
548 S_refto(pTHX_ SV *sv)
553 PERL_ARGS_ASSERT_REFTO;
555 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
558 if (!(sv = LvTARG(sv)))
561 SvREFCNT_inc_void_NN(sv);
563 else if (SvTYPE(sv) == SVt_PVAV) {
564 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
565 av_reify(MUTABLE_AV(sv));
567 SvREFCNT_inc_void_NN(sv);
569 else if (SvPADTMP(sv) && !IS_PADGV(sv))
573 SvREFCNT_inc_void_NN(sv);
576 sv_upgrade(rv, SVt_IV);
586 SV * const sv = POPs;
591 if (!sv || !SvROK(sv))
594 pv = sv_reftype(SvRV(sv),TRUE);
595 PUSHp(pv, strlen(pv));
605 stash = CopSTASH(PL_curcop);
607 SV * const ssv = POPs;
611 if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
612 Perl_croak(aTHX_ "Attempt to bless into a reference");
613 ptr = SvPV_const(ssv,len);
615 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
616 "Explicit blessing to '' (assuming package main)");
617 stash = gv_stashpvn(ptr, len, GV_ADD);
620 (void)sv_bless(TOPs, stash);
629 const char * const elem = SvPV_nolen_const(sv);
630 GV * const gv = MUTABLE_GV(POPs);
635 /* elem will always be NUL terminated. */
636 const char * const second_letter = elem + 1;
639 if (strEQ(second_letter, "RRAY"))
640 tmpRef = MUTABLE_SV(GvAV(gv));
643 if (strEQ(second_letter, "ODE"))
644 tmpRef = MUTABLE_SV(GvCVu(gv));
647 if (strEQ(second_letter, "ILEHANDLE")) {
648 /* finally deprecated in 5.8.0 */
649 deprecate("*glob{FILEHANDLE}");
650 tmpRef = MUTABLE_SV(GvIOp(gv));
653 if (strEQ(second_letter, "ORMAT"))
654 tmpRef = MUTABLE_SV(GvFORM(gv));
657 if (strEQ(second_letter, "LOB"))
658 tmpRef = MUTABLE_SV(gv);
661 if (strEQ(second_letter, "ASH"))
662 tmpRef = MUTABLE_SV(GvHV(gv));
665 if (*second_letter == 'O' && !elem[2])
666 tmpRef = MUTABLE_SV(GvIOp(gv));
669 if (strEQ(second_letter, "AME"))
670 sv = newSVhek(GvNAME_HEK(gv));
673 if (strEQ(second_letter, "ACKAGE")) {
674 const HV * const stash = GvSTASH(gv);
675 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
676 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
680 if (strEQ(second_letter, "CALAR"))
695 /* Pattern matching */
700 register unsigned char *s;
703 register I32 *sfirst;
707 if (sv == PL_lastscream) {
711 s = (unsigned char*)(SvPV(sv, len));
713 if (pos <= 0 || !SvPOK(sv) || SvUTF8(sv)) {
714 /* No point in studying a zero length string, and not safe to study
715 anything that doesn't appear to be a simple scalar (and hence might
716 change between now and when the regexp engine runs without our set
717 magic ever running) such as a reference to an object with overloaded
723 SvSCREAM_off(PL_lastscream);
724 SvREFCNT_dec(PL_lastscream);
726 PL_lastscream = SvREFCNT_inc_simple(sv);
728 s = (unsigned char*)(SvPV(sv, len));
732 if (pos > PL_maxscream) {
733 if (PL_maxscream < 0) {
734 PL_maxscream = pos + 80;
735 Newx(PL_screamfirst, 256, I32);
736 Newx(PL_screamnext, PL_maxscream, I32);
739 PL_maxscream = pos + pos / 4;
740 Renew(PL_screamnext, PL_maxscream, I32);
744 sfirst = PL_screamfirst;
745 snext = PL_screamnext;
747 if (!sfirst || !snext)
748 DIE(aTHX_ "do_study: out of memory");
750 for (ch = 256; ch; --ch)
755 register const I32 ch = s[pos];
757 snext[pos] = sfirst[ch] - pos;
764 /* piggyback on m//g magic */
765 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
774 if (PL_op->op_flags & OPf_STACKED)
776 else if (PL_op->op_private & OPpTARGET_MY)
782 TARG = sv_newmortal();
783 if(PL_op->op_type == OP_TRANSR) {
784 SV * const newsv = newSVsv(sv);
788 else PUSHi(do_trans(sv));
792 /* Lvalue operators. */
804 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
806 do_chop(TARG, *++MARK);
815 SETi(do_chomp(TOPs));
821 dVAR; dSP; dMARK; dTARGET;
822 register I32 count = 0;
825 count += do_chomp(POPs);
835 if (!PL_op->op_private) {
844 SV_CHECK_THINKFIRST_COW_DROP(sv);
846 switch (SvTYPE(sv)) {
850 av_undef(MUTABLE_AV(sv));
853 hv_undef(MUTABLE_HV(sv));
856 if (cv_const_sv((const CV *)sv))
857 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
858 CvANON((const CV *)sv) ? "(anonymous)"
859 : GvENAME(CvGV((const CV *)sv)));
863 /* let user-undef'd sub keep its identity */
864 GV* const gv = CvGV((const CV *)sv);
865 cv_undef(MUTABLE_CV(sv));
866 CvGV_set(MUTABLE_CV(sv), gv);
871 SvSetMagicSV(sv, &PL_sv_undef);
874 else if (isGV_with_GP(sv)) {
878 /* undef *Pkg::meth_name ... */
880 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
881 && HvENAME_get(stash);
883 if((stash = GvHV((const GV *)sv))) {
884 if(HvENAME_get(stash))
885 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
889 gp_free(MUTABLE_GV(sv));
891 GvGP(sv) = gp_ref(gp);
893 GvLINE(sv) = CopLINE(PL_curcop);
894 GvEGV(sv) = MUTABLE_GV(sv);
898 mro_package_moved(NULL, stash, (const GV *)sv, 0);
900 /* undef *Foo::ISA */
901 if( strEQ(GvNAME((const GV *)sv), "ISA")
902 && (stash = GvSTASH((const GV *)sv))
903 && (method_changed || HvENAME(stash)) )
904 mro_isa_changed_in(stash);
905 else if(method_changed)
906 mro_method_changed_in(
907 GvSTASH((const GV *)sv)
914 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
929 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
930 Perl_croak_no_modify(aTHX);
931 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
932 && SvIVX(TOPs) != IV_MIN)
934 SvIV_set(TOPs, SvIVX(TOPs) - 1);
935 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
946 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
947 Perl_croak_no_modify(aTHX);
949 TARG = sv_newmortal();
950 sv_setsv(TARG, TOPs);
951 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
952 && SvIVX(TOPs) != IV_MAX)
954 SvIV_set(TOPs, SvIVX(TOPs) + 1);
955 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
960 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
970 if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
971 Perl_croak_no_modify(aTHX);
973 TARG = sv_newmortal();
974 sv_setsv(TARG, TOPs);
975 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
976 && SvIVX(TOPs) != IV_MIN)
978 SvIV_set(TOPs, SvIVX(TOPs) - 1);
979 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
988 /* Ordinary operators. */
992 dVAR; dSP; dATARGET; SV *svl, *svr;
993 #ifdef PERL_PRESERVE_IVUV
996 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
999 #ifdef PERL_PRESERVE_IVUV
1000 /* For integer to integer power, we do the calculation by hand wherever
1001 we're sure it is safe; otherwise we call pow() and try to convert to
1002 integer afterwards. */
1004 SvIV_please_nomg(svr);
1006 SvIV_please_nomg(svl);
1015 const IV iv = SvIVX(svr);
1019 goto float_it; /* Can't do negative powers this way. */
1023 baseuok = SvUOK(svl);
1025 baseuv = SvUVX(svl);
1027 const IV iv = SvIVX(svl);
1030 baseuok = TRUE; /* effectively it's a UV now */
1032 baseuv = -iv; /* abs, baseuok == false records sign */
1035 /* now we have integer ** positive integer. */
1038 /* foo & (foo - 1) is zero only for a power of 2. */
1039 if (!(baseuv & (baseuv - 1))) {
1040 /* We are raising power-of-2 to a positive integer.
1041 The logic here will work for any base (even non-integer
1042 bases) but it can be less accurate than
1043 pow (base,power) or exp (power * log (base)) when the
1044 intermediate values start to spill out of the mantissa.
1045 With powers of 2 we know this can't happen.
1046 And powers of 2 are the favourite thing for perl
1047 programmers to notice ** not doing what they mean. */
1049 NV base = baseuok ? baseuv : -(NV)baseuv;
1054 while (power >>= 1) {
1062 SvIV_please_nomg(svr);
1065 register unsigned int highbit = 8 * sizeof(UV);
1066 register unsigned int diff = 8 * sizeof(UV);
1067 while (diff >>= 1) {
1069 if (baseuv >> highbit) {
1073 /* we now have baseuv < 2 ** highbit */
1074 if (power * highbit <= 8 * sizeof(UV)) {
1075 /* result will definitely fit in UV, so use UV math
1076 on same algorithm as above */
1077 register UV result = 1;
1078 register UV base = baseuv;
1079 const bool odd_power = cBOOL(power & 1);
1083 while (power >>= 1) {
1090 if (baseuok || !odd_power)
1091 /* answer is positive */
1093 else if (result <= (UV)IV_MAX)
1094 /* answer negative, fits in IV */
1095 SETi( -(IV)result );
1096 else if (result == (UV)IV_MIN)
1097 /* 2's complement assumption: special case IV_MIN */
1100 /* answer negative, doesn't fit */
1101 SETn( -(NV)result );
1111 NV right = SvNV_nomg(svr);
1112 NV left = SvNV_nomg(svl);
1115 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1117 We are building perl with long double support and are on an AIX OS
1118 afflicted with a powl() function that wrongly returns NaNQ for any
1119 negative base. This was reported to IBM as PMR #23047-379 on
1120 03/06/2006. The problem exists in at least the following versions
1121 of AIX and the libm fileset, and no doubt others as well:
1123 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1124 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1125 AIX 5.2.0 bos.adt.libm 5.2.0.85
1127 So, until IBM fixes powl(), we provide the following workaround to
1128 handle the problem ourselves. Our logic is as follows: for
1129 negative bases (left), we use fmod(right, 2) to check if the
1130 exponent is an odd or even integer:
1132 - if odd, powl(left, right) == -powl(-left, right)
1133 - if even, powl(left, right) == powl(-left, right)
1135 If the exponent is not an integer, the result is rightly NaNQ, so
1136 we just return that (as NV_NAN).
1140 NV mod2 = Perl_fmod( right, 2.0 );
1141 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1142 SETn( -Perl_pow( -left, right) );
1143 } else if (mod2 == 0.0) { /* even integer */
1144 SETn( Perl_pow( -left, right) );
1145 } else { /* fractional power */
1149 SETn( Perl_pow( left, right) );
1152 SETn( Perl_pow( left, right) );
1153 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1155 #ifdef PERL_PRESERVE_IVUV
1157 SvIV_please_nomg(svr);
1165 dVAR; dSP; dATARGET; SV *svl, *svr;
1166 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1169 #ifdef PERL_PRESERVE_IVUV
1170 SvIV_please_nomg(svr);
1172 /* Unless the left argument is integer in range we are going to have to
1173 use NV maths. Hence only attempt to coerce the right argument if
1174 we know the left is integer. */
1175 /* Left operand is defined, so is it IV? */
1176 SvIV_please_nomg(svl);
1178 bool auvok = SvUOK(svl);
1179 bool buvok = SvUOK(svr);
1180 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1181 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1190 const IV aiv = SvIVX(svl);
1193 auvok = TRUE; /* effectively it's a UV now */
1195 alow = -aiv; /* abs, auvok == false records sign */
1201 const IV biv = SvIVX(svr);
1204 buvok = TRUE; /* effectively it's a UV now */
1206 blow = -biv; /* abs, buvok == false records sign */
1210 /* If this does sign extension on unsigned it's time for plan B */
1211 ahigh = alow >> (4 * sizeof (UV));
1213 bhigh = blow >> (4 * sizeof (UV));
1215 if (ahigh && bhigh) {
1217 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1218 which is overflow. Drop to NVs below. */
1219 } else if (!ahigh && !bhigh) {
1220 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1221 so the unsigned multiply cannot overflow. */
1222 const UV product = alow * blow;
1223 if (auvok == buvok) {
1224 /* -ve * -ve or +ve * +ve gives a +ve result. */
1228 } else if (product <= (UV)IV_MIN) {
1229 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1230 /* -ve result, which could overflow an IV */
1232 SETi( -(IV)product );
1234 } /* else drop to NVs below. */
1236 /* One operand is large, 1 small */
1239 /* swap the operands */
1241 bhigh = blow; /* bhigh now the temp var for the swap */
1245 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1246 multiplies can't overflow. shift can, add can, -ve can. */
1247 product_middle = ahigh * blow;
1248 if (!(product_middle & topmask)) {
1249 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1251 product_middle <<= (4 * sizeof (UV));
1252 product_low = alow * blow;
1254 /* as for pp_add, UV + something mustn't get smaller.
1255 IIRC ANSI mandates this wrapping *behaviour* for
1256 unsigned whatever the actual representation*/
1257 product_low += product_middle;
1258 if (product_low >= product_middle) {
1259 /* didn't overflow */
1260 if (auvok == buvok) {
1261 /* -ve * -ve or +ve * +ve gives a +ve result. */
1263 SETu( product_low );
1265 } else if (product_low <= (UV)IV_MIN) {
1266 /* 2s complement assumption again */
1267 /* -ve result, which could overflow an IV */
1269 SETi( -(IV)product_low );
1271 } /* else drop to NVs below. */
1273 } /* product_middle too large */
1274 } /* ahigh && bhigh */
1279 NV right = SvNV_nomg(svr);
1280 NV left = SvNV_nomg(svl);
1282 SETn( left * right );
1289 dVAR; dSP; dATARGET; SV *svl, *svr;
1290 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1293 /* Only try to do UV divide first
1294 if ((SLOPPYDIVIDE is true) or
1295 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1297 The assumption is that it is better to use floating point divide
1298 whenever possible, only doing integer divide first if we can't be sure.
1299 If NV_PRESERVES_UV is true then we know at compile time that no UV
1300 can be too large to preserve, so don't need to compile the code to
1301 test the size of UVs. */
1304 # define PERL_TRY_UV_DIVIDE
1305 /* ensure that 20./5. == 4. */
1307 # ifdef PERL_PRESERVE_IVUV
1308 # ifndef NV_PRESERVES_UV
1309 # define PERL_TRY_UV_DIVIDE
1314 #ifdef PERL_TRY_UV_DIVIDE
1315 SvIV_please_nomg(svr);
1317 SvIV_please_nomg(svl);
1319 bool left_non_neg = SvUOK(svl);
1320 bool right_non_neg = SvUOK(svr);
1324 if (right_non_neg) {
1328 const IV biv = SvIVX(svr);
1331 right_non_neg = TRUE; /* effectively it's a UV now */
1337 /* historically undef()/0 gives a "Use of uninitialized value"
1338 warning before dieing, hence this test goes here.
1339 If it were immediately before the second SvIV_please, then
1340 DIE() would be invoked before left was even inspected, so
1341 no inpsection would give no warning. */
1343 DIE(aTHX_ "Illegal division by zero");
1349 const IV aiv = SvIVX(svl);
1352 left_non_neg = TRUE; /* effectively it's a UV now */
1361 /* For sloppy divide we always attempt integer division. */
1363 /* Otherwise we only attempt it if either or both operands
1364 would not be preserved by an NV. If both fit in NVs
1365 we fall through to the NV divide code below. However,
1366 as left >= right to ensure integer result here, we know that
1367 we can skip the test on the right operand - right big
1368 enough not to be preserved can't get here unless left is
1371 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1374 /* Integer division can't overflow, but it can be imprecise. */
1375 const UV result = left / right;
1376 if (result * right == left) {
1377 SP--; /* result is valid */
1378 if (left_non_neg == right_non_neg) {
1379 /* signs identical, result is positive. */
1383 /* 2s complement assumption */
1384 if (result <= (UV)IV_MIN)
1385 SETi( -(IV)result );
1387 /* It's exact but too negative for IV. */
1388 SETn( -(NV)result );
1391 } /* tried integer divide but it was not an integer result */
1392 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1393 } /* left wasn't SvIOK */
1394 } /* right wasn't SvIOK */
1395 #endif /* PERL_TRY_UV_DIVIDE */
1397 NV right = SvNV_nomg(svr);
1398 NV left = SvNV_nomg(svl);
1399 (void)POPs;(void)POPs;
1400 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1401 if (! Perl_isnan(right) && right == 0.0)
1405 DIE(aTHX_ "Illegal division by zero");
1406 PUSHn( left / right );
1413 dVAR; dSP; dATARGET;
1414 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1418 bool left_neg = FALSE;
1419 bool right_neg = FALSE;
1420 bool use_double = FALSE;
1421 bool dright_valid = FALSE;
1424 SV * const svr = TOPs;
1425 SV * const svl = TOPm1s;
1426 SvIV_please_nomg(svr);
1428 right_neg = !SvUOK(svr);
1432 const IV biv = SvIVX(svr);
1435 right_neg = FALSE; /* effectively it's a UV now */
1442 dright = SvNV_nomg(svr);
1443 right_neg = dright < 0;
1446 if (dright < UV_MAX_P1) {
1447 right = U_V(dright);
1448 dright_valid = TRUE; /* In case we need to use double below. */
1454 /* At this point use_double is only true if right is out of range for
1455 a UV. In range NV has been rounded down to nearest UV and
1456 use_double false. */
1457 SvIV_please_nomg(svl);
1458 if (!use_double && SvIOK(svl)) {
1460 left_neg = !SvUOK(svl);
1464 const IV aiv = SvIVX(svl);
1467 left_neg = FALSE; /* effectively it's a UV now */
1475 dleft = SvNV_nomg(svl);
1476 left_neg = dleft < 0;
1480 /* This should be exactly the 5.6 behaviour - if left and right are
1481 both in range for UV then use U_V() rather than floor. */
1483 if (dleft < UV_MAX_P1) {
1484 /* right was in range, so is dleft, so use UVs not double.
1488 /* left is out of range for UV, right was in range, so promote
1489 right (back) to double. */
1491 /* The +0.5 is used in 5.6 even though it is not strictly
1492 consistent with the implicit +0 floor in the U_V()
1493 inside the #if 1. */
1494 dleft = Perl_floor(dleft + 0.5);
1497 dright = Perl_floor(dright + 0.5);
1508 DIE(aTHX_ "Illegal modulus zero");
1510 dans = Perl_fmod(dleft, dright);
1511 if ((left_neg != right_neg) && dans)
1512 dans = dright - dans;
1515 sv_setnv(TARG, dans);
1521 DIE(aTHX_ "Illegal modulus zero");
1524 if ((left_neg != right_neg) && ans)
1527 /* XXX may warn: unary minus operator applied to unsigned type */
1528 /* could change -foo to be (~foo)+1 instead */
1529 if (ans <= ~((UV)IV_MAX)+1)
1530 sv_setiv(TARG, ~ans+1);
1532 sv_setnv(TARG, -(NV)ans);
1535 sv_setuv(TARG, ans);
1544 dVAR; dSP; dATARGET;
1548 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1549 /* TODO: think of some way of doing list-repeat overloading ??? */
1554 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1560 const UV uv = SvUV_nomg(sv);
1562 count = IV_MAX; /* The best we can do? */
1566 const IV iv = SvIV_nomg(sv);
1573 else if (SvNOKp(sv)) {
1574 const NV nv = SvNV_nomg(sv);
1581 count = SvIV_nomg(sv);
1583 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1585 static const char oom_list_extend[] = "Out of memory during list extend";
1586 const I32 items = SP - MARK;
1587 const I32 max = items * count;
1589 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1590 /* Did the max computation overflow? */
1591 if (items > 0 && max > 0 && (max < items || max < count))
1592 Perl_croak(aTHX_ oom_list_extend);
1597 /* This code was intended to fix 20010809.028:
1600 for (($x =~ /./g) x 2) {
1601 print chop; # "abcdabcd" expected as output.
1604 * but that change (#11635) broke this code:
1606 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1608 * I can't think of a better fix that doesn't introduce
1609 * an efficiency hit by copying the SVs. The stack isn't
1610 * refcounted, and mortalisation obviously doesn't
1611 * Do The Right Thing when the stack has more than
1612 * one pointer to the same mortal value.
1616 *SP = sv_2mortal(newSVsv(*SP));
1626 repeatcpy((char*)(MARK + items), (char*)MARK,
1627 items * sizeof(const SV *), count - 1);
1630 else if (count <= 0)
1633 else { /* Note: mark already snarfed by pp_list */
1634 SV * const tmpstr = POPs;
1637 static const char oom_string_extend[] =
1638 "Out of memory during string extend";
1641 sv_setsv_nomg(TARG, tmpstr);
1642 SvPV_force_nomg(TARG, len);
1643 isutf = DO_UTF8(TARG);
1648 const STRLEN max = (UV)count * len;
1649 if (len > MEM_SIZE_MAX / count)
1650 Perl_croak(aTHX_ oom_string_extend);
1651 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1652 SvGROW(TARG, max + 1);
1653 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1654 SvCUR_set(TARG, SvCUR(TARG) * count);
1656 *SvEND(TARG) = '\0';
1659 (void)SvPOK_only_UTF8(TARG);
1661 (void)SvPOK_only(TARG);
1663 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1664 /* The parser saw this as a list repeat, and there
1665 are probably several items on the stack. But we're
1666 in scalar context, and there's no pp_list to save us
1667 now. So drop the rest of the items -- robin@kitsite.com
1679 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1680 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1683 useleft = USE_LEFT(svl);
1684 #ifdef PERL_PRESERVE_IVUV
1685 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1686 "bad things" happen if you rely on signed integers wrapping. */
1687 SvIV_please_nomg(svr);
1689 /* Unless the left argument is integer in range we are going to have to
1690 use NV maths. Hence only attempt to coerce the right argument if
1691 we know the left is integer. */
1692 register UV auv = 0;
1698 a_valid = auvok = 1;
1699 /* left operand is undef, treat as zero. */
1701 /* Left operand is defined, so is it IV? */
1702 SvIV_please_nomg(svl);
1704 if ((auvok = SvUOK(svl)))
1707 register const IV aiv = SvIVX(svl);
1710 auvok = 1; /* Now acting as a sign flag. */
1711 } else { /* 2s complement assumption for IV_MIN */
1719 bool result_good = 0;
1722 bool buvok = SvUOK(svr);
1727 register const IV biv = SvIVX(svr);
1734 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1735 else "IV" now, independent of how it came in.
1736 if a, b represents positive, A, B negative, a maps to -A etc
1741 all UV maths. negate result if A negative.
1742 subtract if signs same, add if signs differ. */
1744 if (auvok ^ buvok) {
1753 /* Must get smaller */
1758 if (result <= buv) {
1759 /* result really should be -(auv-buv). as its negation
1760 of true value, need to swap our result flag */
1772 if (result <= (UV)IV_MIN)
1773 SETi( -(IV)result );
1775 /* result valid, but out of range for IV. */
1776 SETn( -(NV)result );
1780 } /* Overflow, drop through to NVs. */
1785 NV value = SvNV_nomg(svr);
1789 /* left operand is undef, treat as zero - value */
1793 SETn( SvNV_nomg(svl) - value );
1800 dVAR; dSP; dATARGET; SV *svl, *svr;
1801 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1805 const IV shift = SvIV_nomg(svr);
1806 if (PL_op->op_private & HINT_INTEGER) {
1807 const IV i = SvIV_nomg(svl);
1811 const UV u = SvUV_nomg(svl);
1820 dVAR; dSP; dATARGET; SV *svl, *svr;
1821 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
1825 const IV shift = SvIV_nomg(svr);
1826 if (PL_op->op_private & HINT_INTEGER) {
1827 const IV i = SvIV_nomg(svl);
1831 const UV u = SvUV_nomg(svl);
1841 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
1842 #ifdef PERL_PRESERVE_IVUV
1843 SvIV_please_nomg(TOPs);
1845 SvIV_please_nomg(TOPm1s);
1846 if (SvIOK(TOPm1s)) {
1847 bool auvok = SvUOK(TOPm1s);
1848 bool buvok = SvUOK(TOPs);
1850 if (!auvok && !buvok) { /* ## IV < IV ## */
1851 const IV aiv = SvIVX(TOPm1s);
1852 const IV biv = SvIVX(TOPs);
1855 SETs(boolSV(aiv < biv));
1858 if (auvok && buvok) { /* ## UV < UV ## */
1859 const UV auv = SvUVX(TOPm1s);
1860 const UV buv = SvUVX(TOPs);
1863 SETs(boolSV(auv < buv));
1866 if (auvok) { /* ## UV < IV ## */
1868 const IV biv = SvIVX(TOPs);
1871 /* As (a) is a UV, it's >=0, so it cannot be < */
1876 SETs(boolSV(auv < (UV)biv));
1879 { /* ## IV < UV ## */
1880 const IV aiv = SvIVX(TOPm1s);
1884 /* As (b) is a UV, it's >=0, so it must be < */
1891 SETs(boolSV((UV)aiv < buv));
1897 #ifndef NV_PRESERVES_UV
1898 #ifdef PERL_PRESERVE_IVUV
1901 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1903 SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s)));
1908 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1910 if (Perl_isnan(left) || Perl_isnan(right))
1912 SETs(boolSV(left < right));
1915 SETs(boolSV(SvNV_nomg(TOPs) < value));
1924 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1925 #ifdef PERL_PRESERVE_IVUV
1926 SvIV_please_nomg(TOPs);
1928 SvIV_please_nomg(TOPm1s);
1929 if (SvIOK(TOPm1s)) {
1930 bool auvok = SvUOK(TOPm1s);
1931 bool buvok = SvUOK(TOPs);
1933 if (!auvok && !buvok) { /* ## IV > IV ## */
1934 const IV aiv = SvIVX(TOPm1s);
1935 const IV biv = SvIVX(TOPs);
1938 SETs(boolSV(aiv > biv));
1941 if (auvok && buvok) { /* ## UV > UV ## */
1942 const UV auv = SvUVX(TOPm1s);
1943 const UV buv = SvUVX(TOPs);
1946 SETs(boolSV(auv > buv));
1949 if (auvok) { /* ## UV > IV ## */
1951 const IV biv = SvIVX(TOPs);
1955 /* As (a) is a UV, it's >=0, so it must be > */
1960 SETs(boolSV(auv > (UV)biv));
1963 { /* ## IV > UV ## */
1964 const IV aiv = SvIVX(TOPm1s);
1968 /* As (b) is a UV, it's >=0, so it cannot be > */
1975 SETs(boolSV((UV)aiv > buv));
1981 #ifndef NV_PRESERVES_UV
1982 #ifdef PERL_PRESERVE_IVUV
1985 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
1987 SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s)));
1992 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1994 if (Perl_isnan(left) || Perl_isnan(right))
1996 SETs(boolSV(left > right));
1999 SETs(boolSV(SvNV_nomg(TOPs) > value));
2008 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
2009 #ifdef PERL_PRESERVE_IVUV
2010 SvIV_please_nomg(TOPs);
2012 SvIV_please_nomg(TOPm1s);
2013 if (SvIOK(TOPm1s)) {
2014 bool auvok = SvUOK(TOPm1s);
2015 bool buvok = SvUOK(TOPs);
2017 if (!auvok && !buvok) { /* ## IV <= IV ## */
2018 const IV aiv = SvIVX(TOPm1s);
2019 const IV biv = SvIVX(TOPs);
2022 SETs(boolSV(aiv <= biv));
2025 if (auvok && buvok) { /* ## UV <= UV ## */
2026 UV auv = SvUVX(TOPm1s);
2027 UV buv = SvUVX(TOPs);
2030 SETs(boolSV(auv <= buv));
2033 if (auvok) { /* ## UV <= IV ## */
2035 const IV biv = SvIVX(TOPs);
2039 /* As (a) is a UV, it's >=0, so a cannot be <= */
2044 SETs(boolSV(auv <= (UV)biv));
2047 { /* ## IV <= UV ## */
2048 const IV aiv = SvIVX(TOPm1s);
2052 /* As (b) is a UV, it's >=0, so a must be <= */
2059 SETs(boolSV((UV)aiv <= buv));
2065 #ifndef NV_PRESERVES_UV
2066 #ifdef PERL_PRESERVE_IVUV
2069 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2071 SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s)));
2076 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2078 if (Perl_isnan(left) || Perl_isnan(right))
2080 SETs(boolSV(left <= right));
2083 SETs(boolSV(SvNV_nomg(TOPs) <= value));
2092 tryAMAGICbin_MG(ge_amg,AMGf_set|AMGf_numeric);
2093 #ifdef PERL_PRESERVE_IVUV
2094 SvIV_please_nomg(TOPs);
2096 SvIV_please_nomg(TOPm1s);
2097 if (SvIOK(TOPm1s)) {
2098 bool auvok = SvUOK(TOPm1s);
2099 bool buvok = SvUOK(TOPs);
2101 if (!auvok && !buvok) { /* ## IV >= IV ## */
2102 const IV aiv = SvIVX(TOPm1s);
2103 const IV biv = SvIVX(TOPs);
2106 SETs(boolSV(aiv >= biv));
2109 if (auvok && buvok) { /* ## UV >= UV ## */
2110 const UV auv = SvUVX(TOPm1s);
2111 const UV buv = SvUVX(TOPs);
2114 SETs(boolSV(auv >= buv));
2117 if (auvok) { /* ## UV >= IV ## */
2119 const IV biv = SvIVX(TOPs);
2123 /* As (a) is a UV, it's >=0, so it must be >= */
2128 SETs(boolSV(auv >= (UV)biv));
2131 { /* ## IV >= UV ## */
2132 const IV aiv = SvIVX(TOPm1s);
2136 /* As (b) is a UV, it's >=0, so a cannot be >= */
2143 SETs(boolSV((UV)aiv >= buv));
2149 #ifndef NV_PRESERVES_UV
2150 #ifdef PERL_PRESERVE_IVUV
2153 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2155 SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s)));
2160 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2162 if (Perl_isnan(left) || Perl_isnan(right))
2164 SETs(boolSV(left >= right));
2167 SETs(boolSV(SvNV_nomg(TOPs) >= value));
2176 tryAMAGICbin_MG(ne_amg,AMGf_set|AMGf_numeric);
2177 #ifndef NV_PRESERVES_UV
2178 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2180 SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
2184 #ifdef PERL_PRESERVE_IVUV
2185 SvIV_please_nomg(TOPs);
2187 SvIV_please_nomg(TOPm1s);
2188 if (SvIOK(TOPm1s)) {
2189 const bool auvok = SvUOK(TOPm1s);
2190 const bool buvok = SvUOK(TOPs);
2192 if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
2193 /* Casting IV to UV before comparison isn't going to matter
2194 on 2s complement. On 1s complement or sign&magnitude
2195 (if we have any of them) it could make negative zero
2196 differ from normal zero. As I understand it. (Need to
2197 check - is negative zero implementation defined behaviour
2199 const UV buv = SvUVX(POPs);
2200 const UV auv = SvUVX(TOPs);
2202 SETs(boolSV(auv != buv));
2205 { /* ## Mixed IV,UV ## */
2209 /* != is commutative so swap if needed (save code) */
2211 /* swap. top of stack (b) is the iv */
2215 /* As (a) is a UV, it's >0, so it cannot be == */
2224 /* As (b) is a UV, it's >0, so it cannot be == */
2228 uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */
2230 SETs(boolSV((UV)iv != uv));
2237 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2239 if (Perl_isnan(left) || Perl_isnan(right))
2241 SETs(boolSV(left != right));
2244 SETs(boolSV(SvNV_nomg(TOPs) != value));
2253 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2254 #ifndef NV_PRESERVES_UV
2255 if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
2256 const UV right = PTR2UV(SvRV(POPs));
2257 const UV left = PTR2UV(SvRV(TOPs));
2258 SETi((left > right) - (left < right));
2262 #ifdef PERL_PRESERVE_IVUV
2263 /* Fortunately it seems NaN isn't IOK */
2264 SvIV_please_nomg(TOPs);
2266 SvIV_please_nomg(TOPm1s);
2267 if (SvIOK(TOPm1s)) {
2268 const bool leftuvok = SvUOK(TOPm1s);
2269 const bool rightuvok = SvUOK(TOPs);
2271 if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */
2272 const IV leftiv = SvIVX(TOPm1s);
2273 const IV rightiv = SvIVX(TOPs);
2275 if (leftiv > rightiv)
2277 else if (leftiv < rightiv)
2281 } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */
2282 const UV leftuv = SvUVX(TOPm1s);
2283 const UV rightuv = SvUVX(TOPs);
2285 if (leftuv > rightuv)
2287 else if (leftuv < rightuv)
2291 } else if (leftuvok) { /* ## UV <=> IV ## */
2292 const IV rightiv = SvIVX(TOPs);
2294 /* As (a) is a UV, it's >=0, so it cannot be < */
2297 const UV leftuv = SvUVX(TOPm1s);
2298 if (leftuv > (UV)rightiv) {
2300 } else if (leftuv < (UV)rightiv) {
2306 } else { /* ## IV <=> UV ## */
2307 const IV leftiv = SvIVX(TOPm1s);
2309 /* As (b) is a UV, it's >=0, so it must be < */
2312 const UV rightuv = SvUVX(TOPs);
2313 if ((UV)leftiv > rightuv) {
2315 } else if ((UV)leftiv < rightuv) {
2333 if (Perl_isnan(left) || Perl_isnan(right)) {
2337 value = (left > right) - (left < right);
2341 else if (left < right)
2343 else if (left > right)
2359 int amg_type = sle_amg;
2363 switch (PL_op->op_type) {
2382 tryAMAGICbin_MG(amg_type, AMGf_set);
2385 const int cmp = (IN_LOCALE_RUNTIME
2386 ? sv_cmp_locale_flags(left, right, 0)
2387 : sv_cmp_flags(left, right, 0));
2388 SETs(boolSV(cmp * multiplier < rhs));
2396 tryAMAGICbin_MG(seq_amg, AMGf_set);
2399 SETs(boolSV(sv_eq_flags(left, right, 0)));
2407 tryAMAGICbin_MG(sne_amg, AMGf_set);
2410 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2418 tryAMAGICbin_MG(scmp_amg, 0);
2421 const int cmp = (IN_LOCALE_RUNTIME
2422 ? sv_cmp_locale_flags(left, right, 0)
2423 : sv_cmp_flags(left, right, 0));
2431 dVAR; dSP; dATARGET;
2432 tryAMAGICbin_MG(band_amg, AMGf_assign);
2435 if (SvNIOKp(left) || SvNIOKp(right)) {
2436 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2437 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2438 if (PL_op->op_private & HINT_INTEGER) {
2439 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2443 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2446 if (left_ro_nonnum) SvNIOK_off(left);
2447 if (right_ro_nonnum) SvNIOK_off(right);
2450 do_vop(PL_op->op_type, TARG, left, right);
2459 dVAR; dSP; dATARGET;
2460 const int op_type = PL_op->op_type;
2462 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2465 if (SvNIOKp(left) || SvNIOKp(right)) {
2466 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2467 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2468 if (PL_op->op_private & HINT_INTEGER) {
2469 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2470 const IV r = SvIV_nomg(right);
2471 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2475 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2476 const UV r = SvUV_nomg(right);
2477 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2480 if (left_ro_nonnum) SvNIOK_off(left);
2481 if (right_ro_nonnum) SvNIOK_off(right);
2484 do_vop(op_type, TARG, left, right);
2494 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2496 SV * const sv = TOPs;
2497 const int flags = SvFLAGS(sv);
2499 if( !SvNIOK( sv ) && looks_like_number( sv ) ){
2503 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2504 /* It's publicly an integer, or privately an integer-not-float */
2507 if (SvIVX(sv) == IV_MIN) {
2508 /* 2s complement assumption. */
2509 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2512 else if (SvUVX(sv) <= IV_MAX) {
2517 else if (SvIVX(sv) != IV_MIN) {
2521 #ifdef PERL_PRESERVE_IVUV
2529 SETn(-SvNV_nomg(sv));
2530 else if (SvPOKp(sv)) {
2532 const char * const s = SvPV_nomg_const(sv, len);
2533 if (isIDFIRST(*s)) {
2534 sv_setpvs(TARG, "-");
2537 else if (*s == '+' || *s == '-') {
2538 sv_setsv_nomg(TARG, sv);
2539 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2541 else if (DO_UTF8(sv)) {
2542 SvIV_please_nomg(sv);
2544 goto oops_its_an_int;
2546 sv_setnv(TARG, -SvNV_nomg(sv));
2548 sv_setpvs(TARG, "-");
2553 SvIV_please_nomg(sv);
2555 goto oops_its_an_int;
2556 sv_setnv(TARG, -SvNV_nomg(sv));
2561 SETn(-SvNV_nomg(sv));
2569 tryAMAGICun_MG(not_amg, AMGf_set);
2570 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2577 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2581 if (PL_op->op_private & HINT_INTEGER) {
2582 const IV i = ~SvIV_nomg(sv);
2586 const UV u = ~SvUV_nomg(sv);
2595 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2596 sv_setsv_nomg(TARG, sv);
2597 tmps = (U8*)SvPV_force_nomg(TARG, len);
2600 /* Calculate exact length, let's not estimate. */
2605 U8 * const send = tmps + len;
2606 U8 * const origtmps = tmps;
2607 const UV utf8flags = UTF8_ALLOW_ANYUV;
2609 while (tmps < send) {
2610 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2612 targlen += UNISKIP(~c);
2618 /* Now rewind strings and write them. */
2625 Newx(result, targlen + 1, U8);
2627 while (tmps < send) {
2628 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2630 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2633 sv_usepvn_flags(TARG, (char*)result, targlen,
2634 SV_HAS_TRAILING_NUL);
2641 Newx(result, nchar + 1, U8);
2643 while (tmps < send) {
2644 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2649 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2657 register long *tmpl;
2658 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2661 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2666 for ( ; anum > 0; anum--, tmps++)
2674 /* integer versions of some of the above */
2678 dVAR; dSP; dATARGET;
2679 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2682 SETi( left * right );
2690 dVAR; dSP; dATARGET;
2691 tryAMAGICbin_MG(div_amg, AMGf_assign);
2694 IV value = SvIV_nomg(right);
2696 DIE(aTHX_ "Illegal division by zero");
2697 num = SvIV_nomg(left);
2699 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2703 value = num / value;
2709 #if defined(__GLIBC__) && IVSIZE == 8
2716 /* This is the vanilla old i_modulo. */
2717 dVAR; dSP; dATARGET;
2718 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2722 DIE(aTHX_ "Illegal modulus zero");
2723 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2727 SETi( left % right );
2732 #if defined(__GLIBC__) && IVSIZE == 8
2737 /* This is the i_modulo with the workaround for the _moddi3 bug
2738 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2739 * See below for pp_i_modulo. */
2740 dVAR; dSP; dATARGET;
2741 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2745 DIE(aTHX_ "Illegal modulus zero");
2746 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2750 SETi( left % PERL_ABS(right) );
2757 dVAR; dSP; dATARGET;
2758 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2762 DIE(aTHX_ "Illegal modulus zero");
2763 /* The assumption is to use hereafter the old vanilla version... */
2765 PL_ppaddr[OP_I_MODULO] =
2767 /* .. but if we have glibc, we might have a buggy _moddi3
2768 * (at least glicb 2.2.5 is known to have this bug), in other
2769 * words our integer modulus with negative quad as the second
2770 * argument might be broken. Test for this and re-patch the
2771 * opcode dispatch table if that is the case, remembering to
2772 * also apply the workaround so that this first round works
2773 * right, too. See [perl #9402] for more information. */
2777 /* Cannot do this check with inlined IV constants since
2778 * that seems to work correctly even with the buggy glibc. */
2780 /* Yikes, we have the bug.
2781 * Patch in the workaround version. */
2783 PL_ppaddr[OP_I_MODULO] =
2784 &Perl_pp_i_modulo_1;
2785 /* Make certain we work right this time, too. */
2786 right = PERL_ABS(right);
2789 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2793 SETi( left % right );
2801 dVAR; dSP; dATARGET;
2802 tryAMAGICbin_MG(add_amg, AMGf_assign);
2804 dPOPTOPiirl_ul_nomg;
2805 SETi( left + right );
2812 dVAR; dSP; dATARGET;
2813 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2815 dPOPTOPiirl_ul_nomg;
2816 SETi( left - right );
2824 tryAMAGICbin_MG(lt_amg, AMGf_set);
2827 SETs(boolSV(left < right));
2835 tryAMAGICbin_MG(gt_amg, AMGf_set);
2838 SETs(boolSV(left > right));
2846 tryAMAGICbin_MG(le_amg, AMGf_set);
2849 SETs(boolSV(left <= right));
2857 tryAMAGICbin_MG(ge_amg, AMGf_set);
2860 SETs(boolSV(left >= right));
2868 tryAMAGICbin_MG(eq_amg, AMGf_set);
2871 SETs(boolSV(left == right));
2879 tryAMAGICbin_MG(ne_amg, AMGf_set);
2882 SETs(boolSV(left != right));
2890 tryAMAGICbin_MG(ncmp_amg, 0);
2897 else if (left < right)
2909 tryAMAGICun_MG(neg_amg, 0);
2911 SV * const sv = TOPs;
2912 IV const i = SvIV_nomg(sv);
2918 /* High falutin' math. */
2923 tryAMAGICbin_MG(atan2_amg, 0);
2926 SETn(Perl_atan2(left, right));
2934 int amg_type = sin_amg;
2935 const char *neg_report = NULL;
2936 NV (*func)(NV) = Perl_sin;
2937 const int op_type = PL_op->op_type;
2954 amg_type = sqrt_amg;
2956 neg_report = "sqrt";
2961 tryAMAGICun_MG(amg_type, 0);
2963 SV * const arg = POPs;
2964 const NV value = SvNV_nomg(arg);
2966 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2967 SET_NUMERIC_STANDARD();
2968 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2971 XPUSHn(func(value));
2976 /* Support Configure command-line overrides for rand() functions.
2977 After 5.005, perhaps we should replace this by Configure support
2978 for drand48(), random(), or rand(). For 5.005, though, maintain
2979 compatibility by calling rand() but allow the user to override it.
2980 See INSTALL for details. --Andy Dougherty 15 July 1998
2982 /* Now it's after 5.005, and Configure supports drand48() and random(),
2983 in addition to rand(). So the overrides should not be needed any more.
2984 --Jarkko Hietaniemi 27 September 1998
2987 #ifndef HAS_DRAND48_PROTO
2988 extern double drand48 (void);
3001 if (!PL_srand_called) {
3002 (void)seedDrand01((Rand_seed_t)seed());
3003 PL_srand_called = TRUE;
3013 const UV anum = (MAXARG < 1) ? seed() : POPu;
3014 (void)seedDrand01((Rand_seed_t)anum);
3015 PL_srand_called = TRUE;
3019 /* Historically srand always returned true. We can avoid breaking
3021 sv_setpvs(TARG, "0 but true");
3030 tryAMAGICun_MG(int_amg, AMGf_numeric);
3032 SV * const sv = TOPs;
3033 const IV iv = SvIV_nomg(sv);
3034 /* XXX it's arguable that compiler casting to IV might be subtly
3035 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
3036 else preferring IV has introduced a subtle behaviour change bug. OTOH
3037 relying on floating point to be accurate is a bug. */
3042 else if (SvIOK(sv)) {
3044 SETu(SvUV_nomg(sv));
3049 const NV value = SvNV_nomg(sv);
3051 if (value < (NV)UV_MAX + 0.5) {
3054 SETn(Perl_floor(value));
3058 if (value > (NV)IV_MIN - 0.5) {
3061 SETn(Perl_ceil(value));
3072 tryAMAGICun_MG(abs_amg, AMGf_numeric);
3074 SV * const sv = TOPs;
3075 /* This will cache the NV value if string isn't actually integer */
3076 const IV iv = SvIV_nomg(sv);
3081 else if (SvIOK(sv)) {
3082 /* IVX is precise */
3084 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
3092 /* 2s complement assumption. Also, not really needed as
3093 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
3099 const NV value = SvNV_nomg(sv);
3113 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
3117 SV* const sv = POPs;
3119 tmps = (SvPV_const(sv, len));
3121 /* If Unicode, try to downgrade
3122 * If not possible, croak. */
3123 SV* const tsv = sv_2mortal(newSVsv(sv));
3126 sv_utf8_downgrade(tsv, FALSE);
3127 tmps = SvPV_const(tsv, len);
3129 if (PL_op->op_type == OP_HEX)
3132 while (*tmps && len && isSPACE(*tmps))
3136 if (*tmps == 'x' || *tmps == 'X') {
3138 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
3140 else if (*tmps == 'b' || *tmps == 'B')
3141 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
3143 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
3145 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
3159 SV * const sv = TOPs;
3161 if (SvGAMAGIC(sv)) {
3162 /* For an overloaded or magic scalar, we can't know in advance if
3163 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
3164 it likes to cache the length. Maybe that should be a documented
3169 = sv_2pv_flags(sv, &len,
3170 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
3173 sv_setsv(TARG, &PL_sv_undef);
3176 else if (DO_UTF8(sv)) {
3177 SETi(utf8_length((U8*)p, (U8*)p + len));
3181 } else if (SvOK(sv)) {
3182 /* Neither magic nor overloaded. */
3184 SETi(sv_len_utf8(sv));
3188 sv_setsv_nomg(TARG, &PL_sv_undef);
3208 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3210 const IV arybase = CopARYBASE_get(PL_curcop);
3212 const char *repl = NULL;
3214 const int num_args = PL_op->op_private & 7;
3215 bool repl_need_utf8_upgrade = FALSE;
3216 bool repl_is_utf8 = FALSE;
3221 repl = SvPV_const(repl_sv, repl_len);
3222 repl_is_utf8 = DO_UTF8(repl_sv) && SvCUR(repl_sv);
3225 len_iv = SvIV(len_sv);
3226 len_is_uv = SvIOK_UV(len_sv);
3229 pos1_iv = SvIV(pos_sv);
3230 pos1_is_uv = SvIOK_UV(pos_sv);
3236 sv_utf8_upgrade(sv);
3238 else if (DO_UTF8(sv))
3239 repl_need_utf8_upgrade = TRUE;
3241 tmps = SvPV_const(sv, curlen);
3243 utf8_curlen = sv_len_utf8(sv);
3244 if (utf8_curlen == curlen)
3247 curlen = utf8_curlen;
3252 if ( (pos1_is_uv && arybase < 0) || (pos1_iv >= arybase) ) { /* pos >= $[ */
3253 UV pos1_uv = pos1_iv-arybase;
3254 /* Overflow can occur when $[ < 0 */
3255 if (arybase < 0 && pos1_uv < (UV)pos1_iv)
3260 else if (pos1_is_uv ? (UV)pos1_iv > 0 : pos1_iv > 0) {
3261 goto bound_fail; /* $[=3; substr($_,2,...) */
3263 else { /* pos < $[ */
3264 if (pos1_iv == 0) { /* $[=1; substr($_,0,...) */
3269 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3274 if (pos1_is_uv || pos1_iv > 0) {
3275 if ((UV)pos1_iv > curlen)
3280 if (!len_is_uv && len_iv < 0) {
3281 pos2_iv = curlen + len_iv;
3283 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3286 } else { /* len_iv >= 0 */
3287 if (!pos1_is_uv && pos1_iv < 0) {
3288 pos2_iv = pos1_iv + len_iv;
3289 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3291 if ((UV)len_iv > curlen-(UV)pos1_iv)
3294 pos2_iv = pos1_iv+len_iv;
3304 if (!pos2_is_uv && pos2_iv < 0) {
3305 if (!pos1_is_uv && pos1_iv < 0)
3309 else if (!pos1_is_uv && pos1_iv < 0)
3312 if ((UV)pos2_iv < (UV)pos1_iv)
3314 if ((UV)pos2_iv > curlen)
3318 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3319 const STRLEN pos = (STRLEN)( (UV)pos1_iv );
3320 const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3321 STRLEN byte_len = len;
3322 STRLEN byte_pos = utf8_curlen
3323 ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3325 if (lvalue && !repl) {
3328 if (!SvGMAGICAL(sv)) {
3330 SvPV_force_nolen(sv);
3331 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3332 "Attempt to use reference as lvalue in substr");
3334 if (isGV_with_GP(sv))
3335 SvPV_force_nolen(sv);
3336 else if (SvOK(sv)) /* is it defined ? */
3337 (void)SvPOK_only_UTF8(sv);
3339 sv_setpvs(sv, ""); /* avoid lexical reincarnation */
3342 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3343 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3345 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3346 LvTARGOFF(ret) = pos;
3347 LvTARGLEN(ret) = len;
3350 PUSHs(ret); /* avoid SvSETMAGIC here */
3354 SvTAINTED_off(TARG); /* decontaminate */
3355 SvUTF8_off(TARG); /* decontaminate */
3358 sv_setpvn(TARG, tmps, byte_len);
3359 #ifdef USE_LOCALE_COLLATE
3360 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3366 SV* repl_sv_copy = NULL;
3368 if (repl_need_utf8_upgrade) {
3369 repl_sv_copy = newSVsv(repl_sv);
3370 sv_utf8_upgrade(repl_sv_copy);
3371 repl = SvPV_const(repl_sv_copy, repl_len);
3372 repl_is_utf8 = DO_UTF8(repl_sv_copy) && SvCUR(sv);
3376 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3379 SvREFCNT_dec(repl_sv_copy);
3383 PUSHs(TARG); /* avoid SvSETMAGIC here */
3388 Perl_croak(aTHX_ "substr outside of string");
3389 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3396 register const IV size = POPi;
3397 register const IV offset = POPi;
3398 register SV * const src = POPs;
3399 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3402 if (lvalue) { /* it's an lvalue! */
3403 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3404 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3406 LvTARG(ret) = SvREFCNT_inc_simple(src);
3407 LvTARGOFF(ret) = offset;
3408 LvTARGLEN(ret) = size;
3412 SvTAINTED_off(TARG); /* decontaminate */
3416 sv_setuv(ret, do_vecget(src, offset, size));
3432 const char *little_p;
3433 const I32 arybase = CopARYBASE_get(PL_curcop);
3436 const bool is_index = PL_op->op_type == OP_INDEX;
3439 /* arybase is in characters, like offset, so combine prior to the
3440 UTF-8 to bytes calculation. */
3441 offset = POPi - arybase;
3445 big_p = SvPV_const(big, biglen);
3446 little_p = SvPV_const(little, llen);
3448 big_utf8 = DO_UTF8(big);
3449 little_utf8 = DO_UTF8(little);
3450 if (big_utf8 ^ little_utf8) {
3451 /* One needs to be upgraded. */
3452 if (little_utf8 && !PL_encoding) {
3453 /* Well, maybe instead we might be able to downgrade the small
3455 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3458 /* If the large string is ISO-8859-1, and it's not possible to
3459 convert the small string to ISO-8859-1, then there is no
3460 way that it could be found anywhere by index. */
3465 /* At this point, pv is a malloc()ed string. So donate it to temp
3466 to ensure it will get free()d */
3467 little = temp = newSV(0);
3468 sv_usepvn(temp, pv, llen);
3469 little_p = SvPVX(little);
3472 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3475 sv_recode_to_utf8(temp, PL_encoding);
3477 sv_utf8_upgrade(temp);
3482 big_p = SvPV_const(big, biglen);
3485 little_p = SvPV_const(little, llen);
3489 if (SvGAMAGIC(big)) {
3490 /* Life just becomes a lot easier if I use a temporary here.
3491 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3492 will trigger magic and overloading again, as will fbm_instr()
3494 big = newSVpvn_flags(big_p, biglen,
3495 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3498 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3499 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3500 warn on undef, and we've already triggered a warning with the
3501 SvPV_const some lines above. We can't remove that, as we need to
3502 call some SvPV to trigger overloading early and find out if the
3504 This is all getting to messy. The API isn't quite clean enough,
3505 because data access has side effects.
3507 little = newSVpvn_flags(little_p, llen,
3508 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3509 little_p = SvPVX(little);
3513 offset = is_index ? 0 : biglen;
3515 if (big_utf8 && offset > 0)
3516 sv_pos_u2b(big, &offset, 0);
3522 else if (offset > (I32)biglen)
3524 if (!(little_p = is_index
3525 ? fbm_instr((unsigned char*)big_p + offset,
3526 (unsigned char*)big_p + biglen, little, 0)
3527 : rninstr(big_p, big_p + offset,
3528 little_p, little_p + llen)))
3531 retval = little_p - big_p;
3532 if (retval > 0 && big_utf8)
3533 sv_pos_b2u(big, &retval);
3537 PUSHi(retval + arybase);
3543 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3544 if (SvTAINTED(MARK[1]))
3545 TAINT_PROPER("sprintf");
3546 SvTAINTED_off(TARG);
3547 do_sprintf(TARG, SP-MARK, MARK+1);
3548 TAINT_IF(SvTAINTED(TARG));
3560 const U8 *s = (U8*)SvPV_const(argsv, len);
3562 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3563 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3564 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3568 XPUSHu(DO_UTF8(argsv) ?
3569 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3581 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3583 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3585 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3587 (void) POPs; /* Ignore the argument value. */
3588 value = UNICODE_REPLACEMENT;
3594 SvUPGRADE(TARG,SVt_PV);
3596 if (value > 255 && !IN_BYTES) {
3597 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3598 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3599 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3601 (void)SvPOK_only(TARG);
3610 *tmps++ = (char)value;
3612 (void)SvPOK_only(TARG);
3614 if (PL_encoding && !IN_BYTES) {
3615 sv_recode_to_utf8(TARG, PL_encoding);
3617 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3618 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3622 *tmps++ = (char)value;
3638 const char *tmps = SvPV_const(left, len);
3640 if (DO_UTF8(left)) {
3641 /* If Unicode, try to downgrade.
3642 * If not possible, croak.
3643 * Yes, we made this up. */
3644 SV* const tsv = sv_2mortal(newSVsv(left));
3647 sv_utf8_downgrade(tsv, FALSE);
3648 tmps = SvPV_const(tsv, len);
3650 # ifdef USE_ITHREADS
3652 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3653 /* This should be threadsafe because in ithreads there is only
3654 * one thread per interpreter. If this would not be true,
3655 * we would need a mutex to protect this malloc. */
3656 PL_reentrant_buffer->_crypt_struct_buffer =
3657 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3658 #if defined(__GLIBC__) || defined(__EMX__)
3659 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3660 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3661 /* work around glibc-2.2.5 bug */
3662 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3666 # endif /* HAS_CRYPT_R */
3667 # endif /* USE_ITHREADS */
3669 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3671 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3677 "The crypt() function is unimplemented due to excessive paranoia.");
3681 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3682 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3684 /* Both the characters below can be stored in two UTF-8 bytes. In UTF-8 the max
3685 * character that 2 bytes can hold is U+07FF, and in UTF-EBCDIC it is U+03FF.
3686 * See http://www.unicode.org/unicode/reports/tr16 */
3687 #define LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS 0x0178 /* Also is title case */
3688 #define GREEK_CAPITAL_LETTER_MU 0x039C /* Upper and title case of MICRON */
3690 /* Below are several macros that generate code */
3691 /* Generates code to store a unicode codepoint c that is known to occupy
3692 * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */
3693 #define STORE_UNI_TO_UTF8_TWO_BYTE(p, c) \
3695 *(p) = UTF8_TWO_BYTE_HI(c); \
3696 *((p)+1) = UTF8_TWO_BYTE_LO(c); \
3699 /* Like STORE_UNI_TO_UTF8_TWO_BYTE, but advances p to point to the next
3700 * available byte after the two bytes */
3701 #define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
3703 *(p)++ = UTF8_TWO_BYTE_HI(c); \
3704 *((p)++) = UTF8_TWO_BYTE_LO(c); \
3707 /* Generates code to store the upper case of latin1 character l which is known
3708 * to have its upper case be non-latin1 into the two bytes p and p+1. There
3709 * are only two characters that fit this description, and this macro knows
3710 * about them, and that the upper case values fit into two UTF-8 or UTF-EBCDIC
3712 #define STORE_NON_LATIN1_UC(p, l) \
3714 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3715 STORE_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3716 } else { /* Must be the following letter */ \
3717 STORE_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3721 /* Like STORE_NON_LATIN1_UC, but advances p to point to the next available byte
3722 * after the character stored */
3723 #define CAT_NON_LATIN1_UC(p, l) \
3725 if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3726 CAT_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
3728 CAT_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
3732 /* Generates code to add the two UTF-8 bytes (probably u) that are the upper
3733 * case of l into p and p+1. u must be the result of toUPPER_LATIN1_MOD(l),
3734 * and must require two bytes to store it. Advances p to point to the next
3735 * available position */
3736 #define CAT_TWO_BYTE_UNI_UPPER_MOD(p, l, u) \
3738 if ((u) != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
3739 CAT_UNI_TO_UTF8_TWO_BYTE((p), (u)); /* not special, just save it */ \
3740 } else if (l == LATIN_SMALL_LETTER_SHARP_S) { \
3741 *(p)++ = 'S'; *(p)++ = 'S'; /* upper case is 'SS' */ \
3742 } else {/* else is one of the other two special cases */ \
3743 CAT_NON_LATIN1_UC((p), (l)); \
3749 /* Actually is both lcfirst() and ucfirst(). Only the first character
3750 * changes. This means that possibly we can change in-place, ie., just
3751 * take the source and change that one character and store it back, but not
3752 * if read-only etc, or if the length changes */
3757 STRLEN slen; /* slen is the byte length of the whole SV. */
3760 bool inplace; /* ? Convert first char only, in-place */
3761 bool doing_utf8 = FALSE; /* ? using utf8 */
3762 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3763 const int op_type = PL_op->op_type;
3766 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3767 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3768 * stored as UTF-8 at s. */
3769 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3770 * lowercased) character stored in tmpbuf. May be either
3771 * UTF-8 or not, but in either case is the number of bytes */
3775 s = (const U8*)SvPV_nomg_const(source, slen);
3777 if (ckWARN(WARN_UNINITIALIZED))
3778 report_uninit(source);
3783 /* We may be able to get away with changing only the first character, in
3784 * place, but not if read-only, etc. Later we may discover more reasons to
3785 * not convert in-place. */
3786 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3788 /* First calculate what the changed first character should be. This affects
3789 * whether we can just swap it out, leaving the rest of the string unchanged,
3790 * or even if have to convert the dest to UTF-8 when the source isn't */
3792 if (! slen) { /* If empty */
3793 need = 1; /* still need a trailing NUL */
3795 else if (DO_UTF8(source)) { /* Is the source utf8? */
3798 /* TODO: This is #ifdefd out because it has hard-coded the standard mappings,
3799 * and doesn't allow for the user to specify their own. When code is added to
3800 * detect if there is a user-defined mapping in force here, and if so to use
3801 * that, then the code below can be compiled. The detection would be a good
3802 * thing anyway, as currently the user-defined mappings only work on utf8
3803 * strings, and thus depend on the chosen internal storage method, which is a
3805 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3806 if (UTF8_IS_INVARIANT(*s)) {
3808 /* An invariant source character is either ASCII or, in EBCDIC, an
3809 * ASCII equivalent or a caseless C1 control. In both these cases,
3810 * the lower and upper cases of any character are also invariants
3811 * (and title case is the same as upper case). So it is safe to
3812 * use the simple case change macros which avoid the overhead of
3813 * the general functions. Note that if perl were to be extended to
3814 * do locale handling in UTF-8 strings, this wouldn't be true in,
3815 * for example, Lithuanian or Turkic. */
3816 *tmpbuf = (op_type == OP_LCFIRST) ? toLOWER(*s) : toUPPER(*s);
3820 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
3823 /* Similarly, if the source character isn't invariant but is in the
3824 * latin1 range (or EBCDIC equivalent thereof), we have the case
3825 * changes compiled into perl, and can avoid the overhead of the
3826 * general functions. In this range, the characters are stored as
3827 * two UTF-8 bytes, and it so happens that any changed-case version
3828 * is also two bytes (in both ASCIIish and EBCDIC machines). */
3832 /* Convert the two source bytes to a single Unicode code point
3833 * value, change case and save for below */
3834 chr = TWO_BYTE_UTF8_TO_UNI(*s, *(s+1));
3835 if (op_type == OP_LCFIRST) { /* lower casing is easy */
3836 U8 lower = toLOWER_LATIN1(chr);
3837 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, lower);
3839 else { /* ucfirst */
3840 U8 upper = toUPPER_LATIN1_MOD(chr);
3842 /* Most of the latin1 range characters are well-behaved. Their
3843 * title and upper cases are the same, and are also in the
3844 * latin1 range. The macro above returns their upper (hence
3845 * title) case, and all that need be done is to save the result
3846 * for below. However, several characters are problematic, and
3847 * have to be handled specially. The MOD in the macro name
3848 * above means that these tricky characters all get mapped to
3849 * the single character LATIN_SMALL_LETTER_Y_WITH_DIAERESIS.
3850 * This mapping saves some tests for the majority of the
3853 if (upper != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3855 /* Not tricky. Just save it. */
3856 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, upper);
3858 else if (chr == LATIN_SMALL_LETTER_SHARP_S) {
3860 /* This one is tricky because it is two characters long,
3861 * though the UTF-8 is still two bytes, so the stored
3862 * length doesn't change */
3863 *tmpbuf = 'S'; /* The UTF-8 is 'Ss' */
3864 *(tmpbuf + 1) = 's';
3868 /* The other two have their title and upper cases the same,
3869 * but are tricky because the changed-case characters
3870 * aren't in the latin1 range. They, however, do fit into
3871 * two UTF-8 bytes */
3872 STORE_NON_LATIN1_UC(tmpbuf, chr);
3877 #endif /* end of dont want to break user-defined casing */
3879 /* Here, can't short-cut the general case */
3881 utf8_to_uvchr(s, &ulen);
3882 if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
3883 else toLOWER_utf8(s, tmpbuf, &tculen);
3885 /* we can't do in-place if the length changes. */
3886 if (ulen != tculen) inplace = FALSE;
3887 need = slen + 1 - ulen + tculen;
3888 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
3892 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3893 * latin1 is treated as caseless. Note that a locale takes
3895 tculen = 1; /* Most characters will require one byte, but this will
3896 * need to be overridden for the tricky ones */
3899 if (op_type == OP_LCFIRST) {
3901 /* lower case the first letter: no trickiness for any character */
3902 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3903 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3906 else if (IN_LOCALE_RUNTIME) {
3907 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3908 * have upper and title case different
3911 else if (! IN_UNI_8_BIT) {
3912 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3913 * on EBCDIC machines whatever the
3914 * native function does */
3916 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3917 *tmpbuf = toUPPER_LATIN1_MOD(*s);
3919 /* tmpbuf now has the correct title case for all latin1 characters
3920 * except for the several ones that have tricky handling. All
3921 * of these are mapped by the MOD to the letter below. */
3922 if (*tmpbuf == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
3924 /* The length is going to change, with all three of these, so
3925 * can't replace just the first character */
3928 /* We use the original to distinguish between these tricky
3930 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3931 /* Two character title case 'Ss', but can remain non-UTF-8 */
3934 *(tmpbuf + 1) = 's'; /* Assert: length(tmpbuf) >= 2 */
3939 /* The other two tricky ones have their title case outside
3940 * latin1. It is the same as their upper case. */
3942 STORE_NON_LATIN1_UC(tmpbuf, *s);
3944 /* The UTF-8 and UTF-EBCDIC lengths of both these characters
3945 * and their upper cases is 2. */
3948 /* The entire result will have to be in UTF-8. Assume worst
3949 * case sizing in conversion. (all latin1 characters occupy
3950 * at most two bytes in utf8) */
3951 convert_source_to_utf8 = TRUE;
3952 need = slen * 2 + 1;
3954 } /* End of is one of the three special chars */
3955 } /* End of use Unicode (Latin1) semantics */
3956 } /* End of changing the case of the first character */
3958 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3959 * generate the result */
3962 /* We can convert in place. This means we change just the first
3963 * character without disturbing the rest; no need to grow */
3965 s = d = (U8*)SvPV_force_nomg(source, slen);
3971 /* Here, we can't convert in place; we earlier calculated how much
3972 * space we will need, so grow to accommodate that */
3973 SvUPGRADE(dest, SVt_PV);
3974 d = (U8*)SvGROW(dest, need);
3975 (void)SvPOK_only(dest);
3982 if (! convert_source_to_utf8) {
3984 /* Here both source and dest are in UTF-8, but have to create
3985 * the entire output. We initialize the result to be the
3986 * title/lower cased first character, and then append the rest
3988 sv_setpvn(dest, (char*)tmpbuf, tculen);
3990 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3994 const U8 *const send = s + slen;
3996 /* Here the dest needs to be in UTF-8, but the source isn't,
3997 * except we earlier UTF-8'd the first character of the source
3998 * into tmpbuf. First put that into dest, and then append the
3999 * rest of the source, converting it to UTF-8 as we go. */
4001 /* Assert tculen is 2 here because the only two characters that
4002 * get to this part of the code have 2-byte UTF-8 equivalents */
4004 *d++ = *(tmpbuf + 1);
4005 s++; /* We have just processed the 1st char */
4007 for (; s < send; s++) {
4008 d = uvchr_to_utf8(d, *s);
4011 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4015 else { /* in-place UTF-8. Just overwrite the first character */
4016 Copy(tmpbuf, d, tculen, U8);
4017 SvCUR_set(dest, need - 1);
4020 else { /* Neither source nor dest are in or need to be UTF-8 */
4022 if (IN_LOCALE_RUNTIME) {
4026 if (inplace) { /* in-place, only need to change the 1st char */
4029 else { /* Not in-place */
4031 /* Copy the case-changed character(s) from tmpbuf */
4032 Copy(tmpbuf, d, tculen, U8);
4033 d += tculen - 1; /* Code below expects d to point to final
4034 * character stored */
4037 else { /* empty source */
4038 /* See bug #39028: Don't taint if empty */
4042 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
4043 * the destination to retain that flag */
4047 if (!inplace) { /* Finish the rest of the string, unchanged */
4048 /* This will copy the trailing NUL */
4049 Copy(s + 1, d + 1, slen, U8);
4050 SvCUR_set(dest, need - 1);
4057 /* There's so much setup/teardown code common between uc and lc, I wonder if
4058 it would be worth merging the two, and just having a switch outside each
4059 of the three tight loops. There is less and less commonality though */
4073 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4074 && SvTEMP(source) && !DO_UTF8(source)
4075 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
4077 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
4078 * make the loop tight, so we overwrite the source with the dest before
4079 * looking at it, and we need to look at the original source
4080 * afterwards. There would also need to be code added to handle
4081 * switching to not in-place in midstream if we run into characters
4082 * that change the length.
4085 s = d = (U8*)SvPV_force_nomg(source, len);
4092 /* The old implementation would copy source into TARG at this point.
4093 This had the side effect that if source was undef, TARG was now
4094 an undefined SV with PADTMP set, and they don't warn inside
4095 sv_2pv_flags(). However, we're now getting the PV direct from
4096 source, which doesn't have PADTMP set, so it would warn. Hence the
4100 s = (const U8*)SvPV_nomg_const(source, len);
4102 if (ckWARN(WARN_UNINITIALIZED))
4103 report_uninit(source);
4109 SvUPGRADE(dest, SVt_PV);
4110 d = (U8*)SvGROW(dest, min);
4111 (void)SvPOK_only(dest);
4116 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4117 to check DO_UTF8 again here. */
4119 if (DO_UTF8(source)) {
4120 const U8 *const send = s + len;
4121 U8 tmpbuf[UTF8_MAXBYTES+1];
4123 /* All occurrences of these are to be moved to follow any other marks.
4124 * This is context-dependent. We may not be passed enough context to
4125 * move the iota subscript beyond all of them, but we do the best we can
4126 * with what we're given. The result is always better than if we
4127 * hadn't done this. And, the problem would only arise if we are
4128 * passed a character without all its combining marks, which would be
4129 * the caller's mistake. The information this is based on comes from a
4130 * comment in Unicode SpecialCasing.txt, (and the Standard's text
4131 * itself) and so can't be checked properly to see if it ever gets
4132 * revised. But the likelihood of it changing is remote */
4133 bool in_iota_subscript = FALSE;
4136 if (in_iota_subscript && ! is_utf8_mark(s)) {
4137 /* A non-mark. Time to output the iota subscript */
4138 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
4139 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
4141 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4142 in_iota_subscript = FALSE;
4146 /* See comments at the first instance in this file of this ifdef */
4147 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4149 /* If the UTF-8 character is invariant, then it is in the range
4150 * known by the standard macro; result is only one byte long */
4151 if (UTF8_IS_INVARIANT(*s)) {
4155 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4157 /* Likewise, if it fits in a byte, its case change is in our
4159 U8 orig = TWO_BYTE_UTF8_TO_UNI(*s, *s++);
4160 U8 upper = toUPPER_LATIN1_MOD(orig);
4161 CAT_TWO_BYTE_UNI_UPPER_MOD(d, orig, upper);
4169 /* Otherwise, need the general UTF-8 case. Get the changed
4170 * case value and copy it to the output buffer */
4172 const STRLEN u = UTF8SKIP(s);
4175 const UV uv = toUPPER_utf8(s, tmpbuf, &ulen);
4176 if (uv == GREEK_CAPITAL_LETTER_IOTA
4177 && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
4179 in_iota_subscript = TRUE;
4182 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4183 /* If the eventually required minimum size outgrows
4184 * the available space, we need to grow. */
4185 const UV o = d - (U8*)SvPVX_const(dest);
4187 /* If someone uppercases one million U+03B0s we
4188 * SvGROW() one million times. Or we could try
4189 * guessing how much to allocate without allocating too
4190 * much. Such is life. See corresponding comment in
4191 * lc code for another option */
4193 d = (U8*)SvPVX(dest) + o;
4195 Copy(tmpbuf, d, ulen, U8);
4201 if (in_iota_subscript) {
4202 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
4206 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4208 else { /* Not UTF-8 */
4210 const U8 *const send = s + len;
4212 /* Use locale casing if in locale; regular style if not treating
4213 * latin1 as having case; otherwise the latin1 casing. Do the
4214 * whole thing in a tight loop, for speed, */
4215 if (IN_LOCALE_RUNTIME) {
4218 for (; s < send; d++, s++)
4219 *d = toUPPER_LC(*s);
4221 else if (! IN_UNI_8_BIT) {
4222 for (; s < send; d++, s++) {
4227 for (; s < send; d++, s++) {
4228 *d = toUPPER_LATIN1_MOD(*s);
4229 if (*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) continue;
4231 /* The mainstream case is the tight loop above. To avoid
4232 * extra tests in that, all three characters that require
4233 * special handling are mapped by the MOD to the one tested
4235 * Use the source to distinguish between the three cases */
4237 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
4239 /* uc() of this requires 2 characters, but they are
4240 * ASCII. If not enough room, grow the string */
4241 if (SvLEN(dest) < ++min) {
4242 const UV o = d - (U8*)SvPVX_const(dest);
4244 d = (U8*)SvPVX(dest) + o;
4246 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
4247 continue; /* Back to the tight loop; still in ASCII */
4250 /* The other two special handling characters have their
4251 * upper cases outside the latin1 range, hence need to be
4252 * in UTF-8, so the whole result needs to be in UTF-8. So,
4253 * here we are somewhere in the middle of processing a
4254 * non-UTF-8 string, and realize that we will have to convert
4255 * the whole thing to UTF-8. What to do? There are
4256 * several possibilities. The simplest to code is to
4257 * convert what we have so far, set a flag, and continue on
4258 * in the loop. The flag would be tested each time through
4259 * the loop, and if set, the next character would be
4260 * converted to UTF-8 and stored. But, I (khw) didn't want
4261 * to slow down the mainstream case at all for this fairly
4262 * rare case, so I didn't want to add a test that didn't
4263 * absolutely have to be there in the loop, besides the
4264 * possibility that it would get too complicated for
4265 * optimizers to deal with. Another possibility is to just
4266 * give up, convert the source to UTF-8, and restart the
4267 * function that way. Another possibility is to convert
4268 * both what has already been processed and what is yet to
4269 * come separately to UTF-8, then jump into the loop that
4270 * handles UTF-8. But the most efficient time-wise of the
4271 * ones I could think of is what follows, and turned out to
4272 * not require much extra code. */
4274 /* Convert what we have so far into UTF-8, telling the
4275 * function that we know it should be converted, and to
4276 * allow extra space for what we haven't processed yet.
4277 * Assume the worst case space requirements for converting
4278 * what we haven't processed so far: that it will require
4279 * two bytes for each remaining source character, plus the
4280 * NUL at the end. This may cause the string pointer to
4281 * move, so re-find it. */
4283 len = d - (U8*)SvPVX_const(dest);
4284 SvCUR_set(dest, len);
4285 len = sv_utf8_upgrade_flags_grow(dest,
4286 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4288 d = (U8*)SvPVX(dest) + len;
4290 /* And append the current character's upper case in UTF-8 */
4291 CAT_NON_LATIN1_UC(d, *s);
4293 /* Now process the remainder of the source, converting to
4294 * upper and UTF-8. If a resulting byte is invariant in
4295 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4296 * append it to the output. */
4299 for (; s < send; s++) {
4300 U8 upper = toUPPER_LATIN1_MOD(*s);
4301 if UTF8_IS_INVARIANT(upper) {
4305 CAT_TWO_BYTE_UNI_UPPER_MOD(d, *s, upper);
4309 /* Here have processed the whole source; no need to continue
4310 * with the outer loop. Each character has been converted
4311 * to upper case and converted to UTF-8 */
4314 } /* End of processing all latin1-style chars */
4315 } /* End of processing all chars */
4316 } /* End of source is not empty */
4318 if (source != dest) {
4319 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4320 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4322 } /* End of isn't utf8 */
4340 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
4341 && SvTEMP(source) && !DO_UTF8(source)) {
4343 /* We can convert in place, as lowercasing anything in the latin1 range
4344 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4346 s = d = (U8*)SvPV_force_nomg(source, len);
4353 /* The old implementation would copy source into TARG at this point.
4354 This had the side effect that if source was undef, TARG was now
4355 an undefined SV with PADTMP set, and they don't warn inside
4356 sv_2pv_flags(). However, we're now getting the PV direct from
4357 source, which doesn't have PADTMP set, so it would warn. Hence the
4361 s = (const U8*)SvPV_nomg_const(source, len);
4363 if (ckWARN(WARN_UNINITIALIZED))
4364 report_uninit(source);
4370 SvUPGRADE(dest, SVt_PV);
4371 d = (U8*)SvGROW(dest, min);
4372 (void)SvPOK_only(dest);
4377 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4378 to check DO_UTF8 again here. */
4380 if (DO_UTF8(source)) {
4381 const U8 *const send = s + len;
4382 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4385 /* See comments at the first instance in this file of this ifdef */
4386 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4387 if (UTF8_IS_INVARIANT(*s)) {
4389 /* Invariant characters use the standard mappings compiled in.
4394 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4396 /* As do the ones in the Latin1 range */
4397 U8 lower = toLOWER_LATIN1(TWO_BYTE_UTF8_TO_UNI(*s, *s++));
4398 CAT_UNI_TO_UTF8_TWO_BYTE(d, lower);
4403 /* Here, is utf8 not in Latin-1 range, have to go out and get
4404 * the mappings from the tables. */
4406 const STRLEN u = UTF8SKIP(s);
4409 #ifndef CONTEXT_DEPENDENT_CASING
4410 toLOWER_utf8(s, tmpbuf, &ulen);
4412 /* This is ifdefd out because it needs more work and thought. It isn't clear
4413 * that we should do it.
4414 * A minor objection is that this is based on a hard-coded rule from the
4415 * Unicode standard, and may change, but this is not very likely at all.
4416 * mktables should check and warn if it does.
4417 * More importantly, if the sigma occurs at the end of the string, we don't
4418 * have enough context to know whether it is part of a larger string or going
4419 * to be or not. It may be that we are passed a subset of the context, via
4420 * a \U...\E, for example, and we could conceivably know the larger context if
4421 * code were changed to pass that in. But, if the string passed in is an
4422 * intermediate result, and the user concatenates two strings together
4423 * after we have made a final sigma, that would be wrong. If the final sigma
4424 * occurs in the middle of the string we are working on, then we know that it
4425 * should be a final sigma, but otherwise we can't be sure. */
4427 const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
4429 /* If the lower case is a small sigma, it may be that we need
4430 * to change it to a final sigma. This happens at the end of
4431 * a word that contains more than just this character, and only
4432 * when we started with a capital sigma. */
4433 if (uv == UNICODE_GREEK_SMALL_LETTER_SIGMA &&
4434 s > send - len && /* Makes sure not the first letter */
4435 utf8_to_uvchr(s, 0) == UNICODE_GREEK_CAPITAL_LETTER_SIGMA
4438 /* We use the algorithm in:
4439 * http://www.unicode.org/versions/Unicode5.0.0/ch03.pdf (C
4440 * is a CAPITAL SIGMA): If C is preceded by a sequence
4441 * consisting of a cased letter and a case-ignorable
4442 * sequence, and C is not followed by a sequence consisting
4443 * of a case ignorable sequence and then a cased letter,
4444 * then when lowercasing C, C becomes a final sigma */
4446 /* To determine if this is the end of a word, need to peek
4447 * ahead. Look at the next character */
4448 const U8 *peek = s + u;
4450 /* Skip any case ignorable characters */
4451 while (peek < send && is_utf8_case_ignorable(peek)) {
4452 peek += UTF8SKIP(peek);
4455 /* If we reached the end of the string without finding any
4456 * non-case ignorable characters, or if the next such one
4457 * is not-cased, then we have met the conditions for it
4458 * being a final sigma with regards to peek ahead, and so
4459 * must do peek behind for the remaining conditions. (We
4460 * know there is stuff behind to look at since we tested
4461 * above that this isn't the first letter) */
4462 if (peek >= send || ! is_utf8_cased(peek)) {
4463 peek = utf8_hop(s, -1);
4465 /* Here are at the beginning of the first character
4466 * before the original upper case sigma. Keep backing
4467 * up, skipping any case ignorable characters */
4468 while (is_utf8_case_ignorable(peek)) {
4469 peek = utf8_hop(peek, -1);
4472 /* Here peek points to the first byte of the closest
4473 * non-case-ignorable character before the capital
4474 * sigma. If it is cased, then by the Unicode
4475 * algorithm, we should use a small final sigma instead
4476 * of what we have */
4477 if (is_utf8_cased(peek)) {
4478 STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf,
4479 UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA);
4483 else { /* Not a context sensitive mapping */
4484 #endif /* End of commented out context sensitive */
4485 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4487 /* If the eventually required minimum size outgrows
4488 * the available space, we need to grow. */
4489 const UV o = d - (U8*)SvPVX_const(dest);
4491 /* If someone lowercases one million U+0130s we
4492 * SvGROW() one million times. Or we could try
4493 * guessing how much to allocate without allocating too
4494 * much. Such is life. Another option would be to
4495 * grow an extra byte or two more each time we need to
4496 * grow, which would cut down the million to 500K, with
4499 d = (U8*)SvPVX(dest) + o;
4501 #ifdef CONTEXT_DEPENDENT_CASING
4504 /* Copy the newly lowercased letter to the output buffer we're
4506 Copy(tmpbuf, d, ulen, U8);
4509 #ifdef GO_AHEAD_AND_BREAK_USER_DEFINED_CASE_MAPPINGS
4512 } /* End of looping through the source string */
4515 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4516 } else { /* Not utf8 */
4518 const U8 *const send = s + len;
4520 /* Use locale casing if in locale; regular style if not treating
4521 * latin1 as having case; otherwise the latin1 casing. Do the
4522 * whole thing in a tight loop, for speed, */
4523 if (IN_LOCALE_RUNTIME) {
4526 for (; s < send; d++, s++)
4527 *d = toLOWER_LC(*s);
4529 else if (! IN_UNI_8_BIT) {
4530 for (; s < send; d++, s++) {
4535 for (; s < send; d++, s++) {
4536 *d = toLOWER_LATIN1(*s);
4540 if (source != dest) {
4542 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4552 SV * const sv = TOPs;
4554 register const char *s = SvPV_const(sv,len);
4556 SvUTF8_off(TARG); /* decontaminate */
4559 SvUPGRADE(TARG, SVt_PV);
4560 SvGROW(TARG, (len * 2) + 1);
4564 if (UTF8_IS_CONTINUED(*s)) {
4565 STRLEN ulen = UTF8SKIP(s);
4589 SvCUR_set(TARG, d - SvPVX_const(TARG));
4590 (void)SvPOK_only_UTF8(TARG);
4593 sv_setpvn(TARG, s, len);
4602 dVAR; dSP; dMARK; dORIGMARK;
4603 register AV *const av = MUTABLE_AV(POPs);
4604 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4606 if (SvTYPE(av) == SVt_PVAV) {
4607 const I32 arybase = CopARYBASE_get(PL_curcop);
4608 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4609 bool can_preserve = FALSE;
4615 can_preserve = SvCANEXISTDELETE(av);
4618 if (lval && localizing) {
4621 for (svp = MARK + 1; svp <= SP; svp++) {
4622 const I32 elem = SvIV(*svp);
4626 if (max > AvMAX(av))
4630 while (++MARK <= SP) {
4632 I32 elem = SvIV(*MARK);
4633 bool preeminent = TRUE;
4637 if (localizing && can_preserve) {
4638 /* If we can determine whether the element exist,
4639 * Try to preserve the existenceness of a tied array
4640 * element by using EXISTS and DELETE if possible.
4641 * Fallback to FETCH and STORE otherwise. */
4642 preeminent = av_exists(av, elem);
4645 svp = av_fetch(av, elem, lval);
4647 if (!svp || *svp == &PL_sv_undef)
4648 DIE(aTHX_ PL_no_aelem, elem);
4651 save_aelem(av, elem, svp);
4653 SAVEADELETE(av, elem);
4656 *MARK = svp ? *svp : &PL_sv_undef;
4659 if (GIMME != G_ARRAY) {
4661 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4667 /* Smart dereferencing for keys, values and each */
4680 /* N.B.: AMG macros return sv if no overloading is found */
4681 SV *maybe_hv = AMG_CALLun(sv,to_hv);
4682 SV *maybe_av = AMG_CALLun(sv,to_av);
4683 if ( maybe_hv != sv && maybe_av != sv ) {
4684 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
4685 Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}",
4686 PL_op_desc[PL_op->op_type]
4691 else if ( maybe_av != sv ) {
4692 if ( SvTYPE(SvRV(sv)) == SVt_PVHV ) {
4693 /* @{} overload, but underlying reftype is HV */
4694 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
4695 Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as @{}",
4696 PL_op_desc[PL_op->op_type]
4702 else if ( maybe_hv != sv ) {
4703 if ( SvTYPE(SvRV(sv)) == SVt_PVAV ) {
4704 /* %{} overload, but underlying reftype is AV */
4705 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s",
4706 Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}",
4707 PL_op_desc[PL_op->op_type]
4717 if ( SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV ) {
4718 DIE(aTHX_ "Type of argument to %s must be hashref or arrayref",
4719 PL_op_desc[PL_op->op_type] );
4722 /* Delegate to correct function for op type */
4724 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4725 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4728 return (SvTYPE(sv) == SVt_PVHV) ? Perl_pp_each(aTHX) : Perl_pp_aeach(aTHX);
4736 AV *array = MUTABLE_AV(POPs);
4737 const I32 gimme = GIMME_V;
4738 IV *iterp = Perl_av_iter_p(aTHX_ array);
4739 const IV current = (*iterp)++;
4741 if (current > av_len(array)) {
4743 if (gimme == G_SCALAR)
4750 mPUSHi(CopARYBASE_get(PL_curcop) + current);
4751 if (gimme == G_ARRAY) {
4752 SV **const element = av_fetch(array, current, 0);
4753 PUSHs(element ? *element : &PL_sv_undef);
4762 AV *array = MUTABLE_AV(POPs);
4763 const I32 gimme = GIMME_V;
4765 *Perl_av_iter_p(aTHX_ array) = 0;
4767 if (gimme == G_SCALAR) {
4769 PUSHi(av_len(array) + 1);
4771 else if (gimme == G_ARRAY) {
4772 IV n = Perl_av_len(aTHX_ array);
4773 IV i = CopARYBASE_get(PL_curcop);
4777 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4779 for (; i <= n; i++) {
4784 for (i = 0; i <= n; i++) {
4785 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4786 PUSHs(elem ? *elem : &PL_sv_undef);
4793 /* Associative arrays. */
4799 HV * hash = MUTABLE_HV(POPs);
4801 const I32 gimme = GIMME_V;
4804 /* might clobber stack_sp */
4805 entry = hv_iternext(hash);
4810 SV* const sv = hv_iterkeysv(entry);
4811 PUSHs(sv); /* won't clobber stack_sp */
4812 if (gimme == G_ARRAY) {
4815 /* might clobber stack_sp */
4816 val = hv_iterval(hash, entry);
4821 else if (gimme == G_SCALAR)
4828 S_do_delete_local(pTHX)
4832 const I32 gimme = GIMME_V;
4836 if (PL_op->op_private & OPpSLICE) {
4838 SV * const osv = POPs;
4839 const bool tied = SvRMAGICAL(osv)
4840 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4841 const bool can_preserve = SvCANEXISTDELETE(osv)
4842 || mg_find((const SV *)osv, PERL_MAGIC_env);
4843 const U32 type = SvTYPE(osv);
4844 if (type == SVt_PVHV) { /* hash element */
4845 HV * const hv = MUTABLE_HV(osv);
4846 while (++MARK <= SP) {
4847 SV * const keysv = *MARK;
4849 bool preeminent = TRUE;
4851 preeminent = hv_exists_ent(hv, keysv, 0);
4853 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4860 sv = hv_delete_ent(hv, keysv, 0, 0);
4861 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4864 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4866 *MARK = sv_mortalcopy(sv);
4872 SAVEHDELETE(hv, keysv);
4873 *MARK = &PL_sv_undef;
4877 else if (type == SVt_PVAV) { /* array element */
4878 if (PL_op->op_flags & OPf_SPECIAL) {
4879 AV * const av = MUTABLE_AV(osv);
4880 while (++MARK <= SP) {
4881 I32 idx = SvIV(*MARK);
4883 bool preeminent = TRUE;
4885 preeminent = av_exists(av, idx);
4887 SV **svp = av_fetch(av, idx, 1);
4894 sv = av_delete(av, idx, 0);
4895 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4898 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4900 *MARK = sv_mortalcopy(sv);
4906 SAVEADELETE(av, idx);
4907 *MARK = &PL_sv_undef;
4913 DIE(aTHX_ "Not a HASH reference");
4914 if (gimme == G_VOID)
4916 else if (gimme == G_SCALAR) {
4921 *++MARK = &PL_sv_undef;
4926 SV * const keysv = POPs;
4927 SV * const osv = POPs;
4928 const bool tied = SvRMAGICAL(osv)
4929 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4930 const bool can_preserve = SvCANEXISTDELETE(osv)
4931 || mg_find((const SV *)osv, PERL_MAGIC_env);
4932 const U32 type = SvTYPE(osv);
4934 if (type == SVt_PVHV) {
4935 HV * const hv = MUTABLE_HV(osv);
4936 bool preeminent = TRUE;
4938 preeminent = hv_exists_ent(hv, keysv, 0);
4940 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4947 sv = hv_delete_ent(hv, keysv, 0, 0);
4948 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4951 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4953 SV *nsv = sv_mortalcopy(sv);
4959 SAVEHDELETE(hv, keysv);
4961 else if (type == SVt_PVAV) {
4962 if (PL_op->op_flags & OPf_SPECIAL) {
4963 AV * const av = MUTABLE_AV(osv);
4964 I32 idx = SvIV(keysv);
4965 bool preeminent = TRUE;
4967 preeminent = av_exists(av, idx);
4969 SV **svp = av_fetch(av, idx, 1);
4976 sv = av_delete(av, idx, 0);
4977 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4980 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4982 SV *nsv = sv_mortalcopy(sv);
4988 SAVEADELETE(av, idx);
4991 DIE(aTHX_ "panic: avhv_delete no longer supported");
4994 DIE(aTHX_ "Not a HASH reference");
4997 if (gimme != G_VOID)
5011 if (PL_op->op_private & OPpLVAL_INTRO)
5012 return do_delete_local();
5015 discard = (gimme == G_VOID) ? G_DISCARD : 0;
5017 if (PL_op->op_private & OPpSLICE) {
5019 HV * const hv = MUTABLE_HV(POPs);
5020 const U32 hvtype = SvTYPE(hv);
5021 if (hvtype == SVt_PVHV) { /* hash element */
5022 while (++MARK <= SP) {
5023 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
5024 *MARK = sv ? sv : &PL_sv_undef;
5027 else if (hvtype == SVt_PVAV) { /* array element */
5028 if (PL_op->op_flags & OPf_SPECIAL) {
5029 while (++MARK <= SP) {
5030 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
5031 *MARK = sv ? sv : &PL_sv_undef;
5036 DIE(aTHX_ "Not a HASH reference");
5039 else if (gimme == G_SCALAR) {
5044 *++MARK = &PL_sv_undef;
5050 HV * const hv = MUTABLE_HV(POPs);
5052 if (SvTYPE(hv) == SVt_PVHV)
5053 sv = hv_delete_ent(hv, keysv, discard, 0);
5054 else if (SvTYPE(hv) == SVt_PVAV) {
5055 if (PL_op->op_flags & OPf_SPECIAL)
5056 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
5058 DIE(aTHX_ "panic: avhv_delete no longer supported");
5061 DIE(aTHX_ "Not a HASH reference");
5077 if (PL_op->op_private & OPpEXISTS_SUB) {
5079 SV * const sv = POPs;
5080 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
5083 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
5088 hv = MUTABLE_HV(POPs);
5089 if (SvTYPE(hv) == SVt_PVHV) {
5090 if (hv_exists_ent(hv, tmpsv, 0))
5093 else if (SvTYPE(hv) == SVt_PVAV) {
5094 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
5095 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
5100 DIE(aTHX_ "Not a HASH reference");
5107 dVAR; dSP; dMARK; dORIGMARK;
5108 register HV * const hv = MUTABLE_HV(POPs);
5109 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
5110 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
5111 bool can_preserve = FALSE;
5117 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
5118 can_preserve = TRUE;
5121 while (++MARK <= SP) {
5122 SV * const keysv = *MARK;
5125 bool preeminent = TRUE;
5127 if (localizing && can_preserve) {
5128 /* If we can determine whether the element exist,
5129 * try to preserve the existenceness of a tied hash
5130 * element by using EXISTS and DELETE if possible.
5131 * Fallback to FETCH and STORE otherwise. */
5132 preeminent = hv_exists_ent(hv, keysv, 0);
5135 he = hv_fetch_ent(hv, keysv, lval, 0);
5136 svp = he ? &HeVAL(he) : NULL;
5139 if (!svp || *svp == &PL_sv_undef) {
5140 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
5143 if (HvNAME_get(hv) && isGV(*svp))
5144 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
5145 else if (preeminent)
5146 save_helem_flags(hv, keysv, svp,
5147 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
5149 SAVEHDELETE(hv, keysv);
5152 *MARK = svp ? *svp : &PL_sv_undef;
5154 if (GIMME != G_ARRAY) {
5156 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
5162 /* List operators. */
5167 if (GIMME != G_ARRAY) {
5169 *MARK = *SP; /* unwanted list, return last item */
5171 *MARK = &PL_sv_undef;
5181 SV ** const lastrelem = PL_stack_sp;
5182 SV ** const lastlelem = PL_stack_base + POPMARK;
5183 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
5184 register SV ** const firstrelem = lastlelem + 1;
5185 const I32 arybase = CopARYBASE_get(PL_curcop);
5186 I32 is_something_there = FALSE;
5188 register const I32 max = lastrelem - lastlelem;
5189 register SV **lelem;
5191 if (GIMME != G_ARRAY) {
5192 I32 ix = SvIV(*lastlelem);
5197 if (ix < 0 || ix >= max)
5198 *firstlelem = &PL_sv_undef;
5200 *firstlelem = firstrelem[ix];
5206 SP = firstlelem - 1;
5210 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5211 I32 ix = SvIV(*lelem);
5216 if (ix < 0 || ix >= max)
5217 *lelem = &PL_sv_undef;
5219 is_something_there = TRUE;
5220 if (!(*lelem = firstrelem[ix]))
5221 *lelem = &PL_sv_undef;
5224 if (is_something_there)
5227 SP = firstlelem - 1;
5233 dVAR; dSP; dMARK; dORIGMARK;
5234 const I32 items = SP - MARK;
5235 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5236 SP = ORIGMARK; /* av_make() might realloc stack_sp */
5237 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5238 ? newRV_noinc(av) : av);
5244 dVAR; dSP; dMARK; dORIGMARK;
5245 HV* const hv = newHV();
5248 SV * const key = *++MARK;
5249 SV * const val = newSV(0);
5251 sv_setsv(val, *++MARK);
5253 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5254 (void)hv_store_ent(hv,key,val,0);
5257 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5258 ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
5264 dVAR; dSP; dMARK; dORIGMARK;
5265 register AV *ary = MUTABLE_AV(*++MARK);
5269 register I32 offset;
5270 register I32 length;
5274 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5277 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5280 ENTER_with_name("call_SPLICE");
5281 call_method("SPLICE",GIMME_V);
5282 LEAVE_with_name("call_SPLICE");
5290 offset = i = SvIV(*MARK);
5292 offset += AvFILLp(ary) + 1;
5294 offset -= CopARYBASE_get(PL_curcop);
5296 DIE(aTHX_ PL_no_aelem, i);
5298 length = SvIVx(*MARK++);
5300 length += AvFILLp(ary) - offset + 1;
5306 length = AvMAX(ary) + 1; /* close enough to infinity */
5310 length = AvMAX(ary) + 1;
5312 if (offset > AvFILLp(ary) + 1) {
5313 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5314 offset = AvFILLp(ary) + 1;
5316 after = AvFILLp(ary) + 1 - (offset + length);
5317 if (after < 0) { /* not that much array */
5318 length += after; /* offset+length now in array */
5324 /* At this point, MARK .. SP-1 is our new LIST */
5327 diff = newlen - length;
5328 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5331 /* make new elements SVs now: avoid problems if they're from the array */
5332 for (dst = MARK, i = newlen; i; i--) {
5333 SV * const h = *dst;
5334 *dst++ = newSVsv(h);
5337 if (diff < 0) { /* shrinking the area */
5338 SV **tmparyval = NULL;
5340 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5341 Copy(MARK, tmparyval, newlen, SV*);
5344 MARK = ORIGMARK + 1;
5345 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5346 MEXTEND(MARK, length);
5347 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
5349 EXTEND_MORTAL(length);
5350 for (i = length, dst = MARK; i; i--) {
5351 sv_2mortal(*dst); /* free them eventualy */
5358 *MARK = AvARRAY(ary)[offset+length-1];
5361 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5362 SvREFCNT_dec(*dst++); /* free them now */
5365 AvFILLp(ary) += diff;
5367 /* pull up or down? */
5369 if (offset < after) { /* easier to pull up */
5370 if (offset) { /* esp. if nothing to pull */
5371 src = &AvARRAY(ary)[offset-1];
5372 dst = src - diff; /* diff is negative */
5373 for (i = offset; i > 0; i--) /* can't trust Copy */
5377 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5381 if (after) { /* anything to pull down? */
5382 src = AvARRAY(ary) + offset + length;
5383 dst = src + diff; /* diff is negative */
5384 Move(src, dst, after, SV*);
5386 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5387 /* avoid later double free */
5391 dst[--i] = &PL_sv_undef;
5394 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5395 Safefree(tmparyval);
5398 else { /* no, expanding (or same) */
5399 SV** tmparyval = NULL;
5401 Newx(tmparyval, length, SV*); /* so remember deletion */
5402 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5405 if (diff > 0) { /* expanding */
5406 /* push up or down? */
5407 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5411 Move(src, dst, offset, SV*);
5413 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5415 AvFILLp(ary) += diff;
5418 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5419 av_extend(ary, AvFILLp(ary) + diff);
5420 AvFILLp(ary) += diff;
5423 dst = AvARRAY(ary) + AvFILLp(ary);
5425 for (i = after; i; i--) {
5433 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5436 MARK = ORIGMARK + 1;
5437 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5439 Copy(tmparyval, MARK, length, SV*);
5441 EXTEND_MORTAL(length);
5442 for (i = length, dst = MARK; i; i--) {
5443 sv_2mortal(*dst); /* free them eventualy */
5450 else if (length--) {
5451 *MARK = tmparyval[length];
5454 while (length-- > 0)
5455 SvREFCNT_dec(tmparyval[length]);
5459 *MARK = &PL_sv_undef;
5460 Safefree(tmparyval);
5464 mg_set(MUTABLE_SV(ary));
5472 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5473 register AV * const ary = MUTABLE_AV(*++MARK);
5474 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5477 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5480 ENTER_with_name("call_PUSH");
5481 call_method("PUSH",G_SCALAR|G_DISCARD);
5482 LEAVE_with_name("call_PUSH");
5486 PL_delaymagic = DM_DELAY;
5487 for (++MARK; MARK <= SP; MARK++) {
5488 SV * const sv = newSV(0);
5490 sv_setsv(sv, *MARK);
5491 av_store(ary, AvFILLp(ary)+1, sv);
5493 if (PL_delaymagic & DM_ARRAY_ISA)
5494 mg_set(MUTABLE_SV(ary));
5499 if (OP_GIMME(PL_op, 0) != G_VOID) {
5500 PUSHi( AvFILL(ary) + 1 );
5509 AV * const av = PL_op->op_flags & OPf_SPECIAL
5510 ? MUTABLE_AV(GvAV(PL_defgv)) : MUTABLE_AV(POPs);
5511 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5515 (void)sv_2mortal(sv);
5522 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5523 register AV *ary = MUTABLE_AV(*++MARK);
5524 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5527 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5530 ENTER_with_name("call_UNSHIFT");
5531 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
5532 LEAVE_with_name("call_UNSHIFT");
5537 av_unshift(ary, SP - MARK);
5539 SV * const sv = newSVsv(*++MARK);
5540 (void)av_store(ary, i++, sv);
5544 if (OP_GIMME(PL_op, 0) != G_VOID) {
5545 PUSHi( AvFILL(ary) + 1 );
5554 if (GIMME == G_ARRAY) {
5555 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5559 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5560 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5561 av = MUTABLE_AV((*SP));
5562 /* In-place reversing only happens in void context for the array
5563 * assignment. We don't need to push anything on the stack. */
5566 if (SvMAGICAL(av)) {
5568 register SV *tmp = sv_newmortal();
5569 /* For SvCANEXISTDELETE */
5572 bool can_preserve = SvCANEXISTDELETE(av);
5574 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5575 register SV *begin, *end;
5578 if (!av_exists(av, i)) {
5579 if (av_exists(av, j)) {
5580 register SV *sv = av_delete(av, j, 0);
5581 begin = *av_fetch(av, i, TRUE);
5582 sv_setsv_mg(begin, sv);
5586 else if (!av_exists(av, j)) {
5587 register SV *sv = av_delete(av, i, 0);
5588 end = *av_fetch(av, j, TRUE);
5589 sv_setsv_mg(end, sv);
5594 begin = *av_fetch(av, i, TRUE);
5595 end = *av_fetch(av, j, TRUE);
5596 sv_setsv(tmp, begin);
5597 sv_setsv_mg(begin, end);
5598 sv_setsv_mg(end, tmp);
5602 SV **begin = AvARRAY(av);
5605 SV **end = begin + AvFILLp(av);
5607 while (begin < end) {
5608 register SV * const tmp = *begin;
5619 register SV * const tmp = *MARK;
5623 /* safe as long as stack cannot get extended in the above */
5629 register char *down;
5634 SvUTF8_off(TARG); /* decontaminate */
5636 do_join(TARG, &PL_sv_no, MARK, SP);
5638 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5639 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5640 report_uninit(TARG);
5643 up = SvPV_force(TARG, len);
5645 if (DO_UTF8(TARG)) { /* first reverse each character */
5646 U8* s = (U8*)SvPVX(TARG);
5647 const U8* send = (U8*)(s + len);
5649 if (UTF8_IS_INVARIANT(*s)) {
5654 if (!utf8_to_uvchr(s, 0))
5658 down = (char*)(s - 1);
5659 /* reverse this character */
5663 *down-- = (char)tmp;
5669 down = SvPVX(TARG) + len - 1;
5673 *down-- = (char)tmp;
5675 (void)SvPOK_only_UTF8(TARG);
5687 register IV limit = POPi; /* note, negative is forever */
5688 SV * const sv = POPs;
5690 register const char *s = SvPV_const(sv, len);
5691 const bool do_utf8 = DO_UTF8(sv);
5692 const char *strend = s + len;
5694 register REGEXP *rx;
5696 register const char *m;
5698 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
5699 I32 maxiters = slen + 10;
5700 I32 trailing_empty = 0;
5702 const I32 origlimit = limit;
5705 const I32 gimme = GIMME_V;
5707 const I32 oldsave = PL_savestack_ix;
5708 U32 make_mortal = SVs_TEMP;
5713 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5718 DIE(aTHX_ "panic: pp_split");
5721 TAINT_IF((RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) &&
5722 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5724 RX_MATCH_UTF8_set(rx, do_utf8);
5727 if (pm->op_pmreplrootu.op_pmtargetoff) {
5728 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5731 if (pm->op_pmreplrootu.op_pmtargetgv) {
5732 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5737 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5743 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5745 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5752 for (i = AvFILLp(ary); i >= 0; i--)
5753 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5755 /* temporarily switch stacks */
5756 SAVESWITCHSTACK(PL_curstack, ary);
5760 base = SP - PL_stack_base;
5762 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5764 while (*s == ' ' || is_utf8_space((U8*)s))
5767 else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5768 while (isSPACE_LC(*s))
5776 if (RX_EXTFLAGS(rx) & PMf_MULTILINE) {
5780 gimme_scalar = gimme == G_SCALAR && !ary;
5783 limit = maxiters + 2;
5784 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5787 /* this one uses 'm' and is a negative test */
5789 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5790 const int t = UTF8SKIP(m);
5791 /* is_utf8_space returns FALSE for malform utf8 */
5797 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5798 while (m < strend && !isSPACE_LC(*m))
5801 while (m < strend && !isSPACE(*m))
5814 dstr = newSVpvn_flags(s, m-s,
5815 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5819 /* skip the whitespace found last */
5821 s = m + UTF8SKIP(m);
5825 /* this one uses 's' and is a positive test */
5827 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5829 } else if (RX_EXTFLAGS(rx) & RXf_PMf_LOCALE) {
5830 while (s < strend && isSPACE_LC(*s))
5833 while (s < strend && isSPACE(*s))
5838 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5840 for (m = s; m < strend && *m != '\n'; m++)
5853 dstr = newSVpvn_flags(s, m-s,
5854 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5860 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5862 Pre-extend the stack, either the number of bytes or
5863 characters in the string or a limited amount, triggered by:
5865 my ($x, $y) = split //, $str;
5869 if (!gimme_scalar) {
5870 const U32 items = limit - 1;
5879 /* keep track of how many bytes we skip over */
5889 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5902 dstr = newSVpvn(s, 1);
5918 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5919 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5920 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5921 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5922 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5923 SV * const csv = CALLREG_INTUIT_STRING(rx);
5925 len = RX_MINLENRET(rx);
5926 if (len == 1 && !RX_UTF8(rx) && !tail) {
5927 const char c = *SvPV_nolen_const(csv);
5929 for (m = s; m < strend && *m != c; m++)
5940 dstr = newSVpvn_flags(s, m-s,
5941 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5944 /* The rx->minlen is in characters but we want to step
5945 * s ahead by bytes. */
5947 s = (char*)utf8_hop((U8*)m, len);
5949 s = m + len; /* Fake \n at the end */
5953 while (s < strend && --limit &&
5954 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5955 csv, multiline ? FBMrf_MULTILINE : 0)) )
5964 dstr = newSVpvn_flags(s, m-s,
5965 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5968 /* The rx->minlen is in characters but we want to step
5969 * s ahead by bytes. */
5971 s = (char*)utf8_hop((U8*)m, len);
5973 s = m + len; /* Fake \n at the end */
5978 maxiters += slen * RX_NPARENS(rx);
5979 while (s < strend && --limit)
5983 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
5986 if (rex_return == 0)
5988 TAINT_IF(RX_MATCH_TAINTED(rx));
5989 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
5992 orig = RX_SUBBEG(rx);
5994 strend = s + (strend - m);
5996 m = RX_OFFS(rx)[0].start + orig;
6005 dstr = newSVpvn_flags(s, m-s,
6006 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6009 if (RX_NPARENS(rx)) {
6011 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
6012 s = RX_OFFS(rx)[i].start + orig;
6013 m = RX_OFFS(rx)[i].end + orig;
6015 /* japhy (07/27/01) -- the (m && s) test doesn't catch
6016 parens that didn't match -- they should be set to
6017 undef, not the empty string */
6025 if (m >= orig && s >= orig) {
6026 dstr = newSVpvn_flags(s, m-s,
6027 (do_utf8 ? SVf_UTF8 : 0)
6031 dstr = &PL_sv_undef; /* undef, not "" */
6037 s = RX_OFFS(rx)[0].end + orig;
6041 if (!gimme_scalar) {
6042 iters = (SP - PL_stack_base) - base;
6044 if (iters > maxiters)
6045 DIE(aTHX_ "Split loop");
6047 /* keep field after final delim? */
6048 if (s < strend || (iters && origlimit)) {
6049 if (!gimme_scalar) {
6050 const STRLEN l = strend - s;
6051 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
6056 else if (!origlimit) {
6058 iters -= trailing_empty;
6060 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
6061 if (TOPs && !make_mortal)
6063 *SP-- = &PL_sv_undef;
6070 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
6074 if (SvSMAGICAL(ary)) {
6076 mg_set(MUTABLE_SV(ary));
6079 if (gimme == G_ARRAY) {
6081 Copy(AvARRAY(ary), SP + 1, iters, SV*);
6088 ENTER_with_name("call_PUSH");
6089 call_method("PUSH",G_SCALAR|G_DISCARD);
6090 LEAVE_with_name("call_PUSH");
6092 if (gimme == G_ARRAY) {
6094 /* EXTEND should not be needed - we just popped them */
6096 for (i=0; i < iters; i++) {
6097 SV **svp = av_fetch(ary, i, FALSE);
6098 PUSHs((svp) ? *svp : &PL_sv_undef);
6105 if (gimme == G_ARRAY)
6117 SV *const sv = PAD_SVl(PL_op->op_targ);
6119 if (SvPADSTALE(sv)) {
6122 RETURNOP(cLOGOP->op_other);
6124 RETURNOP(cLOGOP->op_next);
6133 assert(SvTYPE(retsv) != SVt_PVCV);
6135 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV) {
6136 retsv = refto(retsv);
6143 PP(unimplemented_op)
6146 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", OP_NAME(PL_op),
6154 HV * const hv = (HV*)POPs;
6156 if (SvRMAGICAL(hv)) {
6157 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
6159 XPUSHs(magic_scalarpack(hv, mg));
6164 XPUSHs(boolSV(HvKEYS(hv) != 0));
6170 * c-indentation-style: bsd
6172 * indent-tabs-mode: t
6175 * ex: set ts=8 sts=4 sw=4 noet: