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)
1626 register PERL_CONTEXT *cx;
1629 if (cxix < cxstack_ix)
1632 POPBLOCK(cx,PL_curpm);
1633 if (CxTYPE(cx) != CXt_EVAL) {
1635 const char* message = SvPVx_const( msv ? msv : ERRSV, msglen);
1636 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1637 PerlIO_write(Perl_error_log, message, msglen);
1642 if (gimme == G_SCALAR)
1643 *++newsp = &PL_sv_undef;
1644 PL_stack_sp = newsp;
1648 /* LEAVE could clobber PL_curcop (see save_re_context())
1649 * XXX it might be better to find a way to avoid messing with
1650 * PL_curcop in save_re_context() instead, but this is a more
1651 * minimal fix --GSAR */
1652 PL_curcop = cx->blk_oldcop;
1654 if (optype == OP_REQUIRE) {
1655 const char* const msg = SvPVx_nolen_const(ERRSV);
1656 SV * const nsv = cx->blk_eval.old_namesv;
1657 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1659 /* note that unlike pp_entereval, pp_require isn't
1660 * supposed to trap errors. So now that we've popped the
1661 * EVAL that pp_require pushed, and processed the error
1662 * message, rethrow the error */
1663 DIE(aTHX_ "%sCompilation failed in require",
1664 *msg ? msg : "Unknown error\n");
1666 assert(CxTYPE(cx) == CXt_EVAL);
1667 PL_restartop = cx->blk_eval.retop;
1673 write_to_stderr( msv ? msv : ERRSV );
1680 dVAR; dSP; dPOPTOPssrl;
1681 if (SvTRUE(left) != SvTRUE(right))
1691 register I32 cxix = dopoptosub(cxstack_ix);
1692 register const PERL_CONTEXT *cx;
1693 register const PERL_CONTEXT *ccstack = cxstack;
1694 const PERL_SI *top_si = PL_curstackinfo;
1696 const char *stashname;
1703 /* we may be in a higher stacklevel, so dig down deeper */
1704 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1705 top_si = top_si->si_prev;
1706 ccstack = top_si->si_cxstack;
1707 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1710 if (GIMME != G_ARRAY) {
1716 /* caller() should not report the automatic calls to &DB::sub */
1717 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1718 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1722 cxix = dopoptosub_at(ccstack, cxix - 1);
1725 cx = &ccstack[cxix];
1726 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1727 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1728 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1729 field below is defined for any cx. */
1730 /* caller() should not report the automatic calls to &DB::sub */
1731 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1732 cx = &ccstack[dbcxix];
1735 stashname = CopSTASHPV(cx->blk_oldcop);
1736 if (GIMME != G_ARRAY) {
1739 PUSHs(&PL_sv_undef);
1742 sv_setpv(TARG, stashname);
1751 PUSHs(&PL_sv_undef);
1753 mPUSHs(newSVpv(stashname, 0));
1754 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1755 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1758 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1759 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1760 /* So is ccstack[dbcxix]. */
1762 SV * const sv = newSV(0);
1763 gv_efullname3(sv, cvgv, NULL);
1765 PUSHs(boolSV(CxHASARGS(cx)));
1768 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1769 PUSHs(boolSV(CxHASARGS(cx)));
1773 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1776 gimme = (I32)cx->blk_gimme;
1777 if (gimme == G_VOID)
1778 PUSHs(&PL_sv_undef);
1780 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1781 if (CxTYPE(cx) == CXt_EVAL) {
1783 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1784 PUSHs(cx->blk_eval.cur_text);
1788 else if (cx->blk_eval.old_namesv) {
1789 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1792 /* eval BLOCK (try blocks have old_namesv == 0) */
1794 PUSHs(&PL_sv_undef);
1795 PUSHs(&PL_sv_undef);
1799 PUSHs(&PL_sv_undef);
1800 PUSHs(&PL_sv_undef);
1802 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1803 && CopSTASH_eq(PL_curcop, PL_debstash))
1805 AV * const ary = cx->blk_sub.argarray;
1806 const int off = AvARRAY(ary) - AvALLOC(ary);
1809 PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
1811 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1814 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1815 av_extend(PL_dbargs, AvFILLp(ary) + off);
1816 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1817 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1819 /* XXX only hints propagated via op_private are currently
1820 * visible (others are not easily accessible, since they
1821 * use the global PL_hints) */
1822 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1825 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1827 if (old_warnings == pWARN_NONE ||
1828 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1829 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1830 else if (old_warnings == pWARN_ALL ||
1831 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1832 /* Get the bit mask for $warnings::Bits{all}, because
1833 * it could have been extended by warnings::register */
1835 HV * const bits = get_hv("warnings::Bits", 0);
1836 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1837 mask = newSVsv(*bits_all);
1840 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1844 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1848 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1849 sv_2mortal(newRV_noinc(
1850 MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1851 cx->blk_oldcop->cop_hints_hash))))
1860 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1861 sv_reset(tmps, CopSTASH(PL_curcop));
1866 /* like pp_nextstate, but used instead when the debugger is active */
1871 PL_curcop = (COP*)PL_op;
1872 TAINT_NOT; /* Each statement is presumed innocent */
1873 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1878 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1879 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1882 register PERL_CONTEXT *cx;
1883 const I32 gimme = G_ARRAY;
1885 GV * const gv = PL_DBgv;
1886 register CV * const cv = GvCV(gv);
1889 DIE(aTHX_ "No DB::DB routine defined");
1891 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1892 /* don't do recursive DB::DB call */
1907 (void)(*CvXSUB(cv))(aTHX_ cv);
1914 PUSHBLOCK(cx, CXt_SUB, SP);
1916 cx->blk_sub.retop = PL_op->op_next;
1919 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1920 RETURNOP(CvSTART(cv));
1930 register PERL_CONTEXT *cx;
1931 const I32 gimme = GIMME_V;
1933 U8 cxtype = CXt_LOOP_FOR;
1938 ENTER_with_name("loop1");
1941 if (PL_op->op_targ) {
1942 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1943 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1944 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1945 SVs_PADSTALE, SVs_PADSTALE);
1947 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1948 #ifndef USE_ITHREADS
1949 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1955 GV * const gv = MUTABLE_GV(POPs);
1956 svp = &GvSV(gv); /* symbol table variable */
1957 SAVEGENERICSV(*svp);
1960 iterdata = (PAD*)gv;
1964 if (PL_op->op_private & OPpITER_DEF)
1965 cxtype |= CXp_FOR_DEF;
1967 ENTER_with_name("loop2");
1969 PUSHBLOCK(cx, cxtype, SP);
1971 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1973 PUSHLOOP_FOR(cx, svp, MARK, 0);
1975 if (PL_op->op_flags & OPf_STACKED) {
1976 SV *maybe_ary = POPs;
1977 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1979 SV * const right = maybe_ary;
1982 if (RANGE_IS_NUMERIC(sv,right)) {
1983 cx->cx_type &= ~CXTYPEMASK;
1984 cx->cx_type |= CXt_LOOP_LAZYIV;
1985 /* Make sure that no-one re-orders cop.h and breaks our
1987 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1988 #ifdef NV_PRESERVES_UV
1989 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1990 (SvNV(sv) > (NV)IV_MAX)))
1992 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1993 (SvNV(right) < (NV)IV_MIN))))
1995 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1998 ((SvUV(sv) > (UV)IV_MAX) ||
1999 (SvNV(sv) > (NV)UV_MAX)))))
2001 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
2003 ((SvNV(right) > 0) &&
2004 ((SvUV(right) > (UV)IV_MAX) ||
2005 (SvNV(right) > (NV)UV_MAX))))))
2007 DIE(aTHX_ "Range iterator outside integer range");
2008 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
2009 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
2011 /* for correct -Dstv display */
2012 cx->blk_oldsp = sp - PL_stack_base;
2016 cx->cx_type &= ~CXTYPEMASK;
2017 cx->cx_type |= CXt_LOOP_LAZYSV;
2018 /* Make sure that no-one re-orders cop.h and breaks our
2020 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2021 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2022 cx->blk_loop.state_u.lazysv.end = right;
2023 SvREFCNT_inc(right);
2024 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2025 /* This will do the upgrade to SVt_PV, and warn if the value
2026 is uninitialised. */
2027 (void) SvPV_nolen_const(right);
2028 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2029 to replace !SvOK() with a pointer to "". */
2031 SvREFCNT_dec(right);
2032 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2036 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2037 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2038 SvREFCNT_inc(maybe_ary);
2039 cx->blk_loop.state_u.ary.ix =
2040 (PL_op->op_private & OPpITER_REVERSED) ?
2041 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2045 else { /* iterating over items on the stack */
2046 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2047 if (PL_op->op_private & OPpITER_REVERSED) {
2048 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2051 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2061 register PERL_CONTEXT *cx;
2062 const I32 gimme = GIMME_V;
2064 ENTER_with_name("loop1");
2066 ENTER_with_name("loop2");
2068 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2069 PUSHLOOP_PLAIN(cx, SP);
2077 register PERL_CONTEXT *cx;
2084 assert(CxTYPE_is_LOOP(cx));
2086 newsp = PL_stack_base + cx->blk_loop.resetsp;
2089 if (gimme == G_VOID)
2091 else if (gimme == G_SCALAR) {
2093 *++newsp = sv_mortalcopy(*SP);
2095 *++newsp = &PL_sv_undef;
2099 *++newsp = sv_mortalcopy(*++mark);
2100 TAINT_NOT; /* Each item is independent */
2106 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2107 PL_curpm = newpm; /* ... and pop $1 et al */
2109 LEAVE_with_name("loop2");
2110 LEAVE_with_name("loop1");
2118 register PERL_CONTEXT *cx;
2119 bool popsub2 = FALSE;
2120 bool clear_errsv = FALSE;
2128 const I32 cxix = dopoptosub(cxstack_ix);
2131 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2132 * sort block, which is a CXt_NULL
2135 PL_stack_base[1] = *PL_stack_sp;
2136 PL_stack_sp = PL_stack_base + 1;
2140 DIE(aTHX_ "Can't return outside a subroutine");
2142 if (cxix < cxstack_ix)
2145 if (CxMULTICALL(&cxstack[cxix])) {
2146 gimme = cxstack[cxix].blk_gimme;
2147 if (gimme == G_VOID)
2148 PL_stack_sp = PL_stack_base;
2149 else if (gimme == G_SCALAR) {
2150 PL_stack_base[1] = *PL_stack_sp;
2151 PL_stack_sp = PL_stack_base + 1;
2157 switch (CxTYPE(cx)) {
2160 retop = cx->blk_sub.retop;
2161 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2164 if (!(PL_in_eval & EVAL_KEEPERR))
2167 retop = cx->blk_eval.retop;
2171 if (optype == OP_REQUIRE &&
2172 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2174 /* Unassume the success we assumed earlier. */
2175 SV * const nsv = cx->blk_eval.old_namesv;
2176 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2177 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2182 retop = cx->blk_sub.retop;
2185 DIE(aTHX_ "panic: return");
2189 if (gimme == G_SCALAR) {
2192 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2194 *++newsp = SvREFCNT_inc(*SP);
2199 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2201 *++newsp = sv_mortalcopy(sv);
2206 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2209 *++newsp = sv_mortalcopy(*SP);
2212 *++newsp = &PL_sv_undef;
2214 else if (gimme == G_ARRAY) {
2215 while (++MARK <= SP) {
2216 *++newsp = (popsub2 && SvTEMP(*MARK))
2217 ? *MARK : sv_mortalcopy(*MARK);
2218 TAINT_NOT; /* Each item is independent */
2221 PL_stack_sp = newsp;
2224 /* Stack values are safe: */
2227 POPSUB(cx,sv); /* release CV and @_ ... */
2231 PL_curpm = newpm; /* ... and pop $1 et al */
2244 register PERL_CONTEXT *cx;
2255 if (PL_op->op_flags & OPf_SPECIAL) {
2256 cxix = dopoptoloop(cxstack_ix);
2258 DIE(aTHX_ "Can't \"last\" outside a loop block");
2261 cxix = dopoptolabel(cPVOP->op_pv);
2263 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2265 if (cxix < cxstack_ix)
2269 cxstack_ix++; /* temporarily protect top context */
2271 switch (CxTYPE(cx)) {
2272 case CXt_LOOP_LAZYIV:
2273 case CXt_LOOP_LAZYSV:
2275 case CXt_LOOP_PLAIN:
2277 newsp = PL_stack_base + cx->blk_loop.resetsp;
2278 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2282 nextop = cx->blk_sub.retop;
2286 nextop = cx->blk_eval.retop;
2290 nextop = cx->blk_sub.retop;
2293 DIE(aTHX_ "panic: last");
2297 if (gimme == G_SCALAR) {
2299 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2300 ? *SP : sv_mortalcopy(*SP);
2302 *++newsp = &PL_sv_undef;
2304 else if (gimme == G_ARRAY) {
2305 while (++MARK <= SP) {
2306 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2307 ? *MARK : sv_mortalcopy(*MARK);
2308 TAINT_NOT; /* Each item is independent */
2316 /* Stack values are safe: */
2318 case CXt_LOOP_LAZYIV:
2319 case CXt_LOOP_PLAIN:
2320 case CXt_LOOP_LAZYSV:
2322 POPLOOP(cx); /* release loop vars ... */
2326 POPSUB(cx,sv); /* release CV and @_ ... */
2329 PL_curpm = newpm; /* ... and pop $1 et al */
2332 PERL_UNUSED_VAR(optype);
2333 PERL_UNUSED_VAR(gimme);
2341 register PERL_CONTEXT *cx;
2344 if (PL_op->op_flags & OPf_SPECIAL) {
2345 cxix = dopoptoloop(cxstack_ix);
2347 DIE(aTHX_ "Can't \"next\" outside a loop block");
2350 cxix = dopoptolabel(cPVOP->op_pv);
2352 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2354 if (cxix < cxstack_ix)
2357 /* clear off anything above the scope we're re-entering, but
2358 * save the rest until after a possible continue block */
2359 inner = PL_scopestack_ix;
2361 if (PL_scopestack_ix < inner)
2362 leave_scope(PL_scopestack[PL_scopestack_ix]);
2363 PL_curcop = cx->blk_oldcop;
2364 return CX_LOOP_NEXTOP_GET(cx);
2371 register PERL_CONTEXT *cx;
2375 if (PL_op->op_flags & OPf_SPECIAL) {
2376 cxix = dopoptoloop(cxstack_ix);
2378 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2381 cxix = dopoptolabel(cPVOP->op_pv);
2383 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2385 if (cxix < cxstack_ix)
2388 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2389 if (redo_op->op_type == OP_ENTER) {
2390 /* pop one less context to avoid $x being freed in while (my $x..) */
2392 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2393 redo_op = redo_op->op_next;
2397 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2398 LEAVE_SCOPE(oldsave);
2400 PL_curcop = cx->blk_oldcop;
2405 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2409 static const char too_deep[] = "Target of goto is too deeply nested";
2411 PERL_ARGS_ASSERT_DOFINDLABEL;
2414 Perl_croak(aTHX_ too_deep);
2415 if (o->op_type == OP_LEAVE ||
2416 o->op_type == OP_SCOPE ||
2417 o->op_type == OP_LEAVELOOP ||
2418 o->op_type == OP_LEAVESUB ||
2419 o->op_type == OP_LEAVETRY)
2421 *ops++ = cUNOPo->op_first;
2423 Perl_croak(aTHX_ too_deep);
2426 if (o->op_flags & OPf_KIDS) {
2428 /* First try all the kids at this level, since that's likeliest. */
2429 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2430 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2431 const char *kid_label = CopLABEL(kCOP);
2432 if (kid_label && strEQ(kid_label, label))
2436 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2437 if (kid == PL_lastgotoprobe)
2439 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2442 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2443 ops[-1]->op_type == OP_DBSTATE)
2448 if ((o = dofindlabel(kid, label, ops, oplimit)))
2461 register PERL_CONTEXT *cx;
2462 #define GOTO_DEPTH 64
2463 OP *enterops[GOTO_DEPTH];
2464 const char *label = NULL;
2465 const bool do_dump = (PL_op->op_type == OP_DUMP);
2466 static const char must_have_label[] = "goto must have label";
2468 if (PL_op->op_flags & OPf_STACKED) {
2469 SV * const sv = POPs;
2471 /* This egregious kludge implements goto &subroutine */
2472 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2474 register PERL_CONTEXT *cx;
2475 CV *cv = MUTABLE_CV(SvRV(sv));
2482 if (!CvROOT(cv) && !CvXSUB(cv)) {
2483 const GV * const gv = CvGV(cv);
2487 /* autoloaded stub? */
2488 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2490 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2491 GvNAMELEN(gv), FALSE);
2492 if (autogv && (cv = GvCV(autogv)))
2494 tmpstr = sv_newmortal();
2495 gv_efullname3(tmpstr, gv, NULL);
2496 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2498 DIE(aTHX_ "Goto undefined subroutine");
2501 /* First do some returnish stuff. */
2502 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2504 cxix = dopoptosub(cxstack_ix);
2506 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2507 if (cxix < cxstack_ix)
2511 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2512 if (CxTYPE(cx) == CXt_EVAL) {
2514 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2516 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2518 else if (CxMULTICALL(cx))
2519 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2520 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2521 /* put @_ back onto stack */
2522 AV* av = cx->blk_sub.argarray;
2524 items = AvFILLp(av) + 1;
2525 EXTEND(SP, items+1); /* @_ could have been extended. */
2526 Copy(AvARRAY(av), SP + 1, items, SV*);
2527 SvREFCNT_dec(GvAV(PL_defgv));
2528 GvAV(PL_defgv) = cx->blk_sub.savearray;
2530 /* abandon @_ if it got reified */
2535 av_extend(av, items-1);
2537 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2540 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2541 AV* const av = GvAV(PL_defgv);
2542 items = AvFILLp(av) + 1;
2543 EXTEND(SP, items+1); /* @_ could have been extended. */
2544 Copy(AvARRAY(av), SP + 1, items, SV*);
2548 if (CxTYPE(cx) == CXt_SUB &&
2549 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2550 SvREFCNT_dec(cx->blk_sub.cv);
2551 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2552 LEAVE_SCOPE(oldsave);
2554 /* Now do some callish stuff. */
2556 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2558 OP* const retop = cx->blk_sub.retop;
2563 for (index=0; index<items; index++)
2564 sv_2mortal(SP[-index]);
2567 /* XS subs don't have a CxSUB, so pop it */
2568 POPBLOCK(cx, PL_curpm);
2569 /* Push a mark for the start of arglist */
2572 (void)(*CvXSUB(cv))(aTHX_ cv);
2577 AV* const padlist = CvPADLIST(cv);
2578 if (CxTYPE(cx) == CXt_EVAL) {
2579 PL_in_eval = CxOLD_IN_EVAL(cx);
2580 PL_eval_root = cx->blk_eval.old_eval_root;
2581 cx->cx_type = CXt_SUB;
2583 cx->blk_sub.cv = cv;
2584 cx->blk_sub.olddepth = CvDEPTH(cv);
2587 if (CvDEPTH(cv) < 2)
2588 SvREFCNT_inc_simple_void_NN(cv);
2590 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2591 sub_crush_depth(cv);
2592 pad_push(padlist, CvDEPTH(cv));
2595 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2598 AV *const av = MUTABLE_AV(PAD_SVl(0));
2600 cx->blk_sub.savearray = GvAV(PL_defgv);
2601 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2602 CX_CURPAD_SAVE(cx->blk_sub);
2603 cx->blk_sub.argarray = av;
2605 if (items >= AvMAX(av) + 1) {
2606 SV **ary = AvALLOC(av);
2607 if (AvARRAY(av) != ary) {
2608 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2611 if (items >= AvMAX(av) + 1) {
2612 AvMAX(av) = items - 1;
2613 Renew(ary,items+1,SV*);
2619 Copy(mark,AvARRAY(av),items,SV*);
2620 AvFILLp(av) = items - 1;
2621 assert(!AvREAL(av));
2623 /* transfer 'ownership' of refcnts to new @_ */
2633 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2634 Perl_get_db_sub(aTHX_ NULL, cv);
2636 CV * const gotocv = get_cvs("DB::goto", 0);
2638 PUSHMARK( PL_stack_sp );
2639 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2644 RETURNOP(CvSTART(cv));
2648 label = SvPV_nolen_const(sv);
2649 if (!(do_dump || *label))
2650 DIE(aTHX_ must_have_label);
2653 else if (PL_op->op_flags & OPf_SPECIAL) {
2655 DIE(aTHX_ must_have_label);
2658 label = cPVOP->op_pv;
2662 if (label && *label) {
2663 OP *gotoprobe = NULL;
2664 bool leaving_eval = FALSE;
2665 bool in_block = FALSE;
2666 PERL_CONTEXT *last_eval_cx = NULL;
2670 PL_lastgotoprobe = NULL;
2672 for (ix = cxstack_ix; ix >= 0; ix--) {
2674 switch (CxTYPE(cx)) {
2676 leaving_eval = TRUE;
2677 if (!CxTRYBLOCK(cx)) {
2678 gotoprobe = (last_eval_cx ?
2679 last_eval_cx->blk_eval.old_eval_root :
2684 /* else fall through */
2685 case CXt_LOOP_LAZYIV:
2686 case CXt_LOOP_LAZYSV:
2688 case CXt_LOOP_PLAIN:
2691 gotoprobe = cx->blk_oldcop->op_sibling;
2697 gotoprobe = cx->blk_oldcop->op_sibling;
2700 gotoprobe = PL_main_root;
2703 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2704 gotoprobe = CvROOT(cx->blk_sub.cv);
2710 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2713 DIE(aTHX_ "panic: goto");
2714 gotoprobe = PL_main_root;
2718 retop = dofindlabel(gotoprobe, label,
2719 enterops, enterops + GOTO_DEPTH);
2723 PL_lastgotoprobe = gotoprobe;
2726 DIE(aTHX_ "Can't find label %s", label);
2728 /* if we're leaving an eval, check before we pop any frames
2729 that we're not going to punt, otherwise the error
2732 if (leaving_eval && *enterops && enterops[1]) {
2734 for (i = 1; enterops[i]; i++)
2735 if (enterops[i]->op_type == OP_ENTERITER)
2736 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2739 if (*enterops && enterops[1]) {
2740 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2742 deprecate("\"goto\" to jump into a construct");
2745 /* pop unwanted frames */
2747 if (ix < cxstack_ix) {
2754 oldsave = PL_scopestack[PL_scopestack_ix];
2755 LEAVE_SCOPE(oldsave);
2758 /* push wanted frames */
2760 if (*enterops && enterops[1]) {
2761 OP * const oldop = PL_op;
2762 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2763 for (; enterops[ix]; ix++) {
2764 PL_op = enterops[ix];
2765 /* Eventually we may want to stack the needed arguments
2766 * for each op. For now, we punt on the hard ones. */
2767 if (PL_op->op_type == OP_ENTERITER)
2768 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2769 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2777 if (!retop) retop = PL_main_start;
2779 PL_restartop = retop;
2780 PL_do_undump = TRUE;
2784 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2785 PL_do_undump = FALSE;
2802 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2804 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2807 PL_exit_flags |= PERL_EXIT_EXPECTED;
2809 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2810 if (anum || !(PL_minus_c && PL_madskills))
2815 PUSHs(&PL_sv_undef);
2822 S_save_lines(pTHX_ AV *array, SV *sv)
2824 const char *s = SvPVX_const(sv);
2825 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2828 PERL_ARGS_ASSERT_SAVE_LINES;
2830 while (s && s < send) {
2832 SV * const tmpstr = newSV_type(SVt_PVMG);
2834 t = (const char *)memchr(s, '\n', send - s);
2840 sv_setpvn(tmpstr, s, t - s);
2841 av_store(array, line++, tmpstr);
2849 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
2851 0 is used as continue inside eval,
2853 3 is used for a die caught by an inner eval - continue inner loop
2855 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
2856 establish a local jmpenv to handle exception traps.
2861 S_docatch(pTHX_ OP *o)
2865 OP * const oldop = PL_op;
2869 assert(CATCH_GET == TRUE);
2876 assert(cxstack_ix >= 0);
2877 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2878 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2883 /* die caught by an inner eval - continue inner loop */
2885 /* NB XXX we rely on the old popped CxEVAL still being at the top
2886 * of the stack; the way die_where() currently works, this
2887 * assumption is valid. In theory The cur_top_env value should be
2888 * returned in another global, the way retop (aka PL_restartop)
2890 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2893 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2895 PL_op = PL_restartop;
2911 /* James Bond: Do you expect me to talk?
2912 Auric Goldfinger: No, Mr. Bond. I expect you to die.
2914 This code is an ugly hack, doesn't work with lexicals in subroutines that are
2915 called more than once, and is only used by regcomp.c, for (?{}) blocks.
2917 Currently it is not used outside the core code. Best if it stays that way.
2920 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2921 /* sv Text to convert to OP tree. */
2922 /* startop op_free() this to undo. */
2923 /* code Short string id of the caller. */
2925 dVAR; dSP; /* Make POPBLOCK work. */
2931 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2932 char *tmpbuf = tbuf;
2935 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2938 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2940 ENTER_with_name("eval");
2941 lex_start(sv, NULL, FALSE);
2943 /* switch to eval mode */
2945 if (IN_PERL_COMPILETIME) {
2946 SAVECOPSTASH_FREE(&PL_compiling);
2947 CopSTASH_set(&PL_compiling, PL_curstash);
2949 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2950 SV * const sv = sv_newmortal();
2951 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2952 code, (unsigned long)++PL_evalseq,
2953 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2958 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2959 (unsigned long)++PL_evalseq);
2960 SAVECOPFILE_FREE(&PL_compiling);
2961 CopFILE_set(&PL_compiling, tmpbuf+2);
2962 SAVECOPLINE(&PL_compiling);
2963 CopLINE_set(&PL_compiling, 1);
2964 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2965 deleting the eval's FILEGV from the stash before gv_check() runs
2966 (i.e. before run-time proper). To work around the coredump that
2967 ensues, we always turn GvMULTI_on for any globals that were
2968 introduced within evals. See force_ident(). GSAR 96-10-12 */
2969 safestr = savepvn(tmpbuf, len);
2970 SAVEDELETE(PL_defstash, safestr, len);
2972 #ifdef OP_IN_REGISTER
2978 /* we get here either during compilation, or via pp_regcomp at runtime */
2979 runtime = IN_PERL_RUNTIME;
2981 runcv = find_runcv(NULL);
2984 PL_op->op_type = OP_ENTEREVAL;
2985 PL_op->op_flags = 0; /* Avoid uninit warning. */
2986 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2990 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2992 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2993 POPBLOCK(cx,PL_curpm);
2996 (*startop)->op_type = OP_NULL;
2997 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2999 /* XXX DAPM do this properly one year */
3000 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
3001 LEAVE_with_name("eval");
3002 if (IN_PERL_COMPILETIME)
3003 CopHINTS_set(&PL_compiling, PL_hints);
3004 #ifdef OP_IN_REGISTER
3007 PERL_UNUSED_VAR(newsp);
3008 PERL_UNUSED_VAR(optype);
3010 return PL_eval_start;
3015 =for apidoc find_runcv
3017 Locate the CV corresponding to the currently executing sub or eval.
3018 If db_seqp is non_null, skip CVs that are in the DB package and populate
3019 *db_seqp with the cop sequence number at the point that the DB:: code was
3020 entered. (allows debuggers to eval in the scope of the breakpoint rather
3021 than in the scope of the debugger itself).
3027 Perl_find_runcv(pTHX_ U32 *db_seqp)
3033 *db_seqp = PL_curcop->cop_seq;
3034 for (si = PL_curstackinfo; si; si = si->si_prev) {
3036 for (ix = si->si_cxix; ix >= 0; ix--) {
3037 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3038 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3039 CV * const cv = cx->blk_sub.cv;
3040 /* skip DB:: code */
3041 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3042 *db_seqp = cx->blk_oldcop->cop_seq;
3047 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3055 /* Run yyparse() in a setjmp wrapper. Returns:
3056 * 0: yyparse() successful
3057 * 1: yyparse() failed
3066 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3070 ret = yyparse() ? 1 : 0;
3084 /* Compile a require/do, an eval '', or a /(?{...})/.
3085 * In the last case, startop is non-null, and contains the address of
3086 * a pointer that should be set to the just-compiled code.
3087 * outside is the lexically enclosing CV (if any) that invoked us.
3088 * Returns a bool indicating whether the compile was successful; if so,
3089 * PL_eval_start contains the first op of the compiled ocde; otherwise,
3090 * pushes undef (also croaks if startop != NULL).
3094 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3097 OP * const saveop = PL_op;
3098 bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3101 PL_in_eval = (in_require
3102 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3107 SAVESPTR(PL_compcv);
3108 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3109 CvEVAL_on(PL_compcv);
3110 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3111 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3113 CvOUTSIDE_SEQ(PL_compcv) = seq;
3114 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3116 /* set up a scratch pad */
3118 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3119 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3123 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3125 /* make sure we compile in the right package */
3127 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3128 SAVESPTR(PL_curstash);
3129 PL_curstash = CopSTASH(PL_curcop);
3131 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3132 SAVESPTR(PL_beginav);
3133 PL_beginav = newAV();
3134 SAVEFREESV(PL_beginav);
3135 SAVESPTR(PL_unitcheckav);
3136 PL_unitcheckav = newAV();
3137 SAVEFREESV(PL_unitcheckav);
3140 SAVEBOOL(PL_madskills);
3144 /* try to compile it */
3146 PL_eval_root = NULL;
3147 PL_curcop = &PL_compiling;
3148 CopARYBASE_set(PL_curcop, 0);
3149 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3150 PL_in_eval |= EVAL_KEEPERR;
3154 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3155 * so honour CATCH_GET and trap it here if necessary */
3157 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX) : yyparse();
3159 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3160 SV **newsp; /* Used by POPBLOCK. */
3161 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
3162 I32 optype; /* Used by POPEVAL. */
3165 PERL_UNUSED_VAR(newsp);
3166 PERL_UNUSED_VAR(optype);
3170 op_free(PL_eval_root);
3171 PL_eval_root = NULL;
3173 if (yystatus != 3) {
3174 SP = PL_stack_base + POPMARK; /* pop original mark */
3176 POPBLOCK(cx,PL_curpm);
3182 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3184 msg = SvPVx_nolen_const(ERRSV);
3186 const SV * const nsv = cx->blk_eval.old_namesv;
3187 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3189 Perl_croak(aTHX_ "%sCompilation failed in require",
3190 *msg ? msg : "Unknown error\n");
3193 if (yystatus != 3) {
3194 POPBLOCK(cx,PL_curpm);
3197 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3198 (*msg ? msg : "Unknown error\n"));
3202 sv_setpvs(ERRSV, "Compilation error");
3205 PUSHs(&PL_sv_undef);
3209 CopLINE_set(&PL_compiling, 0);
3211 *startop = PL_eval_root;
3213 SAVEFREEOP(PL_eval_root);
3215 /* Set the context for this new optree.
3216 * Propagate the context from the eval(). */
3217 if ((gimme & G_WANT) == G_VOID)
3218 scalarvoid(PL_eval_root);
3219 else if ((gimme & G_WANT) == G_ARRAY)
3222 scalar(PL_eval_root);
3224 DEBUG_x(dump_eval());
3226 /* Register with debugger: */
3227 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3228 CV * const cv = get_cvs("DB::postponed", 0);
3232 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3234 call_sv(MUTABLE_SV(cv), G_DISCARD);
3239 call_list(PL_scopestack_ix, PL_unitcheckav);
3241 /* compiled okay, so do it */
3243 CvDEPTH(PL_compcv) = 1;
3244 SP = PL_stack_base + POPMARK; /* pop original mark */
3245 PL_op = saveop; /* The caller may need it. */
3246 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3253 S_check_type_and_open(pTHX_ const char *name)
3256 const int st_rc = PerlLIO_stat(name, &st);
3258 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3260 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3264 return PerlIO_open(name, PERL_SCRIPT_MODE);
3267 #ifndef PERL_DISABLE_PMC
3269 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3273 PERL_ARGS_ASSERT_DOOPEN_PM;
3275 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3276 SV *const pmcsv = newSV(namelen + 2);
3277 char *const pmc = SvPVX(pmcsv);
3280 memcpy(pmc, name, namelen);
3282 pmc[namelen + 1] = '\0';
3284 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3285 fp = check_type_and_open(name);
3288 fp = check_type_and_open(pmc);
3290 SvREFCNT_dec(pmcsv);
3293 fp = check_type_and_open(name);
3298 # define doopen_pm(name, namelen) check_type_and_open(name)
3299 #endif /* !PERL_DISABLE_PMC */
3304 register PERL_CONTEXT *cx;
3311 int vms_unixname = 0;
3313 const char *tryname = NULL;
3315 const I32 gimme = GIMME_V;
3316 int filter_has_file = 0;
3317 PerlIO *tryrsfp = NULL;
3318 SV *filter_cache = NULL;
3319 SV *filter_state = NULL;
3320 SV *filter_sub = NULL;
3326 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3327 sv = new_version(sv);
3328 if (!sv_derived_from(PL_patchlevel, "version"))
3329 upg_version(PL_patchlevel, TRUE);
3330 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3331 if ( vcmp(sv,PL_patchlevel) <= 0 )
3332 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3333 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3336 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3339 SV * const req = SvRV(sv);
3340 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3342 /* get the left hand term */
3343 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3345 first = SvIV(*av_fetch(lav,0,0));
3346 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3347 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3348 || av_len(lav) > 1 /* FP with > 3 digits */
3349 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3351 DIE(aTHX_ "Perl %"SVf" required--this is only "
3352 "%"SVf", stopped", SVfARG(vnormal(req)),
3353 SVfARG(vnormal(PL_patchlevel)));
3355 else { /* probably 'use 5.10' or 'use 5.8' */
3360 second = SvIV(*av_fetch(lav,1,0));
3362 second /= second >= 600 ? 100 : 10;
3363 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3364 (int)first, (int)second);
3365 upg_version(hintsv, TRUE);
3367 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3368 "--this is only %"SVf", stopped",
3369 SVfARG(vnormal(req)),
3370 SVfARG(vnormal(sv_2mortal(hintsv))),
3371 SVfARG(vnormal(PL_patchlevel)));
3376 /* We do this only with use, not require. */
3378 /* If we request a version >= 5.9.5, load feature.pm with the
3379 * feature bundle that corresponds to the required version. */
3380 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3381 SV *const importsv = vnormal(sv);
3382 *SvPVX_mutable(importsv) = ':';
3383 ENTER_with_name("load_feature");
3384 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3385 LEAVE_with_name("load_feature");
3387 /* If a version >= 5.11.0 is requested, strictures are on by default! */
3389 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3390 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3395 name = SvPV_const(sv, len);
3396 if (!(name && len > 0 && *name))
3397 DIE(aTHX_ "Null filename used");
3398 TAINT_PROPER("require");
3402 /* The key in the %ENV hash is in the syntax of file passed as the argument
3403 * usually this is in UNIX format, but sometimes in VMS format, which
3404 * can result in a module being pulled in more than once.
3405 * To prevent this, the key must be stored in UNIX format if the VMS
3406 * name can be translated to UNIX.
3408 if ((unixname = tounixspec(name, NULL)) != NULL) {
3409 unixlen = strlen(unixname);
3415 /* if not VMS or VMS name can not be translated to UNIX, pass it
3418 unixname = (char *) name;
3421 if (PL_op->op_type == OP_REQUIRE) {
3422 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3423 unixname, unixlen, 0);
3425 if (*svp != &PL_sv_undef)
3428 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3429 "Compilation failed in require", unixname);
3433 /* prepare to compile file */
3435 if (path_is_absolute(name)) {
3437 tryrsfp = doopen_pm(name, len);
3440 AV * const ar = GvAVn(PL_incgv);
3446 namesv = newSV_type(SVt_PV);
3447 for (i = 0; i <= AvFILL(ar); i++) {
3448 SV * const dirsv = *av_fetch(ar, i, TRUE);
3450 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3457 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3458 && !sv_isobject(loader))
3460 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3463 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3464 PTR2UV(SvRV(dirsv)), name);
3465 tryname = SvPVX_const(namesv);
3468 ENTER_with_name("call_INC");
3476 if (sv_isobject(loader))
3477 count = call_method("INC", G_ARRAY);
3479 count = call_sv(loader, G_ARRAY);
3482 /* Adjust file name if the hook has set an %INC entry */
3483 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3485 tryname = SvPV_nolen_const(*svp);
3494 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3495 && !isGV_with_GP(SvRV(arg))) {
3496 filter_cache = SvRV(arg);
3497 SvREFCNT_inc_simple_void_NN(filter_cache);
3504 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3508 if (isGV_with_GP(arg)) {
3509 IO * const io = GvIO((const GV *)arg);
3514 tryrsfp = IoIFP(io);
3515 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3516 PerlIO_close(IoOFP(io));
3527 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3529 SvREFCNT_inc_simple_void_NN(filter_sub);
3532 filter_state = SP[i];
3533 SvREFCNT_inc_simple_void(filter_state);
3537 if (!tryrsfp && (filter_cache || filter_sub)) {
3538 tryrsfp = PerlIO_open(BIT_BUCKET,
3546 LEAVE_with_name("call_INC");
3553 filter_has_file = 0;
3555 SvREFCNT_dec(filter_cache);
3556 filter_cache = NULL;
3559 SvREFCNT_dec(filter_state);
3560 filter_state = NULL;
3563 SvREFCNT_dec(filter_sub);
3568 if (!path_is_absolute(name)
3574 dir = SvPV_const(dirsv, dirlen);
3582 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3584 sv_setpv(namesv, unixdir);
3585 sv_catpv(namesv, unixname);
3587 # ifdef __SYMBIAN32__
3588 if (PL_origfilename[0] &&
3589 PL_origfilename[1] == ':' &&
3590 !(dir[0] && dir[1] == ':'))
3591 Perl_sv_setpvf(aTHX_ namesv,
3596 Perl_sv_setpvf(aTHX_ namesv,
3600 /* The equivalent of
3601 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3602 but without the need to parse the format string, or
3603 call strlen on either pointer, and with the correct
3604 allocation up front. */
3606 char *tmp = SvGROW(namesv, dirlen + len + 2);
3608 memcpy(tmp, dir, dirlen);
3611 /* name came from an SV, so it will have a '\0' at the
3612 end that we can copy as part of this memcpy(). */
3613 memcpy(tmp, name, len + 1);
3615 SvCUR_set(namesv, dirlen + len + 1);
3617 /* Don't even actually have to turn SvPOK_on() as we
3618 access it directly with SvPVX() below. */
3622 TAINT_PROPER("require");
3623 tryname = SvPVX_const(namesv);
3624 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3626 if (tryname[0] == '.' && tryname[1] == '/') {
3628 while (*++tryname == '/');
3632 else if (errno == EMFILE)
3633 /* no point in trying other paths if out of handles */
3640 SAVECOPFILE_FREE(&PL_compiling);
3641 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3642 SvREFCNT_dec(namesv);
3644 if (PL_op->op_type == OP_REQUIRE) {
3645 const char *msgstr = name;
3646 if(errno == EMFILE) {
3648 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3650 msgstr = SvPV_nolen_const(msg);
3652 if (namesv) { /* did we lookup @INC? */
3653 AV * const ar = GvAVn(PL_incgv);
3655 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3656 "%s in @INC%s%s (@INC contains:",
3658 (instr(msgstr, ".h ")
3659 ? " (change .h to .ph maybe?)" : ""),
3660 (instr(msgstr, ".ph ")
3661 ? " (did you run h2ph?)" : "")
3664 for (i = 0; i <= AvFILL(ar); i++) {
3665 sv_catpvs(msg, " ");
3666 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3668 sv_catpvs(msg, ")");
3669 msgstr = SvPV_nolen_const(msg);
3672 DIE(aTHX_ "Can't locate %s", msgstr);
3678 SETERRNO(0, SS_NORMAL);
3680 /* Assume success here to prevent recursive requirement. */
3681 /* name is never assigned to again, so len is still strlen(name) */
3682 /* Check whether a hook in @INC has already filled %INC */
3684 (void)hv_store(GvHVn(PL_incgv),
3685 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3687 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3689 (void)hv_store(GvHVn(PL_incgv),
3690 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3693 ENTER_with_name("eval");
3695 lex_start(NULL, tryrsfp, TRUE);
3699 hv_clear(GvHV(PL_hintgv));
3701 SAVECOMPILEWARNINGS();
3702 if (PL_dowarn & G_WARN_ALL_ON)
3703 PL_compiling.cop_warnings = pWARN_ALL ;
3704 else if (PL_dowarn & G_WARN_ALL_OFF)
3705 PL_compiling.cop_warnings = pWARN_NONE ;
3707 PL_compiling.cop_warnings = pWARN_STD ;
3709 if (filter_sub || filter_cache) {
3710 /* We can use the SvPV of the filter PVIO itself as our cache, rather
3711 than hanging another SV from it. In turn, filter_add() optionally
3712 takes the SV to use as the filter (or creates a new SV if passed
3713 NULL), so simply pass in whatever value filter_cache has. */
3714 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3715 IoLINES(datasv) = filter_has_file;
3716 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3717 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3720 /* switch to eval mode */
3721 PUSHBLOCK(cx, CXt_EVAL, SP);
3723 cx->blk_eval.retop = PL_op->op_next;
3725 SAVECOPLINE(&PL_compiling);
3726 CopLINE_set(&PL_compiling, 0);
3730 /* Store and reset encoding. */
3731 encoding = PL_encoding;
3734 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3735 op = DOCATCH(PL_eval_start);
3737 op = PL_op->op_next;
3739 /* Restore encoding. */
3740 PL_encoding = encoding;
3745 /* This is a op added to hold the hints hash for
3746 pp_entereval. The hash can be modified by the code
3747 being eval'ed, so we return a copy instead. */
3753 mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3761 register PERL_CONTEXT *cx;
3763 const I32 gimme = GIMME_V;
3764 const U32 was = PL_breakable_sub_gen;
3765 char tbuf[TYPE_DIGITS(long) + 12];
3766 char *tmpbuf = tbuf;
3770 HV *saved_hh = NULL;
3772 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3773 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3777 TAINT_IF(SvTAINTED(sv));
3778 TAINT_PROPER("eval");
3780 ENTER_with_name("eval");
3781 lex_start(sv, NULL, FALSE);
3784 /* switch to eval mode */
3786 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3787 SV * const temp_sv = sv_newmortal();
3788 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3789 (unsigned long)++PL_evalseq,
3790 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3791 tmpbuf = SvPVX(temp_sv);
3792 len = SvCUR(temp_sv);
3795 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3796 SAVECOPFILE_FREE(&PL_compiling);
3797 CopFILE_set(&PL_compiling, tmpbuf+2);
3798 SAVECOPLINE(&PL_compiling);
3799 CopLINE_set(&PL_compiling, 1);
3800 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3801 deleting the eval's FILEGV from the stash before gv_check() runs
3802 (i.e. before run-time proper). To work around the coredump that
3803 ensues, we always turn GvMULTI_on for any globals that were
3804 introduced within evals. See force_ident(). GSAR 96-10-12 */
3806 PL_hints = PL_op->op_targ;
3808 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3809 SvREFCNT_dec(GvHV(PL_hintgv));
3810 GvHV(PL_hintgv) = saved_hh;
3812 SAVECOMPILEWARNINGS();
3813 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3814 if (PL_compiling.cop_hints_hash) {
3815 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3817 if (Perl_fetch_cop_label(aTHX_ PL_curcop->cop_hints_hash, NULL, NULL)) {
3818 /* The label, if present, is the first entry on the chain. So rather
3819 than writing a blank label in front of it (which involves an
3820 allocation), just use the next entry in the chain. */
3821 PL_compiling.cop_hints_hash
3822 = PL_curcop->cop_hints_hash->refcounted_he_next;
3823 /* Check the assumption that this removed the label. */
3824 assert(Perl_fetch_cop_label(aTHX_ PL_compiling.cop_hints_hash, NULL,
3828 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3829 if (PL_compiling.cop_hints_hash) {
3831 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3832 HINTS_REFCNT_UNLOCK;
3834 /* special case: an eval '' executed within the DB package gets lexically
3835 * placed in the first non-DB CV rather than the current CV - this
3836 * allows the debugger to execute code, find lexicals etc, in the
3837 * scope of the code being debugged. Passing &seq gets find_runcv
3838 * to do the dirty work for us */
3839 runcv = find_runcv(&seq);
3841 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3843 cx->blk_eval.retop = PL_op->op_next;
3845 /* prepare to compile string */
3847 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3848 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3851 if (doeval(gimme, NULL, runcv, seq)) {
3852 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3853 ? (PERLDB_LINE || PERLDB_SAVESRC)
3854 : PERLDB_SAVESRC_NOSUBS) {
3855 /* Retain the filegv we created. */
3857 char *const safestr = savepvn(tmpbuf, len);
3858 SAVEDELETE(PL_defstash, safestr, len);
3860 return DOCATCH(PL_eval_start);
3862 /* We have already left the scope set up earler thanks to the LEAVE
3864 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3865 ? (PERLDB_LINE || PERLDB_SAVESRC)
3866 : PERLDB_SAVESRC_INVALID) {
3867 /* Retain the filegv we created. */
3869 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3871 return PL_op->op_next;
3882 register PERL_CONTEXT *cx;
3884 const U8 save_flags = PL_op -> op_flags;
3889 retop = cx->blk_eval.retop;
3892 if (gimme == G_VOID)
3894 else if (gimme == G_SCALAR) {
3897 if (SvFLAGS(TOPs) & SVs_TEMP)
3900 *MARK = sv_mortalcopy(TOPs);
3904 *MARK = &PL_sv_undef;
3909 /* in case LEAVE wipes old return values */
3910 for (mark = newsp + 1; mark <= SP; mark++) {
3911 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3912 *mark = sv_mortalcopy(*mark);
3913 TAINT_NOT; /* Each item is independent */
3917 PL_curpm = newpm; /* Don't pop $1 et al till now */
3920 assert(CvDEPTH(PL_compcv) == 1);
3922 CvDEPTH(PL_compcv) = 0;
3925 if (optype == OP_REQUIRE &&
3926 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3928 /* Unassume the success we assumed earlier. */
3929 SV * const nsv = cx->blk_eval.old_namesv;
3930 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3931 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3932 /* die_where() did LEAVE, or we won't be here */
3935 LEAVE_with_name("eval");
3936 if (!(save_flags & OPf_SPECIAL)) {
3944 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3945 close to the related Perl_create_eval_scope. */
3947 Perl_delete_eval_scope(pTHX)
3952 register PERL_CONTEXT *cx;
3958 LEAVE_with_name("eval_scope");
3959 PERL_UNUSED_VAR(newsp);
3960 PERL_UNUSED_VAR(gimme);
3961 PERL_UNUSED_VAR(optype);
3964 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3965 also needed by Perl_fold_constants. */
3967 Perl_create_eval_scope(pTHX_ U32 flags)
3970 const I32 gimme = GIMME_V;
3972 ENTER_with_name("eval_scope");
3975 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3978 PL_in_eval = EVAL_INEVAL;
3979 if (flags & G_KEEPERR)
3980 PL_in_eval |= EVAL_KEEPERR;
3983 if (flags & G_FAKINGEVAL) {
3984 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3992 PERL_CONTEXT * const cx = create_eval_scope(0);
3993 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3994 return DOCATCH(PL_op->op_next);
4003 register PERL_CONTEXT *cx;
4008 PERL_UNUSED_VAR(optype);
4011 if (gimme == G_VOID)
4013 else if (gimme == G_SCALAR) {
4017 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4020 *MARK = sv_mortalcopy(TOPs);
4024 *MARK = &PL_sv_undef;
4029 /* in case LEAVE wipes old return values */
4031 for (mark = newsp + 1; mark <= SP; mark++) {
4032 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4033 *mark = sv_mortalcopy(*mark);
4034 TAINT_NOT; /* Each item is independent */
4038 PL_curpm = newpm; /* Don't pop $1 et al till now */
4040 LEAVE_with_name("eval_scope");
4048 register PERL_CONTEXT *cx;
4049 const I32 gimme = GIMME_V;
4051 ENTER_with_name("given");
4054 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
4056 PUSHBLOCK(cx, CXt_GIVEN, SP);
4065 register PERL_CONTEXT *cx;
4069 PERL_UNUSED_CONTEXT;
4072 assert(CxTYPE(cx) == CXt_GIVEN);
4077 PL_curpm = newpm; /* pop $1 et al */
4079 LEAVE_with_name("given");
4084 /* Helper routines used by pp_smartmatch */
4086 S_make_matcher(pTHX_ REGEXP *re)
4089 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4091 PERL_ARGS_ASSERT_MAKE_MATCHER;
4093 PM_SETRE(matcher, ReREFCNT_inc(re));
4095 SAVEFREEOP((OP *) matcher);
4096 ENTER_with_name("matcher"); SAVETMPS;
4102 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4107 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4109 PL_op = (OP *) matcher;
4114 return (SvTRUEx(POPs));
4118 S_destroy_matcher(pTHX_ PMOP *matcher)
4122 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4123 PERL_UNUSED_ARG(matcher);
4126 LEAVE_with_name("matcher");
4129 /* Do a smart match */
4132 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4133 return do_smartmatch(NULL, NULL);
4136 /* This version of do_smartmatch() implements the
4137 * table of smart matches that is found in perlsyn.
4140 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4145 bool object_on_left = FALSE;
4146 SV *e = TOPs; /* e is for 'expression' */
4147 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4149 /* First of all, handle overload magic of the rightmost argument */
4152 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4153 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4155 tmpsv = amagic_call(d, e, smart_amg, 0);
4162 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4165 SP -= 2; /* Pop the values */
4167 /* Take care only to invoke mg_get() once for each argument.
4168 * Currently we do this by copying the SV if it's magical. */
4171 d = sv_mortalcopy(d);
4178 e = sv_mortalcopy(e);
4182 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4189 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4190 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4191 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4193 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4194 object_on_left = TRUE;
4197 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4199 if (object_on_left) {
4200 goto sm_any_sub; /* Treat objects like scalars */
4202 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4203 /* Test sub truth for each key */
4205 bool andedresults = TRUE;
4206 HV *hv = (HV*) SvRV(d);
4207 I32 numkeys = hv_iterinit(hv);
4208 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4211 while ( (he = hv_iternext(hv)) ) {
4212 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4213 ENTER_with_name("smartmatch_hash_key_test");
4216 PUSHs(hv_iterkeysv(he));
4218 c = call_sv(e, G_SCALAR);
4221 andedresults = FALSE;
4223 andedresults = SvTRUEx(POPs) && andedresults;
4225 LEAVE_with_name("smartmatch_hash_key_test");
4232 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4233 /* Test sub truth for each element */
4235 bool andedresults = TRUE;
4236 AV *av = (AV*) SvRV(d);
4237 const I32 len = av_len(av);
4238 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4241 for (i = 0; i <= len; ++i) {
4242 SV * const * const svp = av_fetch(av, i, FALSE);
4243 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4244 ENTER_with_name("smartmatch_array_elem_test");
4250 c = call_sv(e, G_SCALAR);
4253 andedresults = FALSE;
4255 andedresults = SvTRUEx(POPs) && andedresults;
4257 LEAVE_with_name("smartmatch_array_elem_test");
4266 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4267 ENTER_with_name("smartmatch_coderef");
4272 c = call_sv(e, G_SCALAR);
4276 else if (SvTEMP(TOPs))
4277 SvREFCNT_inc_void(TOPs);
4279 LEAVE_with_name("smartmatch_coderef");
4284 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4285 if (object_on_left) {
4286 goto sm_any_hash; /* Treat objects like scalars */
4288 else if (!SvOK(d)) {
4289 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4292 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4293 /* Check that the key-sets are identical */
4295 HV *other_hv = MUTABLE_HV(SvRV(d));
4297 bool other_tied = FALSE;
4298 U32 this_key_count = 0,
4299 other_key_count = 0;
4300 HV *hv = MUTABLE_HV(SvRV(e));
4302 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4303 /* Tied hashes don't know how many keys they have. */
4304 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4307 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4308 HV * const temp = other_hv;
4313 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4316 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4319 /* The hashes have the same number of keys, so it suffices
4320 to check that one is a subset of the other. */
4321 (void) hv_iterinit(hv);
4322 while ( (he = hv_iternext(hv)) ) {
4323 SV *key = hv_iterkeysv(he);
4325 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4328 if(!hv_exists_ent(other_hv, key, 0)) {
4329 (void) hv_iterinit(hv); /* reset iterator */
4335 (void) hv_iterinit(other_hv);
4336 while ( hv_iternext(other_hv) )
4340 other_key_count = HvUSEDKEYS(other_hv);
4342 if (this_key_count != other_key_count)
4347 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4348 AV * const other_av = MUTABLE_AV(SvRV(d));
4349 const I32 other_len = av_len(other_av) + 1;
4351 HV *hv = MUTABLE_HV(SvRV(e));
4353 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4354 for (i = 0; i < other_len; ++i) {
4355 SV ** const svp = av_fetch(other_av, i, FALSE);
4356 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4357 if (svp) { /* ??? When can this not happen? */
4358 if (hv_exists_ent(hv, *svp, 0))
4364 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4365 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4368 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4370 HV *hv = MUTABLE_HV(SvRV(e));
4372 (void) hv_iterinit(hv);
4373 while ( (he = hv_iternext(hv)) ) {
4374 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4375 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4376 (void) hv_iterinit(hv);
4377 destroy_matcher(matcher);
4381 destroy_matcher(matcher);
4387 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4388 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4395 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4396 if (object_on_left) {
4397 goto sm_any_array; /* Treat objects like scalars */
4399 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4400 AV * const other_av = MUTABLE_AV(SvRV(e));
4401 const I32 other_len = av_len(other_av) + 1;
4404 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4405 for (i = 0; i < other_len; ++i) {
4406 SV ** const svp = av_fetch(other_av, i, FALSE);
4408 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4409 if (svp) { /* ??? When can this not happen? */
4410 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4416 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4417 AV *other_av = MUTABLE_AV(SvRV(d));
4418 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4419 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4423 const I32 other_len = av_len(other_av);
4425 if (NULL == seen_this) {
4426 seen_this = newHV();
4427 (void) sv_2mortal(MUTABLE_SV(seen_this));
4429 if (NULL == seen_other) {
4430 seen_other = newHV();
4431 (void) sv_2mortal(MUTABLE_SV(seen_other));
4433 for(i = 0; i <= other_len; ++i) {
4434 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4435 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4437 if (!this_elem || !other_elem) {
4438 if ((this_elem && SvOK(*this_elem))
4439 || (other_elem && SvOK(*other_elem)))
4442 else if (hv_exists_ent(seen_this,
4443 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4444 hv_exists_ent(seen_other,
4445 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4447 if (*this_elem != *other_elem)
4451 (void)hv_store_ent(seen_this,
4452 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4454 (void)hv_store_ent(seen_other,
4455 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4461 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4462 (void) do_smartmatch(seen_this, seen_other);
4464 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4473 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4474 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4477 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4478 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4481 for(i = 0; i <= this_len; ++i) {
4482 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4483 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4484 if (svp && matcher_matches_sv(matcher, *svp)) {
4485 destroy_matcher(matcher);
4489 destroy_matcher(matcher);
4493 else if (!SvOK(d)) {
4494 /* undef ~~ array */
4495 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4498 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4499 for (i = 0; i <= this_len; ++i) {
4500 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4501 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4502 if (!svp || !SvOK(*svp))
4511 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4513 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4514 for (i = 0; i <= this_len; ++i) {
4515 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4522 /* infinite recursion isn't supposed to happen here */
4523 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4524 (void) do_smartmatch(NULL, NULL);
4526 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4535 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4536 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4537 SV *t = d; d = e; e = t;
4538 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4541 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4542 SV *t = d; d = e; e = t;
4543 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4544 goto sm_regex_array;
4547 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4549 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4551 PUSHs(matcher_matches_sv(matcher, d)
4554 destroy_matcher(matcher);
4559 /* See if there is overload magic on left */
4560 else if (object_on_left && SvAMAGIC(d)) {
4562 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4563 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4566 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4574 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4577 else if (!SvOK(d)) {
4578 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4579 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4584 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4585 DEBUG_M(if (SvNIOK(e))
4586 Perl_deb(aTHX_ " applying rule Any-Num\n");
4588 Perl_deb(aTHX_ " applying rule Num-numish\n");
4590 /* numeric comparison */
4593 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4604 /* As a last resort, use string comparison */
4605 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4614 register PERL_CONTEXT *cx;
4615 const I32 gimme = GIMME_V;
4617 /* This is essentially an optimization: if the match
4618 fails, we don't want to push a context and then
4619 pop it again right away, so we skip straight
4620 to the op that follows the leavewhen.
4622 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4623 return cLOGOP->op_other->op_next;
4625 ENTER_with_name("eval");
4628 PUSHBLOCK(cx, CXt_WHEN, SP);
4637 register PERL_CONTEXT *cx;
4643 assert(CxTYPE(cx) == CXt_WHEN);
4648 PL_curpm = newpm; /* pop $1 et al */
4650 LEAVE_with_name("eval");
4658 register PERL_CONTEXT *cx;
4661 cxix = dopoptowhen(cxstack_ix);
4663 DIE(aTHX_ "Can't \"continue\" outside a when block");
4664 if (cxix < cxstack_ix)
4667 /* clear off anything above the scope we're re-entering */
4668 inner = PL_scopestack_ix;
4670 if (PL_scopestack_ix < inner)
4671 leave_scope(PL_scopestack[PL_scopestack_ix]);
4672 PL_curcop = cx->blk_oldcop;
4673 return cx->blk_givwhen.leave_op;
4680 register PERL_CONTEXT *cx;
4683 cxix = dopoptogiven(cxstack_ix);
4685 if (PL_op->op_flags & OPf_SPECIAL)
4686 DIE(aTHX_ "Can't use when() outside a topicalizer");
4688 DIE(aTHX_ "Can't \"break\" outside a given block");
4690 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4691 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4693 if (cxix < cxstack_ix)
4696 /* clear off anything above the scope we're re-entering */
4697 inner = PL_scopestack_ix;
4699 if (PL_scopestack_ix < inner)
4700 leave_scope(PL_scopestack[PL_scopestack_ix]);
4701 PL_curcop = cx->blk_oldcop;
4704 return CX_LOOP_NEXTOP_GET(cx);
4706 return cx->blk_givwhen.leave_op;
4710 S_doparseform(pTHX_ SV *sv)
4713 register char *s = SvPV_force(sv, len);
4714 register char * const send = s + len;
4715 register char *base = NULL;
4716 register I32 skipspaces = 0;
4717 bool noblank = FALSE;
4718 bool repeat = FALSE;
4719 bool postspace = FALSE;
4725 bool unchopnum = FALSE;
4726 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4728 PERL_ARGS_ASSERT_DOPARSEFORM;
4731 Perl_croak(aTHX_ "Null picture in formline");
4733 /* estimate the buffer size needed */
4734 for (base = s; s <= send; s++) {
4735 if (*s == '\n' || *s == '@' || *s == '^')
4741 Newx(fops, maxops, U32);
4746 *fpc++ = FF_LINEMARK;
4747 noblank = repeat = FALSE;
4765 case ' ': case '\t':
4772 } /* else FALL THROUGH */
4780 *fpc++ = FF_LITERAL;
4788 *fpc++ = (U16)skipspaces;
4792 *fpc++ = FF_NEWLINE;
4796 arg = fpc - linepc + 1;
4803 *fpc++ = FF_LINEMARK;
4804 noblank = repeat = FALSE;
4813 ischop = s[-1] == '^';
4819 arg = (s - base) - 1;
4821 *fpc++ = FF_LITERAL;
4829 *fpc++ = 2; /* skip the @* or ^* */
4831 *fpc++ = FF_LINESNGL;
4834 *fpc++ = FF_LINEGLOB;
4836 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4837 arg = ischop ? 512 : 0;
4842 const char * const f = ++s;
4845 arg |= 256 + (s - f);
4847 *fpc++ = s - base; /* fieldsize for FETCH */
4848 *fpc++ = FF_DECIMAL;
4850 unchopnum |= ! ischop;
4852 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4853 arg = ischop ? 512 : 0;
4855 s++; /* skip the '0' first */
4859 const char * const f = ++s;
4862 arg |= 256 + (s - f);
4864 *fpc++ = s - base; /* fieldsize for FETCH */
4865 *fpc++ = FF_0DECIMAL;
4867 unchopnum |= ! ischop;
4871 bool ismore = FALSE;
4874 while (*++s == '>') ;
4875 prespace = FF_SPACE;
4877 else if (*s == '|') {
4878 while (*++s == '|') ;
4879 prespace = FF_HALFSPACE;
4884 while (*++s == '<') ;
4887 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4891 *fpc++ = s - base; /* fieldsize for FETCH */
4893 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4896 *fpc++ = (U16)prespace;
4910 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4912 { /* need to jump to the next word */
4914 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4915 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4916 s = SvPVX(sv) + SvCUR(sv) + z;
4918 Copy(fops, s, arg, U32);
4920 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4923 if (unchopnum && repeat)
4924 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4930 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4932 /* Can value be printed in fldsize chars, using %*.*f ? */
4936 int intsize = fldsize - (value < 0 ? 1 : 0);
4943 while (intsize--) pwr *= 10.0;
4944 while (frcsize--) eps /= 10.0;
4947 if (value + eps >= pwr)
4950 if (value - eps <= -pwr)
4957 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4960 SV * const datasv = FILTER_DATA(idx);
4961 const int filter_has_file = IoLINES(datasv);
4962 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4963 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4968 char *prune_from = NULL;
4969 bool read_from_cache = FALSE;
4972 PERL_ARGS_ASSERT_RUN_USER_FILTER;
4974 assert(maxlen >= 0);
4977 /* I was having segfault trouble under Linux 2.2.5 after a
4978 parse error occured. (Had to hack around it with a test
4979 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4980 not sure where the trouble is yet. XXX */
4983 SV *const cache = datasv;
4986 const char *cache_p = SvPV(cache, cache_len);
4990 /* Running in block mode and we have some cached data already.
4992 if (cache_len >= umaxlen) {
4993 /* In fact, so much data we don't even need to call
4998 const char *const first_nl =
4999 (const char *)memchr(cache_p, '\n', cache_len);
5001 take = first_nl + 1 - cache_p;
5005 sv_catpvn(buf_sv, cache_p, take);
5006 sv_chop(cache, cache_p + take);
5007 /* Definately not EOF */
5011 sv_catsv(buf_sv, cache);
5013 umaxlen -= cache_len;
5016 read_from_cache = TRUE;
5020 /* Filter API says that the filter appends to the contents of the buffer.
5021 Usually the buffer is "", so the details don't matter. But if it's not,
5022 then clearly what it contains is already filtered by this filter, so we
5023 don't want to pass it in a second time.
5024 I'm going to use a mortal in case the upstream filter croaks. */
5025 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5026 ? sv_newmortal() : buf_sv;
5027 SvUPGRADE(upstream, SVt_PV);
5029 if (filter_has_file) {
5030 status = FILTER_READ(idx+1, upstream, 0);
5033 if (filter_sub && status >= 0) {
5037 ENTER_with_name("call_filter_sub");
5042 DEFSV_set(upstream);
5046 PUSHs(filter_state);
5049 count = call_sv(filter_sub, G_SCALAR);
5061 LEAVE_with_name("call_filter_sub");
5064 if(SvOK(upstream)) {
5065 got_p = SvPV(upstream, got_len);
5067 if (got_len > umaxlen) {
5068 prune_from = got_p + umaxlen;
5071 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5072 if (first_nl && first_nl + 1 < got_p + got_len) {
5073 /* There's a second line here... */
5074 prune_from = first_nl + 1;
5079 /* Oh. Too long. Stuff some in our cache. */
5080 STRLEN cached_len = got_p + got_len - prune_from;
5081 SV *const cache = datasv;
5084 /* Cache should be empty. */
5085 assert(!SvCUR(cache));
5088 sv_setpvn(cache, prune_from, cached_len);
5089 /* If you ask for block mode, you may well split UTF-8 characters.
5090 "If it breaks, you get to keep both parts"
5091 (Your code is broken if you don't put them back together again
5092 before something notices.) */
5093 if (SvUTF8(upstream)) {
5096 SvCUR_set(upstream, got_len - cached_len);
5098 /* Can't yet be EOF */
5103 /* If they are at EOF but buf_sv has something in it, then they may never
5104 have touched the SV upstream, so it may be undefined. If we naively
5105 concatenate it then we get a warning about use of uninitialised value.
5107 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5108 sv_catsv(buf_sv, upstream);
5112 IoLINES(datasv) = 0;
5114 SvREFCNT_dec(filter_state);
5115 IoTOP_GV(datasv) = NULL;
5118 SvREFCNT_dec(filter_sub);
5119 IoBOTTOM_GV(datasv) = NULL;
5121 filter_del(S_run_user_filter);
5123 if (status == 0 && read_from_cache) {
5124 /* If we read some data from the cache (and by getting here it implies
5125 that we emptied the cache) then we aren't yet at EOF, and mustn't
5126 report that to our caller. */
5132 /* perhaps someone can come up with a better name for
5133 this? it is not really "absolute", per se ... */
5135 S_path_is_absolute(const char *name)
5137 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5139 if (PERL_FILE_IS_ABSOLUTE(name)
5141 || (*name == '.' && ((name[1] == '/' ||
5142 (name[1] == '.' && name[2] == '/'))
5143 || (name[1] == '\\' ||
5144 ( name[1] == '.' && name[2] == '\\')))
5147 || (*name == '.' && (name[1] == '/' ||
5148 (name[1] == '.' && name[2] == '/')))
5160 * c-indentation-style: bsd
5162 * indent-tabs-mode: t
5165 * ex: set ts=8 sts=4 sw=4 noet: