3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
20 /* This file contains control-oriented pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
26 * Control-oriented means things like pp_enteriter() and pp_next(), which
27 * alter the flow of control of the program.
32 #define PERL_IN_PP_CTL_C
36 #define WORD_ALIGN sizeof(U32)
39 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
41 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
50 cxix = dopoptosub(cxstack_ix);
54 switch (cxstack[cxix].blk_gimme) {
67 /* XXXX Should store the old value to allow for tie/overload - and
68 restore in regcomp, where marked with XXXX. */
78 register PMOP *pm = (PMOP*)cLOGOP->op_other;
82 /* prevent recompiling under /o and ithreads. */
83 #if defined(USE_ITHREADS)
84 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
85 if (PL_op->op_flags & OPf_STACKED) {
94 if (PL_op->op_flags & OPf_STACKED) {
95 /* multiple args; concatentate them */
97 tmpstr = PAD_SV(ARGTARG);
98 sv_setpvn(tmpstr, "", 0);
99 while (++MARK <= SP) {
100 if (PL_amagic_generation) {
102 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
103 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
105 sv_setsv(tmpstr, sv);
109 sv_catsv(tmpstr, *MARK);
118 SV * const sv = SvRV(tmpstr);
119 if (SvTYPE(sv) == SVt_REGEXP)
120 re = ((struct xregexp *)SvANY(sv))->xrx_regexp;
123 re = reg_temp_copy(re);
124 ReREFCNT_dec(PM_GETRE(pm));
129 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
132 /* Check against the last compiled regexp. */
133 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != (I32)len ||
134 memNE(RX_PRECOMP(re), t, len))
136 const regexp_engine *eng = re ? re->engine : NULL;
137 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
140 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
141 } else if (PL_curcop->cop_hints_hash) {
142 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
144 if (ptr && SvIOK(ptr) && SvIV(ptr))
145 eng = INT2PTR(regexp_engine*,SvIV(ptr));
148 if (PL_op->op_flags & OPf_SPECIAL)
149 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
152 pm_flags |= RXf_UTF8;
155 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
157 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
159 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
160 inside tie/overload accessors. */
166 #ifndef INCOMPLETE_TAINTS
169 re->extflags |= RXf_TAINTED;
171 re->extflags &= ~RXf_TAINTED;
175 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
179 #if !defined(USE_ITHREADS)
180 /* can't change the optree at runtime either */
181 /* PMf_KEEP is handled differently under threads to avoid these problems */
182 if (pm->op_pmflags & PMf_KEEP) {
183 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
184 cLOGOP->op_first->op_next = PL_op->op_next;
194 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
195 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
196 register SV * const dstr = cx->sb_dstr;
197 register char *s = cx->sb_s;
198 register char *m = cx->sb_m;
199 char *orig = cx->sb_orig;
200 register REGEXP * const rx = cx->sb_rx;
202 REGEXP *old = PM_GETRE(pm);
206 PM_SETRE(pm,ReREFCNT_inc(rx));
209 rxres_restore(&cx->sb_rxres, rx);
210 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
212 if (cx->sb_iters++) {
213 const I32 saviters = cx->sb_iters;
214 if (cx->sb_iters > cx->sb_maxiters)
215 DIE(aTHX_ "Substitution loop");
217 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
218 cx->sb_rxtainted |= 2;
219 sv_catsv(dstr, POPs);
220 FREETMPS; /* Prevent excess tmp stack */
223 if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
224 s == m, cx->sb_targ, NULL,
225 ((cx->sb_rflags & REXEC_COPY_STR)
226 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
227 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
229 SV * const targ = cx->sb_targ;
231 assert(cx->sb_strend >= s);
232 if(cx->sb_strend > s) {
233 if (DO_UTF8(dstr) && !SvUTF8(targ))
234 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
236 sv_catpvn(dstr, s, cx->sb_strend - s);
238 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
240 #ifdef PERL_OLD_COPY_ON_WRITE
242 sv_force_normal_flags(targ, SV_COW_DROP_PV);
248 SvPV_set(targ, SvPVX(dstr));
249 SvCUR_set(targ, SvCUR(dstr));
250 SvLEN_set(targ, SvLEN(dstr));
253 SvPV_set(dstr, NULL);
255 TAINT_IF(cx->sb_rxtainted & 1);
256 PUSHs(sv_2mortal(newSViv(saviters - 1)));
258 (void)SvPOK_only_UTF8(targ);
259 TAINT_IF(cx->sb_rxtainted);
263 LEAVE_SCOPE(cx->sb_oldsave);
265 RETURNOP(pm->op_next);
267 cx->sb_iters = saviters;
269 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
272 cx->sb_orig = orig = rx->subbeg;
274 cx->sb_strend = s + (cx->sb_strend - m);
276 cx->sb_m = m = rx->offs[0].start + orig;
278 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
279 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
281 sv_catpvn(dstr, s, m-s);
283 cx->sb_s = rx->offs[0].end + orig;
284 { /* Update the pos() information. */
285 SV * const sv = cx->sb_targ;
288 SvUPGRADE(sv, SVt_PVMG);
289 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
290 #ifdef PERL_OLD_COPY_ON_WRITE
292 sv_force_normal_flags(sv, 0);
294 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
303 (void)ReREFCNT_inc(rx);
304 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
305 rxres_save(&cx->sb_rxres, rx);
306 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
310 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
316 if (!p || p[1] < rx->nparens) {
317 #ifdef PERL_OLD_COPY_ON_WRITE
318 i = 7 + rx->nparens * 2;
320 i = 6 + rx->nparens * 2;
329 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : NULL);
330 RX_MATCH_COPIED_off(rx);
332 #ifdef PERL_OLD_COPY_ON_WRITE
333 *p++ = PTR2UV(rx->saved_copy);
334 rx->saved_copy = NULL;
339 *p++ = PTR2UV(rx->subbeg);
340 *p++ = (UV)rx->sublen;
341 for (i = 0; i <= rx->nparens; ++i) {
342 *p++ = (UV)rx->offs[i].start;
343 *p++ = (UV)rx->offs[i].end;
348 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
354 RX_MATCH_COPY_FREE(rx);
355 RX_MATCH_COPIED_set(rx, *p);
358 #ifdef PERL_OLD_COPY_ON_WRITE
360 SvREFCNT_dec (rx->saved_copy);
361 rx->saved_copy = INT2PTR(SV*,*p);
367 rx->subbeg = INT2PTR(char*,*p++);
368 rx->sublen = (I32)(*p++);
369 for (i = 0; i <= rx->nparens; ++i) {
370 rx->offs[i].start = (I32)(*p++);
371 rx->offs[i].end = (I32)(*p++);
376 Perl_rxres_free(pTHX_ void **rsp)
378 UV * const p = (UV*)*rsp;
383 void *tmp = INT2PTR(char*,*p);
386 PoisonFree(*p, 1, sizeof(*p));
388 Safefree(INT2PTR(char*,*p));
390 #ifdef PERL_OLD_COPY_ON_WRITE
392 SvREFCNT_dec (INT2PTR(SV*,p[1]));
402 dVAR; dSP; dMARK; dORIGMARK;
403 register SV * const tmpForm = *++MARK;
408 register SV *sv = NULL;
409 const char *item = NULL;
413 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
414 const char *chophere = NULL;
415 char *linemark = NULL;
417 bool gotsome = FALSE;
419 const STRLEN fudge = SvPOK(tmpForm)
420 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
421 bool item_is_utf8 = FALSE;
422 bool targ_is_utf8 = FALSE;
424 OP * parseres = NULL;
428 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
429 if (SvREADONLY(tmpForm)) {
430 SvREADONLY_off(tmpForm);
431 parseres = doparseform(tmpForm);
432 SvREADONLY_on(tmpForm);
435 parseres = doparseform(tmpForm);
439 SvPV_force(PL_formtarget, len);
440 if (DO_UTF8(PL_formtarget))
442 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
444 f = SvPV_const(tmpForm, len);
445 /* need to jump to the next word */
446 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
450 const char *name = "???";
453 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
454 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
455 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
456 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
457 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
459 case FF_CHECKNL: name = "CHECKNL"; break;
460 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
461 case FF_SPACE: name = "SPACE"; break;
462 case FF_HALFSPACE: name = "HALFSPACE"; break;
463 case FF_ITEM: name = "ITEM"; break;
464 case FF_CHOP: name = "CHOP"; break;
465 case FF_LINEGLOB: name = "LINEGLOB"; break;
466 case FF_NEWLINE: name = "NEWLINE"; break;
467 case FF_MORE: name = "MORE"; break;
468 case FF_LINEMARK: name = "LINEMARK"; break;
469 case FF_END: name = "END"; break;
470 case FF_0DECIMAL: name = "0DECIMAL"; break;
471 case FF_LINESNGL: name = "LINESNGL"; break;
474 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
476 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
487 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
488 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
490 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
491 t = SvEND(PL_formtarget);
494 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
495 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
497 sv_utf8_upgrade(PL_formtarget);
498 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
499 t = SvEND(PL_formtarget);
519 if (ckWARN(WARN_SYNTAX))
520 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
527 const char *s = item = SvPV_const(sv, len);
530 itemsize = sv_len_utf8(sv);
531 if (itemsize != (I32)len) {
533 if (itemsize > fieldsize) {
534 itemsize = fieldsize;
535 itembytes = itemsize;
536 sv_pos_u2b(sv, &itembytes, 0);
540 send = chophere = s + itembytes;
550 sv_pos_b2u(sv, &itemsize);
554 item_is_utf8 = FALSE;
555 if (itemsize > fieldsize)
556 itemsize = fieldsize;
557 send = chophere = s + itemsize;
571 const char *s = item = SvPV_const(sv, len);
574 itemsize = sv_len_utf8(sv);
575 if (itemsize != (I32)len) {
577 if (itemsize <= fieldsize) {
578 const char *send = chophere = s + itemsize;
591 itemsize = fieldsize;
592 itembytes = itemsize;
593 sv_pos_u2b(sv, &itembytes, 0);
594 send = chophere = s + itembytes;
595 while (s < send || (s == send && isSPACE(*s))) {
605 if (strchr(PL_chopset, *s))
610 itemsize = chophere - item;
611 sv_pos_b2u(sv, &itemsize);
617 item_is_utf8 = FALSE;
618 if (itemsize <= fieldsize) {
619 const char *const send = chophere = s + itemsize;
632 itemsize = fieldsize;
633 send = chophere = s + itemsize;
634 while (s < send || (s == send && isSPACE(*s))) {
644 if (strchr(PL_chopset, *s))
649 itemsize = chophere - item;
655 arg = fieldsize - itemsize;
664 arg = fieldsize - itemsize;
675 const char *s = item;
679 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
681 sv_utf8_upgrade(PL_formtarget);
682 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
683 t = SvEND(PL_formtarget);
687 if (UTF8_IS_CONTINUED(*s)) {
688 STRLEN skip = UTF8SKIP(s);
705 if ( !((*t++ = *s++) & ~31) )
711 if (targ_is_utf8 && !item_is_utf8) {
712 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
714 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
715 for (; t < SvEND(PL_formtarget); t++) {
728 const int ch = *t++ = *s++;
731 if ( !((*t++ = *s++) & ~31) )
740 const char *s = chophere;
758 const char *s = item = SvPV_const(sv, len);
760 if ((item_is_utf8 = DO_UTF8(sv)))
761 itemsize = sv_len_utf8(sv);
763 bool chopped = FALSE;
764 const char *const send = s + len;
766 chophere = s + itemsize;
782 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
784 SvUTF8_on(PL_formtarget);
786 SvCUR_set(sv, chophere - item);
787 sv_catsv(PL_formtarget, sv);
788 SvCUR_set(sv, itemsize);
790 sv_catsv(PL_formtarget, sv);
792 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
793 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
794 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
803 #if defined(USE_LONG_DOUBLE)
806 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
810 "%#0*.*f" : "%0*.*f");
815 #if defined(USE_LONG_DOUBLE)
817 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
820 ((arg & 256) ? "%#*.*f" : "%*.*f");
823 /* If the field is marked with ^ and the value is undefined,
825 if ((arg & 512) && !SvOK(sv)) {
833 /* overflow evidence */
834 if (num_overflow(value, fieldsize, arg)) {
840 /* Formats aren't yet marked for locales, so assume "yes". */
842 STORE_NUMERIC_STANDARD_SET_LOCAL();
843 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
844 RESTORE_NUMERIC_STANDARD();
851 while (t-- > linemark && *t == ' ') ;
859 if (arg) { /* repeat until fields exhausted? */
861 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
862 lines += FmLINES(PL_formtarget);
865 if (strnEQ(linemark, linemark - arg, arg))
866 DIE(aTHX_ "Runaway format");
869 SvUTF8_on(PL_formtarget);
870 FmLINES(PL_formtarget) = lines;
872 RETURNOP(cLISTOP->op_first);
883 const char *s = chophere;
884 const char *send = item + len;
886 while (isSPACE(*s) && (s < send))
891 arg = fieldsize - itemsize;
898 if (strnEQ(s1," ",3)) {
899 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
910 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
912 SvUTF8_on(PL_formtarget);
913 FmLINES(PL_formtarget) += lines;
925 if (PL_stack_base + *PL_markstack_ptr == SP) {
927 if (GIMME_V == G_SCALAR)
928 XPUSHs(sv_2mortal(newSViv(0)));
929 RETURNOP(PL_op->op_next->op_next);
931 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
932 pp_pushmark(); /* push dst */
933 pp_pushmark(); /* push src */
934 ENTER; /* enter outer scope */
937 if (PL_op->op_private & OPpGREP_LEX)
938 SAVESPTR(PAD_SVl(PL_op->op_targ));
941 ENTER; /* enter inner scope */
944 src = PL_stack_base[*PL_markstack_ptr];
946 if (PL_op->op_private & OPpGREP_LEX)
947 PAD_SVl(PL_op->op_targ) = src;
952 if (PL_op->op_type == OP_MAPSTART)
953 pp_pushmark(); /* push top */
954 return ((LOGOP*)PL_op->op_next)->op_other;
960 const I32 gimme = GIMME_V;
961 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
967 /* first, move source pointer to the next item in the source list */
968 ++PL_markstack_ptr[-1];
970 /* if there are new items, push them into the destination list */
971 if (items && gimme != G_VOID) {
972 /* might need to make room back there first */
973 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
974 /* XXX this implementation is very pessimal because the stack
975 * is repeatedly extended for every set of items. Is possible
976 * to do this without any stack extension or copying at all
977 * by maintaining a separate list over which the map iterates
978 * (like foreach does). --gsar */
980 /* everything in the stack after the destination list moves
981 * towards the end the stack by the amount of room needed */
982 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
984 /* items to shift up (accounting for the moved source pointer) */
985 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
987 /* This optimization is by Ben Tilly and it does
988 * things differently from what Sarathy (gsar)
989 * is describing. The downside of this optimization is
990 * that leaves "holes" (uninitialized and hopefully unused areas)
991 * to the Perl stack, but on the other hand this
992 * shouldn't be a problem. If Sarathy's idea gets
993 * implemented, this optimization should become
994 * irrelevant. --jhi */
996 shift = count; /* Avoid shifting too often --Ben Tilly */
1000 dst = (SP += shift);
1001 PL_markstack_ptr[-1] += shift;
1002 *PL_markstack_ptr += shift;
1006 /* copy the new items down to the destination list */
1007 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1008 if (gimme == G_ARRAY) {
1010 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1013 /* scalar context: we don't care about which values map returns
1014 * (we use undef here). And so we certainly don't want to do mortal
1015 * copies of meaningless values. */
1016 while (items-- > 0) {
1018 *dst-- = &PL_sv_undef;
1022 LEAVE; /* exit inner scope */
1025 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1027 (void)POPMARK; /* pop top */
1028 LEAVE; /* exit outer scope */
1029 (void)POPMARK; /* pop src */
1030 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1031 (void)POPMARK; /* pop dst */
1032 SP = PL_stack_base + POPMARK; /* pop original mark */
1033 if (gimme == G_SCALAR) {
1034 if (PL_op->op_private & OPpGREP_LEX) {
1035 SV* sv = sv_newmortal();
1036 sv_setiv(sv, items);
1044 else if (gimme == G_ARRAY)
1051 ENTER; /* enter inner scope */
1054 /* set $_ to the new source item */
1055 src = PL_stack_base[PL_markstack_ptr[-1]];
1057 if (PL_op->op_private & OPpGREP_LEX)
1058 PAD_SVl(PL_op->op_targ) = src;
1062 RETURNOP(cLOGOP->op_other);
1071 if (GIMME == G_ARRAY)
1073 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1074 return cLOGOP->op_other;
1084 if (GIMME == G_ARRAY) {
1085 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1089 SV * const targ = PAD_SV(PL_op->op_targ);
1092 if (PL_op->op_private & OPpFLIP_LINENUM) {
1093 if (GvIO(PL_last_in_gv)) {
1094 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1097 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1099 flip = SvIV(sv) == SvIV(GvSV(gv));
1105 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1106 if (PL_op->op_flags & OPf_SPECIAL) {
1114 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1117 sv_setpvn(TARG, "", 0);
1123 /* This code tries to decide if "$left .. $right" should use the
1124 magical string increment, or if the range is numeric (we make
1125 an exception for .."0" [#18165]). AMS 20021031. */
1127 #define RANGE_IS_NUMERIC(left,right) ( \
1128 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1129 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1130 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1131 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1132 && (!SvOK(right) || looks_like_number(right))))
1138 if (GIMME == G_ARRAY) {
1144 if (RANGE_IS_NUMERIC(left,right)) {
1147 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1148 (SvOK(right) && SvNV(right) > IV_MAX))
1149 DIE(aTHX_ "Range iterator outside integer range");
1160 SV * const sv = sv_2mortal(newSViv(i++));
1165 SV * const final = sv_mortalcopy(right);
1167 const char * const tmps = SvPV_const(final, len);
1169 SV *sv = sv_mortalcopy(left);
1170 SvPV_force_nolen(sv);
1171 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1173 if (strEQ(SvPVX_const(sv),tmps))
1175 sv = sv_2mortal(newSVsv(sv));
1182 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1186 if (PL_op->op_private & OPpFLIP_LINENUM) {
1187 if (GvIO(PL_last_in_gv)) {
1188 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1191 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1192 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1200 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1201 sv_catpvs(targ, "E0");
1211 static const char * const context_name[] = {
1224 S_dopoptolabel(pTHX_ const char *label)
1229 for (i = cxstack_ix; i >= 0; i--) {
1230 register const PERL_CONTEXT * const cx = &cxstack[i];
1231 switch (CxTYPE(cx)) {
1239 if (ckWARN(WARN_EXITING))
1240 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1241 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1242 if (CxTYPE(cx) == CXt_NULL)
1246 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1247 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1248 (long)i, cx->blk_loop.label));
1251 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1261 Perl_dowantarray(pTHX)
1264 const I32 gimme = block_gimme();
1265 return (gimme == G_VOID) ? G_SCALAR : gimme;
1269 Perl_block_gimme(pTHX)
1272 const I32 cxix = dopoptosub(cxstack_ix);
1276 switch (cxstack[cxix].blk_gimme) {
1284 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1291 Perl_is_lvalue_sub(pTHX)
1294 const I32 cxix = dopoptosub(cxstack_ix);
1295 assert(cxix >= 0); /* We should only be called from inside subs */
1297 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1298 return cxstack[cxix].blk_sub.lval;
1304 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1308 for (i = startingblock; i >= 0; i--) {
1309 register const PERL_CONTEXT * const cx = &cxstk[i];
1310 switch (CxTYPE(cx)) {
1316 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1324 S_dopoptoeval(pTHX_ I32 startingblock)
1328 for (i = startingblock; i >= 0; i--) {
1329 register const PERL_CONTEXT *cx = &cxstack[i];
1330 switch (CxTYPE(cx)) {
1334 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1342 S_dopoptoloop(pTHX_ I32 startingblock)
1346 for (i = startingblock; i >= 0; i--) {
1347 register const PERL_CONTEXT * const cx = &cxstack[i];
1348 switch (CxTYPE(cx)) {
1354 if (ckWARN(WARN_EXITING))
1355 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1356 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1357 if ((CxTYPE(cx)) == CXt_NULL)
1361 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1369 S_dopoptogiven(pTHX_ I32 startingblock)
1373 for (i = startingblock; i >= 0; i--) {
1374 register const PERL_CONTEXT *cx = &cxstack[i];
1375 switch (CxTYPE(cx)) {
1379 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1382 if (CxFOREACHDEF(cx)) {
1383 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1392 S_dopoptowhen(pTHX_ I32 startingblock)
1396 for (i = startingblock; i >= 0; i--) {
1397 register const PERL_CONTEXT *cx = &cxstack[i];
1398 switch (CxTYPE(cx)) {
1402 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1410 Perl_dounwind(pTHX_ I32 cxix)
1415 while (cxstack_ix > cxix) {
1417 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1418 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1419 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1420 /* Note: we don't need to restore the base context info till the end. */
1421 switch (CxTYPE(cx)) {
1424 continue; /* not break */
1443 PERL_UNUSED_VAR(optype);
1447 Perl_qerror(pTHX_ SV *err)
1451 sv_catsv(ERRSV, err);
1453 sv_catsv(PL_errors, err);
1455 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1457 ++PL_parser->error_count;
1461 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1470 if (PL_in_eval & EVAL_KEEPERR) {
1471 static const char prefix[] = "\t(in cleanup) ";
1472 SV * const err = ERRSV;
1473 const char *e = NULL;
1475 sv_setpvn(err,"",0);
1476 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1478 e = SvPV_const(err, len);
1480 if (*e != *message || strNE(e,message))
1484 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1485 sv_catpvn(err, prefix, sizeof(prefix)-1);
1486 sv_catpvn(err, message, msglen);
1487 if (ckWARN(WARN_MISC)) {
1488 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1489 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1494 sv_setpvn(ERRSV, message, msglen);
1498 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1499 && PL_curstackinfo->si_prev)
1507 register PERL_CONTEXT *cx;
1510 if (cxix < cxstack_ix)
1513 POPBLOCK(cx,PL_curpm);
1514 if (CxTYPE(cx) != CXt_EVAL) {
1516 message = SvPVx_const(ERRSV, msglen);
1517 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1518 PerlIO_write(Perl_error_log, message, msglen);
1523 if (gimme == G_SCALAR)
1524 *++newsp = &PL_sv_undef;
1525 PL_stack_sp = newsp;
1529 /* LEAVE could clobber PL_curcop (see save_re_context())
1530 * XXX it might be better to find a way to avoid messing with
1531 * PL_curcop in save_re_context() instead, but this is a more
1532 * minimal fix --GSAR */
1533 PL_curcop = cx->blk_oldcop;
1535 if (optype == OP_REQUIRE) {
1536 const char* const msg = SvPVx_nolen_const(ERRSV);
1537 SV * const nsv = cx->blk_eval.old_namesv;
1538 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1540 DIE(aTHX_ "%sCompilation failed in require",
1541 *msg ? msg : "Unknown error\n");
1543 assert(CxTYPE(cx) == CXt_EVAL);
1544 return cx->blk_eval.retop;
1548 message = SvPVx_const(ERRSV, msglen);
1550 write_to_stderr(message, msglen);
1558 dVAR; dSP; dPOPTOPssrl;
1559 if (SvTRUE(left) != SvTRUE(right))
1569 register I32 cxix = dopoptosub(cxstack_ix);
1570 register const PERL_CONTEXT *cx;
1571 register const PERL_CONTEXT *ccstack = cxstack;
1572 const PERL_SI *top_si = PL_curstackinfo;
1574 const char *stashname;
1581 /* we may be in a higher stacklevel, so dig down deeper */
1582 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1583 top_si = top_si->si_prev;
1584 ccstack = top_si->si_cxstack;
1585 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1588 if (GIMME != G_ARRAY) {
1594 /* caller() should not report the automatic calls to &DB::sub */
1595 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1596 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1600 cxix = dopoptosub_at(ccstack, cxix - 1);
1603 cx = &ccstack[cxix];
1604 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1605 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1606 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1607 field below is defined for any cx. */
1608 /* caller() should not report the automatic calls to &DB::sub */
1609 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1610 cx = &ccstack[dbcxix];
1613 stashname = CopSTASHPV(cx->blk_oldcop);
1614 if (GIMME != G_ARRAY) {
1617 PUSHs(&PL_sv_undef);
1620 sv_setpv(TARG, stashname);
1629 PUSHs(&PL_sv_undef);
1631 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1632 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1633 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1636 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1637 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1638 /* So is ccstack[dbcxix]. */
1640 SV * const sv = newSV(0);
1641 gv_efullname3(sv, cvgv, NULL);
1642 PUSHs(sv_2mortal(sv));
1643 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1646 PUSHs(sv_2mortal(newSVpvs("(unknown)")));
1647 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1651 PUSHs(sv_2mortal(newSVpvs("(eval)")));
1652 PUSHs(sv_2mortal(newSViv(0)));
1654 gimme = (I32)cx->blk_gimme;
1655 if (gimme == G_VOID)
1656 PUSHs(&PL_sv_undef);
1658 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1659 if (CxTYPE(cx) == CXt_EVAL) {
1661 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1662 PUSHs(cx->blk_eval.cur_text);
1666 else if (cx->blk_eval.old_namesv) {
1667 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1670 /* eval BLOCK (try blocks have old_namesv == 0) */
1672 PUSHs(&PL_sv_undef);
1673 PUSHs(&PL_sv_undef);
1677 PUSHs(&PL_sv_undef);
1678 PUSHs(&PL_sv_undef);
1680 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1681 && CopSTASH_eq(PL_curcop, PL_debstash))
1683 AV * const ary = cx->blk_sub.argarray;
1684 const int off = AvARRAY(ary) - AvALLOC(ary);
1687 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1688 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1690 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1693 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1694 av_extend(PL_dbargs, AvFILLp(ary) + off);
1695 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1696 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1698 /* XXX only hints propagated via op_private are currently
1699 * visible (others are not easily accessible, since they
1700 * use the global PL_hints) */
1701 PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
1704 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1706 if (old_warnings == pWARN_NONE ||
1707 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1708 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1709 else if (old_warnings == pWARN_ALL ||
1710 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1711 /* Get the bit mask for $warnings::Bits{all}, because
1712 * it could have been extended by warnings::register */
1714 HV * const bits = get_hv("warnings::Bits", FALSE);
1715 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1716 mask = newSVsv(*bits_all);
1719 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1723 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1724 PUSHs(sv_2mortal(mask));
1727 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1728 sv_2mortal(newRV_noinc(
1729 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1730 cx->blk_oldcop->cop_hints_hash)))
1739 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1740 sv_reset(tmps, CopSTASH(PL_curcop));
1745 /* like pp_nextstate, but used instead when the debugger is active */
1750 PL_curcop = (COP*)PL_op;
1751 TAINT_NOT; /* Each statement is presumed innocent */
1752 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1755 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1756 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1759 register PERL_CONTEXT *cx;
1760 const I32 gimme = G_ARRAY;
1762 GV * const gv = PL_DBgv;
1763 register CV * const cv = GvCV(gv);
1766 DIE(aTHX_ "No DB::DB routine defined");
1768 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1769 /* don't do recursive DB::DB call */
1784 (void)(*CvXSUB(cv))(aTHX_ cv);
1791 PUSHBLOCK(cx, CXt_SUB, SP);
1793 cx->blk_sub.retop = PL_op->op_next;
1796 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1797 RETURNOP(CvSTART(cv));
1807 register PERL_CONTEXT *cx;
1808 const I32 gimme = GIMME_V;
1810 U16 cxtype = CXt_LOOP | CXp_FOREACH;
1818 if (PL_op->op_targ) {
1819 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1820 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1821 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1822 SVs_PADSTALE, SVs_PADSTALE);
1824 #ifndef USE_ITHREADS
1825 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1828 SAVEPADSV(PL_op->op_targ);
1829 iterdata = INT2PTR(void*, PL_op->op_targ);
1830 cxtype |= CXp_PADVAR;
1834 GV * const gv = (GV*)POPs;
1835 svp = &GvSV(gv); /* symbol table variable */
1836 SAVEGENERICSV(*svp);
1839 iterdata = (void*)gv;
1843 if (PL_op->op_private & OPpITER_DEF)
1844 cxtype |= CXp_FOR_DEF;
1848 PUSHBLOCK(cx, cxtype, SP);
1850 PUSHLOOP(cx, iterdata, MARK);
1852 PUSHLOOP(cx, svp, MARK);
1854 if (PL_op->op_flags & OPf_STACKED) {
1855 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1856 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1858 SV * const right = (SV*)cx->blk_loop.iterary;
1861 if (RANGE_IS_NUMERIC(sv,right)) {
1862 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1863 (SvOK(right) && SvNV(right) >= IV_MAX))
1864 DIE(aTHX_ "Range iterator outside integer range");
1865 cx->blk_loop.iterix = SvIV(sv);
1866 cx->blk_loop.itermax = SvIV(right);
1868 /* for correct -Dstv display */
1869 cx->blk_oldsp = sp - PL_stack_base;
1873 cx->blk_loop.iterlval = newSVsv(sv);
1874 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1875 (void) SvPV_nolen_const(right);
1878 else if (PL_op->op_private & OPpITER_REVERSED) {
1879 cx->blk_loop.itermax = 0;
1880 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1885 cx->blk_loop.iterary = PL_curstack;
1886 AvFILLp(PL_curstack) = SP - PL_stack_base;
1887 if (PL_op->op_private & OPpITER_REVERSED) {
1888 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1889 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1892 cx->blk_loop.iterix = MARK - PL_stack_base;
1902 register PERL_CONTEXT *cx;
1903 const I32 gimme = GIMME_V;
1909 PUSHBLOCK(cx, CXt_LOOP, SP);
1910 PUSHLOOP(cx, 0, SP);
1918 register PERL_CONTEXT *cx;
1925 assert(CxTYPE(cx) == CXt_LOOP);
1927 newsp = PL_stack_base + cx->blk_loop.resetsp;
1930 if (gimme == G_VOID)
1932 else if (gimme == G_SCALAR) {
1934 *++newsp = sv_mortalcopy(*SP);
1936 *++newsp = &PL_sv_undef;
1940 *++newsp = sv_mortalcopy(*++mark);
1941 TAINT_NOT; /* Each item is independent */
1947 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1948 PL_curpm = newpm; /* ... and pop $1 et al */
1959 register PERL_CONTEXT *cx;
1960 bool popsub2 = FALSE;
1961 bool clear_errsv = FALSE;
1969 const I32 cxix = dopoptosub(cxstack_ix);
1972 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1973 * sort block, which is a CXt_NULL
1976 PL_stack_base[1] = *PL_stack_sp;
1977 PL_stack_sp = PL_stack_base + 1;
1981 DIE(aTHX_ "Can't return outside a subroutine");
1983 if (cxix < cxstack_ix)
1986 if (CxMULTICALL(&cxstack[cxix])) {
1987 gimme = cxstack[cxix].blk_gimme;
1988 if (gimme == G_VOID)
1989 PL_stack_sp = PL_stack_base;
1990 else if (gimme == G_SCALAR) {
1991 PL_stack_base[1] = *PL_stack_sp;
1992 PL_stack_sp = PL_stack_base + 1;
1998 switch (CxTYPE(cx)) {
2001 retop = cx->blk_sub.retop;
2002 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2005 if (!(PL_in_eval & EVAL_KEEPERR))
2008 retop = cx->blk_eval.retop;
2012 if (optype == OP_REQUIRE &&
2013 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2015 /* Unassume the success we assumed earlier. */
2016 SV * const nsv = cx->blk_eval.old_namesv;
2017 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2018 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2023 retop = cx->blk_sub.retop;
2026 DIE(aTHX_ "panic: return");
2030 if (gimme == G_SCALAR) {
2033 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2035 *++newsp = SvREFCNT_inc(*SP);
2040 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2042 *++newsp = sv_mortalcopy(sv);
2047 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2050 *++newsp = sv_mortalcopy(*SP);
2053 *++newsp = &PL_sv_undef;
2055 else if (gimme == G_ARRAY) {
2056 while (++MARK <= SP) {
2057 *++newsp = (popsub2 && SvTEMP(*MARK))
2058 ? *MARK : sv_mortalcopy(*MARK);
2059 TAINT_NOT; /* Each item is independent */
2062 PL_stack_sp = newsp;
2065 /* Stack values are safe: */
2068 POPSUB(cx,sv); /* release CV and @_ ... */
2072 PL_curpm = newpm; /* ... and pop $1 et al */
2076 sv_setpvn(ERRSV,"",0);
2084 register PERL_CONTEXT *cx;
2095 if (PL_op->op_flags & OPf_SPECIAL) {
2096 cxix = dopoptoloop(cxstack_ix);
2098 DIE(aTHX_ "Can't \"last\" outside a loop block");
2101 cxix = dopoptolabel(cPVOP->op_pv);
2103 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2105 if (cxix < cxstack_ix)
2109 cxstack_ix++; /* temporarily protect top context */
2111 switch (CxTYPE(cx)) {
2114 newsp = PL_stack_base + cx->blk_loop.resetsp;
2115 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2119 nextop = cx->blk_sub.retop;
2123 nextop = cx->blk_eval.retop;
2127 nextop = cx->blk_sub.retop;
2130 DIE(aTHX_ "panic: last");
2134 if (gimme == G_SCALAR) {
2136 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2137 ? *SP : sv_mortalcopy(*SP);
2139 *++newsp = &PL_sv_undef;
2141 else if (gimme == G_ARRAY) {
2142 while (++MARK <= SP) {
2143 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2144 ? *MARK : sv_mortalcopy(*MARK);
2145 TAINT_NOT; /* Each item is independent */
2153 /* Stack values are safe: */
2156 POPLOOP(cx); /* release loop vars ... */
2160 POPSUB(cx,sv); /* release CV and @_ ... */
2163 PL_curpm = newpm; /* ... and pop $1 et al */
2166 PERL_UNUSED_VAR(optype);
2167 PERL_UNUSED_VAR(gimme);
2175 register PERL_CONTEXT *cx;
2178 if (PL_op->op_flags & OPf_SPECIAL) {
2179 cxix = dopoptoloop(cxstack_ix);
2181 DIE(aTHX_ "Can't \"next\" outside a loop block");
2184 cxix = dopoptolabel(cPVOP->op_pv);
2186 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2188 if (cxix < cxstack_ix)
2191 /* clear off anything above the scope we're re-entering, but
2192 * save the rest until after a possible continue block */
2193 inner = PL_scopestack_ix;
2195 if (PL_scopestack_ix < inner)
2196 leave_scope(PL_scopestack[PL_scopestack_ix]);
2197 PL_curcop = cx->blk_oldcop;
2198 return CX_LOOP_NEXTOP_GET(cx);
2205 register PERL_CONTEXT *cx;
2209 if (PL_op->op_flags & OPf_SPECIAL) {
2210 cxix = dopoptoloop(cxstack_ix);
2212 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2215 cxix = dopoptolabel(cPVOP->op_pv);
2217 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2219 if (cxix < cxstack_ix)
2222 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2223 if (redo_op->op_type == OP_ENTER) {
2224 /* pop one less context to avoid $x being freed in while (my $x..) */
2226 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2227 redo_op = redo_op->op_next;
2231 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2232 LEAVE_SCOPE(oldsave);
2234 PL_curcop = cx->blk_oldcop;
2239 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2243 static const char too_deep[] = "Target of goto is too deeply nested";
2246 Perl_croak(aTHX_ too_deep);
2247 if (o->op_type == OP_LEAVE ||
2248 o->op_type == OP_SCOPE ||
2249 o->op_type == OP_LEAVELOOP ||
2250 o->op_type == OP_LEAVESUB ||
2251 o->op_type == OP_LEAVETRY)
2253 *ops++ = cUNOPo->op_first;
2255 Perl_croak(aTHX_ too_deep);
2258 if (o->op_flags & OPf_KIDS) {
2260 /* First try all the kids at this level, since that's likeliest. */
2261 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2262 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2263 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2266 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2267 if (kid == PL_lastgotoprobe)
2269 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2272 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2273 ops[-1]->op_type == OP_DBSTATE)
2278 if ((o = dofindlabel(kid, label, ops, oplimit)))
2291 register PERL_CONTEXT *cx;
2292 #define GOTO_DEPTH 64
2293 OP *enterops[GOTO_DEPTH];
2294 const char *label = NULL;
2295 const bool do_dump = (PL_op->op_type == OP_DUMP);
2296 static const char must_have_label[] = "goto must have label";
2298 if (PL_op->op_flags & OPf_STACKED) {
2299 SV * const sv = POPs;
2301 /* This egregious kludge implements goto &subroutine */
2302 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2304 register PERL_CONTEXT *cx;
2305 CV* cv = (CV*)SvRV(sv);
2312 if (!CvROOT(cv) && !CvXSUB(cv)) {
2313 const GV * const gv = CvGV(cv);
2317 /* autoloaded stub? */
2318 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2320 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2321 GvNAMELEN(gv), FALSE);
2322 if (autogv && (cv = GvCV(autogv)))
2324 tmpstr = sv_newmortal();
2325 gv_efullname3(tmpstr, gv, NULL);
2326 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2328 DIE(aTHX_ "Goto undefined subroutine");
2331 /* First do some returnish stuff. */
2332 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2334 cxix = dopoptosub(cxstack_ix);
2336 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2337 if (cxix < cxstack_ix)
2341 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2342 if (CxTYPE(cx) == CXt_EVAL) {
2344 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2346 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2348 else if (CxMULTICALL(cx))
2349 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2350 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2351 /* put @_ back onto stack */
2352 AV* av = cx->blk_sub.argarray;
2354 items = AvFILLp(av) + 1;
2355 EXTEND(SP, items+1); /* @_ could have been extended. */
2356 Copy(AvARRAY(av), SP + 1, items, SV*);
2357 SvREFCNT_dec(GvAV(PL_defgv));
2358 GvAV(PL_defgv) = cx->blk_sub.savearray;
2360 /* abandon @_ if it got reified */
2365 av_extend(av, items-1);
2367 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2370 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2371 AV* const av = GvAV(PL_defgv);
2372 items = AvFILLp(av) + 1;
2373 EXTEND(SP, items+1); /* @_ could have been extended. */
2374 Copy(AvARRAY(av), SP + 1, items, SV*);
2378 if (CxTYPE(cx) == CXt_SUB &&
2379 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2380 SvREFCNT_dec(cx->blk_sub.cv);
2381 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2382 LEAVE_SCOPE(oldsave);
2384 /* Now do some callish stuff. */
2386 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2388 OP* const retop = cx->blk_sub.retop;
2393 for (index=0; index<items; index++)
2394 sv_2mortal(SP[-index]);
2397 /* XS subs don't have a CxSUB, so pop it */
2398 POPBLOCK(cx, PL_curpm);
2399 /* Push a mark for the start of arglist */
2402 (void)(*CvXSUB(cv))(aTHX_ cv);
2407 AV* const padlist = CvPADLIST(cv);
2408 if (CxTYPE(cx) == CXt_EVAL) {
2409 PL_in_eval = cx->blk_eval.old_in_eval;
2410 PL_eval_root = cx->blk_eval.old_eval_root;
2411 cx->cx_type = CXt_SUB;
2412 cx->blk_sub.hasargs = 0;
2414 cx->blk_sub.cv = cv;
2415 cx->blk_sub.olddepth = CvDEPTH(cv);
2418 if (CvDEPTH(cv) < 2)
2419 SvREFCNT_inc_simple_void_NN(cv);
2421 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2422 sub_crush_depth(cv);
2423 pad_push(padlist, CvDEPTH(cv));
2426 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2427 if (cx->blk_sub.hasargs)
2429 AV* const av = (AV*)PAD_SVl(0);
2431 cx->blk_sub.savearray = GvAV(PL_defgv);
2432 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2433 CX_CURPAD_SAVE(cx->blk_sub);
2434 cx->blk_sub.argarray = av;
2436 if (items >= AvMAX(av) + 1) {
2437 SV **ary = AvALLOC(av);
2438 if (AvARRAY(av) != ary) {
2439 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2442 if (items >= AvMAX(av) + 1) {
2443 AvMAX(av) = items - 1;
2444 Renew(ary,items+1,SV*);
2450 Copy(mark,AvARRAY(av),items,SV*);
2451 AvFILLp(av) = items - 1;
2452 assert(!AvREAL(av));
2454 /* transfer 'ownership' of refcnts to new @_ */
2464 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2465 Perl_get_db_sub(aTHX_ NULL, cv);
2467 CV * const gotocv = get_cv("DB::goto", FALSE);
2469 PUSHMARK( PL_stack_sp );
2470 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2475 RETURNOP(CvSTART(cv));
2479 label = SvPV_nolen_const(sv);
2480 if (!(do_dump || *label))
2481 DIE(aTHX_ must_have_label);
2484 else if (PL_op->op_flags & OPf_SPECIAL) {
2486 DIE(aTHX_ must_have_label);
2489 label = cPVOP->op_pv;
2491 if (label && *label) {
2492 OP *gotoprobe = NULL;
2493 bool leaving_eval = FALSE;
2494 bool in_block = FALSE;
2495 PERL_CONTEXT *last_eval_cx = NULL;
2499 PL_lastgotoprobe = NULL;
2501 for (ix = cxstack_ix; ix >= 0; ix--) {
2503 switch (CxTYPE(cx)) {
2505 leaving_eval = TRUE;
2506 if (!CxTRYBLOCK(cx)) {
2507 gotoprobe = (last_eval_cx ?
2508 last_eval_cx->blk_eval.old_eval_root :
2513 /* else fall through */
2515 gotoprobe = cx->blk_oldcop->op_sibling;
2521 gotoprobe = cx->blk_oldcop->op_sibling;
2524 gotoprobe = PL_main_root;
2527 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2528 gotoprobe = CvROOT(cx->blk_sub.cv);
2534 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2537 DIE(aTHX_ "panic: goto");
2538 gotoprobe = PL_main_root;
2542 retop = dofindlabel(gotoprobe, label,
2543 enterops, enterops + GOTO_DEPTH);
2547 PL_lastgotoprobe = gotoprobe;
2550 DIE(aTHX_ "Can't find label %s", label);
2552 /* if we're leaving an eval, check before we pop any frames
2553 that we're not going to punt, otherwise the error
2556 if (leaving_eval && *enterops && enterops[1]) {
2558 for (i = 1; enterops[i]; i++)
2559 if (enterops[i]->op_type == OP_ENTERITER)
2560 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2563 /* pop unwanted frames */
2565 if (ix < cxstack_ix) {
2572 oldsave = PL_scopestack[PL_scopestack_ix];
2573 LEAVE_SCOPE(oldsave);
2576 /* push wanted frames */
2578 if (*enterops && enterops[1]) {
2579 OP * const oldop = PL_op;
2580 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2581 for (; enterops[ix]; ix++) {
2582 PL_op = enterops[ix];
2583 /* Eventually we may want to stack the needed arguments
2584 * for each op. For now, we punt on the hard ones. */
2585 if (PL_op->op_type == OP_ENTERITER)
2586 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2587 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2595 if (!retop) retop = PL_main_start;
2597 PL_restartop = retop;
2598 PL_do_undump = TRUE;
2602 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2603 PL_do_undump = FALSE;
2620 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2622 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2625 PL_exit_flags |= PERL_EXIT_EXPECTED;
2627 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2628 if (anum || !(PL_minus_c && PL_madskills))
2633 PUSHs(&PL_sv_undef);
2640 S_save_lines(pTHX_ AV *array, SV *sv)
2642 const char *s = SvPVX_const(sv);
2643 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2646 while (s && s < send) {
2648 SV * const tmpstr = newSV_type(SVt_PVMG);
2650 t = strchr(s, '\n');
2656 sv_setpvn(tmpstr, s, t - s);
2657 av_store(array, line++, tmpstr);
2663 S_docatch(pTHX_ OP *o)
2667 OP * const oldop = PL_op;
2671 assert(CATCH_GET == TRUE);
2678 assert(cxstack_ix >= 0);
2679 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2680 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2685 /* die caught by an inner eval - continue inner loop */
2687 /* NB XXX we rely on the old popped CxEVAL still being at the top
2688 * of the stack; the way die_where() currently works, this
2689 * assumption is valid. In theory The cur_top_env value should be
2690 * returned in another global, the way retop (aka PL_restartop)
2692 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2695 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2697 PL_op = PL_restartop;
2714 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2715 /* sv Text to convert to OP tree. */
2716 /* startop op_free() this to undo. */
2717 /* code Short string id of the caller. */
2719 /* FIXME - how much of this code is common with pp_entereval? */
2720 dVAR; dSP; /* Make POPBLOCK work. */
2726 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2727 char *tmpbuf = tbuf;
2730 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2734 lex_start(sv, NULL, FALSE);
2736 /* switch to eval mode */
2738 if (IN_PERL_COMPILETIME) {
2739 SAVECOPSTASH_FREE(&PL_compiling);
2740 CopSTASH_set(&PL_compiling, PL_curstash);
2742 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2743 SV * const sv = sv_newmortal();
2744 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2745 code, (unsigned long)++PL_evalseq,
2746 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2751 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2752 (unsigned long)++PL_evalseq);
2753 SAVECOPFILE_FREE(&PL_compiling);
2754 CopFILE_set(&PL_compiling, tmpbuf+2);
2755 SAVECOPLINE(&PL_compiling);
2756 CopLINE_set(&PL_compiling, 1);
2757 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2758 deleting the eval's FILEGV from the stash before gv_check() runs
2759 (i.e. before run-time proper). To work around the coredump that
2760 ensues, we always turn GvMULTI_on for any globals that were
2761 introduced within evals. See force_ident(). GSAR 96-10-12 */
2762 safestr = savepvn(tmpbuf, len);
2763 SAVEDELETE(PL_defstash, safestr, len);
2765 #ifdef OP_IN_REGISTER
2771 /* we get here either during compilation, or via pp_regcomp at runtime */
2772 runtime = IN_PERL_RUNTIME;
2774 runcv = find_runcv(NULL);
2777 PL_op->op_type = OP_ENTEREVAL;
2778 PL_op->op_flags = 0; /* Avoid uninit warning. */
2779 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2780 PUSHEVAL(cx, 0, NULL);
2783 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2785 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2786 POPBLOCK(cx,PL_curpm);
2789 (*startop)->op_type = OP_NULL;
2790 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2792 /* XXX DAPM do this properly one year */
2793 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2795 if (IN_PERL_COMPILETIME)
2796 CopHINTS_set(&PL_compiling, PL_hints);
2797 #ifdef OP_IN_REGISTER
2800 PERL_UNUSED_VAR(newsp);
2801 PERL_UNUSED_VAR(optype);
2803 return PL_eval_start;
2808 =for apidoc find_runcv
2810 Locate the CV corresponding to the currently executing sub or eval.
2811 If db_seqp is non_null, skip CVs that are in the DB package and populate
2812 *db_seqp with the cop sequence number at the point that the DB:: code was
2813 entered. (allows debuggers to eval in the scope of the breakpoint rather
2814 than in the scope of the debugger itself).
2820 Perl_find_runcv(pTHX_ U32 *db_seqp)
2826 *db_seqp = PL_curcop->cop_seq;
2827 for (si = PL_curstackinfo; si; si = si->si_prev) {
2829 for (ix = si->si_cxix; ix >= 0; ix--) {
2830 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2831 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2832 CV * const cv = cx->blk_sub.cv;
2833 /* skip DB:: code */
2834 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2835 *db_seqp = cx->blk_oldcop->cop_seq;
2840 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2848 /* Compile a require/do, an eval '', or a /(?{...})/.
2849 * In the last case, startop is non-null, and contains the address of
2850 * a pointer that should be set to the just-compiled code.
2851 * outside is the lexically enclosing CV (if any) that invoked us.
2852 * Returns a bool indicating whether the compile was successful; if so,
2853 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2854 * pushes undef (also croaks if startop != NULL).
2858 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2861 OP * const saveop = PL_op;
2863 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2864 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2869 SAVESPTR(PL_compcv);
2870 PL_compcv = (CV*)newSV_type(SVt_PVCV);
2871 CvEVAL_on(PL_compcv);
2872 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2873 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2875 CvOUTSIDE_SEQ(PL_compcv) = seq;
2876 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2878 /* set up a scratch pad */
2880 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2881 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2885 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2887 /* make sure we compile in the right package */
2889 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2890 SAVESPTR(PL_curstash);
2891 PL_curstash = CopSTASH(PL_curcop);
2893 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2894 SAVESPTR(PL_beginav);
2895 PL_beginav = newAV();
2896 SAVEFREESV(PL_beginav);
2897 SAVESPTR(PL_unitcheckav);
2898 PL_unitcheckav = newAV();
2899 SAVEFREESV(PL_unitcheckav);
2902 SAVEBOOL(PL_madskills);
2906 /* try to compile it */
2908 PL_eval_root = NULL;
2909 PL_curcop = &PL_compiling;
2910 CopARYBASE_set(PL_curcop, 0);
2911 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2912 PL_in_eval |= EVAL_KEEPERR;
2914 sv_setpvn(ERRSV,"",0);
2915 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
2916 SV **newsp; /* Used by POPBLOCK. */
2917 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2918 I32 optype = 0; /* Might be reset by POPEVAL. */
2923 op_free(PL_eval_root);
2924 PL_eval_root = NULL;
2926 SP = PL_stack_base + POPMARK; /* pop original mark */
2928 POPBLOCK(cx,PL_curpm);
2934 msg = SvPVx_nolen_const(ERRSV);
2935 if (optype == OP_REQUIRE) {
2936 const SV * const nsv = cx->blk_eval.old_namesv;
2937 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2939 Perl_croak(aTHX_ "%sCompilation failed in require",
2940 *msg ? msg : "Unknown error\n");
2943 POPBLOCK(cx,PL_curpm);
2945 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2946 (*msg ? msg : "Unknown error\n"));
2950 sv_setpvs(ERRSV, "Compilation error");
2953 PERL_UNUSED_VAR(newsp);
2954 PUSHs(&PL_sv_undef);
2958 CopLINE_set(&PL_compiling, 0);
2960 *startop = PL_eval_root;
2962 SAVEFREEOP(PL_eval_root);
2964 /* Set the context for this new optree.
2965 * If the last op is an OP_REQUIRE, force scalar context.
2966 * Otherwise, propagate the context from the eval(). */
2967 if (PL_eval_root->op_type == OP_LEAVEEVAL
2968 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2969 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2971 scalar(PL_eval_root);
2972 else if (gimme & G_VOID)
2973 scalarvoid(PL_eval_root);
2974 else if (gimme & G_ARRAY)
2977 scalar(PL_eval_root);
2979 DEBUG_x(dump_eval());
2981 /* Register with debugger: */
2982 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
2983 CV * const cv = get_cv("DB::postponed", FALSE);
2987 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2989 call_sv((SV*)cv, G_DISCARD);
2994 call_list(PL_scopestack_ix, PL_unitcheckav);
2996 /* compiled okay, so do it */
2998 CvDEPTH(PL_compcv) = 1;
2999 SP = PL_stack_base + POPMARK; /* pop original mark */
3000 PL_op = saveop; /* The caller may need it. */
3001 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3008 S_check_type_and_open(pTHX_ const char *name)
3011 const int st_rc = PerlLIO_stat(name, &st);
3013 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3017 return PerlIO_open(name, PERL_SCRIPT_MODE);
3020 #ifndef PERL_DISABLE_PMC
3022 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3026 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3027 SV *const pmcsv = newSV(namelen + 2);
3028 char *const pmc = SvPVX(pmcsv);
3031 memcpy(pmc, name, namelen);
3033 pmc[namelen + 1] = '\0';
3035 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3036 fp = check_type_and_open(name);
3039 fp = check_type_and_open(pmc);
3041 SvREFCNT_dec(pmcsv);
3044 fp = check_type_and_open(name);
3049 # define doopen_pm(name, namelen) check_type_and_open(name)
3050 #endif /* !PERL_DISABLE_PMC */
3055 register PERL_CONTEXT *cx;
3062 int vms_unixname = 0;
3064 const char *tryname = NULL;
3066 const I32 gimme = GIMME_V;
3067 int filter_has_file = 0;
3068 PerlIO *tryrsfp = NULL;
3069 SV *filter_cache = NULL;
3070 SV *filter_state = NULL;
3071 SV *filter_sub = NULL;
3077 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3078 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) { /* require v5.6.1 */
3079 HV * hinthv = GvHV(PL_hintgv);
3081 if (hinthv) ptr = hv_fetchs(hinthv, "v_string", FALSE);
3082 if ( !(ptr && *ptr && SvIOK(*ptr) && SvIV(*ptr)) )
3083 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3084 "v-string in use/require non-portable");
3086 sv = new_version(sv);
3087 if (!sv_derived_from(PL_patchlevel, "version"))
3088 upg_version(PL_patchlevel, TRUE);
3089 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3090 if ( vcmp(sv,PL_patchlevel) <= 0 )
3091 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3092 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3095 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3098 SV * const req = SvRV(sv);
3099 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3101 /* get the left hand term */
3102 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3104 first = SvIV(*av_fetch(lav,0,0));
3105 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3106 || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3107 || av_len(lav) > 1 /* FP with > 3 digits */
3108 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3110 DIE(aTHX_ "Perl %"SVf" required--this is only "
3111 "%"SVf", stopped", SVfARG(vnormal(req)),
3112 SVfARG(vnormal(PL_patchlevel)));
3114 else { /* probably 'use 5.10' or 'use 5.8' */
3115 SV * hintsv = newSV(0);
3119 second = SvIV(*av_fetch(lav,1,0));
3121 second /= second >= 600 ? 100 : 10;
3122 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3123 (int)first, (int)second,0);
3124 upg_version(hintsv, TRUE);
3126 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3127 "--this is only %"SVf", stopped",
3128 SVfARG(vnormal(req)),
3129 SVfARG(vnormal(hintsv)),
3130 SVfARG(vnormal(PL_patchlevel)));
3135 /* We do this only with use, not require. */
3137 /* If we request a version >= 5.6.0, then v-string are OK
3138 so set $^H{v_string} to suppress the v-string warning */
3139 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.006), FALSE))) >= 0) {
3140 HV * hinthv = GvHV(PL_hintgv);
3142 SV *hint = newSViv(1);
3143 (void)hv_stores(hinthv, "v_string", hint);
3144 /* This will call through to Perl_magic_sethint() which in turn
3145 sets PL_hints correctly. */
3148 /* If we request a version >= 5.9.5, load feature.pm with the
3149 * feature bundle that corresponds to the required version. */
3150 if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3151 SV *const importsv = vnormal(sv);
3152 *SvPVX_mutable(importsv) = ':';
3154 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, len);
3205 #ifdef MACOS_TRADITIONAL
3209 MacPerl_CanonDir(name, newname, 1);
3210 if (path_is_absolute(newname)) {
3212 tryrsfp = doopen_pm(newname, strlen(newname));
3217 AV * const ar = GvAVn(PL_incgv);
3224 sv_upgrade(namesv, SVt_PV);
3225 for (i = 0; i <= AvFILL(ar); i++) {
3226 SV * const dirsv = *av_fetch(ar, i, TRUE);
3228 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3235 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3236 && !sv_isobject(loader))
3238 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3241 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3242 PTR2UV(SvRV(dirsv)), name);
3243 tryname = SvPVX_const(namesv);
3254 if (sv_isobject(loader))
3255 count = call_method("INC", G_ARRAY);
3257 count = call_sv(loader, G_ARRAY);
3260 /* Adjust file name if the hook has set an %INC entry */
3261 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3263 tryname = SvPVX_const(*svp);
3272 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3273 && !isGV_with_GP(SvRV(arg))) {
3274 filter_cache = SvRV(arg);
3275 SvREFCNT_inc_simple_void_NN(filter_cache);
3282 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3286 if (SvTYPE(arg) == SVt_PVGV) {
3287 IO * const io = GvIO((GV *)arg);
3292 tryrsfp = IoIFP(io);
3293 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3294 PerlIO_close(IoOFP(io));
3305 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3307 SvREFCNT_inc_simple_void_NN(filter_sub);
3310 filter_state = SP[i];
3311 SvREFCNT_inc_simple_void(filter_state);
3315 if (!tryrsfp && (filter_cache || filter_sub)) {
3316 tryrsfp = PerlIO_open(BIT_BUCKET,
3331 filter_has_file = 0;
3333 SvREFCNT_dec(filter_cache);
3334 filter_cache = NULL;
3337 SvREFCNT_dec(filter_state);
3338 filter_state = NULL;
3341 SvREFCNT_dec(filter_sub);
3346 if (!path_is_absolute(name)
3347 #ifdef MACOS_TRADITIONAL
3348 /* We consider paths of the form :a:b ambiguous and interpret them first
3349 as global then as local
3351 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3358 dir = SvPV_const(dirsv, dirlen);
3364 #ifdef MACOS_TRADITIONAL
3368 MacPerl_CanonDir(name, buf2, 1);
3369 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3373 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3375 sv_setpv(namesv, unixdir);
3376 sv_catpv(namesv, unixname);
3378 # ifdef __SYMBIAN32__
3379 if (PL_origfilename[0] &&
3380 PL_origfilename[1] == ':' &&
3381 !(dir[0] && dir[1] == ':'))
3382 Perl_sv_setpvf(aTHX_ namesv,
3387 Perl_sv_setpvf(aTHX_ namesv,
3391 /* The equivalent of
3392 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3393 but without the need to parse the format string, or
3394 call strlen on either pointer, and with the correct
3395 allocation up front. */
3397 char *tmp = SvGROW(namesv, dirlen + len + 2);
3399 memcpy(tmp, dir, dirlen);
3402 /* name came from an SV, so it will have a '\0' at the
3403 end that we can copy as part of this memcpy(). */
3404 memcpy(tmp, name, len + 1);
3406 SvCUR_set(namesv, dirlen + len + 1);
3408 /* Don't even actually have to turn SvPOK_on() as we
3409 access it directly with SvPVX() below. */
3414 TAINT_PROPER("require");
3415 tryname = SvPVX_const(namesv);
3416 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3418 if (tryname[0] == '.' && tryname[1] == '/')
3422 else if (errno == EMFILE)
3423 /* no point in trying other paths if out of handles */
3430 SAVECOPFILE_FREE(&PL_compiling);
3431 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3432 SvREFCNT_dec(namesv);
3434 if (PL_op->op_type == OP_REQUIRE) {
3435 const char *msgstr = name;
3436 if(errno == EMFILE) {
3438 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3440 msgstr = SvPV_nolen_const(msg);
3442 if (namesv) { /* did we lookup @INC? */
3443 AV * const ar = GvAVn(PL_incgv);
3445 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3446 "%s in @INC%s%s (@INC contains:",
3448 (instr(msgstr, ".h ")
3449 ? " (change .h to .ph maybe?)" : ""),
3450 (instr(msgstr, ".ph ")
3451 ? " (did you run h2ph?)" : "")
3454 for (i = 0; i <= AvFILL(ar); i++) {
3455 sv_catpvs(msg, " ");
3456 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3458 sv_catpvs(msg, ")");
3459 msgstr = SvPV_nolen_const(msg);
3462 DIE(aTHX_ "Can't locate %s", msgstr);
3468 SETERRNO(0, SS_NORMAL);
3470 /* Assume success here to prevent recursive requirement. */
3471 /* name is never assigned to again, so len is still strlen(name) */
3472 /* Check whether a hook in @INC has already filled %INC */
3474 (void)hv_store(GvHVn(PL_incgv),
3475 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3477 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3479 (void)hv_store(GvHVn(PL_incgv),
3480 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3485 lex_start(NULL, tryrsfp, TRUE);
3489 SAVECOMPILEWARNINGS();
3490 if (PL_dowarn & G_WARN_ALL_ON)
3491 PL_compiling.cop_warnings = pWARN_ALL ;
3492 else if (PL_dowarn & G_WARN_ALL_OFF)
3493 PL_compiling.cop_warnings = pWARN_NONE ;
3495 PL_compiling.cop_warnings = pWARN_STD ;
3497 if (filter_sub || filter_cache) {
3498 SV * const datasv = filter_add(S_run_user_filter, NULL);
3499 IoLINES(datasv) = filter_has_file;
3500 IoTOP_GV(datasv) = (GV *)filter_state;
3501 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3502 IoFMT_GV(datasv) = (GV *)filter_cache;
3505 /* switch to eval mode */
3506 PUSHBLOCK(cx, CXt_EVAL, SP);
3507 PUSHEVAL(cx, name, NULL);
3508 cx->blk_eval.retop = PL_op->op_next;
3510 SAVECOPLINE(&PL_compiling);
3511 CopLINE_set(&PL_compiling, 0);
3515 /* Store and reset encoding. */
3516 encoding = PL_encoding;
3519 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3520 op = DOCATCH(PL_eval_start);
3522 op = PL_op->op_next;
3524 /* Restore encoding. */
3525 PL_encoding = encoding;
3533 register PERL_CONTEXT *cx;
3535 const I32 gimme = GIMME_V;
3536 const I32 was = PL_sub_generation;
3537 char tbuf[TYPE_DIGITS(long) + 12];
3538 char *tmpbuf = tbuf;
3544 HV *saved_hh = NULL;
3545 const char * const fakestr = "_<(eval )";
3546 const int fakelen = 9 + 1;
3548 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3549 saved_hh = (HV*) SvREFCNT_inc(POPs);
3553 TAINT_IF(SvTAINTED(sv));
3554 TAINT_PROPER("eval");
3557 lex_start(sv, NULL, FALSE);
3560 /* switch to eval mode */
3562 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3563 SV * const temp_sv = sv_newmortal();
3564 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3565 (unsigned long)++PL_evalseq,
3566 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3567 tmpbuf = SvPVX(temp_sv);
3568 len = SvCUR(temp_sv);
3571 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3572 SAVECOPFILE_FREE(&PL_compiling);
3573 CopFILE_set(&PL_compiling, tmpbuf+2);
3574 SAVECOPLINE(&PL_compiling);
3575 CopLINE_set(&PL_compiling, 1);
3576 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3577 deleting the eval's FILEGV from the stash before gv_check() runs
3578 (i.e. before run-time proper). To work around the coredump that
3579 ensues, we always turn GvMULTI_on for any globals that were
3580 introduced within evals. See force_ident(). GSAR 96-10-12 */
3581 safestr = savepvn(tmpbuf, len);
3582 SAVEDELETE(PL_defstash, safestr, len);
3584 PL_hints = PL_op->op_targ;
3586 GvHV(PL_hintgv) = saved_hh;
3587 SAVECOMPILEWARNINGS();
3588 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3589 if (PL_compiling.cop_hints_hash) {
3590 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3592 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3593 if (PL_compiling.cop_hints_hash) {
3595 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3596 HINTS_REFCNT_UNLOCK;
3598 /* special case: an eval '' executed within the DB package gets lexically
3599 * placed in the first non-DB CV rather than the current CV - this
3600 * allows the debugger to execute code, find lexicals etc, in the
3601 * scope of the code being debugged. Passing &seq gets find_runcv
3602 * to do the dirty work for us */
3603 runcv = find_runcv(&seq);
3605 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3606 PUSHEVAL(cx, 0, NULL);
3607 cx->blk_eval.retop = PL_op->op_next;
3609 /* prepare to compile string */
3611 if (PERLDB_LINE && PL_curstash != PL_debstash)
3612 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3614 ok = doeval(gimme, NULL, runcv, seq);
3615 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3617 /* Copy in anything fake and short. */
3618 my_strlcpy(safestr, fakestr, fakelen);
3620 return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3630 register PERL_CONTEXT *cx;
3632 const U8 save_flags = PL_op -> op_flags;
3637 retop = cx->blk_eval.retop;
3640 if (gimme == G_VOID)
3642 else if (gimme == G_SCALAR) {
3645 if (SvFLAGS(TOPs) & SVs_TEMP)
3648 *MARK = sv_mortalcopy(TOPs);
3652 *MARK = &PL_sv_undef;
3657 /* in case LEAVE wipes old return values */
3658 for (mark = newsp + 1; mark <= SP; mark++) {
3659 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3660 *mark = sv_mortalcopy(*mark);
3661 TAINT_NOT; /* Each item is independent */
3665 PL_curpm = newpm; /* Don't pop $1 et al till now */
3668 assert(CvDEPTH(PL_compcv) == 1);
3670 CvDEPTH(PL_compcv) = 0;
3673 if (optype == OP_REQUIRE &&
3674 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3676 /* Unassume the success we assumed earlier. */
3677 SV * const nsv = cx->blk_eval.old_namesv;
3678 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3679 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3680 /* die_where() did LEAVE, or we won't be here */
3684 if (!(save_flags & OPf_SPECIAL))
3685 sv_setpvn(ERRSV,"",0);
3691 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3692 close to the related Perl_create_eval_scope. */
3694 Perl_delete_eval_scope(pTHX)
3699 register PERL_CONTEXT *cx;
3706 PERL_UNUSED_VAR(newsp);
3707 PERL_UNUSED_VAR(gimme);
3708 PERL_UNUSED_VAR(optype);
3711 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3712 also needed by Perl_fold_constants. */
3714 Perl_create_eval_scope(pTHX_ U32 flags)
3717 const I32 gimme = GIMME_V;
3722 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3725 PL_in_eval = EVAL_INEVAL;
3726 if (flags & G_KEEPERR)
3727 PL_in_eval |= EVAL_KEEPERR;
3729 sv_setpvn(ERRSV,"",0);
3730 if (flags & G_FAKINGEVAL) {
3731 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3739 PERL_CONTEXT * const cx = create_eval_scope(0);
3740 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3741 return DOCATCH(PL_op->op_next);
3750 register PERL_CONTEXT *cx;
3755 PERL_UNUSED_VAR(optype);
3758 if (gimme == G_VOID)
3760 else if (gimme == G_SCALAR) {
3764 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3767 *MARK = sv_mortalcopy(TOPs);
3771 *MARK = &PL_sv_undef;
3776 /* in case LEAVE wipes old return values */
3778 for (mark = newsp + 1; mark <= SP; mark++) {
3779 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3780 *mark = sv_mortalcopy(*mark);
3781 TAINT_NOT; /* Each item is independent */
3785 PL_curpm = newpm; /* Don't pop $1 et al till now */
3788 sv_setpvn(ERRSV,"",0);
3795 register PERL_CONTEXT *cx;
3796 const I32 gimme = GIMME_V;
3801 if (PL_op->op_targ == 0) {
3802 SV ** const defsv_p = &GvSV(PL_defgv);
3803 *defsv_p = newSVsv(POPs);
3804 SAVECLEARSV(*defsv_p);
3807 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3809 PUSHBLOCK(cx, CXt_GIVEN, SP);
3818 register PERL_CONTEXT *cx;
3822 PERL_UNUSED_CONTEXT;
3825 assert(CxTYPE(cx) == CXt_GIVEN);
3830 PL_curpm = newpm; /* pop $1 et al */
3837 /* Helper routines used by pp_smartmatch */
3839 S_make_matcher(pTHX_ regexp *re)
3842 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3843 PM_SETRE(matcher, ReREFCNT_inc(re));
3845 SAVEFREEOP((OP *) matcher);
3852 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3857 PL_op = (OP *) matcher;
3862 return (SvTRUEx(POPs));
3866 S_destroy_matcher(pTHX_ PMOP *matcher)
3869 PERL_UNUSED_ARG(matcher);
3874 /* Do a smart match */
3877 return do_smartmatch(NULL, NULL);
3880 /* This version of do_smartmatch() implements the
3881 * table of smart matches that is found in perlsyn.
3884 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3889 SV *e = TOPs; /* e is for 'expression' */
3890 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3891 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3892 regexp *this_regex, *other_regex;
3894 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3896 # define SM_REF(type) ( \
3897 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3898 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3900 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3901 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
3902 && NOT_EMPTY_PROTO(This) && (Other = e)) \
3903 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
3904 && NOT_EMPTY_PROTO(This) && (Other = d)))
3906 # define SM_REGEX ( \
3907 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \
3908 && (this_regex = ((struct xregexp *)SvANY(This))->xrx_regexp) \
3911 (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \
3912 && (this_regex = ((struct xregexp *)SvANY(This))->xrx_regexp) \
3916 # define SM_OTHER_REF(type) \
3917 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3919 # define SM_OTHER_REGEX (SvROK(Other) \
3920 && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \
3921 && (other_regex = ((struct xregexp *)SvANY(SvRV(Other)))->xrx_regexp))
3924 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3925 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3927 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3928 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3930 tryAMAGICbinSET(smart, 0);
3932 SP -= 2; /* Pop the values */
3934 /* Take care only to invoke mg_get() once for each argument.
3935 * Currently we do this by copying the SV if it's magical. */
3938 d = sv_mortalcopy(d);
3945 e = sv_mortalcopy(e);
3950 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3952 if (This == SvRV(Other))
3963 c = call_sv(This, G_SCALAR);
3967 else if (SvTEMP(TOPs))
3968 SvREFCNT_inc_void(TOPs);
3973 else if (SM_REF(PVHV)) {
3974 if (SM_OTHER_REF(PVHV)) {
3975 /* Check that the key-sets are identical */
3977 HV *other_hv = (HV *) SvRV(Other);
3979 bool other_tied = FALSE;
3980 U32 this_key_count = 0,
3981 other_key_count = 0;
3983 /* Tied hashes don't know how many keys they have. */
3984 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
3987 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3988 HV * const temp = other_hv;
3989 other_hv = (HV *) This;
3993 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3996 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
3999 /* The hashes have the same number of keys, so it suffices
4000 to check that one is a subset of the other. */
4001 (void) hv_iterinit((HV *) This);
4002 while ( (he = hv_iternext((HV *) This)) ) {
4004 char * const key = hv_iterkey(he, &key_len);
4008 if(!hv_exists(other_hv, key, key_len)) {
4009 (void) hv_iterinit((HV *) This); /* reset iterator */
4015 (void) hv_iterinit(other_hv);
4016 while ( hv_iternext(other_hv) )
4020 other_key_count = HvUSEDKEYS(other_hv);
4022 if (this_key_count != other_key_count)
4027 else if (SM_OTHER_REF(PVAV)) {
4028 AV * const other_av = (AV *) SvRV(Other);
4029 const I32 other_len = av_len(other_av) + 1;
4032 for (i = 0; i < other_len; ++i) {
4033 SV ** const svp = av_fetch(other_av, i, FALSE);
4037 if (svp) { /* ??? When can this not happen? */
4038 key = SvPV(*svp, key_len);
4039 if (hv_exists((HV *) This, key, key_len))
4045 else if (SM_OTHER_REGEX) {
4046 PMOP * const matcher = make_matcher(other_regex);
4049 (void) hv_iterinit((HV *) This);
4050 while ( (he = hv_iternext((HV *) This)) ) {
4051 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4052 (void) hv_iterinit((HV *) This);
4053 destroy_matcher(matcher);
4057 destroy_matcher(matcher);
4061 if (hv_exists_ent((HV *) This, Other, 0))
4067 else if (SM_REF(PVAV)) {
4068 if (SM_OTHER_REF(PVAV)) {
4069 AV *other_av = (AV *) SvRV(Other);
4070 if (av_len((AV *) This) != av_len(other_av))
4074 const I32 other_len = av_len(other_av);
4076 if (NULL == seen_this) {
4077 seen_this = newHV();
4078 (void) sv_2mortal((SV *) seen_this);
4080 if (NULL == seen_other) {
4081 seen_this = newHV();
4082 (void) sv_2mortal((SV *) seen_other);
4084 for(i = 0; i <= other_len; ++i) {
4085 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4086 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4088 if (!this_elem || !other_elem) {
4089 if (this_elem || other_elem)
4092 else if (SM_SEEN_THIS(*this_elem)
4093 || SM_SEEN_OTHER(*other_elem))
4095 if (*this_elem != *other_elem)
4099 (void)hv_store_ent(seen_this,
4100 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4102 (void)hv_store_ent(seen_other,
4103 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4109 (void) do_smartmatch(seen_this, seen_other);
4119 else if (SM_OTHER_REGEX) {
4120 PMOP * const matcher = make_matcher(other_regex);
4121 const I32 this_len = av_len((AV *) This);
4124 for(i = 0; i <= this_len; ++i) {
4125 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4126 if (svp && matcher_matches_sv(matcher, *svp)) {
4127 destroy_matcher(matcher);
4131 destroy_matcher(matcher);
4134 else if (SvIOK(Other) || SvNOK(Other)) {
4137 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4138 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4145 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4155 else if (SvPOK(Other)) {
4156 const I32 this_len = av_len((AV *) This);
4159 for(i = 0; i <= this_len; ++i) {
4160 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4175 else if (!SvOK(d) || !SvOK(e)) {
4176 if (!SvOK(d) && !SvOK(e))
4181 else if (SM_REGEX) {
4182 PMOP * const matcher = make_matcher(this_regex);
4185 PUSHs(matcher_matches_sv(matcher, Other)
4188 destroy_matcher(matcher);
4191 else if (SM_REF(PVCV)) {
4193 /* This must be a null-prototyped sub, because we
4194 already checked for the other kind. */
4200 c = call_sv(This, G_SCALAR);
4203 PUSHs(&PL_sv_undef);
4204 else if (SvTEMP(TOPs))
4205 SvREFCNT_inc_void(TOPs);
4207 if (SM_OTHER_REF(PVCV)) {
4208 /* This one has to be null-proto'd too.
4209 Call both of 'em, and compare the results */
4211 c = call_sv(SvRV(Other), G_SCALAR);
4214 PUSHs(&PL_sv_undef);
4215 else if (SvTEMP(TOPs))
4216 SvREFCNT_inc_void(TOPs);
4227 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4228 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4230 if (SvPOK(Other) && !looks_like_number(Other)) {
4231 /* String comparison */
4236 /* Otherwise, numeric comparison */
4239 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4250 /* As a last resort, use string comparison */
4259 register PERL_CONTEXT *cx;
4260 const I32 gimme = GIMME_V;
4262 /* This is essentially an optimization: if the match
4263 fails, we don't want to push a context and then
4264 pop it again right away, so we skip straight
4265 to the op that follows the leavewhen.
4267 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4268 return cLOGOP->op_other->op_next;
4273 PUSHBLOCK(cx, CXt_WHEN, SP);
4282 register PERL_CONTEXT *cx;
4288 assert(CxTYPE(cx) == CXt_WHEN);
4293 PL_curpm = newpm; /* pop $1 et al */
4303 register PERL_CONTEXT *cx;
4306 cxix = dopoptowhen(cxstack_ix);
4308 DIE(aTHX_ "Can't \"continue\" outside a when block");
4309 if (cxix < cxstack_ix)
4312 /* clear off anything above the scope we're re-entering */
4313 inner = PL_scopestack_ix;
4315 if (PL_scopestack_ix < inner)
4316 leave_scope(PL_scopestack[PL_scopestack_ix]);
4317 PL_curcop = cx->blk_oldcop;
4318 return cx->blk_givwhen.leave_op;
4325 register PERL_CONTEXT *cx;
4328 cxix = dopoptogiven(cxstack_ix);
4330 if (PL_op->op_flags & OPf_SPECIAL)
4331 DIE(aTHX_ "Can't use when() outside a topicalizer");
4333 DIE(aTHX_ "Can't \"break\" outside a given block");
4335 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4336 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4338 if (cxix < cxstack_ix)
4341 /* clear off anything above the scope we're re-entering */
4342 inner = PL_scopestack_ix;
4344 if (PL_scopestack_ix < inner)
4345 leave_scope(PL_scopestack[PL_scopestack_ix]);
4346 PL_curcop = cx->blk_oldcop;
4349 return CX_LOOP_NEXTOP_GET(cx);
4351 return cx->blk_givwhen.leave_op;
4355 S_doparseform(pTHX_ SV *sv)
4358 register char *s = SvPV_force(sv, len);
4359 register char * const send = s + len;
4360 register char *base = NULL;
4361 register I32 skipspaces = 0;
4362 bool noblank = FALSE;
4363 bool repeat = FALSE;
4364 bool postspace = FALSE;
4370 bool unchopnum = FALSE;
4371 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4374 Perl_croak(aTHX_ "Null picture in formline");
4376 /* estimate the buffer size needed */
4377 for (base = s; s <= send; s++) {
4378 if (*s == '\n' || *s == '@' || *s == '^')
4384 Newx(fops, maxops, U32);
4389 *fpc++ = FF_LINEMARK;
4390 noblank = repeat = FALSE;
4408 case ' ': case '\t':
4415 } /* else FALL THROUGH */
4423 *fpc++ = FF_LITERAL;
4431 *fpc++ = (U16)skipspaces;
4435 *fpc++ = FF_NEWLINE;
4439 arg = fpc - linepc + 1;
4446 *fpc++ = FF_LINEMARK;
4447 noblank = repeat = FALSE;
4456 ischop = s[-1] == '^';
4462 arg = (s - base) - 1;
4464 *fpc++ = FF_LITERAL;
4472 *fpc++ = 2; /* skip the @* or ^* */
4474 *fpc++ = FF_LINESNGL;
4477 *fpc++ = FF_LINEGLOB;
4479 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4480 arg = ischop ? 512 : 0;
4485 const char * const f = ++s;
4488 arg |= 256 + (s - f);
4490 *fpc++ = s - base; /* fieldsize for FETCH */
4491 *fpc++ = FF_DECIMAL;
4493 unchopnum |= ! ischop;
4495 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4496 arg = ischop ? 512 : 0;
4498 s++; /* skip the '0' first */
4502 const char * const f = ++s;
4505 arg |= 256 + (s - f);
4507 *fpc++ = s - base; /* fieldsize for FETCH */
4508 *fpc++ = FF_0DECIMAL;
4510 unchopnum |= ! ischop;
4514 bool ismore = FALSE;
4517 while (*++s == '>') ;
4518 prespace = FF_SPACE;
4520 else if (*s == '|') {
4521 while (*++s == '|') ;
4522 prespace = FF_HALFSPACE;
4527 while (*++s == '<') ;
4530 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4534 *fpc++ = s - base; /* fieldsize for FETCH */
4536 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4539 *fpc++ = (U16)prespace;
4553 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4555 { /* need to jump to the next word */
4557 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4558 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4559 s = SvPVX(sv) + SvCUR(sv) + z;
4561 Copy(fops, s, arg, U32);
4563 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4566 if (unchopnum && repeat)
4567 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4573 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4575 /* Can value be printed in fldsize chars, using %*.*f ? */
4579 int intsize = fldsize - (value < 0 ? 1 : 0);
4586 while (intsize--) pwr *= 10.0;
4587 while (frcsize--) eps /= 10.0;
4590 if (value + eps >= pwr)
4593 if (value - eps <= -pwr)
4600 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4603 SV * const datasv = FILTER_DATA(idx);
4604 const int filter_has_file = IoLINES(datasv);
4605 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4606 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4610 const char *got_p = NULL;
4611 const char *prune_from = NULL;
4612 bool read_from_cache = FALSE;
4615 assert(maxlen >= 0);
4618 /* I was having segfault trouble under Linux 2.2.5 after a
4619 parse error occured. (Had to hack around it with a test
4620 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4621 not sure where the trouble is yet. XXX */
4623 if (IoFMT_GV(datasv)) {
4624 SV *const cache = (SV *)IoFMT_GV(datasv);
4627 const char *cache_p = SvPV(cache, cache_len);
4631 /* Running in block mode and we have some cached data already.
4633 if (cache_len >= umaxlen) {
4634 /* In fact, so much data we don't even need to call
4639 const char *const first_nl =
4640 (const char *)memchr(cache_p, '\n', cache_len);
4642 take = first_nl + 1 - cache_p;
4646 sv_catpvn(buf_sv, cache_p, take);
4647 sv_chop(cache, cache_p + take);
4648 /* Definately not EOF */
4652 sv_catsv(buf_sv, cache);
4654 umaxlen -= cache_len;
4657 read_from_cache = TRUE;
4661 /* Filter API says that the filter appends to the contents of the buffer.
4662 Usually the buffer is "", so the details don't matter. But if it's not,
4663 then clearly what it contains is already filtered by this filter, so we
4664 don't want to pass it in a second time.
4665 I'm going to use a mortal in case the upstream filter croaks. */
4666 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4667 ? sv_newmortal() : buf_sv;
4668 SvUPGRADE(upstream, SVt_PV);
4670 if (filter_has_file) {
4671 status = FILTER_READ(idx+1, upstream, 0);
4674 if (filter_sub && status >= 0) {
4685 PUSHs(sv_2mortal(newSViv(0)));
4687 PUSHs(filter_state);
4690 count = call_sv(filter_sub, G_SCALAR);
4705 if(SvOK(upstream)) {
4706 got_p = SvPV(upstream, got_len);
4708 if (got_len > umaxlen) {
4709 prune_from = got_p + umaxlen;
4712 const char *const first_nl =
4713 (const char *)memchr(got_p, '\n', got_len);
4714 if (first_nl && first_nl + 1 < got_p + got_len) {
4715 /* There's a second line here... */
4716 prune_from = first_nl + 1;
4721 /* Oh. Too long. Stuff some in our cache. */
4722 STRLEN cached_len = got_p + got_len - prune_from;
4723 SV *cache = (SV *)IoFMT_GV(datasv);
4726 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4727 } else if (SvOK(cache)) {
4728 /* Cache should be empty. */
4729 assert(!SvCUR(cache));
4732 sv_setpvn(cache, prune_from, cached_len);
4733 /* If you ask for block mode, you may well split UTF-8 characters.
4734 "If it breaks, you get to keep both parts"
4735 (Your code is broken if you don't put them back together again
4736 before something notices.) */
4737 if (SvUTF8(upstream)) {
4740 SvCUR_set(upstream, got_len - cached_len);
4741 /* Can't yet be EOF */
4746 /* If they are at EOF but buf_sv has something in it, then they may never
4747 have touched the SV upstream, so it may be undefined. If we naively
4748 concatenate it then we get a warning about use of uninitialised value.
4750 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4751 sv_catsv(buf_sv, upstream);
4755 IoLINES(datasv) = 0;
4756 SvREFCNT_dec(IoFMT_GV(datasv));
4758 SvREFCNT_dec(filter_state);
4759 IoTOP_GV(datasv) = NULL;
4762 SvREFCNT_dec(filter_sub);
4763 IoBOTTOM_GV(datasv) = NULL;
4765 filter_del(S_run_user_filter);
4767 if (status == 0 && read_from_cache) {
4768 /* If we read some data from the cache (and by getting here it implies
4769 that we emptied the cache) then we aren't yet at EOF, and mustn't
4770 report that to our caller. */
4776 /* perhaps someone can come up with a better name for
4777 this? it is not really "absolute", per se ... */
4779 S_path_is_absolute(const char *name)
4781 if (PERL_FILE_IS_ABSOLUTE(name)
4782 #ifdef MACOS_TRADITIONAL
4785 || (*name == '.' && (name[1] == '/' ||
4786 (name[1] == '.' && name[2] == '/')))
4798 * c-indentation-style: bsd
4800 * indent-tabs-mode: t
4803 * ex: set ts=8 sts=4 sw=4 noet: