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));
1463 ++PL_parser->error_count;
1467 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1476 if (PL_in_eval & EVAL_KEEPERR) {
1477 static const char prefix[] = "\t(in cleanup) ";
1478 SV * const err = ERRSV;
1479 const char *e = NULL;
1481 sv_setpvn(err,"",0);
1482 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1484 e = SvPV_const(err, len);
1486 if (*e != *message || strNE(e,message))
1490 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1491 sv_catpvn(err, prefix, sizeof(prefix)-1);
1492 sv_catpvn(err, message, msglen);
1493 if (ckWARN(WARN_MISC)) {
1494 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1495 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1500 sv_setpvn(ERRSV, message, msglen);
1504 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1505 && PL_curstackinfo->si_prev)
1513 register PERL_CONTEXT *cx;
1516 if (cxix < cxstack_ix)
1519 POPBLOCK(cx,PL_curpm);
1520 if (CxTYPE(cx) != CXt_EVAL) {
1522 message = SvPVx_const(ERRSV, msglen);
1523 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1524 PerlIO_write(Perl_error_log, message, msglen);
1529 if (gimme == G_SCALAR)
1530 *++newsp = &PL_sv_undef;
1531 PL_stack_sp = newsp;
1535 /* LEAVE could clobber PL_curcop (see save_re_context())
1536 * XXX it might be better to find a way to avoid messing with
1537 * PL_curcop in save_re_context() instead, but this is a more
1538 * minimal fix --GSAR */
1539 PL_curcop = cx->blk_oldcop;
1541 if (optype == OP_REQUIRE) {
1542 const char* const msg = SvPVx_nolen_const(ERRSV);
1543 SV * const nsv = cx->blk_eval.old_namesv;
1544 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1546 DIE(aTHX_ "%sCompilation failed in require",
1547 *msg ? msg : "Unknown error\n");
1549 assert(CxTYPE(cx) == CXt_EVAL);
1550 return cx->blk_eval.retop;
1554 message = SvPVx_const(ERRSV, msglen);
1556 write_to_stderr(message, msglen);
1564 dVAR; dSP; dPOPTOPssrl;
1565 if (SvTRUE(left) != SvTRUE(right))
1575 register I32 cxix = dopoptosub(cxstack_ix);
1576 register const PERL_CONTEXT *cx;
1577 register const PERL_CONTEXT *ccstack = cxstack;
1578 const PERL_SI *top_si = PL_curstackinfo;
1580 const char *stashname;
1587 /* we may be in a higher stacklevel, so dig down deeper */
1588 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1589 top_si = top_si->si_prev;
1590 ccstack = top_si->si_cxstack;
1591 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1594 if (GIMME != G_ARRAY) {
1600 /* caller() should not report the automatic calls to &DB::sub */
1601 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1602 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1606 cxix = dopoptosub_at(ccstack, cxix - 1);
1609 cx = &ccstack[cxix];
1610 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1611 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1612 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1613 field below is defined for any cx. */
1614 /* caller() should not report the automatic calls to &DB::sub */
1615 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1616 cx = &ccstack[dbcxix];
1619 stashname = CopSTASHPV(cx->blk_oldcop);
1620 if (GIMME != G_ARRAY) {
1623 PUSHs(&PL_sv_undef);
1626 sv_setpv(TARG, stashname);
1635 PUSHs(&PL_sv_undef);
1637 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1638 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1639 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1642 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1643 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1644 /* So is ccstack[dbcxix]. */
1646 SV * const sv = newSV(0);
1647 gv_efullname3(sv, cvgv, NULL);
1648 PUSHs(sv_2mortal(sv));
1649 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1652 PUSHs(sv_2mortal(newSVpvs("(unknown)")));
1653 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1657 PUSHs(sv_2mortal(newSVpvs("(eval)")));
1658 PUSHs(sv_2mortal(newSViv(0)));
1660 gimme = (I32)cx->blk_gimme;
1661 if (gimme == G_VOID)
1662 PUSHs(&PL_sv_undef);
1664 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1665 if (CxTYPE(cx) == CXt_EVAL) {
1667 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1668 PUSHs(cx->blk_eval.cur_text);
1672 else if (cx->blk_eval.old_namesv) {
1673 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1676 /* eval BLOCK (try blocks have old_namesv == 0) */
1678 PUSHs(&PL_sv_undef);
1679 PUSHs(&PL_sv_undef);
1683 PUSHs(&PL_sv_undef);
1684 PUSHs(&PL_sv_undef);
1686 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1687 && CopSTASH_eq(PL_curcop, PL_debstash))
1689 AV * const ary = cx->blk_sub.argarray;
1690 const int off = AvARRAY(ary) - AvALLOC(ary);
1693 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1694 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1696 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1699 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1700 av_extend(PL_dbargs, AvFILLp(ary) + off);
1701 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1702 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1704 /* XXX only hints propagated via op_private are currently
1705 * visible (others are not easily accessible, since they
1706 * use the global PL_hints) */
1707 PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
1710 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1712 if (old_warnings == pWARN_NONE ||
1713 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1714 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1715 else if (old_warnings == pWARN_ALL ||
1716 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1717 /* Get the bit mask for $warnings::Bits{all}, because
1718 * it could have been extended by warnings::register */
1720 HV * const bits = get_hv("warnings::Bits", FALSE);
1721 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1722 mask = newSVsv(*bits_all);
1725 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1729 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1730 PUSHs(sv_2mortal(mask));
1733 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1734 sv_2mortal(newRV_noinc(
1735 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1736 cx->blk_oldcop->cop_hints_hash)))
1745 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1746 sv_reset(tmps, CopSTASH(PL_curcop));
1751 /* like pp_nextstate, but used instead when the debugger is active */
1756 PL_curcop = (COP*)PL_op;
1757 TAINT_NOT; /* Each statement is presumed innocent */
1758 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1761 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1762 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1765 register PERL_CONTEXT *cx;
1766 const I32 gimme = G_ARRAY;
1768 GV * const gv = PL_DBgv;
1769 register CV * const cv = GvCV(gv);
1772 DIE(aTHX_ "No DB::DB routine defined");
1774 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1775 /* don't do recursive DB::DB call */
1790 (void)(*CvXSUB(cv))(aTHX_ cv);
1797 PUSHBLOCK(cx, CXt_SUB, SP);
1799 cx->blk_sub.retop = PL_op->op_next;
1802 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1803 RETURNOP(CvSTART(cv));
1813 register PERL_CONTEXT *cx;
1814 const I32 gimme = GIMME_V;
1816 U16 cxtype = CXt_LOOP | CXp_FOREACH;
1824 if (PL_op->op_targ) {
1825 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1826 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1827 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1828 SVs_PADSTALE, SVs_PADSTALE);
1830 #ifndef USE_ITHREADS
1831 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1834 SAVEPADSV(PL_op->op_targ);
1835 iterdata = INT2PTR(void*, PL_op->op_targ);
1836 cxtype |= CXp_PADVAR;
1840 GV * const gv = (GV*)POPs;
1841 svp = &GvSV(gv); /* symbol table variable */
1842 SAVEGENERICSV(*svp);
1845 iterdata = (void*)gv;
1849 if (PL_op->op_private & OPpITER_DEF)
1850 cxtype |= CXp_FOR_DEF;
1854 PUSHBLOCK(cx, cxtype, SP);
1856 PUSHLOOP(cx, iterdata, MARK);
1858 PUSHLOOP(cx, svp, MARK);
1860 if (PL_op->op_flags & OPf_STACKED) {
1861 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1862 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1864 SV * const right = (SV*)cx->blk_loop.iterary;
1867 if (RANGE_IS_NUMERIC(sv,right)) {
1868 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1869 (SvOK(right) && SvNV(right) >= IV_MAX))
1870 DIE(aTHX_ "Range iterator outside integer range");
1871 cx->blk_loop.iterix = SvIV(sv);
1872 cx->blk_loop.itermax = SvIV(right);
1874 /* for correct -Dstv display */
1875 cx->blk_oldsp = sp - PL_stack_base;
1879 cx->blk_loop.iterlval = newSVsv(sv);
1880 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1881 (void) SvPV_nolen_const(right);
1884 else if (PL_op->op_private & OPpITER_REVERSED) {
1885 cx->blk_loop.itermax = 0;
1886 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1891 cx->blk_loop.iterary = PL_curstack;
1892 AvFILLp(PL_curstack) = SP - PL_stack_base;
1893 if (PL_op->op_private & OPpITER_REVERSED) {
1894 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1895 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1898 cx->blk_loop.iterix = MARK - PL_stack_base;
1908 register PERL_CONTEXT *cx;
1909 const I32 gimme = GIMME_V;
1915 PUSHBLOCK(cx, CXt_LOOP, SP);
1916 PUSHLOOP(cx, 0, SP);
1924 register PERL_CONTEXT *cx;
1931 assert(CxTYPE(cx) == CXt_LOOP);
1933 newsp = PL_stack_base + cx->blk_loop.resetsp;
1936 if (gimme == G_VOID)
1938 else if (gimme == G_SCALAR) {
1940 *++newsp = sv_mortalcopy(*SP);
1942 *++newsp = &PL_sv_undef;
1946 *++newsp = sv_mortalcopy(*++mark);
1947 TAINT_NOT; /* Each item is independent */
1953 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1954 PL_curpm = newpm; /* ... and pop $1 et al */
1965 register PERL_CONTEXT *cx;
1966 bool popsub2 = FALSE;
1967 bool clear_errsv = FALSE;
1975 const I32 cxix = dopoptosub(cxstack_ix);
1978 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1979 * sort block, which is a CXt_NULL
1982 PL_stack_base[1] = *PL_stack_sp;
1983 PL_stack_sp = PL_stack_base + 1;
1987 DIE(aTHX_ "Can't return outside a subroutine");
1989 if (cxix < cxstack_ix)
1992 if (CxMULTICALL(&cxstack[cxix])) {
1993 gimme = cxstack[cxix].blk_gimme;
1994 if (gimme == G_VOID)
1995 PL_stack_sp = PL_stack_base;
1996 else if (gimme == G_SCALAR) {
1997 PL_stack_base[1] = *PL_stack_sp;
1998 PL_stack_sp = PL_stack_base + 1;
2004 switch (CxTYPE(cx)) {
2007 retop = cx->blk_sub.retop;
2008 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2011 if (!(PL_in_eval & EVAL_KEEPERR))
2014 retop = cx->blk_eval.retop;
2018 if (optype == OP_REQUIRE &&
2019 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2021 /* Unassume the success we assumed earlier. */
2022 SV * const nsv = cx->blk_eval.old_namesv;
2023 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2024 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2029 retop = cx->blk_sub.retop;
2032 DIE(aTHX_ "panic: return");
2036 if (gimme == G_SCALAR) {
2039 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2041 *++newsp = SvREFCNT_inc(*SP);
2046 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2048 *++newsp = sv_mortalcopy(sv);
2053 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2056 *++newsp = sv_mortalcopy(*SP);
2059 *++newsp = &PL_sv_undef;
2061 else if (gimme == G_ARRAY) {
2062 while (++MARK <= SP) {
2063 *++newsp = (popsub2 && SvTEMP(*MARK))
2064 ? *MARK : sv_mortalcopy(*MARK);
2065 TAINT_NOT; /* Each item is independent */
2068 PL_stack_sp = newsp;
2071 /* Stack values are safe: */
2074 POPSUB(cx,sv); /* release CV and @_ ... */
2078 PL_curpm = newpm; /* ... and pop $1 et al */
2082 sv_setpvn(ERRSV,"",0);
2090 register PERL_CONTEXT *cx;
2101 if (PL_op->op_flags & OPf_SPECIAL) {
2102 cxix = dopoptoloop(cxstack_ix);
2104 DIE(aTHX_ "Can't \"last\" outside a loop block");
2107 cxix = dopoptolabel(cPVOP->op_pv);
2109 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2111 if (cxix < cxstack_ix)
2115 cxstack_ix++; /* temporarily protect top context */
2117 switch (CxTYPE(cx)) {
2120 newsp = PL_stack_base + cx->blk_loop.resetsp;
2121 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2125 nextop = cx->blk_sub.retop;
2129 nextop = cx->blk_eval.retop;
2133 nextop = cx->blk_sub.retop;
2136 DIE(aTHX_ "panic: last");
2140 if (gimme == G_SCALAR) {
2142 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2143 ? *SP : sv_mortalcopy(*SP);
2145 *++newsp = &PL_sv_undef;
2147 else if (gimme == G_ARRAY) {
2148 while (++MARK <= SP) {
2149 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2150 ? *MARK : sv_mortalcopy(*MARK);
2151 TAINT_NOT; /* Each item is independent */
2159 /* Stack values are safe: */
2162 POPLOOP(cx); /* release loop vars ... */
2166 POPSUB(cx,sv); /* release CV and @_ ... */
2169 PL_curpm = newpm; /* ... and pop $1 et al */
2172 PERL_UNUSED_VAR(optype);
2173 PERL_UNUSED_VAR(gimme);
2181 register PERL_CONTEXT *cx;
2184 if (PL_op->op_flags & OPf_SPECIAL) {
2185 cxix = dopoptoloop(cxstack_ix);
2187 DIE(aTHX_ "Can't \"next\" outside a loop block");
2190 cxix = dopoptolabel(cPVOP->op_pv);
2192 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2194 if (cxix < cxstack_ix)
2197 /* clear off anything above the scope we're re-entering, but
2198 * save the rest until after a possible continue block */
2199 inner = PL_scopestack_ix;
2201 if (PL_scopestack_ix < inner)
2202 leave_scope(PL_scopestack[PL_scopestack_ix]);
2203 PL_curcop = cx->blk_oldcop;
2204 return CX_LOOP_NEXTOP_GET(cx);
2211 register PERL_CONTEXT *cx;
2215 if (PL_op->op_flags & OPf_SPECIAL) {
2216 cxix = dopoptoloop(cxstack_ix);
2218 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2221 cxix = dopoptolabel(cPVOP->op_pv);
2223 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2225 if (cxix < cxstack_ix)
2228 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2229 if (redo_op->op_type == OP_ENTER) {
2230 /* pop one less context to avoid $x being freed in while (my $x..) */
2232 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2233 redo_op = redo_op->op_next;
2237 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2238 LEAVE_SCOPE(oldsave);
2240 PL_curcop = cx->blk_oldcop;
2245 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2249 static const char too_deep[] = "Target of goto is too deeply nested";
2252 Perl_croak(aTHX_ too_deep);
2253 if (o->op_type == OP_LEAVE ||
2254 o->op_type == OP_SCOPE ||
2255 o->op_type == OP_LEAVELOOP ||
2256 o->op_type == OP_LEAVESUB ||
2257 o->op_type == OP_LEAVETRY)
2259 *ops++ = cUNOPo->op_first;
2261 Perl_croak(aTHX_ too_deep);
2264 if (o->op_flags & OPf_KIDS) {
2266 /* First try all the kids at this level, since that's likeliest. */
2267 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2268 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2269 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2272 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2273 if (kid == PL_lastgotoprobe)
2275 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2278 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2279 ops[-1]->op_type == OP_DBSTATE)
2284 if ((o = dofindlabel(kid, label, ops, oplimit)))
2297 register PERL_CONTEXT *cx;
2298 #define GOTO_DEPTH 64
2299 OP *enterops[GOTO_DEPTH];
2300 const char *label = NULL;
2301 const bool do_dump = (PL_op->op_type == OP_DUMP);
2302 static const char must_have_label[] = "goto must have label";
2304 if (PL_op->op_flags & OPf_STACKED) {
2305 SV * const sv = POPs;
2307 /* This egregious kludge implements goto &subroutine */
2308 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2310 register PERL_CONTEXT *cx;
2311 CV* cv = (CV*)SvRV(sv);
2318 if (!CvROOT(cv) && !CvXSUB(cv)) {
2319 const GV * const gv = CvGV(cv);
2323 /* autoloaded stub? */
2324 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2326 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2327 GvNAMELEN(gv), FALSE);
2328 if (autogv && (cv = GvCV(autogv)))
2330 tmpstr = sv_newmortal();
2331 gv_efullname3(tmpstr, gv, NULL);
2332 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2334 DIE(aTHX_ "Goto undefined subroutine");
2337 /* First do some returnish stuff. */
2338 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2340 cxix = dopoptosub(cxstack_ix);
2342 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2343 if (cxix < cxstack_ix)
2347 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2348 if (CxTYPE(cx) == CXt_EVAL) {
2350 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2352 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2354 else if (CxMULTICALL(cx))
2355 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2356 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2357 /* put @_ back onto stack */
2358 AV* av = cx->blk_sub.argarray;
2360 items = AvFILLp(av) + 1;
2361 EXTEND(SP, items+1); /* @_ could have been extended. */
2362 Copy(AvARRAY(av), SP + 1, items, SV*);
2363 SvREFCNT_dec(GvAV(PL_defgv));
2364 GvAV(PL_defgv) = cx->blk_sub.savearray;
2366 /* abandon @_ if it got reified */
2371 av_extend(av, items-1);
2373 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2376 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2377 AV* const av = GvAV(PL_defgv);
2378 items = AvFILLp(av) + 1;
2379 EXTEND(SP, items+1); /* @_ could have been extended. */
2380 Copy(AvARRAY(av), SP + 1, items, SV*);
2384 if (CxTYPE(cx) == CXt_SUB &&
2385 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2386 SvREFCNT_dec(cx->blk_sub.cv);
2387 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2388 LEAVE_SCOPE(oldsave);
2390 /* Now do some callish stuff. */
2392 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2394 OP* const retop = cx->blk_sub.retop;
2399 for (index=0; index<items; index++)
2400 sv_2mortal(SP[-index]);
2403 /* XS subs don't have a CxSUB, so pop it */
2404 POPBLOCK(cx, PL_curpm);
2405 /* Push a mark for the start of arglist */
2408 (void)(*CvXSUB(cv))(aTHX_ cv);
2413 AV* const padlist = CvPADLIST(cv);
2414 if (CxTYPE(cx) == CXt_EVAL) {
2415 PL_in_eval = cx->blk_eval.old_in_eval;
2416 PL_eval_root = cx->blk_eval.old_eval_root;
2417 cx->cx_type = CXt_SUB;
2418 cx->blk_sub.hasargs = 0;
2420 cx->blk_sub.cv = cv;
2421 cx->blk_sub.olddepth = CvDEPTH(cv);
2424 if (CvDEPTH(cv) < 2)
2425 SvREFCNT_inc_simple_void_NN(cv);
2427 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2428 sub_crush_depth(cv);
2429 pad_push(padlist, CvDEPTH(cv));
2432 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2433 if (cx->blk_sub.hasargs)
2435 AV* const av = (AV*)PAD_SVl(0);
2437 cx->blk_sub.savearray = GvAV(PL_defgv);
2438 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2439 CX_CURPAD_SAVE(cx->blk_sub);
2440 cx->blk_sub.argarray = av;
2442 if (items >= AvMAX(av) + 1) {
2443 SV **ary = AvALLOC(av);
2444 if (AvARRAY(av) != ary) {
2445 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2448 if (items >= AvMAX(av) + 1) {
2449 AvMAX(av) = items - 1;
2450 Renew(ary,items+1,SV*);
2456 Copy(mark,AvARRAY(av),items,SV*);
2457 AvFILLp(av) = items - 1;
2458 assert(!AvREAL(av));
2460 /* transfer 'ownership' of refcnts to new @_ */
2470 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2471 Perl_get_db_sub(aTHX_ NULL, cv);
2473 CV * const gotocv = get_cv("DB::goto", FALSE);
2475 PUSHMARK( PL_stack_sp );
2476 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2481 RETURNOP(CvSTART(cv));
2485 label = SvPV_nolen_const(sv);
2486 if (!(do_dump || *label))
2487 DIE(aTHX_ must_have_label);
2490 else if (PL_op->op_flags & OPf_SPECIAL) {
2492 DIE(aTHX_ must_have_label);
2495 label = cPVOP->op_pv;
2497 if (label && *label) {
2498 OP *gotoprobe = NULL;
2499 bool leaving_eval = FALSE;
2500 bool in_block = FALSE;
2501 PERL_CONTEXT *last_eval_cx = NULL;
2505 PL_lastgotoprobe = NULL;
2507 for (ix = cxstack_ix; ix >= 0; ix--) {
2509 switch (CxTYPE(cx)) {
2511 leaving_eval = TRUE;
2512 if (!CxTRYBLOCK(cx)) {
2513 gotoprobe = (last_eval_cx ?
2514 last_eval_cx->blk_eval.old_eval_root :
2519 /* else fall through */
2521 gotoprobe = cx->blk_oldcop->op_sibling;
2527 gotoprobe = cx->blk_oldcop->op_sibling;
2530 gotoprobe = PL_main_root;
2533 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2534 gotoprobe = CvROOT(cx->blk_sub.cv);
2540 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2543 DIE(aTHX_ "panic: goto");
2544 gotoprobe = PL_main_root;
2548 retop = dofindlabel(gotoprobe, label,
2549 enterops, enterops + GOTO_DEPTH);
2553 PL_lastgotoprobe = gotoprobe;
2556 DIE(aTHX_ "Can't find label %s", label);
2558 /* if we're leaving an eval, check before we pop any frames
2559 that we're not going to punt, otherwise the error
2562 if (leaving_eval && *enterops && enterops[1]) {
2564 for (i = 1; enterops[i]; i++)
2565 if (enterops[i]->op_type == OP_ENTERITER)
2566 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2569 /* pop unwanted frames */
2571 if (ix < cxstack_ix) {
2578 oldsave = PL_scopestack[PL_scopestack_ix];
2579 LEAVE_SCOPE(oldsave);
2582 /* push wanted frames */
2584 if (*enterops && enterops[1]) {
2585 OP * const oldop = PL_op;
2586 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2587 for (; enterops[ix]; ix++) {
2588 PL_op = enterops[ix];
2589 /* Eventually we may want to stack the needed arguments
2590 * for each op. For now, we punt on the hard ones. */
2591 if (PL_op->op_type == OP_ENTERITER)
2592 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2593 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2601 if (!retop) retop = PL_main_start;
2603 PL_restartop = retop;
2604 PL_do_undump = TRUE;
2608 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2609 PL_do_undump = FALSE;
2626 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2628 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2631 PL_exit_flags |= PERL_EXIT_EXPECTED;
2633 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2634 if (anum || !(PL_minus_c && PL_madskills))
2639 PUSHs(&PL_sv_undef);
2646 S_save_lines(pTHX_ AV *array, SV *sv)
2648 const char *s = SvPVX_const(sv);
2649 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2652 while (s && s < send) {
2654 SV * const tmpstr = newSV_type(SVt_PVMG);
2656 t = strchr(s, '\n');
2662 sv_setpvn(tmpstr, s, t - s);
2663 av_store(array, line++, tmpstr);
2669 S_docatch_body(pTHX)
2677 S_docatch(pTHX_ OP *o)
2681 OP * const oldop = PL_op;
2685 assert(CATCH_GET == TRUE);
2692 assert(cxstack_ix >= 0);
2693 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2694 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2699 /* die caught by an inner eval - continue inner loop */
2701 /* NB XXX we rely on the old popped CxEVAL still being at the top
2702 * of the stack; the way die_where() currently works, this
2703 * assumption is valid. In theory The cur_top_env value should be
2704 * returned in another global, the way retop (aka PL_restartop)
2706 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2709 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2711 PL_op = PL_restartop;
2728 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2729 /* sv Text to convert to OP tree. */
2730 /* startop op_free() this to undo. */
2731 /* code Short string id of the caller. */
2733 /* FIXME - how much of this code is common with pp_entereval? */
2734 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 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2799 (void) 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);
2817 return PL_eval_start;
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.
2866 * Returns a bool indicating whether the compile was successful; if so,
2867 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2868 * pushes undef (also croaks if startop != NULL).
2872 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2875 OP * const saveop = PL_op;
2877 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2878 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2883 SAVESPTR(PL_compcv);
2884 PL_compcv = (CV*)newSV_type(SVt_PVCV);
2885 CvEVAL_on(PL_compcv);
2886 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2887 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2889 CvOUTSIDE_SEQ(PL_compcv) = seq;
2890 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2892 /* set up a scratch pad */
2894 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2895 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2899 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2901 /* make sure we compile in the right package */
2903 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2904 SAVESPTR(PL_curstash);
2905 PL_curstash = CopSTASH(PL_curcop);
2907 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2908 SAVESPTR(PL_beginav);
2909 PL_beginav = newAV();
2910 SAVEFREESV(PL_beginav);
2911 SAVESPTR(PL_unitcheckav);
2912 PL_unitcheckav = newAV();
2913 SAVEFREESV(PL_unitcheckav);
2916 SAVEBOOL(PL_madskills);
2920 /* try to compile it */
2922 PL_eval_root = NULL;
2923 PL_curcop = &PL_compiling;
2924 CopARYBASE_set(PL_curcop, 0);
2925 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2926 PL_in_eval |= EVAL_KEEPERR;
2928 sv_setpvn(ERRSV,"",0);
2929 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
2930 SV **newsp; /* Used by POPBLOCK. */
2931 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2932 I32 optype = 0; /* Might be reset by POPEVAL. */
2937 op_free(PL_eval_root);
2938 PL_eval_root = NULL;
2940 SP = PL_stack_base + POPMARK; /* pop original mark */
2942 POPBLOCK(cx,PL_curpm);
2948 msg = SvPVx_nolen_const(ERRSV);
2949 if (optype == OP_REQUIRE) {
2950 const SV * const nsv = cx->blk_eval.old_namesv;
2951 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2953 Perl_croak(aTHX_ "%sCompilation failed in require",
2954 *msg ? msg : "Unknown error\n");
2957 POPBLOCK(cx,PL_curpm);
2959 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2960 (*msg ? msg : "Unknown error\n"));
2964 sv_setpvs(ERRSV, "Compilation error");
2967 PERL_UNUSED_VAR(newsp);
2968 PUSHs(&PL_sv_undef);
2972 CopLINE_set(&PL_compiling, 0);
2974 *startop = PL_eval_root;
2976 SAVEFREEOP(PL_eval_root);
2978 /* Set the context for this new optree.
2979 * If the last op is an OP_REQUIRE, force scalar context.
2980 * Otherwise, propagate the context from the eval(). */
2981 if (PL_eval_root->op_type == OP_LEAVEEVAL
2982 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2983 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2985 scalar(PL_eval_root);
2986 else if (gimme & G_VOID)
2987 scalarvoid(PL_eval_root);
2988 else if (gimme & G_ARRAY)
2991 scalar(PL_eval_root);
2993 DEBUG_x(dump_eval());
2995 /* Register with debugger: */
2996 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
2997 CV * const cv = get_cv("DB::postponed", FALSE);
3001 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3003 call_sv((SV*)cv, G_DISCARD);
3008 call_list(PL_scopestack_ix, PL_unitcheckav);
3010 /* compiled okay, so do it */
3012 CvDEPTH(PL_compcv) = 1;
3013 SP = PL_stack_base + POPMARK; /* pop original mark */
3014 PL_op = saveop; /* The caller may need it. */
3015 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3022 S_check_type_and_open(pTHX_ const char *name, const char *mode)
3025 const int st_rc = PerlLIO_stat(name, &st);
3027 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3031 return PerlIO_open(name, mode);
3035 S_doopen_pm(pTHX_ const char *name, const char *mode)
3037 #ifndef PERL_DISABLE_PMC
3038 const STRLEN namelen = strlen(name);
3041 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3042 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3043 const char * const pmc = SvPV_nolen_const(pmcsv);
3045 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3046 fp = check_type_and_open(name, mode);
3049 fp = check_type_and_open(pmc, mode);
3051 SvREFCNT_dec(pmcsv);
3054 fp = check_type_and_open(name, mode);
3058 return check_type_and_open(name, mode);
3059 #endif /* !PERL_DISABLE_PMC */
3065 register PERL_CONTEXT *cx;
3072 int vms_unixname = 0;
3074 const char *tryname = NULL;
3076 const I32 gimme = GIMME_V;
3077 int filter_has_file = 0;
3078 PerlIO *tryrsfp = NULL;
3079 SV *filter_cache = NULL;
3080 SV *filter_state = NULL;
3081 SV *filter_sub = NULL;
3087 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3088 if (!PL_v_string_ok &&
3089 SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3090 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3091 "v-string in use/require non-portable");
3093 sv = new_version(sv);
3095 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.006), FALSE))) >= 0)
3096 /* version 5.006 recognises 5.x.y in C<use 5.x.y> so
3097 can portably C<use 5.10.0> following C<use 5.006> */
3098 PL_v_string_ok = TRUE;
3100 if (!sv_derived_from(PL_patchlevel, "version"))
3101 upg_version(PL_patchlevel, TRUE);
3102 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3103 if ( vcmp(sv,PL_patchlevel) <= 0 )
3104 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3105 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3108 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3111 SV * const req = SvRV(sv);
3112 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3114 /* get the left hand term */
3115 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3117 first = SvIV(*av_fetch(lav,0,0));
3118 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3119 || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3120 || av_len(lav) > 1 /* FP with > 3 digits */
3121 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3123 DIE(aTHX_ "Perl %"SVf" required--this is only "
3124 "%"SVf", stopped", SVfARG(vnormal(req)),
3125 SVfARG(vnormal(PL_patchlevel)));
3127 else { /* probably 'use 5.10' or 'use 5.8' */
3128 SV * hintsv = newSV(0);
3132 second = SvIV(*av_fetch(lav,1,0));
3134 second /= second >= 600 ? 100 : 10;
3135 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3136 (int)first, (int)second,0);
3137 upg_version(hintsv, TRUE);
3139 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3140 "--this is only %"SVf", stopped",
3141 SVfARG(vnormal(req)),
3142 SVfARG(vnormal(hintsv)),
3143 SVfARG(vnormal(PL_patchlevel)));
3148 /* If we request a version >= 5.9.5, load feature.pm with the
3149 * feature bundle that corresponds to the required version.
3150 * We do this only with use, not require. */
3151 if (PL_compcv && 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);
3161 name = SvPV_const(sv, len);
3162 if (!(name && len > 0 && *name))
3163 DIE(aTHX_ "Null filename used");
3164 TAINT_PROPER("require");
3168 /* The key in the %ENV hash is in the syntax of file passed as the argument
3169 * usually this is in UNIX format, but sometimes in VMS format, which
3170 * can result in a module being pulled in more than once.
3171 * To prevent this, the key must be stored in UNIX format if the VMS
3172 * name can be translated to UNIX.
3174 if ((unixname = tounixspec(name, NULL)) != NULL) {
3175 unixlen = strlen(unixname);
3181 /* if not VMS or VMS name can not be translated to UNIX, pass it
3184 unixname = (char *) name;
3187 if (PL_op->op_type == OP_REQUIRE) {
3188 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3189 unixname, unixlen, 0);
3191 if (*svp != &PL_sv_undef)
3194 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3195 "Compilation failed in require", unixname);
3199 /* prepare to compile file */
3201 if (path_is_absolute(name)) {
3203 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3205 #ifdef MACOS_TRADITIONAL
3209 MacPerl_CanonDir(name, newname, 1);
3210 if (path_is_absolute(newname)) {
3212 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3217 AV * const ar = GvAVn(PL_incgv);
3224 for (i = 0; i <= AvFILL(ar); i++) {
3225 SV * const dirsv = *av_fetch(ar, i, TRUE);
3227 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3234 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3235 && !sv_isobject(loader))
3237 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3240 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3241 PTR2UV(SvRV(dirsv)), name);
3242 tryname = SvPVX_const(namesv);
3253 if (sv_isobject(loader))
3254 count = call_method("INC", G_ARRAY);
3256 count = call_sv(loader, G_ARRAY);
3259 /* Adjust file name if the hook has set an %INC entry */
3260 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3262 tryname = SvPVX_const(*svp);
3271 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3272 && !isGV_with_GP(SvRV(arg))) {
3273 filter_cache = SvRV(arg);
3274 SvREFCNT_inc_simple_void_NN(filter_cache);
3281 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3285 if (SvTYPE(arg) == SVt_PVGV) {
3286 IO * const io = GvIO((GV *)arg);
3291 tryrsfp = IoIFP(io);
3292 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3293 PerlIO_close(IoOFP(io));
3304 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3306 SvREFCNT_inc_simple_void_NN(filter_sub);
3309 filter_state = SP[i];
3310 SvREFCNT_inc_simple_void(filter_state);
3314 if (!tryrsfp && (filter_cache || filter_sub)) {
3315 tryrsfp = PerlIO_open(BIT_BUCKET,
3330 filter_has_file = 0;
3332 SvREFCNT_dec(filter_cache);
3333 filter_cache = NULL;
3336 SvREFCNT_dec(filter_state);
3337 filter_state = NULL;
3340 SvREFCNT_dec(filter_sub);
3345 if (!path_is_absolute(name)
3346 #ifdef MACOS_TRADITIONAL
3347 /* We consider paths of the form :a:b ambiguous and interpret them first
3348 as global then as local
3350 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3353 const char *dir = SvOK(dirsv) ? SvPV_nolen_const(dirsv) : "";
3354 #ifdef MACOS_TRADITIONAL
3358 MacPerl_CanonDir(name, buf2, 1);
3359 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3363 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3365 sv_setpv(namesv, unixdir);
3366 sv_catpv(namesv, unixname);
3368 # ifdef __SYMBIAN32__
3369 if (PL_origfilename[0] &&
3370 PL_origfilename[1] == ':' &&
3371 !(dir[0] && dir[1] == ':'))
3372 Perl_sv_setpvf(aTHX_ namesv,
3377 Perl_sv_setpvf(aTHX_ namesv,
3381 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3385 TAINT_PROPER("require");
3386 tryname = SvPVX_const(namesv);
3387 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3389 if (tryname[0] == '.' && tryname[1] == '/')
3393 else if (errno == EMFILE)
3394 /* no point in trying other paths if out of handles */
3401 SAVECOPFILE_FREE(&PL_compiling);
3402 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3403 SvREFCNT_dec(namesv);
3405 if (PL_op->op_type == OP_REQUIRE) {
3406 const char *msgstr = name;
3407 if(errno == EMFILE) {
3409 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3411 msgstr = SvPV_nolen_const(msg);
3413 if (namesv) { /* did we lookup @INC? */
3414 AV * const ar = GvAVn(PL_incgv);
3416 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3417 "%s in @INC%s%s (@INC contains:",
3419 (instr(msgstr, ".h ")
3420 ? " (change .h to .ph maybe?)" : ""),
3421 (instr(msgstr, ".ph ")
3422 ? " (did you run h2ph?)" : "")
3425 for (i = 0; i <= AvFILL(ar); i++) {
3426 sv_catpvs(msg, " ");
3427 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3429 sv_catpvs(msg, ")");
3430 msgstr = SvPV_nolen_const(msg);
3433 DIE(aTHX_ "Can't locate %s", msgstr);
3439 SETERRNO(0, SS_NORMAL);
3441 /* Assume success here to prevent recursive requirement. */
3442 /* name is never assigned to again, so len is still strlen(name) */
3443 /* Check whether a hook in @INC has already filled %INC */
3445 (void)hv_store(GvHVn(PL_incgv),
3446 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3448 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3450 (void)hv_store(GvHVn(PL_incgv),
3451 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3456 lex_start(NULL, tryrsfp, TRUE);
3460 SAVECOMPILEWARNINGS();
3461 if (PL_dowarn & G_WARN_ALL_ON)
3462 PL_compiling.cop_warnings = pWARN_ALL ;
3463 else if (PL_dowarn & G_WARN_ALL_OFF)
3464 PL_compiling.cop_warnings = pWARN_NONE ;
3466 PL_compiling.cop_warnings = pWARN_STD ;
3468 if (filter_sub || filter_cache) {
3469 SV * const datasv = filter_add(S_run_user_filter, NULL);
3470 IoLINES(datasv) = filter_has_file;
3471 IoTOP_GV(datasv) = (GV *)filter_state;
3472 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3473 IoFMT_GV(datasv) = (GV *)filter_cache;
3476 /* switch to eval mode */
3477 PUSHBLOCK(cx, CXt_EVAL, SP);
3478 PUSHEVAL(cx, name, NULL);
3479 cx->blk_eval.retop = PL_op->op_next;
3481 SAVECOPLINE(&PL_compiling);
3482 CopLINE_set(&PL_compiling, 0);
3486 /* Store and reset encoding. */
3487 encoding = PL_encoding;
3490 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3491 op = DOCATCH(PL_eval_start);
3493 op = PL_op->op_next;
3495 /* Restore encoding. */
3496 PL_encoding = encoding;
3504 register PERL_CONTEXT *cx;
3506 const I32 gimme = GIMME_V;
3507 const I32 was = PL_sub_generation;
3508 char tbuf[TYPE_DIGITS(long) + 12];
3509 char *tmpbuf = tbuf;
3515 HV *saved_hh = NULL;
3516 const char * const fakestr = "_<(eval )";
3517 const int fakelen = 9 + 1;
3519 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3520 saved_hh = (HV*) SvREFCNT_inc(POPs);
3524 TAINT_IF(SvTAINTED(sv));
3525 TAINT_PROPER("eval");
3528 lex_start(sv, NULL, FALSE);
3531 /* switch to eval mode */
3533 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3534 SV * const temp_sv = sv_newmortal();
3535 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3536 (unsigned long)++PL_evalseq,
3537 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3538 tmpbuf = SvPVX(temp_sv);
3539 len = SvCUR(temp_sv);
3542 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3543 SAVECOPFILE_FREE(&PL_compiling);
3544 CopFILE_set(&PL_compiling, tmpbuf+2);
3545 SAVECOPLINE(&PL_compiling);
3546 CopLINE_set(&PL_compiling, 1);
3547 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3548 deleting the eval's FILEGV from the stash before gv_check() runs
3549 (i.e. before run-time proper). To work around the coredump that
3550 ensues, we always turn GvMULTI_on for any globals that were
3551 introduced within evals. See force_ident(). GSAR 96-10-12 */
3552 safestr = savepvn(tmpbuf, len);
3553 SAVEDELETE(PL_defstash, safestr, len);
3555 PL_hints = PL_op->op_targ;
3557 GvHV(PL_hintgv) = saved_hh;
3558 SAVECOMPILEWARNINGS();
3559 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3560 if (PL_compiling.cop_hints_hash) {
3561 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3563 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3564 if (PL_compiling.cop_hints_hash) {
3566 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3567 HINTS_REFCNT_UNLOCK;
3569 /* special case: an eval '' executed within the DB package gets lexically
3570 * placed in the first non-DB CV rather than the current CV - this
3571 * allows the debugger to execute code, find lexicals etc, in the
3572 * scope of the code being debugged. Passing &seq gets find_runcv
3573 * to do the dirty work for us */
3574 runcv = find_runcv(&seq);
3576 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3577 PUSHEVAL(cx, 0, NULL);
3578 cx->blk_eval.retop = PL_op->op_next;
3580 /* prepare to compile string */
3582 if (PERLDB_LINE && PL_curstash != PL_debstash)
3583 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3585 ok = doeval(gimme, NULL, runcv, seq);
3586 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3588 /* Copy in anything fake and short. */
3589 my_strlcpy(safestr, fakestr, fakelen);
3591 return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3601 register PERL_CONTEXT *cx;
3603 const U8 save_flags = PL_op -> op_flags;
3608 retop = cx->blk_eval.retop;
3611 if (gimme == G_VOID)
3613 else if (gimme == G_SCALAR) {
3616 if (SvFLAGS(TOPs) & SVs_TEMP)
3619 *MARK = sv_mortalcopy(TOPs);
3623 *MARK = &PL_sv_undef;
3628 /* in case LEAVE wipes old return values */
3629 for (mark = newsp + 1; mark <= SP; mark++) {
3630 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3631 *mark = sv_mortalcopy(*mark);
3632 TAINT_NOT; /* Each item is independent */
3636 PL_curpm = newpm; /* Don't pop $1 et al till now */
3639 assert(CvDEPTH(PL_compcv) == 1);
3641 CvDEPTH(PL_compcv) = 0;
3644 if (optype == OP_REQUIRE &&
3645 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3647 /* Unassume the success we assumed earlier. */
3648 SV * const nsv = cx->blk_eval.old_namesv;
3649 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3650 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3651 /* die_where() did LEAVE, or we won't be here */
3655 if (!(save_flags & OPf_SPECIAL))
3656 sv_setpvn(ERRSV,"",0);
3662 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3663 close to the related Perl_create_eval_scope. */
3665 Perl_delete_eval_scope(pTHX)
3670 register PERL_CONTEXT *cx;
3677 PERL_UNUSED_VAR(newsp);
3678 PERL_UNUSED_VAR(gimme);
3679 PERL_UNUSED_VAR(optype);
3682 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3683 also needed by Perl_fold_constants. */
3685 Perl_create_eval_scope(pTHX_ U32 flags)
3688 const I32 gimme = GIMME_V;
3693 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3696 PL_in_eval = EVAL_INEVAL;
3697 if (flags & G_KEEPERR)
3698 PL_in_eval |= EVAL_KEEPERR;
3700 sv_setpvn(ERRSV,"",0);
3701 if (flags & G_FAKINGEVAL) {
3702 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3710 PERL_CONTEXT * const cx = create_eval_scope(0);
3711 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3712 return DOCATCH(PL_op->op_next);
3721 register PERL_CONTEXT *cx;
3726 PERL_UNUSED_VAR(optype);
3729 if (gimme == G_VOID)
3731 else if (gimme == G_SCALAR) {
3735 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3738 *MARK = sv_mortalcopy(TOPs);
3742 *MARK = &PL_sv_undef;
3747 /* in case LEAVE wipes old return values */
3749 for (mark = newsp + 1; mark <= SP; mark++) {
3750 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3751 *mark = sv_mortalcopy(*mark);
3752 TAINT_NOT; /* Each item is independent */
3756 PL_curpm = newpm; /* Don't pop $1 et al till now */
3759 sv_setpvn(ERRSV,"",0);
3766 register PERL_CONTEXT *cx;
3767 const I32 gimme = GIMME_V;
3772 if (PL_op->op_targ == 0) {
3773 SV ** const defsv_p = &GvSV(PL_defgv);
3774 *defsv_p = newSVsv(POPs);
3775 SAVECLEARSV(*defsv_p);
3778 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3780 PUSHBLOCK(cx, CXt_GIVEN, SP);
3789 register PERL_CONTEXT *cx;
3793 PERL_UNUSED_CONTEXT;
3796 assert(CxTYPE(cx) == CXt_GIVEN);
3801 PL_curpm = newpm; /* pop $1 et al */
3808 /* Helper routines used by pp_smartmatch */
3810 S_make_matcher(pTHX_ regexp *re)
3813 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3814 PM_SETRE(matcher, ReREFCNT_inc(re));
3816 SAVEFREEOP((OP *) matcher);
3823 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3828 PL_op = (OP *) matcher;
3833 return (SvTRUEx(POPs));
3837 S_destroy_matcher(pTHX_ PMOP *matcher)
3840 PERL_UNUSED_ARG(matcher);
3845 /* Do a smart match */
3848 return do_smartmatch(NULL, NULL);
3851 /* This version of do_smartmatch() implements the
3852 * table of smart matches that is found in perlsyn.
3855 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3860 SV *e = TOPs; /* e is for 'expression' */
3861 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3862 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3864 regexp *this_regex, *other_regex;
3866 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3868 # define SM_REF(type) ( \
3869 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3870 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3872 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3873 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
3874 && NOT_EMPTY_PROTO(This) && (Other = e)) \
3875 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
3876 && NOT_EMPTY_PROTO(This) && (Other = d)))
3878 # define SM_REGEX ( \
3879 (SvROK(d) && SvMAGICAL(This = SvRV(d)) \
3880 && (mg = mg_find(This, PERL_MAGIC_qr)) \
3881 && (this_regex = (regexp *)mg->mg_obj) \
3884 (SvROK(e) && SvMAGICAL(This = SvRV(e)) \
3885 && (mg = mg_find(This, PERL_MAGIC_qr)) \
3886 && (this_regex = (regexp *)mg->mg_obj) \
3890 # define SM_OTHER_REF(type) \
3891 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3893 # define SM_OTHER_REGEX (SvROK(Other) && SvMAGICAL(SvRV(Other)) \
3894 && (mg = mg_find(SvRV(Other), PERL_MAGIC_qr)) \
3895 && (other_regex = (regexp *)mg->mg_obj))
3898 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3899 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3901 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3902 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3904 tryAMAGICbinSET(smart, 0);
3906 SP -= 2; /* Pop the values */
3908 /* Take care only to invoke mg_get() once for each argument.
3909 * Currently we do this by copying the SV if it's magical. */
3912 d = sv_mortalcopy(d);
3919 e = sv_mortalcopy(e);
3924 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3926 if (This == SvRV(Other))
3937 c = call_sv(This, G_SCALAR);
3941 else if (SvTEMP(TOPs))
3942 SvREFCNT_inc_void(TOPs);
3947 else if (SM_REF(PVHV)) {
3948 if (SM_OTHER_REF(PVHV)) {
3949 /* Check that the key-sets are identical */
3951 HV *other_hv = (HV *) SvRV(Other);
3953 bool other_tied = FALSE;
3954 U32 this_key_count = 0,
3955 other_key_count = 0;
3957 /* Tied hashes don't know how many keys they have. */
3958 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
3961 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3962 HV * const temp = other_hv;
3963 other_hv = (HV *) This;
3967 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3970 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
3973 /* The hashes have the same number of keys, so it suffices
3974 to check that one is a subset of the other. */
3975 (void) hv_iterinit((HV *) This);
3976 while ( (he = hv_iternext((HV *) This)) ) {
3978 char * const key = hv_iterkey(he, &key_len);
3982 if(!hv_exists(other_hv, key, key_len)) {
3983 (void) hv_iterinit((HV *) This); /* reset iterator */
3989 (void) hv_iterinit(other_hv);
3990 while ( hv_iternext(other_hv) )
3994 other_key_count = HvUSEDKEYS(other_hv);
3996 if (this_key_count != other_key_count)
4001 else if (SM_OTHER_REF(PVAV)) {
4002 AV * const other_av = (AV *) SvRV(Other);
4003 const I32 other_len = av_len(other_av) + 1;
4006 if (HvUSEDKEYS((HV *) This) != other_len)
4009 for(i = 0; i < other_len; ++i) {
4010 SV ** const svp = av_fetch(other_av, i, FALSE);
4014 if (!svp) /* ??? When can this happen? */
4017 key = SvPV(*svp, key_len);
4018 if(!hv_exists((HV *) This, key, key_len))
4023 else if (SM_OTHER_REGEX) {
4024 PMOP * const matcher = make_matcher(other_regex);
4027 (void) hv_iterinit((HV *) This);
4028 while ( (he = hv_iternext((HV *) This)) ) {
4029 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4030 (void) hv_iterinit((HV *) This);
4031 destroy_matcher(matcher);
4035 destroy_matcher(matcher);
4039 if (hv_exists_ent((HV *) This, Other, 0))
4045 else if (SM_REF(PVAV)) {
4046 if (SM_OTHER_REF(PVAV)) {
4047 AV *other_av = (AV *) SvRV(Other);
4048 if (av_len((AV *) This) != av_len(other_av))
4052 const I32 other_len = av_len(other_av);
4054 if (NULL == seen_this) {
4055 seen_this = newHV();
4056 (void) sv_2mortal((SV *) seen_this);
4058 if (NULL == seen_other) {
4059 seen_this = newHV();
4060 (void) sv_2mortal((SV *) seen_other);
4062 for(i = 0; i <= other_len; ++i) {
4063 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4064 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4066 if (!this_elem || !other_elem) {
4067 if (this_elem || other_elem)
4070 else if (SM_SEEN_THIS(*this_elem)
4071 || SM_SEEN_OTHER(*other_elem))
4073 if (*this_elem != *other_elem)
4077 (void)hv_store_ent(seen_this,
4078 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4080 (void)hv_store_ent(seen_other,
4081 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4087 (void) do_smartmatch(seen_this, seen_other);
4097 else if (SM_OTHER_REGEX) {
4098 PMOP * const matcher = make_matcher(other_regex);
4099 const I32 this_len = av_len((AV *) This);
4102 for(i = 0; i <= this_len; ++i) {
4103 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4104 if (svp && matcher_matches_sv(matcher, *svp)) {
4105 destroy_matcher(matcher);
4109 destroy_matcher(matcher);
4112 else if (SvIOK(Other) || SvNOK(Other)) {
4115 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4116 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4123 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4133 else if (SvPOK(Other)) {
4134 const I32 this_len = av_len((AV *) This);
4137 for(i = 0; i <= this_len; ++i) {
4138 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4153 else if (!SvOK(d) || !SvOK(e)) {
4154 if (!SvOK(d) && !SvOK(e))
4159 else if (SM_REGEX) {
4160 PMOP * const matcher = make_matcher(this_regex);
4163 PUSHs(matcher_matches_sv(matcher, Other)
4166 destroy_matcher(matcher);
4169 else if (SM_REF(PVCV)) {
4171 /* This must be a null-prototyped sub, because we
4172 already checked for the other kind. */
4178 c = call_sv(This, G_SCALAR);
4181 PUSHs(&PL_sv_undef);
4182 else if (SvTEMP(TOPs))
4183 SvREFCNT_inc_void(TOPs);
4185 if (SM_OTHER_REF(PVCV)) {
4186 /* This one has to be null-proto'd too.
4187 Call both of 'em, and compare the results */
4189 c = call_sv(SvRV(Other), G_SCALAR);
4192 PUSHs(&PL_sv_undef);
4193 else if (SvTEMP(TOPs))
4194 SvREFCNT_inc_void(TOPs);
4205 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4206 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4208 if (SvPOK(Other) && !looks_like_number(Other)) {
4209 /* String comparison */
4214 /* Otherwise, numeric comparison */
4217 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4228 /* As a last resort, use string comparison */
4237 register PERL_CONTEXT *cx;
4238 const I32 gimme = GIMME_V;
4240 /* This is essentially an optimization: if the match
4241 fails, we don't want to push a context and then
4242 pop it again right away, so we skip straight
4243 to the op that follows the leavewhen.
4245 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4246 return cLOGOP->op_other->op_next;
4251 PUSHBLOCK(cx, CXt_WHEN, SP);
4260 register PERL_CONTEXT *cx;
4266 assert(CxTYPE(cx) == CXt_WHEN);
4271 PL_curpm = newpm; /* pop $1 et al */
4281 register PERL_CONTEXT *cx;
4284 cxix = dopoptowhen(cxstack_ix);
4286 DIE(aTHX_ "Can't \"continue\" outside a when block");
4287 if (cxix < cxstack_ix)
4290 /* clear off anything above the scope we're re-entering */
4291 inner = PL_scopestack_ix;
4293 if (PL_scopestack_ix < inner)
4294 leave_scope(PL_scopestack[PL_scopestack_ix]);
4295 PL_curcop = cx->blk_oldcop;
4296 return cx->blk_givwhen.leave_op;
4303 register PERL_CONTEXT *cx;
4306 cxix = dopoptogiven(cxstack_ix);
4308 if (PL_op->op_flags & OPf_SPECIAL)
4309 DIE(aTHX_ "Can't use when() outside a topicalizer");
4311 DIE(aTHX_ "Can't \"break\" outside a given block");
4313 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4314 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4316 if (cxix < cxstack_ix)
4319 /* clear off anything above the scope we're re-entering */
4320 inner = PL_scopestack_ix;
4322 if (PL_scopestack_ix < inner)
4323 leave_scope(PL_scopestack[PL_scopestack_ix]);
4324 PL_curcop = cx->blk_oldcop;
4327 return CX_LOOP_NEXTOP_GET(cx);
4329 return cx->blk_givwhen.leave_op;
4333 S_doparseform(pTHX_ SV *sv)
4336 register char *s = SvPV_force(sv, len);
4337 register char * const send = s + len;
4338 register char *base = NULL;
4339 register I32 skipspaces = 0;
4340 bool noblank = FALSE;
4341 bool repeat = FALSE;
4342 bool postspace = FALSE;
4348 bool unchopnum = FALSE;
4349 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4352 Perl_croak(aTHX_ "Null picture in formline");
4354 /* estimate the buffer size needed */
4355 for (base = s; s <= send; s++) {
4356 if (*s == '\n' || *s == '@' || *s == '^')
4362 Newx(fops, maxops, U32);
4367 *fpc++ = FF_LINEMARK;
4368 noblank = repeat = FALSE;
4386 case ' ': case '\t':
4393 } /* else FALL THROUGH */
4401 *fpc++ = FF_LITERAL;
4409 *fpc++ = (U16)skipspaces;
4413 *fpc++ = FF_NEWLINE;
4417 arg = fpc - linepc + 1;
4424 *fpc++ = FF_LINEMARK;
4425 noblank = repeat = FALSE;
4434 ischop = s[-1] == '^';
4440 arg = (s - base) - 1;
4442 *fpc++ = FF_LITERAL;
4450 *fpc++ = 2; /* skip the @* or ^* */
4452 *fpc++ = FF_LINESNGL;
4455 *fpc++ = FF_LINEGLOB;
4457 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4458 arg = ischop ? 512 : 0;
4463 const char * const f = ++s;
4466 arg |= 256 + (s - f);
4468 *fpc++ = s - base; /* fieldsize for FETCH */
4469 *fpc++ = FF_DECIMAL;
4471 unchopnum |= ! ischop;
4473 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4474 arg = ischop ? 512 : 0;
4476 s++; /* skip the '0' first */
4480 const char * const f = ++s;
4483 arg |= 256 + (s - f);
4485 *fpc++ = s - base; /* fieldsize for FETCH */
4486 *fpc++ = FF_0DECIMAL;
4488 unchopnum |= ! ischop;
4492 bool ismore = FALSE;
4495 while (*++s == '>') ;
4496 prespace = FF_SPACE;
4498 else if (*s == '|') {
4499 while (*++s == '|') ;
4500 prespace = FF_HALFSPACE;
4505 while (*++s == '<') ;
4508 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4512 *fpc++ = s - base; /* fieldsize for FETCH */
4514 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4517 *fpc++ = (U16)prespace;
4531 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4533 { /* need to jump to the next word */
4535 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4536 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4537 s = SvPVX(sv) + SvCUR(sv) + z;
4539 Copy(fops, s, arg, U32);
4541 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4544 if (unchopnum && repeat)
4545 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4551 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4553 /* Can value be printed in fldsize chars, using %*.*f ? */
4557 int intsize = fldsize - (value < 0 ? 1 : 0);
4564 while (intsize--) pwr *= 10.0;
4565 while (frcsize--) eps /= 10.0;
4568 if (value + eps >= pwr)
4571 if (value - eps <= -pwr)
4578 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4581 SV * const datasv = FILTER_DATA(idx);
4582 const int filter_has_file = IoLINES(datasv);
4583 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4584 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4588 const char *got_p = NULL;
4589 const char *prune_from = NULL;
4590 bool read_from_cache = FALSE;
4593 assert(maxlen >= 0);
4596 /* I was having segfault trouble under Linux 2.2.5 after a
4597 parse error occured. (Had to hack around it with a test
4598 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4599 not sure where the trouble is yet. XXX */
4601 if (IoFMT_GV(datasv)) {
4602 SV *const cache = (SV *)IoFMT_GV(datasv);
4605 const char *cache_p = SvPV(cache, cache_len);
4609 /* Running in block mode and we have some cached data already.
4611 if (cache_len >= umaxlen) {
4612 /* In fact, so much data we don't even need to call
4617 const char *const first_nl =
4618 (const char *)memchr(cache_p, '\n', cache_len);
4620 take = first_nl + 1 - cache_p;
4624 sv_catpvn(buf_sv, cache_p, take);
4625 sv_chop(cache, cache_p + take);
4626 /* Definately not EOF */
4630 sv_catsv(buf_sv, cache);
4632 umaxlen -= cache_len;
4635 read_from_cache = TRUE;
4639 /* Filter API says that the filter appends to the contents of the buffer.
4640 Usually the buffer is "", so the details don't matter. But if it's not,
4641 then clearly what it contains is already filtered by this filter, so we
4642 don't want to pass it in a second time.
4643 I'm going to use a mortal in case the upstream filter croaks. */
4644 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4645 ? sv_newmortal() : buf_sv;
4646 SvUPGRADE(upstream, SVt_PV);
4648 if (filter_has_file) {
4649 status = FILTER_READ(idx+1, upstream, 0);
4652 if (filter_sub && status >= 0) {
4663 PUSHs(sv_2mortal(newSViv(0)));
4665 PUSHs(filter_state);
4668 count = call_sv(filter_sub, G_SCALAR);
4683 if(SvOK(upstream)) {
4684 got_p = SvPV(upstream, got_len);
4686 if (got_len > umaxlen) {
4687 prune_from = got_p + umaxlen;
4690 const char *const first_nl =
4691 (const char *)memchr(got_p, '\n', got_len);
4692 if (first_nl && first_nl + 1 < got_p + got_len) {
4693 /* There's a second line here... */
4694 prune_from = first_nl + 1;
4699 /* Oh. Too long. Stuff some in our cache. */
4700 STRLEN cached_len = got_p + got_len - prune_from;
4701 SV *cache = (SV *)IoFMT_GV(datasv);
4704 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4705 } else if (SvOK(cache)) {
4706 /* Cache should be empty. */
4707 assert(!SvCUR(cache));
4710 sv_setpvn(cache, prune_from, cached_len);
4711 /* If you ask for block mode, you may well split UTF-8 characters.
4712 "If it breaks, you get to keep both parts"
4713 (Your code is broken if you don't put them back together again
4714 before something notices.) */
4715 if (SvUTF8(upstream)) {
4718 SvCUR_set(upstream, got_len - cached_len);
4719 /* Can't yet be EOF */
4724 /* If they are at EOF but buf_sv has something in it, then they may never
4725 have touched the SV upstream, so it may be undefined. If we naively
4726 concatenate it then we get a warning about use of uninitialised value.
4728 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4729 sv_catsv(buf_sv, upstream);
4733 IoLINES(datasv) = 0;
4734 SvREFCNT_dec(IoFMT_GV(datasv));
4736 SvREFCNT_dec(filter_state);
4737 IoTOP_GV(datasv) = NULL;
4740 SvREFCNT_dec(filter_sub);
4741 IoBOTTOM_GV(datasv) = NULL;
4743 filter_del(S_run_user_filter);
4745 if (status == 0 && read_from_cache) {
4746 /* If we read some data from the cache (and by getting here it implies
4747 that we emptied the cache) then we aren't yet at EOF, and mustn't
4748 report that to our caller. */
4754 /* perhaps someone can come up with a better name for
4755 this? it is not really "absolute", per se ... */
4757 S_path_is_absolute(const char *name)
4759 if (PERL_FILE_IS_ABSOLUTE(name)
4760 #ifdef MACOS_TRADITIONAL
4763 || (*name == '.' && (name[1] == '/' ||
4764 (name[1] == '.' && name[2] == '/')))
4776 * c-indentation-style: bsd
4778 * indent-tabs-mode: t
4781 * ex: set ts=8 sts=4 sw=4 noet: