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;
83 /* prevent recompiling under /o and ithreads. */
84 #if defined(USE_ITHREADS)
85 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
86 if (PL_op->op_flags & OPf_STACKED) {
95 if (PL_op->op_flags & OPf_STACKED) {
96 /* multiple args; concatentate them */
98 tmpstr = PAD_SV(ARGTARG);
99 sv_setpvn(tmpstr, "", 0);
100 while (++MARK <= SP) {
101 if (PL_amagic_generation) {
103 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
104 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
106 sv_setsv(tmpstr, sv);
110 sv_catsv(tmpstr, *MARK);
119 SV * const sv = SvRV(tmpstr);
121 mg = mg_find(sv, PERL_MAGIC_qr);
124 regexp * const re = reg_temp_copy((regexp *)mg->mg_obj);
125 ReREFCNT_dec(PM_GETRE(pm));
130 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
133 /* Check against the last compiled regexp. */
134 if (!re || !re->precomp || re->prelen != (I32)len ||
135 memNE(re->precomp, t, len))
137 const regexp_engine *eng = re ? re->engine : NULL;
138 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
141 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
142 } else if (PL_curcop->cop_hints_hash) {
143 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
145 if (ptr && SvIOK(ptr) && SvIV(ptr))
146 eng = INT2PTR(regexp_engine*,SvIV(ptr));
149 if (PL_op->op_flags & OPf_SPECIAL)
150 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
153 pm_flags |= RXf_UTF8;
156 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
158 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
160 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
161 inside tie/overload accessors. */
167 #ifndef INCOMPLETE_TAINTS
170 re->extflags |= RXf_TAINTED;
172 re->extflags &= ~RXf_TAINTED;
176 if (!PM_GETRE(pm)->prelen && PL_curpm)
180 #if !defined(USE_ITHREADS)
181 /* can't change the optree at runtime either */
182 /* PMf_KEEP is handled differently under threads to avoid these problems */
183 if (pm->op_pmflags & PMf_KEEP) {
184 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
185 cLOGOP->op_first->op_next = PL_op->op_next;
195 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
196 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
197 register SV * const dstr = cx->sb_dstr;
198 register char *s = cx->sb_s;
199 register char *m = cx->sb_m;
200 char *orig = cx->sb_orig;
201 register REGEXP * const rx = cx->sb_rx;
203 REGEXP *old = PM_GETRE(pm);
207 PM_SETRE(pm,ReREFCNT_inc(rx));
210 rxres_restore(&cx->sb_rxres, rx);
211 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
213 if (cx->sb_iters++) {
214 const I32 saviters = cx->sb_iters;
215 if (cx->sb_iters > cx->sb_maxiters)
216 DIE(aTHX_ "Substitution loop");
218 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
219 cx->sb_rxtainted |= 2;
220 sv_catsv(dstr, POPs);
221 FREETMPS; /* Prevent excess tmp stack */
224 if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
225 s == m, cx->sb_targ, NULL,
226 ((cx->sb_rflags & REXEC_COPY_STR)
227 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
228 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
230 SV * const targ = cx->sb_targ;
232 assert(cx->sb_strend >= s);
233 if(cx->sb_strend > s) {
234 if (DO_UTF8(dstr) && !SvUTF8(targ))
235 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
237 sv_catpvn(dstr, s, cx->sb_strend - s);
239 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
241 #ifdef PERL_OLD_COPY_ON_WRITE
243 sv_force_normal_flags(targ, SV_COW_DROP_PV);
249 SvPV_set(targ, SvPVX(dstr));
250 SvCUR_set(targ, SvCUR(dstr));
251 SvLEN_set(targ, SvLEN(dstr));
254 SvPV_set(dstr, NULL);
256 TAINT_IF(cx->sb_rxtainted & 1);
257 PUSHs(sv_2mortal(newSViv(saviters - 1)));
259 (void)SvPOK_only_UTF8(targ);
260 TAINT_IF(cx->sb_rxtainted);
264 LEAVE_SCOPE(cx->sb_oldsave);
266 RETURNOP(pm->op_next);
268 cx->sb_iters = saviters;
270 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
273 cx->sb_orig = orig = rx->subbeg;
275 cx->sb_strend = s + (cx->sb_strend - m);
277 cx->sb_m = m = rx->offs[0].start + orig;
279 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
280 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
282 sv_catpvn(dstr, s, m-s);
284 cx->sb_s = rx->offs[0].end + orig;
285 { /* Update the pos() information. */
286 SV * const sv = cx->sb_targ;
289 SvUPGRADE(sv, SVt_PVMG);
290 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
291 #ifdef PERL_OLD_COPY_ON_WRITE
293 sv_force_normal_flags(sv, 0);
295 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
304 (void)ReREFCNT_inc(rx);
305 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
306 rxres_save(&cx->sb_rxres, rx);
307 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
311 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
317 if (!p || p[1] < rx->nparens) {
318 #ifdef PERL_OLD_COPY_ON_WRITE
319 i = 7 + rx->nparens * 2;
321 i = 6 + rx->nparens * 2;
330 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : NULL);
331 RX_MATCH_COPIED_off(rx);
333 #ifdef PERL_OLD_COPY_ON_WRITE
334 *p++ = PTR2UV(rx->saved_copy);
335 rx->saved_copy = NULL;
340 *p++ = PTR2UV(rx->subbeg);
341 *p++ = (UV)rx->sublen;
342 for (i = 0; i <= rx->nparens; ++i) {
343 *p++ = (UV)rx->offs[i].start;
344 *p++ = (UV)rx->offs[i].end;
349 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
355 RX_MATCH_COPY_FREE(rx);
356 RX_MATCH_COPIED_set(rx, *p);
359 #ifdef PERL_OLD_COPY_ON_WRITE
361 SvREFCNT_dec (rx->saved_copy);
362 rx->saved_copy = INT2PTR(SV*,*p);
368 rx->subbeg = INT2PTR(char*,*p++);
369 rx->sublen = (I32)(*p++);
370 for (i = 0; i <= rx->nparens; ++i) {
371 rx->offs[i].start = (I32)(*p++);
372 rx->offs[i].end = (I32)(*p++);
377 Perl_rxres_free(pTHX_ void **rsp)
379 UV * const p = (UV*)*rsp;
384 void *tmp = INT2PTR(char*,*p);
387 PoisonFree(*p, 1, sizeof(*p));
389 Safefree(INT2PTR(char*,*p));
391 #ifdef PERL_OLD_COPY_ON_WRITE
393 SvREFCNT_dec (INT2PTR(SV*,p[1]));
403 dVAR; dSP; dMARK; dORIGMARK;
404 register SV * const tmpForm = *++MARK;
409 register SV *sv = NULL;
410 const char *item = NULL;
414 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
415 const char *chophere = NULL;
416 char *linemark = NULL;
418 bool gotsome = FALSE;
420 const STRLEN fudge = SvPOK(tmpForm)
421 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
422 bool item_is_utf8 = FALSE;
423 bool targ_is_utf8 = FALSE;
425 OP * parseres = NULL;
429 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
430 if (SvREADONLY(tmpForm)) {
431 SvREADONLY_off(tmpForm);
432 parseres = doparseform(tmpForm);
433 SvREADONLY_on(tmpForm);
436 parseres = doparseform(tmpForm);
440 SvPV_force(PL_formtarget, len);
441 if (DO_UTF8(PL_formtarget))
443 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
445 f = SvPV_const(tmpForm, len);
446 /* need to jump to the next word */
447 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
451 const char *name = "???";
454 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
455 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
456 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
457 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
458 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
460 case FF_CHECKNL: name = "CHECKNL"; break;
461 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
462 case FF_SPACE: name = "SPACE"; break;
463 case FF_HALFSPACE: name = "HALFSPACE"; break;
464 case FF_ITEM: name = "ITEM"; break;
465 case FF_CHOP: name = "CHOP"; break;
466 case FF_LINEGLOB: name = "LINEGLOB"; break;
467 case FF_NEWLINE: name = "NEWLINE"; break;
468 case FF_MORE: name = "MORE"; break;
469 case FF_LINEMARK: name = "LINEMARK"; break;
470 case FF_END: name = "END"; break;
471 case FF_0DECIMAL: name = "0DECIMAL"; break;
472 case FF_LINESNGL: name = "LINESNGL"; break;
475 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
477 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
488 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
489 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
491 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
492 t = SvEND(PL_formtarget);
495 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
496 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
498 sv_utf8_upgrade(PL_formtarget);
499 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
500 t = SvEND(PL_formtarget);
520 if (ckWARN(WARN_SYNTAX))
521 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
528 const char *s = item = SvPV_const(sv, len);
531 itemsize = sv_len_utf8(sv);
532 if (itemsize != (I32)len) {
534 if (itemsize > fieldsize) {
535 itemsize = fieldsize;
536 itembytes = itemsize;
537 sv_pos_u2b(sv, &itembytes, 0);
541 send = chophere = s + itembytes;
551 sv_pos_b2u(sv, &itemsize);
555 item_is_utf8 = FALSE;
556 if (itemsize > fieldsize)
557 itemsize = fieldsize;
558 send = chophere = s + itemsize;
572 const char *s = item = SvPV_const(sv, len);
575 itemsize = sv_len_utf8(sv);
576 if (itemsize != (I32)len) {
578 if (itemsize <= fieldsize) {
579 const char *send = chophere = s + itemsize;
592 itemsize = fieldsize;
593 itembytes = itemsize;
594 sv_pos_u2b(sv, &itembytes, 0);
595 send = chophere = s + itembytes;
596 while (s < send || (s == send && isSPACE(*s))) {
606 if (strchr(PL_chopset, *s))
611 itemsize = chophere - item;
612 sv_pos_b2u(sv, &itemsize);
618 item_is_utf8 = FALSE;
619 if (itemsize <= fieldsize) {
620 const char *const send = chophere = s + itemsize;
633 itemsize = fieldsize;
634 send = chophere = s + itemsize;
635 while (s < send || (s == send && isSPACE(*s))) {
645 if (strchr(PL_chopset, *s))
650 itemsize = chophere - item;
656 arg = fieldsize - itemsize;
665 arg = fieldsize - itemsize;
676 const char *s = item;
680 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
682 sv_utf8_upgrade(PL_formtarget);
683 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
684 t = SvEND(PL_formtarget);
688 if (UTF8_IS_CONTINUED(*s)) {
689 STRLEN skip = UTF8SKIP(s);
706 if ( !((*t++ = *s++) & ~31) )
712 if (targ_is_utf8 && !item_is_utf8) {
713 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
715 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
716 for (; t < SvEND(PL_formtarget); t++) {
729 const int ch = *t++ = *s++;
732 if ( !((*t++ = *s++) & ~31) )
741 const char *s = chophere;
759 const char *s = item = SvPV_const(sv, len);
761 if ((item_is_utf8 = DO_UTF8(sv)))
762 itemsize = sv_len_utf8(sv);
764 bool chopped = FALSE;
765 const char *const send = s + len;
767 chophere = s + itemsize;
783 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
785 SvUTF8_on(PL_formtarget);
787 SvCUR_set(sv, chophere - item);
788 sv_catsv(PL_formtarget, sv);
789 SvCUR_set(sv, itemsize);
791 sv_catsv(PL_formtarget, sv);
793 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
794 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
795 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
804 #if defined(USE_LONG_DOUBLE)
807 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
811 "%#0*.*f" : "%0*.*f");
816 #if defined(USE_LONG_DOUBLE)
818 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
821 ((arg & 256) ? "%#*.*f" : "%*.*f");
824 /* If the field is marked with ^ and the value is undefined,
826 if ((arg & 512) && !SvOK(sv)) {
834 /* overflow evidence */
835 if (num_overflow(value, fieldsize, arg)) {
841 /* Formats aren't yet marked for locales, so assume "yes". */
843 STORE_NUMERIC_STANDARD_SET_LOCAL();
844 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
845 RESTORE_NUMERIC_STANDARD();
852 while (t-- > linemark && *t == ' ') ;
860 if (arg) { /* repeat until fields exhausted? */
862 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
863 lines += FmLINES(PL_formtarget);
866 if (strnEQ(linemark, linemark - arg, arg))
867 DIE(aTHX_ "Runaway format");
870 SvUTF8_on(PL_formtarget);
871 FmLINES(PL_formtarget) = lines;
873 RETURNOP(cLISTOP->op_first);
884 const char *s = chophere;
885 const char *send = item + len;
887 while (isSPACE(*s) && (s < send))
892 arg = fieldsize - itemsize;
899 if (strnEQ(s1," ",3)) {
900 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
911 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
913 SvUTF8_on(PL_formtarget);
914 FmLINES(PL_formtarget) += lines;
926 if (PL_stack_base + *PL_markstack_ptr == SP) {
928 if (GIMME_V == G_SCALAR)
929 XPUSHs(sv_2mortal(newSViv(0)));
930 RETURNOP(PL_op->op_next->op_next);
932 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
933 pp_pushmark(); /* push dst */
934 pp_pushmark(); /* push src */
935 ENTER; /* enter outer scope */
938 if (PL_op->op_private & OPpGREP_LEX)
939 SAVESPTR(PAD_SVl(PL_op->op_targ));
942 ENTER; /* enter inner scope */
945 src = PL_stack_base[*PL_markstack_ptr];
947 if (PL_op->op_private & OPpGREP_LEX)
948 PAD_SVl(PL_op->op_targ) = src;
953 if (PL_op->op_type == OP_MAPSTART)
954 pp_pushmark(); /* push top */
955 return ((LOGOP*)PL_op->op_next)->op_other;
961 const I32 gimme = GIMME_V;
962 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
968 /* first, move source pointer to the next item in the source list */
969 ++PL_markstack_ptr[-1];
971 /* if there are new items, push them into the destination list */
972 if (items && gimme != G_VOID) {
973 /* might need to make room back there first */
974 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
975 /* XXX this implementation is very pessimal because the stack
976 * is repeatedly extended for every set of items. Is possible
977 * to do this without any stack extension or copying at all
978 * by maintaining a separate list over which the map iterates
979 * (like foreach does). --gsar */
981 /* everything in the stack after the destination list moves
982 * towards the end the stack by the amount of room needed */
983 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
985 /* items to shift up (accounting for the moved source pointer) */
986 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
988 /* This optimization is by Ben Tilly and it does
989 * things differently from what Sarathy (gsar)
990 * is describing. The downside of this optimization is
991 * that leaves "holes" (uninitialized and hopefully unused areas)
992 * to the Perl stack, but on the other hand this
993 * shouldn't be a problem. If Sarathy's idea gets
994 * implemented, this optimization should become
995 * irrelevant. --jhi */
997 shift = count; /* Avoid shifting too often --Ben Tilly */
1001 dst = (SP += shift);
1002 PL_markstack_ptr[-1] += shift;
1003 *PL_markstack_ptr += shift;
1007 /* copy the new items down to the destination list */
1008 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1009 if (gimme == G_ARRAY) {
1011 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1014 /* scalar context: we don't care about which values map returns
1015 * (we use undef here). And so we certainly don't want to do mortal
1016 * copies of meaningless values. */
1017 while (items-- > 0) {
1019 *dst-- = &PL_sv_undef;
1023 LEAVE; /* exit inner scope */
1026 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1028 (void)POPMARK; /* pop top */
1029 LEAVE; /* exit outer scope */
1030 (void)POPMARK; /* pop src */
1031 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1032 (void)POPMARK; /* pop dst */
1033 SP = PL_stack_base + POPMARK; /* pop original mark */
1034 if (gimme == G_SCALAR) {
1035 if (PL_op->op_private & OPpGREP_LEX) {
1036 SV* sv = sv_newmortal();
1037 sv_setiv(sv, items);
1045 else if (gimme == G_ARRAY)
1052 ENTER; /* enter inner scope */
1055 /* set $_ to the new source item */
1056 src = PL_stack_base[PL_markstack_ptr[-1]];
1058 if (PL_op->op_private & OPpGREP_LEX)
1059 PAD_SVl(PL_op->op_targ) = src;
1063 RETURNOP(cLOGOP->op_other);
1072 if (GIMME == G_ARRAY)
1074 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1075 return cLOGOP->op_other;
1085 if (GIMME == G_ARRAY) {
1086 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1090 SV * const targ = PAD_SV(PL_op->op_targ);
1093 if (PL_op->op_private & OPpFLIP_LINENUM) {
1094 if (GvIO(PL_last_in_gv)) {
1095 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1098 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1100 flip = SvIV(sv) == SvIV(GvSV(gv));
1106 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1107 if (PL_op->op_flags & OPf_SPECIAL) {
1115 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1118 sv_setpvn(TARG, "", 0);
1124 /* This code tries to decide if "$left .. $right" should use the
1125 magical string increment, or if the range is numeric (we make
1126 an exception for .."0" [#18165]). AMS 20021031. */
1128 #define RANGE_IS_NUMERIC(left,right) ( \
1129 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1130 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1131 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1132 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1133 && (!SvOK(right) || looks_like_number(right))))
1139 if (GIMME == G_ARRAY) {
1145 if (RANGE_IS_NUMERIC(left,right)) {
1148 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1149 (SvOK(right) && SvNV(right) > IV_MAX))
1150 DIE(aTHX_ "Range iterator outside integer range");
1161 SV * const sv = sv_2mortal(newSViv(i++));
1166 SV * const final = sv_mortalcopy(right);
1168 const char * const tmps = SvPV_const(final, len);
1170 SV *sv = sv_mortalcopy(left);
1171 SvPV_force_nolen(sv);
1172 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1174 if (strEQ(SvPVX_const(sv),tmps))
1176 sv = sv_2mortal(newSVsv(sv));
1183 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1187 if (PL_op->op_private & OPpFLIP_LINENUM) {
1188 if (GvIO(PL_last_in_gv)) {
1189 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1192 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1193 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1201 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1202 sv_catpvs(targ, "E0");
1212 static const char * const context_name[] = {
1225 S_dopoptolabel(pTHX_ const char *label)
1230 for (i = cxstack_ix; i >= 0; i--) {
1231 register const PERL_CONTEXT * const cx = &cxstack[i];
1232 switch (CxTYPE(cx)) {
1240 if (ckWARN(WARN_EXITING))
1241 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1242 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1243 if (CxTYPE(cx) == CXt_NULL)
1247 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1248 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1249 (long)i, cx->blk_loop.label));
1252 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1262 Perl_dowantarray(pTHX)
1265 const I32 gimme = block_gimme();
1266 return (gimme == G_VOID) ? G_SCALAR : gimme;
1270 Perl_block_gimme(pTHX)
1273 const I32 cxix = dopoptosub(cxstack_ix);
1277 switch (cxstack[cxix].blk_gimme) {
1285 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1292 Perl_is_lvalue_sub(pTHX)
1295 const I32 cxix = dopoptosub(cxstack_ix);
1296 assert(cxix >= 0); /* We should only be called from inside subs */
1298 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1299 return cxstack[cxix].blk_sub.lval;
1305 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1309 for (i = startingblock; i >= 0; i--) {
1310 register const PERL_CONTEXT * const cx = &cxstk[i];
1311 switch (CxTYPE(cx)) {
1317 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1325 S_dopoptoeval(pTHX_ I32 startingblock)
1329 for (i = startingblock; i >= 0; i--) {
1330 register const PERL_CONTEXT *cx = &cxstack[i];
1331 switch (CxTYPE(cx)) {
1335 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1343 S_dopoptoloop(pTHX_ I32 startingblock)
1347 for (i = startingblock; i >= 0; i--) {
1348 register const PERL_CONTEXT * const cx = &cxstack[i];
1349 switch (CxTYPE(cx)) {
1355 if (ckWARN(WARN_EXITING))
1356 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1357 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1358 if ((CxTYPE(cx)) == CXt_NULL)
1362 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1370 S_dopoptogiven(pTHX_ I32 startingblock)
1374 for (i = startingblock; i >= 0; i--) {
1375 register const PERL_CONTEXT *cx = &cxstack[i];
1376 switch (CxTYPE(cx)) {
1380 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1383 if (CxFOREACHDEF(cx)) {
1384 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1393 S_dopoptowhen(pTHX_ I32 startingblock)
1397 for (i = startingblock; i >= 0; i--) {
1398 register const PERL_CONTEXT *cx = &cxstack[i];
1399 switch (CxTYPE(cx)) {
1403 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1411 Perl_dounwind(pTHX_ I32 cxix)
1416 while (cxstack_ix > cxix) {
1418 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1419 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1420 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1421 /* Note: we don't need to restore the base context info till the end. */
1422 switch (CxTYPE(cx)) {
1425 continue; /* not break */
1444 PERL_UNUSED_VAR(optype);
1448 Perl_qerror(pTHX_ SV *err)
1452 sv_catsv(ERRSV, err);
1454 sv_catsv(PL_errors, err);
1456 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1458 ++PL_parser->error_count;
1462 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1471 if (PL_in_eval & EVAL_KEEPERR) {
1472 static const char prefix[] = "\t(in cleanup) ";
1473 SV * const err = ERRSV;
1474 const char *e = NULL;
1476 sv_setpvn(err,"",0);
1477 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1479 e = SvPV_const(err, len);
1481 if (*e != *message || strNE(e,message))
1485 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1486 sv_catpvn(err, prefix, sizeof(prefix)-1);
1487 sv_catpvn(err, message, msglen);
1488 if (ckWARN(WARN_MISC)) {
1489 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1490 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1495 sv_setpvn(ERRSV, message, msglen);
1499 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1500 && PL_curstackinfo->si_prev)
1508 register PERL_CONTEXT *cx;
1511 if (cxix < cxstack_ix)
1514 POPBLOCK(cx,PL_curpm);
1515 if (CxTYPE(cx) != CXt_EVAL) {
1517 message = SvPVx_const(ERRSV, msglen);
1518 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1519 PerlIO_write(Perl_error_log, message, msglen);
1524 if (gimme == G_SCALAR)
1525 *++newsp = &PL_sv_undef;
1526 PL_stack_sp = newsp;
1530 /* LEAVE could clobber PL_curcop (see save_re_context())
1531 * XXX it might be better to find a way to avoid messing with
1532 * PL_curcop in save_re_context() instead, but this is a more
1533 * minimal fix --GSAR */
1534 PL_curcop = cx->blk_oldcop;
1536 if (optype == OP_REQUIRE) {
1537 const char* const msg = SvPVx_nolen_const(ERRSV);
1538 SV * const nsv = cx->blk_eval.old_namesv;
1539 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1541 DIE(aTHX_ "%sCompilation failed in require",
1542 *msg ? msg : "Unknown error\n");
1544 assert(CxTYPE(cx) == CXt_EVAL);
1545 return cx->blk_eval.retop;
1549 message = SvPVx_const(ERRSV, msglen);
1551 write_to_stderr(message, msglen);
1559 dVAR; dSP; dPOPTOPssrl;
1560 if (SvTRUE(left) != SvTRUE(right))
1570 register I32 cxix = dopoptosub(cxstack_ix);
1571 register const PERL_CONTEXT *cx;
1572 register const PERL_CONTEXT *ccstack = cxstack;
1573 const PERL_SI *top_si = PL_curstackinfo;
1575 const char *stashname;
1582 /* we may be in a higher stacklevel, so dig down deeper */
1583 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1584 top_si = top_si->si_prev;
1585 ccstack = top_si->si_cxstack;
1586 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1589 if (GIMME != G_ARRAY) {
1595 /* caller() should not report the automatic calls to &DB::sub */
1596 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1597 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1601 cxix = dopoptosub_at(ccstack, cxix - 1);
1604 cx = &ccstack[cxix];
1605 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1606 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1607 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1608 field below is defined for any cx. */
1609 /* caller() should not report the automatic calls to &DB::sub */
1610 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1611 cx = &ccstack[dbcxix];
1614 stashname = CopSTASHPV(cx->blk_oldcop);
1615 if (GIMME != G_ARRAY) {
1618 PUSHs(&PL_sv_undef);
1621 sv_setpv(TARG, stashname);
1630 PUSHs(&PL_sv_undef);
1632 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1633 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1634 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1637 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1638 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1639 /* So is ccstack[dbcxix]. */
1641 SV * const sv = newSV(0);
1642 gv_efullname3(sv, cvgv, NULL);
1643 PUSHs(sv_2mortal(sv));
1644 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1647 PUSHs(sv_2mortal(newSVpvs("(unknown)")));
1648 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1652 PUSHs(sv_2mortal(newSVpvs("(eval)")));
1653 PUSHs(sv_2mortal(newSViv(0)));
1655 gimme = (I32)cx->blk_gimme;
1656 if (gimme == G_VOID)
1657 PUSHs(&PL_sv_undef);
1659 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1660 if (CxTYPE(cx) == CXt_EVAL) {
1662 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1663 PUSHs(cx->blk_eval.cur_text);
1667 else if (cx->blk_eval.old_namesv) {
1668 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1671 /* eval BLOCK (try blocks have old_namesv == 0) */
1673 PUSHs(&PL_sv_undef);
1674 PUSHs(&PL_sv_undef);
1678 PUSHs(&PL_sv_undef);
1679 PUSHs(&PL_sv_undef);
1681 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1682 && CopSTASH_eq(PL_curcop, PL_debstash))
1684 AV * const ary = cx->blk_sub.argarray;
1685 const int off = AvARRAY(ary) - AvALLOC(ary);
1688 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1689 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1691 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1694 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1695 av_extend(PL_dbargs, AvFILLp(ary) + off);
1696 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1697 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1699 /* XXX only hints propagated via op_private are currently
1700 * visible (others are not easily accessible, since they
1701 * use the global PL_hints) */
1702 PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
1705 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1707 if (old_warnings == pWARN_NONE ||
1708 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1709 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1710 else if (old_warnings == pWARN_ALL ||
1711 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1712 /* Get the bit mask for $warnings::Bits{all}, because
1713 * it could have been extended by warnings::register */
1715 HV * const bits = get_hv("warnings::Bits", FALSE);
1716 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1717 mask = newSVsv(*bits_all);
1720 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1724 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1725 PUSHs(sv_2mortal(mask));
1728 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1729 sv_2mortal(newRV_noinc(
1730 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1731 cx->blk_oldcop->cop_hints_hash)))
1740 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1741 sv_reset(tmps, CopSTASH(PL_curcop));
1746 /* like pp_nextstate, but used instead when the debugger is active */
1751 PL_curcop = (COP*)PL_op;
1752 TAINT_NOT; /* Each statement is presumed innocent */
1753 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1756 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1757 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1760 register PERL_CONTEXT *cx;
1761 const I32 gimme = G_ARRAY;
1763 GV * const gv = PL_DBgv;
1764 register CV * const cv = GvCV(gv);
1767 DIE(aTHX_ "No DB::DB routine defined");
1769 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1770 /* don't do recursive DB::DB call */
1785 (void)(*CvXSUB(cv))(aTHX_ cv);
1792 PUSHBLOCK(cx, CXt_SUB, SP);
1794 cx->blk_sub.retop = PL_op->op_next;
1797 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1798 RETURNOP(CvSTART(cv));
1808 register PERL_CONTEXT *cx;
1809 const I32 gimme = GIMME_V;
1811 U16 cxtype = CXt_LOOP | CXp_FOREACH;
1819 if (PL_op->op_targ) {
1820 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1821 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1822 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1823 SVs_PADSTALE, SVs_PADSTALE);
1825 #ifndef USE_ITHREADS
1826 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1829 SAVEPADSV(PL_op->op_targ);
1830 iterdata = INT2PTR(void*, PL_op->op_targ);
1831 cxtype |= CXp_PADVAR;
1835 GV * const gv = (GV*)POPs;
1836 svp = &GvSV(gv); /* symbol table variable */
1837 SAVEGENERICSV(*svp);
1840 iterdata = (void*)gv;
1844 if (PL_op->op_private & OPpITER_DEF)
1845 cxtype |= CXp_FOR_DEF;
1849 PUSHBLOCK(cx, cxtype, SP);
1851 PUSHLOOP(cx, iterdata, MARK);
1853 PUSHLOOP(cx, svp, MARK);
1855 if (PL_op->op_flags & OPf_STACKED) {
1856 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1857 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1859 SV * const right = (SV*)cx->blk_loop.iterary;
1862 if (RANGE_IS_NUMERIC(sv,right)) {
1863 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1864 (SvOK(right) && SvNV(right) >= IV_MAX))
1865 DIE(aTHX_ "Range iterator outside integer range");
1866 cx->blk_loop.iterix = SvIV(sv);
1867 cx->blk_loop.itermax = SvIV(right);
1869 /* for correct -Dstv display */
1870 cx->blk_oldsp = sp - PL_stack_base;
1874 cx->blk_loop.iterlval = newSVsv(sv);
1875 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1876 (void) SvPV_nolen_const(right);
1879 else if (PL_op->op_private & OPpITER_REVERSED) {
1880 cx->blk_loop.itermax = 0;
1881 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1886 cx->blk_loop.iterary = PL_curstack;
1887 AvFILLp(PL_curstack) = SP - PL_stack_base;
1888 if (PL_op->op_private & OPpITER_REVERSED) {
1889 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1890 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1893 cx->blk_loop.iterix = MARK - PL_stack_base;
1903 register PERL_CONTEXT *cx;
1904 const I32 gimme = GIMME_V;
1910 PUSHBLOCK(cx, CXt_LOOP, SP);
1911 PUSHLOOP(cx, 0, SP);
1919 register PERL_CONTEXT *cx;
1926 assert(CxTYPE(cx) == CXt_LOOP);
1928 newsp = PL_stack_base + cx->blk_loop.resetsp;
1931 if (gimme == G_VOID)
1933 else if (gimme == G_SCALAR) {
1935 *++newsp = sv_mortalcopy(*SP);
1937 *++newsp = &PL_sv_undef;
1941 *++newsp = sv_mortalcopy(*++mark);
1942 TAINT_NOT; /* Each item is independent */
1948 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1949 PL_curpm = newpm; /* ... and pop $1 et al */
1960 register PERL_CONTEXT *cx;
1961 bool popsub2 = FALSE;
1962 bool clear_errsv = FALSE;
1970 const I32 cxix = dopoptosub(cxstack_ix);
1973 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1974 * sort block, which is a CXt_NULL
1977 PL_stack_base[1] = *PL_stack_sp;
1978 PL_stack_sp = PL_stack_base + 1;
1982 DIE(aTHX_ "Can't return outside a subroutine");
1984 if (cxix < cxstack_ix)
1987 if (CxMULTICALL(&cxstack[cxix])) {
1988 gimme = cxstack[cxix].blk_gimme;
1989 if (gimme == G_VOID)
1990 PL_stack_sp = PL_stack_base;
1991 else if (gimme == G_SCALAR) {
1992 PL_stack_base[1] = *PL_stack_sp;
1993 PL_stack_sp = PL_stack_base + 1;
1999 switch (CxTYPE(cx)) {
2002 retop = cx->blk_sub.retop;
2003 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2006 if (!(PL_in_eval & EVAL_KEEPERR))
2009 retop = cx->blk_eval.retop;
2013 if (optype == OP_REQUIRE &&
2014 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2016 /* Unassume the success we assumed earlier. */
2017 SV * const nsv = cx->blk_eval.old_namesv;
2018 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2019 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2024 retop = cx->blk_sub.retop;
2027 DIE(aTHX_ "panic: return");
2031 if (gimme == G_SCALAR) {
2034 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2036 *++newsp = SvREFCNT_inc(*SP);
2041 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2043 *++newsp = sv_mortalcopy(sv);
2048 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2051 *++newsp = sv_mortalcopy(*SP);
2054 *++newsp = &PL_sv_undef;
2056 else if (gimme == G_ARRAY) {
2057 while (++MARK <= SP) {
2058 *++newsp = (popsub2 && SvTEMP(*MARK))
2059 ? *MARK : sv_mortalcopy(*MARK);
2060 TAINT_NOT; /* Each item is independent */
2063 PL_stack_sp = newsp;
2066 /* Stack values are safe: */
2069 POPSUB(cx,sv); /* release CV and @_ ... */
2073 PL_curpm = newpm; /* ... and pop $1 et al */
2077 sv_setpvn(ERRSV,"",0);
2085 register PERL_CONTEXT *cx;
2096 if (PL_op->op_flags & OPf_SPECIAL) {
2097 cxix = dopoptoloop(cxstack_ix);
2099 DIE(aTHX_ "Can't \"last\" outside a loop block");
2102 cxix = dopoptolabel(cPVOP->op_pv);
2104 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2106 if (cxix < cxstack_ix)
2110 cxstack_ix++; /* temporarily protect top context */
2112 switch (CxTYPE(cx)) {
2115 newsp = PL_stack_base + cx->blk_loop.resetsp;
2116 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2120 nextop = cx->blk_sub.retop;
2124 nextop = cx->blk_eval.retop;
2128 nextop = cx->blk_sub.retop;
2131 DIE(aTHX_ "panic: last");
2135 if (gimme == G_SCALAR) {
2137 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2138 ? *SP : sv_mortalcopy(*SP);
2140 *++newsp = &PL_sv_undef;
2142 else if (gimme == G_ARRAY) {
2143 while (++MARK <= SP) {
2144 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2145 ? *MARK : sv_mortalcopy(*MARK);
2146 TAINT_NOT; /* Each item is independent */
2154 /* Stack values are safe: */
2157 POPLOOP(cx); /* release loop vars ... */
2161 POPSUB(cx,sv); /* release CV and @_ ... */
2164 PL_curpm = newpm; /* ... and pop $1 et al */
2167 PERL_UNUSED_VAR(optype);
2168 PERL_UNUSED_VAR(gimme);
2176 register PERL_CONTEXT *cx;
2179 if (PL_op->op_flags & OPf_SPECIAL) {
2180 cxix = dopoptoloop(cxstack_ix);
2182 DIE(aTHX_ "Can't \"next\" outside a loop block");
2185 cxix = dopoptolabel(cPVOP->op_pv);
2187 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2189 if (cxix < cxstack_ix)
2192 /* clear off anything above the scope we're re-entering, but
2193 * save the rest until after a possible continue block */
2194 inner = PL_scopestack_ix;
2196 if (PL_scopestack_ix < inner)
2197 leave_scope(PL_scopestack[PL_scopestack_ix]);
2198 PL_curcop = cx->blk_oldcop;
2199 return CX_LOOP_NEXTOP_GET(cx);
2206 register PERL_CONTEXT *cx;
2210 if (PL_op->op_flags & OPf_SPECIAL) {
2211 cxix = dopoptoloop(cxstack_ix);
2213 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2216 cxix = dopoptolabel(cPVOP->op_pv);
2218 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2220 if (cxix < cxstack_ix)
2223 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2224 if (redo_op->op_type == OP_ENTER) {
2225 /* pop one less context to avoid $x being freed in while (my $x..) */
2227 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2228 redo_op = redo_op->op_next;
2232 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2233 LEAVE_SCOPE(oldsave);
2235 PL_curcop = cx->blk_oldcop;
2240 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2244 static const char too_deep[] = "Target of goto is too deeply nested";
2247 Perl_croak(aTHX_ too_deep);
2248 if (o->op_type == OP_LEAVE ||
2249 o->op_type == OP_SCOPE ||
2250 o->op_type == OP_LEAVELOOP ||
2251 o->op_type == OP_LEAVESUB ||
2252 o->op_type == OP_LEAVETRY)
2254 *ops++ = cUNOPo->op_first;
2256 Perl_croak(aTHX_ too_deep);
2259 if (o->op_flags & OPf_KIDS) {
2261 /* First try all the kids at this level, since that's likeliest. */
2262 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2263 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2264 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2267 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2268 if (kid == PL_lastgotoprobe)
2270 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2273 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2274 ops[-1]->op_type == OP_DBSTATE)
2279 if ((o = dofindlabel(kid, label, ops, oplimit)))
2292 register PERL_CONTEXT *cx;
2293 #define GOTO_DEPTH 64
2294 OP *enterops[GOTO_DEPTH];
2295 const char *label = NULL;
2296 const bool do_dump = (PL_op->op_type == OP_DUMP);
2297 static const char must_have_label[] = "goto must have label";
2299 if (PL_op->op_flags & OPf_STACKED) {
2300 SV * const sv = POPs;
2302 /* This egregious kludge implements goto &subroutine */
2303 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2305 register PERL_CONTEXT *cx;
2306 CV* cv = (CV*)SvRV(sv);
2313 if (!CvROOT(cv) && !CvXSUB(cv)) {
2314 const GV * const gv = CvGV(cv);
2318 /* autoloaded stub? */
2319 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2321 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2322 GvNAMELEN(gv), FALSE);
2323 if (autogv && (cv = GvCV(autogv)))
2325 tmpstr = sv_newmortal();
2326 gv_efullname3(tmpstr, gv, NULL);
2327 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2329 DIE(aTHX_ "Goto undefined subroutine");
2332 /* First do some returnish stuff. */
2333 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2335 cxix = dopoptosub(cxstack_ix);
2337 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2338 if (cxix < cxstack_ix)
2342 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2343 if (CxTYPE(cx) == CXt_EVAL) {
2345 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2347 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2349 else if (CxMULTICALL(cx))
2350 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2351 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2352 /* put @_ back onto stack */
2353 AV* av = cx->blk_sub.argarray;
2355 items = AvFILLp(av) + 1;
2356 EXTEND(SP, items+1); /* @_ could have been extended. */
2357 Copy(AvARRAY(av), SP + 1, items, SV*);
2358 SvREFCNT_dec(GvAV(PL_defgv));
2359 GvAV(PL_defgv) = cx->blk_sub.savearray;
2361 /* abandon @_ if it got reified */
2366 av_extend(av, items-1);
2368 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2371 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2372 AV* const av = GvAV(PL_defgv);
2373 items = AvFILLp(av) + 1;
2374 EXTEND(SP, items+1); /* @_ could have been extended. */
2375 Copy(AvARRAY(av), SP + 1, items, SV*);
2379 if (CxTYPE(cx) == CXt_SUB &&
2380 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2381 SvREFCNT_dec(cx->blk_sub.cv);
2382 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2383 LEAVE_SCOPE(oldsave);
2385 /* Now do some callish stuff. */
2387 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2389 OP* const retop = cx->blk_sub.retop;
2394 for (index=0; index<items; index++)
2395 sv_2mortal(SP[-index]);
2398 /* XS subs don't have a CxSUB, so pop it */
2399 POPBLOCK(cx, PL_curpm);
2400 /* Push a mark for the start of arglist */
2403 (void)(*CvXSUB(cv))(aTHX_ cv);
2408 AV* const padlist = CvPADLIST(cv);
2409 if (CxTYPE(cx) == CXt_EVAL) {
2410 PL_in_eval = cx->blk_eval.old_in_eval;
2411 PL_eval_root = cx->blk_eval.old_eval_root;
2412 cx->cx_type = CXt_SUB;
2413 cx->blk_sub.hasargs = 0;
2415 cx->blk_sub.cv = cv;
2416 cx->blk_sub.olddepth = CvDEPTH(cv);
2419 if (CvDEPTH(cv) < 2)
2420 SvREFCNT_inc_simple_void_NN(cv);
2422 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2423 sub_crush_depth(cv);
2424 pad_push(padlist, CvDEPTH(cv));
2427 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2428 if (cx->blk_sub.hasargs)
2430 AV* const av = (AV*)PAD_SVl(0);
2432 cx->blk_sub.savearray = GvAV(PL_defgv);
2433 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2434 CX_CURPAD_SAVE(cx->blk_sub);
2435 cx->blk_sub.argarray = av;
2437 if (items >= AvMAX(av) + 1) {
2438 SV **ary = AvALLOC(av);
2439 if (AvARRAY(av) != ary) {
2440 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2443 if (items >= AvMAX(av) + 1) {
2444 AvMAX(av) = items - 1;
2445 Renew(ary,items+1,SV*);
2451 Copy(mark,AvARRAY(av),items,SV*);
2452 AvFILLp(av) = items - 1;
2453 assert(!AvREAL(av));
2455 /* transfer 'ownership' of refcnts to new @_ */
2465 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2466 Perl_get_db_sub(aTHX_ NULL, cv);
2468 CV * const gotocv = get_cv("DB::goto", FALSE);
2470 PUSHMARK( PL_stack_sp );
2471 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2476 RETURNOP(CvSTART(cv));
2480 label = SvPV_nolen_const(sv);
2481 if (!(do_dump || *label))
2482 DIE(aTHX_ must_have_label);
2485 else if (PL_op->op_flags & OPf_SPECIAL) {
2487 DIE(aTHX_ must_have_label);
2490 label = cPVOP->op_pv;
2492 if (label && *label) {
2493 OP *gotoprobe = NULL;
2494 bool leaving_eval = FALSE;
2495 bool in_block = FALSE;
2496 PERL_CONTEXT *last_eval_cx = NULL;
2500 PL_lastgotoprobe = NULL;
2502 for (ix = cxstack_ix; ix >= 0; ix--) {
2504 switch (CxTYPE(cx)) {
2506 leaving_eval = TRUE;
2507 if (!CxTRYBLOCK(cx)) {
2508 gotoprobe = (last_eval_cx ?
2509 last_eval_cx->blk_eval.old_eval_root :
2514 /* else fall through */
2516 gotoprobe = cx->blk_oldcop->op_sibling;
2522 gotoprobe = cx->blk_oldcop->op_sibling;
2525 gotoprobe = PL_main_root;
2528 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2529 gotoprobe = CvROOT(cx->blk_sub.cv);
2535 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2538 DIE(aTHX_ "panic: goto");
2539 gotoprobe = PL_main_root;
2543 retop = dofindlabel(gotoprobe, label,
2544 enterops, enterops + GOTO_DEPTH);
2548 PL_lastgotoprobe = gotoprobe;
2551 DIE(aTHX_ "Can't find label %s", label);
2553 /* if we're leaving an eval, check before we pop any frames
2554 that we're not going to punt, otherwise the error
2557 if (leaving_eval && *enterops && enterops[1]) {
2559 for (i = 1; enterops[i]; i++)
2560 if (enterops[i]->op_type == OP_ENTERITER)
2561 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2564 /* pop unwanted frames */
2566 if (ix < cxstack_ix) {
2573 oldsave = PL_scopestack[PL_scopestack_ix];
2574 LEAVE_SCOPE(oldsave);
2577 /* push wanted frames */
2579 if (*enterops && enterops[1]) {
2580 OP * const oldop = PL_op;
2581 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2582 for (; enterops[ix]; ix++) {
2583 PL_op = enterops[ix];
2584 /* Eventually we may want to stack the needed arguments
2585 * for each op. For now, we punt on the hard ones. */
2586 if (PL_op->op_type == OP_ENTERITER)
2587 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2588 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2596 if (!retop) retop = PL_main_start;
2598 PL_restartop = retop;
2599 PL_do_undump = TRUE;
2603 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2604 PL_do_undump = FALSE;
2621 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2623 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2626 PL_exit_flags |= PERL_EXIT_EXPECTED;
2628 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2629 if (anum || !(PL_minus_c && PL_madskills))
2634 PUSHs(&PL_sv_undef);
2641 S_save_lines(pTHX_ AV *array, SV *sv)
2643 const char *s = SvPVX_const(sv);
2644 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2647 while (s && s < send) {
2649 SV * const tmpstr = newSV_type(SVt_PVMG);
2651 t = strchr(s, '\n');
2657 sv_setpvn(tmpstr, s, t - s);
2658 av_store(array, line++, tmpstr);
2664 S_docatch(pTHX_ OP *o)
2668 OP * const oldop = PL_op;
2672 assert(CATCH_GET == TRUE);
2679 assert(cxstack_ix >= 0);
2680 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2681 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2686 /* die caught by an inner eval - continue inner loop */
2688 /* NB XXX we rely on the old popped CxEVAL still being at the top
2689 * of the stack; the way die_where() currently works, this
2690 * assumption is valid. In theory The cur_top_env value should be
2691 * returned in another global, the way retop (aka PL_restartop)
2693 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2696 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2698 PL_op = PL_restartop;
2715 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2716 /* sv Text to convert to OP tree. */
2717 /* startop op_free() this to undo. */
2718 /* code Short string id of the caller. */
2720 /* FIXME - how much of this code is common with pp_entereval? */
2721 dVAR; dSP; /* Make POPBLOCK work. */
2727 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2728 char *tmpbuf = tbuf;
2731 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2735 lex_start(sv, NULL, FALSE);
2737 /* switch to eval mode */
2739 if (IN_PERL_COMPILETIME) {
2740 SAVECOPSTASH_FREE(&PL_compiling);
2741 CopSTASH_set(&PL_compiling, PL_curstash);
2743 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2744 SV * const sv = sv_newmortal();
2745 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2746 code, (unsigned long)++PL_evalseq,
2747 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2752 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2753 (unsigned long)++PL_evalseq);
2754 SAVECOPFILE_FREE(&PL_compiling);
2755 CopFILE_set(&PL_compiling, tmpbuf+2);
2756 SAVECOPLINE(&PL_compiling);
2757 CopLINE_set(&PL_compiling, 1);
2758 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2759 deleting the eval's FILEGV from the stash before gv_check() runs
2760 (i.e. before run-time proper). To work around the coredump that
2761 ensues, we always turn GvMULTI_on for any globals that were
2762 introduced within evals. See force_ident(). GSAR 96-10-12 */
2763 safestr = savepvn(tmpbuf, len);
2764 SAVEDELETE(PL_defstash, safestr, len);
2766 #ifdef OP_IN_REGISTER
2772 /* we get here either during compilation, or via pp_regcomp at runtime */
2773 runtime = IN_PERL_RUNTIME;
2775 runcv = find_runcv(NULL);
2778 PL_op->op_type = OP_ENTEREVAL;
2779 PL_op->op_flags = 0; /* Avoid uninit warning. */
2780 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2781 PUSHEVAL(cx, 0, NULL);
2784 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2786 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2787 POPBLOCK(cx,PL_curpm);
2790 (*startop)->op_type = OP_NULL;
2791 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2793 /* XXX DAPM do this properly one year */
2794 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2796 if (IN_PERL_COMPILETIME)
2797 CopHINTS_set(&PL_compiling, PL_hints);
2798 #ifdef OP_IN_REGISTER
2801 PERL_UNUSED_VAR(newsp);
2802 PERL_UNUSED_VAR(optype);
2804 return PL_eval_start;
2809 =for apidoc find_runcv
2811 Locate the CV corresponding to the currently executing sub or eval.
2812 If db_seqp is non_null, skip CVs that are in the DB package and populate
2813 *db_seqp with the cop sequence number at the point that the DB:: code was
2814 entered. (allows debuggers to eval in the scope of the breakpoint rather
2815 than in the scope of the debugger itself).
2821 Perl_find_runcv(pTHX_ U32 *db_seqp)
2827 *db_seqp = PL_curcop->cop_seq;
2828 for (si = PL_curstackinfo; si; si = si->si_prev) {
2830 for (ix = si->si_cxix; ix >= 0; ix--) {
2831 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2832 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2833 CV * const cv = cx->blk_sub.cv;
2834 /* skip DB:: code */
2835 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2836 *db_seqp = cx->blk_oldcop->cop_seq;
2841 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2849 /* Compile a require/do, an eval '', or a /(?{...})/.
2850 * In the last case, startop is non-null, and contains the address of
2851 * a pointer that should be set to the just-compiled code.
2852 * outside is the lexically enclosing CV (if any) that invoked us.
2853 * Returns a bool indicating whether the compile was successful; if so,
2854 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2855 * pushes undef (also croaks if startop != NULL).
2859 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2862 OP * const saveop = PL_op;
2864 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2865 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2870 SAVESPTR(PL_compcv);
2871 PL_compcv = (CV*)newSV_type(SVt_PVCV);
2872 CvEVAL_on(PL_compcv);
2873 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2874 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2876 CvOUTSIDE_SEQ(PL_compcv) = seq;
2877 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2879 /* set up a scratch pad */
2881 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2882 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2886 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2888 /* make sure we compile in the right package */
2890 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2891 SAVESPTR(PL_curstash);
2892 PL_curstash = CopSTASH(PL_curcop);
2894 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2895 SAVESPTR(PL_beginav);
2896 PL_beginav = newAV();
2897 SAVEFREESV(PL_beginav);
2898 SAVESPTR(PL_unitcheckav);
2899 PL_unitcheckav = newAV();
2900 SAVEFREESV(PL_unitcheckav);
2903 SAVEBOOL(PL_madskills);
2907 /* try to compile it */
2909 PL_eval_root = NULL;
2910 PL_curcop = &PL_compiling;
2911 CopARYBASE_set(PL_curcop, 0);
2912 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2913 PL_in_eval |= EVAL_KEEPERR;
2915 sv_setpvn(ERRSV,"",0);
2916 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
2917 SV **newsp; /* Used by POPBLOCK. */
2918 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2919 I32 optype = 0; /* Might be reset by POPEVAL. */
2924 op_free(PL_eval_root);
2925 PL_eval_root = NULL;
2927 SP = PL_stack_base + POPMARK; /* pop original mark */
2929 POPBLOCK(cx,PL_curpm);
2935 msg = SvPVx_nolen_const(ERRSV);
2936 if (optype == OP_REQUIRE) {
2937 const SV * const nsv = cx->blk_eval.old_namesv;
2938 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2940 Perl_croak(aTHX_ "%sCompilation failed in require",
2941 *msg ? msg : "Unknown error\n");
2944 POPBLOCK(cx,PL_curpm);
2946 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2947 (*msg ? msg : "Unknown error\n"));
2951 sv_setpvs(ERRSV, "Compilation error");
2954 PERL_UNUSED_VAR(newsp);
2955 PUSHs(&PL_sv_undef);
2959 CopLINE_set(&PL_compiling, 0);
2961 *startop = PL_eval_root;
2963 SAVEFREEOP(PL_eval_root);
2965 /* Set the context for this new optree.
2966 * If the last op is an OP_REQUIRE, force scalar context.
2967 * Otherwise, propagate the context from the eval(). */
2968 if (PL_eval_root->op_type == OP_LEAVEEVAL
2969 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2970 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2972 scalar(PL_eval_root);
2973 else if (gimme & G_VOID)
2974 scalarvoid(PL_eval_root);
2975 else if (gimme & G_ARRAY)
2978 scalar(PL_eval_root);
2980 DEBUG_x(dump_eval());
2982 /* Register with debugger: */
2983 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
2984 CV * const cv = get_cv("DB::postponed", FALSE);
2988 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2990 call_sv((SV*)cv, G_DISCARD);
2995 call_list(PL_scopestack_ix, PL_unitcheckav);
2997 /* compiled okay, so do it */
2999 CvDEPTH(PL_compcv) = 1;
3000 SP = PL_stack_base + POPMARK; /* pop original mark */
3001 PL_op = saveop; /* The caller may need it. */
3002 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3009 S_check_type_and_open(pTHX_ const char *name)
3012 const int st_rc = PerlLIO_stat(name, &st);
3014 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3018 return PerlIO_open(name, PERL_SCRIPT_MODE);
3021 #ifndef PERL_DISABLE_PMC
3023 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3027 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3028 SV *const pmcsv = newSV(namelen + 2);
3029 char *const pmc = SvPVX(pmcsv);
3032 memcpy(pmc, name, namelen);
3034 pmc[namelen + 1] = '\0';
3036 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3037 fp = check_type_and_open(name);
3040 fp = check_type_and_open(pmc);
3042 SvREFCNT_dec(pmcsv);
3045 fp = check_type_and_open(name);
3050 # define doopen_pm(name, namelen) check_type_and_open(name)
3051 #endif /* !PERL_DISABLE_PMC */
3056 register PERL_CONTEXT *cx;
3063 int vms_unixname = 0;
3065 const char *tryname = NULL;
3067 const I32 gimme = GIMME_V;
3068 int filter_has_file = 0;
3069 PerlIO *tryrsfp = NULL;
3070 SV *filter_cache = NULL;
3071 SV *filter_state = NULL;
3072 SV *filter_sub = NULL;
3078 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3079 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) { /* require v5.6.1 */
3080 HV * hinthv = GvHV(PL_hintgv);
3082 if (hinthv) ptr = hv_fetchs(hinthv, "v_string", FALSE);
3083 if ( !(ptr && *ptr && SvIOK(*ptr) && SvIV(*ptr)) )
3084 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3085 "v-string in use/require non-portable");
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.6.0, then v-string are OK
3139 so set $^H{v_string} to suppress the v-string warning */
3140 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.006), FALSE))) >= 0) {
3141 HV * hinthv = GvHV(PL_hintgv);
3143 SV *hint = newSViv(1);
3144 (void)hv_stores(hinthv, "v_string", hint);
3145 /* This will call through to Perl_magic_sethint() which in turn
3146 sets PL_hints correctly. */
3149 /* If we request a version >= 5.9.5, load feature.pm with the
3150 * feature bundle that corresponds to the required version. */
3151 if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3152 SV *const importsv = vnormal(sv);
3153 *SvPVX_mutable(importsv) = ':';
3155 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3162 name = SvPV_const(sv, len);
3163 if (!(name && len > 0 && *name))
3164 DIE(aTHX_ "Null filename used");
3165 TAINT_PROPER("require");
3169 /* The key in the %ENV hash is in the syntax of file passed as the argument
3170 * usually this is in UNIX format, but sometimes in VMS format, which
3171 * can result in a module being pulled in more than once.
3172 * To prevent this, the key must be stored in UNIX format if the VMS
3173 * name can be translated to UNIX.
3175 if ((unixname = tounixspec(name, NULL)) != NULL) {
3176 unixlen = strlen(unixname);
3182 /* if not VMS or VMS name can not be translated to UNIX, pass it
3185 unixname = (char *) name;
3188 if (PL_op->op_type == OP_REQUIRE) {
3189 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3190 unixname, unixlen, 0);
3192 if (*svp != &PL_sv_undef)
3195 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3196 "Compilation failed in require", unixname);
3200 /* prepare to compile file */
3202 if (path_is_absolute(name)) {
3204 tryrsfp = doopen_pm(name, len);
3206 #ifdef MACOS_TRADITIONAL
3210 MacPerl_CanonDir(name, newname, 1);
3211 if (path_is_absolute(newname)) {
3213 tryrsfp = doopen_pm(newname, strlen(newname));
3218 AV * const ar = GvAVn(PL_incgv);
3225 sv_upgrade(namesv, SVt_PV);
3226 for (i = 0; i <= AvFILL(ar); i++) {
3227 SV * const dirsv = *av_fetch(ar, i, TRUE);
3229 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3236 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3237 && !sv_isobject(loader))
3239 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3242 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3243 PTR2UV(SvRV(dirsv)), name);
3244 tryname = SvPVX_const(namesv);
3255 if (sv_isobject(loader))
3256 count = call_method("INC", G_ARRAY);
3258 count = call_sv(loader, G_ARRAY);
3261 /* Adjust file name if the hook has set an %INC entry */
3262 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3264 tryname = SvPVX_const(*svp);
3273 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3274 && !isGV_with_GP(SvRV(arg))) {
3275 filter_cache = SvRV(arg);
3276 SvREFCNT_inc_simple_void_NN(filter_cache);
3283 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3287 if (SvTYPE(arg) == SVt_PVGV) {
3288 IO * const io = GvIO((GV *)arg);
3293 tryrsfp = IoIFP(io);
3294 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3295 PerlIO_close(IoOFP(io));
3306 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3308 SvREFCNT_inc_simple_void_NN(filter_sub);
3311 filter_state = SP[i];
3312 SvREFCNT_inc_simple_void(filter_state);
3316 if (!tryrsfp && (filter_cache || filter_sub)) {
3317 tryrsfp = PerlIO_open(BIT_BUCKET,
3332 filter_has_file = 0;
3334 SvREFCNT_dec(filter_cache);
3335 filter_cache = NULL;
3338 SvREFCNT_dec(filter_state);
3339 filter_state = NULL;
3342 SvREFCNT_dec(filter_sub);
3347 if (!path_is_absolute(name)
3348 #ifdef MACOS_TRADITIONAL
3349 /* We consider paths of the form :a:b ambiguous and interpret them first
3350 as global then as local
3352 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3359 dir = SvPV_const(dirsv, dirlen);
3365 #ifdef MACOS_TRADITIONAL
3369 MacPerl_CanonDir(name, buf2, 1);
3370 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3374 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3376 sv_setpv(namesv, unixdir);
3377 sv_catpv(namesv, unixname);
3379 # ifdef __SYMBIAN32__
3380 if (PL_origfilename[0] &&
3381 PL_origfilename[1] == ':' &&
3382 !(dir[0] && dir[1] == ':'))
3383 Perl_sv_setpvf(aTHX_ namesv,
3388 Perl_sv_setpvf(aTHX_ namesv,
3392 /* The equivalent of
3393 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3394 but without the need to parse the format string, or
3395 call strlen on either pointer, and with the correct
3396 allocation up front. */
3398 char *tmp = SvGROW(namesv, dirlen + len + 2);
3400 memcpy(tmp, dir, dirlen);
3403 /* name came from an SV, so it will have a '\0' at the
3404 end that we can copy as part of this memcpy(). */
3405 memcpy(tmp, name, len + 1);
3407 SvCUR_set(namesv, dirlen + len + 1);
3409 /* Don't even actually have to turn SvPOK_on() as we
3410 access it directly with SvPVX() below. */
3415 TAINT_PROPER("require");
3416 tryname = SvPVX_const(namesv);
3417 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3419 if (tryname[0] == '.' && tryname[1] == '/')
3423 else if (errno == EMFILE)
3424 /* no point in trying other paths if out of handles */
3431 SAVECOPFILE_FREE(&PL_compiling);
3432 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3433 SvREFCNT_dec(namesv);
3435 if (PL_op->op_type == OP_REQUIRE) {
3436 const char *msgstr = name;
3437 if(errno == EMFILE) {
3439 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3441 msgstr = SvPV_nolen_const(msg);
3443 if (namesv) { /* did we lookup @INC? */
3444 AV * const ar = GvAVn(PL_incgv);
3446 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3447 "%s in @INC%s%s (@INC contains:",
3449 (instr(msgstr, ".h ")
3450 ? " (change .h to .ph maybe?)" : ""),
3451 (instr(msgstr, ".ph ")
3452 ? " (did you run h2ph?)" : "")
3455 for (i = 0; i <= AvFILL(ar); i++) {
3456 sv_catpvs(msg, " ");
3457 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3459 sv_catpvs(msg, ")");
3460 msgstr = SvPV_nolen_const(msg);
3463 DIE(aTHX_ "Can't locate %s", msgstr);
3469 SETERRNO(0, SS_NORMAL);
3471 /* Assume success here to prevent recursive requirement. */
3472 /* name is never assigned to again, so len is still strlen(name) */
3473 /* Check whether a hook in @INC has already filled %INC */
3475 (void)hv_store(GvHVn(PL_incgv),
3476 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3478 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3480 (void)hv_store(GvHVn(PL_incgv),
3481 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3486 lex_start(NULL, tryrsfp, TRUE);
3490 SAVECOMPILEWARNINGS();
3491 if (PL_dowarn & G_WARN_ALL_ON)
3492 PL_compiling.cop_warnings = pWARN_ALL ;
3493 else if (PL_dowarn & G_WARN_ALL_OFF)
3494 PL_compiling.cop_warnings = pWARN_NONE ;
3496 PL_compiling.cop_warnings = pWARN_STD ;
3498 if (filter_sub || filter_cache) {
3499 SV * const datasv = filter_add(S_run_user_filter, NULL);
3500 IoLINES(datasv) = filter_has_file;
3501 IoTOP_GV(datasv) = (GV *)filter_state;
3502 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3503 IoFMT_GV(datasv) = (GV *)filter_cache;
3506 /* switch to eval mode */
3507 PUSHBLOCK(cx, CXt_EVAL, SP);
3508 PUSHEVAL(cx, name, NULL);
3509 cx->blk_eval.retop = PL_op->op_next;
3511 SAVECOPLINE(&PL_compiling);
3512 CopLINE_set(&PL_compiling, 0);
3516 /* Store and reset encoding. */
3517 encoding = PL_encoding;
3520 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3521 op = DOCATCH(PL_eval_start);
3523 op = PL_op->op_next;
3525 /* Restore encoding. */
3526 PL_encoding = encoding;
3534 register PERL_CONTEXT *cx;
3536 const I32 gimme = GIMME_V;
3537 const I32 was = PL_sub_generation;
3538 char tbuf[TYPE_DIGITS(long) + 12];
3539 char *tmpbuf = tbuf;
3545 HV *saved_hh = NULL;
3546 const char * const fakestr = "_<(eval )";
3547 const int fakelen = 9 + 1;
3549 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3550 saved_hh = (HV*) SvREFCNT_inc(POPs);
3554 TAINT_IF(SvTAINTED(sv));
3555 TAINT_PROPER("eval");
3558 lex_start(sv, NULL, FALSE);
3561 /* switch to eval mode */
3563 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3564 SV * const temp_sv = sv_newmortal();
3565 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3566 (unsigned long)++PL_evalseq,
3567 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3568 tmpbuf = SvPVX(temp_sv);
3569 len = SvCUR(temp_sv);
3572 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3573 SAVECOPFILE_FREE(&PL_compiling);
3574 CopFILE_set(&PL_compiling, tmpbuf+2);
3575 SAVECOPLINE(&PL_compiling);
3576 CopLINE_set(&PL_compiling, 1);
3577 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3578 deleting the eval's FILEGV from the stash before gv_check() runs
3579 (i.e. before run-time proper). To work around the coredump that
3580 ensues, we always turn GvMULTI_on for any globals that were
3581 introduced within evals. See force_ident(). GSAR 96-10-12 */
3582 safestr = savepvn(tmpbuf, len);
3583 SAVEDELETE(PL_defstash, safestr, len);
3585 PL_hints = PL_op->op_targ;
3587 GvHV(PL_hintgv) = saved_hh;
3588 SAVECOMPILEWARNINGS();
3589 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3590 if (PL_compiling.cop_hints_hash) {
3591 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3593 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3594 if (PL_compiling.cop_hints_hash) {
3596 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3597 HINTS_REFCNT_UNLOCK;
3599 /* special case: an eval '' executed within the DB package gets lexically
3600 * placed in the first non-DB CV rather than the current CV - this
3601 * allows the debugger to execute code, find lexicals etc, in the
3602 * scope of the code being debugged. Passing &seq gets find_runcv
3603 * to do the dirty work for us */
3604 runcv = find_runcv(&seq);
3606 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3607 PUSHEVAL(cx, 0, NULL);
3608 cx->blk_eval.retop = PL_op->op_next;
3610 /* prepare to compile string */
3612 if (PERLDB_LINE && PL_curstash != PL_debstash)
3613 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3615 ok = doeval(gimme, NULL, runcv, seq);
3616 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3618 /* Copy in anything fake and short. */
3619 my_strlcpy(safestr, fakestr, fakelen);
3621 return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3631 register PERL_CONTEXT *cx;
3633 const U8 save_flags = PL_op -> op_flags;
3638 retop = cx->blk_eval.retop;
3641 if (gimme == G_VOID)
3643 else if (gimme == G_SCALAR) {
3646 if (SvFLAGS(TOPs) & SVs_TEMP)
3649 *MARK = sv_mortalcopy(TOPs);
3653 *MARK = &PL_sv_undef;
3658 /* in case LEAVE wipes old return values */
3659 for (mark = newsp + 1; mark <= SP; mark++) {
3660 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3661 *mark = sv_mortalcopy(*mark);
3662 TAINT_NOT; /* Each item is independent */
3666 PL_curpm = newpm; /* Don't pop $1 et al till now */
3669 assert(CvDEPTH(PL_compcv) == 1);
3671 CvDEPTH(PL_compcv) = 0;
3674 if (optype == OP_REQUIRE &&
3675 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3677 /* Unassume the success we assumed earlier. */
3678 SV * const nsv = cx->blk_eval.old_namesv;
3679 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3680 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3681 /* die_where() did LEAVE, or we won't be here */
3685 if (!(save_flags & OPf_SPECIAL))
3686 sv_setpvn(ERRSV,"",0);
3692 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3693 close to the related Perl_create_eval_scope. */
3695 Perl_delete_eval_scope(pTHX)
3700 register PERL_CONTEXT *cx;
3707 PERL_UNUSED_VAR(newsp);
3708 PERL_UNUSED_VAR(gimme);
3709 PERL_UNUSED_VAR(optype);
3712 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3713 also needed by Perl_fold_constants. */
3715 Perl_create_eval_scope(pTHX_ U32 flags)
3718 const I32 gimme = GIMME_V;
3723 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3726 PL_in_eval = EVAL_INEVAL;
3727 if (flags & G_KEEPERR)
3728 PL_in_eval |= EVAL_KEEPERR;
3730 sv_setpvn(ERRSV,"",0);
3731 if (flags & G_FAKINGEVAL) {
3732 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3740 PERL_CONTEXT * const cx = create_eval_scope(0);
3741 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3742 return DOCATCH(PL_op->op_next);
3751 register PERL_CONTEXT *cx;
3756 PERL_UNUSED_VAR(optype);
3759 if (gimme == G_VOID)
3761 else if (gimme == G_SCALAR) {
3765 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3768 *MARK = sv_mortalcopy(TOPs);
3772 *MARK = &PL_sv_undef;
3777 /* in case LEAVE wipes old return values */
3779 for (mark = newsp + 1; mark <= SP; mark++) {
3780 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3781 *mark = sv_mortalcopy(*mark);
3782 TAINT_NOT; /* Each item is independent */
3786 PL_curpm = newpm; /* Don't pop $1 et al till now */
3789 sv_setpvn(ERRSV,"",0);
3796 register PERL_CONTEXT *cx;
3797 const I32 gimme = GIMME_V;
3802 if (PL_op->op_targ == 0) {
3803 SV ** const defsv_p = &GvSV(PL_defgv);
3804 *defsv_p = newSVsv(POPs);
3805 SAVECLEARSV(*defsv_p);
3808 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3810 PUSHBLOCK(cx, CXt_GIVEN, SP);
3819 register PERL_CONTEXT *cx;
3823 PERL_UNUSED_CONTEXT;
3826 assert(CxTYPE(cx) == CXt_GIVEN);
3831 PL_curpm = newpm; /* pop $1 et al */
3838 /* Helper routines used by pp_smartmatch */
3840 S_make_matcher(pTHX_ regexp *re)
3843 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3844 PM_SETRE(matcher, ReREFCNT_inc(re));
3846 SAVEFREEOP((OP *) matcher);
3853 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3858 PL_op = (OP *) matcher;
3863 return (SvTRUEx(POPs));
3867 S_destroy_matcher(pTHX_ PMOP *matcher)
3870 PERL_UNUSED_ARG(matcher);
3875 /* Do a smart match */
3878 return do_smartmatch(NULL, NULL);
3881 /* This version of do_smartmatch() implements the
3882 * table of smart matches that is found in perlsyn.
3885 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3890 SV *e = TOPs; /* e is for 'expression' */
3891 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3892 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3894 regexp *this_regex, *other_regex;
3896 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3898 # define SM_REF(type) ( \
3899 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3900 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3902 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3903 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
3904 && NOT_EMPTY_PROTO(This) && (Other = e)) \
3905 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
3906 && NOT_EMPTY_PROTO(This) && (Other = d)))
3908 # define SM_REGEX ( \
3909 (SvROK(d) && SvMAGICAL(This = SvRV(d)) \
3910 && (mg = mg_find(This, PERL_MAGIC_qr)) \
3911 && (this_regex = (regexp *)mg->mg_obj) \
3914 (SvROK(e) && SvMAGICAL(This = SvRV(e)) \
3915 && (mg = mg_find(This, PERL_MAGIC_qr)) \
3916 && (this_regex = (regexp *)mg->mg_obj) \
3920 # define SM_OTHER_REF(type) \
3921 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3923 # define SM_OTHER_REGEX (SvROK(Other) && SvMAGICAL(SvRV(Other)) \
3924 && (mg = mg_find(SvRV(Other), PERL_MAGIC_qr)) \
3925 && (other_regex = (regexp *)mg->mg_obj))
3928 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3929 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3931 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3932 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3934 tryAMAGICbinSET(smart, 0);
3936 SP -= 2; /* Pop the values */
3938 /* Take care only to invoke mg_get() once for each argument.
3939 * Currently we do this by copying the SV if it's magical. */
3942 d = sv_mortalcopy(d);
3949 e = sv_mortalcopy(e);
3954 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3956 if (This == SvRV(Other))
3967 c = call_sv(This, G_SCALAR);
3971 else if (SvTEMP(TOPs))
3972 SvREFCNT_inc_void(TOPs);
3977 else if (SM_REF(PVHV)) {
3978 if (SM_OTHER_REF(PVHV)) {
3979 /* Check that the key-sets are identical */
3981 HV *other_hv = (HV *) SvRV(Other);
3983 bool other_tied = FALSE;
3984 U32 this_key_count = 0,
3985 other_key_count = 0;
3987 /* Tied hashes don't know how many keys they have. */
3988 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
3991 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3992 HV * const temp = other_hv;
3993 other_hv = (HV *) This;
3997 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
4000 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
4003 /* The hashes have the same number of keys, so it suffices
4004 to check that one is a subset of the other. */
4005 (void) hv_iterinit((HV *) This);
4006 while ( (he = hv_iternext((HV *) This)) ) {
4008 char * const key = hv_iterkey(he, &key_len);
4012 if(!hv_exists(other_hv, key, key_len)) {
4013 (void) hv_iterinit((HV *) This); /* reset iterator */
4019 (void) hv_iterinit(other_hv);
4020 while ( hv_iternext(other_hv) )
4024 other_key_count = HvUSEDKEYS(other_hv);
4026 if (this_key_count != other_key_count)
4031 else if (SM_OTHER_REF(PVAV)) {
4032 AV * const other_av = (AV *) SvRV(Other);
4033 const I32 other_len = av_len(other_av) + 1;
4036 for (i = 0; i < other_len; ++i) {
4037 SV ** const svp = av_fetch(other_av, i, FALSE);
4041 if (svp) { /* ??? When can this not happen? */
4042 key = SvPV(*svp, key_len);
4043 if (hv_exists((HV *) This, key, key_len))
4049 else if (SM_OTHER_REGEX) {
4050 PMOP * const matcher = make_matcher(other_regex);
4053 (void) hv_iterinit((HV *) This);
4054 while ( (he = hv_iternext((HV *) This)) ) {
4055 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4056 (void) hv_iterinit((HV *) This);
4057 destroy_matcher(matcher);
4061 destroy_matcher(matcher);
4065 if (hv_exists_ent((HV *) This, Other, 0))
4071 else if (SM_REF(PVAV)) {
4072 if (SM_OTHER_REF(PVAV)) {
4073 AV *other_av = (AV *) SvRV(Other);
4074 if (av_len((AV *) This) != av_len(other_av))
4078 const I32 other_len = av_len(other_av);
4080 if (NULL == seen_this) {
4081 seen_this = newHV();
4082 (void) sv_2mortal((SV *) seen_this);
4084 if (NULL == seen_other) {
4085 seen_this = newHV();
4086 (void) sv_2mortal((SV *) seen_other);
4088 for(i = 0; i <= other_len; ++i) {
4089 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4090 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4092 if (!this_elem || !other_elem) {
4093 if (this_elem || other_elem)
4096 else if (SM_SEEN_THIS(*this_elem)
4097 || SM_SEEN_OTHER(*other_elem))
4099 if (*this_elem != *other_elem)
4103 (void)hv_store_ent(seen_this,
4104 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4106 (void)hv_store_ent(seen_other,
4107 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4113 (void) do_smartmatch(seen_this, seen_other);
4123 else if (SM_OTHER_REGEX) {
4124 PMOP * const matcher = make_matcher(other_regex);
4125 const I32 this_len = av_len((AV *) This);
4128 for(i = 0; i <= this_len; ++i) {
4129 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4130 if (svp && matcher_matches_sv(matcher, *svp)) {
4131 destroy_matcher(matcher);
4135 destroy_matcher(matcher);
4138 else if (SvIOK(Other) || SvNOK(Other)) {
4141 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4142 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4149 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4159 else if (SvPOK(Other)) {
4160 const I32 this_len = av_len((AV *) This);
4163 for(i = 0; i <= this_len; ++i) {
4164 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4179 else if (!SvOK(d) || !SvOK(e)) {
4180 if (!SvOK(d) && !SvOK(e))
4185 else if (SM_REGEX) {
4186 PMOP * const matcher = make_matcher(this_regex);
4189 PUSHs(matcher_matches_sv(matcher, Other)
4192 destroy_matcher(matcher);
4195 else if (SM_REF(PVCV)) {
4197 /* This must be a null-prototyped sub, because we
4198 already checked for the other kind. */
4204 c = call_sv(This, G_SCALAR);
4207 PUSHs(&PL_sv_undef);
4208 else if (SvTEMP(TOPs))
4209 SvREFCNT_inc_void(TOPs);
4211 if (SM_OTHER_REF(PVCV)) {
4212 /* This one has to be null-proto'd too.
4213 Call both of 'em, and compare the results */
4215 c = call_sv(SvRV(Other), G_SCALAR);
4218 PUSHs(&PL_sv_undef);
4219 else if (SvTEMP(TOPs))
4220 SvREFCNT_inc_void(TOPs);
4231 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4232 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4234 if (SvPOK(Other) && !looks_like_number(Other)) {
4235 /* String comparison */
4240 /* Otherwise, numeric comparison */
4243 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4254 /* As a last resort, use string comparison */
4263 register PERL_CONTEXT *cx;
4264 const I32 gimme = GIMME_V;
4266 /* This is essentially an optimization: if the match
4267 fails, we don't want to push a context and then
4268 pop it again right away, so we skip straight
4269 to the op that follows the leavewhen.
4271 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4272 return cLOGOP->op_other->op_next;
4277 PUSHBLOCK(cx, CXt_WHEN, SP);
4286 register PERL_CONTEXT *cx;
4292 assert(CxTYPE(cx) == CXt_WHEN);
4297 PL_curpm = newpm; /* pop $1 et al */
4307 register PERL_CONTEXT *cx;
4310 cxix = dopoptowhen(cxstack_ix);
4312 DIE(aTHX_ "Can't \"continue\" outside a when block");
4313 if (cxix < cxstack_ix)
4316 /* clear off anything above the scope we're re-entering */
4317 inner = PL_scopestack_ix;
4319 if (PL_scopestack_ix < inner)
4320 leave_scope(PL_scopestack[PL_scopestack_ix]);
4321 PL_curcop = cx->blk_oldcop;
4322 return cx->blk_givwhen.leave_op;
4329 register PERL_CONTEXT *cx;
4332 cxix = dopoptogiven(cxstack_ix);
4334 if (PL_op->op_flags & OPf_SPECIAL)
4335 DIE(aTHX_ "Can't use when() outside a topicalizer");
4337 DIE(aTHX_ "Can't \"break\" outside a given block");
4339 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4340 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4342 if (cxix < cxstack_ix)
4345 /* clear off anything above the scope we're re-entering */
4346 inner = PL_scopestack_ix;
4348 if (PL_scopestack_ix < inner)
4349 leave_scope(PL_scopestack[PL_scopestack_ix]);
4350 PL_curcop = cx->blk_oldcop;
4353 return CX_LOOP_NEXTOP_GET(cx);
4355 return cx->blk_givwhen.leave_op;
4359 S_doparseform(pTHX_ SV *sv)
4362 register char *s = SvPV_force(sv, len);
4363 register char * const send = s + len;
4364 register char *base = NULL;
4365 register I32 skipspaces = 0;
4366 bool noblank = FALSE;
4367 bool repeat = FALSE;
4368 bool postspace = FALSE;
4374 bool unchopnum = FALSE;
4375 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4378 Perl_croak(aTHX_ "Null picture in formline");
4380 /* estimate the buffer size needed */
4381 for (base = s; s <= send; s++) {
4382 if (*s == '\n' || *s == '@' || *s == '^')
4388 Newx(fops, maxops, U32);
4393 *fpc++ = FF_LINEMARK;
4394 noblank = repeat = FALSE;
4412 case ' ': case '\t':
4419 } /* else FALL THROUGH */
4427 *fpc++ = FF_LITERAL;
4435 *fpc++ = (U16)skipspaces;
4439 *fpc++ = FF_NEWLINE;
4443 arg = fpc - linepc + 1;
4450 *fpc++ = FF_LINEMARK;
4451 noblank = repeat = FALSE;
4460 ischop = s[-1] == '^';
4466 arg = (s - base) - 1;
4468 *fpc++ = FF_LITERAL;
4476 *fpc++ = 2; /* skip the @* or ^* */
4478 *fpc++ = FF_LINESNGL;
4481 *fpc++ = FF_LINEGLOB;
4483 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4484 arg = ischop ? 512 : 0;
4489 const char * const f = ++s;
4492 arg |= 256 + (s - f);
4494 *fpc++ = s - base; /* fieldsize for FETCH */
4495 *fpc++ = FF_DECIMAL;
4497 unchopnum |= ! ischop;
4499 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4500 arg = ischop ? 512 : 0;
4502 s++; /* skip the '0' first */
4506 const char * const f = ++s;
4509 arg |= 256 + (s - f);
4511 *fpc++ = s - base; /* fieldsize for FETCH */
4512 *fpc++ = FF_0DECIMAL;
4514 unchopnum |= ! ischop;
4518 bool ismore = FALSE;
4521 while (*++s == '>') ;
4522 prespace = FF_SPACE;
4524 else if (*s == '|') {
4525 while (*++s == '|') ;
4526 prespace = FF_HALFSPACE;
4531 while (*++s == '<') ;
4534 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4538 *fpc++ = s - base; /* fieldsize for FETCH */
4540 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4543 *fpc++ = (U16)prespace;
4557 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4559 { /* need to jump to the next word */
4561 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4562 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4563 s = SvPVX(sv) + SvCUR(sv) + z;
4565 Copy(fops, s, arg, U32);
4567 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4570 if (unchopnum && repeat)
4571 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4577 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4579 /* Can value be printed in fldsize chars, using %*.*f ? */
4583 int intsize = fldsize - (value < 0 ? 1 : 0);
4590 while (intsize--) pwr *= 10.0;
4591 while (frcsize--) eps /= 10.0;
4594 if (value + eps >= pwr)
4597 if (value - eps <= -pwr)
4604 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4607 SV * const datasv = FILTER_DATA(idx);
4608 const int filter_has_file = IoLINES(datasv);
4609 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4610 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4614 const char *got_p = NULL;
4615 const char *prune_from = NULL;
4616 bool read_from_cache = FALSE;
4619 assert(maxlen >= 0);
4622 /* I was having segfault trouble under Linux 2.2.5 after a
4623 parse error occured. (Had to hack around it with a test
4624 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4625 not sure where the trouble is yet. XXX */
4627 if (IoFMT_GV(datasv)) {
4628 SV *const cache = (SV *)IoFMT_GV(datasv);
4631 const char *cache_p = SvPV(cache, cache_len);
4635 /* Running in block mode and we have some cached data already.
4637 if (cache_len >= umaxlen) {
4638 /* In fact, so much data we don't even need to call
4643 const char *const first_nl =
4644 (const char *)memchr(cache_p, '\n', cache_len);
4646 take = first_nl + 1 - cache_p;
4650 sv_catpvn(buf_sv, cache_p, take);
4651 sv_chop(cache, cache_p + take);
4652 /* Definately not EOF */
4656 sv_catsv(buf_sv, cache);
4658 umaxlen -= cache_len;
4661 read_from_cache = TRUE;
4665 /* Filter API says that the filter appends to the contents of the buffer.
4666 Usually the buffer is "", so the details don't matter. But if it's not,
4667 then clearly what it contains is already filtered by this filter, so we
4668 don't want to pass it in a second time.
4669 I'm going to use a mortal in case the upstream filter croaks. */
4670 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4671 ? sv_newmortal() : buf_sv;
4672 SvUPGRADE(upstream, SVt_PV);
4674 if (filter_has_file) {
4675 status = FILTER_READ(idx+1, upstream, 0);
4678 if (filter_sub && status >= 0) {
4689 PUSHs(sv_2mortal(newSViv(0)));
4691 PUSHs(filter_state);
4694 count = call_sv(filter_sub, G_SCALAR);
4709 if(SvOK(upstream)) {
4710 got_p = SvPV(upstream, got_len);
4712 if (got_len > umaxlen) {
4713 prune_from = got_p + umaxlen;
4716 const char *const first_nl =
4717 (const char *)memchr(got_p, '\n', got_len);
4718 if (first_nl && first_nl + 1 < got_p + got_len) {
4719 /* There's a second line here... */
4720 prune_from = first_nl + 1;
4725 /* Oh. Too long. Stuff some in our cache. */
4726 STRLEN cached_len = got_p + got_len - prune_from;
4727 SV *cache = (SV *)IoFMT_GV(datasv);
4730 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4731 } else if (SvOK(cache)) {
4732 /* Cache should be empty. */
4733 assert(!SvCUR(cache));
4736 sv_setpvn(cache, prune_from, cached_len);
4737 /* If you ask for block mode, you may well split UTF-8 characters.
4738 "If it breaks, you get to keep both parts"
4739 (Your code is broken if you don't put them back together again
4740 before something notices.) */
4741 if (SvUTF8(upstream)) {
4744 SvCUR_set(upstream, got_len - cached_len);
4745 /* Can't yet be EOF */
4750 /* If they are at EOF but buf_sv has something in it, then they may never
4751 have touched the SV upstream, so it may be undefined. If we naively
4752 concatenate it then we get a warning about use of uninitialised value.
4754 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4755 sv_catsv(buf_sv, upstream);
4759 IoLINES(datasv) = 0;
4760 SvREFCNT_dec(IoFMT_GV(datasv));
4762 SvREFCNT_dec(filter_state);
4763 IoTOP_GV(datasv) = NULL;
4766 SvREFCNT_dec(filter_sub);
4767 IoBOTTOM_GV(datasv) = NULL;
4769 filter_del(S_run_user_filter);
4771 if (status == 0 && read_from_cache) {
4772 /* If we read some data from the cache (and by getting here it implies
4773 that we emptied the cache) then we aren't yet at EOF, and mustn't
4774 report that to our caller. */
4780 /* perhaps someone can come up with a better name for
4781 this? it is not really "absolute", per se ... */
4783 S_path_is_absolute(const char *name)
4785 if (PERL_FILE_IS_ABSOLUTE(name)
4786 #ifdef MACOS_TRADITIONAL
4789 || (*name == '.' && (name[1] == '/' ||
4790 (name[1] == '.' && name[2] == '/')))
4802 * c-indentation-style: bsd
4804 * indent-tabs-mode: t
4807 * ex: set ts=8 sts=4 sw=4 noet: