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))
48 cxix = dopoptosub(cxstack_ix);
52 switch (cxstack[cxix].blk_gimme) {
65 /* XXXX Should store the old value to allow for tie/overload - and
66 restore in regcomp, where marked with XXXX. */
76 register PMOP *pm = (PMOP*)cLOGOP->op_other;
81 /* prevent recompiling under /o and ithreads. */
82 #if defined(USE_ITHREADS)
83 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
84 if (PL_op->op_flags & OPf_STACKED) {
93 if (PL_op->op_flags & OPf_STACKED) {
94 /* multiple args; concatentate them */
96 tmpstr = PAD_SV(ARGTARG);
97 sv_setpvn(tmpstr, "", 0);
98 while (++MARK <= SP) {
99 if (PL_amagic_generation) {
101 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
102 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
104 sv_setsv(tmpstr, sv);
108 sv_catsv(tmpstr, *MARK);
117 SV * const sv = SvRV(tmpstr);
119 mg = mg_find(sv, PERL_MAGIC_qr);
122 regexp * const re = reg_temp_copy((regexp *)mg->mg_obj);
123 ReREFCNT_dec(PM_GETRE(pm));
128 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
131 /* Check against the last compiled regexp. */
132 if (!re || !re->precomp || re->prelen != (I32)len ||
133 memNE(re->precomp, t, len))
135 const regexp_engine *eng = re ? re->engine : NULL;
136 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
139 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
140 } else if (PL_curcop->cop_hints_hash) {
141 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
143 if (ptr && SvIOK(ptr) && SvIV(ptr))
144 eng = INT2PTR(regexp_engine*,SvIV(ptr));
147 if (PL_op->op_flags & OPf_SPECIAL)
148 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
151 pm_flags |= RXf_UTF8;
154 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
156 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
158 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
159 inside tie/overload accessors. */
165 #ifndef INCOMPLETE_TAINTS
168 re->extflags |= RXf_TAINTED;
170 re->extflags &= ~RXf_TAINTED;
174 if (!PM_GETRE(pm)->prelen && PL_curpm)
178 #if !defined(USE_ITHREADS)
179 /* can't change the optree at runtime either */
180 /* PMf_KEEP is handled differently under threads to avoid these problems */
181 if (pm->op_pmflags & PMf_KEEP) {
182 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
183 cLOGOP->op_first->op_next = PL_op->op_next;
193 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
194 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
195 register SV * const dstr = cx->sb_dstr;
196 register char *s = cx->sb_s;
197 register char *m = cx->sb_m;
198 char *orig = cx->sb_orig;
199 register REGEXP * const rx = cx->sb_rx;
201 REGEXP *old = PM_GETRE(pm);
205 PM_SETRE(pm,ReREFCNT_inc(rx));
208 rxres_restore(&cx->sb_rxres, rx);
209 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
211 if (cx->sb_iters++) {
212 const I32 saviters = cx->sb_iters;
213 if (cx->sb_iters > cx->sb_maxiters)
214 DIE(aTHX_ "Substitution loop");
216 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
217 cx->sb_rxtainted |= 2;
218 sv_catsv(dstr, POPs);
219 FREETMPS; /* Prevent excess tmp stack */
222 if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
223 s == m, cx->sb_targ, NULL,
224 ((cx->sb_rflags & REXEC_COPY_STR)
225 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
226 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
228 SV * const targ = cx->sb_targ;
230 assert(cx->sb_strend >= s);
231 if(cx->sb_strend > s) {
232 if (DO_UTF8(dstr) && !SvUTF8(targ))
233 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
235 sv_catpvn(dstr, s, cx->sb_strend - s);
237 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
239 #ifdef PERL_OLD_COPY_ON_WRITE
241 sv_force_normal_flags(targ, SV_COW_DROP_PV);
247 SvPV_set(targ, SvPVX(dstr));
248 SvCUR_set(targ, SvCUR(dstr));
249 SvLEN_set(targ, SvLEN(dstr));
252 SvPV_set(dstr, NULL);
254 TAINT_IF(cx->sb_rxtainted & 1);
255 PUSHs(sv_2mortal(newSViv(saviters - 1)));
257 (void)SvPOK_only_UTF8(targ);
258 TAINT_IF(cx->sb_rxtainted);
262 LEAVE_SCOPE(cx->sb_oldsave);
264 RETURNOP(pm->op_next);
266 cx->sb_iters = saviters;
268 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
271 cx->sb_orig = orig = rx->subbeg;
273 cx->sb_strend = s + (cx->sb_strend - m);
275 cx->sb_m = m = rx->offs[0].start + orig;
277 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
278 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
280 sv_catpvn(dstr, s, m-s);
282 cx->sb_s = rx->offs[0].end + orig;
283 { /* Update the pos() information. */
284 SV * const sv = cx->sb_targ;
287 SvUPGRADE(sv, SVt_PVMG);
288 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
289 #ifdef PERL_OLD_COPY_ON_WRITE
291 sv_force_normal_flags(sv, 0);
293 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
302 (void)ReREFCNT_inc(rx);
303 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
304 rxres_save(&cx->sb_rxres, rx);
305 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
309 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
315 if (!p || p[1] < rx->nparens) {
316 #ifdef PERL_OLD_COPY_ON_WRITE
317 i = 7 + rx->nparens * 2;
319 i = 6 + rx->nparens * 2;
328 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : NULL);
329 RX_MATCH_COPIED_off(rx);
331 #ifdef PERL_OLD_COPY_ON_WRITE
332 *p++ = PTR2UV(rx->saved_copy);
333 rx->saved_copy = NULL;
338 *p++ = PTR2UV(rx->subbeg);
339 *p++ = (UV)rx->sublen;
340 for (i = 0; i <= rx->nparens; ++i) {
341 *p++ = (UV)rx->offs[i].start;
342 *p++ = (UV)rx->offs[i].end;
347 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
353 RX_MATCH_COPY_FREE(rx);
354 RX_MATCH_COPIED_set(rx, *p);
357 #ifdef PERL_OLD_COPY_ON_WRITE
359 SvREFCNT_dec (rx->saved_copy);
360 rx->saved_copy = INT2PTR(SV*,*p);
366 rx->subbeg = INT2PTR(char*,*p++);
367 rx->sublen = (I32)(*p++);
368 for (i = 0; i <= rx->nparens; ++i) {
369 rx->offs[i].start = (I32)(*p++);
370 rx->offs[i].end = (I32)(*p++);
375 Perl_rxres_free(pTHX_ void **rsp)
377 UV * const p = (UV*)*rsp;
382 void *tmp = INT2PTR(char*,*p);
385 PoisonFree(*p, 1, sizeof(*p));
387 Safefree(INT2PTR(char*,*p));
389 #ifdef PERL_OLD_COPY_ON_WRITE
391 SvREFCNT_dec (INT2PTR(SV*,p[1]));
401 dVAR; dSP; dMARK; dORIGMARK;
402 register SV * const tmpForm = *++MARK;
407 register SV *sv = NULL;
408 const char *item = NULL;
412 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
413 const char *chophere = NULL;
414 char *linemark = NULL;
416 bool gotsome = FALSE;
418 const STRLEN fudge = SvPOK(tmpForm)
419 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
420 bool item_is_utf8 = FALSE;
421 bool targ_is_utf8 = FALSE;
423 OP * parseres = NULL;
427 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
428 if (SvREADONLY(tmpForm)) {
429 SvREADONLY_off(tmpForm);
430 parseres = doparseform(tmpForm);
431 SvREADONLY_on(tmpForm);
434 parseres = doparseform(tmpForm);
438 SvPV_force(PL_formtarget, len);
439 if (DO_UTF8(PL_formtarget))
441 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
443 f = SvPV_const(tmpForm, len);
444 /* need to jump to the next word */
445 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
449 const char *name = "???";
452 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
453 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
454 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
455 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
456 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
458 case FF_CHECKNL: name = "CHECKNL"; break;
459 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
460 case FF_SPACE: name = "SPACE"; break;
461 case FF_HALFSPACE: name = "HALFSPACE"; break;
462 case FF_ITEM: name = "ITEM"; break;
463 case FF_CHOP: name = "CHOP"; break;
464 case FF_LINEGLOB: name = "LINEGLOB"; break;
465 case FF_NEWLINE: name = "NEWLINE"; break;
466 case FF_MORE: name = "MORE"; break;
467 case FF_LINEMARK: name = "LINEMARK"; break;
468 case FF_END: name = "END"; break;
469 case FF_0DECIMAL: name = "0DECIMAL"; break;
470 case FF_LINESNGL: name = "LINESNGL"; break;
473 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
475 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
486 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
487 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
489 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
490 t = SvEND(PL_formtarget);
493 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
494 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
496 sv_utf8_upgrade(PL_formtarget);
497 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
498 t = SvEND(PL_formtarget);
518 if (ckWARN(WARN_SYNTAX))
519 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
526 const char *s = item = SvPV_const(sv, len);
529 itemsize = sv_len_utf8(sv);
530 if (itemsize != (I32)len) {
532 if (itemsize > fieldsize) {
533 itemsize = fieldsize;
534 itembytes = itemsize;
535 sv_pos_u2b(sv, &itembytes, 0);
539 send = chophere = s + itembytes;
549 sv_pos_b2u(sv, &itemsize);
553 item_is_utf8 = FALSE;
554 if (itemsize > fieldsize)
555 itemsize = fieldsize;
556 send = chophere = s + itemsize;
570 const char *s = item = SvPV_const(sv, len);
573 itemsize = sv_len_utf8(sv);
574 if (itemsize != (I32)len) {
576 if (itemsize <= fieldsize) {
577 const char *send = chophere = s + itemsize;
590 itemsize = fieldsize;
591 itembytes = itemsize;
592 sv_pos_u2b(sv, &itembytes, 0);
593 send = chophere = s + itembytes;
594 while (s < send || (s == send && isSPACE(*s))) {
604 if (strchr(PL_chopset, *s))
609 itemsize = chophere - item;
610 sv_pos_b2u(sv, &itemsize);
616 item_is_utf8 = FALSE;
617 if (itemsize <= fieldsize) {
618 const char *const send = chophere = s + itemsize;
631 itemsize = fieldsize;
632 send = chophere = s + itemsize;
633 while (s < send || (s == send && isSPACE(*s))) {
643 if (strchr(PL_chopset, *s))
648 itemsize = chophere - item;
654 arg = fieldsize - itemsize;
663 arg = fieldsize - itemsize;
674 const char *s = item;
678 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
680 sv_utf8_upgrade(PL_formtarget);
681 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
682 t = SvEND(PL_formtarget);
686 if (UTF8_IS_CONTINUED(*s)) {
687 STRLEN skip = UTF8SKIP(s);
704 if ( !((*t++ = *s++) & ~31) )
710 if (targ_is_utf8 && !item_is_utf8) {
711 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
713 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
714 for (; t < SvEND(PL_formtarget); t++) {
727 const int ch = *t++ = *s++;
730 if ( !((*t++ = *s++) & ~31) )
739 const char *s = chophere;
757 const char *s = item = SvPV_const(sv, len);
759 if ((item_is_utf8 = DO_UTF8(sv)))
760 itemsize = sv_len_utf8(sv);
762 bool chopped = FALSE;
763 const char *const send = s + len;
765 chophere = s + itemsize;
781 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
783 SvUTF8_on(PL_formtarget);
785 SvCUR_set(sv, chophere - item);
786 sv_catsv(PL_formtarget, sv);
787 SvCUR_set(sv, itemsize);
789 sv_catsv(PL_formtarget, sv);
791 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
792 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
793 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
802 #if defined(USE_LONG_DOUBLE)
805 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
809 "%#0*.*f" : "%0*.*f");
814 #if defined(USE_LONG_DOUBLE)
816 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
819 ((arg & 256) ? "%#*.*f" : "%*.*f");
822 /* If the field is marked with ^ and the value is undefined,
824 if ((arg & 512) && !SvOK(sv)) {
832 /* overflow evidence */
833 if (num_overflow(value, fieldsize, arg)) {
839 /* Formats aren't yet marked for locales, so assume "yes". */
841 STORE_NUMERIC_STANDARD_SET_LOCAL();
842 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
843 RESTORE_NUMERIC_STANDARD();
850 while (t-- > linemark && *t == ' ') ;
858 if (arg) { /* repeat until fields exhausted? */
860 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
861 lines += FmLINES(PL_formtarget);
864 if (strnEQ(linemark, linemark - arg, arg))
865 DIE(aTHX_ "Runaway format");
868 SvUTF8_on(PL_formtarget);
869 FmLINES(PL_formtarget) = lines;
871 RETURNOP(cLISTOP->op_first);
882 const char *s = chophere;
883 const char *send = item + len;
885 while (isSPACE(*s) && (s < send))
890 arg = fieldsize - itemsize;
897 if (strnEQ(s1," ",3)) {
898 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
909 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
911 SvUTF8_on(PL_formtarget);
912 FmLINES(PL_formtarget) += lines;
924 if (PL_stack_base + *PL_markstack_ptr == SP) {
926 if (GIMME_V == G_SCALAR)
927 XPUSHs(sv_2mortal(newSViv(0)));
928 RETURNOP(PL_op->op_next->op_next);
930 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
931 pp_pushmark(); /* push dst */
932 pp_pushmark(); /* push src */
933 ENTER; /* enter outer scope */
936 if (PL_op->op_private & OPpGREP_LEX)
937 SAVESPTR(PAD_SVl(PL_op->op_targ));
940 ENTER; /* enter inner scope */
943 src = PL_stack_base[*PL_markstack_ptr];
945 if (PL_op->op_private & OPpGREP_LEX)
946 PAD_SVl(PL_op->op_targ) = src;
951 if (PL_op->op_type == OP_MAPSTART)
952 pp_pushmark(); /* push top */
953 return ((LOGOP*)PL_op->op_next)->op_other;
959 const I32 gimme = GIMME_V;
960 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
966 /* first, move source pointer to the next item in the source list */
967 ++PL_markstack_ptr[-1];
969 /* if there are new items, push them into the destination list */
970 if (items && gimme != G_VOID) {
971 /* might need to make room back there first */
972 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
973 /* XXX this implementation is very pessimal because the stack
974 * is repeatedly extended for every set of items. Is possible
975 * to do this without any stack extension or copying at all
976 * by maintaining a separate list over which the map iterates
977 * (like foreach does). --gsar */
979 /* everything in the stack after the destination list moves
980 * towards the end the stack by the amount of room needed */
981 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
983 /* items to shift up (accounting for the moved source pointer) */
984 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
986 /* This optimization is by Ben Tilly and it does
987 * things differently from what Sarathy (gsar)
988 * is describing. The downside of this optimization is
989 * that leaves "holes" (uninitialized and hopefully unused areas)
990 * to the Perl stack, but on the other hand this
991 * shouldn't be a problem. If Sarathy's idea gets
992 * implemented, this optimization should become
993 * irrelevant. --jhi */
995 shift = count; /* Avoid shifting too often --Ben Tilly */
1000 PL_markstack_ptr[-1] += shift;
1001 *PL_markstack_ptr += shift;
1005 /* copy the new items down to the destination list */
1006 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1007 if (gimme == G_ARRAY) {
1009 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1012 /* scalar context: we don't care about which values map returns
1013 * (we use undef here). And so we certainly don't want to do mortal
1014 * copies of meaningless values. */
1015 while (items-- > 0) {
1017 *dst-- = &PL_sv_undef;
1021 LEAVE; /* exit inner scope */
1024 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1026 (void)POPMARK; /* pop top */
1027 LEAVE; /* exit outer scope */
1028 (void)POPMARK; /* pop src */
1029 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1030 (void)POPMARK; /* pop dst */
1031 SP = PL_stack_base + POPMARK; /* pop original mark */
1032 if (gimme == G_SCALAR) {
1033 if (PL_op->op_private & OPpGREP_LEX) {
1034 SV* sv = sv_newmortal();
1035 sv_setiv(sv, items);
1043 else if (gimme == G_ARRAY)
1050 ENTER; /* enter inner scope */
1053 /* set $_ to the new source item */
1054 src = PL_stack_base[PL_markstack_ptr[-1]];
1056 if (PL_op->op_private & OPpGREP_LEX)
1057 PAD_SVl(PL_op->op_targ) = src;
1061 RETURNOP(cLOGOP->op_other);
1070 if (GIMME == G_ARRAY)
1072 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1073 return cLOGOP->op_other;
1083 if (GIMME == G_ARRAY) {
1084 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1088 SV * const targ = PAD_SV(PL_op->op_targ);
1091 if (PL_op->op_private & OPpFLIP_LINENUM) {
1092 if (GvIO(PL_last_in_gv)) {
1093 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1096 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1098 flip = SvIV(sv) == SvIV(GvSV(gv));
1104 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1105 if (PL_op->op_flags & OPf_SPECIAL) {
1113 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1116 sv_setpvn(TARG, "", 0);
1122 /* This code tries to decide if "$left .. $right" should use the
1123 magical string increment, or if the range is numeric (we make
1124 an exception for .."0" [#18165]). AMS 20021031. */
1126 #define RANGE_IS_NUMERIC(left,right) ( \
1127 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1128 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1129 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1130 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1131 && (!SvOK(right) || looks_like_number(right))))
1137 if (GIMME == G_ARRAY) {
1143 if (RANGE_IS_NUMERIC(left,right)) {
1146 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1147 (SvOK(right) && SvNV(right) > IV_MAX))
1148 DIE(aTHX_ "Range iterator outside integer range");
1159 SV * const sv = sv_2mortal(newSViv(i++));
1164 SV * const final = sv_mortalcopy(right);
1166 const char * const tmps = SvPV_const(final, len);
1168 SV *sv = sv_mortalcopy(left);
1169 SvPV_force_nolen(sv);
1170 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1172 if (strEQ(SvPVX_const(sv),tmps))
1174 sv = sv_2mortal(newSVsv(sv));
1181 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1185 if (PL_op->op_private & OPpFLIP_LINENUM) {
1186 if (GvIO(PL_last_in_gv)) {
1187 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1190 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1191 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1199 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1200 sv_catpvs(targ, "E0");
1210 static const char * const context_name[] = {
1223 S_dopoptolabel(pTHX_ const char *label)
1228 for (i = cxstack_ix; i >= 0; i--) {
1229 register const PERL_CONTEXT * const cx = &cxstack[i];
1230 switch (CxTYPE(cx)) {
1238 if (ckWARN(WARN_EXITING))
1239 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1240 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1241 if (CxTYPE(cx) == CXt_NULL)
1245 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1246 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1247 (long)i, cx->blk_loop.label));
1250 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1260 Perl_dowantarray(pTHX)
1263 const I32 gimme = block_gimme();
1264 return (gimme == G_VOID) ? G_SCALAR : gimme;
1268 Perl_block_gimme(pTHX)
1271 const I32 cxix = dopoptosub(cxstack_ix);
1275 switch (cxstack[cxix].blk_gimme) {
1283 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1290 Perl_is_lvalue_sub(pTHX)
1293 const I32 cxix = dopoptosub(cxstack_ix);
1294 assert(cxix >= 0); /* We should only be called from inside subs */
1296 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1297 return cxstack[cxix].blk_sub.lval;
1303 S_dopoptosub(pTHX_ I32 startingblock)
1306 return dopoptosub_at(cxstack, startingblock);
1310 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1314 for (i = startingblock; i >= 0; i--) {
1315 register const PERL_CONTEXT * const cx = &cxstk[i];
1316 switch (CxTYPE(cx)) {
1322 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1330 S_dopoptoeval(pTHX_ I32 startingblock)
1334 for (i = startingblock; i >= 0; i--) {
1335 register const PERL_CONTEXT *cx = &cxstack[i];
1336 switch (CxTYPE(cx)) {
1340 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1348 S_dopoptoloop(pTHX_ I32 startingblock)
1352 for (i = startingblock; i >= 0; i--) {
1353 register const PERL_CONTEXT * const cx = &cxstack[i];
1354 switch (CxTYPE(cx)) {
1360 if (ckWARN(WARN_EXITING))
1361 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1362 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1363 if ((CxTYPE(cx)) == CXt_NULL)
1367 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1375 S_dopoptogiven(pTHX_ I32 startingblock)
1379 for (i = startingblock; i >= 0; i--) {
1380 register const PERL_CONTEXT *cx = &cxstack[i];
1381 switch (CxTYPE(cx)) {
1385 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1388 if (CxFOREACHDEF(cx)) {
1389 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1398 S_dopoptowhen(pTHX_ I32 startingblock)
1402 for (i = startingblock; i >= 0; i--) {
1403 register const PERL_CONTEXT *cx = &cxstack[i];
1404 switch (CxTYPE(cx)) {
1408 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1416 Perl_dounwind(pTHX_ I32 cxix)
1421 while (cxstack_ix > cxix) {
1423 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1424 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1425 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1426 /* Note: we don't need to restore the base context info till the end. */
1427 switch (CxTYPE(cx)) {
1430 continue; /* not break */
1449 PERL_UNUSED_VAR(optype);
1453 Perl_qerror(pTHX_ SV *err)
1457 sv_catsv(ERRSV, err);
1459 sv_catsv(PL_errors, err);
1461 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1466 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1475 if (PL_in_eval & EVAL_KEEPERR) {
1476 static const char prefix[] = "\t(in cleanup) ";
1477 SV * const err = ERRSV;
1478 const char *e = NULL;
1480 sv_setpvn(err,"",0);
1481 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1483 e = SvPV_const(err, len);
1485 if (*e != *message || strNE(e,message))
1489 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1490 sv_catpvn(err, prefix, sizeof(prefix)-1);
1491 sv_catpvn(err, message, msglen);
1492 if (ckWARN(WARN_MISC)) {
1493 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1494 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1499 sv_setpvn(ERRSV, message, msglen);
1503 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1504 && PL_curstackinfo->si_prev)
1512 register PERL_CONTEXT *cx;
1515 if (cxix < cxstack_ix)
1518 POPBLOCK(cx,PL_curpm);
1519 if (CxTYPE(cx) != CXt_EVAL) {
1521 message = SvPVx_const(ERRSV, msglen);
1522 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1523 PerlIO_write(Perl_error_log, message, msglen);
1528 if (gimme == G_SCALAR)
1529 *++newsp = &PL_sv_undef;
1530 PL_stack_sp = newsp;
1534 /* LEAVE could clobber PL_curcop (see save_re_context())
1535 * XXX it might be better to find a way to avoid messing with
1536 * PL_curcop in save_re_context() instead, but this is a more
1537 * minimal fix --GSAR */
1538 PL_curcop = cx->blk_oldcop;
1540 if (optype == OP_REQUIRE) {
1541 const char* const msg = SvPVx_nolen_const(ERRSV);
1542 SV * const nsv = cx->blk_eval.old_namesv;
1543 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1545 DIE(aTHX_ "%sCompilation failed in require",
1546 *msg ? msg : "Unknown error\n");
1548 assert(CxTYPE(cx) == CXt_EVAL);
1549 return cx->blk_eval.retop;
1553 message = SvPVx_const(ERRSV, msglen);
1555 write_to_stderr(message, msglen);
1563 dVAR; dSP; dPOPTOPssrl;
1564 if (SvTRUE(left) != SvTRUE(right))
1574 register I32 cxix = dopoptosub(cxstack_ix);
1575 register const PERL_CONTEXT *cx;
1576 register const PERL_CONTEXT *ccstack = cxstack;
1577 const PERL_SI *top_si = PL_curstackinfo;
1579 const char *stashname;
1586 /* we may be in a higher stacklevel, so dig down deeper */
1587 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1588 top_si = top_si->si_prev;
1589 ccstack = top_si->si_cxstack;
1590 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1593 if (GIMME != G_ARRAY) {
1599 /* caller() should not report the automatic calls to &DB::sub */
1600 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1601 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1605 cxix = dopoptosub_at(ccstack, cxix - 1);
1608 cx = &ccstack[cxix];
1609 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1610 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1611 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1612 field below is defined for any cx. */
1613 /* caller() should not report the automatic calls to &DB::sub */
1614 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1615 cx = &ccstack[dbcxix];
1618 stashname = CopSTASHPV(cx->blk_oldcop);
1619 if (GIMME != G_ARRAY) {
1622 PUSHs(&PL_sv_undef);
1625 sv_setpv(TARG, stashname);
1634 PUSHs(&PL_sv_undef);
1636 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1637 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1638 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1641 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1642 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1643 /* So is ccstack[dbcxix]. */
1645 SV * const sv = newSV(0);
1646 gv_efullname3(sv, cvgv, NULL);
1647 PUSHs(sv_2mortal(sv));
1648 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1651 PUSHs(sv_2mortal(newSVpvs("(unknown)")));
1652 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1656 PUSHs(sv_2mortal(newSVpvs("(eval)")));
1657 PUSHs(sv_2mortal(newSViv(0)));
1659 gimme = (I32)cx->blk_gimme;
1660 if (gimme == G_VOID)
1661 PUSHs(&PL_sv_undef);
1663 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1664 if (CxTYPE(cx) == CXt_EVAL) {
1666 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1667 PUSHs(cx->blk_eval.cur_text);
1671 else if (cx->blk_eval.old_namesv) {
1672 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1675 /* eval BLOCK (try blocks have old_namesv == 0) */
1677 PUSHs(&PL_sv_undef);
1678 PUSHs(&PL_sv_undef);
1682 PUSHs(&PL_sv_undef);
1683 PUSHs(&PL_sv_undef);
1685 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1686 && CopSTASH_eq(PL_curcop, PL_debstash))
1688 AV * const ary = cx->blk_sub.argarray;
1689 const int off = AvARRAY(ary) - AvALLOC(ary);
1692 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1693 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1695 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1698 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1699 av_extend(PL_dbargs, AvFILLp(ary) + off);
1700 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1701 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1703 /* XXX only hints propagated via op_private are currently
1704 * visible (others are not easily accessible, since they
1705 * use the global PL_hints) */
1706 PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
1709 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1711 if (old_warnings == pWARN_NONE ||
1712 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1713 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1714 else if (old_warnings == pWARN_ALL ||
1715 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1716 /* Get the bit mask for $warnings::Bits{all}, because
1717 * it could have been extended by warnings::register */
1719 HV * const bits = get_hv("warnings::Bits", FALSE);
1720 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1721 mask = newSVsv(*bits_all);
1724 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1728 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1729 PUSHs(sv_2mortal(mask));
1732 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1733 sv_2mortal(newRV_noinc(
1734 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1735 cx->blk_oldcop->cop_hints_hash)))
1744 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1745 sv_reset(tmps, CopSTASH(PL_curcop));
1750 /* like pp_nextstate, but used instead when the debugger is active */
1755 PL_curcop = (COP*)PL_op;
1756 TAINT_NOT; /* Each statement is presumed innocent */
1757 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1760 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1761 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1764 register PERL_CONTEXT *cx;
1765 const I32 gimme = G_ARRAY;
1767 GV * const gv = PL_DBgv;
1768 register CV * const cv = GvCV(gv);
1771 DIE(aTHX_ "No DB::DB routine defined");
1773 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1774 /* don't do recursive DB::DB call */
1789 (void)(*CvXSUB(cv))(aTHX_ cv);
1796 PUSHBLOCK(cx, CXt_SUB, SP);
1798 cx->blk_sub.retop = PL_op->op_next;
1801 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1802 RETURNOP(CvSTART(cv));
1812 register PERL_CONTEXT *cx;
1813 const I32 gimme = GIMME_V;
1815 U16 cxtype = CXt_LOOP | CXp_FOREACH;
1823 if (PL_op->op_targ) {
1824 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1825 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1826 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1827 SVs_PADSTALE, SVs_PADSTALE);
1829 #ifndef USE_ITHREADS
1830 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1833 SAVEPADSV(PL_op->op_targ);
1834 iterdata = INT2PTR(void*, PL_op->op_targ);
1835 cxtype |= CXp_PADVAR;
1839 GV * const gv = (GV*)POPs;
1840 svp = &GvSV(gv); /* symbol table variable */
1841 SAVEGENERICSV(*svp);
1844 iterdata = (void*)gv;
1848 if (PL_op->op_private & OPpITER_DEF)
1849 cxtype |= CXp_FOR_DEF;
1853 PUSHBLOCK(cx, cxtype, SP);
1855 PUSHLOOP(cx, iterdata, MARK);
1857 PUSHLOOP(cx, svp, MARK);
1859 if (PL_op->op_flags & OPf_STACKED) {
1860 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1861 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1863 SV * const right = (SV*)cx->blk_loop.iterary;
1866 if (RANGE_IS_NUMERIC(sv,right)) {
1867 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1868 (SvOK(right) && SvNV(right) >= IV_MAX))
1869 DIE(aTHX_ "Range iterator outside integer range");
1870 cx->blk_loop.iterix = SvIV(sv);
1871 cx->blk_loop.itermax = SvIV(right);
1873 /* for correct -Dstv display */
1874 cx->blk_oldsp = sp - PL_stack_base;
1878 cx->blk_loop.iterlval = newSVsv(sv);
1879 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1880 (void) SvPV_nolen_const(right);
1883 else if (PL_op->op_private & OPpITER_REVERSED) {
1884 cx->blk_loop.itermax = 0;
1885 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1890 cx->blk_loop.iterary = PL_curstack;
1891 AvFILLp(PL_curstack) = SP - PL_stack_base;
1892 if (PL_op->op_private & OPpITER_REVERSED) {
1893 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1894 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1897 cx->blk_loop.iterix = MARK - PL_stack_base;
1907 register PERL_CONTEXT *cx;
1908 const I32 gimme = GIMME_V;
1914 PUSHBLOCK(cx, CXt_LOOP, SP);
1915 PUSHLOOP(cx, 0, SP);
1923 register PERL_CONTEXT *cx;
1930 assert(CxTYPE(cx) == CXt_LOOP);
1932 newsp = PL_stack_base + cx->blk_loop.resetsp;
1935 if (gimme == G_VOID)
1937 else if (gimme == G_SCALAR) {
1939 *++newsp = sv_mortalcopy(*SP);
1941 *++newsp = &PL_sv_undef;
1945 *++newsp = sv_mortalcopy(*++mark);
1946 TAINT_NOT; /* Each item is independent */
1952 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1953 PL_curpm = newpm; /* ... and pop $1 et al */
1964 register PERL_CONTEXT *cx;
1965 bool popsub2 = FALSE;
1966 bool clear_errsv = FALSE;
1974 const I32 cxix = dopoptosub(cxstack_ix);
1977 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1978 * sort block, which is a CXt_NULL
1981 PL_stack_base[1] = *PL_stack_sp;
1982 PL_stack_sp = PL_stack_base + 1;
1986 DIE(aTHX_ "Can't return outside a subroutine");
1988 if (cxix < cxstack_ix)
1991 if (CxMULTICALL(&cxstack[cxix])) {
1992 gimme = cxstack[cxix].blk_gimme;
1993 if (gimme == G_VOID)
1994 PL_stack_sp = PL_stack_base;
1995 else if (gimme == G_SCALAR) {
1996 PL_stack_base[1] = *PL_stack_sp;
1997 PL_stack_sp = PL_stack_base + 1;
2003 switch (CxTYPE(cx)) {
2006 retop = cx->blk_sub.retop;
2007 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2010 if (!(PL_in_eval & EVAL_KEEPERR))
2013 retop = cx->blk_eval.retop;
2017 if (optype == OP_REQUIRE &&
2018 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2020 /* Unassume the success we assumed earlier. */
2021 SV * const nsv = cx->blk_eval.old_namesv;
2022 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2023 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2028 retop = cx->blk_sub.retop;
2031 DIE(aTHX_ "panic: return");
2035 if (gimme == G_SCALAR) {
2038 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2040 *++newsp = SvREFCNT_inc(*SP);
2045 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2047 *++newsp = sv_mortalcopy(sv);
2052 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2055 *++newsp = sv_mortalcopy(*SP);
2058 *++newsp = &PL_sv_undef;
2060 else if (gimme == G_ARRAY) {
2061 while (++MARK <= SP) {
2062 *++newsp = (popsub2 && SvTEMP(*MARK))
2063 ? *MARK : sv_mortalcopy(*MARK);
2064 TAINT_NOT; /* Each item is independent */
2067 PL_stack_sp = newsp;
2070 /* Stack values are safe: */
2073 POPSUB(cx,sv); /* release CV and @_ ... */
2077 PL_curpm = newpm; /* ... and pop $1 et al */
2081 sv_setpvn(ERRSV,"",0);
2089 register PERL_CONTEXT *cx;
2100 if (PL_op->op_flags & OPf_SPECIAL) {
2101 cxix = dopoptoloop(cxstack_ix);
2103 DIE(aTHX_ "Can't \"last\" outside a loop block");
2106 cxix = dopoptolabel(cPVOP->op_pv);
2108 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2110 if (cxix < cxstack_ix)
2114 cxstack_ix++; /* temporarily protect top context */
2116 switch (CxTYPE(cx)) {
2119 newsp = PL_stack_base + cx->blk_loop.resetsp;
2120 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2124 nextop = cx->blk_sub.retop;
2128 nextop = cx->blk_eval.retop;
2132 nextop = cx->blk_sub.retop;
2135 DIE(aTHX_ "panic: last");
2139 if (gimme == G_SCALAR) {
2141 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2142 ? *SP : sv_mortalcopy(*SP);
2144 *++newsp = &PL_sv_undef;
2146 else if (gimme == G_ARRAY) {
2147 while (++MARK <= SP) {
2148 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2149 ? *MARK : sv_mortalcopy(*MARK);
2150 TAINT_NOT; /* Each item is independent */
2158 /* Stack values are safe: */
2161 POPLOOP(cx); /* release loop vars ... */
2165 POPSUB(cx,sv); /* release CV and @_ ... */
2168 PL_curpm = newpm; /* ... and pop $1 et al */
2171 PERL_UNUSED_VAR(optype);
2172 PERL_UNUSED_VAR(gimme);
2180 register PERL_CONTEXT *cx;
2183 if (PL_op->op_flags & OPf_SPECIAL) {
2184 cxix = dopoptoloop(cxstack_ix);
2186 DIE(aTHX_ "Can't \"next\" outside a loop block");
2189 cxix = dopoptolabel(cPVOP->op_pv);
2191 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2193 if (cxix < cxstack_ix)
2196 /* clear off anything above the scope we're re-entering, but
2197 * save the rest until after a possible continue block */
2198 inner = PL_scopestack_ix;
2200 if (PL_scopestack_ix < inner)
2201 leave_scope(PL_scopestack[PL_scopestack_ix]);
2202 PL_curcop = cx->blk_oldcop;
2203 return CX_LOOP_NEXTOP_GET(cx);
2210 register PERL_CONTEXT *cx;
2214 if (PL_op->op_flags & OPf_SPECIAL) {
2215 cxix = dopoptoloop(cxstack_ix);
2217 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2220 cxix = dopoptolabel(cPVOP->op_pv);
2222 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2224 if (cxix < cxstack_ix)
2227 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2228 if (redo_op->op_type == OP_ENTER) {
2229 /* pop one less context to avoid $x being freed in while (my $x..) */
2231 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2232 redo_op = redo_op->op_next;
2236 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2237 LEAVE_SCOPE(oldsave);
2239 PL_curcop = cx->blk_oldcop;
2244 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2248 static const char too_deep[] = "Target of goto is too deeply nested";
2251 Perl_croak(aTHX_ too_deep);
2252 if (o->op_type == OP_LEAVE ||
2253 o->op_type == OP_SCOPE ||
2254 o->op_type == OP_LEAVELOOP ||
2255 o->op_type == OP_LEAVESUB ||
2256 o->op_type == OP_LEAVETRY)
2258 *ops++ = cUNOPo->op_first;
2260 Perl_croak(aTHX_ too_deep);
2263 if (o->op_flags & OPf_KIDS) {
2265 /* First try all the kids at this level, since that's likeliest. */
2266 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2267 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2268 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2271 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2272 if (kid == PL_lastgotoprobe)
2274 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2277 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2278 ops[-1]->op_type == OP_DBSTATE)
2283 if ((o = dofindlabel(kid, label, ops, oplimit)))
2296 register PERL_CONTEXT *cx;
2297 #define GOTO_DEPTH 64
2298 OP *enterops[GOTO_DEPTH];
2299 const char *label = NULL;
2300 const bool do_dump = (PL_op->op_type == OP_DUMP);
2301 static const char must_have_label[] = "goto must have label";
2303 if (PL_op->op_flags & OPf_STACKED) {
2304 SV * const sv = POPs;
2306 /* This egregious kludge implements goto &subroutine */
2307 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2309 register PERL_CONTEXT *cx;
2310 CV* cv = (CV*)SvRV(sv);
2317 if (!CvROOT(cv) && !CvXSUB(cv)) {
2318 const GV * const gv = CvGV(cv);
2322 /* autoloaded stub? */
2323 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2325 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2326 GvNAMELEN(gv), FALSE);
2327 if (autogv && (cv = GvCV(autogv)))
2329 tmpstr = sv_newmortal();
2330 gv_efullname3(tmpstr, gv, NULL);
2331 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2333 DIE(aTHX_ "Goto undefined subroutine");
2336 /* First do some returnish stuff. */
2337 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2339 cxix = dopoptosub(cxstack_ix);
2341 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2342 if (cxix < cxstack_ix)
2346 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2347 if (CxTYPE(cx) == CXt_EVAL) {
2349 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2351 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2353 else if (CxMULTICALL(cx))
2354 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2355 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2356 /* put @_ back onto stack */
2357 AV* av = cx->blk_sub.argarray;
2359 items = AvFILLp(av) + 1;
2360 EXTEND(SP, items+1); /* @_ could have been extended. */
2361 Copy(AvARRAY(av), SP + 1, items, SV*);
2362 SvREFCNT_dec(GvAV(PL_defgv));
2363 GvAV(PL_defgv) = cx->blk_sub.savearray;
2365 /* abandon @_ if it got reified */
2370 av_extend(av, items-1);
2372 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2375 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2376 AV* const av = GvAV(PL_defgv);
2377 items = AvFILLp(av) + 1;
2378 EXTEND(SP, items+1); /* @_ could have been extended. */
2379 Copy(AvARRAY(av), SP + 1, items, SV*);
2383 if (CxTYPE(cx) == CXt_SUB &&
2384 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2385 SvREFCNT_dec(cx->blk_sub.cv);
2386 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2387 LEAVE_SCOPE(oldsave);
2389 /* Now do some callish stuff. */
2391 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2393 OP* const retop = cx->blk_sub.retop;
2398 for (index=0; index<items; index++)
2399 sv_2mortal(SP[-index]);
2402 /* XS subs don't have a CxSUB, so pop it */
2403 POPBLOCK(cx, PL_curpm);
2404 /* Push a mark for the start of arglist */
2407 (void)(*CvXSUB(cv))(aTHX_ cv);
2412 AV* const padlist = CvPADLIST(cv);
2413 if (CxTYPE(cx) == CXt_EVAL) {
2414 PL_in_eval = cx->blk_eval.old_in_eval;
2415 PL_eval_root = cx->blk_eval.old_eval_root;
2416 cx->cx_type = CXt_SUB;
2417 cx->blk_sub.hasargs = 0;
2419 cx->blk_sub.cv = cv;
2420 cx->blk_sub.olddepth = CvDEPTH(cv);
2423 if (CvDEPTH(cv) < 2)
2424 SvREFCNT_inc_simple_void_NN(cv);
2426 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2427 sub_crush_depth(cv);
2428 pad_push(padlist, CvDEPTH(cv));
2431 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2432 if (cx->blk_sub.hasargs)
2434 AV* const av = (AV*)PAD_SVl(0);
2436 cx->blk_sub.savearray = GvAV(PL_defgv);
2437 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2438 CX_CURPAD_SAVE(cx->blk_sub);
2439 cx->blk_sub.argarray = av;
2441 if (items >= AvMAX(av) + 1) {
2442 SV **ary = AvALLOC(av);
2443 if (AvARRAY(av) != ary) {
2444 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2447 if (items >= AvMAX(av) + 1) {
2448 AvMAX(av) = items - 1;
2449 Renew(ary,items+1,SV*);
2455 Copy(mark,AvARRAY(av),items,SV*);
2456 AvFILLp(av) = items - 1;
2457 assert(!AvREAL(av));
2459 /* transfer 'ownership' of refcnts to new @_ */
2469 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2470 Perl_get_db_sub(aTHX_ NULL, cv);
2472 CV * const gotocv = get_cv("DB::goto", FALSE);
2474 PUSHMARK( PL_stack_sp );
2475 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2480 RETURNOP(CvSTART(cv));
2484 label = SvPV_nolen_const(sv);
2485 if (!(do_dump || *label))
2486 DIE(aTHX_ must_have_label);
2489 else if (PL_op->op_flags & OPf_SPECIAL) {
2491 DIE(aTHX_ must_have_label);
2494 label = cPVOP->op_pv;
2496 if (label && *label) {
2497 OP *gotoprobe = NULL;
2498 bool leaving_eval = FALSE;
2499 bool in_block = FALSE;
2500 PERL_CONTEXT *last_eval_cx = NULL;
2504 PL_lastgotoprobe = NULL;
2506 for (ix = cxstack_ix; ix >= 0; ix--) {
2508 switch (CxTYPE(cx)) {
2510 leaving_eval = TRUE;
2511 if (!CxTRYBLOCK(cx)) {
2512 gotoprobe = (last_eval_cx ?
2513 last_eval_cx->blk_eval.old_eval_root :
2518 /* else fall through */
2520 gotoprobe = cx->blk_oldcop->op_sibling;
2526 gotoprobe = cx->blk_oldcop->op_sibling;
2529 gotoprobe = PL_main_root;
2532 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2533 gotoprobe = CvROOT(cx->blk_sub.cv);
2539 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2542 DIE(aTHX_ "panic: goto");
2543 gotoprobe = PL_main_root;
2547 retop = dofindlabel(gotoprobe, label,
2548 enterops, enterops + GOTO_DEPTH);
2552 PL_lastgotoprobe = gotoprobe;
2555 DIE(aTHX_ "Can't find label %s", label);
2557 /* if we're leaving an eval, check before we pop any frames
2558 that we're not going to punt, otherwise the error
2561 if (leaving_eval && *enterops && enterops[1]) {
2563 for (i = 1; enterops[i]; i++)
2564 if (enterops[i]->op_type == OP_ENTERITER)
2565 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2568 /* pop unwanted frames */
2570 if (ix < cxstack_ix) {
2577 oldsave = PL_scopestack[PL_scopestack_ix];
2578 LEAVE_SCOPE(oldsave);
2581 /* push wanted frames */
2583 if (*enterops && enterops[1]) {
2584 OP * const oldop = PL_op;
2585 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2586 for (; enterops[ix]; ix++) {
2587 PL_op = enterops[ix];
2588 /* Eventually we may want to stack the needed arguments
2589 * for each op. For now, we punt on the hard ones. */
2590 if (PL_op->op_type == OP_ENTERITER)
2591 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2592 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2600 if (!retop) retop = PL_main_start;
2602 PL_restartop = retop;
2603 PL_do_undump = TRUE;
2607 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2608 PL_do_undump = FALSE;
2625 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2627 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2630 PL_exit_flags |= PERL_EXIT_EXPECTED;
2632 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2633 if (anum || !(PL_minus_c && PL_madskills))
2638 PUSHs(&PL_sv_undef);
2645 S_save_lines(pTHX_ AV *array, SV *sv)
2647 const char *s = SvPVX_const(sv);
2648 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2651 while (s && s < send) {
2653 SV * const tmpstr = newSV_type(SVt_PVMG);
2655 t = strchr(s, '\n');
2661 sv_setpvn(tmpstr, s, t - s);
2662 av_store(array, line++, tmpstr);
2668 S_docatch_body(pTHX)
2676 S_docatch(pTHX_ OP *o)
2680 OP * const oldop = PL_op;
2684 assert(CATCH_GET == TRUE);
2691 assert(cxstack_ix >= 0);
2692 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2693 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2698 /* die caught by an inner eval - continue inner loop */
2700 /* NB XXX we rely on the old popped CxEVAL still being at the top
2701 * of the stack; the way die_where() currently works, this
2702 * assumption is valid. In theory The cur_top_env value should be
2703 * returned in another global, the way retop (aka PL_restartop)
2705 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2708 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2710 PL_op = PL_restartop;
2727 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2728 /* sv Text to convert to OP tree. */
2729 /* startop op_free() this to undo. */
2730 /* code Short string id of the caller. */
2732 /* FIXME - how much of this code is common with pp_entereval? */
2733 dVAR; dSP; /* Make POPBLOCK work. */
2740 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2741 char *tmpbuf = tbuf;
2744 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2748 lex_start(sv, NULL, FALSE);
2750 /* switch to eval mode */
2752 if (IN_PERL_COMPILETIME) {
2753 SAVECOPSTASH_FREE(&PL_compiling);
2754 CopSTASH_set(&PL_compiling, PL_curstash);
2756 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2757 SV * const sv = sv_newmortal();
2758 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2759 code, (unsigned long)++PL_evalseq,
2760 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2765 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2766 (unsigned long)++PL_evalseq);
2767 SAVECOPFILE_FREE(&PL_compiling);
2768 CopFILE_set(&PL_compiling, tmpbuf+2);
2769 SAVECOPLINE(&PL_compiling);
2770 CopLINE_set(&PL_compiling, 1);
2771 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2772 deleting the eval's FILEGV from the stash before gv_check() runs
2773 (i.e. before run-time proper). To work around the coredump that
2774 ensues, we always turn GvMULTI_on for any globals that were
2775 introduced within evals. See force_ident(). GSAR 96-10-12 */
2776 safestr = savepvn(tmpbuf, len);
2777 SAVEDELETE(PL_defstash, safestr, len);
2779 #ifdef OP_IN_REGISTER
2785 /* we get here either during compilation, or via pp_regcomp at runtime */
2786 runtime = IN_PERL_RUNTIME;
2788 runcv = find_runcv(NULL);
2791 PL_op->op_type = OP_ENTEREVAL;
2792 PL_op->op_flags = 0; /* Avoid uninit warning. */
2793 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2794 PUSHEVAL(cx, 0, NULL);
2797 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2799 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2800 POPBLOCK(cx,PL_curpm);
2803 (*startop)->op_type = OP_NULL;
2804 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2806 /* XXX DAPM do this properly one year */
2807 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2809 if (IN_PERL_COMPILETIME)
2810 CopHINTS_set(&PL_compiling, PL_hints);
2811 #ifdef OP_IN_REGISTER
2814 PERL_UNUSED_VAR(newsp);
2815 PERL_UNUSED_VAR(optype);
2822 =for apidoc find_runcv
2824 Locate the CV corresponding to the currently executing sub or eval.
2825 If db_seqp is non_null, skip CVs that are in the DB package and populate
2826 *db_seqp with the cop sequence number at the point that the DB:: code was
2827 entered. (allows debuggers to eval in the scope of the breakpoint rather
2828 than in the scope of the debugger itself).
2834 Perl_find_runcv(pTHX_ U32 *db_seqp)
2840 *db_seqp = PL_curcop->cop_seq;
2841 for (si = PL_curstackinfo; si; si = si->si_prev) {
2843 for (ix = si->si_cxix; ix >= 0; ix--) {
2844 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2845 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2846 CV * const cv = cx->blk_sub.cv;
2847 /* skip DB:: code */
2848 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2849 *db_seqp = cx->blk_oldcop->cop_seq;
2854 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2862 /* Compile a require/do, an eval '', or a /(?{...})/.
2863 * In the last case, startop is non-null, and contains the address of
2864 * a pointer that should be set to the just-compiled code.
2865 * outside is the lexically enclosing CV (if any) that invoked us.
2869 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2872 OP * const saveop = PL_op;
2874 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2875 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2880 SAVESPTR(PL_compcv);
2881 PL_compcv = (CV*)newSV_type(SVt_PVCV);
2882 CvEVAL_on(PL_compcv);
2883 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2884 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2886 CvOUTSIDE_SEQ(PL_compcv) = seq;
2887 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2889 /* set up a scratch pad */
2891 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2892 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2896 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2898 /* make sure we compile in the right package */
2900 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2901 SAVESPTR(PL_curstash);
2902 PL_curstash = CopSTASH(PL_curcop);
2904 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2905 SAVESPTR(PL_beginav);
2906 PL_beginav = newAV();
2907 SAVEFREESV(PL_beginav);
2908 SAVESPTR(PL_unitcheckav);
2909 PL_unitcheckav = newAV();
2910 SAVEFREESV(PL_unitcheckav);
2911 SAVEI8(PL_error_count);
2914 SAVEBOOL(PL_madskills);
2918 /* try to compile it */
2920 PL_eval_root = NULL;
2922 PL_curcop = &PL_compiling;
2923 CopARYBASE_set(PL_curcop, 0);
2924 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2925 PL_in_eval |= EVAL_KEEPERR;
2927 sv_setpvn(ERRSV,"",0);
2928 if (yyparse() || PL_error_count || !PL_eval_root) {
2929 SV **newsp; /* Used by POPBLOCK. */
2930 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2931 I32 optype = 0; /* Might be reset by POPEVAL. */
2936 op_free(PL_eval_root);
2937 PL_eval_root = NULL;
2939 SP = PL_stack_base + POPMARK; /* pop original mark */
2941 POPBLOCK(cx,PL_curpm);
2947 msg = SvPVx_nolen_const(ERRSV);
2948 if (optype == OP_REQUIRE) {
2949 const SV * const nsv = cx->blk_eval.old_namesv;
2950 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2952 DIE(aTHX_ "%sCompilation failed in require",
2953 *msg ? msg : "Unknown error\n");
2956 POPBLOCK(cx,PL_curpm);
2958 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2959 (*msg ? msg : "Unknown error\n"));
2963 sv_setpvs(ERRSV, "Compilation error");
2966 PERL_UNUSED_VAR(newsp);
2969 CopLINE_set(&PL_compiling, 0);
2971 *startop = PL_eval_root;
2973 SAVEFREEOP(PL_eval_root);
2975 /* Set the context for this new optree.
2976 * If the last op is an OP_REQUIRE, force scalar context.
2977 * Otherwise, propagate the context from the eval(). */
2978 if (PL_eval_root->op_type == OP_LEAVEEVAL
2979 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2980 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2982 scalar(PL_eval_root);
2983 else if (gimme & G_VOID)
2984 scalarvoid(PL_eval_root);
2985 else if (gimme & G_ARRAY)
2988 scalar(PL_eval_root);
2990 DEBUG_x(dump_eval());
2992 /* Register with debugger: */
2993 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
2994 CV * const cv = get_cv("DB::postponed", FALSE);
2998 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3000 call_sv((SV*)cv, G_DISCARD);
3005 call_list(PL_scopestack_ix, PL_unitcheckav);
3007 /* compiled okay, so do it */
3009 CvDEPTH(PL_compcv) = 1;
3010 SP = PL_stack_base + POPMARK; /* pop original mark */
3011 PL_op = saveop; /* The caller may need it. */
3012 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3014 RETURNOP(PL_eval_start);
3018 S_check_type_and_open(pTHX_ const char *name, const char *mode)
3021 const int st_rc = PerlLIO_stat(name, &st);
3023 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3027 return PerlIO_open(name, mode);
3031 S_doopen_pm(pTHX_ const char *name, const char *mode)
3033 #ifndef PERL_DISABLE_PMC
3034 const STRLEN namelen = strlen(name);
3037 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3038 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3039 const char * const pmc = SvPV_nolen_const(pmcsv);
3041 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3042 fp = check_type_and_open(name, mode);
3045 fp = check_type_and_open(pmc, mode);
3047 SvREFCNT_dec(pmcsv);
3050 fp = check_type_and_open(name, mode);
3054 return check_type_and_open(name, mode);
3055 #endif /* !PERL_DISABLE_PMC */
3061 register PERL_CONTEXT *cx;
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 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3081 "v-string in use/require non-portable");
3083 sv = new_version(sv);
3084 if (!sv_derived_from(PL_patchlevel, "version"))
3085 upg_version(PL_patchlevel, TRUE);
3086 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3087 if ( vcmp(sv,PL_patchlevel) <= 0 )
3088 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3089 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3092 if ( vcmp(sv,PL_patchlevel) > 0 )
3093 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3094 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3097 /* If we request a version >= 5.9.5, load feature.pm with the
3098 * feature bundle that corresponds to the required version.
3099 * We do this only with use, not require. */
3100 if (PL_compcv && vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3101 SV *const importsv = vnormal(sv);
3102 *SvPVX_mutable(importsv) = ':';
3104 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3110 name = SvPV_const(sv, len);
3111 if (!(name && len > 0 && *name))
3112 DIE(aTHX_ "Null filename used");
3113 TAINT_PROPER("require");
3114 if (PL_op->op_type == OP_REQUIRE) {
3115 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3117 if (*svp != &PL_sv_undef)
3120 DIE(aTHX_ "Compilation failed in require");
3124 /* prepare to compile file */
3126 if (path_is_absolute(name)) {
3128 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3130 #ifdef MACOS_TRADITIONAL
3134 MacPerl_CanonDir(name, newname, 1);
3135 if (path_is_absolute(newname)) {
3137 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3142 AV * const ar = GvAVn(PL_incgv);
3146 if ((unixname = tounixspec(name, NULL)) != NULL)
3150 for (i = 0; i <= AvFILL(ar); i++) {
3151 SV * const dirsv = *av_fetch(ar, i, TRUE);
3153 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3160 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3161 && !sv_isobject(loader))
3163 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3166 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3167 PTR2UV(SvRV(dirsv)), name);
3168 tryname = SvPVX_const(namesv);
3179 if (sv_isobject(loader))
3180 count = call_method("INC", G_ARRAY);
3182 count = call_sv(loader, G_ARRAY);
3185 /* Adjust file name if the hook has set an %INC entry */
3186 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3188 tryname = SvPVX_const(*svp);
3197 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3198 && !isGV_with_GP(SvRV(arg))) {
3199 filter_cache = SvRV(arg);
3200 SvREFCNT_inc_simple_void_NN(filter_cache);
3207 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3211 if (SvTYPE(arg) == SVt_PVGV) {
3212 IO * const io = GvIO((GV *)arg);
3217 tryrsfp = IoIFP(io);
3218 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3219 PerlIO_close(IoOFP(io));
3230 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3232 SvREFCNT_inc_simple_void_NN(filter_sub);
3235 filter_state = SP[i];
3236 SvREFCNT_inc_simple_void(filter_state);
3240 if (!tryrsfp && (filter_cache || filter_sub)) {
3241 tryrsfp = PerlIO_open(BIT_BUCKET,
3256 filter_has_file = 0;
3258 SvREFCNT_dec(filter_cache);
3259 filter_cache = NULL;
3262 SvREFCNT_dec(filter_state);
3263 filter_state = NULL;
3266 SvREFCNT_dec(filter_sub);
3271 if (!path_is_absolute(name)
3272 #ifdef MACOS_TRADITIONAL
3273 /* We consider paths of the form :a:b ambiguous and interpret them first
3274 as global then as local
3276 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3279 const char *dir = SvPV_nolen_const(dirsv);
3280 #ifdef MACOS_TRADITIONAL
3284 MacPerl_CanonDir(name, buf2, 1);
3285 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3289 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3291 sv_setpv(namesv, unixdir);
3292 sv_catpv(namesv, unixname);
3294 # ifdef __SYMBIAN32__
3295 if (PL_origfilename[0] &&
3296 PL_origfilename[1] == ':' &&
3297 !(dir[0] && dir[1] == ':'))
3298 Perl_sv_setpvf(aTHX_ namesv,
3303 Perl_sv_setpvf(aTHX_ namesv,
3307 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3311 TAINT_PROPER("require");
3312 tryname = SvPVX_const(namesv);
3313 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3315 if (tryname[0] == '.' && tryname[1] == '/')
3319 else if (errno == EMFILE)
3320 /* no point in trying other paths if out of handles */
3327 SAVECOPFILE_FREE(&PL_compiling);
3328 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3329 SvREFCNT_dec(namesv);
3331 if (PL_op->op_type == OP_REQUIRE) {
3332 const char *msgstr = name;
3333 if(errno == EMFILE) {
3335 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3337 msgstr = SvPV_nolen_const(msg);
3339 if (namesv) { /* did we lookup @INC? */
3340 AV * const ar = GvAVn(PL_incgv);
3342 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3343 "%s in @INC%s%s (@INC contains:",
3345 (instr(msgstr, ".h ")
3346 ? " (change .h to .ph maybe?)" : ""),
3347 (instr(msgstr, ".ph ")
3348 ? " (did you run h2ph?)" : "")
3351 for (i = 0; i <= AvFILL(ar); i++) {
3352 sv_catpvs(msg, " ");
3353 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3355 sv_catpvs(msg, ")");
3356 msgstr = SvPV_nolen_const(msg);
3359 DIE(aTHX_ "Can't locate %s", msgstr);
3365 SETERRNO(0, SS_NORMAL);
3367 /* Assume success here to prevent recursive requirement. */
3368 /* name is never assigned to again, so len is still strlen(name) */
3369 /* Check whether a hook in @INC has already filled %INC */
3371 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3373 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3375 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc_simple(hook_sv), 0 );
3380 lex_start(NULL, tryrsfp, TRUE);
3384 SAVECOMPILEWARNINGS();
3385 if (PL_dowarn & G_WARN_ALL_ON)
3386 PL_compiling.cop_warnings = pWARN_ALL ;
3387 else if (PL_dowarn & G_WARN_ALL_OFF)
3388 PL_compiling.cop_warnings = pWARN_NONE ;
3390 PL_compiling.cop_warnings = pWARN_STD ;
3392 if (filter_sub || filter_cache) {
3393 SV * const datasv = filter_add(S_run_user_filter, NULL);
3394 IoLINES(datasv) = filter_has_file;
3395 IoTOP_GV(datasv) = (GV *)filter_state;
3396 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3397 IoFMT_GV(datasv) = (GV *)filter_cache;
3400 /* switch to eval mode */
3401 PUSHBLOCK(cx, CXt_EVAL, SP);
3402 PUSHEVAL(cx, name, NULL);
3403 cx->blk_eval.retop = PL_op->op_next;
3405 SAVECOPLINE(&PL_compiling);
3406 CopLINE_set(&PL_compiling, 0);
3410 /* Store and reset encoding. */
3411 encoding = PL_encoding;
3414 op = DOCATCH(doeval(gimme, NULL, NULL, PL_curcop->cop_seq));
3416 /* Restore encoding. */
3417 PL_encoding = encoding;
3425 register PERL_CONTEXT *cx;
3427 const I32 gimme = GIMME_V;
3428 const I32 was = PL_sub_generation;
3429 char tbuf[TYPE_DIGITS(long) + 12];
3430 char *tmpbuf = tbuf;
3436 HV *saved_hh = NULL;
3437 const char * const fakestr = "_<(eval )";
3438 const int fakelen = 9 + 1;
3440 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3441 saved_hh = (HV*) SvREFCNT_inc(POPs);
3445 TAINT_IF(SvTAINTED(sv));
3446 TAINT_PROPER("eval");
3449 lex_start(sv, NULL, FALSE);
3452 /* switch to eval mode */
3454 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3455 SV * const temp_sv = sv_newmortal();
3456 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3457 (unsigned long)++PL_evalseq,
3458 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3459 tmpbuf = SvPVX(temp_sv);
3460 len = SvCUR(temp_sv);
3463 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3464 SAVECOPFILE_FREE(&PL_compiling);
3465 CopFILE_set(&PL_compiling, tmpbuf+2);
3466 SAVECOPLINE(&PL_compiling);
3467 CopLINE_set(&PL_compiling, 1);
3468 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3469 deleting the eval's FILEGV from the stash before gv_check() runs
3470 (i.e. before run-time proper). To work around the coredump that
3471 ensues, we always turn GvMULTI_on for any globals that were
3472 introduced within evals. See force_ident(). GSAR 96-10-12 */
3473 safestr = savepvn(tmpbuf, len);
3474 SAVEDELETE(PL_defstash, safestr, len);
3476 PL_hints = PL_op->op_targ;
3478 GvHV(PL_hintgv) = saved_hh;
3479 SAVECOMPILEWARNINGS();
3480 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3481 if (PL_compiling.cop_hints_hash) {
3482 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3484 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3485 if (PL_compiling.cop_hints_hash) {
3487 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3488 HINTS_REFCNT_UNLOCK;
3490 /* special case: an eval '' executed within the DB package gets lexically
3491 * placed in the first non-DB CV rather than the current CV - this
3492 * allows the debugger to execute code, find lexicals etc, in the
3493 * scope of the code being debugged. Passing &seq gets find_runcv
3494 * to do the dirty work for us */
3495 runcv = find_runcv(&seq);
3497 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3498 PUSHEVAL(cx, 0, NULL);
3499 cx->blk_eval.retop = PL_op->op_next;
3501 /* prepare to compile string */
3503 if (PERLDB_LINE && PL_curstash != PL_debstash)
3504 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3506 ret = doeval(gimme, NULL, runcv, seq);
3507 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3508 && ret != PL_op->op_next) { /* Successive compilation. */
3509 /* Copy in anything fake and short. */
3510 my_strlcpy(safestr, fakestr, fakelen);
3512 return DOCATCH(ret);
3522 register PERL_CONTEXT *cx;
3524 const U8 save_flags = PL_op -> op_flags;
3529 retop = cx->blk_eval.retop;
3532 if (gimme == G_VOID)
3534 else if (gimme == G_SCALAR) {
3537 if (SvFLAGS(TOPs) & SVs_TEMP)
3540 *MARK = sv_mortalcopy(TOPs);
3544 *MARK = &PL_sv_undef;
3549 /* in case LEAVE wipes old return values */
3550 for (mark = newsp + 1; mark <= SP; mark++) {
3551 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3552 *mark = sv_mortalcopy(*mark);
3553 TAINT_NOT; /* Each item is independent */
3557 PL_curpm = newpm; /* Don't pop $1 et al till now */
3560 assert(CvDEPTH(PL_compcv) == 1);
3562 CvDEPTH(PL_compcv) = 0;
3565 if (optype == OP_REQUIRE &&
3566 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3568 /* Unassume the success we assumed earlier. */
3569 SV * const nsv = cx->blk_eval.old_namesv;
3570 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3571 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3572 /* die_where() did LEAVE, or we won't be here */
3576 if (!(save_flags & OPf_SPECIAL))
3577 sv_setpvn(ERRSV,"",0);
3583 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3584 close to the related Perl_create_eval_scope. */
3586 Perl_delete_eval_scope(pTHX)
3591 register PERL_CONTEXT *cx;
3598 PERL_UNUSED_VAR(newsp);
3599 PERL_UNUSED_VAR(gimme);
3600 PERL_UNUSED_VAR(optype);
3603 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3604 also needed by Perl_fold_constants. */
3606 Perl_create_eval_scope(pTHX_ U32 flags)
3609 const I32 gimme = GIMME_V;
3614 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3617 PL_in_eval = EVAL_INEVAL;
3618 if (flags & G_KEEPERR)
3619 PL_in_eval |= EVAL_KEEPERR;
3621 sv_setpvn(ERRSV,"",0);
3622 if (flags & G_FAKINGEVAL) {
3623 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3631 PERL_CONTEXT * const cx = create_eval_scope(0);
3632 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3633 return DOCATCH(PL_op->op_next);
3642 register PERL_CONTEXT *cx;
3647 PERL_UNUSED_VAR(optype);
3650 if (gimme == G_VOID)
3652 else if (gimme == G_SCALAR) {
3656 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3659 *MARK = sv_mortalcopy(TOPs);
3663 *MARK = &PL_sv_undef;
3668 /* in case LEAVE wipes old return values */
3670 for (mark = newsp + 1; mark <= SP; mark++) {
3671 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3672 *mark = sv_mortalcopy(*mark);
3673 TAINT_NOT; /* Each item is independent */
3677 PL_curpm = newpm; /* Don't pop $1 et al till now */
3680 sv_setpvn(ERRSV,"",0);
3687 register PERL_CONTEXT *cx;
3688 const I32 gimme = GIMME_V;
3693 if (PL_op->op_targ == 0) {
3694 SV ** const defsv_p = &GvSV(PL_defgv);
3695 *defsv_p = newSVsv(POPs);
3696 SAVECLEARSV(*defsv_p);
3699 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3701 PUSHBLOCK(cx, CXt_GIVEN, SP);
3710 register PERL_CONTEXT *cx;
3714 PERL_UNUSED_CONTEXT;
3717 assert(CxTYPE(cx) == CXt_GIVEN);
3722 PL_curpm = newpm; /* pop $1 et al */
3729 /* Helper routines used by pp_smartmatch */
3731 S_make_matcher(pTHX_ regexp *re)
3734 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3735 PM_SETRE(matcher, ReREFCNT_inc(re));
3737 SAVEFREEOP((OP *) matcher);
3744 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3749 PL_op = (OP *) matcher;
3754 return (SvTRUEx(POPs));
3758 S_destroy_matcher(pTHX_ PMOP *matcher)
3761 PERL_UNUSED_ARG(matcher);
3766 /* Do a smart match */
3769 return do_smartmatch(NULL, NULL);
3772 /* This version of do_smartmatch() implements the
3773 * table of smart matches that is found in perlsyn.
3776 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3781 SV *e = TOPs; /* e is for 'expression' */
3782 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3783 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3785 regexp *this_regex, *other_regex;
3787 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3789 # define SM_REF(type) ( \
3790 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3791 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3793 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3794 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
3795 && NOT_EMPTY_PROTO(This) && (Other = e)) \
3796 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
3797 && NOT_EMPTY_PROTO(This) && (Other = d)))
3799 # define SM_REGEX ( \
3800 (SvROK(d) && SvMAGICAL(This = SvRV(d)) \
3801 && (mg = mg_find(This, PERL_MAGIC_qr)) \
3802 && (this_regex = (regexp *)mg->mg_obj) \
3805 (SvROK(e) && SvMAGICAL(This = SvRV(e)) \
3806 && (mg = mg_find(This, PERL_MAGIC_qr)) \
3807 && (this_regex = (regexp *)mg->mg_obj) \
3811 # define SM_OTHER_REF(type) \
3812 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3814 # define SM_OTHER_REGEX (SvROK(Other) && SvMAGICAL(SvRV(Other)) \
3815 && (mg = mg_find(SvRV(Other), PERL_MAGIC_qr)) \
3816 && (other_regex = (regexp *)mg->mg_obj))
3819 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3820 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3822 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3823 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3825 tryAMAGICbinSET(smart, 0);
3827 SP -= 2; /* Pop the values */
3829 /* Take care only to invoke mg_get() once for each argument.
3830 * Currently we do this by copying the SV if it's magical. */
3833 d = sv_mortalcopy(d);
3840 e = sv_mortalcopy(e);
3845 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3847 if (This == SvRV(Other))
3858 c = call_sv(This, G_SCALAR);
3862 else if (SvTEMP(TOPs))
3863 SvREFCNT_inc_void(TOPs);
3868 else if (SM_REF(PVHV)) {
3869 if (SM_OTHER_REF(PVHV)) {
3870 /* Check that the key-sets are identical */
3872 HV *other_hv = (HV *) SvRV(Other);
3874 bool other_tied = FALSE;
3875 U32 this_key_count = 0,
3876 other_key_count = 0;
3878 /* Tied hashes don't know how many keys they have. */
3879 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
3882 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3883 HV * const temp = other_hv;
3884 other_hv = (HV *) This;
3888 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3891 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
3894 /* The hashes have the same number of keys, so it suffices
3895 to check that one is a subset of the other. */
3896 (void) hv_iterinit((HV *) This);
3897 while ( (he = hv_iternext((HV *) This)) ) {
3899 char * const key = hv_iterkey(he, &key_len);
3903 if(!hv_exists(other_hv, key, key_len)) {
3904 (void) hv_iterinit((HV *) This); /* reset iterator */
3910 (void) hv_iterinit(other_hv);
3911 while ( hv_iternext(other_hv) )
3915 other_key_count = HvUSEDKEYS(other_hv);
3917 if (this_key_count != other_key_count)
3922 else if (SM_OTHER_REF(PVAV)) {
3923 AV * const other_av = (AV *) SvRV(Other);
3924 const I32 other_len = av_len(other_av) + 1;
3927 if (HvUSEDKEYS((HV *) This) != other_len)
3930 for(i = 0; i < other_len; ++i) {
3931 SV ** const svp = av_fetch(other_av, i, FALSE);
3935 if (!svp) /* ??? When can this happen? */
3938 key = SvPV(*svp, key_len);
3939 if(!hv_exists((HV *) This, key, key_len))
3944 else if (SM_OTHER_REGEX) {
3945 PMOP * const matcher = make_matcher(other_regex);
3948 (void) hv_iterinit((HV *) This);
3949 while ( (he = hv_iternext((HV *) This)) ) {
3950 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
3951 (void) hv_iterinit((HV *) This);
3952 destroy_matcher(matcher);
3956 destroy_matcher(matcher);
3960 if (hv_exists_ent((HV *) This, Other, 0))
3966 else if (SM_REF(PVAV)) {
3967 if (SM_OTHER_REF(PVAV)) {
3968 AV *other_av = (AV *) SvRV(Other);
3969 if (av_len((AV *) This) != av_len(other_av))
3973 const I32 other_len = av_len(other_av);
3975 if (NULL == seen_this) {
3976 seen_this = newHV();
3977 (void) sv_2mortal((SV *) seen_this);
3979 if (NULL == seen_other) {
3980 seen_this = newHV();
3981 (void) sv_2mortal((SV *) seen_other);
3983 for(i = 0; i <= other_len; ++i) {
3984 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
3985 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
3987 if (!this_elem || !other_elem) {
3988 if (this_elem || other_elem)
3991 else if (SM_SEEN_THIS(*this_elem)
3992 || SM_SEEN_OTHER(*other_elem))
3994 if (*this_elem != *other_elem)
3998 hv_store_ent(seen_this,
3999 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4001 hv_store_ent(seen_other,
4002 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4008 (void) do_smartmatch(seen_this, seen_other);
4018 else if (SM_OTHER_REGEX) {
4019 PMOP * const matcher = make_matcher(other_regex);
4020 const I32 this_len = av_len((AV *) This);
4023 for(i = 0; i <= this_len; ++i) {
4024 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4025 if (svp && matcher_matches_sv(matcher, *svp)) {
4026 destroy_matcher(matcher);
4030 destroy_matcher(matcher);
4033 else if (SvIOK(Other) || SvNOK(Other)) {
4036 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4037 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4044 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4054 else if (SvPOK(Other)) {
4055 const I32 this_len = av_len((AV *) This);
4058 for(i = 0; i <= this_len; ++i) {
4059 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4074 else if (!SvOK(d) || !SvOK(e)) {
4075 if (!SvOK(d) && !SvOK(e))
4080 else if (SM_REGEX) {
4081 PMOP * const matcher = make_matcher(this_regex);
4084 PUSHs(matcher_matches_sv(matcher, Other)
4087 destroy_matcher(matcher);
4090 else if (SM_REF(PVCV)) {
4092 /* This must be a null-prototyped sub, because we
4093 already checked for the other kind. */
4099 c = call_sv(This, G_SCALAR);
4102 PUSHs(&PL_sv_undef);
4103 else if (SvTEMP(TOPs))
4104 SvREFCNT_inc_void(TOPs);
4106 if (SM_OTHER_REF(PVCV)) {
4107 /* This one has to be null-proto'd too.
4108 Call both of 'em, and compare the results */
4110 c = call_sv(SvRV(Other), G_SCALAR);
4113 PUSHs(&PL_sv_undef);
4114 else if (SvTEMP(TOPs))
4115 SvREFCNT_inc_void(TOPs);
4126 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4127 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4129 if (SvPOK(Other) && !looks_like_number(Other)) {
4130 /* String comparison */
4135 /* Otherwise, numeric comparison */
4138 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4149 /* As a last resort, use string comparison */
4158 register PERL_CONTEXT *cx;
4159 const I32 gimme = GIMME_V;
4161 /* This is essentially an optimization: if the match
4162 fails, we don't want to push a context and then
4163 pop it again right away, so we skip straight
4164 to the op that follows the leavewhen.
4166 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4167 return cLOGOP->op_other->op_next;
4172 PUSHBLOCK(cx, CXt_WHEN, SP);
4181 register PERL_CONTEXT *cx;
4187 assert(CxTYPE(cx) == CXt_WHEN);
4192 PL_curpm = newpm; /* pop $1 et al */
4202 register PERL_CONTEXT *cx;
4205 cxix = dopoptowhen(cxstack_ix);
4207 DIE(aTHX_ "Can't \"continue\" outside a when block");
4208 if (cxix < cxstack_ix)
4211 /* clear off anything above the scope we're re-entering */
4212 inner = PL_scopestack_ix;
4214 if (PL_scopestack_ix < inner)
4215 leave_scope(PL_scopestack[PL_scopestack_ix]);
4216 PL_curcop = cx->blk_oldcop;
4217 return cx->blk_givwhen.leave_op;
4224 register PERL_CONTEXT *cx;
4227 cxix = dopoptogiven(cxstack_ix);
4229 if (PL_op->op_flags & OPf_SPECIAL)
4230 DIE(aTHX_ "Can't use when() outside a topicalizer");
4232 DIE(aTHX_ "Can't \"break\" outside a given block");
4234 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4235 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4237 if (cxix < cxstack_ix)
4240 /* clear off anything above the scope we're re-entering */
4241 inner = PL_scopestack_ix;
4243 if (PL_scopestack_ix < inner)
4244 leave_scope(PL_scopestack[PL_scopestack_ix]);
4245 PL_curcop = cx->blk_oldcop;
4248 return CX_LOOP_NEXTOP_GET(cx);
4250 return cx->blk_givwhen.leave_op;
4254 S_doparseform(pTHX_ SV *sv)
4257 register char *s = SvPV_force(sv, len);
4258 register char * const send = s + len;
4259 register char *base = NULL;
4260 register I32 skipspaces = 0;
4261 bool noblank = FALSE;
4262 bool repeat = FALSE;
4263 bool postspace = FALSE;
4269 bool unchopnum = FALSE;
4270 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4273 Perl_croak(aTHX_ "Null picture in formline");
4275 /* estimate the buffer size needed */
4276 for (base = s; s <= send; s++) {
4277 if (*s == '\n' || *s == '@' || *s == '^')
4283 Newx(fops, maxops, U32);
4288 *fpc++ = FF_LINEMARK;
4289 noblank = repeat = FALSE;
4307 case ' ': case '\t':
4314 } /* else FALL THROUGH */
4322 *fpc++ = FF_LITERAL;
4330 *fpc++ = (U16)skipspaces;
4334 *fpc++ = FF_NEWLINE;
4338 arg = fpc - linepc + 1;
4345 *fpc++ = FF_LINEMARK;
4346 noblank = repeat = FALSE;
4355 ischop = s[-1] == '^';
4361 arg = (s - base) - 1;
4363 *fpc++ = FF_LITERAL;
4371 *fpc++ = 2; /* skip the @* or ^* */
4373 *fpc++ = FF_LINESNGL;
4376 *fpc++ = FF_LINEGLOB;
4378 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4379 arg = ischop ? 512 : 0;
4384 const char * const f = ++s;
4387 arg |= 256 + (s - f);
4389 *fpc++ = s - base; /* fieldsize for FETCH */
4390 *fpc++ = FF_DECIMAL;
4392 unchopnum |= ! ischop;
4394 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4395 arg = ischop ? 512 : 0;
4397 s++; /* skip the '0' first */
4401 const char * const f = ++s;
4404 arg |= 256 + (s - f);
4406 *fpc++ = s - base; /* fieldsize for FETCH */
4407 *fpc++ = FF_0DECIMAL;
4409 unchopnum |= ! ischop;
4413 bool ismore = FALSE;
4416 while (*++s == '>') ;
4417 prespace = FF_SPACE;
4419 else if (*s == '|') {
4420 while (*++s == '|') ;
4421 prespace = FF_HALFSPACE;
4426 while (*++s == '<') ;
4429 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4433 *fpc++ = s - base; /* fieldsize for FETCH */
4435 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4438 *fpc++ = (U16)prespace;
4452 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4454 { /* need to jump to the next word */
4456 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4457 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4458 s = SvPVX(sv) + SvCUR(sv) + z;
4460 Copy(fops, s, arg, U32);
4462 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4465 if (unchopnum && repeat)
4466 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4472 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4474 /* Can value be printed in fldsize chars, using %*.*f ? */
4478 int intsize = fldsize - (value < 0 ? 1 : 0);
4485 while (intsize--) pwr *= 10.0;
4486 while (frcsize--) eps /= 10.0;
4489 if (value + eps >= pwr)
4492 if (value - eps <= -pwr)
4499 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4502 SV * const datasv = FILTER_DATA(idx);
4503 const int filter_has_file = IoLINES(datasv);
4504 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4505 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4509 const char *got_p = NULL;
4510 const char *prune_from = NULL;
4511 bool read_from_cache = FALSE;
4514 assert(maxlen >= 0);
4517 /* I was having segfault trouble under Linux 2.2.5 after a
4518 parse error occured. (Had to hack around it with a test
4519 for PL_error_count == 0.) Solaris doesn't segfault --
4520 not sure where the trouble is yet. XXX */
4522 if (IoFMT_GV(datasv)) {
4523 SV *const cache = (SV *)IoFMT_GV(datasv);
4526 const char *cache_p = SvPV(cache, cache_len);
4530 /* Running in block mode and we have some cached data already.
4532 if (cache_len >= umaxlen) {
4533 /* In fact, so much data we don't even need to call
4538 const char *const first_nl =
4539 (const char *)memchr(cache_p, '\n', cache_len);
4541 take = first_nl + 1 - cache_p;
4545 sv_catpvn(buf_sv, cache_p, take);
4546 sv_chop(cache, cache_p + take);
4547 /* Definately not EOF */
4551 sv_catsv(buf_sv, cache);
4553 umaxlen -= cache_len;
4556 read_from_cache = TRUE;
4560 /* Filter API says that the filter appends to the contents of the buffer.
4561 Usually the buffer is "", so the details don't matter. But if it's not,
4562 then clearly what it contains is already filtered by this filter, so we
4563 don't want to pass it in a second time.
4564 I'm going to use a mortal in case the upstream filter croaks. */
4565 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4566 ? sv_newmortal() : buf_sv;
4567 SvUPGRADE(upstream, SVt_PV);
4569 if (filter_has_file) {
4570 status = FILTER_READ(idx+1, upstream, 0);
4573 if (filter_sub && status >= 0) {
4584 PUSHs(sv_2mortal(newSViv(0)));
4586 PUSHs(filter_state);
4589 count = call_sv(filter_sub, G_SCALAR);
4604 if(SvOK(upstream)) {
4605 got_p = SvPV(upstream, got_len);
4607 if (got_len > umaxlen) {
4608 prune_from = got_p + umaxlen;
4611 const char *const first_nl =
4612 (const char *)memchr(got_p, '\n', got_len);
4613 if (first_nl && first_nl + 1 < got_p + got_len) {
4614 /* There's a second line here... */
4615 prune_from = first_nl + 1;
4620 /* Oh. Too long. Stuff some in our cache. */
4621 STRLEN cached_len = got_p + got_len - prune_from;
4622 SV *cache = (SV *)IoFMT_GV(datasv);
4625 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4626 } else if (SvOK(cache)) {
4627 /* Cache should be empty. */
4628 assert(!SvCUR(cache));
4631 sv_setpvn(cache, prune_from, cached_len);
4632 /* If you ask for block mode, you may well split UTF-8 characters.
4633 "If it breaks, you get to keep both parts"
4634 (Your code is broken if you don't put them back together again
4635 before something notices.) */
4636 if (SvUTF8(upstream)) {
4639 SvCUR_set(upstream, got_len - cached_len);
4640 /* Can't yet be EOF */
4645 /* If they are at EOF but buf_sv has something in it, then they may never
4646 have touched the SV upstream, so it may be undefined. If we naively
4647 concatenate it then we get a warning about use of uninitialised value.
4649 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4650 sv_catsv(buf_sv, upstream);
4654 IoLINES(datasv) = 0;
4655 SvREFCNT_dec(IoFMT_GV(datasv));
4657 SvREFCNT_dec(filter_state);
4658 IoTOP_GV(datasv) = NULL;
4661 SvREFCNT_dec(filter_sub);
4662 IoBOTTOM_GV(datasv) = NULL;
4664 filter_del(S_run_user_filter);
4666 if (status == 0 && read_from_cache) {
4667 /* If we read some data from the cache (and by getting here it implies
4668 that we emptied the cache) then we aren't yet at EOF, and mustn't
4669 report that to our caller. */
4675 /* perhaps someone can come up with a better name for
4676 this? it is not really "absolute", per se ... */
4678 S_path_is_absolute(const char *name)
4680 if (PERL_FILE_IS_ABSOLUTE(name)
4681 #ifdef MACOS_TRADITIONAL
4684 || (*name == '.' && (name[1] == '/' ||
4685 (name[1] == '.' && name[2] == '/')))
4697 * c-indentation-style: bsd
4699 * indent-tabs-mode: t
4702 * ex: set ts=8 sts=4 sw=4 noet: