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) {
74 } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
75 const I32 flags = is_lvalue_sub();
76 if (flags && !(flags & OPpENTERSUB_INARGS)) {
77 if (GIMME == G_SCALAR)
78 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
84 if (gimme == G_ARRAY) {
85 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
87 if (SvMAGICAL(TARG)) {
89 for (i=0; i < (U32)maxarg; i++) {
90 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
91 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
95 Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
99 else if (gimme == G_SCALAR) {
100 SV* const sv = sv_newmortal();
101 const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
102 sv_setiv(sv, maxarg);
113 assert(SvTYPE(TARG) == SVt_PVHV);
115 if (PL_op->op_private & OPpLVAL_INTRO)
116 if (!(PL_op->op_private & OPpPAD_STATE))
117 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
118 if (PL_op->op_flags & OPf_REF)
120 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
121 const I32 flags = is_lvalue_sub();
122 if (flags && !(flags & OPpENTERSUB_INARGS)) {
123 if (GIMME == G_SCALAR)
124 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
129 if (gimme == G_ARRAY) {
130 RETURNOP(Perl_do_kv(aTHX));
132 else if (gimme == G_SCALAR) {
133 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
141 static const char S_no_symref_sv[] =
142 "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
144 /* In some cases this function inspects PL_op. If this function is called
145 for new op types, more bool parameters may need to be added in place of
148 When noinit is true, the absence of a gv will cause a retval of undef.
149 This is unrelated to the cv-to-gv assignment case.
153 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
157 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
160 sv = amagic_deref_call(sv, to_gv_amg);
164 if (SvTYPE(sv) == SVt_PVIO) {
165 GV * const gv = MUTABLE_GV(sv_newmortal());
166 gv_init(gv, 0, "$__ANONIO__", 11, 0);
167 GvIOp(gv) = MUTABLE_IO(sv);
168 SvREFCNT_inc_void_NN(sv);
171 else if (!isGV_with_GP(sv))
172 return (SV *)Perl_die(aTHX_ "Not a GLOB reference");
175 if (!isGV_with_GP(sv)) {
177 /* If this is a 'my' scalar and flag is set then vivify
180 if (vivify_sv && sv != &PL_sv_undef) {
183 Perl_croak_no_modify(aTHX);
184 if (cUNOP->op_targ) {
185 SV * const namesv = PAD_SV(cUNOP->op_targ);
186 gv = MUTABLE_GV(newSV(0));
187 gv_init_sv(gv, CopSTASH(PL_curcop), namesv, 0);
190 const char * const name = CopSTASHPV(PL_curcop);
191 gv = newGVgen_flags(name,
192 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
194 prepare_SV_for_RV(sv);
195 SvRV_set(sv, MUTABLE_SV(gv));
200 if (PL_op->op_flags & OPf_REF || strict)
201 return (SV *)Perl_die(aTHX_ PL_no_usym, "a symbol");
202 if (ckWARN(WARN_UNINITIALIZED))
208 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
209 sv, GV_ADDMG, SVt_PVGV
219 (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""),
222 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
223 == OPpDONT_INIT_GV) {
224 /* We are the target of a coderef assignment. Return
225 the scalar unchanged, and let pp_sasssign deal with
229 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
231 /* FAKE globs in the symbol table cause weird bugs (#77810) */
236 SV *newsv = sv_newmortal();
237 sv_setsv_flags(newsv, sv, 0);
249 sv, PL_op->op_private & OPpDEREF,
250 PL_op->op_private & HINT_STRICT_REFS,
251 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
252 || PL_op->op_type == OP_READLINE
254 if (PL_op->op_private & OPpLVAL_INTRO)
255 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
260 /* Helper function for pp_rv2sv and pp_rv2av */
262 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
263 const svtype type, SV ***spp)
268 PERL_ARGS_ASSERT_SOFTREF2XV;
270 if (PL_op->op_private & HINT_STRICT_REFS) {
272 Perl_die(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), what);
274 Perl_die(aTHX_ PL_no_usym, what);
278 PL_op->op_flags & OPf_REF &&
279 PL_op->op_next->op_type != OP_BOOLKEYS
281 Perl_die(aTHX_ PL_no_usym, what);
282 if (ckWARN(WARN_UNINITIALIZED))
284 if (type != SVt_PV && GIMME_V == G_ARRAY) {
288 **spp = &PL_sv_undef;
291 if ((PL_op->op_flags & OPf_SPECIAL) &&
292 !(PL_op->op_flags & OPf_MOD))
294 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
296 **spp = &PL_sv_undef;
301 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
314 sv = amagic_deref_call(sv, to_sv_amg);
318 switch (SvTYPE(sv)) {
324 DIE(aTHX_ "Not a SCALAR reference");
331 if (!isGV_with_GP(gv)) {
332 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
338 if (PL_op->op_flags & OPf_MOD) {
339 if (PL_op->op_private & OPpLVAL_INTRO) {
340 if (cUNOP->op_first->op_type == OP_NULL)
341 sv = save_scalar(MUTABLE_GV(TOPs));
343 sv = save_scalar(gv);
345 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
347 else if (PL_op->op_private & OPpDEREF)
348 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
357 AV * const av = MUTABLE_AV(TOPs);
358 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
360 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
362 *sv = newSV_type(SVt_PVMG);
363 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
367 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
376 if (PL_op->op_flags & OPf_MOD || LVRET) {
377 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
378 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
380 LvTARG(ret) = SvREFCNT_inc_simple(sv);
381 PUSHs(ret); /* no SvSETMAGIC */
385 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
386 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
387 if (mg && mg->mg_len >= 0) {
405 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
407 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT)) == OPpMAY_RETURN_CONSTANT)
410 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
411 /* (But not in defined().) */
413 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
416 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
417 if ((PL_op->op_private & OPpLVAL_INTRO)) {
418 if (gv && GvCV(gv) == cv && (gv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
421 DIE(aTHX_ "Can't modify non-lvalue subroutine call");
424 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
428 cv = MUTABLE_CV(&PL_sv_undef);
429 SETs(MUTABLE_SV(cv));
439 SV *ret = &PL_sv_undef;
441 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
442 const char * s = SvPVX_const(TOPs);
443 if (strnEQ(s, "CORE::", 6)) {
444 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
445 if (!code || code == -KEY_CORE)
446 DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
447 if (code < 0) { /* Overridable. */
448 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
454 cv = sv_2cv(TOPs, &stash, &gv, 0);
456 ret = newSVpvn_flags(
457 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
467 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
469 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
471 PUSHs(MUTABLE_SV(cv));
485 if (GIMME != G_ARRAY) {
489 *MARK = &PL_sv_undef;
490 *MARK = refto(*MARK);
494 EXTEND_MORTAL(SP - MARK);
496 *MARK = refto(*MARK);
501 S_refto(pTHX_ SV *sv)
506 PERL_ARGS_ASSERT_REFTO;
508 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
511 if (!(sv = LvTARG(sv)))
514 SvREFCNT_inc_void_NN(sv);
516 else if (SvTYPE(sv) == SVt_PVAV) {
517 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
518 av_reify(MUTABLE_AV(sv));
520 SvREFCNT_inc_void_NN(sv);
522 else if (SvPADTMP(sv) && !IS_PADGV(sv))
526 SvREFCNT_inc_void_NN(sv);
529 sv_upgrade(rv, SVt_IV);
538 SV * const sv = POPs;
543 if (!sv || !SvROK(sv))
546 (void)sv_ref(TARG,SvRV(sv),TRUE);
558 stash = CopSTASH(PL_curcop);
560 SV * const ssv = POPs;
564 if (!ssv) goto curstash;
565 if (!SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
566 Perl_croak(aTHX_ "Attempt to bless into a reference");
567 ptr = SvPV_const(ssv,len);
569 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
570 "Explicit blessing to '' (assuming package main)");
571 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
574 (void)sv_bless(TOPs, stash);
584 const char * const elem = SvPV_const(sv, len);
585 GV * const gv = MUTABLE_GV(POPs);
590 /* elem will always be NUL terminated. */
591 const char * const second_letter = elem + 1;
594 if (len == 5 && strEQ(second_letter, "RRAY"))
595 tmpRef = MUTABLE_SV(GvAV(gv));
598 if (len == 4 && strEQ(second_letter, "ODE"))
599 tmpRef = MUTABLE_SV(GvCVu(gv));
602 if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
603 /* finally deprecated in 5.8.0 */
604 deprecate("*glob{FILEHANDLE}");
605 tmpRef = MUTABLE_SV(GvIOp(gv));
608 if (len == 6 && strEQ(second_letter, "ORMAT"))
609 tmpRef = MUTABLE_SV(GvFORM(gv));
612 if (len == 4 && strEQ(second_letter, "LOB"))
613 tmpRef = MUTABLE_SV(gv);
616 if (len == 4 && strEQ(second_letter, "ASH"))
617 tmpRef = MUTABLE_SV(GvHV(gv));
620 if (*second_letter == 'O' && !elem[2] && len == 2)
621 tmpRef = MUTABLE_SV(GvIOp(gv));
624 if (len == 4 && strEQ(second_letter, "AME"))
625 sv = newSVhek(GvNAME_HEK(gv));
628 if (len == 7 && strEQ(second_letter, "ACKAGE")) {
629 const HV * const stash = GvSTASH(gv);
630 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
631 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
635 if (len == 6 && strEQ(second_letter, "CALAR"))
650 /* Pattern matching */
655 register unsigned char *s;
658 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_study) : NULL;
662 if (mg && SvSCREAM(sv))
665 s = (unsigned char*)(SvPV(sv, len));
666 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
667 /* No point in studying a zero length string, and not safe to study
668 anything that doesn't appear to be a simple scalar (and hence might
669 change between now and when the regexp engine runs without our set
670 magic ever running) such as a reference to an object with overloaded
671 stringification. Also refuse to study an FBM scalar, as this gives
672 more flexibility in SV flag usage. No real-world code would ever
673 end up studying an FBM scalar, so this isn't a real pessimisation.
674 Endemic use of I32 in Perl_screaminstr makes it hard to safely push
675 the study length limit from I32_MAX to U32_MAX - 1.
682 } else if (len < 0xFFFF) {
687 size = (256 + len) * quanta;
688 sfirst_raw = (char *)safemalloc(size);
691 DIE(aTHX_ "do_study: out of memory");
695 mg = sv_magicext(sv, NULL, PERL_MAGIC_study, &PL_vtbl_regexp, NULL, 0);
696 mg->mg_ptr = sfirst_raw;
698 mg->mg_private = quanta;
700 memset(sfirst_raw, ~0, 256 * quanta);
702 /* The assumption here is that most studied strings are fairly short, hence
703 the pain of the extra code is worth it, given the memory savings.
704 80 character string, 336 bytes as U8, down from 1344 as U32
705 800 character string, 2112 bytes as U16, down from 4224 as U32
709 U8 *const sfirst = (U8 *)sfirst_raw;
710 U8 *const snext = sfirst + 256;
712 const U8 ch = s[len];
713 snext[len] = sfirst[ch];
716 } else if (quanta == 2) {
717 U16 *const sfirst = (U16 *)sfirst_raw;
718 U16 *const snext = sfirst + 256;
720 const U8 ch = s[len];
721 snext[len] = sfirst[ch];
725 U32 *const sfirst = (U32 *)sfirst_raw;
726 U32 *const snext = sfirst + 256;
728 const U8 ch = s[len];
729 snext[len] = sfirst[ch];
742 if (PL_op->op_flags & OPf_STACKED)
744 else if (PL_op->op_private & OPpTARGET_MY)
750 TARG = sv_newmortal();
751 if(PL_op->op_type == OP_TRANSR) {
753 const char * const pv = SvPV(sv,len);
754 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
758 else PUSHi(do_trans(sv));
762 /* Lvalue operators. */
765 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
771 PERL_ARGS_ASSERT_DO_CHOMP;
773 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
775 if (SvTYPE(sv) == SVt_PVAV) {
777 AV *const av = MUTABLE_AV(sv);
778 const I32 max = AvFILL(av);
780 for (i = 0; i <= max; i++) {
781 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
782 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
783 do_chomp(retval, sv, chomping);
787 else if (SvTYPE(sv) == SVt_PVHV) {
788 HV* const hv = MUTABLE_HV(sv);
790 (void)hv_iterinit(hv);
791 while ((entry = hv_iternext(hv)))
792 do_chomp(retval, hv_iterval(hv,entry), chomping);
795 else if (SvREADONLY(sv)) {
797 /* SV is copy-on-write */
798 sv_force_normal_flags(sv, 0);
801 Perl_croak_no_modify(aTHX);
806 /* XXX, here sv is utf8-ized as a side-effect!
807 If encoding.pm is used properly, almost string-generating
808 operations, including literal strings, chr(), input data, etc.
809 should have been utf8-ized already, right?
811 sv_recode_to_utf8(sv, PL_encoding);
817 char *temp_buffer = NULL;
826 while (len && s[-1] == '\n') {
833 STRLEN rslen, rs_charlen;
834 const char *rsptr = SvPV_const(PL_rs, rslen);
836 rs_charlen = SvUTF8(PL_rs)
840 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
841 /* Assumption is that rs is shorter than the scalar. */
843 /* RS is utf8, scalar is 8 bit. */
845 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
848 /* Cannot downgrade, therefore cannot possibly match
850 assert (temp_buffer == rsptr);
856 else if (PL_encoding) {
857 /* RS is 8 bit, encoding.pm is used.
858 * Do not recode PL_rs as a side-effect. */
859 svrecode = newSVpvn(rsptr, rslen);
860 sv_recode_to_utf8(svrecode, PL_encoding);
861 rsptr = SvPV_const(svrecode, rslen);
862 rs_charlen = sv_len_utf8(svrecode);
865 /* RS is 8 bit, scalar is utf8. */
866 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
880 if (memNE(s, rsptr, rslen))
882 SvIVX(retval) += rs_charlen;
885 s = SvPV_force_nomg_nolen(sv);
893 SvREFCNT_dec(svrecode);
895 Safefree(temp_buffer);
897 if (len && !SvPOK(sv))
898 s = SvPV_force_nomg(sv, len);
901 char * const send = s + len;
902 char * const start = s;
904 while (s > start && UTF8_IS_CONTINUATION(*s))
906 if (is_utf8_string((U8*)s, send - s)) {
907 sv_setpvn(retval, s, send - s);
909 SvCUR_set(sv, s - start);
915 sv_setpvs(retval, "");
919 sv_setpvn(retval, s, 1);
926 sv_setpvs(retval, "");
934 const bool chomping = PL_op->op_type == OP_SCHOMP;
938 do_chomp(TARG, TOPs, chomping);
945 dVAR; dSP; dMARK; dTARGET; dORIGMARK;
946 const bool chomping = PL_op->op_type == OP_CHOMP;
951 do_chomp(TARG, *++MARK, chomping);
962 if (!PL_op->op_private) {
971 SV_CHECK_THINKFIRST_COW_DROP(sv);
973 switch (SvTYPE(sv)) {
977 av_undef(MUTABLE_AV(sv));
980 hv_undef(MUTABLE_HV(sv));
983 if (cv_const_sv((const CV *)sv))
984 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
985 "Constant subroutine %"SVf" undefined",
986 SVfARG(CvANON((const CV *)sv)
987 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
988 : sv_2mortal(newSVhek(GvENAME_HEK(CvGV((const CV *)sv))))));
992 /* let user-undef'd sub keep its identity */
993 GV* const gv = CvGV((const CV *)sv);
994 cv_undef(MUTABLE_CV(sv));
995 CvGV_set(MUTABLE_CV(sv), gv);
1000 SvSetMagicSV(sv, &PL_sv_undef);
1003 else if (isGV_with_GP(sv)) {
1007 /* undef *Pkg::meth_name ... */
1009 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1010 && HvENAME_get(stash);
1012 if((stash = GvHV((const GV *)sv))) {
1013 if(HvENAME_get(stash))
1014 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1018 gp_free(MUTABLE_GV(sv));
1020 GvGP_set(sv, gp_ref(gp));
1021 GvSV(sv) = newSV(0);
1022 GvLINE(sv) = CopLINE(PL_curcop);
1023 GvEGV(sv) = MUTABLE_GV(sv);
1027 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1029 /* undef *Foo::ISA */
1030 if( strEQ(GvNAME((const GV *)sv), "ISA")
1031 && (stash = GvSTASH((const GV *)sv))
1032 && (method_changed || HvENAME(stash)) )
1033 mro_isa_changed_in(stash);
1034 else if(method_changed)
1035 mro_method_changed_in(
1036 GvSTASH((const GV *)sv)
1043 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1059 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1060 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
1061 Perl_croak_no_modify(aTHX);
1063 TARG = sv_newmortal();
1064 sv_setsv(TARG, TOPs);
1065 if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1066 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
1068 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
1069 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1073 else sv_dec_nomg(TOPs);
1075 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1076 if (inc && !SvOK(TARG))
1082 /* Ordinary operators. */
1086 dVAR; dSP; dATARGET; SV *svl, *svr;
1087 #ifdef PERL_PRESERVE_IVUV
1090 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1093 #ifdef PERL_PRESERVE_IVUV
1094 /* For integer to integer power, we do the calculation by hand wherever
1095 we're sure it is safe; otherwise we call pow() and try to convert to
1096 integer afterwards. */
1098 SvIV_please_nomg(svr);
1100 SvIV_please_nomg(svl);
1109 const IV iv = SvIVX(svr);
1113 goto float_it; /* Can't do negative powers this way. */
1117 baseuok = SvUOK(svl);
1119 baseuv = SvUVX(svl);
1121 const IV iv = SvIVX(svl);
1124 baseuok = TRUE; /* effectively it's a UV now */
1126 baseuv = -iv; /* abs, baseuok == false records sign */
1129 /* now we have integer ** positive integer. */
1132 /* foo & (foo - 1) is zero only for a power of 2. */
1133 if (!(baseuv & (baseuv - 1))) {
1134 /* We are raising power-of-2 to a positive integer.
1135 The logic here will work for any base (even non-integer
1136 bases) but it can be less accurate than
1137 pow (base,power) or exp (power * log (base)) when the
1138 intermediate values start to spill out of the mantissa.
1139 With powers of 2 we know this can't happen.
1140 And powers of 2 are the favourite thing for perl
1141 programmers to notice ** not doing what they mean. */
1143 NV base = baseuok ? baseuv : -(NV)baseuv;
1148 while (power >>= 1) {
1156 SvIV_please_nomg(svr);
1159 register unsigned int highbit = 8 * sizeof(UV);
1160 register unsigned int diff = 8 * sizeof(UV);
1161 while (diff >>= 1) {
1163 if (baseuv >> highbit) {
1167 /* we now have baseuv < 2 ** highbit */
1168 if (power * highbit <= 8 * sizeof(UV)) {
1169 /* result will definitely fit in UV, so use UV math
1170 on same algorithm as above */
1171 register UV result = 1;
1172 register UV base = baseuv;
1173 const bool odd_power = cBOOL(power & 1);
1177 while (power >>= 1) {
1184 if (baseuok || !odd_power)
1185 /* answer is positive */
1187 else if (result <= (UV)IV_MAX)
1188 /* answer negative, fits in IV */
1189 SETi( -(IV)result );
1190 else if (result == (UV)IV_MIN)
1191 /* 2's complement assumption: special case IV_MIN */
1194 /* answer negative, doesn't fit */
1195 SETn( -(NV)result );
1205 NV right = SvNV_nomg(svr);
1206 NV left = SvNV_nomg(svl);
1209 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1211 We are building perl with long double support and are on an AIX OS
1212 afflicted with a powl() function that wrongly returns NaNQ for any
1213 negative base. This was reported to IBM as PMR #23047-379 on
1214 03/06/2006. The problem exists in at least the following versions
1215 of AIX and the libm fileset, and no doubt others as well:
1217 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1218 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1219 AIX 5.2.0 bos.adt.libm 5.2.0.85
1221 So, until IBM fixes powl(), we provide the following workaround to
1222 handle the problem ourselves. Our logic is as follows: for
1223 negative bases (left), we use fmod(right, 2) to check if the
1224 exponent is an odd or even integer:
1226 - if odd, powl(left, right) == -powl(-left, right)
1227 - if even, powl(left, right) == powl(-left, right)
1229 If the exponent is not an integer, the result is rightly NaNQ, so
1230 we just return that (as NV_NAN).
1234 NV mod2 = Perl_fmod( right, 2.0 );
1235 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1236 SETn( -Perl_pow( -left, right) );
1237 } else if (mod2 == 0.0) { /* even integer */
1238 SETn( Perl_pow( -left, right) );
1239 } else { /* fractional power */
1243 SETn( Perl_pow( left, right) );
1246 SETn( Perl_pow( left, right) );
1247 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1249 #ifdef PERL_PRESERVE_IVUV
1251 SvIV_please_nomg(svr);
1259 dVAR; dSP; dATARGET; SV *svl, *svr;
1260 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1263 #ifdef PERL_PRESERVE_IVUV
1264 SvIV_please_nomg(svr);
1266 /* Unless the left argument is integer in range we are going to have to
1267 use NV maths. Hence only attempt to coerce the right argument if
1268 we know the left is integer. */
1269 /* Left operand is defined, so is it IV? */
1270 SvIV_please_nomg(svl);
1272 bool auvok = SvUOK(svl);
1273 bool buvok = SvUOK(svr);
1274 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1275 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1284 const IV aiv = SvIVX(svl);
1287 auvok = TRUE; /* effectively it's a UV now */
1289 alow = -aiv; /* abs, auvok == false records sign */
1295 const IV biv = SvIVX(svr);
1298 buvok = TRUE; /* effectively it's a UV now */
1300 blow = -biv; /* abs, buvok == false records sign */
1304 /* If this does sign extension on unsigned it's time for plan B */
1305 ahigh = alow >> (4 * sizeof (UV));
1307 bhigh = blow >> (4 * sizeof (UV));
1309 if (ahigh && bhigh) {
1311 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1312 which is overflow. Drop to NVs below. */
1313 } else if (!ahigh && !bhigh) {
1314 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1315 so the unsigned multiply cannot overflow. */
1316 const UV product = alow * blow;
1317 if (auvok == buvok) {
1318 /* -ve * -ve or +ve * +ve gives a +ve result. */
1322 } else if (product <= (UV)IV_MIN) {
1323 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1324 /* -ve result, which could overflow an IV */
1326 SETi( -(IV)product );
1328 } /* else drop to NVs below. */
1330 /* One operand is large, 1 small */
1333 /* swap the operands */
1335 bhigh = blow; /* bhigh now the temp var for the swap */
1339 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1340 multiplies can't overflow. shift can, add can, -ve can. */
1341 product_middle = ahigh * blow;
1342 if (!(product_middle & topmask)) {
1343 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1345 product_middle <<= (4 * sizeof (UV));
1346 product_low = alow * blow;
1348 /* as for pp_add, UV + something mustn't get smaller.
1349 IIRC ANSI mandates this wrapping *behaviour* for
1350 unsigned whatever the actual representation*/
1351 product_low += product_middle;
1352 if (product_low >= product_middle) {
1353 /* didn't overflow */
1354 if (auvok == buvok) {
1355 /* -ve * -ve or +ve * +ve gives a +ve result. */
1357 SETu( product_low );
1359 } else if (product_low <= (UV)IV_MIN) {
1360 /* 2s complement assumption again */
1361 /* -ve result, which could overflow an IV */
1363 SETi( -(IV)product_low );
1365 } /* else drop to NVs below. */
1367 } /* product_middle too large */
1368 } /* ahigh && bhigh */
1373 NV right = SvNV_nomg(svr);
1374 NV left = SvNV_nomg(svl);
1376 SETn( left * right );
1383 dVAR; dSP; dATARGET; SV *svl, *svr;
1384 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1387 /* Only try to do UV divide first
1388 if ((SLOPPYDIVIDE is true) or
1389 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1391 The assumption is that it is better to use floating point divide
1392 whenever possible, only doing integer divide first if we can't be sure.
1393 If NV_PRESERVES_UV is true then we know at compile time that no UV
1394 can be too large to preserve, so don't need to compile the code to
1395 test the size of UVs. */
1398 # define PERL_TRY_UV_DIVIDE
1399 /* ensure that 20./5. == 4. */
1401 # ifdef PERL_PRESERVE_IVUV
1402 # ifndef NV_PRESERVES_UV
1403 # define PERL_TRY_UV_DIVIDE
1408 #ifdef PERL_TRY_UV_DIVIDE
1409 SvIV_please_nomg(svr);
1411 SvIV_please_nomg(svl);
1413 bool left_non_neg = SvUOK(svl);
1414 bool right_non_neg = SvUOK(svr);
1418 if (right_non_neg) {
1422 const IV biv = SvIVX(svr);
1425 right_non_neg = TRUE; /* effectively it's a UV now */
1431 /* historically undef()/0 gives a "Use of uninitialized value"
1432 warning before dieing, hence this test goes here.
1433 If it were immediately before the second SvIV_please, then
1434 DIE() would be invoked before left was even inspected, so
1435 no inspection would give no warning. */
1437 DIE(aTHX_ "Illegal division by zero");
1443 const IV aiv = SvIVX(svl);
1446 left_non_neg = TRUE; /* effectively it's a UV now */
1455 /* For sloppy divide we always attempt integer division. */
1457 /* Otherwise we only attempt it if either or both operands
1458 would not be preserved by an NV. If both fit in NVs
1459 we fall through to the NV divide code below. However,
1460 as left >= right to ensure integer result here, we know that
1461 we can skip the test on the right operand - right big
1462 enough not to be preserved can't get here unless left is
1465 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1468 /* Integer division can't overflow, but it can be imprecise. */
1469 const UV result = left / right;
1470 if (result * right == left) {
1471 SP--; /* result is valid */
1472 if (left_non_neg == right_non_neg) {
1473 /* signs identical, result is positive. */
1477 /* 2s complement assumption */
1478 if (result <= (UV)IV_MIN)
1479 SETi( -(IV)result );
1481 /* It's exact but too negative for IV. */
1482 SETn( -(NV)result );
1485 } /* tried integer divide but it was not an integer result */
1486 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1487 } /* left wasn't SvIOK */
1488 } /* right wasn't SvIOK */
1489 #endif /* PERL_TRY_UV_DIVIDE */
1491 NV right = SvNV_nomg(svr);
1492 NV left = SvNV_nomg(svl);
1493 (void)POPs;(void)POPs;
1494 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1495 if (! Perl_isnan(right) && right == 0.0)
1499 DIE(aTHX_ "Illegal division by zero");
1500 PUSHn( left / right );
1507 dVAR; dSP; dATARGET;
1508 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1512 bool left_neg = FALSE;
1513 bool right_neg = FALSE;
1514 bool use_double = FALSE;
1515 bool dright_valid = FALSE;
1518 SV * const svr = TOPs;
1519 SV * const svl = TOPm1s;
1520 SvIV_please_nomg(svr);
1522 right_neg = !SvUOK(svr);
1526 const IV biv = SvIVX(svr);
1529 right_neg = FALSE; /* effectively it's a UV now */
1536 dright = SvNV_nomg(svr);
1537 right_neg = dright < 0;
1540 if (dright < UV_MAX_P1) {
1541 right = U_V(dright);
1542 dright_valid = TRUE; /* In case we need to use double below. */
1548 /* At this point use_double is only true if right is out of range for
1549 a UV. In range NV has been rounded down to nearest UV and
1550 use_double false. */
1551 SvIV_please_nomg(svl);
1552 if (!use_double && SvIOK(svl)) {
1554 left_neg = !SvUOK(svl);
1558 const IV aiv = SvIVX(svl);
1561 left_neg = FALSE; /* effectively it's a UV now */
1569 dleft = SvNV_nomg(svl);
1570 left_neg = dleft < 0;
1574 /* This should be exactly the 5.6 behaviour - if left and right are
1575 both in range for UV then use U_V() rather than floor. */
1577 if (dleft < UV_MAX_P1) {
1578 /* right was in range, so is dleft, so use UVs not double.
1582 /* left is out of range for UV, right was in range, so promote
1583 right (back) to double. */
1585 /* The +0.5 is used in 5.6 even though it is not strictly
1586 consistent with the implicit +0 floor in the U_V()
1587 inside the #if 1. */
1588 dleft = Perl_floor(dleft + 0.5);
1591 dright = Perl_floor(dright + 0.5);
1602 DIE(aTHX_ "Illegal modulus zero");
1604 dans = Perl_fmod(dleft, dright);
1605 if ((left_neg != right_neg) && dans)
1606 dans = dright - dans;
1609 sv_setnv(TARG, dans);
1615 DIE(aTHX_ "Illegal modulus zero");
1618 if ((left_neg != right_neg) && ans)
1621 /* XXX may warn: unary minus operator applied to unsigned type */
1622 /* could change -foo to be (~foo)+1 instead */
1623 if (ans <= ~((UV)IV_MAX)+1)
1624 sv_setiv(TARG, ~ans+1);
1626 sv_setnv(TARG, -(NV)ans);
1629 sv_setuv(TARG, ans);
1638 dVAR; dSP; dATARGET;
1642 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1643 /* TODO: think of some way of doing list-repeat overloading ??? */
1648 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1654 const UV uv = SvUV_nomg(sv);
1656 count = IV_MAX; /* The best we can do? */
1660 const IV iv = SvIV_nomg(sv);
1667 else if (SvNOKp(sv)) {
1668 const NV nv = SvNV_nomg(sv);
1675 count = SvIV_nomg(sv);
1677 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1679 static const char oom_list_extend[] = "Out of memory during list extend";
1680 const I32 items = SP - MARK;
1681 const I32 max = items * count;
1683 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1684 /* Did the max computation overflow? */
1685 if (items > 0 && max > 0 && (max < items || max < count))
1686 Perl_croak(aTHX_ oom_list_extend);
1691 /* This code was intended to fix 20010809.028:
1694 for (($x =~ /./g) x 2) {
1695 print chop; # "abcdabcd" expected as output.
1698 * but that change (#11635) broke this code:
1700 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1702 * I can't think of a better fix that doesn't introduce
1703 * an efficiency hit by copying the SVs. The stack isn't
1704 * refcounted, and mortalisation obviously doesn't
1705 * Do The Right Thing when the stack has more than
1706 * one pointer to the same mortal value.
1710 *SP = sv_2mortal(newSVsv(*SP));
1720 repeatcpy((char*)(MARK + items), (char*)MARK,
1721 items * sizeof(const SV *), count - 1);
1724 else if (count <= 0)
1727 else { /* Note: mark already snarfed by pp_list */
1728 SV * const tmpstr = POPs;
1731 static const char oom_string_extend[] =
1732 "Out of memory during string extend";
1735 sv_setsv_nomg(TARG, tmpstr);
1736 SvPV_force_nomg(TARG, len);
1737 isutf = DO_UTF8(TARG);
1742 const STRLEN max = (UV)count * len;
1743 if (len > MEM_SIZE_MAX / count)
1744 Perl_croak(aTHX_ oom_string_extend);
1745 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1746 SvGROW(TARG, max + 1);
1747 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1748 SvCUR_set(TARG, SvCUR(TARG) * count);
1750 *SvEND(TARG) = '\0';
1753 (void)SvPOK_only_UTF8(TARG);
1755 (void)SvPOK_only(TARG);
1757 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1758 /* The parser saw this as a list repeat, and there
1759 are probably several items on the stack. But we're
1760 in scalar context, and there's no pp_list to save us
1761 now. So drop the rest of the items -- robin@kitsite.com
1773 dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
1774 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1777 useleft = USE_LEFT(svl);
1778 #ifdef PERL_PRESERVE_IVUV
1779 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1780 "bad things" happen if you rely on signed integers wrapping. */
1781 SvIV_please_nomg(svr);
1783 /* Unless the left argument is integer in range we are going to have to
1784 use NV maths. Hence only attempt to coerce the right argument if
1785 we know the left is integer. */
1786 register UV auv = 0;
1792 a_valid = auvok = 1;
1793 /* left operand is undef, treat as zero. */
1795 /* Left operand is defined, so is it IV? */
1796 SvIV_please_nomg(svl);
1798 if ((auvok = SvUOK(svl)))
1801 register const IV aiv = SvIVX(svl);
1804 auvok = 1; /* Now acting as a sign flag. */
1805 } else { /* 2s complement assumption for IV_MIN */
1813 bool result_good = 0;
1816 bool buvok = SvUOK(svr);
1821 register const IV biv = SvIVX(svr);
1828 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1829 else "IV" now, independent of how it came in.
1830 if a, b represents positive, A, B negative, a maps to -A etc
1835 all UV maths. negate result if A negative.
1836 subtract if signs same, add if signs differ. */
1838 if (auvok ^ buvok) {
1847 /* Must get smaller */
1852 if (result <= buv) {
1853 /* result really should be -(auv-buv). as its negation
1854 of true value, need to swap our result flag */
1866 if (result <= (UV)IV_MIN)
1867 SETi( -(IV)result );
1869 /* result valid, but out of range for IV. */
1870 SETn( -(NV)result );
1874 } /* Overflow, drop through to NVs. */
1879 NV value = SvNV_nomg(svr);
1883 /* left operand is undef, treat as zero - value */
1887 SETn( SvNV_nomg(svl) - value );
1894 dVAR; dSP; dATARGET; SV *svl, *svr;
1895 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1899 const IV shift = SvIV_nomg(svr);
1900 if (PL_op->op_private & HINT_INTEGER) {
1901 const IV i = SvIV_nomg(svl);
1905 const UV u = SvUV_nomg(svl);
1914 dVAR; dSP; dATARGET; SV *svl, *svr;
1915 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
1919 const IV shift = SvIV_nomg(svr);
1920 if (PL_op->op_private & HINT_INTEGER) {
1921 const IV i = SvIV_nomg(svl);
1925 const UV u = SvUV_nomg(svl);
1937 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
1941 (SvIOK_notUV(left) && SvIOK_notUV(right))
1942 ? (SvIVX(left) < SvIVX(right))
1943 : (do_ncmp(left, right) == -1)
1953 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1957 (SvIOK_notUV(left) && SvIOK_notUV(right))
1958 ? (SvIVX(left) > SvIVX(right))
1959 : (do_ncmp(left, right) == 1)
1969 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1973 (SvIOK_notUV(left) && SvIOK_notUV(right))
1974 ? (SvIVX(left) <= SvIVX(right))
1975 : (do_ncmp(left, right) <= 0)
1985 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1989 (SvIOK_notUV(left) && SvIOK_notUV(right))
1990 ? (SvIVX(left) >= SvIVX(right))
1991 : ( (do_ncmp(left, right) & 2) == 0)
2001 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2005 (SvIOK_notUV(left) && SvIOK_notUV(right))
2006 ? (SvIVX(left) != SvIVX(right))
2007 : (do_ncmp(left, right) != 0)
2012 /* compare left and right SVs. Returns:
2016 * 2: left or right was a NaN
2019 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2023 PERL_ARGS_ASSERT_DO_NCMP;
2024 #ifdef PERL_PRESERVE_IVUV
2025 SvIV_please_nomg(right);
2026 /* Fortunately it seems NaN isn't IOK */
2028 SvIV_please_nomg(left);
2031 const IV leftiv = SvIVX(left);
2032 if (!SvUOK(right)) {
2033 /* ## IV <=> IV ## */
2034 const IV rightiv = SvIVX(right);
2035 return (leftiv > rightiv) - (leftiv < rightiv);
2037 /* ## IV <=> UV ## */
2039 /* As (b) is a UV, it's >=0, so it must be < */
2042 const UV rightuv = SvUVX(right);
2043 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2048 /* ## UV <=> UV ## */
2049 const UV leftuv = SvUVX(left);
2050 const UV rightuv = SvUVX(right);
2051 return (leftuv > rightuv) - (leftuv < rightuv);
2053 /* ## UV <=> IV ## */
2055 const IV rightiv = SvIVX(right);
2057 /* As (a) is a UV, it's >=0, so it cannot be < */
2060 const UV leftuv = SvUVX(left);
2061 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2069 NV const rnv = SvNV_nomg(right);
2070 NV const lnv = SvNV_nomg(left);
2072 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2073 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2076 return (lnv > rnv) - (lnv < rnv);
2095 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2098 value = do_ncmp(left, right);
2113 int amg_type = sle_amg;
2117 switch (PL_op->op_type) {
2136 tryAMAGICbin_MG(amg_type, AMGf_set);
2139 const int cmp = (IN_LOCALE_RUNTIME
2140 ? sv_cmp_locale_flags(left, right, 0)
2141 : sv_cmp_flags(left, right, 0));
2142 SETs(boolSV(cmp * multiplier < rhs));
2150 tryAMAGICbin_MG(seq_amg, AMGf_set);
2153 SETs(boolSV(sv_eq_flags(left, right, 0)));
2161 tryAMAGICbin_MG(sne_amg, AMGf_set);
2164 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2172 tryAMAGICbin_MG(scmp_amg, 0);
2175 const int cmp = (IN_LOCALE_RUNTIME
2176 ? sv_cmp_locale_flags(left, right, 0)
2177 : sv_cmp_flags(left, right, 0));
2185 dVAR; dSP; dATARGET;
2186 tryAMAGICbin_MG(band_amg, AMGf_assign);
2189 if (SvNIOKp(left) || SvNIOKp(right)) {
2190 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2191 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2192 if (PL_op->op_private & HINT_INTEGER) {
2193 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2197 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2200 if (left_ro_nonnum) SvNIOK_off(left);
2201 if (right_ro_nonnum) SvNIOK_off(right);
2204 do_vop(PL_op->op_type, TARG, left, right);
2213 dVAR; dSP; dATARGET;
2214 const int op_type = PL_op->op_type;
2216 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2219 if (SvNIOKp(left) || SvNIOKp(right)) {
2220 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2221 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2222 if (PL_op->op_private & HINT_INTEGER) {
2223 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2224 const IV r = SvIV_nomg(right);
2225 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2229 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2230 const UV r = SvUV_nomg(right);
2231 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2234 if (left_ro_nonnum) SvNIOK_off(left);
2235 if (right_ro_nonnum) SvNIOK_off(right);
2238 do_vop(op_type, TARG, left, right);
2248 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2250 SV * const sv = TOPs;
2251 const int flags = SvFLAGS(sv);
2253 if( !SvNIOK( sv ) && looks_like_number( sv ) ){
2257 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
2258 /* It's publicly an integer, or privately an integer-not-float */
2261 if (SvIVX(sv) == IV_MIN) {
2262 /* 2s complement assumption. */
2263 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) == IV_MIN */
2266 else if (SvUVX(sv) <= IV_MAX) {
2271 else if (SvIVX(sv) != IV_MIN) {
2275 #ifdef PERL_PRESERVE_IVUV
2283 SETn(-SvNV_nomg(sv));
2284 else if (SvPOKp(sv)) {
2286 const char * const s = SvPV_nomg_const(sv, len);
2287 if (isIDFIRST(*s)) {
2288 sv_setpvs(TARG, "-");
2291 else if (*s == '+' || *s == '-') {
2292 sv_setsv_nomg(TARG, sv);
2293 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2295 else if (DO_UTF8(sv)) {
2296 SvIV_please_nomg(sv);
2298 goto oops_its_an_int;
2300 sv_setnv(TARG, -SvNV_nomg(sv));
2302 sv_setpvs(TARG, "-");
2307 SvIV_please_nomg(sv);
2309 goto oops_its_an_int;
2310 sv_setnv(TARG, -SvNV_nomg(sv));
2315 SETn(-SvNV_nomg(sv));
2323 tryAMAGICun_MG(not_amg, AMGf_set);
2324 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2331 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2335 if (PL_op->op_private & HINT_INTEGER) {
2336 const IV i = ~SvIV_nomg(sv);
2340 const UV u = ~SvUV_nomg(sv);
2349 (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
2350 sv_setsv_nomg(TARG, sv);
2351 tmps = (U8*)SvPV_force_nomg(TARG, len);
2354 /* Calculate exact length, let's not estimate. */
2359 U8 * const send = tmps + len;
2360 U8 * const origtmps = tmps;
2361 const UV utf8flags = UTF8_ALLOW_ANYUV;
2363 while (tmps < send) {
2364 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2366 targlen += UNISKIP(~c);
2372 /* Now rewind strings and write them. */
2379 Newx(result, targlen + 1, U8);
2381 while (tmps < send) {
2382 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2384 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2387 sv_usepvn_flags(TARG, (char*)result, targlen,
2388 SV_HAS_TRAILING_NUL);
2395 Newx(result, nchar + 1, U8);
2397 while (tmps < send) {
2398 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2403 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2411 register long *tmpl;
2412 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2415 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2420 for ( ; anum > 0; anum--, tmps++)
2428 /* integer versions of some of the above */
2432 dVAR; dSP; dATARGET;
2433 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2436 SETi( left * right );
2444 dVAR; dSP; dATARGET;
2445 tryAMAGICbin_MG(div_amg, AMGf_assign);
2448 IV value = SvIV_nomg(right);
2450 DIE(aTHX_ "Illegal division by zero");
2451 num = SvIV_nomg(left);
2453 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2457 value = num / value;
2463 #if defined(__GLIBC__) && IVSIZE == 8
2470 /* This is the vanilla old i_modulo. */
2471 dVAR; dSP; dATARGET;
2472 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2476 DIE(aTHX_ "Illegal modulus zero");
2477 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2481 SETi( left % right );
2486 #if defined(__GLIBC__) && IVSIZE == 8
2491 /* This is the i_modulo with the workaround for the _moddi3 bug
2492 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2493 * See below for pp_i_modulo. */
2494 dVAR; dSP; dATARGET;
2495 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2499 DIE(aTHX_ "Illegal modulus zero");
2500 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2504 SETi( left % PERL_ABS(right) );
2511 dVAR; dSP; dATARGET;
2512 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2516 DIE(aTHX_ "Illegal modulus zero");
2517 /* The assumption is to use hereafter the old vanilla version... */
2519 PL_ppaddr[OP_I_MODULO] =
2521 /* .. but if we have glibc, we might have a buggy _moddi3
2522 * (at least glicb 2.2.5 is known to have this bug), in other
2523 * words our integer modulus with negative quad as the second
2524 * argument might be broken. Test for this and re-patch the
2525 * opcode dispatch table if that is the case, remembering to
2526 * also apply the workaround so that this first round works
2527 * right, too. See [perl #9402] for more information. */
2531 /* Cannot do this check with inlined IV constants since
2532 * that seems to work correctly even with the buggy glibc. */
2534 /* Yikes, we have the bug.
2535 * Patch in the workaround version. */
2537 PL_ppaddr[OP_I_MODULO] =
2538 &Perl_pp_i_modulo_1;
2539 /* Make certain we work right this time, too. */
2540 right = PERL_ABS(right);
2543 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2547 SETi( left % right );
2555 dVAR; dSP; dATARGET;
2556 tryAMAGICbin_MG(add_amg, AMGf_assign);
2558 dPOPTOPiirl_ul_nomg;
2559 SETi( left + right );
2566 dVAR; dSP; dATARGET;
2567 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2569 dPOPTOPiirl_ul_nomg;
2570 SETi( left - right );
2578 tryAMAGICbin_MG(lt_amg, AMGf_set);
2581 SETs(boolSV(left < right));
2589 tryAMAGICbin_MG(gt_amg, AMGf_set);
2592 SETs(boolSV(left > right));
2600 tryAMAGICbin_MG(le_amg, AMGf_set);
2603 SETs(boolSV(left <= right));
2611 tryAMAGICbin_MG(ge_amg, AMGf_set);
2614 SETs(boolSV(left >= right));
2622 tryAMAGICbin_MG(eq_amg, AMGf_set);
2625 SETs(boolSV(left == right));
2633 tryAMAGICbin_MG(ne_amg, AMGf_set);
2636 SETs(boolSV(left != right));
2644 tryAMAGICbin_MG(ncmp_amg, 0);
2651 else if (left < right)
2663 tryAMAGICun_MG(neg_amg, 0);
2665 SV * const sv = TOPs;
2666 IV const i = SvIV_nomg(sv);
2672 /* High falutin' math. */
2677 tryAMAGICbin_MG(atan2_amg, 0);
2680 SETn(Perl_atan2(left, right));
2688 int amg_type = sin_amg;
2689 const char *neg_report = NULL;
2690 NV (*func)(NV) = Perl_sin;
2691 const int op_type = PL_op->op_type;
2708 amg_type = sqrt_amg;
2710 neg_report = "sqrt";
2715 tryAMAGICun_MG(amg_type, 0);
2717 SV * const arg = POPs;
2718 const NV value = SvNV_nomg(arg);
2720 if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
2721 SET_NUMERIC_STANDARD();
2722 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2725 XPUSHn(func(value));
2730 /* Support Configure command-line overrides for rand() functions.
2731 After 5.005, perhaps we should replace this by Configure support
2732 for drand48(), random(), or rand(). For 5.005, though, maintain
2733 compatibility by calling rand() but allow the user to override it.
2734 See INSTALL for details. --Andy Dougherty 15 July 1998
2736 /* Now it's after 5.005, and Configure supports drand48() and random(),
2737 in addition to rand(). So the overrides should not be needed any more.
2738 --Jarkko Hietaniemi 27 September 1998
2741 #ifndef HAS_DRAND48_PROTO
2742 extern double drand48 (void);
2752 value = 1.0; (void)POPs;
2758 if (!PL_srand_called) {
2759 (void)seedDrand01((Rand_seed_t)seed());
2760 PL_srand_called = TRUE;
2770 const UV anum = (MAXARG < 1 || (!TOPs && !POPs)) ? seed() : POPu;
2771 (void)seedDrand01((Rand_seed_t)anum);
2772 PL_srand_called = TRUE;
2776 /* Historically srand always returned true. We can avoid breaking
2778 sv_setpvs(TARG, "0 but true");
2787 tryAMAGICun_MG(int_amg, AMGf_numeric);
2789 SV * const sv = TOPs;
2790 const IV iv = SvIV_nomg(sv);
2791 /* XXX it's arguable that compiler casting to IV might be subtly
2792 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2793 else preferring IV has introduced a subtle behaviour change bug. OTOH
2794 relying on floating point to be accurate is a bug. */
2799 else if (SvIOK(sv)) {
2801 SETu(SvUV_nomg(sv));
2806 const NV value = SvNV_nomg(sv);
2808 if (value < (NV)UV_MAX + 0.5) {
2811 SETn(Perl_floor(value));
2815 if (value > (NV)IV_MIN - 0.5) {
2818 SETn(Perl_ceil(value));
2829 tryAMAGICun_MG(abs_amg, AMGf_numeric);
2831 SV * const sv = TOPs;
2832 /* This will cache the NV value if string isn't actually integer */
2833 const IV iv = SvIV_nomg(sv);
2838 else if (SvIOK(sv)) {
2839 /* IVX is precise */
2841 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
2849 /* 2s complement assumption. Also, not really needed as
2850 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2856 const NV value = SvNV_nomg(sv);
2870 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2874 SV* const sv = POPs;
2876 tmps = (SvPV_const(sv, len));
2878 /* If Unicode, try to downgrade
2879 * If not possible, croak. */
2880 SV* const tsv = sv_2mortal(newSVsv(sv));
2883 sv_utf8_downgrade(tsv, FALSE);
2884 tmps = SvPV_const(tsv, len);
2886 if (PL_op->op_type == OP_HEX)
2889 while (*tmps && len && isSPACE(*tmps))
2893 if (*tmps == 'x' || *tmps == 'X') {
2895 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2897 else if (*tmps == 'b' || *tmps == 'B')
2898 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2900 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2902 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2916 SV * const sv = TOPs;
2918 if (SvGAMAGIC(sv)) {
2919 /* For an overloaded or magic scalar, we can't know in advance if
2920 it's going to be UTF-8 or not. Also, we can't call sv_len_utf8 as
2921 it likes to cache the length. Maybe that should be a documented
2926 = sv_2pv_flags(sv, &len,
2927 SV_UNDEF_RETURNS_NULL|SV_CONST_RETURN|SV_GMAGIC);
2930 if (!SvPADTMP(TARG)) {
2931 sv_setsv(TARG, &PL_sv_undef);
2936 else if (DO_UTF8(sv)) {
2937 SETi(utf8_length((U8*)p, (U8*)p + len));
2941 } else if (SvOK(sv)) {
2942 /* Neither magic nor overloaded. */
2944 SETi(sv_len_utf8(sv));
2948 if (!SvPADTMP(TARG)) {
2949 sv_setsv_nomg(TARG, &PL_sv_undef);
2971 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
2972 const bool rvalue = (GIMME_V != G_VOID);
2975 const char *repl = NULL;
2977 int num_args = PL_op->op_private & 7;
2978 bool repl_need_utf8_upgrade = FALSE;
2979 bool repl_is_utf8 = FALSE;
2983 if(!(repl_sv = POPs)) num_args--;
2985 if ((len_sv = POPs)) {
2986 len_iv = SvIV(len_sv);
2987 len_is_uv = SvIOK_UV(len_sv);
2992 pos1_iv = SvIV(pos_sv);
2993 pos1_is_uv = SvIOK_UV(pos_sv);
2995 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3001 repl = SvPV_const(repl_sv, repl_len);
3002 repl_is_utf8 = DO_UTF8(repl_sv) && repl_len;
3005 sv_utf8_upgrade(sv);
3007 else if (DO_UTF8(sv))
3008 repl_need_utf8_upgrade = TRUE;
3012 tmps = NULL; /* unused */
3014 if (SvOK(sv)) (void)SvPV_nomg_const(sv, curlen);
3017 else tmps = SvPV_const(sv, curlen);
3019 utf8_curlen = sv_len_utf8(sv);
3020 if (utf8_curlen == curlen)
3023 curlen = utf8_curlen;
3028 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3029 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3032 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3036 if (!len_is_uv && len_iv < 0) {
3037 pos2_iv = curlen + len_iv;
3039 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3042 } else { /* len_iv >= 0 */
3043 if (!pos1_is_uv && pos1_iv < 0) {
3044 pos2_iv = pos1_iv + len_iv;
3045 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3047 if ((UV)len_iv > curlen-(UV)pos1_iv)
3050 pos2_iv = pos1_iv+len_iv;
3060 if (!pos2_is_uv && pos2_iv < 0) {
3061 if (!pos1_is_uv && pos1_iv < 0)
3065 else if (!pos1_is_uv && pos1_iv < 0)
3068 if ((UV)pos2_iv < (UV)pos1_iv)
3070 if ((UV)pos2_iv > curlen)
3074 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3075 const STRLEN pos = (STRLEN)( (UV)pos1_iv );
3076 const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3077 STRLEN byte_len = len;
3078 STRLEN byte_pos = utf8_curlen
3079 ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
3083 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3084 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3086 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3087 LvTARGOFF(ret) = pos;
3088 LvTARGLEN(ret) = len;
3091 PUSHs(ret); /* avoid SvSETMAGIC here */
3098 SvTAINTED_off(TARG); /* decontaminate */
3099 SvUTF8_off(TARG); /* decontaminate */
3100 sv_setpvn(TARG, tmps, byte_len);
3101 #ifdef USE_LOCALE_COLLATE
3102 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3109 SV* repl_sv_copy = NULL;
3111 if (repl_need_utf8_upgrade) {
3112 repl_sv_copy = newSVsv(repl_sv);
3113 sv_utf8_upgrade(repl_sv_copy);
3114 repl = SvPV_const(repl_sv_copy, repl_len);
3115 repl_is_utf8 = DO_UTF8(repl_sv_copy) && repl_len;
3118 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3119 "Attempt to use reference as lvalue in substr"
3123 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3126 SvREFCNT_dec(repl_sv_copy);
3138 Perl_croak(aTHX_ "substr outside of string");
3139 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3146 register const IV size = POPi;
3147 register const IV offset = POPi;
3148 register SV * const src = POPs;
3149 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3152 if (lvalue) { /* it's an lvalue! */
3153 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3154 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3156 LvTARG(ret) = SvREFCNT_inc_simple(src);
3157 LvTARGOFF(ret) = offset;
3158 LvTARGLEN(ret) = size;
3162 SvTAINTED_off(TARG); /* decontaminate */
3166 sv_setuv(ret, do_vecget(src, offset, size));
3182 const char *little_p;
3185 const bool is_index = PL_op->op_type == OP_INDEX;
3186 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3192 big_p = SvPV_const(big, biglen);
3193 little_p = SvPV_const(little, llen);
3195 big_utf8 = DO_UTF8(big);
3196 little_utf8 = DO_UTF8(little);
3197 if (big_utf8 ^ little_utf8) {
3198 /* One needs to be upgraded. */
3199 if (little_utf8 && !PL_encoding) {
3200 /* Well, maybe instead we might be able to downgrade the small
3202 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3205 /* If the large string is ISO-8859-1, and it's not possible to
3206 convert the small string to ISO-8859-1, then there is no
3207 way that it could be found anywhere by index. */
3212 /* At this point, pv is a malloc()ed string. So donate it to temp
3213 to ensure it will get free()d */
3214 little = temp = newSV(0);
3215 sv_usepvn(temp, pv, llen);
3216 little_p = SvPVX(little);
3219 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3222 sv_recode_to_utf8(temp, PL_encoding);
3224 sv_utf8_upgrade(temp);
3229 big_p = SvPV_const(big, biglen);
3232 little_p = SvPV_const(little, llen);
3236 if (SvGAMAGIC(big)) {
3237 /* Life just becomes a lot easier if I use a temporary here.
3238 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3239 will trigger magic and overloading again, as will fbm_instr()
3241 big = newSVpvn_flags(big_p, biglen,
3242 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3245 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3246 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3247 warn on undef, and we've already triggered a warning with the
3248 SvPV_const some lines above. We can't remove that, as we need to
3249 call some SvPV to trigger overloading early and find out if the
3251 This is all getting to messy. The API isn't quite clean enough,
3252 because data access has side effects.
3254 little = newSVpvn_flags(little_p, llen,
3255 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3256 little_p = SvPVX(little);
3260 offset = is_index ? 0 : biglen;
3262 if (big_utf8 && offset > 0)
3263 sv_pos_u2b(big, &offset, 0);
3269 else if (offset > (I32)biglen)
3271 if (!(little_p = is_index
3272 ? fbm_instr((unsigned char*)big_p + offset,
3273 (unsigned char*)big_p + biglen, little, 0)
3274 : rninstr(big_p, big_p + offset,
3275 little_p, little_p + llen)))
3278 retval = little_p - big_p;
3279 if (retval > 0 && big_utf8)
3280 sv_pos_b2u(big, &retval);
3290 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
3291 SvTAINTED_off(TARG);
3292 do_sprintf(TARG, SP-MARK, MARK+1);
3293 TAINT_IF(SvTAINTED(TARG));
3305 const U8 *s = (U8*)SvPV_const(argsv, len);
3307 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3308 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3309 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3313 XPUSHu(DO_UTF8(argsv) ?
3314 utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
3326 if (((SvIOK_notUV(TOPs) && SvIV(TOPs) < 0)
3328 (SvNOK(TOPs) && SvNV(TOPs) < 0.0))) {
3330 value = POPu; /* chr(-1) eq chr(0xff), etc. */
3332 (void) POPs; /* Ignore the argument value. */
3333 value = UNICODE_REPLACEMENT;
3339 SvUPGRADE(TARG,SVt_PV);
3341 if (value > 255 && !IN_BYTES) {
3342 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3343 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3344 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3346 (void)SvPOK_only(TARG);
3355 *tmps++ = (char)value;
3357 (void)SvPOK_only(TARG);
3359 if (PL_encoding && !IN_BYTES) {
3360 sv_recode_to_utf8(TARG, PL_encoding);
3362 if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
3363 UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
3367 *tmps++ = (char)value;
3383 const char *tmps = SvPV_const(left, len);
3385 if (DO_UTF8(left)) {
3386 /* If Unicode, try to downgrade.
3387 * If not possible, croak.
3388 * Yes, we made this up. */
3389 SV* const tsv = sv_2mortal(newSVsv(left));
3392 sv_utf8_downgrade(tsv, FALSE);
3393 tmps = SvPV_const(tsv, len);
3395 # ifdef USE_ITHREADS
3397 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3398 /* This should be threadsafe because in ithreads there is only
3399 * one thread per interpreter. If this would not be true,
3400 * we would need a mutex to protect this malloc. */
3401 PL_reentrant_buffer->_crypt_struct_buffer =
3402 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3403 #if defined(__GLIBC__) || defined(__EMX__)
3404 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3405 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3406 /* work around glibc-2.2.5 bug */
3407 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3411 # endif /* HAS_CRYPT_R */
3412 # endif /* USE_ITHREADS */
3414 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3416 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3422 "The crypt() function is unimplemented due to excessive paranoia.");
3426 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3427 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3429 /* Generates code to store a unicode codepoint c that is known to occupy
3430 * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1,
3431 * and p is advanced to point to the next available byte after the two bytes */
3432 #define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
3434 *(p)++ = UTF8_TWO_BYTE_HI(c); \
3435 *((p)++) = UTF8_TWO_BYTE_LO(c); \
3440 /* Actually is both lcfirst() and ucfirst(). Only the first character
3441 * changes. This means that possibly we can change in-place, ie., just
3442 * take the source and change that one character and store it back, but not
3443 * if read-only etc, or if the length changes */
3448 STRLEN slen; /* slen is the byte length of the whole SV. */
3451 bool inplace; /* ? Convert first char only, in-place */
3452 bool doing_utf8 = FALSE; /* ? using utf8 */
3453 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3454 const int op_type = PL_op->op_type;
3457 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3458 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3459 * stored as UTF-8 at s. */
3460 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3461 * lowercased) character stored in tmpbuf. May be either
3462 * UTF-8 or not, but in either case is the number of bytes */
3466 s = (const U8*)SvPV_nomg_const(source, slen);
3468 if (ckWARN(WARN_UNINITIALIZED))
3469 report_uninit(source);
3474 /* We may be able to get away with changing only the first character, in
3475 * place, but not if read-only, etc. Later we may discover more reasons to
3476 * not convert in-place. */
3477 inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
3479 /* First calculate what the changed first character should be. This affects
3480 * whether we can just swap it out, leaving the rest of the string unchanged,
3481 * or even if have to convert the dest to UTF-8 when the source isn't */
3483 if (! slen) { /* If empty */
3484 need = 1; /* still need a trailing NUL */
3487 else if (DO_UTF8(source)) { /* Is the source utf8? */
3490 if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
3491 else toLOWER_utf8(s, tmpbuf, &tculen);
3493 /* we can't do in-place if the length changes. */
3494 if (ulen != tculen) inplace = FALSE;
3495 need = slen + 1 - ulen + tculen;
3497 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3498 * latin1 is treated as caseless. Note that a locale takes
3500 ulen = 1; /* Original character is 1 byte */
3501 tculen = 1; /* Most characters will require one byte, but this will
3502 * need to be overridden for the tricky ones */
3505 if (op_type == OP_LCFIRST) {
3507 /* lower case the first letter: no trickiness for any character */
3508 *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
3509 ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
3512 else if (IN_LOCALE_RUNTIME) {
3513 *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
3514 * have upper and title case different
3517 else if (! IN_UNI_8_BIT) {
3518 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3519 * on EBCDIC machines whatever the
3520 * native function does */
3522 else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
3523 UV title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3525 assert(tculen == 2);
3527 /* If the result is an upper Latin1-range character, it can
3528 * still be represented in one byte, which is its ordinal */
3529 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3530 *tmpbuf = (U8) title_ord;
3534 /* Otherwise it became more than one ASCII character (in
3535 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3536 * beyond Latin1, so the number of bytes changed, so can't
3537 * replace just the first character in place. */
3540 /* If the result won't fit in a byte, the entire result will
3541 * have to be in UTF-8. Assume worst case sizing in
3542 * conversion. (all latin1 characters occupy at most two bytes
3544 if (title_ord > 255) {
3546 convert_source_to_utf8 = TRUE;
3547 need = slen * 2 + 1;
3549 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3550 * (both) characters whose title case is above 255 is
3554 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3555 need = slen + 1 + 1;
3559 } /* End of use Unicode (Latin1) semantics */
3560 } /* End of changing the case of the first character */
3562 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3563 * generate the result */
3566 /* We can convert in place. This means we change just the first
3567 * character without disturbing the rest; no need to grow */
3569 s = d = (U8*)SvPV_force_nomg(source, slen);
3575 /* Here, we can't convert in place; we earlier calculated how much
3576 * space we will need, so grow to accommodate that */
3577 SvUPGRADE(dest, SVt_PV);
3578 d = (U8*)SvGROW(dest, need);
3579 (void)SvPOK_only(dest);
3586 if (! convert_source_to_utf8) {
3588 /* Here both source and dest are in UTF-8, but have to create
3589 * the entire output. We initialize the result to be the
3590 * title/lower cased first character, and then append the rest
3592 sv_setpvn(dest, (char*)tmpbuf, tculen);
3594 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3598 const U8 *const send = s + slen;
3600 /* Here the dest needs to be in UTF-8, but the source isn't,
3601 * except we earlier UTF-8'd the first character of the source
3602 * into tmpbuf. First put that into dest, and then append the
3603 * rest of the source, converting it to UTF-8 as we go. */
3605 /* Assert tculen is 2 here because the only two characters that
3606 * get to this part of the code have 2-byte UTF-8 equivalents */
3608 *d++ = *(tmpbuf + 1);
3609 s++; /* We have just processed the 1st char */
3611 for (; s < send; s++) {
3612 d = uvchr_to_utf8(d, *s);
3615 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3619 else { /* in-place UTF-8. Just overwrite the first character */
3620 Copy(tmpbuf, d, tculen, U8);
3621 SvCUR_set(dest, need - 1);
3624 else { /* Neither source nor dest are in or need to be UTF-8 */
3626 if (IN_LOCALE_RUNTIME) {
3630 if (inplace) { /* in-place, only need to change the 1st char */
3633 else { /* Not in-place */
3635 /* Copy the case-changed character(s) from tmpbuf */
3636 Copy(tmpbuf, d, tculen, U8);
3637 d += tculen - 1; /* Code below expects d to point to final
3638 * character stored */
3641 else { /* empty source */
3642 /* See bug #39028: Don't taint if empty */
3646 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3647 * the destination to retain that flag */
3651 if (!inplace) { /* Finish the rest of the string, unchanged */
3652 /* This will copy the trailing NUL */
3653 Copy(s + 1, d + 1, slen, U8);
3654 SvCUR_set(dest, need - 1);
3657 if (dest != source && SvTAINTED(source))
3663 /* There's so much setup/teardown code common between uc and lc, I wonder if
3664 it would be worth merging the two, and just having a switch outside each
3665 of the three tight loops. There is less and less commonality though */
3679 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3680 && SvTEMP(source) && !DO_UTF8(source)
3681 && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
3683 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3684 * make the loop tight, so we overwrite the source with the dest before
3685 * looking at it, and we need to look at the original source
3686 * afterwards. There would also need to be code added to handle
3687 * switching to not in-place in midstream if we run into characters
3688 * that change the length.
3691 s = d = (U8*)SvPV_force_nomg(source, len);
3698 /* The old implementation would copy source into TARG at this point.
3699 This had the side effect that if source was undef, TARG was now
3700 an undefined SV with PADTMP set, and they don't warn inside
3701 sv_2pv_flags(). However, we're now getting the PV direct from
3702 source, which doesn't have PADTMP set, so it would warn. Hence the
3706 s = (const U8*)SvPV_nomg_const(source, len);
3708 if (ckWARN(WARN_UNINITIALIZED))
3709 report_uninit(source);
3715 SvUPGRADE(dest, SVt_PV);
3716 d = (U8*)SvGROW(dest, min);
3717 (void)SvPOK_only(dest);
3722 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3723 to check DO_UTF8 again here. */
3725 if (DO_UTF8(source)) {
3726 const U8 *const send = s + len;
3727 U8 tmpbuf[UTF8_MAXBYTES+1];
3729 /* All occurrences of these are to be moved to follow any other marks.
3730 * This is context-dependent. We may not be passed enough context to
3731 * move the iota subscript beyond all of them, but we do the best we can
3732 * with what we're given. The result is always better than if we
3733 * hadn't done this. And, the problem would only arise if we are
3734 * passed a character without all its combining marks, which would be
3735 * the caller's mistake. The information this is based on comes from a
3736 * comment in Unicode SpecialCasing.txt, (and the Standard's text
3737 * itself) and so can't be checked properly to see if it ever gets
3738 * revised. But the likelihood of it changing is remote */
3739 bool in_iota_subscript = FALSE;
3745 if (in_iota_subscript && ! is_utf8_mark(s)) {
3747 /* A non-mark. Time to output the iota subscript */
3748 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
3749 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3751 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
3752 in_iota_subscript = FALSE;
3755 /* Then handle the current character. Get the changed case value
3756 * and copy it to the output buffer */
3759 uv = toUPPER_utf8(s, tmpbuf, &ulen);
3760 if (uv == GREEK_CAPITAL_LETTER_IOTA
3761 && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
3763 in_iota_subscript = TRUE;
3766 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3767 /* If the eventually required minimum size outgrows the
3768 * available space, we need to grow. */
3769 const UV o = d - (U8*)SvPVX_const(dest);
3771 /* If someone uppercases one million U+03B0s we SvGROW()
3772 * one million times. Or we could try guessing how much to
3773 * allocate without allocating too much. Such is life.
3774 * See corresponding comment in lc code for another option
3777 d = (U8*)SvPVX(dest) + o;
3779 Copy(tmpbuf, d, ulen, U8);
3784 if (in_iota_subscript) {
3785 CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
3789 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3791 else { /* Not UTF-8 */
3793 const U8 *const send = s + len;
3795 /* Use locale casing if in locale; regular style if not treating
3796 * latin1 as having case; otherwise the latin1 casing. Do the
3797 * whole thing in a tight loop, for speed, */
3798 if (IN_LOCALE_RUNTIME) {
3801 for (; s < send; d++, s++)
3802 *d = toUPPER_LC(*s);
3804 else if (! IN_UNI_8_BIT) {
3805 for (; s < send; d++, s++) {
3810 for (; s < send; d++, s++) {
3811 *d = toUPPER_LATIN1_MOD(*s);
3812 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) continue;
3814 /* The mainstream case is the tight loop above. To avoid
3815 * extra tests in that, all three characters that require
3816 * special handling are mapped by the MOD to the one tested
3818 * Use the source to distinguish between the three cases */
3820 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3822 /* uc() of this requires 2 characters, but they are
3823 * ASCII. If not enough room, grow the string */
3824 if (SvLEN(dest) < ++min) {
3825 const UV o = d - (U8*)SvPVX_const(dest);
3827 d = (U8*)SvPVX(dest) + o;
3829 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3830 continue; /* Back to the tight loop; still in ASCII */
3833 /* The other two special handling characters have their
3834 * upper cases outside the latin1 range, hence need to be
3835 * in UTF-8, so the whole result needs to be in UTF-8. So,
3836 * here we are somewhere in the middle of processing a
3837 * non-UTF-8 string, and realize that we will have to convert
3838 * the whole thing to UTF-8. What to do? There are
3839 * several possibilities. The simplest to code is to
3840 * convert what we have so far, set a flag, and continue on
3841 * in the loop. The flag would be tested each time through
3842 * the loop, and if set, the next character would be
3843 * converted to UTF-8 and stored. But, I (khw) didn't want
3844 * to slow down the mainstream case at all for this fairly
3845 * rare case, so I didn't want to add a test that didn't
3846 * absolutely have to be there in the loop, besides the
3847 * possibility that it would get too complicated for
3848 * optimizers to deal with. Another possibility is to just
3849 * give up, convert the source to UTF-8, and restart the
3850 * function that way. Another possibility is to convert
3851 * both what has already been processed and what is yet to
3852 * come separately to UTF-8, then jump into the loop that
3853 * handles UTF-8. But the most efficient time-wise of the
3854 * ones I could think of is what follows, and turned out to
3855 * not require much extra code. */
3857 /* Convert what we have so far into UTF-8, telling the
3858 * function that we know it should be converted, and to
3859 * allow extra space for what we haven't processed yet.
3860 * Assume the worst case space requirements for converting
3861 * what we haven't processed so far: that it will require
3862 * two bytes for each remaining source character, plus the
3863 * NUL at the end. This may cause the string pointer to
3864 * move, so re-find it. */
3866 len = d - (U8*)SvPVX_const(dest);
3867 SvCUR_set(dest, len);
3868 len = sv_utf8_upgrade_flags_grow(dest,
3869 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3871 d = (U8*)SvPVX(dest) + len;
3873 /* Now process the remainder of the source, converting to
3874 * upper and UTF-8. If a resulting byte is invariant in
3875 * UTF-8, output it as-is, otherwise convert to UTF-8 and
3876 * append it to the output. */
3877 for (; s < send; s++) {
3878 (void) _to_upper_title_latin1(*s, d, &len, 'S');
3882 /* Here have processed the whole source; no need to continue
3883 * with the outer loop. Each character has been converted
3884 * to upper case and converted to UTF-8 */
3887 } /* End of processing all latin1-style chars */
3888 } /* End of processing all chars */
3889 } /* End of source is not empty */
3891 if (source != dest) {
3892 *d = '\0'; /* Here d points to 1 after last char, add NUL */
3893 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3895 } /* End of isn't utf8 */
3896 if (dest != source && SvTAINTED(source))
3915 if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
3916 && SvTEMP(source) && !DO_UTF8(source)) {
3918 /* We can convert in place, as lowercasing anything in the latin1 range
3919 * (or else DO_UTF8 would have been on) doesn't lengthen it */
3921 s = d = (U8*)SvPV_force_nomg(source, len);
3928 /* The old implementation would copy source into TARG at this point.
3929 This had the side effect that if source was undef, TARG was now
3930 an undefined SV with PADTMP set, and they don't warn inside
3931 sv_2pv_flags(). However, we're now getting the PV direct from
3932 source, which doesn't have PADTMP set, so it would warn. Hence the
3936 s = (const U8*)SvPV_nomg_const(source, len);
3938 if (ckWARN(WARN_UNINITIALIZED))
3939 report_uninit(source);
3945 SvUPGRADE(dest, SVt_PV);
3946 d = (U8*)SvGROW(dest, min);
3947 (void)SvPOK_only(dest);
3952 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3953 to check DO_UTF8 again here. */
3955 if (DO_UTF8(source)) {
3956 const U8 *const send = s + len;
3957 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3960 const STRLEN u = UTF8SKIP(s);
3963 toLOWER_utf8(s, tmpbuf, &ulen);
3965 /* Here is where we would do context-sensitive actions. See the
3966 * commit message for this comment for why there isn't any */
3968 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3970 /* If the eventually required minimum size outgrows the
3971 * available space, we need to grow. */
3972 const UV o = d - (U8*)SvPVX_const(dest);
3974 /* If someone lowercases one million U+0130s we SvGROW() one
3975 * million times. Or we could try guessing how much to
3976 * allocate without allocating too much. Such is life.
3977 * Another option would be to grow an extra byte or two more
3978 * each time we need to grow, which would cut down the million
3979 * to 500K, with little waste */
3981 d = (U8*)SvPVX(dest) + o;
3984 /* Copy the newly lowercased letter to the output buffer we're
3986 Copy(tmpbuf, d, ulen, U8);
3989 } /* End of looping through the source string */
3992 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3993 } else { /* Not utf8 */
3995 const U8 *const send = s + len;
3997 /* Use locale casing if in locale; regular style if not treating
3998 * latin1 as having case; otherwise the latin1 casing. Do the
3999 * whole thing in a tight loop, for speed, */
4000 if (IN_LOCALE_RUNTIME) {
4003 for (; s < send; d++, s++)
4004 *d = toLOWER_LC(*s);
4006 else if (! IN_UNI_8_BIT) {
4007 for (; s < send; d++, s++) {
4012 for (; s < send; d++, s++) {
4013 *d = toLOWER_LATIN1(*s);
4017 if (source != dest) {
4019 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4022 if (dest != source && SvTAINTED(source))
4031 SV * const sv = TOPs;
4033 register const char *s = SvPV_const(sv,len);
4035 SvUTF8_off(TARG); /* decontaminate */
4038 SvUPGRADE(TARG, SVt_PV);
4039 SvGROW(TARG, (len * 2) + 1);
4043 if (UTF8_IS_CONTINUED(*s)) {
4044 STRLEN ulen = UTF8SKIP(s);
4068 SvCUR_set(TARG, d - SvPVX_const(TARG));
4069 (void)SvPOK_only_UTF8(TARG);
4072 sv_setpvn(TARG, s, len);
4081 dVAR; dSP; dMARK; dORIGMARK;
4082 register AV *const av = MUTABLE_AV(POPs);
4083 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4085 if (SvTYPE(av) == SVt_PVAV) {
4086 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4087 bool can_preserve = FALSE;
4093 can_preserve = SvCANEXISTDELETE(av);
4096 if (lval && localizing) {
4099 for (svp = MARK + 1; svp <= SP; svp++) {
4100 const I32 elem = SvIV(*svp);
4104 if (max > AvMAX(av))
4108 while (++MARK <= SP) {
4110 I32 elem = SvIV(*MARK);
4111 bool preeminent = TRUE;
4113 if (localizing && can_preserve) {
4114 /* If we can determine whether the element exist,
4115 * Try to preserve the existenceness of a tied array
4116 * element by using EXISTS and DELETE if possible.
4117 * Fallback to FETCH and STORE otherwise. */
4118 preeminent = av_exists(av, elem);
4121 svp = av_fetch(av, elem, lval);
4123 if (!svp || *svp == &PL_sv_undef)
4124 DIE(aTHX_ PL_no_aelem, elem);
4127 save_aelem(av, elem, svp);
4129 SAVEADELETE(av, elem);
4132 *MARK = svp ? *svp : &PL_sv_undef;
4135 if (GIMME != G_ARRAY) {
4137 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4143 /* Smart dereferencing for keys, values and each */
4155 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4160 "Type of argument to %s must be unblessed hashref or arrayref",
4161 PL_op_desc[PL_op->op_type] );
4164 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4166 "Can't modify %s in %s",
4167 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4170 /* Delegate to correct function for op type */
4172 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4173 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4176 return (SvTYPE(sv) == SVt_PVHV) ? Perl_pp_each(aTHX) : Perl_pp_aeach(aTHX);
4184 AV *array = MUTABLE_AV(POPs);
4185 const I32 gimme = GIMME_V;
4186 IV *iterp = Perl_av_iter_p(aTHX_ array);
4187 const IV current = (*iterp)++;
4189 if (current > av_len(array)) {
4191 if (gimme == G_SCALAR)
4199 if (gimme == G_ARRAY) {
4200 SV **const element = av_fetch(array, current, 0);
4201 PUSHs(element ? *element : &PL_sv_undef);
4210 AV *array = MUTABLE_AV(POPs);
4211 const I32 gimme = GIMME_V;
4213 *Perl_av_iter_p(aTHX_ array) = 0;
4215 if (gimme == G_SCALAR) {
4217 PUSHi(av_len(array) + 1);
4219 else if (gimme == G_ARRAY) {
4220 IV n = Perl_av_len(aTHX_ array);
4225 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4226 for (i = 0; i <= n; i++) {
4231 for (i = 0; i <= n; i++) {
4232 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4233 PUSHs(elem ? *elem : &PL_sv_undef);
4240 /* Associative arrays. */
4246 HV * hash = MUTABLE_HV(POPs);
4248 const I32 gimme = GIMME_V;
4251 /* might clobber stack_sp */
4252 entry = hv_iternext(hash);
4257 SV* const sv = hv_iterkeysv(entry);
4258 PUSHs(sv); /* won't clobber stack_sp */
4259 if (gimme == G_ARRAY) {
4262 /* might clobber stack_sp */
4263 val = hv_iterval(hash, entry);
4268 else if (gimme == G_SCALAR)
4275 S_do_delete_local(pTHX)
4279 const I32 gimme = GIMME_V;
4283 if (PL_op->op_private & OPpSLICE) {
4285 SV * const osv = POPs;
4286 const bool tied = SvRMAGICAL(osv)
4287 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4288 const bool can_preserve = SvCANEXISTDELETE(osv)
4289 || mg_find((const SV *)osv, PERL_MAGIC_env);
4290 const U32 type = SvTYPE(osv);
4291 if (type == SVt_PVHV) { /* hash element */
4292 HV * const hv = MUTABLE_HV(osv);
4293 while (++MARK <= SP) {
4294 SV * const keysv = *MARK;
4296 bool preeminent = TRUE;
4298 preeminent = hv_exists_ent(hv, keysv, 0);
4300 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4307 sv = hv_delete_ent(hv, keysv, 0, 0);
4308 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4311 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4313 *MARK = sv_mortalcopy(sv);
4319 SAVEHDELETE(hv, keysv);
4320 *MARK = &PL_sv_undef;
4324 else if (type == SVt_PVAV) { /* array element */
4325 if (PL_op->op_flags & OPf_SPECIAL) {
4326 AV * const av = MUTABLE_AV(osv);
4327 while (++MARK <= SP) {
4328 I32 idx = SvIV(*MARK);
4330 bool preeminent = TRUE;
4332 preeminent = av_exists(av, idx);
4334 SV **svp = av_fetch(av, idx, 1);
4341 sv = av_delete(av, idx, 0);
4342 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4345 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4347 *MARK = sv_mortalcopy(sv);
4353 SAVEADELETE(av, idx);
4354 *MARK = &PL_sv_undef;
4360 DIE(aTHX_ "Not a HASH reference");
4361 if (gimme == G_VOID)
4363 else if (gimme == G_SCALAR) {
4368 *++MARK = &PL_sv_undef;
4373 SV * const keysv = POPs;
4374 SV * const osv = POPs;
4375 const bool tied = SvRMAGICAL(osv)
4376 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4377 const bool can_preserve = SvCANEXISTDELETE(osv)
4378 || mg_find((const SV *)osv, PERL_MAGIC_env);
4379 const U32 type = SvTYPE(osv);
4381 if (type == SVt_PVHV) {
4382 HV * const hv = MUTABLE_HV(osv);
4383 bool preeminent = TRUE;
4385 preeminent = hv_exists_ent(hv, keysv, 0);
4387 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4394 sv = hv_delete_ent(hv, keysv, 0, 0);
4395 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4398 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4400 SV *nsv = sv_mortalcopy(sv);
4406 SAVEHDELETE(hv, keysv);
4408 else if (type == SVt_PVAV) {
4409 if (PL_op->op_flags & OPf_SPECIAL) {
4410 AV * const av = MUTABLE_AV(osv);
4411 I32 idx = SvIV(keysv);
4412 bool preeminent = TRUE;
4414 preeminent = av_exists(av, idx);
4416 SV **svp = av_fetch(av, idx, 1);
4423 sv = av_delete(av, idx, 0);
4424 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4427 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4429 SV *nsv = sv_mortalcopy(sv);
4435 SAVEADELETE(av, idx);
4438 DIE(aTHX_ "panic: avhv_delete no longer supported");
4441 DIE(aTHX_ "Not a HASH reference");
4444 if (gimme != G_VOID)
4458 if (PL_op->op_private & OPpLVAL_INTRO)
4459 return do_delete_local();
4462 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4464 if (PL_op->op_private & OPpSLICE) {
4466 HV * const hv = MUTABLE_HV(POPs);
4467 const U32 hvtype = SvTYPE(hv);
4468 if (hvtype == SVt_PVHV) { /* hash element */
4469 while (++MARK <= SP) {
4470 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4471 *MARK = sv ? sv : &PL_sv_undef;
4474 else if (hvtype == SVt_PVAV) { /* array element */
4475 if (PL_op->op_flags & OPf_SPECIAL) {
4476 while (++MARK <= SP) {
4477 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4478 *MARK = sv ? sv : &PL_sv_undef;
4483 DIE(aTHX_ "Not a HASH reference");
4486 else if (gimme == G_SCALAR) {
4491 *++MARK = &PL_sv_undef;
4497 HV * const hv = MUTABLE_HV(POPs);
4499 if (SvTYPE(hv) == SVt_PVHV)
4500 sv = hv_delete_ent(hv, keysv, discard, 0);
4501 else if (SvTYPE(hv) == SVt_PVAV) {
4502 if (PL_op->op_flags & OPf_SPECIAL)
4503 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4505 DIE(aTHX_ "panic: avhv_delete no longer supported");
4508 DIE(aTHX_ "Not a HASH reference");
4524 if (PL_op->op_private & OPpEXISTS_SUB) {
4526 SV * const sv = POPs;
4527 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4530 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4535 hv = MUTABLE_HV(POPs);
4536 if (SvTYPE(hv) == SVt_PVHV) {
4537 if (hv_exists_ent(hv, tmpsv, 0))
4540 else if (SvTYPE(hv) == SVt_PVAV) {
4541 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4542 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4547 DIE(aTHX_ "Not a HASH reference");
4554 dVAR; dSP; dMARK; dORIGMARK;
4555 register HV * const hv = MUTABLE_HV(POPs);
4556 register const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4557 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4558 bool can_preserve = FALSE;
4564 if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
4565 can_preserve = TRUE;
4568 while (++MARK <= SP) {
4569 SV * const keysv = *MARK;
4572 bool preeminent = TRUE;
4574 if (localizing && can_preserve) {
4575 /* If we can determine whether the element exist,
4576 * try to preserve the existenceness of a tied hash
4577 * element by using EXISTS and DELETE if possible.
4578 * Fallback to FETCH and STORE otherwise. */
4579 preeminent = hv_exists_ent(hv, keysv, 0);
4582 he = hv_fetch_ent(hv, keysv, lval, 0);
4583 svp = he ? &HeVAL(he) : NULL;
4586 if (!svp || *svp == &PL_sv_undef) {
4587 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4590 if (HvNAME_get(hv) && isGV(*svp))
4591 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4592 else if (preeminent)
4593 save_helem_flags(hv, keysv, svp,
4594 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4596 SAVEHDELETE(hv, keysv);
4599 *MARK = svp ? *svp : &PL_sv_undef;
4601 if (GIMME != G_ARRAY) {
4603 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4609 /* List operators. */
4614 if (GIMME != G_ARRAY) {
4616 *MARK = *SP; /* unwanted list, return last item */
4618 *MARK = &PL_sv_undef;
4628 SV ** const lastrelem = PL_stack_sp;
4629 SV ** const lastlelem = PL_stack_base + POPMARK;
4630 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4631 register SV ** const firstrelem = lastlelem + 1;
4632 I32 is_something_there = FALSE;
4634 register const I32 max = lastrelem - lastlelem;
4635 register SV **lelem;
4637 if (GIMME != G_ARRAY) {
4638 I32 ix = SvIV(*lastlelem);
4641 if (ix < 0 || ix >= max)
4642 *firstlelem = &PL_sv_undef;
4644 *firstlelem = firstrelem[ix];
4650 SP = firstlelem - 1;
4654 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
4655 I32 ix = SvIV(*lelem);
4658 if (ix < 0 || ix >= max)
4659 *lelem = &PL_sv_undef;
4661 is_something_there = TRUE;
4662 if (!(*lelem = firstrelem[ix]))
4663 *lelem = &PL_sv_undef;
4666 if (is_something_there)
4669 SP = firstlelem - 1;
4675 dVAR; dSP; dMARK; dORIGMARK;
4676 const I32 items = SP - MARK;
4677 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
4678 SP = ORIGMARK; /* av_make() might realloc stack_sp */
4679 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4680 ? newRV_noinc(av) : av);
4686 dVAR; dSP; dMARK; dORIGMARK;
4687 HV* const hv = newHV();
4690 SV * const key = *++MARK;
4691 SV * const val = newSV(0);
4693 sv_setsv(val, *++MARK);
4695 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
4696 (void)hv_store_ent(hv,key,val,0);
4699 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
4700 ? newRV_noinc(MUTABLE_SV(hv)) : MUTABLE_SV(hv));
4705 S_deref_plain_array(pTHX_ AV *ary)
4707 if (SvTYPE(ary) == SVt_PVAV) return ary;
4708 SvGETMAGIC((SV *)ary);
4709 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
4710 Perl_die(aTHX_ "Not an ARRAY reference");
4711 else if (SvOBJECT(SvRV(ary)))
4712 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
4713 return (AV *)SvRV(ary);
4716 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
4717 # define DEREF_PLAIN_ARRAY(ary) \
4720 SvTYPE(aRrRay) == SVt_PVAV \
4722 : S_deref_plain_array(aTHX_ aRrRay); \
4725 # define DEREF_PLAIN_ARRAY(ary) \
4727 PL_Sv = (SV *)(ary), \
4728 SvTYPE(PL_Sv) == SVt_PVAV \
4730 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
4736 dVAR; dSP; dMARK; dORIGMARK;
4737 int num_args = (SP - MARK);
4738 register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
4742 register I32 offset;
4743 register I32 length;
4747 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4750 return Perl_tied_method(aTHX_ "SPLICE", mark - 1, MUTABLE_SV(ary), mg,
4751 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
4758 offset = i = SvIV(*MARK);
4760 offset += AvFILLp(ary) + 1;
4762 DIE(aTHX_ PL_no_aelem, i);
4764 length = SvIVx(*MARK++);
4766 length += AvFILLp(ary) - offset + 1;
4772 length = AvMAX(ary) + 1; /* close enough to infinity */
4776 length = AvMAX(ary) + 1;
4778 if (offset > AvFILLp(ary) + 1) {
4780 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
4781 offset = AvFILLp(ary) + 1;
4783 after = AvFILLp(ary) + 1 - (offset + length);
4784 if (after < 0) { /* not that much array */
4785 length += after; /* offset+length now in array */
4791 /* At this point, MARK .. SP-1 is our new LIST */
4794 diff = newlen - length;
4795 if (newlen && !AvREAL(ary) && AvREIFY(ary))
4798 /* make new elements SVs now: avoid problems if they're from the array */
4799 for (dst = MARK, i = newlen; i; i--) {
4800 SV * const h = *dst;
4801 *dst++ = newSVsv(h);
4804 if (diff < 0) { /* shrinking the area */
4805 SV **tmparyval = NULL;
4807 Newx(tmparyval, newlen, SV*); /* so remember insertion */
4808 Copy(MARK, tmparyval, newlen, SV*);
4811 MARK = ORIGMARK + 1;
4812 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4813 MEXTEND(MARK, length);
4814 Copy(AvARRAY(ary)+offset, MARK, length, SV*);
4816 EXTEND_MORTAL(length);
4817 for (i = length, dst = MARK; i; i--) {
4818 sv_2mortal(*dst); /* free them eventually */
4825 *MARK = AvARRAY(ary)[offset+length-1];
4828 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
4829 SvREFCNT_dec(*dst++); /* free them now */
4832 AvFILLp(ary) += diff;
4834 /* pull up or down? */
4836 if (offset < after) { /* easier to pull up */
4837 if (offset) { /* esp. if nothing to pull */
4838 src = &AvARRAY(ary)[offset-1];
4839 dst = src - diff; /* diff is negative */
4840 for (i = offset; i > 0; i--) /* can't trust Copy */
4844 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
4848 if (after) { /* anything to pull down? */
4849 src = AvARRAY(ary) + offset + length;
4850 dst = src + diff; /* diff is negative */
4851 Move(src, dst, after, SV*);
4853 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
4854 /* avoid later double free */
4858 dst[--i] = &PL_sv_undef;
4861 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
4862 Safefree(tmparyval);
4865 else { /* no, expanding (or same) */
4866 SV** tmparyval = NULL;
4868 Newx(tmparyval, length, SV*); /* so remember deletion */
4869 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
4872 if (diff > 0) { /* expanding */
4873 /* push up or down? */
4874 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
4878 Move(src, dst, offset, SV*);
4880 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
4882 AvFILLp(ary) += diff;
4885 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
4886 av_extend(ary, AvFILLp(ary) + diff);
4887 AvFILLp(ary) += diff;
4890 dst = AvARRAY(ary) + AvFILLp(ary);
4892 for (i = after; i; i--) {
4900 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
4903 MARK = ORIGMARK + 1;
4904 if (GIMME == G_ARRAY) { /* copy return vals to stack */
4906 Copy(tmparyval, MARK, length, SV*);
4908 EXTEND_MORTAL(length);
4909 for (i = length, dst = MARK; i; i--) {
4910 sv_2mortal(*dst); /* free them eventually */
4917 else if (length--) {
4918 *MARK = tmparyval[length];
4921 while (length-- > 0)
4922 SvREFCNT_dec(tmparyval[length]);
4926 *MARK = &PL_sv_undef;
4927 Safefree(tmparyval);
4931 mg_set(MUTABLE_SV(ary));
4939 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4940 register AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
4941 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4944 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4947 ENTER_with_name("call_PUSH");
4948 call_method("PUSH",G_SCALAR|G_DISCARD);
4949 LEAVE_with_name("call_PUSH");
4953 PL_delaymagic = DM_DELAY;
4954 for (++MARK; MARK <= SP; MARK++) {
4955 SV * const sv = newSV(0);
4957 sv_setsv(sv, *MARK);
4958 av_store(ary, AvFILLp(ary)+1, sv);
4960 if (PL_delaymagic & DM_ARRAY_ISA)
4961 mg_set(MUTABLE_SV(ary));
4966 if (OP_GIMME(PL_op, 0) != G_VOID) {
4967 PUSHi( AvFILL(ary) + 1 );
4976 AV * const av = PL_op->op_flags & OPf_SPECIAL
4977 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
4978 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
4982 (void)sv_2mortal(sv);
4989 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4990 register AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
4991 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
4994 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
4997 ENTER_with_name("call_UNSHIFT");
4998 call_method("UNSHIFT",G_SCALAR|G_DISCARD);
4999 LEAVE_with_name("call_UNSHIFT");
5004 av_unshift(ary, SP - MARK);
5006 SV * const sv = newSVsv(*++MARK);
5007 (void)av_store(ary, i++, sv);
5011 if (OP_GIMME(PL_op, 0) != G_VOID) {
5012 PUSHi( AvFILL(ary) + 1 );
5021 if (GIMME == G_ARRAY) {
5022 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5026 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5027 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5028 av = MUTABLE_AV((*SP));
5029 /* In-place reversing only happens in void context for the array
5030 * assignment. We don't need to push anything on the stack. */
5033 if (SvMAGICAL(av)) {
5035 register SV *tmp = sv_newmortal();
5036 /* For SvCANEXISTDELETE */
5039 bool can_preserve = SvCANEXISTDELETE(av);
5041 for (i = 0, j = av_len(av); i < j; ++i, --j) {
5042 register SV *begin, *end;
5045 if (!av_exists(av, i)) {
5046 if (av_exists(av, j)) {
5047 register SV *sv = av_delete(av, j, 0);
5048 begin = *av_fetch(av, i, TRUE);
5049 sv_setsv_mg(begin, sv);
5053 else if (!av_exists(av, j)) {
5054 register SV *sv = av_delete(av, i, 0);
5055 end = *av_fetch(av, j, TRUE);
5056 sv_setsv_mg(end, sv);
5061 begin = *av_fetch(av, i, TRUE);
5062 end = *av_fetch(av, j, TRUE);
5063 sv_setsv(tmp, begin);
5064 sv_setsv_mg(begin, end);
5065 sv_setsv_mg(end, tmp);
5069 SV **begin = AvARRAY(av);
5072 SV **end = begin + AvFILLp(av);
5074 while (begin < end) {
5075 register SV * const tmp = *begin;
5086 register SV * const tmp = *MARK;
5090 /* safe as long as stack cannot get extended in the above */
5096 register char *down;
5101 SvUTF8_off(TARG); /* decontaminate */
5103 do_join(TARG, &PL_sv_no, MARK, SP);
5105 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5106 if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
5107 report_uninit(TARG);
5110 up = SvPV_force(TARG, len);
5112 if (DO_UTF8(TARG)) { /* first reverse each character */
5113 U8* s = (U8*)SvPVX(TARG);
5114 const U8* send = (U8*)(s + len);
5116 if (UTF8_IS_INVARIANT(*s)) {
5121 if (!utf8_to_uvchr(s, 0))
5125 down = (char*)(s - 1);
5126 /* reverse this character */
5130 *down-- = (char)tmp;
5136 down = SvPVX(TARG) + len - 1;
5140 *down-- = (char)tmp;
5142 (void)SvPOK_only_UTF8(TARG);
5154 register IV limit = POPi; /* note, negative is forever */
5155 SV * const sv = POPs;
5157 register const char *s = SvPV_const(sv, len);
5158 const bool do_utf8 = DO_UTF8(sv);
5159 const char *strend = s + len;
5161 register REGEXP *rx;
5163 register const char *m;
5165 const STRLEN slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : (STRLEN)(strend - s);
5166 I32 maxiters = slen + 10;
5167 I32 trailing_empty = 0;
5169 const I32 origlimit = limit;
5172 const I32 gimme = GIMME_V;
5174 const I32 oldsave = PL_savestack_ix;
5175 U32 make_mortal = SVs_TEMP;
5180 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5185 DIE(aTHX_ "panic: pp_split");
5188 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5189 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5191 RX_MATCH_UTF8_set(rx, do_utf8);
5194 if (pm->op_pmreplrootu.op_pmtargetoff) {
5195 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5198 if (pm->op_pmreplrootu.op_pmtargetgv) {
5199 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5204 if (ary && (gimme != G_ARRAY || (pm->op_pmflags & PMf_ONCE))) {
5210 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5212 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5219 for (i = AvFILLp(ary); i >= 0; i--)
5220 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5222 /* temporarily switch stacks */
5223 SAVESWITCHSTACK(PL_curstack, ary);
5227 base = SP - PL_stack_base;
5229 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5231 while (*s == ' ' || is_utf8_space((U8*)s))
5234 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5235 while (isSPACE_LC(*s))
5243 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5247 gimme_scalar = gimme == G_SCALAR && !ary;
5250 limit = maxiters + 2;
5251 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5254 /* this one uses 'm' and is a negative test */
5256 while (m < strend && !( *m == ' ' || is_utf8_space((U8*)m) )) {
5257 const int t = UTF8SKIP(m);
5258 /* is_utf8_space returns FALSE for malform utf8 */
5265 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5266 while (m < strend && !isSPACE_LC(*m))
5269 while (m < strend && !isSPACE(*m))
5282 dstr = newSVpvn_flags(s, m-s,
5283 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5287 /* skip the whitespace found last */
5289 s = m + UTF8SKIP(m);
5293 /* this one uses 's' and is a positive test */
5295 while (s < strend && ( *s == ' ' || is_utf8_space((U8*)s) ))
5298 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5299 while (s < strend && isSPACE_LC(*s))
5302 while (s < strend && isSPACE(*s))
5307 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5309 for (m = s; m < strend && *m != '\n'; m++)
5322 dstr = newSVpvn_flags(s, m-s,
5323 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5329 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5331 Pre-extend the stack, either the number of bytes or
5332 characters in the string or a limited amount, triggered by:
5334 my ($x, $y) = split //, $str;
5338 if (!gimme_scalar) {
5339 const U32 items = limit - 1;
5348 /* keep track of how many bytes we skip over */
5358 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5371 dstr = newSVpvn(s, 1);
5387 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5388 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5389 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5390 && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
5391 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5392 SV * const csv = CALLREG_INTUIT_STRING(rx);
5394 len = RX_MINLENRET(rx);
5395 if (len == 1 && !RX_UTF8(rx) && !tail) {
5396 const char c = *SvPV_nolen_const(csv);
5398 for (m = s; m < strend && *m != c; m++)
5409 dstr = newSVpvn_flags(s, m-s,
5410 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5413 /* The rx->minlen is in characters but we want to step
5414 * s ahead by bytes. */
5416 s = (char*)utf8_hop((U8*)m, len);
5418 s = m + len; /* Fake \n at the end */
5422 while (s < strend && --limit &&
5423 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5424 csv, multiline ? FBMrf_MULTILINE : 0)) )
5433 dstr = newSVpvn_flags(s, m-s,
5434 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5437 /* The rx->minlen is in characters but we want to step
5438 * s ahead by bytes. */
5440 s = (char*)utf8_hop((U8*)m, len);
5442 s = m + len; /* Fake \n at the end */
5447 maxiters += slen * RX_NPARENS(rx);
5448 while (s < strend && --limit)
5452 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
5453 sv, NULL, SvSCREAM(sv) ? REXEC_SCREAM : 0);
5455 if (rex_return == 0)
5457 TAINT_IF(RX_MATCH_TAINTED(rx));
5458 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
5461 orig = RX_SUBBEG(rx);
5463 strend = s + (strend - m);
5465 m = RX_OFFS(rx)[0].start + orig;
5474 dstr = newSVpvn_flags(s, m-s,
5475 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5478 if (RX_NPARENS(rx)) {
5480 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5481 s = RX_OFFS(rx)[i].start + orig;
5482 m = RX_OFFS(rx)[i].end + orig;
5484 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5485 parens that didn't match -- they should be set to
5486 undef, not the empty string */
5494 if (m >= orig && s >= orig) {
5495 dstr = newSVpvn_flags(s, m-s,
5496 (do_utf8 ? SVf_UTF8 : 0)
5500 dstr = &PL_sv_undef; /* undef, not "" */
5506 s = RX_OFFS(rx)[0].end + orig;
5510 if (!gimme_scalar) {
5511 iters = (SP - PL_stack_base) - base;
5513 if (iters > maxiters)
5514 DIE(aTHX_ "Split loop");
5516 /* keep field after final delim? */
5517 if (s < strend || (iters && origlimit)) {
5518 if (!gimme_scalar) {
5519 const STRLEN l = strend - s;
5520 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5525 else if (!origlimit) {
5527 iters -= trailing_empty;
5529 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5530 if (TOPs && !make_mortal)
5532 *SP-- = &PL_sv_undef;
5539 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5543 if (SvSMAGICAL(ary)) {
5545 mg_set(MUTABLE_SV(ary));
5548 if (gimme == G_ARRAY) {
5550 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5557 ENTER_with_name("call_PUSH");
5558 call_method("PUSH",G_SCALAR|G_DISCARD);
5559 LEAVE_with_name("call_PUSH");
5561 if (gimme == G_ARRAY) {
5563 /* EXTEND should not be needed - we just popped them */
5565 for (i=0; i < iters; i++) {
5566 SV **svp = av_fetch(ary, i, FALSE);
5567 PUSHs((svp) ? *svp : &PL_sv_undef);
5574 if (gimme == G_ARRAY)
5586 SV *const sv = PAD_SVl(PL_op->op_targ);
5588 if (SvPADSTALE(sv)) {
5591 RETURNOP(cLOGOP->op_other);
5593 RETURNOP(cLOGOP->op_next);
5603 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5604 || SvTYPE(retsv) == SVt_PVCV) {
5605 retsv = refto(retsv);
5612 PP(unimplemented_op)
5615 const Optype op_type = PL_op->op_type;
5616 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5617 with out of range op numbers - it only "special" cases op_custom.
5618 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5619 if we get here for a custom op then that means that the custom op didn't
5620 have an implementation. Given that OP_NAME() looks up the custom op
5621 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5622 registers &PL_unimplemented_op as the address of their custom op.
5623 NULL doesn't generate a useful error message. "custom" does. */
5624 const char *const name = op_type >= OP_max
5625 ? "[out of range]" : PL_op_name[PL_op->op_type];
5626 if(OP_IS_SOCKET(op_type))
5627 DIE(aTHX_ PL_no_sock_func, name);
5628 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
5635 HV * const hv = (HV*)POPs;
5637 if (SvTYPE(hv) != SVt_PVHV) { XPUSHs(&PL_sv_no); RETURN; }
5639 if (SvRMAGICAL(hv)) {
5640 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
5642 XPUSHs(magic_scalarpack(hv, mg));
5647 XPUSHs(boolSV(HvUSEDKEYS(hv) != 0));
5651 /* For sorting out arguments passed to a &CORE:: subroutine */
5655 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
5656 int defgv = PL_opargs[opnum] & OA_DEFGV, whicharg = 0;
5657 AV * const at_ = GvAV(PL_defgv);
5658 SV **svp = AvARRAY(at_);
5659 I32 minargs = 0, maxargs = 0, numargs = AvFILLp(at_)+1;
5660 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
5661 bool seen_question = 0;
5662 const char *err = NULL;
5663 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
5665 /* Count how many args there are first, to get some idea how far to
5666 extend the stack. */
5668 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
5670 if (oa & OA_OPTIONAL) seen_question = 1;
5671 if (!seen_question) minargs++;
5675 if(numargs < minargs) err = "Not enough";
5676 else if(numargs > maxargs) err = "Too many";
5678 /* diag_listed_as: Too many arguments for %s */
5680 "%s arguments for %s", err,
5681 opnum ? OP_DESC(PL_op->op_next) : SvPV_nolen_const(cSVOP_sv)
5684 /* Reset the stack pointer. Without this, we end up returning our own
5685 arguments in list context, in addition to the values we are supposed
5686 to return. nextstate usually does this on sub entry, but we need
5687 to run the next op with the caller's hints, so we cannot have a
5689 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
5691 if(!maxargs) RETURN;
5693 /* We do this here, rather than with a separate pushmark op, as it has
5694 to come in between two things this function does (stack reset and
5695 arg pushing). This seems the easiest way to do it. */
5698 (void)Perl_pp_pushmark(aTHX);
5701 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
5702 PUTBACK; /* The code below can die in various places. */
5704 oa = PL_opargs[opnum] >> OASHIFT;
5705 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
5709 if (!numargs && defgv && whicharg == minargs + 1) {
5710 PERL_SI * const oldsi = PL_curstackinfo;
5711 I32 const oldcxix = oldsi->si_cxix;
5713 if (oldcxix) oldsi->si_cxix--;
5714 else PL_curstackinfo = oldsi->si_prev;
5715 caller = find_runcv(NULL);
5716 PL_curstackinfo = oldsi;
5717 oldsi->si_cxix = oldcxix;
5718 PUSHs(find_rundefsv2(
5719 caller,cxstack[cxstack_ix].blk_oldcop->cop_seq
5722 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
5726 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
5731 if (!svp || !*svp || !SvROK(*svp)
5732 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
5734 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5735 "Type of arg %d to &CORE::%s must be hash reference",
5736 whicharg, OP_DESC(PL_op->op_next)
5741 if (!numargs) PUSHs(NULL);
5742 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
5743 /* no magic here, as the prototype will have added an extra
5744 refgen and we just want what was there before that */
5747 const bool constr = PL_op->op_private & whicharg;
5749 svp && *svp ? *svp : &PL_sv_undef,
5750 constr, CopHINTS_get(PL_curcop) & HINT_STRICT_REFS,
5757 const bool wantscalar =
5758 PL_op->op_private & OPpCOREARGS_SCALARMOD;
5759 if (!svp || !*svp || !SvROK(*svp)
5760 /* We have to permit globrefs even for the \$ proto, as
5761 *foo is indistinguishable from ${\*foo}, and the proto-
5762 type permits the latter. */
5763 || SvTYPE(SvRV(*svp)) > (
5764 wantscalar ? SVt_PVLV
5765 : opnum == OP_LOCK ? SVt_PVCV
5770 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
5771 "Type of arg %d to &CORE::%s must be %s",
5772 whicharg, OP_DESC(PL_op->op_next),
5774 ? "scalar reference"
5776 ? "reference to one of [$@%&*]"
5777 : "reference to one of [$@%*]"
5783 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
5795 if (PL_op->op_private & OPpOFFBYONE) {
5796 PERL_SI * const oldsi = PL_curstackinfo;
5797 I32 const oldcxix = oldsi->si_cxix;
5798 if (oldcxix) oldsi->si_cxix--;
5799 else PL_curstackinfo = oldsi->si_prev;
5800 cv = find_runcv(NULL);
5801 PL_curstackinfo = oldsi;
5802 oldsi->si_cxix = oldcxix;
5804 else cv = find_runcv(NULL);
5805 XPUSHs(CvUNIQUE(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
5812 * c-indentation-style: bsd
5814 * indent-tabs-mode: t
5817 * ex: set ts=8 sts=4 sw=4 noet: