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) {
97 #define tryAMAGICregexp(rx) \
99 if (SvROK(rx) && SvAMAGIC(rx)) { \
100 SV *sv = AMG_CALLun(rx, regexp); \
104 if (SvTYPE(sv) != SVt_REGEXP) \
105 Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
112 if (PL_op->op_flags & OPf_STACKED) {
113 /* multiple args; concatentate them */
115 tmpstr = PAD_SV(ARGTARG);
116 sv_setpvs(tmpstr, "");
117 while (++MARK <= SP) {
119 if (PL_amagic_generation) {
122 tryAMAGICregexp(msv);
124 if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
125 (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
127 sv_setsv(tmpstr, sv);
131 sv_catsv(tmpstr, msv);
138 tryAMAGICregexp(tmpstr);
141 #undef tryAMAGICregexp
144 SV * const sv = SvRV(tmpstr);
145 if (SvTYPE(sv) == SVt_REGEXP)
148 else if (SvTYPE(tmpstr) == SVt_REGEXP)
149 re = (REGEXP*) tmpstr;
152 /* The match's LHS's get-magic might need to access this op's reg-
153 exp (as is sometimes the case with $'; see bug 70764). So we
154 must call get-magic now before we replace the regexp. Hopeful-
155 ly this hack can be replaced with the approach described at
156 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
157 /msg122415.html some day. */
158 if(pm->op_type == OP_MATCH) {
160 const bool was_tainted = PL_tainted;
161 if (pm->op_flags & OPf_STACKED)
163 else if (pm->op_private & OPpTARGET_MY)
164 lhs = PAD_SV(pm->op_targ);
167 /* Restore the previous value of PL_tainted (which may have been
168 modified by get-magic), to avoid incorrectly setting the
169 RXf_TAINTED flag further down. */
170 PL_tainted = was_tainted;
173 re = reg_temp_copy(NULL, re);
174 ReREFCNT_dec(PM_GETRE(pm));
179 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
181 assert (re != (REGEXP*) &PL_sv_undef);
183 /* Check against the last compiled regexp. */
184 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
185 memNE(RX_PRECOMP(re), t, len))
187 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
188 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
192 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
194 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
196 } else if (PL_curcop->cop_hints_hash) {
197 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
199 if (ptr && SvIOK(ptr) && SvIV(ptr))
200 eng = INT2PTR(regexp_engine*,SvIV(ptr));
203 if (PL_op->op_flags & OPf_SPECIAL)
204 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
206 if (DO_UTF8(tmpstr)) {
207 assert (SvUTF8(tmpstr));
208 } else if (SvUTF8(tmpstr)) {
209 /* Not doing UTF-8, despite what the SV says. Is this only if
210 we're trapped in use 'bytes'? */
211 /* Make a copy of the octet sequence, but without the flag on,
212 as the compiler now honours the SvUTF8 flag on tmpstr. */
214 const char *const p = SvPV(tmpstr, len);
215 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
219 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
221 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
223 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
224 inside tie/overload accessors. */
230 #ifndef INCOMPLETE_TAINTS
233 RX_EXTFLAGS(re) |= RXf_TAINTED;
235 RX_EXTFLAGS(re) &= ~RXf_TAINTED;
239 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
243 #if !defined(USE_ITHREADS)
244 /* can't change the optree at runtime either */
245 /* PMf_KEEP is handled differently under threads to avoid these problems */
246 if (pm->op_pmflags & PMf_KEEP) {
247 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
248 cLOGOP->op_first->op_next = PL_op->op_next;
258 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
259 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
260 register SV * const dstr = cx->sb_dstr;
261 register char *s = cx->sb_s;
262 register char *m = cx->sb_m;
263 char *orig = cx->sb_orig;
264 register REGEXP * const rx = cx->sb_rx;
266 REGEXP *old = PM_GETRE(pm);
273 PM_SETRE(pm,ReREFCNT_inc(rx));
276 rxres_restore(&cx->sb_rxres, rx);
277 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
279 if (cx->sb_iters++) {
280 const I32 saviters = cx->sb_iters;
281 if (cx->sb_iters > cx->sb_maxiters)
282 DIE(aTHX_ "Substitution loop");
284 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
286 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
287 cx->sb_rxtainted |= 2;
288 sv_catsv_nomg(dstr, POPs);
289 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
293 if (CxONCE(cx) || s < orig ||
294 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
295 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
296 ((cx->sb_rflags & REXEC_COPY_STR)
297 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
298 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
300 SV * const targ = cx->sb_targ;
302 assert(cx->sb_strend >= s);
303 if(cx->sb_strend > s) {
304 if (DO_UTF8(dstr) && !SvUTF8(targ))
305 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
307 sv_catpvn(dstr, s, cx->sb_strend - s);
309 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
311 #ifdef PERL_OLD_COPY_ON_WRITE
313 sv_force_normal_flags(targ, SV_COW_DROP_PV);
319 SvPV_set(targ, SvPVX(dstr));
320 SvCUR_set(targ, SvCUR(dstr));
321 SvLEN_set(targ, SvLEN(dstr));
324 SvPV_set(dstr, NULL);
326 TAINT_IF(cx->sb_rxtainted & 1);
327 mPUSHi(saviters - 1);
329 (void)SvPOK_only_UTF8(targ);
330 TAINT_IF(cx->sb_rxtainted);
334 LEAVE_SCOPE(cx->sb_oldsave);
336 RETURNOP(pm->op_next);
338 cx->sb_iters = saviters;
340 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
343 cx->sb_orig = orig = RX_SUBBEG(rx);
345 cx->sb_strend = s + (cx->sb_strend - m);
347 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
349 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
350 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
352 sv_catpvn(dstr, s, m-s);
354 cx->sb_s = RX_OFFS(rx)[0].end + orig;
355 { /* Update the pos() information. */
356 SV * const sv = cx->sb_targ;
358 SvUPGRADE(sv, SVt_PVMG);
359 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
360 #ifdef PERL_OLD_COPY_ON_WRITE
362 sv_force_normal_flags(sv, 0);
364 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
367 mg->mg_len = m - orig;
370 (void)ReREFCNT_inc(rx);
371 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
372 rxres_save(&cx->sb_rxres, rx);
373 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
377 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
382 PERL_ARGS_ASSERT_RXRES_SAVE;
385 if (!p || p[1] < RX_NPARENS(rx)) {
386 #ifdef PERL_OLD_COPY_ON_WRITE
387 i = 7 + RX_NPARENS(rx) * 2;
389 i = 6 + RX_NPARENS(rx) * 2;
398 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
399 RX_MATCH_COPIED_off(rx);
401 #ifdef PERL_OLD_COPY_ON_WRITE
402 *p++ = PTR2UV(RX_SAVED_COPY(rx));
403 RX_SAVED_COPY(rx) = NULL;
406 *p++ = RX_NPARENS(rx);
408 *p++ = PTR2UV(RX_SUBBEG(rx));
409 *p++ = (UV)RX_SUBLEN(rx);
410 for (i = 0; i <= RX_NPARENS(rx); ++i) {
411 *p++ = (UV)RX_OFFS(rx)[i].start;
412 *p++ = (UV)RX_OFFS(rx)[i].end;
417 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
422 PERL_ARGS_ASSERT_RXRES_RESTORE;
425 RX_MATCH_COPY_FREE(rx);
426 RX_MATCH_COPIED_set(rx, *p);
429 #ifdef PERL_OLD_COPY_ON_WRITE
430 if (RX_SAVED_COPY(rx))
431 SvREFCNT_dec (RX_SAVED_COPY(rx));
432 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
436 RX_NPARENS(rx) = *p++;
438 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
439 RX_SUBLEN(rx) = (I32)(*p++);
440 for (i = 0; i <= RX_NPARENS(rx); ++i) {
441 RX_OFFS(rx)[i].start = (I32)(*p++);
442 RX_OFFS(rx)[i].end = (I32)(*p++);
447 S_rxres_free(pTHX_ void **rsp)
449 UV * const p = (UV*)*rsp;
451 PERL_ARGS_ASSERT_RXRES_FREE;
456 void *tmp = INT2PTR(char*,*p);
459 PoisonFree(*p, 1, sizeof(*p));
461 Safefree(INT2PTR(char*,*p));
463 #ifdef PERL_OLD_COPY_ON_WRITE
465 SvREFCNT_dec (INT2PTR(SV*,p[1]));
475 dVAR; dSP; dMARK; dORIGMARK;
476 register SV * const tmpForm = *++MARK;
481 register SV *sv = NULL;
482 const char *item = NULL;
486 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
487 const char *chophere = NULL;
488 char *linemark = NULL;
490 bool gotsome = FALSE;
492 const STRLEN fudge = SvPOK(tmpForm)
493 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
494 bool item_is_utf8 = FALSE;
495 bool targ_is_utf8 = FALSE;
497 OP * parseres = NULL;
500 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
501 if (SvREADONLY(tmpForm)) {
502 SvREADONLY_off(tmpForm);
503 parseres = doparseform(tmpForm);
504 SvREADONLY_on(tmpForm);
507 parseres = doparseform(tmpForm);
511 SvPV_force(PL_formtarget, len);
512 if (DO_UTF8(PL_formtarget))
514 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
516 f = SvPV_const(tmpForm, len);
517 /* need to jump to the next word */
518 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
522 const char *name = "???";
525 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
526 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
527 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
528 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
529 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
531 case FF_CHECKNL: name = "CHECKNL"; break;
532 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
533 case FF_SPACE: name = "SPACE"; break;
534 case FF_HALFSPACE: name = "HALFSPACE"; break;
535 case FF_ITEM: name = "ITEM"; break;
536 case FF_CHOP: name = "CHOP"; break;
537 case FF_LINEGLOB: name = "LINEGLOB"; break;
538 case FF_NEWLINE: name = "NEWLINE"; break;
539 case FF_MORE: name = "MORE"; break;
540 case FF_LINEMARK: name = "LINEMARK"; break;
541 case FF_END: name = "END"; break;
542 case FF_0DECIMAL: name = "0DECIMAL"; break;
543 case FF_LINESNGL: name = "LINESNGL"; break;
546 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
548 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
559 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
560 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
562 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
563 t = SvEND(PL_formtarget);
567 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
568 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
570 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
571 t = SvEND(PL_formtarget);
591 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
598 const char *s = item = SvPV_const(sv, len);
601 itemsize = sv_len_utf8(sv);
602 if (itemsize != (I32)len) {
604 if (itemsize > fieldsize) {
605 itemsize = fieldsize;
606 itembytes = itemsize;
607 sv_pos_u2b(sv, &itembytes, 0);
611 send = chophere = s + itembytes;
621 sv_pos_b2u(sv, &itemsize);
625 item_is_utf8 = FALSE;
626 if (itemsize > fieldsize)
627 itemsize = fieldsize;
628 send = chophere = s + itemsize;
642 const char *s = item = SvPV_const(sv, len);
645 itemsize = sv_len_utf8(sv);
646 if (itemsize != (I32)len) {
648 if (itemsize <= fieldsize) {
649 const char *send = chophere = s + itemsize;
662 itemsize = fieldsize;
663 itembytes = itemsize;
664 sv_pos_u2b(sv, &itembytes, 0);
665 send = chophere = s + itembytes;
666 while (s < send || (s == send && isSPACE(*s))) {
676 if (strchr(PL_chopset, *s))
681 itemsize = chophere - item;
682 sv_pos_b2u(sv, &itemsize);
688 item_is_utf8 = FALSE;
689 if (itemsize <= fieldsize) {
690 const char *const send = chophere = s + itemsize;
703 itemsize = fieldsize;
704 send = chophere = s + itemsize;
705 while (s < send || (s == send && isSPACE(*s))) {
715 if (strchr(PL_chopset, *s))
720 itemsize = chophere - item;
726 arg = fieldsize - itemsize;
735 arg = fieldsize - itemsize;
746 const char *s = item;
750 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
752 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
754 t = SvEND(PL_formtarget);
758 if (UTF8_IS_CONTINUED(*s)) {
759 STRLEN skip = UTF8SKIP(s);
776 if ( !((*t++ = *s++) & ~31) )
782 if (targ_is_utf8 && !item_is_utf8) {
783 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
785 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
786 for (; t < SvEND(PL_formtarget); t++) {
799 const int ch = *t++ = *s++;
802 if ( !((*t++ = *s++) & ~31) )
811 const char *s = chophere;
825 const bool oneline = fpc[-1] == FF_LINESNGL;
826 const char *s = item = SvPV_const(sv, len);
827 item_is_utf8 = DO_UTF8(sv);
830 STRLEN to_copy = itemsize;
831 const char *const send = s + len;
832 const U8 *source = (const U8 *) s;
836 chophere = s + itemsize;
840 to_copy = s - SvPVX_const(sv) - 1;
852 if (targ_is_utf8 && !item_is_utf8) {
853 source = tmp = bytes_to_utf8(source, &to_copy);
854 SvCUR_set(PL_formtarget,
855 t - SvPVX_const(PL_formtarget));
857 if (item_is_utf8 && !targ_is_utf8) {
858 /* Upgrade targ to UTF8, and then we reduce it to
859 a problem we have a simple solution for. */
860 SvCUR_set(PL_formtarget,
861 t - SvPVX_const(PL_formtarget));
863 /* Don't need get magic. */
864 sv_utf8_upgrade_nomg(PL_formtarget);
866 SvCUR_set(PL_formtarget,
867 t - SvPVX_const(PL_formtarget));
870 /* Easy. They agree. */
871 assert (item_is_utf8 == targ_is_utf8);
873 SvGROW(PL_formtarget,
874 SvCUR(PL_formtarget) + to_copy + fudge + 1);
875 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
877 Copy(source, t, to_copy, char);
879 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
881 if (SvGMAGICAL(sv)) {
882 /* Mustn't call sv_pos_b2u() as it does a second
883 mg_get(). Is this a bug? Do we need a _flags()
885 itemsize = utf8_length(source, source + itemsize);
887 sv_pos_b2u(sv, &itemsize);
899 #if defined(USE_LONG_DOUBLE)
902 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
906 "%#0*.*f" : "%0*.*f");
911 #if defined(USE_LONG_DOUBLE)
913 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
916 ((arg & 256) ? "%#*.*f" : "%*.*f");
919 /* If the field is marked with ^ and the value is undefined,
921 if ((arg & 512) && !SvOK(sv)) {
929 /* overflow evidence */
930 if (num_overflow(value, fieldsize, arg)) {
936 /* Formats aren't yet marked for locales, so assume "yes". */
938 STORE_NUMERIC_STANDARD_SET_LOCAL();
939 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
940 RESTORE_NUMERIC_STANDARD();
947 while (t-- > linemark && *t == ' ') ;
955 if (arg) { /* repeat until fields exhausted? */
957 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
958 lines += FmLINES(PL_formtarget);
960 SvUTF8_on(PL_formtarget);
961 FmLINES(PL_formtarget) = lines;
963 RETURNOP(cLISTOP->op_first);
974 const char *s = chophere;
975 const char *send = item + len;
977 while (isSPACE(*s) && (s < send))
982 arg = fieldsize - itemsize;
989 if (strnEQ(s1," ",3)) {
990 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
1001 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1003 SvUTF8_on(PL_formtarget);
1004 FmLINES(PL_formtarget) += lines;
1016 if (PL_stack_base + *PL_markstack_ptr == SP) {
1018 if (GIMME_V == G_SCALAR)
1020 RETURNOP(PL_op->op_next->op_next);
1022 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
1023 pp_pushmark(); /* push dst */
1024 pp_pushmark(); /* push src */
1025 ENTER_with_name("grep"); /* enter outer scope */
1028 if (PL_op->op_private & OPpGREP_LEX)
1029 SAVESPTR(PAD_SVl(PL_op->op_targ));
1032 ENTER_with_name("grep_item"); /* enter inner scope */
1035 src = PL_stack_base[*PL_markstack_ptr];
1037 if (PL_op->op_private & OPpGREP_LEX)
1038 PAD_SVl(PL_op->op_targ) = src;
1043 if (PL_op->op_type == OP_MAPSTART)
1044 pp_pushmark(); /* push top */
1045 return ((LOGOP*)PL_op->op_next)->op_other;
1051 const I32 gimme = GIMME_V;
1052 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1058 /* first, move source pointer to the next item in the source list */
1059 ++PL_markstack_ptr[-1];
1061 /* if there are new items, push them into the destination list */
1062 if (items && gimme != G_VOID) {
1063 /* might need to make room back there first */
1064 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1065 /* XXX this implementation is very pessimal because the stack
1066 * is repeatedly extended for every set of items. Is possible
1067 * to do this without any stack extension or copying at all
1068 * by maintaining a separate list over which the map iterates
1069 * (like foreach does). --gsar */
1071 /* everything in the stack after the destination list moves
1072 * towards the end the stack by the amount of room needed */
1073 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1075 /* items to shift up (accounting for the moved source pointer) */
1076 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1078 /* This optimization is by Ben Tilly and it does
1079 * things differently from what Sarathy (gsar)
1080 * is describing. The downside of this optimization is
1081 * that leaves "holes" (uninitialized and hopefully unused areas)
1082 * to the Perl stack, but on the other hand this
1083 * shouldn't be a problem. If Sarathy's idea gets
1084 * implemented, this optimization should become
1085 * irrelevant. --jhi */
1087 shift = count; /* Avoid shifting too often --Ben Tilly */
1091 dst = (SP += shift);
1092 PL_markstack_ptr[-1] += shift;
1093 *PL_markstack_ptr += shift;
1097 /* copy the new items down to the destination list */
1098 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1099 if (gimme == G_ARRAY) {
1101 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1104 /* scalar context: we don't care about which values map returns
1105 * (we use undef here). And so we certainly don't want to do mortal
1106 * copies of meaningless values. */
1107 while (items-- > 0) {
1109 *dst-- = &PL_sv_undef;
1113 LEAVE_with_name("grep_item"); /* exit inner scope */
1116 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1118 (void)POPMARK; /* pop top */
1119 LEAVE_with_name("grep"); /* exit outer scope */
1120 (void)POPMARK; /* pop src */
1121 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1122 (void)POPMARK; /* pop dst */
1123 SP = PL_stack_base + POPMARK; /* pop original mark */
1124 if (gimme == G_SCALAR) {
1125 if (PL_op->op_private & OPpGREP_LEX) {
1126 SV* sv = sv_newmortal();
1127 sv_setiv(sv, items);
1135 else if (gimme == G_ARRAY)
1142 ENTER_with_name("grep_item"); /* enter inner scope */
1145 /* set $_ to the new source item */
1146 src = PL_stack_base[PL_markstack_ptr[-1]];
1148 if (PL_op->op_private & OPpGREP_LEX)
1149 PAD_SVl(PL_op->op_targ) = src;
1153 RETURNOP(cLOGOP->op_other);
1162 if (GIMME == G_ARRAY)
1164 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1165 return cLOGOP->op_other;
1175 if (GIMME == G_ARRAY) {
1176 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1180 SV * const targ = PAD_SV(PL_op->op_targ);
1183 if (PL_op->op_private & OPpFLIP_LINENUM) {
1184 if (GvIO(PL_last_in_gv)) {
1185 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1188 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1190 flip = SvIV(sv) == SvIV(GvSV(gv));
1196 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1197 if (PL_op->op_flags & OPf_SPECIAL) {
1205 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1208 sv_setpvs(TARG, "");
1214 /* This code tries to decide if "$left .. $right" should use the
1215 magical string increment, or if the range is numeric (we make
1216 an exception for .."0" [#18165]). AMS 20021031. */
1218 #define RANGE_IS_NUMERIC(left,right) ( \
1219 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1220 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1221 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1222 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1223 && (!SvOK(right) || looks_like_number(right))))
1229 if (GIMME == G_ARRAY) {
1235 if (RANGE_IS_NUMERIC(left,right)) {
1238 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1239 (SvOK(right) && SvNV(right) > IV_MAX))
1240 DIE(aTHX_ "Range iterator outside integer range");
1251 SV * const sv = sv_2mortal(newSViv(i++));
1256 SV * const final = sv_mortalcopy(right);
1258 const char * const tmps = SvPV_const(final, len);
1260 SV *sv = sv_mortalcopy(left);
1261 SvPV_force_nolen(sv);
1262 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1264 if (strEQ(SvPVX_const(sv),tmps))
1266 sv = sv_2mortal(newSVsv(sv));
1273 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1277 if (PL_op->op_private & OPpFLIP_LINENUM) {
1278 if (GvIO(PL_last_in_gv)) {
1279 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1282 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1283 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1291 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1292 sv_catpvs(targ, "E0");
1302 static const char * const context_name[] = {
1304 NULL, /* CXt_WHEN never actually needs "block" */
1305 NULL, /* CXt_BLOCK never actually needs "block" */
1306 NULL, /* CXt_GIVEN never actually needs "block" */
1307 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1308 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1309 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1310 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1318 S_dopoptolabel(pTHX_ const char *label)
1323 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1325 for (i = cxstack_ix; i >= 0; i--) {
1326 register const PERL_CONTEXT * const cx = &cxstack[i];
1327 switch (CxTYPE(cx)) {
1333 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1334 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1335 if (CxTYPE(cx) == CXt_NULL)
1338 case CXt_LOOP_LAZYIV:
1339 case CXt_LOOP_LAZYSV:
1341 case CXt_LOOP_PLAIN:
1343 const char *cx_label = CxLABEL(cx);
1344 if (!cx_label || strNE(label, cx_label) ) {
1345 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1346 (long)i, cx_label));
1349 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1360 Perl_dowantarray(pTHX)
1363 const I32 gimme = block_gimme();
1364 return (gimme == G_VOID) ? G_SCALAR : gimme;
1368 Perl_block_gimme(pTHX)
1371 const I32 cxix = dopoptosub(cxstack_ix);
1375 switch (cxstack[cxix].blk_gimme) {
1383 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1390 Perl_is_lvalue_sub(pTHX)
1393 const I32 cxix = dopoptosub(cxstack_ix);
1394 assert(cxix >= 0); /* We should only be called from inside subs */
1396 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1397 return CxLVAL(cxstack + cxix);
1403 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1408 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1410 for (i = startingblock; i >= 0; i--) {
1411 register const PERL_CONTEXT * const cx = &cxstk[i];
1412 switch (CxTYPE(cx)) {
1418 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1426 S_dopoptoeval(pTHX_ I32 startingblock)
1430 for (i = startingblock; i >= 0; i--) {
1431 register const PERL_CONTEXT *cx = &cxstack[i];
1432 switch (CxTYPE(cx)) {
1436 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1444 S_dopoptoloop(pTHX_ I32 startingblock)
1448 for (i = startingblock; i >= 0; i--) {
1449 register const PERL_CONTEXT * const cx = &cxstack[i];
1450 switch (CxTYPE(cx)) {
1456 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1457 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1458 if ((CxTYPE(cx)) == CXt_NULL)
1461 case CXt_LOOP_LAZYIV:
1462 case CXt_LOOP_LAZYSV:
1464 case CXt_LOOP_PLAIN:
1465 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1473 S_dopoptogiven(pTHX_ I32 startingblock)
1477 for (i = startingblock; i >= 0; i--) {
1478 register const PERL_CONTEXT *cx = &cxstack[i];
1479 switch (CxTYPE(cx)) {
1483 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1485 case CXt_LOOP_PLAIN:
1486 assert(!CxFOREACHDEF(cx));
1488 case CXt_LOOP_LAZYIV:
1489 case CXt_LOOP_LAZYSV:
1491 if (CxFOREACHDEF(cx)) {
1492 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1501 S_dopoptowhen(pTHX_ I32 startingblock)
1505 for (i = startingblock; i >= 0; i--) {
1506 register const PERL_CONTEXT *cx = &cxstack[i];
1507 switch (CxTYPE(cx)) {
1511 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1519 Perl_dounwind(pTHX_ I32 cxix)
1524 while (cxstack_ix > cxix) {
1526 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1527 DEBUG_CX("UNWIND"); \
1528 /* Note: we don't need to restore the base context info till the end. */
1529 switch (CxTYPE(cx)) {
1532 continue; /* not break */
1540 case CXt_LOOP_LAZYIV:
1541 case CXt_LOOP_LAZYSV:
1543 case CXt_LOOP_PLAIN:
1554 PERL_UNUSED_VAR(optype);
1558 Perl_qerror(pTHX_ SV *err)
1562 PERL_ARGS_ASSERT_QERROR;
1565 sv_catsv(ERRSV, err);
1567 sv_catsv(PL_errors, err);
1569 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1571 ++PL_parser->error_count;
1575 Perl_die_unwind(pTHX_ SV *msv)
1578 SV *exceptsv = sv_mortalcopy(msv);
1579 U8 in_eval = PL_in_eval;
1580 PERL_ARGS_ASSERT_DIE_UNWIND;
1586 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1587 && PL_curstackinfo->si_prev)
1596 register PERL_CONTEXT *cx;
1599 if (cxix < cxstack_ix)
1602 POPBLOCK(cx,PL_curpm);
1603 if (CxTYPE(cx) != CXt_EVAL) {
1605 const char* message = SvPVx_const(exceptsv, msglen);
1606 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1607 PerlIO_write(Perl_error_log, message, msglen);
1611 namesv = cx->blk_eval.old_namesv;
1613 if (gimme == G_SCALAR)
1614 *++newsp = &PL_sv_undef;
1615 PL_stack_sp = newsp;
1619 /* LEAVE could clobber PL_curcop (see save_re_context())
1620 * XXX it might be better to find a way to avoid messing with
1621 * PL_curcop in save_re_context() instead, but this is a more
1622 * minimal fix --GSAR */
1623 PL_curcop = cx->blk_oldcop;
1625 if (optype == OP_REQUIRE) {
1626 const char* const msg = SvPVx_nolen_const(exceptsv);
1627 (void)hv_store(GvHVn(PL_incgv),
1628 SvPVX_const(namesv), SvCUR(namesv),
1630 /* note that unlike pp_entereval, pp_require isn't
1631 * supposed to trap errors. So now that we've popped the
1632 * EVAL that pp_require pushed, and processed the error
1633 * message, rethrow the error */
1634 DIE(aTHX_ "%sCompilation failed in require",
1635 *msg ? msg : "Unknown error\n");
1637 if (in_eval & EVAL_KEEPERR) {
1638 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1639 SvPV_nolen_const(exceptsv));
1642 sv_setsv(ERRSV, exceptsv);
1644 assert(CxTYPE(cx) == CXt_EVAL);
1645 PL_restartjmpenv = cx->blk_eval.cur_top_env;
1646 PL_restartop = cx->blk_eval.retop;
1652 write_to_stderr(exceptsv);
1659 dVAR; dSP; dPOPTOPssrl;
1660 if (SvTRUE(left) != SvTRUE(right))
1670 register I32 cxix = dopoptosub(cxstack_ix);
1671 register const PERL_CONTEXT *cx;
1672 register const PERL_CONTEXT *ccstack = cxstack;
1673 const PERL_SI *top_si = PL_curstackinfo;
1675 const char *stashname;
1682 /* we may be in a higher stacklevel, so dig down deeper */
1683 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1684 top_si = top_si->si_prev;
1685 ccstack = top_si->si_cxstack;
1686 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1689 if (GIMME != G_ARRAY) {
1695 /* caller() should not report the automatic calls to &DB::sub */
1696 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1697 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1701 cxix = dopoptosub_at(ccstack, cxix - 1);
1704 cx = &ccstack[cxix];
1705 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1706 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1707 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1708 field below is defined for any cx. */
1709 /* caller() should not report the automatic calls to &DB::sub */
1710 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1711 cx = &ccstack[dbcxix];
1714 stashname = CopSTASHPV(cx->blk_oldcop);
1715 if (GIMME != G_ARRAY) {
1718 PUSHs(&PL_sv_undef);
1721 sv_setpv(TARG, stashname);
1730 PUSHs(&PL_sv_undef);
1732 mPUSHs(newSVpv(stashname, 0));
1733 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1734 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1737 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1738 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1739 /* So is ccstack[dbcxix]. */
1741 SV * const sv = newSV(0);
1742 gv_efullname3(sv, cvgv, NULL);
1744 PUSHs(boolSV(CxHASARGS(cx)));
1747 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1748 PUSHs(boolSV(CxHASARGS(cx)));
1752 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1755 gimme = (I32)cx->blk_gimme;
1756 if (gimme == G_VOID)
1757 PUSHs(&PL_sv_undef);
1759 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1760 if (CxTYPE(cx) == CXt_EVAL) {
1762 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1763 PUSHs(cx->blk_eval.cur_text);
1767 else if (cx->blk_eval.old_namesv) {
1768 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1771 /* eval BLOCK (try blocks have old_namesv == 0) */
1773 PUSHs(&PL_sv_undef);
1774 PUSHs(&PL_sv_undef);
1778 PUSHs(&PL_sv_undef);
1779 PUSHs(&PL_sv_undef);
1781 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1782 && CopSTASH_eq(PL_curcop, PL_debstash))
1784 AV * const ary = cx->blk_sub.argarray;
1785 const int off = AvARRAY(ary) - AvALLOC(ary);
1788 PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
1790 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1793 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1794 av_extend(PL_dbargs, AvFILLp(ary) + off);
1795 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1796 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1798 /* XXX only hints propagated via op_private are currently
1799 * visible (others are not easily accessible, since they
1800 * use the global PL_hints) */
1801 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1804 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1806 if (old_warnings == pWARN_NONE ||
1807 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1808 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1809 else if (old_warnings == pWARN_ALL ||
1810 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1811 /* Get the bit mask for $warnings::Bits{all}, because
1812 * it could have been extended by warnings::register */
1814 HV * const bits = get_hv("warnings::Bits", 0);
1815 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1816 mask = newSVsv(*bits_all);
1819 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1823 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1827 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1828 sv_2mortal(newRV_noinc(
1829 MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1830 cx->blk_oldcop->cop_hints_hash))))
1839 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1840 sv_reset(tmps, CopSTASH(PL_curcop));
1845 /* like pp_nextstate, but used instead when the debugger is active */
1850 PL_curcop = (COP*)PL_op;
1851 TAINT_NOT; /* Each statement is presumed innocent */
1852 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1857 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1858 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1861 register PERL_CONTEXT *cx;
1862 const I32 gimme = G_ARRAY;
1864 GV * const gv = PL_DBgv;
1865 register CV * const cv = GvCV(gv);
1868 DIE(aTHX_ "No DB::DB routine defined");
1870 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1871 /* don't do recursive DB::DB call */
1886 (void)(*CvXSUB(cv))(aTHX_ cv);
1893 PUSHBLOCK(cx, CXt_SUB, SP);
1895 cx->blk_sub.retop = PL_op->op_next;
1898 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1899 RETURNOP(CvSTART(cv));
1909 register PERL_CONTEXT *cx;
1910 const I32 gimme = GIMME_V;
1912 U8 cxtype = CXt_LOOP_FOR;
1917 ENTER_with_name("loop1");
1920 if (PL_op->op_targ) {
1921 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1922 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1923 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1924 SVs_PADSTALE, SVs_PADSTALE);
1926 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1927 #ifndef USE_ITHREADS
1928 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1934 GV * const gv = MUTABLE_GV(POPs);
1935 svp = &GvSV(gv); /* symbol table variable */
1936 SAVEGENERICSV(*svp);
1939 iterdata = (PAD*)gv;
1943 if (PL_op->op_private & OPpITER_DEF)
1944 cxtype |= CXp_FOR_DEF;
1946 ENTER_with_name("loop2");
1948 PUSHBLOCK(cx, cxtype, SP);
1950 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1952 PUSHLOOP_FOR(cx, svp, MARK, 0);
1954 if (PL_op->op_flags & OPf_STACKED) {
1955 SV *maybe_ary = POPs;
1956 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1958 SV * const right = maybe_ary;
1961 if (RANGE_IS_NUMERIC(sv,right)) {
1962 cx->cx_type &= ~CXTYPEMASK;
1963 cx->cx_type |= CXt_LOOP_LAZYIV;
1964 /* Make sure that no-one re-orders cop.h and breaks our
1966 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1967 #ifdef NV_PRESERVES_UV
1968 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1969 (SvNV(sv) > (NV)IV_MAX)))
1971 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1972 (SvNV(right) < (NV)IV_MIN))))
1974 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1977 ((SvUV(sv) > (UV)IV_MAX) ||
1978 (SvNV(sv) > (NV)UV_MAX)))))
1980 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1982 ((SvNV(right) > 0) &&
1983 ((SvUV(right) > (UV)IV_MAX) ||
1984 (SvNV(right) > (NV)UV_MAX))))))
1986 DIE(aTHX_ "Range iterator outside integer range");
1987 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1988 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1990 /* for correct -Dstv display */
1991 cx->blk_oldsp = sp - PL_stack_base;
1995 cx->cx_type &= ~CXTYPEMASK;
1996 cx->cx_type |= CXt_LOOP_LAZYSV;
1997 /* Make sure that no-one re-orders cop.h and breaks our
1999 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2000 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2001 cx->blk_loop.state_u.lazysv.end = right;
2002 SvREFCNT_inc(right);
2003 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2004 /* This will do the upgrade to SVt_PV, and warn if the value
2005 is uninitialised. */
2006 (void) SvPV_nolen_const(right);
2007 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2008 to replace !SvOK() with a pointer to "". */
2010 SvREFCNT_dec(right);
2011 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2015 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2016 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2017 SvREFCNT_inc(maybe_ary);
2018 cx->blk_loop.state_u.ary.ix =
2019 (PL_op->op_private & OPpITER_REVERSED) ?
2020 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2024 else { /* iterating over items on the stack */
2025 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2026 if (PL_op->op_private & OPpITER_REVERSED) {
2027 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2030 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2040 register PERL_CONTEXT *cx;
2041 const I32 gimme = GIMME_V;
2043 ENTER_with_name("loop1");
2045 ENTER_with_name("loop2");
2047 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2048 PUSHLOOP_PLAIN(cx, SP);
2056 register PERL_CONTEXT *cx;
2063 assert(CxTYPE_is_LOOP(cx));
2065 newsp = PL_stack_base + cx->blk_loop.resetsp;
2068 if (gimme == G_VOID)
2070 else if (gimme == G_SCALAR) {
2072 *++newsp = sv_mortalcopy(*SP);
2074 *++newsp = &PL_sv_undef;
2078 *++newsp = sv_mortalcopy(*++mark);
2079 TAINT_NOT; /* Each item is independent */
2085 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2086 PL_curpm = newpm; /* ... and pop $1 et al */
2088 LEAVE_with_name("loop2");
2089 LEAVE_with_name("loop1");
2097 register PERL_CONTEXT *cx;
2098 bool popsub2 = FALSE;
2099 bool clear_errsv = FALSE;
2108 const I32 cxix = dopoptosub(cxstack_ix);
2111 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2112 * sort block, which is a CXt_NULL
2115 PL_stack_base[1] = *PL_stack_sp;
2116 PL_stack_sp = PL_stack_base + 1;
2120 DIE(aTHX_ "Can't return outside a subroutine");
2122 if (cxix < cxstack_ix)
2125 if (CxMULTICALL(&cxstack[cxix])) {
2126 gimme = cxstack[cxix].blk_gimme;
2127 if (gimme == G_VOID)
2128 PL_stack_sp = PL_stack_base;
2129 else if (gimme == G_SCALAR) {
2130 PL_stack_base[1] = *PL_stack_sp;
2131 PL_stack_sp = PL_stack_base + 1;
2137 switch (CxTYPE(cx)) {
2140 retop = cx->blk_sub.retop;
2141 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2144 if (!(PL_in_eval & EVAL_KEEPERR))
2147 namesv = cx->blk_eval.old_namesv;
2148 retop = cx->blk_eval.retop;
2152 if (optype == OP_REQUIRE &&
2153 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2155 /* Unassume the success we assumed earlier. */
2156 (void)hv_delete(GvHVn(PL_incgv),
2157 SvPVX_const(namesv), SvCUR(namesv),
2159 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2164 retop = cx->blk_sub.retop;
2167 DIE(aTHX_ "panic: return");
2171 if (gimme == G_SCALAR) {
2174 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2176 *++newsp = SvREFCNT_inc(*SP);
2181 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2183 *++newsp = sv_mortalcopy(sv);
2188 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2191 *++newsp = sv_mortalcopy(*SP);
2194 *++newsp = &PL_sv_undef;
2196 else if (gimme == G_ARRAY) {
2197 while (++MARK <= SP) {
2198 *++newsp = (popsub2 && SvTEMP(*MARK))
2199 ? *MARK : sv_mortalcopy(*MARK);
2200 TAINT_NOT; /* Each item is independent */
2203 PL_stack_sp = newsp;
2206 /* Stack values are safe: */
2209 POPSUB(cx,sv); /* release CV and @_ ... */
2213 PL_curpm = newpm; /* ... and pop $1 et al */
2226 register PERL_CONTEXT *cx;
2237 if (PL_op->op_flags & OPf_SPECIAL) {
2238 cxix = dopoptoloop(cxstack_ix);
2240 DIE(aTHX_ "Can't \"last\" outside a loop block");
2243 cxix = dopoptolabel(cPVOP->op_pv);
2245 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2247 if (cxix < cxstack_ix)
2251 cxstack_ix++; /* temporarily protect top context */
2253 switch (CxTYPE(cx)) {
2254 case CXt_LOOP_LAZYIV:
2255 case CXt_LOOP_LAZYSV:
2257 case CXt_LOOP_PLAIN:
2259 newsp = PL_stack_base + cx->blk_loop.resetsp;
2260 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2264 nextop = cx->blk_sub.retop;
2268 nextop = cx->blk_eval.retop;
2272 nextop = cx->blk_sub.retop;
2275 DIE(aTHX_ "panic: last");
2279 if (gimme == G_SCALAR) {
2281 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2282 ? *SP : sv_mortalcopy(*SP);
2284 *++newsp = &PL_sv_undef;
2286 else if (gimme == G_ARRAY) {
2287 while (++MARK <= SP) {
2288 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2289 ? *MARK : sv_mortalcopy(*MARK);
2290 TAINT_NOT; /* Each item is independent */
2298 /* Stack values are safe: */
2300 case CXt_LOOP_LAZYIV:
2301 case CXt_LOOP_PLAIN:
2302 case CXt_LOOP_LAZYSV:
2304 POPLOOP(cx); /* release loop vars ... */
2308 POPSUB(cx,sv); /* release CV and @_ ... */
2311 PL_curpm = newpm; /* ... and pop $1 et al */
2314 PERL_UNUSED_VAR(optype);
2315 PERL_UNUSED_VAR(gimme);
2323 register PERL_CONTEXT *cx;
2326 if (PL_op->op_flags & OPf_SPECIAL) {
2327 cxix = dopoptoloop(cxstack_ix);
2329 DIE(aTHX_ "Can't \"next\" outside a loop block");
2332 cxix = dopoptolabel(cPVOP->op_pv);
2334 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2336 if (cxix < cxstack_ix)
2339 /* clear off anything above the scope we're re-entering, but
2340 * save the rest until after a possible continue block */
2341 inner = PL_scopestack_ix;
2343 if (PL_scopestack_ix < inner)
2344 leave_scope(PL_scopestack[PL_scopestack_ix]);
2345 PL_curcop = cx->blk_oldcop;
2346 return CX_LOOP_NEXTOP_GET(cx);
2353 register PERL_CONTEXT *cx;
2357 if (PL_op->op_flags & OPf_SPECIAL) {
2358 cxix = dopoptoloop(cxstack_ix);
2360 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2363 cxix = dopoptolabel(cPVOP->op_pv);
2365 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2367 if (cxix < cxstack_ix)
2370 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2371 if (redo_op->op_type == OP_ENTER) {
2372 /* pop one less context to avoid $x being freed in while (my $x..) */
2374 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2375 redo_op = redo_op->op_next;
2379 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2380 LEAVE_SCOPE(oldsave);
2382 PL_curcop = cx->blk_oldcop;
2387 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2391 static const char too_deep[] = "Target of goto is too deeply nested";
2393 PERL_ARGS_ASSERT_DOFINDLABEL;
2396 Perl_croak(aTHX_ too_deep);
2397 if (o->op_type == OP_LEAVE ||
2398 o->op_type == OP_SCOPE ||
2399 o->op_type == OP_LEAVELOOP ||
2400 o->op_type == OP_LEAVESUB ||
2401 o->op_type == OP_LEAVETRY)
2403 *ops++ = cUNOPo->op_first;
2405 Perl_croak(aTHX_ too_deep);
2408 if (o->op_flags & OPf_KIDS) {
2410 /* First try all the kids at this level, since that's likeliest. */
2411 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2412 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2413 const char *kid_label = CopLABEL(kCOP);
2414 if (kid_label && strEQ(kid_label, label))
2418 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2419 if (kid == PL_lastgotoprobe)
2421 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2424 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2425 ops[-1]->op_type == OP_DBSTATE)
2430 if ((o = dofindlabel(kid, label, ops, oplimit)))
2443 register PERL_CONTEXT *cx;
2444 #define GOTO_DEPTH 64
2445 OP *enterops[GOTO_DEPTH];
2446 const char *label = NULL;
2447 const bool do_dump = (PL_op->op_type == OP_DUMP);
2448 static const char must_have_label[] = "goto must have label";
2450 if (PL_op->op_flags & OPf_STACKED) {
2451 SV * const sv = POPs;
2453 /* This egregious kludge implements goto &subroutine */
2454 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2456 register PERL_CONTEXT *cx;
2457 CV *cv = MUTABLE_CV(SvRV(sv));
2464 if (!CvROOT(cv) && !CvXSUB(cv)) {
2465 const GV * const gv = CvGV(cv);
2469 /* autoloaded stub? */
2470 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2472 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2473 GvNAMELEN(gv), FALSE);
2474 if (autogv && (cv = GvCV(autogv)))
2476 tmpstr = sv_newmortal();
2477 gv_efullname3(tmpstr, gv, NULL);
2478 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2480 DIE(aTHX_ "Goto undefined subroutine");
2483 /* First do some returnish stuff. */
2484 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2486 cxix = dopoptosub(cxstack_ix);
2488 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2489 if (cxix < cxstack_ix)
2493 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2494 if (CxTYPE(cx) == CXt_EVAL) {
2496 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2498 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2500 else if (CxMULTICALL(cx))
2501 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2502 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2503 /* put @_ back onto stack */
2504 AV* av = cx->blk_sub.argarray;
2506 items = AvFILLp(av) + 1;
2507 EXTEND(SP, items+1); /* @_ could have been extended. */
2508 Copy(AvARRAY(av), SP + 1, items, SV*);
2509 SvREFCNT_dec(GvAV(PL_defgv));
2510 GvAV(PL_defgv) = cx->blk_sub.savearray;
2512 /* abandon @_ if it got reified */
2517 av_extend(av, items-1);
2519 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2522 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2523 AV* const av = GvAV(PL_defgv);
2524 items = AvFILLp(av) + 1;
2525 EXTEND(SP, items+1); /* @_ could have been extended. */
2526 Copy(AvARRAY(av), SP + 1, items, SV*);
2530 if (CxTYPE(cx) == CXt_SUB &&
2531 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2532 SvREFCNT_dec(cx->blk_sub.cv);
2533 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2534 LEAVE_SCOPE(oldsave);
2536 /* Now do some callish stuff. */
2538 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2540 OP* const retop = cx->blk_sub.retop;
2545 for (index=0; index<items; index++)
2546 sv_2mortal(SP[-index]);
2549 /* XS subs don't have a CxSUB, so pop it */
2550 POPBLOCK(cx, PL_curpm);
2551 /* Push a mark for the start of arglist */
2554 (void)(*CvXSUB(cv))(aTHX_ cv);
2559 AV* const padlist = CvPADLIST(cv);
2560 if (CxTYPE(cx) == CXt_EVAL) {
2561 PL_in_eval = CxOLD_IN_EVAL(cx);
2562 PL_eval_root = cx->blk_eval.old_eval_root;
2563 cx->cx_type = CXt_SUB;
2565 cx->blk_sub.cv = cv;
2566 cx->blk_sub.olddepth = CvDEPTH(cv);
2569 if (CvDEPTH(cv) < 2)
2570 SvREFCNT_inc_simple_void_NN(cv);
2572 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2573 sub_crush_depth(cv);
2574 pad_push(padlist, CvDEPTH(cv));
2577 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2580 AV *const av = MUTABLE_AV(PAD_SVl(0));
2582 cx->blk_sub.savearray = GvAV(PL_defgv);
2583 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2584 CX_CURPAD_SAVE(cx->blk_sub);
2585 cx->blk_sub.argarray = av;
2587 if (items >= AvMAX(av) + 1) {
2588 SV **ary = AvALLOC(av);
2589 if (AvARRAY(av) != ary) {
2590 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2593 if (items >= AvMAX(av) + 1) {
2594 AvMAX(av) = items - 1;
2595 Renew(ary,items+1,SV*);
2601 Copy(mark,AvARRAY(av),items,SV*);
2602 AvFILLp(av) = items - 1;
2603 assert(!AvREAL(av));
2605 /* transfer 'ownership' of refcnts to new @_ */
2615 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2616 Perl_get_db_sub(aTHX_ NULL, cv);
2618 CV * const gotocv = get_cvs("DB::goto", 0);
2620 PUSHMARK( PL_stack_sp );
2621 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2626 RETURNOP(CvSTART(cv));
2630 label = SvPV_nolen_const(sv);
2631 if (!(do_dump || *label))
2632 DIE(aTHX_ must_have_label);
2635 else if (PL_op->op_flags & OPf_SPECIAL) {
2637 DIE(aTHX_ must_have_label);
2640 label = cPVOP->op_pv;
2644 if (label && *label) {
2645 OP *gotoprobe = NULL;
2646 bool leaving_eval = FALSE;
2647 bool in_block = FALSE;
2648 PERL_CONTEXT *last_eval_cx = NULL;
2652 PL_lastgotoprobe = NULL;
2654 for (ix = cxstack_ix; ix >= 0; ix--) {
2656 switch (CxTYPE(cx)) {
2658 leaving_eval = TRUE;
2659 if (!CxTRYBLOCK(cx)) {
2660 gotoprobe = (last_eval_cx ?
2661 last_eval_cx->blk_eval.old_eval_root :
2666 /* else fall through */
2667 case CXt_LOOP_LAZYIV:
2668 case CXt_LOOP_LAZYSV:
2670 case CXt_LOOP_PLAIN:
2673 gotoprobe = cx->blk_oldcop->op_sibling;
2679 gotoprobe = cx->blk_oldcop->op_sibling;
2682 gotoprobe = PL_main_root;
2685 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2686 gotoprobe = CvROOT(cx->blk_sub.cv);
2692 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2695 DIE(aTHX_ "panic: goto");
2696 gotoprobe = PL_main_root;
2700 retop = dofindlabel(gotoprobe, label,
2701 enterops, enterops + GOTO_DEPTH);
2705 PL_lastgotoprobe = gotoprobe;
2708 DIE(aTHX_ "Can't find label %s", label);
2710 /* if we're leaving an eval, check before we pop any frames
2711 that we're not going to punt, otherwise the error
2714 if (leaving_eval && *enterops && enterops[1]) {
2716 for (i = 1; enterops[i]; i++)
2717 if (enterops[i]->op_type == OP_ENTERITER)
2718 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2721 if (*enterops && enterops[1]) {
2722 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2724 deprecate("\"goto\" to jump into a construct");
2727 /* pop unwanted frames */
2729 if (ix < cxstack_ix) {
2736 oldsave = PL_scopestack[PL_scopestack_ix];
2737 LEAVE_SCOPE(oldsave);
2740 /* push wanted frames */
2742 if (*enterops && enterops[1]) {
2743 OP * const oldop = PL_op;
2744 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2745 for (; enterops[ix]; ix++) {
2746 PL_op = enterops[ix];
2747 /* Eventually we may want to stack the needed arguments
2748 * for each op. For now, we punt on the hard ones. */
2749 if (PL_op->op_type == OP_ENTERITER)
2750 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2751 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2759 if (!retop) retop = PL_main_start;
2761 PL_restartop = retop;
2762 PL_do_undump = TRUE;
2766 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2767 PL_do_undump = FALSE;
2784 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2786 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2789 PL_exit_flags |= PERL_EXIT_EXPECTED;
2791 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2792 if (anum || !(PL_minus_c && PL_madskills))
2797 PUSHs(&PL_sv_undef);
2804 S_save_lines(pTHX_ AV *array, SV *sv)
2806 const char *s = SvPVX_const(sv);
2807 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2810 PERL_ARGS_ASSERT_SAVE_LINES;
2812 while (s && s < send) {
2814 SV * const tmpstr = newSV_type(SVt_PVMG);
2816 t = (const char *)memchr(s, '\n', send - s);
2822 sv_setpvn(tmpstr, s, t - s);
2823 av_store(array, line++, tmpstr);
2831 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
2833 0 is used as continue inside eval,
2835 3 is used for a die caught by an inner eval - continue inner loop
2837 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
2838 establish a local jmpenv to handle exception traps.
2843 S_docatch(pTHX_ OP *o)
2847 OP * const oldop = PL_op;
2851 assert(CATCH_GET == TRUE);
2858 assert(cxstack_ix >= 0);
2859 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2860 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2865 /* die caught by an inner eval - continue inner loop */
2866 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
2867 PL_restartjmpenv = NULL;
2868 PL_op = PL_restartop;
2884 /* James Bond: Do you expect me to talk?
2885 Auric Goldfinger: No, Mr. Bond. I expect you to die.
2887 This code is an ugly hack, doesn't work with lexicals in subroutines that are
2888 called more than once, and is only used by regcomp.c, for (?{}) blocks.
2890 Currently it is not used outside the core code. Best if it stays that way.
2893 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2894 /* sv Text to convert to OP tree. */
2895 /* startop op_free() this to undo. */
2896 /* code Short string id of the caller. */
2898 dVAR; dSP; /* Make POPBLOCK work. */
2904 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2905 char *tmpbuf = tbuf;
2908 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2911 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2913 ENTER_with_name("eval");
2914 lex_start(sv, NULL, FALSE);
2916 /* switch to eval mode */
2918 if (IN_PERL_COMPILETIME) {
2919 SAVECOPSTASH_FREE(&PL_compiling);
2920 CopSTASH_set(&PL_compiling, PL_curstash);
2922 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2923 SV * const sv = sv_newmortal();
2924 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2925 code, (unsigned long)++PL_evalseq,
2926 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2931 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2932 (unsigned long)++PL_evalseq);
2933 SAVECOPFILE_FREE(&PL_compiling);
2934 CopFILE_set(&PL_compiling, tmpbuf+2);
2935 SAVECOPLINE(&PL_compiling);
2936 CopLINE_set(&PL_compiling, 1);
2937 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2938 deleting the eval's FILEGV from the stash before gv_check() runs
2939 (i.e. before run-time proper). To work around the coredump that
2940 ensues, we always turn GvMULTI_on for any globals that were
2941 introduced within evals. See force_ident(). GSAR 96-10-12 */
2942 safestr = savepvn(tmpbuf, len);
2943 SAVEDELETE(PL_defstash, safestr, len);
2945 #ifdef OP_IN_REGISTER
2951 /* we get here either during compilation, or via pp_regcomp at runtime */
2952 runtime = IN_PERL_RUNTIME;
2954 runcv = find_runcv(NULL);
2957 PL_op->op_type = OP_ENTEREVAL;
2958 PL_op->op_flags = 0; /* Avoid uninit warning. */
2959 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2963 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2965 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2966 POPBLOCK(cx,PL_curpm);
2969 (*startop)->op_type = OP_NULL;
2970 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2972 /* XXX DAPM do this properly one year */
2973 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2974 LEAVE_with_name("eval");
2975 if (IN_PERL_COMPILETIME)
2976 CopHINTS_set(&PL_compiling, PL_hints);
2977 #ifdef OP_IN_REGISTER
2980 PERL_UNUSED_VAR(newsp);
2981 PERL_UNUSED_VAR(optype);
2983 return PL_eval_start;
2988 =for apidoc find_runcv
2990 Locate the CV corresponding to the currently executing sub or eval.
2991 If db_seqp is non_null, skip CVs that are in the DB package and populate
2992 *db_seqp with the cop sequence number at the point that the DB:: code was
2993 entered. (allows debuggers to eval in the scope of the breakpoint rather
2994 than in the scope of the debugger itself).
3000 Perl_find_runcv(pTHX_ U32 *db_seqp)
3006 *db_seqp = PL_curcop->cop_seq;
3007 for (si = PL_curstackinfo; si; si = si->si_prev) {
3009 for (ix = si->si_cxix; ix >= 0; ix--) {
3010 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3011 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3012 CV * const cv = cx->blk_sub.cv;
3013 /* skip DB:: code */
3014 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3015 *db_seqp = cx->blk_oldcop->cop_seq;
3020 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3028 /* Run yyparse() in a setjmp wrapper. Returns:
3029 * 0: yyparse() successful
3030 * 1: yyparse() failed
3039 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3043 ret = yyparse() ? 1 : 0;
3057 /* Compile a require/do, an eval '', or a /(?{...})/.
3058 * In the last case, startop is non-null, and contains the address of
3059 * a pointer that should be set to the just-compiled code.
3060 * outside is the lexically enclosing CV (if any) that invoked us.
3061 * Returns a bool indicating whether the compile was successful; if so,
3062 * PL_eval_start contains the first op of the compiled ocde; otherwise,
3063 * pushes undef (also croaks if startop != NULL).
3067 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3070 OP * const saveop = PL_op;
3071 bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3074 PL_in_eval = (in_require
3075 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3080 SAVESPTR(PL_compcv);
3081 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3082 CvEVAL_on(PL_compcv);
3083 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3084 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3086 CvOUTSIDE_SEQ(PL_compcv) = seq;
3087 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3089 /* set up a scratch pad */
3091 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3092 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3096 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3098 /* make sure we compile in the right package */
3100 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3101 SAVESPTR(PL_curstash);
3102 PL_curstash = CopSTASH(PL_curcop);
3104 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3105 SAVESPTR(PL_beginav);
3106 PL_beginav = newAV();
3107 SAVEFREESV(PL_beginav);
3108 SAVESPTR(PL_unitcheckav);
3109 PL_unitcheckav = newAV();
3110 SAVEFREESV(PL_unitcheckav);
3113 SAVEBOOL(PL_madskills);
3117 /* try to compile it */
3119 PL_eval_root = NULL;
3120 PL_curcop = &PL_compiling;
3121 CopARYBASE_set(PL_curcop, 0);
3122 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3123 PL_in_eval |= EVAL_KEEPERR;
3127 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3128 * so honour CATCH_GET and trap it here if necessary */
3130 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX) : yyparse();
3132 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3133 SV **newsp; /* Used by POPBLOCK. */
3134 PERL_CONTEXT *cx = NULL;
3135 I32 optype; /* Used by POPEVAL. */
3139 PERL_UNUSED_VAR(newsp);
3140 PERL_UNUSED_VAR(optype);
3142 /* note that if yystatus == 3, then the EVAL CX block has already
3143 * been popped, and various vars restored */
3145 if (yystatus != 3) {
3147 op_free(PL_eval_root);
3148 PL_eval_root = NULL;
3150 SP = PL_stack_base + POPMARK; /* pop original mark */
3152 POPBLOCK(cx,PL_curpm);
3154 namesv = cx->blk_eval.old_namesv;
3159 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3161 msg = SvPVx_nolen_const(ERRSV);
3164 /* If cx is still NULL, it means that we didn't go in the
3165 * POPEVAL branch. */
3166 cx = &cxstack[cxstack_ix];
3167 assert(CxTYPE(cx) == CXt_EVAL);
3168 namesv = cx->blk_eval.old_namesv;
3170 (void)hv_store(GvHVn(PL_incgv),
3171 SvPVX_const(namesv), SvCUR(namesv),
3173 Perl_croak(aTHX_ "%sCompilation failed in require",
3174 *msg ? msg : "Unknown error\n");
3177 if (yystatus != 3) {
3178 POPBLOCK(cx,PL_curpm);
3181 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3182 (*msg ? msg : "Unknown error\n"));
3186 sv_setpvs(ERRSV, "Compilation error");
3189 PUSHs(&PL_sv_undef);
3193 CopLINE_set(&PL_compiling, 0);
3195 *startop = PL_eval_root;
3197 SAVEFREEOP(PL_eval_root);
3199 /* Set the context for this new optree.
3200 * Propagate the context from the eval(). */
3201 if ((gimme & G_WANT) == G_VOID)
3202 scalarvoid(PL_eval_root);
3203 else if ((gimme & G_WANT) == G_ARRAY)
3206 scalar(PL_eval_root);
3208 DEBUG_x(dump_eval());
3210 /* Register with debugger: */
3211 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3212 CV * const cv = get_cvs("DB::postponed", 0);
3216 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3218 call_sv(MUTABLE_SV(cv), G_DISCARD);
3223 call_list(PL_scopestack_ix, PL_unitcheckav);
3225 /* compiled okay, so do it */
3227 CvDEPTH(PL_compcv) = 1;
3228 SP = PL_stack_base + POPMARK; /* pop original mark */
3229 PL_op = saveop; /* The caller may need it. */
3230 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3237 S_check_type_and_open(pTHX_ const char *name)
3240 const int st_rc = PerlLIO_stat(name, &st);
3242 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3244 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3248 return PerlIO_open(name, PERL_SCRIPT_MODE);
3251 #ifndef PERL_DISABLE_PMC
3253 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3257 PERL_ARGS_ASSERT_DOOPEN_PM;
3259 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3260 SV *const pmcsv = newSV(namelen + 2);
3261 char *const pmc = SvPVX(pmcsv);
3264 memcpy(pmc, name, namelen);
3266 pmc[namelen + 1] = '\0';
3268 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3269 fp = check_type_and_open(name);
3272 fp = check_type_and_open(pmc);
3274 SvREFCNT_dec(pmcsv);
3277 fp = check_type_and_open(name);
3282 # define doopen_pm(name, namelen) check_type_and_open(name)
3283 #endif /* !PERL_DISABLE_PMC */
3288 register PERL_CONTEXT *cx;
3295 int vms_unixname = 0;
3297 const char *tryname = NULL;
3299 const I32 gimme = GIMME_V;
3300 int filter_has_file = 0;
3301 PerlIO *tryrsfp = NULL;
3302 SV *filter_cache = NULL;
3303 SV *filter_state = NULL;
3304 SV *filter_sub = NULL;
3310 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3311 sv = new_version(sv);
3312 if (!sv_derived_from(PL_patchlevel, "version"))
3313 upg_version(PL_patchlevel, TRUE);
3314 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3315 if ( vcmp(sv,PL_patchlevel) <= 0 )
3316 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3317 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3320 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3323 SV * const req = SvRV(sv);
3324 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3326 /* get the left hand term */
3327 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3329 first = SvIV(*av_fetch(lav,0,0));
3330 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3331 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3332 || av_len(lav) > 1 /* FP with > 3 digits */
3333 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3335 DIE(aTHX_ "Perl %"SVf" required--this is only "
3336 "%"SVf", stopped", SVfARG(vnormal(req)),
3337 SVfARG(vnormal(PL_patchlevel)));
3339 else { /* probably 'use 5.10' or 'use 5.8' */
3344 second = SvIV(*av_fetch(lav,1,0));
3346 second /= second >= 600 ? 100 : 10;
3347 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3348 (int)first, (int)second);
3349 upg_version(hintsv, TRUE);
3351 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3352 "--this is only %"SVf", stopped",
3353 SVfARG(vnormal(req)),
3354 SVfARG(vnormal(sv_2mortal(hintsv))),
3355 SVfARG(vnormal(PL_patchlevel)));
3360 /* We do this only with "use", not "require" or "no". */
3362 !(cUNOP->op_first->op_private & OPpCONST_NOVER) &&
3363 /* If we request a version >= 5.9.5, load feature.pm with the
3364 * feature bundle that corresponds to the required version. */
3365 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3366 SV *const importsv = vnormal(sv);
3367 *SvPVX_mutable(importsv) = ':';
3368 ENTER_with_name("load_feature");
3369 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3370 LEAVE_with_name("load_feature");
3372 /* If a version >= 5.11.0 is requested, strictures are on by default! */
3374 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3375 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3380 name = SvPV_const(sv, len);
3381 if (!(name && len > 0 && *name))
3382 DIE(aTHX_ "Null filename used");
3383 TAINT_PROPER("require");
3387 /* The key in the %ENV hash is in the syntax of file passed as the argument
3388 * usually this is in UNIX format, but sometimes in VMS format, which
3389 * can result in a module being pulled in more than once.
3390 * To prevent this, the key must be stored in UNIX format if the VMS
3391 * name can be translated to UNIX.
3393 if ((unixname = tounixspec(name, NULL)) != NULL) {
3394 unixlen = strlen(unixname);
3400 /* if not VMS or VMS name can not be translated to UNIX, pass it
3403 unixname = (char *) name;
3406 if (PL_op->op_type == OP_REQUIRE) {
3407 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3408 unixname, unixlen, 0);
3410 if (*svp != &PL_sv_undef)
3413 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3414 "Compilation failed in require", unixname);
3418 /* prepare to compile file */
3420 if (path_is_absolute(name)) {
3422 tryrsfp = doopen_pm(name, len);
3425 AV * const ar = GvAVn(PL_incgv);
3431 namesv = newSV_type(SVt_PV);
3432 for (i = 0; i <= AvFILL(ar); i++) {
3433 SV * const dirsv = *av_fetch(ar, i, TRUE);
3435 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3442 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3443 && !sv_isobject(loader))
3445 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3448 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3449 PTR2UV(SvRV(dirsv)), name);
3450 tryname = SvPVX_const(namesv);
3453 ENTER_with_name("call_INC");
3461 if (sv_isobject(loader))
3462 count = call_method("INC", G_ARRAY);
3464 count = call_sv(loader, G_ARRAY);
3467 /* Adjust file name if the hook has set an %INC entry */
3468 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3470 tryname = SvPV_nolen_const(*svp);
3479 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3480 && !isGV_with_GP(SvRV(arg))) {
3481 filter_cache = SvRV(arg);
3482 SvREFCNT_inc_simple_void_NN(filter_cache);
3489 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3493 if (isGV_with_GP(arg)) {
3494 IO * const io = GvIO((const GV *)arg);
3499 tryrsfp = IoIFP(io);
3500 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3501 PerlIO_close(IoOFP(io));
3512 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3514 SvREFCNT_inc_simple_void_NN(filter_sub);
3517 filter_state = SP[i];
3518 SvREFCNT_inc_simple_void(filter_state);
3522 if (!tryrsfp && (filter_cache || filter_sub)) {
3523 tryrsfp = PerlIO_open(BIT_BUCKET,
3531 LEAVE_with_name("call_INC");
3538 filter_has_file = 0;
3540 SvREFCNT_dec(filter_cache);
3541 filter_cache = NULL;
3544 SvREFCNT_dec(filter_state);
3545 filter_state = NULL;
3548 SvREFCNT_dec(filter_sub);
3553 if (!path_is_absolute(name)
3559 dir = SvPV_const(dirsv, dirlen);
3567 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3569 sv_setpv(namesv, unixdir);
3570 sv_catpv(namesv, unixname);
3572 # ifdef __SYMBIAN32__
3573 if (PL_origfilename[0] &&
3574 PL_origfilename[1] == ':' &&
3575 !(dir[0] && dir[1] == ':'))
3576 Perl_sv_setpvf(aTHX_ namesv,
3581 Perl_sv_setpvf(aTHX_ namesv,
3585 /* The equivalent of
3586 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3587 but without the need to parse the format string, or
3588 call strlen on either pointer, and with the correct
3589 allocation up front. */
3591 char *tmp = SvGROW(namesv, dirlen + len + 2);
3593 memcpy(tmp, dir, dirlen);
3596 /* name came from an SV, so it will have a '\0' at the
3597 end that we can copy as part of this memcpy(). */
3598 memcpy(tmp, name, len + 1);
3600 SvCUR_set(namesv, dirlen + len + 1);
3602 /* Don't even actually have to turn SvPOK_on() as we
3603 access it directly with SvPVX() below. */
3607 TAINT_PROPER("require");
3608 tryname = SvPVX_const(namesv);
3609 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3611 if (tryname[0] == '.' && tryname[1] == '/') {
3613 while (*++tryname == '/');
3617 else if (errno == EMFILE)
3618 /* no point in trying other paths if out of handles */
3625 SAVECOPFILE_FREE(&PL_compiling);
3626 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3627 SvREFCNT_dec(namesv);
3629 if (PL_op->op_type == OP_REQUIRE) {
3630 const char *msgstr = name;
3631 if(errno == EMFILE) {
3633 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3635 msgstr = SvPV_nolen_const(msg);
3637 if (namesv) { /* did we lookup @INC? */
3638 AV * const ar = GvAVn(PL_incgv);
3640 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3641 "%s in @INC%s%s (@INC contains:",
3643 (instr(msgstr, ".h ")
3644 ? " (change .h to .ph maybe?)" : ""),
3645 (instr(msgstr, ".ph ")
3646 ? " (did you run h2ph?)" : "")
3649 for (i = 0; i <= AvFILL(ar); i++) {
3650 sv_catpvs(msg, " ");
3651 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3653 sv_catpvs(msg, ")");
3654 msgstr = SvPV_nolen_const(msg);
3657 DIE(aTHX_ "Can't locate %s", msgstr);
3663 SETERRNO(0, SS_NORMAL);
3665 /* Assume success here to prevent recursive requirement. */
3666 /* name is never assigned to again, so len is still strlen(name) */
3667 /* Check whether a hook in @INC has already filled %INC */
3669 (void)hv_store(GvHVn(PL_incgv),
3670 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3672 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3674 (void)hv_store(GvHVn(PL_incgv),
3675 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3678 ENTER_with_name("eval");
3680 lex_start(NULL, tryrsfp, TRUE);
3684 hv_clear(GvHV(PL_hintgv));
3686 SAVECOMPILEWARNINGS();
3687 if (PL_dowarn & G_WARN_ALL_ON)
3688 PL_compiling.cop_warnings = pWARN_ALL ;
3689 else if (PL_dowarn & G_WARN_ALL_OFF)
3690 PL_compiling.cop_warnings = pWARN_NONE ;
3692 PL_compiling.cop_warnings = pWARN_STD ;
3694 if (filter_sub || filter_cache) {
3695 /* We can use the SvPV of the filter PVIO itself as our cache, rather
3696 than hanging another SV from it. In turn, filter_add() optionally
3697 takes the SV to use as the filter (or creates a new SV if passed
3698 NULL), so simply pass in whatever value filter_cache has. */
3699 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3700 IoLINES(datasv) = filter_has_file;
3701 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3702 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3705 /* switch to eval mode */
3706 PUSHBLOCK(cx, CXt_EVAL, SP);
3708 cx->blk_eval.retop = PL_op->op_next;
3710 SAVECOPLINE(&PL_compiling);
3711 CopLINE_set(&PL_compiling, 0);
3715 /* Store and reset encoding. */
3716 encoding = PL_encoding;
3719 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3720 op = DOCATCH(PL_eval_start);
3722 op = PL_op->op_next;
3724 /* Restore encoding. */
3725 PL_encoding = encoding;
3730 /* This is a op added to hold the hints hash for
3731 pp_entereval. The hash can be modified by the code
3732 being eval'ed, so we return a copy instead. */
3738 mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3746 register PERL_CONTEXT *cx;
3748 const I32 gimme = GIMME_V;
3749 const U32 was = PL_breakable_sub_gen;
3750 char tbuf[TYPE_DIGITS(long) + 12];
3751 char *tmpbuf = tbuf;
3755 HV *saved_hh = NULL;
3757 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3758 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3762 TAINT_IF(SvTAINTED(sv));
3763 TAINT_PROPER("eval");
3765 ENTER_with_name("eval");
3766 lex_start(sv, NULL, FALSE);
3769 /* switch to eval mode */
3771 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3772 SV * const temp_sv = sv_newmortal();
3773 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3774 (unsigned long)++PL_evalseq,
3775 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3776 tmpbuf = SvPVX(temp_sv);
3777 len = SvCUR(temp_sv);
3780 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3781 SAVECOPFILE_FREE(&PL_compiling);
3782 CopFILE_set(&PL_compiling, tmpbuf+2);
3783 SAVECOPLINE(&PL_compiling);
3784 CopLINE_set(&PL_compiling, 1);
3785 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3786 deleting the eval's FILEGV from the stash before gv_check() runs
3787 (i.e. before run-time proper). To work around the coredump that
3788 ensues, we always turn GvMULTI_on for any globals that were
3789 introduced within evals. See force_ident(). GSAR 96-10-12 */
3791 PL_hints = PL_op->op_targ;
3793 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3794 SvREFCNT_dec(GvHV(PL_hintgv));
3795 GvHV(PL_hintgv) = saved_hh;
3797 SAVECOMPILEWARNINGS();
3798 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3799 if (PL_compiling.cop_hints_hash) {
3800 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3802 if (Perl_fetch_cop_label(aTHX_ PL_curcop->cop_hints_hash, NULL, NULL)) {
3803 /* The label, if present, is the first entry on the chain. So rather
3804 than writing a blank label in front of it (which involves an
3805 allocation), just use the next entry in the chain. */
3806 PL_compiling.cop_hints_hash
3807 = PL_curcop->cop_hints_hash->refcounted_he_next;
3808 /* Check the assumption that this removed the label. */
3809 assert(Perl_fetch_cop_label(aTHX_ PL_compiling.cop_hints_hash, NULL,
3813 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3814 if (PL_compiling.cop_hints_hash) {
3816 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3817 HINTS_REFCNT_UNLOCK;
3819 /* special case: an eval '' executed within the DB package gets lexically
3820 * placed in the first non-DB CV rather than the current CV - this
3821 * allows the debugger to execute code, find lexicals etc, in the
3822 * scope of the code being debugged. Passing &seq gets find_runcv
3823 * to do the dirty work for us */
3824 runcv = find_runcv(&seq);
3826 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3828 cx->blk_eval.retop = PL_op->op_next;
3830 /* prepare to compile string */
3832 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3833 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3836 if (doeval(gimme, NULL, runcv, seq)) {
3837 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3838 ? (PERLDB_LINE || PERLDB_SAVESRC)
3839 : PERLDB_SAVESRC_NOSUBS) {
3840 /* Retain the filegv we created. */
3842 char *const safestr = savepvn(tmpbuf, len);
3843 SAVEDELETE(PL_defstash, safestr, len);
3845 return DOCATCH(PL_eval_start);
3847 /* We have already left the scope set up earler thanks to the LEAVE
3849 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3850 ? (PERLDB_LINE || PERLDB_SAVESRC)
3851 : PERLDB_SAVESRC_INVALID) {
3852 /* Retain the filegv we created. */
3854 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3856 return PL_op->op_next;
3867 register PERL_CONTEXT *cx;
3869 const U8 save_flags = PL_op -> op_flags;
3875 namesv = cx->blk_eval.old_namesv;
3876 retop = cx->blk_eval.retop;
3879 if (gimme == G_VOID)
3881 else if (gimme == G_SCALAR) {
3884 if (SvFLAGS(TOPs) & SVs_TEMP)
3887 *MARK = sv_mortalcopy(TOPs);
3891 *MARK = &PL_sv_undef;
3896 /* in case LEAVE wipes old return values */
3897 for (mark = newsp + 1; mark <= SP; mark++) {
3898 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3899 *mark = sv_mortalcopy(*mark);
3900 TAINT_NOT; /* Each item is independent */
3904 PL_curpm = newpm; /* Don't pop $1 et al till now */
3907 assert(CvDEPTH(PL_compcv) == 1);
3909 CvDEPTH(PL_compcv) = 0;
3912 if (optype == OP_REQUIRE &&
3913 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3915 /* Unassume the success we assumed earlier. */
3916 (void)hv_delete(GvHVn(PL_incgv),
3917 SvPVX_const(namesv), SvCUR(namesv),
3919 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
3921 /* die_unwind() did LEAVE, or we won't be here */
3924 LEAVE_with_name("eval");
3925 if (!(save_flags & OPf_SPECIAL)) {
3933 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3934 close to the related Perl_create_eval_scope. */
3936 Perl_delete_eval_scope(pTHX)
3941 register PERL_CONTEXT *cx;
3947 LEAVE_with_name("eval_scope");
3948 PERL_UNUSED_VAR(newsp);
3949 PERL_UNUSED_VAR(gimme);
3950 PERL_UNUSED_VAR(optype);
3953 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3954 also needed by Perl_fold_constants. */
3956 Perl_create_eval_scope(pTHX_ U32 flags)
3959 const I32 gimme = GIMME_V;
3961 ENTER_with_name("eval_scope");
3964 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3967 PL_in_eval = EVAL_INEVAL;
3968 if (flags & G_KEEPERR)
3969 PL_in_eval |= EVAL_KEEPERR;
3972 if (flags & G_FAKINGEVAL) {
3973 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3981 PERL_CONTEXT * const cx = create_eval_scope(0);
3982 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3983 return DOCATCH(PL_op->op_next);
3992 register PERL_CONTEXT *cx;
3997 PERL_UNUSED_VAR(optype);
4000 if (gimme == G_VOID)
4002 else if (gimme == G_SCALAR) {
4006 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4009 *MARK = sv_mortalcopy(TOPs);
4013 *MARK = &PL_sv_undef;
4018 /* in case LEAVE wipes old return values */
4020 for (mark = newsp + 1; mark <= SP; mark++) {
4021 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4022 *mark = sv_mortalcopy(*mark);
4023 TAINT_NOT; /* Each item is independent */
4027 PL_curpm = newpm; /* Don't pop $1 et al till now */
4029 LEAVE_with_name("eval_scope");
4037 register PERL_CONTEXT *cx;
4038 const I32 gimme = GIMME_V;
4040 ENTER_with_name("given");
4043 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
4045 PUSHBLOCK(cx, CXt_GIVEN, SP);
4054 register PERL_CONTEXT *cx;
4058 PERL_UNUSED_CONTEXT;
4061 assert(CxTYPE(cx) == CXt_GIVEN);
4064 if (gimme == G_VOID)
4066 else if (gimme == G_SCALAR) {
4070 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4073 *MARK = sv_mortalcopy(TOPs);
4077 *MARK = &PL_sv_undef;
4082 /* in case LEAVE wipes old return values */
4084 for (mark = newsp + 1; mark <= SP; mark++) {
4085 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4086 *mark = sv_mortalcopy(*mark);
4087 TAINT_NOT; /* Each item is independent */
4091 PL_curpm = newpm; /* Don't pop $1 et al till now */
4093 LEAVE_with_name("given");
4097 /* Helper routines used by pp_smartmatch */
4099 S_make_matcher(pTHX_ REGEXP *re)
4102 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4104 PERL_ARGS_ASSERT_MAKE_MATCHER;
4106 PM_SETRE(matcher, ReREFCNT_inc(re));
4108 SAVEFREEOP((OP *) matcher);
4109 ENTER_with_name("matcher"); SAVETMPS;
4115 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4120 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4122 PL_op = (OP *) matcher;
4127 return (SvTRUEx(POPs));
4131 S_destroy_matcher(pTHX_ PMOP *matcher)
4135 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4136 PERL_UNUSED_ARG(matcher);
4139 LEAVE_with_name("matcher");
4142 /* Do a smart match */
4145 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4146 return do_smartmatch(NULL, NULL);
4149 /* This version of do_smartmatch() implements the
4150 * table of smart matches that is found in perlsyn.
4153 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4158 bool object_on_left = FALSE;
4159 SV *e = TOPs; /* e is for 'expression' */
4160 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4162 /* First of all, handle overload magic of the rightmost argument */
4165 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4166 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4168 tmpsv = amagic_call(d, e, smart_amg, 0);
4175 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4178 SP -= 2; /* Pop the values */
4180 /* Take care only to invoke mg_get() once for each argument.
4181 * Currently we do this by copying the SV if it's magical. */
4184 d = sv_mortalcopy(d);
4191 e = sv_mortalcopy(e);
4195 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4202 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4203 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4204 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4206 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4207 object_on_left = TRUE;
4210 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4212 if (object_on_left) {
4213 goto sm_any_sub; /* Treat objects like scalars */
4215 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4216 /* Test sub truth for each key */
4218 bool andedresults = TRUE;
4219 HV *hv = (HV*) SvRV(d);
4220 I32 numkeys = hv_iterinit(hv);
4221 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4224 while ( (he = hv_iternext(hv)) ) {
4225 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4226 ENTER_with_name("smartmatch_hash_key_test");
4229 PUSHs(hv_iterkeysv(he));
4231 c = call_sv(e, G_SCALAR);
4234 andedresults = FALSE;
4236 andedresults = SvTRUEx(POPs) && andedresults;
4238 LEAVE_with_name("smartmatch_hash_key_test");
4245 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4246 /* Test sub truth for each element */
4248 bool andedresults = TRUE;
4249 AV *av = (AV*) SvRV(d);
4250 const I32 len = av_len(av);
4251 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4254 for (i = 0; i <= len; ++i) {
4255 SV * const * const svp = av_fetch(av, i, FALSE);
4256 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4257 ENTER_with_name("smartmatch_array_elem_test");
4263 c = call_sv(e, G_SCALAR);
4266 andedresults = FALSE;
4268 andedresults = SvTRUEx(POPs) && andedresults;
4270 LEAVE_with_name("smartmatch_array_elem_test");
4279 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4280 ENTER_with_name("smartmatch_coderef");
4285 c = call_sv(e, G_SCALAR);
4289 else if (SvTEMP(TOPs))
4290 SvREFCNT_inc_void(TOPs);
4292 LEAVE_with_name("smartmatch_coderef");
4297 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4298 if (object_on_left) {
4299 goto sm_any_hash; /* Treat objects like scalars */
4301 else if (!SvOK(d)) {
4302 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4305 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4306 /* Check that the key-sets are identical */
4308 HV *other_hv = MUTABLE_HV(SvRV(d));
4310 bool other_tied = FALSE;
4311 U32 this_key_count = 0,
4312 other_key_count = 0;
4313 HV *hv = MUTABLE_HV(SvRV(e));
4315 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4316 /* Tied hashes don't know how many keys they have. */
4317 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4320 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4321 HV * const temp = other_hv;
4326 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4329 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4332 /* The hashes have the same number of keys, so it suffices
4333 to check that one is a subset of the other. */
4334 (void) hv_iterinit(hv);
4335 while ( (he = hv_iternext(hv)) ) {
4336 SV *key = hv_iterkeysv(he);
4338 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4341 if(!hv_exists_ent(other_hv, key, 0)) {
4342 (void) hv_iterinit(hv); /* reset iterator */
4348 (void) hv_iterinit(other_hv);
4349 while ( hv_iternext(other_hv) )
4353 other_key_count = HvUSEDKEYS(other_hv);
4355 if (this_key_count != other_key_count)
4360 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4361 AV * const other_av = MUTABLE_AV(SvRV(d));
4362 const I32 other_len = av_len(other_av) + 1;
4364 HV *hv = MUTABLE_HV(SvRV(e));
4366 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4367 for (i = 0; i < other_len; ++i) {
4368 SV ** const svp = av_fetch(other_av, i, FALSE);
4369 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4370 if (svp) { /* ??? When can this not happen? */
4371 if (hv_exists_ent(hv, *svp, 0))
4377 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4378 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4381 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4383 HV *hv = MUTABLE_HV(SvRV(e));
4385 (void) hv_iterinit(hv);
4386 while ( (he = hv_iternext(hv)) ) {
4387 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4388 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4389 (void) hv_iterinit(hv);
4390 destroy_matcher(matcher);
4394 destroy_matcher(matcher);
4400 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4401 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4408 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4409 if (object_on_left) {
4410 goto sm_any_array; /* Treat objects like scalars */
4412 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4413 AV * const other_av = MUTABLE_AV(SvRV(e));
4414 const I32 other_len = av_len(other_av) + 1;
4417 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4418 for (i = 0; i < other_len; ++i) {
4419 SV ** const svp = av_fetch(other_av, i, FALSE);
4421 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4422 if (svp) { /* ??? When can this not happen? */
4423 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4429 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4430 AV *other_av = MUTABLE_AV(SvRV(d));
4431 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4432 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4436 const I32 other_len = av_len(other_av);
4438 if (NULL == seen_this) {
4439 seen_this = newHV();
4440 (void) sv_2mortal(MUTABLE_SV(seen_this));
4442 if (NULL == seen_other) {
4443 seen_other = newHV();
4444 (void) sv_2mortal(MUTABLE_SV(seen_other));
4446 for(i = 0; i <= other_len; ++i) {
4447 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4448 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4450 if (!this_elem || !other_elem) {
4451 if ((this_elem && SvOK(*this_elem))
4452 || (other_elem && SvOK(*other_elem)))
4455 else if (hv_exists_ent(seen_this,
4456 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4457 hv_exists_ent(seen_other,
4458 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4460 if (*this_elem != *other_elem)
4464 (void)hv_store_ent(seen_this,
4465 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4467 (void)hv_store_ent(seen_other,
4468 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4474 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4475 (void) do_smartmatch(seen_this, seen_other);
4477 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4486 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4487 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4490 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4491 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4494 for(i = 0; i <= this_len; ++i) {
4495 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4496 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4497 if (svp && matcher_matches_sv(matcher, *svp)) {
4498 destroy_matcher(matcher);
4502 destroy_matcher(matcher);
4506 else if (!SvOK(d)) {
4507 /* undef ~~ array */
4508 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4511 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4512 for (i = 0; i <= this_len; ++i) {
4513 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4514 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4515 if (!svp || !SvOK(*svp))
4524 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4526 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4527 for (i = 0; i <= this_len; ++i) {
4528 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4535 /* infinite recursion isn't supposed to happen here */
4536 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4537 (void) do_smartmatch(NULL, NULL);
4539 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4548 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4549 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4550 SV *t = d; d = e; e = t;
4551 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4554 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4555 SV *t = d; d = e; e = t;
4556 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4557 goto sm_regex_array;
4560 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4562 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4564 PUSHs(matcher_matches_sv(matcher, d)
4567 destroy_matcher(matcher);
4572 /* See if there is overload magic on left */
4573 else if (object_on_left && SvAMAGIC(d)) {
4575 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4576 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4579 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4587 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4590 else if (!SvOK(d)) {
4591 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4592 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4597 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4598 DEBUG_M(if (SvNIOK(e))
4599 Perl_deb(aTHX_ " applying rule Any-Num\n");
4601 Perl_deb(aTHX_ " applying rule Num-numish\n");
4603 /* numeric comparison */
4606 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4617 /* As a last resort, use string comparison */
4618 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4627 register PERL_CONTEXT *cx;
4628 const I32 gimme = GIMME_V;
4630 /* This is essentially an optimization: if the match
4631 fails, we don't want to push a context and then
4632 pop it again right away, so we skip straight
4633 to the op that follows the leavewhen.
4634 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4636 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4637 RETURNOP(cLOGOP->op_other->op_next);
4639 ENTER_with_name("eval");
4642 PUSHBLOCK(cx, CXt_WHEN, SP);
4651 register PERL_CONTEXT *cx;
4657 assert(CxTYPE(cx) == CXt_WHEN);
4662 PL_curpm = newpm; /* pop $1 et al */
4664 LEAVE_with_name("eval");
4672 register PERL_CONTEXT *cx;
4675 cxix = dopoptowhen(cxstack_ix);
4677 DIE(aTHX_ "Can't \"continue\" outside a when block");
4678 if (cxix < cxstack_ix)
4681 /* clear off anything above the scope we're re-entering */
4682 inner = PL_scopestack_ix;
4684 if (PL_scopestack_ix < inner)
4685 leave_scope(PL_scopestack[PL_scopestack_ix]);
4686 PL_curcop = cx->blk_oldcop;
4687 return cx->blk_givwhen.leave_op;
4694 register PERL_CONTEXT *cx;
4698 cxix = dopoptogiven(cxstack_ix);
4700 if (PL_op->op_flags & OPf_SPECIAL)
4701 DIE(aTHX_ "Can't use when() outside a topicalizer");
4703 DIE(aTHX_ "Can't \"break\" outside a given block");
4705 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4706 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4708 if (cxix < cxstack_ix)
4711 /* clear off anything above the scope we're re-entering */
4712 inner = PL_scopestack_ix;
4714 if (PL_scopestack_ix < inner)
4715 leave_scope(PL_scopestack[PL_scopestack_ix]);
4716 PL_curcop = cx->blk_oldcop;
4719 return CX_LOOP_NEXTOP_GET(cx);
4721 /* RETURNOP calls PUTBACK which restores the old old sp */
4722 RETURNOP(cx->blk_givwhen.leave_op);
4726 S_doparseform(pTHX_ SV *sv)
4729 register char *s = SvPV_force(sv, len);
4730 register char * const send = s + len;
4731 register char *base = NULL;
4732 register I32 skipspaces = 0;
4733 bool noblank = FALSE;
4734 bool repeat = FALSE;
4735 bool postspace = FALSE;
4741 bool unchopnum = FALSE;
4742 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4744 PERL_ARGS_ASSERT_DOPARSEFORM;
4747 Perl_croak(aTHX_ "Null picture in formline");
4749 /* estimate the buffer size needed */
4750 for (base = s; s <= send; s++) {
4751 if (*s == '\n' || *s == '@' || *s == '^')
4757 Newx(fops, maxops, U32);
4762 *fpc++ = FF_LINEMARK;
4763 noblank = repeat = FALSE;
4781 case ' ': case '\t':
4788 } /* else FALL THROUGH */
4796 *fpc++ = FF_LITERAL;
4804 *fpc++ = (U16)skipspaces;
4808 *fpc++ = FF_NEWLINE;
4812 arg = fpc - linepc + 1;
4819 *fpc++ = FF_LINEMARK;
4820 noblank = repeat = FALSE;
4829 ischop = s[-1] == '^';
4835 arg = (s - base) - 1;
4837 *fpc++ = FF_LITERAL;
4845 *fpc++ = 2; /* skip the @* or ^* */
4847 *fpc++ = FF_LINESNGL;
4850 *fpc++ = FF_LINEGLOB;
4852 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4853 arg = ischop ? 512 : 0;
4858 const char * const f = ++s;
4861 arg |= 256 + (s - f);
4863 *fpc++ = s - base; /* fieldsize for FETCH */
4864 *fpc++ = FF_DECIMAL;
4866 unchopnum |= ! ischop;
4868 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4869 arg = ischop ? 512 : 0;
4871 s++; /* skip the '0' first */
4875 const char * const f = ++s;
4878 arg |= 256 + (s - f);
4880 *fpc++ = s - base; /* fieldsize for FETCH */
4881 *fpc++ = FF_0DECIMAL;
4883 unchopnum |= ! ischop;
4887 bool ismore = FALSE;
4890 while (*++s == '>') ;
4891 prespace = FF_SPACE;
4893 else if (*s == '|') {
4894 while (*++s == '|') ;
4895 prespace = FF_HALFSPACE;
4900 while (*++s == '<') ;
4903 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4907 *fpc++ = s - base; /* fieldsize for FETCH */
4909 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4912 *fpc++ = (U16)prespace;
4926 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4928 { /* need to jump to the next word */
4930 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4931 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4932 s = SvPVX(sv) + SvCUR(sv) + z;
4934 Copy(fops, s, arg, U32);
4936 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4939 if (unchopnum && repeat)
4940 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4946 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4948 /* Can value be printed in fldsize chars, using %*.*f ? */
4952 int intsize = fldsize - (value < 0 ? 1 : 0);
4959 while (intsize--) pwr *= 10.0;
4960 while (frcsize--) eps /= 10.0;
4963 if (value + eps >= pwr)
4966 if (value - eps <= -pwr)
4973 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4976 SV * const datasv = FILTER_DATA(idx);
4977 const int filter_has_file = IoLINES(datasv);
4978 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4979 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4984 char *prune_from = NULL;
4985 bool read_from_cache = FALSE;
4988 PERL_ARGS_ASSERT_RUN_USER_FILTER;
4990 assert(maxlen >= 0);
4993 /* I was having segfault trouble under Linux 2.2.5 after a
4994 parse error occured. (Had to hack around it with a test
4995 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4996 not sure where the trouble is yet. XXX */
4999 SV *const cache = datasv;
5002 const char *cache_p = SvPV(cache, cache_len);
5006 /* Running in block mode and we have some cached data already.
5008 if (cache_len >= umaxlen) {
5009 /* In fact, so much data we don't even need to call
5014 const char *const first_nl =
5015 (const char *)memchr(cache_p, '\n', cache_len);
5017 take = first_nl + 1 - cache_p;
5021 sv_catpvn(buf_sv, cache_p, take);
5022 sv_chop(cache, cache_p + take);
5023 /* Definately not EOF */
5027 sv_catsv(buf_sv, cache);
5029 umaxlen -= cache_len;
5032 read_from_cache = TRUE;
5036 /* Filter API says that the filter appends to the contents of the buffer.
5037 Usually the buffer is "", so the details don't matter. But if it's not,
5038 then clearly what it contains is already filtered by this filter, so we
5039 don't want to pass it in a second time.
5040 I'm going to use a mortal in case the upstream filter croaks. */
5041 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5042 ? sv_newmortal() : buf_sv;
5043 SvUPGRADE(upstream, SVt_PV);
5045 if (filter_has_file) {
5046 status = FILTER_READ(idx+1, upstream, 0);
5049 if (filter_sub && status >= 0) {
5053 ENTER_with_name("call_filter_sub");
5058 DEFSV_set(upstream);
5062 PUSHs(filter_state);
5065 count = call_sv(filter_sub, G_SCALAR);
5077 LEAVE_with_name("call_filter_sub");
5080 if(SvOK(upstream)) {
5081 got_p = SvPV(upstream, got_len);
5083 if (got_len > umaxlen) {
5084 prune_from = got_p + umaxlen;
5087 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5088 if (first_nl && first_nl + 1 < got_p + got_len) {
5089 /* There's a second line here... */
5090 prune_from = first_nl + 1;
5095 /* Oh. Too long. Stuff some in our cache. */
5096 STRLEN cached_len = got_p + got_len - prune_from;
5097 SV *const cache = datasv;
5100 /* Cache should be empty. */
5101 assert(!SvCUR(cache));
5104 sv_setpvn(cache, prune_from, cached_len);
5105 /* If you ask for block mode, you may well split UTF-8 characters.
5106 "If it breaks, you get to keep both parts"
5107 (Your code is broken if you don't put them back together again
5108 before something notices.) */
5109 if (SvUTF8(upstream)) {
5112 SvCUR_set(upstream, got_len - cached_len);
5114 /* Can't yet be EOF */
5119 /* If they are at EOF but buf_sv has something in it, then they may never
5120 have touched the SV upstream, so it may be undefined. If we naively
5121 concatenate it then we get a warning about use of uninitialised value.
5123 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5124 sv_catsv(buf_sv, upstream);
5128 IoLINES(datasv) = 0;
5130 SvREFCNT_dec(filter_state);
5131 IoTOP_GV(datasv) = NULL;
5134 SvREFCNT_dec(filter_sub);
5135 IoBOTTOM_GV(datasv) = NULL;
5137 filter_del(S_run_user_filter);
5139 if (status == 0 && read_from_cache) {
5140 /* If we read some data from the cache (and by getting here it implies
5141 that we emptied the cache) then we aren't yet at EOF, and mustn't
5142 report that to our caller. */
5148 /* perhaps someone can come up with a better name for
5149 this? it is not really "absolute", per se ... */
5151 S_path_is_absolute(const char *name)
5153 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5155 if (PERL_FILE_IS_ABSOLUTE(name)
5157 || (*name == '.' && ((name[1] == '/' ||
5158 (name[1] == '.' && name[2] == '/'))
5159 || (name[1] == '\\' ||
5160 ( name[1] == '.' && name[2] == '\\')))
5163 || (*name == '.' && (name[1] == '/' ||
5164 (name[1] == '.' && name[2] == '/')))
5176 * c-indentation-style: bsd
5178 * indent-tabs-mode: t
5181 * ex: set ts=8 sts=4 sw=4 noet: