3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 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.
20 /* This file contains control-oriented pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
26 * Control-oriented means things like pp_enteriter() and pp_next(), which
27 * alter the flow of control of the program.
32 #define PERL_IN_PP_CTL_C
36 #define WORD_ALIGN sizeof(U32)
39 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
41 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
50 cxix = dopoptosub(cxstack_ix);
54 switch (cxstack[cxix].blk_gimme) {
67 /* XXXX Should store the old value to allow for tie/overload - and
68 restore in regcomp, where marked with XXXX. */
78 register PMOP *pm = (PMOP*)cLOGOP->op_other;
82 /* prevent recompiling under /o and ithreads. */
83 #if defined(USE_ITHREADS)
84 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
85 if (PL_op->op_flags & OPf_STACKED) {
94 if (PL_op->op_flags & OPf_STACKED) {
95 /* multiple args; concatentate them */
97 tmpstr = PAD_SV(ARGTARG);
98 sv_setpvn(tmpstr, "", 0);
99 while (++MARK <= SP) {
100 if (PL_amagic_generation) {
102 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
103 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
105 sv_setsv(tmpstr, sv);
109 sv_catsv(tmpstr, *MARK);
118 SV * const sv = SvRV(tmpstr);
119 if (SvTYPE(sv) == SVt_REGEXP)
123 re = reg_temp_copy(re);
124 ReREFCNT_dec(PM_GETRE(pm));
129 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
131 assert (re != (REGEXP*) &PL_sv_undef);
133 /* Check against the last compiled regexp. */
134 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
135 memNE(RX_PRECOMP(re), t, len))
137 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
138 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
142 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
144 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
146 } else if (PL_curcop->cop_hints_hash) {
147 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
149 if (ptr && SvIOK(ptr) && SvIV(ptr))
150 eng = INT2PTR(regexp_engine*,SvIV(ptr));
153 if (PL_op->op_flags & OPf_SPECIAL)
154 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
156 if (DO_UTF8(tmpstr)) {
157 assert (SvUTF8(tmpstr));
158 } else if (SvUTF8(tmpstr)) {
159 /* Not doing UTF-8, despite what the SV says. Is this only if
160 we're trapped in use 'bytes'? */
161 /* Make a copy of the octet sequence, but without the flag on,
162 as the compiler now honours the SvUTF8 flag on tmpstr. */
164 const char *const p = SvPV(tmpstr, len);
165 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
169 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
171 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
173 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
174 inside tie/overload accessors. */
180 #ifndef INCOMPLETE_TAINTS
183 RX_EXTFLAGS(re) |= RXf_TAINTED;
185 RX_EXTFLAGS(re) &= ~RXf_TAINTED;
189 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
193 #if !defined(USE_ITHREADS)
194 /* can't change the optree at runtime either */
195 /* PMf_KEEP is handled differently under threads to avoid these problems */
196 if (pm->op_pmflags & PMf_KEEP) {
197 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
198 cLOGOP->op_first->op_next = PL_op->op_next;
208 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
209 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
210 register SV * const dstr = cx->sb_dstr;
211 register char *s = cx->sb_s;
212 register char *m = cx->sb_m;
213 char *orig = cx->sb_orig;
214 register REGEXP * const rx = cx->sb_rx;
216 REGEXP *old = PM_GETRE(pm);
220 PM_SETRE(pm,ReREFCNT_inc(rx));
223 rxres_restore(&cx->sb_rxres, rx);
224 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
226 if (cx->sb_iters++) {
227 const I32 saviters = cx->sb_iters;
228 if (cx->sb_iters > cx->sb_maxiters)
229 DIE(aTHX_ "Substitution loop");
231 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
232 cx->sb_rxtainted |= 2;
233 sv_catsv(dstr, POPs);
234 FREETMPS; /* Prevent excess tmp stack */
237 if (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
238 s == m, cx->sb_targ, NULL,
239 ((cx->sb_rflags & REXEC_COPY_STR)
240 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
241 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
243 SV * const targ = cx->sb_targ;
245 assert(cx->sb_strend >= s);
246 if(cx->sb_strend > s) {
247 if (DO_UTF8(dstr) && !SvUTF8(targ))
248 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
250 sv_catpvn(dstr, s, cx->sb_strend - s);
252 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
254 #ifdef PERL_OLD_COPY_ON_WRITE
256 sv_force_normal_flags(targ, SV_COW_DROP_PV);
262 SvPV_set(targ, SvPVX(dstr));
263 SvCUR_set(targ, SvCUR(dstr));
264 SvLEN_set(targ, SvLEN(dstr));
267 SvPV_set(dstr, NULL);
269 TAINT_IF(cx->sb_rxtainted & 1);
270 mPUSHi(saviters - 1);
272 (void)SvPOK_only_UTF8(targ);
273 TAINT_IF(cx->sb_rxtainted);
277 LEAVE_SCOPE(cx->sb_oldsave);
279 RETURNOP(pm->op_next);
281 cx->sb_iters = saviters;
283 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
286 cx->sb_orig = orig = RX_SUBBEG(rx);
288 cx->sb_strend = s + (cx->sb_strend - m);
290 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
292 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
293 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
295 sv_catpvn(dstr, s, m-s);
297 cx->sb_s = RX_OFFS(rx)[0].end + orig;
298 { /* Update the pos() information. */
299 SV * const sv = cx->sb_targ;
302 SvUPGRADE(sv, SVt_PVMG);
303 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
304 #ifdef PERL_OLD_COPY_ON_WRITE
306 sv_force_normal_flags(sv, 0);
308 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
317 (void)ReREFCNT_inc(rx);
318 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
319 rxres_save(&cx->sb_rxres, rx);
320 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
324 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
329 PERL_ARGS_ASSERT_RXRES_SAVE;
332 if (!p || p[1] < RX_NPARENS(rx)) {
333 #ifdef PERL_OLD_COPY_ON_WRITE
334 i = 7 + RX_NPARENS(rx) * 2;
336 i = 6 + RX_NPARENS(rx) * 2;
345 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
346 RX_MATCH_COPIED_off(rx);
348 #ifdef PERL_OLD_COPY_ON_WRITE
349 *p++ = PTR2UV(RX_SAVED_COPY(rx));
350 RX_SAVED_COPY(rx) = NULL;
353 *p++ = RX_NPARENS(rx);
355 *p++ = PTR2UV(RX_SUBBEG(rx));
356 *p++ = (UV)RX_SUBLEN(rx);
357 for (i = 0; i <= RX_NPARENS(rx); ++i) {
358 *p++ = (UV)RX_OFFS(rx)[i].start;
359 *p++ = (UV)RX_OFFS(rx)[i].end;
364 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
369 PERL_ARGS_ASSERT_RXRES_RESTORE;
372 RX_MATCH_COPY_FREE(rx);
373 RX_MATCH_COPIED_set(rx, *p);
376 #ifdef PERL_OLD_COPY_ON_WRITE
377 if (RX_SAVED_COPY(rx))
378 SvREFCNT_dec (RX_SAVED_COPY(rx));
379 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
383 RX_NPARENS(rx) = *p++;
385 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
386 RX_SUBLEN(rx) = (I32)(*p++);
387 for (i = 0; i <= RX_NPARENS(rx); ++i) {
388 RX_OFFS(rx)[i].start = (I32)(*p++);
389 RX_OFFS(rx)[i].end = (I32)(*p++);
394 Perl_rxres_free(pTHX_ void **rsp)
396 UV * const p = (UV*)*rsp;
398 PERL_ARGS_ASSERT_RXRES_FREE;
403 void *tmp = INT2PTR(char*,*p);
406 PoisonFree(*p, 1, sizeof(*p));
408 Safefree(INT2PTR(char*,*p));
410 #ifdef PERL_OLD_COPY_ON_WRITE
412 SvREFCNT_dec (INT2PTR(SV*,p[1]));
422 dVAR; dSP; dMARK; dORIGMARK;
423 register SV * const tmpForm = *++MARK;
428 register SV *sv = NULL;
429 const char *item = NULL;
433 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
434 const char *chophere = NULL;
435 char *linemark = NULL;
437 bool gotsome = FALSE;
439 const STRLEN fudge = SvPOK(tmpForm)
440 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
441 bool item_is_utf8 = FALSE;
442 bool targ_is_utf8 = FALSE;
444 OP * parseres = NULL;
448 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
449 if (SvREADONLY(tmpForm)) {
450 SvREADONLY_off(tmpForm);
451 parseres = doparseform(tmpForm);
452 SvREADONLY_on(tmpForm);
455 parseres = doparseform(tmpForm);
459 SvPV_force(PL_formtarget, len);
460 if (DO_UTF8(PL_formtarget))
462 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
464 f = SvPV_const(tmpForm, len);
465 /* need to jump to the next word */
466 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
470 const char *name = "???";
473 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
474 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
475 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
476 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
477 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
479 case FF_CHECKNL: name = "CHECKNL"; break;
480 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
481 case FF_SPACE: name = "SPACE"; break;
482 case FF_HALFSPACE: name = "HALFSPACE"; break;
483 case FF_ITEM: name = "ITEM"; break;
484 case FF_CHOP: name = "CHOP"; break;
485 case FF_LINEGLOB: name = "LINEGLOB"; break;
486 case FF_NEWLINE: name = "NEWLINE"; break;
487 case FF_MORE: name = "MORE"; break;
488 case FF_LINEMARK: name = "LINEMARK"; break;
489 case FF_END: name = "END"; break;
490 case FF_0DECIMAL: name = "0DECIMAL"; break;
491 case FF_LINESNGL: name = "LINESNGL"; break;
494 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
496 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
507 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
508 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
510 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
511 t = SvEND(PL_formtarget);
514 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
515 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
517 sv_utf8_upgrade(PL_formtarget);
518 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
519 t = SvEND(PL_formtarget);
539 if (ckWARN(WARN_SYNTAX))
540 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
547 const char *s = item = SvPV_const(sv, len);
550 itemsize = sv_len_utf8(sv);
551 if (itemsize != (I32)len) {
553 if (itemsize > fieldsize) {
554 itemsize = fieldsize;
555 itembytes = itemsize;
556 sv_pos_u2b(sv, &itembytes, 0);
560 send = chophere = s + itembytes;
570 sv_pos_b2u(sv, &itemsize);
574 item_is_utf8 = FALSE;
575 if (itemsize > fieldsize)
576 itemsize = fieldsize;
577 send = chophere = s + itemsize;
591 const char *s = item = SvPV_const(sv, len);
594 itemsize = sv_len_utf8(sv);
595 if (itemsize != (I32)len) {
597 if (itemsize <= fieldsize) {
598 const char *send = chophere = s + itemsize;
611 itemsize = fieldsize;
612 itembytes = itemsize;
613 sv_pos_u2b(sv, &itembytes, 0);
614 send = chophere = s + itembytes;
615 while (s < send || (s == send && isSPACE(*s))) {
625 if (strchr(PL_chopset, *s))
630 itemsize = chophere - item;
631 sv_pos_b2u(sv, &itemsize);
637 item_is_utf8 = FALSE;
638 if (itemsize <= fieldsize) {
639 const char *const send = chophere = s + itemsize;
652 itemsize = fieldsize;
653 send = chophere = s + itemsize;
654 while (s < send || (s == send && isSPACE(*s))) {
664 if (strchr(PL_chopset, *s))
669 itemsize = chophere - item;
675 arg = fieldsize - itemsize;
684 arg = fieldsize - itemsize;
695 const char *s = item;
699 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
701 sv_utf8_upgrade(PL_formtarget);
702 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
703 t = SvEND(PL_formtarget);
707 if (UTF8_IS_CONTINUED(*s)) {
708 STRLEN skip = UTF8SKIP(s);
725 if ( !((*t++ = *s++) & ~31) )
731 if (targ_is_utf8 && !item_is_utf8) {
732 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
734 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
735 for (; t < SvEND(PL_formtarget); t++) {
748 const int ch = *t++ = *s++;
751 if ( !((*t++ = *s++) & ~31) )
760 const char *s = chophere;
778 const char *s = item = SvPV_const(sv, len);
780 if ((item_is_utf8 = DO_UTF8(sv)))
781 itemsize = sv_len_utf8(sv);
783 bool chopped = FALSE;
784 const char *const send = s + len;
786 chophere = s + itemsize;
802 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
804 SvUTF8_on(PL_formtarget);
806 SvCUR_set(sv, chophere - item);
807 sv_catsv(PL_formtarget, sv);
808 SvCUR_set(sv, itemsize);
810 sv_catsv(PL_formtarget, sv);
812 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
813 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
814 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
823 #if defined(USE_LONG_DOUBLE)
826 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
830 "%#0*.*f" : "%0*.*f");
835 #if defined(USE_LONG_DOUBLE)
837 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
840 ((arg & 256) ? "%#*.*f" : "%*.*f");
843 /* If the field is marked with ^ and the value is undefined,
845 if ((arg & 512) && !SvOK(sv)) {
853 /* overflow evidence */
854 if (num_overflow(value, fieldsize, arg)) {
860 /* Formats aren't yet marked for locales, so assume "yes". */
862 STORE_NUMERIC_STANDARD_SET_LOCAL();
863 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
864 RESTORE_NUMERIC_STANDARD();
871 while (t-- > linemark && *t == ' ') ;
879 if (arg) { /* repeat until fields exhausted? */
881 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
882 lines += FmLINES(PL_formtarget);
885 if (strnEQ(linemark, linemark - arg, arg))
886 DIE(aTHX_ "Runaway format");
889 SvUTF8_on(PL_formtarget);
890 FmLINES(PL_formtarget) = lines;
892 RETURNOP(cLISTOP->op_first);
903 const char *s = chophere;
904 const char *send = item + len;
906 while (isSPACE(*s) && (s < send))
911 arg = fieldsize - itemsize;
918 if (strnEQ(s1," ",3)) {
919 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
930 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
932 SvUTF8_on(PL_formtarget);
933 FmLINES(PL_formtarget) += lines;
945 if (PL_stack_base + *PL_markstack_ptr == SP) {
947 if (GIMME_V == G_SCALAR)
949 RETURNOP(PL_op->op_next->op_next);
951 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
952 pp_pushmark(); /* push dst */
953 pp_pushmark(); /* push src */
954 ENTER; /* enter outer scope */
957 if (PL_op->op_private & OPpGREP_LEX)
958 SAVESPTR(PAD_SVl(PL_op->op_targ));
961 ENTER; /* enter inner scope */
964 src = PL_stack_base[*PL_markstack_ptr];
966 if (PL_op->op_private & OPpGREP_LEX)
967 PAD_SVl(PL_op->op_targ) = src;
972 if (PL_op->op_type == OP_MAPSTART)
973 pp_pushmark(); /* push top */
974 return ((LOGOP*)PL_op->op_next)->op_other;
980 const I32 gimme = GIMME_V;
981 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
987 /* first, move source pointer to the next item in the source list */
988 ++PL_markstack_ptr[-1];
990 /* if there are new items, push them into the destination list */
991 if (items && gimme != G_VOID) {
992 /* might need to make room back there first */
993 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
994 /* XXX this implementation is very pessimal because the stack
995 * is repeatedly extended for every set of items. Is possible
996 * to do this without any stack extension or copying at all
997 * by maintaining a separate list over which the map iterates
998 * (like foreach does). --gsar */
1000 /* everything in the stack after the destination list moves
1001 * towards the end the stack by the amount of room needed */
1002 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1004 /* items to shift up (accounting for the moved source pointer) */
1005 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1007 /* This optimization is by Ben Tilly and it does
1008 * things differently from what Sarathy (gsar)
1009 * is describing. The downside of this optimization is
1010 * that leaves "holes" (uninitialized and hopefully unused areas)
1011 * to the Perl stack, but on the other hand this
1012 * shouldn't be a problem. If Sarathy's idea gets
1013 * implemented, this optimization should become
1014 * irrelevant. --jhi */
1016 shift = count; /* Avoid shifting too often --Ben Tilly */
1020 dst = (SP += shift);
1021 PL_markstack_ptr[-1] += shift;
1022 *PL_markstack_ptr += shift;
1026 /* copy the new items down to the destination list */
1027 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1028 if (gimme == G_ARRAY) {
1030 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1033 /* scalar context: we don't care about which values map returns
1034 * (we use undef here). And so we certainly don't want to do mortal
1035 * copies of meaningless values. */
1036 while (items-- > 0) {
1038 *dst-- = &PL_sv_undef;
1042 LEAVE; /* exit inner scope */
1045 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1047 (void)POPMARK; /* pop top */
1048 LEAVE; /* exit outer scope */
1049 (void)POPMARK; /* pop src */
1050 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1051 (void)POPMARK; /* pop dst */
1052 SP = PL_stack_base + POPMARK; /* pop original mark */
1053 if (gimme == G_SCALAR) {
1054 if (PL_op->op_private & OPpGREP_LEX) {
1055 SV* sv = sv_newmortal();
1056 sv_setiv(sv, items);
1064 else if (gimme == G_ARRAY)
1071 ENTER; /* enter inner scope */
1074 /* set $_ to the new source item */
1075 src = PL_stack_base[PL_markstack_ptr[-1]];
1077 if (PL_op->op_private & OPpGREP_LEX)
1078 PAD_SVl(PL_op->op_targ) = src;
1082 RETURNOP(cLOGOP->op_other);
1091 if (GIMME == G_ARRAY)
1093 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1094 return cLOGOP->op_other;
1104 if (GIMME == G_ARRAY) {
1105 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1109 SV * const targ = PAD_SV(PL_op->op_targ);
1112 if (PL_op->op_private & OPpFLIP_LINENUM) {
1113 if (GvIO(PL_last_in_gv)) {
1114 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1117 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1119 flip = SvIV(sv) == SvIV(GvSV(gv));
1125 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1126 if (PL_op->op_flags & OPf_SPECIAL) {
1134 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1137 sv_setpvn(TARG, "", 0);
1143 /* This code tries to decide if "$left .. $right" should use the
1144 magical string increment, or if the range is numeric (we make
1145 an exception for .."0" [#18165]). AMS 20021031. */
1147 #define RANGE_IS_NUMERIC(left,right) ( \
1148 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1149 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1150 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1151 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1152 && (!SvOK(right) || looks_like_number(right))))
1158 if (GIMME == G_ARRAY) {
1164 if (RANGE_IS_NUMERIC(left,right)) {
1167 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1168 (SvOK(right) && SvNV(right) > IV_MAX))
1169 DIE(aTHX_ "Range iterator outside integer range");
1180 SV * const sv = sv_2mortal(newSViv(i++));
1185 SV * const final = sv_mortalcopy(right);
1187 const char * const tmps = SvPV_const(final, len);
1189 SV *sv = sv_mortalcopy(left);
1190 SvPV_force_nolen(sv);
1191 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1193 if (strEQ(SvPVX_const(sv),tmps))
1195 sv = sv_2mortal(newSVsv(sv));
1202 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1206 if (PL_op->op_private & OPpFLIP_LINENUM) {
1207 if (GvIO(PL_last_in_gv)) {
1208 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1211 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1212 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1220 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1221 sv_catpvs(targ, "E0");
1231 static const char * const context_name[] = {
1234 NULL, /* CXt_BLOCK never actually needs "block" */
1236 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1237 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1238 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1239 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1247 S_dopoptolabel(pTHX_ const char *label)
1252 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1254 for (i = cxstack_ix; i >= 0; i--) {
1255 register const PERL_CONTEXT * const cx = &cxstack[i];
1256 switch (CxTYPE(cx)) {
1264 if (ckWARN(WARN_EXITING))
1265 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1266 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1267 if (CxTYPE(cx) == CXt_NULL)
1270 case CXt_LOOP_LAZYIV:
1271 case CXt_LOOP_LAZYSV:
1273 case CXt_LOOP_PLAIN:
1274 if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
1275 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1276 (long)i, CxLABEL(cx)));
1279 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1289 Perl_dowantarray(pTHX)
1292 const I32 gimme = block_gimme();
1293 return (gimme == G_VOID) ? G_SCALAR : gimme;
1297 Perl_block_gimme(pTHX)
1300 const I32 cxix = dopoptosub(cxstack_ix);
1304 switch (cxstack[cxix].blk_gimme) {
1312 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1319 Perl_is_lvalue_sub(pTHX)
1322 const I32 cxix = dopoptosub(cxstack_ix);
1323 assert(cxix >= 0); /* We should only be called from inside subs */
1325 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1326 return CxLVAL(cxstack + cxix);
1332 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1337 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1339 for (i = startingblock; i >= 0; i--) {
1340 register const PERL_CONTEXT * const cx = &cxstk[i];
1341 switch (CxTYPE(cx)) {
1347 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1355 S_dopoptoeval(pTHX_ I32 startingblock)
1359 for (i = startingblock; i >= 0; i--) {
1360 register const PERL_CONTEXT *cx = &cxstack[i];
1361 switch (CxTYPE(cx)) {
1365 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1373 S_dopoptoloop(pTHX_ I32 startingblock)
1377 for (i = startingblock; i >= 0; i--) {
1378 register const PERL_CONTEXT * const cx = &cxstack[i];
1379 switch (CxTYPE(cx)) {
1385 if (ckWARN(WARN_EXITING))
1386 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1387 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1388 if ((CxTYPE(cx)) == CXt_NULL)
1391 case CXt_LOOP_LAZYIV:
1392 case CXt_LOOP_LAZYSV:
1394 case CXt_LOOP_PLAIN:
1395 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1403 S_dopoptogiven(pTHX_ I32 startingblock)
1407 for (i = startingblock; i >= 0; i--) {
1408 register const PERL_CONTEXT *cx = &cxstack[i];
1409 switch (CxTYPE(cx)) {
1413 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1415 case CXt_LOOP_PLAIN:
1416 assert(!CxFOREACHDEF(cx));
1418 case CXt_LOOP_LAZYIV:
1419 case CXt_LOOP_LAZYSV:
1421 if (CxFOREACHDEF(cx)) {
1422 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1431 S_dopoptowhen(pTHX_ I32 startingblock)
1435 for (i = startingblock; i >= 0; i--) {
1436 register const PERL_CONTEXT *cx = &cxstack[i];
1437 switch (CxTYPE(cx)) {
1441 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1449 Perl_dounwind(pTHX_ I32 cxix)
1454 while (cxstack_ix > cxix) {
1456 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1457 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1458 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1459 /* Note: we don't need to restore the base context info till the end. */
1460 switch (CxTYPE(cx)) {
1463 continue; /* not break */
1471 case CXt_LOOP_LAZYIV:
1472 case CXt_LOOP_LAZYSV:
1474 case CXt_LOOP_PLAIN:
1485 PERL_UNUSED_VAR(optype);
1489 Perl_qerror(pTHX_ SV *err)
1493 PERL_ARGS_ASSERT_QERROR;
1496 sv_catsv(ERRSV, err);
1498 sv_catsv(PL_errors, err);
1500 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1502 ++PL_parser->error_count;
1506 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1515 if (PL_in_eval & EVAL_KEEPERR) {
1516 static const char prefix[] = "\t(in cleanup) ";
1517 SV * const err = ERRSV;
1518 const char *e = NULL;
1520 sv_setpvn(err,"",0);
1521 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1523 e = SvPV_const(err, len);
1525 if (*e != *message || strNE(e,message))
1529 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1530 sv_catpvn(err, prefix, sizeof(prefix)-1);
1531 sv_catpvn(err, message, msglen);
1532 if (ckWARN(WARN_MISC)) {
1533 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1534 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1539 sv_setpvn(ERRSV, message, msglen);
1543 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1544 && PL_curstackinfo->si_prev)
1552 register PERL_CONTEXT *cx;
1555 if (cxix < cxstack_ix)
1558 POPBLOCK(cx,PL_curpm);
1559 if (CxTYPE(cx) != CXt_EVAL) {
1561 message = SvPVx_const(ERRSV, msglen);
1562 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1563 PerlIO_write(Perl_error_log, message, msglen);
1568 if (gimme == G_SCALAR)
1569 *++newsp = &PL_sv_undef;
1570 PL_stack_sp = newsp;
1574 /* LEAVE could clobber PL_curcop (see save_re_context())
1575 * XXX it might be better to find a way to avoid messing with
1576 * PL_curcop in save_re_context() instead, but this is a more
1577 * minimal fix --GSAR */
1578 PL_curcop = cx->blk_oldcop;
1580 if (optype == OP_REQUIRE) {
1581 const char* const msg = SvPVx_nolen_const(ERRSV);
1582 SV * const nsv = cx->blk_eval.old_namesv;
1583 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1585 DIE(aTHX_ "%sCompilation failed in require",
1586 *msg ? msg : "Unknown error\n");
1588 assert(CxTYPE(cx) == CXt_EVAL);
1589 return cx->blk_eval.retop;
1593 message = SvPVx_const(ERRSV, msglen);
1595 write_to_stderr(message, msglen);
1603 dVAR; dSP; dPOPTOPssrl;
1604 if (SvTRUE(left) != SvTRUE(right))
1614 register I32 cxix = dopoptosub(cxstack_ix);
1615 register const PERL_CONTEXT *cx;
1616 register const PERL_CONTEXT *ccstack = cxstack;
1617 const PERL_SI *top_si = PL_curstackinfo;
1619 const char *stashname;
1626 /* we may be in a higher stacklevel, so dig down deeper */
1627 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1628 top_si = top_si->si_prev;
1629 ccstack = top_si->si_cxstack;
1630 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1633 if (GIMME != G_ARRAY) {
1639 /* caller() should not report the automatic calls to &DB::sub */
1640 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1641 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1645 cxix = dopoptosub_at(ccstack, cxix - 1);
1648 cx = &ccstack[cxix];
1649 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1650 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1651 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1652 field below is defined for any cx. */
1653 /* caller() should not report the automatic calls to &DB::sub */
1654 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1655 cx = &ccstack[dbcxix];
1658 stashname = CopSTASHPV(cx->blk_oldcop);
1659 if (GIMME != G_ARRAY) {
1662 PUSHs(&PL_sv_undef);
1665 sv_setpv(TARG, stashname);
1674 PUSHs(&PL_sv_undef);
1676 mPUSHs(newSVpv(stashname, 0));
1677 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1678 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1681 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1682 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1683 /* So is ccstack[dbcxix]. */
1685 SV * const sv = newSV(0);
1686 gv_efullname3(sv, cvgv, NULL);
1688 PUSHs(boolSV(CxHASARGS(cx)));
1691 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1692 PUSHs(boolSV(CxHASARGS(cx)));
1696 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1699 gimme = (I32)cx->blk_gimme;
1700 if (gimme == G_VOID)
1701 PUSHs(&PL_sv_undef);
1703 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1704 if (CxTYPE(cx) == CXt_EVAL) {
1706 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1707 PUSHs(cx->blk_eval.cur_text);
1711 else if (cx->blk_eval.old_namesv) {
1712 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1715 /* eval BLOCK (try blocks have old_namesv == 0) */
1717 PUSHs(&PL_sv_undef);
1718 PUSHs(&PL_sv_undef);
1722 PUSHs(&PL_sv_undef);
1723 PUSHs(&PL_sv_undef);
1725 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1726 && CopSTASH_eq(PL_curcop, PL_debstash))
1728 AV * const ary = cx->blk_sub.argarray;
1729 const int off = AvARRAY(ary) - AvALLOC(ary);
1732 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1733 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1735 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1738 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1739 av_extend(PL_dbargs, AvFILLp(ary) + off);
1740 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1741 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1743 /* XXX only hints propagated via op_private are currently
1744 * visible (others are not easily accessible, since they
1745 * use the global PL_hints) */
1746 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1749 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1751 if (old_warnings == pWARN_NONE ||
1752 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1753 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1754 else if (old_warnings == pWARN_ALL ||
1755 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1756 /* Get the bit mask for $warnings::Bits{all}, because
1757 * it could have been extended by warnings::register */
1759 HV * const bits = get_hv("warnings::Bits", FALSE);
1760 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1761 mask = newSVsv(*bits_all);
1764 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1768 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1772 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1773 sv_2mortal(newRV_noinc(
1774 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1775 cx->blk_oldcop->cop_hints_hash)))
1784 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1785 sv_reset(tmps, CopSTASH(PL_curcop));
1790 /* like pp_nextstate, but used instead when the debugger is active */
1795 PL_curcop = (COP*)PL_op;
1796 TAINT_NOT; /* Each statement is presumed innocent */
1797 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1800 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1801 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1804 register PERL_CONTEXT *cx;
1805 const I32 gimme = G_ARRAY;
1807 GV * const gv = PL_DBgv;
1808 register CV * const cv = GvCV(gv);
1811 DIE(aTHX_ "No DB::DB routine defined");
1813 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1814 /* don't do recursive DB::DB call */
1829 (void)(*CvXSUB(cv))(aTHX_ cv);
1836 PUSHBLOCK(cx, CXt_SUB, SP);
1838 cx->blk_sub.retop = PL_op->op_next;
1841 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1842 RETURNOP(CvSTART(cv));
1852 register PERL_CONTEXT *cx;
1853 const I32 gimme = GIMME_V;
1855 U8 cxtype = CXt_LOOP_FOR;
1863 if (PL_op->op_targ) {
1864 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1865 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1866 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1867 SVs_PADSTALE, SVs_PADSTALE);
1869 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1870 #ifndef USE_ITHREADS
1871 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1877 GV * const gv = (GV*)POPs;
1878 svp = &GvSV(gv); /* symbol table variable */
1879 SAVEGENERICSV(*svp);
1882 iterdata = (PAD*)gv;
1886 if (PL_op->op_private & OPpITER_DEF)
1887 cxtype |= CXp_FOR_DEF;
1891 PUSHBLOCK(cx, cxtype, SP);
1893 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1895 PUSHLOOP_FOR(cx, svp, MARK, 0);
1897 if (PL_op->op_flags & OPf_STACKED) {
1898 SV *maybe_ary = POPs;
1899 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1901 SV * const right = maybe_ary;
1904 if (RANGE_IS_NUMERIC(sv,right)) {
1905 cx->cx_type &= ~CXTYPEMASK;
1906 cx->cx_type |= CXt_LOOP_LAZYIV;
1907 /* Make sure that no-one re-orders cop.h and breaks our
1909 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1910 #ifdef NV_PRESERVES_UV
1911 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1912 (SvNV(sv) > (NV)IV_MAX)))
1914 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1915 (SvNV(right) < (NV)IV_MIN))))
1917 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1920 ((SvUV(sv) > (UV)IV_MAX) ||
1921 (SvNV(sv) > (NV)UV_MAX)))))
1923 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1925 ((SvNV(right) > 0) &&
1926 ((SvUV(right) > (UV)IV_MAX) ||
1927 (SvNV(right) > (NV)UV_MAX))))))
1929 DIE(aTHX_ "Range iterator outside integer range");
1930 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1931 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1933 /* for correct -Dstv display */
1934 cx->blk_oldsp = sp - PL_stack_base;
1938 cx->cx_type &= ~CXTYPEMASK;
1939 cx->cx_type |= CXt_LOOP_LAZYSV;
1940 /* Make sure that no-one re-orders cop.h and breaks our
1942 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
1943 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
1944 cx->blk_loop.state_u.lazysv.end = right;
1945 SvREFCNT_inc(right);
1946 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
1947 /* This will do the upgrade to SVt_PV, and warn if the value
1948 is uninitialised. */
1949 (void) SvPV_nolen_const(right);
1950 /* Doing this avoids a check every time in pp_iter in pp_hot.c
1951 to replace !SvOK() with a pointer to "". */
1953 SvREFCNT_dec(right);
1954 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
1958 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
1959 cx->blk_loop.state_u.ary.ary = (AV*)maybe_ary;
1960 SvREFCNT_inc(maybe_ary);
1961 cx->blk_loop.state_u.ary.ix =
1962 (PL_op->op_private & OPpITER_REVERSED) ?
1963 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
1967 else { /* iterating over items on the stack */
1968 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
1969 if (PL_op->op_private & OPpITER_REVERSED) {
1970 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
1973 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
1983 register PERL_CONTEXT *cx;
1984 const I32 gimme = GIMME_V;
1990 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
1991 PUSHLOOP_PLAIN(cx, SP);
1999 register PERL_CONTEXT *cx;
2006 assert(CxTYPE_is_LOOP(cx));
2008 newsp = PL_stack_base + cx->blk_loop.resetsp;
2011 if (gimme == G_VOID)
2013 else if (gimme == G_SCALAR) {
2015 *++newsp = sv_mortalcopy(*SP);
2017 *++newsp = &PL_sv_undef;
2021 *++newsp = sv_mortalcopy(*++mark);
2022 TAINT_NOT; /* Each item is independent */
2028 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2029 PL_curpm = newpm; /* ... and pop $1 et al */
2040 register PERL_CONTEXT *cx;
2041 bool popsub2 = FALSE;
2042 bool clear_errsv = FALSE;
2050 const I32 cxix = dopoptosub(cxstack_ix);
2053 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2054 * sort block, which is a CXt_NULL
2057 PL_stack_base[1] = *PL_stack_sp;
2058 PL_stack_sp = PL_stack_base + 1;
2062 DIE(aTHX_ "Can't return outside a subroutine");
2064 if (cxix < cxstack_ix)
2067 if (CxMULTICALL(&cxstack[cxix])) {
2068 gimme = cxstack[cxix].blk_gimme;
2069 if (gimme == G_VOID)
2070 PL_stack_sp = PL_stack_base;
2071 else if (gimme == G_SCALAR) {
2072 PL_stack_base[1] = *PL_stack_sp;
2073 PL_stack_sp = PL_stack_base + 1;
2079 switch (CxTYPE(cx)) {
2082 retop = cx->blk_sub.retop;
2083 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2086 if (!(PL_in_eval & EVAL_KEEPERR))
2089 retop = cx->blk_eval.retop;
2093 if (optype == OP_REQUIRE &&
2094 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2096 /* Unassume the success we assumed earlier. */
2097 SV * const nsv = cx->blk_eval.old_namesv;
2098 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2099 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2104 retop = cx->blk_sub.retop;
2107 DIE(aTHX_ "panic: return");
2111 if (gimme == G_SCALAR) {
2114 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2116 *++newsp = SvREFCNT_inc(*SP);
2121 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2123 *++newsp = sv_mortalcopy(sv);
2128 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2131 *++newsp = sv_mortalcopy(*SP);
2134 *++newsp = &PL_sv_undef;
2136 else if (gimme == G_ARRAY) {
2137 while (++MARK <= SP) {
2138 *++newsp = (popsub2 && SvTEMP(*MARK))
2139 ? *MARK : sv_mortalcopy(*MARK);
2140 TAINT_NOT; /* Each item is independent */
2143 PL_stack_sp = newsp;
2146 /* Stack values are safe: */
2149 POPSUB(cx,sv); /* release CV and @_ ... */
2153 PL_curpm = newpm; /* ... and pop $1 et al */
2157 sv_setpvn(ERRSV,"",0);
2165 register PERL_CONTEXT *cx;
2176 if (PL_op->op_flags & OPf_SPECIAL) {
2177 cxix = dopoptoloop(cxstack_ix);
2179 DIE(aTHX_ "Can't \"last\" outside a loop block");
2182 cxix = dopoptolabel(cPVOP->op_pv);
2184 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2186 if (cxix < cxstack_ix)
2190 cxstack_ix++; /* temporarily protect top context */
2192 switch (CxTYPE(cx)) {
2193 case CXt_LOOP_LAZYIV:
2194 case CXt_LOOP_LAZYSV:
2196 case CXt_LOOP_PLAIN:
2198 newsp = PL_stack_base + cx->blk_loop.resetsp;
2199 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2203 nextop = cx->blk_sub.retop;
2207 nextop = cx->blk_eval.retop;
2211 nextop = cx->blk_sub.retop;
2214 DIE(aTHX_ "panic: last");
2218 if (gimme == G_SCALAR) {
2220 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2221 ? *SP : sv_mortalcopy(*SP);
2223 *++newsp = &PL_sv_undef;
2225 else if (gimme == G_ARRAY) {
2226 while (++MARK <= SP) {
2227 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2228 ? *MARK : sv_mortalcopy(*MARK);
2229 TAINT_NOT; /* Each item is independent */
2237 /* Stack values are safe: */
2239 case CXt_LOOP_LAZYIV:
2240 case CXt_LOOP_PLAIN:
2241 case CXt_LOOP_LAZYSV:
2243 POPLOOP(cx); /* release loop vars ... */
2247 POPSUB(cx,sv); /* release CV and @_ ... */
2250 PL_curpm = newpm; /* ... and pop $1 et al */
2253 PERL_UNUSED_VAR(optype);
2254 PERL_UNUSED_VAR(gimme);
2262 register PERL_CONTEXT *cx;
2265 if (PL_op->op_flags & OPf_SPECIAL) {
2266 cxix = dopoptoloop(cxstack_ix);
2268 DIE(aTHX_ "Can't \"next\" outside a loop block");
2271 cxix = dopoptolabel(cPVOP->op_pv);
2273 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2275 if (cxix < cxstack_ix)
2278 /* clear off anything above the scope we're re-entering, but
2279 * save the rest until after a possible continue block */
2280 inner = PL_scopestack_ix;
2282 if (PL_scopestack_ix < inner)
2283 leave_scope(PL_scopestack[PL_scopestack_ix]);
2284 PL_curcop = cx->blk_oldcop;
2285 return CX_LOOP_NEXTOP_GET(cx);
2292 register PERL_CONTEXT *cx;
2296 if (PL_op->op_flags & OPf_SPECIAL) {
2297 cxix = dopoptoloop(cxstack_ix);
2299 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2302 cxix = dopoptolabel(cPVOP->op_pv);
2304 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2306 if (cxix < cxstack_ix)
2309 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2310 if (redo_op->op_type == OP_ENTER) {
2311 /* pop one less context to avoid $x being freed in while (my $x..) */
2313 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2314 redo_op = redo_op->op_next;
2318 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2319 LEAVE_SCOPE(oldsave);
2321 PL_curcop = cx->blk_oldcop;
2326 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2330 static const char too_deep[] = "Target of goto is too deeply nested";
2332 PERL_ARGS_ASSERT_DOFINDLABEL;
2335 Perl_croak(aTHX_ too_deep);
2336 if (o->op_type == OP_LEAVE ||
2337 o->op_type == OP_SCOPE ||
2338 o->op_type == OP_LEAVELOOP ||
2339 o->op_type == OP_LEAVESUB ||
2340 o->op_type == OP_LEAVETRY)
2342 *ops++ = cUNOPo->op_first;
2344 Perl_croak(aTHX_ too_deep);
2347 if (o->op_flags & OPf_KIDS) {
2349 /* First try all the kids at this level, since that's likeliest. */
2350 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2351 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2352 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2355 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2356 if (kid == PL_lastgotoprobe)
2358 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2361 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2362 ops[-1]->op_type == OP_DBSTATE)
2367 if ((o = dofindlabel(kid, label, ops, oplimit)))
2380 register PERL_CONTEXT *cx;
2381 #define GOTO_DEPTH 64
2382 OP *enterops[GOTO_DEPTH];
2383 const char *label = NULL;
2384 const bool do_dump = (PL_op->op_type == OP_DUMP);
2385 static const char must_have_label[] = "goto must have label";
2387 if (PL_op->op_flags & OPf_STACKED) {
2388 SV * const sv = POPs;
2390 /* This egregious kludge implements goto &subroutine */
2391 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2393 register PERL_CONTEXT *cx;
2394 CV* cv = (CV*)SvRV(sv);
2401 if (!CvROOT(cv) && !CvXSUB(cv)) {
2402 const GV * const gv = CvGV(cv);
2406 /* autoloaded stub? */
2407 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2409 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2410 GvNAMELEN(gv), FALSE);
2411 if (autogv && (cv = GvCV(autogv)))
2413 tmpstr = sv_newmortal();
2414 gv_efullname3(tmpstr, gv, NULL);
2415 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2417 DIE(aTHX_ "Goto undefined subroutine");
2420 /* First do some returnish stuff. */
2421 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2423 cxix = dopoptosub(cxstack_ix);
2425 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2426 if (cxix < cxstack_ix)
2430 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2431 if (CxTYPE(cx) == CXt_EVAL) {
2433 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2435 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2437 else if (CxMULTICALL(cx))
2438 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2439 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2440 /* put @_ back onto stack */
2441 AV* av = cx->blk_sub.argarray;
2443 items = AvFILLp(av) + 1;
2444 EXTEND(SP, items+1); /* @_ could have been extended. */
2445 Copy(AvARRAY(av), SP + 1, items, SV*);
2446 SvREFCNT_dec(GvAV(PL_defgv));
2447 GvAV(PL_defgv) = cx->blk_sub.savearray;
2449 /* abandon @_ if it got reified */
2454 av_extend(av, items-1);
2456 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2459 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2460 AV* const av = GvAV(PL_defgv);
2461 items = AvFILLp(av) + 1;
2462 EXTEND(SP, items+1); /* @_ could have been extended. */
2463 Copy(AvARRAY(av), SP + 1, items, SV*);
2467 if (CxTYPE(cx) == CXt_SUB &&
2468 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2469 SvREFCNT_dec(cx->blk_sub.cv);
2470 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2471 LEAVE_SCOPE(oldsave);
2473 /* Now do some callish stuff. */
2475 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2477 OP* const retop = cx->blk_sub.retop;
2482 for (index=0; index<items; index++)
2483 sv_2mortal(SP[-index]);
2486 /* XS subs don't have a CxSUB, so pop it */
2487 POPBLOCK(cx, PL_curpm);
2488 /* Push a mark for the start of arglist */
2491 (void)(*CvXSUB(cv))(aTHX_ cv);
2496 AV* const padlist = CvPADLIST(cv);
2497 if (CxTYPE(cx) == CXt_EVAL) {
2498 PL_in_eval = CxOLD_IN_EVAL(cx);
2499 PL_eval_root = cx->blk_eval.old_eval_root;
2500 cx->cx_type = CXt_SUB;
2502 cx->blk_sub.cv = cv;
2503 cx->blk_sub.olddepth = CvDEPTH(cv);
2506 if (CvDEPTH(cv) < 2)
2507 SvREFCNT_inc_simple_void_NN(cv);
2509 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2510 sub_crush_depth(cv);
2511 pad_push(padlist, CvDEPTH(cv));
2514 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2517 AV* const av = (AV*)PAD_SVl(0);
2519 cx->blk_sub.savearray = GvAV(PL_defgv);
2520 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2521 CX_CURPAD_SAVE(cx->blk_sub);
2522 cx->blk_sub.argarray = av;
2524 if (items >= AvMAX(av) + 1) {
2525 SV **ary = AvALLOC(av);
2526 if (AvARRAY(av) != ary) {
2527 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2530 if (items >= AvMAX(av) + 1) {
2531 AvMAX(av) = items - 1;
2532 Renew(ary,items+1,SV*);
2538 Copy(mark,AvARRAY(av),items,SV*);
2539 AvFILLp(av) = items - 1;
2540 assert(!AvREAL(av));
2542 /* transfer 'ownership' of refcnts to new @_ */
2552 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2553 Perl_get_db_sub(aTHX_ NULL, cv);
2555 CV * const gotocv = get_cv("DB::goto", FALSE);
2557 PUSHMARK( PL_stack_sp );
2558 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2563 RETURNOP(CvSTART(cv));
2567 label = SvPV_nolen_const(sv);
2568 if (!(do_dump || *label))
2569 DIE(aTHX_ must_have_label);
2572 else if (PL_op->op_flags & OPf_SPECIAL) {
2574 DIE(aTHX_ must_have_label);
2577 label = cPVOP->op_pv;
2579 if (label && *label) {
2580 OP *gotoprobe = NULL;
2581 bool leaving_eval = FALSE;
2582 bool in_block = FALSE;
2583 PERL_CONTEXT *last_eval_cx = NULL;
2587 PL_lastgotoprobe = NULL;
2589 for (ix = cxstack_ix; ix >= 0; ix--) {
2591 switch (CxTYPE(cx)) {
2593 leaving_eval = TRUE;
2594 if (!CxTRYBLOCK(cx)) {
2595 gotoprobe = (last_eval_cx ?
2596 last_eval_cx->blk_eval.old_eval_root :
2601 /* else fall through */
2602 case CXt_LOOP_LAZYIV:
2603 case CXt_LOOP_LAZYSV:
2605 case CXt_LOOP_PLAIN:
2606 gotoprobe = cx->blk_oldcop->op_sibling;
2612 gotoprobe = cx->blk_oldcop->op_sibling;
2615 gotoprobe = PL_main_root;
2618 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2619 gotoprobe = CvROOT(cx->blk_sub.cv);
2625 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2628 DIE(aTHX_ "panic: goto");
2629 gotoprobe = PL_main_root;
2633 retop = dofindlabel(gotoprobe, label,
2634 enterops, enterops + GOTO_DEPTH);
2638 PL_lastgotoprobe = gotoprobe;
2641 DIE(aTHX_ "Can't find label %s", label);
2643 /* if we're leaving an eval, check before we pop any frames
2644 that we're not going to punt, otherwise the error
2647 if (leaving_eval && *enterops && enterops[1]) {
2649 for (i = 1; enterops[i]; i++)
2650 if (enterops[i]->op_type == OP_ENTERITER)
2651 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2654 /* pop unwanted frames */
2656 if (ix < cxstack_ix) {
2663 oldsave = PL_scopestack[PL_scopestack_ix];
2664 LEAVE_SCOPE(oldsave);
2667 /* push wanted frames */
2669 if (*enterops && enterops[1]) {
2670 OP * const oldop = PL_op;
2671 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2672 for (; enterops[ix]; ix++) {
2673 PL_op = enterops[ix];
2674 /* Eventually we may want to stack the needed arguments
2675 * for each op. For now, we punt on the hard ones. */
2676 if (PL_op->op_type == OP_ENTERITER)
2677 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2678 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2686 if (!retop) retop = PL_main_start;
2688 PL_restartop = retop;
2689 PL_do_undump = TRUE;
2693 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2694 PL_do_undump = FALSE;
2711 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2713 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2716 PL_exit_flags |= PERL_EXIT_EXPECTED;
2718 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2719 if (anum || !(PL_minus_c && PL_madskills))
2724 PUSHs(&PL_sv_undef);
2731 S_save_lines(pTHX_ AV *array, SV *sv)
2733 const char *s = SvPVX_const(sv);
2734 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2737 PERL_ARGS_ASSERT_SAVE_LINES;
2739 while (s && s < send) {
2741 SV * const tmpstr = newSV_type(SVt_PVMG);
2743 t = strchr(s, '\n');
2749 sv_setpvn(tmpstr, s, t - s);
2750 av_store(array, line++, tmpstr);
2756 S_docatch(pTHX_ OP *o)
2760 OP * const oldop = PL_op;
2764 assert(CATCH_GET == TRUE);
2771 assert(cxstack_ix >= 0);
2772 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2773 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2778 /* die caught by an inner eval - continue inner loop */
2780 /* NB XXX we rely on the old popped CxEVAL still being at the top
2781 * of the stack; the way die_where() currently works, this
2782 * assumption is valid. In theory The cur_top_env value should be
2783 * returned in another global, the way retop (aka PL_restartop)
2785 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2788 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2790 PL_op = PL_restartop;
2807 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2808 /* sv Text to convert to OP tree. */
2809 /* startop op_free() this to undo. */
2810 /* code Short string id of the caller. */
2812 /* FIXME - how much of this code is common with pp_entereval? */
2813 dVAR; dSP; /* Make POPBLOCK work. */
2819 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2820 char *tmpbuf = tbuf;
2823 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2826 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2829 lex_start(sv, NULL, FALSE);
2831 /* switch to eval mode */
2833 if (IN_PERL_COMPILETIME) {
2834 SAVECOPSTASH_FREE(&PL_compiling);
2835 CopSTASH_set(&PL_compiling, PL_curstash);
2837 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2838 SV * const sv = sv_newmortal();
2839 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2840 code, (unsigned long)++PL_evalseq,
2841 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2846 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2847 (unsigned long)++PL_evalseq);
2848 SAVECOPFILE_FREE(&PL_compiling);
2849 CopFILE_set(&PL_compiling, tmpbuf+2);
2850 SAVECOPLINE(&PL_compiling);
2851 CopLINE_set(&PL_compiling, 1);
2852 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2853 deleting the eval's FILEGV from the stash before gv_check() runs
2854 (i.e. before run-time proper). To work around the coredump that
2855 ensues, we always turn GvMULTI_on for any globals that were
2856 introduced within evals. See force_ident(). GSAR 96-10-12 */
2857 safestr = savepvn(tmpbuf, len);
2858 SAVEDELETE(PL_defstash, safestr, len);
2860 #ifdef OP_IN_REGISTER
2866 /* we get here either during compilation, or via pp_regcomp at runtime */
2867 runtime = IN_PERL_RUNTIME;
2869 runcv = find_runcv(NULL);
2872 PL_op->op_type = OP_ENTEREVAL;
2873 PL_op->op_flags = 0; /* Avoid uninit warning. */
2874 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2878 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2880 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2881 POPBLOCK(cx,PL_curpm);
2884 (*startop)->op_type = OP_NULL;
2885 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2887 /* XXX DAPM do this properly one year */
2888 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2890 if (IN_PERL_COMPILETIME)
2891 CopHINTS_set(&PL_compiling, PL_hints);
2892 #ifdef OP_IN_REGISTER
2895 PERL_UNUSED_VAR(newsp);
2896 PERL_UNUSED_VAR(optype);
2898 return PL_eval_start;
2903 =for apidoc find_runcv
2905 Locate the CV corresponding to the currently executing sub or eval.
2906 If db_seqp is non_null, skip CVs that are in the DB package and populate
2907 *db_seqp with the cop sequence number at the point that the DB:: code was
2908 entered. (allows debuggers to eval in the scope of the breakpoint rather
2909 than in the scope of the debugger itself).
2915 Perl_find_runcv(pTHX_ U32 *db_seqp)
2921 *db_seqp = PL_curcop->cop_seq;
2922 for (si = PL_curstackinfo; si; si = si->si_prev) {
2924 for (ix = si->si_cxix; ix >= 0; ix--) {
2925 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2926 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2927 CV * const cv = cx->blk_sub.cv;
2928 /* skip DB:: code */
2929 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2930 *db_seqp = cx->blk_oldcop->cop_seq;
2935 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2943 /* Compile a require/do, an eval '', or a /(?{...})/.
2944 * In the last case, startop is non-null, and contains the address of
2945 * a pointer that should be set to the just-compiled code.
2946 * outside is the lexically enclosing CV (if any) that invoked us.
2947 * Returns a bool indicating whether the compile was successful; if so,
2948 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2949 * pushes undef (also croaks if startop != NULL).
2953 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2956 OP * const saveop = PL_op;
2958 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2959 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2964 SAVESPTR(PL_compcv);
2965 PL_compcv = (CV*)newSV_type(SVt_PVCV);
2966 CvEVAL_on(PL_compcv);
2967 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2968 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2970 CvOUTSIDE_SEQ(PL_compcv) = seq;
2971 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2973 /* set up a scratch pad */
2975 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2976 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2980 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2982 /* make sure we compile in the right package */
2984 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2985 SAVESPTR(PL_curstash);
2986 PL_curstash = CopSTASH(PL_curcop);
2988 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2989 SAVESPTR(PL_beginav);
2990 PL_beginav = newAV();
2991 SAVEFREESV(PL_beginav);
2992 SAVESPTR(PL_unitcheckav);
2993 PL_unitcheckav = newAV();
2994 SAVEFREESV(PL_unitcheckav);
2997 SAVEBOOL(PL_madskills);
3001 /* try to compile it */
3003 PL_eval_root = NULL;
3004 PL_curcop = &PL_compiling;
3005 CopARYBASE_set(PL_curcop, 0);
3006 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3007 PL_in_eval |= EVAL_KEEPERR;
3009 sv_setpvn(ERRSV,"",0);
3010 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
3011 SV **newsp; /* Used by POPBLOCK. */
3012 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
3013 I32 optype = 0; /* Might be reset by POPEVAL. */
3018 op_free(PL_eval_root);
3019 PL_eval_root = NULL;
3021 SP = PL_stack_base + POPMARK; /* pop original mark */
3023 POPBLOCK(cx,PL_curpm);
3029 msg = SvPVx_nolen_const(ERRSV);
3030 if (optype == OP_REQUIRE) {
3031 const SV * const nsv = cx->blk_eval.old_namesv;
3032 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3034 Perl_croak(aTHX_ "%sCompilation failed in require",
3035 *msg ? msg : "Unknown error\n");
3038 POPBLOCK(cx,PL_curpm);
3040 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3041 (*msg ? msg : "Unknown error\n"));
3045 sv_setpvs(ERRSV, "Compilation error");
3048 PERL_UNUSED_VAR(newsp);
3049 PUSHs(&PL_sv_undef);
3053 CopLINE_set(&PL_compiling, 0);
3055 *startop = PL_eval_root;
3057 SAVEFREEOP(PL_eval_root);
3059 /* Set the context for this new optree.
3060 * If the last op is an OP_REQUIRE, force scalar context.
3061 * Otherwise, propagate the context from the eval(). */
3062 if (PL_eval_root->op_type == OP_LEAVEEVAL
3063 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3064 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3066 scalar(PL_eval_root);
3067 else if ((gimme & G_WANT) == G_VOID)
3068 scalarvoid(PL_eval_root);
3069 else if ((gimme & G_WANT) == G_ARRAY)
3072 scalar(PL_eval_root);
3074 DEBUG_x(dump_eval());
3076 /* Register with debugger: */
3077 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3078 CV * const cv = get_cv("DB::postponed", FALSE);
3082 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3084 call_sv((SV*)cv, G_DISCARD);
3089 call_list(PL_scopestack_ix, PL_unitcheckav);
3091 /* compiled okay, so do it */
3093 CvDEPTH(PL_compcv) = 1;
3094 SP = PL_stack_base + POPMARK; /* pop original mark */
3095 PL_op = saveop; /* The caller may need it. */
3096 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3103 S_check_type_and_open(pTHX_ const char *name)
3106 const int st_rc = PerlLIO_stat(name, &st);
3108 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3110 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3114 return PerlIO_open(name, PERL_SCRIPT_MODE);
3117 #ifndef PERL_DISABLE_PMC
3119 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3123 PERL_ARGS_ASSERT_DOOPEN_PM;
3125 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3126 SV *const pmcsv = newSV(namelen + 2);
3127 char *const pmc = SvPVX(pmcsv);
3130 memcpy(pmc, name, namelen);
3132 pmc[namelen + 1] = '\0';
3134 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3135 fp = check_type_and_open(name);
3138 fp = check_type_and_open(pmc);
3140 SvREFCNT_dec(pmcsv);
3143 fp = check_type_and_open(name);
3148 # define doopen_pm(name, namelen) check_type_and_open(name)
3149 #endif /* !PERL_DISABLE_PMC */
3154 register PERL_CONTEXT *cx;
3161 int vms_unixname = 0;
3163 const char *tryname = NULL;
3165 const I32 gimme = GIMME_V;
3166 int filter_has_file = 0;
3167 PerlIO *tryrsfp = NULL;
3168 SV *filter_cache = NULL;
3169 SV *filter_state = NULL;
3170 SV *filter_sub = NULL;
3176 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3177 sv = new_version(sv);
3178 if (!sv_derived_from(PL_patchlevel, "version"))
3179 upg_version(PL_patchlevel, TRUE);
3180 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3181 if ( vcmp(sv,PL_patchlevel) <= 0 )
3182 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3183 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3186 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3189 SV * const req = SvRV(sv);
3190 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3192 /* get the left hand term */
3193 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3195 first = SvIV(*av_fetch(lav,0,0));
3196 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3197 || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3198 || av_len(lav) > 1 /* FP with > 3 digits */
3199 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3201 DIE(aTHX_ "Perl %"SVf" required--this is only "
3202 "%"SVf", stopped", SVfARG(vnormal(req)),
3203 SVfARG(vnormal(PL_patchlevel)));
3205 else { /* probably 'use 5.10' or 'use 5.8' */
3206 SV * hintsv = newSV(0);
3210 second = SvIV(*av_fetch(lav,1,0));
3212 second /= second >= 600 ? 100 : 10;
3213 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3214 (int)first, (int)second,0);
3215 upg_version(hintsv, TRUE);
3217 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3218 "--this is only %"SVf", stopped",
3219 SVfARG(vnormal(req)),
3220 SVfARG(vnormal(hintsv)),
3221 SVfARG(vnormal(PL_patchlevel)));
3226 /* We do this only with use, not require. */
3228 /* If we request a version >= 5.9.5, load feature.pm with the
3229 * feature bundle that corresponds to the required version. */
3230 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3231 SV *const importsv = vnormal(sv);
3232 *SvPVX_mutable(importsv) = ':';
3234 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3240 name = SvPV_const(sv, len);
3241 if (!(name && len > 0 && *name))
3242 DIE(aTHX_ "Null filename used");
3243 TAINT_PROPER("require");
3247 /* The key in the %ENV hash is in the syntax of file passed as the argument
3248 * usually this is in UNIX format, but sometimes in VMS format, which
3249 * can result in a module being pulled in more than once.
3250 * To prevent this, the key must be stored in UNIX format if the VMS
3251 * name can be translated to UNIX.
3253 if ((unixname = tounixspec(name, NULL)) != NULL) {
3254 unixlen = strlen(unixname);
3260 /* if not VMS or VMS name can not be translated to UNIX, pass it
3263 unixname = (char *) name;
3266 if (PL_op->op_type == OP_REQUIRE) {
3267 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3268 unixname, unixlen, 0);
3270 if (*svp != &PL_sv_undef)
3273 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3274 "Compilation failed in require", unixname);
3278 /* prepare to compile file */
3280 if (path_is_absolute(name)) {
3282 tryrsfp = doopen_pm(name, len);
3284 #ifdef MACOS_TRADITIONAL
3288 MacPerl_CanonDir(name, newname, 1);
3289 if (path_is_absolute(newname)) {
3291 tryrsfp = doopen_pm(newname, strlen(newname));
3296 AV * const ar = GvAVn(PL_incgv);
3302 namesv = newSV_type(SVt_PV);
3303 for (i = 0; i <= AvFILL(ar); i++) {
3304 SV * const dirsv = *av_fetch(ar, i, TRUE);
3306 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3313 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3314 && !sv_isobject(loader))
3316 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3319 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3320 PTR2UV(SvRV(dirsv)), name);
3321 tryname = SvPVX_const(namesv);
3332 if (sv_isobject(loader))
3333 count = call_method("INC", G_ARRAY);
3335 count = call_sv(loader, G_ARRAY);
3338 /* Adjust file name if the hook has set an %INC entry */
3339 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3341 tryname = SvPVX_const(*svp);
3350 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3351 && !isGV_with_GP(SvRV(arg))) {
3352 filter_cache = SvRV(arg);
3353 SvREFCNT_inc_simple_void_NN(filter_cache);
3360 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3364 if (SvTYPE(arg) == SVt_PVGV) {
3365 IO * const io = GvIO((GV *)arg);
3370 tryrsfp = IoIFP(io);
3371 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3372 PerlIO_close(IoOFP(io));
3383 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3385 SvREFCNT_inc_simple_void_NN(filter_sub);
3388 filter_state = SP[i];
3389 SvREFCNT_inc_simple_void(filter_state);
3393 if (!tryrsfp && (filter_cache || filter_sub)) {
3394 tryrsfp = PerlIO_open(BIT_BUCKET,
3409 filter_has_file = 0;
3411 SvREFCNT_dec(filter_cache);
3412 filter_cache = NULL;
3415 SvREFCNT_dec(filter_state);
3416 filter_state = NULL;
3419 SvREFCNT_dec(filter_sub);
3424 if (!path_is_absolute(name)
3425 #ifdef MACOS_TRADITIONAL
3426 /* We consider paths of the form :a:b ambiguous and interpret them first
3427 as global then as local
3429 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3436 dir = SvPV_const(dirsv, dirlen);
3442 #ifdef MACOS_TRADITIONAL
3446 MacPerl_CanonDir(name, buf2, 1);
3447 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3451 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3453 sv_setpv(namesv, unixdir);
3454 sv_catpv(namesv, unixname);
3456 # ifdef __SYMBIAN32__
3457 if (PL_origfilename[0] &&
3458 PL_origfilename[1] == ':' &&
3459 !(dir[0] && dir[1] == ':'))
3460 Perl_sv_setpvf(aTHX_ namesv,
3465 Perl_sv_setpvf(aTHX_ namesv,
3469 /* The equivalent of
3470 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3471 but without the need to parse the format string, or
3472 call strlen on either pointer, and with the correct
3473 allocation up front. */
3475 char *tmp = SvGROW(namesv, dirlen + len + 2);
3477 memcpy(tmp, dir, dirlen);
3480 /* name came from an SV, so it will have a '\0' at the
3481 end that we can copy as part of this memcpy(). */
3482 memcpy(tmp, name, len + 1);
3484 SvCUR_set(namesv, dirlen + len + 1);
3486 /* Don't even actually have to turn SvPOK_on() as we
3487 access it directly with SvPVX() below. */
3492 TAINT_PROPER("require");
3493 tryname = SvPVX_const(namesv);
3494 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3496 if (tryname[0] == '.' && tryname[1] == '/')
3500 else if (errno == EMFILE)
3501 /* no point in trying other paths if out of handles */
3508 SAVECOPFILE_FREE(&PL_compiling);
3509 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3510 SvREFCNT_dec(namesv);
3512 if (PL_op->op_type == OP_REQUIRE) {
3513 const char *msgstr = name;
3514 if(errno == EMFILE) {
3516 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3518 msgstr = SvPV_nolen_const(msg);
3520 if (namesv) { /* did we lookup @INC? */
3521 AV * const ar = GvAVn(PL_incgv);
3523 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3524 "%s in @INC%s%s (@INC contains:",
3526 (instr(msgstr, ".h ")
3527 ? " (change .h to .ph maybe?)" : ""),
3528 (instr(msgstr, ".ph ")
3529 ? " (did you run h2ph?)" : "")
3532 for (i = 0; i <= AvFILL(ar); i++) {
3533 sv_catpvs(msg, " ");
3534 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3536 sv_catpvs(msg, ")");
3537 msgstr = SvPV_nolen_const(msg);
3540 DIE(aTHX_ "Can't locate %s", msgstr);
3546 SETERRNO(0, SS_NORMAL);
3548 /* Assume success here to prevent recursive requirement. */
3549 /* name is never assigned to again, so len is still strlen(name) */
3550 /* Check whether a hook in @INC has already filled %INC */
3552 (void)hv_store(GvHVn(PL_incgv),
3553 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3555 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3557 (void)hv_store(GvHVn(PL_incgv),
3558 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3563 lex_start(NULL, tryrsfp, TRUE);
3567 if (PL_compiling.cop_hints_hash) {
3568 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3569 PL_compiling.cop_hints_hash = NULL;
3572 SAVECOMPILEWARNINGS();
3573 if (PL_dowarn & G_WARN_ALL_ON)
3574 PL_compiling.cop_warnings = pWARN_ALL ;
3575 else if (PL_dowarn & G_WARN_ALL_OFF)
3576 PL_compiling.cop_warnings = pWARN_NONE ;
3578 PL_compiling.cop_warnings = pWARN_STD ;
3580 if (filter_sub || filter_cache) {
3581 SV * const datasv = filter_add(S_run_user_filter, NULL);
3582 IoLINES(datasv) = filter_has_file;
3583 IoTOP_GV(datasv) = (GV *)filter_state;
3584 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3585 IoFMT_GV(datasv) = (GV *)filter_cache;
3588 /* switch to eval mode */
3589 PUSHBLOCK(cx, CXt_EVAL, SP);
3591 cx->blk_eval.retop = PL_op->op_next;
3593 SAVECOPLINE(&PL_compiling);
3594 CopLINE_set(&PL_compiling, 0);
3598 /* Store and reset encoding. */
3599 encoding = PL_encoding;
3602 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3603 op = DOCATCH(PL_eval_start);
3605 op = PL_op->op_next;
3607 /* Restore encoding. */
3608 PL_encoding = encoding;
3613 /* This is a op added to hold the hints hash for
3614 pp_entereval. The hash can be modified by the code
3615 being eval'ed, so we return a copy instead. */
3621 mXPUSHs((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv));
3629 register PERL_CONTEXT *cx;
3631 const I32 gimme = GIMME_V;
3632 const I32 was = PL_sub_generation;
3633 char tbuf[TYPE_DIGITS(long) + 12];
3634 char *tmpbuf = tbuf;
3640 HV *saved_hh = NULL;
3641 const char * const fakestr = "_<(eval )";
3642 const int fakelen = 9 + 1;
3644 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3645 saved_hh = (HV*) SvREFCNT_inc(POPs);
3649 TAINT_IF(SvTAINTED(sv));
3650 TAINT_PROPER("eval");
3653 lex_start(sv, NULL, FALSE);
3656 /* switch to eval mode */
3658 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3659 SV * const temp_sv = sv_newmortal();
3660 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3661 (unsigned long)++PL_evalseq,
3662 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3663 tmpbuf = SvPVX(temp_sv);
3664 len = SvCUR(temp_sv);
3667 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3668 SAVECOPFILE_FREE(&PL_compiling);
3669 CopFILE_set(&PL_compiling, tmpbuf+2);
3670 SAVECOPLINE(&PL_compiling);
3671 CopLINE_set(&PL_compiling, 1);
3672 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3673 deleting the eval's FILEGV from the stash before gv_check() runs
3674 (i.e. before run-time proper). To work around the coredump that
3675 ensues, we always turn GvMULTI_on for any globals that were
3676 introduced within evals. See force_ident(). GSAR 96-10-12 */
3677 safestr = savepvn(tmpbuf, len);
3678 SAVEDELETE(PL_defstash, safestr, len);
3680 PL_hints = PL_op->op_targ;
3682 GvHV(PL_hintgv) = saved_hh;
3683 SAVECOMPILEWARNINGS();
3684 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3685 if (PL_compiling.cop_hints_hash) {
3686 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3688 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3689 if (PL_compiling.cop_hints_hash) {
3691 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3692 HINTS_REFCNT_UNLOCK;
3694 /* special case: an eval '' executed within the DB package gets lexically
3695 * placed in the first non-DB CV rather than the current CV - this
3696 * allows the debugger to execute code, find lexicals etc, in the
3697 * scope of the code being debugged. Passing &seq gets find_runcv
3698 * to do the dirty work for us */
3699 runcv = find_runcv(&seq);
3701 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3703 cx->blk_eval.retop = PL_op->op_next;
3705 /* prepare to compile string */
3707 if (PERLDB_LINE && PL_curstash != PL_debstash)
3708 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3710 ok = doeval(gimme, NULL, runcv, seq);
3711 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3713 /* Copy in anything fake and short. */
3714 my_strlcpy(safestr, fakestr, fakelen);
3716 return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3726 register PERL_CONTEXT *cx;
3728 const U8 save_flags = PL_op -> op_flags;
3733 retop = cx->blk_eval.retop;
3736 if (gimme == G_VOID)
3738 else if (gimme == G_SCALAR) {
3741 if (SvFLAGS(TOPs) & SVs_TEMP)
3744 *MARK = sv_mortalcopy(TOPs);
3748 *MARK = &PL_sv_undef;
3753 /* in case LEAVE wipes old return values */
3754 for (mark = newsp + 1; mark <= SP; mark++) {
3755 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3756 *mark = sv_mortalcopy(*mark);
3757 TAINT_NOT; /* Each item is independent */
3761 PL_curpm = newpm; /* Don't pop $1 et al till now */
3764 assert(CvDEPTH(PL_compcv) == 1);
3766 CvDEPTH(PL_compcv) = 0;
3769 if (optype == OP_REQUIRE &&
3770 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3772 /* Unassume the success we assumed earlier. */
3773 SV * const nsv = cx->blk_eval.old_namesv;
3774 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3775 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3776 /* die_where() did LEAVE, or we won't be here */
3780 if (!(save_flags & OPf_SPECIAL))
3781 sv_setpvn(ERRSV,"",0);
3787 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3788 close to the related Perl_create_eval_scope. */
3790 Perl_delete_eval_scope(pTHX)
3795 register PERL_CONTEXT *cx;
3802 PERL_UNUSED_VAR(newsp);
3803 PERL_UNUSED_VAR(gimme);
3804 PERL_UNUSED_VAR(optype);
3807 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3808 also needed by Perl_fold_constants. */
3810 Perl_create_eval_scope(pTHX_ U32 flags)
3813 const I32 gimme = GIMME_V;
3818 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3821 PL_in_eval = EVAL_INEVAL;
3822 if (flags & G_KEEPERR)
3823 PL_in_eval |= EVAL_KEEPERR;
3825 sv_setpvn(ERRSV,"",0);
3826 if (flags & G_FAKINGEVAL) {
3827 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3835 PERL_CONTEXT * const cx = create_eval_scope(0);
3836 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3837 return DOCATCH(PL_op->op_next);
3846 register PERL_CONTEXT *cx;
3851 PERL_UNUSED_VAR(optype);
3854 if (gimme == G_VOID)
3856 else if (gimme == G_SCALAR) {
3860 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3863 *MARK = sv_mortalcopy(TOPs);
3867 *MARK = &PL_sv_undef;
3872 /* in case LEAVE wipes old return values */
3874 for (mark = newsp + 1; mark <= SP; mark++) {
3875 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3876 *mark = sv_mortalcopy(*mark);
3877 TAINT_NOT; /* Each item is independent */
3881 PL_curpm = newpm; /* Don't pop $1 et al till now */
3884 sv_setpvn(ERRSV,"",0);
3891 register PERL_CONTEXT *cx;
3892 const I32 gimme = GIMME_V;
3897 if (PL_op->op_targ == 0) {
3898 SV ** const defsv_p = &GvSV(PL_defgv);
3899 *defsv_p = newSVsv(POPs);
3900 SAVECLEARSV(*defsv_p);
3903 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3905 PUSHBLOCK(cx, CXt_GIVEN, SP);
3914 register PERL_CONTEXT *cx;
3918 PERL_UNUSED_CONTEXT;
3921 assert(CxTYPE(cx) == CXt_GIVEN);
3926 PL_curpm = newpm; /* pop $1 et al */
3933 /* Helper routines used by pp_smartmatch */
3935 S_make_matcher(pTHX_ REGEXP *re)
3938 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3940 PERL_ARGS_ASSERT_MAKE_MATCHER;
3942 PM_SETRE(matcher, ReREFCNT_inc(re));
3944 SAVEFREEOP((OP *) matcher);
3951 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3956 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
3958 PL_op = (OP *) matcher;
3963 return (SvTRUEx(POPs));
3967 S_destroy_matcher(pTHX_ PMOP *matcher)
3971 PERL_ARGS_ASSERT_DESTROY_MATCHER;
3972 PERL_UNUSED_ARG(matcher);
3978 /* Do a smart match */
3981 return do_smartmatch(NULL, NULL);
3984 /* This version of do_smartmatch() implements the
3985 * table of smart matches that is found in perlsyn.
3988 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3993 SV *e = TOPs; /* e is for 'expression' */
3994 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3995 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3996 REGEXP *this_regex, *other_regex;
3998 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
4000 # define SM_REF(type) ( \
4001 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
4002 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
4004 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
4005 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
4006 && NOT_EMPTY_PROTO(This) && (Other = e)) \
4007 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
4008 && NOT_EMPTY_PROTO(This) && (Other = d)))
4010 # define SM_REGEX ( \
4011 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \
4012 && (this_regex = (REGEXP*) This) \
4015 (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \
4016 && (this_regex = (REGEXP*) This) \
4020 # define SM_OTHER_REF(type) \
4021 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
4023 # define SM_OTHER_REGEX (SvROK(Other) \
4024 && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \
4025 && (other_regex = (REGEXP*) SvRV(Other)))
4028 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
4029 sv_2mortal(newSViv(PTR2IV(sv))), 0)
4031 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
4032 sv_2mortal(newSViv(PTR2IV(sv))), 0)
4034 tryAMAGICbinSET(smart, 0);
4036 SP -= 2; /* Pop the values */
4038 /* Take care only to invoke mg_get() once for each argument.
4039 * Currently we do this by copying the SV if it's magical. */
4042 d = sv_mortalcopy(d);
4049 e = sv_mortalcopy(e);
4054 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
4056 if (This == SvRV(Other))
4067 c = call_sv(This, G_SCALAR);
4071 else if (SvTEMP(TOPs))
4072 SvREFCNT_inc_void(TOPs);
4077 else if (SM_REF(PVHV)) {
4078 if (SM_OTHER_REF(PVHV)) {
4079 /* Check that the key-sets are identical */
4081 HV *other_hv = (HV *) SvRV(Other);
4083 bool other_tied = FALSE;
4084 U32 this_key_count = 0,
4085 other_key_count = 0;
4087 /* Tied hashes don't know how many keys they have. */
4088 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
4091 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
4092 HV * const temp = other_hv;
4093 other_hv = (HV *) This;
4097 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
4100 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
4103 /* The hashes have the same number of keys, so it suffices
4104 to check that one is a subset of the other. */
4105 (void) hv_iterinit((HV *) This);
4106 while ( (he = hv_iternext((HV *) This)) ) {
4108 char * const key = hv_iterkey(he, &key_len);
4112 if(!hv_exists(other_hv, key, key_len)) {
4113 (void) hv_iterinit((HV *) This); /* reset iterator */
4119 (void) hv_iterinit(other_hv);
4120 while ( hv_iternext(other_hv) )
4124 other_key_count = HvUSEDKEYS(other_hv);
4126 if (this_key_count != other_key_count)
4131 else if (SM_OTHER_REF(PVAV)) {
4132 AV * const other_av = (AV *) SvRV(Other);
4133 const I32 other_len = av_len(other_av) + 1;
4136 for (i = 0; i < other_len; ++i) {
4137 SV ** const svp = av_fetch(other_av, i, FALSE);
4141 if (svp) { /* ??? When can this not happen? */
4142 key = SvPV(*svp, key_len);
4143 if (hv_exists((HV *) This, key, key_len))
4149 else if (SM_OTHER_REGEX) {
4150 PMOP * const matcher = make_matcher(other_regex);
4153 (void) hv_iterinit((HV *) This);
4154 while ( (he = hv_iternext((HV *) This)) ) {
4155 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4156 (void) hv_iterinit((HV *) This);
4157 destroy_matcher(matcher);
4161 destroy_matcher(matcher);
4165 if (hv_exists_ent((HV *) This, Other, 0))
4171 else if (SM_REF(PVAV)) {
4172 if (SM_OTHER_REF(PVAV)) {
4173 AV *other_av = (AV *) SvRV(Other);
4174 if (av_len((AV *) This) != av_len(other_av))
4178 const I32 other_len = av_len(other_av);
4180 if (NULL == seen_this) {
4181 seen_this = newHV();
4182 (void) sv_2mortal((SV *) seen_this);
4184 if (NULL == seen_other) {
4185 seen_this = newHV();
4186 (void) sv_2mortal((SV *) seen_other);
4188 for(i = 0; i <= other_len; ++i) {
4189 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4190 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4192 if (!this_elem || !other_elem) {
4193 if (this_elem || other_elem)
4196 else if (SM_SEEN_THIS(*this_elem)
4197 || SM_SEEN_OTHER(*other_elem))
4199 if (*this_elem != *other_elem)
4203 (void)hv_store_ent(seen_this,
4204 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4206 (void)hv_store_ent(seen_other,
4207 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4213 (void) do_smartmatch(seen_this, seen_other);
4223 else if (SM_OTHER_REGEX) {
4224 PMOP * const matcher = make_matcher(other_regex);
4225 const I32 this_len = av_len((AV *) This);
4228 for(i = 0; i <= this_len; ++i) {
4229 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4230 if (svp && matcher_matches_sv(matcher, *svp)) {
4231 destroy_matcher(matcher);
4235 destroy_matcher(matcher);
4238 else if (SvIOK(Other) || SvNOK(Other)) {
4241 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4242 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4249 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4259 else if (SvPOK(Other)) {
4260 const I32 this_len = av_len((AV *) This);
4263 for(i = 0; i <= this_len; ++i) {
4264 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4279 else if (!SvOK(d) || !SvOK(e)) {
4280 if (!SvOK(d) && !SvOK(e))
4285 else if (SM_REGEX) {
4286 PMOP * const matcher = make_matcher(this_regex);
4289 PUSHs(matcher_matches_sv(matcher, Other)
4292 destroy_matcher(matcher);
4295 else if (SM_REF(PVCV)) {
4297 /* This must be a null-prototyped sub, because we
4298 already checked for the other kind. */
4304 c = call_sv(This, G_SCALAR);
4307 PUSHs(&PL_sv_undef);
4308 else if (SvTEMP(TOPs))
4309 SvREFCNT_inc_void(TOPs);
4311 if (SM_OTHER_REF(PVCV)) {
4312 /* This one has to be null-proto'd too.
4313 Call both of 'em, and compare the results */
4315 c = call_sv(SvRV(Other), G_SCALAR);
4318 PUSHs(&PL_sv_undef);
4319 else if (SvTEMP(TOPs))
4320 SvREFCNT_inc_void(TOPs);
4331 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4332 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4334 if (SvPOK(Other) && !looks_like_number(Other)) {
4335 /* String comparison */
4340 /* Otherwise, numeric comparison */
4343 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4354 /* As a last resort, use string comparison */
4363 register PERL_CONTEXT *cx;
4364 const I32 gimme = GIMME_V;
4366 /* This is essentially an optimization: if the match
4367 fails, we don't want to push a context and then
4368 pop it again right away, so we skip straight
4369 to the op that follows the leavewhen.
4371 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4372 return cLOGOP->op_other->op_next;
4377 PUSHBLOCK(cx, CXt_WHEN, SP);
4386 register PERL_CONTEXT *cx;
4392 assert(CxTYPE(cx) == CXt_WHEN);
4397 PL_curpm = newpm; /* pop $1 et al */
4407 register PERL_CONTEXT *cx;
4410 cxix = dopoptowhen(cxstack_ix);
4412 DIE(aTHX_ "Can't \"continue\" outside a when block");
4413 if (cxix < cxstack_ix)
4416 /* clear off anything above the scope we're re-entering */
4417 inner = PL_scopestack_ix;
4419 if (PL_scopestack_ix < inner)
4420 leave_scope(PL_scopestack[PL_scopestack_ix]);
4421 PL_curcop = cx->blk_oldcop;
4422 return cx->blk_givwhen.leave_op;
4429 register PERL_CONTEXT *cx;
4432 cxix = dopoptogiven(cxstack_ix);
4434 if (PL_op->op_flags & OPf_SPECIAL)
4435 DIE(aTHX_ "Can't use when() outside a topicalizer");
4437 DIE(aTHX_ "Can't \"break\" outside a given block");
4439 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4440 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4442 if (cxix < cxstack_ix)
4445 /* clear off anything above the scope we're re-entering */
4446 inner = PL_scopestack_ix;
4448 if (PL_scopestack_ix < inner)
4449 leave_scope(PL_scopestack[PL_scopestack_ix]);
4450 PL_curcop = cx->blk_oldcop;
4453 return CX_LOOP_NEXTOP_GET(cx);
4455 return cx->blk_givwhen.leave_op;
4459 S_doparseform(pTHX_ SV *sv)
4462 register char *s = SvPV_force(sv, len);
4463 register char * const send = s + len;
4464 register char *base = NULL;
4465 register I32 skipspaces = 0;
4466 bool noblank = FALSE;
4467 bool repeat = FALSE;
4468 bool postspace = FALSE;
4474 bool unchopnum = FALSE;
4475 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4477 PERL_ARGS_ASSERT_DOPARSEFORM;
4480 Perl_croak(aTHX_ "Null picture in formline");
4482 /* estimate the buffer size needed */
4483 for (base = s; s <= send; s++) {
4484 if (*s == '\n' || *s == '@' || *s == '^')
4490 Newx(fops, maxops, U32);
4495 *fpc++ = FF_LINEMARK;
4496 noblank = repeat = FALSE;
4514 case ' ': case '\t':
4521 } /* else FALL THROUGH */
4529 *fpc++ = FF_LITERAL;
4537 *fpc++ = (U16)skipspaces;
4541 *fpc++ = FF_NEWLINE;
4545 arg = fpc - linepc + 1;
4552 *fpc++ = FF_LINEMARK;
4553 noblank = repeat = FALSE;
4562 ischop = s[-1] == '^';
4568 arg = (s - base) - 1;
4570 *fpc++ = FF_LITERAL;
4578 *fpc++ = 2; /* skip the @* or ^* */
4580 *fpc++ = FF_LINESNGL;
4583 *fpc++ = FF_LINEGLOB;
4585 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4586 arg = ischop ? 512 : 0;
4591 const char * const f = ++s;
4594 arg |= 256 + (s - f);
4596 *fpc++ = s - base; /* fieldsize for FETCH */
4597 *fpc++ = FF_DECIMAL;
4599 unchopnum |= ! ischop;
4601 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4602 arg = ischop ? 512 : 0;
4604 s++; /* skip the '0' first */
4608 const char * const f = ++s;
4611 arg |= 256 + (s - f);
4613 *fpc++ = s - base; /* fieldsize for FETCH */
4614 *fpc++ = FF_0DECIMAL;
4616 unchopnum |= ! ischop;
4620 bool ismore = FALSE;
4623 while (*++s == '>') ;
4624 prespace = FF_SPACE;
4626 else if (*s == '|') {
4627 while (*++s == '|') ;
4628 prespace = FF_HALFSPACE;
4633 while (*++s == '<') ;
4636 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4640 *fpc++ = s - base; /* fieldsize for FETCH */
4642 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4645 *fpc++ = (U16)prespace;
4659 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4661 { /* need to jump to the next word */
4663 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4664 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4665 s = SvPVX(sv) + SvCUR(sv) + z;
4667 Copy(fops, s, arg, U32);
4669 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4672 if (unchopnum && repeat)
4673 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4679 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4681 /* Can value be printed in fldsize chars, using %*.*f ? */
4685 int intsize = fldsize - (value < 0 ? 1 : 0);
4692 while (intsize--) pwr *= 10.0;
4693 while (frcsize--) eps /= 10.0;
4696 if (value + eps >= pwr)
4699 if (value - eps <= -pwr)
4706 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4709 SV * const datasv = FILTER_DATA(idx);
4710 const int filter_has_file = IoLINES(datasv);
4711 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4712 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4716 const char *got_p = NULL;
4717 const char *prune_from = NULL;
4718 bool read_from_cache = FALSE;
4721 PERL_ARGS_ASSERT_RUN_USER_FILTER;
4723 assert(maxlen >= 0);
4726 /* I was having segfault trouble under Linux 2.2.5 after a
4727 parse error occured. (Had to hack around it with a test
4728 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4729 not sure where the trouble is yet. XXX */
4731 if (IoFMT_GV(datasv)) {
4732 SV *const cache = (SV *)IoFMT_GV(datasv);
4735 const char *cache_p = SvPV(cache, cache_len);
4739 /* Running in block mode and we have some cached data already.
4741 if (cache_len >= umaxlen) {
4742 /* In fact, so much data we don't even need to call
4747 const char *const first_nl =
4748 (const char *)memchr(cache_p, '\n', cache_len);
4750 take = first_nl + 1 - cache_p;
4754 sv_catpvn(buf_sv, cache_p, take);
4755 sv_chop(cache, cache_p + take);
4756 /* Definately not EOF */
4760 sv_catsv(buf_sv, cache);
4762 umaxlen -= cache_len;
4765 read_from_cache = TRUE;
4769 /* Filter API says that the filter appends to the contents of the buffer.
4770 Usually the buffer is "", so the details don't matter. But if it's not,
4771 then clearly what it contains is already filtered by this filter, so we
4772 don't want to pass it in a second time.
4773 I'm going to use a mortal in case the upstream filter croaks. */
4774 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4775 ? sv_newmortal() : buf_sv;
4776 SvUPGRADE(upstream, SVt_PV);
4778 if (filter_has_file) {
4779 status = FILTER_READ(idx+1, upstream, 0);
4782 if (filter_sub && status >= 0) {
4795 PUSHs(filter_state);
4798 count = call_sv(filter_sub, G_SCALAR);
4813 if(SvOK(upstream)) {
4814 got_p = SvPV(upstream, got_len);
4816 if (got_len > umaxlen) {
4817 prune_from = got_p + umaxlen;
4820 const char *const first_nl =
4821 (const char *)memchr(got_p, '\n', got_len);
4822 if (first_nl && first_nl + 1 < got_p + got_len) {
4823 /* There's a second line here... */
4824 prune_from = first_nl + 1;
4829 /* Oh. Too long. Stuff some in our cache. */
4830 STRLEN cached_len = got_p + got_len - prune_from;
4831 SV *cache = (SV *)IoFMT_GV(datasv);
4834 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4835 } else if (SvOK(cache)) {
4836 /* Cache should be empty. */
4837 assert(!SvCUR(cache));
4840 sv_setpvn(cache, prune_from, cached_len);
4841 /* If you ask for block mode, you may well split UTF-8 characters.
4842 "If it breaks, you get to keep both parts"
4843 (Your code is broken if you don't put them back together again
4844 before something notices.) */
4845 if (SvUTF8(upstream)) {
4848 SvCUR_set(upstream, got_len - cached_len);
4849 /* Can't yet be EOF */
4854 /* If they are at EOF but buf_sv has something in it, then they may never
4855 have touched the SV upstream, so it may be undefined. If we naively
4856 concatenate it then we get a warning about use of uninitialised value.
4858 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4859 sv_catsv(buf_sv, upstream);
4863 IoLINES(datasv) = 0;
4864 SvREFCNT_dec(IoFMT_GV(datasv));
4866 SvREFCNT_dec(filter_state);
4867 IoTOP_GV(datasv) = NULL;
4870 SvREFCNT_dec(filter_sub);
4871 IoBOTTOM_GV(datasv) = NULL;
4873 filter_del(S_run_user_filter);
4875 if (status == 0 && read_from_cache) {
4876 /* If we read some data from the cache (and by getting here it implies
4877 that we emptied the cache) then we aren't yet at EOF, and mustn't
4878 report that to our caller. */
4884 /* perhaps someone can come up with a better name for
4885 this? it is not really "absolute", per se ... */
4887 S_path_is_absolute(const char *name)
4889 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
4891 if (PERL_FILE_IS_ABSOLUTE(name)
4892 #ifdef MACOS_TRADITIONAL
4895 || (*name == '.' && (name[1] == '/' ||
4896 (name[1] == '.' && name[2] == '/')))
4908 * c-indentation-style: bsd
4910 * indent-tabs-mode: t
4913 * ex: set ts=8 sts=4 sw=4 noet: