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;
301 SvUPGRADE(sv, SVt_PVMG);
302 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
303 #ifdef PERL_OLD_COPY_ON_WRITE
305 sv_force_normal_flags(sv, 0);
307 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
310 mg->mg_len = m - orig;
313 (void)ReREFCNT_inc(rx);
314 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
315 rxres_save(&cx->sb_rxres, rx);
316 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
320 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
325 PERL_ARGS_ASSERT_RXRES_SAVE;
328 if (!p || p[1] < RX_NPARENS(rx)) {
329 #ifdef PERL_OLD_COPY_ON_WRITE
330 i = 7 + RX_NPARENS(rx) * 2;
332 i = 6 + RX_NPARENS(rx) * 2;
341 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
342 RX_MATCH_COPIED_off(rx);
344 #ifdef PERL_OLD_COPY_ON_WRITE
345 *p++ = PTR2UV(RX_SAVED_COPY(rx));
346 RX_SAVED_COPY(rx) = NULL;
349 *p++ = RX_NPARENS(rx);
351 *p++ = PTR2UV(RX_SUBBEG(rx));
352 *p++ = (UV)RX_SUBLEN(rx);
353 for (i = 0; i <= RX_NPARENS(rx); ++i) {
354 *p++ = (UV)RX_OFFS(rx)[i].start;
355 *p++ = (UV)RX_OFFS(rx)[i].end;
360 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
365 PERL_ARGS_ASSERT_RXRES_RESTORE;
368 RX_MATCH_COPY_FREE(rx);
369 RX_MATCH_COPIED_set(rx, *p);
372 #ifdef PERL_OLD_COPY_ON_WRITE
373 if (RX_SAVED_COPY(rx))
374 SvREFCNT_dec (RX_SAVED_COPY(rx));
375 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
379 RX_NPARENS(rx) = *p++;
381 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
382 RX_SUBLEN(rx) = (I32)(*p++);
383 for (i = 0; i <= RX_NPARENS(rx); ++i) {
384 RX_OFFS(rx)[i].start = (I32)(*p++);
385 RX_OFFS(rx)[i].end = (I32)(*p++);
390 Perl_rxres_free(pTHX_ void **rsp)
392 UV * const p = (UV*)*rsp;
394 PERL_ARGS_ASSERT_RXRES_FREE;
399 void *tmp = INT2PTR(char*,*p);
402 PoisonFree(*p, 1, sizeof(*p));
404 Safefree(INT2PTR(char*,*p));
406 #ifdef PERL_OLD_COPY_ON_WRITE
408 SvREFCNT_dec (INT2PTR(SV*,p[1]));
418 dVAR; dSP; dMARK; dORIGMARK;
419 register SV * const tmpForm = *++MARK;
424 register SV *sv = NULL;
425 const char *item = NULL;
429 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
430 const char *chophere = NULL;
431 char *linemark = NULL;
433 bool gotsome = FALSE;
435 const STRLEN fudge = SvPOK(tmpForm)
436 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
437 bool item_is_utf8 = FALSE;
438 bool targ_is_utf8 = FALSE;
440 OP * parseres = NULL;
444 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
445 if (SvREADONLY(tmpForm)) {
446 SvREADONLY_off(tmpForm);
447 parseres = doparseform(tmpForm);
448 SvREADONLY_on(tmpForm);
451 parseres = doparseform(tmpForm);
455 SvPV_force(PL_formtarget, len);
456 if (DO_UTF8(PL_formtarget))
458 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
460 f = SvPV_const(tmpForm, len);
461 /* need to jump to the next word */
462 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
466 const char *name = "???";
469 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
470 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
471 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
472 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
473 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
475 case FF_CHECKNL: name = "CHECKNL"; break;
476 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
477 case FF_SPACE: name = "SPACE"; break;
478 case FF_HALFSPACE: name = "HALFSPACE"; break;
479 case FF_ITEM: name = "ITEM"; break;
480 case FF_CHOP: name = "CHOP"; break;
481 case FF_LINEGLOB: name = "LINEGLOB"; break;
482 case FF_NEWLINE: name = "NEWLINE"; break;
483 case FF_MORE: name = "MORE"; break;
484 case FF_LINEMARK: name = "LINEMARK"; break;
485 case FF_END: name = "END"; break;
486 case FF_0DECIMAL: name = "0DECIMAL"; break;
487 case FF_LINESNGL: name = "LINESNGL"; break;
490 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
492 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
503 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
504 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
506 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
507 t = SvEND(PL_formtarget);
510 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
511 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
513 sv_utf8_upgrade(PL_formtarget);
514 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
515 t = SvEND(PL_formtarget);
535 if (ckWARN(WARN_SYNTAX))
536 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
543 const char *s = item = SvPV_const(sv, len);
546 itemsize = sv_len_utf8(sv);
547 if (itemsize != (I32)len) {
549 if (itemsize > fieldsize) {
550 itemsize = fieldsize;
551 itembytes = itemsize;
552 sv_pos_u2b(sv, &itembytes, 0);
556 send = chophere = s + itembytes;
566 sv_pos_b2u(sv, &itemsize);
570 item_is_utf8 = FALSE;
571 if (itemsize > fieldsize)
572 itemsize = fieldsize;
573 send = chophere = s + itemsize;
587 const char *s = item = SvPV_const(sv, len);
590 itemsize = sv_len_utf8(sv);
591 if (itemsize != (I32)len) {
593 if (itemsize <= fieldsize) {
594 const char *send = chophere = s + itemsize;
607 itemsize = fieldsize;
608 itembytes = itemsize;
609 sv_pos_u2b(sv, &itembytes, 0);
610 send = chophere = s + itembytes;
611 while (s < send || (s == send && isSPACE(*s))) {
621 if (strchr(PL_chopset, *s))
626 itemsize = chophere - item;
627 sv_pos_b2u(sv, &itemsize);
633 item_is_utf8 = FALSE;
634 if (itemsize <= fieldsize) {
635 const char *const send = chophere = s + itemsize;
648 itemsize = fieldsize;
649 send = chophere = s + itemsize;
650 while (s < send || (s == send && isSPACE(*s))) {
660 if (strchr(PL_chopset, *s))
665 itemsize = chophere - item;
671 arg = fieldsize - itemsize;
680 arg = fieldsize - itemsize;
691 const char *s = item;
695 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
697 sv_utf8_upgrade(PL_formtarget);
698 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
699 t = SvEND(PL_formtarget);
703 if (UTF8_IS_CONTINUED(*s)) {
704 STRLEN skip = UTF8SKIP(s);
721 if ( !((*t++ = *s++) & ~31) )
727 if (targ_is_utf8 && !item_is_utf8) {
728 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
730 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
731 for (; t < SvEND(PL_formtarget); t++) {
744 const int ch = *t++ = *s++;
747 if ( !((*t++ = *s++) & ~31) )
756 const char *s = chophere;
774 const char *s = item = SvPV_const(sv, len);
776 if ((item_is_utf8 = DO_UTF8(sv)))
777 itemsize = sv_len_utf8(sv);
779 bool chopped = FALSE;
780 const char *const send = s + len;
782 chophere = s + itemsize;
798 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
800 SvUTF8_on(PL_formtarget);
802 SvCUR_set(sv, chophere - item);
803 sv_catsv(PL_formtarget, sv);
804 SvCUR_set(sv, itemsize);
806 sv_catsv(PL_formtarget, sv);
808 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
809 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
810 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
819 #if defined(USE_LONG_DOUBLE)
822 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
826 "%#0*.*f" : "%0*.*f");
831 #if defined(USE_LONG_DOUBLE)
833 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
836 ((arg & 256) ? "%#*.*f" : "%*.*f");
839 /* If the field is marked with ^ and the value is undefined,
841 if ((arg & 512) && !SvOK(sv)) {
849 /* overflow evidence */
850 if (num_overflow(value, fieldsize, arg)) {
856 /* Formats aren't yet marked for locales, so assume "yes". */
858 STORE_NUMERIC_STANDARD_SET_LOCAL();
859 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
860 RESTORE_NUMERIC_STANDARD();
867 while (t-- > linemark && *t == ' ') ;
875 if (arg) { /* repeat until fields exhausted? */
877 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
878 lines += FmLINES(PL_formtarget);
881 if (strnEQ(linemark, linemark - arg, arg))
882 DIE(aTHX_ "Runaway format");
885 SvUTF8_on(PL_formtarget);
886 FmLINES(PL_formtarget) = lines;
888 RETURNOP(cLISTOP->op_first);
899 const char *s = chophere;
900 const char *send = item + len;
902 while (isSPACE(*s) && (s < send))
907 arg = fieldsize - itemsize;
914 if (strnEQ(s1," ",3)) {
915 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
926 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
928 SvUTF8_on(PL_formtarget);
929 FmLINES(PL_formtarget) += lines;
941 if (PL_stack_base + *PL_markstack_ptr == SP) {
943 if (GIMME_V == G_SCALAR)
945 RETURNOP(PL_op->op_next->op_next);
947 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
948 pp_pushmark(); /* push dst */
949 pp_pushmark(); /* push src */
950 ENTER; /* enter outer scope */
953 if (PL_op->op_private & OPpGREP_LEX)
954 SAVESPTR(PAD_SVl(PL_op->op_targ));
957 ENTER; /* enter inner scope */
960 src = PL_stack_base[*PL_markstack_ptr];
962 if (PL_op->op_private & OPpGREP_LEX)
963 PAD_SVl(PL_op->op_targ) = src;
968 if (PL_op->op_type == OP_MAPSTART)
969 pp_pushmark(); /* push top */
970 return ((LOGOP*)PL_op->op_next)->op_other;
976 const I32 gimme = GIMME_V;
977 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
983 /* first, move source pointer to the next item in the source list */
984 ++PL_markstack_ptr[-1];
986 /* if there are new items, push them into the destination list */
987 if (items && gimme != G_VOID) {
988 /* might need to make room back there first */
989 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
990 /* XXX this implementation is very pessimal because the stack
991 * is repeatedly extended for every set of items. Is possible
992 * to do this without any stack extension or copying at all
993 * by maintaining a separate list over which the map iterates
994 * (like foreach does). --gsar */
996 /* everything in the stack after the destination list moves
997 * towards the end the stack by the amount of room needed */
998 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1000 /* items to shift up (accounting for the moved source pointer) */
1001 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1003 /* This optimization is by Ben Tilly and it does
1004 * things differently from what Sarathy (gsar)
1005 * is describing. The downside of this optimization is
1006 * that leaves "holes" (uninitialized and hopefully unused areas)
1007 * to the Perl stack, but on the other hand this
1008 * shouldn't be a problem. If Sarathy's idea gets
1009 * implemented, this optimization should become
1010 * irrelevant. --jhi */
1012 shift = count; /* Avoid shifting too often --Ben Tilly */
1016 dst = (SP += shift);
1017 PL_markstack_ptr[-1] += shift;
1018 *PL_markstack_ptr += shift;
1022 /* copy the new items down to the destination list */
1023 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1024 if (gimme == G_ARRAY) {
1026 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1029 /* scalar context: we don't care about which values map returns
1030 * (we use undef here). And so we certainly don't want to do mortal
1031 * copies of meaningless values. */
1032 while (items-- > 0) {
1034 *dst-- = &PL_sv_undef;
1038 LEAVE; /* exit inner scope */
1041 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1043 (void)POPMARK; /* pop top */
1044 LEAVE; /* exit outer scope */
1045 (void)POPMARK; /* pop src */
1046 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1047 (void)POPMARK; /* pop dst */
1048 SP = PL_stack_base + POPMARK; /* pop original mark */
1049 if (gimme == G_SCALAR) {
1050 if (PL_op->op_private & OPpGREP_LEX) {
1051 SV* sv = sv_newmortal();
1052 sv_setiv(sv, items);
1060 else if (gimme == G_ARRAY)
1067 ENTER; /* enter inner scope */
1070 /* set $_ to the new source item */
1071 src = PL_stack_base[PL_markstack_ptr[-1]];
1073 if (PL_op->op_private & OPpGREP_LEX)
1074 PAD_SVl(PL_op->op_targ) = src;
1078 RETURNOP(cLOGOP->op_other);
1087 if (GIMME == G_ARRAY)
1089 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1090 return cLOGOP->op_other;
1100 if (GIMME == G_ARRAY) {
1101 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1105 SV * const targ = PAD_SV(PL_op->op_targ);
1108 if (PL_op->op_private & OPpFLIP_LINENUM) {
1109 if (GvIO(PL_last_in_gv)) {
1110 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1113 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1115 flip = SvIV(sv) == SvIV(GvSV(gv));
1121 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1122 if (PL_op->op_flags & OPf_SPECIAL) {
1130 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1133 sv_setpvn(TARG, "", 0);
1139 /* This code tries to decide if "$left .. $right" should use the
1140 magical string increment, or if the range is numeric (we make
1141 an exception for .."0" [#18165]). AMS 20021031. */
1143 #define RANGE_IS_NUMERIC(left,right) ( \
1144 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1145 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1146 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1147 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1148 && (!SvOK(right) || looks_like_number(right))))
1154 if (GIMME == G_ARRAY) {
1160 if (RANGE_IS_NUMERIC(left,right)) {
1163 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1164 (SvOK(right) && SvNV(right) > IV_MAX))
1165 DIE(aTHX_ "Range iterator outside integer range");
1176 SV * const sv = sv_2mortal(newSViv(i++));
1181 SV * const final = sv_mortalcopy(right);
1183 const char * const tmps = SvPV_const(final, len);
1185 SV *sv = sv_mortalcopy(left);
1186 SvPV_force_nolen(sv);
1187 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1189 if (strEQ(SvPVX_const(sv),tmps))
1191 sv = sv_2mortal(newSVsv(sv));
1198 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1202 if (PL_op->op_private & OPpFLIP_LINENUM) {
1203 if (GvIO(PL_last_in_gv)) {
1204 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1207 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1208 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1216 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1217 sv_catpvs(targ, "E0");
1227 static const char * const context_name[] = {
1230 NULL, /* CXt_BLOCK never actually needs "block" */
1232 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1233 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1234 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1235 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1243 S_dopoptolabel(pTHX_ const char *label)
1248 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1250 for (i = cxstack_ix; i >= 0; i--) {
1251 register const PERL_CONTEXT * const cx = &cxstack[i];
1252 switch (CxTYPE(cx)) {
1260 if (ckWARN(WARN_EXITING))
1261 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1262 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1263 if (CxTYPE(cx) == CXt_NULL)
1266 case CXt_LOOP_LAZYIV:
1267 case CXt_LOOP_LAZYSV:
1269 case CXt_LOOP_PLAIN:
1270 if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
1271 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1272 (long)i, CxLABEL(cx)));
1275 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1285 Perl_dowantarray(pTHX)
1288 const I32 gimme = block_gimme();
1289 return (gimme == G_VOID) ? G_SCALAR : gimme;
1293 Perl_block_gimme(pTHX)
1296 const I32 cxix = dopoptosub(cxstack_ix);
1300 switch (cxstack[cxix].blk_gimme) {
1308 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1315 Perl_is_lvalue_sub(pTHX)
1318 const I32 cxix = dopoptosub(cxstack_ix);
1319 assert(cxix >= 0); /* We should only be called from inside subs */
1321 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1322 return CxLVAL(cxstack + cxix);
1328 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1333 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1335 for (i = startingblock; i >= 0; i--) {
1336 register const PERL_CONTEXT * const cx = &cxstk[i];
1337 switch (CxTYPE(cx)) {
1343 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1351 S_dopoptoeval(pTHX_ I32 startingblock)
1355 for (i = startingblock; i >= 0; i--) {
1356 register const PERL_CONTEXT *cx = &cxstack[i];
1357 switch (CxTYPE(cx)) {
1361 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1369 S_dopoptoloop(pTHX_ I32 startingblock)
1373 for (i = startingblock; i >= 0; i--) {
1374 register const PERL_CONTEXT * const cx = &cxstack[i];
1375 switch (CxTYPE(cx)) {
1381 if (ckWARN(WARN_EXITING))
1382 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1383 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1384 if ((CxTYPE(cx)) == CXt_NULL)
1387 case CXt_LOOP_LAZYIV:
1388 case CXt_LOOP_LAZYSV:
1390 case CXt_LOOP_PLAIN:
1391 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1399 S_dopoptogiven(pTHX_ I32 startingblock)
1403 for (i = startingblock; i >= 0; i--) {
1404 register const PERL_CONTEXT *cx = &cxstack[i];
1405 switch (CxTYPE(cx)) {
1409 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1411 case CXt_LOOP_PLAIN:
1412 assert(!CxFOREACHDEF(cx));
1414 case CXt_LOOP_LAZYIV:
1415 case CXt_LOOP_LAZYSV:
1417 if (CxFOREACHDEF(cx)) {
1418 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1427 S_dopoptowhen(pTHX_ I32 startingblock)
1431 for (i = startingblock; i >= 0; i--) {
1432 register const PERL_CONTEXT *cx = &cxstack[i];
1433 switch (CxTYPE(cx)) {
1437 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1445 Perl_dounwind(pTHX_ I32 cxix)
1450 while (cxstack_ix > cxix) {
1452 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1453 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1454 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1455 /* Note: we don't need to restore the base context info till the end. */
1456 switch (CxTYPE(cx)) {
1459 continue; /* not break */
1467 case CXt_LOOP_LAZYIV:
1468 case CXt_LOOP_LAZYSV:
1470 case CXt_LOOP_PLAIN:
1481 PERL_UNUSED_VAR(optype);
1485 Perl_qerror(pTHX_ SV *err)
1489 PERL_ARGS_ASSERT_QERROR;
1492 sv_catsv(ERRSV, err);
1494 sv_catsv(PL_errors, err);
1496 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1498 ++PL_parser->error_count;
1502 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1511 if (PL_in_eval & EVAL_KEEPERR) {
1512 static const char prefix[] = "\t(in cleanup) ";
1513 SV * const err = ERRSV;
1514 const char *e = NULL;
1516 sv_setpvn(err,"",0);
1517 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1519 e = SvPV_const(err, len);
1521 if (*e != *message || strNE(e,message))
1525 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1526 sv_catpvn(err, prefix, sizeof(prefix)-1);
1527 sv_catpvn(err, message, msglen);
1528 if (ckWARN(WARN_MISC)) {
1529 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1530 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1535 sv_setpvn(ERRSV, message, msglen);
1539 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1540 && PL_curstackinfo->si_prev)
1548 register PERL_CONTEXT *cx;
1551 if (cxix < cxstack_ix)
1554 POPBLOCK(cx,PL_curpm);
1555 if (CxTYPE(cx) != CXt_EVAL) {
1557 message = SvPVx_const(ERRSV, msglen);
1558 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1559 PerlIO_write(Perl_error_log, message, msglen);
1564 if (gimme == G_SCALAR)
1565 *++newsp = &PL_sv_undef;
1566 PL_stack_sp = newsp;
1570 /* LEAVE could clobber PL_curcop (see save_re_context())
1571 * XXX it might be better to find a way to avoid messing with
1572 * PL_curcop in save_re_context() instead, but this is a more
1573 * minimal fix --GSAR */
1574 PL_curcop = cx->blk_oldcop;
1576 if (optype == OP_REQUIRE) {
1577 const char* const msg = SvPVx_nolen_const(ERRSV);
1578 SV * const nsv = cx->blk_eval.old_namesv;
1579 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1581 DIE(aTHX_ "%sCompilation failed in require",
1582 *msg ? msg : "Unknown error\n");
1584 assert(CxTYPE(cx) == CXt_EVAL);
1585 return cx->blk_eval.retop;
1589 message = SvPVx_const(ERRSV, msglen);
1591 write_to_stderr(message, msglen);
1599 dVAR; dSP; dPOPTOPssrl;
1600 if (SvTRUE(left) != SvTRUE(right))
1610 register I32 cxix = dopoptosub(cxstack_ix);
1611 register const PERL_CONTEXT *cx;
1612 register const PERL_CONTEXT *ccstack = cxstack;
1613 const PERL_SI *top_si = PL_curstackinfo;
1615 const char *stashname;
1622 /* we may be in a higher stacklevel, so dig down deeper */
1623 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1624 top_si = top_si->si_prev;
1625 ccstack = top_si->si_cxstack;
1626 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1629 if (GIMME != G_ARRAY) {
1635 /* caller() should not report the automatic calls to &DB::sub */
1636 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1637 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1641 cxix = dopoptosub_at(ccstack, cxix - 1);
1644 cx = &ccstack[cxix];
1645 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1646 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1647 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1648 field below is defined for any cx. */
1649 /* caller() should not report the automatic calls to &DB::sub */
1650 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1651 cx = &ccstack[dbcxix];
1654 stashname = CopSTASHPV(cx->blk_oldcop);
1655 if (GIMME != G_ARRAY) {
1658 PUSHs(&PL_sv_undef);
1661 sv_setpv(TARG, stashname);
1670 PUSHs(&PL_sv_undef);
1672 mPUSHs(newSVpv(stashname, 0));
1673 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1674 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1677 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1678 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1679 /* So is ccstack[dbcxix]. */
1681 SV * const sv = newSV(0);
1682 gv_efullname3(sv, cvgv, NULL);
1684 PUSHs(boolSV(CxHASARGS(cx)));
1687 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1688 PUSHs(boolSV(CxHASARGS(cx)));
1692 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1695 gimme = (I32)cx->blk_gimme;
1696 if (gimme == G_VOID)
1697 PUSHs(&PL_sv_undef);
1699 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1700 if (CxTYPE(cx) == CXt_EVAL) {
1702 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1703 PUSHs(cx->blk_eval.cur_text);
1707 else if (cx->blk_eval.old_namesv) {
1708 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1711 /* eval BLOCK (try blocks have old_namesv == 0) */
1713 PUSHs(&PL_sv_undef);
1714 PUSHs(&PL_sv_undef);
1718 PUSHs(&PL_sv_undef);
1719 PUSHs(&PL_sv_undef);
1721 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1722 && CopSTASH_eq(PL_curcop, PL_debstash))
1724 AV * const ary = cx->blk_sub.argarray;
1725 const int off = AvARRAY(ary) - AvALLOC(ary);
1728 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1729 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1731 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1734 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1735 av_extend(PL_dbargs, AvFILLp(ary) + off);
1736 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1737 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1739 /* XXX only hints propagated via op_private are currently
1740 * visible (others are not easily accessible, since they
1741 * use the global PL_hints) */
1742 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1745 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1747 if (old_warnings == pWARN_NONE ||
1748 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1749 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1750 else if (old_warnings == pWARN_ALL ||
1751 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1752 /* Get the bit mask for $warnings::Bits{all}, because
1753 * it could have been extended by warnings::register */
1755 HV * const bits = get_hv("warnings::Bits", FALSE);
1756 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1757 mask = newSVsv(*bits_all);
1760 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1764 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1768 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1769 sv_2mortal(newRV_noinc(
1770 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1771 cx->blk_oldcop->cop_hints_hash)))
1780 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1781 sv_reset(tmps, CopSTASH(PL_curcop));
1786 /* like pp_nextstate, but used instead when the debugger is active */
1791 PL_curcop = (COP*)PL_op;
1792 TAINT_NOT; /* Each statement is presumed innocent */
1793 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1796 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1797 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1800 register PERL_CONTEXT *cx;
1801 const I32 gimme = G_ARRAY;
1803 GV * const gv = PL_DBgv;
1804 register CV * const cv = GvCV(gv);
1807 DIE(aTHX_ "No DB::DB routine defined");
1809 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1810 /* don't do recursive DB::DB call */
1825 (void)(*CvXSUB(cv))(aTHX_ cv);
1832 PUSHBLOCK(cx, CXt_SUB, SP);
1834 cx->blk_sub.retop = PL_op->op_next;
1837 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1838 RETURNOP(CvSTART(cv));
1848 register PERL_CONTEXT *cx;
1849 const I32 gimme = GIMME_V;
1851 U8 cxtype = CXt_LOOP_FOR;
1859 if (PL_op->op_targ) {
1860 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1861 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1862 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1863 SVs_PADSTALE, SVs_PADSTALE);
1865 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1866 #ifndef USE_ITHREADS
1867 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1873 GV * const gv = (GV*)POPs;
1874 svp = &GvSV(gv); /* symbol table variable */
1875 SAVEGENERICSV(*svp);
1878 iterdata = (PAD*)gv;
1882 if (PL_op->op_private & OPpITER_DEF)
1883 cxtype |= CXp_FOR_DEF;
1887 PUSHBLOCK(cx, cxtype, SP);
1889 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1891 PUSHLOOP_FOR(cx, svp, MARK, 0);
1893 if (PL_op->op_flags & OPf_STACKED) {
1894 SV *maybe_ary = POPs;
1895 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1897 SV * const right = maybe_ary;
1900 if (RANGE_IS_NUMERIC(sv,right)) {
1901 cx->cx_type &= ~CXTYPEMASK;
1902 cx->cx_type |= CXt_LOOP_LAZYIV;
1903 /* Make sure that no-one re-orders cop.h and breaks our
1905 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1906 #ifdef NV_PRESERVES_UV
1907 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1908 (SvNV(sv) > (NV)IV_MAX)))
1910 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1911 (SvNV(right) < (NV)IV_MIN))))
1913 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1916 ((SvUV(sv) > (UV)IV_MAX) ||
1917 (SvNV(sv) > (NV)UV_MAX)))))
1919 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1921 ((SvNV(right) > 0) &&
1922 ((SvUV(right) > (UV)IV_MAX) ||
1923 (SvNV(right) > (NV)UV_MAX))))))
1925 DIE(aTHX_ "Range iterator outside integer range");
1926 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1927 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1929 /* for correct -Dstv display */
1930 cx->blk_oldsp = sp - PL_stack_base;
1934 cx->cx_type &= ~CXTYPEMASK;
1935 cx->cx_type |= CXt_LOOP_LAZYSV;
1936 /* Make sure that no-one re-orders cop.h and breaks our
1938 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
1939 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
1940 cx->blk_loop.state_u.lazysv.end = right;
1941 SvREFCNT_inc(right);
1942 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
1943 /* This will do the upgrade to SVt_PV, and warn if the value
1944 is uninitialised. */
1945 (void) SvPV_nolen_const(right);
1946 /* Doing this avoids a check every time in pp_iter in pp_hot.c
1947 to replace !SvOK() with a pointer to "". */
1949 SvREFCNT_dec(right);
1950 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
1954 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
1955 cx->blk_loop.state_u.ary.ary = (AV*)maybe_ary;
1956 SvREFCNT_inc(maybe_ary);
1957 cx->blk_loop.state_u.ary.ix =
1958 (PL_op->op_private & OPpITER_REVERSED) ?
1959 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
1963 else { /* iterating over items on the stack */
1964 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
1965 if (PL_op->op_private & OPpITER_REVERSED) {
1966 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
1969 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
1979 register PERL_CONTEXT *cx;
1980 const I32 gimme = GIMME_V;
1986 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
1987 PUSHLOOP_PLAIN(cx, SP);
1995 register PERL_CONTEXT *cx;
2002 assert(CxTYPE_is_LOOP(cx));
2004 newsp = PL_stack_base + cx->blk_loop.resetsp;
2007 if (gimme == G_VOID)
2009 else if (gimme == G_SCALAR) {
2011 *++newsp = sv_mortalcopy(*SP);
2013 *++newsp = &PL_sv_undef;
2017 *++newsp = sv_mortalcopy(*++mark);
2018 TAINT_NOT; /* Each item is independent */
2024 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2025 PL_curpm = newpm; /* ... and pop $1 et al */
2036 register PERL_CONTEXT *cx;
2037 bool popsub2 = FALSE;
2038 bool clear_errsv = FALSE;
2046 const I32 cxix = dopoptosub(cxstack_ix);
2049 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2050 * sort block, which is a CXt_NULL
2053 PL_stack_base[1] = *PL_stack_sp;
2054 PL_stack_sp = PL_stack_base + 1;
2058 DIE(aTHX_ "Can't return outside a subroutine");
2060 if (cxix < cxstack_ix)
2063 if (CxMULTICALL(&cxstack[cxix])) {
2064 gimme = cxstack[cxix].blk_gimme;
2065 if (gimme == G_VOID)
2066 PL_stack_sp = PL_stack_base;
2067 else if (gimme == G_SCALAR) {
2068 PL_stack_base[1] = *PL_stack_sp;
2069 PL_stack_sp = PL_stack_base + 1;
2075 switch (CxTYPE(cx)) {
2078 retop = cx->blk_sub.retop;
2079 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2082 if (!(PL_in_eval & EVAL_KEEPERR))
2085 retop = cx->blk_eval.retop;
2089 if (optype == OP_REQUIRE &&
2090 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2092 /* Unassume the success we assumed earlier. */
2093 SV * const nsv = cx->blk_eval.old_namesv;
2094 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2095 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2100 retop = cx->blk_sub.retop;
2103 DIE(aTHX_ "panic: return");
2107 if (gimme == G_SCALAR) {
2110 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2112 *++newsp = SvREFCNT_inc(*SP);
2117 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2119 *++newsp = sv_mortalcopy(sv);
2124 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2127 *++newsp = sv_mortalcopy(*SP);
2130 *++newsp = &PL_sv_undef;
2132 else if (gimme == G_ARRAY) {
2133 while (++MARK <= SP) {
2134 *++newsp = (popsub2 && SvTEMP(*MARK))
2135 ? *MARK : sv_mortalcopy(*MARK);
2136 TAINT_NOT; /* Each item is independent */
2139 PL_stack_sp = newsp;
2142 /* Stack values are safe: */
2145 POPSUB(cx,sv); /* release CV and @_ ... */
2149 PL_curpm = newpm; /* ... and pop $1 et al */
2153 sv_setpvn(ERRSV,"",0);
2161 register PERL_CONTEXT *cx;
2172 if (PL_op->op_flags & OPf_SPECIAL) {
2173 cxix = dopoptoloop(cxstack_ix);
2175 DIE(aTHX_ "Can't \"last\" outside a loop block");
2178 cxix = dopoptolabel(cPVOP->op_pv);
2180 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2182 if (cxix < cxstack_ix)
2186 cxstack_ix++; /* temporarily protect top context */
2188 switch (CxTYPE(cx)) {
2189 case CXt_LOOP_LAZYIV:
2190 case CXt_LOOP_LAZYSV:
2192 case CXt_LOOP_PLAIN:
2194 newsp = PL_stack_base + cx->blk_loop.resetsp;
2195 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2199 nextop = cx->blk_sub.retop;
2203 nextop = cx->blk_eval.retop;
2207 nextop = cx->blk_sub.retop;
2210 DIE(aTHX_ "panic: last");
2214 if (gimme == G_SCALAR) {
2216 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2217 ? *SP : sv_mortalcopy(*SP);
2219 *++newsp = &PL_sv_undef;
2221 else if (gimme == G_ARRAY) {
2222 while (++MARK <= SP) {
2223 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2224 ? *MARK : sv_mortalcopy(*MARK);
2225 TAINT_NOT; /* Each item is independent */
2233 /* Stack values are safe: */
2235 case CXt_LOOP_LAZYIV:
2236 case CXt_LOOP_PLAIN:
2237 case CXt_LOOP_LAZYSV:
2239 POPLOOP(cx); /* release loop vars ... */
2243 POPSUB(cx,sv); /* release CV and @_ ... */
2246 PL_curpm = newpm; /* ... and pop $1 et al */
2249 PERL_UNUSED_VAR(optype);
2250 PERL_UNUSED_VAR(gimme);
2258 register PERL_CONTEXT *cx;
2261 if (PL_op->op_flags & OPf_SPECIAL) {
2262 cxix = dopoptoloop(cxstack_ix);
2264 DIE(aTHX_ "Can't \"next\" outside a loop block");
2267 cxix = dopoptolabel(cPVOP->op_pv);
2269 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2271 if (cxix < cxstack_ix)
2274 /* clear off anything above the scope we're re-entering, but
2275 * save the rest until after a possible continue block */
2276 inner = PL_scopestack_ix;
2278 if (PL_scopestack_ix < inner)
2279 leave_scope(PL_scopestack[PL_scopestack_ix]);
2280 PL_curcop = cx->blk_oldcop;
2281 return CX_LOOP_NEXTOP_GET(cx);
2288 register PERL_CONTEXT *cx;
2292 if (PL_op->op_flags & OPf_SPECIAL) {
2293 cxix = dopoptoloop(cxstack_ix);
2295 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2298 cxix = dopoptolabel(cPVOP->op_pv);
2300 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2302 if (cxix < cxstack_ix)
2305 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2306 if (redo_op->op_type == OP_ENTER) {
2307 /* pop one less context to avoid $x being freed in while (my $x..) */
2309 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2310 redo_op = redo_op->op_next;
2314 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2315 LEAVE_SCOPE(oldsave);
2317 PL_curcop = cx->blk_oldcop;
2322 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2326 static const char too_deep[] = "Target of goto is too deeply nested";
2328 PERL_ARGS_ASSERT_DOFINDLABEL;
2331 Perl_croak(aTHX_ too_deep);
2332 if (o->op_type == OP_LEAVE ||
2333 o->op_type == OP_SCOPE ||
2334 o->op_type == OP_LEAVELOOP ||
2335 o->op_type == OP_LEAVESUB ||
2336 o->op_type == OP_LEAVETRY)
2338 *ops++ = cUNOPo->op_first;
2340 Perl_croak(aTHX_ too_deep);
2343 if (o->op_flags & OPf_KIDS) {
2345 /* First try all the kids at this level, since that's likeliest. */
2346 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2347 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2348 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2351 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2352 if (kid == PL_lastgotoprobe)
2354 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2357 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2358 ops[-1]->op_type == OP_DBSTATE)
2363 if ((o = dofindlabel(kid, label, ops, oplimit)))
2376 register PERL_CONTEXT *cx;
2377 #define GOTO_DEPTH 64
2378 OP *enterops[GOTO_DEPTH];
2379 const char *label = NULL;
2380 const bool do_dump = (PL_op->op_type == OP_DUMP);
2381 static const char must_have_label[] = "goto must have label";
2383 if (PL_op->op_flags & OPf_STACKED) {
2384 SV * const sv = POPs;
2386 /* This egregious kludge implements goto &subroutine */
2387 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2389 register PERL_CONTEXT *cx;
2390 CV* cv = (CV*)SvRV(sv);
2397 if (!CvROOT(cv) && !CvXSUB(cv)) {
2398 const GV * const gv = CvGV(cv);
2402 /* autoloaded stub? */
2403 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2405 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2406 GvNAMELEN(gv), FALSE);
2407 if (autogv && (cv = GvCV(autogv)))
2409 tmpstr = sv_newmortal();
2410 gv_efullname3(tmpstr, gv, NULL);
2411 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2413 DIE(aTHX_ "Goto undefined subroutine");
2416 /* First do some returnish stuff. */
2417 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2419 cxix = dopoptosub(cxstack_ix);
2421 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2422 if (cxix < cxstack_ix)
2426 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2427 if (CxTYPE(cx) == CXt_EVAL) {
2429 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2431 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2433 else if (CxMULTICALL(cx))
2434 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2435 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2436 /* put @_ back onto stack */
2437 AV* av = cx->blk_sub.argarray;
2439 items = AvFILLp(av) + 1;
2440 EXTEND(SP, items+1); /* @_ could have been extended. */
2441 Copy(AvARRAY(av), SP + 1, items, SV*);
2442 SvREFCNT_dec(GvAV(PL_defgv));
2443 GvAV(PL_defgv) = cx->blk_sub.savearray;
2445 /* abandon @_ if it got reified */
2450 av_extend(av, items-1);
2452 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2455 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2456 AV* const av = GvAV(PL_defgv);
2457 items = AvFILLp(av) + 1;
2458 EXTEND(SP, items+1); /* @_ could have been extended. */
2459 Copy(AvARRAY(av), SP + 1, items, SV*);
2463 if (CxTYPE(cx) == CXt_SUB &&
2464 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2465 SvREFCNT_dec(cx->blk_sub.cv);
2466 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2467 LEAVE_SCOPE(oldsave);
2469 /* Now do some callish stuff. */
2471 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2473 OP* const retop = cx->blk_sub.retop;
2478 for (index=0; index<items; index++)
2479 sv_2mortal(SP[-index]);
2482 /* XS subs don't have a CxSUB, so pop it */
2483 POPBLOCK(cx, PL_curpm);
2484 /* Push a mark for the start of arglist */
2487 (void)(*CvXSUB(cv))(aTHX_ cv);
2492 AV* const padlist = CvPADLIST(cv);
2493 if (CxTYPE(cx) == CXt_EVAL) {
2494 PL_in_eval = CxOLD_IN_EVAL(cx);
2495 PL_eval_root = cx->blk_eval.old_eval_root;
2496 cx->cx_type = CXt_SUB;
2498 cx->blk_sub.cv = cv;
2499 cx->blk_sub.olddepth = CvDEPTH(cv);
2502 if (CvDEPTH(cv) < 2)
2503 SvREFCNT_inc_simple_void_NN(cv);
2505 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2506 sub_crush_depth(cv);
2507 pad_push(padlist, CvDEPTH(cv));
2510 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2513 AV* const av = (AV*)PAD_SVl(0);
2515 cx->blk_sub.savearray = GvAV(PL_defgv);
2516 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2517 CX_CURPAD_SAVE(cx->blk_sub);
2518 cx->blk_sub.argarray = av;
2520 if (items >= AvMAX(av) + 1) {
2521 SV **ary = AvALLOC(av);
2522 if (AvARRAY(av) != ary) {
2523 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2526 if (items >= AvMAX(av) + 1) {
2527 AvMAX(av) = items - 1;
2528 Renew(ary,items+1,SV*);
2534 Copy(mark,AvARRAY(av),items,SV*);
2535 AvFILLp(av) = items - 1;
2536 assert(!AvREAL(av));
2538 /* transfer 'ownership' of refcnts to new @_ */
2548 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2549 Perl_get_db_sub(aTHX_ NULL, cv);
2551 CV * const gotocv = get_cv("DB::goto", FALSE);
2553 PUSHMARK( PL_stack_sp );
2554 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2559 RETURNOP(CvSTART(cv));
2563 label = SvPV_nolen_const(sv);
2564 if (!(do_dump || *label))
2565 DIE(aTHX_ must_have_label);
2568 else if (PL_op->op_flags & OPf_SPECIAL) {
2570 DIE(aTHX_ must_have_label);
2573 label = cPVOP->op_pv;
2575 if (label && *label) {
2576 OP *gotoprobe = NULL;
2577 bool leaving_eval = FALSE;
2578 bool in_block = FALSE;
2579 PERL_CONTEXT *last_eval_cx = NULL;
2583 PL_lastgotoprobe = NULL;
2585 for (ix = cxstack_ix; ix >= 0; ix--) {
2587 switch (CxTYPE(cx)) {
2589 leaving_eval = TRUE;
2590 if (!CxTRYBLOCK(cx)) {
2591 gotoprobe = (last_eval_cx ?
2592 last_eval_cx->blk_eval.old_eval_root :
2597 /* else fall through */
2598 case CXt_LOOP_LAZYIV:
2599 case CXt_LOOP_LAZYSV:
2601 case CXt_LOOP_PLAIN:
2602 gotoprobe = cx->blk_oldcop->op_sibling;
2608 gotoprobe = cx->blk_oldcop->op_sibling;
2611 gotoprobe = PL_main_root;
2614 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2615 gotoprobe = CvROOT(cx->blk_sub.cv);
2621 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2624 DIE(aTHX_ "panic: goto");
2625 gotoprobe = PL_main_root;
2629 retop = dofindlabel(gotoprobe, label,
2630 enterops, enterops + GOTO_DEPTH);
2634 PL_lastgotoprobe = gotoprobe;
2637 DIE(aTHX_ "Can't find label %s", label);
2639 /* if we're leaving an eval, check before we pop any frames
2640 that we're not going to punt, otherwise the error
2643 if (leaving_eval && *enterops && enterops[1]) {
2645 for (i = 1; enterops[i]; i++)
2646 if (enterops[i]->op_type == OP_ENTERITER)
2647 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2650 /* pop unwanted frames */
2652 if (ix < cxstack_ix) {
2659 oldsave = PL_scopestack[PL_scopestack_ix];
2660 LEAVE_SCOPE(oldsave);
2663 /* push wanted frames */
2665 if (*enterops && enterops[1]) {
2666 OP * const oldop = PL_op;
2667 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2668 for (; enterops[ix]; ix++) {
2669 PL_op = enterops[ix];
2670 /* Eventually we may want to stack the needed arguments
2671 * for each op. For now, we punt on the hard ones. */
2672 if (PL_op->op_type == OP_ENTERITER)
2673 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2674 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2682 if (!retop) retop = PL_main_start;
2684 PL_restartop = retop;
2685 PL_do_undump = TRUE;
2689 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2690 PL_do_undump = FALSE;
2707 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2709 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2712 PL_exit_flags |= PERL_EXIT_EXPECTED;
2714 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2715 if (anum || !(PL_minus_c && PL_madskills))
2720 PUSHs(&PL_sv_undef);
2727 S_save_lines(pTHX_ AV *array, SV *sv)
2729 const char *s = SvPVX_const(sv);
2730 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2733 PERL_ARGS_ASSERT_SAVE_LINES;
2735 while (s && s < send) {
2737 SV * const tmpstr = newSV_type(SVt_PVMG);
2739 t = strchr(s, '\n');
2745 sv_setpvn(tmpstr, s, t - s);
2746 av_store(array, line++, tmpstr);
2752 S_docatch(pTHX_ OP *o)
2756 OP * const oldop = PL_op;
2760 assert(CATCH_GET == TRUE);
2767 assert(cxstack_ix >= 0);
2768 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2769 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2774 /* die caught by an inner eval - continue inner loop */
2776 /* NB XXX we rely on the old popped CxEVAL still being at the top
2777 * of the stack; the way die_where() currently works, this
2778 * assumption is valid. In theory The cur_top_env value should be
2779 * returned in another global, the way retop (aka PL_restartop)
2781 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2784 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2786 PL_op = PL_restartop;
2803 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2804 /* sv Text to convert to OP tree. */
2805 /* startop op_free() this to undo. */
2806 /* code Short string id of the caller. */
2808 /* FIXME - how much of this code is common with pp_entereval? */
2809 dVAR; dSP; /* Make POPBLOCK work. */
2815 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2816 char *tmpbuf = tbuf;
2819 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2822 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2825 lex_start(sv, NULL, FALSE);
2827 /* switch to eval mode */
2829 if (IN_PERL_COMPILETIME) {
2830 SAVECOPSTASH_FREE(&PL_compiling);
2831 CopSTASH_set(&PL_compiling, PL_curstash);
2833 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2834 SV * const sv = sv_newmortal();
2835 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2836 code, (unsigned long)++PL_evalseq,
2837 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2842 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2843 (unsigned long)++PL_evalseq);
2844 SAVECOPFILE_FREE(&PL_compiling);
2845 CopFILE_set(&PL_compiling, tmpbuf+2);
2846 SAVECOPLINE(&PL_compiling);
2847 CopLINE_set(&PL_compiling, 1);
2848 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2849 deleting the eval's FILEGV from the stash before gv_check() runs
2850 (i.e. before run-time proper). To work around the coredump that
2851 ensues, we always turn GvMULTI_on for any globals that were
2852 introduced within evals. See force_ident(). GSAR 96-10-12 */
2853 safestr = savepvn(tmpbuf, len);
2854 SAVEDELETE(PL_defstash, safestr, len);
2856 #ifdef OP_IN_REGISTER
2862 /* we get here either during compilation, or via pp_regcomp at runtime */
2863 runtime = IN_PERL_RUNTIME;
2865 runcv = find_runcv(NULL);
2868 PL_op->op_type = OP_ENTEREVAL;
2869 PL_op->op_flags = 0; /* Avoid uninit warning. */
2870 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2874 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2876 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2877 POPBLOCK(cx,PL_curpm);
2880 (*startop)->op_type = OP_NULL;
2881 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2883 /* XXX DAPM do this properly one year */
2884 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2886 if (IN_PERL_COMPILETIME)
2887 CopHINTS_set(&PL_compiling, PL_hints);
2888 #ifdef OP_IN_REGISTER
2891 PERL_UNUSED_VAR(newsp);
2892 PERL_UNUSED_VAR(optype);
2894 return PL_eval_start;
2899 =for apidoc find_runcv
2901 Locate the CV corresponding to the currently executing sub or eval.
2902 If db_seqp is non_null, skip CVs that are in the DB package and populate
2903 *db_seqp with the cop sequence number at the point that the DB:: code was
2904 entered. (allows debuggers to eval in the scope of the breakpoint rather
2905 than in the scope of the debugger itself).
2911 Perl_find_runcv(pTHX_ U32 *db_seqp)
2917 *db_seqp = PL_curcop->cop_seq;
2918 for (si = PL_curstackinfo; si; si = si->si_prev) {
2920 for (ix = si->si_cxix; ix >= 0; ix--) {
2921 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2922 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2923 CV * const cv = cx->blk_sub.cv;
2924 /* skip DB:: code */
2925 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2926 *db_seqp = cx->blk_oldcop->cop_seq;
2931 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2939 /* Compile a require/do, an eval '', or a /(?{...})/.
2940 * In the last case, startop is non-null, and contains the address of
2941 * a pointer that should be set to the just-compiled code.
2942 * outside is the lexically enclosing CV (if any) that invoked us.
2943 * Returns a bool indicating whether the compile was successful; if so,
2944 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2945 * pushes undef (also croaks if startop != NULL).
2949 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2952 OP * const saveop = PL_op;
2954 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2955 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2960 SAVESPTR(PL_compcv);
2961 PL_compcv = (CV*)newSV_type(SVt_PVCV);
2962 CvEVAL_on(PL_compcv);
2963 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2964 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2966 CvOUTSIDE_SEQ(PL_compcv) = seq;
2967 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2969 /* set up a scratch pad */
2971 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2972 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2976 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2978 /* make sure we compile in the right package */
2980 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2981 SAVESPTR(PL_curstash);
2982 PL_curstash = CopSTASH(PL_curcop);
2984 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2985 SAVESPTR(PL_beginav);
2986 PL_beginav = newAV();
2987 SAVEFREESV(PL_beginav);
2988 SAVESPTR(PL_unitcheckav);
2989 PL_unitcheckav = newAV();
2990 SAVEFREESV(PL_unitcheckav);
2993 SAVEBOOL(PL_madskills);
2997 /* try to compile it */
2999 PL_eval_root = NULL;
3000 PL_curcop = &PL_compiling;
3001 CopARYBASE_set(PL_curcop, 0);
3002 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3003 PL_in_eval |= EVAL_KEEPERR;
3005 sv_setpvn(ERRSV,"",0);
3006 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
3007 SV **newsp; /* Used by POPBLOCK. */
3008 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
3009 I32 optype = 0; /* Might be reset by POPEVAL. */
3014 op_free(PL_eval_root);
3015 PL_eval_root = NULL;
3017 SP = PL_stack_base + POPMARK; /* pop original mark */
3019 POPBLOCK(cx,PL_curpm);
3025 msg = SvPVx_nolen_const(ERRSV);
3026 if (optype == OP_REQUIRE) {
3027 const SV * const nsv = cx->blk_eval.old_namesv;
3028 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3030 Perl_croak(aTHX_ "%sCompilation failed in require",
3031 *msg ? msg : "Unknown error\n");
3034 POPBLOCK(cx,PL_curpm);
3036 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3037 (*msg ? msg : "Unknown error\n"));
3041 sv_setpvs(ERRSV, "Compilation error");
3044 PERL_UNUSED_VAR(newsp);
3045 PUSHs(&PL_sv_undef);
3049 CopLINE_set(&PL_compiling, 0);
3051 *startop = PL_eval_root;
3053 SAVEFREEOP(PL_eval_root);
3055 /* Set the context for this new optree.
3056 * If the last op is an OP_REQUIRE, force scalar context.
3057 * Otherwise, propagate the context from the eval(). */
3058 if (PL_eval_root->op_type == OP_LEAVEEVAL
3059 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3060 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3062 scalar(PL_eval_root);
3063 else if ((gimme & G_WANT) == G_VOID)
3064 scalarvoid(PL_eval_root);
3065 else if ((gimme & G_WANT) == G_ARRAY)
3068 scalar(PL_eval_root);
3070 DEBUG_x(dump_eval());
3072 /* Register with debugger: */
3073 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3074 CV * const cv = get_cv("DB::postponed", FALSE);
3078 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3080 call_sv((SV*)cv, G_DISCARD);
3085 call_list(PL_scopestack_ix, PL_unitcheckav);
3087 /* compiled okay, so do it */
3089 CvDEPTH(PL_compcv) = 1;
3090 SP = PL_stack_base + POPMARK; /* pop original mark */
3091 PL_op = saveop; /* The caller may need it. */
3092 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3099 S_check_type_and_open(pTHX_ const char *name)
3102 const int st_rc = PerlLIO_stat(name, &st);
3104 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3106 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3110 return PerlIO_open(name, PERL_SCRIPT_MODE);
3113 #ifndef PERL_DISABLE_PMC
3115 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3119 PERL_ARGS_ASSERT_DOOPEN_PM;
3121 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3122 SV *const pmcsv = newSV(namelen + 2);
3123 char *const pmc = SvPVX(pmcsv);
3126 memcpy(pmc, name, namelen);
3128 pmc[namelen + 1] = '\0';
3130 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3131 fp = check_type_and_open(name);
3134 fp = check_type_and_open(pmc);
3136 SvREFCNT_dec(pmcsv);
3139 fp = check_type_and_open(name);
3144 # define doopen_pm(name, namelen) check_type_and_open(name)
3145 #endif /* !PERL_DISABLE_PMC */
3150 register PERL_CONTEXT *cx;
3157 int vms_unixname = 0;
3159 const char *tryname = NULL;
3161 const I32 gimme = GIMME_V;
3162 int filter_has_file = 0;
3163 PerlIO *tryrsfp = NULL;
3164 SV *filter_cache = NULL;
3165 SV *filter_state = NULL;
3166 SV *filter_sub = NULL;
3172 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3173 sv = new_version(sv);
3174 if (!sv_derived_from(PL_patchlevel, "version"))
3175 upg_version(PL_patchlevel, TRUE);
3176 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3177 if ( vcmp(sv,PL_patchlevel) <= 0 )
3178 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3179 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3182 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3185 SV * const req = SvRV(sv);
3186 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3188 /* get the left hand term */
3189 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3191 first = SvIV(*av_fetch(lav,0,0));
3192 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3193 || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3194 || av_len(lav) > 1 /* FP with > 3 digits */
3195 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3197 DIE(aTHX_ "Perl %"SVf" required--this is only "
3198 "%"SVf", stopped", SVfARG(vnormal(req)),
3199 SVfARG(vnormal(PL_patchlevel)));
3201 else { /* probably 'use 5.10' or 'use 5.8' */
3202 SV * hintsv = newSV(0);
3206 second = SvIV(*av_fetch(lav,1,0));
3208 second /= second >= 600 ? 100 : 10;
3209 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3210 (int)first, (int)second,0);
3211 upg_version(hintsv, TRUE);
3213 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3214 "--this is only %"SVf", stopped",
3215 SVfARG(vnormal(req)),
3216 SVfARG(vnormal(hintsv)),
3217 SVfARG(vnormal(PL_patchlevel)));
3222 /* We do this only with use, not require. */
3224 /* If we request a version >= 5.9.5, load feature.pm with the
3225 * feature bundle that corresponds to the required version. */
3226 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3227 SV *const importsv = vnormal(sv);
3228 *SvPVX_mutable(importsv) = ':';
3230 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3236 name = SvPV_const(sv, len);
3237 if (!(name && len > 0 && *name))
3238 DIE(aTHX_ "Null filename used");
3239 TAINT_PROPER("require");
3243 /* The key in the %ENV hash is in the syntax of file passed as the argument
3244 * usually this is in UNIX format, but sometimes in VMS format, which
3245 * can result in a module being pulled in more than once.
3246 * To prevent this, the key must be stored in UNIX format if the VMS
3247 * name can be translated to UNIX.
3249 if ((unixname = tounixspec(name, NULL)) != NULL) {
3250 unixlen = strlen(unixname);
3256 /* if not VMS or VMS name can not be translated to UNIX, pass it
3259 unixname = (char *) name;
3262 if (PL_op->op_type == OP_REQUIRE) {
3263 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3264 unixname, unixlen, 0);
3266 if (*svp != &PL_sv_undef)
3269 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3270 "Compilation failed in require", unixname);
3274 /* prepare to compile file */
3276 if (path_is_absolute(name)) {
3278 tryrsfp = doopen_pm(name, len);
3280 #ifdef MACOS_TRADITIONAL
3284 MacPerl_CanonDir(name, newname, 1);
3285 if (path_is_absolute(newname)) {
3287 tryrsfp = doopen_pm(newname, strlen(newname));
3292 AV * const ar = GvAVn(PL_incgv);
3298 namesv = newSV_type(SVt_PV);
3299 for (i = 0; i <= AvFILL(ar); i++) {
3300 SV * const dirsv = *av_fetch(ar, i, TRUE);
3302 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3309 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3310 && !sv_isobject(loader))
3312 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3315 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3316 PTR2UV(SvRV(dirsv)), name);
3317 tryname = SvPVX_const(namesv);
3328 if (sv_isobject(loader))
3329 count = call_method("INC", G_ARRAY);
3331 count = call_sv(loader, G_ARRAY);
3334 /* Adjust file name if the hook has set an %INC entry */
3335 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3337 tryname = SvPVX_const(*svp);
3346 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3347 && !isGV_with_GP(SvRV(arg))) {
3348 filter_cache = SvRV(arg);
3349 SvREFCNT_inc_simple_void_NN(filter_cache);
3356 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3360 if (SvTYPE(arg) == SVt_PVGV) {
3361 IO * const io = GvIO((GV *)arg);
3366 tryrsfp = IoIFP(io);
3367 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3368 PerlIO_close(IoOFP(io));
3379 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3381 SvREFCNT_inc_simple_void_NN(filter_sub);
3384 filter_state = SP[i];
3385 SvREFCNT_inc_simple_void(filter_state);
3389 if (!tryrsfp && (filter_cache || filter_sub)) {
3390 tryrsfp = PerlIO_open(BIT_BUCKET,
3405 filter_has_file = 0;
3407 SvREFCNT_dec(filter_cache);
3408 filter_cache = NULL;
3411 SvREFCNT_dec(filter_state);
3412 filter_state = NULL;
3415 SvREFCNT_dec(filter_sub);
3420 if (!path_is_absolute(name)
3421 #ifdef MACOS_TRADITIONAL
3422 /* We consider paths of the form :a:b ambiguous and interpret them first
3423 as global then as local
3425 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3432 dir = SvPV_const(dirsv, dirlen);
3438 #ifdef MACOS_TRADITIONAL
3442 MacPerl_CanonDir(name, buf2, 1);
3443 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3447 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3449 sv_setpv(namesv, unixdir);
3450 sv_catpv(namesv, unixname);
3452 # ifdef __SYMBIAN32__
3453 if (PL_origfilename[0] &&
3454 PL_origfilename[1] == ':' &&
3455 !(dir[0] && dir[1] == ':'))
3456 Perl_sv_setpvf(aTHX_ namesv,
3461 Perl_sv_setpvf(aTHX_ namesv,
3465 /* The equivalent of
3466 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3467 but without the need to parse the format string, or
3468 call strlen on either pointer, and with the correct
3469 allocation up front. */
3471 char *tmp = SvGROW(namesv, dirlen + len + 2);
3473 memcpy(tmp, dir, dirlen);
3476 /* name came from an SV, so it will have a '\0' at the
3477 end that we can copy as part of this memcpy(). */
3478 memcpy(tmp, name, len + 1);
3480 SvCUR_set(namesv, dirlen + len + 1);
3482 /* Don't even actually have to turn SvPOK_on() as we
3483 access it directly with SvPVX() below. */
3488 TAINT_PROPER("require");
3489 tryname = SvPVX_const(namesv);
3490 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3492 if (tryname[0] == '.' && tryname[1] == '/')
3496 else if (errno == EMFILE)
3497 /* no point in trying other paths if out of handles */
3504 SAVECOPFILE_FREE(&PL_compiling);
3505 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3506 SvREFCNT_dec(namesv);
3508 if (PL_op->op_type == OP_REQUIRE) {
3509 const char *msgstr = name;
3510 if(errno == EMFILE) {
3512 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3514 msgstr = SvPV_nolen_const(msg);
3516 if (namesv) { /* did we lookup @INC? */
3517 AV * const ar = GvAVn(PL_incgv);
3519 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3520 "%s in @INC%s%s (@INC contains:",
3522 (instr(msgstr, ".h ")
3523 ? " (change .h to .ph maybe?)" : ""),
3524 (instr(msgstr, ".ph ")
3525 ? " (did you run h2ph?)" : "")
3528 for (i = 0; i <= AvFILL(ar); i++) {
3529 sv_catpvs(msg, " ");
3530 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3532 sv_catpvs(msg, ")");
3533 msgstr = SvPV_nolen_const(msg);
3536 DIE(aTHX_ "Can't locate %s", msgstr);
3542 SETERRNO(0, SS_NORMAL);
3544 /* Assume success here to prevent recursive requirement. */
3545 /* name is never assigned to again, so len is still strlen(name) */
3546 /* Check whether a hook in @INC has already filled %INC */
3548 (void)hv_store(GvHVn(PL_incgv),
3549 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3551 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3553 (void)hv_store(GvHVn(PL_incgv),
3554 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3559 lex_start(NULL, tryrsfp, TRUE);
3563 if (PL_compiling.cop_hints_hash) {
3564 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3565 PL_compiling.cop_hints_hash = NULL;
3568 SAVECOMPILEWARNINGS();
3569 if (PL_dowarn & G_WARN_ALL_ON)
3570 PL_compiling.cop_warnings = pWARN_ALL ;
3571 else if (PL_dowarn & G_WARN_ALL_OFF)
3572 PL_compiling.cop_warnings = pWARN_NONE ;
3574 PL_compiling.cop_warnings = pWARN_STD ;
3576 if (filter_sub || filter_cache) {
3577 SV * const datasv = filter_add(S_run_user_filter, NULL);
3578 IoLINES(datasv) = filter_has_file;
3579 IoTOP_GV(datasv) = (GV *)filter_state;
3580 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3581 IoFMT_GV(datasv) = (GV *)filter_cache;
3584 /* switch to eval mode */
3585 PUSHBLOCK(cx, CXt_EVAL, SP);
3587 cx->blk_eval.retop = PL_op->op_next;
3589 SAVECOPLINE(&PL_compiling);
3590 CopLINE_set(&PL_compiling, 0);
3594 /* Store and reset encoding. */
3595 encoding = PL_encoding;
3598 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3599 op = DOCATCH(PL_eval_start);
3601 op = PL_op->op_next;
3603 /* Restore encoding. */
3604 PL_encoding = encoding;
3609 /* This is a op added to hold the hints hash for
3610 pp_entereval. The hash can be modified by the code
3611 being eval'ed, so we return a copy instead. */
3617 mXPUSHs((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv));
3625 register PERL_CONTEXT *cx;
3627 const I32 gimme = GIMME_V;
3628 const I32 was = PL_sub_generation;
3629 char tbuf[TYPE_DIGITS(long) + 12];
3630 char *tmpbuf = tbuf;
3636 HV *saved_hh = NULL;
3637 const char * const fakestr = "_<(eval )";
3638 const int fakelen = 9 + 1;
3640 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3641 saved_hh = (HV*) SvREFCNT_inc(POPs);
3645 TAINT_IF(SvTAINTED(sv));
3646 TAINT_PROPER("eval");
3649 lex_start(sv, NULL, FALSE);
3652 /* switch to eval mode */
3654 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3655 SV * const temp_sv = sv_newmortal();
3656 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3657 (unsigned long)++PL_evalseq,
3658 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3659 tmpbuf = SvPVX(temp_sv);
3660 len = SvCUR(temp_sv);
3663 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3664 SAVECOPFILE_FREE(&PL_compiling);
3665 CopFILE_set(&PL_compiling, tmpbuf+2);
3666 SAVECOPLINE(&PL_compiling);
3667 CopLINE_set(&PL_compiling, 1);
3668 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3669 deleting the eval's FILEGV from the stash before gv_check() runs
3670 (i.e. before run-time proper). To work around the coredump that
3671 ensues, we always turn GvMULTI_on for any globals that were
3672 introduced within evals. See force_ident(). GSAR 96-10-12 */
3673 safestr = savepvn(tmpbuf, len);
3674 SAVEDELETE(PL_defstash, safestr, len);
3676 PL_hints = PL_op->op_targ;
3678 GvHV(PL_hintgv) = saved_hh;
3679 SAVECOMPILEWARNINGS();
3680 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3681 if (PL_compiling.cop_hints_hash) {
3682 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3684 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3685 if (PL_compiling.cop_hints_hash) {
3687 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3688 HINTS_REFCNT_UNLOCK;
3690 /* special case: an eval '' executed within the DB package gets lexically
3691 * placed in the first non-DB CV rather than the current CV - this
3692 * allows the debugger to execute code, find lexicals etc, in the
3693 * scope of the code being debugged. Passing &seq gets find_runcv
3694 * to do the dirty work for us */
3695 runcv = find_runcv(&seq);
3697 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3699 cx->blk_eval.retop = PL_op->op_next;
3701 /* prepare to compile string */
3703 if (PERLDB_LINE && PL_curstash != PL_debstash)
3704 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3706 ok = doeval(gimme, NULL, runcv, seq);
3707 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3709 /* Copy in anything fake and short. */
3710 my_strlcpy(safestr, fakestr, fakelen);
3712 return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3722 register PERL_CONTEXT *cx;
3724 const U8 save_flags = PL_op -> op_flags;
3729 retop = cx->blk_eval.retop;
3732 if (gimme == G_VOID)
3734 else if (gimme == G_SCALAR) {
3737 if (SvFLAGS(TOPs) & SVs_TEMP)
3740 *MARK = sv_mortalcopy(TOPs);
3744 *MARK = &PL_sv_undef;
3749 /* in case LEAVE wipes old return values */
3750 for (mark = newsp + 1; mark <= SP; mark++) {
3751 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3752 *mark = sv_mortalcopy(*mark);
3753 TAINT_NOT; /* Each item is independent */
3757 PL_curpm = newpm; /* Don't pop $1 et al till now */
3760 assert(CvDEPTH(PL_compcv) == 1);
3762 CvDEPTH(PL_compcv) = 0;
3765 if (optype == OP_REQUIRE &&
3766 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3768 /* Unassume the success we assumed earlier. */
3769 SV * const nsv = cx->blk_eval.old_namesv;
3770 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3771 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3772 /* die_where() did LEAVE, or we won't be here */
3776 if (!(save_flags & OPf_SPECIAL))
3777 sv_setpvn(ERRSV,"",0);
3783 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3784 close to the related Perl_create_eval_scope. */
3786 Perl_delete_eval_scope(pTHX)
3791 register PERL_CONTEXT *cx;
3798 PERL_UNUSED_VAR(newsp);
3799 PERL_UNUSED_VAR(gimme);
3800 PERL_UNUSED_VAR(optype);
3803 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3804 also needed by Perl_fold_constants. */
3806 Perl_create_eval_scope(pTHX_ U32 flags)
3809 const I32 gimme = GIMME_V;
3814 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3817 PL_in_eval = EVAL_INEVAL;
3818 if (flags & G_KEEPERR)
3819 PL_in_eval |= EVAL_KEEPERR;
3821 sv_setpvn(ERRSV,"",0);
3822 if (flags & G_FAKINGEVAL) {
3823 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3831 PERL_CONTEXT * const cx = create_eval_scope(0);
3832 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3833 return DOCATCH(PL_op->op_next);
3842 register PERL_CONTEXT *cx;
3847 PERL_UNUSED_VAR(optype);
3850 if (gimme == G_VOID)
3852 else if (gimme == G_SCALAR) {
3856 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3859 *MARK = sv_mortalcopy(TOPs);
3863 *MARK = &PL_sv_undef;
3868 /* in case LEAVE wipes old return values */
3870 for (mark = newsp + 1; mark <= SP; mark++) {
3871 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3872 *mark = sv_mortalcopy(*mark);
3873 TAINT_NOT; /* Each item is independent */
3877 PL_curpm = newpm; /* Don't pop $1 et al till now */
3880 sv_setpvn(ERRSV,"",0);
3887 register PERL_CONTEXT *cx;
3888 const I32 gimme = GIMME_V;
3893 if (PL_op->op_targ == 0) {
3894 SV ** const defsv_p = &GvSV(PL_defgv);
3895 *defsv_p = newSVsv(POPs);
3896 SAVECLEARSV(*defsv_p);
3899 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3901 PUSHBLOCK(cx, CXt_GIVEN, SP);
3910 register PERL_CONTEXT *cx;
3914 PERL_UNUSED_CONTEXT;
3917 assert(CxTYPE(cx) == CXt_GIVEN);
3922 PL_curpm = newpm; /* pop $1 et al */
3929 /* Helper routines used by pp_smartmatch */
3931 S_make_matcher(pTHX_ REGEXP *re)
3934 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3936 PERL_ARGS_ASSERT_MAKE_MATCHER;
3938 PM_SETRE(matcher, ReREFCNT_inc(re));
3940 SAVEFREEOP((OP *) matcher);
3947 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3952 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
3954 PL_op = (OP *) matcher;
3959 return (SvTRUEx(POPs));
3963 S_destroy_matcher(pTHX_ PMOP *matcher)
3967 PERL_ARGS_ASSERT_DESTROY_MATCHER;
3968 PERL_UNUSED_ARG(matcher);
3974 /* Do a smart match */
3977 return do_smartmatch(NULL, NULL);
3980 /* This version of do_smartmatch() implements the
3981 * table of smart matches that is found in perlsyn.
3984 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3989 SV *e = TOPs; /* e is for 'expression' */
3990 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3991 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3992 REGEXP *this_regex, *other_regex;
3994 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3996 # define SM_REF(type) ( \
3997 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3998 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
4000 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
4001 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
4002 && NOT_EMPTY_PROTO(This) && (Other = e)) \
4003 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
4004 && NOT_EMPTY_PROTO(This) && (Other = d)))
4006 # define SM_REGEX ( \
4007 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \
4008 && (this_regex = (REGEXP*) This) \
4011 (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \
4012 && (this_regex = (REGEXP*) This) \
4016 # define SM_OTHER_REF(type) \
4017 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
4019 # define SM_OTHER_REGEX (SvROK(Other) \
4020 && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \
4021 && (other_regex = (REGEXP*) SvRV(Other)))
4024 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
4025 sv_2mortal(newSViv(PTR2IV(sv))), 0)
4027 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
4028 sv_2mortal(newSViv(PTR2IV(sv))), 0)
4030 tryAMAGICbinSET(smart, 0);
4032 SP -= 2; /* Pop the values */
4034 /* Take care only to invoke mg_get() once for each argument.
4035 * Currently we do this by copying the SV if it's magical. */
4038 d = sv_mortalcopy(d);
4045 e = sv_mortalcopy(e);
4050 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
4052 if (This == SvRV(Other))
4063 c = call_sv(This, G_SCALAR);
4067 else if (SvTEMP(TOPs))
4068 SvREFCNT_inc_void(TOPs);
4073 else if (SM_REF(PVHV)) {
4074 if (SM_OTHER_REF(PVHV)) {
4075 /* Check that the key-sets are identical */
4077 HV *other_hv = (HV *) SvRV(Other);
4079 bool other_tied = FALSE;
4080 U32 this_key_count = 0,
4081 other_key_count = 0;
4083 /* Tied hashes don't know how many keys they have. */
4084 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
4087 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
4088 HV * const temp = other_hv;
4089 other_hv = (HV *) This;
4093 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
4096 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
4099 /* The hashes have the same number of keys, so it suffices
4100 to check that one is a subset of the other. */
4101 (void) hv_iterinit((HV *) This);
4102 while ( (he = hv_iternext((HV *) This)) ) {
4104 char * const key = hv_iterkey(he, &key_len);
4108 if(!hv_exists(other_hv, key, key_len)) {
4109 (void) hv_iterinit((HV *) This); /* reset iterator */
4115 (void) hv_iterinit(other_hv);
4116 while ( hv_iternext(other_hv) )
4120 other_key_count = HvUSEDKEYS(other_hv);
4122 if (this_key_count != other_key_count)
4127 else if (SM_OTHER_REF(PVAV)) {
4128 AV * const other_av = (AV *) SvRV(Other);
4129 const I32 other_len = av_len(other_av) + 1;
4132 for (i = 0; i < other_len; ++i) {
4133 SV ** const svp = av_fetch(other_av, i, FALSE);
4137 if (svp) { /* ??? When can this not happen? */
4138 key = SvPV(*svp, key_len);
4139 if (hv_exists((HV *) This, key, key_len))
4145 else if (SM_OTHER_REGEX) {
4146 PMOP * const matcher = make_matcher(other_regex);
4149 (void) hv_iterinit((HV *) This);
4150 while ( (he = hv_iternext((HV *) This)) ) {
4151 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4152 (void) hv_iterinit((HV *) This);
4153 destroy_matcher(matcher);
4157 destroy_matcher(matcher);
4161 if (hv_exists_ent((HV *) This, Other, 0))
4167 else if (SM_REF(PVAV)) {
4168 if (SM_OTHER_REF(PVAV)) {
4169 AV *other_av = (AV *) SvRV(Other);
4170 if (av_len((AV *) This) != av_len(other_av))
4174 const I32 other_len = av_len(other_av);
4176 if (NULL == seen_this) {
4177 seen_this = newHV();
4178 (void) sv_2mortal((SV *) seen_this);
4180 if (NULL == seen_other) {
4181 seen_this = newHV();
4182 (void) sv_2mortal((SV *) seen_other);
4184 for(i = 0; i <= other_len; ++i) {
4185 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4186 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4188 if (!this_elem || !other_elem) {
4189 if (this_elem || other_elem)
4192 else if (SM_SEEN_THIS(*this_elem)
4193 || SM_SEEN_OTHER(*other_elem))
4195 if (*this_elem != *other_elem)
4199 (void)hv_store_ent(seen_this,
4200 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4202 (void)hv_store_ent(seen_other,
4203 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4209 (void) do_smartmatch(seen_this, seen_other);
4219 else if (SM_OTHER_REGEX) {
4220 PMOP * const matcher = make_matcher(other_regex);
4221 const I32 this_len = av_len((AV *) This);
4224 for(i = 0; i <= this_len; ++i) {
4225 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4226 if (svp && matcher_matches_sv(matcher, *svp)) {
4227 destroy_matcher(matcher);
4231 destroy_matcher(matcher);
4234 else if (SvIOK(Other) || SvNOK(Other)) {
4237 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4238 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4245 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4255 else if (SvPOK(Other)) {
4256 const I32 this_len = av_len((AV *) This);
4259 for(i = 0; i <= this_len; ++i) {
4260 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4275 else if (!SvOK(d) || !SvOK(e)) {
4276 if (!SvOK(d) && !SvOK(e))
4281 else if (SM_REGEX) {
4282 PMOP * const matcher = make_matcher(this_regex);
4285 PUSHs(matcher_matches_sv(matcher, Other)
4288 destroy_matcher(matcher);
4291 else if (SM_REF(PVCV)) {
4293 /* This must be a null-prototyped sub, because we
4294 already checked for the other kind. */
4300 c = call_sv(This, G_SCALAR);
4303 PUSHs(&PL_sv_undef);
4304 else if (SvTEMP(TOPs))
4305 SvREFCNT_inc_void(TOPs);
4307 if (SM_OTHER_REF(PVCV)) {
4308 /* This one has to be null-proto'd too.
4309 Call both of 'em, and compare the results */
4311 c = call_sv(SvRV(Other), G_SCALAR);
4314 PUSHs(&PL_sv_undef);
4315 else if (SvTEMP(TOPs))
4316 SvREFCNT_inc_void(TOPs);
4327 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4328 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4330 if (SvPOK(Other) && !looks_like_number(Other)) {
4331 /* String comparison */
4336 /* Otherwise, numeric comparison */
4339 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4350 /* As a last resort, use string comparison */
4359 register PERL_CONTEXT *cx;
4360 const I32 gimme = GIMME_V;
4362 /* This is essentially an optimization: if the match
4363 fails, we don't want to push a context and then
4364 pop it again right away, so we skip straight
4365 to the op that follows the leavewhen.
4367 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4368 return cLOGOP->op_other->op_next;
4373 PUSHBLOCK(cx, CXt_WHEN, SP);
4382 register PERL_CONTEXT *cx;
4388 assert(CxTYPE(cx) == CXt_WHEN);
4393 PL_curpm = newpm; /* pop $1 et al */
4403 register PERL_CONTEXT *cx;
4406 cxix = dopoptowhen(cxstack_ix);
4408 DIE(aTHX_ "Can't \"continue\" outside a when block");
4409 if (cxix < cxstack_ix)
4412 /* clear off anything above the scope we're re-entering */
4413 inner = PL_scopestack_ix;
4415 if (PL_scopestack_ix < inner)
4416 leave_scope(PL_scopestack[PL_scopestack_ix]);
4417 PL_curcop = cx->blk_oldcop;
4418 return cx->blk_givwhen.leave_op;
4425 register PERL_CONTEXT *cx;
4428 cxix = dopoptogiven(cxstack_ix);
4430 if (PL_op->op_flags & OPf_SPECIAL)
4431 DIE(aTHX_ "Can't use when() outside a topicalizer");
4433 DIE(aTHX_ "Can't \"break\" outside a given block");
4435 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4436 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4438 if (cxix < cxstack_ix)
4441 /* clear off anything above the scope we're re-entering */
4442 inner = PL_scopestack_ix;
4444 if (PL_scopestack_ix < inner)
4445 leave_scope(PL_scopestack[PL_scopestack_ix]);
4446 PL_curcop = cx->blk_oldcop;
4449 return CX_LOOP_NEXTOP_GET(cx);
4451 return cx->blk_givwhen.leave_op;
4455 S_doparseform(pTHX_ SV *sv)
4458 register char *s = SvPV_force(sv, len);
4459 register char * const send = s + len;
4460 register char *base = NULL;
4461 register I32 skipspaces = 0;
4462 bool noblank = FALSE;
4463 bool repeat = FALSE;
4464 bool postspace = FALSE;
4470 bool unchopnum = FALSE;
4471 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4473 PERL_ARGS_ASSERT_DOPARSEFORM;
4476 Perl_croak(aTHX_ "Null picture in formline");
4478 /* estimate the buffer size needed */
4479 for (base = s; s <= send; s++) {
4480 if (*s == '\n' || *s == '@' || *s == '^')
4486 Newx(fops, maxops, U32);
4491 *fpc++ = FF_LINEMARK;
4492 noblank = repeat = FALSE;
4510 case ' ': case '\t':
4517 } /* else FALL THROUGH */
4525 *fpc++ = FF_LITERAL;
4533 *fpc++ = (U16)skipspaces;
4537 *fpc++ = FF_NEWLINE;
4541 arg = fpc - linepc + 1;
4548 *fpc++ = FF_LINEMARK;
4549 noblank = repeat = FALSE;
4558 ischop = s[-1] == '^';
4564 arg = (s - base) - 1;
4566 *fpc++ = FF_LITERAL;
4574 *fpc++ = 2; /* skip the @* or ^* */
4576 *fpc++ = FF_LINESNGL;
4579 *fpc++ = FF_LINEGLOB;
4581 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4582 arg = ischop ? 512 : 0;
4587 const char * const f = ++s;
4590 arg |= 256 + (s - f);
4592 *fpc++ = s - base; /* fieldsize for FETCH */
4593 *fpc++ = FF_DECIMAL;
4595 unchopnum |= ! ischop;
4597 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4598 arg = ischop ? 512 : 0;
4600 s++; /* skip the '0' first */
4604 const char * const f = ++s;
4607 arg |= 256 + (s - f);
4609 *fpc++ = s - base; /* fieldsize for FETCH */
4610 *fpc++ = FF_0DECIMAL;
4612 unchopnum |= ! ischop;
4616 bool ismore = FALSE;
4619 while (*++s == '>') ;
4620 prespace = FF_SPACE;
4622 else if (*s == '|') {
4623 while (*++s == '|') ;
4624 prespace = FF_HALFSPACE;
4629 while (*++s == '<') ;
4632 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4636 *fpc++ = s - base; /* fieldsize for FETCH */
4638 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4641 *fpc++ = (U16)prespace;
4655 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4657 { /* need to jump to the next word */
4659 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4660 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4661 s = SvPVX(sv) + SvCUR(sv) + z;
4663 Copy(fops, s, arg, U32);
4665 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4668 if (unchopnum && repeat)
4669 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4675 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4677 /* Can value be printed in fldsize chars, using %*.*f ? */
4681 int intsize = fldsize - (value < 0 ? 1 : 0);
4688 while (intsize--) pwr *= 10.0;
4689 while (frcsize--) eps /= 10.0;
4692 if (value + eps >= pwr)
4695 if (value - eps <= -pwr)
4702 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4705 SV * const datasv = FILTER_DATA(idx);
4706 const int filter_has_file = IoLINES(datasv);
4707 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4708 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4712 const char *got_p = NULL;
4713 const char *prune_from = NULL;
4714 bool read_from_cache = FALSE;
4717 PERL_ARGS_ASSERT_RUN_USER_FILTER;
4719 assert(maxlen >= 0);
4722 /* I was having segfault trouble under Linux 2.2.5 after a
4723 parse error occured. (Had to hack around it with a test
4724 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4725 not sure where the trouble is yet. XXX */
4727 if (IoFMT_GV(datasv)) {
4728 SV *const cache = (SV *)IoFMT_GV(datasv);
4731 const char *cache_p = SvPV(cache, cache_len);
4735 /* Running in block mode and we have some cached data already.
4737 if (cache_len >= umaxlen) {
4738 /* In fact, so much data we don't even need to call
4743 const char *const first_nl =
4744 (const char *)memchr(cache_p, '\n', cache_len);
4746 take = first_nl + 1 - cache_p;
4750 sv_catpvn(buf_sv, cache_p, take);
4751 sv_chop(cache, cache_p + take);
4752 /* Definately not EOF */
4756 sv_catsv(buf_sv, cache);
4758 umaxlen -= cache_len;
4761 read_from_cache = TRUE;
4765 /* Filter API says that the filter appends to the contents of the buffer.
4766 Usually the buffer is "", so the details don't matter. But if it's not,
4767 then clearly what it contains is already filtered by this filter, so we
4768 don't want to pass it in a second time.
4769 I'm going to use a mortal in case the upstream filter croaks. */
4770 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4771 ? sv_newmortal() : buf_sv;
4772 SvUPGRADE(upstream, SVt_PV);
4774 if (filter_has_file) {
4775 status = FILTER_READ(idx+1, upstream, 0);
4778 if (filter_sub && status >= 0) {
4791 PUSHs(filter_state);
4794 count = call_sv(filter_sub, G_SCALAR);
4809 if(SvOK(upstream)) {
4810 got_p = SvPV(upstream, got_len);
4812 if (got_len > umaxlen) {
4813 prune_from = got_p + umaxlen;
4816 const char *const first_nl =
4817 (const char *)memchr(got_p, '\n', got_len);
4818 if (first_nl && first_nl + 1 < got_p + got_len) {
4819 /* There's a second line here... */
4820 prune_from = first_nl + 1;
4825 /* Oh. Too long. Stuff some in our cache. */
4826 STRLEN cached_len = got_p + got_len - prune_from;
4827 SV *cache = (SV *)IoFMT_GV(datasv);
4830 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4831 } else if (SvOK(cache)) {
4832 /* Cache should be empty. */
4833 assert(!SvCUR(cache));
4836 sv_setpvn(cache, prune_from, cached_len);
4837 /* If you ask for block mode, you may well split UTF-8 characters.
4838 "If it breaks, you get to keep both parts"
4839 (Your code is broken if you don't put them back together again
4840 before something notices.) */
4841 if (SvUTF8(upstream)) {
4844 SvCUR_set(upstream, got_len - cached_len);
4845 /* Can't yet be EOF */
4850 /* If they are at EOF but buf_sv has something in it, then they may never
4851 have touched the SV upstream, so it may be undefined. If we naively
4852 concatenate it then we get a warning about use of uninitialised value.
4854 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4855 sv_catsv(buf_sv, upstream);
4859 IoLINES(datasv) = 0;
4860 SvREFCNT_dec(IoFMT_GV(datasv));
4862 SvREFCNT_dec(filter_state);
4863 IoTOP_GV(datasv) = NULL;
4866 SvREFCNT_dec(filter_sub);
4867 IoBOTTOM_GV(datasv) = NULL;
4869 filter_del(S_run_user_filter);
4871 if (status == 0 && read_from_cache) {
4872 /* If we read some data from the cache (and by getting here it implies
4873 that we emptied the cache) then we aren't yet at EOF, and mustn't
4874 report that to our caller. */
4880 /* perhaps someone can come up with a better name for
4881 this? it is not really "absolute", per se ... */
4883 S_path_is_absolute(const char *name)
4885 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
4887 if (PERL_FILE_IS_ABSOLUTE(name)
4888 #ifdef MACOS_TRADITIONAL
4891 || (*name == '.' && (name[1] == '/' ||
4892 (name[1] == '.' && name[2] == '/')))
4904 * c-indentation-style: bsd
4906 * indent-tabs-mode: t
4909 * ex: set ts=8 sts=4 sw=4 noet: