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_where(pTHX_ SV *msv)
1584 if (PL_in_eval & EVAL_KEEPERR) {
1585 static const char prefix[] = "\t(in cleanup) ";
1586 SV * const err = ERRSV;
1587 const char *e = NULL;
1590 else if (SvCUR(err) >= sizeof(prefix)+SvCUR(msv)-1) {
1593 const char* message = SvPV_const(msv, msglen);
1594 e = SvPV_const(err, len);
1596 if (*e != *message || strNE(e,message))
1601 SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(msv));
1602 sv_catpvn(err, prefix, sizeof(prefix)-1);
1604 start = SvCUR(err)-SvCUR(msv)-sizeof(prefix)+1;
1605 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s",
1606 SvPVX_const(err)+start);
1611 const char* message = SvPV_const(msv, msglen);
1612 sv_setpvn(ERRSV, message, msglen);
1613 SvFLAGS(ERRSV) |= SvFLAGS(msv) & SVf_UTF8;
1617 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1618 && PL_curstackinfo->si_prev)
1627 register PERL_CONTEXT *cx;
1630 if (cxix < cxstack_ix)
1633 POPBLOCK(cx,PL_curpm);
1634 if (CxTYPE(cx) != CXt_EVAL) {
1636 const char* message = SvPVx_const( msv ? msv : ERRSV, msglen);
1637 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1638 PerlIO_write(Perl_error_log, message, msglen);
1642 namesv = cx->blk_eval.old_namesv;
1644 if (gimme == G_SCALAR)
1645 *++newsp = &PL_sv_undef;
1646 PL_stack_sp = newsp;
1650 /* LEAVE could clobber PL_curcop (see save_re_context())
1651 * XXX it might be better to find a way to avoid messing with
1652 * PL_curcop in save_re_context() instead, but this is a more
1653 * minimal fix --GSAR */
1654 PL_curcop = cx->blk_oldcop;
1656 if (optype == OP_REQUIRE) {
1657 const char* const msg = SvPVx_nolen_const(ERRSV);
1658 (void)hv_store(GvHVn(PL_incgv),
1659 SvPVX_const(namesv), SvCUR(namesv),
1661 /* note that unlike pp_entereval, pp_require isn't
1662 * supposed to trap errors. So now that we've popped the
1663 * EVAL that pp_require pushed, and processed the error
1664 * message, rethrow the error */
1665 DIE(aTHX_ "%sCompilation failed in require",
1666 *msg ? msg : "Unknown error\n");
1668 assert(CxTYPE(cx) == CXt_EVAL);
1669 PL_restartjmpenv = cx->blk_eval.cur_top_env;
1670 PL_restartop = cx->blk_eval.retop;
1676 write_to_stderr( msv ? msv : ERRSV );
1683 dVAR; dSP; dPOPTOPssrl;
1684 if (SvTRUE(left) != SvTRUE(right))
1694 register I32 cxix = dopoptosub(cxstack_ix);
1695 register const PERL_CONTEXT *cx;
1696 register const PERL_CONTEXT *ccstack = cxstack;
1697 const PERL_SI *top_si = PL_curstackinfo;
1699 const char *stashname;
1706 /* we may be in a higher stacklevel, so dig down deeper */
1707 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1708 top_si = top_si->si_prev;
1709 ccstack = top_si->si_cxstack;
1710 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1713 if (GIMME != G_ARRAY) {
1719 /* caller() should not report the automatic calls to &DB::sub */
1720 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1721 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1725 cxix = dopoptosub_at(ccstack, cxix - 1);
1728 cx = &ccstack[cxix];
1729 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1730 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1731 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1732 field below is defined for any cx. */
1733 /* caller() should not report the automatic calls to &DB::sub */
1734 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1735 cx = &ccstack[dbcxix];
1738 stashname = CopSTASHPV(cx->blk_oldcop);
1739 if (GIMME != G_ARRAY) {
1742 PUSHs(&PL_sv_undef);
1745 sv_setpv(TARG, stashname);
1754 PUSHs(&PL_sv_undef);
1756 mPUSHs(newSVpv(stashname, 0));
1757 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1758 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1761 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1762 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1763 /* So is ccstack[dbcxix]. */
1765 SV * const sv = newSV(0);
1766 gv_efullname3(sv, cvgv, NULL);
1768 PUSHs(boolSV(CxHASARGS(cx)));
1771 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1772 PUSHs(boolSV(CxHASARGS(cx)));
1776 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1779 gimme = (I32)cx->blk_gimme;
1780 if (gimme == G_VOID)
1781 PUSHs(&PL_sv_undef);
1783 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1784 if (CxTYPE(cx) == CXt_EVAL) {
1786 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1787 PUSHs(cx->blk_eval.cur_text);
1791 else if (cx->blk_eval.old_namesv) {
1792 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1795 /* eval BLOCK (try blocks have old_namesv == 0) */
1797 PUSHs(&PL_sv_undef);
1798 PUSHs(&PL_sv_undef);
1802 PUSHs(&PL_sv_undef);
1803 PUSHs(&PL_sv_undef);
1805 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1806 && CopSTASH_eq(PL_curcop, PL_debstash))
1808 AV * const ary = cx->blk_sub.argarray;
1809 const int off = AvARRAY(ary) - AvALLOC(ary);
1812 PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
1814 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1817 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1818 av_extend(PL_dbargs, AvFILLp(ary) + off);
1819 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1820 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1822 /* XXX only hints propagated via op_private are currently
1823 * visible (others are not easily accessible, since they
1824 * use the global PL_hints) */
1825 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1828 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1830 if (old_warnings == pWARN_NONE ||
1831 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1832 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1833 else if (old_warnings == pWARN_ALL ||
1834 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1835 /* Get the bit mask for $warnings::Bits{all}, because
1836 * it could have been extended by warnings::register */
1838 HV * const bits = get_hv("warnings::Bits", 0);
1839 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1840 mask = newSVsv(*bits_all);
1843 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1847 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1851 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1852 sv_2mortal(newRV_noinc(
1853 MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1854 cx->blk_oldcop->cop_hints_hash))))
1863 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1864 sv_reset(tmps, CopSTASH(PL_curcop));
1869 /* like pp_nextstate, but used instead when the debugger is active */
1874 PL_curcop = (COP*)PL_op;
1875 TAINT_NOT; /* Each statement is presumed innocent */
1876 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1881 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1882 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1885 register PERL_CONTEXT *cx;
1886 const I32 gimme = G_ARRAY;
1888 GV * const gv = PL_DBgv;
1889 register CV * const cv = GvCV(gv);
1892 DIE(aTHX_ "No DB::DB routine defined");
1894 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1895 /* don't do recursive DB::DB call */
1910 (void)(*CvXSUB(cv))(aTHX_ cv);
1917 PUSHBLOCK(cx, CXt_SUB, SP);
1919 cx->blk_sub.retop = PL_op->op_next;
1922 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1923 RETURNOP(CvSTART(cv));
1933 register PERL_CONTEXT *cx;
1934 const I32 gimme = GIMME_V;
1936 U8 cxtype = CXt_LOOP_FOR;
1941 ENTER_with_name("loop1");
1944 if (PL_op->op_targ) {
1945 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1946 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1947 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1948 SVs_PADSTALE, SVs_PADSTALE);
1950 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1951 #ifndef USE_ITHREADS
1952 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1958 GV * const gv = MUTABLE_GV(POPs);
1959 svp = &GvSV(gv); /* symbol table variable */
1960 SAVEGENERICSV(*svp);
1963 iterdata = (PAD*)gv;
1967 if (PL_op->op_private & OPpITER_DEF)
1968 cxtype |= CXp_FOR_DEF;
1970 ENTER_with_name("loop2");
1972 PUSHBLOCK(cx, cxtype, SP);
1974 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1976 PUSHLOOP_FOR(cx, svp, MARK, 0);
1978 if (PL_op->op_flags & OPf_STACKED) {
1979 SV *maybe_ary = POPs;
1980 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1982 SV * const right = maybe_ary;
1985 if (RANGE_IS_NUMERIC(sv,right)) {
1986 cx->cx_type &= ~CXTYPEMASK;
1987 cx->cx_type |= CXt_LOOP_LAZYIV;
1988 /* Make sure that no-one re-orders cop.h and breaks our
1990 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1991 #ifdef NV_PRESERVES_UV
1992 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1993 (SvNV(sv) > (NV)IV_MAX)))
1995 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1996 (SvNV(right) < (NV)IV_MIN))))
1998 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
2001 ((SvUV(sv) > (UV)IV_MAX) ||
2002 (SvNV(sv) > (NV)UV_MAX)))))
2004 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
2006 ((SvNV(right) > 0) &&
2007 ((SvUV(right) > (UV)IV_MAX) ||
2008 (SvNV(right) > (NV)UV_MAX))))))
2010 DIE(aTHX_ "Range iterator outside integer range");
2011 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
2012 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
2014 /* for correct -Dstv display */
2015 cx->blk_oldsp = sp - PL_stack_base;
2019 cx->cx_type &= ~CXTYPEMASK;
2020 cx->cx_type |= CXt_LOOP_LAZYSV;
2021 /* Make sure that no-one re-orders cop.h and breaks our
2023 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2024 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2025 cx->blk_loop.state_u.lazysv.end = right;
2026 SvREFCNT_inc(right);
2027 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2028 /* This will do the upgrade to SVt_PV, and warn if the value
2029 is uninitialised. */
2030 (void) SvPV_nolen_const(right);
2031 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2032 to replace !SvOK() with a pointer to "". */
2034 SvREFCNT_dec(right);
2035 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2039 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2040 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2041 SvREFCNT_inc(maybe_ary);
2042 cx->blk_loop.state_u.ary.ix =
2043 (PL_op->op_private & OPpITER_REVERSED) ?
2044 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2048 else { /* iterating over items on the stack */
2049 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2050 if (PL_op->op_private & OPpITER_REVERSED) {
2051 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2054 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2064 register PERL_CONTEXT *cx;
2065 const I32 gimme = GIMME_V;
2067 ENTER_with_name("loop1");
2069 ENTER_with_name("loop2");
2071 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2072 PUSHLOOP_PLAIN(cx, SP);
2080 register PERL_CONTEXT *cx;
2087 assert(CxTYPE_is_LOOP(cx));
2089 newsp = PL_stack_base + cx->blk_loop.resetsp;
2092 if (gimme == G_VOID)
2094 else if (gimme == G_SCALAR) {
2096 *++newsp = sv_mortalcopy(*SP);
2098 *++newsp = &PL_sv_undef;
2102 *++newsp = sv_mortalcopy(*++mark);
2103 TAINT_NOT; /* Each item is independent */
2109 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2110 PL_curpm = newpm; /* ... and pop $1 et al */
2112 LEAVE_with_name("loop2");
2113 LEAVE_with_name("loop1");
2121 register PERL_CONTEXT *cx;
2122 bool popsub2 = FALSE;
2123 bool clear_errsv = FALSE;
2132 const I32 cxix = dopoptosub(cxstack_ix);
2135 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2136 * sort block, which is a CXt_NULL
2139 PL_stack_base[1] = *PL_stack_sp;
2140 PL_stack_sp = PL_stack_base + 1;
2144 DIE(aTHX_ "Can't return outside a subroutine");
2146 if (cxix < cxstack_ix)
2149 if (CxMULTICALL(&cxstack[cxix])) {
2150 gimme = cxstack[cxix].blk_gimme;
2151 if (gimme == G_VOID)
2152 PL_stack_sp = PL_stack_base;
2153 else if (gimme == G_SCALAR) {
2154 PL_stack_base[1] = *PL_stack_sp;
2155 PL_stack_sp = PL_stack_base + 1;
2161 switch (CxTYPE(cx)) {
2164 retop = cx->blk_sub.retop;
2165 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2168 if (!(PL_in_eval & EVAL_KEEPERR))
2171 namesv = cx->blk_eval.old_namesv;
2172 retop = cx->blk_eval.retop;
2176 if (optype == OP_REQUIRE &&
2177 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2179 /* Unassume the success we assumed earlier. */
2180 (void)hv_delete(GvHVn(PL_incgv),
2181 SvPVX_const(namesv), SvCUR(namesv),
2183 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2188 retop = cx->blk_sub.retop;
2191 DIE(aTHX_ "panic: return");
2195 if (gimme == G_SCALAR) {
2198 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2200 *++newsp = SvREFCNT_inc(*SP);
2205 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2207 *++newsp = sv_mortalcopy(sv);
2212 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2215 *++newsp = sv_mortalcopy(*SP);
2218 *++newsp = &PL_sv_undef;
2220 else if (gimme == G_ARRAY) {
2221 while (++MARK <= SP) {
2222 *++newsp = (popsub2 && SvTEMP(*MARK))
2223 ? *MARK : sv_mortalcopy(*MARK);
2224 TAINT_NOT; /* Each item is independent */
2227 PL_stack_sp = newsp;
2230 /* Stack values are safe: */
2233 POPSUB(cx,sv); /* release CV and @_ ... */
2237 PL_curpm = newpm; /* ... and pop $1 et al */
2250 register PERL_CONTEXT *cx;
2261 if (PL_op->op_flags & OPf_SPECIAL) {
2262 cxix = dopoptoloop(cxstack_ix);
2264 DIE(aTHX_ "Can't \"last\" outside a loop block");
2267 cxix = dopoptolabel(cPVOP->op_pv);
2269 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2271 if (cxix < cxstack_ix)
2275 cxstack_ix++; /* temporarily protect top context */
2277 switch (CxTYPE(cx)) {
2278 case CXt_LOOP_LAZYIV:
2279 case CXt_LOOP_LAZYSV:
2281 case CXt_LOOP_PLAIN:
2283 newsp = PL_stack_base + cx->blk_loop.resetsp;
2284 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2288 nextop = cx->blk_sub.retop;
2292 nextop = cx->blk_eval.retop;
2296 nextop = cx->blk_sub.retop;
2299 DIE(aTHX_ "panic: last");
2303 if (gimme == G_SCALAR) {
2305 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2306 ? *SP : sv_mortalcopy(*SP);
2308 *++newsp = &PL_sv_undef;
2310 else if (gimme == G_ARRAY) {
2311 while (++MARK <= SP) {
2312 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2313 ? *MARK : sv_mortalcopy(*MARK);
2314 TAINT_NOT; /* Each item is independent */
2322 /* Stack values are safe: */
2324 case CXt_LOOP_LAZYIV:
2325 case CXt_LOOP_PLAIN:
2326 case CXt_LOOP_LAZYSV:
2328 POPLOOP(cx); /* release loop vars ... */
2332 POPSUB(cx,sv); /* release CV and @_ ... */
2335 PL_curpm = newpm; /* ... and pop $1 et al */
2338 PERL_UNUSED_VAR(optype);
2339 PERL_UNUSED_VAR(gimme);
2347 register PERL_CONTEXT *cx;
2350 if (PL_op->op_flags & OPf_SPECIAL) {
2351 cxix = dopoptoloop(cxstack_ix);
2353 DIE(aTHX_ "Can't \"next\" outside a loop block");
2356 cxix = dopoptolabel(cPVOP->op_pv);
2358 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2360 if (cxix < cxstack_ix)
2363 /* clear off anything above the scope we're re-entering, but
2364 * save the rest until after a possible continue block */
2365 inner = PL_scopestack_ix;
2367 if (PL_scopestack_ix < inner)
2368 leave_scope(PL_scopestack[PL_scopestack_ix]);
2369 PL_curcop = cx->blk_oldcop;
2370 return CX_LOOP_NEXTOP_GET(cx);
2377 register PERL_CONTEXT *cx;
2381 if (PL_op->op_flags & OPf_SPECIAL) {
2382 cxix = dopoptoloop(cxstack_ix);
2384 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2387 cxix = dopoptolabel(cPVOP->op_pv);
2389 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2391 if (cxix < cxstack_ix)
2394 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2395 if (redo_op->op_type == OP_ENTER) {
2396 /* pop one less context to avoid $x being freed in while (my $x..) */
2398 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2399 redo_op = redo_op->op_next;
2403 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2404 LEAVE_SCOPE(oldsave);
2406 PL_curcop = cx->blk_oldcop;
2411 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2415 static const char too_deep[] = "Target of goto is too deeply nested";
2417 PERL_ARGS_ASSERT_DOFINDLABEL;
2420 Perl_croak(aTHX_ too_deep);
2421 if (o->op_type == OP_LEAVE ||
2422 o->op_type == OP_SCOPE ||
2423 o->op_type == OP_LEAVELOOP ||
2424 o->op_type == OP_LEAVESUB ||
2425 o->op_type == OP_LEAVETRY)
2427 *ops++ = cUNOPo->op_first;
2429 Perl_croak(aTHX_ too_deep);
2432 if (o->op_flags & OPf_KIDS) {
2434 /* First try all the kids at this level, since that's likeliest. */
2435 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2436 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2437 const char *kid_label = CopLABEL(kCOP);
2438 if (kid_label && strEQ(kid_label, label))
2442 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2443 if (kid == PL_lastgotoprobe)
2445 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2448 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2449 ops[-1]->op_type == OP_DBSTATE)
2454 if ((o = dofindlabel(kid, label, ops, oplimit)))
2467 register PERL_CONTEXT *cx;
2468 #define GOTO_DEPTH 64
2469 OP *enterops[GOTO_DEPTH];
2470 const char *label = NULL;
2471 const bool do_dump = (PL_op->op_type == OP_DUMP);
2472 static const char must_have_label[] = "goto must have label";
2474 if (PL_op->op_flags & OPf_STACKED) {
2475 SV * const sv = POPs;
2477 /* This egregious kludge implements goto &subroutine */
2478 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2480 register PERL_CONTEXT *cx;
2481 CV *cv = MUTABLE_CV(SvRV(sv));
2488 if (!CvROOT(cv) && !CvXSUB(cv)) {
2489 const GV * const gv = CvGV(cv);
2493 /* autoloaded stub? */
2494 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2496 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2497 GvNAMELEN(gv), FALSE);
2498 if (autogv && (cv = GvCV(autogv)))
2500 tmpstr = sv_newmortal();
2501 gv_efullname3(tmpstr, gv, NULL);
2502 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2504 DIE(aTHX_ "Goto undefined subroutine");
2507 /* First do some returnish stuff. */
2508 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2510 cxix = dopoptosub(cxstack_ix);
2512 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2513 if (cxix < cxstack_ix)
2517 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2518 if (CxTYPE(cx) == CXt_EVAL) {
2520 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2522 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2524 else if (CxMULTICALL(cx))
2525 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2526 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2527 /* put @_ back onto stack */
2528 AV* av = cx->blk_sub.argarray;
2530 items = AvFILLp(av) + 1;
2531 EXTEND(SP, items+1); /* @_ could have been extended. */
2532 Copy(AvARRAY(av), SP + 1, items, SV*);
2533 SvREFCNT_dec(GvAV(PL_defgv));
2534 GvAV(PL_defgv) = cx->blk_sub.savearray;
2536 /* abandon @_ if it got reified */
2541 av_extend(av, items-1);
2543 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2546 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2547 AV* const av = GvAV(PL_defgv);
2548 items = AvFILLp(av) + 1;
2549 EXTEND(SP, items+1); /* @_ could have been extended. */
2550 Copy(AvARRAY(av), SP + 1, items, SV*);
2554 if (CxTYPE(cx) == CXt_SUB &&
2555 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2556 SvREFCNT_dec(cx->blk_sub.cv);
2557 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2558 LEAVE_SCOPE(oldsave);
2560 /* Now do some callish stuff. */
2562 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2564 OP* const retop = cx->blk_sub.retop;
2569 for (index=0; index<items; index++)
2570 sv_2mortal(SP[-index]);
2573 /* XS subs don't have a CxSUB, so pop it */
2574 POPBLOCK(cx, PL_curpm);
2575 /* Push a mark for the start of arglist */
2578 (void)(*CvXSUB(cv))(aTHX_ cv);
2583 AV* const padlist = CvPADLIST(cv);
2584 if (CxTYPE(cx) == CXt_EVAL) {
2585 PL_in_eval = CxOLD_IN_EVAL(cx);
2586 PL_eval_root = cx->blk_eval.old_eval_root;
2587 cx->cx_type = CXt_SUB;
2589 cx->blk_sub.cv = cv;
2590 cx->blk_sub.olddepth = CvDEPTH(cv);
2593 if (CvDEPTH(cv) < 2)
2594 SvREFCNT_inc_simple_void_NN(cv);
2596 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2597 sub_crush_depth(cv);
2598 pad_push(padlist, CvDEPTH(cv));
2601 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2604 AV *const av = MUTABLE_AV(PAD_SVl(0));
2606 cx->blk_sub.savearray = GvAV(PL_defgv);
2607 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2608 CX_CURPAD_SAVE(cx->blk_sub);
2609 cx->blk_sub.argarray = av;
2611 if (items >= AvMAX(av) + 1) {
2612 SV **ary = AvALLOC(av);
2613 if (AvARRAY(av) != ary) {
2614 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2617 if (items >= AvMAX(av) + 1) {
2618 AvMAX(av) = items - 1;
2619 Renew(ary,items+1,SV*);
2625 Copy(mark,AvARRAY(av),items,SV*);
2626 AvFILLp(av) = items - 1;
2627 assert(!AvREAL(av));
2629 /* transfer 'ownership' of refcnts to new @_ */
2639 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2640 Perl_get_db_sub(aTHX_ NULL, cv);
2642 CV * const gotocv = get_cvs("DB::goto", 0);
2644 PUSHMARK( PL_stack_sp );
2645 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2650 RETURNOP(CvSTART(cv));
2654 label = SvPV_nolen_const(sv);
2655 if (!(do_dump || *label))
2656 DIE(aTHX_ must_have_label);
2659 else if (PL_op->op_flags & OPf_SPECIAL) {
2661 DIE(aTHX_ must_have_label);
2664 label = cPVOP->op_pv;
2668 if (label && *label) {
2669 OP *gotoprobe = NULL;
2670 bool leaving_eval = FALSE;
2671 bool in_block = FALSE;
2672 PERL_CONTEXT *last_eval_cx = NULL;
2676 PL_lastgotoprobe = NULL;
2678 for (ix = cxstack_ix; ix >= 0; ix--) {
2680 switch (CxTYPE(cx)) {
2682 leaving_eval = TRUE;
2683 if (!CxTRYBLOCK(cx)) {
2684 gotoprobe = (last_eval_cx ?
2685 last_eval_cx->blk_eval.old_eval_root :
2690 /* else fall through */
2691 case CXt_LOOP_LAZYIV:
2692 case CXt_LOOP_LAZYSV:
2694 case CXt_LOOP_PLAIN:
2697 gotoprobe = cx->blk_oldcop->op_sibling;
2703 gotoprobe = cx->blk_oldcop->op_sibling;
2706 gotoprobe = PL_main_root;
2709 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2710 gotoprobe = CvROOT(cx->blk_sub.cv);
2716 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2719 DIE(aTHX_ "panic: goto");
2720 gotoprobe = PL_main_root;
2724 retop = dofindlabel(gotoprobe, label,
2725 enterops, enterops + GOTO_DEPTH);
2729 PL_lastgotoprobe = gotoprobe;
2732 DIE(aTHX_ "Can't find label %s", label);
2734 /* if we're leaving an eval, check before we pop any frames
2735 that we're not going to punt, otherwise the error
2738 if (leaving_eval && *enterops && enterops[1]) {
2740 for (i = 1; enterops[i]; i++)
2741 if (enterops[i]->op_type == OP_ENTERITER)
2742 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2745 if (*enterops && enterops[1]) {
2746 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2748 deprecate("\"goto\" to jump into a construct");
2751 /* pop unwanted frames */
2753 if (ix < cxstack_ix) {
2760 oldsave = PL_scopestack[PL_scopestack_ix];
2761 LEAVE_SCOPE(oldsave);
2764 /* push wanted frames */
2766 if (*enterops && enterops[1]) {
2767 OP * const oldop = PL_op;
2768 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2769 for (; enterops[ix]; ix++) {
2770 PL_op = enterops[ix];
2771 /* Eventually we may want to stack the needed arguments
2772 * for each op. For now, we punt on the hard ones. */
2773 if (PL_op->op_type == OP_ENTERITER)
2774 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2775 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2783 if (!retop) retop = PL_main_start;
2785 PL_restartop = retop;
2786 PL_do_undump = TRUE;
2790 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2791 PL_do_undump = FALSE;
2808 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2810 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2813 PL_exit_flags |= PERL_EXIT_EXPECTED;
2815 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2816 if (anum || !(PL_minus_c && PL_madskills))
2821 PUSHs(&PL_sv_undef);
2828 S_save_lines(pTHX_ AV *array, SV *sv)
2830 const char *s = SvPVX_const(sv);
2831 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2834 PERL_ARGS_ASSERT_SAVE_LINES;
2836 while (s && s < send) {
2838 SV * const tmpstr = newSV_type(SVt_PVMG);
2840 t = (const char *)memchr(s, '\n', send - s);
2846 sv_setpvn(tmpstr, s, t - s);
2847 av_store(array, line++, tmpstr);
2855 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
2857 0 is used as continue inside eval,
2859 3 is used for a die caught by an inner eval - continue inner loop
2861 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
2862 establish a local jmpenv to handle exception traps.
2867 S_docatch(pTHX_ OP *o)
2871 OP * const oldop = PL_op;
2875 assert(CATCH_GET == TRUE);
2882 assert(cxstack_ix >= 0);
2883 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2884 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2889 /* die caught by an inner eval - continue inner loop */
2890 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
2891 PL_restartjmpenv = NULL;
2892 PL_op = PL_restartop;
2908 /* James Bond: Do you expect me to talk?
2909 Auric Goldfinger: No, Mr. Bond. I expect you to die.
2911 This code is an ugly hack, doesn't work with lexicals in subroutines that are
2912 called more than once, and is only used by regcomp.c, for (?{}) blocks.
2914 Currently it is not used outside the core code. Best if it stays that way.
2917 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2918 /* sv Text to convert to OP tree. */
2919 /* startop op_free() this to undo. */
2920 /* code Short string id of the caller. */
2922 dVAR; dSP; /* Make POPBLOCK work. */
2928 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2929 char *tmpbuf = tbuf;
2932 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2935 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2937 ENTER_with_name("eval");
2938 lex_start(sv, NULL, FALSE);
2940 /* switch to eval mode */
2942 if (IN_PERL_COMPILETIME) {
2943 SAVECOPSTASH_FREE(&PL_compiling);
2944 CopSTASH_set(&PL_compiling, PL_curstash);
2946 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2947 SV * const sv = sv_newmortal();
2948 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2949 code, (unsigned long)++PL_evalseq,
2950 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2955 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2956 (unsigned long)++PL_evalseq);
2957 SAVECOPFILE_FREE(&PL_compiling);
2958 CopFILE_set(&PL_compiling, tmpbuf+2);
2959 SAVECOPLINE(&PL_compiling);
2960 CopLINE_set(&PL_compiling, 1);
2961 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2962 deleting the eval's FILEGV from the stash before gv_check() runs
2963 (i.e. before run-time proper). To work around the coredump that
2964 ensues, we always turn GvMULTI_on for any globals that were
2965 introduced within evals. See force_ident(). GSAR 96-10-12 */
2966 safestr = savepvn(tmpbuf, len);
2967 SAVEDELETE(PL_defstash, safestr, len);
2969 #ifdef OP_IN_REGISTER
2975 /* we get here either during compilation, or via pp_regcomp at runtime */
2976 runtime = IN_PERL_RUNTIME;
2978 runcv = find_runcv(NULL);
2981 PL_op->op_type = OP_ENTEREVAL;
2982 PL_op->op_flags = 0; /* Avoid uninit warning. */
2983 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2987 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2989 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2990 POPBLOCK(cx,PL_curpm);
2993 (*startop)->op_type = OP_NULL;
2994 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2996 /* XXX DAPM do this properly one year */
2997 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2998 LEAVE_with_name("eval");
2999 if (IN_PERL_COMPILETIME)
3000 CopHINTS_set(&PL_compiling, PL_hints);
3001 #ifdef OP_IN_REGISTER
3004 PERL_UNUSED_VAR(newsp);
3005 PERL_UNUSED_VAR(optype);
3007 return PL_eval_start;
3012 =for apidoc find_runcv
3014 Locate the CV corresponding to the currently executing sub or eval.
3015 If db_seqp is non_null, skip CVs that are in the DB package and populate
3016 *db_seqp with the cop sequence number at the point that the DB:: code was
3017 entered. (allows debuggers to eval in the scope of the breakpoint rather
3018 than in the scope of the debugger itself).
3024 Perl_find_runcv(pTHX_ U32 *db_seqp)
3030 *db_seqp = PL_curcop->cop_seq;
3031 for (si = PL_curstackinfo; si; si = si->si_prev) {
3033 for (ix = si->si_cxix; ix >= 0; ix--) {
3034 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3035 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3036 CV * const cv = cx->blk_sub.cv;
3037 /* skip DB:: code */
3038 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3039 *db_seqp = cx->blk_oldcop->cop_seq;
3044 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3052 /* Run yyparse() in a setjmp wrapper. Returns:
3053 * 0: yyparse() successful
3054 * 1: yyparse() failed
3063 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3067 ret = yyparse() ? 1 : 0;
3081 /* Compile a require/do, an eval '', or a /(?{...})/.
3082 * In the last case, startop is non-null, and contains the address of
3083 * a pointer that should be set to the just-compiled code.
3084 * outside is the lexically enclosing CV (if any) that invoked us.
3085 * Returns a bool indicating whether the compile was successful; if so,
3086 * PL_eval_start contains the first op of the compiled ocde; otherwise,
3087 * pushes undef (also croaks if startop != NULL).
3091 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3094 OP * const saveop = PL_op;
3095 bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3098 PL_in_eval = (in_require
3099 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3104 SAVESPTR(PL_compcv);
3105 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3106 CvEVAL_on(PL_compcv);
3107 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3108 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3110 CvOUTSIDE_SEQ(PL_compcv) = seq;
3111 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3113 /* set up a scratch pad */
3115 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3116 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3120 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3122 /* make sure we compile in the right package */
3124 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3125 SAVESPTR(PL_curstash);
3126 PL_curstash = CopSTASH(PL_curcop);
3128 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3129 SAVESPTR(PL_beginav);
3130 PL_beginav = newAV();
3131 SAVEFREESV(PL_beginav);
3132 SAVESPTR(PL_unitcheckav);
3133 PL_unitcheckav = newAV();
3134 SAVEFREESV(PL_unitcheckav);
3137 SAVEBOOL(PL_madskills);
3141 /* try to compile it */
3143 PL_eval_root = NULL;
3144 PL_curcop = &PL_compiling;
3145 CopARYBASE_set(PL_curcop, 0);
3146 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3147 PL_in_eval |= EVAL_KEEPERR;
3151 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3152 * so honour CATCH_GET and trap it here if necessary */
3154 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX) : yyparse();
3156 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3157 SV **newsp; /* Used by POPBLOCK. */
3158 PERL_CONTEXT *cx = NULL;
3159 I32 optype; /* Used by POPEVAL. */
3163 PERL_UNUSED_VAR(newsp);
3164 PERL_UNUSED_VAR(optype);
3168 op_free(PL_eval_root);
3169 PL_eval_root = NULL;
3171 if (yystatus != 3) {
3172 SP = PL_stack_base + POPMARK; /* pop original mark */
3174 POPBLOCK(cx,PL_curpm);
3176 namesv = cx->blk_eval.old_namesv;
3181 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3183 msg = SvPVx_nolen_const(ERRSV);
3186 /* If cx is still NULL, it means that we didn't go in the
3187 * POPEVAL branch. */
3188 cx = &cxstack[cxstack_ix];
3189 assert(CxTYPE(cx) == CXt_EVAL);
3190 namesv = cx->blk_eval.old_namesv;
3192 (void)hv_store(GvHVn(PL_incgv),
3193 SvPVX_const(namesv), SvCUR(namesv),
3195 Perl_croak(aTHX_ "%sCompilation failed in require",
3196 *msg ? msg : "Unknown error\n");
3199 if (yystatus != 3) {
3200 POPBLOCK(cx,PL_curpm);
3203 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3204 (*msg ? msg : "Unknown error\n"));
3208 sv_setpvs(ERRSV, "Compilation error");
3211 PUSHs(&PL_sv_undef);
3215 CopLINE_set(&PL_compiling, 0);
3217 *startop = PL_eval_root;
3219 SAVEFREEOP(PL_eval_root);
3221 /* Set the context for this new optree.
3222 * Propagate the context from the eval(). */
3223 if ((gimme & G_WANT) == G_VOID)
3224 scalarvoid(PL_eval_root);
3225 else if ((gimme & G_WANT) == G_ARRAY)
3228 scalar(PL_eval_root);
3230 DEBUG_x(dump_eval());
3232 /* Register with debugger: */
3233 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3234 CV * const cv = get_cvs("DB::postponed", 0);
3238 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3240 call_sv(MUTABLE_SV(cv), G_DISCARD);
3245 call_list(PL_scopestack_ix, PL_unitcheckav);
3247 /* compiled okay, so do it */
3249 CvDEPTH(PL_compcv) = 1;
3250 SP = PL_stack_base + POPMARK; /* pop original mark */
3251 PL_op = saveop; /* The caller may need it. */
3252 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3259 S_check_type_and_open(pTHX_ const char *name)
3262 const int st_rc = PerlLIO_stat(name, &st);
3264 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3266 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3270 return PerlIO_open(name, PERL_SCRIPT_MODE);
3273 #ifndef PERL_DISABLE_PMC
3275 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3279 PERL_ARGS_ASSERT_DOOPEN_PM;
3281 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3282 SV *const pmcsv = newSV(namelen + 2);
3283 char *const pmc = SvPVX(pmcsv);
3286 memcpy(pmc, name, namelen);
3288 pmc[namelen + 1] = '\0';
3290 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3291 fp = check_type_and_open(name);
3294 fp = check_type_and_open(pmc);
3296 SvREFCNT_dec(pmcsv);
3299 fp = check_type_and_open(name);
3304 # define doopen_pm(name, namelen) check_type_and_open(name)
3305 #endif /* !PERL_DISABLE_PMC */
3310 register PERL_CONTEXT *cx;
3317 int vms_unixname = 0;
3319 const char *tryname = NULL;
3321 const I32 gimme = GIMME_V;
3322 int filter_has_file = 0;
3323 PerlIO *tryrsfp = NULL;
3324 SV *filter_cache = NULL;
3325 SV *filter_state = NULL;
3326 SV *filter_sub = NULL;
3332 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3333 sv = new_version(sv);
3334 if (!sv_derived_from(PL_patchlevel, "version"))
3335 upg_version(PL_patchlevel, TRUE);
3336 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3337 if ( vcmp(sv,PL_patchlevel) <= 0 )
3338 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3339 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3342 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3345 SV * const req = SvRV(sv);
3346 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3348 /* get the left hand term */
3349 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3351 first = SvIV(*av_fetch(lav,0,0));
3352 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3353 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3354 || av_len(lav) > 1 /* FP with > 3 digits */
3355 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3357 DIE(aTHX_ "Perl %"SVf" required--this is only "
3358 "%"SVf", stopped", SVfARG(vnormal(req)),
3359 SVfARG(vnormal(PL_patchlevel)));
3361 else { /* probably 'use 5.10' or 'use 5.8' */
3366 second = SvIV(*av_fetch(lav,1,0));
3368 second /= second >= 600 ? 100 : 10;
3369 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3370 (int)first, (int)second);
3371 upg_version(hintsv, TRUE);
3373 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3374 "--this is only %"SVf", stopped",
3375 SVfARG(vnormal(req)),
3376 SVfARG(vnormal(sv_2mortal(hintsv))),
3377 SVfARG(vnormal(PL_patchlevel)));
3382 /* We do this only with use, not require. */
3384 /* If we request a version >= 5.9.5, load feature.pm with the
3385 * feature bundle that corresponds to the required version. */
3386 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3387 SV *const importsv = vnormal(sv);
3388 *SvPVX_mutable(importsv) = ':';
3389 ENTER_with_name("load_feature");
3390 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3391 LEAVE_with_name("load_feature");
3393 /* If a version >= 5.11.0 is requested, strictures are on by default! */
3395 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3396 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3401 name = SvPV_const(sv, len);
3402 if (!(name && len > 0 && *name))
3403 DIE(aTHX_ "Null filename used");
3404 TAINT_PROPER("require");
3408 /* The key in the %ENV hash is in the syntax of file passed as the argument
3409 * usually this is in UNIX format, but sometimes in VMS format, which
3410 * can result in a module being pulled in more than once.
3411 * To prevent this, the key must be stored in UNIX format if the VMS
3412 * name can be translated to UNIX.
3414 if ((unixname = tounixspec(name, NULL)) != NULL) {
3415 unixlen = strlen(unixname);
3421 /* if not VMS or VMS name can not be translated to UNIX, pass it
3424 unixname = (char *) name;
3427 if (PL_op->op_type == OP_REQUIRE) {
3428 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3429 unixname, unixlen, 0);
3431 if (*svp != &PL_sv_undef)
3434 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3435 "Compilation failed in require", unixname);
3439 /* prepare to compile file */
3441 if (path_is_absolute(name)) {
3443 tryrsfp = doopen_pm(name, len);
3446 AV * const ar = GvAVn(PL_incgv);
3452 namesv = newSV_type(SVt_PV);
3453 for (i = 0; i <= AvFILL(ar); i++) {
3454 SV * const dirsv = *av_fetch(ar, i, TRUE);
3456 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3463 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3464 && !sv_isobject(loader))
3466 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3469 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3470 PTR2UV(SvRV(dirsv)), name);
3471 tryname = SvPVX_const(namesv);
3474 ENTER_with_name("call_INC");
3482 if (sv_isobject(loader))
3483 count = call_method("INC", G_ARRAY);
3485 count = call_sv(loader, G_ARRAY);
3488 /* Adjust file name if the hook has set an %INC entry */
3489 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3491 tryname = SvPV_nolen_const(*svp);
3500 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3501 && !isGV_with_GP(SvRV(arg))) {
3502 filter_cache = SvRV(arg);
3503 SvREFCNT_inc_simple_void_NN(filter_cache);
3510 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3514 if (isGV_with_GP(arg)) {
3515 IO * const io = GvIO((const GV *)arg);
3520 tryrsfp = IoIFP(io);
3521 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3522 PerlIO_close(IoOFP(io));
3533 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3535 SvREFCNT_inc_simple_void_NN(filter_sub);
3538 filter_state = SP[i];
3539 SvREFCNT_inc_simple_void(filter_state);
3543 if (!tryrsfp && (filter_cache || filter_sub)) {
3544 tryrsfp = PerlIO_open(BIT_BUCKET,
3552 LEAVE_with_name("call_INC");
3559 filter_has_file = 0;
3561 SvREFCNT_dec(filter_cache);
3562 filter_cache = NULL;
3565 SvREFCNT_dec(filter_state);
3566 filter_state = NULL;
3569 SvREFCNT_dec(filter_sub);
3574 if (!path_is_absolute(name)
3580 dir = SvPV_const(dirsv, dirlen);
3588 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3590 sv_setpv(namesv, unixdir);
3591 sv_catpv(namesv, unixname);
3593 # ifdef __SYMBIAN32__
3594 if (PL_origfilename[0] &&
3595 PL_origfilename[1] == ':' &&
3596 !(dir[0] && dir[1] == ':'))
3597 Perl_sv_setpvf(aTHX_ namesv,
3602 Perl_sv_setpvf(aTHX_ namesv,
3606 /* The equivalent of
3607 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3608 but without the need to parse the format string, or
3609 call strlen on either pointer, and with the correct
3610 allocation up front. */
3612 char *tmp = SvGROW(namesv, dirlen + len + 2);
3614 memcpy(tmp, dir, dirlen);
3617 /* name came from an SV, so it will have a '\0' at the
3618 end that we can copy as part of this memcpy(). */
3619 memcpy(tmp, name, len + 1);
3621 SvCUR_set(namesv, dirlen + len + 1);
3623 /* Don't even actually have to turn SvPOK_on() as we
3624 access it directly with SvPVX() below. */
3628 TAINT_PROPER("require");
3629 tryname = SvPVX_const(namesv);
3630 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3632 if (tryname[0] == '.' && tryname[1] == '/') {
3634 while (*++tryname == '/');
3638 else if (errno == EMFILE)
3639 /* no point in trying other paths if out of handles */
3646 SAVECOPFILE_FREE(&PL_compiling);
3647 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3648 SvREFCNT_dec(namesv);
3650 if (PL_op->op_type == OP_REQUIRE) {
3651 const char *msgstr = name;
3652 if(errno == EMFILE) {
3654 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3656 msgstr = SvPV_nolen_const(msg);
3658 if (namesv) { /* did we lookup @INC? */
3659 AV * const ar = GvAVn(PL_incgv);
3661 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3662 "%s in @INC%s%s (@INC contains:",
3664 (instr(msgstr, ".h ")
3665 ? " (change .h to .ph maybe?)" : ""),
3666 (instr(msgstr, ".ph ")
3667 ? " (did you run h2ph?)" : "")
3670 for (i = 0; i <= AvFILL(ar); i++) {
3671 sv_catpvs(msg, " ");
3672 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3674 sv_catpvs(msg, ")");
3675 msgstr = SvPV_nolen_const(msg);
3678 DIE(aTHX_ "Can't locate %s", msgstr);
3684 SETERRNO(0, SS_NORMAL);
3686 /* Assume success here to prevent recursive requirement. */
3687 /* name is never assigned to again, so len is still strlen(name) */
3688 /* Check whether a hook in @INC has already filled %INC */
3690 (void)hv_store(GvHVn(PL_incgv),
3691 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3693 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3695 (void)hv_store(GvHVn(PL_incgv),
3696 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3699 ENTER_with_name("eval");
3701 lex_start(NULL, tryrsfp, TRUE);
3705 hv_clear(GvHV(PL_hintgv));
3707 SAVECOMPILEWARNINGS();
3708 if (PL_dowarn & G_WARN_ALL_ON)
3709 PL_compiling.cop_warnings = pWARN_ALL ;
3710 else if (PL_dowarn & G_WARN_ALL_OFF)
3711 PL_compiling.cop_warnings = pWARN_NONE ;
3713 PL_compiling.cop_warnings = pWARN_STD ;
3715 if (filter_sub || filter_cache) {
3716 /* We can use the SvPV of the filter PVIO itself as our cache, rather
3717 than hanging another SV from it. In turn, filter_add() optionally
3718 takes the SV to use as the filter (or creates a new SV if passed
3719 NULL), so simply pass in whatever value filter_cache has. */
3720 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3721 IoLINES(datasv) = filter_has_file;
3722 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3723 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3726 /* switch to eval mode */
3727 PUSHBLOCK(cx, CXt_EVAL, SP);
3729 cx->blk_eval.retop = PL_op->op_next;
3731 SAVECOPLINE(&PL_compiling);
3732 CopLINE_set(&PL_compiling, 0);
3736 /* Store and reset encoding. */
3737 encoding = PL_encoding;
3740 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3741 op = DOCATCH(PL_eval_start);
3743 op = PL_op->op_next;
3745 /* Restore encoding. */
3746 PL_encoding = encoding;
3751 /* This is a op added to hold the hints hash for
3752 pp_entereval. The hash can be modified by the code
3753 being eval'ed, so we return a copy instead. */
3759 mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3767 register PERL_CONTEXT *cx;
3769 const I32 gimme = GIMME_V;
3770 const U32 was = PL_breakable_sub_gen;
3771 char tbuf[TYPE_DIGITS(long) + 12];
3772 char *tmpbuf = tbuf;
3776 HV *saved_hh = NULL;
3778 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3779 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3783 TAINT_IF(SvTAINTED(sv));
3784 TAINT_PROPER("eval");
3786 ENTER_with_name("eval");
3787 lex_start(sv, NULL, FALSE);
3790 /* switch to eval mode */
3792 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3793 SV * const temp_sv = sv_newmortal();
3794 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3795 (unsigned long)++PL_evalseq,
3796 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3797 tmpbuf = SvPVX(temp_sv);
3798 len = SvCUR(temp_sv);
3801 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3802 SAVECOPFILE_FREE(&PL_compiling);
3803 CopFILE_set(&PL_compiling, tmpbuf+2);
3804 SAVECOPLINE(&PL_compiling);
3805 CopLINE_set(&PL_compiling, 1);
3806 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3807 deleting the eval's FILEGV from the stash before gv_check() runs
3808 (i.e. before run-time proper). To work around the coredump that
3809 ensues, we always turn GvMULTI_on for any globals that were
3810 introduced within evals. See force_ident(). GSAR 96-10-12 */
3812 PL_hints = PL_op->op_targ;
3814 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3815 SvREFCNT_dec(GvHV(PL_hintgv));
3816 GvHV(PL_hintgv) = saved_hh;
3818 SAVECOMPILEWARNINGS();
3819 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3820 if (PL_compiling.cop_hints_hash) {
3821 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3823 if (Perl_fetch_cop_label(aTHX_ PL_curcop->cop_hints_hash, NULL, NULL)) {
3824 /* The label, if present, is the first entry on the chain. So rather
3825 than writing a blank label in front of it (which involves an
3826 allocation), just use the next entry in the chain. */
3827 PL_compiling.cop_hints_hash
3828 = PL_curcop->cop_hints_hash->refcounted_he_next;
3829 /* Check the assumption that this removed the label. */
3830 assert(Perl_fetch_cop_label(aTHX_ PL_compiling.cop_hints_hash, NULL,
3834 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3835 if (PL_compiling.cop_hints_hash) {
3837 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3838 HINTS_REFCNT_UNLOCK;
3840 /* special case: an eval '' executed within the DB package gets lexically
3841 * placed in the first non-DB CV rather than the current CV - this
3842 * allows the debugger to execute code, find lexicals etc, in the
3843 * scope of the code being debugged. Passing &seq gets find_runcv
3844 * to do the dirty work for us */
3845 runcv = find_runcv(&seq);
3847 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3849 cx->blk_eval.retop = PL_op->op_next;
3851 /* prepare to compile string */
3853 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3854 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3857 if (doeval(gimme, NULL, runcv, seq)) {
3858 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3859 ? (PERLDB_LINE || PERLDB_SAVESRC)
3860 : PERLDB_SAVESRC_NOSUBS) {
3861 /* Retain the filegv we created. */
3863 char *const safestr = savepvn(tmpbuf, len);
3864 SAVEDELETE(PL_defstash, safestr, len);
3866 return DOCATCH(PL_eval_start);
3868 /* We have already left the scope set up earler thanks to the LEAVE
3870 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3871 ? (PERLDB_LINE || PERLDB_SAVESRC)
3872 : PERLDB_SAVESRC_INVALID) {
3873 /* Retain the filegv we created. */
3875 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3877 return PL_op->op_next;
3888 register PERL_CONTEXT *cx;
3890 const U8 save_flags = PL_op -> op_flags;
3896 namesv = cx->blk_eval.old_namesv;
3897 retop = cx->blk_eval.retop;
3900 if (gimme == G_VOID)
3902 else if (gimme == G_SCALAR) {
3905 if (SvFLAGS(TOPs) & SVs_TEMP)
3908 *MARK = sv_mortalcopy(TOPs);
3912 *MARK = &PL_sv_undef;
3917 /* in case LEAVE wipes old return values */
3918 for (mark = newsp + 1; mark <= SP; mark++) {
3919 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3920 *mark = sv_mortalcopy(*mark);
3921 TAINT_NOT; /* Each item is independent */
3925 PL_curpm = newpm; /* Don't pop $1 et al till now */
3928 assert(CvDEPTH(PL_compcv) == 1);
3930 CvDEPTH(PL_compcv) = 0;
3933 if (optype == OP_REQUIRE &&
3934 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3936 /* Unassume the success we assumed earlier. */
3937 (void)hv_delete(GvHVn(PL_incgv),
3938 SvPVX_const(namesv), SvCUR(namesv),
3940 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
3942 /* die_where() did LEAVE, or we won't be here */
3945 LEAVE_with_name("eval");
3946 if (!(save_flags & OPf_SPECIAL)) {
3954 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3955 close to the related Perl_create_eval_scope. */
3957 Perl_delete_eval_scope(pTHX)
3962 register PERL_CONTEXT *cx;
3968 LEAVE_with_name("eval_scope");
3969 PERL_UNUSED_VAR(newsp);
3970 PERL_UNUSED_VAR(gimme);
3971 PERL_UNUSED_VAR(optype);
3974 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3975 also needed by Perl_fold_constants. */
3977 Perl_create_eval_scope(pTHX_ U32 flags)
3980 const I32 gimme = GIMME_V;
3982 ENTER_with_name("eval_scope");
3985 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3988 PL_in_eval = EVAL_INEVAL;
3989 if (flags & G_KEEPERR)
3990 PL_in_eval |= EVAL_KEEPERR;
3993 if (flags & G_FAKINGEVAL) {
3994 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4002 PERL_CONTEXT * const cx = create_eval_scope(0);
4003 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4004 return DOCATCH(PL_op->op_next);
4013 register PERL_CONTEXT *cx;
4018 PERL_UNUSED_VAR(optype);
4021 if (gimme == G_VOID)
4023 else if (gimme == G_SCALAR) {
4027 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4030 *MARK = sv_mortalcopy(TOPs);
4034 *MARK = &PL_sv_undef;
4039 /* in case LEAVE wipes old return values */
4041 for (mark = newsp + 1; mark <= SP; mark++) {
4042 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4043 *mark = sv_mortalcopy(*mark);
4044 TAINT_NOT; /* Each item is independent */
4048 PL_curpm = newpm; /* Don't pop $1 et al till now */
4050 LEAVE_with_name("eval_scope");
4058 register PERL_CONTEXT *cx;
4059 const I32 gimme = GIMME_V;
4061 ENTER_with_name("given");
4064 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
4066 PUSHBLOCK(cx, CXt_GIVEN, SP);
4075 register PERL_CONTEXT *cx;
4079 PERL_UNUSED_CONTEXT;
4082 assert(CxTYPE(cx) == CXt_GIVEN);
4087 PL_curpm = newpm; /* pop $1 et al */
4089 LEAVE_with_name("given");
4094 /* Helper routines used by pp_smartmatch */
4096 S_make_matcher(pTHX_ REGEXP *re)
4099 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4101 PERL_ARGS_ASSERT_MAKE_MATCHER;
4103 PM_SETRE(matcher, ReREFCNT_inc(re));
4105 SAVEFREEOP((OP *) matcher);
4106 ENTER_with_name("matcher"); SAVETMPS;
4112 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4117 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4119 PL_op = (OP *) matcher;
4124 return (SvTRUEx(POPs));
4128 S_destroy_matcher(pTHX_ PMOP *matcher)
4132 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4133 PERL_UNUSED_ARG(matcher);
4136 LEAVE_with_name("matcher");
4139 /* Do a smart match */
4142 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4143 return do_smartmatch(NULL, NULL);
4146 /* This version of do_smartmatch() implements the
4147 * table of smart matches that is found in perlsyn.
4150 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4155 bool object_on_left = FALSE;
4156 SV *e = TOPs; /* e is for 'expression' */
4157 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4159 /* First of all, handle overload magic of the rightmost argument */
4162 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4163 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4165 tmpsv = amagic_call(d, e, smart_amg, 0);
4172 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4175 SP -= 2; /* Pop the values */
4177 /* Take care only to invoke mg_get() once for each argument.
4178 * Currently we do this by copying the SV if it's magical. */
4181 d = sv_mortalcopy(d);
4188 e = sv_mortalcopy(e);
4192 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4199 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4200 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4201 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4203 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4204 object_on_left = TRUE;
4207 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4209 if (object_on_left) {
4210 goto sm_any_sub; /* Treat objects like scalars */
4212 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4213 /* Test sub truth for each key */
4215 bool andedresults = TRUE;
4216 HV *hv = (HV*) SvRV(d);
4217 I32 numkeys = hv_iterinit(hv);
4218 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4221 while ( (he = hv_iternext(hv)) ) {
4222 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4223 ENTER_with_name("smartmatch_hash_key_test");
4226 PUSHs(hv_iterkeysv(he));
4228 c = call_sv(e, G_SCALAR);
4231 andedresults = FALSE;
4233 andedresults = SvTRUEx(POPs) && andedresults;
4235 LEAVE_with_name("smartmatch_hash_key_test");
4242 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4243 /* Test sub truth for each element */
4245 bool andedresults = TRUE;
4246 AV *av = (AV*) SvRV(d);
4247 const I32 len = av_len(av);
4248 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4251 for (i = 0; i <= len; ++i) {
4252 SV * const * const svp = av_fetch(av, i, FALSE);
4253 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4254 ENTER_with_name("smartmatch_array_elem_test");
4260 c = call_sv(e, G_SCALAR);
4263 andedresults = FALSE;
4265 andedresults = SvTRUEx(POPs) && andedresults;
4267 LEAVE_with_name("smartmatch_array_elem_test");
4276 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4277 ENTER_with_name("smartmatch_coderef");
4282 c = call_sv(e, G_SCALAR);
4286 else if (SvTEMP(TOPs))
4287 SvREFCNT_inc_void(TOPs);
4289 LEAVE_with_name("smartmatch_coderef");
4294 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4295 if (object_on_left) {
4296 goto sm_any_hash; /* Treat objects like scalars */
4298 else if (!SvOK(d)) {
4299 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4302 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4303 /* Check that the key-sets are identical */
4305 HV *other_hv = MUTABLE_HV(SvRV(d));
4307 bool other_tied = FALSE;
4308 U32 this_key_count = 0,
4309 other_key_count = 0;
4310 HV *hv = MUTABLE_HV(SvRV(e));
4312 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4313 /* Tied hashes don't know how many keys they have. */
4314 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4317 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4318 HV * const temp = other_hv;
4323 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4326 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4329 /* The hashes have the same number of keys, so it suffices
4330 to check that one is a subset of the other. */
4331 (void) hv_iterinit(hv);
4332 while ( (he = hv_iternext(hv)) ) {
4333 SV *key = hv_iterkeysv(he);
4335 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4338 if(!hv_exists_ent(other_hv, key, 0)) {
4339 (void) hv_iterinit(hv); /* reset iterator */
4345 (void) hv_iterinit(other_hv);
4346 while ( hv_iternext(other_hv) )
4350 other_key_count = HvUSEDKEYS(other_hv);
4352 if (this_key_count != other_key_count)
4357 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4358 AV * const other_av = MUTABLE_AV(SvRV(d));
4359 const I32 other_len = av_len(other_av) + 1;
4361 HV *hv = MUTABLE_HV(SvRV(e));
4363 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4364 for (i = 0; i < other_len; ++i) {
4365 SV ** const svp = av_fetch(other_av, i, FALSE);
4366 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4367 if (svp) { /* ??? When can this not happen? */
4368 if (hv_exists_ent(hv, *svp, 0))
4374 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4375 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4378 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4380 HV *hv = MUTABLE_HV(SvRV(e));
4382 (void) hv_iterinit(hv);
4383 while ( (he = hv_iternext(hv)) ) {
4384 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4385 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4386 (void) hv_iterinit(hv);
4387 destroy_matcher(matcher);
4391 destroy_matcher(matcher);
4397 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4398 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4405 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4406 if (object_on_left) {
4407 goto sm_any_array; /* Treat objects like scalars */
4409 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4410 AV * const other_av = MUTABLE_AV(SvRV(e));
4411 const I32 other_len = av_len(other_av) + 1;
4414 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4415 for (i = 0; i < other_len; ++i) {
4416 SV ** const svp = av_fetch(other_av, i, FALSE);
4418 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4419 if (svp) { /* ??? When can this not happen? */
4420 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4426 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4427 AV *other_av = MUTABLE_AV(SvRV(d));
4428 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4429 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4433 const I32 other_len = av_len(other_av);
4435 if (NULL == seen_this) {
4436 seen_this = newHV();
4437 (void) sv_2mortal(MUTABLE_SV(seen_this));
4439 if (NULL == seen_other) {
4440 seen_other = newHV();
4441 (void) sv_2mortal(MUTABLE_SV(seen_other));
4443 for(i = 0; i <= other_len; ++i) {
4444 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4445 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4447 if (!this_elem || !other_elem) {
4448 if ((this_elem && SvOK(*this_elem))
4449 || (other_elem && SvOK(*other_elem)))
4452 else if (hv_exists_ent(seen_this,
4453 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4454 hv_exists_ent(seen_other,
4455 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4457 if (*this_elem != *other_elem)
4461 (void)hv_store_ent(seen_this,
4462 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4464 (void)hv_store_ent(seen_other,
4465 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4471 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4472 (void) do_smartmatch(seen_this, seen_other);
4474 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4483 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4484 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4487 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4488 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4491 for(i = 0; i <= this_len; ++i) {
4492 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4493 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4494 if (svp && matcher_matches_sv(matcher, *svp)) {
4495 destroy_matcher(matcher);
4499 destroy_matcher(matcher);
4503 else if (!SvOK(d)) {
4504 /* undef ~~ array */
4505 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4508 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4509 for (i = 0; i <= this_len; ++i) {
4510 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4511 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4512 if (!svp || !SvOK(*svp))
4521 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4523 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4524 for (i = 0; i <= this_len; ++i) {
4525 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4532 /* infinite recursion isn't supposed to happen here */
4533 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4534 (void) do_smartmatch(NULL, NULL);
4536 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4545 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4546 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4547 SV *t = d; d = e; e = t;
4548 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4551 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4552 SV *t = d; d = e; e = t;
4553 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4554 goto sm_regex_array;
4557 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4559 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4561 PUSHs(matcher_matches_sv(matcher, d)
4564 destroy_matcher(matcher);
4569 /* See if there is overload magic on left */
4570 else if (object_on_left && SvAMAGIC(d)) {
4572 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4573 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4576 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4584 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4587 else if (!SvOK(d)) {
4588 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4589 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4594 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4595 DEBUG_M(if (SvNIOK(e))
4596 Perl_deb(aTHX_ " applying rule Any-Num\n");
4598 Perl_deb(aTHX_ " applying rule Num-numish\n");
4600 /* numeric comparison */
4603 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4614 /* As a last resort, use string comparison */
4615 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4624 register PERL_CONTEXT *cx;
4625 const I32 gimme = GIMME_V;
4627 /* This is essentially an optimization: if the match
4628 fails, we don't want to push a context and then
4629 pop it again right away, so we skip straight
4630 to the op that follows the leavewhen.
4632 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4633 return cLOGOP->op_other->op_next;
4635 ENTER_with_name("eval");
4638 PUSHBLOCK(cx, CXt_WHEN, SP);
4647 register PERL_CONTEXT *cx;
4653 assert(CxTYPE(cx) == CXt_WHEN);
4658 PL_curpm = newpm; /* pop $1 et al */
4660 LEAVE_with_name("eval");
4668 register PERL_CONTEXT *cx;
4671 cxix = dopoptowhen(cxstack_ix);
4673 DIE(aTHX_ "Can't \"continue\" outside a when block");
4674 if (cxix < cxstack_ix)
4677 /* clear off anything above the scope we're re-entering */
4678 inner = PL_scopestack_ix;
4680 if (PL_scopestack_ix < inner)
4681 leave_scope(PL_scopestack[PL_scopestack_ix]);
4682 PL_curcop = cx->blk_oldcop;
4683 return cx->blk_givwhen.leave_op;
4690 register PERL_CONTEXT *cx;
4693 cxix = dopoptogiven(cxstack_ix);
4695 if (PL_op->op_flags & OPf_SPECIAL)
4696 DIE(aTHX_ "Can't use when() outside a topicalizer");
4698 DIE(aTHX_ "Can't \"break\" outside a given block");
4700 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4701 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4703 if (cxix < cxstack_ix)
4706 /* clear off anything above the scope we're re-entering */
4707 inner = PL_scopestack_ix;
4709 if (PL_scopestack_ix < inner)
4710 leave_scope(PL_scopestack[PL_scopestack_ix]);
4711 PL_curcop = cx->blk_oldcop;
4714 return CX_LOOP_NEXTOP_GET(cx);
4716 return cx->blk_givwhen.leave_op;
4720 S_doparseform(pTHX_ SV *sv)
4723 register char *s = SvPV_force(sv, len);
4724 register char * const send = s + len;
4725 register char *base = NULL;
4726 register I32 skipspaces = 0;
4727 bool noblank = FALSE;
4728 bool repeat = FALSE;
4729 bool postspace = FALSE;
4735 bool unchopnum = FALSE;
4736 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4738 PERL_ARGS_ASSERT_DOPARSEFORM;
4741 Perl_croak(aTHX_ "Null picture in formline");
4743 /* estimate the buffer size needed */
4744 for (base = s; s <= send; s++) {
4745 if (*s == '\n' || *s == '@' || *s == '^')
4751 Newx(fops, maxops, U32);
4756 *fpc++ = FF_LINEMARK;
4757 noblank = repeat = FALSE;
4775 case ' ': case '\t':
4782 } /* else FALL THROUGH */
4790 *fpc++ = FF_LITERAL;
4798 *fpc++ = (U16)skipspaces;
4802 *fpc++ = FF_NEWLINE;
4806 arg = fpc - linepc + 1;
4813 *fpc++ = FF_LINEMARK;
4814 noblank = repeat = FALSE;
4823 ischop = s[-1] == '^';
4829 arg = (s - base) - 1;
4831 *fpc++ = FF_LITERAL;
4839 *fpc++ = 2; /* skip the @* or ^* */
4841 *fpc++ = FF_LINESNGL;
4844 *fpc++ = FF_LINEGLOB;
4846 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4847 arg = ischop ? 512 : 0;
4852 const char * const f = ++s;
4855 arg |= 256 + (s - f);
4857 *fpc++ = s - base; /* fieldsize for FETCH */
4858 *fpc++ = FF_DECIMAL;
4860 unchopnum |= ! ischop;
4862 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4863 arg = ischop ? 512 : 0;
4865 s++; /* skip the '0' first */
4869 const char * const f = ++s;
4872 arg |= 256 + (s - f);
4874 *fpc++ = s - base; /* fieldsize for FETCH */
4875 *fpc++ = FF_0DECIMAL;
4877 unchopnum |= ! ischop;
4881 bool ismore = FALSE;
4884 while (*++s == '>') ;
4885 prespace = FF_SPACE;
4887 else if (*s == '|') {
4888 while (*++s == '|') ;
4889 prespace = FF_HALFSPACE;
4894 while (*++s == '<') ;
4897 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4901 *fpc++ = s - base; /* fieldsize for FETCH */
4903 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4906 *fpc++ = (U16)prespace;
4920 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4922 { /* need to jump to the next word */
4924 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4925 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4926 s = SvPVX(sv) + SvCUR(sv) + z;
4928 Copy(fops, s, arg, U32);
4930 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4933 if (unchopnum && repeat)
4934 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4940 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4942 /* Can value be printed in fldsize chars, using %*.*f ? */
4946 int intsize = fldsize - (value < 0 ? 1 : 0);
4953 while (intsize--) pwr *= 10.0;
4954 while (frcsize--) eps /= 10.0;
4957 if (value + eps >= pwr)
4960 if (value - eps <= -pwr)
4967 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4970 SV * const datasv = FILTER_DATA(idx);
4971 const int filter_has_file = IoLINES(datasv);
4972 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4973 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4978 char *prune_from = NULL;
4979 bool read_from_cache = FALSE;
4982 PERL_ARGS_ASSERT_RUN_USER_FILTER;
4984 assert(maxlen >= 0);
4987 /* I was having segfault trouble under Linux 2.2.5 after a
4988 parse error occured. (Had to hack around it with a test
4989 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4990 not sure where the trouble is yet. XXX */
4993 SV *const cache = datasv;
4996 const char *cache_p = SvPV(cache, cache_len);
5000 /* Running in block mode and we have some cached data already.
5002 if (cache_len >= umaxlen) {
5003 /* In fact, so much data we don't even need to call
5008 const char *const first_nl =
5009 (const char *)memchr(cache_p, '\n', cache_len);
5011 take = first_nl + 1 - cache_p;
5015 sv_catpvn(buf_sv, cache_p, take);
5016 sv_chop(cache, cache_p + take);
5017 /* Definately not EOF */
5021 sv_catsv(buf_sv, cache);
5023 umaxlen -= cache_len;
5026 read_from_cache = TRUE;
5030 /* Filter API says that the filter appends to the contents of the buffer.
5031 Usually the buffer is "", so the details don't matter. But if it's not,
5032 then clearly what it contains is already filtered by this filter, so we
5033 don't want to pass it in a second time.
5034 I'm going to use a mortal in case the upstream filter croaks. */
5035 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5036 ? sv_newmortal() : buf_sv;
5037 SvUPGRADE(upstream, SVt_PV);
5039 if (filter_has_file) {
5040 status = FILTER_READ(idx+1, upstream, 0);
5043 if (filter_sub && status >= 0) {
5047 ENTER_with_name("call_filter_sub");
5052 DEFSV_set(upstream);
5056 PUSHs(filter_state);
5059 count = call_sv(filter_sub, G_SCALAR);
5071 LEAVE_with_name("call_filter_sub");
5074 if(SvOK(upstream)) {
5075 got_p = SvPV(upstream, got_len);
5077 if (got_len > umaxlen) {
5078 prune_from = got_p + umaxlen;
5081 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5082 if (first_nl && first_nl + 1 < got_p + got_len) {
5083 /* There's a second line here... */
5084 prune_from = first_nl + 1;
5089 /* Oh. Too long. Stuff some in our cache. */
5090 STRLEN cached_len = got_p + got_len - prune_from;
5091 SV *const cache = datasv;
5094 /* Cache should be empty. */
5095 assert(!SvCUR(cache));
5098 sv_setpvn(cache, prune_from, cached_len);
5099 /* If you ask for block mode, you may well split UTF-8 characters.
5100 "If it breaks, you get to keep both parts"
5101 (Your code is broken if you don't put them back together again
5102 before something notices.) */
5103 if (SvUTF8(upstream)) {
5106 SvCUR_set(upstream, got_len - cached_len);
5108 /* Can't yet be EOF */
5113 /* If they are at EOF but buf_sv has something in it, then they may never
5114 have touched the SV upstream, so it may be undefined. If we naively
5115 concatenate it then we get a warning about use of uninitialised value.
5117 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5118 sv_catsv(buf_sv, upstream);
5122 IoLINES(datasv) = 0;
5124 SvREFCNT_dec(filter_state);
5125 IoTOP_GV(datasv) = NULL;
5128 SvREFCNT_dec(filter_sub);
5129 IoBOTTOM_GV(datasv) = NULL;
5131 filter_del(S_run_user_filter);
5133 if (status == 0 && read_from_cache) {
5134 /* If we read some data from the cache (and by getting here it implies
5135 that we emptied the cache) then we aren't yet at EOF, and mustn't
5136 report that to our caller. */
5142 /* perhaps someone can come up with a better name for
5143 this? it is not really "absolute", per se ... */
5145 S_path_is_absolute(const char *name)
5147 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5149 if (PERL_FILE_IS_ABSOLUTE(name)
5151 || (*name == '.' && ((name[1] == '/' ||
5152 (name[1] == '.' && name[2] == '/'))
5153 || (name[1] == '\\' ||
5154 ( name[1] == '.' && name[2] == '\\')))
5157 || (*name == '.' && (name[1] == '/' ||
5158 (name[1] == '.' && name[2] == '/')))
5170 * c-indentation-style: bsd
5172 * indent-tabs-mode: t
5175 * ex: set ts=8 sts=4 sw=4 noet: