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);
236 if (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
237 s == m, cx->sb_targ, NULL,
238 ((cx->sb_rflags & REXEC_COPY_STR)
239 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
240 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
242 SV * const targ = cx->sb_targ;
244 assert(cx->sb_strend >= s);
245 if(cx->sb_strend > s) {
246 if (DO_UTF8(dstr) && !SvUTF8(targ))
247 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
249 sv_catpvn(dstr, s, cx->sb_strend - s);
251 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
253 #ifdef PERL_OLD_COPY_ON_WRITE
255 sv_force_normal_flags(targ, SV_COW_DROP_PV);
261 SvPV_set(targ, SvPVX(dstr));
262 SvCUR_set(targ, SvCUR(dstr));
263 SvLEN_set(targ, SvLEN(dstr));
266 SvPV_set(dstr, NULL);
268 TAINT_IF(cx->sb_rxtainted & 1);
269 mPUSHi(saviters - 1);
271 (void)SvPOK_only_UTF8(targ);
272 TAINT_IF(cx->sb_rxtainted);
276 LEAVE_SCOPE(cx->sb_oldsave);
278 RETURNOP(pm->op_next);
280 cx->sb_iters = saviters;
282 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
285 cx->sb_orig = orig = RX_SUBBEG(rx);
287 cx->sb_strend = s + (cx->sb_strend - m);
289 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
291 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
292 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
294 sv_catpvn(dstr, s, m-s);
296 cx->sb_s = RX_OFFS(rx)[0].end + orig;
297 { /* Update the pos() information. */
298 SV * const sv = cx->sb_targ;
300 SvUPGRADE(sv, SVt_PVMG);
301 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
302 #ifdef PERL_OLD_COPY_ON_WRITE
304 sv_force_normal_flags(sv, 0);
306 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
309 mg->mg_len = m - orig;
312 (void)ReREFCNT_inc(rx);
313 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
314 rxres_save(&cx->sb_rxres, rx);
315 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
319 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
324 PERL_ARGS_ASSERT_RXRES_SAVE;
327 if (!p || p[1] < RX_NPARENS(rx)) {
328 #ifdef PERL_OLD_COPY_ON_WRITE
329 i = 7 + RX_NPARENS(rx) * 2;
331 i = 6 + RX_NPARENS(rx) * 2;
340 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
341 RX_MATCH_COPIED_off(rx);
343 #ifdef PERL_OLD_COPY_ON_WRITE
344 *p++ = PTR2UV(RX_SAVED_COPY(rx));
345 RX_SAVED_COPY(rx) = NULL;
348 *p++ = RX_NPARENS(rx);
350 *p++ = PTR2UV(RX_SUBBEG(rx));
351 *p++ = (UV)RX_SUBLEN(rx);
352 for (i = 0; i <= RX_NPARENS(rx); ++i) {
353 *p++ = (UV)RX_OFFS(rx)[i].start;
354 *p++ = (UV)RX_OFFS(rx)[i].end;
359 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
364 PERL_ARGS_ASSERT_RXRES_RESTORE;
367 RX_MATCH_COPY_FREE(rx);
368 RX_MATCH_COPIED_set(rx, *p);
371 #ifdef PERL_OLD_COPY_ON_WRITE
372 if (RX_SAVED_COPY(rx))
373 SvREFCNT_dec (RX_SAVED_COPY(rx));
374 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
378 RX_NPARENS(rx) = *p++;
380 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
381 RX_SUBLEN(rx) = (I32)(*p++);
382 for (i = 0; i <= RX_NPARENS(rx); ++i) {
383 RX_OFFS(rx)[i].start = (I32)(*p++);
384 RX_OFFS(rx)[i].end = (I32)(*p++);
389 Perl_rxres_free(pTHX_ void **rsp)
391 UV * const p = (UV*)*rsp;
393 PERL_ARGS_ASSERT_RXRES_FREE;
398 void *tmp = INT2PTR(char*,*p);
401 PoisonFree(*p, 1, sizeof(*p));
403 Safefree(INT2PTR(char*,*p));
405 #ifdef PERL_OLD_COPY_ON_WRITE
407 SvREFCNT_dec (INT2PTR(SV*,p[1]));
417 dVAR; dSP; dMARK; dORIGMARK;
418 register SV * const tmpForm = *++MARK;
423 register SV *sv = NULL;
424 const char *item = NULL;
428 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
429 const char *chophere = NULL;
430 char *linemark = NULL;
432 bool gotsome = FALSE;
434 const STRLEN fudge = SvPOK(tmpForm)
435 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
436 bool item_is_utf8 = FALSE;
437 bool targ_is_utf8 = FALSE;
439 OP * parseres = NULL;
443 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
444 if (SvREADONLY(tmpForm)) {
445 SvREADONLY_off(tmpForm);
446 parseres = doparseform(tmpForm);
447 SvREADONLY_on(tmpForm);
450 parseres = doparseform(tmpForm);
454 SvPV_force(PL_formtarget, len);
455 if (DO_UTF8(PL_formtarget))
457 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
459 f = SvPV_const(tmpForm, len);
460 /* need to jump to the next word */
461 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
465 const char *name = "???";
468 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
469 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
470 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
471 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
472 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
474 case FF_CHECKNL: name = "CHECKNL"; break;
475 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
476 case FF_SPACE: name = "SPACE"; break;
477 case FF_HALFSPACE: name = "HALFSPACE"; break;
478 case FF_ITEM: name = "ITEM"; break;
479 case FF_CHOP: name = "CHOP"; break;
480 case FF_LINEGLOB: name = "LINEGLOB"; break;
481 case FF_NEWLINE: name = "NEWLINE"; break;
482 case FF_MORE: name = "MORE"; break;
483 case FF_LINEMARK: name = "LINEMARK"; break;
484 case FF_END: name = "END"; break;
485 case FF_0DECIMAL: name = "0DECIMAL"; break;
486 case FF_LINESNGL: name = "LINESNGL"; break;
489 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
491 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
502 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
503 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
505 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
506 t = SvEND(PL_formtarget);
509 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
510 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
512 sv_utf8_upgrade(PL_formtarget);
513 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
514 t = SvEND(PL_formtarget);
534 if (ckWARN(WARN_SYNTAX))
535 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
542 const char *s = item = SvPV_const(sv, len);
545 itemsize = sv_len_utf8(sv);
546 if (itemsize != (I32)len) {
548 if (itemsize > fieldsize) {
549 itemsize = fieldsize;
550 itembytes = itemsize;
551 sv_pos_u2b(sv, &itembytes, 0);
555 send = chophere = s + itembytes;
565 sv_pos_b2u(sv, &itemsize);
569 item_is_utf8 = FALSE;
570 if (itemsize > fieldsize)
571 itemsize = fieldsize;
572 send = chophere = s + itemsize;
586 const char *s = item = SvPV_const(sv, len);
589 itemsize = sv_len_utf8(sv);
590 if (itemsize != (I32)len) {
592 if (itemsize <= fieldsize) {
593 const char *send = chophere = s + itemsize;
606 itemsize = fieldsize;
607 itembytes = itemsize;
608 sv_pos_u2b(sv, &itembytes, 0);
609 send = chophere = s + itembytes;
610 while (s < send || (s == send && isSPACE(*s))) {
620 if (strchr(PL_chopset, *s))
625 itemsize = chophere - item;
626 sv_pos_b2u(sv, &itemsize);
632 item_is_utf8 = FALSE;
633 if (itemsize <= fieldsize) {
634 const char *const send = chophere = s + itemsize;
647 itemsize = fieldsize;
648 send = chophere = s + itemsize;
649 while (s < send || (s == send && isSPACE(*s))) {
659 if (strchr(PL_chopset, *s))
664 itemsize = chophere - item;
670 arg = fieldsize - itemsize;
679 arg = fieldsize - itemsize;
690 const char *s = item;
694 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
696 sv_utf8_upgrade(PL_formtarget);
697 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
698 t = SvEND(PL_formtarget);
702 if (UTF8_IS_CONTINUED(*s)) {
703 STRLEN skip = UTF8SKIP(s);
720 if ( !((*t++ = *s++) & ~31) )
726 if (targ_is_utf8 && !item_is_utf8) {
727 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
729 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
730 for (; t < SvEND(PL_formtarget); t++) {
743 const int ch = *t++ = *s++;
746 if ( !((*t++ = *s++) & ~31) )
755 const char *s = chophere;
773 const char *s = item = SvPV_const(sv, len);
775 if ((item_is_utf8 = DO_UTF8(sv)))
776 itemsize = sv_len_utf8(sv);
778 bool chopped = FALSE;
779 const char *const send = s + len;
781 chophere = s + itemsize;
797 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
799 SvUTF8_on(PL_formtarget);
801 SvCUR_set(sv, chophere - item);
802 sv_catsv(PL_formtarget, sv);
803 SvCUR_set(sv, itemsize);
805 sv_catsv(PL_formtarget, sv);
807 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
808 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
809 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
818 #if defined(USE_LONG_DOUBLE)
821 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
825 "%#0*.*f" : "%0*.*f");
830 #if defined(USE_LONG_DOUBLE)
832 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
835 ((arg & 256) ? "%#*.*f" : "%*.*f");
838 /* If the field is marked with ^ and the value is undefined,
840 if ((arg & 512) && !SvOK(sv)) {
848 /* overflow evidence */
849 if (num_overflow(value, fieldsize, arg)) {
855 /* Formats aren't yet marked for locales, so assume "yes". */
857 STORE_NUMERIC_STANDARD_SET_LOCAL();
858 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
859 RESTORE_NUMERIC_STANDARD();
866 while (t-- > linemark && *t == ' ') ;
874 if (arg) { /* repeat until fields exhausted? */
876 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
877 lines += FmLINES(PL_formtarget);
880 if (strnEQ(linemark, linemark - arg, arg))
881 DIE(aTHX_ "Runaway format");
884 SvUTF8_on(PL_formtarget);
885 FmLINES(PL_formtarget) = lines;
887 RETURNOP(cLISTOP->op_first);
898 const char *s = chophere;
899 const char *send = item + len;
901 while (isSPACE(*s) && (s < send))
906 arg = fieldsize - itemsize;
913 if (strnEQ(s1," ",3)) {
914 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
925 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
927 SvUTF8_on(PL_formtarget);
928 FmLINES(PL_formtarget) += lines;
940 if (PL_stack_base + *PL_markstack_ptr == SP) {
942 if (GIMME_V == G_SCALAR)
944 RETURNOP(PL_op->op_next->op_next);
946 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
947 pp_pushmark(); /* push dst */
948 pp_pushmark(); /* push src */
949 ENTER; /* enter outer scope */
952 if (PL_op->op_private & OPpGREP_LEX)
953 SAVESPTR(PAD_SVl(PL_op->op_targ));
956 ENTER; /* enter inner scope */
959 src = PL_stack_base[*PL_markstack_ptr];
961 if (PL_op->op_private & OPpGREP_LEX)
962 PAD_SVl(PL_op->op_targ) = src;
967 if (PL_op->op_type == OP_MAPSTART)
968 pp_pushmark(); /* push top */
969 return ((LOGOP*)PL_op->op_next)->op_other;
975 const I32 gimme = GIMME_V;
976 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
982 /* first, move source pointer to the next item in the source list */
983 ++PL_markstack_ptr[-1];
985 /* if there are new items, push them into the destination list */
986 if (items && gimme != G_VOID) {
987 /* might need to make room back there first */
988 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
989 /* XXX this implementation is very pessimal because the stack
990 * is repeatedly extended for every set of items. Is possible
991 * to do this without any stack extension or copying at all
992 * by maintaining a separate list over which the map iterates
993 * (like foreach does). --gsar */
995 /* everything in the stack after the destination list moves
996 * towards the end the stack by the amount of room needed */
997 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
999 /* items to shift up (accounting for the moved source pointer) */
1000 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1002 /* This optimization is by Ben Tilly and it does
1003 * things differently from what Sarathy (gsar)
1004 * is describing. The downside of this optimization is
1005 * that leaves "holes" (uninitialized and hopefully unused areas)
1006 * to the Perl stack, but on the other hand this
1007 * shouldn't be a problem. If Sarathy's idea gets
1008 * implemented, this optimization should become
1009 * irrelevant. --jhi */
1011 shift = count; /* Avoid shifting too often --Ben Tilly */
1015 dst = (SP += shift);
1016 PL_markstack_ptr[-1] += shift;
1017 *PL_markstack_ptr += shift;
1021 /* copy the new items down to the destination list */
1022 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1023 if (gimme == G_ARRAY) {
1025 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1028 /* scalar context: we don't care about which values map returns
1029 * (we use undef here). And so we certainly don't want to do mortal
1030 * copies of meaningless values. */
1031 while (items-- > 0) {
1033 *dst-- = &PL_sv_undef;
1037 LEAVE; /* exit inner scope */
1040 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1042 (void)POPMARK; /* pop top */
1043 LEAVE; /* exit outer scope */
1044 (void)POPMARK; /* pop src */
1045 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1046 (void)POPMARK; /* pop dst */
1047 SP = PL_stack_base + POPMARK; /* pop original mark */
1048 if (gimme == G_SCALAR) {
1049 if (PL_op->op_private & OPpGREP_LEX) {
1050 SV* sv = sv_newmortal();
1051 sv_setiv(sv, items);
1059 else if (gimme == G_ARRAY)
1066 ENTER; /* enter inner scope */
1069 /* set $_ to the new source item */
1070 src = PL_stack_base[PL_markstack_ptr[-1]];
1072 if (PL_op->op_private & OPpGREP_LEX)
1073 PAD_SVl(PL_op->op_targ) = src;
1077 RETURNOP(cLOGOP->op_other);
1086 if (GIMME == G_ARRAY)
1088 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1089 return cLOGOP->op_other;
1099 if (GIMME == G_ARRAY) {
1100 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1104 SV * const targ = PAD_SV(PL_op->op_targ);
1107 if (PL_op->op_private & OPpFLIP_LINENUM) {
1108 if (GvIO(PL_last_in_gv)) {
1109 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1112 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1114 flip = SvIV(sv) == SvIV(GvSV(gv));
1120 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1121 if (PL_op->op_flags & OPf_SPECIAL) {
1129 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1132 sv_setpvn(TARG, "", 0);
1138 /* This code tries to decide if "$left .. $right" should use the
1139 magical string increment, or if the range is numeric (we make
1140 an exception for .."0" [#18165]). AMS 20021031. */
1142 #define RANGE_IS_NUMERIC(left,right) ( \
1143 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1144 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1145 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1146 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1147 && (!SvOK(right) || looks_like_number(right))))
1153 if (GIMME == G_ARRAY) {
1159 if (RANGE_IS_NUMERIC(left,right)) {
1162 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1163 (SvOK(right) && SvNV(right) > IV_MAX))
1164 DIE(aTHX_ "Range iterator outside integer range");
1175 SV * const sv = sv_2mortal(newSViv(i++));
1180 SV * const final = sv_mortalcopy(right);
1182 const char * const tmps = SvPV_const(final, len);
1184 SV *sv = sv_mortalcopy(left);
1185 SvPV_force_nolen(sv);
1186 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1188 if (strEQ(SvPVX_const(sv),tmps))
1190 sv = sv_2mortal(newSVsv(sv));
1197 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1201 if (PL_op->op_private & OPpFLIP_LINENUM) {
1202 if (GvIO(PL_last_in_gv)) {
1203 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1206 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1207 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1215 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1216 sv_catpvs(targ, "E0");
1226 static const char * const context_name[] = {
1229 NULL, /* CXt_BLOCK never actually needs "block" */
1231 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1232 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1233 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1234 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1242 S_dopoptolabel(pTHX_ const char *label)
1247 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1249 for (i = cxstack_ix; i >= 0; i--) {
1250 register const PERL_CONTEXT * const cx = &cxstack[i];
1251 switch (CxTYPE(cx)) {
1259 if (ckWARN(WARN_EXITING))
1260 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1261 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1262 if (CxTYPE(cx) == CXt_NULL)
1265 case CXt_LOOP_LAZYIV:
1266 case CXt_LOOP_LAZYSV:
1268 case CXt_LOOP_PLAIN:
1269 if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
1270 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1271 (long)i, CxLABEL(cx)));
1274 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1284 Perl_dowantarray(pTHX)
1287 const I32 gimme = block_gimme();
1288 return (gimme == G_VOID) ? G_SCALAR : gimme;
1292 Perl_block_gimme(pTHX)
1295 const I32 cxix = dopoptosub(cxstack_ix);
1299 switch (cxstack[cxix].blk_gimme) {
1307 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1314 Perl_is_lvalue_sub(pTHX)
1317 const I32 cxix = dopoptosub(cxstack_ix);
1318 assert(cxix >= 0); /* We should only be called from inside subs */
1320 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1321 return CxLVAL(cxstack + cxix);
1327 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1332 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1334 for (i = startingblock; i >= 0; i--) {
1335 register const PERL_CONTEXT * const cx = &cxstk[i];
1336 switch (CxTYPE(cx)) {
1342 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1350 S_dopoptoeval(pTHX_ I32 startingblock)
1354 for (i = startingblock; i >= 0; i--) {
1355 register const PERL_CONTEXT *cx = &cxstack[i];
1356 switch (CxTYPE(cx)) {
1360 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1368 S_dopoptoloop(pTHX_ I32 startingblock)
1372 for (i = startingblock; i >= 0; i--) {
1373 register const PERL_CONTEXT * const cx = &cxstack[i];
1374 switch (CxTYPE(cx)) {
1380 if (ckWARN(WARN_EXITING))
1381 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1382 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1383 if ((CxTYPE(cx)) == CXt_NULL)
1386 case CXt_LOOP_LAZYIV:
1387 case CXt_LOOP_LAZYSV:
1389 case CXt_LOOP_PLAIN:
1390 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1398 S_dopoptogiven(pTHX_ I32 startingblock)
1402 for (i = startingblock; i >= 0; i--) {
1403 register const PERL_CONTEXT *cx = &cxstack[i];
1404 switch (CxTYPE(cx)) {
1408 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1410 case CXt_LOOP_PLAIN:
1411 assert(!CxFOREACHDEF(cx));
1413 case CXt_LOOP_LAZYIV:
1414 case CXt_LOOP_LAZYSV:
1416 if (CxFOREACHDEF(cx)) {
1417 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1426 S_dopoptowhen(pTHX_ I32 startingblock)
1430 for (i = startingblock; i >= 0; i--) {
1431 register const PERL_CONTEXT *cx = &cxstack[i];
1432 switch (CxTYPE(cx)) {
1436 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1444 Perl_dounwind(pTHX_ I32 cxix)
1449 while (cxstack_ix > cxix) {
1451 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1452 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1453 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1454 /* Note: we don't need to restore the base context info till the end. */
1455 switch (CxTYPE(cx)) {
1458 continue; /* not break */
1466 case CXt_LOOP_LAZYIV:
1467 case CXt_LOOP_LAZYSV:
1469 case CXt_LOOP_PLAIN:
1480 PERL_UNUSED_VAR(optype);
1484 Perl_qerror(pTHX_ SV *err)
1488 PERL_ARGS_ASSERT_QERROR;
1491 sv_catsv(ERRSV, err);
1493 sv_catsv(PL_errors, err);
1495 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1497 ++PL_parser->error_count;
1501 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1510 if (PL_in_eval & EVAL_KEEPERR) {
1511 static const char prefix[] = "\t(in cleanup) ";
1512 SV * const err = ERRSV;
1513 const char *e = NULL;
1515 sv_setpvn(err,"",0);
1516 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1518 e = SvPV_const(err, len);
1520 if (*e != *message || strNE(e,message))
1524 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1525 sv_catpvn(err, prefix, sizeof(prefix)-1);
1526 sv_catpvn(err, message, msglen);
1527 if (ckWARN(WARN_MISC)) {
1528 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1529 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1534 sv_setpvn(ERRSV, message, msglen);
1538 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1539 && PL_curstackinfo->si_prev)
1547 register PERL_CONTEXT *cx;
1550 if (cxix < cxstack_ix)
1553 POPBLOCK(cx,PL_curpm);
1554 if (CxTYPE(cx) != CXt_EVAL) {
1556 message = SvPVx_const(ERRSV, msglen);
1557 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1558 PerlIO_write(Perl_error_log, message, msglen);
1563 if (gimme == G_SCALAR)
1564 *++newsp = &PL_sv_undef;
1565 PL_stack_sp = newsp;
1569 /* LEAVE could clobber PL_curcop (see save_re_context())
1570 * XXX it might be better to find a way to avoid messing with
1571 * PL_curcop in save_re_context() instead, but this is a more
1572 * minimal fix --GSAR */
1573 PL_curcop = cx->blk_oldcop;
1575 if (optype == OP_REQUIRE) {
1576 const char* const msg = SvPVx_nolen_const(ERRSV);
1577 SV * const nsv = cx->blk_eval.old_namesv;
1578 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1580 DIE(aTHX_ "%sCompilation failed in require",
1581 *msg ? msg : "Unknown error\n");
1583 assert(CxTYPE(cx) == CXt_EVAL);
1584 return cx->blk_eval.retop;
1588 message = SvPVx_const(ERRSV, msglen);
1590 write_to_stderr(message, msglen);
1598 dVAR; dSP; dPOPTOPssrl;
1599 if (SvTRUE(left) != SvTRUE(right))
1609 register I32 cxix = dopoptosub(cxstack_ix);
1610 register const PERL_CONTEXT *cx;
1611 register const PERL_CONTEXT *ccstack = cxstack;
1612 const PERL_SI *top_si = PL_curstackinfo;
1614 const char *stashname;
1621 /* we may be in a higher stacklevel, so dig down deeper */
1622 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1623 top_si = top_si->si_prev;
1624 ccstack = top_si->si_cxstack;
1625 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1628 if (GIMME != G_ARRAY) {
1634 /* caller() should not report the automatic calls to &DB::sub */
1635 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1636 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1640 cxix = dopoptosub_at(ccstack, cxix - 1);
1643 cx = &ccstack[cxix];
1644 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1645 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1646 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1647 field below is defined for any cx. */
1648 /* caller() should not report the automatic calls to &DB::sub */
1649 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1650 cx = &ccstack[dbcxix];
1653 stashname = CopSTASHPV(cx->blk_oldcop);
1654 if (GIMME != G_ARRAY) {
1657 PUSHs(&PL_sv_undef);
1660 sv_setpv(TARG, stashname);
1669 PUSHs(&PL_sv_undef);
1671 mPUSHs(newSVpv(stashname, 0));
1672 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1673 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1676 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1677 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1678 /* So is ccstack[dbcxix]. */
1680 SV * const sv = newSV(0);
1681 gv_efullname3(sv, cvgv, NULL);
1683 PUSHs(boolSV(CxHASARGS(cx)));
1686 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1687 PUSHs(boolSV(CxHASARGS(cx)));
1691 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1694 gimme = (I32)cx->blk_gimme;
1695 if (gimme == G_VOID)
1696 PUSHs(&PL_sv_undef);
1698 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1699 if (CxTYPE(cx) == CXt_EVAL) {
1701 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1702 PUSHs(cx->blk_eval.cur_text);
1706 else if (cx->blk_eval.old_namesv) {
1707 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1710 /* eval BLOCK (try blocks have old_namesv == 0) */
1712 PUSHs(&PL_sv_undef);
1713 PUSHs(&PL_sv_undef);
1717 PUSHs(&PL_sv_undef);
1718 PUSHs(&PL_sv_undef);
1720 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1721 && CopSTASH_eq(PL_curcop, PL_debstash))
1723 AV * const ary = cx->blk_sub.argarray;
1724 const int off = AvARRAY(ary) - AvALLOC(ary);
1727 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1728 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1730 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1733 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1734 av_extend(PL_dbargs, AvFILLp(ary) + off);
1735 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1736 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1738 /* XXX only hints propagated via op_private are currently
1739 * visible (others are not easily accessible, since they
1740 * use the global PL_hints) */
1741 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1744 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1746 if (old_warnings == pWARN_NONE ||
1747 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1748 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1749 else if (old_warnings == pWARN_ALL ||
1750 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1751 /* Get the bit mask for $warnings::Bits{all}, because
1752 * it could have been extended by warnings::register */
1754 HV * const bits = get_hv("warnings::Bits", FALSE);
1755 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1756 mask = newSVsv(*bits_all);
1759 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1763 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1767 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1768 sv_2mortal(newRV_noinc(
1769 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1770 cx->blk_oldcop->cop_hints_hash)))
1779 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1780 sv_reset(tmps, CopSTASH(PL_curcop));
1785 /* like pp_nextstate, but used instead when the debugger is active */
1790 PL_curcop = (COP*)PL_op;
1791 TAINT_NOT; /* Each statement is presumed innocent */
1792 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1795 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1796 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1799 register PERL_CONTEXT *cx;
1800 const I32 gimme = G_ARRAY;
1802 GV * const gv = PL_DBgv;
1803 register CV * const cv = GvCV(gv);
1806 DIE(aTHX_ "No DB::DB routine defined");
1808 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1809 /* don't do recursive DB::DB call */
1824 (void)(*CvXSUB(cv))(aTHX_ cv);
1831 PUSHBLOCK(cx, CXt_SUB, SP);
1833 cx->blk_sub.retop = PL_op->op_next;
1836 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1837 RETURNOP(CvSTART(cv));
1847 register PERL_CONTEXT *cx;
1848 const I32 gimme = GIMME_V;
1850 U8 cxtype = CXt_LOOP_FOR;
1858 if (PL_op->op_targ) {
1859 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1860 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1861 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1862 SVs_PADSTALE, SVs_PADSTALE);
1864 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1865 #ifndef USE_ITHREADS
1866 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1872 GV * const gv = (GV*)POPs;
1873 svp = &GvSV(gv); /* symbol table variable */
1874 SAVEGENERICSV(*svp);
1877 iterdata = (PAD*)gv;
1881 if (PL_op->op_private & OPpITER_DEF)
1882 cxtype |= CXp_FOR_DEF;
1886 PUSHBLOCK(cx, cxtype, SP);
1888 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1890 PUSHLOOP_FOR(cx, svp, MARK, 0);
1892 if (PL_op->op_flags & OPf_STACKED) {
1893 SV *maybe_ary = POPs;
1894 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1896 SV * const right = maybe_ary;
1899 if (RANGE_IS_NUMERIC(sv,right)) {
1900 cx->cx_type &= ~CXTYPEMASK;
1901 cx->cx_type |= CXt_LOOP_LAZYIV;
1902 /* Make sure that no-one re-orders cop.h and breaks our
1904 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1905 #ifdef NV_PRESERVES_UV
1906 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1907 (SvNV(sv) > (NV)IV_MAX)))
1909 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1910 (SvNV(right) < (NV)IV_MIN))))
1912 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1915 ((SvUV(sv) > (UV)IV_MAX) ||
1916 (SvNV(sv) > (NV)UV_MAX)))))
1918 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1920 ((SvNV(right) > 0) &&
1921 ((SvUV(right) > (UV)IV_MAX) ||
1922 (SvNV(right) > (NV)UV_MAX))))))
1924 DIE(aTHX_ "Range iterator outside integer range");
1925 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1926 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1928 /* for correct -Dstv display */
1929 cx->blk_oldsp = sp - PL_stack_base;
1933 cx->cx_type &= ~CXTYPEMASK;
1934 cx->cx_type |= CXt_LOOP_LAZYSV;
1935 /* Make sure that no-one re-orders cop.h and breaks our
1937 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
1938 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
1939 cx->blk_loop.state_u.lazysv.end = right;
1940 SvREFCNT_inc(right);
1941 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
1942 /* This will do the upgrade to SVt_PV, and warn if the value
1943 is uninitialised. */
1944 (void) SvPV_nolen_const(right);
1945 /* Doing this avoids a check every time in pp_iter in pp_hot.c
1946 to replace !SvOK() with a pointer to "". */
1948 SvREFCNT_dec(right);
1949 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
1953 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
1954 cx->blk_loop.state_u.ary.ary = (AV*)maybe_ary;
1955 SvREFCNT_inc(maybe_ary);
1956 cx->blk_loop.state_u.ary.ix =
1957 (PL_op->op_private & OPpITER_REVERSED) ?
1958 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
1962 else { /* iterating over items on the stack */
1963 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
1964 if (PL_op->op_private & OPpITER_REVERSED) {
1965 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
1968 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
1978 register PERL_CONTEXT *cx;
1979 const I32 gimme = GIMME_V;
1985 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
1986 PUSHLOOP_PLAIN(cx, SP);
1994 register PERL_CONTEXT *cx;
2001 assert(CxTYPE_is_LOOP(cx));
2003 newsp = PL_stack_base + cx->blk_loop.resetsp;
2006 if (gimme == G_VOID)
2008 else if (gimme == G_SCALAR) {
2010 *++newsp = sv_mortalcopy(*SP);
2012 *++newsp = &PL_sv_undef;
2016 *++newsp = sv_mortalcopy(*++mark);
2017 TAINT_NOT; /* Each item is independent */
2023 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2024 PL_curpm = newpm; /* ... and pop $1 et al */
2035 register PERL_CONTEXT *cx;
2036 bool popsub2 = FALSE;
2037 bool clear_errsv = FALSE;
2045 const I32 cxix = dopoptosub(cxstack_ix);
2048 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2049 * sort block, which is a CXt_NULL
2052 PL_stack_base[1] = *PL_stack_sp;
2053 PL_stack_sp = PL_stack_base + 1;
2057 DIE(aTHX_ "Can't return outside a subroutine");
2059 if (cxix < cxstack_ix)
2062 if (CxMULTICALL(&cxstack[cxix])) {
2063 gimme = cxstack[cxix].blk_gimme;
2064 if (gimme == G_VOID)
2065 PL_stack_sp = PL_stack_base;
2066 else if (gimme == G_SCALAR) {
2067 PL_stack_base[1] = *PL_stack_sp;
2068 PL_stack_sp = PL_stack_base + 1;
2074 switch (CxTYPE(cx)) {
2077 retop = cx->blk_sub.retop;
2078 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2081 if (!(PL_in_eval & EVAL_KEEPERR))
2084 retop = cx->blk_eval.retop;
2088 if (optype == OP_REQUIRE &&
2089 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2091 /* Unassume the success we assumed earlier. */
2092 SV * const nsv = cx->blk_eval.old_namesv;
2093 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2094 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2099 retop = cx->blk_sub.retop;
2102 DIE(aTHX_ "panic: return");
2106 if (gimme == G_SCALAR) {
2109 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2111 *++newsp = SvREFCNT_inc(*SP);
2116 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2118 *++newsp = sv_mortalcopy(sv);
2123 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2126 *++newsp = sv_mortalcopy(*SP);
2129 *++newsp = &PL_sv_undef;
2131 else if (gimme == G_ARRAY) {
2132 while (++MARK <= SP) {
2133 *++newsp = (popsub2 && SvTEMP(*MARK))
2134 ? *MARK : sv_mortalcopy(*MARK);
2135 TAINT_NOT; /* Each item is independent */
2138 PL_stack_sp = newsp;
2141 /* Stack values are safe: */
2144 POPSUB(cx,sv); /* release CV and @_ ... */
2148 PL_curpm = newpm; /* ... and pop $1 et al */
2152 sv_setpvn(ERRSV,"",0);
2160 register PERL_CONTEXT *cx;
2171 if (PL_op->op_flags & OPf_SPECIAL) {
2172 cxix = dopoptoloop(cxstack_ix);
2174 DIE(aTHX_ "Can't \"last\" outside a loop block");
2177 cxix = dopoptolabel(cPVOP->op_pv);
2179 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2181 if (cxix < cxstack_ix)
2185 cxstack_ix++; /* temporarily protect top context */
2187 switch (CxTYPE(cx)) {
2188 case CXt_LOOP_LAZYIV:
2189 case CXt_LOOP_LAZYSV:
2191 case CXt_LOOP_PLAIN:
2193 newsp = PL_stack_base + cx->blk_loop.resetsp;
2194 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2198 nextop = cx->blk_sub.retop;
2202 nextop = cx->blk_eval.retop;
2206 nextop = cx->blk_sub.retop;
2209 DIE(aTHX_ "panic: last");
2213 if (gimme == G_SCALAR) {
2215 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2216 ? *SP : sv_mortalcopy(*SP);
2218 *++newsp = &PL_sv_undef;
2220 else if (gimme == G_ARRAY) {
2221 while (++MARK <= SP) {
2222 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2223 ? *MARK : sv_mortalcopy(*MARK);
2224 TAINT_NOT; /* Each item is independent */
2232 /* Stack values are safe: */
2234 case CXt_LOOP_LAZYIV:
2235 case CXt_LOOP_PLAIN:
2236 case CXt_LOOP_LAZYSV:
2238 POPLOOP(cx); /* release loop vars ... */
2242 POPSUB(cx,sv); /* release CV and @_ ... */
2245 PL_curpm = newpm; /* ... and pop $1 et al */
2248 PERL_UNUSED_VAR(optype);
2249 PERL_UNUSED_VAR(gimme);
2257 register PERL_CONTEXT *cx;
2260 if (PL_op->op_flags & OPf_SPECIAL) {
2261 cxix = dopoptoloop(cxstack_ix);
2263 DIE(aTHX_ "Can't \"next\" outside a loop block");
2266 cxix = dopoptolabel(cPVOP->op_pv);
2268 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2270 if (cxix < cxstack_ix)
2273 /* clear off anything above the scope we're re-entering, but
2274 * save the rest until after a possible continue block */
2275 inner = PL_scopestack_ix;
2277 if (PL_scopestack_ix < inner)
2278 leave_scope(PL_scopestack[PL_scopestack_ix]);
2279 PL_curcop = cx->blk_oldcop;
2280 return CX_LOOP_NEXTOP_GET(cx);
2287 register PERL_CONTEXT *cx;
2291 if (PL_op->op_flags & OPf_SPECIAL) {
2292 cxix = dopoptoloop(cxstack_ix);
2294 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2297 cxix = dopoptolabel(cPVOP->op_pv);
2299 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2301 if (cxix < cxstack_ix)
2304 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2305 if (redo_op->op_type == OP_ENTER) {
2306 /* pop one less context to avoid $x being freed in while (my $x..) */
2308 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2309 redo_op = redo_op->op_next;
2313 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2314 LEAVE_SCOPE(oldsave);
2316 PL_curcop = cx->blk_oldcop;
2321 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2325 static const char too_deep[] = "Target of goto is too deeply nested";
2327 PERL_ARGS_ASSERT_DOFINDLABEL;
2330 Perl_croak(aTHX_ too_deep);
2331 if (o->op_type == OP_LEAVE ||
2332 o->op_type == OP_SCOPE ||
2333 o->op_type == OP_LEAVELOOP ||
2334 o->op_type == OP_LEAVESUB ||
2335 o->op_type == OP_LEAVETRY)
2337 *ops++ = cUNOPo->op_first;
2339 Perl_croak(aTHX_ too_deep);
2342 if (o->op_flags & OPf_KIDS) {
2344 /* First try all the kids at this level, since that's likeliest. */
2345 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2346 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2347 CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label))
2350 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2351 if (kid == PL_lastgotoprobe)
2353 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2356 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2357 ops[-1]->op_type == OP_DBSTATE)
2362 if ((o = dofindlabel(kid, label, ops, oplimit)))
2375 register PERL_CONTEXT *cx;
2376 #define GOTO_DEPTH 64
2377 OP *enterops[GOTO_DEPTH];
2378 const char *label = NULL;
2379 const bool do_dump = (PL_op->op_type == OP_DUMP);
2380 static const char must_have_label[] = "goto must have label";
2382 if (PL_op->op_flags & OPf_STACKED) {
2383 SV * const sv = POPs;
2385 /* This egregious kludge implements goto &subroutine */
2386 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2388 register PERL_CONTEXT *cx;
2389 CV* cv = (CV*)SvRV(sv);
2396 if (!CvROOT(cv) && !CvXSUB(cv)) {
2397 const GV * const gv = CvGV(cv);
2401 /* autoloaded stub? */
2402 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2404 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2405 GvNAMELEN(gv), FALSE);
2406 if (autogv && (cv = GvCV(autogv)))
2408 tmpstr = sv_newmortal();
2409 gv_efullname3(tmpstr, gv, NULL);
2410 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2412 DIE(aTHX_ "Goto undefined subroutine");
2415 /* First do some returnish stuff. */
2416 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2418 cxix = dopoptosub(cxstack_ix);
2420 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2421 if (cxix < cxstack_ix)
2425 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2426 if (CxTYPE(cx) == CXt_EVAL) {
2428 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2430 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2432 else if (CxMULTICALL(cx))
2433 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2434 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2435 /* put @_ back onto stack */
2436 AV* av = cx->blk_sub.argarray;
2438 items = AvFILLp(av) + 1;
2439 EXTEND(SP, items+1); /* @_ could have been extended. */
2440 Copy(AvARRAY(av), SP + 1, items, SV*);
2441 SvREFCNT_dec(GvAV(PL_defgv));
2442 GvAV(PL_defgv) = cx->blk_sub.savearray;
2444 /* abandon @_ if it got reified */
2449 av_extend(av, items-1);
2451 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2454 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2455 AV* const av = GvAV(PL_defgv);
2456 items = AvFILLp(av) + 1;
2457 EXTEND(SP, items+1); /* @_ could have been extended. */
2458 Copy(AvARRAY(av), SP + 1, items, SV*);
2462 if (CxTYPE(cx) == CXt_SUB &&
2463 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2464 SvREFCNT_dec(cx->blk_sub.cv);
2465 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2466 LEAVE_SCOPE(oldsave);
2468 /* Now do some callish stuff. */
2470 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2472 OP* const retop = cx->blk_sub.retop;
2477 for (index=0; index<items; index++)
2478 sv_2mortal(SP[-index]);
2481 /* XS subs don't have a CxSUB, so pop it */
2482 POPBLOCK(cx, PL_curpm);
2483 /* Push a mark for the start of arglist */
2486 (void)(*CvXSUB(cv))(aTHX_ cv);
2491 AV* const padlist = CvPADLIST(cv);
2492 if (CxTYPE(cx) == CXt_EVAL) {
2493 PL_in_eval = CxOLD_IN_EVAL(cx);
2494 PL_eval_root = cx->blk_eval.old_eval_root;
2495 cx->cx_type = CXt_SUB;
2497 cx->blk_sub.cv = cv;
2498 cx->blk_sub.olddepth = CvDEPTH(cv);
2501 if (CvDEPTH(cv) < 2)
2502 SvREFCNT_inc_simple_void_NN(cv);
2504 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2505 sub_crush_depth(cv);
2506 pad_push(padlist, CvDEPTH(cv));
2509 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2512 AV* const av = (AV*)PAD_SVl(0);
2514 cx->blk_sub.savearray = GvAV(PL_defgv);
2515 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2516 CX_CURPAD_SAVE(cx->blk_sub);
2517 cx->blk_sub.argarray = av;
2519 if (items >= AvMAX(av) + 1) {
2520 SV **ary = AvALLOC(av);
2521 if (AvARRAY(av) != ary) {
2522 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2525 if (items >= AvMAX(av) + 1) {
2526 AvMAX(av) = items - 1;
2527 Renew(ary,items+1,SV*);
2533 Copy(mark,AvARRAY(av),items,SV*);
2534 AvFILLp(av) = items - 1;
2535 assert(!AvREAL(av));
2537 /* transfer 'ownership' of refcnts to new @_ */
2547 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2548 Perl_get_db_sub(aTHX_ NULL, cv);
2550 CV * const gotocv = get_cv("DB::goto", FALSE);
2552 PUSHMARK( PL_stack_sp );
2553 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2558 RETURNOP(CvSTART(cv));
2562 label = SvPV_nolen_const(sv);
2563 if (!(do_dump || *label))
2564 DIE(aTHX_ must_have_label);
2567 else if (PL_op->op_flags & OPf_SPECIAL) {
2569 DIE(aTHX_ must_have_label);
2572 label = cPVOP->op_pv;
2574 if (label && *label) {
2575 OP *gotoprobe = NULL;
2576 bool leaving_eval = FALSE;
2577 bool in_block = FALSE;
2578 PERL_CONTEXT *last_eval_cx = NULL;
2582 PL_lastgotoprobe = NULL;
2584 for (ix = cxstack_ix; ix >= 0; ix--) {
2586 switch (CxTYPE(cx)) {
2588 leaving_eval = TRUE;
2589 if (!CxTRYBLOCK(cx)) {
2590 gotoprobe = (last_eval_cx ?
2591 last_eval_cx->blk_eval.old_eval_root :
2596 /* else fall through */
2597 case CXt_LOOP_LAZYIV:
2598 case CXt_LOOP_LAZYSV:
2600 case CXt_LOOP_PLAIN:
2601 gotoprobe = cx->blk_oldcop->op_sibling;
2607 gotoprobe = cx->blk_oldcop->op_sibling;
2610 gotoprobe = PL_main_root;
2613 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2614 gotoprobe = CvROOT(cx->blk_sub.cv);
2620 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2623 DIE(aTHX_ "panic: goto");
2624 gotoprobe = PL_main_root;
2628 retop = dofindlabel(gotoprobe, label,
2629 enterops, enterops + GOTO_DEPTH);
2633 PL_lastgotoprobe = gotoprobe;
2636 DIE(aTHX_ "Can't find label %s", label);
2638 /* if we're leaving an eval, check before we pop any frames
2639 that we're not going to punt, otherwise the error
2642 if (leaving_eval && *enterops && enterops[1]) {
2644 for (i = 1; enterops[i]; i++)
2645 if (enterops[i]->op_type == OP_ENTERITER)
2646 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2649 /* pop unwanted frames */
2651 if (ix < cxstack_ix) {
2658 oldsave = PL_scopestack[PL_scopestack_ix];
2659 LEAVE_SCOPE(oldsave);
2662 /* push wanted frames */
2664 if (*enterops && enterops[1]) {
2665 OP * const oldop = PL_op;
2666 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2667 for (; enterops[ix]; ix++) {
2668 PL_op = enterops[ix];
2669 /* Eventually we may want to stack the needed arguments
2670 * for each op. For now, we punt on the hard ones. */
2671 if (PL_op->op_type == OP_ENTERITER)
2672 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2673 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2681 if (!retop) retop = PL_main_start;
2683 PL_restartop = retop;
2684 PL_do_undump = TRUE;
2688 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2689 PL_do_undump = FALSE;
2706 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2708 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2711 PL_exit_flags |= PERL_EXIT_EXPECTED;
2713 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2714 if (anum || !(PL_minus_c && PL_madskills))
2719 PUSHs(&PL_sv_undef);
2726 S_save_lines(pTHX_ AV *array, SV *sv)
2728 const char *s = SvPVX_const(sv);
2729 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2732 PERL_ARGS_ASSERT_SAVE_LINES;
2734 while (s && s < send) {
2736 SV * const tmpstr = newSV_type(SVt_PVMG);
2738 t = strchr(s, '\n');
2744 sv_setpvn(tmpstr, s, t - s);
2745 av_store(array, line++, tmpstr);
2751 S_docatch(pTHX_ OP *o)
2755 OP * const oldop = PL_op;
2759 assert(CATCH_GET == TRUE);
2766 assert(cxstack_ix >= 0);
2767 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2768 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2773 /* die caught by an inner eval - continue inner loop */
2775 /* NB XXX we rely on the old popped CxEVAL still being at the top
2776 * of the stack; the way die_where() currently works, this
2777 * assumption is valid. In theory The cur_top_env value should be
2778 * returned in another global, the way retop (aka PL_restartop)
2780 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2783 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2785 PL_op = PL_restartop;
2802 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2803 /* sv Text to convert to OP tree. */
2804 /* startop op_free() this to undo. */
2805 /* code Short string id of the caller. */
2807 /* FIXME - how much of this code is common with pp_entereval? */
2808 dVAR; dSP; /* Make POPBLOCK work. */
2814 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2815 char *tmpbuf = tbuf;
2818 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2821 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2824 lex_start(sv, NULL, FALSE);
2826 /* switch to eval mode */
2828 if (IN_PERL_COMPILETIME) {
2829 SAVECOPSTASH_FREE(&PL_compiling);
2830 CopSTASH_set(&PL_compiling, PL_curstash);
2832 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2833 SV * const sv = sv_newmortal();
2834 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2835 code, (unsigned long)++PL_evalseq,
2836 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2841 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2842 (unsigned long)++PL_evalseq);
2843 SAVECOPFILE_FREE(&PL_compiling);
2844 CopFILE_set(&PL_compiling, tmpbuf+2);
2845 SAVECOPLINE(&PL_compiling);
2846 CopLINE_set(&PL_compiling, 1);
2847 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2848 deleting the eval's FILEGV from the stash before gv_check() runs
2849 (i.e. before run-time proper). To work around the coredump that
2850 ensues, we always turn GvMULTI_on for any globals that were
2851 introduced within evals. See force_ident(). GSAR 96-10-12 */
2852 safestr = savepvn(tmpbuf, len);
2853 SAVEDELETE(PL_defstash, safestr, len);
2855 #ifdef OP_IN_REGISTER
2861 /* we get here either during compilation, or via pp_regcomp at runtime */
2862 runtime = IN_PERL_RUNTIME;
2864 runcv = find_runcv(NULL);
2867 PL_op->op_type = OP_ENTEREVAL;
2868 PL_op->op_flags = 0; /* Avoid uninit warning. */
2869 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2873 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2875 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2876 POPBLOCK(cx,PL_curpm);
2879 (*startop)->op_type = OP_NULL;
2880 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2882 /* XXX DAPM do this properly one year */
2883 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2885 if (IN_PERL_COMPILETIME)
2886 CopHINTS_set(&PL_compiling, PL_hints);
2887 #ifdef OP_IN_REGISTER
2890 PERL_UNUSED_VAR(newsp);
2891 PERL_UNUSED_VAR(optype);
2893 return PL_eval_start;
2898 =for apidoc find_runcv
2900 Locate the CV corresponding to the currently executing sub or eval.
2901 If db_seqp is non_null, skip CVs that are in the DB package and populate
2902 *db_seqp with the cop sequence number at the point that the DB:: code was
2903 entered. (allows debuggers to eval in the scope of the breakpoint rather
2904 than in the scope of the debugger itself).
2910 Perl_find_runcv(pTHX_ U32 *db_seqp)
2916 *db_seqp = PL_curcop->cop_seq;
2917 for (si = PL_curstackinfo; si; si = si->si_prev) {
2919 for (ix = si->si_cxix; ix >= 0; ix--) {
2920 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2921 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2922 CV * const cv = cx->blk_sub.cv;
2923 /* skip DB:: code */
2924 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2925 *db_seqp = cx->blk_oldcop->cop_seq;
2930 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2938 /* Compile a require/do, an eval '', or a /(?{...})/.
2939 * In the last case, startop is non-null, and contains the address of
2940 * a pointer that should be set to the just-compiled code.
2941 * outside is the lexically enclosing CV (if any) that invoked us.
2942 * Returns a bool indicating whether the compile was successful; if so,
2943 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2944 * pushes undef (also croaks if startop != NULL).
2948 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2951 OP * const saveop = PL_op;
2953 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2954 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2959 SAVESPTR(PL_compcv);
2960 PL_compcv = (CV*)newSV_type(SVt_PVCV);
2961 CvEVAL_on(PL_compcv);
2962 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2963 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2965 CvOUTSIDE_SEQ(PL_compcv) = seq;
2966 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2968 /* set up a scratch pad */
2970 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2971 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2975 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2977 /* make sure we compile in the right package */
2979 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2980 SAVESPTR(PL_curstash);
2981 PL_curstash = CopSTASH(PL_curcop);
2983 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2984 SAVESPTR(PL_beginav);
2985 PL_beginav = newAV();
2986 SAVEFREESV(PL_beginav);
2987 SAVESPTR(PL_unitcheckav);
2988 PL_unitcheckav = newAV();
2989 SAVEFREESV(PL_unitcheckav);
2992 SAVEBOOL(PL_madskills);
2996 /* try to compile it */
2998 PL_eval_root = NULL;
2999 PL_curcop = &PL_compiling;
3000 CopARYBASE_set(PL_curcop, 0);
3001 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3002 PL_in_eval |= EVAL_KEEPERR;
3004 sv_setpvn(ERRSV,"",0);
3005 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
3006 SV **newsp; /* Used by POPBLOCK. */
3007 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
3008 I32 optype = 0; /* Might be reset by POPEVAL. */
3013 op_free(PL_eval_root);
3014 PL_eval_root = NULL;
3016 SP = PL_stack_base + POPMARK; /* pop original mark */
3018 POPBLOCK(cx,PL_curpm);
3024 msg = SvPVx_nolen_const(ERRSV);
3025 if (optype == OP_REQUIRE) {
3026 const SV * const nsv = cx->blk_eval.old_namesv;
3027 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3029 Perl_croak(aTHX_ "%sCompilation failed in require",
3030 *msg ? msg : "Unknown error\n");
3033 POPBLOCK(cx,PL_curpm);
3035 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3036 (*msg ? msg : "Unknown error\n"));
3040 sv_setpvs(ERRSV, "Compilation error");
3043 PERL_UNUSED_VAR(newsp);
3044 PUSHs(&PL_sv_undef);
3048 CopLINE_set(&PL_compiling, 0);
3050 *startop = PL_eval_root;
3052 SAVEFREEOP(PL_eval_root);
3054 /* Set the context for this new optree.
3055 * If the last op is an OP_REQUIRE, force scalar context.
3056 * Otherwise, propagate the context from the eval(). */
3057 if (PL_eval_root->op_type == OP_LEAVEEVAL
3058 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3059 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3061 scalar(PL_eval_root);
3062 else if ((gimme & G_WANT) == G_VOID)
3063 scalarvoid(PL_eval_root);
3064 else if ((gimme & G_WANT) == G_ARRAY)
3067 scalar(PL_eval_root);
3069 DEBUG_x(dump_eval());
3071 /* Register with debugger: */
3072 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3073 CV * const cv = get_cv("DB::postponed", FALSE);
3077 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3079 call_sv((SV*)cv, G_DISCARD);
3084 call_list(PL_scopestack_ix, PL_unitcheckav);
3086 /* compiled okay, so do it */
3088 CvDEPTH(PL_compcv) = 1;
3089 SP = PL_stack_base + POPMARK; /* pop original mark */
3090 PL_op = saveop; /* The caller may need it. */
3091 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3098 S_check_type_and_open(pTHX_ const char *name)
3101 const int st_rc = PerlLIO_stat(name, &st);
3103 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3105 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3109 return PerlIO_open(name, PERL_SCRIPT_MODE);
3112 #ifndef PERL_DISABLE_PMC
3114 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3118 PERL_ARGS_ASSERT_DOOPEN_PM;
3120 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3121 SV *const pmcsv = newSV(namelen + 2);
3122 char *const pmc = SvPVX(pmcsv);
3125 memcpy(pmc, name, namelen);
3127 pmc[namelen + 1] = '\0';
3129 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3130 fp = check_type_and_open(name);
3133 fp = check_type_and_open(pmc);
3135 SvREFCNT_dec(pmcsv);
3138 fp = check_type_and_open(name);
3143 # define doopen_pm(name, namelen) check_type_and_open(name)
3144 #endif /* !PERL_DISABLE_PMC */
3149 register PERL_CONTEXT *cx;
3156 int vms_unixname = 0;
3158 const char *tryname = NULL;
3160 const I32 gimme = GIMME_V;
3161 int filter_has_file = 0;
3162 PerlIO *tryrsfp = NULL;
3163 SV *filter_cache = NULL;
3164 SV *filter_state = NULL;
3165 SV *filter_sub = NULL;
3171 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3172 sv = new_version(sv);
3173 if (!sv_derived_from(PL_patchlevel, "version"))
3174 upg_version(PL_patchlevel, TRUE);
3175 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3176 if ( vcmp(sv,PL_patchlevel) <= 0 )
3177 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3178 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3181 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3184 SV * const req = SvRV(sv);
3185 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3187 /* get the left hand term */
3188 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3190 first = SvIV(*av_fetch(lav,0,0));
3191 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3192 || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3193 || av_len(lav) > 1 /* FP with > 3 digits */
3194 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3196 DIE(aTHX_ "Perl %"SVf" required--this is only "
3197 "%"SVf", stopped", SVfARG(vnormal(req)),
3198 SVfARG(vnormal(PL_patchlevel)));
3200 else { /* probably 'use 5.10' or 'use 5.8' */
3201 SV * hintsv = newSV(0);
3205 second = SvIV(*av_fetch(lav,1,0));
3207 second /= second >= 600 ? 100 : 10;
3208 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3209 (int)first, (int)second,0);
3210 upg_version(hintsv, TRUE);
3212 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3213 "--this is only %"SVf", stopped",
3214 SVfARG(vnormal(req)),
3215 SVfARG(vnormal(hintsv)),
3216 SVfARG(vnormal(PL_patchlevel)));
3221 /* We do this only with use, not require. */
3223 /* If we request a version >= 5.9.5, load feature.pm with the
3224 * feature bundle that corresponds to the required version. */
3225 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3226 SV *const importsv = vnormal(sv);
3227 *SvPVX_mutable(importsv) = ':';
3229 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3235 name = SvPV_const(sv, len);
3236 if (!(name && len > 0 && *name))
3237 DIE(aTHX_ "Null filename used");
3238 TAINT_PROPER("require");
3242 /* The key in the %ENV hash is in the syntax of file passed as the argument
3243 * usually this is in UNIX format, but sometimes in VMS format, which
3244 * can result in a module being pulled in more than once.
3245 * To prevent this, the key must be stored in UNIX format if the VMS
3246 * name can be translated to UNIX.
3248 if ((unixname = tounixspec(name, NULL)) != NULL) {
3249 unixlen = strlen(unixname);
3255 /* if not VMS or VMS name can not be translated to UNIX, pass it
3258 unixname = (char *) name;
3261 if (PL_op->op_type == OP_REQUIRE) {
3262 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3263 unixname, unixlen, 0);
3265 if (*svp != &PL_sv_undef)
3268 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3269 "Compilation failed in require", unixname);
3273 /* prepare to compile file */
3275 if (path_is_absolute(name)) {
3277 tryrsfp = doopen_pm(name, len);
3279 #ifdef MACOS_TRADITIONAL
3283 MacPerl_CanonDir(name, newname, 1);
3284 if (path_is_absolute(newname)) {
3286 tryrsfp = doopen_pm(newname, strlen(newname));
3291 AV * const ar = GvAVn(PL_incgv);
3297 namesv = newSV_type(SVt_PV);
3298 for (i = 0; i <= AvFILL(ar); i++) {
3299 SV * const dirsv = *av_fetch(ar, i, TRUE);
3301 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3308 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3309 && !sv_isobject(loader))
3311 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3314 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3315 PTR2UV(SvRV(dirsv)), name);
3316 tryname = SvPVX_const(namesv);
3327 if (sv_isobject(loader))
3328 count = call_method("INC", G_ARRAY);
3330 count = call_sv(loader, G_ARRAY);
3333 /* Adjust file name if the hook has set an %INC entry */
3334 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3336 tryname = SvPVX_const(*svp);
3345 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3346 && !isGV_with_GP(SvRV(arg))) {
3347 filter_cache = SvRV(arg);
3348 SvREFCNT_inc_simple_void_NN(filter_cache);
3355 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3359 if (SvTYPE(arg) == SVt_PVGV) {
3360 IO * const io = GvIO((GV *)arg);
3365 tryrsfp = IoIFP(io);
3366 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3367 PerlIO_close(IoOFP(io));
3378 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3380 SvREFCNT_inc_simple_void_NN(filter_sub);
3383 filter_state = SP[i];
3384 SvREFCNT_inc_simple_void(filter_state);
3388 if (!tryrsfp && (filter_cache || filter_sub)) {
3389 tryrsfp = PerlIO_open(BIT_BUCKET,
3404 filter_has_file = 0;
3406 SvREFCNT_dec(filter_cache);
3407 filter_cache = NULL;
3410 SvREFCNT_dec(filter_state);
3411 filter_state = NULL;
3414 SvREFCNT_dec(filter_sub);
3419 if (!path_is_absolute(name)
3420 #ifdef MACOS_TRADITIONAL
3421 /* We consider paths of the form :a:b ambiguous and interpret them first
3422 as global then as local
3424 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3431 dir = SvPV_const(dirsv, dirlen);
3437 #ifdef MACOS_TRADITIONAL
3441 MacPerl_CanonDir(name, buf2, 1);
3442 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3446 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3448 sv_setpv(namesv, unixdir);
3449 sv_catpv(namesv, unixname);
3451 # ifdef __SYMBIAN32__
3452 if (PL_origfilename[0] &&
3453 PL_origfilename[1] == ':' &&
3454 !(dir[0] && dir[1] == ':'))
3455 Perl_sv_setpvf(aTHX_ namesv,
3460 Perl_sv_setpvf(aTHX_ namesv,
3464 /* The equivalent of
3465 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3466 but without the need to parse the format string, or
3467 call strlen on either pointer, and with the correct
3468 allocation up front. */
3470 char *tmp = SvGROW(namesv, dirlen + len + 2);
3472 memcpy(tmp, dir, dirlen);
3475 /* name came from an SV, so it will have a '\0' at the
3476 end that we can copy as part of this memcpy(). */
3477 memcpy(tmp, name, len + 1);
3479 SvCUR_set(namesv, dirlen + len + 1);
3481 /* Don't even actually have to turn SvPOK_on() as we
3482 access it directly with SvPVX() below. */
3487 TAINT_PROPER("require");
3488 tryname = SvPVX_const(namesv);
3489 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3491 if (tryname[0] == '.' && tryname[1] == '/')
3495 else if (errno == EMFILE)
3496 /* no point in trying other paths if out of handles */
3503 SAVECOPFILE_FREE(&PL_compiling);
3504 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3505 SvREFCNT_dec(namesv);
3507 if (PL_op->op_type == OP_REQUIRE) {
3508 const char *msgstr = name;
3509 if(errno == EMFILE) {
3511 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3513 msgstr = SvPV_nolen_const(msg);
3515 if (namesv) { /* did we lookup @INC? */
3516 AV * const ar = GvAVn(PL_incgv);
3518 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3519 "%s in @INC%s%s (@INC contains:",
3521 (instr(msgstr, ".h ")
3522 ? " (change .h to .ph maybe?)" : ""),
3523 (instr(msgstr, ".ph ")
3524 ? " (did you run h2ph?)" : "")
3527 for (i = 0; i <= AvFILL(ar); i++) {
3528 sv_catpvs(msg, " ");
3529 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3531 sv_catpvs(msg, ")");
3532 msgstr = SvPV_nolen_const(msg);
3535 DIE(aTHX_ "Can't locate %s", msgstr);
3541 SETERRNO(0, SS_NORMAL);
3543 /* Assume success here to prevent recursive requirement. */
3544 /* name is never assigned to again, so len is still strlen(name) */
3545 /* Check whether a hook in @INC has already filled %INC */
3547 (void)hv_store(GvHVn(PL_incgv),
3548 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3550 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3552 (void)hv_store(GvHVn(PL_incgv),
3553 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3558 lex_start(NULL, tryrsfp, TRUE);
3562 if (PL_compiling.cop_hints_hash) {
3563 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3564 PL_compiling.cop_hints_hash = NULL;
3567 SAVECOMPILEWARNINGS();
3568 if (PL_dowarn & G_WARN_ALL_ON)
3569 PL_compiling.cop_warnings = pWARN_ALL ;
3570 else if (PL_dowarn & G_WARN_ALL_OFF)
3571 PL_compiling.cop_warnings = pWARN_NONE ;
3573 PL_compiling.cop_warnings = pWARN_STD ;
3575 if (filter_sub || filter_cache) {
3576 SV * const datasv = filter_add(S_run_user_filter, NULL);
3577 IoLINES(datasv) = filter_has_file;
3578 IoTOP_GV(datasv) = (GV *)filter_state;
3579 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3580 IoFMT_GV(datasv) = (GV *)filter_cache;
3583 /* switch to eval mode */
3584 PUSHBLOCK(cx, CXt_EVAL, SP);
3586 cx->blk_eval.retop = PL_op->op_next;
3588 SAVECOPLINE(&PL_compiling);
3589 CopLINE_set(&PL_compiling, 0);
3593 /* Store and reset encoding. */
3594 encoding = PL_encoding;
3597 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3598 op = DOCATCH(PL_eval_start);
3600 op = PL_op->op_next;
3602 /* Restore encoding. */
3603 PL_encoding = encoding;
3608 /* This is a op added to hold the hints hash for
3609 pp_entereval. The hash can be modified by the code
3610 being eval'ed, so we return a copy instead. */
3616 mXPUSHs((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv));
3624 register PERL_CONTEXT *cx;
3626 const I32 gimme = GIMME_V;
3627 const I32 was = PL_sub_generation;
3628 char tbuf[TYPE_DIGITS(long) + 12];
3629 char *tmpbuf = tbuf;
3635 HV *saved_hh = NULL;
3636 const char * const fakestr = "_<(eval )";
3637 const int fakelen = 9 + 1;
3639 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3640 saved_hh = (HV*) SvREFCNT_inc(POPs);
3644 TAINT_IF(SvTAINTED(sv));
3645 TAINT_PROPER("eval");
3648 lex_start(sv, NULL, FALSE);
3651 /* switch to eval mode */
3653 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3654 SV * const temp_sv = sv_newmortal();
3655 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3656 (unsigned long)++PL_evalseq,
3657 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3658 tmpbuf = SvPVX(temp_sv);
3659 len = SvCUR(temp_sv);
3662 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3663 SAVECOPFILE_FREE(&PL_compiling);
3664 CopFILE_set(&PL_compiling, tmpbuf+2);
3665 SAVECOPLINE(&PL_compiling);
3666 CopLINE_set(&PL_compiling, 1);
3667 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3668 deleting the eval's FILEGV from the stash before gv_check() runs
3669 (i.e. before run-time proper). To work around the coredump that
3670 ensues, we always turn GvMULTI_on for any globals that were
3671 introduced within evals. See force_ident(). GSAR 96-10-12 */
3672 safestr = savepvn(tmpbuf, len);
3673 SAVEDELETE(PL_defstash, safestr, len);
3675 PL_hints = PL_op->op_targ;
3677 GvHV(PL_hintgv) = saved_hh;
3678 SAVECOMPILEWARNINGS();
3679 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3680 if (PL_compiling.cop_hints_hash) {
3681 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3683 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3684 if (PL_compiling.cop_hints_hash) {
3686 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3687 HINTS_REFCNT_UNLOCK;
3689 /* special case: an eval '' executed within the DB package gets lexically
3690 * placed in the first non-DB CV rather than the current CV - this
3691 * allows the debugger to execute code, find lexicals etc, in the
3692 * scope of the code being debugged. Passing &seq gets find_runcv
3693 * to do the dirty work for us */
3694 runcv = find_runcv(&seq);
3696 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3698 cx->blk_eval.retop = PL_op->op_next;
3700 /* prepare to compile string */
3702 if (PERLDB_LINE && PL_curstash != PL_debstash)
3703 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3705 ok = doeval(gimme, NULL, runcv, seq);
3706 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3708 /* Copy in anything fake and short. */
3709 my_strlcpy(safestr, fakestr, fakelen);
3711 return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3721 register PERL_CONTEXT *cx;
3723 const U8 save_flags = PL_op -> op_flags;
3728 retop = cx->blk_eval.retop;
3731 if (gimme == G_VOID)
3733 else if (gimme == G_SCALAR) {
3736 if (SvFLAGS(TOPs) & SVs_TEMP)
3739 *MARK = sv_mortalcopy(TOPs);
3743 *MARK = &PL_sv_undef;
3748 /* in case LEAVE wipes old return values */
3749 for (mark = newsp + 1; mark <= SP; mark++) {
3750 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3751 *mark = sv_mortalcopy(*mark);
3752 TAINT_NOT; /* Each item is independent */
3756 PL_curpm = newpm; /* Don't pop $1 et al till now */
3759 assert(CvDEPTH(PL_compcv) == 1);
3761 CvDEPTH(PL_compcv) = 0;
3764 if (optype == OP_REQUIRE &&
3765 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3767 /* Unassume the success we assumed earlier. */
3768 SV * const nsv = cx->blk_eval.old_namesv;
3769 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3770 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3771 /* die_where() did LEAVE, or we won't be here */
3775 if (!(save_flags & OPf_SPECIAL))
3776 sv_setpvn(ERRSV,"",0);
3782 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3783 close to the related Perl_create_eval_scope. */
3785 Perl_delete_eval_scope(pTHX)
3790 register PERL_CONTEXT *cx;
3797 PERL_UNUSED_VAR(newsp);
3798 PERL_UNUSED_VAR(gimme);
3799 PERL_UNUSED_VAR(optype);
3802 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3803 also needed by Perl_fold_constants. */
3805 Perl_create_eval_scope(pTHX_ U32 flags)
3808 const I32 gimme = GIMME_V;
3813 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3816 PL_in_eval = EVAL_INEVAL;
3817 if (flags & G_KEEPERR)
3818 PL_in_eval |= EVAL_KEEPERR;
3820 sv_setpvn(ERRSV,"",0);
3821 if (flags & G_FAKINGEVAL) {
3822 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3830 PERL_CONTEXT * const cx = create_eval_scope(0);
3831 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3832 return DOCATCH(PL_op->op_next);
3841 register PERL_CONTEXT *cx;
3846 PERL_UNUSED_VAR(optype);
3849 if (gimme == G_VOID)
3851 else if (gimme == G_SCALAR) {
3855 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3858 *MARK = sv_mortalcopy(TOPs);
3862 *MARK = &PL_sv_undef;
3867 /* in case LEAVE wipes old return values */
3869 for (mark = newsp + 1; mark <= SP; mark++) {
3870 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3871 *mark = sv_mortalcopy(*mark);
3872 TAINT_NOT; /* Each item is independent */
3876 PL_curpm = newpm; /* Don't pop $1 et al till now */
3879 sv_setpvn(ERRSV,"",0);
3886 register PERL_CONTEXT *cx;
3887 const I32 gimme = GIMME_V;
3892 if (PL_op->op_targ == 0) {
3893 SV ** const defsv_p = &GvSV(PL_defgv);
3894 *defsv_p = newSVsv(POPs);
3895 SAVECLEARSV(*defsv_p);
3898 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3900 PUSHBLOCK(cx, CXt_GIVEN, SP);
3909 register PERL_CONTEXT *cx;
3913 PERL_UNUSED_CONTEXT;
3916 assert(CxTYPE(cx) == CXt_GIVEN);
3921 PL_curpm = newpm; /* pop $1 et al */
3928 /* Helper routines used by pp_smartmatch */
3930 S_make_matcher(pTHX_ REGEXP *re)
3933 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3935 PERL_ARGS_ASSERT_MAKE_MATCHER;
3937 PM_SETRE(matcher, ReREFCNT_inc(re));
3939 SAVEFREEOP((OP *) matcher);
3946 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3951 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
3953 PL_op = (OP *) matcher;
3958 return (SvTRUEx(POPs));
3962 S_destroy_matcher(pTHX_ PMOP *matcher)
3966 PERL_ARGS_ASSERT_DESTROY_MATCHER;
3967 PERL_UNUSED_ARG(matcher);
3973 /* Do a smart match */
3976 return do_smartmatch(NULL, NULL);
3979 /* This version of do_smartmatch() implements the
3980 * table of smart matches that is found in perlsyn.
3983 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3988 SV *e = TOPs; /* e is for 'expression' */
3989 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3990 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3991 REGEXP *this_regex, *other_regex;
3993 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3995 # define SM_REF(type) ( \
3996 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3997 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3999 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
4000 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
4001 && NOT_EMPTY_PROTO(This) && (Other = e)) \
4002 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
4003 && NOT_EMPTY_PROTO(This) && (Other = d)))
4005 # define SM_REGEX ( \
4006 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \
4007 && (this_regex = (REGEXP*) This) \
4010 (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \
4011 && (this_regex = (REGEXP*) This) \
4015 # define SM_OBJECT ( \
4016 (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) \
4018 (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) ) \
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);
4052 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4057 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
4059 if (This == SvRV(Other))
4070 c = call_sv(This, G_SCALAR);
4074 else if (SvTEMP(TOPs))
4075 SvREFCNT_inc_void(TOPs);
4080 else if (SM_REF(PVHV)) {
4081 if (SM_OTHER_REF(PVHV)) {
4082 /* Check that the key-sets are identical */
4084 HV *other_hv = (HV *) SvRV(Other);
4086 bool other_tied = FALSE;
4087 U32 this_key_count = 0,
4088 other_key_count = 0;
4090 /* Tied hashes don't know how many keys they have. */
4091 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
4094 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
4095 HV * const temp = other_hv;
4096 other_hv = (HV *) This;
4100 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
4103 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
4106 /* The hashes have the same number of keys, so it suffices
4107 to check that one is a subset of the other. */
4108 (void) hv_iterinit((HV *) This);
4109 while ( (he = hv_iternext((HV *) This)) ) {
4111 char * const key = hv_iterkey(he, &key_len);
4115 if(!hv_exists(other_hv, key, key_len)) {
4116 (void) hv_iterinit((HV *) This); /* reset iterator */
4122 (void) hv_iterinit(other_hv);
4123 while ( hv_iternext(other_hv) )
4127 other_key_count = HvUSEDKEYS(other_hv);
4129 if (this_key_count != other_key_count)
4134 else if (SM_OTHER_REF(PVAV)) {
4135 AV * const other_av = (AV *) SvRV(Other);
4136 const I32 other_len = av_len(other_av) + 1;
4139 for (i = 0; i < other_len; ++i) {
4140 SV ** const svp = av_fetch(other_av, i, FALSE);
4144 if (svp) { /* ??? When can this not happen? */
4145 key = SvPV(*svp, key_len);
4146 if (hv_exists((HV *) This, key, key_len))
4152 else if (SM_OTHER_REGEX) {
4153 PMOP * const matcher = make_matcher(other_regex);
4156 (void) hv_iterinit((HV *) This);
4157 while ( (he = hv_iternext((HV *) This)) ) {
4158 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4159 (void) hv_iterinit((HV *) This);
4160 destroy_matcher(matcher);
4164 destroy_matcher(matcher);
4168 if (hv_exists_ent((HV *) This, Other, 0))
4174 else if (SM_REF(PVAV)) {
4175 if (SM_OTHER_REF(PVAV)) {
4176 AV *other_av = (AV *) SvRV(Other);
4177 if (av_len((AV *) This) != av_len(other_av))
4181 const I32 other_len = av_len(other_av);
4183 if (NULL == seen_this) {
4184 seen_this = newHV();
4185 (void) sv_2mortal((SV *) seen_this);
4187 if (NULL == seen_other) {
4188 seen_this = newHV();
4189 (void) sv_2mortal((SV *) seen_other);
4191 for(i = 0; i <= other_len; ++i) {
4192 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4193 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4195 if (!this_elem || !other_elem) {
4196 if (this_elem || other_elem)
4199 else if (SM_SEEN_THIS(*this_elem)
4200 || SM_SEEN_OTHER(*other_elem))
4202 if (*this_elem != *other_elem)
4206 (void)hv_store_ent(seen_this,
4207 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4209 (void)hv_store_ent(seen_other,
4210 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4216 (void) do_smartmatch(seen_this, seen_other);
4226 else if (SM_OTHER_REGEX) {
4227 PMOP * const matcher = make_matcher(other_regex);
4228 const I32 this_len = av_len((AV *) This);
4231 for(i = 0; i <= this_len; ++i) {
4232 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4233 if (svp && matcher_matches_sv(matcher, *svp)) {
4234 destroy_matcher(matcher);
4238 destroy_matcher(matcher);
4241 else if (SvIOK(Other) || SvNOK(Other)) {
4244 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4245 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4252 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4262 else if (SvPOK(Other)) {
4263 const I32 this_len = av_len((AV *) This);
4266 for(i = 0; i <= this_len; ++i) {
4267 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4282 else if (!SvOK(d) || !SvOK(e)) {
4283 if (!SvOK(d) && !SvOK(e))
4288 else if (SM_REGEX) {
4289 PMOP * const matcher = make_matcher(this_regex);
4292 PUSHs(matcher_matches_sv(matcher, Other)
4295 destroy_matcher(matcher);
4298 else if (SM_REF(PVCV)) {
4300 /* This must be a null-prototyped sub, because we
4301 already checked for the other kind. */
4307 c = call_sv(This, G_SCALAR);
4310 PUSHs(&PL_sv_undef);
4311 else if (SvTEMP(TOPs))
4312 SvREFCNT_inc_void(TOPs);
4314 if (SM_OTHER_REF(PVCV)) {
4315 /* This one has to be null-proto'd too.
4316 Call both of 'em, and compare the results */
4318 c = call_sv(SvRV(Other), G_SCALAR);
4321 PUSHs(&PL_sv_undef);
4322 else if (SvTEMP(TOPs))
4323 SvREFCNT_inc_void(TOPs);
4334 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4335 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4337 if (SvPOK(Other) && !looks_like_number(Other)) {
4338 /* String comparison */
4343 /* Otherwise, numeric comparison */
4346 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4357 /* As a last resort, use string comparison */
4366 register PERL_CONTEXT *cx;
4367 const I32 gimme = GIMME_V;
4369 /* This is essentially an optimization: if the match
4370 fails, we don't want to push a context and then
4371 pop it again right away, so we skip straight
4372 to the op that follows the leavewhen.
4374 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4375 return cLOGOP->op_other->op_next;
4380 PUSHBLOCK(cx, CXt_WHEN, SP);
4389 register PERL_CONTEXT *cx;
4395 assert(CxTYPE(cx) == CXt_WHEN);
4400 PL_curpm = newpm; /* pop $1 et al */
4410 register PERL_CONTEXT *cx;
4413 cxix = dopoptowhen(cxstack_ix);
4415 DIE(aTHX_ "Can't \"continue\" outside a when block");
4416 if (cxix < cxstack_ix)
4419 /* clear off anything above the scope we're re-entering */
4420 inner = PL_scopestack_ix;
4422 if (PL_scopestack_ix < inner)
4423 leave_scope(PL_scopestack[PL_scopestack_ix]);
4424 PL_curcop = cx->blk_oldcop;
4425 return cx->blk_givwhen.leave_op;
4432 register PERL_CONTEXT *cx;
4435 cxix = dopoptogiven(cxstack_ix);
4437 if (PL_op->op_flags & OPf_SPECIAL)
4438 DIE(aTHX_ "Can't use when() outside a topicalizer");
4440 DIE(aTHX_ "Can't \"break\" outside a given block");
4442 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4443 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4445 if (cxix < cxstack_ix)
4448 /* clear off anything above the scope we're re-entering */
4449 inner = PL_scopestack_ix;
4451 if (PL_scopestack_ix < inner)
4452 leave_scope(PL_scopestack[PL_scopestack_ix]);
4453 PL_curcop = cx->blk_oldcop;
4456 return CX_LOOP_NEXTOP_GET(cx);
4458 return cx->blk_givwhen.leave_op;
4462 S_doparseform(pTHX_ SV *sv)
4465 register char *s = SvPV_force(sv, len);
4466 register char * const send = s + len;
4467 register char *base = NULL;
4468 register I32 skipspaces = 0;
4469 bool noblank = FALSE;
4470 bool repeat = FALSE;
4471 bool postspace = FALSE;
4477 bool unchopnum = FALSE;
4478 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4480 PERL_ARGS_ASSERT_DOPARSEFORM;
4483 Perl_croak(aTHX_ "Null picture in formline");
4485 /* estimate the buffer size needed */
4486 for (base = s; s <= send; s++) {
4487 if (*s == '\n' || *s == '@' || *s == '^')
4493 Newx(fops, maxops, U32);
4498 *fpc++ = FF_LINEMARK;
4499 noblank = repeat = FALSE;
4517 case ' ': case '\t':
4524 } /* else FALL THROUGH */
4532 *fpc++ = FF_LITERAL;
4540 *fpc++ = (U16)skipspaces;
4544 *fpc++ = FF_NEWLINE;
4548 arg = fpc - linepc + 1;
4555 *fpc++ = FF_LINEMARK;
4556 noblank = repeat = FALSE;
4565 ischop = s[-1] == '^';
4571 arg = (s - base) - 1;
4573 *fpc++ = FF_LITERAL;
4581 *fpc++ = 2; /* skip the @* or ^* */
4583 *fpc++ = FF_LINESNGL;
4586 *fpc++ = FF_LINEGLOB;
4588 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4589 arg = ischop ? 512 : 0;
4594 const char * const f = ++s;
4597 arg |= 256 + (s - f);
4599 *fpc++ = s - base; /* fieldsize for FETCH */
4600 *fpc++ = FF_DECIMAL;
4602 unchopnum |= ! ischop;
4604 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4605 arg = ischop ? 512 : 0;
4607 s++; /* skip the '0' first */
4611 const char * const f = ++s;
4614 arg |= 256 + (s - f);
4616 *fpc++ = s - base; /* fieldsize for FETCH */
4617 *fpc++ = FF_0DECIMAL;
4619 unchopnum |= ! ischop;
4623 bool ismore = FALSE;
4626 while (*++s == '>') ;
4627 prespace = FF_SPACE;
4629 else if (*s == '|') {
4630 while (*++s == '|') ;
4631 prespace = FF_HALFSPACE;
4636 while (*++s == '<') ;
4639 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4643 *fpc++ = s - base; /* fieldsize for FETCH */
4645 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4648 *fpc++ = (U16)prespace;
4662 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4664 { /* need to jump to the next word */
4666 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4667 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4668 s = SvPVX(sv) + SvCUR(sv) + z;
4670 Copy(fops, s, arg, U32);
4672 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4675 if (unchopnum && repeat)
4676 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4682 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4684 /* Can value be printed in fldsize chars, using %*.*f ? */
4688 int intsize = fldsize - (value < 0 ? 1 : 0);
4695 while (intsize--) pwr *= 10.0;
4696 while (frcsize--) eps /= 10.0;
4699 if (value + eps >= pwr)
4702 if (value - eps <= -pwr)
4709 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4712 SV * const datasv = FILTER_DATA(idx);
4713 const int filter_has_file = IoLINES(datasv);
4714 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4715 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4719 const char *got_p = NULL;
4720 const char *prune_from = NULL;
4721 bool read_from_cache = FALSE;
4724 PERL_ARGS_ASSERT_RUN_USER_FILTER;
4726 assert(maxlen >= 0);
4729 /* I was having segfault trouble under Linux 2.2.5 after a
4730 parse error occured. (Had to hack around it with a test
4731 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4732 not sure where the trouble is yet. XXX */
4734 if (IoFMT_GV(datasv)) {
4735 SV *const cache = (SV *)IoFMT_GV(datasv);
4738 const char *cache_p = SvPV(cache, cache_len);
4742 /* Running in block mode and we have some cached data already.
4744 if (cache_len >= umaxlen) {
4745 /* In fact, so much data we don't even need to call
4750 const char *const first_nl =
4751 (const char *)memchr(cache_p, '\n', cache_len);
4753 take = first_nl + 1 - cache_p;
4757 sv_catpvn(buf_sv, cache_p, take);
4758 sv_chop(cache, cache_p + take);
4759 /* Definately not EOF */
4763 sv_catsv(buf_sv, cache);
4765 umaxlen -= cache_len;
4768 read_from_cache = TRUE;
4772 /* Filter API says that the filter appends to the contents of the buffer.
4773 Usually the buffer is "", so the details don't matter. But if it's not,
4774 then clearly what it contains is already filtered by this filter, so we
4775 don't want to pass it in a second time.
4776 I'm going to use a mortal in case the upstream filter croaks. */
4777 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4778 ? sv_newmortal() : buf_sv;
4779 SvUPGRADE(upstream, SVt_PV);
4781 if (filter_has_file) {
4782 status = FILTER_READ(idx+1, upstream, 0);
4785 if (filter_sub && status >= 0) {
4798 PUSHs(filter_state);
4801 count = call_sv(filter_sub, G_SCALAR);
4816 if(SvOK(upstream)) {
4817 got_p = SvPV(upstream, got_len);
4819 if (got_len > umaxlen) {
4820 prune_from = got_p + umaxlen;
4823 const char *const first_nl =
4824 (const char *)memchr(got_p, '\n', got_len);
4825 if (first_nl && first_nl + 1 < got_p + got_len) {
4826 /* There's a second line here... */
4827 prune_from = first_nl + 1;
4832 /* Oh. Too long. Stuff some in our cache. */
4833 STRLEN cached_len = got_p + got_len - prune_from;
4834 SV *cache = (SV *)IoFMT_GV(datasv);
4837 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4838 } else if (SvOK(cache)) {
4839 /* Cache should be empty. */
4840 assert(!SvCUR(cache));
4843 sv_setpvn(cache, prune_from, cached_len);
4844 /* If you ask for block mode, you may well split UTF-8 characters.
4845 "If it breaks, you get to keep both parts"
4846 (Your code is broken if you don't put them back together again
4847 before something notices.) */
4848 if (SvUTF8(upstream)) {
4851 SvCUR_set(upstream, got_len - cached_len);
4852 /* Can't yet be EOF */
4857 /* If they are at EOF but buf_sv has something in it, then they may never
4858 have touched the SV upstream, so it may be undefined. If we naively
4859 concatenate it then we get a warning about use of uninitialised value.
4861 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4862 sv_catsv(buf_sv, upstream);
4866 IoLINES(datasv) = 0;
4867 SvREFCNT_dec(IoFMT_GV(datasv));
4869 SvREFCNT_dec(filter_state);
4870 IoTOP_GV(datasv) = NULL;
4873 SvREFCNT_dec(filter_sub);
4874 IoBOTTOM_GV(datasv) = NULL;
4876 filter_del(S_run_user_filter);
4878 if (status == 0 && read_from_cache) {
4879 /* If we read some data from the cache (and by getting here it implies
4880 that we emptied the cache) then we aren't yet at EOF, and mustn't
4881 report that to our caller. */
4887 /* perhaps someone can come up with a better name for
4888 this? it is not really "absolute", per se ... */
4890 S_path_is_absolute(const char *name)
4892 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
4894 if (PERL_FILE_IS_ABSOLUTE(name)
4895 #ifdef MACOS_TRADITIONAL
4898 || (*name == '.' && (name[1] == '/' ||
4899 (name[1] == '.' && name[2] == '/')))
4911 * c-indentation-style: bsd
4913 * indent-tabs-mode: t
4916 * ex: set ts=8 sts=4 sw=4 noet: