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) != 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);
164 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
166 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
168 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
169 inside tie/overload accessors. */
175 #ifndef INCOMPLETE_TAINTS
178 RX_EXTFLAGS(re) |= RXf_TAINTED;
180 RX_EXTFLAGS(re) &= ~RXf_TAINTED;
184 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
188 #if !defined(USE_ITHREADS)
189 /* can't change the optree at runtime either */
190 /* PMf_KEEP is handled differently under threads to avoid these problems */
191 if (pm->op_pmflags & PMf_KEEP) {
192 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
193 cLOGOP->op_first->op_next = PL_op->op_next;
203 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
204 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
205 register SV * const dstr = cx->sb_dstr;
206 register char *s = cx->sb_s;
207 register char *m = cx->sb_m;
208 char *orig = cx->sb_orig;
209 register REGEXP * const rx = cx->sb_rx;
211 REGEXP *old = PM_GETRE(pm);
215 PM_SETRE(pm,ReREFCNT_inc(rx));
218 rxres_restore(&cx->sb_rxres, rx);
219 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
221 if (cx->sb_iters++) {
222 const I32 saviters = cx->sb_iters;
223 if (cx->sb_iters > cx->sb_maxiters)
224 DIE(aTHX_ "Substitution loop");
226 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
227 cx->sb_rxtainted |= 2;
228 sv_catsv(dstr, POPs);
229 FREETMPS; /* Prevent excess tmp stack */
232 if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
233 s == m, cx->sb_targ, NULL,
234 ((cx->sb_rflags & REXEC_COPY_STR)
235 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
236 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
238 SV * const targ = cx->sb_targ;
240 assert(cx->sb_strend >= s);
241 if(cx->sb_strend > s) {
242 if (DO_UTF8(dstr) && !SvUTF8(targ))
243 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
245 sv_catpvn(dstr, s, cx->sb_strend - s);
247 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
249 #ifdef PERL_OLD_COPY_ON_WRITE
251 sv_force_normal_flags(targ, SV_COW_DROP_PV);
257 SvPV_set(targ, SvPVX(dstr));
258 SvCUR_set(targ, SvCUR(dstr));
259 SvLEN_set(targ, SvLEN(dstr));
262 SvPV_set(dstr, NULL);
264 TAINT_IF(cx->sb_rxtainted & 1);
265 mPUSHi(saviters - 1);
267 (void)SvPOK_only_UTF8(targ);
268 TAINT_IF(cx->sb_rxtainted);
272 LEAVE_SCOPE(cx->sb_oldsave);
274 RETURNOP(pm->op_next);
276 cx->sb_iters = saviters;
278 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
281 cx->sb_orig = orig = RX_SUBBEG(rx);
283 cx->sb_strend = s + (cx->sb_strend - m);
285 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
287 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
288 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
290 sv_catpvn(dstr, s, m-s);
292 cx->sb_s = RX_OFFS(rx)[0].end + orig;
293 { /* Update the pos() information. */
294 SV * const sv = cx->sb_targ;
297 SvUPGRADE(sv, SVt_PVMG);
298 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
299 #ifdef PERL_OLD_COPY_ON_WRITE
301 sv_force_normal_flags(sv, 0);
303 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
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)
325 if (!p || p[1] < RX_NPARENS(rx)) {
326 #ifdef PERL_OLD_COPY_ON_WRITE
327 i = 7 + RX_NPARENS(rx) * 2;
329 i = 6 + RX_NPARENS(rx) * 2;
338 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
339 RX_MATCH_COPIED_off(rx);
341 #ifdef PERL_OLD_COPY_ON_WRITE
342 *p++ = PTR2UV(RX_SAVED_COPY(rx));
343 RX_SAVED_COPY(rx) = NULL;
346 *p++ = RX_NPARENS(rx);
348 *p++ = PTR2UV(RX_SUBBEG(rx));
349 *p++ = (UV)RX_SUBLEN(rx);
350 for (i = 0; i <= RX_NPARENS(rx); ++i) {
351 *p++ = (UV)RX_OFFS(rx)[i].start;
352 *p++ = (UV)RX_OFFS(rx)[i].end;
357 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
363 RX_MATCH_COPY_FREE(rx);
364 RX_MATCH_COPIED_set(rx, *p);
367 #ifdef PERL_OLD_COPY_ON_WRITE
368 if (RX_SAVED_COPY(rx))
369 SvREFCNT_dec (RX_SAVED_COPY(rx));
370 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
374 RX_NPARENS(rx) = *p++;
376 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
377 RX_SUBLEN(rx) = (I32)(*p++);
378 for (i = 0; i <= RX_NPARENS(rx); ++i) {
379 RX_OFFS(rx)[i].start = (I32)(*p++);
380 RX_OFFS(rx)[i].end = (I32)(*p++);
385 Perl_rxres_free(pTHX_ void **rsp)
387 UV * const p = (UV*)*rsp;
392 void *tmp = INT2PTR(char*,*p);
395 PoisonFree(*p, 1, sizeof(*p));
397 Safefree(INT2PTR(char*,*p));
399 #ifdef PERL_OLD_COPY_ON_WRITE
401 SvREFCNT_dec (INT2PTR(SV*,p[1]));
411 dVAR; dSP; dMARK; dORIGMARK;
412 register SV * const tmpForm = *++MARK;
417 register SV *sv = NULL;
418 const char *item = NULL;
422 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
423 const char *chophere = NULL;
424 char *linemark = NULL;
426 bool gotsome = FALSE;
428 const STRLEN fudge = SvPOK(tmpForm)
429 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
430 bool item_is_utf8 = FALSE;
431 bool targ_is_utf8 = FALSE;
433 OP * parseres = NULL;
437 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
438 if (SvREADONLY(tmpForm)) {
439 SvREADONLY_off(tmpForm);
440 parseres = doparseform(tmpForm);
441 SvREADONLY_on(tmpForm);
444 parseres = doparseform(tmpForm);
448 SvPV_force(PL_formtarget, len);
449 if (DO_UTF8(PL_formtarget))
451 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
453 f = SvPV_const(tmpForm, len);
454 /* need to jump to the next word */
455 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
459 const char *name = "???";
462 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
463 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
464 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
465 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
466 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
468 case FF_CHECKNL: name = "CHECKNL"; break;
469 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
470 case FF_SPACE: name = "SPACE"; break;
471 case FF_HALFSPACE: name = "HALFSPACE"; break;
472 case FF_ITEM: name = "ITEM"; break;
473 case FF_CHOP: name = "CHOP"; break;
474 case FF_LINEGLOB: name = "LINEGLOB"; break;
475 case FF_NEWLINE: name = "NEWLINE"; break;
476 case FF_MORE: name = "MORE"; break;
477 case FF_LINEMARK: name = "LINEMARK"; break;
478 case FF_END: name = "END"; break;
479 case FF_0DECIMAL: name = "0DECIMAL"; break;
480 case FF_LINESNGL: name = "LINESNGL"; break;
483 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
485 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
496 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
497 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
499 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
500 t = SvEND(PL_formtarget);
503 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
504 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
506 sv_utf8_upgrade(PL_formtarget);
507 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
508 t = SvEND(PL_formtarget);
528 if (ckWARN(WARN_SYNTAX))
529 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
536 const char *s = item = SvPV_const(sv, len);
539 itemsize = sv_len_utf8(sv);
540 if (itemsize != (I32)len) {
542 if (itemsize > fieldsize) {
543 itemsize = fieldsize;
544 itembytes = itemsize;
545 sv_pos_u2b(sv, &itembytes, 0);
549 send = chophere = s + itembytes;
559 sv_pos_b2u(sv, &itemsize);
563 item_is_utf8 = FALSE;
564 if (itemsize > fieldsize)
565 itemsize = fieldsize;
566 send = chophere = s + itemsize;
580 const char *s = item = SvPV_const(sv, len);
583 itemsize = sv_len_utf8(sv);
584 if (itemsize != (I32)len) {
586 if (itemsize <= fieldsize) {
587 const char *send = chophere = s + itemsize;
600 itemsize = fieldsize;
601 itembytes = itemsize;
602 sv_pos_u2b(sv, &itembytes, 0);
603 send = chophere = s + itembytes;
604 while (s < send || (s == send && isSPACE(*s))) {
614 if (strchr(PL_chopset, *s))
619 itemsize = chophere - item;
620 sv_pos_b2u(sv, &itemsize);
626 item_is_utf8 = FALSE;
627 if (itemsize <= fieldsize) {
628 const char *const send = chophere = s + itemsize;
641 itemsize = fieldsize;
642 send = chophere = s + itemsize;
643 while (s < send || (s == send && isSPACE(*s))) {
653 if (strchr(PL_chopset, *s))
658 itemsize = chophere - item;
664 arg = fieldsize - itemsize;
673 arg = fieldsize - itemsize;
684 const char *s = item;
688 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
690 sv_utf8_upgrade(PL_formtarget);
691 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
692 t = SvEND(PL_formtarget);
696 if (UTF8_IS_CONTINUED(*s)) {
697 STRLEN skip = UTF8SKIP(s);
714 if ( !((*t++ = *s++) & ~31) )
720 if (targ_is_utf8 && !item_is_utf8) {
721 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
723 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
724 for (; t < SvEND(PL_formtarget); t++) {
737 const int ch = *t++ = *s++;
740 if ( !((*t++ = *s++) & ~31) )
749 const char *s = chophere;
767 const char *s = item = SvPV_const(sv, len);
769 if ((item_is_utf8 = DO_UTF8(sv)))
770 itemsize = sv_len_utf8(sv);
772 bool chopped = FALSE;
773 const char *const send = s + len;
775 chophere = s + itemsize;
791 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
793 SvUTF8_on(PL_formtarget);
795 SvCUR_set(sv, chophere - item);
796 sv_catsv(PL_formtarget, sv);
797 SvCUR_set(sv, itemsize);
799 sv_catsv(PL_formtarget, sv);
801 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
802 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
803 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
812 #if defined(USE_LONG_DOUBLE)
815 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
819 "%#0*.*f" : "%0*.*f");
824 #if defined(USE_LONG_DOUBLE)
826 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
829 ((arg & 256) ? "%#*.*f" : "%*.*f");
832 /* If the field is marked with ^ and the value is undefined,
834 if ((arg & 512) && !SvOK(sv)) {
842 /* overflow evidence */
843 if (num_overflow(value, fieldsize, arg)) {
849 /* Formats aren't yet marked for locales, so assume "yes". */
851 STORE_NUMERIC_STANDARD_SET_LOCAL();
852 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
853 RESTORE_NUMERIC_STANDARD();
860 while (t-- > linemark && *t == ' ') ;
868 if (arg) { /* repeat until fields exhausted? */
870 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
871 lines += FmLINES(PL_formtarget);
874 if (strnEQ(linemark, linemark - arg, arg))
875 DIE(aTHX_ "Runaway format");
878 SvUTF8_on(PL_formtarget);
879 FmLINES(PL_formtarget) = lines;
881 RETURNOP(cLISTOP->op_first);
892 const char *s = chophere;
893 const char *send = item + len;
895 while (isSPACE(*s) && (s < send))
900 arg = fieldsize - itemsize;
907 if (strnEQ(s1," ",3)) {
908 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
919 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
921 SvUTF8_on(PL_formtarget);
922 FmLINES(PL_formtarget) += lines;
934 if (PL_stack_base + *PL_markstack_ptr == SP) {
936 if (GIMME_V == G_SCALAR)
938 RETURNOP(PL_op->op_next->op_next);
940 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
941 pp_pushmark(); /* push dst */
942 pp_pushmark(); /* push src */
943 ENTER; /* enter outer scope */
946 if (PL_op->op_private & OPpGREP_LEX)
947 SAVESPTR(PAD_SVl(PL_op->op_targ));
950 ENTER; /* enter inner scope */
953 src = PL_stack_base[*PL_markstack_ptr];
955 if (PL_op->op_private & OPpGREP_LEX)
956 PAD_SVl(PL_op->op_targ) = src;
961 if (PL_op->op_type == OP_MAPSTART)
962 pp_pushmark(); /* push top */
963 return ((LOGOP*)PL_op->op_next)->op_other;
969 const I32 gimme = GIMME_V;
970 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
976 /* first, move source pointer to the next item in the source list */
977 ++PL_markstack_ptr[-1];
979 /* if there are new items, push them into the destination list */
980 if (items && gimme != G_VOID) {
981 /* might need to make room back there first */
982 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
983 /* XXX this implementation is very pessimal because the stack
984 * is repeatedly extended for every set of items. Is possible
985 * to do this without any stack extension or copying at all
986 * by maintaining a separate list over which the map iterates
987 * (like foreach does). --gsar */
989 /* everything in the stack after the destination list moves
990 * towards the end the stack by the amount of room needed */
991 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
993 /* items to shift up (accounting for the moved source pointer) */
994 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
996 /* This optimization is by Ben Tilly and it does
997 * things differently from what Sarathy (gsar)
998 * is describing. The downside of this optimization is
999 * that leaves "holes" (uninitialized and hopefully unused areas)
1000 * to the Perl stack, but on the other hand this
1001 * shouldn't be a problem. If Sarathy's idea gets
1002 * implemented, this optimization should become
1003 * irrelevant. --jhi */
1005 shift = count; /* Avoid shifting too often --Ben Tilly */
1009 dst = (SP += shift);
1010 PL_markstack_ptr[-1] += shift;
1011 *PL_markstack_ptr += shift;
1015 /* copy the new items down to the destination list */
1016 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1017 if (gimme == G_ARRAY) {
1019 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1022 /* scalar context: we don't care about which values map returns
1023 * (we use undef here). And so we certainly don't want to do mortal
1024 * copies of meaningless values. */
1025 while (items-- > 0) {
1027 *dst-- = &PL_sv_undef;
1031 LEAVE; /* exit inner scope */
1034 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1036 (void)POPMARK; /* pop top */
1037 LEAVE; /* exit outer scope */
1038 (void)POPMARK; /* pop src */
1039 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1040 (void)POPMARK; /* pop dst */
1041 SP = PL_stack_base + POPMARK; /* pop original mark */
1042 if (gimme == G_SCALAR) {
1043 if (PL_op->op_private & OPpGREP_LEX) {
1044 SV* sv = sv_newmortal();
1045 sv_setiv(sv, items);
1053 else if (gimme == G_ARRAY)
1060 ENTER; /* enter inner scope */
1063 /* set $_ to the new source item */
1064 src = PL_stack_base[PL_markstack_ptr[-1]];
1066 if (PL_op->op_private & OPpGREP_LEX)
1067 PAD_SVl(PL_op->op_targ) = src;
1071 RETURNOP(cLOGOP->op_other);
1080 if (GIMME == G_ARRAY)
1082 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1083 return cLOGOP->op_other;
1093 if (GIMME == G_ARRAY) {
1094 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1098 SV * const targ = PAD_SV(PL_op->op_targ);
1101 if (PL_op->op_private & OPpFLIP_LINENUM) {
1102 if (GvIO(PL_last_in_gv)) {
1103 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1106 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1108 flip = SvIV(sv) == SvIV(GvSV(gv));
1114 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1115 if (PL_op->op_flags & OPf_SPECIAL) {
1123 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1126 sv_setpvn(TARG, "", 0);
1132 /* This code tries to decide if "$left .. $right" should use the
1133 magical string increment, or if the range is numeric (we make
1134 an exception for .."0" [#18165]). AMS 20021031. */
1136 #define RANGE_IS_NUMERIC(left,right) ( \
1137 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1138 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1139 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1140 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1141 && (!SvOK(right) || looks_like_number(right))))
1147 if (GIMME == G_ARRAY) {
1153 if (RANGE_IS_NUMERIC(left,right)) {
1156 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1157 (SvOK(right) && SvNV(right) > IV_MAX))
1158 DIE(aTHX_ "Range iterator outside integer range");
1169 SV * const sv = sv_2mortal(newSViv(i++));
1174 SV * const final = sv_mortalcopy(right);
1176 const char * const tmps = SvPV_const(final, len);
1178 SV *sv = sv_mortalcopy(left);
1179 SvPV_force_nolen(sv);
1180 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1182 if (strEQ(SvPVX_const(sv),tmps))
1184 sv = sv_2mortal(newSVsv(sv));
1191 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1195 if (PL_op->op_private & OPpFLIP_LINENUM) {
1196 if (GvIO(PL_last_in_gv)) {
1197 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1200 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1201 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1209 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1210 sv_catpvs(targ, "E0");
1220 static const char * const context_name[] = {
1233 S_dopoptolabel(pTHX_ const char *label)
1238 for (i = cxstack_ix; i >= 0; i--) {
1239 register const PERL_CONTEXT * const cx = &cxstack[i];
1240 switch (CxTYPE(cx)) {
1248 if (ckWARN(WARN_EXITING))
1249 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1250 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1251 if (CxTYPE(cx) == CXt_NULL)
1255 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1256 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1257 (long)i, cx->blk_loop.label));
1260 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1270 Perl_dowantarray(pTHX)
1273 const I32 gimme = block_gimme();
1274 return (gimme == G_VOID) ? G_SCALAR : gimme;
1278 Perl_block_gimme(pTHX)
1281 const I32 cxix = dopoptosub(cxstack_ix);
1285 switch (cxstack[cxix].blk_gimme) {
1293 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1300 Perl_is_lvalue_sub(pTHX)
1303 const I32 cxix = dopoptosub(cxstack_ix);
1304 assert(cxix >= 0); /* We should only be called from inside subs */
1306 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1307 return cxstack[cxix].blk_sub.lval;
1313 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1317 for (i = startingblock; i >= 0; i--) {
1318 register const PERL_CONTEXT * const cx = &cxstk[i];
1319 switch (CxTYPE(cx)) {
1325 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1333 S_dopoptoeval(pTHX_ I32 startingblock)
1337 for (i = startingblock; i >= 0; i--) {
1338 register const PERL_CONTEXT *cx = &cxstack[i];
1339 switch (CxTYPE(cx)) {
1343 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1351 S_dopoptoloop(pTHX_ I32 startingblock)
1355 for (i = startingblock; i >= 0; i--) {
1356 register const PERL_CONTEXT * const cx = &cxstack[i];
1357 switch (CxTYPE(cx)) {
1363 if (ckWARN(WARN_EXITING))
1364 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1365 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1366 if ((CxTYPE(cx)) == CXt_NULL)
1370 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1378 S_dopoptogiven(pTHX_ I32 startingblock)
1382 for (i = startingblock; i >= 0; i--) {
1383 register const PERL_CONTEXT *cx = &cxstack[i];
1384 switch (CxTYPE(cx)) {
1388 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1391 if (CxFOREACHDEF(cx)) {
1392 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1401 S_dopoptowhen(pTHX_ I32 startingblock)
1405 for (i = startingblock; i >= 0; i--) {
1406 register const PERL_CONTEXT *cx = &cxstack[i];
1407 switch (CxTYPE(cx)) {
1411 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1419 Perl_dounwind(pTHX_ I32 cxix)
1424 while (cxstack_ix > cxix) {
1426 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1427 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1428 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1429 /* Note: we don't need to restore the base context info till the end. */
1430 switch (CxTYPE(cx)) {
1433 continue; /* not break */
1452 PERL_UNUSED_VAR(optype);
1456 Perl_qerror(pTHX_ SV *err)
1460 sv_catsv(ERRSV, err);
1462 sv_catsv(PL_errors, err);
1464 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1466 ++PL_parser->error_count;
1470 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1479 if (PL_in_eval & EVAL_KEEPERR) {
1480 static const char prefix[] = "\t(in cleanup) ";
1481 SV * const err = ERRSV;
1482 const char *e = NULL;
1484 sv_setpvn(err,"",0);
1485 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1487 e = SvPV_const(err, len);
1489 if (*e != *message || strNE(e,message))
1493 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1494 sv_catpvn(err, prefix, sizeof(prefix)-1);
1495 sv_catpvn(err, message, msglen);
1496 if (ckWARN(WARN_MISC)) {
1497 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1498 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1503 sv_setpvn(ERRSV, message, msglen);
1507 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1508 && PL_curstackinfo->si_prev)
1516 register PERL_CONTEXT *cx;
1519 if (cxix < cxstack_ix)
1522 POPBLOCK(cx,PL_curpm);
1523 if (CxTYPE(cx) != CXt_EVAL) {
1525 message = SvPVx_const(ERRSV, msglen);
1526 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1527 PerlIO_write(Perl_error_log, message, msglen);
1532 if (gimme == G_SCALAR)
1533 *++newsp = &PL_sv_undef;
1534 PL_stack_sp = newsp;
1538 /* LEAVE could clobber PL_curcop (see save_re_context())
1539 * XXX it might be better to find a way to avoid messing with
1540 * PL_curcop in save_re_context() instead, but this is a more
1541 * minimal fix --GSAR */
1542 PL_curcop = cx->blk_oldcop;
1544 if (optype == OP_REQUIRE) {
1545 const char* const msg = SvPVx_nolen_const(ERRSV);
1546 SV * const nsv = cx->blk_eval.old_namesv;
1547 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1549 DIE(aTHX_ "%sCompilation failed in require",
1550 *msg ? msg : "Unknown error\n");
1552 assert(CxTYPE(cx) == CXt_EVAL);
1553 return cx->blk_eval.retop;
1557 message = SvPVx_const(ERRSV, msglen);
1559 write_to_stderr(message, msglen);
1567 dVAR; dSP; dPOPTOPssrl;
1568 if (SvTRUE(left) != SvTRUE(right))
1578 register I32 cxix = dopoptosub(cxstack_ix);
1579 register const PERL_CONTEXT *cx;
1580 register const PERL_CONTEXT *ccstack = cxstack;
1581 const PERL_SI *top_si = PL_curstackinfo;
1583 const char *stashname;
1590 /* we may be in a higher stacklevel, so dig down deeper */
1591 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1592 top_si = top_si->si_prev;
1593 ccstack = top_si->si_cxstack;
1594 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1597 if (GIMME != G_ARRAY) {
1603 /* caller() should not report the automatic calls to &DB::sub */
1604 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1605 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1609 cxix = dopoptosub_at(ccstack, cxix - 1);
1612 cx = &ccstack[cxix];
1613 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1614 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1615 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1616 field below is defined for any cx. */
1617 /* caller() should not report the automatic calls to &DB::sub */
1618 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1619 cx = &ccstack[dbcxix];
1622 stashname = CopSTASHPV(cx->blk_oldcop);
1623 if (GIMME != G_ARRAY) {
1626 PUSHs(&PL_sv_undef);
1629 sv_setpv(TARG, stashname);
1638 PUSHs(&PL_sv_undef);
1640 mPUSHs(newSVpv(stashname, 0));
1641 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1642 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1645 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1646 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1647 /* So is ccstack[dbcxix]. */
1649 SV * const sv = newSV(0);
1650 gv_efullname3(sv, cvgv, NULL);
1652 mPUSHi((I32)cx->blk_sub.hasargs);
1655 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1656 mPUSHi((I32)cx->blk_sub.hasargs);
1660 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1663 gimme = (I32)cx->blk_gimme;
1664 if (gimme == G_VOID)
1665 PUSHs(&PL_sv_undef);
1667 mPUSHi(gimme & G_ARRAY);
1668 if (CxTYPE(cx) == CXt_EVAL) {
1670 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1671 PUSHs(cx->blk_eval.cur_text);
1675 else if (cx->blk_eval.old_namesv) {
1676 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1679 /* eval BLOCK (try blocks have old_namesv == 0) */
1681 PUSHs(&PL_sv_undef);
1682 PUSHs(&PL_sv_undef);
1686 PUSHs(&PL_sv_undef);
1687 PUSHs(&PL_sv_undef);
1689 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1690 && CopSTASH_eq(PL_curcop, PL_debstash))
1692 AV * const ary = cx->blk_sub.argarray;
1693 const int off = AvARRAY(ary) - AvALLOC(ary);
1696 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1697 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1699 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1702 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1703 av_extend(PL_dbargs, AvFILLp(ary) + off);
1704 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1705 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1707 /* XXX only hints propagated via op_private are currently
1708 * visible (others are not easily accessible, since they
1709 * use the global PL_hints) */
1710 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1713 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1715 if (old_warnings == pWARN_NONE ||
1716 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1717 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1718 else if (old_warnings == pWARN_ALL ||
1719 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1720 /* Get the bit mask for $warnings::Bits{all}, because
1721 * it could have been extended by warnings::register */
1723 HV * const bits = get_hv("warnings::Bits", FALSE);
1724 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1725 mask = newSVsv(*bits_all);
1728 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1732 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1736 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1737 sv_2mortal(newRV_noinc(
1738 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1739 cx->blk_oldcop->cop_hints_hash)))
1748 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1749 sv_reset(tmps, CopSTASH(PL_curcop));
1754 /* like pp_nextstate, but used instead when the debugger is active */
1759 PL_curcop = (COP*)PL_op;
1760 TAINT_NOT; /* Each statement is presumed innocent */
1761 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1764 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1765 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1768 register PERL_CONTEXT *cx;
1769 const I32 gimme = G_ARRAY;
1771 GV * const gv = PL_DBgv;
1772 register CV * const cv = GvCV(gv);
1775 DIE(aTHX_ "No DB::DB routine defined");
1777 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1778 /* don't do recursive DB::DB call */
1793 (void)(*CvXSUB(cv))(aTHX_ cv);
1800 PUSHBLOCK(cx, CXt_SUB, SP);
1802 cx->blk_sub.retop = PL_op->op_next;
1805 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1806 RETURNOP(CvSTART(cv));
1816 register PERL_CONTEXT *cx;
1817 const I32 gimme = GIMME_V;
1819 U16 cxtype = CXt_LOOP | CXp_FOREACH;
1827 if (PL_op->op_targ) {
1828 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1829 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1830 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1831 SVs_PADSTALE, SVs_PADSTALE);
1833 #ifndef USE_ITHREADS
1834 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1837 SAVEPADSV(PL_op->op_targ);
1838 iterdata = INT2PTR(void*, PL_op->op_targ);
1839 cxtype |= CXp_PADVAR;
1843 GV * const gv = (GV*)POPs;
1844 svp = &GvSV(gv); /* symbol table variable */
1845 SAVEGENERICSV(*svp);
1848 iterdata = (void*)gv;
1852 if (PL_op->op_private & OPpITER_DEF)
1853 cxtype |= CXp_FOR_DEF;
1857 PUSHBLOCK(cx, cxtype, SP);
1859 PUSHLOOP(cx, iterdata, MARK);
1861 PUSHLOOP(cx, svp, MARK);
1863 if (PL_op->op_flags & OPf_STACKED) {
1864 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1865 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1867 SV * const right = (SV*)cx->blk_loop.iterary;
1870 if (RANGE_IS_NUMERIC(sv,right)) {
1871 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1872 (SvOK(right) && SvNV(right) >= IV_MAX))
1873 DIE(aTHX_ "Range iterator outside integer range");
1874 cx->blk_loop.iterix = SvIV(sv);
1875 cx->blk_loop.itermax = SvIV(right);
1877 /* for correct -Dstv display */
1878 cx->blk_oldsp = sp - PL_stack_base;
1882 cx->blk_loop.iterlval = newSVsv(sv);
1883 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1884 (void) SvPV_nolen_const(right);
1887 else if (PL_op->op_private & OPpITER_REVERSED) {
1888 cx->blk_loop.itermax = 0;
1889 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1894 cx->blk_loop.iterary = PL_curstack;
1895 AvFILLp(PL_curstack) = SP - PL_stack_base;
1896 if (PL_op->op_private & OPpITER_REVERSED) {
1897 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1898 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1901 cx->blk_loop.iterix = MARK - PL_stack_base;
1911 register PERL_CONTEXT *cx;
1912 const I32 gimme = GIMME_V;
1918 PUSHBLOCK(cx, CXt_LOOP, SP);
1919 PUSHLOOP(cx, 0, SP);
1927 register PERL_CONTEXT *cx;
1934 assert(CxTYPE(cx) == CXt_LOOP);
1936 newsp = PL_stack_base + cx->blk_loop.resetsp;
1939 if (gimme == G_VOID)
1941 else if (gimme == G_SCALAR) {
1943 *++newsp = sv_mortalcopy(*SP);
1945 *++newsp = &PL_sv_undef;
1949 *++newsp = sv_mortalcopy(*++mark);
1950 TAINT_NOT; /* Each item is independent */
1956 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1957 PL_curpm = newpm; /* ... and pop $1 et al */
1968 register PERL_CONTEXT *cx;
1969 bool popsub2 = FALSE;
1970 bool clear_errsv = FALSE;
1978 const I32 cxix = dopoptosub(cxstack_ix);
1981 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1982 * sort block, which is a CXt_NULL
1985 PL_stack_base[1] = *PL_stack_sp;
1986 PL_stack_sp = PL_stack_base + 1;
1990 DIE(aTHX_ "Can't return outside a subroutine");
1992 if (cxix < cxstack_ix)
1995 if (CxMULTICALL(&cxstack[cxix])) {
1996 gimme = cxstack[cxix].blk_gimme;
1997 if (gimme == G_VOID)
1998 PL_stack_sp = PL_stack_base;
1999 else if (gimme == G_SCALAR) {
2000 PL_stack_base[1] = *PL_stack_sp;
2001 PL_stack_sp = PL_stack_base + 1;
2007 switch (CxTYPE(cx)) {
2010 retop = cx->blk_sub.retop;
2011 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2014 if (!(PL_in_eval & EVAL_KEEPERR))
2017 retop = cx->blk_eval.retop;
2021 if (optype == OP_REQUIRE &&
2022 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2024 /* Unassume the success we assumed earlier. */
2025 SV * const nsv = cx->blk_eval.old_namesv;
2026 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2027 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2032 retop = cx->blk_sub.retop;
2035 DIE(aTHX_ "panic: return");
2039 if (gimme == G_SCALAR) {
2042 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2044 *++newsp = SvREFCNT_inc(*SP);
2049 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2051 *++newsp = sv_mortalcopy(sv);
2056 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2059 *++newsp = sv_mortalcopy(*SP);
2062 *++newsp = &PL_sv_undef;
2064 else if (gimme == G_ARRAY) {
2065 while (++MARK <= SP) {
2066 *++newsp = (popsub2 && SvTEMP(*MARK))
2067 ? *MARK : sv_mortalcopy(*MARK);
2068 TAINT_NOT; /* Each item is independent */
2071 PL_stack_sp = newsp;
2074 /* Stack values are safe: */
2077 POPSUB(cx,sv); /* release CV and @_ ... */
2081 PL_curpm = newpm; /* ... and pop $1 et al */
2085 sv_setpvn(ERRSV,"",0);
2093 register PERL_CONTEXT *cx;
2104 if (PL_op->op_flags & OPf_SPECIAL) {
2105 cxix = dopoptoloop(cxstack_ix);
2107 DIE(aTHX_ "Can't \"last\" outside a loop block");
2110 cxix = dopoptolabel(cPVOP->op_pv);
2112 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2114 if (cxix < cxstack_ix)
2118 cxstack_ix++; /* temporarily protect top context */
2120 switch (CxTYPE(cx)) {
2123 newsp = PL_stack_base + cx->blk_loop.resetsp;
2124 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2128 nextop = cx->blk_sub.retop;
2132 nextop = cx->blk_eval.retop;
2136 nextop = cx->blk_sub.retop;
2139 DIE(aTHX_ "panic: last");
2143 if (gimme == G_SCALAR) {
2145 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2146 ? *SP : sv_mortalcopy(*SP);
2148 *++newsp = &PL_sv_undef;
2150 else if (gimme == G_ARRAY) {
2151 while (++MARK <= SP) {
2152 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2153 ? *MARK : sv_mortalcopy(*MARK);
2154 TAINT_NOT; /* Each item is independent */
2162 /* Stack values are safe: */
2165 POPLOOP(cx); /* release loop vars ... */
2169 POPSUB(cx,sv); /* release CV and @_ ... */
2172 PL_curpm = newpm; /* ... and pop $1 et al */
2175 PERL_UNUSED_VAR(optype);
2176 PERL_UNUSED_VAR(gimme);
2184 register PERL_CONTEXT *cx;
2187 if (PL_op->op_flags & OPf_SPECIAL) {
2188 cxix = dopoptoloop(cxstack_ix);
2190 DIE(aTHX_ "Can't \"next\" outside a loop block");
2193 cxix = dopoptolabel(cPVOP->op_pv);
2195 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2197 if (cxix < cxstack_ix)
2200 /* clear off anything above the scope we're re-entering, but
2201 * save the rest until after a possible continue block */
2202 inner = PL_scopestack_ix;
2204 if (PL_scopestack_ix < inner)
2205 leave_scope(PL_scopestack[PL_scopestack_ix]);
2206 PL_curcop = cx->blk_oldcop;
2207 return CX_LOOP_NEXTOP_GET(cx);
2214 register PERL_CONTEXT *cx;
2218 if (PL_op->op_flags & OPf_SPECIAL) {
2219 cxix = dopoptoloop(cxstack_ix);
2221 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2224 cxix = dopoptolabel(cPVOP->op_pv);
2226 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2228 if (cxix < cxstack_ix)
2231 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2232 if (redo_op->op_type == OP_ENTER) {
2233 /* pop one less context to avoid $x being freed in while (my $x..) */
2235 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2236 redo_op = redo_op->op_next;
2240 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2241 LEAVE_SCOPE(oldsave);
2243 PL_curcop = cx->blk_oldcop;
2248 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2252 static const char too_deep[] = "Target of goto is too deeply nested";
2255 Perl_croak(aTHX_ too_deep);
2256 if (o->op_type == OP_LEAVE ||
2257 o->op_type == OP_SCOPE ||
2258 o->op_type == OP_LEAVELOOP ||
2259 o->op_type == OP_LEAVESUB ||
2260 o->op_type == OP_LEAVETRY)
2262 *ops++ = cUNOPo->op_first;
2264 Perl_croak(aTHX_ too_deep);
2267 if (o->op_flags & OPf_KIDS) {
2269 /* First try all the kids at this level, since that's likeliest. */
2270 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2271 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2272 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2275 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2276 if (kid == PL_lastgotoprobe)
2278 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2281 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2282 ops[-1]->op_type == OP_DBSTATE)
2287 if ((o = dofindlabel(kid, label, ops, oplimit)))
2300 register PERL_CONTEXT *cx;
2301 #define GOTO_DEPTH 64
2302 OP *enterops[GOTO_DEPTH];
2303 const char *label = NULL;
2304 const bool do_dump = (PL_op->op_type == OP_DUMP);
2305 static const char must_have_label[] = "goto must have label";
2307 if (PL_op->op_flags & OPf_STACKED) {
2308 SV * const sv = POPs;
2310 /* This egregious kludge implements goto &subroutine */
2311 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2313 register PERL_CONTEXT *cx;
2314 CV* cv = (CV*)SvRV(sv);
2321 if (!CvROOT(cv) && !CvXSUB(cv)) {
2322 const GV * const gv = CvGV(cv);
2326 /* autoloaded stub? */
2327 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2329 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2330 GvNAMELEN(gv), FALSE);
2331 if (autogv && (cv = GvCV(autogv)))
2333 tmpstr = sv_newmortal();
2334 gv_efullname3(tmpstr, gv, NULL);
2335 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2337 DIE(aTHX_ "Goto undefined subroutine");
2340 /* First do some returnish stuff. */
2341 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2343 cxix = dopoptosub(cxstack_ix);
2345 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2346 if (cxix < cxstack_ix)
2350 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2351 if (CxTYPE(cx) == CXt_EVAL) {
2353 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2355 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2357 else if (CxMULTICALL(cx))
2358 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2359 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2360 /* put @_ back onto stack */
2361 AV* av = cx->blk_sub.argarray;
2363 items = AvFILLp(av) + 1;
2364 EXTEND(SP, items+1); /* @_ could have been extended. */
2365 Copy(AvARRAY(av), SP + 1, items, SV*);
2366 SvREFCNT_dec(GvAV(PL_defgv));
2367 GvAV(PL_defgv) = cx->blk_sub.savearray;
2369 /* abandon @_ if it got reified */
2374 av_extend(av, items-1);
2376 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2379 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2380 AV* const av = GvAV(PL_defgv);
2381 items = AvFILLp(av) + 1;
2382 EXTEND(SP, items+1); /* @_ could have been extended. */
2383 Copy(AvARRAY(av), SP + 1, items, SV*);
2387 if (CxTYPE(cx) == CXt_SUB &&
2388 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2389 SvREFCNT_dec(cx->blk_sub.cv);
2390 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2391 LEAVE_SCOPE(oldsave);
2393 /* Now do some callish stuff. */
2395 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2397 OP* const retop = cx->blk_sub.retop;
2402 for (index=0; index<items; index++)
2403 sv_2mortal(SP[-index]);
2406 /* XS subs don't have a CxSUB, so pop it */
2407 POPBLOCK(cx, PL_curpm);
2408 /* Push a mark for the start of arglist */
2411 (void)(*CvXSUB(cv))(aTHX_ cv);
2416 AV* const padlist = CvPADLIST(cv);
2417 if (CxTYPE(cx) == CXt_EVAL) {
2418 PL_in_eval = cx->blk_eval.old_in_eval;
2419 PL_eval_root = cx->blk_eval.old_eval_root;
2420 cx->cx_type = CXt_SUB;
2421 cx->blk_sub.hasargs = 0;
2423 cx->blk_sub.cv = cv;
2424 cx->blk_sub.olddepth = CvDEPTH(cv);
2427 if (CvDEPTH(cv) < 2)
2428 SvREFCNT_inc_simple_void_NN(cv);
2430 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2431 sub_crush_depth(cv);
2432 pad_push(padlist, CvDEPTH(cv));
2435 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2436 if (cx->blk_sub.hasargs)
2438 AV* const av = (AV*)PAD_SVl(0);
2440 cx->blk_sub.savearray = GvAV(PL_defgv);
2441 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2442 CX_CURPAD_SAVE(cx->blk_sub);
2443 cx->blk_sub.argarray = av;
2445 if (items >= AvMAX(av) + 1) {
2446 SV **ary = AvALLOC(av);
2447 if (AvARRAY(av) != ary) {
2448 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2451 if (items >= AvMAX(av) + 1) {
2452 AvMAX(av) = items - 1;
2453 Renew(ary,items+1,SV*);
2459 Copy(mark,AvARRAY(av),items,SV*);
2460 AvFILLp(av) = items - 1;
2461 assert(!AvREAL(av));
2463 /* transfer 'ownership' of refcnts to new @_ */
2473 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2474 Perl_get_db_sub(aTHX_ NULL, cv);
2476 CV * const gotocv = get_cv("DB::goto", FALSE);
2478 PUSHMARK( PL_stack_sp );
2479 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2484 RETURNOP(CvSTART(cv));
2488 label = SvPV_nolen_const(sv);
2489 if (!(do_dump || *label))
2490 DIE(aTHX_ must_have_label);
2493 else if (PL_op->op_flags & OPf_SPECIAL) {
2495 DIE(aTHX_ must_have_label);
2498 label = cPVOP->op_pv;
2500 if (label && *label) {
2501 OP *gotoprobe = NULL;
2502 bool leaving_eval = FALSE;
2503 bool in_block = FALSE;
2504 PERL_CONTEXT *last_eval_cx = NULL;
2508 PL_lastgotoprobe = NULL;
2510 for (ix = cxstack_ix; ix >= 0; ix--) {
2512 switch (CxTYPE(cx)) {
2514 leaving_eval = TRUE;
2515 if (!CxTRYBLOCK(cx)) {
2516 gotoprobe = (last_eval_cx ?
2517 last_eval_cx->blk_eval.old_eval_root :
2522 /* else fall through */
2524 gotoprobe = cx->blk_oldcop->op_sibling;
2530 gotoprobe = cx->blk_oldcop->op_sibling;
2533 gotoprobe = PL_main_root;
2536 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2537 gotoprobe = CvROOT(cx->blk_sub.cv);
2543 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2546 DIE(aTHX_ "panic: goto");
2547 gotoprobe = PL_main_root;
2551 retop = dofindlabel(gotoprobe, label,
2552 enterops, enterops + GOTO_DEPTH);
2556 PL_lastgotoprobe = gotoprobe;
2559 DIE(aTHX_ "Can't find label %s", label);
2561 /* if we're leaving an eval, check before we pop any frames
2562 that we're not going to punt, otherwise the error
2565 if (leaving_eval && *enterops && enterops[1]) {
2567 for (i = 1; enterops[i]; i++)
2568 if (enterops[i]->op_type == OP_ENTERITER)
2569 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2572 /* pop unwanted frames */
2574 if (ix < cxstack_ix) {
2581 oldsave = PL_scopestack[PL_scopestack_ix];
2582 LEAVE_SCOPE(oldsave);
2585 /* push wanted frames */
2587 if (*enterops && enterops[1]) {
2588 OP * const oldop = PL_op;
2589 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2590 for (; enterops[ix]; ix++) {
2591 PL_op = enterops[ix];
2592 /* Eventually we may want to stack the needed arguments
2593 * for each op. For now, we punt on the hard ones. */
2594 if (PL_op->op_type == OP_ENTERITER)
2595 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2596 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2604 if (!retop) retop = PL_main_start;
2606 PL_restartop = retop;
2607 PL_do_undump = TRUE;
2611 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2612 PL_do_undump = FALSE;
2629 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2631 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2634 PL_exit_flags |= PERL_EXIT_EXPECTED;
2636 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2637 if (anum || !(PL_minus_c && PL_madskills))
2642 PUSHs(&PL_sv_undef);
2649 S_save_lines(pTHX_ AV *array, SV *sv)
2651 const char *s = SvPVX_const(sv);
2652 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2655 while (s && s < send) {
2657 SV * const tmpstr = newSV_type(SVt_PVMG);
2659 t = strchr(s, '\n');
2665 sv_setpvn(tmpstr, s, t - s);
2666 av_store(array, line++, tmpstr);
2672 S_docatch(pTHX_ OP *o)
2676 OP * const oldop = PL_op;
2680 assert(CATCH_GET == TRUE);
2687 assert(cxstack_ix >= 0);
2688 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2689 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2694 /* die caught by an inner eval - continue inner loop */
2696 /* NB XXX we rely on the old popped CxEVAL still being at the top
2697 * of the stack; the way die_where() currently works, this
2698 * assumption is valid. In theory The cur_top_env value should be
2699 * returned in another global, the way retop (aka PL_restartop)
2701 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2704 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2706 PL_op = PL_restartop;
2723 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2724 /* sv Text to convert to OP tree. */
2725 /* startop op_free() this to undo. */
2726 /* code Short string id of the caller. */
2728 /* FIXME - how much of this code is common with pp_entereval? */
2729 dVAR; dSP; /* Make POPBLOCK work. */
2735 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2736 char *tmpbuf = tbuf;
2739 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2743 lex_start(sv, NULL, FALSE);
2745 /* switch to eval mode */
2747 if (IN_PERL_COMPILETIME) {
2748 SAVECOPSTASH_FREE(&PL_compiling);
2749 CopSTASH_set(&PL_compiling, PL_curstash);
2751 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2752 SV * const sv = sv_newmortal();
2753 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2754 code, (unsigned long)++PL_evalseq,
2755 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2760 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2761 (unsigned long)++PL_evalseq);
2762 SAVECOPFILE_FREE(&PL_compiling);
2763 CopFILE_set(&PL_compiling, tmpbuf+2);
2764 SAVECOPLINE(&PL_compiling);
2765 CopLINE_set(&PL_compiling, 1);
2766 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2767 deleting the eval's FILEGV from the stash before gv_check() runs
2768 (i.e. before run-time proper). To work around the coredump that
2769 ensues, we always turn GvMULTI_on for any globals that were
2770 introduced within evals. See force_ident(). GSAR 96-10-12 */
2771 safestr = savepvn(tmpbuf, len);
2772 SAVEDELETE(PL_defstash, safestr, len);
2774 #ifdef OP_IN_REGISTER
2780 /* we get here either during compilation, or via pp_regcomp at runtime */
2781 runtime = IN_PERL_RUNTIME;
2783 runcv = find_runcv(NULL);
2786 PL_op->op_type = OP_ENTEREVAL;
2787 PL_op->op_flags = 0; /* Avoid uninit warning. */
2788 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2789 PUSHEVAL(cx, 0, NULL);
2792 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2794 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2795 POPBLOCK(cx,PL_curpm);
2798 (*startop)->op_type = OP_NULL;
2799 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2801 /* XXX DAPM do this properly one year */
2802 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2804 if (IN_PERL_COMPILETIME)
2805 CopHINTS_set(&PL_compiling, PL_hints);
2806 #ifdef OP_IN_REGISTER
2809 PERL_UNUSED_VAR(newsp);
2810 PERL_UNUSED_VAR(optype);
2812 return PL_eval_start;
2817 =for apidoc find_runcv
2819 Locate the CV corresponding to the currently executing sub or eval.
2820 If db_seqp is non_null, skip CVs that are in the DB package and populate
2821 *db_seqp with the cop sequence number at the point that the DB:: code was
2822 entered. (allows debuggers to eval in the scope of the breakpoint rather
2823 than in the scope of the debugger itself).
2829 Perl_find_runcv(pTHX_ U32 *db_seqp)
2835 *db_seqp = PL_curcop->cop_seq;
2836 for (si = PL_curstackinfo; si; si = si->si_prev) {
2838 for (ix = si->si_cxix; ix >= 0; ix--) {
2839 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2840 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2841 CV * const cv = cx->blk_sub.cv;
2842 /* skip DB:: code */
2843 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2844 *db_seqp = cx->blk_oldcop->cop_seq;
2849 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2857 /* Compile a require/do, an eval '', or a /(?{...})/.
2858 * In the last case, startop is non-null, and contains the address of
2859 * a pointer that should be set to the just-compiled code.
2860 * outside is the lexically enclosing CV (if any) that invoked us.
2861 * Returns a bool indicating whether the compile was successful; if so,
2862 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2863 * pushes undef (also croaks if startop != NULL).
2867 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2870 OP * const saveop = PL_op;
2872 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2873 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2878 SAVESPTR(PL_compcv);
2879 PL_compcv = (CV*)newSV_type(SVt_PVCV);
2880 CvEVAL_on(PL_compcv);
2881 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2882 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2884 CvOUTSIDE_SEQ(PL_compcv) = seq;
2885 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2887 /* set up a scratch pad */
2889 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2890 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2894 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2896 /* make sure we compile in the right package */
2898 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2899 SAVESPTR(PL_curstash);
2900 PL_curstash = CopSTASH(PL_curcop);
2902 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2903 SAVESPTR(PL_beginav);
2904 PL_beginav = newAV();
2905 SAVEFREESV(PL_beginav);
2906 SAVESPTR(PL_unitcheckav);
2907 PL_unitcheckav = newAV();
2908 SAVEFREESV(PL_unitcheckav);
2911 SAVEBOOL(PL_madskills);
2915 /* try to compile it */
2917 PL_eval_root = NULL;
2918 PL_curcop = &PL_compiling;
2919 CopARYBASE_set(PL_curcop, 0);
2920 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2921 PL_in_eval |= EVAL_KEEPERR;
2923 sv_setpvn(ERRSV,"",0);
2924 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
2925 SV **newsp; /* Used by POPBLOCK. */
2926 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2927 I32 optype = 0; /* Might be reset by POPEVAL. */
2932 op_free(PL_eval_root);
2933 PL_eval_root = NULL;
2935 SP = PL_stack_base + POPMARK; /* pop original mark */
2937 POPBLOCK(cx,PL_curpm);
2943 msg = SvPVx_nolen_const(ERRSV);
2944 if (optype == OP_REQUIRE) {
2945 const SV * const nsv = cx->blk_eval.old_namesv;
2946 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2948 Perl_croak(aTHX_ "%sCompilation failed in require",
2949 *msg ? msg : "Unknown error\n");
2952 POPBLOCK(cx,PL_curpm);
2954 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2955 (*msg ? msg : "Unknown error\n"));
2959 sv_setpvs(ERRSV, "Compilation error");
2962 PERL_UNUSED_VAR(newsp);
2963 PUSHs(&PL_sv_undef);
2967 CopLINE_set(&PL_compiling, 0);
2969 *startop = PL_eval_root;
2971 SAVEFREEOP(PL_eval_root);
2973 /* Set the context for this new optree.
2974 * If the last op is an OP_REQUIRE, force scalar context.
2975 * Otherwise, propagate the context from the eval(). */
2976 if (PL_eval_root->op_type == OP_LEAVEEVAL
2977 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2978 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2980 scalar(PL_eval_root);
2981 else if (gimme & G_VOID)
2982 scalarvoid(PL_eval_root);
2983 else if (gimme & G_ARRAY)
2986 scalar(PL_eval_root);
2988 DEBUG_x(dump_eval());
2990 /* Register with debugger: */
2991 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
2992 CV * const cv = get_cv("DB::postponed", FALSE);
2996 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2998 call_sv((SV*)cv, G_DISCARD);
3003 call_list(PL_scopestack_ix, PL_unitcheckav);
3005 /* compiled okay, so do it */
3007 CvDEPTH(PL_compcv) = 1;
3008 SP = PL_stack_base + POPMARK; /* pop original mark */
3009 PL_op = saveop; /* The caller may need it. */
3010 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3017 S_check_type_and_open(pTHX_ const char *name)
3020 const int st_rc = PerlLIO_stat(name, &st);
3022 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3026 return PerlIO_open(name, PERL_SCRIPT_MODE);
3029 #ifndef PERL_DISABLE_PMC
3031 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3035 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3036 SV *const pmcsv = newSV(namelen + 2);
3037 char *const pmc = SvPVX(pmcsv);
3040 memcpy(pmc, name, namelen);
3042 pmc[namelen + 1] = '\0';
3044 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3045 fp = check_type_and_open(name);
3048 fp = check_type_and_open(pmc);
3050 SvREFCNT_dec(pmcsv);
3053 fp = check_type_and_open(name);
3058 # define doopen_pm(name, namelen) check_type_and_open(name)
3059 #endif /* !PERL_DISABLE_PMC */
3064 register PERL_CONTEXT *cx;
3071 int vms_unixname = 0;
3073 const char *tryname = NULL;
3075 const I32 gimme = GIMME_V;
3076 int filter_has_file = 0;
3077 PerlIO *tryrsfp = NULL;
3078 SV *filter_cache = NULL;
3079 SV *filter_state = NULL;
3080 SV *filter_sub = NULL;
3086 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3087 sv = new_version(sv);
3088 if (!sv_derived_from(PL_patchlevel, "version"))
3089 upg_version(PL_patchlevel, TRUE);
3090 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3091 if ( vcmp(sv,PL_patchlevel) <= 0 )
3092 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3093 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3096 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3099 SV * const req = SvRV(sv);
3100 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3102 /* get the left hand term */
3103 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3105 first = SvIV(*av_fetch(lav,0,0));
3106 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3107 || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3108 || av_len(lav) > 1 /* FP with > 3 digits */
3109 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3111 DIE(aTHX_ "Perl %"SVf" required--this is only "
3112 "%"SVf", stopped", SVfARG(vnormal(req)),
3113 SVfARG(vnormal(PL_patchlevel)));
3115 else { /* probably 'use 5.10' or 'use 5.8' */
3116 SV * hintsv = newSV(0);
3120 second = SvIV(*av_fetch(lav,1,0));
3122 second /= second >= 600 ? 100 : 10;
3123 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3124 (int)first, (int)second,0);
3125 upg_version(hintsv, TRUE);
3127 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3128 "--this is only %"SVf", stopped",
3129 SVfARG(vnormal(req)),
3130 SVfARG(vnormal(hintsv)),
3131 SVfARG(vnormal(PL_patchlevel)));
3136 /* We do this only with use, not require. */
3138 /* If we request a version >= 5.9.5, load feature.pm with the
3139 * feature bundle that corresponds to the required version. */
3140 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3141 SV *const importsv = vnormal(sv);
3142 *SvPVX_mutable(importsv) = ':';
3144 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3150 name = SvPV_const(sv, len);
3151 if (!(name && len > 0 && *name))
3152 DIE(aTHX_ "Null filename used");
3153 TAINT_PROPER("require");
3157 /* The key in the %ENV hash is in the syntax of file passed as the argument
3158 * usually this is in UNIX format, but sometimes in VMS format, which
3159 * can result in a module being pulled in more than once.
3160 * To prevent this, the key must be stored in UNIX format if the VMS
3161 * name can be translated to UNIX.
3163 if ((unixname = tounixspec(name, NULL)) != NULL) {
3164 unixlen = strlen(unixname);
3170 /* if not VMS or VMS name can not be translated to UNIX, pass it
3173 unixname = (char *) name;
3176 if (PL_op->op_type == OP_REQUIRE) {
3177 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3178 unixname, unixlen, 0);
3180 if (*svp != &PL_sv_undef)
3183 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3184 "Compilation failed in require", unixname);
3188 /* prepare to compile file */
3190 if (path_is_absolute(name)) {
3192 tryrsfp = doopen_pm(name, len);
3194 #ifdef MACOS_TRADITIONAL
3198 MacPerl_CanonDir(name, newname, 1);
3199 if (path_is_absolute(newname)) {
3201 tryrsfp = doopen_pm(newname, strlen(newname));
3206 AV * const ar = GvAVn(PL_incgv);
3212 namesv = newSV_type(SVt_PV);
3213 for (i = 0; i <= AvFILL(ar); i++) {
3214 SV * const dirsv = *av_fetch(ar, i, TRUE);
3216 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3223 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3224 && !sv_isobject(loader))
3226 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3229 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3230 PTR2UV(SvRV(dirsv)), name);
3231 tryname = SvPVX_const(namesv);
3242 if (sv_isobject(loader))
3243 count = call_method("INC", G_ARRAY);
3245 count = call_sv(loader, G_ARRAY);
3248 /* Adjust file name if the hook has set an %INC entry */
3249 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3251 tryname = SvPVX_const(*svp);
3260 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3261 && !isGV_with_GP(SvRV(arg))) {
3262 filter_cache = SvRV(arg);
3263 SvREFCNT_inc_simple_void_NN(filter_cache);
3270 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3274 if (SvTYPE(arg) == SVt_PVGV) {
3275 IO * const io = GvIO((GV *)arg);
3280 tryrsfp = IoIFP(io);
3281 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3282 PerlIO_close(IoOFP(io));
3293 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3295 SvREFCNT_inc_simple_void_NN(filter_sub);
3298 filter_state = SP[i];
3299 SvREFCNT_inc_simple_void(filter_state);
3303 if (!tryrsfp && (filter_cache || filter_sub)) {
3304 tryrsfp = PerlIO_open(BIT_BUCKET,
3319 filter_has_file = 0;
3321 SvREFCNT_dec(filter_cache);
3322 filter_cache = NULL;
3325 SvREFCNT_dec(filter_state);
3326 filter_state = NULL;
3329 SvREFCNT_dec(filter_sub);
3334 if (!path_is_absolute(name)
3335 #ifdef MACOS_TRADITIONAL
3336 /* We consider paths of the form :a:b ambiguous and interpret them first
3337 as global then as local
3339 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3346 dir = SvPV_const(dirsv, dirlen);
3352 #ifdef MACOS_TRADITIONAL
3356 MacPerl_CanonDir(name, buf2, 1);
3357 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3361 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3363 sv_setpv(namesv, unixdir);
3364 sv_catpv(namesv, unixname);
3366 # ifdef __SYMBIAN32__
3367 if (PL_origfilename[0] &&
3368 PL_origfilename[1] == ':' &&
3369 !(dir[0] && dir[1] == ':'))
3370 Perl_sv_setpvf(aTHX_ namesv,
3375 Perl_sv_setpvf(aTHX_ namesv,
3379 /* The equivalent of
3380 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3381 but without the need to parse the format string, or
3382 call strlen on either pointer, and with the correct
3383 allocation up front. */
3385 char *tmp = SvGROW(namesv, dirlen + len + 2);
3387 memcpy(tmp, dir, dirlen);
3390 /* name came from an SV, so it will have a '\0' at the
3391 end that we can copy as part of this memcpy(). */
3392 memcpy(tmp, name, len + 1);
3394 SvCUR_set(namesv, dirlen + len + 1);
3396 /* Don't even actually have to turn SvPOK_on() as we
3397 access it directly with SvPVX() below. */
3402 TAINT_PROPER("require");
3403 tryname = SvPVX_const(namesv);
3404 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3406 if (tryname[0] == '.' && tryname[1] == '/')
3410 else if (errno == EMFILE)
3411 /* no point in trying other paths if out of handles */
3418 SAVECOPFILE_FREE(&PL_compiling);
3419 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3420 SvREFCNT_dec(namesv);
3422 if (PL_op->op_type == OP_REQUIRE) {
3423 const char *msgstr = name;
3424 if(errno == EMFILE) {
3426 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3428 msgstr = SvPV_nolen_const(msg);
3430 if (namesv) { /* did we lookup @INC? */
3431 AV * const ar = GvAVn(PL_incgv);
3433 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3434 "%s in @INC%s%s (@INC contains:",
3436 (instr(msgstr, ".h ")
3437 ? " (change .h to .ph maybe?)" : ""),
3438 (instr(msgstr, ".ph ")
3439 ? " (did you run h2ph?)" : "")
3442 for (i = 0; i <= AvFILL(ar); i++) {
3443 sv_catpvs(msg, " ");
3444 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3446 sv_catpvs(msg, ")");
3447 msgstr = SvPV_nolen_const(msg);
3450 DIE(aTHX_ "Can't locate %s", msgstr);
3456 SETERRNO(0, SS_NORMAL);
3458 /* Assume success here to prevent recursive requirement. */
3459 /* name is never assigned to again, so len is still strlen(name) */
3460 /* Check whether a hook in @INC has already filled %INC */
3462 (void)hv_store(GvHVn(PL_incgv),
3463 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3465 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3467 (void)hv_store(GvHVn(PL_incgv),
3468 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3473 lex_start(NULL, tryrsfp, TRUE);
3477 SAVECOMPILEWARNINGS();
3478 if (PL_dowarn & G_WARN_ALL_ON)
3479 PL_compiling.cop_warnings = pWARN_ALL ;
3480 else if (PL_dowarn & G_WARN_ALL_OFF)
3481 PL_compiling.cop_warnings = pWARN_NONE ;
3483 PL_compiling.cop_warnings = pWARN_STD ;
3485 if (filter_sub || filter_cache) {
3486 SV * const datasv = filter_add(S_run_user_filter, NULL);
3487 IoLINES(datasv) = filter_has_file;
3488 IoTOP_GV(datasv) = (GV *)filter_state;
3489 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3490 IoFMT_GV(datasv) = (GV *)filter_cache;
3493 /* switch to eval mode */
3494 PUSHBLOCK(cx, CXt_EVAL, SP);
3495 PUSHEVAL(cx, name, NULL);
3496 cx->blk_eval.retop = PL_op->op_next;
3498 SAVECOPLINE(&PL_compiling);
3499 CopLINE_set(&PL_compiling, 0);
3503 /* Store and reset encoding. */
3504 encoding = PL_encoding;
3507 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3508 op = DOCATCH(PL_eval_start);
3510 op = PL_op->op_next;
3512 /* Restore encoding. */
3513 PL_encoding = encoding;
3521 register PERL_CONTEXT *cx;
3523 const I32 gimme = GIMME_V;
3524 const I32 was = PL_sub_generation;
3525 char tbuf[TYPE_DIGITS(long) + 12];
3526 char *tmpbuf = tbuf;
3532 HV *saved_hh = NULL;
3533 const char * const fakestr = "_<(eval )";
3534 const int fakelen = 9 + 1;
3536 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3537 saved_hh = (HV*) SvREFCNT_inc(POPs);
3541 TAINT_IF(SvTAINTED(sv));
3542 TAINT_PROPER("eval");
3545 lex_start(sv, NULL, FALSE);
3548 /* switch to eval mode */
3550 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3551 SV * const temp_sv = sv_newmortal();
3552 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3553 (unsigned long)++PL_evalseq,
3554 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3555 tmpbuf = SvPVX(temp_sv);
3556 len = SvCUR(temp_sv);
3559 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3560 SAVECOPFILE_FREE(&PL_compiling);
3561 CopFILE_set(&PL_compiling, tmpbuf+2);
3562 SAVECOPLINE(&PL_compiling);
3563 CopLINE_set(&PL_compiling, 1);
3564 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3565 deleting the eval's FILEGV from the stash before gv_check() runs
3566 (i.e. before run-time proper). To work around the coredump that
3567 ensues, we always turn GvMULTI_on for any globals that were
3568 introduced within evals. See force_ident(). GSAR 96-10-12 */
3569 safestr = savepvn(tmpbuf, len);
3570 SAVEDELETE(PL_defstash, safestr, len);
3572 PL_hints = PL_op->op_targ;
3574 GvHV(PL_hintgv) = saved_hh;
3575 SAVECOMPILEWARNINGS();
3576 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3577 if (PL_compiling.cop_hints_hash) {
3578 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3580 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3581 if (PL_compiling.cop_hints_hash) {
3583 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3584 HINTS_REFCNT_UNLOCK;
3586 /* special case: an eval '' executed within the DB package gets lexically
3587 * placed in the first non-DB CV rather than the current CV - this
3588 * allows the debugger to execute code, find lexicals etc, in the
3589 * scope of the code being debugged. Passing &seq gets find_runcv
3590 * to do the dirty work for us */
3591 runcv = find_runcv(&seq);
3593 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3594 PUSHEVAL(cx, 0, NULL);
3595 cx->blk_eval.retop = PL_op->op_next;
3597 /* prepare to compile string */
3599 if (PERLDB_LINE && PL_curstash != PL_debstash)
3600 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3602 ok = doeval(gimme, NULL, runcv, seq);
3603 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3605 /* Copy in anything fake and short. */
3606 my_strlcpy(safestr, fakestr, fakelen);
3608 return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3618 register PERL_CONTEXT *cx;
3620 const U8 save_flags = PL_op -> op_flags;
3625 retop = cx->blk_eval.retop;
3628 if (gimme == G_VOID)
3630 else if (gimme == G_SCALAR) {
3633 if (SvFLAGS(TOPs) & SVs_TEMP)
3636 *MARK = sv_mortalcopy(TOPs);
3640 *MARK = &PL_sv_undef;
3645 /* in case LEAVE wipes old return values */
3646 for (mark = newsp + 1; mark <= SP; mark++) {
3647 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3648 *mark = sv_mortalcopy(*mark);
3649 TAINT_NOT; /* Each item is independent */
3653 PL_curpm = newpm; /* Don't pop $1 et al till now */
3656 assert(CvDEPTH(PL_compcv) == 1);
3658 CvDEPTH(PL_compcv) = 0;
3661 if (optype == OP_REQUIRE &&
3662 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3664 /* Unassume the success we assumed earlier. */
3665 SV * const nsv = cx->blk_eval.old_namesv;
3666 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3667 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3668 /* die_where() did LEAVE, or we won't be here */
3672 if (!(save_flags & OPf_SPECIAL))
3673 sv_setpvn(ERRSV,"",0);
3679 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3680 close to the related Perl_create_eval_scope. */
3682 Perl_delete_eval_scope(pTHX)
3687 register PERL_CONTEXT *cx;
3694 PERL_UNUSED_VAR(newsp);
3695 PERL_UNUSED_VAR(gimme);
3696 PERL_UNUSED_VAR(optype);
3699 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3700 also needed by Perl_fold_constants. */
3702 Perl_create_eval_scope(pTHX_ U32 flags)
3705 const I32 gimme = GIMME_V;
3710 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3713 PL_in_eval = EVAL_INEVAL;
3714 if (flags & G_KEEPERR)
3715 PL_in_eval |= EVAL_KEEPERR;
3717 sv_setpvn(ERRSV,"",0);
3718 if (flags & G_FAKINGEVAL) {
3719 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3727 PERL_CONTEXT * const cx = create_eval_scope(0);
3728 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3729 return DOCATCH(PL_op->op_next);
3738 register PERL_CONTEXT *cx;
3743 PERL_UNUSED_VAR(optype);
3746 if (gimme == G_VOID)
3748 else if (gimme == G_SCALAR) {
3752 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3755 *MARK = sv_mortalcopy(TOPs);
3759 *MARK = &PL_sv_undef;
3764 /* in case LEAVE wipes old return values */
3766 for (mark = newsp + 1; mark <= SP; mark++) {
3767 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3768 *mark = sv_mortalcopy(*mark);
3769 TAINT_NOT; /* Each item is independent */
3773 PL_curpm = newpm; /* Don't pop $1 et al till now */
3776 sv_setpvn(ERRSV,"",0);
3783 register PERL_CONTEXT *cx;
3784 const I32 gimme = GIMME_V;
3789 if (PL_op->op_targ == 0) {
3790 SV ** const defsv_p = &GvSV(PL_defgv);
3791 *defsv_p = newSVsv(POPs);
3792 SAVECLEARSV(*defsv_p);
3795 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3797 PUSHBLOCK(cx, CXt_GIVEN, SP);
3806 register PERL_CONTEXT *cx;
3810 PERL_UNUSED_CONTEXT;
3813 assert(CxTYPE(cx) == CXt_GIVEN);
3818 PL_curpm = newpm; /* pop $1 et al */
3825 /* Helper routines used by pp_smartmatch */
3827 S_make_matcher(pTHX_ REGEXP *re)
3830 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3831 PM_SETRE(matcher, ReREFCNT_inc(re));
3833 SAVEFREEOP((OP *) matcher);
3840 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3845 PL_op = (OP *) matcher;
3850 return (SvTRUEx(POPs));
3854 S_destroy_matcher(pTHX_ PMOP *matcher)
3857 PERL_UNUSED_ARG(matcher);
3862 /* Do a smart match */
3865 return do_smartmatch(NULL, NULL);
3868 /* This version of do_smartmatch() implements the
3869 * table of smart matches that is found in perlsyn.
3872 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3877 SV *e = TOPs; /* e is for 'expression' */
3878 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3879 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3880 REGEXP *this_regex, *other_regex;
3882 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3884 # define SM_REF(type) ( \
3885 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3886 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3888 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3889 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
3890 && NOT_EMPTY_PROTO(This) && (Other = e)) \
3891 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
3892 && NOT_EMPTY_PROTO(This) && (Other = d)))
3894 # define SM_REGEX ( \
3895 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \
3896 && (this_regex = (REGEXP*) This) \
3899 (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \
3900 && (this_regex = (REGEXP*) This) \
3904 # define SM_OTHER_REF(type) \
3905 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3907 # define SM_OTHER_REGEX (SvROK(Other) \
3908 && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \
3909 && (other_regex = (REGEXP*) SvRV(Other)))
3912 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3913 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3915 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3916 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3918 tryAMAGICbinSET(smart, 0);
3920 SP -= 2; /* Pop the values */
3922 /* Take care only to invoke mg_get() once for each argument.
3923 * Currently we do this by copying the SV if it's magical. */
3926 d = sv_mortalcopy(d);
3933 e = sv_mortalcopy(e);
3938 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3940 if (This == SvRV(Other))
3951 c = call_sv(This, G_SCALAR);
3955 else if (SvTEMP(TOPs))
3956 SvREFCNT_inc_void(TOPs);
3961 else if (SM_REF(PVHV)) {
3962 if (SM_OTHER_REF(PVHV)) {
3963 /* Check that the key-sets are identical */
3965 HV *other_hv = (HV *) SvRV(Other);
3967 bool other_tied = FALSE;
3968 U32 this_key_count = 0,
3969 other_key_count = 0;
3971 /* Tied hashes don't know how many keys they have. */
3972 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
3975 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3976 HV * const temp = other_hv;
3977 other_hv = (HV *) This;
3981 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3984 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
3987 /* The hashes have the same number of keys, so it suffices
3988 to check that one is a subset of the other. */
3989 (void) hv_iterinit((HV *) This);
3990 while ( (he = hv_iternext((HV *) This)) ) {
3992 char * const key = hv_iterkey(he, &key_len);
3996 if(!hv_exists(other_hv, key, key_len)) {
3997 (void) hv_iterinit((HV *) This); /* reset iterator */
4003 (void) hv_iterinit(other_hv);
4004 while ( hv_iternext(other_hv) )
4008 other_key_count = HvUSEDKEYS(other_hv);
4010 if (this_key_count != other_key_count)
4015 else if (SM_OTHER_REF(PVAV)) {
4016 AV * const other_av = (AV *) SvRV(Other);
4017 const I32 other_len = av_len(other_av) + 1;
4020 for (i = 0; i < other_len; ++i) {
4021 SV ** const svp = av_fetch(other_av, i, FALSE);
4025 if (svp) { /* ??? When can this not happen? */
4026 key = SvPV(*svp, key_len);
4027 if (hv_exists((HV *) This, key, key_len))
4033 else if (SM_OTHER_REGEX) {
4034 PMOP * const matcher = make_matcher(other_regex);
4037 (void) hv_iterinit((HV *) This);
4038 while ( (he = hv_iternext((HV *) This)) ) {
4039 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4040 (void) hv_iterinit((HV *) This);
4041 destroy_matcher(matcher);
4045 destroy_matcher(matcher);
4049 if (hv_exists_ent((HV *) This, Other, 0))
4055 else if (SM_REF(PVAV)) {
4056 if (SM_OTHER_REF(PVAV)) {
4057 AV *other_av = (AV *) SvRV(Other);
4058 if (av_len((AV *) This) != av_len(other_av))
4062 const I32 other_len = av_len(other_av);
4064 if (NULL == seen_this) {
4065 seen_this = newHV();
4066 (void) sv_2mortal((SV *) seen_this);
4068 if (NULL == seen_other) {
4069 seen_this = newHV();
4070 (void) sv_2mortal((SV *) seen_other);
4072 for(i = 0; i <= other_len; ++i) {
4073 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4074 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4076 if (!this_elem || !other_elem) {
4077 if (this_elem || other_elem)
4080 else if (SM_SEEN_THIS(*this_elem)
4081 || SM_SEEN_OTHER(*other_elem))
4083 if (*this_elem != *other_elem)
4087 (void)hv_store_ent(seen_this,
4088 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4090 (void)hv_store_ent(seen_other,
4091 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4097 (void) do_smartmatch(seen_this, seen_other);
4107 else if (SM_OTHER_REGEX) {
4108 PMOP * const matcher = make_matcher(other_regex);
4109 const I32 this_len = av_len((AV *) This);
4112 for(i = 0; i <= this_len; ++i) {
4113 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4114 if (svp && matcher_matches_sv(matcher, *svp)) {
4115 destroy_matcher(matcher);
4119 destroy_matcher(matcher);
4122 else if (SvIOK(Other) || SvNOK(Other)) {
4125 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4126 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4133 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4143 else if (SvPOK(Other)) {
4144 const I32 this_len = av_len((AV *) This);
4147 for(i = 0; i <= this_len; ++i) {
4148 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4163 else if (!SvOK(d) || !SvOK(e)) {
4164 if (!SvOK(d) && !SvOK(e))
4169 else if (SM_REGEX) {
4170 PMOP * const matcher = make_matcher(this_regex);
4173 PUSHs(matcher_matches_sv(matcher, Other)
4176 destroy_matcher(matcher);
4179 else if (SM_REF(PVCV)) {
4181 /* This must be a null-prototyped sub, because we
4182 already checked for the other kind. */
4188 c = call_sv(This, G_SCALAR);
4191 PUSHs(&PL_sv_undef);
4192 else if (SvTEMP(TOPs))
4193 SvREFCNT_inc_void(TOPs);
4195 if (SM_OTHER_REF(PVCV)) {
4196 /* This one has to be null-proto'd too.
4197 Call both of 'em, and compare the results */
4199 c = call_sv(SvRV(Other), G_SCALAR);
4202 PUSHs(&PL_sv_undef);
4203 else if (SvTEMP(TOPs))
4204 SvREFCNT_inc_void(TOPs);
4215 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4216 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4218 if (SvPOK(Other) && !looks_like_number(Other)) {
4219 /* String comparison */
4224 /* Otherwise, numeric comparison */
4227 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4238 /* As a last resort, use string comparison */
4247 register PERL_CONTEXT *cx;
4248 const I32 gimme = GIMME_V;
4250 /* This is essentially an optimization: if the match
4251 fails, we don't want to push a context and then
4252 pop it again right away, so we skip straight
4253 to the op that follows the leavewhen.
4255 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4256 return cLOGOP->op_other->op_next;
4261 PUSHBLOCK(cx, CXt_WHEN, SP);
4270 register PERL_CONTEXT *cx;
4276 assert(CxTYPE(cx) == CXt_WHEN);
4281 PL_curpm = newpm; /* pop $1 et al */
4291 register PERL_CONTEXT *cx;
4294 cxix = dopoptowhen(cxstack_ix);
4296 DIE(aTHX_ "Can't \"continue\" outside a when block");
4297 if (cxix < cxstack_ix)
4300 /* clear off anything above the scope we're re-entering */
4301 inner = PL_scopestack_ix;
4303 if (PL_scopestack_ix < inner)
4304 leave_scope(PL_scopestack[PL_scopestack_ix]);
4305 PL_curcop = cx->blk_oldcop;
4306 return cx->blk_givwhen.leave_op;
4313 register PERL_CONTEXT *cx;
4316 cxix = dopoptogiven(cxstack_ix);
4318 if (PL_op->op_flags & OPf_SPECIAL)
4319 DIE(aTHX_ "Can't use when() outside a topicalizer");
4321 DIE(aTHX_ "Can't \"break\" outside a given block");
4323 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4324 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4326 if (cxix < cxstack_ix)
4329 /* clear off anything above the scope we're re-entering */
4330 inner = PL_scopestack_ix;
4332 if (PL_scopestack_ix < inner)
4333 leave_scope(PL_scopestack[PL_scopestack_ix]);
4334 PL_curcop = cx->blk_oldcop;
4337 return CX_LOOP_NEXTOP_GET(cx);
4339 return cx->blk_givwhen.leave_op;
4343 S_doparseform(pTHX_ SV *sv)
4346 register char *s = SvPV_force(sv, len);
4347 register char * const send = s + len;
4348 register char *base = NULL;
4349 register I32 skipspaces = 0;
4350 bool noblank = FALSE;
4351 bool repeat = FALSE;
4352 bool postspace = FALSE;
4358 bool unchopnum = FALSE;
4359 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4362 Perl_croak(aTHX_ "Null picture in formline");
4364 /* estimate the buffer size needed */
4365 for (base = s; s <= send; s++) {
4366 if (*s == '\n' || *s == '@' || *s == '^')
4372 Newx(fops, maxops, U32);
4377 *fpc++ = FF_LINEMARK;
4378 noblank = repeat = FALSE;
4396 case ' ': case '\t':
4403 } /* else FALL THROUGH */
4411 *fpc++ = FF_LITERAL;
4419 *fpc++ = (U16)skipspaces;
4423 *fpc++ = FF_NEWLINE;
4427 arg = fpc - linepc + 1;
4434 *fpc++ = FF_LINEMARK;
4435 noblank = repeat = FALSE;
4444 ischop = s[-1] == '^';
4450 arg = (s - base) - 1;
4452 *fpc++ = FF_LITERAL;
4460 *fpc++ = 2; /* skip the @* or ^* */
4462 *fpc++ = FF_LINESNGL;
4465 *fpc++ = FF_LINEGLOB;
4467 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4468 arg = ischop ? 512 : 0;
4473 const char * const f = ++s;
4476 arg |= 256 + (s - f);
4478 *fpc++ = s - base; /* fieldsize for FETCH */
4479 *fpc++ = FF_DECIMAL;
4481 unchopnum |= ! ischop;
4483 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4484 arg = ischop ? 512 : 0;
4486 s++; /* skip the '0' first */
4490 const char * const f = ++s;
4493 arg |= 256 + (s - f);
4495 *fpc++ = s - base; /* fieldsize for FETCH */
4496 *fpc++ = FF_0DECIMAL;
4498 unchopnum |= ! ischop;
4502 bool ismore = FALSE;
4505 while (*++s == '>') ;
4506 prespace = FF_SPACE;
4508 else if (*s == '|') {
4509 while (*++s == '|') ;
4510 prespace = FF_HALFSPACE;
4515 while (*++s == '<') ;
4518 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4522 *fpc++ = s - base; /* fieldsize for FETCH */
4524 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4527 *fpc++ = (U16)prespace;
4541 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4543 { /* need to jump to the next word */
4545 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4546 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4547 s = SvPVX(sv) + SvCUR(sv) + z;
4549 Copy(fops, s, arg, U32);
4551 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4554 if (unchopnum && repeat)
4555 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4561 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4563 /* Can value be printed in fldsize chars, using %*.*f ? */
4567 int intsize = fldsize - (value < 0 ? 1 : 0);
4574 while (intsize--) pwr *= 10.0;
4575 while (frcsize--) eps /= 10.0;
4578 if (value + eps >= pwr)
4581 if (value - eps <= -pwr)
4588 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4591 SV * const datasv = FILTER_DATA(idx);
4592 const int filter_has_file = IoLINES(datasv);
4593 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4594 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4598 const char *got_p = NULL;
4599 const char *prune_from = NULL;
4600 bool read_from_cache = FALSE;
4603 assert(maxlen >= 0);
4606 /* I was having segfault trouble under Linux 2.2.5 after a
4607 parse error occured. (Had to hack around it with a test
4608 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4609 not sure where the trouble is yet. XXX */
4611 if (IoFMT_GV(datasv)) {
4612 SV *const cache = (SV *)IoFMT_GV(datasv);
4615 const char *cache_p = SvPV(cache, cache_len);
4619 /* Running in block mode and we have some cached data already.
4621 if (cache_len >= umaxlen) {
4622 /* In fact, so much data we don't even need to call
4627 const char *const first_nl =
4628 (const char *)memchr(cache_p, '\n', cache_len);
4630 take = first_nl + 1 - cache_p;
4634 sv_catpvn(buf_sv, cache_p, take);
4635 sv_chop(cache, cache_p + take);
4636 /* Definately not EOF */
4640 sv_catsv(buf_sv, cache);
4642 umaxlen -= cache_len;
4645 read_from_cache = TRUE;
4649 /* Filter API says that the filter appends to the contents of the buffer.
4650 Usually the buffer is "", so the details don't matter. But if it's not,
4651 then clearly what it contains is already filtered by this filter, so we
4652 don't want to pass it in a second time.
4653 I'm going to use a mortal in case the upstream filter croaks. */
4654 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4655 ? sv_newmortal() : buf_sv;
4656 SvUPGRADE(upstream, SVt_PV);
4658 if (filter_has_file) {
4659 status = FILTER_READ(idx+1, upstream, 0);
4662 if (filter_sub && status >= 0) {
4675 PUSHs(filter_state);
4678 count = call_sv(filter_sub, G_SCALAR);
4693 if(SvOK(upstream)) {
4694 got_p = SvPV(upstream, got_len);
4696 if (got_len > umaxlen) {
4697 prune_from = got_p + umaxlen;
4700 const char *const first_nl =
4701 (const char *)memchr(got_p, '\n', got_len);
4702 if (first_nl && first_nl + 1 < got_p + got_len) {
4703 /* There's a second line here... */
4704 prune_from = first_nl + 1;
4709 /* Oh. Too long. Stuff some in our cache. */
4710 STRLEN cached_len = got_p + got_len - prune_from;
4711 SV *cache = (SV *)IoFMT_GV(datasv);
4714 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4715 } else if (SvOK(cache)) {
4716 /* Cache should be empty. */
4717 assert(!SvCUR(cache));
4720 sv_setpvn(cache, prune_from, cached_len);
4721 /* If you ask for block mode, you may well split UTF-8 characters.
4722 "If it breaks, you get to keep both parts"
4723 (Your code is broken if you don't put them back together again
4724 before something notices.) */
4725 if (SvUTF8(upstream)) {
4728 SvCUR_set(upstream, got_len - cached_len);
4729 /* Can't yet be EOF */
4734 /* If they are at EOF but buf_sv has something in it, then they may never
4735 have touched the SV upstream, so it may be undefined. If we naively
4736 concatenate it then we get a warning about use of uninitialised value.
4738 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4739 sv_catsv(buf_sv, upstream);
4743 IoLINES(datasv) = 0;
4744 SvREFCNT_dec(IoFMT_GV(datasv));
4746 SvREFCNT_dec(filter_state);
4747 IoTOP_GV(datasv) = NULL;
4750 SvREFCNT_dec(filter_sub);
4751 IoBOTTOM_GV(datasv) = NULL;
4753 filter_del(S_run_user_filter);
4755 if (status == 0 && read_from_cache) {
4756 /* If we read some data from the cache (and by getting here it implies
4757 that we emptied the cache) then we aren't yet at EOF, and mustn't
4758 report that to our caller. */
4764 /* perhaps someone can come up with a better name for
4765 this? it is not really "absolute", per se ... */
4767 S_path_is_absolute(const char *name)
4769 if (PERL_FILE_IS_ABSOLUTE(name)
4770 #ifdef MACOS_TRADITIONAL
4773 || (*name == '.' && (name[1] == '/' ||
4774 (name[1] == '.' && name[2] == '/')))
4786 * c-indentation-style: bsd
4788 * indent-tabs-mode: t
4791 * ex: set ts=8 sts=4 sw=4 noet: