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) : "";
132 /* Check against the last compiled regexp. */
133 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != (I32)len ||
134 memNE(RX_PRECOMP(re), t, len))
136 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
137 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
140 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
141 } else if (PL_curcop->cop_hints_hash) {
142 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
144 if (ptr && SvIOK(ptr) && SvIV(ptr))
145 eng = INT2PTR(regexp_engine*,SvIV(ptr));
148 if (PL_op->op_flags & OPf_SPECIAL)
149 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
151 if (DO_UTF8(tmpstr)) {
152 assert (SvUTF8(tmpstr));
153 } else if (SvUTF8(tmpstr)) {
154 /* Not doing UTF-8, despite what the SV says. Is this only if
155 we're trapped in use 'bytes'? */
156 /* Make a copy of the octet sequence, but without the flag on,
157 as the compiler now honours the SvUTF8 flag on tmpstr. */
159 const char *const p = SvPV(tmpstr, len);
160 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
162 assert(!(pm_flags & RXf_UTF8));
165 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
167 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
169 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
170 inside tie/overload accessors. */
176 #ifndef INCOMPLETE_TAINTS
179 RX_EXTFLAGS(re) |= RXf_TAINTED;
181 RX_EXTFLAGS(re) &= ~RXf_TAINTED;
185 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
189 #if !defined(USE_ITHREADS)
190 /* can't change the optree at runtime either */
191 /* PMf_KEEP is handled differently under threads to avoid these problems */
192 if (pm->op_pmflags & PMf_KEEP) {
193 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
194 cLOGOP->op_first->op_next = PL_op->op_next;
204 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
205 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
206 register SV * const dstr = cx->sb_dstr;
207 register char *s = cx->sb_s;
208 register char *m = cx->sb_m;
209 char *orig = cx->sb_orig;
210 register REGEXP * const rx = cx->sb_rx;
212 REGEXP *old = PM_GETRE(pm);
216 PM_SETRE(pm,ReREFCNT_inc(rx));
219 rxres_restore(&cx->sb_rxres, rx);
220 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
222 if (cx->sb_iters++) {
223 const I32 saviters = cx->sb_iters;
224 if (cx->sb_iters > cx->sb_maxiters)
225 DIE(aTHX_ "Substitution loop");
227 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
228 cx->sb_rxtainted |= 2;
229 sv_catsv(dstr, POPs);
230 FREETMPS; /* Prevent excess tmp stack */
233 if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
234 s == m, cx->sb_targ, NULL,
235 ((cx->sb_rflags & REXEC_COPY_STR)
236 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
237 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
239 SV * const targ = cx->sb_targ;
241 assert(cx->sb_strend >= s);
242 if(cx->sb_strend > s) {
243 if (DO_UTF8(dstr) && !SvUTF8(targ))
244 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
246 sv_catpvn(dstr, s, cx->sb_strend - s);
248 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
250 #ifdef PERL_OLD_COPY_ON_WRITE
252 sv_force_normal_flags(targ, SV_COW_DROP_PV);
258 SvPV_set(targ, SvPVX(dstr));
259 SvCUR_set(targ, SvCUR(dstr));
260 SvLEN_set(targ, SvLEN(dstr));
263 SvPV_set(dstr, NULL);
265 TAINT_IF(cx->sb_rxtainted & 1);
266 mPUSHi(saviters - 1);
268 (void)SvPOK_only_UTF8(targ);
269 TAINT_IF(cx->sb_rxtainted);
273 LEAVE_SCOPE(cx->sb_oldsave);
275 RETURNOP(pm->op_next);
277 cx->sb_iters = saviters;
279 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
282 cx->sb_orig = orig = RX_SUBBEG(rx);
284 cx->sb_strend = s + (cx->sb_strend - m);
286 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
288 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
289 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
291 sv_catpvn(dstr, s, m-s);
293 cx->sb_s = RX_OFFS(rx)[0].end + orig;
294 { /* Update the pos() information. */
295 SV * const sv = cx->sb_targ;
298 SvUPGRADE(sv, SVt_PVMG);
299 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
300 #ifdef PERL_OLD_COPY_ON_WRITE
302 sv_force_normal_flags(sv, 0);
304 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
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)
326 if (!p || p[1] < RX_NPARENS(rx)) {
327 #ifdef PERL_OLD_COPY_ON_WRITE
328 i = 7 + RX_NPARENS(rx) * 2;
330 i = 6 + RX_NPARENS(rx) * 2;
339 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
340 RX_MATCH_COPIED_off(rx);
342 #ifdef PERL_OLD_COPY_ON_WRITE
343 *p++ = PTR2UV(RX_SAVED_COPY(rx));
344 RX_SAVED_COPY(rx) = NULL;
347 *p++ = RX_NPARENS(rx);
349 *p++ = PTR2UV(RX_SUBBEG(rx));
350 *p++ = (UV)RX_SUBLEN(rx);
351 for (i = 0; i <= RX_NPARENS(rx); ++i) {
352 *p++ = (UV)RX_OFFS(rx)[i].start;
353 *p++ = (UV)RX_OFFS(rx)[i].end;
358 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
364 RX_MATCH_COPY_FREE(rx);
365 RX_MATCH_COPIED_set(rx, *p);
368 #ifdef PERL_OLD_COPY_ON_WRITE
369 if (RX_SAVED_COPY(rx))
370 SvREFCNT_dec (RX_SAVED_COPY(rx));
371 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
375 RX_NPARENS(rx) = *p++;
377 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
378 RX_SUBLEN(rx) = (I32)(*p++);
379 for (i = 0; i <= RX_NPARENS(rx); ++i) {
380 RX_OFFS(rx)[i].start = (I32)(*p++);
381 RX_OFFS(rx)[i].end = (I32)(*p++);
386 Perl_rxres_free(pTHX_ void **rsp)
388 UV * const p = (UV*)*rsp;
393 void *tmp = INT2PTR(char*,*p);
396 PoisonFree(*p, 1, sizeof(*p));
398 Safefree(INT2PTR(char*,*p));
400 #ifdef PERL_OLD_COPY_ON_WRITE
402 SvREFCNT_dec (INT2PTR(SV*,p[1]));
412 dVAR; dSP; dMARK; dORIGMARK;
413 register SV * const tmpForm = *++MARK;
418 register SV *sv = NULL;
419 const char *item = NULL;
423 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
424 const char *chophere = NULL;
425 char *linemark = NULL;
427 bool gotsome = FALSE;
429 const STRLEN fudge = SvPOK(tmpForm)
430 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
431 bool item_is_utf8 = FALSE;
432 bool targ_is_utf8 = FALSE;
434 OP * parseres = NULL;
438 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
439 if (SvREADONLY(tmpForm)) {
440 SvREADONLY_off(tmpForm);
441 parseres = doparseform(tmpForm);
442 SvREADONLY_on(tmpForm);
445 parseres = doparseform(tmpForm);
449 SvPV_force(PL_formtarget, len);
450 if (DO_UTF8(PL_formtarget))
452 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
454 f = SvPV_const(tmpForm, len);
455 /* need to jump to the next word */
456 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
460 const char *name = "???";
463 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
464 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
465 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
466 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
467 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
469 case FF_CHECKNL: name = "CHECKNL"; break;
470 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
471 case FF_SPACE: name = "SPACE"; break;
472 case FF_HALFSPACE: name = "HALFSPACE"; break;
473 case FF_ITEM: name = "ITEM"; break;
474 case FF_CHOP: name = "CHOP"; break;
475 case FF_LINEGLOB: name = "LINEGLOB"; break;
476 case FF_NEWLINE: name = "NEWLINE"; break;
477 case FF_MORE: name = "MORE"; break;
478 case FF_LINEMARK: name = "LINEMARK"; break;
479 case FF_END: name = "END"; break;
480 case FF_0DECIMAL: name = "0DECIMAL"; break;
481 case FF_LINESNGL: name = "LINESNGL"; break;
484 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
486 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
497 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
498 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
500 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
501 t = SvEND(PL_formtarget);
504 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
505 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
507 sv_utf8_upgrade(PL_formtarget);
508 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
509 t = SvEND(PL_formtarget);
529 if (ckWARN(WARN_SYNTAX))
530 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
537 const char *s = item = SvPV_const(sv, len);
540 itemsize = sv_len_utf8(sv);
541 if (itemsize != (I32)len) {
543 if (itemsize > fieldsize) {
544 itemsize = fieldsize;
545 itembytes = itemsize;
546 sv_pos_u2b(sv, &itembytes, 0);
550 send = chophere = s + itembytes;
560 sv_pos_b2u(sv, &itemsize);
564 item_is_utf8 = FALSE;
565 if (itemsize > fieldsize)
566 itemsize = fieldsize;
567 send = chophere = s + itemsize;
581 const char *s = item = SvPV_const(sv, len);
584 itemsize = sv_len_utf8(sv);
585 if (itemsize != (I32)len) {
587 if (itemsize <= fieldsize) {
588 const char *send = chophere = s + itemsize;
601 itemsize = fieldsize;
602 itembytes = itemsize;
603 sv_pos_u2b(sv, &itembytes, 0);
604 send = chophere = s + itembytes;
605 while (s < send || (s == send && isSPACE(*s))) {
615 if (strchr(PL_chopset, *s))
620 itemsize = chophere - item;
621 sv_pos_b2u(sv, &itemsize);
627 item_is_utf8 = FALSE;
628 if (itemsize <= fieldsize) {
629 const char *const send = chophere = s + itemsize;
642 itemsize = fieldsize;
643 send = chophere = s + itemsize;
644 while (s < send || (s == send && isSPACE(*s))) {
654 if (strchr(PL_chopset, *s))
659 itemsize = chophere - item;
665 arg = fieldsize - itemsize;
674 arg = fieldsize - itemsize;
685 const char *s = item;
689 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
691 sv_utf8_upgrade(PL_formtarget);
692 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
693 t = SvEND(PL_formtarget);
697 if (UTF8_IS_CONTINUED(*s)) {
698 STRLEN skip = UTF8SKIP(s);
715 if ( !((*t++ = *s++) & ~31) )
721 if (targ_is_utf8 && !item_is_utf8) {
722 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
724 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
725 for (; t < SvEND(PL_formtarget); t++) {
738 const int ch = *t++ = *s++;
741 if ( !((*t++ = *s++) & ~31) )
750 const char *s = chophere;
768 const char *s = item = SvPV_const(sv, len);
770 if ((item_is_utf8 = DO_UTF8(sv)))
771 itemsize = sv_len_utf8(sv);
773 bool chopped = FALSE;
774 const char *const send = s + len;
776 chophere = s + itemsize;
792 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
794 SvUTF8_on(PL_formtarget);
796 SvCUR_set(sv, chophere - item);
797 sv_catsv(PL_formtarget, sv);
798 SvCUR_set(sv, itemsize);
800 sv_catsv(PL_formtarget, sv);
802 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
803 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
804 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
813 #if defined(USE_LONG_DOUBLE)
816 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
820 "%#0*.*f" : "%0*.*f");
825 #if defined(USE_LONG_DOUBLE)
827 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
830 ((arg & 256) ? "%#*.*f" : "%*.*f");
833 /* If the field is marked with ^ and the value is undefined,
835 if ((arg & 512) && !SvOK(sv)) {
843 /* overflow evidence */
844 if (num_overflow(value, fieldsize, arg)) {
850 /* Formats aren't yet marked for locales, so assume "yes". */
852 STORE_NUMERIC_STANDARD_SET_LOCAL();
853 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
854 RESTORE_NUMERIC_STANDARD();
861 while (t-- > linemark && *t == ' ') ;
869 if (arg) { /* repeat until fields exhausted? */
871 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
872 lines += FmLINES(PL_formtarget);
875 if (strnEQ(linemark, linemark - arg, arg))
876 DIE(aTHX_ "Runaway format");
879 SvUTF8_on(PL_formtarget);
880 FmLINES(PL_formtarget) = lines;
882 RETURNOP(cLISTOP->op_first);
893 const char *s = chophere;
894 const char *send = item + len;
896 while (isSPACE(*s) && (s < send))
901 arg = fieldsize - itemsize;
908 if (strnEQ(s1," ",3)) {
909 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
920 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
922 SvUTF8_on(PL_formtarget);
923 FmLINES(PL_formtarget) += lines;
935 if (PL_stack_base + *PL_markstack_ptr == SP) {
937 if (GIMME_V == G_SCALAR)
939 RETURNOP(PL_op->op_next->op_next);
941 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
942 pp_pushmark(); /* push dst */
943 pp_pushmark(); /* push src */
944 ENTER; /* enter outer scope */
947 if (PL_op->op_private & OPpGREP_LEX)
948 SAVESPTR(PAD_SVl(PL_op->op_targ));
951 ENTER; /* enter inner scope */
954 src = PL_stack_base[*PL_markstack_ptr];
956 if (PL_op->op_private & OPpGREP_LEX)
957 PAD_SVl(PL_op->op_targ) = src;
962 if (PL_op->op_type == OP_MAPSTART)
963 pp_pushmark(); /* push top */
964 return ((LOGOP*)PL_op->op_next)->op_other;
970 const I32 gimme = GIMME_V;
971 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
977 /* first, move source pointer to the next item in the source list */
978 ++PL_markstack_ptr[-1];
980 /* if there are new items, push them into the destination list */
981 if (items && gimme != G_VOID) {
982 /* might need to make room back there first */
983 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
984 /* XXX this implementation is very pessimal because the stack
985 * is repeatedly extended for every set of items. Is possible
986 * to do this without any stack extension or copying at all
987 * by maintaining a separate list over which the map iterates
988 * (like foreach does). --gsar */
990 /* everything in the stack after the destination list moves
991 * towards the end the stack by the amount of room needed */
992 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
994 /* items to shift up (accounting for the moved source pointer) */
995 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
997 /* This optimization is by Ben Tilly and it does
998 * things differently from what Sarathy (gsar)
999 * is describing. The downside of this optimization is
1000 * that leaves "holes" (uninitialized and hopefully unused areas)
1001 * to the Perl stack, but on the other hand this
1002 * shouldn't be a problem. If Sarathy's idea gets
1003 * implemented, this optimization should become
1004 * irrelevant. --jhi */
1006 shift = count; /* Avoid shifting too often --Ben Tilly */
1010 dst = (SP += shift);
1011 PL_markstack_ptr[-1] += shift;
1012 *PL_markstack_ptr += shift;
1016 /* copy the new items down to the destination list */
1017 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1018 if (gimme == G_ARRAY) {
1020 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1023 /* scalar context: we don't care about which values map returns
1024 * (we use undef here). And so we certainly don't want to do mortal
1025 * copies of meaningless values. */
1026 while (items-- > 0) {
1028 *dst-- = &PL_sv_undef;
1032 LEAVE; /* exit inner scope */
1035 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1037 (void)POPMARK; /* pop top */
1038 LEAVE; /* exit outer scope */
1039 (void)POPMARK; /* pop src */
1040 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1041 (void)POPMARK; /* pop dst */
1042 SP = PL_stack_base + POPMARK; /* pop original mark */
1043 if (gimme == G_SCALAR) {
1044 if (PL_op->op_private & OPpGREP_LEX) {
1045 SV* sv = sv_newmortal();
1046 sv_setiv(sv, items);
1054 else if (gimme == G_ARRAY)
1061 ENTER; /* enter inner scope */
1064 /* set $_ to the new source item */
1065 src = PL_stack_base[PL_markstack_ptr[-1]];
1067 if (PL_op->op_private & OPpGREP_LEX)
1068 PAD_SVl(PL_op->op_targ) = src;
1072 RETURNOP(cLOGOP->op_other);
1081 if (GIMME == G_ARRAY)
1083 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1084 return cLOGOP->op_other;
1094 if (GIMME == G_ARRAY) {
1095 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1099 SV * const targ = PAD_SV(PL_op->op_targ);
1102 if (PL_op->op_private & OPpFLIP_LINENUM) {
1103 if (GvIO(PL_last_in_gv)) {
1104 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1107 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1109 flip = SvIV(sv) == SvIV(GvSV(gv));
1115 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1116 if (PL_op->op_flags & OPf_SPECIAL) {
1124 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1127 sv_setpvn(TARG, "", 0);
1133 /* This code tries to decide if "$left .. $right" should use the
1134 magical string increment, or if the range is numeric (we make
1135 an exception for .."0" [#18165]). AMS 20021031. */
1137 #define RANGE_IS_NUMERIC(left,right) ( \
1138 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1139 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1140 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1141 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1142 && (!SvOK(right) || looks_like_number(right))))
1148 if (GIMME == G_ARRAY) {
1154 if (RANGE_IS_NUMERIC(left,right)) {
1157 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1158 (SvOK(right) && SvNV(right) > IV_MAX))
1159 DIE(aTHX_ "Range iterator outside integer range");
1170 SV * const sv = sv_2mortal(newSViv(i++));
1175 SV * const final = sv_mortalcopy(right);
1177 const char * const tmps = SvPV_const(final, len);
1179 SV *sv = sv_mortalcopy(left);
1180 SvPV_force_nolen(sv);
1181 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1183 if (strEQ(SvPVX_const(sv),tmps))
1185 sv = sv_2mortal(newSVsv(sv));
1192 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1196 if (PL_op->op_private & OPpFLIP_LINENUM) {
1197 if (GvIO(PL_last_in_gv)) {
1198 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1201 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1202 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1210 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1211 sv_catpvs(targ, "E0");
1221 static const char * const context_name[] = {
1234 S_dopoptolabel(pTHX_ const char *label)
1239 for (i = cxstack_ix; i >= 0; i--) {
1240 register const PERL_CONTEXT * const cx = &cxstack[i];
1241 switch (CxTYPE(cx)) {
1249 if (ckWARN(WARN_EXITING))
1250 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1251 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1252 if (CxTYPE(cx) == CXt_NULL)
1256 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1257 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1258 (long)i, cx->blk_loop.label));
1261 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1271 Perl_dowantarray(pTHX)
1274 const I32 gimme = block_gimme();
1275 return (gimme == G_VOID) ? G_SCALAR : gimme;
1279 Perl_block_gimme(pTHX)
1282 const I32 cxix = dopoptosub(cxstack_ix);
1286 switch (cxstack[cxix].blk_gimme) {
1294 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1301 Perl_is_lvalue_sub(pTHX)
1304 const I32 cxix = dopoptosub(cxstack_ix);
1305 assert(cxix >= 0); /* We should only be called from inside subs */
1307 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1308 return cxstack[cxix].blk_sub.lval;
1314 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1318 for (i = startingblock; i >= 0; i--) {
1319 register const PERL_CONTEXT * const cx = &cxstk[i];
1320 switch (CxTYPE(cx)) {
1326 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1334 S_dopoptoeval(pTHX_ I32 startingblock)
1338 for (i = startingblock; i >= 0; i--) {
1339 register const PERL_CONTEXT *cx = &cxstack[i];
1340 switch (CxTYPE(cx)) {
1344 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1352 S_dopoptoloop(pTHX_ I32 startingblock)
1356 for (i = startingblock; i >= 0; i--) {
1357 register const PERL_CONTEXT * const cx = &cxstack[i];
1358 switch (CxTYPE(cx)) {
1364 if (ckWARN(WARN_EXITING))
1365 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1366 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1367 if ((CxTYPE(cx)) == CXt_NULL)
1371 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1379 S_dopoptogiven(pTHX_ I32 startingblock)
1383 for (i = startingblock; i >= 0; i--) {
1384 register const PERL_CONTEXT *cx = &cxstack[i];
1385 switch (CxTYPE(cx)) {
1389 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1392 if (CxFOREACHDEF(cx)) {
1393 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1402 S_dopoptowhen(pTHX_ I32 startingblock)
1406 for (i = startingblock; i >= 0; i--) {
1407 register const PERL_CONTEXT *cx = &cxstack[i];
1408 switch (CxTYPE(cx)) {
1412 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1420 Perl_dounwind(pTHX_ I32 cxix)
1425 while (cxstack_ix > cxix) {
1427 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1428 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1429 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1430 /* Note: we don't need to restore the base context info till the end. */
1431 switch (CxTYPE(cx)) {
1434 continue; /* not break */
1453 PERL_UNUSED_VAR(optype);
1457 Perl_qerror(pTHX_ SV *err)
1461 sv_catsv(ERRSV, err);
1463 sv_catsv(PL_errors, err);
1465 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1467 ++PL_parser->error_count;
1471 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1480 if (PL_in_eval & EVAL_KEEPERR) {
1481 static const char prefix[] = "\t(in cleanup) ";
1482 SV * const err = ERRSV;
1483 const char *e = NULL;
1485 sv_setpvn(err,"",0);
1486 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1488 e = SvPV_const(err, len);
1490 if (*e != *message || strNE(e,message))
1494 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1495 sv_catpvn(err, prefix, sizeof(prefix)-1);
1496 sv_catpvn(err, message, msglen);
1497 if (ckWARN(WARN_MISC)) {
1498 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1499 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1504 sv_setpvn(ERRSV, message, msglen);
1508 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1509 && PL_curstackinfo->si_prev)
1517 register PERL_CONTEXT *cx;
1520 if (cxix < cxstack_ix)
1523 POPBLOCK(cx,PL_curpm);
1524 if (CxTYPE(cx) != CXt_EVAL) {
1526 message = SvPVx_const(ERRSV, msglen);
1527 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1528 PerlIO_write(Perl_error_log, message, msglen);
1533 if (gimme == G_SCALAR)
1534 *++newsp = &PL_sv_undef;
1535 PL_stack_sp = newsp;
1539 /* LEAVE could clobber PL_curcop (see save_re_context())
1540 * XXX it might be better to find a way to avoid messing with
1541 * PL_curcop in save_re_context() instead, but this is a more
1542 * minimal fix --GSAR */
1543 PL_curcop = cx->blk_oldcop;
1545 if (optype == OP_REQUIRE) {
1546 const char* const msg = SvPVx_nolen_const(ERRSV);
1547 SV * const nsv = cx->blk_eval.old_namesv;
1548 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1550 DIE(aTHX_ "%sCompilation failed in require",
1551 *msg ? msg : "Unknown error\n");
1553 assert(CxTYPE(cx) == CXt_EVAL);
1554 return cx->blk_eval.retop;
1558 message = SvPVx_const(ERRSV, msglen);
1560 write_to_stderr(message, msglen);
1568 dVAR; dSP; dPOPTOPssrl;
1569 if (SvTRUE(left) != SvTRUE(right))
1579 register I32 cxix = dopoptosub(cxstack_ix);
1580 register const PERL_CONTEXT *cx;
1581 register const PERL_CONTEXT *ccstack = cxstack;
1582 const PERL_SI *top_si = PL_curstackinfo;
1584 const char *stashname;
1591 /* we may be in a higher stacklevel, so dig down deeper */
1592 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1593 top_si = top_si->si_prev;
1594 ccstack = top_si->si_cxstack;
1595 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1598 if (GIMME != G_ARRAY) {
1604 /* caller() should not report the automatic calls to &DB::sub */
1605 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1606 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1610 cxix = dopoptosub_at(ccstack, cxix - 1);
1613 cx = &ccstack[cxix];
1614 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1615 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1616 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1617 field below is defined for any cx. */
1618 /* caller() should not report the automatic calls to &DB::sub */
1619 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1620 cx = &ccstack[dbcxix];
1623 stashname = CopSTASHPV(cx->blk_oldcop);
1624 if (GIMME != G_ARRAY) {
1627 PUSHs(&PL_sv_undef);
1630 sv_setpv(TARG, stashname);
1639 PUSHs(&PL_sv_undef);
1641 mPUSHs(newSVpv(stashname, 0));
1642 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1643 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1646 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1647 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1648 /* So is ccstack[dbcxix]. */
1650 SV * const sv = newSV(0);
1651 gv_efullname3(sv, cvgv, NULL);
1653 mPUSHi((I32)cx->blk_sub.hasargs);
1656 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1657 mPUSHi((I32)cx->blk_sub.hasargs);
1661 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1664 gimme = (I32)cx->blk_gimme;
1665 if (gimme == G_VOID)
1666 PUSHs(&PL_sv_undef);
1668 mPUSHi(gimme & G_ARRAY);
1669 if (CxTYPE(cx) == CXt_EVAL) {
1671 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1672 PUSHs(cx->blk_eval.cur_text);
1676 else if (cx->blk_eval.old_namesv) {
1677 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1680 /* eval BLOCK (try blocks have old_namesv == 0) */
1682 PUSHs(&PL_sv_undef);
1683 PUSHs(&PL_sv_undef);
1687 PUSHs(&PL_sv_undef);
1688 PUSHs(&PL_sv_undef);
1690 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1691 && CopSTASH_eq(PL_curcop, PL_debstash))
1693 AV * const ary = cx->blk_sub.argarray;
1694 const int off = AvARRAY(ary) - AvALLOC(ary);
1697 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1698 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1700 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1703 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1704 av_extend(PL_dbargs, AvFILLp(ary) + off);
1705 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1706 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1708 /* XXX only hints propagated via op_private are currently
1709 * visible (others are not easily accessible, since they
1710 * use the global PL_hints) */
1711 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1714 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1716 if (old_warnings == pWARN_NONE ||
1717 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1718 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1719 else if (old_warnings == pWARN_ALL ||
1720 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1721 /* Get the bit mask for $warnings::Bits{all}, because
1722 * it could have been extended by warnings::register */
1724 HV * const bits = get_hv("warnings::Bits", FALSE);
1725 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1726 mask = newSVsv(*bits_all);
1729 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1733 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1737 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1738 sv_2mortal(newRV_noinc(
1739 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1740 cx->blk_oldcop->cop_hints_hash)))
1749 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1750 sv_reset(tmps, CopSTASH(PL_curcop));
1755 /* like pp_nextstate, but used instead when the debugger is active */
1760 PL_curcop = (COP*)PL_op;
1761 TAINT_NOT; /* Each statement is presumed innocent */
1762 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1765 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1766 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1769 register PERL_CONTEXT *cx;
1770 const I32 gimme = G_ARRAY;
1772 GV * const gv = PL_DBgv;
1773 register CV * const cv = GvCV(gv);
1776 DIE(aTHX_ "No DB::DB routine defined");
1778 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1779 /* don't do recursive DB::DB call */
1794 (void)(*CvXSUB(cv))(aTHX_ cv);
1801 PUSHBLOCK(cx, CXt_SUB, SP);
1803 cx->blk_sub.retop = PL_op->op_next;
1806 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1807 RETURNOP(CvSTART(cv));
1817 register PERL_CONTEXT *cx;
1818 const I32 gimme = GIMME_V;
1820 U16 cxtype = CXt_LOOP | CXp_FOREACH;
1828 if (PL_op->op_targ) {
1829 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1830 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1831 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1832 SVs_PADSTALE, SVs_PADSTALE);
1834 #ifndef USE_ITHREADS
1835 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1838 SAVEPADSV(PL_op->op_targ);
1839 iterdata = INT2PTR(void*, PL_op->op_targ);
1840 cxtype |= CXp_PADVAR;
1844 GV * const gv = (GV*)POPs;
1845 svp = &GvSV(gv); /* symbol table variable */
1846 SAVEGENERICSV(*svp);
1849 iterdata = (void*)gv;
1853 if (PL_op->op_private & OPpITER_DEF)
1854 cxtype |= CXp_FOR_DEF;
1858 PUSHBLOCK(cx, cxtype, SP);
1860 PUSHLOOP(cx, iterdata, MARK);
1862 PUSHLOOP(cx, svp, MARK);
1864 if (PL_op->op_flags & OPf_STACKED) {
1865 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1866 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1868 SV * const right = (SV*)cx->blk_loop.iterary;
1871 if (RANGE_IS_NUMERIC(sv,right)) {
1872 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1873 (SvOK(right) && SvNV(right) >= IV_MAX))
1874 DIE(aTHX_ "Range iterator outside integer range");
1875 cx->blk_loop.iterix = SvIV(sv);
1876 cx->blk_loop.itermax = SvIV(right);
1878 /* for correct -Dstv display */
1879 cx->blk_oldsp = sp - PL_stack_base;
1883 cx->blk_loop.iterlval = newSVsv(sv);
1884 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1885 (void) SvPV_nolen_const(right);
1888 else if (PL_op->op_private & OPpITER_REVERSED) {
1889 cx->blk_loop.itermax = 0;
1890 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1895 cx->blk_loop.iterary = PL_curstack;
1896 AvFILLp(PL_curstack) = SP - PL_stack_base;
1897 if (PL_op->op_private & OPpITER_REVERSED) {
1898 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1899 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1902 cx->blk_loop.iterix = MARK - PL_stack_base;
1912 register PERL_CONTEXT *cx;
1913 const I32 gimme = GIMME_V;
1919 PUSHBLOCK(cx, CXt_LOOP, SP);
1920 PUSHLOOP(cx, 0, SP);
1928 register PERL_CONTEXT *cx;
1935 assert(CxTYPE(cx) == CXt_LOOP);
1937 newsp = PL_stack_base + cx->blk_loop.resetsp;
1940 if (gimme == G_VOID)
1942 else if (gimme == G_SCALAR) {
1944 *++newsp = sv_mortalcopy(*SP);
1946 *++newsp = &PL_sv_undef;
1950 *++newsp = sv_mortalcopy(*++mark);
1951 TAINT_NOT; /* Each item is independent */
1957 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1958 PL_curpm = newpm; /* ... and pop $1 et al */
1969 register PERL_CONTEXT *cx;
1970 bool popsub2 = FALSE;
1971 bool clear_errsv = FALSE;
1979 const I32 cxix = dopoptosub(cxstack_ix);
1982 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1983 * sort block, which is a CXt_NULL
1986 PL_stack_base[1] = *PL_stack_sp;
1987 PL_stack_sp = PL_stack_base + 1;
1991 DIE(aTHX_ "Can't return outside a subroutine");
1993 if (cxix < cxstack_ix)
1996 if (CxMULTICALL(&cxstack[cxix])) {
1997 gimme = cxstack[cxix].blk_gimme;
1998 if (gimme == G_VOID)
1999 PL_stack_sp = PL_stack_base;
2000 else if (gimme == G_SCALAR) {
2001 PL_stack_base[1] = *PL_stack_sp;
2002 PL_stack_sp = PL_stack_base + 1;
2008 switch (CxTYPE(cx)) {
2011 retop = cx->blk_sub.retop;
2012 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2015 if (!(PL_in_eval & EVAL_KEEPERR))
2018 retop = cx->blk_eval.retop;
2022 if (optype == OP_REQUIRE &&
2023 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2025 /* Unassume the success we assumed earlier. */
2026 SV * const nsv = cx->blk_eval.old_namesv;
2027 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2028 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2033 retop = cx->blk_sub.retop;
2036 DIE(aTHX_ "panic: return");
2040 if (gimme == G_SCALAR) {
2043 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2045 *++newsp = SvREFCNT_inc(*SP);
2050 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2052 *++newsp = sv_mortalcopy(sv);
2057 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2060 *++newsp = sv_mortalcopy(*SP);
2063 *++newsp = &PL_sv_undef;
2065 else if (gimme == G_ARRAY) {
2066 while (++MARK <= SP) {
2067 *++newsp = (popsub2 && SvTEMP(*MARK))
2068 ? *MARK : sv_mortalcopy(*MARK);
2069 TAINT_NOT; /* Each item is independent */
2072 PL_stack_sp = newsp;
2075 /* Stack values are safe: */
2078 POPSUB(cx,sv); /* release CV and @_ ... */
2082 PL_curpm = newpm; /* ... and pop $1 et al */
2086 sv_setpvn(ERRSV,"",0);
2094 register PERL_CONTEXT *cx;
2105 if (PL_op->op_flags & OPf_SPECIAL) {
2106 cxix = dopoptoloop(cxstack_ix);
2108 DIE(aTHX_ "Can't \"last\" outside a loop block");
2111 cxix = dopoptolabel(cPVOP->op_pv);
2113 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2115 if (cxix < cxstack_ix)
2119 cxstack_ix++; /* temporarily protect top context */
2121 switch (CxTYPE(cx)) {
2124 newsp = PL_stack_base + cx->blk_loop.resetsp;
2125 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2129 nextop = cx->blk_sub.retop;
2133 nextop = cx->blk_eval.retop;
2137 nextop = cx->blk_sub.retop;
2140 DIE(aTHX_ "panic: last");
2144 if (gimme == G_SCALAR) {
2146 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2147 ? *SP : sv_mortalcopy(*SP);
2149 *++newsp = &PL_sv_undef;
2151 else if (gimme == G_ARRAY) {
2152 while (++MARK <= SP) {
2153 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2154 ? *MARK : sv_mortalcopy(*MARK);
2155 TAINT_NOT; /* Each item is independent */
2163 /* Stack values are safe: */
2166 POPLOOP(cx); /* release loop vars ... */
2170 POPSUB(cx,sv); /* release CV and @_ ... */
2173 PL_curpm = newpm; /* ... and pop $1 et al */
2176 PERL_UNUSED_VAR(optype);
2177 PERL_UNUSED_VAR(gimme);
2185 register PERL_CONTEXT *cx;
2188 if (PL_op->op_flags & OPf_SPECIAL) {
2189 cxix = dopoptoloop(cxstack_ix);
2191 DIE(aTHX_ "Can't \"next\" outside a loop block");
2194 cxix = dopoptolabel(cPVOP->op_pv);
2196 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2198 if (cxix < cxstack_ix)
2201 /* clear off anything above the scope we're re-entering, but
2202 * save the rest until after a possible continue block */
2203 inner = PL_scopestack_ix;
2205 if (PL_scopestack_ix < inner)
2206 leave_scope(PL_scopestack[PL_scopestack_ix]);
2207 PL_curcop = cx->blk_oldcop;
2208 return CX_LOOP_NEXTOP_GET(cx);
2215 register PERL_CONTEXT *cx;
2219 if (PL_op->op_flags & OPf_SPECIAL) {
2220 cxix = dopoptoloop(cxstack_ix);
2222 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2225 cxix = dopoptolabel(cPVOP->op_pv);
2227 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2229 if (cxix < cxstack_ix)
2232 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2233 if (redo_op->op_type == OP_ENTER) {
2234 /* pop one less context to avoid $x being freed in while (my $x..) */
2236 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2237 redo_op = redo_op->op_next;
2241 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2242 LEAVE_SCOPE(oldsave);
2244 PL_curcop = cx->blk_oldcop;
2249 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2253 static const char too_deep[] = "Target of goto is too deeply nested";
2256 Perl_croak(aTHX_ too_deep);
2257 if (o->op_type == OP_LEAVE ||
2258 o->op_type == OP_SCOPE ||
2259 o->op_type == OP_LEAVELOOP ||
2260 o->op_type == OP_LEAVESUB ||
2261 o->op_type == OP_LEAVETRY)
2263 *ops++ = cUNOPo->op_first;
2265 Perl_croak(aTHX_ too_deep);
2268 if (o->op_flags & OPf_KIDS) {
2270 /* First try all the kids at this level, since that's likeliest. */
2271 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2272 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2273 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2276 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2277 if (kid == PL_lastgotoprobe)
2279 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2282 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2283 ops[-1]->op_type == OP_DBSTATE)
2288 if ((o = dofindlabel(kid, label, ops, oplimit)))
2301 register PERL_CONTEXT *cx;
2302 #define GOTO_DEPTH 64
2303 OP *enterops[GOTO_DEPTH];
2304 const char *label = NULL;
2305 const bool do_dump = (PL_op->op_type == OP_DUMP);
2306 static const char must_have_label[] = "goto must have label";
2308 if (PL_op->op_flags & OPf_STACKED) {
2309 SV * const sv = POPs;
2311 /* This egregious kludge implements goto &subroutine */
2312 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2314 register PERL_CONTEXT *cx;
2315 CV* cv = (CV*)SvRV(sv);
2322 if (!CvROOT(cv) && !CvXSUB(cv)) {
2323 const GV * const gv = CvGV(cv);
2327 /* autoloaded stub? */
2328 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2330 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2331 GvNAMELEN(gv), FALSE);
2332 if (autogv && (cv = GvCV(autogv)))
2334 tmpstr = sv_newmortal();
2335 gv_efullname3(tmpstr, gv, NULL);
2336 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2338 DIE(aTHX_ "Goto undefined subroutine");
2341 /* First do some returnish stuff. */
2342 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2344 cxix = dopoptosub(cxstack_ix);
2346 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2347 if (cxix < cxstack_ix)
2351 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2352 if (CxTYPE(cx) == CXt_EVAL) {
2354 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2356 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2358 else if (CxMULTICALL(cx))
2359 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2360 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2361 /* put @_ back onto stack */
2362 AV* av = cx->blk_sub.argarray;
2364 items = AvFILLp(av) + 1;
2365 EXTEND(SP, items+1); /* @_ could have been extended. */
2366 Copy(AvARRAY(av), SP + 1, items, SV*);
2367 SvREFCNT_dec(GvAV(PL_defgv));
2368 GvAV(PL_defgv) = cx->blk_sub.savearray;
2370 /* abandon @_ if it got reified */
2375 av_extend(av, items-1);
2377 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2380 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2381 AV* const av = GvAV(PL_defgv);
2382 items = AvFILLp(av) + 1;
2383 EXTEND(SP, items+1); /* @_ could have been extended. */
2384 Copy(AvARRAY(av), SP + 1, items, SV*);
2388 if (CxTYPE(cx) == CXt_SUB &&
2389 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2390 SvREFCNT_dec(cx->blk_sub.cv);
2391 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2392 LEAVE_SCOPE(oldsave);
2394 /* Now do some callish stuff. */
2396 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2398 OP* const retop = cx->blk_sub.retop;
2403 for (index=0; index<items; index++)
2404 sv_2mortal(SP[-index]);
2407 /* XS subs don't have a CxSUB, so pop it */
2408 POPBLOCK(cx, PL_curpm);
2409 /* Push a mark for the start of arglist */
2412 (void)(*CvXSUB(cv))(aTHX_ cv);
2417 AV* const padlist = CvPADLIST(cv);
2418 if (CxTYPE(cx) == CXt_EVAL) {
2419 PL_in_eval = cx->blk_eval.old_in_eval;
2420 PL_eval_root = cx->blk_eval.old_eval_root;
2421 cx->cx_type = CXt_SUB;
2422 cx->blk_sub.hasargs = 0;
2424 cx->blk_sub.cv = cv;
2425 cx->blk_sub.olddepth = CvDEPTH(cv);
2428 if (CvDEPTH(cv) < 2)
2429 SvREFCNT_inc_simple_void_NN(cv);
2431 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2432 sub_crush_depth(cv);
2433 pad_push(padlist, CvDEPTH(cv));
2436 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2437 if (cx->blk_sub.hasargs)
2439 AV* const av = (AV*)PAD_SVl(0);
2441 cx->blk_sub.savearray = GvAV(PL_defgv);
2442 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2443 CX_CURPAD_SAVE(cx->blk_sub);
2444 cx->blk_sub.argarray = av;
2446 if (items >= AvMAX(av) + 1) {
2447 SV **ary = AvALLOC(av);
2448 if (AvARRAY(av) != ary) {
2449 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2452 if (items >= AvMAX(av) + 1) {
2453 AvMAX(av) = items - 1;
2454 Renew(ary,items+1,SV*);
2460 Copy(mark,AvARRAY(av),items,SV*);
2461 AvFILLp(av) = items - 1;
2462 assert(!AvREAL(av));
2464 /* transfer 'ownership' of refcnts to new @_ */
2474 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2475 Perl_get_db_sub(aTHX_ NULL, cv);
2477 CV * const gotocv = get_cv("DB::goto", FALSE);
2479 PUSHMARK( PL_stack_sp );
2480 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2485 RETURNOP(CvSTART(cv));
2489 label = SvPV_nolen_const(sv);
2490 if (!(do_dump || *label))
2491 DIE(aTHX_ must_have_label);
2494 else if (PL_op->op_flags & OPf_SPECIAL) {
2496 DIE(aTHX_ must_have_label);
2499 label = cPVOP->op_pv;
2501 if (label && *label) {
2502 OP *gotoprobe = NULL;
2503 bool leaving_eval = FALSE;
2504 bool in_block = FALSE;
2505 PERL_CONTEXT *last_eval_cx = NULL;
2509 PL_lastgotoprobe = NULL;
2511 for (ix = cxstack_ix; ix >= 0; ix--) {
2513 switch (CxTYPE(cx)) {
2515 leaving_eval = TRUE;
2516 if (!CxTRYBLOCK(cx)) {
2517 gotoprobe = (last_eval_cx ?
2518 last_eval_cx->blk_eval.old_eval_root :
2523 /* else fall through */
2525 gotoprobe = cx->blk_oldcop->op_sibling;
2531 gotoprobe = cx->blk_oldcop->op_sibling;
2534 gotoprobe = PL_main_root;
2537 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2538 gotoprobe = CvROOT(cx->blk_sub.cv);
2544 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2547 DIE(aTHX_ "panic: goto");
2548 gotoprobe = PL_main_root;
2552 retop = dofindlabel(gotoprobe, label,
2553 enterops, enterops + GOTO_DEPTH);
2557 PL_lastgotoprobe = gotoprobe;
2560 DIE(aTHX_ "Can't find label %s", label);
2562 /* if we're leaving an eval, check before we pop any frames
2563 that we're not going to punt, otherwise the error
2566 if (leaving_eval && *enterops && enterops[1]) {
2568 for (i = 1; enterops[i]; i++)
2569 if (enterops[i]->op_type == OP_ENTERITER)
2570 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2573 /* pop unwanted frames */
2575 if (ix < cxstack_ix) {
2582 oldsave = PL_scopestack[PL_scopestack_ix];
2583 LEAVE_SCOPE(oldsave);
2586 /* push wanted frames */
2588 if (*enterops && enterops[1]) {
2589 OP * const oldop = PL_op;
2590 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2591 for (; enterops[ix]; ix++) {
2592 PL_op = enterops[ix];
2593 /* Eventually we may want to stack the needed arguments
2594 * for each op. For now, we punt on the hard ones. */
2595 if (PL_op->op_type == OP_ENTERITER)
2596 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2597 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2605 if (!retop) retop = PL_main_start;
2607 PL_restartop = retop;
2608 PL_do_undump = TRUE;
2612 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2613 PL_do_undump = FALSE;
2630 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2632 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2635 PL_exit_flags |= PERL_EXIT_EXPECTED;
2637 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2638 if (anum || !(PL_minus_c && PL_madskills))
2643 PUSHs(&PL_sv_undef);
2650 S_save_lines(pTHX_ AV *array, SV *sv)
2652 const char *s = SvPVX_const(sv);
2653 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2656 while (s && s < send) {
2658 SV * const tmpstr = newSV_type(SVt_PVMG);
2660 t = strchr(s, '\n');
2666 sv_setpvn(tmpstr, s, t - s);
2667 av_store(array, line++, tmpstr);
2673 S_docatch(pTHX_ OP *o)
2677 OP * const oldop = PL_op;
2681 assert(CATCH_GET == TRUE);
2688 assert(cxstack_ix >= 0);
2689 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2690 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2695 /* die caught by an inner eval - continue inner loop */
2697 /* NB XXX we rely on the old popped CxEVAL still being at the top
2698 * of the stack; the way die_where() currently works, this
2699 * assumption is valid. In theory The cur_top_env value should be
2700 * returned in another global, the way retop (aka PL_restartop)
2702 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2705 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2707 PL_op = PL_restartop;
2724 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2725 /* sv Text to convert to OP tree. */
2726 /* startop op_free() this to undo. */
2727 /* code Short string id of the caller. */
2729 /* FIXME - how much of this code is common with pp_entereval? */
2730 dVAR; dSP; /* Make POPBLOCK work. */
2736 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2737 char *tmpbuf = tbuf;
2740 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2744 lex_start(sv, NULL, FALSE);
2746 /* switch to eval mode */
2748 if (IN_PERL_COMPILETIME) {
2749 SAVECOPSTASH_FREE(&PL_compiling);
2750 CopSTASH_set(&PL_compiling, PL_curstash);
2752 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2753 SV * const sv = sv_newmortal();
2754 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2755 code, (unsigned long)++PL_evalseq,
2756 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2761 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2762 (unsigned long)++PL_evalseq);
2763 SAVECOPFILE_FREE(&PL_compiling);
2764 CopFILE_set(&PL_compiling, tmpbuf+2);
2765 SAVECOPLINE(&PL_compiling);
2766 CopLINE_set(&PL_compiling, 1);
2767 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2768 deleting the eval's FILEGV from the stash before gv_check() runs
2769 (i.e. before run-time proper). To work around the coredump that
2770 ensues, we always turn GvMULTI_on for any globals that were
2771 introduced within evals. See force_ident(). GSAR 96-10-12 */
2772 safestr = savepvn(tmpbuf, len);
2773 SAVEDELETE(PL_defstash, safestr, len);
2775 #ifdef OP_IN_REGISTER
2781 /* we get here either during compilation, or via pp_regcomp at runtime */
2782 runtime = IN_PERL_RUNTIME;
2784 runcv = find_runcv(NULL);
2787 PL_op->op_type = OP_ENTEREVAL;
2788 PL_op->op_flags = 0; /* Avoid uninit warning. */
2789 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2790 PUSHEVAL(cx, 0, NULL);
2793 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2795 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2796 POPBLOCK(cx,PL_curpm);
2799 (*startop)->op_type = OP_NULL;
2800 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2802 /* XXX DAPM do this properly one year */
2803 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2805 if (IN_PERL_COMPILETIME)
2806 CopHINTS_set(&PL_compiling, PL_hints);
2807 #ifdef OP_IN_REGISTER
2810 PERL_UNUSED_VAR(newsp);
2811 PERL_UNUSED_VAR(optype);
2813 return PL_eval_start;
2818 =for apidoc find_runcv
2820 Locate the CV corresponding to the currently executing sub or eval.
2821 If db_seqp is non_null, skip CVs that are in the DB package and populate
2822 *db_seqp with the cop sequence number at the point that the DB:: code was
2823 entered. (allows debuggers to eval in the scope of the breakpoint rather
2824 than in the scope of the debugger itself).
2830 Perl_find_runcv(pTHX_ U32 *db_seqp)
2836 *db_seqp = PL_curcop->cop_seq;
2837 for (si = PL_curstackinfo; si; si = si->si_prev) {
2839 for (ix = si->si_cxix; ix >= 0; ix--) {
2840 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2841 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2842 CV * const cv = cx->blk_sub.cv;
2843 /* skip DB:: code */
2844 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2845 *db_seqp = cx->blk_oldcop->cop_seq;
2850 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2858 /* Compile a require/do, an eval '', or a /(?{...})/.
2859 * In the last case, startop is non-null, and contains the address of
2860 * a pointer that should be set to the just-compiled code.
2861 * outside is the lexically enclosing CV (if any) that invoked us.
2862 * Returns a bool indicating whether the compile was successful; if so,
2863 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2864 * pushes undef (also croaks if startop != NULL).
2868 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2871 OP * const saveop = PL_op;
2873 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2874 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2879 SAVESPTR(PL_compcv);
2880 PL_compcv = (CV*)newSV_type(SVt_PVCV);
2881 CvEVAL_on(PL_compcv);
2882 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2883 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2885 CvOUTSIDE_SEQ(PL_compcv) = seq;
2886 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2888 /* set up a scratch pad */
2890 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2891 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2895 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2897 /* make sure we compile in the right package */
2899 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2900 SAVESPTR(PL_curstash);
2901 PL_curstash = CopSTASH(PL_curcop);
2903 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2904 SAVESPTR(PL_beginav);
2905 PL_beginav = newAV();
2906 SAVEFREESV(PL_beginav);
2907 SAVESPTR(PL_unitcheckav);
2908 PL_unitcheckav = newAV();
2909 SAVEFREESV(PL_unitcheckav);
2912 SAVEBOOL(PL_madskills);
2916 /* try to compile it */
2918 PL_eval_root = NULL;
2919 PL_curcop = &PL_compiling;
2920 CopARYBASE_set(PL_curcop, 0);
2921 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2922 PL_in_eval |= EVAL_KEEPERR;
2924 sv_setpvn(ERRSV,"",0);
2925 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
2926 SV **newsp; /* Used by POPBLOCK. */
2927 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2928 I32 optype = 0; /* Might be reset by POPEVAL. */
2933 op_free(PL_eval_root);
2934 PL_eval_root = NULL;
2936 SP = PL_stack_base + POPMARK; /* pop original mark */
2938 POPBLOCK(cx,PL_curpm);
2944 msg = SvPVx_nolen_const(ERRSV);
2945 if (optype == OP_REQUIRE) {
2946 const SV * const nsv = cx->blk_eval.old_namesv;
2947 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2949 Perl_croak(aTHX_ "%sCompilation failed in require",
2950 *msg ? msg : "Unknown error\n");
2953 POPBLOCK(cx,PL_curpm);
2955 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2956 (*msg ? msg : "Unknown error\n"));
2960 sv_setpvs(ERRSV, "Compilation error");
2963 PERL_UNUSED_VAR(newsp);
2964 PUSHs(&PL_sv_undef);
2968 CopLINE_set(&PL_compiling, 0);
2970 *startop = PL_eval_root;
2972 SAVEFREEOP(PL_eval_root);
2974 /* Set the context for this new optree.
2975 * If the last op is an OP_REQUIRE, force scalar context.
2976 * Otherwise, propagate the context from the eval(). */
2977 if (PL_eval_root->op_type == OP_LEAVEEVAL
2978 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2979 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2981 scalar(PL_eval_root);
2982 else if (gimme & G_VOID)
2983 scalarvoid(PL_eval_root);
2984 else if (gimme & G_ARRAY)
2987 scalar(PL_eval_root);
2989 DEBUG_x(dump_eval());
2991 /* Register with debugger: */
2992 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
2993 CV * const cv = get_cv("DB::postponed", FALSE);
2997 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2999 call_sv((SV*)cv, G_DISCARD);
3004 call_list(PL_scopestack_ix, PL_unitcheckav);
3006 /* compiled okay, so do it */
3008 CvDEPTH(PL_compcv) = 1;
3009 SP = PL_stack_base + POPMARK; /* pop original mark */
3010 PL_op = saveop; /* The caller may need it. */
3011 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3018 S_check_type_and_open(pTHX_ const char *name)
3021 const int st_rc = PerlLIO_stat(name, &st);
3023 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3027 return PerlIO_open(name, PERL_SCRIPT_MODE);
3030 #ifndef PERL_DISABLE_PMC
3032 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3036 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3037 SV *const pmcsv = newSV(namelen + 2);
3038 char *const pmc = SvPVX(pmcsv);
3041 memcpy(pmc, name, namelen);
3043 pmc[namelen + 1] = '\0';
3045 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3046 fp = check_type_and_open(name);
3049 fp = check_type_and_open(pmc);
3051 SvREFCNT_dec(pmcsv);
3054 fp = check_type_and_open(name);
3059 # define doopen_pm(name, namelen) check_type_and_open(name)
3060 #endif /* !PERL_DISABLE_PMC */
3065 register PERL_CONTEXT *cx;
3072 int vms_unixname = 0;
3074 const char *tryname = NULL;
3076 const I32 gimme = GIMME_V;
3077 int filter_has_file = 0;
3078 PerlIO *tryrsfp = NULL;
3079 SV *filter_cache = NULL;
3080 SV *filter_state = NULL;
3081 SV *filter_sub = NULL;
3087 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3088 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) { /* require v5.6.1 */
3089 HV * hinthv = GvHV(PL_hintgv);
3091 if (hinthv) ptr = hv_fetchs(hinthv, "v_string", FALSE);
3092 if ( !(ptr && *ptr && SvIOK(*ptr) && SvIV(*ptr)) )
3093 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3094 "v-string in use/require non-portable");
3096 sv = new_version(sv);
3097 if (!sv_derived_from(PL_patchlevel, "version"))
3098 upg_version(PL_patchlevel, TRUE);
3099 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3100 if ( vcmp(sv,PL_patchlevel) <= 0 )
3101 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3102 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3105 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3108 SV * const req = SvRV(sv);
3109 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3111 /* get the left hand term */
3112 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3114 first = SvIV(*av_fetch(lav,0,0));
3115 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3116 || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3117 || av_len(lav) > 1 /* FP with > 3 digits */
3118 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3120 DIE(aTHX_ "Perl %"SVf" required--this is only "
3121 "%"SVf", stopped", SVfARG(vnormal(req)),
3122 SVfARG(vnormal(PL_patchlevel)));
3124 else { /* probably 'use 5.10' or 'use 5.8' */
3125 SV * hintsv = newSV(0);
3129 second = SvIV(*av_fetch(lav,1,0));
3131 second /= second >= 600 ? 100 : 10;
3132 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3133 (int)first, (int)second,0);
3134 upg_version(hintsv, TRUE);
3136 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3137 "--this is only %"SVf", stopped",
3138 SVfARG(vnormal(req)),
3139 SVfARG(vnormal(hintsv)),
3140 SVfARG(vnormal(PL_patchlevel)));
3145 /* We do this only with use, not require. */
3147 /* If we request a version >= 5.6.0, then v-string are OK
3148 so set $^H{v_string} to suppress the v-string warning */
3149 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.006), FALSE))) >= 0) {
3150 HV * hinthv = GvHV(PL_hintgv);
3152 SV *hint = newSViv(1);
3153 (void)hv_stores(hinthv, "v_string", hint);
3154 /* This will call through to Perl_magic_sethint() which in turn
3155 sets PL_hints correctly. */
3158 /* If we request a version >= 5.9.5, load feature.pm with the
3159 * feature bundle that corresponds to the required version. */
3160 if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3161 SV *const importsv = vnormal(sv);
3162 *SvPVX_mutable(importsv) = ':';
3164 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3171 name = SvPV_const(sv, len);
3172 if (!(name && len > 0 && *name))
3173 DIE(aTHX_ "Null filename used");
3174 TAINT_PROPER("require");
3178 /* The key in the %ENV hash is in the syntax of file passed as the argument
3179 * usually this is in UNIX format, but sometimes in VMS format, which
3180 * can result in a module being pulled in more than once.
3181 * To prevent this, the key must be stored in UNIX format if the VMS
3182 * name can be translated to UNIX.
3184 if ((unixname = tounixspec(name, NULL)) != NULL) {
3185 unixlen = strlen(unixname);
3191 /* if not VMS or VMS name can not be translated to UNIX, pass it
3194 unixname = (char *) name;
3197 if (PL_op->op_type == OP_REQUIRE) {
3198 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3199 unixname, unixlen, 0);
3201 if (*svp != &PL_sv_undef)
3204 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3205 "Compilation failed in require", unixname);
3209 /* prepare to compile file */
3211 if (path_is_absolute(name)) {
3213 tryrsfp = doopen_pm(name, len);
3215 #ifdef MACOS_TRADITIONAL
3219 MacPerl_CanonDir(name, newname, 1);
3220 if (path_is_absolute(newname)) {
3222 tryrsfp = doopen_pm(newname, strlen(newname));
3227 AV * const ar = GvAVn(PL_incgv);
3234 sv_upgrade(namesv, SVt_PV);
3235 for (i = 0; i <= AvFILL(ar); i++) {
3236 SV * const dirsv = *av_fetch(ar, i, TRUE);
3238 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3245 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3246 && !sv_isobject(loader))
3248 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3251 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3252 PTR2UV(SvRV(dirsv)), name);
3253 tryname = SvPVX_const(namesv);
3264 if (sv_isobject(loader))
3265 count = call_method("INC", G_ARRAY);
3267 count = call_sv(loader, G_ARRAY);
3270 /* Adjust file name if the hook has set an %INC entry */
3271 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3273 tryname = SvPVX_const(*svp);
3282 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3283 && !isGV_with_GP(SvRV(arg))) {
3284 filter_cache = SvRV(arg);
3285 SvREFCNT_inc_simple_void_NN(filter_cache);
3292 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3296 if (SvTYPE(arg) == SVt_PVGV) {
3297 IO * const io = GvIO((GV *)arg);
3302 tryrsfp = IoIFP(io);
3303 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3304 PerlIO_close(IoOFP(io));
3315 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3317 SvREFCNT_inc_simple_void_NN(filter_sub);
3320 filter_state = SP[i];
3321 SvREFCNT_inc_simple_void(filter_state);
3325 if (!tryrsfp && (filter_cache || filter_sub)) {
3326 tryrsfp = PerlIO_open(BIT_BUCKET,
3341 filter_has_file = 0;
3343 SvREFCNT_dec(filter_cache);
3344 filter_cache = NULL;
3347 SvREFCNT_dec(filter_state);
3348 filter_state = NULL;
3351 SvREFCNT_dec(filter_sub);
3356 if (!path_is_absolute(name)
3357 #ifdef MACOS_TRADITIONAL
3358 /* We consider paths of the form :a:b ambiguous and interpret them first
3359 as global then as local
3361 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3368 dir = SvPV_const(dirsv, dirlen);
3374 #ifdef MACOS_TRADITIONAL
3378 MacPerl_CanonDir(name, buf2, 1);
3379 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3383 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3385 sv_setpv(namesv, unixdir);
3386 sv_catpv(namesv, unixname);
3388 # ifdef __SYMBIAN32__
3389 if (PL_origfilename[0] &&
3390 PL_origfilename[1] == ':' &&
3391 !(dir[0] && dir[1] == ':'))
3392 Perl_sv_setpvf(aTHX_ namesv,
3397 Perl_sv_setpvf(aTHX_ namesv,
3401 /* The equivalent of
3402 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3403 but without the need to parse the format string, or
3404 call strlen on either pointer, and with the correct
3405 allocation up front. */
3407 char *tmp = SvGROW(namesv, dirlen + len + 2);
3409 memcpy(tmp, dir, dirlen);
3412 /* name came from an SV, so it will have a '\0' at the
3413 end that we can copy as part of this memcpy(). */
3414 memcpy(tmp, name, len + 1);
3416 SvCUR_set(namesv, dirlen + len + 1);
3418 /* Don't even actually have to turn SvPOK_on() as we
3419 access it directly with SvPVX() below. */
3424 TAINT_PROPER("require");
3425 tryname = SvPVX_const(namesv);
3426 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3428 if (tryname[0] == '.' && tryname[1] == '/')
3432 else if (errno == EMFILE)
3433 /* no point in trying other paths if out of handles */
3440 SAVECOPFILE_FREE(&PL_compiling);
3441 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3442 SvREFCNT_dec(namesv);
3444 if (PL_op->op_type == OP_REQUIRE) {
3445 const char *msgstr = name;
3446 if(errno == EMFILE) {
3448 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3450 msgstr = SvPV_nolen_const(msg);
3452 if (namesv) { /* did we lookup @INC? */
3453 AV * const ar = GvAVn(PL_incgv);
3455 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3456 "%s in @INC%s%s (@INC contains:",
3458 (instr(msgstr, ".h ")
3459 ? " (change .h to .ph maybe?)" : ""),
3460 (instr(msgstr, ".ph ")
3461 ? " (did you run h2ph?)" : "")
3464 for (i = 0; i <= AvFILL(ar); i++) {
3465 sv_catpvs(msg, " ");
3466 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3468 sv_catpvs(msg, ")");
3469 msgstr = SvPV_nolen_const(msg);
3472 DIE(aTHX_ "Can't locate %s", msgstr);
3478 SETERRNO(0, SS_NORMAL);
3480 /* Assume success here to prevent recursive requirement. */
3481 /* name is never assigned to again, so len is still strlen(name) */
3482 /* Check whether a hook in @INC has already filled %INC */
3484 (void)hv_store(GvHVn(PL_incgv),
3485 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3487 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3489 (void)hv_store(GvHVn(PL_incgv),
3490 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3495 lex_start(NULL, tryrsfp, TRUE);
3499 SAVECOMPILEWARNINGS();
3500 if (PL_dowarn & G_WARN_ALL_ON)
3501 PL_compiling.cop_warnings = pWARN_ALL ;
3502 else if (PL_dowarn & G_WARN_ALL_OFF)
3503 PL_compiling.cop_warnings = pWARN_NONE ;
3505 PL_compiling.cop_warnings = pWARN_STD ;
3507 if (filter_sub || filter_cache) {
3508 SV * const datasv = filter_add(S_run_user_filter, NULL);
3509 IoLINES(datasv) = filter_has_file;
3510 IoTOP_GV(datasv) = (GV *)filter_state;
3511 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3512 IoFMT_GV(datasv) = (GV *)filter_cache;
3515 /* switch to eval mode */
3516 PUSHBLOCK(cx, CXt_EVAL, SP);
3517 PUSHEVAL(cx, name, NULL);
3518 cx->blk_eval.retop = PL_op->op_next;
3520 SAVECOPLINE(&PL_compiling);
3521 CopLINE_set(&PL_compiling, 0);
3525 /* Store and reset encoding. */
3526 encoding = PL_encoding;
3529 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3530 op = DOCATCH(PL_eval_start);
3532 op = PL_op->op_next;
3534 /* Restore encoding. */
3535 PL_encoding = encoding;
3543 register PERL_CONTEXT *cx;
3545 const I32 gimme = GIMME_V;
3546 const I32 was = PL_sub_generation;
3547 char tbuf[TYPE_DIGITS(long) + 12];
3548 char *tmpbuf = tbuf;
3554 HV *saved_hh = NULL;
3555 const char * const fakestr = "_<(eval )";
3556 const int fakelen = 9 + 1;
3558 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3559 saved_hh = (HV*) SvREFCNT_inc(POPs);
3563 TAINT_IF(SvTAINTED(sv));
3564 TAINT_PROPER("eval");
3567 lex_start(sv, NULL, FALSE);
3570 /* switch to eval mode */
3572 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3573 SV * const temp_sv = sv_newmortal();
3574 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3575 (unsigned long)++PL_evalseq,
3576 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3577 tmpbuf = SvPVX(temp_sv);
3578 len = SvCUR(temp_sv);
3581 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3582 SAVECOPFILE_FREE(&PL_compiling);
3583 CopFILE_set(&PL_compiling, tmpbuf+2);
3584 SAVECOPLINE(&PL_compiling);
3585 CopLINE_set(&PL_compiling, 1);
3586 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3587 deleting the eval's FILEGV from the stash before gv_check() runs
3588 (i.e. before run-time proper). To work around the coredump that
3589 ensues, we always turn GvMULTI_on for any globals that were
3590 introduced within evals. See force_ident(). GSAR 96-10-12 */
3591 safestr = savepvn(tmpbuf, len);
3592 SAVEDELETE(PL_defstash, safestr, len);
3594 PL_hints = PL_op->op_targ;
3596 GvHV(PL_hintgv) = saved_hh;
3597 SAVECOMPILEWARNINGS();
3598 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3599 if (PL_compiling.cop_hints_hash) {
3600 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3602 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3603 if (PL_compiling.cop_hints_hash) {
3605 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3606 HINTS_REFCNT_UNLOCK;
3608 /* special case: an eval '' executed within the DB package gets lexically
3609 * placed in the first non-DB CV rather than the current CV - this
3610 * allows the debugger to execute code, find lexicals etc, in the
3611 * scope of the code being debugged. Passing &seq gets find_runcv
3612 * to do the dirty work for us */
3613 runcv = find_runcv(&seq);
3615 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3616 PUSHEVAL(cx, 0, NULL);
3617 cx->blk_eval.retop = PL_op->op_next;
3619 /* prepare to compile string */
3621 if (PERLDB_LINE && PL_curstash != PL_debstash)
3622 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3624 ok = doeval(gimme, NULL, runcv, seq);
3625 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3627 /* Copy in anything fake and short. */
3628 my_strlcpy(safestr, fakestr, fakelen);
3630 return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3640 register PERL_CONTEXT *cx;
3642 const U8 save_flags = PL_op -> op_flags;
3647 retop = cx->blk_eval.retop;
3650 if (gimme == G_VOID)
3652 else if (gimme == G_SCALAR) {
3655 if (SvFLAGS(TOPs) & SVs_TEMP)
3658 *MARK = sv_mortalcopy(TOPs);
3662 *MARK = &PL_sv_undef;
3667 /* in case LEAVE wipes old return values */
3668 for (mark = newsp + 1; mark <= SP; mark++) {
3669 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3670 *mark = sv_mortalcopy(*mark);
3671 TAINT_NOT; /* Each item is independent */
3675 PL_curpm = newpm; /* Don't pop $1 et al till now */
3678 assert(CvDEPTH(PL_compcv) == 1);
3680 CvDEPTH(PL_compcv) = 0;
3683 if (optype == OP_REQUIRE &&
3684 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3686 /* Unassume the success we assumed earlier. */
3687 SV * const nsv = cx->blk_eval.old_namesv;
3688 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3689 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3690 /* die_where() did LEAVE, or we won't be here */
3694 if (!(save_flags & OPf_SPECIAL))
3695 sv_setpvn(ERRSV,"",0);
3701 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3702 close to the related Perl_create_eval_scope. */
3704 Perl_delete_eval_scope(pTHX)
3709 register PERL_CONTEXT *cx;
3716 PERL_UNUSED_VAR(newsp);
3717 PERL_UNUSED_VAR(gimme);
3718 PERL_UNUSED_VAR(optype);
3721 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3722 also needed by Perl_fold_constants. */
3724 Perl_create_eval_scope(pTHX_ U32 flags)
3727 const I32 gimme = GIMME_V;
3732 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3735 PL_in_eval = EVAL_INEVAL;
3736 if (flags & G_KEEPERR)
3737 PL_in_eval |= EVAL_KEEPERR;
3739 sv_setpvn(ERRSV,"",0);
3740 if (flags & G_FAKINGEVAL) {
3741 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3749 PERL_CONTEXT * const cx = create_eval_scope(0);
3750 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3751 return DOCATCH(PL_op->op_next);
3760 register PERL_CONTEXT *cx;
3765 PERL_UNUSED_VAR(optype);
3768 if (gimme == G_VOID)
3770 else if (gimme == G_SCALAR) {
3774 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3777 *MARK = sv_mortalcopy(TOPs);
3781 *MARK = &PL_sv_undef;
3786 /* in case LEAVE wipes old return values */
3788 for (mark = newsp + 1; mark <= SP; mark++) {
3789 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3790 *mark = sv_mortalcopy(*mark);
3791 TAINT_NOT; /* Each item is independent */
3795 PL_curpm = newpm; /* Don't pop $1 et al till now */
3798 sv_setpvn(ERRSV,"",0);
3805 register PERL_CONTEXT *cx;
3806 const I32 gimme = GIMME_V;
3811 if (PL_op->op_targ == 0) {
3812 SV ** const defsv_p = &GvSV(PL_defgv);
3813 *defsv_p = newSVsv(POPs);
3814 SAVECLEARSV(*defsv_p);
3817 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3819 PUSHBLOCK(cx, CXt_GIVEN, SP);
3828 register PERL_CONTEXT *cx;
3832 PERL_UNUSED_CONTEXT;
3835 assert(CxTYPE(cx) == CXt_GIVEN);
3840 PL_curpm = newpm; /* pop $1 et al */
3847 /* Helper routines used by pp_smartmatch */
3849 S_make_matcher(pTHX_ REGEXP *re)
3852 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3853 PM_SETRE(matcher, ReREFCNT_inc(re));
3855 SAVEFREEOP((OP *) matcher);
3862 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3867 PL_op = (OP *) matcher;
3872 return (SvTRUEx(POPs));
3876 S_destroy_matcher(pTHX_ PMOP *matcher)
3879 PERL_UNUSED_ARG(matcher);
3884 /* Do a smart match */
3887 return do_smartmatch(NULL, NULL);
3890 /* This version of do_smartmatch() implements the
3891 * table of smart matches that is found in perlsyn.
3894 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3899 SV *e = TOPs; /* e is for 'expression' */
3900 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3901 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3902 REGEXP *this_regex, *other_regex;
3904 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3906 # define SM_REF(type) ( \
3907 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3908 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3910 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3911 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
3912 && NOT_EMPTY_PROTO(This) && (Other = e)) \
3913 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
3914 && NOT_EMPTY_PROTO(This) && (Other = d)))
3916 # define SM_REGEX ( \
3917 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \
3918 && (this_regex = This) \
3921 (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \
3922 && (this_regex = This) \
3926 # define SM_OTHER_REF(type) \
3927 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3929 # define SM_OTHER_REGEX (SvROK(Other) \
3930 && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \
3931 && (other_regex = SvRV(Other)))
3934 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3935 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3937 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3938 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3940 tryAMAGICbinSET(smart, 0);
3942 SP -= 2; /* Pop the values */
3944 /* Take care only to invoke mg_get() once for each argument.
3945 * Currently we do this by copying the SV if it's magical. */
3948 d = sv_mortalcopy(d);
3955 e = sv_mortalcopy(e);
3960 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3962 if (This == SvRV(Other))
3973 c = call_sv(This, G_SCALAR);
3977 else if (SvTEMP(TOPs))
3978 SvREFCNT_inc_void(TOPs);
3983 else if (SM_REF(PVHV)) {
3984 if (SM_OTHER_REF(PVHV)) {
3985 /* Check that the key-sets are identical */
3987 HV *other_hv = (HV *) SvRV(Other);
3989 bool other_tied = FALSE;
3990 U32 this_key_count = 0,
3991 other_key_count = 0;
3993 /* Tied hashes don't know how many keys they have. */
3994 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
3997 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3998 HV * const temp = other_hv;
3999 other_hv = (HV *) This;
4003 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
4006 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
4009 /* The hashes have the same number of keys, so it suffices
4010 to check that one is a subset of the other. */
4011 (void) hv_iterinit((HV *) This);
4012 while ( (he = hv_iternext((HV *) This)) ) {
4014 char * const key = hv_iterkey(he, &key_len);
4018 if(!hv_exists(other_hv, key, key_len)) {
4019 (void) hv_iterinit((HV *) This); /* reset iterator */
4025 (void) hv_iterinit(other_hv);
4026 while ( hv_iternext(other_hv) )
4030 other_key_count = HvUSEDKEYS(other_hv);
4032 if (this_key_count != other_key_count)
4037 else if (SM_OTHER_REF(PVAV)) {
4038 AV * const other_av = (AV *) SvRV(Other);
4039 const I32 other_len = av_len(other_av) + 1;
4042 for (i = 0; i < other_len; ++i) {
4043 SV ** const svp = av_fetch(other_av, i, FALSE);
4047 if (svp) { /* ??? When can this not happen? */
4048 key = SvPV(*svp, key_len);
4049 if (hv_exists((HV *) This, key, key_len))
4055 else if (SM_OTHER_REGEX) {
4056 PMOP * const matcher = make_matcher(other_regex);
4059 (void) hv_iterinit((HV *) This);
4060 while ( (he = hv_iternext((HV *) This)) ) {
4061 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4062 (void) hv_iterinit((HV *) This);
4063 destroy_matcher(matcher);
4067 destroy_matcher(matcher);
4071 if (hv_exists_ent((HV *) This, Other, 0))
4077 else if (SM_REF(PVAV)) {
4078 if (SM_OTHER_REF(PVAV)) {
4079 AV *other_av = (AV *) SvRV(Other);
4080 if (av_len((AV *) This) != av_len(other_av))
4084 const I32 other_len = av_len(other_av);
4086 if (NULL == seen_this) {
4087 seen_this = newHV();
4088 (void) sv_2mortal((SV *) seen_this);
4090 if (NULL == seen_other) {
4091 seen_this = newHV();
4092 (void) sv_2mortal((SV *) seen_other);
4094 for(i = 0; i <= other_len; ++i) {
4095 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4096 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4098 if (!this_elem || !other_elem) {
4099 if (this_elem || other_elem)
4102 else if (SM_SEEN_THIS(*this_elem)
4103 || SM_SEEN_OTHER(*other_elem))
4105 if (*this_elem != *other_elem)
4109 (void)hv_store_ent(seen_this,
4110 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4112 (void)hv_store_ent(seen_other,
4113 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4119 (void) do_smartmatch(seen_this, seen_other);
4129 else if (SM_OTHER_REGEX) {
4130 PMOP * const matcher = make_matcher(other_regex);
4131 const I32 this_len = av_len((AV *) This);
4134 for(i = 0; i <= this_len; ++i) {
4135 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4136 if (svp && matcher_matches_sv(matcher, *svp)) {
4137 destroy_matcher(matcher);
4141 destroy_matcher(matcher);
4144 else if (SvIOK(Other) || SvNOK(Other)) {
4147 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4148 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4155 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4165 else if (SvPOK(Other)) {
4166 const I32 this_len = av_len((AV *) This);
4169 for(i = 0; i <= this_len; ++i) {
4170 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4185 else if (!SvOK(d) || !SvOK(e)) {
4186 if (!SvOK(d) && !SvOK(e))
4191 else if (SM_REGEX) {
4192 PMOP * const matcher = make_matcher(this_regex);
4195 PUSHs(matcher_matches_sv(matcher, Other)
4198 destroy_matcher(matcher);
4201 else if (SM_REF(PVCV)) {
4203 /* This must be a null-prototyped sub, because we
4204 already checked for the other kind. */
4210 c = call_sv(This, G_SCALAR);
4213 PUSHs(&PL_sv_undef);
4214 else if (SvTEMP(TOPs))
4215 SvREFCNT_inc_void(TOPs);
4217 if (SM_OTHER_REF(PVCV)) {
4218 /* This one has to be null-proto'd too.
4219 Call both of 'em, and compare the results */
4221 c = call_sv(SvRV(Other), G_SCALAR);
4224 PUSHs(&PL_sv_undef);
4225 else if (SvTEMP(TOPs))
4226 SvREFCNT_inc_void(TOPs);
4237 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4238 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4240 if (SvPOK(Other) && !looks_like_number(Other)) {
4241 /* String comparison */
4246 /* Otherwise, numeric comparison */
4249 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4260 /* As a last resort, use string comparison */
4269 register PERL_CONTEXT *cx;
4270 const I32 gimme = GIMME_V;
4272 /* This is essentially an optimization: if the match
4273 fails, we don't want to push a context and then
4274 pop it again right away, so we skip straight
4275 to the op that follows the leavewhen.
4277 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4278 return cLOGOP->op_other->op_next;
4283 PUSHBLOCK(cx, CXt_WHEN, SP);
4292 register PERL_CONTEXT *cx;
4298 assert(CxTYPE(cx) == CXt_WHEN);
4303 PL_curpm = newpm; /* pop $1 et al */
4313 register PERL_CONTEXT *cx;
4316 cxix = dopoptowhen(cxstack_ix);
4318 DIE(aTHX_ "Can't \"continue\" outside a when block");
4319 if (cxix < cxstack_ix)
4322 /* clear off anything above the scope we're re-entering */
4323 inner = PL_scopestack_ix;
4325 if (PL_scopestack_ix < inner)
4326 leave_scope(PL_scopestack[PL_scopestack_ix]);
4327 PL_curcop = cx->blk_oldcop;
4328 return cx->blk_givwhen.leave_op;
4335 register PERL_CONTEXT *cx;
4338 cxix = dopoptogiven(cxstack_ix);
4340 if (PL_op->op_flags & OPf_SPECIAL)
4341 DIE(aTHX_ "Can't use when() outside a topicalizer");
4343 DIE(aTHX_ "Can't \"break\" outside a given block");
4345 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4346 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4348 if (cxix < cxstack_ix)
4351 /* clear off anything above the scope we're re-entering */
4352 inner = PL_scopestack_ix;
4354 if (PL_scopestack_ix < inner)
4355 leave_scope(PL_scopestack[PL_scopestack_ix]);
4356 PL_curcop = cx->blk_oldcop;
4359 return CX_LOOP_NEXTOP_GET(cx);
4361 return cx->blk_givwhen.leave_op;
4365 S_doparseform(pTHX_ SV *sv)
4368 register char *s = SvPV_force(sv, len);
4369 register char * const send = s + len;
4370 register char *base = NULL;
4371 register I32 skipspaces = 0;
4372 bool noblank = FALSE;
4373 bool repeat = FALSE;
4374 bool postspace = FALSE;
4380 bool unchopnum = FALSE;
4381 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4384 Perl_croak(aTHX_ "Null picture in formline");
4386 /* estimate the buffer size needed */
4387 for (base = s; s <= send; s++) {
4388 if (*s == '\n' || *s == '@' || *s == '^')
4394 Newx(fops, maxops, U32);
4399 *fpc++ = FF_LINEMARK;
4400 noblank = repeat = FALSE;
4418 case ' ': case '\t':
4425 } /* else FALL THROUGH */
4433 *fpc++ = FF_LITERAL;
4441 *fpc++ = (U16)skipspaces;
4445 *fpc++ = FF_NEWLINE;
4449 arg = fpc - linepc + 1;
4456 *fpc++ = FF_LINEMARK;
4457 noblank = repeat = FALSE;
4466 ischop = s[-1] == '^';
4472 arg = (s - base) - 1;
4474 *fpc++ = FF_LITERAL;
4482 *fpc++ = 2; /* skip the @* or ^* */
4484 *fpc++ = FF_LINESNGL;
4487 *fpc++ = FF_LINEGLOB;
4489 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4490 arg = ischop ? 512 : 0;
4495 const char * const f = ++s;
4498 arg |= 256 + (s - f);
4500 *fpc++ = s - base; /* fieldsize for FETCH */
4501 *fpc++ = FF_DECIMAL;
4503 unchopnum |= ! ischop;
4505 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4506 arg = ischop ? 512 : 0;
4508 s++; /* skip the '0' first */
4512 const char * const f = ++s;
4515 arg |= 256 + (s - f);
4517 *fpc++ = s - base; /* fieldsize for FETCH */
4518 *fpc++ = FF_0DECIMAL;
4520 unchopnum |= ! ischop;
4524 bool ismore = FALSE;
4527 while (*++s == '>') ;
4528 prespace = FF_SPACE;
4530 else if (*s == '|') {
4531 while (*++s == '|') ;
4532 prespace = FF_HALFSPACE;
4537 while (*++s == '<') ;
4540 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4544 *fpc++ = s - base; /* fieldsize for FETCH */
4546 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4549 *fpc++ = (U16)prespace;
4563 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4565 { /* need to jump to the next word */
4567 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4568 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4569 s = SvPVX(sv) + SvCUR(sv) + z;
4571 Copy(fops, s, arg, U32);
4573 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4576 if (unchopnum && repeat)
4577 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4583 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4585 /* Can value be printed in fldsize chars, using %*.*f ? */
4589 int intsize = fldsize - (value < 0 ? 1 : 0);
4596 while (intsize--) pwr *= 10.0;
4597 while (frcsize--) eps /= 10.0;
4600 if (value + eps >= pwr)
4603 if (value - eps <= -pwr)
4610 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4613 SV * const datasv = FILTER_DATA(idx);
4614 const int filter_has_file = IoLINES(datasv);
4615 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4616 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4620 const char *got_p = NULL;
4621 const char *prune_from = NULL;
4622 bool read_from_cache = FALSE;
4625 assert(maxlen >= 0);
4628 /* I was having segfault trouble under Linux 2.2.5 after a
4629 parse error occured. (Had to hack around it with a test
4630 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4631 not sure where the trouble is yet. XXX */
4633 if (IoFMT_GV(datasv)) {
4634 SV *const cache = (SV *)IoFMT_GV(datasv);
4637 const char *cache_p = SvPV(cache, cache_len);
4641 /* Running in block mode and we have some cached data already.
4643 if (cache_len >= umaxlen) {
4644 /* In fact, so much data we don't even need to call
4649 const char *const first_nl =
4650 (const char *)memchr(cache_p, '\n', cache_len);
4652 take = first_nl + 1 - cache_p;
4656 sv_catpvn(buf_sv, cache_p, take);
4657 sv_chop(cache, cache_p + take);
4658 /* Definately not EOF */
4662 sv_catsv(buf_sv, cache);
4664 umaxlen -= cache_len;
4667 read_from_cache = TRUE;
4671 /* Filter API says that the filter appends to the contents of the buffer.
4672 Usually the buffer is "", so the details don't matter. But if it's not,
4673 then clearly what it contains is already filtered by this filter, so we
4674 don't want to pass it in a second time.
4675 I'm going to use a mortal in case the upstream filter croaks. */
4676 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4677 ? sv_newmortal() : buf_sv;
4678 SvUPGRADE(upstream, SVt_PV);
4680 if (filter_has_file) {
4681 status = FILTER_READ(idx+1, upstream, 0);
4684 if (filter_sub && status >= 0) {
4697 PUSHs(filter_state);
4700 count = call_sv(filter_sub, G_SCALAR);
4715 if(SvOK(upstream)) {
4716 got_p = SvPV(upstream, got_len);
4718 if (got_len > umaxlen) {
4719 prune_from = got_p + umaxlen;
4722 const char *const first_nl =
4723 (const char *)memchr(got_p, '\n', got_len);
4724 if (first_nl && first_nl + 1 < got_p + got_len) {
4725 /* There's a second line here... */
4726 prune_from = first_nl + 1;
4731 /* Oh. Too long. Stuff some in our cache. */
4732 STRLEN cached_len = got_p + got_len - prune_from;
4733 SV *cache = (SV *)IoFMT_GV(datasv);
4736 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4737 } else if (SvOK(cache)) {
4738 /* Cache should be empty. */
4739 assert(!SvCUR(cache));
4742 sv_setpvn(cache, prune_from, cached_len);
4743 /* If you ask for block mode, you may well split UTF-8 characters.
4744 "If it breaks, you get to keep both parts"
4745 (Your code is broken if you don't put them back together again
4746 before something notices.) */
4747 if (SvUTF8(upstream)) {
4750 SvCUR_set(upstream, got_len - cached_len);
4751 /* Can't yet be EOF */
4756 /* If they are at EOF but buf_sv has something in it, then they may never
4757 have touched the SV upstream, so it may be undefined. If we naively
4758 concatenate it then we get a warning about use of uninitialised value.
4760 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4761 sv_catsv(buf_sv, upstream);
4765 IoLINES(datasv) = 0;
4766 SvREFCNT_dec(IoFMT_GV(datasv));
4768 SvREFCNT_dec(filter_state);
4769 IoTOP_GV(datasv) = NULL;
4772 SvREFCNT_dec(filter_sub);
4773 IoBOTTOM_GV(datasv) = NULL;
4775 filter_del(S_run_user_filter);
4777 if (status == 0 && read_from_cache) {
4778 /* If we read some data from the cache (and by getting here it implies
4779 that we emptied the cache) then we aren't yet at EOF, and mustn't
4780 report that to our caller. */
4786 /* perhaps someone can come up with a better name for
4787 this? it is not really "absolute", per se ... */
4789 S_path_is_absolute(const char *name)
4791 if (PERL_FILE_IS_ABSOLUTE(name)
4792 #ifdef MACOS_TRADITIONAL
4795 || (*name == '.' && (name[1] == '/' ||
4796 (name[1] == '.' && name[2] == '/')))
4808 * c-indentation-style: bsd
4810 * indent-tabs-mode: t
4813 * ex: set ts=8 sts=4 sw=4 noet: