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.
32 #include "regcharclass.h"
34 /* XXX I can't imagine anyone who doesn't have this actually _needs_
35 it, since pid_t is an integral type.
38 #ifdef NEED_GETPID_PROTO
39 extern Pid_t getpid (void);
43 * Some BSDs and Cygwin default to POSIX math instead of IEEE.
44 * This switches them over to IEEE.
46 #if defined(LIBM_LIB_VERSION)
47 _LIB_VERSION_TYPE _LIB_VERSION = _IEEE_;
50 static const STRLEN small_mu_len = sizeof(GREEK_SMALL_LETTER_MU_UTF8) - 1;
51 static const STRLEN capital_iota_len = sizeof(GREEK_CAPITAL_LETTER_IOTA_UTF8) - 1;
53 /* variations on pp_null */
58 if (GIMME_V == G_SCALAR)
69 assert(SvTYPE(TARG) == SVt_PVAV);
70 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
71 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
72 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
74 if (PL_op->op_flags & OPf_REF) {
77 } else if (PL_op->op_private & OPpMAYBE_LVSUB) {
78 const I32 flags = is_lvalue_sub();
79 if (flags && !(flags & OPpENTERSUB_INARGS)) {
80 if (GIMME == G_SCALAR)
81 /* diag_listed_as: Can't return %s to lvalue scalar context */
82 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
88 if (gimme == G_ARRAY) {
89 /* XXX see also S_pushav in pp_hot.c */
90 const Size_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
92 if (SvMAGICAL(TARG)) {
94 for (i=0; i < maxarg; i++) {
95 SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
96 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
101 for (i=0; i < (PADOFFSET)maxarg; i++) {
102 SV * const sv = AvARRAY((const AV *)TARG)[i];
103 SP[i+1] = sv ? sv : &PL_sv_undef;
108 else if (gimme == G_SCALAR) {
109 SV* const sv = sv_newmortal();
110 const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
111 sv_setiv(sv, maxarg);
122 assert(SvTYPE(TARG) == SVt_PVHV);
124 if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
125 if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
126 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
127 if (PL_op->op_flags & OPf_REF)
129 else if (PL_op->op_private & OPpMAYBE_LVSUB) {
130 const I32 flags = is_lvalue_sub();
131 if (flags && !(flags & OPpENTERSUB_INARGS)) {
132 if (GIMME == G_SCALAR)
133 /* diag_listed_as: Can't return %s to lvalue scalar context */
134 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
139 if (gimme == G_ARRAY) {
140 RETURNOP(Perl_do_kv(aTHX));
142 else if ((PL_op->op_private & OPpTRUEBOOL
143 || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
144 && block_gimme() == G_VOID ))
145 && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied)))
146 SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
147 else if (gimme == G_SCALAR) {
148 SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
157 assert(SvTYPE(TARG) == SVt_PVCV);
165 SvPADSTALE_off(TARG);
173 mg_find(PadlistNAMESARRAY(CvPADLIST(find_runcv(NULL)))[ARGTARG],
175 assert(SvTYPE(TARG) == SVt_PVCV);
178 if (CvISXSUB(mg->mg_obj)) { /* constant */
179 /* XXX Should we clone it here? */
180 /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
181 to introcv and remove the SvPADSTALE_off. */
182 SAVEPADSVANDMORTALIZE(ARGTARG);
183 PAD_SVl(ARGTARG) = SvREFCNT_inc_simple_NN(mg->mg_obj);
186 if (CvROOT(mg->mg_obj)) {
187 assert(CvCLONE(mg->mg_obj));
188 assert(!CvCLONED(mg->mg_obj));
190 cv_clone_into((CV *)mg->mg_obj,(CV *)TARG);
191 SAVECLEARSV(PAD_SVl(ARGTARG));
198 static const char S_no_symref_sv[] =
199 "Can't use string (\"%" SVf32 "\"%s) as %s ref while \"strict refs\" in use";
201 /* In some cases this function inspects PL_op. If this function is called
202 for new op types, more bool parameters may need to be added in place of
205 When noinit is true, the absence of a gv will cause a retval of undef.
206 This is unrelated to the cv-to-gv assignment case.
210 S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict,
213 if (!isGV(sv) || SvFAKE(sv)) SvGETMAGIC(sv);
216 sv = amagic_deref_call(sv, to_gv_amg);
220 if (SvTYPE(sv) == SVt_PVIO) {
221 GV * const gv = MUTABLE_GV(sv_newmortal());
222 gv_init(gv, 0, "__ANONIO__", 10, 0);
223 GvIOp(gv) = MUTABLE_IO(sv);
224 SvREFCNT_inc_void_NN(sv);
227 else if (!isGV_with_GP(sv)) {
228 Perl_die(aTHX_ "Not a GLOB reference");
232 if (!isGV_with_GP(sv)) {
234 /* If this is a 'my' scalar and flag is set then vivify
237 if (vivify_sv && sv != &PL_sv_undef) {
240 Perl_croak_no_modify();
241 if (cUNOP->op_targ) {
242 SV * const namesv = PAD_SV(cUNOP->op_targ);
243 HV *stash = CopSTASH(PL_curcop);
244 if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
245 gv = MUTABLE_GV(newSV(0));
246 gv_init_sv(gv, stash, namesv, 0);
249 const char * const name = CopSTASHPV(PL_curcop);
250 gv = newGVgen_flags(name,
251 HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 );
252 SvREFCNT_inc_simple_void_NN(gv);
254 prepare_SV_for_RV(sv);
255 SvRV_set(sv, MUTABLE_SV(gv));
260 if (PL_op->op_flags & OPf_REF || strict) {
261 Perl_die(aTHX_ PL_no_usym, "a symbol");
263 if (ckWARN(WARN_UNINITIALIZED))
269 if (!(sv = MUTABLE_SV(gv_fetchsv_nomg(
270 sv, GV_ADDMG, SVt_PVGV
279 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
283 if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV))
284 == OPpDONT_INIT_GV) {
285 /* We are the target of a coderef assignment. Return
286 the scalar unchanged, and let pp_sasssign deal with
290 sv = MUTABLE_SV(gv_fetchsv_nomg(sv, GV_ADD, SVt_PVGV));
292 /* FAKE globs in the symbol table cause weird bugs (#77810) */
296 if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
297 SV *newsv = sv_newmortal();
298 sv_setsv_flags(newsv, sv, 0);
310 sv, PL_op->op_private & OPpDEREF,
311 PL_op->op_private & HINT_STRICT_REFS,
312 ((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
313 || PL_op->op_type == OP_READLINE
315 if (PL_op->op_private & OPpLVAL_INTRO)
316 save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
321 /* Helper function for pp_rv2sv and pp_rv2av */
323 Perl_softref2xv(pTHX_ SV *const sv, const char *const what,
324 const svtype type, SV ***spp)
328 PERL_ARGS_ASSERT_SOFTREF2XV;
330 if (PL_op->op_private & HINT_STRICT_REFS) {
332 Perl_die(aTHX_ S_no_symref_sv, sv,
333 (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
335 Perl_die(aTHX_ PL_no_usym, what);
339 PL_op->op_flags & OPf_REF
341 Perl_die(aTHX_ PL_no_usym, what);
342 if (ckWARN(WARN_UNINITIALIZED))
344 if (type != SVt_PV && GIMME_V == G_ARRAY) {
348 **spp = &PL_sv_undef;
351 if ((PL_op->op_flags & OPf_SPECIAL) &&
352 !(PL_op->op_flags & OPf_MOD))
354 if (!(gv = gv_fetchsv_nomg(sv, GV_ADDMG, type)))
356 **spp = &PL_sv_undef;
361 gv = gv_fetchsv_nomg(sv, GV_ADD, type);
374 sv = amagic_deref_call(sv, to_sv_amg);
378 switch (SvTYPE(sv)) {
384 DIE(aTHX_ "Not a SCALAR reference");
391 if (!isGV_with_GP(gv)) {
392 gv = Perl_softref2xv(aTHX_ sv, "a SCALAR", SVt_PV, &sp);
398 if (PL_op->op_flags & OPf_MOD) {
399 if (PL_op->op_private & OPpLVAL_INTRO) {
400 if (cUNOP->op_first->op_type == OP_NULL)
401 sv = save_scalar(MUTABLE_GV(TOPs));
403 sv = save_scalar(gv);
405 Perl_croak(aTHX_ "%s", PL_no_localize_ref);
407 else if (PL_op->op_private & OPpDEREF)
408 sv = vivify_ref(sv, PL_op->op_private & OPpDEREF);
417 AV * const av = MUTABLE_AV(TOPs);
418 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
420 SV ** const sv = Perl_av_arylen_p(aTHX_ MUTABLE_AV(av));
422 *sv = newSV_type(SVt_PVMG);
423 sv_magic(*sv, MUTABLE_SV(av), PERL_MAGIC_arylen, NULL, 0);
427 SETs(sv_2mortal(newSViv(AvFILL(MUTABLE_AV(av)))));
436 if (PL_op->op_flags & OPf_MOD || LVRET) {
437 SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));/* Not TARG RT#67838 */
438 sv_magic(ret, NULL, PERL_MAGIC_pos, NULL, 0);
440 LvTARG(ret) = SvREFCNT_inc_simple(sv);
441 PUSHs(ret); /* no SvSETMAGIC */
445 const MAGIC * const mg = mg_find_mglob(sv);
446 if (mg && mg->mg_len != -1) {
448 STRLEN i = mg->mg_len;
449 if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
450 i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
463 const I32 flags = (PL_op->op_flags & OPf_SPECIAL)
465 : ((PL_op->op_private & (OPpLVAL_INTRO|OPpMAY_RETURN_CONSTANT))
466 == OPpMAY_RETURN_CONSTANT)
469 /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
470 /* (But not in defined().) */
472 CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
474 else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
475 cv = SvTYPE(SvRV(gv)) == SVt_PVCV
476 ? MUTABLE_CV(SvRV(gv))
480 cv = MUTABLE_CV(&PL_sv_undef);
481 SETs(MUTABLE_SV(cv));
491 SV *ret = &PL_sv_undef;
493 if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
494 if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
495 const char * s = SvPVX_const(TOPs);
496 if (strnEQ(s, "CORE::", 6)) {
497 const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
499 DIE(aTHX_ "Can't find an opnumber for \"%"UTF8f"\"",
500 UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
502 SV * const sv = core_prototype(NULL, s + 6, code, NULL);
508 cv = sv_2cv(TOPs, &stash, &gv, 0);
510 ret = newSVpvn_flags(
511 CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
521 CV *cv = MUTABLE_CV(PAD_SV(PL_op->op_targ));
523 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
525 PUSHs(MUTABLE_SV(cv));
539 if (GIMME != G_ARRAY) {
543 *MARK = &PL_sv_undef;
544 *MARK = refto(*MARK);
548 EXTEND_MORTAL(SP - MARK);
550 *MARK = refto(*MARK);
555 S_refto(pTHX_ SV *sv)
559 PERL_ARGS_ASSERT_REFTO;
561 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
564 if (!(sv = LvTARG(sv)))
567 SvREFCNT_inc_void_NN(sv);
569 else if (SvTYPE(sv) == SVt_PVAV) {
570 if (!AvREAL((const AV *)sv) && AvREIFY((const AV *)sv))
571 av_reify(MUTABLE_AV(sv));
573 SvREFCNT_inc_void_NN(sv);
575 else if (SvPADTMP(sv)) {
580 SvREFCNT_inc_void_NN(sv);
583 sv_upgrade(rv, SVt_IV);
592 SV * const sv = TOPs;
600 /* use the return value that is in a register, its the same as TARG */
601 TARG = sv_ref(TARG,SvRV(sv),TRUE);
616 stash = CopSTASH(PL_curcop);
617 if (SvTYPE(stash) != SVt_PVHV)
618 Perl_croak(aTHX_ "Attempt to bless into a freed package");
621 SV * const ssv = POPs;
625 if (!ssv) goto curstash;
628 if (!SvAMAGIC(ssv)) {
630 Perl_croak(aTHX_ "Attempt to bless into a reference");
632 /* SvAMAGIC is on here, but it only means potentially overloaded,
633 so after stringification: */
634 ptr = SvPV_nomg_const(ssv,len);
635 /* We need to check the flag again: */
636 if (!SvAMAGIC(ssv)) goto frog;
638 else ptr = SvPV_nomg_const(ssv,len);
640 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
641 "Explicit blessing to '' (assuming package main)");
642 stash = gv_stashpvn(ptr, len, GV_ADD|SvUTF8(ssv));
645 (void)sv_bless(TOPs, stash);
655 const char * const elem = SvPV_const(sv, len);
656 GV * const gv = MUTABLE_GV(POPs);
661 /* elem will always be NUL terminated. */
662 const char * const second_letter = elem + 1;
665 if (len == 5 && strEQ(second_letter, "RRAY"))
667 tmpRef = MUTABLE_SV(GvAV(gv));
668 if (tmpRef && !AvREAL((const AV *)tmpRef)
669 && AvREIFY((const AV *)tmpRef))
670 av_reify(MUTABLE_AV(tmpRef));
674 if (len == 4 && strEQ(second_letter, "ODE"))
675 tmpRef = MUTABLE_SV(GvCVu(gv));
678 if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
679 /* finally deprecated in 5.8.0 */
680 deprecate("*glob{FILEHANDLE}");
681 tmpRef = MUTABLE_SV(GvIOp(gv));
684 if (len == 6 && strEQ(second_letter, "ORMAT"))
685 tmpRef = MUTABLE_SV(GvFORM(gv));
688 if (len == 4 && strEQ(second_letter, "LOB"))
689 tmpRef = MUTABLE_SV(gv);
692 if (len == 4 && strEQ(second_letter, "ASH"))
693 tmpRef = MUTABLE_SV(GvHV(gv));
696 if (*second_letter == 'O' && !elem[2] && len == 2)
697 tmpRef = MUTABLE_SV(GvIOp(gv));
700 if (len == 4 && strEQ(second_letter, "AME"))
701 sv = newSVhek(GvNAME_HEK(gv));
704 if (len == 7 && strEQ(second_letter, "ACKAGE")) {
705 const HV * const stash = GvSTASH(gv);
706 const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
707 sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
711 if (len == 6 && strEQ(second_letter, "CALAR"))
726 /* Pattern matching */
734 if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
735 /* Historically, study was skipped in these cases. */
739 /* Make study a no-op. It's no longer useful and its existence
740 complicates matters elsewhere. */
745 /* also used for: pp_transr() */
752 if (PL_op->op_flags & OPf_STACKED)
754 else if (PL_op->op_private & OPpTARGET_MY)
760 if(PL_op->op_type == OP_TRANSR) {
762 const char * const pv = SvPV(sv,len);
763 SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
768 TARG = sv_newmortal();
774 /* Lvalue operators. */
777 S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping)
782 PERL_ARGS_ASSERT_DO_CHOMP;
784 if (chomping && (RsSNARF(PL_rs) || RsRECORD(PL_rs)))
786 if (SvTYPE(sv) == SVt_PVAV) {
788 AV *const av = MUTABLE_AV(sv);
789 const I32 max = AvFILL(av);
791 for (i = 0; i <= max; i++) {
792 sv = MUTABLE_SV(av_fetch(av, i, FALSE));
793 if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
794 do_chomp(retval, sv, chomping);
798 else if (SvTYPE(sv) == SVt_PVHV) {
799 HV* const hv = MUTABLE_HV(sv);
801 (void)hv_iterinit(hv);
802 while ((entry = hv_iternext(hv)))
803 do_chomp(retval, hv_iterval(hv,entry), chomping);
806 else if (SvREADONLY(sv)) {
807 Perl_croak_no_modify();
809 else if (SvIsCOW(sv)) {
810 sv_force_normal_flags(sv, 0);
815 /* XXX, here sv is utf8-ized as a side-effect!
816 If encoding.pm is used properly, almost string-generating
817 operations, including literal strings, chr(), input data, etc.
818 should have been utf8-ized already, right?
820 sv_recode_to_utf8(sv, PL_encoding);
826 char *temp_buffer = NULL;
835 while (len && s[-1] == '\n') {
842 STRLEN rslen, rs_charlen;
843 const char *rsptr = SvPV_const(PL_rs, rslen);
845 rs_charlen = SvUTF8(PL_rs)
849 if (SvUTF8(PL_rs) != SvUTF8(sv)) {
850 /* Assumption is that rs is shorter than the scalar. */
852 /* RS is utf8, scalar is 8 bit. */
854 temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
857 /* Cannot downgrade, therefore cannot possibly match
859 assert (temp_buffer == rsptr);
865 else if (PL_encoding) {
866 /* RS is 8 bit, encoding.pm is used.
867 * Do not recode PL_rs as a side-effect. */
868 svrecode = newSVpvn(rsptr, rslen);
869 sv_recode_to_utf8(svrecode, PL_encoding);
870 rsptr = SvPV_const(svrecode, rslen);
871 rs_charlen = sv_len_utf8(svrecode);
874 /* RS is 8 bit, scalar is utf8. */
875 temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
889 if (memNE(s, rsptr, rslen))
891 SvIVX(retval) += rs_charlen;
894 s = SvPV_force_nomg_nolen(sv);
902 SvREFCNT_dec(svrecode);
904 Safefree(temp_buffer);
906 if (len && !SvPOK(sv))
907 s = SvPV_force_nomg(sv, len);
910 char * const send = s + len;
911 char * const start = s;
913 while (s > start && UTF8_IS_CONTINUATION(*s))
915 if (is_utf8_string((U8*)s, send - s)) {
916 sv_setpvn(retval, s, send - s);
918 SvCUR_set(sv, s - start);
924 sv_setpvs(retval, "");
928 sv_setpvn(retval, s, 1);
935 sv_setpvs(retval, "");
941 /* also used for: pp_schomp() */
946 const bool chomping = PL_op->op_type == OP_SCHOMP;
950 do_chomp(TARG, TOPs, chomping);
956 /* also used for: pp_chomp() */
960 dSP; dMARK; dTARGET; dORIGMARK;
961 const bool chomping = PL_op->op_type == OP_CHOMP;
966 do_chomp(TARG, *++MARK, chomping);
977 if (!PL_op->op_private) {
986 if (SvTHINKFIRST(sv))
987 sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF);
989 switch (SvTYPE(sv)) {
993 av_undef(MUTABLE_AV(sv));
996 hv_undef(MUTABLE_HV(sv));
999 if (cv_const_sv((const CV *)sv))
1000 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1001 "Constant subroutine %"SVf" undefined",
1002 SVfARG(CvANON((const CV *)sv)
1003 ? newSVpvs_flags("(anonymous)", SVs_TEMP)
1004 : sv_2mortal(newSVhek(
1006 ? CvNAME_HEK((CV *)sv)
1007 : GvENAME_HEK(CvGV((const CV *)sv))
1012 /* let user-undef'd sub keep its identity */
1013 cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME);
1016 assert(isGV_with_GP(sv));
1017 assert(!SvFAKE(sv));
1022 /* undef *Pkg::meth_name ... */
1024 = GvCVu((const GV *)sv) && (stash = GvSTASH((const GV *)sv))
1025 && HvENAME_get(stash);
1027 if((stash = GvHV((const GV *)sv))) {
1028 if(HvENAME_get(stash))
1029 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)stash));
1033 SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
1034 gp_free(MUTABLE_GV(sv));
1036 GvGP_set(sv, gp_ref(gp));
1037 #ifndef PERL_DONT_CREATE_GVSV
1038 GvSV(sv) = newSV(0);
1040 GvLINE(sv) = CopLINE(PL_curcop);
1041 GvEGV(sv) = MUTABLE_GV(sv);
1045 mro_package_moved(NULL, stash, (const GV *)sv, 0);
1047 /* undef *Foo::ISA */
1048 if( strEQ(GvNAME((const GV *)sv), "ISA")
1049 && (stash = GvSTASH((const GV *)sv))
1050 && (method_changed || HvENAME(stash)) )
1051 mro_isa_changed_in(stash);
1052 else if(method_changed)
1053 mro_method_changed_in(
1054 GvSTASH((const GV *)sv)
1060 if (SvTYPE(sv) >= SVt_PV && SvPVX_const(sv) && SvLEN(sv)) {
1073 /* also used for: pp_i_postdec() pp_i_postinc() pp_postdec() */
1079 PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC;
1080 if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
1081 Perl_croak_no_modify();
1083 TARG = sv_newmortal();
1084 sv_setsv(TARG, TOPs);
1085 if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
1086 && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
1088 SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
1089 SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
1093 else sv_dec_nomg(TOPs);
1095 /* special case for undef: see thread at 2003-03/msg00536.html in archive */
1096 if (inc && !SvOK(TARG))
1102 /* Ordinary operators. */
1106 dSP; dATARGET; SV *svl, *svr;
1107 #ifdef PERL_PRESERVE_IVUV
1110 tryAMAGICbin_MG(pow_amg, AMGf_assign|AMGf_numeric);
1113 #ifdef PERL_PRESERVE_IVUV
1114 /* For integer to integer power, we do the calculation by hand wherever
1115 we're sure it is safe; otherwise we call pow() and try to convert to
1116 integer afterwards. */
1117 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1125 const IV iv = SvIVX(svr);
1129 goto float_it; /* Can't do negative powers this way. */
1133 baseuok = SvUOK(svl);
1135 baseuv = SvUVX(svl);
1137 const IV iv = SvIVX(svl);
1140 baseuok = TRUE; /* effectively it's a UV now */
1142 baseuv = -iv; /* abs, baseuok == false records sign */
1145 /* now we have integer ** positive integer. */
1148 /* foo & (foo - 1) is zero only for a power of 2. */
1149 if (!(baseuv & (baseuv - 1))) {
1150 /* We are raising power-of-2 to a positive integer.
1151 The logic here will work for any base (even non-integer
1152 bases) but it can be less accurate than
1153 pow (base,power) or exp (power * log (base)) when the
1154 intermediate values start to spill out of the mantissa.
1155 With powers of 2 we know this can't happen.
1156 And powers of 2 are the favourite thing for perl
1157 programmers to notice ** not doing what they mean. */
1159 NV base = baseuok ? baseuv : -(NV)baseuv;
1164 while (power >>= 1) {
1172 SvIV_please_nomg(svr);
1175 unsigned int highbit = 8 * sizeof(UV);
1176 unsigned int diff = 8 * sizeof(UV);
1177 while (diff >>= 1) {
1179 if (baseuv >> highbit) {
1183 /* we now have baseuv < 2 ** highbit */
1184 if (power * highbit <= 8 * sizeof(UV)) {
1185 /* result will definitely fit in UV, so use UV math
1186 on same algorithm as above */
1189 const bool odd_power = cBOOL(power & 1);
1193 while (power >>= 1) {
1200 if (baseuok || !odd_power)
1201 /* answer is positive */
1203 else if (result <= (UV)IV_MAX)
1204 /* answer negative, fits in IV */
1205 SETi( -(IV)result );
1206 else if (result == (UV)IV_MIN)
1207 /* 2's complement assumption: special case IV_MIN */
1210 /* answer negative, doesn't fit */
1211 SETn( -(NV)result );
1219 NV right = SvNV_nomg(svr);
1220 NV left = SvNV_nomg(svl);
1223 #if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
1225 We are building perl with long double support and are on an AIX OS
1226 afflicted with a powl() function that wrongly returns NaNQ for any
1227 negative base. This was reported to IBM as PMR #23047-379 on
1228 03/06/2006. The problem exists in at least the following versions
1229 of AIX and the libm fileset, and no doubt others as well:
1231 AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
1232 AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
1233 AIX 5.2.0 bos.adt.libm 5.2.0.85
1235 So, until IBM fixes powl(), we provide the following workaround to
1236 handle the problem ourselves. Our logic is as follows: for
1237 negative bases (left), we use fmod(right, 2) to check if the
1238 exponent is an odd or even integer:
1240 - if odd, powl(left, right) == -powl(-left, right)
1241 - if even, powl(left, right) == powl(-left, right)
1243 If the exponent is not an integer, the result is rightly NaNQ, so
1244 we just return that (as NV_NAN).
1248 NV mod2 = Perl_fmod( right, 2.0 );
1249 if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
1250 SETn( -Perl_pow( -left, right) );
1251 } else if (mod2 == 0.0) { /* even integer */
1252 SETn( Perl_pow( -left, right) );
1253 } else { /* fractional power */
1257 SETn( Perl_pow( left, right) );
1260 SETn( Perl_pow( left, right) );
1261 #endif /* HAS_AIX_POWL_NEG_BASE_BUG */
1263 #ifdef PERL_PRESERVE_IVUV
1265 SvIV_please_nomg(svr);
1273 dSP; dATARGET; SV *svl, *svr;
1274 tryAMAGICbin_MG(mult_amg, AMGf_assign|AMGf_numeric);
1277 #ifdef PERL_PRESERVE_IVUV
1278 if (SvIV_please_nomg(svr)) {
1279 /* Unless the left argument is integer in range we are going to have to
1280 use NV maths. Hence only attempt to coerce the right argument if
1281 we know the left is integer. */
1282 /* Left operand is defined, so is it IV? */
1283 if (SvIV_please_nomg(svl)) {
1284 bool auvok = SvUOK(svl);
1285 bool buvok = SvUOK(svr);
1286 const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
1287 const UV botmask = ~((~ (UV)0) << (4 * sizeof (UV)));
1296 const IV aiv = SvIVX(svl);
1299 auvok = TRUE; /* effectively it's a UV now */
1301 alow = -aiv; /* abs, auvok == false records sign */
1307 const IV biv = SvIVX(svr);
1310 buvok = TRUE; /* effectively it's a UV now */
1312 blow = -biv; /* abs, buvok == false records sign */
1316 /* If this does sign extension on unsigned it's time for plan B */
1317 ahigh = alow >> (4 * sizeof (UV));
1319 bhigh = blow >> (4 * sizeof (UV));
1321 if (ahigh && bhigh) {
1323 /* eg 32 bit is at least 0x10000 * 0x10000 == 0x100000000
1324 which is overflow. Drop to NVs below. */
1325 } else if (!ahigh && !bhigh) {
1326 /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001
1327 so the unsigned multiply cannot overflow. */
1328 const UV product = alow * blow;
1329 if (auvok == buvok) {
1330 /* -ve * -ve or +ve * +ve gives a +ve result. */
1334 } else if (product <= (UV)IV_MIN) {
1335 /* 2s complement assumption that (UV)-IV_MIN is correct. */
1336 /* -ve result, which could overflow an IV */
1338 SETi( -(IV)product );
1340 } /* else drop to NVs below. */
1342 /* One operand is large, 1 small */
1345 /* swap the operands */
1347 bhigh = blow; /* bhigh now the temp var for the swap */
1351 /* now, ((ahigh * blow) << half_UV_len) + (alow * blow)
1352 multiplies can't overflow. shift can, add can, -ve can. */
1353 product_middle = ahigh * blow;
1354 if (!(product_middle & topmask)) {
1355 /* OK, (ahigh * blow) won't lose bits when we shift it. */
1357 product_middle <<= (4 * sizeof (UV));
1358 product_low = alow * blow;
1360 /* as for pp_add, UV + something mustn't get smaller.
1361 IIRC ANSI mandates this wrapping *behaviour* for
1362 unsigned whatever the actual representation*/
1363 product_low += product_middle;
1364 if (product_low >= product_middle) {
1365 /* didn't overflow */
1366 if (auvok == buvok) {
1367 /* -ve * -ve or +ve * +ve gives a +ve result. */
1369 SETu( product_low );
1371 } else if (product_low <= (UV)IV_MIN) {
1372 /* 2s complement assumption again */
1373 /* -ve result, which could overflow an IV */
1375 SETi( -(IV)product_low );
1377 } /* else drop to NVs below. */
1379 } /* product_middle too large */
1380 } /* ahigh && bhigh */
1385 NV right = SvNV_nomg(svr);
1386 NV left = SvNV_nomg(svl);
1388 SETn( left * right );
1395 dSP; dATARGET; SV *svl, *svr;
1396 tryAMAGICbin_MG(div_amg, AMGf_assign|AMGf_numeric);
1399 /* Only try to do UV divide first
1400 if ((SLOPPYDIVIDE is true) or
1401 (PERL_PRESERVE_IVUV is true and one or both SV is a UV too large
1403 The assumption is that it is better to use floating point divide
1404 whenever possible, only doing integer divide first if we can't be sure.
1405 If NV_PRESERVES_UV is true then we know at compile time that no UV
1406 can be too large to preserve, so don't need to compile the code to
1407 test the size of UVs. */
1410 # define PERL_TRY_UV_DIVIDE
1411 /* ensure that 20./5. == 4. */
1413 # ifdef PERL_PRESERVE_IVUV
1414 # ifndef NV_PRESERVES_UV
1415 # define PERL_TRY_UV_DIVIDE
1420 #ifdef PERL_TRY_UV_DIVIDE
1421 if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
1422 bool left_non_neg = SvUOK(svl);
1423 bool right_non_neg = SvUOK(svr);
1427 if (right_non_neg) {
1431 const IV biv = SvIVX(svr);
1434 right_non_neg = TRUE; /* effectively it's a UV now */
1440 /* historically undef()/0 gives a "Use of uninitialized value"
1441 warning before dieing, hence this test goes here.
1442 If it were immediately before the second SvIV_please, then
1443 DIE() would be invoked before left was even inspected, so
1444 no inspection would give no warning. */
1446 DIE(aTHX_ "Illegal division by zero");
1452 const IV aiv = SvIVX(svl);
1455 left_non_neg = TRUE; /* effectively it's a UV now */
1464 /* For sloppy divide we always attempt integer division. */
1466 /* Otherwise we only attempt it if either or both operands
1467 would not be preserved by an NV. If both fit in NVs
1468 we fall through to the NV divide code below. However,
1469 as left >= right to ensure integer result here, we know that
1470 we can skip the test on the right operand - right big
1471 enough not to be preserved can't get here unless left is
1474 && (left > ((UV)1 << NV_PRESERVES_UV_BITS))
1477 /* Integer division can't overflow, but it can be imprecise. */
1478 const UV result = left / right;
1479 if (result * right == left) {
1480 SP--; /* result is valid */
1481 if (left_non_neg == right_non_neg) {
1482 /* signs identical, result is positive. */
1486 /* 2s complement assumption */
1487 if (result <= (UV)IV_MIN)
1488 SETi( -(IV)result );
1490 /* It's exact but too negative for IV. */
1491 SETn( -(NV)result );
1494 } /* tried integer divide but it was not an integer result */
1495 } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
1496 } /* one operand wasn't SvIOK */
1497 #endif /* PERL_TRY_UV_DIVIDE */
1499 NV right = SvNV_nomg(svr);
1500 NV left = SvNV_nomg(svl);
1501 (void)POPs;(void)POPs;
1502 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1503 if (! Perl_isnan(right) && right == 0.0)
1507 DIE(aTHX_ "Illegal division by zero");
1508 PUSHn( left / right );
1516 tryAMAGICbin_MG(modulo_amg, AMGf_assign|AMGf_numeric);
1520 bool left_neg = FALSE;
1521 bool right_neg = FALSE;
1522 bool use_double = FALSE;
1523 bool dright_valid = FALSE;
1526 SV * const svr = TOPs;
1527 SV * const svl = TOPm1s;
1528 if (SvIV_please_nomg(svr)) {
1529 right_neg = !SvUOK(svr);
1533 const IV biv = SvIVX(svr);
1536 right_neg = FALSE; /* effectively it's a UV now */
1543 dright = SvNV_nomg(svr);
1544 right_neg = dright < 0;
1547 if (dright < UV_MAX_P1) {
1548 right = U_V(dright);
1549 dright_valid = TRUE; /* In case we need to use double below. */
1555 /* At this point use_double is only true if right is out of range for
1556 a UV. In range NV has been rounded down to nearest UV and
1557 use_double false. */
1558 if (!use_double && SvIV_please_nomg(svl)) {
1559 left_neg = !SvUOK(svl);
1563 const IV aiv = SvIVX(svl);
1566 left_neg = FALSE; /* effectively it's a UV now */
1573 dleft = SvNV_nomg(svl);
1574 left_neg = dleft < 0;
1578 /* This should be exactly the 5.6 behaviour - if left and right are
1579 both in range for UV then use U_V() rather than floor. */
1581 if (dleft < UV_MAX_P1) {
1582 /* right was in range, so is dleft, so use UVs not double.
1586 /* left is out of range for UV, right was in range, so promote
1587 right (back) to double. */
1589 /* The +0.5 is used in 5.6 even though it is not strictly
1590 consistent with the implicit +0 floor in the U_V()
1591 inside the #if 1. */
1592 dleft = Perl_floor(dleft + 0.5);
1595 dright = Perl_floor(dright + 0.5);
1606 DIE(aTHX_ "Illegal modulus zero");
1608 dans = Perl_fmod(dleft, dright);
1609 if ((left_neg != right_neg) && dans)
1610 dans = dright - dans;
1613 sv_setnv(TARG, dans);
1619 DIE(aTHX_ "Illegal modulus zero");
1622 if ((left_neg != right_neg) && ans)
1625 /* XXX may warn: unary minus operator applied to unsigned type */
1626 /* could change -foo to be (~foo)+1 instead */
1627 if (ans <= ~((UV)IV_MAX)+1)
1628 sv_setiv(TARG, ~ans+1);
1630 sv_setnv(TARG, -(NV)ans);
1633 sv_setuv(TARG, ans);
1646 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1647 /* TODO: think of some way of doing list-repeat overloading ??? */
1652 tryAMAGICbin_MG(repeat_amg, AMGf_assign);
1658 const UV uv = SvUV_nomg(sv);
1660 count = IV_MAX; /* The best we can do? */
1664 count = SvIV_nomg(sv);
1667 else if (SvNOKp(sv)) {
1668 const NV nv = SvNV_nomg(sv);
1670 count = -1; /* An arbitrary negative integer */
1675 count = SvIV_nomg(sv);
1679 Perl_ck_warner(aTHX_ packWARN(WARN_NUMERIC),
1680 "Negative repeat count does nothing");
1683 if (GIMME == G_ARRAY && PL_op->op_private & OPpREPEAT_DOLIST) {
1685 static const char* const oom_list_extend = "Out of memory during list extend";
1686 const I32 items = SP - MARK;
1687 const I32 max = items * count;
1688 const U8 mod = PL_op->op_flags & OPf_MOD;
1690 MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
1691 /* Did the max computation overflow? */
1692 if (items > 0 && max > 0 && (max < items || max < count))
1693 Perl_croak(aTHX_ "%s", oom_list_extend);
1698 /* This code was intended to fix 20010809.028:
1701 for (($x =~ /./g) x 2) {
1702 print chop; # "abcdabcd" expected as output.
1705 * but that change (#11635) broke this code:
1707 $x = [("foo")x2]; # only one "foo" ended up in the anonlist.
1709 * I can't think of a better fix that doesn't introduce
1710 * an efficiency hit by copying the SVs. The stack isn't
1711 * refcounted, and mortalisation obviously doesn't
1712 * Do The Right Thing when the stack has more than
1713 * one pointer to the same mortal value.
1717 *SP = sv_2mortal(newSVsv(*SP));
1722 if (mod && SvPADTMP(*SP)) {
1723 *SP = sv_mortalcopy(*SP);
1731 repeatcpy((char*)(MARK + items), (char*)MARK,
1732 items * sizeof(const SV *), count - 1);
1735 else if (count <= 0)
1738 else { /* Note: mark already snarfed by pp_list */
1739 SV * const tmpstr = POPs;
1742 static const char* const oom_string_extend =
1743 "Out of memory during string extend";
1746 sv_setsv_nomg(TARG, tmpstr);
1747 SvPV_force_nomg(TARG, len);
1748 isutf = DO_UTF8(TARG);
1753 const STRLEN max = (UV)count * len;
1754 if (len > MEM_SIZE_MAX / count)
1755 Perl_croak(aTHX_ "%s", oom_string_extend);
1756 MEM_WRAP_CHECK_1(max, char, oom_string_extend);
1757 SvGROW(TARG, max + 1);
1758 repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
1759 SvCUR_set(TARG, SvCUR(TARG) * count);
1761 *SvEND(TARG) = '\0';
1764 (void)SvPOK_only_UTF8(TARG);
1766 (void)SvPOK_only(TARG);
1768 if (PL_op->op_private & OPpREPEAT_DOLIST) {
1769 /* The parser saw this as a list repeat, and there
1770 are probably several items on the stack. But we're
1771 in scalar context, and there's no pp_list to save us
1772 now. So drop the rest of the items -- robin@kitsite.com
1784 dSP; dATARGET; bool useleft; SV *svl, *svr;
1785 tryAMAGICbin_MG(subtr_amg, AMGf_assign|AMGf_numeric);
1788 useleft = USE_LEFT(svl);
1789 #ifdef PERL_PRESERVE_IVUV
1790 /* See comments in pp_add (in pp_hot.c) about Overflow, and how
1791 "bad things" happen if you rely on signed integers wrapping. */
1792 if (SvIV_please_nomg(svr)) {
1793 /* Unless the left argument is integer in range we are going to have to
1794 use NV maths. Hence only attempt to coerce the right argument if
1795 we know the left is integer. */
1802 a_valid = auvok = 1;
1803 /* left operand is undef, treat as zero. */
1805 /* Left operand is defined, so is it IV? */
1806 if (SvIV_please_nomg(svl)) {
1807 if ((auvok = SvUOK(svl)))
1810 const IV aiv = SvIVX(svl);
1813 auvok = 1; /* Now acting as a sign flag. */
1814 } else { /* 2s complement assumption for IV_MIN */
1822 bool result_good = 0;
1825 bool buvok = SvUOK(svr);
1830 const IV biv = SvIVX(svr);
1837 /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
1838 else "IV" now, independent of how it came in.
1839 if a, b represents positive, A, B negative, a maps to -A etc
1844 all UV maths. negate result if A negative.
1845 subtract if signs same, add if signs differ. */
1847 if (auvok ^ buvok) {
1856 /* Must get smaller */
1861 if (result <= buv) {
1862 /* result really should be -(auv-buv). as its negation
1863 of true value, need to swap our result flag */
1875 if (result <= (UV)IV_MIN)
1876 SETi( -(IV)result );
1878 /* result valid, but out of range for IV. */
1879 SETn( -(NV)result );
1883 } /* Overflow, drop through to NVs. */
1888 NV value = SvNV_nomg(svr);
1892 /* left operand is undef, treat as zero - value */
1896 SETn( SvNV_nomg(svl) - value );
1903 dSP; dATARGET; SV *svl, *svr;
1904 tryAMAGICbin_MG(lshift_amg, AMGf_assign|AMGf_numeric);
1908 const IV shift = SvIV_nomg(svr);
1909 if (PL_op->op_private & HINT_INTEGER) {
1910 const IV i = SvIV_nomg(svl);
1914 const UV u = SvUV_nomg(svl);
1923 dSP; dATARGET; SV *svl, *svr;
1924 tryAMAGICbin_MG(rshift_amg, AMGf_assign|AMGf_numeric);
1928 const IV shift = SvIV_nomg(svr);
1929 if (PL_op->op_private & HINT_INTEGER) {
1930 const IV i = SvIV_nomg(svl);
1934 const UV u = SvUV_nomg(svl);
1946 tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric);
1950 (SvIOK_notUV(left) && SvIOK_notUV(right))
1951 ? (SvIVX(left) < SvIVX(right))
1952 : (do_ncmp(left, right) == -1)
1962 tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric);
1966 (SvIOK_notUV(left) && SvIOK_notUV(right))
1967 ? (SvIVX(left) > SvIVX(right))
1968 : (do_ncmp(left, right) == 1)
1978 tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric);
1982 (SvIOK_notUV(left) && SvIOK_notUV(right))
1983 ? (SvIVX(left) <= SvIVX(right))
1984 : (do_ncmp(left, right) <= 0)
1994 tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric);
1998 (SvIOK_notUV(left) && SvIOK_notUV(right))
1999 ? (SvIVX(left) >= SvIVX(right))
2000 : ( (do_ncmp(left, right) & 2) == 0)
2010 tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric);
2014 (SvIOK_notUV(left) && SvIOK_notUV(right))
2015 ? (SvIVX(left) != SvIVX(right))
2016 : (do_ncmp(left, right) != 0)
2021 /* compare left and right SVs. Returns:
2025 * 2: left or right was a NaN
2028 Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
2030 PERL_ARGS_ASSERT_DO_NCMP;
2031 #ifdef PERL_PRESERVE_IVUV
2032 /* Fortunately it seems NaN isn't IOK */
2033 if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
2035 const IV leftiv = SvIVX(left);
2036 if (!SvUOK(right)) {
2037 /* ## IV <=> IV ## */
2038 const IV rightiv = SvIVX(right);
2039 return (leftiv > rightiv) - (leftiv < rightiv);
2041 /* ## IV <=> UV ## */
2043 /* As (b) is a UV, it's >=0, so it must be < */
2046 const UV rightuv = SvUVX(right);
2047 return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
2052 /* ## UV <=> UV ## */
2053 const UV leftuv = SvUVX(left);
2054 const UV rightuv = SvUVX(right);
2055 return (leftuv > rightuv) - (leftuv < rightuv);
2057 /* ## UV <=> IV ## */
2059 const IV rightiv = SvIVX(right);
2061 /* As (a) is a UV, it's >=0, so it cannot be < */
2064 const UV leftuv = SvUVX(left);
2065 return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
2068 assert(0); /* NOTREACHED */
2072 NV const rnv = SvNV_nomg(right);
2073 NV const lnv = SvNV_nomg(left);
2075 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2076 if (Perl_isnan(lnv) || Perl_isnan(rnv)) {
2079 return (lnv > rnv) - (lnv < rnv);
2098 tryAMAGICbin_MG(ncmp_amg, AMGf_numeric);
2101 value = do_ncmp(left, right);
2113 /* also used for: pp_sge() pp_sgt() pp_slt() */
2119 int amg_type = sle_amg;
2123 switch (PL_op->op_type) {
2142 tryAMAGICbin_MG(amg_type, AMGf_set);
2146 #ifdef USE_LOCALE_COLLATE
2147 (IN_LC_RUNTIME(LC_COLLATE))
2148 ? sv_cmp_locale_flags(left, right, 0)
2151 sv_cmp_flags(left, right, 0);
2152 SETs(boolSV(cmp * multiplier < rhs));
2160 tryAMAGICbin_MG(seq_amg, AMGf_set);
2163 SETs(boolSV(sv_eq_flags(left, right, 0)));
2171 tryAMAGICbin_MG(sne_amg, AMGf_set);
2174 SETs(boolSV(!sv_eq_flags(left, right, 0)));
2182 tryAMAGICbin_MG(scmp_amg, 0);
2186 #ifdef USE_LOCALE_COLLATE
2187 (IN_LC_RUNTIME(LC_COLLATE))
2188 ? sv_cmp_locale_flags(left, right, 0)
2191 sv_cmp_flags(left, right, 0);
2200 tryAMAGICbin_MG(band_amg, AMGf_assign);
2203 if (SvNIOKp(left) || SvNIOKp(right)) {
2204 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2205 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2206 if (PL_op->op_private & HINT_INTEGER) {
2207 const IV i = SvIV_nomg(left) & SvIV_nomg(right);
2211 const UV u = SvUV_nomg(left) & SvUV_nomg(right);
2214 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2215 if (right_ro_nonnum) SvNIOK_off(right);
2218 do_vop(PL_op->op_type, TARG, left, right);
2226 /* also used for: pp_bit_xor() */
2231 const int op_type = PL_op->op_type;
2233 tryAMAGICbin_MG((op_type == OP_BIT_OR ? bor_amg : bxor_amg), AMGf_assign);
2236 if (SvNIOKp(left) || SvNIOKp(right)) {
2237 const bool left_ro_nonnum = !SvNIOKp(left) && SvREADONLY(left);
2238 const bool right_ro_nonnum = !SvNIOKp(right) && SvREADONLY(right);
2239 if (PL_op->op_private & HINT_INTEGER) {
2240 const IV l = (USE_LEFT(left) ? SvIV_nomg(left) : 0);
2241 const IV r = SvIV_nomg(right);
2242 const IV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2246 const UV l = (USE_LEFT(left) ? SvUV_nomg(left) : 0);
2247 const UV r = SvUV_nomg(right);
2248 const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
2251 if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
2252 if (right_ro_nonnum) SvNIOK_off(right);
2255 do_vop(op_type, TARG, left, right);
2262 PERL_STATIC_INLINE bool
2263 S_negate_string(pTHX)
2268 SV * const sv = TOPs;
2269 if (!SvPOKp(sv) || SvNIOK(sv) || (!SvPOK(sv) && SvNIOKp(sv)))
2271 s = SvPV_nomg_const(sv, len);
2272 if (isIDFIRST(*s)) {
2273 sv_setpvs(TARG, "-");
2276 else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
2277 sv_setsv_nomg(TARG, sv);
2278 *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
2288 tryAMAGICun_MG(neg_amg, AMGf_numeric);
2289 if (S_negate_string(aTHX)) return NORMAL;
2291 SV * const sv = TOPs;
2294 /* It's publicly an integer */
2297 if (SvIVX(sv) == IV_MIN) {
2298 /* 2s complement assumption. */
2299 SETi(SvIVX(sv)); /* special case: -((UV)IV_MAX+1) ==
2303 else if (SvUVX(sv) <= IV_MAX) {
2308 else if (SvIVX(sv) != IV_MIN) {
2312 #ifdef PERL_PRESERVE_IVUV
2319 if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
2320 SETn(-SvNV_nomg(sv));
2321 else if (SvPOKp(sv) && SvIV_please_nomg(sv))
2322 goto oops_its_an_int;
2324 SETn(-SvNV_nomg(sv));
2332 tryAMAGICun_MG(not_amg, AMGf_set);
2333 *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
2340 tryAMAGICun_MG(compl_amg, AMGf_numeric);
2344 if (PL_op->op_private & HINT_INTEGER) {
2345 const IV i = ~SvIV_nomg(sv);
2349 const UV u = ~SvUV_nomg(sv);
2358 sv_copypv_nomg(TARG, sv);
2359 tmps = (U8*)SvPV_nomg(TARG, len);
2362 /* Calculate exact length, let's not estimate. */
2367 U8 * const send = tmps + len;
2368 U8 * const origtmps = tmps;
2369 const UV utf8flags = UTF8_ALLOW_ANYUV;
2371 while (tmps < send) {
2372 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2374 targlen += UNISKIP(~c);
2380 /* Now rewind strings and write them. */
2387 Newx(result, targlen + 1, U8);
2389 while (tmps < send) {
2390 const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2392 p = uvchr_to_utf8_flags(p, ~c, UNICODE_ALLOW_ANY);
2395 sv_usepvn_flags(TARG, (char*)result, targlen,
2396 SV_HAS_TRAILING_NUL);
2403 Newx(result, nchar + 1, U8);
2405 while (tmps < send) {
2406 const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags);
2411 sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL);
2420 for ( ; anum && (unsigned long)tmps % sizeof(long); anum--, tmps++)
2423 for ( ; anum >= (I32)sizeof(long); anum -= (I32)sizeof(long), tmpl++)
2428 for ( ; anum > 0; anum--, tmps++)
2436 /* integer versions of some of the above */
2441 tryAMAGICbin_MG(mult_amg, AMGf_assign);
2444 SETi( left * right );
2453 tryAMAGICbin_MG(div_amg, AMGf_assign);
2456 IV value = SvIV_nomg(right);
2458 DIE(aTHX_ "Illegal division by zero");
2459 num = SvIV_nomg(left);
2461 /* avoid FPE_INTOVF on some platforms when num is IV_MIN */
2465 value = num / value;
2471 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2478 /* This is the vanilla old i_modulo. */
2480 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2484 DIE(aTHX_ "Illegal modulus zero");
2485 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2489 SETi( left % right );
2494 #if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS)
2499 /* This is the i_modulo with the workaround for the _moddi3 bug
2500 * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround).
2501 * See below for pp_i_modulo. */
2503 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2507 DIE(aTHX_ "Illegal modulus zero");
2508 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2512 SETi( left % PERL_ABS(right) );
2519 dVAR; dSP; dATARGET;
2520 tryAMAGICbin_MG(modulo_amg, AMGf_assign);
2524 DIE(aTHX_ "Illegal modulus zero");
2525 /* The assumption is to use hereafter the old vanilla version... */
2527 PL_ppaddr[OP_I_MODULO] =
2529 /* .. but if we have glibc, we might have a buggy _moddi3
2530 * (at least glicb 2.2.5 is known to have this bug), in other
2531 * words our integer modulus with negative quad as the second
2532 * argument might be broken. Test for this and re-patch the
2533 * opcode dispatch table if that is the case, remembering to
2534 * also apply the workaround so that this first round works
2535 * right, too. See [perl #9402] for more information. */
2539 /* Cannot do this check with inlined IV constants since
2540 * that seems to work correctly even with the buggy glibc. */
2542 /* Yikes, we have the bug.
2543 * Patch in the workaround version. */
2545 PL_ppaddr[OP_I_MODULO] =
2546 &Perl_pp_i_modulo_1;
2547 /* Make certain we work right this time, too. */
2548 right = PERL_ABS(right);
2551 /* avoid FPE_INTOVF on some platforms when left is IV_MIN */
2555 SETi( left % right );
2564 tryAMAGICbin_MG(add_amg, AMGf_assign);
2566 dPOPTOPiirl_ul_nomg;
2567 SETi( left + right );
2575 tryAMAGICbin_MG(subtr_amg, AMGf_assign);
2577 dPOPTOPiirl_ul_nomg;
2578 SETi( left - right );
2586 tryAMAGICbin_MG(lt_amg, AMGf_set);
2589 SETs(boolSV(left < right));
2597 tryAMAGICbin_MG(gt_amg, AMGf_set);
2600 SETs(boolSV(left > right));
2608 tryAMAGICbin_MG(le_amg, AMGf_set);
2611 SETs(boolSV(left <= right));
2619 tryAMAGICbin_MG(ge_amg, AMGf_set);
2622 SETs(boolSV(left >= right));
2630 tryAMAGICbin_MG(eq_amg, AMGf_set);
2633 SETs(boolSV(left == right));
2641 tryAMAGICbin_MG(ne_amg, AMGf_set);
2644 SETs(boolSV(left != right));
2652 tryAMAGICbin_MG(ncmp_amg, 0);
2659 else if (left < right)
2671 tryAMAGICun_MG(neg_amg, 0);
2672 if (S_negate_string(aTHX)) return NORMAL;
2674 SV * const sv = TOPs;
2675 IV const i = SvIV_nomg(sv);
2681 /* High falutin' math. */
2686 tryAMAGICbin_MG(atan2_amg, 0);
2689 SETn(Perl_atan2(left, right));
2695 /* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */
2700 int amg_type = fallback_amg;
2701 const char *neg_report = NULL;
2702 const int op_type = PL_op->op_type;
2705 case OP_SIN: amg_type = sin_amg; break;
2706 case OP_COS: amg_type = cos_amg; break;
2707 case OP_EXP: amg_type = exp_amg; break;
2708 case OP_LOG: amg_type = log_amg; neg_report = "log"; break;
2709 case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break;
2712 assert(amg_type != fallback_amg);
2714 tryAMAGICun_MG(amg_type, 0);
2716 SV * const arg = POPs;
2717 const NV value = SvNV_nomg(arg);
2719 if (neg_report) { /* log or sqrt */
2721 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2722 ! Perl_isnan(value) &&
2724 (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0))) {
2725 SET_NUMERIC_STANDARD();
2726 /* diag_listed_as: Can't take log of %g */
2727 DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
2732 case OP_SIN: result = Perl_sin(value); break;
2733 case OP_COS: result = Perl_cos(value); break;
2734 case OP_EXP: result = Perl_exp(value); break;
2735 case OP_LOG: result = Perl_log(value); break;
2736 case OP_SQRT: result = Perl_sqrt(value); break;
2743 /* Support Configure command-line overrides for rand() functions.
2744 After 5.005, perhaps we should replace this by Configure support
2745 for drand48(), random(), or rand(). For 5.005, though, maintain
2746 compatibility by calling rand() but allow the user to override it.
2747 See INSTALL for details. --Andy Dougherty 15 July 1998
2749 /* Now it's after 5.005, and Configure supports drand48() and random(),
2750 in addition to rand(). So the overrides should not be needed any more.
2751 --Jarkko Hietaniemi 27 September 1998
2756 if (!PL_srand_called) {
2757 (void)seedDrand01((Rand_seed_t)seed());
2758 PL_srand_called = TRUE;
2768 SV * const sv = POPs;
2774 /* 1 of 2 things can be carried through SvNV, SP or TARG, SP was carried */
2775 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2776 if (! Perl_isnan(value) && value == 0.0)
2786 sv_setnv_mg(TARG, value);
2797 if (MAXARG >= 1 && (TOPs || POPs)) {
2804 pv = SvPV(top, len);
2805 flags = grok_number(pv, len, &anum);
2807 if (!(flags & IS_NUMBER_IN_UV)) {
2808 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
2809 "Integer overflow in srand");
2817 (void)seedDrand01((Rand_seed_t)anum);
2818 PL_srand_called = TRUE;
2822 /* Historically srand always returned true. We can avoid breaking
2824 sv_setpvs(TARG, "0 but true");
2833 tryAMAGICun_MG(int_amg, AMGf_numeric);
2835 SV * const sv = TOPs;
2836 const IV iv = SvIV_nomg(sv);
2837 /* XXX it's arguable that compiler casting to IV might be subtly
2838 different from modf (for numbers inside (IV_MIN,UV_MAX)) in which
2839 else preferring IV has introduced a subtle behaviour change bug. OTOH
2840 relying on floating point to be accurate is a bug. */
2845 else if (SvIOK(sv)) {
2847 SETu(SvUV_nomg(sv));
2852 const NV value = SvNV_nomg(sv);
2853 if (SvNOK(sv) && UNLIKELY(Perl_isinfnan(SvNV(sv))))
2855 else if (value >= 0.0) {
2856 if (value < (NV)UV_MAX + 0.5) {
2859 SETn(Perl_floor(value));
2863 if (value > (NV)IV_MIN - 0.5) {
2866 SETn(Perl_ceil(value));
2877 tryAMAGICun_MG(abs_amg, AMGf_numeric);
2879 SV * const sv = TOPs;
2880 /* This will cache the NV value if string isn't actually integer */
2881 const IV iv = SvIV_nomg(sv);
2886 else if (SvIOK(sv)) {
2887 /* IVX is precise */
2889 SETu(SvUV_nomg(sv)); /* force it to be numeric only */
2897 /* 2s complement assumption. Also, not really needed as
2898 IV_MIN and -IV_MIN should both be %100...00 and NV-able */
2904 const NV value = SvNV_nomg(sv);
2915 /* also used for: pp_hex() */
2921 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES;
2925 SV* const sv = POPs;
2927 tmps = (SvPV_const(sv, len));
2929 /* If Unicode, try to downgrade
2930 * If not possible, croak. */
2931 SV* const tsv = sv_2mortal(newSVsv(sv));
2934 sv_utf8_downgrade(tsv, FALSE);
2935 tmps = SvPV_const(tsv, len);
2937 if (PL_op->op_type == OP_HEX)
2940 while (*tmps && len && isSPACE(*tmps))
2944 if (isALPHA_FOLD_EQ(*tmps, 'x')) {
2946 result_uv = grok_hex (tmps, &len, &flags, &result_nv);
2948 else if (isALPHA_FOLD_EQ(*tmps, 'b'))
2949 result_uv = grok_bin (tmps, &len, &flags, &result_nv);
2951 result_uv = grok_oct (tmps, &len, &flags, &result_nv);
2953 if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
2967 SV * const sv = TOPs;
2969 U32 in_bytes = IN_BYTES;
2970 /* simplest case shortcut */
2971 /* turn off SVf_UTF8 in tmp flags if HINT_BYTES on*/
2972 U32 svflags = (SvFLAGS(sv) ^ (in_bytes << 26)) & (SVf_POK|SVs_GMG|SVf_UTF8);
2973 assert(HINT_BYTES == 0x00000008 && SVf_UTF8 == 0x20000000 && (SVf_UTF8 == HINT_BYTES << 26));
2976 if(LIKELY(svflags == SVf_POK))
2978 if(svflags & SVs_GMG)
2981 if (!IN_BYTES) /* reread to avoid using an C auto/register */
2982 sv_setiv(TARG, (IV)sv_len_utf8_nomg(sv));
2986 /* unrolled SvPV_nomg_const(sv,len) */
2991 (void)sv_2pv_flags(sv, &len, 0|SV_CONST_RETURN);
2993 sv_setiv(TARG, (IV)(len));
2996 if (!SvPADTMP(TARG)) {
2997 sv_setsv_nomg(TARG, &PL_sv_undef);
2998 } else { /* TARG is on stack at this point and is overwriten by SETs.
2999 This branch is the odd one out, so put TARG by default on
3000 stack earlier to let local SP go out of liveness sooner */
3007 return NORMAL; /* no putback, SP didn't move in this opcode */
3010 /* Returns false if substring is completely outside original string.
3011 No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
3012 always be true for an explicit 0.
3015 Perl_translate_substr_offsets( STRLEN curlen, IV pos1_iv,
3016 bool pos1_is_uv, IV len_iv,
3017 bool len_is_uv, STRLEN *posp,
3023 PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
3025 if (!pos1_is_uv && pos1_iv < 0 && curlen) {
3026 pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
3029 if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
3032 if (len_iv || len_is_uv) {
3033 if (!len_is_uv && len_iv < 0) {
3034 pos2_iv = curlen + len_iv;
3036 pos2_is_uv = curlen-1 > ~(UV)len_iv;
3039 } else { /* len_iv >= 0 */
3040 if (!pos1_is_uv && pos1_iv < 0) {
3041 pos2_iv = pos1_iv + len_iv;
3042 pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
3044 if ((UV)len_iv > curlen-(UV)pos1_iv)
3047 pos2_iv = pos1_iv+len_iv;
3057 if (!pos2_is_uv && pos2_iv < 0) {
3058 if (!pos1_is_uv && pos1_iv < 0)
3062 else if (!pos1_is_uv && pos1_iv < 0)
3065 if ((UV)pos2_iv < (UV)pos1_iv)
3067 if ((UV)pos2_iv > curlen)
3070 /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
3071 *posp = (STRLEN)( (UV)pos1_iv );
3072 *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
3089 I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3090 const bool rvalue = (GIMME_V != G_VOID);
3093 const char *repl = NULL;
3095 int num_args = PL_op->op_private & 7;
3096 bool repl_need_utf8_upgrade = FALSE;
3100 if(!(repl_sv = POPs)) num_args--;
3102 if ((len_sv = POPs)) {
3103 len_iv = SvIV(len_sv);
3104 len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
3109 pos1_iv = SvIV(pos_sv);
3110 pos1_is_uv = SvIOK_UV(pos_sv);
3112 if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
3117 if (lvalue && !repl_sv) {
3119 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3120 sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
3122 LvTARG(ret) = SvREFCNT_inc_simple(sv);
3124 pos1_is_uv || pos1_iv >= 0
3125 ? (STRLEN)(UV)pos1_iv
3126 : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
3128 len_is_uv || len_iv > 0
3129 ? (STRLEN)(UV)len_iv
3130 : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
3133 PUSHs(ret); /* avoid SvSETMAGIC here */
3137 repl = SvPV_const(repl_sv, repl_len);
3140 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
3141 "Attempt to use reference as lvalue in substr"
3143 tmps = SvPV_force_nomg(sv, curlen);
3144 if (DO_UTF8(repl_sv) && repl_len) {
3146 sv_utf8_upgrade_nomg(sv);
3150 else if (DO_UTF8(sv))
3151 repl_need_utf8_upgrade = TRUE;
3153 else tmps = SvPV_const(sv, curlen);
3155 utf8_curlen = sv_or_pv_len_utf8(sv, tmps, curlen);
3156 if (utf8_curlen == curlen)
3159 curlen = utf8_curlen;
3165 STRLEN pos, len, byte_len, byte_pos;
3167 if (!translate_substr_offsets(
3168 curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
3172 byte_pos = utf8_curlen
3173 ? sv_or_pv_pos_u2b(sv, tmps, pos, &byte_len) : pos;
3178 SvTAINTED_off(TARG); /* decontaminate */
3179 SvUTF8_off(TARG); /* decontaminate */
3180 sv_setpvn(TARG, tmps, byte_len);
3181 #ifdef USE_LOCALE_COLLATE
3182 sv_unmagic(TARG, PERL_MAGIC_collxfrm);
3189 SV* repl_sv_copy = NULL;
3191 if (repl_need_utf8_upgrade) {
3192 repl_sv_copy = newSVsv(repl_sv);
3193 sv_utf8_upgrade(repl_sv_copy);
3194 repl = SvPV_const(repl_sv_copy, repl_len);
3198 sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
3199 SvREFCNT_dec(repl_sv_copy);
3211 Perl_croak(aTHX_ "substr outside of string");
3212 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
3219 const IV size = POPi;
3220 const IV offset = POPi;
3221 SV * const src = POPs;
3222 const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
3225 if (lvalue) { /* it's an lvalue! */
3226 ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
3227 sv_magic(ret, NULL, PERL_MAGIC_vec, NULL, 0);
3229 LvTARG(ret) = SvREFCNT_inc_simple(src);
3230 LvTARGOFF(ret) = offset;
3231 LvTARGLEN(ret) = size;
3235 SvTAINTED_off(TARG); /* decontaminate */
3239 sv_setuv(ret, do_vecget(src, offset, size));
3245 /* also used for: pp_rindex() */
3258 const char *little_p;
3261 const bool is_index = PL_op->op_type == OP_INDEX;
3262 const bool threeargs = MAXARG >= 3 && (TOPs || ((void)POPs,0));
3268 big_p = SvPV_const(big, biglen);
3269 little_p = SvPV_const(little, llen);
3271 big_utf8 = DO_UTF8(big);
3272 little_utf8 = DO_UTF8(little);
3273 if (big_utf8 ^ little_utf8) {
3274 /* One needs to be upgraded. */
3275 if (little_utf8 && !PL_encoding) {
3276 /* Well, maybe instead we might be able to downgrade the small
3278 char * const pv = (char*)bytes_from_utf8((U8 *)little_p, &llen,
3281 /* If the large string is ISO-8859-1, and it's not possible to
3282 convert the small string to ISO-8859-1, then there is no
3283 way that it could be found anywhere by index. */
3288 /* At this point, pv is a malloc()ed string. So donate it to temp
3289 to ensure it will get free()d */
3290 little = temp = newSV(0);
3291 sv_usepvn(temp, pv, llen);
3292 little_p = SvPVX(little);
3295 ? newSVpvn(big_p, biglen) : newSVpvn(little_p, llen);
3298 sv_recode_to_utf8(temp, PL_encoding);
3300 sv_utf8_upgrade(temp);
3305 big_p = SvPV_const(big, biglen);
3308 little_p = SvPV_const(little, llen);
3312 if (SvGAMAGIC(big)) {
3313 /* Life just becomes a lot easier if I use a temporary here.
3314 Otherwise I need to avoid calls to sv_pos_u2b(), which (dangerously)
3315 will trigger magic and overloading again, as will fbm_instr()
3317 big = newSVpvn_flags(big_p, biglen,
3318 SVs_TEMP | (big_utf8 ? SVf_UTF8 : 0));
3321 if (SvGAMAGIC(little) || (is_index && !SvOK(little))) {
3322 /* index && SvOK() is a hack. fbm_instr() calls SvPV_const, which will
3323 warn on undef, and we've already triggered a warning with the
3324 SvPV_const some lines above. We can't remove that, as we need to
3325 call some SvPV to trigger overloading early and find out if the
3327 This is all getting to messy. The API isn't quite clean enough,
3328 because data access has side effects.
3330 little = newSVpvn_flags(little_p, llen,
3331 SVs_TEMP | (little_utf8 ? SVf_UTF8 : 0));
3332 little_p = SvPVX(little);
3336 offset = is_index ? 0 : biglen;
3338 if (big_utf8 && offset > 0)
3339 offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
3345 else if (offset > (SSize_t)biglen)
3347 if (!(little_p = is_index
3348 ? fbm_instr((unsigned char*)big_p + offset,
3349 (unsigned char*)big_p + biglen, little, 0)
3350 : rninstr(big_p, big_p + offset,
3351 little_p, little_p + llen)))
3354 retval = little_p - big_p;
3355 if (retval > 0 && big_utf8)
3356 retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
3366 dSP; dMARK; dORIGMARK; dTARGET;
3367 SvTAINTED_off(TARG);
3368 do_sprintf(TARG, SP-MARK, MARK+1);
3369 TAINT_IF(SvTAINTED(TARG));
3381 const U8 *s = (U8*)SvPV_const(argsv, len);
3383 if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
3384 SV * const tmpsv = sv_2mortal(newSVsv(argsv));
3385 s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
3386 len = UTF8SKIP(s); /* Should be well-formed; so this is its length */
3390 XPUSHu(DO_UTF8(argsv)
3391 ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
3405 if (UNLIKELY(isinfnansv(top)))
3406 Perl_croak(aTHX_ "Cannot chr %"NVgf, SvNV(top));
3408 if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */
3409 && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0)
3411 ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top)))
3412 && SvNV_nomg(top) < 0.0))) {
3413 if (ckWARN(WARN_UTF8)) {
3414 if (SvGMAGICAL(top)) {
3415 SV *top2 = sv_newmortal();
3416 sv_setsv_nomg(top2, top);
3419 Perl_warner(aTHX_ packWARN(WARN_UTF8),
3420 "Invalid negative number (%"SVf") in chr", SVfARG(top));
3422 value = UNICODE_REPLACEMENT;
3424 value = SvUV_nomg(top);
3428 SvUPGRADE(TARG,SVt_PV);
3430 if (value > 255 && !IN_BYTES) {
3431 SvGROW(TARG, (STRLEN)UNISKIP(value)+1);
3432 tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value, 0);
3433 SvCUR_set(TARG, tmps - SvPVX_const(TARG));
3435 (void)SvPOK_only(TARG);
3444 *tmps++ = (char)value;
3446 (void)SvPOK_only(TARG);
3448 if (PL_encoding && !IN_BYTES) {
3449 sv_recode_to_utf8(TARG, PL_encoding);
3451 if (SvCUR(TARG) == 0
3452 || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
3453 || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
3458 *tmps++ = (char)value;
3474 const char *tmps = SvPV_const(left, len);
3476 if (DO_UTF8(left)) {
3477 /* If Unicode, try to downgrade.
3478 * If not possible, croak.
3479 * Yes, we made this up. */
3480 SV* const tsv = sv_2mortal(newSVsv(left));
3483 sv_utf8_downgrade(tsv, FALSE);
3484 tmps = SvPV_const(tsv, len);
3486 # ifdef USE_ITHREADS
3488 if (!PL_reentrant_buffer->_crypt_struct_buffer) {
3489 /* This should be threadsafe because in ithreads there is only
3490 * one thread per interpreter. If this would not be true,
3491 * we would need a mutex to protect this malloc. */
3492 PL_reentrant_buffer->_crypt_struct_buffer =
3493 (struct crypt_data *)safemalloc(sizeof(struct crypt_data));
3494 #if defined(__GLIBC__) || defined(__EMX__)
3495 if (PL_reentrant_buffer->_crypt_struct_buffer) {
3496 PL_reentrant_buffer->_crypt_struct_buffer->initialized = 0;
3497 /* work around glibc-2.2.5 bug */
3498 PL_reentrant_buffer->_crypt_struct_buffer->current_saltbits = 0;
3502 # endif /* HAS_CRYPT_R */
3503 # endif /* USE_ITHREADS */
3505 sv_setpv(TARG, fcrypt(tmps, SvPV_nolen_const(right)));
3507 sv_setpv(TARG, PerlProc_crypt(tmps, SvPV_nolen_const(right)));
3513 "The crypt() function is unimplemented due to excessive paranoia.");
3517 /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
3518 * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
3521 /* also used for: pp_lcfirst() */
3525 /* Actually is both lcfirst() and ucfirst(). Only the first character
3526 * changes. This means that possibly we can change in-place, ie., just
3527 * take the source and change that one character and store it back, but not
3528 * if read-only etc, or if the length changes */
3532 STRLEN slen; /* slen is the byte length of the whole SV. */
3535 bool inplace; /* ? Convert first char only, in-place */
3536 bool doing_utf8 = FALSE; /* ? using utf8 */
3537 bool convert_source_to_utf8 = FALSE; /* ? need to convert */
3538 const int op_type = PL_op->op_type;
3541 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3542 STRLEN ulen; /* ulen is the byte length of the original Unicode character
3543 * stored as UTF-8 at s. */
3544 STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
3545 * lowercased) character stored in tmpbuf. May be either
3546 * UTF-8 or not, but in either case is the number of bytes */
3548 s = (const U8*)SvPV_const(source, slen);
3550 /* We may be able to get away with changing only the first character, in
3551 * place, but not if read-only, etc. Later we may discover more reasons to
3552 * not convert in-place. */
3553 inplace = !SvREADONLY(source)
3554 && ( SvPADTMP(source)
3555 || ( SvTEMP(source) && !SvSMAGICAL(source)
3556 && SvREFCNT(source) == 1));
3558 /* First calculate what the changed first character should be. This affects
3559 * whether we can just swap it out, leaving the rest of the string unchanged,
3560 * or even if have to convert the dest to UTF-8 when the source isn't */
3562 if (! slen) { /* If empty */
3563 need = 1; /* still need a trailing NUL */
3566 else if (DO_UTF8(source)) { /* Is the source utf8? */
3569 if (op_type == OP_UCFIRST) {
3570 #ifdef USE_LOCALE_CTYPE
3571 _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3573 _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
3577 #ifdef USE_LOCALE_CTYPE
3578 _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
3580 _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
3584 /* we can't do in-place if the length changes. */
3585 if (ulen != tculen) inplace = FALSE;
3586 need = slen + 1 - ulen + tculen;
3588 else { /* Non-zero length, non-UTF-8, Need to consider locale and if
3589 * latin1 is treated as caseless. Note that a locale takes
3591 ulen = 1; /* Original character is 1 byte */
3592 tculen = 1; /* Most characters will require one byte, but this will
3593 * need to be overridden for the tricky ones */
3596 if (op_type == OP_LCFIRST) {
3598 /* lower case the first letter: no trickiness for any character */
3600 #ifdef USE_LOCALE_CTYPE
3601 (IN_LC_RUNTIME(LC_CTYPE))
3606 ? toLOWER_LATIN1(*s)
3610 #ifdef USE_LOCALE_CTYPE
3611 else if (IN_LC_RUNTIME(LC_CTYPE)) {
3612 if (IN_UTF8_CTYPE_LOCALE) {
3616 *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
3617 locales have upper and title case
3621 else if (! IN_UNI_8_BIT) {
3622 *tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
3623 * on EBCDIC machines whatever the
3624 * native function does */
3627 /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
3628 * UTF-8, which we treat as not in locale), and cased latin1 */
3630 #ifdef USE_LOCALE_CTYPE
3634 title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
3636 assert(tculen == 2);
3638 /* If the result is an upper Latin1-range character, it can
3639 * still be represented in one byte, which is its ordinal */
3640 if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
3641 *tmpbuf = (U8) title_ord;
3645 /* Otherwise it became more than one ASCII character (in
3646 * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
3647 * beyond Latin1, so the number of bytes changed, so can't
3648 * replace just the first character in place. */
3651 /* If the result won't fit in a byte, the entire result
3652 * will have to be in UTF-8. Assume worst case sizing in
3653 * conversion. (all latin1 characters occupy at most two
3655 if (title_ord > 255) {
3657 convert_source_to_utf8 = TRUE;
3658 need = slen * 2 + 1;
3660 /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
3661 * (both) characters whose title case is above 255 is
3665 else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
3666 need = slen + 1 + 1;
3670 } /* End of use Unicode (Latin1) semantics */
3671 } /* End of changing the case of the first character */
3673 /* Here, have the first character's changed case stored in tmpbuf. Ready to
3674 * generate the result */
3677 /* We can convert in place. This means we change just the first
3678 * character without disturbing the rest; no need to grow */
3680 s = d = (U8*)SvPV_force_nomg(source, slen);
3686 /* Here, we can't convert in place; we earlier calculated how much
3687 * space we will need, so grow to accommodate that */
3688 SvUPGRADE(dest, SVt_PV);
3689 d = (U8*)SvGROW(dest, need);
3690 (void)SvPOK_only(dest);
3697 if (! convert_source_to_utf8) {
3699 /* Here both source and dest are in UTF-8, but have to create
3700 * the entire output. We initialize the result to be the
3701 * title/lower cased first character, and then append the rest
3703 sv_setpvn(dest, (char*)tmpbuf, tculen);
3705 sv_catpvn(dest, (char*)(s + ulen), slen - ulen);
3709 const U8 *const send = s + slen;
3711 /* Here the dest needs to be in UTF-8, but the source isn't,
3712 * except we earlier UTF-8'd the first character of the source
3713 * into tmpbuf. First put that into dest, and then append the
3714 * rest of the source, converting it to UTF-8 as we go. */
3716 /* Assert tculen is 2 here because the only two characters that
3717 * get to this part of the code have 2-byte UTF-8 equivalents */
3719 *d++ = *(tmpbuf + 1);
3720 s++; /* We have just processed the 1st char */
3722 for (; s < send; s++) {
3723 d = uvchr_to_utf8(d, *s);
3726 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3730 else { /* in-place UTF-8. Just overwrite the first character */
3731 Copy(tmpbuf, d, tculen, U8);
3732 SvCUR_set(dest, need - 1);
3736 else { /* Neither source nor dest are in or need to be UTF-8 */
3738 if (inplace) { /* in-place, only need to change the 1st char */
3741 else { /* Not in-place */
3743 /* Copy the case-changed character(s) from tmpbuf */
3744 Copy(tmpbuf, d, tculen, U8);
3745 d += tculen - 1; /* Code below expects d to point to final
3746 * character stored */
3749 else { /* empty source */
3750 /* See bug #39028: Don't taint if empty */
3754 /* In a "use bytes" we don't treat the source as UTF-8, but, still want
3755 * the destination to retain that flag */
3756 if (SvUTF8(source) && ! IN_BYTES)
3759 if (!inplace) { /* Finish the rest of the string, unchanged */
3760 /* This will copy the trailing NUL */
3761 Copy(s + 1, d + 1, slen, U8);
3762 SvCUR_set(dest, need - 1);
3765 #ifdef USE_LOCALE_CTYPE
3766 if (IN_LC_RUNTIME(LC_CTYPE)) {
3771 if (dest != source && SvTAINTED(source))
3777 /* There's so much setup/teardown code common between uc and lc, I wonder if
3778 it would be worth merging the two, and just having a switch outside each
3779 of the three tight loops. There is less and less commonality though */
3792 if ((SvPADTMP(source)
3794 (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1))
3795 && !SvREADONLY(source) && SvPOK(source)
3798 #ifdef USE_LOCALE_CTYPE
3799 (IN_LC_RUNTIME(LC_CTYPE))
3800 ? ! IN_UTF8_CTYPE_LOCALE
3806 /* We can convert in place. The reason we can't if in UNI_8_BIT is to
3807 * make the loop tight, so we overwrite the source with the dest before
3808 * looking at it, and we need to look at the original source
3809 * afterwards. There would also need to be code added to handle
3810 * switching to not in-place in midstream if we run into characters
3811 * that change the length. Since being in locale overrides UNI_8_BIT,
3812 * that latter becomes irrelevant in the above test; instead for
3813 * locale, the size can't normally change, except if the locale is a
3816 s = d = (U8*)SvPV_force_nomg(source, len);
3823 s = (const U8*)SvPV_nomg_const(source, len);
3826 SvUPGRADE(dest, SVt_PV);
3827 d = (U8*)SvGROW(dest, min);
3828 (void)SvPOK_only(dest);
3833 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
3834 to check DO_UTF8 again here. */
3836 if (DO_UTF8(source)) {
3837 const U8 *const send = s + len;
3838 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
3840 /* All occurrences of these are to be moved to follow any other marks.
3841 * This is context-dependent. We may not be passed enough context to
3842 * move the iota subscript beyond all of them, but we do the best we can
3843 * with what we're given. The result is always better than if we
3844 * hadn't done this. And, the problem would only arise if we are
3845 * passed a character without all its combining marks, which would be
3846 * the caller's mistake. The information this is based on comes from a
3847 * comment in Unicode SpecialCasing.txt, (and the Standard's text
3848 * itself) and so can't be checked properly to see if it ever gets
3849 * revised. But the likelihood of it changing is remote */
3850 bool in_iota_subscript = FALSE;
3856 if (in_iota_subscript && ! _is_utf8_mark(s)) {
3858 /* A non-mark. Time to output the iota subscript */
3859 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3860 d += capital_iota_len;
3861 in_iota_subscript = FALSE;
3864 /* Then handle the current character. Get the changed case value
3865 * and copy it to the output buffer */
3868 #ifdef USE_LOCALE_CTYPE
3869 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
3871 uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
3873 #define GREEK_CAPITAL_LETTER_IOTA 0x0399
3874 #define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
3875 if (uv == GREEK_CAPITAL_LETTER_IOTA
3876 && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
3878 in_iota_subscript = TRUE;
3881 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
3882 /* If the eventually required minimum size outgrows the
3883 * available space, we need to grow. */
3884 const UV o = d - (U8*)SvPVX_const(dest);
3886 /* If someone uppercases one million U+03B0s we SvGROW()
3887 * one million times. Or we could try guessing how much to
3888 * allocate without allocating too much. Such is life.
3889 * See corresponding comment in lc code for another option
3892 d = (U8*)SvPVX(dest) + o;
3894 Copy(tmpbuf, d, ulen, U8);
3899 if (in_iota_subscript) {
3900 Copy(GREEK_CAPITAL_LETTER_IOTA_UTF8, d, capital_iota_len, U8);
3901 d += capital_iota_len;
3906 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
3908 else { /* Not UTF-8 */
3910 const U8 *const send = s + len;
3912 /* Use locale casing if in locale; regular style if not treating
3913 * latin1 as having case; otherwise the latin1 casing. Do the
3914 * whole thing in a tight loop, for speed, */
3915 #ifdef USE_LOCALE_CTYPE
3916 if (IN_LC_RUNTIME(LC_CTYPE)) {
3917 if (IN_UTF8_CTYPE_LOCALE) {
3920 for (; s < send; d++, s++)
3921 *d = (U8) toUPPER_LC(*s);
3925 if (! IN_UNI_8_BIT) {
3926 for (; s < send; d++, s++) {
3931 #ifdef USE_LOCALE_CTYPE
3934 for (; s < send; d++, s++) {
3935 *d = toUPPER_LATIN1_MOD(*s);
3936 if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3940 /* The mainstream case is the tight loop above. To avoid
3941 * extra tests in that, all three characters that require
3942 * special handling are mapped by the MOD to the one tested
3944 * Use the source to distinguish between the three cases */
3946 if (*s == LATIN_SMALL_LETTER_SHARP_S) {
3948 /* uc() of this requires 2 characters, but they are
3949 * ASCII. If not enough room, grow the string */
3950 if (SvLEN(dest) < ++min) {
3951 const UV o = d - (U8*)SvPVX_const(dest);
3953 d = (U8*)SvPVX(dest) + o;
3955 *d++ = 'S'; *d = 'S'; /* upper case is 'SS' */
3956 continue; /* Back to the tight loop; still in ASCII */
3959 /* The other two special handling characters have their
3960 * upper cases outside the latin1 range, hence need to be
3961 * in UTF-8, so the whole result needs to be in UTF-8. So,
3962 * here we are somewhere in the middle of processing a
3963 * non-UTF-8 string, and realize that we will have to convert
3964 * the whole thing to UTF-8. What to do? There are
3965 * several possibilities. The simplest to code is to
3966 * convert what we have so far, set a flag, and continue on
3967 * in the loop. The flag would be tested each time through
3968 * the loop, and if set, the next character would be
3969 * converted to UTF-8 and stored. But, I (khw) didn't want
3970 * to slow down the mainstream case at all for this fairly
3971 * rare case, so I didn't want to add a test that didn't
3972 * absolutely have to be there in the loop, besides the
3973 * possibility that it would get too complicated for
3974 * optimizers to deal with. Another possibility is to just
3975 * give up, convert the source to UTF-8, and restart the
3976 * function that way. Another possibility is to convert
3977 * both what has already been processed and what is yet to
3978 * come separately to UTF-8, then jump into the loop that
3979 * handles UTF-8. But the most efficient time-wise of the
3980 * ones I could think of is what follows, and turned out to
3981 * not require much extra code. */
3983 /* Convert what we have so far into UTF-8, telling the
3984 * function that we know it should be converted, and to
3985 * allow extra space for what we haven't processed yet.
3986 * Assume the worst case space requirements for converting
3987 * what we haven't processed so far: that it will require
3988 * two bytes for each remaining source character, plus the
3989 * NUL at the end. This may cause the string pointer to
3990 * move, so re-find it. */
3992 len = d - (U8*)SvPVX_const(dest);
3993 SvCUR_set(dest, len);
3994 len = sv_utf8_upgrade_flags_grow(dest,
3995 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3997 d = (U8*)SvPVX(dest) + len;
3999 /* Now process the remainder of the source, converting to
4000 * upper and UTF-8. If a resulting byte is invariant in
4001 * UTF-8, output it as-is, otherwise convert to UTF-8 and
4002 * append it to the output. */
4003 for (; s < send; s++) {
4004 (void) _to_upper_title_latin1(*s, d, &len, 'S');
4008 /* Here have processed the whole source; no need to continue
4009 * with the outer loop. Each character has been converted
4010 * to upper case and converted to UTF-8 */
4013 } /* End of processing all latin1-style chars */
4014 } /* End of processing all chars */
4015 } /* End of source is not empty */
4017 if (source != dest) {
4018 *d = '\0'; /* Here d points to 1 after last char, add NUL */
4019 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4021 } /* End of isn't utf8 */
4022 #ifdef USE_LOCALE_CTYPE
4023 if (IN_LC_RUNTIME(LC_CTYPE)) {
4028 if (dest != source && SvTAINTED(source))
4046 if ( ( SvPADTMP(source)
4047 || ( SvTEMP(source) && !SvSMAGICAL(source)
4048 && SvREFCNT(source) == 1 )
4050 && !SvREADONLY(source) && SvPOK(source)
4051 && !DO_UTF8(source)) {
4053 /* We can convert in place, as lowercasing anything in the latin1 range
4054 * (or else DO_UTF8 would have been on) doesn't lengthen it */
4056 s = d = (U8*)SvPV_force_nomg(source, len);
4063 s = (const U8*)SvPV_nomg_const(source, len);
4066 SvUPGRADE(dest, SVt_PV);
4067 d = (U8*)SvGROW(dest, min);
4068 (void)SvPOK_only(dest);
4073 /* Overloaded values may have toggled the UTF-8 flag on source, so we need
4074 to check DO_UTF8 again here. */
4076 if (DO_UTF8(source)) {
4077 const U8 *const send = s + len;
4078 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4081 const STRLEN u = UTF8SKIP(s);
4084 #ifdef USE_LOCALE_CTYPE
4085 _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
4087 _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
4090 /* Here is where we would do context-sensitive actions. See the
4091 * commit message for 86510fb15 for why there isn't any */
4093 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4095 /* If the eventually required minimum size outgrows the
4096 * available space, we need to grow. */
4097 const UV o = d - (U8*)SvPVX_const(dest);
4099 /* If someone lowercases one million U+0130s we SvGROW() one
4100 * million times. Or we could try guessing how much to
4101 * allocate without allocating too much. Such is life.
4102 * Another option would be to grow an extra byte or two more
4103 * each time we need to grow, which would cut down the million
4104 * to 500K, with little waste */
4106 d = (U8*)SvPVX(dest) + o;
4109 /* Copy the newly lowercased letter to the output buffer we're
4111 Copy(tmpbuf, d, ulen, U8);
4114 } /* End of looping through the source string */
4117 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4118 } else { /* Not utf8 */
4120 const U8 *const send = s + len;
4122 /* Use locale casing if in locale; regular style if not treating
4123 * latin1 as having case; otherwise the latin1 casing. Do the
4124 * whole thing in a tight loop, for speed, */
4125 #ifdef USE_LOCALE_CTYPE
4126 if (IN_LC_RUNTIME(LC_CTYPE)) {
4127 for (; s < send; d++, s++)
4128 *d = toLOWER_LC(*s);
4132 if (! IN_UNI_8_BIT) {
4133 for (; s < send; d++, s++) {
4138 for (; s < send; d++, s++) {
4139 *d = toLOWER_LATIN1(*s);
4143 if (source != dest) {
4145 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4148 #ifdef USE_LOCALE_CTYPE
4149 if (IN_LC_RUNTIME(LC_CTYPE)) {
4154 if (dest != source && SvTAINTED(source))
4163 SV * const sv = TOPs;
4165 const char *s = SvPV_const(sv,len);
4167 SvUTF8_off(TARG); /* decontaminate */
4170 SvUPGRADE(TARG, SVt_PV);
4171 SvGROW(TARG, (len * 2) + 1);
4175 STRLEN ulen = UTF8SKIP(s);
4176 bool to_quote = FALSE;
4178 if (UTF8_IS_INVARIANT(*s)) {
4179 if (_isQUOTEMETA(*s)) {
4183 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
4185 #ifdef USE_LOCALE_CTYPE
4186 /* In locale, we quote all non-ASCII Latin1 chars.
4187 * Otherwise use the quoting rules */
4189 IN_LC_RUNTIME(LC_CTYPE)
4192 _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1))))
4197 else if (is_QUOTEMETA_high(s)) {
4212 else if (IN_UNI_8_BIT) {
4214 if (_isQUOTEMETA(*s))
4220 /* For non UNI_8_BIT (and hence in locale) just quote all \W
4221 * including everything above ASCII */
4223 if (!isWORDCHAR_A(*s))
4229 SvCUR_set(TARG, d - SvPVX_const(TARG));
4230 (void)SvPOK_only_UTF8(TARG);
4233 sv_setpvn(TARG, s, len);
4249 U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
4250 const bool full_folding = TRUE; /* This variable is here so we can easily
4251 move to more generality later */
4252 const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
4253 #ifdef USE_LOCALE_CTYPE
4254 | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
4258 /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
4259 * You are welcome(?) -Hugmeir
4267 s = (const U8*)SvPV_nomg_const(source, len);
4269 if (ckWARN(WARN_UNINITIALIZED))
4270 report_uninit(source);
4277 SvUPGRADE(dest, SVt_PV);
4278 d = (U8*)SvGROW(dest, min);
4279 (void)SvPOK_only(dest);
4284 if (DO_UTF8(source)) { /* UTF-8 flagged string. */
4286 const STRLEN u = UTF8SKIP(s);
4289 _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
4291 if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
4292 const UV o = d - (U8*)SvPVX_const(dest);
4294 d = (U8*)SvPVX(dest) + o;
4297 Copy(tmpbuf, d, ulen, U8);
4302 } /* Unflagged string */
4304 #ifdef USE_LOCALE_CTYPE
4305 if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
4306 if (IN_UTF8_CTYPE_LOCALE) {
4307 goto do_uni_folding;
4309 for (; s < send; d++, s++)
4310 *d = (U8) toFOLD_LC(*s);
4314 if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
4315 for (; s < send; d++, s++)
4319 #ifdef USE_LOCALE_CTYPE
4322 /* For ASCII and the Latin-1 range, there's only two troublesome
4323 * folds, \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full
4324 * casefolding becomes 'ss'; and \x{B5} (\N{MICRO SIGN}), which
4325 * under any fold becomes \x{3BC} (\N{GREEK SMALL LETTER MU}) --
4326 * For the rest, the casefold is their lowercase. */
4327 for (; s < send; d++, s++) {
4328 if (*s == MICRO_SIGN) {
4329 /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU},
4330 * which is outside of the latin-1 range. There's a couple
4331 * of ways to deal with this -- khw discusses them in
4332 * pp_lc/uc, so go there :) What we do here is upgrade what
4333 * we had already casefolded, then enter an inner loop that
4334 * appends the rest of the characters as UTF-8. */
4335 len = d - (U8*)SvPVX_const(dest);
4336 SvCUR_set(dest, len);
4337 len = sv_utf8_upgrade_flags_grow(dest,
4338 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4339 /* The max expansion for latin1
4340 * chars is 1 byte becomes 2 */
4342 d = (U8*)SvPVX(dest) + len;
4344 Copy(GREEK_SMALL_LETTER_MU_UTF8, d, small_mu_len, U8);
4347 for (; s < send; s++) {
4349 UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
4350 if UVCHR_IS_INVARIANT(fc) {
4352 && *s == LATIN_SMALL_LETTER_SHARP_S)
4361 Copy(tmpbuf, d, ulen, U8);
4367 else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
4368 /* Under full casefolding, LATIN SMALL LETTER SHARP S
4369 * becomes "ss", which may require growing the SV. */
4370 if (SvLEN(dest) < ++min) {
4371 const UV o = d - (U8*)SvPVX_const(dest);
4373 d = (U8*)SvPVX(dest) + o;
4378 else { /* If it's not one of those two, the fold is their lower
4380 *d = toLOWER_LATIN1(*s);
4386 SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
4388 #ifdef USE_LOCALE_CTYPE
4389 if (IN_LC_RUNTIME(LC_CTYPE)) {
4394 if (SvTAINTED(source))
4404 dSP; dMARK; dORIGMARK;
4405 AV *const av = MUTABLE_AV(POPs);
4406 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4408 if (SvTYPE(av) == SVt_PVAV) {
4409 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4410 bool can_preserve = FALSE;
4416 can_preserve = SvCANEXISTDELETE(av);
4419 if (lval && localizing) {
4422 for (svp = MARK + 1; svp <= SP; svp++) {
4423 const SSize_t elem = SvIV(*svp);
4427 if (max > AvMAX(av))
4431 while (++MARK <= SP) {
4433 SSize_t elem = SvIV(*MARK);
4434 bool preeminent = TRUE;
4436 if (localizing && can_preserve) {
4437 /* If we can determine whether the element exist,
4438 * Try to preserve the existenceness of a tied array
4439 * element by using EXISTS and DELETE if possible.
4440 * Fallback to FETCH and STORE otherwise. */
4441 preeminent = av_exists(av, elem);
4444 svp = av_fetch(av, elem, lval);
4447 DIE(aTHX_ PL_no_aelem, elem);
4450 save_aelem(av, elem, svp);
4452 SAVEADELETE(av, elem);
4455 *MARK = svp ? *svp : &PL_sv_undef;
4458 if (GIMME != G_ARRAY) {
4460 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4469 AV *const av = MUTABLE_AV(POPs);
4470 I32 lval = (PL_op->op_flags & OPf_MOD);
4471 SSize_t items = SP - MARK;
4473 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4474 const I32 flags = is_lvalue_sub();
4476 if (!(flags & OPpENTERSUB_INARGS))
4477 /* diag_listed_as: Can't modify %s in %s */
4478 Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
4485 *(MARK+items*2-1) = *(MARK+items);
4491 while (++MARK <= SP) {
4494 svp = av_fetch(av, SvIV(*MARK), lval);
4496 if (!svp || !*svp || *svp == &PL_sv_undef) {
4497 DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
4499 *MARK = sv_mortalcopy(*MARK);
4501 *++MARK = svp ? *svp : &PL_sv_undef;
4503 if (GIMME != G_ARRAY) {
4504 MARK = SP - items*2;
4505 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4512 /* Smart dereferencing for keys, values and each */
4514 /* also used for: pp_reach() pp_rvalues() */
4526 (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV)
4531 "Type of argument to %s must be unblessed hashref or arrayref",
4532 PL_op_desc[PL_op->op_type] );
4535 if (PL_op->op_flags & OPf_SPECIAL && SvTYPE(sv) == SVt_PVAV)
4537 "Can't modify %s in %s",
4538 PL_op_desc[PL_op->op_type], PL_op_desc[PL_op->op_next->op_type]
4541 /* Delegate to correct function for op type */
4543 if (PL_op->op_type == OP_RKEYS || PL_op->op_type == OP_RVALUES) {
4544 return (SvTYPE(sv) == SVt_PVHV) ? Perl_do_kv(aTHX) : Perl_pp_akeys(aTHX);
4547 return (SvTYPE(sv) == SVt_PVHV)
4548 ? Perl_pp_each(aTHX)
4549 : Perl_pp_aeach(aTHX);
4556 AV *array = MUTABLE_AV(POPs);
4557 const I32 gimme = GIMME_V;
4558 IV *iterp = Perl_av_iter_p(aTHX_ array);
4559 const IV current = (*iterp)++;
4561 if (current > av_tindex(array)) {
4563 if (gimme == G_SCALAR)
4571 if (gimme == G_ARRAY) {
4572 SV **const element = av_fetch(array, current, 0);
4573 PUSHs(element ? *element : &PL_sv_undef);
4578 /* also used for: pp_avalues()*/
4582 AV *array = MUTABLE_AV(POPs);
4583 const I32 gimme = GIMME_V;
4585 *Perl_av_iter_p(aTHX_ array) = 0;
4587 if (gimme == G_SCALAR) {
4589 PUSHi(av_tindex(array) + 1);
4591 else if (gimme == G_ARRAY) {
4592 IV n = Perl_av_len(aTHX_ array);
4597 if (PL_op->op_type == OP_AKEYS || PL_op->op_type == OP_RKEYS) {
4598 for (i = 0; i <= n; i++) {
4603 for (i = 0; i <= n; i++) {
4604 SV *const *const elem = Perl_av_fetch(aTHX_ array, i, 0);
4605 PUSHs(elem ? *elem : &PL_sv_undef);
4612 /* Associative arrays. */
4617 HV * hash = MUTABLE_HV(POPs);
4619 const I32 gimme = GIMME_V;
4622 /* might clobber stack_sp */
4623 entry = hv_iternext(hash);
4628 SV* const sv = hv_iterkeysv(entry);
4629 PUSHs(sv); /* won't clobber stack_sp */
4630 if (gimme == G_ARRAY) {
4633 /* might clobber stack_sp */
4634 val = hv_iterval(hash, entry);
4639 else if (gimme == G_SCALAR)
4646 S_do_delete_local(pTHX)
4649 const I32 gimme = GIMME_V;
4652 const bool sliced = !!(PL_op->op_private & OPpSLICE);
4653 SV **unsliced_keysv = sliced ? NULL : sp--;
4654 SV * const osv = POPs;
4655 SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
4657 const bool tied = SvRMAGICAL(osv)
4658 && mg_find((const SV *)osv, PERL_MAGIC_tied);
4659 const bool can_preserve = SvCANEXISTDELETE(osv);
4660 const U32 type = SvTYPE(osv);
4661 SV ** const end = sliced ? SP : unsliced_keysv;
4663 if (type == SVt_PVHV) { /* hash element */
4664 HV * const hv = MUTABLE_HV(osv);
4665 while (++MARK <= end) {
4666 SV * const keysv = *MARK;
4668 bool preeminent = TRUE;
4670 preeminent = hv_exists_ent(hv, keysv, 0);
4672 HE *he = hv_fetch_ent(hv, keysv, 1, 0);
4679 sv = hv_delete_ent(hv, keysv, 0, 0);
4681 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4684 if (!sv) DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4685 save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
4687 *MARK = sv_mortalcopy(sv);
4693 SAVEHDELETE(hv, keysv);
4694 *MARK = &PL_sv_undef;
4698 else if (type == SVt_PVAV) { /* array element */
4699 if (PL_op->op_flags & OPf_SPECIAL) {
4700 AV * const av = MUTABLE_AV(osv);
4701 while (++MARK <= end) {
4702 SSize_t idx = SvIV(*MARK);
4704 bool preeminent = TRUE;
4706 preeminent = av_exists(av, idx);
4708 SV **svp = av_fetch(av, idx, 1);
4715 sv = av_delete(av, idx, 0);
4717 SvREFCNT_inc_simple_void(sv); /* De-mortalize */
4720 save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
4722 *MARK = sv_mortalcopy(sv);
4728 SAVEADELETE(av, idx);
4729 *MARK = &PL_sv_undef;
4734 DIE(aTHX_ "panic: avhv_delete no longer supported");
4737 DIE(aTHX_ "Not a HASH reference");
4739 if (gimme == G_VOID)
4741 else if (gimme == G_SCALAR) {
4746 *++MARK = &PL_sv_undef;
4750 else if (gimme != G_VOID)
4751 PUSHs(*unsliced_keysv);
4762 if (PL_op->op_private & OPpLVAL_INTRO)
4763 return do_delete_local();
4766 discard = (gimme == G_VOID) ? G_DISCARD : 0;
4768 if (PL_op->op_private & OPpSLICE) {
4770 HV * const hv = MUTABLE_HV(POPs);
4771 const U32 hvtype = SvTYPE(hv);
4772 if (hvtype == SVt_PVHV) { /* hash element */
4773 while (++MARK <= SP) {
4774 SV * const sv = hv_delete_ent(hv, *MARK, discard, 0);
4775 *MARK = sv ? sv : &PL_sv_undef;
4778 else if (hvtype == SVt_PVAV) { /* array element */
4779 if (PL_op->op_flags & OPf_SPECIAL) {
4780 while (++MARK <= SP) {
4781 SV * const sv = av_delete(MUTABLE_AV(hv), SvIV(*MARK), discard);
4782 *MARK = sv ? sv : &PL_sv_undef;
4787 DIE(aTHX_ "Not a HASH reference");
4790 else if (gimme == G_SCALAR) {
4795 *++MARK = &PL_sv_undef;
4801 HV * const hv = MUTABLE_HV(POPs);
4803 if (SvTYPE(hv) == SVt_PVHV)
4804 sv = hv_delete_ent(hv, keysv, discard, 0);
4805 else if (SvTYPE(hv) == SVt_PVAV) {
4806 if (PL_op->op_flags & OPf_SPECIAL)
4807 sv = av_delete(MUTABLE_AV(hv), SvIV(keysv), discard);
4809 DIE(aTHX_ "panic: avhv_delete no longer supported");
4812 DIE(aTHX_ "Not a HASH reference");
4827 if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
4829 SV * const sv = POPs;
4830 CV * const cv = sv_2cv(sv, &hv, &gv, 0);
4833 if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv))
4838 hv = MUTABLE_HV(POPs);
4839 if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
4840 if (hv_exists_ent(hv, tmpsv, 0))
4843 else if (SvTYPE(hv) == SVt_PVAV) {
4844 if (PL_op->op_flags & OPf_SPECIAL) { /* array element */
4845 if (av_exists(MUTABLE_AV(hv), SvIV(tmpsv)))
4850 DIE(aTHX_ "Not a HASH reference");
4857 dSP; dMARK; dORIGMARK;
4858 HV * const hv = MUTABLE_HV(POPs);
4859 const I32 lval = (PL_op->op_flags & OPf_MOD || LVRET);
4860 const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
4861 bool can_preserve = FALSE;
4867 if (SvCANEXISTDELETE(hv))
4868 can_preserve = TRUE;
4871 while (++MARK <= SP) {
4872 SV * const keysv = *MARK;
4875 bool preeminent = TRUE;
4877 if (localizing && can_preserve) {
4878 /* If we can determine whether the element exist,
4879 * try to preserve the existenceness of a tied hash
4880 * element by using EXISTS and DELETE if possible.
4881 * Fallback to FETCH and STORE otherwise. */
4882 preeminent = hv_exists_ent(hv, keysv, 0);
4885 he = hv_fetch_ent(hv, keysv, lval, 0);
4886 svp = he ? &HeVAL(he) : NULL;
4889 if (!svp || !*svp || *svp == &PL_sv_undef) {
4890 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4893 if (HvNAME_get(hv) && isGV(*svp))
4894 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
4895 else if (preeminent)
4896 save_helem_flags(hv, keysv, svp,
4897 (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
4899 SAVEHDELETE(hv, keysv);
4902 *MARK = svp && *svp ? *svp : &PL_sv_undef;
4904 if (GIMME != G_ARRAY) {
4906 *++MARK = SP > ORIGMARK ? *SP : &PL_sv_undef;
4915 HV * const hv = MUTABLE_HV(POPs);
4916 I32 lval = (PL_op->op_flags & OPf_MOD);
4917 SSize_t items = SP - MARK;
4919 if (PL_op->op_private & OPpMAYBE_LVSUB) {
4920 const I32 flags = is_lvalue_sub();
4922 if (!(flags & OPpENTERSUB_INARGS))
4923 /* diag_listed_as: Can't modify %s in %s */
4924 Perl_croak(aTHX_ "Can't modify key/value hash slice in list assignment");
4931 *(MARK+items*2-1) = *(MARK+items);
4937 while (++MARK <= SP) {
4938 SV * const keysv = *MARK;
4942 he = hv_fetch_ent(hv, keysv, lval, 0);
4943 svp = he ? &HeVAL(he) : NULL;
4946 if (!svp || !*svp || *svp == &PL_sv_undef) {
4947 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
4949 *MARK = sv_mortalcopy(*MARK);
4951 *++MARK = svp && *svp ? *svp : &PL_sv_undef;
4953 if (GIMME != G_ARRAY) {
4954 MARK = SP - items*2;
4955 *++MARK = items > 0 ? *SP : &PL_sv_undef;
4961 /* List operators. */
4965 I32 markidx = POPMARK;
4966 if (GIMME != G_ARRAY) {
4967 SV **mark = PL_stack_base + markidx;
4970 *MARK = *SP; /* unwanted list, return last item */
4972 *MARK = &PL_sv_undef;
4982 SV ** const lastrelem = PL_stack_sp;
4983 SV ** const lastlelem = PL_stack_base + POPMARK;
4984 SV ** const firstlelem = PL_stack_base + POPMARK + 1;
4985 SV ** const firstrelem = lastlelem + 1;
4986 I32 is_something_there = FALSE;
4987 const U8 mod = PL_op->op_flags & OPf_MOD;
4989 const I32 max = lastrelem - lastlelem;
4992 if (GIMME != G_ARRAY) {
4993 I32 ix = SvIV(*lastlelem);
4996 if (ix < 0 || ix >= max)
4997 *firstlelem = &PL_sv_undef;
4999 *firstlelem = firstrelem[ix];
5005 SP = firstlelem - 1;
5009 for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
5010 I32 ix = SvIV(*lelem);
5013 if (ix < 0 || ix >= max)
5014 *lelem = &PL_sv_undef;
5016 is_something_there = TRUE;
5017 if (!(*lelem = firstrelem[ix]))
5018 *lelem = &PL_sv_undef;
5019 else if (mod && SvPADTMP(*lelem)) {
5020 *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
5024 if (is_something_there)
5027 SP = firstlelem - 1;
5034 const I32 items = SP - MARK;
5035 SV * const av = MUTABLE_SV(av_make(items, MARK+1));
5037 mXPUSHs((PL_op->op_flags & OPf_SPECIAL)
5038 ? newRV_noinc(av) : av);
5044 dSP; dMARK; dORIGMARK;
5045 HV* const hv = newHV();
5046 SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
5047 ? newRV_noinc(MUTABLE_SV(hv))
5052 (MARK++, SvGMAGICAL(*MARK) ? sv_mortalcopy(*MARK) : *MARK);
5059 sv_setsv(val, *MARK);
5063 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash");
5066 (void)hv_store_ent(hv,key,val,0);
5074 S_deref_plain_array(pTHX_ AV *ary)
5076 if (SvTYPE(ary) == SVt_PVAV) return ary;
5077 SvGETMAGIC((SV *)ary);
5078 if (!SvROK(ary) || SvTYPE(SvRV(ary)) != SVt_PVAV)
5079 Perl_die(aTHX_ "Not an ARRAY reference");
5080 else if (SvOBJECT(SvRV(ary)))
5081 Perl_die(aTHX_ "Not an unblessed ARRAY reference");
5082 return (AV *)SvRV(ary);
5085 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
5086 # define DEREF_PLAIN_ARRAY(ary) \
5089 SvTYPE(aRrRay) == SVt_PVAV \
5091 : S_deref_plain_array(aTHX_ aRrRay); \
5094 # define DEREF_PLAIN_ARRAY(ary) \
5096 PL_Sv = (SV *)(ary), \
5097 SvTYPE(PL_Sv) == SVt_PVAV \
5099 : S_deref_plain_array(aTHX_ (AV *)PL_Sv) \
5105 dSP; dMARK; dORIGMARK;
5106 int num_args = (SP - MARK);
5107 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5116 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5119 return Perl_tied_method(aTHX_ SV_CONST(SPLICE), mark - 1, MUTABLE_SV(ary), mg,
5120 GIMME_V | TIED_METHOD_ARGUMENTS_ON_STACK,
5127 offset = i = SvIV(*MARK);
5129 offset += AvFILLp(ary) + 1;
5131 DIE(aTHX_ PL_no_aelem, i);
5133 length = SvIVx(*MARK++);
5135 length += AvFILLp(ary) - offset + 1;
5141 length = AvMAX(ary) + 1; /* close enough to infinity */
5145 length = AvMAX(ary) + 1;
5147 if (offset > AvFILLp(ary) + 1) {
5149 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" );
5150 offset = AvFILLp(ary) + 1;
5152 after = AvFILLp(ary) + 1 - (offset + length);
5153 if (after < 0) { /* not that much array */
5154 length += after; /* offset+length now in array */
5160 /* At this point, MARK .. SP-1 is our new LIST */
5163 diff = newlen - length;
5164 if (newlen && !AvREAL(ary) && AvREIFY(ary))
5167 /* make new elements SVs now: avoid problems if they're from the array */
5168 for (dst = MARK, i = newlen; i; i--) {
5169 SV * const h = *dst;
5170 *dst++ = newSVsv(h);
5173 if (diff < 0) { /* shrinking the area */
5174 SV **tmparyval = NULL;
5176 Newx(tmparyval, newlen, SV*); /* so remember insertion */
5177 Copy(MARK, tmparyval, newlen, SV*);
5180 MARK = ORIGMARK + 1;
5181 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5182 const bool real = cBOOL(AvREAL(ary));
5183 MEXTEND(MARK, length);
5185 EXTEND_MORTAL(length);
5186 for (i = 0, dst = MARK; i < length; i++) {
5187 if ((*dst = AvARRAY(ary)[i+offset])) {
5189 sv_2mortal(*dst); /* free them eventually */
5192 *dst = &PL_sv_undef;
5198 *MARK = AvARRAY(ary)[offset+length-1];
5201 for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
5202 SvREFCNT_dec(*dst++); /* free them now */
5205 AvFILLp(ary) += diff;
5207 /* pull up or down? */
5209 if (offset < after) { /* easier to pull up */
5210 if (offset) { /* esp. if nothing to pull */
5211 src = &AvARRAY(ary)[offset-1];
5212 dst = src - diff; /* diff is negative */
5213 for (i = offset; i > 0; i--) /* can't trust Copy */
5217 AvARRAY(ary) = AvARRAY(ary) - diff; /* diff is negative */
5221 if (after) { /* anything to pull down? */
5222 src = AvARRAY(ary) + offset + length;
5223 dst = src + diff; /* diff is negative */
5224 Move(src, dst, after, SV*);
5226 dst = &AvARRAY(ary)[AvFILLp(ary)+1];
5227 /* avoid later double free */
5234 Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
5235 Safefree(tmparyval);
5238 else { /* no, expanding (or same) */
5239 SV** tmparyval = NULL;
5241 Newx(tmparyval, length, SV*); /* so remember deletion */
5242 Copy(AvARRAY(ary)+offset, tmparyval, length, SV*);
5245 if (diff > 0) { /* expanding */
5246 /* push up or down? */
5247 if (offset < after && diff <= AvARRAY(ary) - AvALLOC(ary)) {
5251 Move(src, dst, offset, SV*);
5253 AvARRAY(ary) = AvARRAY(ary) - diff;/* diff is positive */
5255 AvFILLp(ary) += diff;
5258 if (AvFILLp(ary) + diff >= AvMAX(ary)) /* oh, well */
5259 av_extend(ary, AvFILLp(ary) + diff);
5260 AvFILLp(ary) += diff;
5263 dst = AvARRAY(ary) + AvFILLp(ary);
5265 for (i = after; i; i--) {
5273 Copy( MARK, AvARRAY(ary) + offset, newlen, SV* );
5276 MARK = ORIGMARK + 1;
5277 if (GIMME == G_ARRAY) { /* copy return vals to stack */
5279 const bool real = cBOOL(AvREAL(ary));
5281 EXTEND_MORTAL(length);
5282 for (i = 0, dst = MARK; i < length; i++) {
5283 if ((*dst = tmparyval[i])) {
5285 sv_2mortal(*dst); /* free them eventually */
5287 else *dst = &PL_sv_undef;
5293 else if (length--) {
5294 *MARK = tmparyval[length];
5297 while (length-- > 0)
5298 SvREFCNT_dec(tmparyval[length]);
5302 *MARK = &PL_sv_undef;
5303 Safefree(tmparyval);
5307 mg_set(MUTABLE_SV(ary));
5315 dSP; dMARK; dORIGMARK; dTARGET;
5316 AV * const ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5317 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5320 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5323 ENTER_with_name("call_PUSH");
5324 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5325 LEAVE_with_name("call_PUSH");
5329 if (SvREADONLY(ary) && MARK < SP) Perl_croak_no_modify();
5330 PL_delaymagic = DM_DELAY;
5331 for (++MARK; MARK <= SP; MARK++) {
5333 if (*MARK) SvGETMAGIC(*MARK);
5336 sv_setsv_nomg(sv, *MARK);
5337 av_store(ary, AvFILLp(ary)+1, sv);
5339 if (PL_delaymagic & DM_ARRAY_ISA)
5340 mg_set(MUTABLE_SV(ary));
5345 if (OP_GIMME(PL_op, 0) != G_VOID) {
5346 PUSHi( AvFILL(ary) + 1 );
5351 /* also used for: pp_pop()*/
5355 AV * const av = PL_op->op_flags & OPf_SPECIAL
5356 ? MUTABLE_AV(GvAV(PL_defgv)) : DEREF_PLAIN_ARRAY(MUTABLE_AV(POPs));
5357 SV * const sv = PL_op->op_type == OP_SHIFT ? av_shift(av) : av_pop(av);
5361 (void)sv_2mortal(sv);
5368 dSP; dMARK; dORIGMARK; dTARGET;
5369 AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
5370 const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
5373 *MARK-- = SvTIED_obj(MUTABLE_SV(ary), mg);
5376 ENTER_with_name("call_UNSHIFT");
5377 call_sv(SV_CONST(UNSHIFT),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5378 LEAVE_with_name("call_UNSHIFT");
5383 av_unshift(ary, SP - MARK);
5385 SV * const sv = newSVsv(*++MARK);
5386 (void)av_store(ary, i++, sv);
5390 if (OP_GIMME(PL_op, 0) != G_VOID) {
5391 PUSHi( AvFILL(ary) + 1 );
5400 if (GIMME == G_ARRAY) {
5401 if (PL_op->op_private & OPpREVERSE_INPLACE) {
5405 assert( MARK+1 == SP && *SP && SvTYPE(*SP) == SVt_PVAV);
5406 (void)POPMARK; /* remove mark associated with ex-OP_AASSIGN */
5407 av = MUTABLE_AV((*SP));
5408 /* In-place reversing only happens in void context for the array
5409 * assignment. We don't need to push anything on the stack. */
5412 if (SvMAGICAL(av)) {
5414 SV *tmp = sv_newmortal();
5415 /* For SvCANEXISTDELETE */
5418 bool can_preserve = SvCANEXISTDELETE(av);
5420 for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
5424 if (!av_exists(av, i)) {
5425 if (av_exists(av, j)) {
5426 SV *sv = av_delete(av, j, 0);
5427 begin = *av_fetch(av, i, TRUE);
5428 sv_setsv_mg(begin, sv);
5432 else if (!av_exists(av, j)) {
5433 SV *sv = av_delete(av, i, 0);
5434 end = *av_fetch(av, j, TRUE);
5435 sv_setsv_mg(end, sv);
5440 begin = *av_fetch(av, i, TRUE);
5441 end = *av_fetch(av, j, TRUE);
5442 sv_setsv(tmp, begin);
5443 sv_setsv_mg(begin, end);
5444 sv_setsv_mg(end, tmp);
5448 SV **begin = AvARRAY(av);
5451 SV **end = begin + AvFILLp(av);
5453 while (begin < end) {
5454 SV * const tmp = *begin;
5465 SV * const tmp = *MARK;
5469 /* safe as long as stack cannot get extended in the above */
5480 SvUTF8_off(TARG); /* decontaminate */
5482 do_join(TARG, &PL_sv_no, MARK, SP);
5484 sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
5487 up = SvPV_force(TARG, len);
5489 if (DO_UTF8(TARG)) { /* first reverse each character */
5490 U8* s = (U8*)SvPVX(TARG);
5491 const U8* send = (U8*)(s + len);
5493 if (UTF8_IS_INVARIANT(*s)) {
5498 if (!utf8_to_uvchr_buf(s, send, 0))
5502 down = (char*)(s - 1);
5503 /* reverse this character */
5507 *down-- = (char)tmp;
5513 down = SvPVX(TARG) + len - 1;
5517 *down-- = (char)tmp;
5519 (void)SvPOK_only_UTF8(TARG);
5531 IV limit = POPi; /* note, negative is forever */
5532 SV * const sv = POPs;
5534 const char *s = SvPV_const(sv, len);
5535 const bool do_utf8 = DO_UTF8(sv);
5536 const char *strend = s + len;
5542 const STRLEN slen = do_utf8
5543 ? utf8_length((U8*)s, (U8*)strend)
5544 : (STRLEN)(strend - s);
5545 SSize_t maxiters = slen + 10;
5546 I32 trailing_empty = 0;
5548 const I32 origlimit = limit;
5551 const I32 gimme = GIMME_V;
5553 const I32 oldsave = PL_savestack_ix;
5554 U32 make_mortal = SVs_TEMP;
5559 Copy(&LvTARGOFF(POPs), &pm, 1, PMOP*);
5564 DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
5567 TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
5568 (RX_EXTFLAGS(rx) & (RXf_WHITE | RXf_SKIPWHITE)));
5571 if (pm->op_pmreplrootu.op_pmtargetoff) {
5572 ary = GvAVn(MUTABLE_GV(PAD_SVl(pm->op_pmreplrootu.op_pmtargetoff)));
5575 if (pm->op_pmreplrootu.op_pmtargetgv) {
5576 ary = GvAVn(pm->op_pmreplrootu.op_pmtargetgv);
5587 if ((mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied))) {
5589 XPUSHs(SvTIED_obj(MUTABLE_SV(ary), mg));
5596 for (i = AvFILLp(ary); i >= 0; i--)
5597 AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
5599 /* temporarily switch stacks */
5600 SAVESWITCHSTACK(PL_curstack, ary);
5604 base = SP - PL_stack_base;
5606 if (RX_EXTFLAGS(rx) & RXf_SKIPWHITE) {
5608 while (isSPACE_utf8(s))
5611 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET) {
5612 while (isSPACE_LC(*s))
5620 if (RX_EXTFLAGS(rx) & RXf_PMf_MULTILINE) {
5624 gimme_scalar = gimme == G_SCALAR && !ary;
5627 limit = maxiters + 2;
5628 if (RX_EXTFLAGS(rx) & RXf_WHITE) {
5631 /* this one uses 'm' and is a negative test */
5633 while (m < strend && ! isSPACE_utf8(m) ) {
5634 const int t = UTF8SKIP(m);
5635 /* isSPACE_utf8 returns FALSE for malform utf8 */
5642 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5644 while (m < strend && !isSPACE_LC(*m))
5647 while (m < strend && !isSPACE(*m))
5660 dstr = newSVpvn_flags(s, m-s,
5661 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5665 /* skip the whitespace found last */
5667 s = m + UTF8SKIP(m);
5671 /* this one uses 's' and is a positive test */
5673 while (s < strend && isSPACE_utf8(s) )
5676 else if (get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET)
5678 while (s < strend && isSPACE_LC(*s))
5681 while (s < strend && isSPACE(*s))
5686 else if (RX_EXTFLAGS(rx) & RXf_START_ONLY) {
5688 for (m = s; m < strend && *m != '\n'; m++)
5701 dstr = newSVpvn_flags(s, m-s,
5702 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5708 else if (RX_EXTFLAGS(rx) & RXf_NULL && !(s >= strend)) {
5710 Pre-extend the stack, either the number of bytes or
5711 characters in the string or a limited amount, triggered by:
5713 my ($x, $y) = split //, $str;
5717 if (!gimme_scalar) {
5718 const U32 items = limit - 1;
5727 /* keep track of how many bytes we skip over */
5737 dstr = newSVpvn_flags(m, s-m, SVf_UTF8 | make_mortal);
5750 dstr = newSVpvn(s, 1);
5766 else if (do_utf8 == (RX_UTF8(rx) != 0) &&
5767 (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
5768 && (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
5769 && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
5770 const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
5771 SV * const csv = CALLREG_INTUIT_STRING(rx);
5773 len = RX_MINLENRET(rx);
5774 if (len == 1 && !RX_UTF8(rx) && !tail) {
5775 const char c = *SvPV_nolen_const(csv);
5777 for (m = s; m < strend && *m != c; m++)
5788 dstr = newSVpvn_flags(s, m-s,
5789 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5792 /* The rx->minlen is in characters but we want to step
5793 * s ahead by bytes. */
5795 s = (char*)utf8_hop((U8*)m, len);
5797 s = m + len; /* Fake \n at the end */
5801 while (s < strend && --limit &&
5802 (m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
5803 csv, multiline ? FBMrf_MULTILINE : 0)) )
5812 dstr = newSVpvn_flags(s, m-s,
5813 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5816 /* The rx->minlen is in characters but we want to step
5817 * s ahead by bytes. */
5819 s = (char*)utf8_hop((U8*)m, len);
5821 s = m + len; /* Fake \n at the end */
5826 maxiters += slen * RX_NPARENS(rx);
5827 while (s < strend && --limit)
5831 rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1,
5834 if (rex_return == 0)
5836 TAINT_IF(RX_MATCH_TAINTED(rx));
5837 /* we never pass the REXEC_COPY_STR flag, so it should
5838 * never get copied */
5839 assert(!RX_MATCH_COPIED(rx));
5840 m = RX_OFFS(rx)[0].start + orig;
5849 dstr = newSVpvn_flags(s, m-s,
5850 (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5853 if (RX_NPARENS(rx)) {
5855 for (i = 1; i <= (I32)RX_NPARENS(rx); i++) {
5856 s = RX_OFFS(rx)[i].start + orig;
5857 m = RX_OFFS(rx)[i].end + orig;
5859 /* japhy (07/27/01) -- the (m && s) test doesn't catch
5860 parens that didn't match -- they should be set to
5861 undef, not the empty string */
5869 if (m >= orig && s >= orig) {
5870 dstr = newSVpvn_flags(s, m-s,
5871 (do_utf8 ? SVf_UTF8 : 0)
5875 dstr = &PL_sv_undef; /* undef, not "" */
5881 s = RX_OFFS(rx)[0].end + orig;
5885 if (!gimme_scalar) {
5886 iters = (SP - PL_stack_base) - base;
5888 if (iters > maxiters)
5889 DIE(aTHX_ "Split loop");
5891 /* keep field after final delim? */
5892 if (s < strend || (iters && origlimit)) {
5893 if (!gimme_scalar) {
5894 const STRLEN l = strend - s;
5895 dstr = newSVpvn_flags(s, l, (do_utf8 ? SVf_UTF8 : 0) | make_mortal);
5900 else if (!origlimit) {
5902 iters -= trailing_empty;
5904 while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0)) {
5905 if (TOPs && !make_mortal)
5907 *SP-- = &PL_sv_undef;
5914 LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
5918 if (SvSMAGICAL(ary)) {
5920 mg_set(MUTABLE_SV(ary));
5923 if (gimme == G_ARRAY) {
5925 Copy(AvARRAY(ary), SP + 1, iters, SV*);
5932 ENTER_with_name("call_PUSH");
5933 call_sv(SV_CONST(PUSH),G_SCALAR|G_DISCARD|G_METHOD_NAMED);
5934 LEAVE_with_name("call_PUSH");
5936 if (gimme == G_ARRAY) {
5938 /* EXTEND should not be needed - we just popped them */
5940 for (i=0; i < iters; i++) {
5941 SV **svp = av_fetch(ary, i, FALSE);
5942 PUSHs((svp) ? *svp : &PL_sv_undef);
5949 if (gimme == G_ARRAY)
5961 SV *const sv = PAD_SVl(PL_op->op_targ);
5963 if (SvPADSTALE(sv)) {
5966 RETURNOP(cLOGOP->op_other);
5968 RETURNOP(cLOGOP->op_next);
5977 if (SvTYPE(retsv) == SVt_PVAV || SvTYPE(retsv) == SVt_PVHV
5978 || SvTYPE(retsv) == SVt_PVCV) {
5979 retsv = refto(retsv);
5986 /* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops
5987 * that aren't implemented on a particular platform */
5989 PP(unimplemented_op)
5991 const Optype op_type = PL_op->op_type;
5992 /* Using OP_NAME() isn't going to be helpful here. Firstly, it doesn't cope
5993 with out of range op numbers - it only "special" cases op_custom.
5994 Secondly, as the three ops we "panic" on are padmy, mapstart and custom,
5995 if we get here for a custom op then that means that the custom op didn't
5996 have an implementation. Given that OP_NAME() looks up the custom op
5997 by its pp_addr, likely it will return NULL, unless someone (unhelpfully)
5998 registers &PL_unimplemented_op as the address of their custom op.
5999 NULL doesn't generate a useful error message. "custom" does. */
6000 const char *const name = op_type >= OP_max
6001 ? "[out of range]" : PL_op_name[PL_op->op_type];
6002 if(OP_IS_SOCKET(op_type))
6003 DIE(aTHX_ PL_no_sock_func, name);
6004 DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name, op_type);
6007 /* For sorting out arguments passed to a &CORE:: subroutine */
6011 int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
6012 int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
6013 AV * const at_ = GvAV(PL_defgv);
6014 SV **svp = at_ ? AvARRAY(at_) : NULL;
6015 I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
6016 I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
6017 bool seen_question = 0;
6018 const char *err = NULL;
6019 const bool pushmark = PL_op->op_private & OPpCOREARGS_PUSHMARK;
6021 /* Count how many args there are first, to get some idea how far to
6022 extend the stack. */
6024 if ((oa & 7) == OA_LIST) { maxargs = I32_MAX; break; }
6026 if (oa & OA_OPTIONAL) seen_question = 1;
6027 if (!seen_question) minargs++;
6031 if(numargs < minargs) err = "Not enough";
6032 else if(numargs > maxargs) err = "Too many";
6034 /* diag_listed_as: Too many arguments for %s */
6036 "%s arguments for %s", err,
6037 opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
6040 /* Reset the stack pointer. Without this, we end up returning our own
6041 arguments in list context, in addition to the values we are supposed
6042 to return. nextstate usually does this on sub entry, but we need
6043 to run the next op with the caller's hints, so we cannot have a
6045 SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
6047 if(!maxargs) RETURN;
6049 /* We do this here, rather than with a separate pushmark op, as it has
6050 to come in between two things this function does (stack reset and
6051 arg pushing). This seems the easiest way to do it. */
6054 (void)Perl_pp_pushmark(aTHX);
6057 EXTEND(SP, maxargs == I32_MAX ? numargs : maxargs);
6058 PUTBACK; /* The code below can die in various places. */
6060 oa = PL_opargs[opnum] >> OASHIFT;
6061 for (; oa&&(numargs||!pushmark); (void)(numargs&&(++svp,--numargs))) {
6066 if (!numargs && defgv && whicharg == minargs + 1) {
6067 PUSHs(find_rundefsv2(
6068 find_runcv_where(FIND_RUNCV_level_eq, 1, NULL),
6069 cxstack[cxstack_ix].blk_oldcop->cop_seq
6072 else PUSHs(numargs ? svp && *svp ? *svp : &PL_sv_undef : NULL);
6076 PUSHs(svp && *svp ? *svp : &PL_sv_undef);
6081 if (!svp || !*svp || !SvROK(*svp)
6082 || SvTYPE(SvRV(*svp)) != SVt_PVHV)
6084 /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
6085 "Type of arg %d to &CORE::%s must be hash reference",
6086 whicharg, OP_DESC(PL_op->op_next)
6091 if (!numargs) PUSHs(NULL);
6092 else if(svp && *svp && SvROK(*svp) && isGV_with_GP(SvRV(*svp)))
6093 /* no magic here, as the prototype will have added an extra
6094 refgen and we just want what was there before that */
6097 const bool constr = PL_op->op_private & whicharg;
6099 svp && *svp ? *svp : &PL_sv_undef,
6100 constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
6106 if (!numargs) goto try_defsv;
6108 const bool wantscalar =
6109 PL_op->op_private & OPpCOREARGS_SCALARMOD;
6110 if (!svp || !*svp || !SvROK(*svp)
6111 /* We have to permit globrefs even for the \$ proto, as
6112 *foo is indistinguishable from ${\*foo}, and the proto-
6113 type permits the latter. */
6114 || SvTYPE(SvRV(*svp)) > (
6115 wantscalar ? SVt_PVLV
6116 : opnum == OP_LOCK || opnum == OP_UNDEF
6122 "Type of arg %d to &CORE::%s must be %s",
6123 whicharg, PL_op_name[opnum],
6125 ? "scalar reference"
6126 : opnum == OP_LOCK || opnum == OP_UNDEF
6127 ? "reference to one of [$@%&*]"
6128 : "reference to one of [$@%*]"
6131 if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
6132 && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
6133 /* Undo @_ localisation, so that sub exit does not undo
6134 part of our undeffing. */
6135 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
6137 cx->cx_type &= ~ CXp_HASARGS;
6138 assert(!AvREAL(cx->blk_sub.argarray));
6143 DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
6155 if (PL_op->op_private & OPpOFFBYONE) {
6156 cv = find_runcv_where(FIND_RUNCV_level_eq, 1, NULL);
6158 else cv = find_runcv(NULL);
6159 XPUSHs(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
6166 SV * const key = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6167 SV * const left = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6169 if (!SvROK(sv)) DIE(aTHX_ "Assigned value is not a reference");
6170 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
6171 /* diag_listed_as: Assigned value is not %s reference */
6172 DIE(aTHX_ "Assigned value is not a SCALAR reference");
6173 switch (left ? SvTYPE(left) : 0) {
6176 SV * const old = PAD_SV(ARGTARG);
6177 PAD_SETSV(ARGTARG, SvREFCNT_inc_NN(SvRV(sv)));
6179 if (PL_op->op_private & OPpLVAL_INTRO)
6180 SAVECLEARSV(PAD_SVl(ARGTARG));
6184 if (PL_op->op_private & OPpLVAL_INTRO) {
6185 save_pushptrptr((GV *)left, SvREFCNT_inc_simple(GvSV(left)),
6189 gv_setref(left, sv);
6193 av_store((AV *)left, SvIV(key), SvREFCNT_inc_simple_NN(SvRV(sv)));
6196 if (PL_op->op_flags & OPf_MOD)
6197 SETs(sv_2mortal(newSVsv(sv)));
6198 /* XXX else can weak references go stale before they are read, e.g.,
6206 SV * const ret = sv_2mortal(newSV_type(SVt_PVMG));
6207 SV * const elem = PL_op->op_private & OPpLVREF_ELEM ? POPs : NULL;
6208 SV * const arg = PL_op->op_flags & OPf_STACKED ? POPs : NULL;
6210 PERL_MAGIC_lvref, (char *)elem, elem ? HEf_SVKEY : ARGTARG);
6211 if (PL_op->op_private & OPpLVAL_INTRO) {
6212 if (PL_op->op_flags & OPf_STACKED) {
6213 save_pushptrptr((GV *)arg, SvREFCNT_inc_simple(GvSV(arg)),
6218 SAVECLEARSV(PAD_SVl(ARGTARG));
6226 DIE(aTHX_ "Unimplemented");
6231 * c-indentation-style: bsd
6233 * indent-tabs-mode: nil
6236 * ex: set ts=8 sts=4 sw=4 et: