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);
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 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) { /* require v5.6.1 */
3088 HV * hinthv = GvHV(PL_hintgv);
3090 if (hinthv) ptr = hv_fetchs(hinthv, "v_string", FALSE);
3091 if ( !(ptr && *ptr && SvIOK(*ptr) && SvIV(*ptr)) )
3092 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3093 "v-string in use/require non-portable");
3095 sv = new_version(sv);
3096 if (!sv_derived_from(PL_patchlevel, "version"))
3097 upg_version(PL_patchlevel, TRUE);
3098 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3099 if ( vcmp(sv,PL_patchlevel) <= 0 )
3100 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3101 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3104 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3107 SV * const req = SvRV(sv);
3108 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3110 /* get the left hand term */
3111 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3113 first = SvIV(*av_fetch(lav,0,0));
3114 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3115 || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3116 || av_len(lav) > 1 /* FP with > 3 digits */
3117 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3119 DIE(aTHX_ "Perl %"SVf" required--this is only "
3120 "%"SVf", stopped", SVfARG(vnormal(req)),
3121 SVfARG(vnormal(PL_patchlevel)));
3123 else { /* probably 'use 5.10' or 'use 5.8' */
3124 SV * hintsv = newSV(0);
3128 second = SvIV(*av_fetch(lav,1,0));
3130 second /= second >= 600 ? 100 : 10;
3131 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3132 (int)first, (int)second,0);
3133 upg_version(hintsv, TRUE);
3135 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3136 "--this is only %"SVf", stopped",
3137 SVfARG(vnormal(req)),
3138 SVfARG(vnormal(hintsv)),
3139 SVfARG(vnormal(PL_patchlevel)));
3144 /* We do this only with use, not require. */
3146 /* If we request a version >= 5.6.0, then v-string are OK
3147 so set $^H{v_string} to suppress the v-string warning */
3148 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.006), FALSE))) >= 0) {
3149 HV * hinthv = GvHV(PL_hintgv);
3151 SV *hint = newSViv(1);
3152 (void)hv_stores(hinthv, "v_string", hint);
3153 /* This will call through to Perl_magic_sethint() which in turn
3154 sets PL_hints correctly. */
3157 /* If we request a version >= 5.9.5, load feature.pm with the
3158 * feature bundle that corresponds to the required version. */
3159 if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3160 SV *const importsv = vnormal(sv);
3161 *SvPVX_mutable(importsv) = ':';
3163 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3170 name = SvPV_const(sv, len);
3171 if (!(name && len > 0 && *name))
3172 DIE(aTHX_ "Null filename used");
3173 TAINT_PROPER("require");
3177 /* The key in the %ENV hash is in the syntax of file passed as the argument
3178 * usually this is in UNIX format, but sometimes in VMS format, which
3179 * can result in a module being pulled in more than once.
3180 * To prevent this, the key must be stored in UNIX format if the VMS
3181 * name can be translated to UNIX.
3183 if ((unixname = tounixspec(name, NULL)) != NULL) {
3184 unixlen = strlen(unixname);
3190 /* if not VMS or VMS name can not be translated to UNIX, pass it
3193 unixname = (char *) name;
3196 if (PL_op->op_type == OP_REQUIRE) {
3197 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3198 unixname, unixlen, 0);
3200 if (*svp != &PL_sv_undef)
3203 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3204 "Compilation failed in require", unixname);
3208 /* prepare to compile file */
3210 if (path_is_absolute(name)) {
3212 tryrsfp = doopen_pm(name, len);
3214 #ifdef MACOS_TRADITIONAL
3218 MacPerl_CanonDir(name, newname, 1);
3219 if (path_is_absolute(newname)) {
3221 tryrsfp = doopen_pm(newname, strlen(newname));
3226 AV * const ar = GvAVn(PL_incgv);
3233 sv_upgrade(namesv, SVt_PV);
3234 for (i = 0; i <= AvFILL(ar); i++) {
3235 SV * const dirsv = *av_fetch(ar, i, TRUE);
3237 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3244 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3245 && !sv_isobject(loader))
3247 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3250 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3251 PTR2UV(SvRV(dirsv)), name);
3252 tryname = SvPVX_const(namesv);
3263 if (sv_isobject(loader))
3264 count = call_method("INC", G_ARRAY);
3266 count = call_sv(loader, G_ARRAY);
3269 /* Adjust file name if the hook has set an %INC entry */
3270 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3272 tryname = SvPVX_const(*svp);
3281 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3282 && !isGV_with_GP(SvRV(arg))) {
3283 filter_cache = SvRV(arg);
3284 SvREFCNT_inc_simple_void_NN(filter_cache);
3291 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3295 if (SvTYPE(arg) == SVt_PVGV) {
3296 IO * const io = GvIO((GV *)arg);
3301 tryrsfp = IoIFP(io);
3302 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3303 PerlIO_close(IoOFP(io));
3314 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3316 SvREFCNT_inc_simple_void_NN(filter_sub);
3319 filter_state = SP[i];
3320 SvREFCNT_inc_simple_void(filter_state);
3324 if (!tryrsfp && (filter_cache || filter_sub)) {
3325 tryrsfp = PerlIO_open(BIT_BUCKET,
3340 filter_has_file = 0;
3342 SvREFCNT_dec(filter_cache);
3343 filter_cache = NULL;
3346 SvREFCNT_dec(filter_state);
3347 filter_state = NULL;
3350 SvREFCNT_dec(filter_sub);
3355 if (!path_is_absolute(name)
3356 #ifdef MACOS_TRADITIONAL
3357 /* We consider paths of the form :a:b ambiguous and interpret them first
3358 as global then as local
3360 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3367 dir = SvPV_const(dirsv, dirlen);
3373 #ifdef MACOS_TRADITIONAL
3377 MacPerl_CanonDir(name, buf2, 1);
3378 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3382 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3384 sv_setpv(namesv, unixdir);
3385 sv_catpv(namesv, unixname);
3387 # ifdef __SYMBIAN32__
3388 if (PL_origfilename[0] &&
3389 PL_origfilename[1] == ':' &&
3390 !(dir[0] && dir[1] == ':'))
3391 Perl_sv_setpvf(aTHX_ namesv,
3396 Perl_sv_setpvf(aTHX_ namesv,
3400 /* The equivalent of
3401 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3402 but without the need to parse the format string, or
3403 call strlen on either pointer, and with the correct
3404 allocation up front. */
3406 char *tmp = SvGROW(namesv, dirlen + len + 2);
3408 memcpy(tmp, dir, dirlen);
3411 /* name came from an SV, so it will have a '\0' at the
3412 end that we can copy as part of this memcpy(). */
3413 memcpy(tmp, name, len + 1);
3415 SvCUR_set(namesv, dirlen + len + 1);
3417 /* Don't even actually have to turn SvPOK_on() as we
3418 access it directly with SvPVX() below. */
3423 TAINT_PROPER("require");
3424 tryname = SvPVX_const(namesv);
3425 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3427 if (tryname[0] == '.' && tryname[1] == '/')
3431 else if (errno == EMFILE)
3432 /* no point in trying other paths if out of handles */
3439 SAVECOPFILE_FREE(&PL_compiling);
3440 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3441 SvREFCNT_dec(namesv);
3443 if (PL_op->op_type == OP_REQUIRE) {
3444 const char *msgstr = name;
3445 if(errno == EMFILE) {
3447 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3449 msgstr = SvPV_nolen_const(msg);
3451 if (namesv) { /* did we lookup @INC? */
3452 AV * const ar = GvAVn(PL_incgv);
3454 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3455 "%s in @INC%s%s (@INC contains:",
3457 (instr(msgstr, ".h ")
3458 ? " (change .h to .ph maybe?)" : ""),
3459 (instr(msgstr, ".ph ")
3460 ? " (did you run h2ph?)" : "")
3463 for (i = 0; i <= AvFILL(ar); i++) {
3464 sv_catpvs(msg, " ");
3465 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3467 sv_catpvs(msg, ")");
3468 msgstr = SvPV_nolen_const(msg);
3471 DIE(aTHX_ "Can't locate %s", msgstr);
3477 SETERRNO(0, SS_NORMAL);
3479 /* Assume success here to prevent recursive requirement. */
3480 /* name is never assigned to again, so len is still strlen(name) */
3481 /* Check whether a hook in @INC has already filled %INC */
3483 (void)hv_store(GvHVn(PL_incgv),
3484 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3486 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3488 (void)hv_store(GvHVn(PL_incgv),
3489 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3494 lex_start(NULL, tryrsfp, TRUE);
3498 SAVECOMPILEWARNINGS();
3499 if (PL_dowarn & G_WARN_ALL_ON)
3500 PL_compiling.cop_warnings = pWARN_ALL ;
3501 else if (PL_dowarn & G_WARN_ALL_OFF)
3502 PL_compiling.cop_warnings = pWARN_NONE ;
3504 PL_compiling.cop_warnings = pWARN_STD ;
3506 if (filter_sub || filter_cache) {
3507 SV * const datasv = filter_add(S_run_user_filter, NULL);
3508 IoLINES(datasv) = filter_has_file;
3509 IoTOP_GV(datasv) = (GV *)filter_state;
3510 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3511 IoFMT_GV(datasv) = (GV *)filter_cache;
3514 /* switch to eval mode */
3515 PUSHBLOCK(cx, CXt_EVAL, SP);
3516 PUSHEVAL(cx, name, NULL);
3517 cx->blk_eval.retop = PL_op->op_next;
3519 SAVECOPLINE(&PL_compiling);
3520 CopLINE_set(&PL_compiling, 0);
3524 /* Store and reset encoding. */
3525 encoding = PL_encoding;
3528 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3529 op = DOCATCH(PL_eval_start);
3531 op = PL_op->op_next;
3533 /* Restore encoding. */
3534 PL_encoding = encoding;
3542 register PERL_CONTEXT *cx;
3544 const I32 gimme = GIMME_V;
3545 const I32 was = PL_sub_generation;
3546 char tbuf[TYPE_DIGITS(long) + 12];
3547 char *tmpbuf = tbuf;
3553 HV *saved_hh = NULL;
3554 const char * const fakestr = "_<(eval )";
3555 const int fakelen = 9 + 1;
3557 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3558 saved_hh = (HV*) SvREFCNT_inc(POPs);
3562 TAINT_IF(SvTAINTED(sv));
3563 TAINT_PROPER("eval");
3566 lex_start(sv, NULL, FALSE);
3569 /* switch to eval mode */
3571 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3572 SV * const temp_sv = sv_newmortal();
3573 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3574 (unsigned long)++PL_evalseq,
3575 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3576 tmpbuf = SvPVX(temp_sv);
3577 len = SvCUR(temp_sv);
3580 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3581 SAVECOPFILE_FREE(&PL_compiling);
3582 CopFILE_set(&PL_compiling, tmpbuf+2);
3583 SAVECOPLINE(&PL_compiling);
3584 CopLINE_set(&PL_compiling, 1);
3585 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3586 deleting the eval's FILEGV from the stash before gv_check() runs
3587 (i.e. before run-time proper). To work around the coredump that
3588 ensues, we always turn GvMULTI_on for any globals that were
3589 introduced within evals. See force_ident(). GSAR 96-10-12 */
3590 safestr = savepvn(tmpbuf, len);
3591 SAVEDELETE(PL_defstash, safestr, len);
3593 PL_hints = PL_op->op_targ;
3595 GvHV(PL_hintgv) = saved_hh;
3596 SAVECOMPILEWARNINGS();
3597 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3598 if (PL_compiling.cop_hints_hash) {
3599 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3601 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3602 if (PL_compiling.cop_hints_hash) {
3604 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3605 HINTS_REFCNT_UNLOCK;
3607 /* special case: an eval '' executed within the DB package gets lexically
3608 * placed in the first non-DB CV rather than the current CV - this
3609 * allows the debugger to execute code, find lexicals etc, in the
3610 * scope of the code being debugged. Passing &seq gets find_runcv
3611 * to do the dirty work for us */
3612 runcv = find_runcv(&seq);
3614 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3615 PUSHEVAL(cx, 0, NULL);
3616 cx->blk_eval.retop = PL_op->op_next;
3618 /* prepare to compile string */
3620 if (PERLDB_LINE && PL_curstash != PL_debstash)
3621 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3623 ok = doeval(gimme, NULL, runcv, seq);
3624 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3626 /* Copy in anything fake and short. */
3627 my_strlcpy(safestr, fakestr, fakelen);
3629 return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3639 register PERL_CONTEXT *cx;
3641 const U8 save_flags = PL_op -> op_flags;
3646 retop = cx->blk_eval.retop;
3649 if (gimme == G_VOID)
3651 else if (gimme == G_SCALAR) {
3654 if (SvFLAGS(TOPs) & SVs_TEMP)
3657 *MARK = sv_mortalcopy(TOPs);
3661 *MARK = &PL_sv_undef;
3666 /* in case LEAVE wipes old return values */
3667 for (mark = newsp + 1; mark <= SP; mark++) {
3668 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3669 *mark = sv_mortalcopy(*mark);
3670 TAINT_NOT; /* Each item is independent */
3674 PL_curpm = newpm; /* Don't pop $1 et al till now */
3677 assert(CvDEPTH(PL_compcv) == 1);
3679 CvDEPTH(PL_compcv) = 0;
3682 if (optype == OP_REQUIRE &&
3683 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3685 /* Unassume the success we assumed earlier. */
3686 SV * const nsv = cx->blk_eval.old_namesv;
3687 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3688 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3689 /* die_where() did LEAVE, or we won't be here */
3693 if (!(save_flags & OPf_SPECIAL))
3694 sv_setpvn(ERRSV,"",0);
3700 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3701 close to the related Perl_create_eval_scope. */
3703 Perl_delete_eval_scope(pTHX)
3708 register PERL_CONTEXT *cx;
3715 PERL_UNUSED_VAR(newsp);
3716 PERL_UNUSED_VAR(gimme);
3717 PERL_UNUSED_VAR(optype);
3720 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3721 also needed by Perl_fold_constants. */
3723 Perl_create_eval_scope(pTHX_ U32 flags)
3726 const I32 gimme = GIMME_V;
3731 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3734 PL_in_eval = EVAL_INEVAL;
3735 if (flags & G_KEEPERR)
3736 PL_in_eval |= EVAL_KEEPERR;
3738 sv_setpvn(ERRSV,"",0);
3739 if (flags & G_FAKINGEVAL) {
3740 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3748 PERL_CONTEXT * const cx = create_eval_scope(0);
3749 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3750 return DOCATCH(PL_op->op_next);
3759 register PERL_CONTEXT *cx;
3764 PERL_UNUSED_VAR(optype);
3767 if (gimme == G_VOID)
3769 else if (gimme == G_SCALAR) {
3773 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3776 *MARK = sv_mortalcopy(TOPs);
3780 *MARK = &PL_sv_undef;
3785 /* in case LEAVE wipes old return values */
3787 for (mark = newsp + 1; mark <= SP; mark++) {
3788 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3789 *mark = sv_mortalcopy(*mark);
3790 TAINT_NOT; /* Each item is independent */
3794 PL_curpm = newpm; /* Don't pop $1 et al till now */
3797 sv_setpvn(ERRSV,"",0);
3804 register PERL_CONTEXT *cx;
3805 const I32 gimme = GIMME_V;
3810 if (PL_op->op_targ == 0) {
3811 SV ** const defsv_p = &GvSV(PL_defgv);
3812 *defsv_p = newSVsv(POPs);
3813 SAVECLEARSV(*defsv_p);
3816 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3818 PUSHBLOCK(cx, CXt_GIVEN, SP);
3827 register PERL_CONTEXT *cx;
3831 PERL_UNUSED_CONTEXT;
3834 assert(CxTYPE(cx) == CXt_GIVEN);
3839 PL_curpm = newpm; /* pop $1 et al */
3846 /* Helper routines used by pp_smartmatch */
3848 S_make_matcher(pTHX_ REGEXP *re)
3851 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3852 PM_SETRE(matcher, ReREFCNT_inc(re));
3854 SAVEFREEOP((OP *) matcher);
3861 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3866 PL_op = (OP *) matcher;
3871 return (SvTRUEx(POPs));
3875 S_destroy_matcher(pTHX_ PMOP *matcher)
3878 PERL_UNUSED_ARG(matcher);
3883 /* Do a smart match */
3886 return do_smartmatch(NULL, NULL);
3889 /* This version of do_smartmatch() implements the
3890 * table of smart matches that is found in perlsyn.
3893 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3898 SV *e = TOPs; /* e is for 'expression' */
3899 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3900 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3901 REGEXP *this_regex, *other_regex;
3903 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3905 # define SM_REF(type) ( \
3906 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3907 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3909 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3910 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
3911 && NOT_EMPTY_PROTO(This) && (Other = e)) \
3912 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
3913 && NOT_EMPTY_PROTO(This) && (Other = d)))
3915 # define SM_REGEX ( \
3916 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \
3917 && (this_regex = (REGEXP*) This) \
3920 (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \
3921 && (this_regex = (REGEXP*) This) \
3925 # define SM_OTHER_REF(type) \
3926 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3928 # define SM_OTHER_REGEX (SvROK(Other) \
3929 && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \
3930 && (other_regex = (REGEXP*) SvRV(Other)))
3933 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3934 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3936 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3937 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3939 tryAMAGICbinSET(smart, 0);
3941 SP -= 2; /* Pop the values */
3943 /* Take care only to invoke mg_get() once for each argument.
3944 * Currently we do this by copying the SV if it's magical. */
3947 d = sv_mortalcopy(d);
3954 e = sv_mortalcopy(e);
3959 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3961 if (This == SvRV(Other))
3972 c = call_sv(This, G_SCALAR);
3976 else if (SvTEMP(TOPs))
3977 SvREFCNT_inc_void(TOPs);
3982 else if (SM_REF(PVHV)) {
3983 if (SM_OTHER_REF(PVHV)) {
3984 /* Check that the key-sets are identical */
3986 HV *other_hv = (HV *) SvRV(Other);
3988 bool other_tied = FALSE;
3989 U32 this_key_count = 0,
3990 other_key_count = 0;
3992 /* Tied hashes don't know how many keys they have. */
3993 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
3996 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3997 HV * const temp = other_hv;
3998 other_hv = (HV *) This;
4002 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
4005 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
4008 /* The hashes have the same number of keys, so it suffices
4009 to check that one is a subset of the other. */
4010 (void) hv_iterinit((HV *) This);
4011 while ( (he = hv_iternext((HV *) This)) ) {
4013 char * const key = hv_iterkey(he, &key_len);
4017 if(!hv_exists(other_hv, key, key_len)) {
4018 (void) hv_iterinit((HV *) This); /* reset iterator */
4024 (void) hv_iterinit(other_hv);
4025 while ( hv_iternext(other_hv) )
4029 other_key_count = HvUSEDKEYS(other_hv);
4031 if (this_key_count != other_key_count)
4036 else if (SM_OTHER_REF(PVAV)) {
4037 AV * const other_av = (AV *) SvRV(Other);
4038 const I32 other_len = av_len(other_av) + 1;
4041 for (i = 0; i < other_len; ++i) {
4042 SV ** const svp = av_fetch(other_av, i, FALSE);
4046 if (svp) { /* ??? When can this not happen? */
4047 key = SvPV(*svp, key_len);
4048 if (hv_exists((HV *) This, key, key_len))
4054 else if (SM_OTHER_REGEX) {
4055 PMOP * const matcher = make_matcher(other_regex);
4058 (void) hv_iterinit((HV *) This);
4059 while ( (he = hv_iternext((HV *) This)) ) {
4060 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4061 (void) hv_iterinit((HV *) This);
4062 destroy_matcher(matcher);
4066 destroy_matcher(matcher);
4070 if (hv_exists_ent((HV *) This, Other, 0))
4076 else if (SM_REF(PVAV)) {
4077 if (SM_OTHER_REF(PVAV)) {
4078 AV *other_av = (AV *) SvRV(Other);
4079 if (av_len((AV *) This) != av_len(other_av))
4083 const I32 other_len = av_len(other_av);
4085 if (NULL == seen_this) {
4086 seen_this = newHV();
4087 (void) sv_2mortal((SV *) seen_this);
4089 if (NULL == seen_other) {
4090 seen_this = newHV();
4091 (void) sv_2mortal((SV *) seen_other);
4093 for(i = 0; i <= other_len; ++i) {
4094 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4095 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4097 if (!this_elem || !other_elem) {
4098 if (this_elem || other_elem)
4101 else if (SM_SEEN_THIS(*this_elem)
4102 || SM_SEEN_OTHER(*other_elem))
4104 if (*this_elem != *other_elem)
4108 (void)hv_store_ent(seen_this,
4109 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4111 (void)hv_store_ent(seen_other,
4112 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4118 (void) do_smartmatch(seen_this, seen_other);
4128 else if (SM_OTHER_REGEX) {
4129 PMOP * const matcher = make_matcher(other_regex);
4130 const I32 this_len = av_len((AV *) This);
4133 for(i = 0; i <= this_len; ++i) {
4134 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4135 if (svp && matcher_matches_sv(matcher, *svp)) {
4136 destroy_matcher(matcher);
4140 destroy_matcher(matcher);
4143 else if (SvIOK(Other) || SvNOK(Other)) {
4146 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4147 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4154 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4164 else if (SvPOK(Other)) {
4165 const I32 this_len = av_len((AV *) This);
4168 for(i = 0; i <= this_len; ++i) {
4169 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4184 else if (!SvOK(d) || !SvOK(e)) {
4185 if (!SvOK(d) && !SvOK(e))
4190 else if (SM_REGEX) {
4191 PMOP * const matcher = make_matcher(this_regex);
4194 PUSHs(matcher_matches_sv(matcher, Other)
4197 destroy_matcher(matcher);
4200 else if (SM_REF(PVCV)) {
4202 /* This must be a null-prototyped sub, because we
4203 already checked for the other kind. */
4209 c = call_sv(This, G_SCALAR);
4212 PUSHs(&PL_sv_undef);
4213 else if (SvTEMP(TOPs))
4214 SvREFCNT_inc_void(TOPs);
4216 if (SM_OTHER_REF(PVCV)) {
4217 /* This one has to be null-proto'd too.
4218 Call both of 'em, and compare the results */
4220 c = call_sv(SvRV(Other), G_SCALAR);
4223 PUSHs(&PL_sv_undef);
4224 else if (SvTEMP(TOPs))
4225 SvREFCNT_inc_void(TOPs);
4236 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4237 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4239 if (SvPOK(Other) && !looks_like_number(Other)) {
4240 /* String comparison */
4245 /* Otherwise, numeric comparison */
4248 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4259 /* As a last resort, use string comparison */
4268 register PERL_CONTEXT *cx;
4269 const I32 gimme = GIMME_V;
4271 /* This is essentially an optimization: if the match
4272 fails, we don't want to push a context and then
4273 pop it again right away, so we skip straight
4274 to the op that follows the leavewhen.
4276 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4277 return cLOGOP->op_other->op_next;
4282 PUSHBLOCK(cx, CXt_WHEN, SP);
4291 register PERL_CONTEXT *cx;
4297 assert(CxTYPE(cx) == CXt_WHEN);
4302 PL_curpm = newpm; /* pop $1 et al */
4312 register PERL_CONTEXT *cx;
4315 cxix = dopoptowhen(cxstack_ix);
4317 DIE(aTHX_ "Can't \"continue\" outside a when block");
4318 if (cxix < cxstack_ix)
4321 /* clear off anything above the scope we're re-entering */
4322 inner = PL_scopestack_ix;
4324 if (PL_scopestack_ix < inner)
4325 leave_scope(PL_scopestack[PL_scopestack_ix]);
4326 PL_curcop = cx->blk_oldcop;
4327 return cx->blk_givwhen.leave_op;
4334 register PERL_CONTEXT *cx;
4337 cxix = dopoptogiven(cxstack_ix);
4339 if (PL_op->op_flags & OPf_SPECIAL)
4340 DIE(aTHX_ "Can't use when() outside a topicalizer");
4342 DIE(aTHX_ "Can't \"break\" outside a given block");
4344 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4345 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4347 if (cxix < cxstack_ix)
4350 /* clear off anything above the scope we're re-entering */
4351 inner = PL_scopestack_ix;
4353 if (PL_scopestack_ix < inner)
4354 leave_scope(PL_scopestack[PL_scopestack_ix]);
4355 PL_curcop = cx->blk_oldcop;
4358 return CX_LOOP_NEXTOP_GET(cx);
4360 return cx->blk_givwhen.leave_op;
4364 S_doparseform(pTHX_ SV *sv)
4367 register char *s = SvPV_force(sv, len);
4368 register char * const send = s + len;
4369 register char *base = NULL;
4370 register I32 skipspaces = 0;
4371 bool noblank = FALSE;
4372 bool repeat = FALSE;
4373 bool postspace = FALSE;
4379 bool unchopnum = FALSE;
4380 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4383 Perl_croak(aTHX_ "Null picture in formline");
4385 /* estimate the buffer size needed */
4386 for (base = s; s <= send; s++) {
4387 if (*s == '\n' || *s == '@' || *s == '^')
4393 Newx(fops, maxops, U32);
4398 *fpc++ = FF_LINEMARK;
4399 noblank = repeat = FALSE;
4417 case ' ': case '\t':
4424 } /* else FALL THROUGH */
4432 *fpc++ = FF_LITERAL;
4440 *fpc++ = (U16)skipspaces;
4444 *fpc++ = FF_NEWLINE;
4448 arg = fpc - linepc + 1;
4455 *fpc++ = FF_LINEMARK;
4456 noblank = repeat = FALSE;
4465 ischop = s[-1] == '^';
4471 arg = (s - base) - 1;
4473 *fpc++ = FF_LITERAL;
4481 *fpc++ = 2; /* skip the @* or ^* */
4483 *fpc++ = FF_LINESNGL;
4486 *fpc++ = FF_LINEGLOB;
4488 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4489 arg = ischop ? 512 : 0;
4494 const char * const f = ++s;
4497 arg |= 256 + (s - f);
4499 *fpc++ = s - base; /* fieldsize for FETCH */
4500 *fpc++ = FF_DECIMAL;
4502 unchopnum |= ! ischop;
4504 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4505 arg = ischop ? 512 : 0;
4507 s++; /* skip the '0' first */
4511 const char * const f = ++s;
4514 arg |= 256 + (s - f);
4516 *fpc++ = s - base; /* fieldsize for FETCH */
4517 *fpc++ = FF_0DECIMAL;
4519 unchopnum |= ! ischop;
4523 bool ismore = FALSE;
4526 while (*++s == '>') ;
4527 prespace = FF_SPACE;
4529 else if (*s == '|') {
4530 while (*++s == '|') ;
4531 prespace = FF_HALFSPACE;
4536 while (*++s == '<') ;
4539 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4543 *fpc++ = s - base; /* fieldsize for FETCH */
4545 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4548 *fpc++ = (U16)prespace;
4562 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4564 { /* need to jump to the next word */
4566 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4567 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4568 s = SvPVX(sv) + SvCUR(sv) + z;
4570 Copy(fops, s, arg, U32);
4572 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4575 if (unchopnum && repeat)
4576 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4582 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4584 /* Can value be printed in fldsize chars, using %*.*f ? */
4588 int intsize = fldsize - (value < 0 ? 1 : 0);
4595 while (intsize--) pwr *= 10.0;
4596 while (frcsize--) eps /= 10.0;
4599 if (value + eps >= pwr)
4602 if (value - eps <= -pwr)
4609 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4612 SV * const datasv = FILTER_DATA(idx);
4613 const int filter_has_file = IoLINES(datasv);
4614 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4615 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4619 const char *got_p = NULL;
4620 const char *prune_from = NULL;
4621 bool read_from_cache = FALSE;
4624 assert(maxlen >= 0);
4627 /* I was having segfault trouble under Linux 2.2.5 after a
4628 parse error occured. (Had to hack around it with a test
4629 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4630 not sure where the trouble is yet. XXX */
4632 if (IoFMT_GV(datasv)) {
4633 SV *const cache = (SV *)IoFMT_GV(datasv);
4636 const char *cache_p = SvPV(cache, cache_len);
4640 /* Running in block mode and we have some cached data already.
4642 if (cache_len >= umaxlen) {
4643 /* In fact, so much data we don't even need to call
4648 const char *const first_nl =
4649 (const char *)memchr(cache_p, '\n', cache_len);
4651 take = first_nl + 1 - cache_p;
4655 sv_catpvn(buf_sv, cache_p, take);
4656 sv_chop(cache, cache_p + take);
4657 /* Definately not EOF */
4661 sv_catsv(buf_sv, cache);
4663 umaxlen -= cache_len;
4666 read_from_cache = TRUE;
4670 /* Filter API says that the filter appends to the contents of the buffer.
4671 Usually the buffer is "", so the details don't matter. But if it's not,
4672 then clearly what it contains is already filtered by this filter, so we
4673 don't want to pass it in a second time.
4674 I'm going to use a mortal in case the upstream filter croaks. */
4675 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4676 ? sv_newmortal() : buf_sv;
4677 SvUPGRADE(upstream, SVt_PV);
4679 if (filter_has_file) {
4680 status = FILTER_READ(idx+1, upstream, 0);
4683 if (filter_sub && status >= 0) {
4696 PUSHs(filter_state);
4699 count = call_sv(filter_sub, G_SCALAR);
4714 if(SvOK(upstream)) {
4715 got_p = SvPV(upstream, got_len);
4717 if (got_len > umaxlen) {
4718 prune_from = got_p + umaxlen;
4721 const char *const first_nl =
4722 (const char *)memchr(got_p, '\n', got_len);
4723 if (first_nl && first_nl + 1 < got_p + got_len) {
4724 /* There's a second line here... */
4725 prune_from = first_nl + 1;
4730 /* Oh. Too long. Stuff some in our cache. */
4731 STRLEN cached_len = got_p + got_len - prune_from;
4732 SV *cache = (SV *)IoFMT_GV(datasv);
4735 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4736 } else if (SvOK(cache)) {
4737 /* Cache should be empty. */
4738 assert(!SvCUR(cache));
4741 sv_setpvn(cache, prune_from, cached_len);
4742 /* If you ask for block mode, you may well split UTF-8 characters.
4743 "If it breaks, you get to keep both parts"
4744 (Your code is broken if you don't put them back together again
4745 before something notices.) */
4746 if (SvUTF8(upstream)) {
4749 SvCUR_set(upstream, got_len - cached_len);
4750 /* Can't yet be EOF */
4755 /* If they are at EOF but buf_sv has something in it, then they may never
4756 have touched the SV upstream, so it may be undefined. If we naively
4757 concatenate it then we get a warning about use of uninitialised value.
4759 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4760 sv_catsv(buf_sv, upstream);
4764 IoLINES(datasv) = 0;
4765 SvREFCNT_dec(IoFMT_GV(datasv));
4767 SvREFCNT_dec(filter_state);
4768 IoTOP_GV(datasv) = NULL;
4771 SvREFCNT_dec(filter_sub);
4772 IoBOTTOM_GV(datasv) = NULL;
4774 filter_del(S_run_user_filter);
4776 if (status == 0 && read_from_cache) {
4777 /* If we read some data from the cache (and by getting here it implies
4778 that we emptied the cache) then we aren't yet at EOF, and mustn't
4779 report that to our caller. */
4785 /* perhaps someone can come up with a better name for
4786 this? it is not really "absolute", per se ... */
4788 S_path_is_absolute(const char *name)
4790 if (PERL_FILE_IS_ABSOLUTE(name)
4791 #ifdef MACOS_TRADITIONAL
4794 || (*name == '.' && (name[1] == '/' ||
4795 (name[1] == '.' && name[2] == '/')))
4807 * c-indentation-style: bsd
4809 * indent-tabs-mode: t
4812 * ex: set ts=8 sts=4 sw=4 noet: