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 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
19 * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains control-oriented pp ("push/pop") functions that
23 * execute the opcodes that make up a perl program. A typical pp function
24 * expects to find its arguments on the stack, and usually pushes its
25 * results onto the stack, hence the 'pp' terminology. Each OP structure
26 * contains a pointer to the relevant pp_foo() function.
28 * Control-oriented means things like pp_enteriter() and pp_next(), which
29 * alter the flow of control of the program.
34 #define PERL_IN_PP_CTL_C
38 #define WORD_ALIGN sizeof(U32)
41 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
43 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
52 cxix = dopoptosub(cxstack_ix);
56 switch (cxstack[cxix].blk_gimme) {
69 /* XXXX Should store the old value to allow for tie/overload - and
70 restore in regcomp, where marked with XXXX. */
80 register PMOP *pm = (PMOP*)cLOGOP->op_other;
84 /* prevent recompiling under /o and ithreads. */
85 #if defined(USE_ITHREADS)
86 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
87 if (PL_op->op_flags & OPf_STACKED) {
96 if (PL_op->op_flags & OPf_STACKED) {
97 /* multiple args; concatentate them */
99 tmpstr = PAD_SV(ARGTARG);
100 sv_setpvs(tmpstr, "");
101 while (++MARK <= SP) {
102 if (PL_amagic_generation) {
104 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
105 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
107 sv_setsv(tmpstr, sv);
111 sv_catsv(tmpstr, *MARK);
120 SV * const sv = SvRV(tmpstr);
121 if (SvTYPE(sv) == SVt_REGEXP)
125 re = reg_temp_copy(re);
126 ReREFCNT_dec(PM_GETRE(pm));
131 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
133 assert (re != (REGEXP*) &PL_sv_undef);
135 /* Check against the last compiled regexp. */
136 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
137 memNE(RX_PRECOMP(re), t, len))
139 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
140 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
144 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
146 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
148 } else if (PL_curcop->cop_hints_hash) {
149 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
151 if (ptr && SvIOK(ptr) && SvIV(ptr))
152 eng = INT2PTR(regexp_engine*,SvIV(ptr));
155 if (PL_op->op_flags & OPf_SPECIAL)
156 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
158 if (DO_UTF8(tmpstr)) {
159 assert (SvUTF8(tmpstr));
160 } else if (SvUTF8(tmpstr)) {
161 /* Not doing UTF-8, despite what the SV says. Is this only if
162 we're trapped in use 'bytes'? */
163 /* Make a copy of the octet sequence, but without the flag on,
164 as the compiler now honours the SvUTF8 flag on tmpstr. */
166 const char *const p = SvPV(tmpstr, len);
167 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
171 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
173 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
175 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
176 inside tie/overload accessors. */
182 #ifndef INCOMPLETE_TAINTS
185 RX_EXTFLAGS(re) |= RXf_TAINTED;
187 RX_EXTFLAGS(re) &= ~RXf_TAINTED;
191 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
195 #if !defined(USE_ITHREADS)
196 /* can't change the optree at runtime either */
197 /* PMf_KEEP is handled differently under threads to avoid these problems */
198 if (pm->op_pmflags & PMf_KEEP) {
199 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
200 cLOGOP->op_first->op_next = PL_op->op_next;
210 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
211 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
212 register SV * const dstr = cx->sb_dstr;
213 register char *s = cx->sb_s;
214 register char *m = cx->sb_m;
215 char *orig = cx->sb_orig;
216 register REGEXP * const rx = cx->sb_rx;
218 REGEXP *old = PM_GETRE(pm);
222 PM_SETRE(pm,ReREFCNT_inc(rx));
225 rxres_restore(&cx->sb_rxres, rx);
226 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
228 if (cx->sb_iters++) {
229 const I32 saviters = cx->sb_iters;
230 if (cx->sb_iters > cx->sb_maxiters)
231 DIE(aTHX_ "Substitution loop");
233 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
234 cx->sb_rxtainted |= 2;
235 sv_catsv(dstr, POPs);
236 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
240 if (CxONCE(cx) || s < orig ||
241 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
242 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
243 ((cx->sb_rflags & REXEC_COPY_STR)
244 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
245 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
247 SV * const targ = cx->sb_targ;
249 assert(cx->sb_strend >= s);
250 if(cx->sb_strend > s) {
251 if (DO_UTF8(dstr) && !SvUTF8(targ))
252 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
254 sv_catpvn(dstr, s, cx->sb_strend - s);
256 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
258 #ifdef PERL_OLD_COPY_ON_WRITE
260 sv_force_normal_flags(targ, SV_COW_DROP_PV);
266 SvPV_set(targ, SvPVX(dstr));
267 SvCUR_set(targ, SvCUR(dstr));
268 SvLEN_set(targ, SvLEN(dstr));
271 SvPV_set(dstr, NULL);
273 TAINT_IF(cx->sb_rxtainted & 1);
274 mPUSHi(saviters - 1);
276 (void)SvPOK_only_UTF8(targ);
277 TAINT_IF(cx->sb_rxtainted);
281 LEAVE_SCOPE(cx->sb_oldsave);
283 RETURNOP(pm->op_next);
285 cx->sb_iters = saviters;
287 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
290 cx->sb_orig = orig = RX_SUBBEG(rx);
292 cx->sb_strend = s + (cx->sb_strend - m);
294 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
296 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
297 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
299 sv_catpvn(dstr, s, m-s);
301 cx->sb_s = RX_OFFS(rx)[0].end + orig;
302 { /* Update the pos() information. */
303 SV * const sv = cx->sb_targ;
305 SvUPGRADE(sv, SVt_PVMG);
306 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
307 #ifdef PERL_OLD_COPY_ON_WRITE
309 sv_force_normal_flags(sv, 0);
311 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
314 mg->mg_len = m - orig;
317 (void)ReREFCNT_inc(rx);
318 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
319 rxres_save(&cx->sb_rxres, rx);
320 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
324 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
329 PERL_ARGS_ASSERT_RXRES_SAVE;
332 if (!p || p[1] < RX_NPARENS(rx)) {
333 #ifdef PERL_OLD_COPY_ON_WRITE
334 i = 7 + RX_NPARENS(rx) * 2;
336 i = 6 + RX_NPARENS(rx) * 2;
345 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
346 RX_MATCH_COPIED_off(rx);
348 #ifdef PERL_OLD_COPY_ON_WRITE
349 *p++ = PTR2UV(RX_SAVED_COPY(rx));
350 RX_SAVED_COPY(rx) = NULL;
353 *p++ = RX_NPARENS(rx);
355 *p++ = PTR2UV(RX_SUBBEG(rx));
356 *p++ = (UV)RX_SUBLEN(rx);
357 for (i = 0; i <= RX_NPARENS(rx); ++i) {
358 *p++ = (UV)RX_OFFS(rx)[i].start;
359 *p++ = (UV)RX_OFFS(rx)[i].end;
364 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
369 PERL_ARGS_ASSERT_RXRES_RESTORE;
372 RX_MATCH_COPY_FREE(rx);
373 RX_MATCH_COPIED_set(rx, *p);
376 #ifdef PERL_OLD_COPY_ON_WRITE
377 if (RX_SAVED_COPY(rx))
378 SvREFCNT_dec (RX_SAVED_COPY(rx));
379 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
383 RX_NPARENS(rx) = *p++;
385 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
386 RX_SUBLEN(rx) = (I32)(*p++);
387 for (i = 0; i <= RX_NPARENS(rx); ++i) {
388 RX_OFFS(rx)[i].start = (I32)(*p++);
389 RX_OFFS(rx)[i].end = (I32)(*p++);
394 S_rxres_free(pTHX_ void **rsp)
396 UV * const p = (UV*)*rsp;
398 PERL_ARGS_ASSERT_RXRES_FREE;
403 void *tmp = INT2PTR(char*,*p);
406 PoisonFree(*p, 1, sizeof(*p));
408 Safefree(INT2PTR(char*,*p));
410 #ifdef PERL_OLD_COPY_ON_WRITE
412 SvREFCNT_dec (INT2PTR(SV*,p[1]));
422 dVAR; dSP; dMARK; dORIGMARK;
423 register SV * const tmpForm = *++MARK;
428 register SV *sv = NULL;
429 const char *item = NULL;
433 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
434 const char *chophere = NULL;
435 char *linemark = NULL;
437 bool gotsome = FALSE;
439 const STRLEN fudge = SvPOK(tmpForm)
440 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
441 bool item_is_utf8 = FALSE;
442 bool targ_is_utf8 = FALSE;
444 OP * parseres = NULL;
447 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
448 if (SvREADONLY(tmpForm)) {
449 SvREADONLY_off(tmpForm);
450 parseres = doparseform(tmpForm);
451 SvREADONLY_on(tmpForm);
454 parseres = doparseform(tmpForm);
458 SvPV_force(PL_formtarget, len);
459 if (DO_UTF8(PL_formtarget))
461 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
463 f = SvPV_const(tmpForm, len);
464 /* need to jump to the next word */
465 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
469 const char *name = "???";
472 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
473 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
474 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
475 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
476 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
478 case FF_CHECKNL: name = "CHECKNL"; break;
479 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
480 case FF_SPACE: name = "SPACE"; break;
481 case FF_HALFSPACE: name = "HALFSPACE"; break;
482 case FF_ITEM: name = "ITEM"; break;
483 case FF_CHOP: name = "CHOP"; break;
484 case FF_LINEGLOB: name = "LINEGLOB"; break;
485 case FF_NEWLINE: name = "NEWLINE"; break;
486 case FF_MORE: name = "MORE"; break;
487 case FF_LINEMARK: name = "LINEMARK"; break;
488 case FF_END: name = "END"; break;
489 case FF_0DECIMAL: name = "0DECIMAL"; break;
490 case FF_LINESNGL: name = "LINESNGL"; break;
493 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
495 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
506 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
507 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
509 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
510 t = SvEND(PL_formtarget);
514 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
515 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
517 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
518 t = SvEND(PL_formtarget);
538 if (ckWARN(WARN_SYNTAX))
539 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
546 const char *s = item = SvPV_const(sv, len);
549 itemsize = sv_len_utf8(sv);
550 if (itemsize != (I32)len) {
552 if (itemsize > fieldsize) {
553 itemsize = fieldsize;
554 itembytes = itemsize;
555 sv_pos_u2b(sv, &itembytes, 0);
559 send = chophere = s + itembytes;
569 sv_pos_b2u(sv, &itemsize);
573 item_is_utf8 = FALSE;
574 if (itemsize > fieldsize)
575 itemsize = fieldsize;
576 send = chophere = s + itemsize;
590 const char *s = item = SvPV_const(sv, len);
593 itemsize = sv_len_utf8(sv);
594 if (itemsize != (I32)len) {
596 if (itemsize <= fieldsize) {
597 const char *send = chophere = s + itemsize;
610 itemsize = fieldsize;
611 itembytes = itemsize;
612 sv_pos_u2b(sv, &itembytes, 0);
613 send = chophere = s + itembytes;
614 while (s < send || (s == send && isSPACE(*s))) {
624 if (strchr(PL_chopset, *s))
629 itemsize = chophere - item;
630 sv_pos_b2u(sv, &itemsize);
636 item_is_utf8 = FALSE;
637 if (itemsize <= fieldsize) {
638 const char *const send = chophere = s + itemsize;
651 itemsize = fieldsize;
652 send = chophere = s + itemsize;
653 while (s < send || (s == send && isSPACE(*s))) {
663 if (strchr(PL_chopset, *s))
668 itemsize = chophere - item;
674 arg = fieldsize - itemsize;
683 arg = fieldsize - itemsize;
694 const char *s = item;
698 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
700 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
702 t = SvEND(PL_formtarget);
706 if (UTF8_IS_CONTINUED(*s)) {
707 STRLEN skip = UTF8SKIP(s);
724 if ( !((*t++ = *s++) & ~31) )
730 if (targ_is_utf8 && !item_is_utf8) {
731 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
733 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
734 for (; t < SvEND(PL_formtarget); t++) {
747 const int ch = *t++ = *s++;
750 if ( !((*t++ = *s++) & ~31) )
759 const char *s = chophere;
773 const bool oneline = fpc[-1] == FF_LINESNGL;
774 const char *s = item = SvPV_const(sv, len);
775 item_is_utf8 = DO_UTF8(sv);
778 STRLEN to_copy = itemsize;
779 const char *const send = s + len;
780 const U8 *source = (const U8 *) s;
784 chophere = s + itemsize;
788 to_copy = s - SvPVX_const(sv) - 1;
800 if (targ_is_utf8 && !item_is_utf8) {
801 source = tmp = bytes_to_utf8(source, &to_copy);
802 SvCUR_set(PL_formtarget,
803 t - SvPVX_const(PL_formtarget));
805 if (item_is_utf8 && !targ_is_utf8) {
806 /* Upgrade targ to UTF8, and then we reduce it to
807 a problem we have a simple solution for. */
808 SvCUR_set(PL_formtarget,
809 t - SvPVX_const(PL_formtarget));
811 /* Don't need get magic. */
812 sv_utf8_upgrade_nomg(PL_formtarget);
814 SvCUR_set(PL_formtarget,
815 t - SvPVX_const(PL_formtarget));
818 /* Easy. They agree. */
819 assert (item_is_utf8 == targ_is_utf8);
821 SvGROW(PL_formtarget,
822 SvCUR(PL_formtarget) + to_copy + fudge + 1);
823 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
825 Copy(source, t, to_copy, char);
827 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
829 if (SvGMAGICAL(sv)) {
830 /* Mustn't call sv_pos_b2u() as it does a second
831 mg_get(). Is this a bug? Do we need a _flags()
833 itemsize = utf8_length(source, source + itemsize);
835 sv_pos_b2u(sv, &itemsize);
847 #if defined(USE_LONG_DOUBLE)
850 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
854 "%#0*.*f" : "%0*.*f");
859 #if defined(USE_LONG_DOUBLE)
861 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
864 ((arg & 256) ? "%#*.*f" : "%*.*f");
867 /* If the field is marked with ^ and the value is undefined,
869 if ((arg & 512) && !SvOK(sv)) {
877 /* overflow evidence */
878 if (num_overflow(value, fieldsize, arg)) {
884 /* Formats aren't yet marked for locales, so assume "yes". */
886 STORE_NUMERIC_STANDARD_SET_LOCAL();
887 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
888 RESTORE_NUMERIC_STANDARD();
895 while (t-- > linemark && *t == ' ') ;
903 if (arg) { /* repeat until fields exhausted? */
905 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
906 lines += FmLINES(PL_formtarget);
909 if (strnEQ(linemark, linemark - arg, arg))
910 DIE(aTHX_ "Runaway format");
913 SvUTF8_on(PL_formtarget);
914 FmLINES(PL_formtarget) = lines;
916 RETURNOP(cLISTOP->op_first);
927 const char *s = chophere;
928 const char *send = item + len;
930 while (isSPACE(*s) && (s < send))
935 arg = fieldsize - itemsize;
942 if (strnEQ(s1," ",3)) {
943 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
954 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
956 SvUTF8_on(PL_formtarget);
957 FmLINES(PL_formtarget) += lines;
969 if (PL_stack_base + *PL_markstack_ptr == SP) {
971 if (GIMME_V == G_SCALAR)
973 RETURNOP(PL_op->op_next->op_next);
975 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
976 pp_pushmark(); /* push dst */
977 pp_pushmark(); /* push src */
978 ENTER; /* enter outer scope */
981 if (PL_op->op_private & OPpGREP_LEX)
982 SAVESPTR(PAD_SVl(PL_op->op_targ));
985 ENTER; /* enter inner scope */
988 src = PL_stack_base[*PL_markstack_ptr];
990 if (PL_op->op_private & OPpGREP_LEX)
991 PAD_SVl(PL_op->op_targ) = src;
996 if (PL_op->op_type == OP_MAPSTART)
997 pp_pushmark(); /* push top */
998 return ((LOGOP*)PL_op->op_next)->op_other;
1004 const I32 gimme = GIMME_V;
1005 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1011 /* first, move source pointer to the next item in the source list */
1012 ++PL_markstack_ptr[-1];
1014 /* if there are new items, push them into the destination list */
1015 if (items && gimme != G_VOID) {
1016 /* might need to make room back there first */
1017 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1018 /* XXX this implementation is very pessimal because the stack
1019 * is repeatedly extended for every set of items. Is possible
1020 * to do this without any stack extension or copying at all
1021 * by maintaining a separate list over which the map iterates
1022 * (like foreach does). --gsar */
1024 /* everything in the stack after the destination list moves
1025 * towards the end the stack by the amount of room needed */
1026 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1028 /* items to shift up (accounting for the moved source pointer) */
1029 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1031 /* This optimization is by Ben Tilly and it does
1032 * things differently from what Sarathy (gsar)
1033 * is describing. The downside of this optimization is
1034 * that leaves "holes" (uninitialized and hopefully unused areas)
1035 * to the Perl stack, but on the other hand this
1036 * shouldn't be a problem. If Sarathy's idea gets
1037 * implemented, this optimization should become
1038 * irrelevant. --jhi */
1040 shift = count; /* Avoid shifting too often --Ben Tilly */
1044 dst = (SP += shift);
1045 PL_markstack_ptr[-1] += shift;
1046 *PL_markstack_ptr += shift;
1050 /* copy the new items down to the destination list */
1051 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1052 if (gimme == G_ARRAY) {
1054 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1057 /* scalar context: we don't care about which values map returns
1058 * (we use undef here). And so we certainly don't want to do mortal
1059 * copies of meaningless values. */
1060 while (items-- > 0) {
1062 *dst-- = &PL_sv_undef;
1066 LEAVE; /* exit inner scope */
1069 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1071 (void)POPMARK; /* pop top */
1072 LEAVE; /* exit outer scope */
1073 (void)POPMARK; /* pop src */
1074 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1075 (void)POPMARK; /* pop dst */
1076 SP = PL_stack_base + POPMARK; /* pop original mark */
1077 if (gimme == G_SCALAR) {
1078 if (PL_op->op_private & OPpGREP_LEX) {
1079 SV* sv = sv_newmortal();
1080 sv_setiv(sv, items);
1088 else if (gimme == G_ARRAY)
1095 ENTER; /* enter inner scope */
1098 /* set $_ to the new source item */
1099 src = PL_stack_base[PL_markstack_ptr[-1]];
1101 if (PL_op->op_private & OPpGREP_LEX)
1102 PAD_SVl(PL_op->op_targ) = src;
1106 RETURNOP(cLOGOP->op_other);
1115 if (GIMME == G_ARRAY)
1117 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1118 return cLOGOP->op_other;
1128 if (GIMME == G_ARRAY) {
1129 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1133 SV * const targ = PAD_SV(PL_op->op_targ);
1136 if (PL_op->op_private & OPpFLIP_LINENUM) {
1137 if (GvIO(PL_last_in_gv)) {
1138 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1141 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1143 flip = SvIV(sv) == SvIV(GvSV(gv));
1149 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1150 if (PL_op->op_flags & OPf_SPECIAL) {
1158 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1161 sv_setpvs(TARG, "");
1167 /* This code tries to decide if "$left .. $right" should use the
1168 magical string increment, or if the range is numeric (we make
1169 an exception for .."0" [#18165]). AMS 20021031. */
1171 #define RANGE_IS_NUMERIC(left,right) ( \
1172 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1173 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1174 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1175 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1176 && (!SvOK(right) || looks_like_number(right))))
1182 if (GIMME == G_ARRAY) {
1188 if (RANGE_IS_NUMERIC(left,right)) {
1191 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1192 (SvOK(right) && SvNV(right) > IV_MAX))
1193 DIE(aTHX_ "Range iterator outside integer range");
1204 SV * const sv = sv_2mortal(newSViv(i++));
1209 SV * const final = sv_mortalcopy(right);
1211 const char * const tmps = SvPV_const(final, len);
1213 SV *sv = sv_mortalcopy(left);
1214 SvPV_force_nolen(sv);
1215 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1217 if (strEQ(SvPVX_const(sv),tmps))
1219 sv = sv_2mortal(newSVsv(sv));
1226 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1230 if (PL_op->op_private & OPpFLIP_LINENUM) {
1231 if (GvIO(PL_last_in_gv)) {
1232 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1235 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1236 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1244 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1245 sv_catpvs(targ, "E0");
1255 static const char * const context_name[] = {
1257 NULL, /* CXt_WHEN never actually needs "block" */
1258 NULL, /* CXt_BLOCK never actually needs "block" */
1259 NULL, /* CXt_GIVEN never actually needs "block" */
1260 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1261 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1262 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1263 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1271 S_dopoptolabel(pTHX_ const char *label)
1276 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1278 for (i = cxstack_ix; i >= 0; i--) {
1279 register const PERL_CONTEXT * const cx = &cxstack[i];
1280 switch (CxTYPE(cx)) {
1286 if (ckWARN(WARN_EXITING))
1287 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1288 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1289 if (CxTYPE(cx) == CXt_NULL)
1292 case CXt_LOOP_LAZYIV:
1293 case CXt_LOOP_LAZYSV:
1295 case CXt_LOOP_PLAIN:
1296 if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
1297 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1298 (long)i, CxLABEL(cx)));
1301 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1311 Perl_dowantarray(pTHX)
1314 const I32 gimme = block_gimme();
1315 return (gimme == G_VOID) ? G_SCALAR : gimme;
1319 Perl_block_gimme(pTHX)
1322 const I32 cxix = dopoptosub(cxstack_ix);
1326 switch (cxstack[cxix].blk_gimme) {
1334 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1341 Perl_is_lvalue_sub(pTHX)
1344 const I32 cxix = dopoptosub(cxstack_ix);
1345 assert(cxix >= 0); /* We should only be called from inside subs */
1347 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1348 return CxLVAL(cxstack + cxix);
1354 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1359 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1361 for (i = startingblock; i >= 0; i--) {
1362 register const PERL_CONTEXT * const cx = &cxstk[i];
1363 switch (CxTYPE(cx)) {
1369 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1377 S_dopoptoeval(pTHX_ I32 startingblock)
1381 for (i = startingblock; i >= 0; i--) {
1382 register const PERL_CONTEXT *cx = &cxstack[i];
1383 switch (CxTYPE(cx)) {
1387 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1395 S_dopoptoloop(pTHX_ I32 startingblock)
1399 for (i = startingblock; i >= 0; i--) {
1400 register const PERL_CONTEXT * const cx = &cxstack[i];
1401 switch (CxTYPE(cx)) {
1407 if (ckWARN(WARN_EXITING))
1408 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1409 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1410 if ((CxTYPE(cx)) == CXt_NULL)
1413 case CXt_LOOP_LAZYIV:
1414 case CXt_LOOP_LAZYSV:
1416 case CXt_LOOP_PLAIN:
1417 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1425 S_dopoptogiven(pTHX_ I32 startingblock)
1429 for (i = startingblock; i >= 0; i--) {
1430 register const PERL_CONTEXT *cx = &cxstack[i];
1431 switch (CxTYPE(cx)) {
1435 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1437 case CXt_LOOP_PLAIN:
1438 assert(!CxFOREACHDEF(cx));
1440 case CXt_LOOP_LAZYIV:
1441 case CXt_LOOP_LAZYSV:
1443 if (CxFOREACHDEF(cx)) {
1444 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1453 S_dopoptowhen(pTHX_ I32 startingblock)
1457 for (i = startingblock; i >= 0; i--) {
1458 register const PERL_CONTEXT *cx = &cxstack[i];
1459 switch (CxTYPE(cx)) {
1463 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1471 Perl_dounwind(pTHX_ I32 cxix)
1476 while (cxstack_ix > cxix) {
1478 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1479 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1480 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1481 /* Note: we don't need to restore the base context info till the end. */
1482 switch (CxTYPE(cx)) {
1485 continue; /* not break */
1493 case CXt_LOOP_LAZYIV:
1494 case CXt_LOOP_LAZYSV:
1496 case CXt_LOOP_PLAIN:
1507 PERL_UNUSED_VAR(optype);
1511 Perl_qerror(pTHX_ SV *err)
1515 PERL_ARGS_ASSERT_QERROR;
1518 sv_catsv(ERRSV, err);
1520 sv_catsv(PL_errors, err);
1522 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1524 ++PL_parser->error_count;
1528 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1537 if (PL_in_eval & EVAL_KEEPERR) {
1538 static const char prefix[] = "\t(in cleanup) ";
1539 SV * const err = ERRSV;
1540 const char *e = NULL;
1543 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1545 e = SvPV_const(err, len);
1547 if (*e != *message || strNE(e,message))
1551 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1552 sv_catpvn(err, prefix, sizeof(prefix)-1);
1553 sv_catpvn(err, message, msglen);
1554 if (ckWARN(WARN_MISC)) {
1555 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1556 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s",
1557 SvPVX_const(err)+start);
1562 sv_setpvn(ERRSV, message, msglen);
1566 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1567 && PL_curstackinfo->si_prev)
1575 register PERL_CONTEXT *cx;
1578 if (cxix < cxstack_ix)
1581 POPBLOCK(cx,PL_curpm);
1582 if (CxTYPE(cx) != CXt_EVAL) {
1584 message = SvPVx_const(ERRSV, msglen);
1585 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1586 PerlIO_write(Perl_error_log, message, msglen);
1591 if (gimme == G_SCALAR)
1592 *++newsp = &PL_sv_undef;
1593 PL_stack_sp = newsp;
1597 /* LEAVE could clobber PL_curcop (see save_re_context())
1598 * XXX it might be better to find a way to avoid messing with
1599 * PL_curcop in save_re_context() instead, but this is a more
1600 * minimal fix --GSAR */
1601 PL_curcop = cx->blk_oldcop;
1603 if (optype == OP_REQUIRE) {
1604 const char* const msg = SvPVx_nolen_const(ERRSV);
1605 SV * const nsv = cx->blk_eval.old_namesv;
1606 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1608 DIE(aTHX_ "%sCompilation failed in require",
1609 *msg ? msg : "Unknown error\n");
1611 assert(CxTYPE(cx) == CXt_EVAL);
1612 return cx->blk_eval.retop;
1616 message = SvPVx_const(ERRSV, msglen);
1618 write_to_stderr(message, msglen);
1626 dVAR; dSP; dPOPTOPssrl;
1627 if (SvTRUE(left) != SvTRUE(right))
1637 register I32 cxix = dopoptosub(cxstack_ix);
1638 register const PERL_CONTEXT *cx;
1639 register const PERL_CONTEXT *ccstack = cxstack;
1640 const PERL_SI *top_si = PL_curstackinfo;
1642 const char *stashname;
1649 /* we may be in a higher stacklevel, so dig down deeper */
1650 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1651 top_si = top_si->si_prev;
1652 ccstack = top_si->si_cxstack;
1653 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1656 if (GIMME != G_ARRAY) {
1662 /* caller() should not report the automatic calls to &DB::sub */
1663 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1664 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1668 cxix = dopoptosub_at(ccstack, cxix - 1);
1671 cx = &ccstack[cxix];
1672 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1673 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1674 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1675 field below is defined for any cx. */
1676 /* caller() should not report the automatic calls to &DB::sub */
1677 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1678 cx = &ccstack[dbcxix];
1681 stashname = CopSTASHPV(cx->blk_oldcop);
1682 if (GIMME != G_ARRAY) {
1685 PUSHs(&PL_sv_undef);
1688 sv_setpv(TARG, stashname);
1697 PUSHs(&PL_sv_undef);
1699 mPUSHs(newSVpv(stashname, 0));
1700 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1701 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1704 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1705 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1706 /* So is ccstack[dbcxix]. */
1708 SV * const sv = newSV(0);
1709 gv_efullname3(sv, cvgv, NULL);
1711 PUSHs(boolSV(CxHASARGS(cx)));
1714 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1715 PUSHs(boolSV(CxHASARGS(cx)));
1719 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1722 gimme = (I32)cx->blk_gimme;
1723 if (gimme == G_VOID)
1724 PUSHs(&PL_sv_undef);
1726 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1727 if (CxTYPE(cx) == CXt_EVAL) {
1729 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1730 PUSHs(cx->blk_eval.cur_text);
1734 else if (cx->blk_eval.old_namesv) {
1735 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1738 /* eval BLOCK (try blocks have old_namesv == 0) */
1740 PUSHs(&PL_sv_undef);
1741 PUSHs(&PL_sv_undef);
1745 PUSHs(&PL_sv_undef);
1746 PUSHs(&PL_sv_undef);
1748 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1749 && CopSTASH_eq(PL_curcop, PL_debstash))
1751 AV * const ary = cx->blk_sub.argarray;
1752 const int off = AvARRAY(ary) - AvALLOC(ary);
1755 PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
1757 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1760 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1761 av_extend(PL_dbargs, AvFILLp(ary) + off);
1762 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1763 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1765 /* XXX only hints propagated via op_private are currently
1766 * visible (others are not easily accessible, since they
1767 * use the global PL_hints) */
1768 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1771 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1773 if (old_warnings == pWARN_NONE ||
1774 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1775 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1776 else if (old_warnings == pWARN_ALL ||
1777 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1778 /* Get the bit mask for $warnings::Bits{all}, because
1779 * it could have been extended by warnings::register */
1781 HV * const bits = get_hv("warnings::Bits", 0);
1782 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1783 mask = newSVsv(*bits_all);
1786 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1790 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1794 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1795 sv_2mortal(newRV_noinc(
1796 MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1797 cx->blk_oldcop->cop_hints_hash))))
1806 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1807 sv_reset(tmps, CopSTASH(PL_curcop));
1812 /* like pp_nextstate, but used instead when the debugger is active */
1817 PL_curcop = (COP*)PL_op;
1818 TAINT_NOT; /* Each statement is presumed innocent */
1819 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1822 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1823 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1826 register PERL_CONTEXT *cx;
1827 const I32 gimme = G_ARRAY;
1829 GV * const gv = PL_DBgv;
1830 register CV * const cv = GvCV(gv);
1833 DIE(aTHX_ "No DB::DB routine defined");
1835 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1836 /* don't do recursive DB::DB call */
1851 (void)(*CvXSUB(cv))(aTHX_ cv);
1858 PUSHBLOCK(cx, CXt_SUB, SP);
1860 cx->blk_sub.retop = PL_op->op_next;
1863 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1864 RETURNOP(CvSTART(cv));
1874 register PERL_CONTEXT *cx;
1875 const I32 gimme = GIMME_V;
1877 U8 cxtype = CXt_LOOP_FOR;
1885 if (PL_op->op_targ) {
1886 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1887 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1888 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1889 SVs_PADSTALE, SVs_PADSTALE);
1891 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1892 #ifndef USE_ITHREADS
1893 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1899 GV * const gv = MUTABLE_GV(POPs);
1900 svp = &GvSV(gv); /* symbol table variable */
1901 SAVEGENERICSV(*svp);
1904 iterdata = (PAD*)gv;
1908 if (PL_op->op_private & OPpITER_DEF)
1909 cxtype |= CXp_FOR_DEF;
1913 PUSHBLOCK(cx, cxtype, SP);
1915 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1917 PUSHLOOP_FOR(cx, svp, MARK, 0);
1919 if (PL_op->op_flags & OPf_STACKED) {
1920 SV *maybe_ary = POPs;
1921 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1923 SV * const right = maybe_ary;
1926 if (RANGE_IS_NUMERIC(sv,right)) {
1927 cx->cx_type &= ~CXTYPEMASK;
1928 cx->cx_type |= CXt_LOOP_LAZYIV;
1929 /* Make sure that no-one re-orders cop.h and breaks our
1931 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1932 #ifdef NV_PRESERVES_UV
1933 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1934 (SvNV(sv) > (NV)IV_MAX)))
1936 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1937 (SvNV(right) < (NV)IV_MIN))))
1939 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1942 ((SvUV(sv) > (UV)IV_MAX) ||
1943 (SvNV(sv) > (NV)UV_MAX)))))
1945 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1947 ((SvNV(right) > 0) &&
1948 ((SvUV(right) > (UV)IV_MAX) ||
1949 (SvNV(right) > (NV)UV_MAX))))))
1951 DIE(aTHX_ "Range iterator outside integer range");
1952 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1953 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1955 /* for correct -Dstv display */
1956 cx->blk_oldsp = sp - PL_stack_base;
1960 cx->cx_type &= ~CXTYPEMASK;
1961 cx->cx_type |= CXt_LOOP_LAZYSV;
1962 /* Make sure that no-one re-orders cop.h and breaks our
1964 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
1965 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
1966 cx->blk_loop.state_u.lazysv.end = right;
1967 SvREFCNT_inc(right);
1968 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
1969 /* This will do the upgrade to SVt_PV, and warn if the value
1970 is uninitialised. */
1971 (void) SvPV_nolen_const(right);
1972 /* Doing this avoids a check every time in pp_iter in pp_hot.c
1973 to replace !SvOK() with a pointer to "". */
1975 SvREFCNT_dec(right);
1976 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
1980 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
1981 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
1982 SvREFCNT_inc(maybe_ary);
1983 cx->blk_loop.state_u.ary.ix =
1984 (PL_op->op_private & OPpITER_REVERSED) ?
1985 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
1989 else { /* iterating over items on the stack */
1990 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
1991 if (PL_op->op_private & OPpITER_REVERSED) {
1992 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
1995 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2005 register PERL_CONTEXT *cx;
2006 const I32 gimme = GIMME_V;
2012 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2013 PUSHLOOP_PLAIN(cx, SP);
2021 register PERL_CONTEXT *cx;
2028 assert(CxTYPE_is_LOOP(cx));
2030 newsp = PL_stack_base + cx->blk_loop.resetsp;
2033 if (gimme == G_VOID)
2035 else if (gimme == G_SCALAR) {
2037 *++newsp = sv_mortalcopy(*SP);
2039 *++newsp = &PL_sv_undef;
2043 *++newsp = sv_mortalcopy(*++mark);
2044 TAINT_NOT; /* Each item is independent */
2050 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2051 PL_curpm = newpm; /* ... and pop $1 et al */
2062 register PERL_CONTEXT *cx;
2063 bool popsub2 = FALSE;
2064 bool clear_errsv = FALSE;
2072 const I32 cxix = dopoptosub(cxstack_ix);
2075 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2076 * sort block, which is a CXt_NULL
2079 PL_stack_base[1] = *PL_stack_sp;
2080 PL_stack_sp = PL_stack_base + 1;
2084 DIE(aTHX_ "Can't return outside a subroutine");
2086 if (cxix < cxstack_ix)
2089 if (CxMULTICALL(&cxstack[cxix])) {
2090 gimme = cxstack[cxix].blk_gimme;
2091 if (gimme == G_VOID)
2092 PL_stack_sp = PL_stack_base;
2093 else if (gimme == G_SCALAR) {
2094 PL_stack_base[1] = *PL_stack_sp;
2095 PL_stack_sp = PL_stack_base + 1;
2101 switch (CxTYPE(cx)) {
2104 retop = cx->blk_sub.retop;
2105 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2108 if (!(PL_in_eval & EVAL_KEEPERR))
2111 retop = cx->blk_eval.retop;
2115 if (optype == OP_REQUIRE &&
2116 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2118 /* Unassume the success we assumed earlier. */
2119 SV * const nsv = cx->blk_eval.old_namesv;
2120 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2121 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2126 retop = cx->blk_sub.retop;
2129 DIE(aTHX_ "panic: return");
2133 if (gimme == G_SCALAR) {
2136 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2138 *++newsp = SvREFCNT_inc(*SP);
2143 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2145 *++newsp = sv_mortalcopy(sv);
2150 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2153 *++newsp = sv_mortalcopy(*SP);
2156 *++newsp = &PL_sv_undef;
2158 else if (gimme == G_ARRAY) {
2159 while (++MARK <= SP) {
2160 *++newsp = (popsub2 && SvTEMP(*MARK))
2161 ? *MARK : sv_mortalcopy(*MARK);
2162 TAINT_NOT; /* Each item is independent */
2165 PL_stack_sp = newsp;
2168 /* Stack values are safe: */
2171 POPSUB(cx,sv); /* release CV and @_ ... */
2175 PL_curpm = newpm; /* ... and pop $1 et al */
2188 register PERL_CONTEXT *cx;
2199 if (PL_op->op_flags & OPf_SPECIAL) {
2200 cxix = dopoptoloop(cxstack_ix);
2202 DIE(aTHX_ "Can't \"last\" outside a loop block");
2205 cxix = dopoptolabel(cPVOP->op_pv);
2207 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2209 if (cxix < cxstack_ix)
2213 cxstack_ix++; /* temporarily protect top context */
2215 switch (CxTYPE(cx)) {
2216 case CXt_LOOP_LAZYIV:
2217 case CXt_LOOP_LAZYSV:
2219 case CXt_LOOP_PLAIN:
2221 newsp = PL_stack_base + cx->blk_loop.resetsp;
2222 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2226 nextop = cx->blk_sub.retop;
2230 nextop = cx->blk_eval.retop;
2234 nextop = cx->blk_sub.retop;
2237 DIE(aTHX_ "panic: last");
2241 if (gimme == G_SCALAR) {
2243 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2244 ? *SP : sv_mortalcopy(*SP);
2246 *++newsp = &PL_sv_undef;
2248 else if (gimme == G_ARRAY) {
2249 while (++MARK <= SP) {
2250 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2251 ? *MARK : sv_mortalcopy(*MARK);
2252 TAINT_NOT; /* Each item is independent */
2260 /* Stack values are safe: */
2262 case CXt_LOOP_LAZYIV:
2263 case CXt_LOOP_PLAIN:
2264 case CXt_LOOP_LAZYSV:
2266 POPLOOP(cx); /* release loop vars ... */
2270 POPSUB(cx,sv); /* release CV and @_ ... */
2273 PL_curpm = newpm; /* ... and pop $1 et al */
2276 PERL_UNUSED_VAR(optype);
2277 PERL_UNUSED_VAR(gimme);
2285 register PERL_CONTEXT *cx;
2288 if (PL_op->op_flags & OPf_SPECIAL) {
2289 cxix = dopoptoloop(cxstack_ix);
2291 DIE(aTHX_ "Can't \"next\" outside a loop block");
2294 cxix = dopoptolabel(cPVOP->op_pv);
2296 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2298 if (cxix < cxstack_ix)
2301 /* clear off anything above the scope we're re-entering, but
2302 * save the rest until after a possible continue block */
2303 inner = PL_scopestack_ix;
2305 if (PL_scopestack_ix < inner)
2306 leave_scope(PL_scopestack[PL_scopestack_ix]);
2307 PL_curcop = cx->blk_oldcop;
2308 return CX_LOOP_NEXTOP_GET(cx);
2315 register PERL_CONTEXT *cx;
2319 if (PL_op->op_flags & OPf_SPECIAL) {
2320 cxix = dopoptoloop(cxstack_ix);
2322 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2325 cxix = dopoptolabel(cPVOP->op_pv);
2327 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2329 if (cxix < cxstack_ix)
2332 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2333 if (redo_op->op_type == OP_ENTER) {
2334 /* pop one less context to avoid $x being freed in while (my $x..) */
2336 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2337 redo_op = redo_op->op_next;
2341 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2342 LEAVE_SCOPE(oldsave);
2344 PL_curcop = cx->blk_oldcop;
2349 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2353 static const char too_deep[] = "Target of goto is too deeply nested";
2355 PERL_ARGS_ASSERT_DOFINDLABEL;
2358 Perl_croak(aTHX_ too_deep);
2359 if (o->op_type == OP_LEAVE ||
2360 o->op_type == OP_SCOPE ||
2361 o->op_type == OP_LEAVELOOP ||
2362 o->op_type == OP_LEAVESUB ||
2363 o->op_type == OP_LEAVETRY)
2365 *ops++ = cUNOPo->op_first;
2367 Perl_croak(aTHX_ too_deep);
2370 if (o->op_flags & OPf_KIDS) {
2372 /* First try all the kids at this level, since that's likeliest. */
2373 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2374 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2375 CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label))
2378 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2379 if (kid == PL_lastgotoprobe)
2381 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2384 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2385 ops[-1]->op_type == OP_DBSTATE)
2390 if ((o = dofindlabel(kid, label, ops, oplimit)))
2403 register PERL_CONTEXT *cx;
2404 #define GOTO_DEPTH 64
2405 OP *enterops[GOTO_DEPTH];
2406 const char *label = NULL;
2407 const bool do_dump = (PL_op->op_type == OP_DUMP);
2408 static const char must_have_label[] = "goto must have label";
2410 if (PL_op->op_flags & OPf_STACKED) {
2411 SV * const sv = POPs;
2413 /* This egregious kludge implements goto &subroutine */
2414 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2416 register PERL_CONTEXT *cx;
2417 CV *cv = MUTABLE_CV(SvRV(sv));
2424 if (!CvROOT(cv) && !CvXSUB(cv)) {
2425 const GV * const gv = CvGV(cv);
2429 /* autoloaded stub? */
2430 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2432 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2433 GvNAMELEN(gv), FALSE);
2434 if (autogv && (cv = GvCV(autogv)))
2436 tmpstr = sv_newmortal();
2437 gv_efullname3(tmpstr, gv, NULL);
2438 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2440 DIE(aTHX_ "Goto undefined subroutine");
2443 /* First do some returnish stuff. */
2444 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2446 cxix = dopoptosub(cxstack_ix);
2448 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2449 if (cxix < cxstack_ix)
2453 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2454 if (CxTYPE(cx) == CXt_EVAL) {
2456 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2458 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2460 else if (CxMULTICALL(cx))
2461 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2462 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2463 /* put @_ back onto stack */
2464 AV* av = cx->blk_sub.argarray;
2466 items = AvFILLp(av) + 1;
2467 EXTEND(SP, items+1); /* @_ could have been extended. */
2468 Copy(AvARRAY(av), SP + 1, items, SV*);
2469 SvREFCNT_dec(GvAV(PL_defgv));
2470 GvAV(PL_defgv) = cx->blk_sub.savearray;
2472 /* abandon @_ if it got reified */
2477 av_extend(av, items-1);
2479 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2482 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2483 AV* const av = GvAV(PL_defgv);
2484 items = AvFILLp(av) + 1;
2485 EXTEND(SP, items+1); /* @_ could have been extended. */
2486 Copy(AvARRAY(av), SP + 1, items, SV*);
2490 if (CxTYPE(cx) == CXt_SUB &&
2491 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2492 SvREFCNT_dec(cx->blk_sub.cv);
2493 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2494 LEAVE_SCOPE(oldsave);
2496 /* Now do some callish stuff. */
2498 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2500 OP* const retop = cx->blk_sub.retop;
2505 for (index=0; index<items; index++)
2506 sv_2mortal(SP[-index]);
2509 /* XS subs don't have a CxSUB, so pop it */
2510 POPBLOCK(cx, PL_curpm);
2511 /* Push a mark for the start of arglist */
2514 (void)(*CvXSUB(cv))(aTHX_ cv);
2519 AV* const padlist = CvPADLIST(cv);
2520 if (CxTYPE(cx) == CXt_EVAL) {
2521 PL_in_eval = CxOLD_IN_EVAL(cx);
2522 PL_eval_root = cx->blk_eval.old_eval_root;
2523 cx->cx_type = CXt_SUB;
2525 cx->blk_sub.cv = cv;
2526 cx->blk_sub.olddepth = CvDEPTH(cv);
2529 if (CvDEPTH(cv) < 2)
2530 SvREFCNT_inc_simple_void_NN(cv);
2532 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2533 sub_crush_depth(cv);
2534 pad_push(padlist, CvDEPTH(cv));
2537 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2540 AV *const av = MUTABLE_AV(PAD_SVl(0));
2542 cx->blk_sub.savearray = GvAV(PL_defgv);
2543 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2544 CX_CURPAD_SAVE(cx->blk_sub);
2545 cx->blk_sub.argarray = av;
2547 if (items >= AvMAX(av) + 1) {
2548 SV **ary = AvALLOC(av);
2549 if (AvARRAY(av) != ary) {
2550 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2553 if (items >= AvMAX(av) + 1) {
2554 AvMAX(av) = items - 1;
2555 Renew(ary,items+1,SV*);
2561 Copy(mark,AvARRAY(av),items,SV*);
2562 AvFILLp(av) = items - 1;
2563 assert(!AvREAL(av));
2565 /* transfer 'ownership' of refcnts to new @_ */
2575 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2576 Perl_get_db_sub(aTHX_ NULL, cv);
2578 CV * const gotocv = get_cvs("DB::goto", 0);
2580 PUSHMARK( PL_stack_sp );
2581 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2586 RETURNOP(CvSTART(cv));
2590 label = SvPV_nolen_const(sv);
2591 if (!(do_dump || *label))
2592 DIE(aTHX_ must_have_label);
2595 else if (PL_op->op_flags & OPf_SPECIAL) {
2597 DIE(aTHX_ must_have_label);
2600 label = cPVOP->op_pv;
2602 if (label && *label) {
2603 OP *gotoprobe = NULL;
2604 bool leaving_eval = FALSE;
2605 bool in_block = FALSE;
2606 PERL_CONTEXT *last_eval_cx = NULL;
2610 PL_lastgotoprobe = NULL;
2612 for (ix = cxstack_ix; ix >= 0; ix--) {
2614 switch (CxTYPE(cx)) {
2616 leaving_eval = TRUE;
2617 if (!CxTRYBLOCK(cx)) {
2618 gotoprobe = (last_eval_cx ?
2619 last_eval_cx->blk_eval.old_eval_root :
2624 /* else fall through */
2625 case CXt_LOOP_LAZYIV:
2626 case CXt_LOOP_LAZYSV:
2628 case CXt_LOOP_PLAIN:
2631 gotoprobe = cx->blk_oldcop->op_sibling;
2637 gotoprobe = cx->blk_oldcop->op_sibling;
2640 gotoprobe = PL_main_root;
2643 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2644 gotoprobe = CvROOT(cx->blk_sub.cv);
2650 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2653 DIE(aTHX_ "panic: goto");
2654 gotoprobe = PL_main_root;
2658 retop = dofindlabel(gotoprobe, label,
2659 enterops, enterops + GOTO_DEPTH);
2663 PL_lastgotoprobe = gotoprobe;
2666 DIE(aTHX_ "Can't find label %s", label);
2668 /* if we're leaving an eval, check before we pop any frames
2669 that we're not going to punt, otherwise the error
2672 if (leaving_eval && *enterops && enterops[1]) {
2674 for (i = 1; enterops[i]; i++)
2675 if (enterops[i]->op_type == OP_ENTERITER)
2676 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2679 /* pop unwanted frames */
2681 if (ix < cxstack_ix) {
2688 oldsave = PL_scopestack[PL_scopestack_ix];
2689 LEAVE_SCOPE(oldsave);
2692 /* push wanted frames */
2694 if (*enterops && enterops[1]) {
2695 OP * const oldop = PL_op;
2696 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2697 for (; enterops[ix]; ix++) {
2698 PL_op = enterops[ix];
2699 /* Eventually we may want to stack the needed arguments
2700 * for each op. For now, we punt on the hard ones. */
2701 if (PL_op->op_type == OP_ENTERITER)
2702 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2703 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2711 if (!retop) retop = PL_main_start;
2713 PL_restartop = retop;
2714 PL_do_undump = TRUE;
2718 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2719 PL_do_undump = FALSE;
2736 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2738 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2741 PL_exit_flags |= PERL_EXIT_EXPECTED;
2743 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2744 if (anum || !(PL_minus_c && PL_madskills))
2749 PUSHs(&PL_sv_undef);
2756 S_save_lines(pTHX_ AV *array, SV *sv)
2758 const char *s = SvPVX_const(sv);
2759 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2762 PERL_ARGS_ASSERT_SAVE_LINES;
2764 while (s && s < send) {
2766 SV * const tmpstr = newSV_type(SVt_PVMG);
2768 t = (const char *)memchr(s, '\n', send - s);
2774 sv_setpvn(tmpstr, s, t - s);
2775 av_store(array, line++, tmpstr);
2781 S_docatch(pTHX_ OP *o)
2785 OP * const oldop = PL_op;
2789 assert(CATCH_GET == TRUE);
2796 assert(cxstack_ix >= 0);
2797 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2798 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2803 /* die caught by an inner eval - continue inner loop */
2805 /* NB XXX we rely on the old popped CxEVAL still being at the top
2806 * of the stack; the way die_where() currently works, this
2807 * assumption is valid. In theory The cur_top_env value should be
2808 * returned in another global, the way retop (aka PL_restartop)
2810 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2813 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2815 PL_op = PL_restartop;
2832 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2833 /* sv Text to convert to OP tree. */
2834 /* startop op_free() this to undo. */
2835 /* code Short string id of the caller. */
2837 /* FIXME - how much of this code is common with pp_entereval? */
2838 dVAR; dSP; /* Make POPBLOCK work. */
2844 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2845 char *tmpbuf = tbuf;
2848 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2851 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2854 lex_start(sv, NULL, FALSE);
2856 /* switch to eval mode */
2858 if (IN_PERL_COMPILETIME) {
2859 SAVECOPSTASH_FREE(&PL_compiling);
2860 CopSTASH_set(&PL_compiling, PL_curstash);
2862 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2863 SV * const sv = sv_newmortal();
2864 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2865 code, (unsigned long)++PL_evalseq,
2866 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2871 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2872 (unsigned long)++PL_evalseq);
2873 SAVECOPFILE_FREE(&PL_compiling);
2874 CopFILE_set(&PL_compiling, tmpbuf+2);
2875 SAVECOPLINE(&PL_compiling);
2876 CopLINE_set(&PL_compiling, 1);
2877 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2878 deleting the eval's FILEGV from the stash before gv_check() runs
2879 (i.e. before run-time proper). To work around the coredump that
2880 ensues, we always turn GvMULTI_on for any globals that were
2881 introduced within evals. See force_ident(). GSAR 96-10-12 */
2882 safestr = savepvn(tmpbuf, len);
2883 SAVEDELETE(PL_defstash, safestr, len);
2885 #ifdef OP_IN_REGISTER
2891 /* we get here either during compilation, or via pp_regcomp at runtime */
2892 runtime = IN_PERL_RUNTIME;
2894 runcv = find_runcv(NULL);
2897 PL_op->op_type = OP_ENTEREVAL;
2898 PL_op->op_flags = 0; /* Avoid uninit warning. */
2899 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2903 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2905 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2906 POPBLOCK(cx,PL_curpm);
2909 (*startop)->op_type = OP_NULL;
2910 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2912 /* XXX DAPM do this properly one year */
2913 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2915 if (IN_PERL_COMPILETIME)
2916 CopHINTS_set(&PL_compiling, PL_hints);
2917 #ifdef OP_IN_REGISTER
2920 PERL_UNUSED_VAR(newsp);
2921 PERL_UNUSED_VAR(optype);
2923 return PL_eval_start;
2928 =for apidoc find_runcv
2930 Locate the CV corresponding to the currently executing sub or eval.
2931 If db_seqp is non_null, skip CVs that are in the DB package and populate
2932 *db_seqp with the cop sequence number at the point that the DB:: code was
2933 entered. (allows debuggers to eval in the scope of the breakpoint rather
2934 than in the scope of the debugger itself).
2940 Perl_find_runcv(pTHX_ U32 *db_seqp)
2946 *db_seqp = PL_curcop->cop_seq;
2947 for (si = PL_curstackinfo; si; si = si->si_prev) {
2949 for (ix = si->si_cxix; ix >= 0; ix--) {
2950 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2951 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2952 CV * const cv = cx->blk_sub.cv;
2953 /* skip DB:: code */
2954 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2955 *db_seqp = cx->blk_oldcop->cop_seq;
2960 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2968 /* Compile a require/do, an eval '', or a /(?{...})/.
2969 * In the last case, startop is non-null, and contains the address of
2970 * a pointer that should be set to the just-compiled code.
2971 * outside is the lexically enclosing CV (if any) that invoked us.
2972 * Returns a bool indicating whether the compile was successful; if so,
2973 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2974 * pushes undef (also croaks if startop != NULL).
2978 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2981 OP * const saveop = PL_op;
2983 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2984 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2989 SAVESPTR(PL_compcv);
2990 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2991 CvEVAL_on(PL_compcv);
2992 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2993 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2995 CvOUTSIDE_SEQ(PL_compcv) = seq;
2996 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2998 /* set up a scratch pad */
3000 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3001 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3005 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3007 /* make sure we compile in the right package */
3009 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3010 SAVESPTR(PL_curstash);
3011 PL_curstash = CopSTASH(PL_curcop);
3013 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3014 SAVESPTR(PL_beginav);
3015 PL_beginav = newAV();
3016 SAVEFREESV(PL_beginav);
3017 SAVESPTR(PL_unitcheckav);
3018 PL_unitcheckav = newAV();
3019 SAVEFREESV(PL_unitcheckav);
3022 SAVEBOOL(PL_madskills);
3026 /* try to compile it */
3028 PL_eval_root = NULL;
3029 PL_curcop = &PL_compiling;
3030 CopARYBASE_set(PL_curcop, 0);
3031 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3032 PL_in_eval |= EVAL_KEEPERR;
3035 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
3036 SV **newsp; /* Used by POPBLOCK. */
3037 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
3038 I32 optype = 0; /* Might be reset by POPEVAL. */
3043 op_free(PL_eval_root);
3044 PL_eval_root = NULL;
3046 SP = PL_stack_base + POPMARK; /* pop original mark */
3048 POPBLOCK(cx,PL_curpm);
3052 LEAVE; /* pp_entereval knows about this LEAVE. */
3054 msg = SvPVx_nolen_const(ERRSV);
3055 if (optype == OP_REQUIRE) {
3056 const SV * const nsv = cx->blk_eval.old_namesv;
3057 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3059 Perl_croak(aTHX_ "%sCompilation failed in require",
3060 *msg ? msg : "Unknown error\n");
3063 POPBLOCK(cx,PL_curpm);
3065 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3066 (*msg ? msg : "Unknown error\n"));
3070 sv_setpvs(ERRSV, "Compilation error");
3073 PERL_UNUSED_VAR(newsp);
3074 PUSHs(&PL_sv_undef);
3078 CopLINE_set(&PL_compiling, 0);
3080 *startop = PL_eval_root;
3082 SAVEFREEOP(PL_eval_root);
3084 /* Set the context for this new optree.
3085 * If the last op is an OP_REQUIRE, force scalar context.
3086 * Otherwise, propagate the context from the eval(). */
3087 if (PL_eval_root->op_type == OP_LEAVEEVAL
3088 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3089 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3091 scalar(PL_eval_root);
3092 else if ((gimme & G_WANT) == G_VOID)
3093 scalarvoid(PL_eval_root);
3094 else if ((gimme & G_WANT) == G_ARRAY)
3097 scalar(PL_eval_root);
3099 DEBUG_x(dump_eval());
3101 /* Register with debugger: */
3102 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3103 CV * const cv = get_cvs("DB::postponed", 0);
3107 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3109 call_sv(MUTABLE_SV(cv), G_DISCARD);
3114 call_list(PL_scopestack_ix, PL_unitcheckav);
3116 /* compiled okay, so do it */
3118 CvDEPTH(PL_compcv) = 1;
3119 SP = PL_stack_base + POPMARK; /* pop original mark */
3120 PL_op = saveop; /* The caller may need it. */
3121 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3128 S_check_type_and_open(pTHX_ const char *name)
3131 const int st_rc = PerlLIO_stat(name, &st);
3133 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3135 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3139 return PerlIO_open(name, PERL_SCRIPT_MODE);
3142 #ifndef PERL_DISABLE_PMC
3144 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3148 PERL_ARGS_ASSERT_DOOPEN_PM;
3150 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3151 SV *const pmcsv = newSV(namelen + 2);
3152 char *const pmc = SvPVX(pmcsv);
3155 memcpy(pmc, name, namelen);
3157 pmc[namelen + 1] = '\0';
3159 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3160 fp = check_type_and_open(name);
3163 fp = check_type_and_open(pmc);
3165 SvREFCNT_dec(pmcsv);
3168 fp = check_type_and_open(name);
3173 # define doopen_pm(name, namelen) check_type_and_open(name)
3174 #endif /* !PERL_DISABLE_PMC */
3179 register PERL_CONTEXT *cx;
3186 int vms_unixname = 0;
3188 const char *tryname = NULL;
3190 const I32 gimme = GIMME_V;
3191 int filter_has_file = 0;
3192 PerlIO *tryrsfp = NULL;
3193 SV *filter_cache = NULL;
3194 SV *filter_state = NULL;
3195 SV *filter_sub = NULL;
3201 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3202 sv = new_version(sv);
3203 if (!sv_derived_from(PL_patchlevel, "version"))
3204 upg_version(PL_patchlevel, TRUE);
3205 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3206 if ( vcmp(sv,PL_patchlevel) <= 0 )
3207 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3208 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3211 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3214 SV * const req = SvRV(sv);
3215 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3217 /* get the left hand term */
3218 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3220 first = SvIV(*av_fetch(lav,0,0));
3221 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3222 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3223 || av_len(lav) > 1 /* FP with > 3 digits */
3224 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3226 DIE(aTHX_ "Perl %"SVf" required--this is only "
3227 "%"SVf", stopped", SVfARG(vnormal(req)),
3228 SVfARG(vnormal(PL_patchlevel)));
3230 else { /* probably 'use 5.10' or 'use 5.8' */
3231 SV * hintsv = newSV(0);
3235 second = SvIV(*av_fetch(lav,1,0));
3237 second /= second >= 600 ? 100 : 10;
3238 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3239 (int)first, (int)second,0);
3240 upg_version(hintsv, TRUE);
3242 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3243 "--this is only %"SVf", stopped",
3244 SVfARG(vnormal(req)),
3245 SVfARG(vnormal(hintsv)),
3246 SVfARG(vnormal(PL_patchlevel)));
3251 /* We do this only with use, not require. */
3253 /* If we request a version >= 5.9.5, load feature.pm with the
3254 * feature bundle that corresponds to the required version. */
3255 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3256 SV *const importsv = vnormal(sv);
3257 *SvPVX_mutable(importsv) = ':';
3259 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3262 /* If a version >= 5.11.0 is requested, strictures are on by default! */
3264 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3265 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3270 name = SvPV_const(sv, len);
3271 if (!(name && len > 0 && *name))
3272 DIE(aTHX_ "Null filename used");
3273 TAINT_PROPER("require");
3277 /* The key in the %ENV hash is in the syntax of file passed as the argument
3278 * usually this is in UNIX format, but sometimes in VMS format, which
3279 * can result in a module being pulled in more than once.
3280 * To prevent this, the key must be stored in UNIX format if the VMS
3281 * name can be translated to UNIX.
3283 if ((unixname = tounixspec(name, NULL)) != NULL) {
3284 unixlen = strlen(unixname);
3290 /* if not VMS or VMS name can not be translated to UNIX, pass it
3293 unixname = (char *) name;
3296 if (PL_op->op_type == OP_REQUIRE) {
3297 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3298 unixname, unixlen, 0);
3300 if (*svp != &PL_sv_undef)
3303 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3304 "Compilation failed in require", unixname);
3308 /* prepare to compile file */
3310 if (path_is_absolute(name)) {
3312 tryrsfp = doopen_pm(name, len);
3315 AV * const ar = GvAVn(PL_incgv);
3321 namesv = newSV_type(SVt_PV);
3322 for (i = 0; i <= AvFILL(ar); i++) {
3323 SV * const dirsv = *av_fetch(ar, i, TRUE);
3325 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3332 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3333 && !sv_isobject(loader))
3335 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3338 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3339 PTR2UV(SvRV(dirsv)), name);
3340 tryname = SvPVX_const(namesv);
3351 if (sv_isobject(loader))
3352 count = call_method("INC", G_ARRAY);
3354 count = call_sv(loader, G_ARRAY);
3357 /* Adjust file name if the hook has set an %INC entry */
3358 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3360 tryname = SvPV_nolen_const(*svp);
3369 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3370 && !isGV_with_GP(SvRV(arg))) {
3371 filter_cache = SvRV(arg);
3372 SvREFCNT_inc_simple_void_NN(filter_cache);
3379 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3383 if (isGV_with_GP(arg)) {
3384 IO * const io = GvIO((const GV *)arg);
3389 tryrsfp = IoIFP(io);
3390 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3391 PerlIO_close(IoOFP(io));
3402 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3404 SvREFCNT_inc_simple_void_NN(filter_sub);
3407 filter_state = SP[i];
3408 SvREFCNT_inc_simple_void(filter_state);
3412 if (!tryrsfp && (filter_cache || filter_sub)) {
3413 tryrsfp = PerlIO_open(BIT_BUCKET,
3428 filter_has_file = 0;
3430 SvREFCNT_dec(filter_cache);
3431 filter_cache = NULL;
3434 SvREFCNT_dec(filter_state);
3435 filter_state = NULL;
3438 SvREFCNT_dec(filter_sub);
3443 if (!path_is_absolute(name)
3449 dir = SvPV_const(dirsv, dirlen);
3457 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3459 sv_setpv(namesv, unixdir);
3460 sv_catpv(namesv, unixname);
3462 # ifdef __SYMBIAN32__
3463 if (PL_origfilename[0] &&
3464 PL_origfilename[1] == ':' &&
3465 !(dir[0] && dir[1] == ':'))
3466 Perl_sv_setpvf(aTHX_ namesv,
3471 Perl_sv_setpvf(aTHX_ namesv,
3475 /* The equivalent of
3476 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3477 but without the need to parse the format string, or
3478 call strlen on either pointer, and with the correct
3479 allocation up front. */
3481 char *tmp = SvGROW(namesv, dirlen + len + 2);
3483 memcpy(tmp, dir, dirlen);
3486 /* name came from an SV, so it will have a '\0' at the
3487 end that we can copy as part of this memcpy(). */
3488 memcpy(tmp, name, len + 1);
3490 SvCUR_set(namesv, dirlen + len + 1);
3492 /* Don't even actually have to turn SvPOK_on() as we
3493 access it directly with SvPVX() below. */
3497 TAINT_PROPER("require");
3498 tryname = SvPVX_const(namesv);
3499 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3501 if (tryname[0] == '.' && tryname[1] == '/') {
3503 while (*++tryname == '/');
3507 else if (errno == EMFILE)
3508 /* no point in trying other paths if out of handles */
3515 SAVECOPFILE_FREE(&PL_compiling);
3516 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3517 SvREFCNT_dec(namesv);
3519 if (PL_op->op_type == OP_REQUIRE) {
3520 const char *msgstr = name;
3521 if(errno == EMFILE) {
3523 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3525 msgstr = SvPV_nolen_const(msg);
3527 if (namesv) { /* did we lookup @INC? */
3528 AV * const ar = GvAVn(PL_incgv);
3530 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3531 "%s in @INC%s%s (@INC contains:",
3533 (instr(msgstr, ".h ")
3534 ? " (change .h to .ph maybe?)" : ""),
3535 (instr(msgstr, ".ph ")
3536 ? " (did you run h2ph?)" : "")
3539 for (i = 0; i <= AvFILL(ar); i++) {
3540 sv_catpvs(msg, " ");
3541 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3543 sv_catpvs(msg, ")");
3544 msgstr = SvPV_nolen_const(msg);
3547 DIE(aTHX_ "Can't locate %s", msgstr);
3553 SETERRNO(0, SS_NORMAL);
3555 /* Assume success here to prevent recursive requirement. */
3556 /* name is never assigned to again, so len is still strlen(name) */
3557 /* Check whether a hook in @INC has already filled %INC */
3559 (void)hv_store(GvHVn(PL_incgv),
3560 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3562 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3564 (void)hv_store(GvHVn(PL_incgv),
3565 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3570 lex_start(NULL, tryrsfp, TRUE);
3574 hv_clear(GvHV(PL_hintgv));
3576 SAVECOMPILEWARNINGS();
3577 if (PL_dowarn & G_WARN_ALL_ON)
3578 PL_compiling.cop_warnings = pWARN_ALL ;
3579 else if (PL_dowarn & G_WARN_ALL_OFF)
3580 PL_compiling.cop_warnings = pWARN_NONE ;
3582 PL_compiling.cop_warnings = pWARN_STD ;
3584 if (filter_sub || filter_cache) {
3585 SV * const datasv = filter_add(S_run_user_filter, NULL);
3586 IoLINES(datasv) = filter_has_file;
3587 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3588 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3589 IoFMT_GV(datasv) = MUTABLE_GV(filter_cache);
3592 /* switch to eval mode */
3593 PUSHBLOCK(cx, CXt_EVAL, SP);
3595 cx->blk_eval.retop = PL_op->op_next;
3597 SAVECOPLINE(&PL_compiling);
3598 CopLINE_set(&PL_compiling, 0);
3602 /* Store and reset encoding. */
3603 encoding = PL_encoding;
3606 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3607 op = DOCATCH(PL_eval_start);
3609 op = PL_op->op_next;
3611 /* Restore encoding. */
3612 PL_encoding = encoding;
3617 /* This is a op added to hold the hints hash for
3618 pp_entereval. The hash can be modified by the code
3619 being eval'ed, so we return a copy instead. */
3625 mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3633 register PERL_CONTEXT *cx;
3635 const I32 gimme = GIMME_V;
3636 const U32 was = PL_breakable_sub_gen;
3637 char tbuf[TYPE_DIGITS(long) + 12];
3638 char *tmpbuf = tbuf;
3642 HV *saved_hh = NULL;
3644 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3645 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3649 TAINT_IF(SvTAINTED(sv));
3650 TAINT_PROPER("eval");
3653 lex_start(sv, NULL, FALSE);
3656 /* switch to eval mode */
3658 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3659 SV * const temp_sv = sv_newmortal();
3660 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3661 (unsigned long)++PL_evalseq,
3662 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3663 tmpbuf = SvPVX(temp_sv);
3664 len = SvCUR(temp_sv);
3667 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3668 SAVECOPFILE_FREE(&PL_compiling);
3669 CopFILE_set(&PL_compiling, tmpbuf+2);
3670 SAVECOPLINE(&PL_compiling);
3671 CopLINE_set(&PL_compiling, 1);
3672 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3673 deleting the eval's FILEGV from the stash before gv_check() runs
3674 (i.e. before run-time proper). To work around the coredump that
3675 ensues, we always turn GvMULTI_on for any globals that were
3676 introduced within evals. See force_ident(). GSAR 96-10-12 */
3678 PL_hints = PL_op->op_targ;
3680 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3681 SvREFCNT_dec(GvHV(PL_hintgv));
3682 GvHV(PL_hintgv) = saved_hh;
3684 SAVECOMPILEWARNINGS();
3685 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3686 if (PL_compiling.cop_hints_hash) {
3687 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3689 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3690 if (PL_compiling.cop_hints_hash) {
3692 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3693 HINTS_REFCNT_UNLOCK;
3695 /* special case: an eval '' executed within the DB package gets lexically
3696 * placed in the first non-DB CV rather than the current CV - this
3697 * allows the debugger to execute code, find lexicals etc, in the
3698 * scope of the code being debugged. Passing &seq gets find_runcv
3699 * to do the dirty work for us */
3700 runcv = find_runcv(&seq);
3702 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3704 cx->blk_eval.retop = PL_op->op_next;
3706 /* prepare to compile string */
3708 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3709 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3712 if (doeval(gimme, NULL, runcv, seq)) {
3713 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3714 ? (PERLDB_LINE || PERLDB_SAVESRC)
3715 : PERLDB_SAVESRC_NOSUBS) {
3716 /* Retain the filegv we created. */
3718 char *const safestr = savepvn(tmpbuf, len);
3719 SAVEDELETE(PL_defstash, safestr, len);
3721 return DOCATCH(PL_eval_start);
3723 /* We have already left the scope set up earler thanks to the LEAVE
3725 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3726 ? (PERLDB_LINE || PERLDB_SAVESRC)
3727 : PERLDB_SAVESRC_INVALID) {
3728 /* Retain the filegv we created. */
3730 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3732 return PL_op->op_next;
3743 register PERL_CONTEXT *cx;
3745 const U8 save_flags = PL_op -> op_flags;
3750 retop = cx->blk_eval.retop;
3753 if (gimme == G_VOID)
3755 else if (gimme == G_SCALAR) {
3758 if (SvFLAGS(TOPs) & SVs_TEMP)
3761 *MARK = sv_mortalcopy(TOPs);
3765 *MARK = &PL_sv_undef;
3770 /* in case LEAVE wipes old return values */
3771 for (mark = newsp + 1; mark <= SP; mark++) {
3772 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3773 *mark = sv_mortalcopy(*mark);
3774 TAINT_NOT; /* Each item is independent */
3778 PL_curpm = newpm; /* Don't pop $1 et al till now */
3781 assert(CvDEPTH(PL_compcv) == 1);
3783 CvDEPTH(PL_compcv) = 0;
3786 if (optype == OP_REQUIRE &&
3787 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3789 /* Unassume the success we assumed earlier. */
3790 SV * const nsv = cx->blk_eval.old_namesv;
3791 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3792 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3793 /* die_where() did LEAVE, or we won't be here */
3797 if (!(save_flags & OPf_SPECIAL)) {
3805 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3806 close to the related Perl_create_eval_scope. */
3808 Perl_delete_eval_scope(pTHX)
3813 register PERL_CONTEXT *cx;
3820 PERL_UNUSED_VAR(newsp);
3821 PERL_UNUSED_VAR(gimme);
3822 PERL_UNUSED_VAR(optype);
3825 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3826 also needed by Perl_fold_constants. */
3828 Perl_create_eval_scope(pTHX_ U32 flags)
3831 const I32 gimme = GIMME_V;
3836 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3839 PL_in_eval = EVAL_INEVAL;
3840 if (flags & G_KEEPERR)
3841 PL_in_eval |= EVAL_KEEPERR;
3844 if (flags & G_FAKINGEVAL) {
3845 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3853 PERL_CONTEXT * const cx = create_eval_scope(0);
3854 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3855 return DOCATCH(PL_op->op_next);
3864 register PERL_CONTEXT *cx;
3869 PERL_UNUSED_VAR(optype);
3872 if (gimme == G_VOID)
3874 else if (gimme == G_SCALAR) {
3878 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3881 *MARK = sv_mortalcopy(TOPs);
3885 *MARK = &PL_sv_undef;
3890 /* in case LEAVE wipes old return values */
3892 for (mark = newsp + 1; mark <= SP; mark++) {
3893 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3894 *mark = sv_mortalcopy(*mark);
3895 TAINT_NOT; /* Each item is independent */
3899 PL_curpm = newpm; /* Don't pop $1 et al till now */
3909 register PERL_CONTEXT *cx;
3910 const I32 gimme = GIMME_V;
3915 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3917 PUSHBLOCK(cx, CXt_GIVEN, SP);
3926 register PERL_CONTEXT *cx;
3930 PERL_UNUSED_CONTEXT;
3933 assert(CxTYPE(cx) == CXt_GIVEN);
3938 PL_curpm = newpm; /* pop $1 et al */
3945 /* Helper routines used by pp_smartmatch */
3947 S_make_matcher(pTHX_ REGEXP *re)
3950 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3952 PERL_ARGS_ASSERT_MAKE_MATCHER;
3954 PM_SETRE(matcher, ReREFCNT_inc(re));
3956 SAVEFREEOP((OP *) matcher);
3963 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3968 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
3970 PL_op = (OP *) matcher;
3975 return (SvTRUEx(POPs));
3979 S_destroy_matcher(pTHX_ PMOP *matcher)
3983 PERL_ARGS_ASSERT_DESTROY_MATCHER;
3984 PERL_UNUSED_ARG(matcher);
3990 /* Do a smart match */
3993 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
3994 return do_smartmatch(NULL, NULL);
3997 /* This version of do_smartmatch() implements the
3998 * table of smart matches that is found in perlsyn.
4001 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4006 bool object_on_left = FALSE;
4007 SV *e = TOPs; /* e is for 'expression' */
4008 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4010 /* First of all, handle overload magic of the rightmost argument */
4013 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4014 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4016 tmpsv = amagic_call(d, e, smart_amg, 0);
4023 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4026 SP -= 2; /* Pop the values */
4028 /* Take care only to invoke mg_get() once for each argument.
4029 * Currently we do this by copying the SV if it's magical. */
4032 d = sv_mortalcopy(d);
4039 e = sv_mortalcopy(e);
4043 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4050 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4051 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4052 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4054 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4055 object_on_left = TRUE;
4058 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4060 if (object_on_left) {
4061 goto sm_any_sub; /* Treat objects like scalars */
4063 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4064 /* Test sub truth for each key */
4066 bool andedresults = TRUE;
4067 HV *hv = (HV*) SvRV(d);
4068 I32 numkeys = hv_iterinit(hv);
4069 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4072 while ( (he = hv_iternext(hv)) ) {
4073 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4077 PUSHs(hv_iterkeysv(he));
4079 c = call_sv(e, G_SCALAR);
4082 andedresults = FALSE;
4084 andedresults = SvTRUEx(POPs) && andedresults;
4093 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4094 /* Test sub truth for each element */
4096 bool andedresults = TRUE;
4097 AV *av = (AV*) SvRV(d);
4098 const I32 len = av_len(av);
4099 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4102 for (i = 0; i <= len; ++i) {
4103 SV * const * const svp = av_fetch(av, i, FALSE);
4104 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4111 c = call_sv(e, G_SCALAR);
4114 andedresults = FALSE;
4116 andedresults = SvTRUEx(POPs) && andedresults;
4127 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4133 c = call_sv(e, G_SCALAR);
4137 else if (SvTEMP(TOPs))
4138 SvREFCNT_inc_void(TOPs);
4145 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4146 if (object_on_left) {
4147 goto sm_any_hash; /* Treat objects like scalars */
4149 else if (!SvOK(d)) {
4150 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4153 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4154 /* Check that the key-sets are identical */
4156 HV *other_hv = MUTABLE_HV(SvRV(d));
4158 bool other_tied = FALSE;
4159 U32 this_key_count = 0,
4160 other_key_count = 0;
4161 HV *hv = MUTABLE_HV(SvRV(e));
4163 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4164 /* Tied hashes don't know how many keys they have. */
4165 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4168 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4169 HV * const temp = other_hv;
4174 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4177 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4180 /* The hashes have the same number of keys, so it suffices
4181 to check that one is a subset of the other. */
4182 (void) hv_iterinit(hv);
4183 while ( (he = hv_iternext(hv)) ) {
4184 SV *key = hv_iterkeysv(he);
4186 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4189 if(!hv_exists_ent(other_hv, key, 0)) {
4190 (void) hv_iterinit(hv); /* reset iterator */
4196 (void) hv_iterinit(other_hv);
4197 while ( hv_iternext(other_hv) )
4201 other_key_count = HvUSEDKEYS(other_hv);
4203 if (this_key_count != other_key_count)
4208 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4209 AV * const other_av = MUTABLE_AV(SvRV(d));
4210 const I32 other_len = av_len(other_av) + 1;
4212 HV *hv = MUTABLE_HV(SvRV(e));
4214 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4215 for (i = 0; i < other_len; ++i) {
4216 SV ** const svp = av_fetch(other_av, i, FALSE);
4217 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4218 if (svp) { /* ??? When can this not happen? */
4219 if (hv_exists_ent(hv, *svp, 0))
4225 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4226 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4229 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4231 HV *hv = MUTABLE_HV(SvRV(e));
4233 (void) hv_iterinit(hv);
4234 while ( (he = hv_iternext(hv)) ) {
4235 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4236 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4237 (void) hv_iterinit(hv);
4238 destroy_matcher(matcher);
4242 destroy_matcher(matcher);
4248 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4249 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4256 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4257 if (object_on_left) {
4258 goto sm_any_array; /* Treat objects like scalars */
4260 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4261 AV * const other_av = MUTABLE_AV(SvRV(e));
4262 const I32 other_len = av_len(other_av) + 1;
4265 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4266 for (i = 0; i < other_len; ++i) {
4267 SV ** const svp = av_fetch(other_av, i, FALSE);
4269 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4270 if (svp) { /* ??? When can this not happen? */
4271 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4277 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4278 AV *other_av = MUTABLE_AV(SvRV(d));
4279 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4280 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4284 const I32 other_len = av_len(other_av);
4286 if (NULL == seen_this) {
4287 seen_this = newHV();
4288 (void) sv_2mortal(MUTABLE_SV(seen_this));
4290 if (NULL == seen_other) {
4291 seen_this = newHV();
4292 (void) sv_2mortal(MUTABLE_SV(seen_other));
4294 for(i = 0; i <= other_len; ++i) {
4295 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4296 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4298 if (!this_elem || !other_elem) {
4299 if (this_elem || other_elem)
4302 else if (hv_exists_ent(seen_this,
4303 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4304 hv_exists_ent(seen_other,
4305 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4307 if (*this_elem != *other_elem)
4311 (void)hv_store_ent(seen_this,
4312 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4314 (void)hv_store_ent(seen_other,
4315 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4321 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4322 (void) do_smartmatch(seen_this, seen_other);
4324 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4333 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4334 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4337 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4338 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4341 for(i = 0; i <= this_len; ++i) {
4342 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4343 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4344 if (svp && matcher_matches_sv(matcher, *svp)) {
4345 destroy_matcher(matcher);
4349 destroy_matcher(matcher);
4353 else if (!SvOK(d)) {
4354 /* undef ~~ array */
4355 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4358 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4359 for (i = 0; i <= this_len; ++i) {
4360 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4361 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4362 if (!svp || !SvOK(*svp))
4371 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4373 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4374 for (i = 0; i <= this_len; ++i) {
4375 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4382 /* infinite recursion isn't supposed to happen here */
4383 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4384 (void) do_smartmatch(NULL, NULL);
4386 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4395 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4396 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4397 SV *t = d; d = e; e = t;
4398 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4401 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4402 SV *t = d; d = e; e = t;
4403 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4404 goto sm_regex_array;
4407 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4409 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4411 PUSHs(matcher_matches_sv(matcher, d)
4414 destroy_matcher(matcher);
4419 /* See if there is overload magic on left */
4420 else if (object_on_left && SvAMAGIC(d)) {
4422 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4423 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4426 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4434 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4437 else if (!SvOK(d)) {
4438 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4439 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4444 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4445 DEBUG_M(if (SvNIOK(e))
4446 Perl_deb(aTHX_ " applying rule Any-Num\n");
4448 Perl_deb(aTHX_ " applying rule Num-numish\n");
4450 /* numeric comparison */
4453 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4464 /* As a last resort, use string comparison */
4465 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4474 register PERL_CONTEXT *cx;
4475 const I32 gimme = GIMME_V;
4477 /* This is essentially an optimization: if the match
4478 fails, we don't want to push a context and then
4479 pop it again right away, so we skip straight
4480 to the op that follows the leavewhen.
4482 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4483 return cLOGOP->op_other->op_next;
4488 PUSHBLOCK(cx, CXt_WHEN, SP);
4497 register PERL_CONTEXT *cx;
4503 assert(CxTYPE(cx) == CXt_WHEN);
4508 PL_curpm = newpm; /* pop $1 et al */