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) \
100 if (SvROK(rx) && SvAMAGIC(rx)) { \
101 SV *sv = AMG_CALLun(rx, regexp); \
105 if (SvTYPE(sv) != SVt_REGEXP) \
106 Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
113 if (PL_op->op_flags & OPf_STACKED) {
114 /* multiple args; concatentate them */
116 tmpstr = PAD_SV(ARGTARG);
117 sv_setpvs(tmpstr, "");
118 while (++MARK <= SP) {
122 tryAMAGICregexp(msv);
124 if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
125 (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
127 sv_setsv(tmpstr, sv);
130 sv_catsv(tmpstr, msv);
137 tryAMAGICregexp(tmpstr);
140 #undef tryAMAGICregexp
143 SV * const sv = SvRV(tmpstr);
144 if (SvTYPE(sv) == SVt_REGEXP)
147 else if (SvTYPE(tmpstr) == SVt_REGEXP)
148 re = (REGEXP*) tmpstr;
151 /* The match's LHS's get-magic might need to access this op's reg-
152 exp (as is sometimes the case with $'; see bug 70764). So we
153 must call get-magic now before we replace the regexp. Hopeful-
154 ly this hack can be replaced with the approach described at
155 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
156 /msg122415.html some day. */
157 if(pm->op_type == OP_MATCH) {
159 const bool was_tainted = PL_tainted;
160 if (pm->op_flags & OPf_STACKED)
162 else if (pm->op_private & OPpTARGET_MY)
163 lhs = PAD_SV(pm->op_targ);
166 /* Restore the previous value of PL_tainted (which may have been
167 modified by get-magic), to avoid incorrectly setting the
168 RXf_TAINTED flag further down. */
169 PL_tainted = was_tainted;
172 re = reg_temp_copy(NULL, re);
173 ReREFCNT_dec(PM_GETRE(pm));
178 const char *t = SvOK(tmpstr) ? SvPV_nomg_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);
217 else if (SvAMAGIC(tmpstr)) {
218 /* make a copy to avoid extra stringifies */
219 tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
223 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
225 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
227 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
228 inside tie/overload accessors. */
234 #ifndef INCOMPLETE_TAINTS
237 RX_EXTFLAGS(re) |= RXf_TAINTED;
239 RX_EXTFLAGS(re) &= ~RXf_TAINTED;
243 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
247 #if !defined(USE_ITHREADS)
248 /* can't change the optree at runtime either */
249 /* PMf_KEEP is handled differently under threads to avoid these problems */
250 if (pm->op_pmflags & PMf_KEEP) {
251 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
252 cLOGOP->op_first->op_next = PL_op->op_next;
262 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
263 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
264 register SV * const dstr = cx->sb_dstr;
265 register char *s = cx->sb_s;
266 register char *m = cx->sb_m;
267 char *orig = cx->sb_orig;
268 register REGEXP * const rx = cx->sb_rx;
270 REGEXP *old = PM_GETRE(pm);
277 PM_SETRE(pm,ReREFCNT_inc(rx));
280 rxres_restore(&cx->sb_rxres, rx);
281 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
283 if (cx->sb_iters++) {
284 const I32 saviters = cx->sb_iters;
285 if (cx->sb_iters > cx->sb_maxiters)
286 DIE(aTHX_ "Substitution loop");
288 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
290 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
291 cx->sb_rxtainted |= 2;
292 sv_catsv_nomg(dstr, POPs);
293 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
297 if (CxONCE(cx) || s < orig ||
298 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
299 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
300 ((cx->sb_rflags & REXEC_COPY_STR)
301 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
302 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
304 SV * const targ = cx->sb_targ;
306 assert(cx->sb_strend >= s);
307 if(cx->sb_strend > s) {
308 if (DO_UTF8(dstr) && !SvUTF8(targ))
309 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
311 sv_catpvn(dstr, s, cx->sb_strend - s);
313 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
315 #ifdef PERL_OLD_COPY_ON_WRITE
317 sv_force_normal_flags(targ, SV_COW_DROP_PV);
323 SvPV_set(targ, SvPVX(dstr));
324 SvCUR_set(targ, SvCUR(dstr));
325 SvLEN_set(targ, SvLEN(dstr));
328 SvPV_set(dstr, NULL);
330 TAINT_IF(cx->sb_rxtainted & 1);
331 if (pm->op_pmflags & PMf_NONDESTRUCT)
334 mPUSHi(saviters - 1);
336 (void)SvPOK_only_UTF8(targ);
337 TAINT_IF(cx->sb_rxtainted);
341 LEAVE_SCOPE(cx->sb_oldsave);
343 RETURNOP(pm->op_next);
345 cx->sb_iters = saviters;
347 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
350 cx->sb_orig = orig = RX_SUBBEG(rx);
352 cx->sb_strend = s + (cx->sb_strend - m);
354 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
356 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
357 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
359 sv_catpvn(dstr, s, m-s);
361 cx->sb_s = RX_OFFS(rx)[0].end + orig;
362 { /* Update the pos() information. */
363 SV * const sv = cx->sb_targ;
365 SvUPGRADE(sv, SVt_PVMG);
366 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
367 #ifdef PERL_OLD_COPY_ON_WRITE
369 sv_force_normal_flags(sv, 0);
371 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
374 mg->mg_len = m - orig;
377 (void)ReREFCNT_inc(rx);
378 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
379 rxres_save(&cx->sb_rxres, rx);
380 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
384 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
389 PERL_ARGS_ASSERT_RXRES_SAVE;
392 if (!p || p[1] < RX_NPARENS(rx)) {
393 #ifdef PERL_OLD_COPY_ON_WRITE
394 i = 7 + RX_NPARENS(rx) * 2;
396 i = 6 + RX_NPARENS(rx) * 2;
405 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
406 RX_MATCH_COPIED_off(rx);
408 #ifdef PERL_OLD_COPY_ON_WRITE
409 *p++ = PTR2UV(RX_SAVED_COPY(rx));
410 RX_SAVED_COPY(rx) = NULL;
413 *p++ = RX_NPARENS(rx);
415 *p++ = PTR2UV(RX_SUBBEG(rx));
416 *p++ = (UV)RX_SUBLEN(rx);
417 for (i = 0; i <= RX_NPARENS(rx); ++i) {
418 *p++ = (UV)RX_OFFS(rx)[i].start;
419 *p++ = (UV)RX_OFFS(rx)[i].end;
424 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
429 PERL_ARGS_ASSERT_RXRES_RESTORE;
432 RX_MATCH_COPY_FREE(rx);
433 RX_MATCH_COPIED_set(rx, *p);
436 #ifdef PERL_OLD_COPY_ON_WRITE
437 if (RX_SAVED_COPY(rx))
438 SvREFCNT_dec (RX_SAVED_COPY(rx));
439 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
443 RX_NPARENS(rx) = *p++;
445 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
446 RX_SUBLEN(rx) = (I32)(*p++);
447 for (i = 0; i <= RX_NPARENS(rx); ++i) {
448 RX_OFFS(rx)[i].start = (I32)(*p++);
449 RX_OFFS(rx)[i].end = (I32)(*p++);
454 S_rxres_free(pTHX_ void **rsp)
456 UV * const p = (UV*)*rsp;
458 PERL_ARGS_ASSERT_RXRES_FREE;
463 void *tmp = INT2PTR(char*,*p);
466 PoisonFree(*p, 1, sizeof(*p));
468 Safefree(INT2PTR(char*,*p));
470 #ifdef PERL_OLD_COPY_ON_WRITE
472 SvREFCNT_dec (INT2PTR(SV*,p[1]));
482 dVAR; dSP; dMARK; dORIGMARK;
483 register SV * const tmpForm = *++MARK;
488 register SV *sv = NULL;
489 const char *item = NULL;
493 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
494 const char *chophere = NULL;
495 char *linemark = NULL;
497 bool gotsome = FALSE;
499 const STRLEN fudge = SvPOK(tmpForm)
500 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
501 bool item_is_utf8 = FALSE;
502 bool targ_is_utf8 = FALSE;
504 OP * parseres = NULL;
507 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
508 if (SvREADONLY(tmpForm)) {
509 SvREADONLY_off(tmpForm);
510 parseres = doparseform(tmpForm);
511 SvREADONLY_on(tmpForm);
514 parseres = doparseform(tmpForm);
518 SvPV_force(PL_formtarget, len);
519 if (DO_UTF8(PL_formtarget))
521 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
523 f = SvPV_const(tmpForm, len);
524 /* need to jump to the next word */
525 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
529 const char *name = "???";
532 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
533 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
534 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
535 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
536 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
538 case FF_CHECKNL: name = "CHECKNL"; break;
539 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
540 case FF_SPACE: name = "SPACE"; break;
541 case FF_HALFSPACE: name = "HALFSPACE"; break;
542 case FF_ITEM: name = "ITEM"; break;
543 case FF_CHOP: name = "CHOP"; break;
544 case FF_LINEGLOB: name = "LINEGLOB"; break;
545 case FF_NEWLINE: name = "NEWLINE"; break;
546 case FF_MORE: name = "MORE"; break;
547 case FF_LINEMARK: name = "LINEMARK"; break;
548 case FF_END: name = "END"; break;
549 case FF_0DECIMAL: name = "0DECIMAL"; break;
550 case FF_LINESNGL: name = "LINESNGL"; break;
553 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
555 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
566 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
567 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
569 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
570 t = SvEND(PL_formtarget);
574 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
575 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
577 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
578 t = SvEND(PL_formtarget);
598 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
605 const char *s = item = SvPV_const(sv, len);
608 itemsize = sv_len_utf8(sv);
609 if (itemsize != (I32)len) {
611 if (itemsize > fieldsize) {
612 itemsize = fieldsize;
613 itembytes = itemsize;
614 sv_pos_u2b(sv, &itembytes, 0);
618 send = chophere = s + itembytes;
628 sv_pos_b2u(sv, &itemsize);
632 item_is_utf8 = FALSE;
633 if (itemsize > fieldsize)
634 itemsize = fieldsize;
635 send = chophere = s + itemsize;
649 const char *s = item = SvPV_const(sv, len);
652 itemsize = sv_len_utf8(sv);
653 if (itemsize != (I32)len) {
655 if (itemsize <= fieldsize) {
656 const char *send = chophere = s + itemsize;
669 itemsize = fieldsize;
670 itembytes = itemsize;
671 sv_pos_u2b(sv, &itembytes, 0);
672 send = chophere = s + itembytes;
673 while (s < send || (s == send && isSPACE(*s))) {
683 if (strchr(PL_chopset, *s))
688 itemsize = chophere - item;
689 sv_pos_b2u(sv, &itemsize);
695 item_is_utf8 = FALSE;
696 if (itemsize <= fieldsize) {
697 const char *const send = chophere = s + itemsize;
710 itemsize = fieldsize;
711 send = chophere = s + itemsize;
712 while (s < send || (s == send && isSPACE(*s))) {
722 if (strchr(PL_chopset, *s))
727 itemsize = chophere - item;
733 arg = fieldsize - itemsize;
742 arg = fieldsize - itemsize;
753 const char *s = item;
757 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
759 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
761 t = SvEND(PL_formtarget);
765 if (UTF8_IS_CONTINUED(*s)) {
766 STRLEN skip = UTF8SKIP(s);
783 if ( !((*t++ = *s++) & ~31) )
789 if (targ_is_utf8 && !item_is_utf8) {
790 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
792 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
793 for (; t < SvEND(PL_formtarget); t++) {
806 const int ch = *t++ = *s++;
809 if ( !((*t++ = *s++) & ~31) )
818 const char *s = chophere;
832 const bool oneline = fpc[-1] == FF_LINESNGL;
833 const char *s = item = SvPV_const(sv, len);
834 item_is_utf8 = DO_UTF8(sv);
837 STRLEN to_copy = itemsize;
838 const char *const send = s + len;
839 const U8 *source = (const U8 *) s;
843 chophere = s + itemsize;
847 to_copy = s - SvPVX_const(sv) - 1;
859 if (targ_is_utf8 && !item_is_utf8) {
860 source = tmp = bytes_to_utf8(source, &to_copy);
861 SvCUR_set(PL_formtarget,
862 t - SvPVX_const(PL_formtarget));
864 if (item_is_utf8 && !targ_is_utf8) {
865 /* Upgrade targ to UTF8, and then we reduce it to
866 a problem we have a simple solution for. */
867 SvCUR_set(PL_formtarget,
868 t - SvPVX_const(PL_formtarget));
870 /* Don't need get magic. */
871 sv_utf8_upgrade_nomg(PL_formtarget);
873 SvCUR_set(PL_formtarget,
874 t - SvPVX_const(PL_formtarget));
877 /* Easy. They agree. */
878 assert (item_is_utf8 == targ_is_utf8);
880 SvGROW(PL_formtarget,
881 SvCUR(PL_formtarget) + to_copy + fudge + 1);
882 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
884 Copy(source, t, to_copy, char);
886 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
888 if (SvGMAGICAL(sv)) {
889 /* Mustn't call sv_pos_b2u() as it does a second
890 mg_get(). Is this a bug? Do we need a _flags()
892 itemsize = utf8_length(source, source + itemsize);
894 sv_pos_b2u(sv, &itemsize);
906 #if defined(USE_LONG_DOUBLE)
909 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
913 "%#0*.*f" : "%0*.*f");
918 #if defined(USE_LONG_DOUBLE)
920 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
923 ((arg & 256) ? "%#*.*f" : "%*.*f");
926 /* If the field is marked with ^ and the value is undefined,
928 if ((arg & 512) && !SvOK(sv)) {
936 /* overflow evidence */
937 if (num_overflow(value, fieldsize, arg)) {
943 /* Formats aren't yet marked for locales, so assume "yes". */
945 STORE_NUMERIC_STANDARD_SET_LOCAL();
946 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
947 RESTORE_NUMERIC_STANDARD();
954 while (t-- > linemark && *t == ' ') ;
962 if (arg) { /* repeat until fields exhausted? */
964 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
965 lines += FmLINES(PL_formtarget);
967 SvUTF8_on(PL_formtarget);
968 FmLINES(PL_formtarget) = lines;
970 RETURNOP(cLISTOP->op_first);
981 const char *s = chophere;
982 const char *send = item + len;
984 while (isSPACE(*s) && (s < send))
989 arg = fieldsize - itemsize;
996 if (strnEQ(s1," ",3)) {
997 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
1008 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1010 SvUTF8_on(PL_formtarget);
1011 FmLINES(PL_formtarget) += lines;
1023 if (PL_stack_base + *PL_markstack_ptr == SP) {
1025 if (GIMME_V == G_SCALAR)
1027 RETURNOP(PL_op->op_next->op_next);
1029 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
1030 pp_pushmark(); /* push dst */
1031 pp_pushmark(); /* push src */
1032 ENTER_with_name("grep"); /* enter outer scope */
1035 if (PL_op->op_private & OPpGREP_LEX)
1036 SAVESPTR(PAD_SVl(PL_op->op_targ));
1039 ENTER_with_name("grep_item"); /* enter inner scope */
1042 src = PL_stack_base[*PL_markstack_ptr];
1044 if (PL_op->op_private & OPpGREP_LEX)
1045 PAD_SVl(PL_op->op_targ) = src;
1050 if (PL_op->op_type == OP_MAPSTART)
1051 pp_pushmark(); /* push top */
1052 return ((LOGOP*)PL_op->op_next)->op_other;
1058 const I32 gimme = GIMME_V;
1059 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1065 /* first, move source pointer to the next item in the source list */
1066 ++PL_markstack_ptr[-1];
1068 /* if there are new items, push them into the destination list */
1069 if (items && gimme != G_VOID) {
1070 /* might need to make room back there first */
1071 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1072 /* XXX this implementation is very pessimal because the stack
1073 * is repeatedly extended for every set of items. Is possible
1074 * to do this without any stack extension or copying at all
1075 * by maintaining a separate list over which the map iterates
1076 * (like foreach does). --gsar */
1078 /* everything in the stack after the destination list moves
1079 * towards the end the stack by the amount of room needed */
1080 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1082 /* items to shift up (accounting for the moved source pointer) */
1083 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1085 /* This optimization is by Ben Tilly and it does
1086 * things differently from what Sarathy (gsar)
1087 * is describing. The downside of this optimization is
1088 * that leaves "holes" (uninitialized and hopefully unused areas)
1089 * to the Perl stack, but on the other hand this
1090 * shouldn't be a problem. If Sarathy's idea gets
1091 * implemented, this optimization should become
1092 * irrelevant. --jhi */
1094 shift = count; /* Avoid shifting too often --Ben Tilly */
1098 dst = (SP += shift);
1099 PL_markstack_ptr[-1] += shift;
1100 *PL_markstack_ptr += shift;
1104 /* copy the new items down to the destination list */
1105 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1106 if (gimme == G_ARRAY) {
1108 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1111 /* scalar context: we don't care about which values map returns
1112 * (we use undef here). And so we certainly don't want to do mortal
1113 * copies of meaningless values. */
1114 while (items-- > 0) {
1116 *dst-- = &PL_sv_undef;
1120 LEAVE_with_name("grep_item"); /* exit inner scope */
1123 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1125 (void)POPMARK; /* pop top */
1126 LEAVE_with_name("grep"); /* exit outer scope */
1127 (void)POPMARK; /* pop src */
1128 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1129 (void)POPMARK; /* pop dst */
1130 SP = PL_stack_base + POPMARK; /* pop original mark */
1131 if (gimme == G_SCALAR) {
1132 if (PL_op->op_private & OPpGREP_LEX) {
1133 SV* sv = sv_newmortal();
1134 sv_setiv(sv, items);
1142 else if (gimme == G_ARRAY)
1149 ENTER_with_name("grep_item"); /* enter inner scope */
1152 /* set $_ to the new source item */
1153 src = PL_stack_base[PL_markstack_ptr[-1]];
1155 if (PL_op->op_private & OPpGREP_LEX)
1156 PAD_SVl(PL_op->op_targ) = src;
1160 RETURNOP(cLOGOP->op_other);
1169 if (GIMME == G_ARRAY)
1171 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1172 return cLOGOP->op_other;
1182 if (GIMME == G_ARRAY) {
1183 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1187 SV * const targ = PAD_SV(PL_op->op_targ);
1190 if (PL_op->op_private & OPpFLIP_LINENUM) {
1191 if (GvIO(PL_last_in_gv)) {
1192 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1195 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1197 flip = SvIV(sv) == SvIV(GvSV(gv));
1203 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1204 if (PL_op->op_flags & OPf_SPECIAL) {
1212 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1215 sv_setpvs(TARG, "");
1221 /* This code tries to decide if "$left .. $right" should use the
1222 magical string increment, or if the range is numeric (we make
1223 an exception for .."0" [#18165]). AMS 20021031. */
1225 #define RANGE_IS_NUMERIC(left,right) ( \
1226 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1227 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1228 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1229 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1230 && (!SvOK(right) || looks_like_number(right))))
1236 if (GIMME == G_ARRAY) {
1242 if (RANGE_IS_NUMERIC(left,right)) {
1245 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1246 (SvOK(right) && SvNV(right) > IV_MAX))
1247 DIE(aTHX_ "Range iterator outside integer range");
1258 SV * const sv = sv_2mortal(newSViv(i++));
1263 SV * const final = sv_mortalcopy(right);
1265 const char * const tmps = SvPV_const(final, len);
1267 SV *sv = sv_mortalcopy(left);
1268 SvPV_force_nolen(sv);
1269 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1271 if (strEQ(SvPVX_const(sv),tmps))
1273 sv = sv_2mortal(newSVsv(sv));
1280 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1284 if (PL_op->op_private & OPpFLIP_LINENUM) {
1285 if (GvIO(PL_last_in_gv)) {
1286 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1289 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1290 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1298 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1299 sv_catpvs(targ, "E0");
1309 static const char * const context_name[] = {
1311 NULL, /* CXt_WHEN never actually needs "block" */
1312 NULL, /* CXt_BLOCK never actually needs "block" */
1313 NULL, /* CXt_GIVEN never actually needs "block" */
1314 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1315 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1316 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1317 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1325 S_dopoptolabel(pTHX_ const char *label)
1330 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1332 for (i = cxstack_ix; i >= 0; i--) {
1333 register const PERL_CONTEXT * const cx = &cxstack[i];
1334 switch (CxTYPE(cx)) {
1340 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1341 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1342 if (CxTYPE(cx) == CXt_NULL)
1345 case CXt_LOOP_LAZYIV:
1346 case CXt_LOOP_LAZYSV:
1348 case CXt_LOOP_PLAIN:
1350 const char *cx_label = CxLABEL(cx);
1351 if (!cx_label || strNE(label, cx_label) ) {
1352 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1353 (long)i, cx_label));
1356 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1367 Perl_dowantarray(pTHX)
1370 const I32 gimme = block_gimme();
1371 return (gimme == G_VOID) ? G_SCALAR : gimme;
1375 Perl_block_gimme(pTHX)
1378 const I32 cxix = dopoptosub(cxstack_ix);
1382 switch (cxstack[cxix].blk_gimme) {
1390 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1397 Perl_is_lvalue_sub(pTHX)
1400 const I32 cxix = dopoptosub(cxstack_ix);
1401 assert(cxix >= 0); /* We should only be called from inside subs */
1403 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1404 return CxLVAL(cxstack + cxix);
1410 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1415 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1417 for (i = startingblock; i >= 0; i--) {
1418 register const PERL_CONTEXT * const cx = &cxstk[i];
1419 switch (CxTYPE(cx)) {
1425 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1433 S_dopoptoeval(pTHX_ I32 startingblock)
1437 for (i = startingblock; i >= 0; i--) {
1438 register const PERL_CONTEXT *cx = &cxstack[i];
1439 switch (CxTYPE(cx)) {
1443 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1451 S_dopoptoloop(pTHX_ I32 startingblock)
1455 for (i = startingblock; i >= 0; i--) {
1456 register const PERL_CONTEXT * const cx = &cxstack[i];
1457 switch (CxTYPE(cx)) {
1463 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1464 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1465 if ((CxTYPE(cx)) == CXt_NULL)
1468 case CXt_LOOP_LAZYIV:
1469 case CXt_LOOP_LAZYSV:
1471 case CXt_LOOP_PLAIN:
1472 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1480 S_dopoptogiven(pTHX_ I32 startingblock)
1484 for (i = startingblock; i >= 0; i--) {
1485 register const PERL_CONTEXT *cx = &cxstack[i];
1486 switch (CxTYPE(cx)) {
1490 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1492 case CXt_LOOP_PLAIN:
1493 assert(!CxFOREACHDEF(cx));
1495 case CXt_LOOP_LAZYIV:
1496 case CXt_LOOP_LAZYSV:
1498 if (CxFOREACHDEF(cx)) {
1499 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1508 S_dopoptowhen(pTHX_ I32 startingblock)
1512 for (i = startingblock; i >= 0; i--) {
1513 register const PERL_CONTEXT *cx = &cxstack[i];
1514 switch (CxTYPE(cx)) {
1518 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1526 Perl_dounwind(pTHX_ I32 cxix)
1531 while (cxstack_ix > cxix) {
1533 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1534 DEBUG_CX("UNWIND"); \
1535 /* Note: we don't need to restore the base context info till the end. */
1536 switch (CxTYPE(cx)) {
1539 continue; /* not break */
1547 case CXt_LOOP_LAZYIV:
1548 case CXt_LOOP_LAZYSV:
1550 case CXt_LOOP_PLAIN:
1561 PERL_UNUSED_VAR(optype);
1565 Perl_qerror(pTHX_ SV *err)
1569 PERL_ARGS_ASSERT_QERROR;
1572 sv_catsv(ERRSV, err);
1574 sv_catsv(PL_errors, err);
1576 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1578 ++PL_parser->error_count;
1582 Perl_die_unwind(pTHX_ SV *msv)
1585 SV *exceptsv = sv_mortalcopy(msv);
1586 U8 in_eval = PL_in_eval;
1587 PERL_ARGS_ASSERT_DIE_UNWIND;
1593 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1594 && PL_curstackinfo->si_prev)
1603 register PERL_CONTEXT *cx;
1606 if (cxix < cxstack_ix)
1609 POPBLOCK(cx,PL_curpm);
1610 if (CxTYPE(cx) != CXt_EVAL) {
1612 const char* message = SvPVx_const(exceptsv, msglen);
1613 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1614 PerlIO_write(Perl_error_log, message, msglen);
1618 namesv = cx->blk_eval.old_namesv;
1620 if (gimme == G_SCALAR)
1621 *++newsp = &PL_sv_undef;
1622 PL_stack_sp = newsp;
1626 /* LEAVE could clobber PL_curcop (see save_re_context())
1627 * XXX it might be better to find a way to avoid messing with
1628 * PL_curcop in save_re_context() instead, but this is a more
1629 * minimal fix --GSAR */
1630 PL_curcop = cx->blk_oldcop;
1632 if (optype == OP_REQUIRE) {
1633 const char* const msg = SvPVx_nolen_const(exceptsv);
1634 (void)hv_store(GvHVn(PL_incgv),
1635 SvPVX_const(namesv), SvCUR(namesv),
1637 /* note that unlike pp_entereval, pp_require isn't
1638 * supposed to trap errors. So now that we've popped the
1639 * EVAL that pp_require pushed, and processed the error
1640 * message, rethrow the error */
1641 Perl_croak(aTHX_ "%sCompilation failed in require",
1642 *msg ? msg : "Unknown error\n");
1644 if (in_eval & EVAL_KEEPERR) {
1645 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1646 SvPV_nolen_const(exceptsv));
1649 sv_setsv(ERRSV, exceptsv);
1651 assert(CxTYPE(cx) == CXt_EVAL);
1652 PL_restartjmpenv = cx->blk_eval.cur_top_env;
1653 PL_restartop = cx->blk_eval.retop;
1659 write_to_stderr(exceptsv);
1666 dVAR; dSP; dPOPTOPssrl;
1667 if (SvTRUE(left) != SvTRUE(right))
1677 register I32 cxix = dopoptosub(cxstack_ix);
1678 register const PERL_CONTEXT *cx;
1679 register const PERL_CONTEXT *ccstack = cxstack;
1680 const PERL_SI *top_si = PL_curstackinfo;
1682 const char *stashname;
1689 /* we may be in a higher stacklevel, so dig down deeper */
1690 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1691 top_si = top_si->si_prev;
1692 ccstack = top_si->si_cxstack;
1693 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1696 if (GIMME != G_ARRAY) {
1702 /* caller() should not report the automatic calls to &DB::sub */
1703 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1704 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1708 cxix = dopoptosub_at(ccstack, cxix - 1);
1711 cx = &ccstack[cxix];
1712 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1713 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1714 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1715 field below is defined for any cx. */
1716 /* caller() should not report the automatic calls to &DB::sub */
1717 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1718 cx = &ccstack[dbcxix];
1721 stashname = CopSTASHPV(cx->blk_oldcop);
1722 if (GIMME != G_ARRAY) {
1725 PUSHs(&PL_sv_undef);
1728 sv_setpv(TARG, stashname);
1737 PUSHs(&PL_sv_undef);
1739 mPUSHs(newSVpv(stashname, 0));
1740 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1741 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1744 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1745 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1746 /* So is ccstack[dbcxix]. */
1748 SV * const sv = newSV(0);
1749 gv_efullname3(sv, cvgv, NULL);
1751 PUSHs(boolSV(CxHASARGS(cx)));
1754 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1755 PUSHs(boolSV(CxHASARGS(cx)));
1759 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1762 gimme = (I32)cx->blk_gimme;
1763 if (gimme == G_VOID)
1764 PUSHs(&PL_sv_undef);
1766 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1767 if (CxTYPE(cx) == CXt_EVAL) {
1769 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1770 PUSHs(cx->blk_eval.cur_text);
1774 else if (cx->blk_eval.old_namesv) {
1775 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1778 /* eval BLOCK (try blocks have old_namesv == 0) */
1780 PUSHs(&PL_sv_undef);
1781 PUSHs(&PL_sv_undef);
1785 PUSHs(&PL_sv_undef);
1786 PUSHs(&PL_sv_undef);
1788 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1789 && CopSTASH_eq(PL_curcop, PL_debstash))
1791 AV * const ary = cx->blk_sub.argarray;
1792 const int off = AvARRAY(ary) - AvALLOC(ary);
1795 PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
1797 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1800 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1801 av_extend(PL_dbargs, AvFILLp(ary) + off);
1802 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1803 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1805 /* XXX only hints propagated via op_private are currently
1806 * visible (others are not easily accessible, since they
1807 * use the global PL_hints) */
1808 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1811 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1813 if (old_warnings == pWARN_NONE ||
1814 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1815 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1816 else if (old_warnings == pWARN_ALL ||
1817 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1818 /* Get the bit mask for $warnings::Bits{all}, because
1819 * it could have been extended by warnings::register */
1821 HV * const bits = get_hv("warnings::Bits", 0);
1822 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1823 mask = newSVsv(*bits_all);
1826 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1830 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1834 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1835 sv_2mortal(newRV_noinc(
1836 MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1837 cx->blk_oldcop->cop_hints_hash))))
1846 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1847 sv_reset(tmps, CopSTASH(PL_curcop));
1852 /* like pp_nextstate, but used instead when the debugger is active */
1857 PL_curcop = (COP*)PL_op;
1858 TAINT_NOT; /* Each statement is presumed innocent */
1859 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1864 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1865 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1868 register PERL_CONTEXT *cx;
1869 const I32 gimme = G_ARRAY;
1871 GV * const gv = PL_DBgv;
1872 register CV * const cv = GvCV(gv);
1875 DIE(aTHX_ "No DB::DB routine defined");
1877 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1878 /* don't do recursive DB::DB call */
1893 (void)(*CvXSUB(cv))(aTHX_ cv);
1900 PUSHBLOCK(cx, CXt_SUB, SP);
1902 cx->blk_sub.retop = PL_op->op_next;
1905 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1906 RETURNOP(CvSTART(cv));
1916 register PERL_CONTEXT *cx;
1917 const I32 gimme = GIMME_V;
1919 U8 cxtype = CXt_LOOP_FOR;
1924 ENTER_with_name("loop1");
1927 if (PL_op->op_targ) {
1928 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1929 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1930 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1931 SVs_PADSTALE, SVs_PADSTALE);
1933 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1934 #ifndef USE_ITHREADS
1935 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1941 GV * const gv = MUTABLE_GV(POPs);
1942 svp = &GvSV(gv); /* symbol table variable */
1943 SAVEGENERICSV(*svp);
1946 iterdata = (PAD*)gv;
1950 if (PL_op->op_private & OPpITER_DEF)
1951 cxtype |= CXp_FOR_DEF;
1953 ENTER_with_name("loop2");
1955 PUSHBLOCK(cx, cxtype, SP);
1957 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1959 PUSHLOOP_FOR(cx, svp, MARK, 0);
1961 if (PL_op->op_flags & OPf_STACKED) {
1962 SV *maybe_ary = POPs;
1963 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1965 SV * const right = maybe_ary;
1968 if (RANGE_IS_NUMERIC(sv,right)) {
1969 cx->cx_type &= ~CXTYPEMASK;
1970 cx->cx_type |= CXt_LOOP_LAZYIV;
1971 /* Make sure that no-one re-orders cop.h and breaks our
1973 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1974 #ifdef NV_PRESERVES_UV
1975 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1976 (SvNV(sv) > (NV)IV_MAX)))
1978 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1979 (SvNV(right) < (NV)IV_MIN))))
1981 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1984 ((SvUV(sv) > (UV)IV_MAX) ||
1985 (SvNV(sv) > (NV)UV_MAX)))))
1987 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1989 ((SvNV(right) > 0) &&
1990 ((SvUV(right) > (UV)IV_MAX) ||
1991 (SvNV(right) > (NV)UV_MAX))))))
1993 DIE(aTHX_ "Range iterator outside integer range");
1994 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1995 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1997 /* for correct -Dstv display */
1998 cx->blk_oldsp = sp - PL_stack_base;
2002 cx->cx_type &= ~CXTYPEMASK;
2003 cx->cx_type |= CXt_LOOP_LAZYSV;
2004 /* Make sure that no-one re-orders cop.h and breaks our
2006 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2007 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2008 cx->blk_loop.state_u.lazysv.end = right;
2009 SvREFCNT_inc(right);
2010 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2011 /* This will do the upgrade to SVt_PV, and warn if the value
2012 is uninitialised. */
2013 (void) SvPV_nolen_const(right);
2014 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2015 to replace !SvOK() with a pointer to "". */
2017 SvREFCNT_dec(right);
2018 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2022 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2023 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2024 SvREFCNT_inc(maybe_ary);
2025 cx->blk_loop.state_u.ary.ix =
2026 (PL_op->op_private & OPpITER_REVERSED) ?
2027 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2031 else { /* iterating over items on the stack */
2032 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2033 if (PL_op->op_private & OPpITER_REVERSED) {
2034 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2037 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2047 register PERL_CONTEXT *cx;
2048 const I32 gimme = GIMME_V;
2050 ENTER_with_name("loop1");
2052 ENTER_with_name("loop2");
2054 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2055 PUSHLOOP_PLAIN(cx, SP);
2063 register PERL_CONTEXT *cx;
2070 assert(CxTYPE_is_LOOP(cx));
2072 newsp = PL_stack_base + cx->blk_loop.resetsp;
2075 if (gimme == G_VOID)
2077 else if (gimme == G_SCALAR) {
2079 *++newsp = sv_mortalcopy(*SP);
2081 *++newsp = &PL_sv_undef;
2085 *++newsp = sv_mortalcopy(*++mark);
2086 TAINT_NOT; /* Each item is independent */
2092 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2093 PL_curpm = newpm; /* ... and pop $1 et al */
2095 LEAVE_with_name("loop2");
2096 LEAVE_with_name("loop1");
2104 register PERL_CONTEXT *cx;
2105 bool popsub2 = FALSE;
2106 bool clear_errsv = FALSE;
2115 const I32 cxix = dopoptosub(cxstack_ix);
2118 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2119 * sort block, which is a CXt_NULL
2122 PL_stack_base[1] = *PL_stack_sp;
2123 PL_stack_sp = PL_stack_base + 1;
2127 DIE(aTHX_ "Can't return outside a subroutine");
2129 if (cxix < cxstack_ix)
2132 if (CxMULTICALL(&cxstack[cxix])) {
2133 gimme = cxstack[cxix].blk_gimme;
2134 if (gimme == G_VOID)
2135 PL_stack_sp = PL_stack_base;
2136 else if (gimme == G_SCALAR) {
2137 PL_stack_base[1] = *PL_stack_sp;
2138 PL_stack_sp = PL_stack_base + 1;
2144 switch (CxTYPE(cx)) {
2147 retop = cx->blk_sub.retop;
2148 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2151 if (!(PL_in_eval & EVAL_KEEPERR))
2154 namesv = cx->blk_eval.old_namesv;
2155 retop = cx->blk_eval.retop;
2159 if (optype == OP_REQUIRE &&
2160 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2162 /* Unassume the success we assumed earlier. */
2163 (void)hv_delete(GvHVn(PL_incgv),
2164 SvPVX_const(namesv), SvCUR(namesv),
2166 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2171 retop = cx->blk_sub.retop;
2174 DIE(aTHX_ "panic: return");
2178 if (gimme == G_SCALAR) {
2181 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2183 *++newsp = SvREFCNT_inc(*SP);
2188 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2190 *++newsp = sv_mortalcopy(sv);
2195 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2198 *++newsp = sv_mortalcopy(*SP);
2201 *++newsp = &PL_sv_undef;
2203 else if (gimme == G_ARRAY) {
2204 while (++MARK <= SP) {
2205 *++newsp = (popsub2 && SvTEMP(*MARK))
2206 ? *MARK : sv_mortalcopy(*MARK);
2207 TAINT_NOT; /* Each item is independent */
2210 PL_stack_sp = newsp;
2213 /* Stack values are safe: */
2216 POPSUB(cx,sv); /* release CV and @_ ... */
2220 PL_curpm = newpm; /* ... and pop $1 et al */
2233 register PERL_CONTEXT *cx;
2244 if (PL_op->op_flags & OPf_SPECIAL) {
2245 cxix = dopoptoloop(cxstack_ix);
2247 DIE(aTHX_ "Can't \"last\" outside a loop block");
2250 cxix = dopoptolabel(cPVOP->op_pv);
2252 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2254 if (cxix < cxstack_ix)
2258 cxstack_ix++; /* temporarily protect top context */
2260 switch (CxTYPE(cx)) {
2261 case CXt_LOOP_LAZYIV:
2262 case CXt_LOOP_LAZYSV:
2264 case CXt_LOOP_PLAIN:
2266 newsp = PL_stack_base + cx->blk_loop.resetsp;
2267 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2271 nextop = cx->blk_sub.retop;
2275 nextop = cx->blk_eval.retop;
2279 nextop = cx->blk_sub.retop;
2282 DIE(aTHX_ "panic: last");
2286 if (gimme == G_SCALAR) {
2288 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2289 ? *SP : sv_mortalcopy(*SP);
2291 *++newsp = &PL_sv_undef;
2293 else if (gimme == G_ARRAY) {
2294 while (++MARK <= SP) {
2295 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2296 ? *MARK : sv_mortalcopy(*MARK);
2297 TAINT_NOT; /* Each item is independent */
2305 /* Stack values are safe: */
2307 case CXt_LOOP_LAZYIV:
2308 case CXt_LOOP_PLAIN:
2309 case CXt_LOOP_LAZYSV:
2311 POPLOOP(cx); /* release loop vars ... */
2315 POPSUB(cx,sv); /* release CV and @_ ... */
2318 PL_curpm = newpm; /* ... and pop $1 et al */
2321 PERL_UNUSED_VAR(optype);
2322 PERL_UNUSED_VAR(gimme);
2330 register PERL_CONTEXT *cx;
2333 if (PL_op->op_flags & OPf_SPECIAL) {
2334 cxix = dopoptoloop(cxstack_ix);
2336 DIE(aTHX_ "Can't \"next\" outside a loop block");
2339 cxix = dopoptolabel(cPVOP->op_pv);
2341 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2343 if (cxix < cxstack_ix)
2346 /* clear off anything above the scope we're re-entering, but
2347 * save the rest until after a possible continue block */
2348 inner = PL_scopestack_ix;
2350 if (PL_scopestack_ix < inner)
2351 leave_scope(PL_scopestack[PL_scopestack_ix]);
2352 PL_curcop = cx->blk_oldcop;
2353 return CX_LOOP_NEXTOP_GET(cx);
2360 register PERL_CONTEXT *cx;
2364 if (PL_op->op_flags & OPf_SPECIAL) {
2365 cxix = dopoptoloop(cxstack_ix);
2367 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2370 cxix = dopoptolabel(cPVOP->op_pv);
2372 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2374 if (cxix < cxstack_ix)
2377 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2378 if (redo_op->op_type == OP_ENTER) {
2379 /* pop one less context to avoid $x being freed in while (my $x..) */
2381 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2382 redo_op = redo_op->op_next;
2386 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2387 LEAVE_SCOPE(oldsave);
2389 PL_curcop = cx->blk_oldcop;
2394 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2398 static const char too_deep[] = "Target of goto is too deeply nested";
2400 PERL_ARGS_ASSERT_DOFINDLABEL;
2403 Perl_croak(aTHX_ too_deep);
2404 if (o->op_type == OP_LEAVE ||
2405 o->op_type == OP_SCOPE ||
2406 o->op_type == OP_LEAVELOOP ||
2407 o->op_type == OP_LEAVESUB ||
2408 o->op_type == OP_LEAVETRY)
2410 *ops++ = cUNOPo->op_first;
2412 Perl_croak(aTHX_ too_deep);
2415 if (o->op_flags & OPf_KIDS) {
2417 /* First try all the kids at this level, since that's likeliest. */
2418 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2419 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2420 const char *kid_label = CopLABEL(kCOP);
2421 if (kid_label && strEQ(kid_label, label))
2425 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2426 if (kid == PL_lastgotoprobe)
2428 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2431 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2432 ops[-1]->op_type == OP_DBSTATE)
2437 if ((o = dofindlabel(kid, label, ops, oplimit)))
2450 register PERL_CONTEXT *cx;
2451 #define GOTO_DEPTH 64
2452 OP *enterops[GOTO_DEPTH];
2453 const char *label = NULL;
2454 const bool do_dump = (PL_op->op_type == OP_DUMP);
2455 static const char must_have_label[] = "goto must have label";
2457 if (PL_op->op_flags & OPf_STACKED) {
2458 SV * const sv = POPs;
2460 /* This egregious kludge implements goto &subroutine */
2461 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2463 register PERL_CONTEXT *cx;
2464 CV *cv = MUTABLE_CV(SvRV(sv));
2471 if (!CvROOT(cv) && !CvXSUB(cv)) {
2472 const GV * const gv = CvGV(cv);
2476 /* autoloaded stub? */
2477 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2479 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2480 GvNAMELEN(gv), FALSE);
2481 if (autogv && (cv = GvCV(autogv)))
2483 tmpstr = sv_newmortal();
2484 gv_efullname3(tmpstr, gv, NULL);
2485 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2487 DIE(aTHX_ "Goto undefined subroutine");
2490 /* First do some returnish stuff. */
2491 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2493 cxix = dopoptosub(cxstack_ix);
2495 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2496 if (cxix < cxstack_ix)
2500 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2501 if (CxTYPE(cx) == CXt_EVAL) {
2503 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2505 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2507 else if (CxMULTICALL(cx))
2508 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2509 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2510 /* put @_ back onto stack */
2511 AV* av = cx->blk_sub.argarray;
2513 items = AvFILLp(av) + 1;
2514 EXTEND(SP, items+1); /* @_ could have been extended. */
2515 Copy(AvARRAY(av), SP + 1, items, SV*);
2516 SvREFCNT_dec(GvAV(PL_defgv));
2517 GvAV(PL_defgv) = cx->blk_sub.savearray;
2519 /* abandon @_ if it got reified */
2524 av_extend(av, items-1);
2526 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2529 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2530 AV* const av = GvAV(PL_defgv);
2531 items = AvFILLp(av) + 1;
2532 EXTEND(SP, items+1); /* @_ could have been extended. */
2533 Copy(AvARRAY(av), SP + 1, items, SV*);
2537 if (CxTYPE(cx) == CXt_SUB &&
2538 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2539 SvREFCNT_dec(cx->blk_sub.cv);
2540 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2541 LEAVE_SCOPE(oldsave);
2543 /* Now do some callish stuff. */
2545 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2547 OP* const retop = cx->blk_sub.retop;
2552 for (index=0; index<items; index++)
2553 sv_2mortal(SP[-index]);
2556 /* XS subs don't have a CxSUB, so pop it */
2557 POPBLOCK(cx, PL_curpm);
2558 /* Push a mark for the start of arglist */
2561 (void)(*CvXSUB(cv))(aTHX_ cv);
2566 AV* const padlist = CvPADLIST(cv);
2567 if (CxTYPE(cx) == CXt_EVAL) {
2568 PL_in_eval = CxOLD_IN_EVAL(cx);
2569 PL_eval_root = cx->blk_eval.old_eval_root;
2570 cx->cx_type = CXt_SUB;
2572 cx->blk_sub.cv = cv;
2573 cx->blk_sub.olddepth = CvDEPTH(cv);
2576 if (CvDEPTH(cv) < 2)
2577 SvREFCNT_inc_simple_void_NN(cv);
2579 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2580 sub_crush_depth(cv);
2581 pad_push(padlist, CvDEPTH(cv));
2584 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2587 AV *const av = MUTABLE_AV(PAD_SVl(0));
2589 cx->blk_sub.savearray = GvAV(PL_defgv);
2590 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2591 CX_CURPAD_SAVE(cx->blk_sub);
2592 cx->blk_sub.argarray = av;
2594 if (items >= AvMAX(av) + 1) {
2595 SV **ary = AvALLOC(av);
2596 if (AvARRAY(av) != ary) {
2597 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2600 if (items >= AvMAX(av) + 1) {
2601 AvMAX(av) = items - 1;
2602 Renew(ary,items+1,SV*);
2608 Copy(mark,AvARRAY(av),items,SV*);
2609 AvFILLp(av) = items - 1;
2610 assert(!AvREAL(av));
2612 /* transfer 'ownership' of refcnts to new @_ */
2622 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2623 Perl_get_db_sub(aTHX_ NULL, cv);
2625 CV * const gotocv = get_cvs("DB::goto", 0);
2627 PUSHMARK( PL_stack_sp );
2628 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2633 RETURNOP(CvSTART(cv));
2637 label = SvPV_nolen_const(sv);
2638 if (!(do_dump || *label))
2639 DIE(aTHX_ must_have_label);
2642 else if (PL_op->op_flags & OPf_SPECIAL) {
2644 DIE(aTHX_ must_have_label);
2647 label = cPVOP->op_pv;
2651 if (label && *label) {
2652 OP *gotoprobe = NULL;
2653 bool leaving_eval = FALSE;
2654 bool in_block = FALSE;
2655 PERL_CONTEXT *last_eval_cx = NULL;
2659 PL_lastgotoprobe = NULL;
2661 for (ix = cxstack_ix; ix >= 0; ix--) {
2663 switch (CxTYPE(cx)) {
2665 leaving_eval = TRUE;
2666 if (!CxTRYBLOCK(cx)) {
2667 gotoprobe = (last_eval_cx ?
2668 last_eval_cx->blk_eval.old_eval_root :
2673 /* else fall through */
2674 case CXt_LOOP_LAZYIV:
2675 case CXt_LOOP_LAZYSV:
2677 case CXt_LOOP_PLAIN:
2680 gotoprobe = cx->blk_oldcop->op_sibling;
2686 gotoprobe = cx->blk_oldcop->op_sibling;
2689 gotoprobe = PL_main_root;
2692 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2693 gotoprobe = CvROOT(cx->blk_sub.cv);
2699 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2702 DIE(aTHX_ "panic: goto");
2703 gotoprobe = PL_main_root;
2707 retop = dofindlabel(gotoprobe, label,
2708 enterops, enterops + GOTO_DEPTH);
2712 PL_lastgotoprobe = gotoprobe;
2715 DIE(aTHX_ "Can't find label %s", label);
2717 /* if we're leaving an eval, check before we pop any frames
2718 that we're not going to punt, otherwise the error
2721 if (leaving_eval && *enterops && enterops[1]) {
2723 for (i = 1; enterops[i]; i++)
2724 if (enterops[i]->op_type == OP_ENTERITER)
2725 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2728 if (*enterops && enterops[1]) {
2729 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2731 deprecate("\"goto\" to jump into a construct");
2734 /* pop unwanted frames */
2736 if (ix < cxstack_ix) {
2743 oldsave = PL_scopestack[PL_scopestack_ix];
2744 LEAVE_SCOPE(oldsave);
2747 /* push wanted frames */
2749 if (*enterops && enterops[1]) {
2750 OP * const oldop = PL_op;
2751 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2752 for (; enterops[ix]; ix++) {
2753 PL_op = enterops[ix];
2754 /* Eventually we may want to stack the needed arguments
2755 * for each op. For now, we punt on the hard ones. */
2756 if (PL_op->op_type == OP_ENTERITER)
2757 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2758 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2766 if (!retop) retop = PL_main_start;
2768 PL_restartop = retop;
2769 PL_do_undump = TRUE;
2773 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2774 PL_do_undump = FALSE;
2791 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2793 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2796 PL_exit_flags |= PERL_EXIT_EXPECTED;
2798 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2799 if (anum || !(PL_minus_c && PL_madskills))
2804 PUSHs(&PL_sv_undef);
2811 S_save_lines(pTHX_ AV *array, SV *sv)
2813 const char *s = SvPVX_const(sv);
2814 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2817 PERL_ARGS_ASSERT_SAVE_LINES;
2819 while (s && s < send) {
2821 SV * const tmpstr = newSV_type(SVt_PVMG);
2823 t = (const char *)memchr(s, '\n', send - s);
2829 sv_setpvn(tmpstr, s, t - s);
2830 av_store(array, line++, tmpstr);
2838 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
2840 0 is used as continue inside eval,
2842 3 is used for a die caught by an inner eval - continue inner loop
2844 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
2845 establish a local jmpenv to handle exception traps.
2850 S_docatch(pTHX_ OP *o)
2854 OP * const oldop = PL_op;
2858 assert(CATCH_GET == TRUE);
2865 assert(cxstack_ix >= 0);
2866 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2867 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2872 /* die caught by an inner eval - continue inner loop */
2873 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
2874 PL_restartjmpenv = NULL;
2875 PL_op = PL_restartop;
2891 /* James Bond: Do you expect me to talk?
2892 Auric Goldfinger: No, Mr. Bond. I expect you to die.
2894 This code is an ugly hack, doesn't work with lexicals in subroutines that are
2895 called more than once, and is only used by regcomp.c, for (?{}) blocks.
2897 Currently it is not used outside the core code. Best if it stays that way.
2900 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2901 /* sv Text to convert to OP tree. */
2902 /* startop op_free() this to undo. */
2903 /* code Short string id of the caller. */
2905 dVAR; dSP; /* Make POPBLOCK work. */
2911 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2912 char *tmpbuf = tbuf;
2915 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2919 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2921 ENTER_with_name("eval");
2922 lex_start(sv, NULL, FALSE);
2924 /* switch to eval mode */
2926 if (IN_PERL_COMPILETIME) {
2927 SAVECOPSTASH_FREE(&PL_compiling);
2928 CopSTASH_set(&PL_compiling, PL_curstash);
2930 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2931 SV * const sv = sv_newmortal();
2932 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2933 code, (unsigned long)++PL_evalseq,
2934 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2939 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2940 (unsigned long)++PL_evalseq);
2941 SAVECOPFILE_FREE(&PL_compiling);
2942 CopFILE_set(&PL_compiling, tmpbuf+2);
2943 SAVECOPLINE(&PL_compiling);
2944 CopLINE_set(&PL_compiling, 1);
2945 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2946 deleting the eval's FILEGV from the stash before gv_check() runs
2947 (i.e. before run-time proper). To work around the coredump that
2948 ensues, we always turn GvMULTI_on for any globals that were
2949 introduced within evals. See force_ident(). GSAR 96-10-12 */
2950 safestr = savepvn(tmpbuf, len);
2951 SAVEDELETE(PL_defstash, safestr, len);
2953 #ifdef OP_IN_REGISTER
2959 /* we get here either during compilation, or via pp_regcomp at runtime */
2960 runtime = IN_PERL_RUNTIME;
2962 runcv = find_runcv(NULL);
2965 PL_op->op_type = OP_ENTEREVAL;
2966 PL_op->op_flags = 0; /* Avoid uninit warning. */
2967 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2969 need_catch = CATCH_GET;
2973 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2975 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2976 CATCH_SET(need_catch);
2977 POPBLOCK(cx,PL_curpm);
2980 (*startop)->op_type = OP_NULL;
2981 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2983 /* XXX DAPM do this properly one year */
2984 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2985 LEAVE_with_name("eval");
2986 if (IN_PERL_COMPILETIME)
2987 CopHINTS_set(&PL_compiling, PL_hints);
2988 #ifdef OP_IN_REGISTER
2991 PERL_UNUSED_VAR(newsp);
2992 PERL_UNUSED_VAR(optype);
2994 return PL_eval_start;
2999 =for apidoc find_runcv
3001 Locate the CV corresponding to the currently executing sub or eval.
3002 If db_seqp is non_null, skip CVs that are in the DB package and populate
3003 *db_seqp with the cop sequence number at the point that the DB:: code was
3004 entered. (allows debuggers to eval in the scope of the breakpoint rather
3005 than in the scope of the debugger itself).
3011 Perl_find_runcv(pTHX_ U32 *db_seqp)
3017 *db_seqp = PL_curcop->cop_seq;
3018 for (si = PL_curstackinfo; si; si = si->si_prev) {
3020 for (ix = si->si_cxix; ix >= 0; ix--) {
3021 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3022 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3023 CV * const cv = cx->blk_sub.cv;
3024 /* skip DB:: code */
3025 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3026 *db_seqp = cx->blk_oldcop->cop_seq;
3031 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3039 /* Run yyparse() in a setjmp wrapper. Returns:
3040 * 0: yyparse() successful
3041 * 1: yyparse() failed
3050 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3054 ret = yyparse() ? 1 : 0;
3068 /* Compile a require/do, an eval '', or a /(?{...})/.
3069 * In the last case, startop is non-null, and contains the address of
3070 * a pointer that should be set to the just-compiled code.
3071 * outside is the lexically enclosing CV (if any) that invoked us.
3072 * Returns a bool indicating whether the compile was successful; if so,
3073 * PL_eval_start contains the first op of the compiled ocde; otherwise,
3074 * pushes undef (also croaks if startop != NULL).
3078 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3081 OP * const saveop = PL_op;
3082 bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3085 PL_in_eval = (in_require
3086 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3091 SAVESPTR(PL_compcv);
3092 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3093 CvEVAL_on(PL_compcv);
3094 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3095 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3097 CvOUTSIDE_SEQ(PL_compcv) = seq;
3098 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3100 /* set up a scratch pad */
3102 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3103 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3107 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3109 /* make sure we compile in the right package */
3111 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3112 SAVESPTR(PL_curstash);
3113 PL_curstash = CopSTASH(PL_curcop);
3115 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3116 SAVESPTR(PL_beginav);
3117 PL_beginav = newAV();
3118 SAVEFREESV(PL_beginav);
3119 SAVESPTR(PL_unitcheckav);
3120 PL_unitcheckav = newAV();
3121 SAVEFREESV(PL_unitcheckav);
3124 SAVEBOOL(PL_madskills);
3128 /* try to compile it */
3130 PL_eval_root = NULL;
3131 PL_curcop = &PL_compiling;
3132 CopARYBASE_set(PL_curcop, 0);
3133 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3134 PL_in_eval |= EVAL_KEEPERR;
3138 CALL_BLOCK_HOOKS(eval, saveop);
3140 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3141 * so honour CATCH_GET and trap it here if necessary */
3143 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX) : yyparse();
3145 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3146 SV **newsp; /* Used by POPBLOCK. */
3147 PERL_CONTEXT *cx = NULL;
3148 I32 optype; /* Used by POPEVAL. */
3152 PERL_UNUSED_VAR(newsp);
3153 PERL_UNUSED_VAR(optype);
3155 /* note that if yystatus == 3, then the EVAL CX block has already
3156 * been popped, and various vars restored */
3158 if (yystatus != 3) {
3160 op_free(PL_eval_root);
3161 PL_eval_root = NULL;
3163 SP = PL_stack_base + POPMARK; /* pop original mark */
3165 POPBLOCK(cx,PL_curpm);
3167 namesv = cx->blk_eval.old_namesv;
3172 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3174 msg = SvPVx_nolen_const(ERRSV);
3177 /* If cx is still NULL, it means that we didn't go in the
3178 * POPEVAL branch. */
3179 cx = &cxstack[cxstack_ix];
3180 assert(CxTYPE(cx) == CXt_EVAL);
3181 namesv = cx->blk_eval.old_namesv;
3183 (void)hv_store(GvHVn(PL_incgv),
3184 SvPVX_const(namesv), SvCUR(namesv),
3186 Perl_croak(aTHX_ "%sCompilation failed in require",
3187 *msg ? msg : "Unknown error\n");
3190 if (yystatus != 3) {
3191 POPBLOCK(cx,PL_curpm);
3194 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3195 (*msg ? msg : "Unknown error\n"));
3199 sv_setpvs(ERRSV, "Compilation error");
3202 PUSHs(&PL_sv_undef);
3206 CopLINE_set(&PL_compiling, 0);
3208 *startop = PL_eval_root;
3210 SAVEFREEOP(PL_eval_root);
3212 /* Set the context for this new optree.
3213 * Propagate the context from the eval(). */
3214 if ((gimme & G_WANT) == G_VOID)
3215 scalarvoid(PL_eval_root);
3216 else if ((gimme & G_WANT) == G_ARRAY)
3219 scalar(PL_eval_root);
3221 DEBUG_x(dump_eval());
3223 /* Register with debugger: */
3224 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3225 CV * const cv = get_cvs("DB::postponed", 0);
3229 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3231 call_sv(MUTABLE_SV(cv), G_DISCARD);
3236 call_list(PL_scopestack_ix, PL_unitcheckav);
3238 /* compiled okay, so do it */
3240 CvDEPTH(PL_compcv) = 1;
3241 SP = PL_stack_base + POPMARK; /* pop original mark */
3242 PL_op = saveop; /* The caller may need it. */
3243 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3250 S_check_type_and_open(pTHX_ const char *name)
3253 const int st_rc = PerlLIO_stat(name, &st);
3255 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3257 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3261 return PerlIO_open(name, PERL_SCRIPT_MODE);
3264 #ifndef PERL_DISABLE_PMC
3266 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3270 PERL_ARGS_ASSERT_DOOPEN_PM;
3272 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3273 SV *const pmcsv = newSV(namelen + 2);
3274 char *const pmc = SvPVX(pmcsv);
3277 memcpy(pmc, name, namelen);
3279 pmc[namelen + 1] = '\0';
3281 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3282 fp = check_type_and_open(name);
3285 fp = check_type_and_open(pmc);
3287 SvREFCNT_dec(pmcsv);
3290 fp = check_type_and_open(name);
3295 # define doopen_pm(name, namelen) check_type_and_open(name)
3296 #endif /* !PERL_DISABLE_PMC */
3301 register PERL_CONTEXT *cx;
3308 int vms_unixname = 0;
3310 const char *tryname = NULL;
3312 const I32 gimme = GIMME_V;
3313 int filter_has_file = 0;
3314 PerlIO *tryrsfp = NULL;
3315 SV *filter_cache = NULL;
3316 SV *filter_state = NULL;
3317 SV *filter_sub = NULL;
3323 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3324 sv = new_version(sv);
3325 if (!sv_derived_from(PL_patchlevel, "version"))
3326 upg_version(PL_patchlevel, TRUE);
3327 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3328 if ( vcmp(sv,PL_patchlevel) <= 0 )
3329 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3330 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3333 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3336 SV * const req = SvRV(sv);
3337 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3339 /* get the left hand term */
3340 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3342 first = SvIV(*av_fetch(lav,0,0));
3343 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3344 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3345 || av_len(lav) > 1 /* FP with > 3 digits */
3346 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3348 DIE(aTHX_ "Perl %"SVf" required--this is only "
3349 "%"SVf", stopped", SVfARG(vnormal(req)),
3350 SVfARG(vnormal(PL_patchlevel)));
3352 else { /* probably 'use 5.10' or 'use 5.8' */
3357 second = SvIV(*av_fetch(lav,1,0));
3359 second /= second >= 600 ? 100 : 10;
3360 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3361 (int)first, (int)second);
3362 upg_version(hintsv, TRUE);
3364 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3365 "--this is only %"SVf", stopped",
3366 SVfARG(vnormal(req)),
3367 SVfARG(vnormal(sv_2mortal(hintsv))),
3368 SVfARG(vnormal(PL_patchlevel)));
3373 /* We do this only with "use", not "require" or "no". */
3374 if (PL_compcv && !(cUNOP->op_first->op_private & OPpCONST_NOVER)) {
3375 /* If we request a version >= 5.9.5, load feature.pm with the
3376 * feature bundle that corresponds to the required version. */
3377 if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3378 SV *const importsv = vnormal(sv);
3379 *SvPVX_mutable(importsv) = ':';
3380 ENTER_with_name("load_feature");
3381 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3382 LEAVE_with_name("load_feature");
3384 /* If a version >= 5.11.0 is requested, strictures are on by default! */
3385 if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3386 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3392 name = SvPV_const(sv, len);
3393 if (!(name && len > 0 && *name))
3394 DIE(aTHX_ "Null filename used");
3395 TAINT_PROPER("require");
3399 /* The key in the %ENV hash is in the syntax of file passed as the argument
3400 * usually this is in UNIX format, but sometimes in VMS format, which
3401 * can result in a module being pulled in more than once.
3402 * To prevent this, the key must be stored in UNIX format if the VMS
3403 * name can be translated to UNIX.
3405 if ((unixname = tounixspec(name, NULL)) != NULL) {
3406 unixlen = strlen(unixname);
3412 /* if not VMS or VMS name can not be translated to UNIX, pass it
3415 unixname = (char *) name;
3418 if (PL_op->op_type == OP_REQUIRE) {
3419 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3420 unixname, unixlen, 0);
3422 if (*svp != &PL_sv_undef)
3425 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3426 "Compilation failed in require", unixname);
3430 /* prepare to compile file */
3432 if (path_is_absolute(name)) {
3434 tryrsfp = doopen_pm(name, len);
3437 AV * const ar = GvAVn(PL_incgv);
3443 namesv = newSV_type(SVt_PV);
3444 for (i = 0; i <= AvFILL(ar); i++) {
3445 SV * const dirsv = *av_fetch(ar, i, TRUE);
3447 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3454 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3455 && !sv_isobject(loader))
3457 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3460 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3461 PTR2UV(SvRV(dirsv)), name);
3462 tryname = SvPVX_const(namesv);
3465 ENTER_with_name("call_INC");
3473 if (sv_isobject(loader))
3474 count = call_method("INC", G_ARRAY);
3476 count = call_sv(loader, G_ARRAY);
3486 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3487 && !isGV_with_GP(SvRV(arg))) {
3488 filter_cache = SvRV(arg);
3489 SvREFCNT_inc_simple_void_NN(filter_cache);
3496 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3500 if (isGV_with_GP(arg)) {
3501 IO * const io = GvIO((const GV *)arg);
3506 tryrsfp = IoIFP(io);
3507 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3508 PerlIO_close(IoOFP(io));
3519 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3521 SvREFCNT_inc_simple_void_NN(filter_sub);
3524 filter_state = SP[i];
3525 SvREFCNT_inc_simple_void(filter_state);
3529 if (!tryrsfp && (filter_cache || filter_sub)) {
3530 tryrsfp = PerlIO_open(BIT_BUCKET,
3538 LEAVE_with_name("call_INC");
3540 /* Adjust file name if the hook has set an %INC entry.
3541 This needs to happen after the FREETMPS above. */
3542 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3544 tryname = SvPV_nolen_const(*svp);
3551 filter_has_file = 0;
3553 SvREFCNT_dec(filter_cache);
3554 filter_cache = NULL;
3557 SvREFCNT_dec(filter_state);
3558 filter_state = NULL;
3561 SvREFCNT_dec(filter_sub);
3566 if (!path_is_absolute(name)
3572 dir = SvPV_const(dirsv, dirlen);
3580 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3582 sv_setpv(namesv, unixdir);
3583 sv_catpv(namesv, unixname);
3585 # ifdef __SYMBIAN32__
3586 if (PL_origfilename[0] &&
3587 PL_origfilename[1] == ':' &&
3588 !(dir[0] && dir[1] == ':'))
3589 Perl_sv_setpvf(aTHX_ namesv,
3594 Perl_sv_setpvf(aTHX_ namesv,
3598 /* The equivalent of
3599 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3600 but without the need to parse the format string, or
3601 call strlen on either pointer, and with the correct
3602 allocation up front. */
3604 char *tmp = SvGROW(namesv, dirlen + len + 2);
3606 memcpy(tmp, dir, dirlen);
3609 /* name came from an SV, so it will have a '\0' at the
3610 end that we can copy as part of this memcpy(). */
3611 memcpy(tmp, name, len + 1);
3613 SvCUR_set(namesv, dirlen + len + 1);
3615 /* Don't even actually have to turn SvPOK_on() as we
3616 access it directly with SvPVX() below. */
3620 TAINT_PROPER("require");
3621 tryname = SvPVX_const(namesv);
3622 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3624 if (tryname[0] == '.' && tryname[1] == '/') {
3626 while (*++tryname == '/');
3630 else if (errno == EMFILE)
3631 /* no point in trying other paths if out of handles */
3639 SAVECOPFILE_FREE(&PL_compiling);
3640 CopFILE_set(&PL_compiling, tryname);
3642 SvREFCNT_dec(namesv);
3644 if (PL_op->op_type == OP_REQUIRE) {
3645 if(errno == EMFILE) {
3646 /* diag_listed_as: Can't locate %s */
3647 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(errno));
3649 if (namesv) { /* did we lookup @INC? */
3650 AV * const ar = GvAVn(PL_incgv);
3652 SV *const inc = newSVpvs_flags("", SVs_TEMP);
3653 for (i = 0; i <= AvFILL(ar); i++) {
3654 sv_catpvs(inc, " ");
3655 sv_catsv(inc, *av_fetch(ar, i, TRUE));
3658 /* diag_listed_as: Can't locate %s */
3660 "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
3662 (memEQ(name + len - 2, ".h", 3)
3663 ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
3664 (memEQ(name + len - 3, ".ph", 4)
3665 ? " (did you run h2ph?)" : ""),
3670 DIE(aTHX_ "Can't locate %s", name);
3676 SETERRNO(0, SS_NORMAL);
3678 /* Assume success here to prevent recursive requirement. */
3679 /* name is never assigned to again, so len is still strlen(name) */
3680 /* Check whether a hook in @INC has already filled %INC */
3682 (void)hv_store(GvHVn(PL_incgv),
3683 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3685 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3687 (void)hv_store(GvHVn(PL_incgv),
3688 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3691 ENTER_with_name("eval");
3693 lex_start(NULL, tryrsfp, TRUE);
3697 hv_clear(GvHV(PL_hintgv));
3699 SAVECOMPILEWARNINGS();
3700 if (PL_dowarn & G_WARN_ALL_ON)
3701 PL_compiling.cop_warnings = pWARN_ALL ;
3702 else if (PL_dowarn & G_WARN_ALL_OFF)
3703 PL_compiling.cop_warnings = pWARN_NONE ;
3705 PL_compiling.cop_warnings = pWARN_STD ;
3707 if (filter_sub || filter_cache) {
3708 /* We can use the SvPV of the filter PVIO itself as our cache, rather
3709 than hanging another SV from it. In turn, filter_add() optionally
3710 takes the SV to use as the filter (or creates a new SV if passed
3711 NULL), so simply pass in whatever value filter_cache has. */
3712 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3713 IoLINES(datasv) = filter_has_file;
3714 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3715 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3718 /* switch to eval mode */
3719 PUSHBLOCK(cx, CXt_EVAL, SP);
3721 cx->blk_eval.retop = PL_op->op_next;
3723 SAVECOPLINE(&PL_compiling);
3724 CopLINE_set(&PL_compiling, 0);
3728 /* Store and reset encoding. */
3729 encoding = PL_encoding;
3732 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3733 op = DOCATCH(PL_eval_start);
3735 op = PL_op->op_next;
3737 /* Restore encoding. */
3738 PL_encoding = encoding;
3743 /* This is a op added to hold the hints hash for
3744 pp_entereval. The hash can be modified by the code
3745 being eval'ed, so we return a copy instead. */
3751 mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3759 register PERL_CONTEXT *cx;
3761 const I32 gimme = GIMME_V;
3762 const U32 was = PL_breakable_sub_gen;
3763 char tbuf[TYPE_DIGITS(long) + 12];
3764 char *tmpbuf = tbuf;
3768 HV *saved_hh = NULL;
3770 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3771 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3775 /* make sure we've got a plain PV (no overload etc) before testing
3776 * for taint. Making a copy here is probably overkill, but better
3777 * safe than sorry */
3779 const char * const p = SvPV_const(sv, len);
3781 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
3784 TAINT_IF(SvTAINTED(sv));
3785 TAINT_PROPER("eval");
3787 ENTER_with_name("eval");
3788 lex_start(sv, NULL, FALSE);
3791 /* switch to eval mode */
3793 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3794 SV * const temp_sv = sv_newmortal();
3795 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3796 (unsigned long)++PL_evalseq,
3797 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3798 tmpbuf = SvPVX(temp_sv);
3799 len = SvCUR(temp_sv);
3802 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3803 SAVECOPFILE_FREE(&PL_compiling);
3804 CopFILE_set(&PL_compiling, tmpbuf+2);
3805 SAVECOPLINE(&PL_compiling);
3806 CopLINE_set(&PL_compiling, 1);
3807 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3808 deleting the eval's FILEGV from the stash before gv_check() runs
3809 (i.e. before run-time proper). To work around the coredump that
3810 ensues, we always turn GvMULTI_on for any globals that were
3811 introduced within evals. See force_ident(). GSAR 96-10-12 */
3813 PL_hints = PL_op->op_targ;
3815 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3816 SvREFCNT_dec(GvHV(PL_hintgv));
3817 GvHV(PL_hintgv) = saved_hh;
3819 SAVECOMPILEWARNINGS();
3820 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3821 if (PL_compiling.cop_hints_hash) {
3822 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3824 if (Perl_fetch_cop_label(aTHX_ PL_curcop->cop_hints_hash, NULL, NULL)) {
3825 /* The label, if present, is the first entry on the chain. So rather
3826 than writing a blank label in front of it (which involves an
3827 allocation), just use the next entry in the chain. */
3828 PL_compiling.cop_hints_hash
3829 = PL_curcop->cop_hints_hash->refcounted_he_next;
3830 /* Check the assumption that this removed the label. */
3831 assert(Perl_fetch_cop_label(aTHX_ PL_compiling.cop_hints_hash, NULL,
3835 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3836 if (PL_compiling.cop_hints_hash) {
3838 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3839 HINTS_REFCNT_UNLOCK;
3841 /* special case: an eval '' executed within the DB package gets lexically
3842 * placed in the first non-DB CV rather than the current CV - this
3843 * allows the debugger to execute code, find lexicals etc, in the
3844 * scope of the code being debugged. Passing &seq gets find_runcv
3845 * to do the dirty work for us */
3846 runcv = find_runcv(&seq);
3848 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3850 cx->blk_eval.retop = PL_op->op_next;
3852 /* prepare to compile string */
3854 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3855 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3858 if (doeval(gimme, NULL, runcv, seq)) {
3859 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3860 ? (PERLDB_LINE || PERLDB_SAVESRC)
3861 : PERLDB_SAVESRC_NOSUBS) {
3862 /* Retain the filegv we created. */
3864 char *const safestr = savepvn(tmpbuf, len);
3865 SAVEDELETE(PL_defstash, safestr, len);
3867 return DOCATCH(PL_eval_start);
3869 /* We have already left the scope set up earler thanks to the LEAVE
3871 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3872 ? (PERLDB_LINE || PERLDB_SAVESRC)
3873 : PERLDB_SAVESRC_INVALID) {
3874 /* Retain the filegv we created. */
3876 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3878 return PL_op->op_next;
3889 register PERL_CONTEXT *cx;
3891 const U8 save_flags = PL_op -> op_flags;
3897 namesv = cx->blk_eval.old_namesv;
3898 retop = cx->blk_eval.retop;
3901 if (gimme == G_VOID)
3903 else if (gimme == G_SCALAR) {
3906 if (SvFLAGS(TOPs) & SVs_TEMP)
3909 *MARK = sv_mortalcopy(TOPs);
3913 *MARK = &PL_sv_undef;
3918 /* in case LEAVE wipes old return values */
3919 for (mark = newsp + 1; mark <= SP; mark++) {
3920 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3921 *mark = sv_mortalcopy(*mark);
3922 TAINT_NOT; /* Each item is independent */
3926 PL_curpm = newpm; /* Don't pop $1 et al till now */
3929 assert(CvDEPTH(PL_compcv) == 1);
3931 CvDEPTH(PL_compcv) = 0;
3934 if (optype == OP_REQUIRE &&
3935 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3937 /* Unassume the success we assumed earlier. */
3938 (void)hv_delete(GvHVn(PL_incgv),
3939 SvPVX_const(namesv), SvCUR(namesv),
3941 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
3943 /* die_unwind() did LEAVE, or we won't be here */
3946 LEAVE_with_name("eval");
3947 if (!(save_flags & OPf_SPECIAL)) {
3955 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3956 close to the related Perl_create_eval_scope. */
3958 Perl_delete_eval_scope(pTHX)
3963 register PERL_CONTEXT *cx;
3969 LEAVE_with_name("eval_scope");
3970 PERL_UNUSED_VAR(newsp);
3971 PERL_UNUSED_VAR(gimme);
3972 PERL_UNUSED_VAR(optype);
3975 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3976 also needed by Perl_fold_constants. */
3978 Perl_create_eval_scope(pTHX_ U32 flags)
3981 const I32 gimme = GIMME_V;
3983 ENTER_with_name("eval_scope");
3986 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3989 PL_in_eval = EVAL_INEVAL;
3990 if (flags & G_KEEPERR)
3991 PL_in_eval |= EVAL_KEEPERR;
3994 if (flags & G_FAKINGEVAL) {
3995 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4003 PERL_CONTEXT * const cx = create_eval_scope(0);
4004 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4005 return DOCATCH(PL_op->op_next);
4014 register PERL_CONTEXT *cx;
4019 PERL_UNUSED_VAR(optype);
4022 if (gimme == G_VOID)
4024 else if (gimme == G_SCALAR) {
4028 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4031 *MARK = sv_mortalcopy(TOPs);
4035 *MARK = &PL_sv_undef;
4040 /* in case LEAVE wipes old return values */
4042 for (mark = newsp + 1; mark <= SP; mark++) {
4043 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4044 *mark = sv_mortalcopy(*mark);
4045 TAINT_NOT; /* Each item is independent */
4049 PL_curpm = newpm; /* Don't pop $1 et al till now */
4051 LEAVE_with_name("eval_scope");
4059 register PERL_CONTEXT *cx;
4060 const I32 gimme = GIMME_V;
4062 ENTER_with_name("given");
4065 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
4067 PUSHBLOCK(cx, CXt_GIVEN, SP);
4076 register PERL_CONTEXT *cx;
4080 PERL_UNUSED_CONTEXT;
4083 assert(CxTYPE(cx) == CXt_GIVEN);
4086 if (gimme == G_VOID)
4088 else if (gimme == G_SCALAR) {
4092 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4095 *MARK = sv_mortalcopy(TOPs);
4099 *MARK = &PL_sv_undef;
4104 /* in case LEAVE wipes old return values */
4106 for (mark = newsp + 1; mark <= SP; mark++) {
4107 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4108 *mark = sv_mortalcopy(*mark);
4109 TAINT_NOT; /* Each item is independent */
4113 PL_curpm = newpm; /* Don't pop $1 et al till now */
4115 LEAVE_with_name("given");
4119 /* Helper routines used by pp_smartmatch */
4121 S_make_matcher(pTHX_ REGEXP *re)
4124 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4126 PERL_ARGS_ASSERT_MAKE_MATCHER;
4128 PM_SETRE(matcher, ReREFCNT_inc(re));
4130 SAVEFREEOP((OP *) matcher);
4131 ENTER_with_name("matcher"); SAVETMPS;
4137 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4142 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4144 PL_op = (OP *) matcher;
4149 return (SvTRUEx(POPs));
4153 S_destroy_matcher(pTHX_ PMOP *matcher)
4157 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4158 PERL_UNUSED_ARG(matcher);
4161 LEAVE_with_name("matcher");
4164 /* Do a smart match */
4167 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4168 return do_smartmatch(NULL, NULL);
4171 /* This version of do_smartmatch() implements the
4172 * table of smart matches that is found in perlsyn.
4175 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4180 bool object_on_left = FALSE;
4181 SV *e = TOPs; /* e is for 'expression' */
4182 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4184 /* Take care only to invoke mg_get() once for each argument.
4185 * Currently we do this by copying the SV if it's magical. */
4188 d = sv_mortalcopy(d);
4195 e = sv_mortalcopy(e);
4197 /* First of all, handle overload magic of the rightmost argument */
4200 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4201 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4203 tmpsv = amagic_call(d, e, smart_amg, 0);
4210 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4213 SP -= 2; /* Pop the values */
4218 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4225 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4226 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4227 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4229 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4230 object_on_left = TRUE;
4233 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4235 if (object_on_left) {
4236 goto sm_any_sub; /* Treat objects like scalars */
4238 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4239 /* Test sub truth for each key */
4241 bool andedresults = TRUE;
4242 HV *hv = (HV*) SvRV(d);
4243 I32 numkeys = hv_iterinit(hv);
4244 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4247 while ( (he = hv_iternext(hv)) ) {
4248 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4249 ENTER_with_name("smartmatch_hash_key_test");
4252 PUSHs(hv_iterkeysv(he));
4254 c = call_sv(e, G_SCALAR);
4257 andedresults = FALSE;
4259 andedresults = SvTRUEx(POPs) && andedresults;
4261 LEAVE_with_name("smartmatch_hash_key_test");
4268 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4269 /* Test sub truth for each element */
4271 bool andedresults = TRUE;
4272 AV *av = (AV*) SvRV(d);
4273 const I32 len = av_len(av);
4274 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4277 for (i = 0; i <= len; ++i) {
4278 SV * const * const svp = av_fetch(av, i, FALSE);
4279 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4280 ENTER_with_name("smartmatch_array_elem_test");
4286 c = call_sv(e, G_SCALAR);
4289 andedresults = FALSE;
4291 andedresults = SvTRUEx(POPs) && andedresults;
4293 LEAVE_with_name("smartmatch_array_elem_test");
4302 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4303 ENTER_with_name("smartmatch_coderef");
4308 c = call_sv(e, G_SCALAR);
4312 else if (SvTEMP(TOPs))
4313 SvREFCNT_inc_void(TOPs);
4315 LEAVE_with_name("smartmatch_coderef");
4320 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4321 if (object_on_left) {
4322 goto sm_any_hash; /* Treat objects like scalars */
4324 else if (!SvOK(d)) {
4325 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4328 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4329 /* Check that the key-sets are identical */
4331 HV *other_hv = MUTABLE_HV(SvRV(d));
4333 bool other_tied = FALSE;
4334 U32 this_key_count = 0,
4335 other_key_count = 0;
4336 HV *hv = MUTABLE_HV(SvRV(e));
4338 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4339 /* Tied hashes don't know how many keys they have. */
4340 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4343 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4344 HV * const temp = other_hv;
4349 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4352 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4355 /* The hashes have the same number of keys, so it suffices
4356 to check that one is a subset of the other. */
4357 (void) hv_iterinit(hv);
4358 while ( (he = hv_iternext(hv)) ) {
4359 SV *key = hv_iterkeysv(he);
4361 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4364 if(!hv_exists_ent(other_hv, key, 0)) {
4365 (void) hv_iterinit(hv); /* reset iterator */
4371 (void) hv_iterinit(other_hv);
4372 while ( hv_iternext(other_hv) )
4376 other_key_count = HvUSEDKEYS(other_hv);
4378 if (this_key_count != other_key_count)
4383 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4384 AV * const other_av = MUTABLE_AV(SvRV(d));
4385 const I32 other_len = av_len(other_av) + 1;
4387 HV *hv = MUTABLE_HV(SvRV(e));
4389 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4390 for (i = 0; i < other_len; ++i) {
4391 SV ** const svp = av_fetch(other_av, i, FALSE);
4392 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4393 if (svp) { /* ??? When can this not happen? */
4394 if (hv_exists_ent(hv, *svp, 0))
4400 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4401 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4404 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4406 HV *hv = MUTABLE_HV(SvRV(e));
4408 (void) hv_iterinit(hv);
4409 while ( (he = hv_iternext(hv)) ) {
4410 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4411 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4412 (void) hv_iterinit(hv);
4413 destroy_matcher(matcher);
4417 destroy_matcher(matcher);
4423 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4424 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4431 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4432 if (object_on_left) {
4433 goto sm_any_array; /* Treat objects like scalars */
4435 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4436 AV * const other_av = MUTABLE_AV(SvRV(e));
4437 const I32 other_len = av_len(other_av) + 1;
4440 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4441 for (i = 0; i < other_len; ++i) {
4442 SV ** const svp = av_fetch(other_av, i, FALSE);
4444 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4445 if (svp) { /* ??? When can this not happen? */
4446 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4452 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4453 AV *other_av = MUTABLE_AV(SvRV(d));
4454 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4455 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4459 const I32 other_len = av_len(other_av);
4461 if (NULL == seen_this) {
4462 seen_this = newHV();
4463 (void) sv_2mortal(MUTABLE_SV(seen_this));
4465 if (NULL == seen_other) {
4466 seen_other = newHV();
4467 (void) sv_2mortal(MUTABLE_SV(seen_other));
4469 for(i = 0; i <= other_len; ++i) {
4470 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4471 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4473 if (!this_elem || !other_elem) {
4474 if ((this_elem && SvOK(*this_elem))
4475 || (other_elem && SvOK(*other_elem)))
4478 else if (hv_exists_ent(seen_this,
4479 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4480 hv_exists_ent(seen_other,
4481 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4483 if (*this_elem != *other_elem)
4487 (void)hv_store_ent(seen_this,
4488 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4490 (void)hv_store_ent(seen_other,
4491 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4497 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4498 (void) do_smartmatch(seen_this, seen_other);
4500 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4509 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4510 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4513 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4514 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4517 for(i = 0; i <= this_len; ++i) {
4518 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4519 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4520 if (svp && matcher_matches_sv(matcher, *svp)) {
4521 destroy_matcher(matcher);
4525 destroy_matcher(matcher);
4529 else if (!SvOK(d)) {
4530 /* undef ~~ array */
4531 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4534 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4535 for (i = 0; i <= this_len; ++i) {
4536 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4537 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4538 if (!svp || !SvOK(*svp))
4547 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4549 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4550 for (i = 0; i <= this_len; ++i) {
4551 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4558 /* infinite recursion isn't supposed to happen here */
4559 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4560 (void) do_smartmatch(NULL, NULL);
4562 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4571 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4572 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4573 SV *t = d; d = e; e = t;
4574 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4577 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4578 SV *t = d; d = e; e = t;
4579 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4580 goto sm_regex_array;
4583 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4585 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4587 PUSHs(matcher_matches_sv(matcher, d)
4590 destroy_matcher(matcher);
4595 /* See if there is overload magic on left */
4596 else if (object_on_left && SvAMAGIC(d)) {
4598 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4599 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4602 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4610 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4613 else if (!SvOK(d)) {
4614 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4615 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4620 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4621 DEBUG_M(if (SvNIOK(e))
4622 Perl_deb(aTHX_ " applying rule Any-Num\n");
4624 Perl_deb(aTHX_ " applying rule Num-numish\n");
4626 /* numeric comparison */
4629 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4640 /* As a last resort, use string comparison */
4641 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4650 register PERL_CONTEXT *cx;
4651 const I32 gimme = GIMME_V;
4653 /* This is essentially an optimization: if the match
4654 fails, we don't want to push a context and then
4655 pop it again right away, so we skip straight
4656 to the op that follows the leavewhen.
4657 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4659 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4660 RETURNOP(cLOGOP->op_other->op_next);
4662 ENTER_with_name("eval");
4665 PUSHBLOCK(cx, CXt_WHEN, SP);
4674 register PERL_CONTEXT *cx;
4680 assert(CxTYPE(cx) == CXt_WHEN);
4685 PL_curpm = newpm; /* pop $1 et al */
4687 LEAVE_with_name("eval");
4695 register PERL_CONTEXT *cx;
4698 cxix = dopoptowhen(cxstack_ix);
4700 DIE(aTHX_ "Can't \"continue\" outside a when block");
4701 if (cxix < cxstack_ix)
4704 /* clear off anything above the scope we're re-entering */
4705 inner = PL_scopestack_ix;
4707 if (PL_scopestack_ix < inner)
4708 leave_scope(PL_scopestack[PL_scopestack_ix]);
4709 PL_curcop = cx->blk_oldcop;
4710 return cx->blk_givwhen.leave_op;
4717 register PERL_CONTEXT *cx;
4721 cxix = dopoptogiven(cxstack_ix);
4723 if (PL_op->op_flags & OPf_SPECIAL)
4724 DIE(aTHX_ "Can't use when() outside a topicalizer");
4726 DIE(aTHX_ "Can't \"break\" outside a given block");
4728 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4729 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4731 if (cxix < cxstack_ix)
4734 /* clear off anything above the scope we're re-entering */
4735 inner = PL_scopestack_ix;
4737 if (PL_scopestack_ix < inner)
4738 leave_scope(PL_scopestack[PL_scopestack_ix]);
4739 PL_curcop = cx->blk_oldcop;
4742 return CX_LOOP_NEXTOP_GET(cx);
4744 /* RETURNOP calls PUTBACK which restores the old old sp */
4745 RETURNOP(cx->blk_givwhen.leave_op);
4749 S_doparseform(pTHX_ SV *sv)
4752 register char *s = SvPV_force(sv, len);
4753 register char * const send = s + len;
4754 register char *base = NULL;
4755 register I32 skipspaces = 0;
4756 bool noblank = FALSE;
4757 bool repeat = FALSE;
4758 bool postspace = FALSE;
4764 bool unchopnum = FALSE;
4765 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4767 PERL_ARGS_ASSERT_DOPARSEFORM;
4770 Perl_croak(aTHX_ "Null picture in formline");
4772 /* estimate the buffer size needed */
4773 for (base = s; s <= send; s++) {
4774 if (*s == '\n' || *s == '@' || *s == '^')
4780 Newx(fops, maxops, U32);
4785 *fpc++ = FF_LINEMARK;
4786 noblank = repeat = FALSE;
4804 case ' ': case '\t':
4811 } /* else FALL THROUGH */
4819 *fpc++ = FF_LITERAL;
4827 *fpc++ = (U16)skipspaces;
4831 *fpc++ = FF_NEWLINE;
4835 arg = fpc - linepc + 1;
4842 *fpc++ = FF_LINEMARK;
4843 noblank = repeat = FALSE;
4852 ischop = s[-1] == '^';
4858 arg = (s - base) - 1;
4860 *fpc++ = FF_LITERAL;
4868 *fpc++ = 2; /* skip the @* or ^* */
4870 *fpc++ = FF_LINESNGL;
4873 *fpc++ = FF_LINEGLOB;
4875 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4876 arg = ischop ? 512 : 0;
4881 const char * const f = ++s;
4884 arg |= 256 + (s - f);
4886 *fpc++ = s - base; /* fieldsize for FETCH */
4887 *fpc++ = FF_DECIMAL;
4889 unchopnum |= ! ischop;
4891 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4892 arg = ischop ? 512 : 0;
4894 s++; /* skip the '0' first */
4898 const char * const f = ++s;
4901 arg |= 256 + (s - f);
4903 *fpc++ = s - base; /* fieldsize for FETCH */
4904 *fpc++ = FF_0DECIMAL;
4906 unchopnum |= ! ischop;
4910 bool ismore = FALSE;
4913 while (*++s == '>') ;
4914 prespace = FF_SPACE;
4916 else if (*s == '|') {
4917 while (*++s == '|') ;
4918 prespace = FF_HALFSPACE;
4923 while (*++s == '<') ;
4926 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4930 *fpc++ = s - base; /* fieldsize for FETCH */
4932 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4935 *fpc++ = (U16)prespace;
4949 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4951 { /* need to jump to the next word */
4953 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4954 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4955 s = SvPVX(sv) + SvCUR(sv) + z;
4957 Copy(fops, s, arg, U32);
4959 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4962 if (unchopnum && repeat)
4963 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4969 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4971 /* Can value be printed in fldsize chars, using %*.*f ? */
4975 int intsize = fldsize - (value < 0 ? 1 : 0);
4982 while (intsize--) pwr *= 10.0;
4983 while (frcsize--) eps /= 10.0;
4986 if (value + eps >= pwr)
4989 if (value - eps <= -pwr)
4996 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4999 SV * const datasv = FILTER_DATA(idx);
5000 const int filter_has_file = IoLINES(datasv);
5001 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5002 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5007 char *prune_from = NULL;
5008 bool read_from_cache = FALSE;
5011 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5013 assert(maxlen >= 0);
5016 /* I was having segfault trouble under Linux 2.2.5 after a
5017 parse error occured. (Had to hack around it with a test
5018 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5019 not sure where the trouble is yet. XXX */
5022 SV *const cache = datasv;
5025 const char *cache_p = SvPV(cache, cache_len);
5029 /* Running in block mode and we have some cached data already.
5031 if (cache_len >= umaxlen) {
5032 /* In fact, so much data we don't even need to call
5037 const char *const first_nl =
5038 (const char *)memchr(cache_p, '\n', cache_len);
5040 take = first_nl + 1 - cache_p;
5044 sv_catpvn(buf_sv, cache_p, take);
5045 sv_chop(cache, cache_p + take);
5046 /* Definately not EOF */
5050 sv_catsv(buf_sv, cache);
5052 umaxlen -= cache_len;
5055 read_from_cache = TRUE;
5059 /* Filter API says that the filter appends to the contents of the buffer.
5060 Usually the buffer is "", so the details don't matter. But if it's not,
5061 then clearly what it contains is already filtered by this filter, so we
5062 don't want to pass it in a second time.
5063 I'm going to use a mortal in case the upstream filter croaks. */
5064 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5065 ? sv_newmortal() : buf_sv;
5066 SvUPGRADE(upstream, SVt_PV);
5068 if (filter_has_file) {
5069 status = FILTER_READ(idx+1, upstream, 0);
5072 if (filter_sub && status >= 0) {
5076 ENTER_with_name("call_filter_sub");
5081 DEFSV_set(upstream);
5085 PUSHs(filter_state);
5088 count = call_sv(filter_sub, G_SCALAR);
5100 LEAVE_with_name("call_filter_sub");
5103 if(SvOK(upstream)) {
5104 got_p = SvPV(upstream, got_len);
5106 if (got_len > umaxlen) {
5107 prune_from = got_p + umaxlen;
5110 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5111 if (first_nl && first_nl + 1 < got_p + got_len) {
5112 /* There's a second line here... */
5113 prune_from = first_nl + 1;
5118 /* Oh. Too long. Stuff some in our cache. */
5119 STRLEN cached_len = got_p + got_len - prune_from;
5120 SV *const cache = datasv;
5123 /* Cache should be empty. */
5124 assert(!SvCUR(cache));
5127 sv_setpvn(cache, prune_from, cached_len);
5128 /* If you ask for block mode, you may well split UTF-8 characters.
5129 "If it breaks, you get to keep both parts"
5130 (Your code is broken if you don't put them back together again
5131 before something notices.) */
5132 if (SvUTF8(upstream)) {
5135 SvCUR_set(upstream, got_len - cached_len);
5137 /* Can't yet be EOF */
5142 /* If they are at EOF but buf_sv has something in it, then they may never
5143 have touched the SV upstream, so it may be undefined. If we naively
5144 concatenate it then we get a warning about use of uninitialised value.
5146 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5147 sv_catsv(buf_sv, upstream);
5151 IoLINES(datasv) = 0;
5153 SvREFCNT_dec(filter_state);
5154 IoTOP_GV(datasv) = NULL;
5157 SvREFCNT_dec(filter_sub);
5158 IoBOTTOM_GV(datasv) = NULL;
5160 filter_del(S_run_user_filter);
5162 if (status == 0 && read_from_cache) {
5163 /* If we read some data from the cache (and by getting here it implies
5164 that we emptied the cache) then we aren't yet at EOF, and mustn't
5165 report that to our caller. */
5171 /* perhaps someone can come up with a better name for
5172 this? it is not really "absolute", per se ... */
5174 S_path_is_absolute(const char *name)
5176 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5178 if (PERL_FILE_IS_ABSOLUTE(name)
5180 || (*name == '.' && ((name[1] == '/' ||
5181 (name[1] == '.' && name[2] == '/'))
5182 || (name[1] == '\\' ||
5183 ( name[1] == '.' && name[2] == '\\')))
5186 || (*name == '.' && (name[1] == '/' ||
5187 (name[1] == '.' && name[2] == '/')))
5199 * c-indentation-style: bsd
5201 * indent-tabs-mode: t
5204 * ex: set ts=8 sts=4 sw=4 noet: