3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
20 /* This file contains control-oriented pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
26 * Control-oriented means things like pp_enteriter() and pp_next(), which
27 * alter the flow of control of the program.
32 #define PERL_IN_PP_CTL_C
36 #define WORD_ALIGN sizeof(U32)
39 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
41 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
50 cxix = dopoptosub(cxstack_ix);
54 switch (cxstack[cxix].blk_gimme) {
67 /* XXXX Should store the old value to allow for tie/overload - and
68 restore in regcomp, where marked with XXXX. */
78 register PMOP *pm = (PMOP*)cLOGOP->op_other;
83 /* prevent recompiling under /o and ithreads. */
84 #if defined(USE_ITHREADS)
85 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
86 if (PL_op->op_flags & OPf_STACKED) {
95 if (PL_op->op_flags & OPf_STACKED) {
96 /* multiple args; concatentate them */
98 tmpstr = PAD_SV(ARGTARG);
99 sv_setpvn(tmpstr, "", 0);
100 while (++MARK <= SP) {
101 if (PL_amagic_generation) {
103 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
104 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
106 sv_setsv(tmpstr, sv);
110 sv_catsv(tmpstr, *MARK);
119 SV * const sv = SvRV(tmpstr);
121 mg = mg_find(sv, PERL_MAGIC_qr);
124 regexp * const re = reg_temp_copy((regexp *)mg->mg_obj);
125 ReREFCNT_dec(PM_GETRE(pm));
130 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
133 /* Check against the last compiled regexp. */
134 if (!re || !re->precomp || re->prelen != (I32)len ||
135 memNE(re->precomp, t, len))
137 const regexp_engine *eng = re ? re->engine : NULL;
138 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
141 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
142 } else if (PL_curcop->cop_hints_hash) {
143 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
145 if (ptr && SvIOK(ptr) && SvIV(ptr))
146 eng = INT2PTR(regexp_engine*,SvIV(ptr));
149 if (PL_op->op_flags & OPf_SPECIAL)
150 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
153 pm_flags |= RXf_UTF8;
156 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
158 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
160 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
161 inside tie/overload accessors. */
167 #ifndef INCOMPLETE_TAINTS
170 re->extflags |= RXf_TAINTED;
172 re->extflags &= ~RXf_TAINTED;
176 if (!PM_GETRE(pm)->prelen && PL_curpm)
180 #if !defined(USE_ITHREADS)
181 /* can't change the optree at runtime either */
182 /* PMf_KEEP is handled differently under threads to avoid these problems */
183 if (pm->op_pmflags & PMf_KEEP) {
184 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
185 cLOGOP->op_first->op_next = PL_op->op_next;
195 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
196 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
197 register SV * const dstr = cx->sb_dstr;
198 register char *s = cx->sb_s;
199 register char *m = cx->sb_m;
200 char *orig = cx->sb_orig;
201 register REGEXP * const rx = cx->sb_rx;
203 REGEXP *old = PM_GETRE(pm);
207 PM_SETRE(pm,ReREFCNT_inc(rx));
210 rxres_restore(&cx->sb_rxres, rx);
211 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
213 if (cx->sb_iters++) {
214 const I32 saviters = cx->sb_iters;
215 if (cx->sb_iters > cx->sb_maxiters)
216 DIE(aTHX_ "Substitution loop");
218 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
219 cx->sb_rxtainted |= 2;
220 sv_catsv(dstr, POPs);
221 FREETMPS; /* Prevent excess tmp stack */
224 if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
225 s == m, cx->sb_targ, NULL,
226 ((cx->sb_rflags & REXEC_COPY_STR)
227 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
228 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
230 SV * const targ = cx->sb_targ;
232 assert(cx->sb_strend >= s);
233 if(cx->sb_strend > s) {
234 if (DO_UTF8(dstr) && !SvUTF8(targ))
235 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
237 sv_catpvn(dstr, s, cx->sb_strend - s);
239 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
241 #ifdef PERL_OLD_COPY_ON_WRITE
243 sv_force_normal_flags(targ, SV_COW_DROP_PV);
249 SvPV_set(targ, SvPVX(dstr));
250 SvCUR_set(targ, SvCUR(dstr));
251 SvLEN_set(targ, SvLEN(dstr));
254 SvPV_set(dstr, NULL);
256 TAINT_IF(cx->sb_rxtainted & 1);
257 PUSHs(sv_2mortal(newSViv(saviters - 1)));
259 (void)SvPOK_only_UTF8(targ);
260 TAINT_IF(cx->sb_rxtainted);
264 LEAVE_SCOPE(cx->sb_oldsave);
266 RETURNOP(pm->op_next);
268 cx->sb_iters = saviters;
270 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
273 cx->sb_orig = orig = rx->subbeg;
275 cx->sb_strend = s + (cx->sb_strend - m);
277 cx->sb_m = m = rx->offs[0].start + orig;
279 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
280 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
282 sv_catpvn(dstr, s, m-s);
284 cx->sb_s = rx->offs[0].end + orig;
285 { /* Update the pos() information. */
286 SV * const sv = cx->sb_targ;
289 SvUPGRADE(sv, SVt_PVMG);
290 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
291 #ifdef PERL_OLD_COPY_ON_WRITE
293 sv_force_normal_flags(sv, 0);
295 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
304 (void)ReREFCNT_inc(rx);
305 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
306 rxres_save(&cx->sb_rxres, rx);
307 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
311 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
317 if (!p || p[1] < rx->nparens) {
318 #ifdef PERL_OLD_COPY_ON_WRITE
319 i = 7 + rx->nparens * 2;
321 i = 6 + rx->nparens * 2;
330 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : NULL);
331 RX_MATCH_COPIED_off(rx);
333 #ifdef PERL_OLD_COPY_ON_WRITE
334 *p++ = PTR2UV(rx->saved_copy);
335 rx->saved_copy = NULL;
340 *p++ = PTR2UV(rx->subbeg);
341 *p++ = (UV)rx->sublen;
342 for (i = 0; i <= rx->nparens; ++i) {
343 *p++ = (UV)rx->offs[i].start;
344 *p++ = (UV)rx->offs[i].end;
349 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
355 RX_MATCH_COPY_FREE(rx);
356 RX_MATCH_COPIED_set(rx, *p);
359 #ifdef PERL_OLD_COPY_ON_WRITE
361 SvREFCNT_dec (rx->saved_copy);
362 rx->saved_copy = INT2PTR(SV*,*p);
368 rx->subbeg = INT2PTR(char*,*p++);
369 rx->sublen = (I32)(*p++);
370 for (i = 0; i <= rx->nparens; ++i) {
371 rx->offs[i].start = (I32)(*p++);
372 rx->offs[i].end = (I32)(*p++);
377 Perl_rxres_free(pTHX_ void **rsp)
379 UV * const p = (UV*)*rsp;
384 void *tmp = INT2PTR(char*,*p);
387 PoisonFree(*p, 1, sizeof(*p));
389 Safefree(INT2PTR(char*,*p));
391 #ifdef PERL_OLD_COPY_ON_WRITE
393 SvREFCNT_dec (INT2PTR(SV*,p[1]));
403 dVAR; dSP; dMARK; dORIGMARK;
404 register SV * const tmpForm = *++MARK;
409 register SV *sv = NULL;
410 const char *item = NULL;
414 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
415 const char *chophere = NULL;
416 char *linemark = NULL;
418 bool gotsome = FALSE;
420 const STRLEN fudge = SvPOK(tmpForm)
421 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
422 bool item_is_utf8 = FALSE;
423 bool targ_is_utf8 = FALSE;
425 OP * parseres = NULL;
429 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
430 if (SvREADONLY(tmpForm)) {
431 SvREADONLY_off(tmpForm);
432 parseres = doparseform(tmpForm);
433 SvREADONLY_on(tmpForm);
436 parseres = doparseform(tmpForm);
440 SvPV_force(PL_formtarget, len);
441 if (DO_UTF8(PL_formtarget))
443 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
445 f = SvPV_const(tmpForm, len);
446 /* need to jump to the next word */
447 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
451 const char *name = "???";
454 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
455 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
456 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
457 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
458 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
460 case FF_CHECKNL: name = "CHECKNL"; break;
461 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
462 case FF_SPACE: name = "SPACE"; break;
463 case FF_HALFSPACE: name = "HALFSPACE"; break;
464 case FF_ITEM: name = "ITEM"; break;
465 case FF_CHOP: name = "CHOP"; break;
466 case FF_LINEGLOB: name = "LINEGLOB"; break;
467 case FF_NEWLINE: name = "NEWLINE"; break;
468 case FF_MORE: name = "MORE"; break;
469 case FF_LINEMARK: name = "LINEMARK"; break;
470 case FF_END: name = "END"; break;
471 case FF_0DECIMAL: name = "0DECIMAL"; break;
472 case FF_LINESNGL: name = "LINESNGL"; break;
475 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
477 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
488 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
489 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
491 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
492 t = SvEND(PL_formtarget);
495 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
496 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
498 sv_utf8_upgrade(PL_formtarget);
499 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
500 t = SvEND(PL_formtarget);
520 if (ckWARN(WARN_SYNTAX))
521 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
528 const char *s = item = SvPV_const(sv, len);
531 itemsize = sv_len_utf8(sv);
532 if (itemsize != (I32)len) {
534 if (itemsize > fieldsize) {
535 itemsize = fieldsize;
536 itembytes = itemsize;
537 sv_pos_u2b(sv, &itembytes, 0);
541 send = chophere = s + itembytes;
551 sv_pos_b2u(sv, &itemsize);
555 item_is_utf8 = FALSE;
556 if (itemsize > fieldsize)
557 itemsize = fieldsize;
558 send = chophere = s + itemsize;
572 const char *s = item = SvPV_const(sv, len);
575 itemsize = sv_len_utf8(sv);
576 if (itemsize != (I32)len) {
578 if (itemsize <= fieldsize) {
579 const char *send = chophere = s + itemsize;
592 itemsize = fieldsize;
593 itembytes = itemsize;
594 sv_pos_u2b(sv, &itembytes, 0);
595 send = chophere = s + itembytes;
596 while (s < send || (s == send && isSPACE(*s))) {
606 if (strchr(PL_chopset, *s))
611 itemsize = chophere - item;
612 sv_pos_b2u(sv, &itemsize);
618 item_is_utf8 = FALSE;
619 if (itemsize <= fieldsize) {
620 const char *const send = chophere = s + itemsize;
633 itemsize = fieldsize;
634 send = chophere = s + itemsize;
635 while (s < send || (s == send && isSPACE(*s))) {
645 if (strchr(PL_chopset, *s))
650 itemsize = chophere - item;
656 arg = fieldsize - itemsize;
665 arg = fieldsize - itemsize;
676 const char *s = item;
680 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
682 sv_utf8_upgrade(PL_formtarget);
683 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
684 t = SvEND(PL_formtarget);
688 if (UTF8_IS_CONTINUED(*s)) {
689 STRLEN skip = UTF8SKIP(s);
706 if ( !((*t++ = *s++) & ~31) )
712 if (targ_is_utf8 && !item_is_utf8) {
713 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
715 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
716 for (; t < SvEND(PL_formtarget); t++) {
729 const int ch = *t++ = *s++;
732 if ( !((*t++ = *s++) & ~31) )
741 const char *s = chophere;
759 const char *s = item = SvPV_const(sv, len);
761 if ((item_is_utf8 = DO_UTF8(sv)))
762 itemsize = sv_len_utf8(sv);
764 bool chopped = FALSE;
765 const char *const send = s + len;
767 chophere = s + itemsize;
783 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
785 SvUTF8_on(PL_formtarget);
787 SvCUR_set(sv, chophere - item);
788 sv_catsv(PL_formtarget, sv);
789 SvCUR_set(sv, itemsize);
791 sv_catsv(PL_formtarget, sv);
793 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
794 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
795 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
804 #if defined(USE_LONG_DOUBLE)
807 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
811 "%#0*.*f" : "%0*.*f");
816 #if defined(USE_LONG_DOUBLE)
818 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
821 ((arg & 256) ? "%#*.*f" : "%*.*f");
824 /* If the field is marked with ^ and the value is undefined,
826 if ((arg & 512) && !SvOK(sv)) {
834 /* overflow evidence */
835 if (num_overflow(value, fieldsize, arg)) {
841 /* Formats aren't yet marked for locales, so assume "yes". */
843 STORE_NUMERIC_STANDARD_SET_LOCAL();
844 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
845 RESTORE_NUMERIC_STANDARD();
852 while (t-- > linemark && *t == ' ') ;
860 if (arg) { /* repeat until fields exhausted? */
862 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
863 lines += FmLINES(PL_formtarget);
866 if (strnEQ(linemark, linemark - arg, arg))
867 DIE(aTHX_ "Runaway format");
870 SvUTF8_on(PL_formtarget);
871 FmLINES(PL_formtarget) = lines;
873 RETURNOP(cLISTOP->op_first);
884 const char *s = chophere;
885 const char *send = item + len;
887 while (isSPACE(*s) && (s < send))
892 arg = fieldsize - itemsize;
899 if (strnEQ(s1," ",3)) {
900 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
911 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
913 SvUTF8_on(PL_formtarget);
914 FmLINES(PL_formtarget) += lines;
926 if (PL_stack_base + *PL_markstack_ptr == SP) {
928 if (GIMME_V == G_SCALAR)
929 XPUSHs(sv_2mortal(newSViv(0)));
930 RETURNOP(PL_op->op_next->op_next);
932 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
933 pp_pushmark(); /* push dst */
934 pp_pushmark(); /* push src */
935 ENTER; /* enter outer scope */
938 if (PL_op->op_private & OPpGREP_LEX)
939 SAVESPTR(PAD_SVl(PL_op->op_targ));
942 ENTER; /* enter inner scope */
945 src = PL_stack_base[*PL_markstack_ptr];
947 if (PL_op->op_private & OPpGREP_LEX)
948 PAD_SVl(PL_op->op_targ) = src;
953 if (PL_op->op_type == OP_MAPSTART)
954 pp_pushmark(); /* push top */
955 return ((LOGOP*)PL_op->op_next)->op_other;
961 const I32 gimme = GIMME_V;
962 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
968 /* first, move source pointer to the next item in the source list */
969 ++PL_markstack_ptr[-1];
971 /* if there are new items, push them into the destination list */
972 if (items && gimme != G_VOID) {
973 /* might need to make room back there first */
974 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
975 /* XXX this implementation is very pessimal because the stack
976 * is repeatedly extended for every set of items. Is possible
977 * to do this without any stack extension or copying at all
978 * by maintaining a separate list over which the map iterates
979 * (like foreach does). --gsar */
981 /* everything in the stack after the destination list moves
982 * towards the end the stack by the amount of room needed */
983 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
985 /* items to shift up (accounting for the moved source pointer) */
986 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
988 /* This optimization is by Ben Tilly and it does
989 * things differently from what Sarathy (gsar)
990 * is describing. The downside of this optimization is
991 * that leaves "holes" (uninitialized and hopefully unused areas)
992 * to the Perl stack, but on the other hand this
993 * shouldn't be a problem. If Sarathy's idea gets
994 * implemented, this optimization should become
995 * irrelevant. --jhi */
997 shift = count; /* Avoid shifting too often --Ben Tilly */
1001 dst = (SP += shift);
1002 PL_markstack_ptr[-1] += shift;
1003 *PL_markstack_ptr += shift;
1007 /* copy the new items down to the destination list */
1008 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1009 if (gimme == G_ARRAY) {
1011 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1014 /* scalar context: we don't care about which values map returns
1015 * (we use undef here). And so we certainly don't want to do mortal
1016 * copies of meaningless values. */
1017 while (items-- > 0) {
1019 *dst-- = &PL_sv_undef;
1023 LEAVE; /* exit inner scope */
1026 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1028 (void)POPMARK; /* pop top */
1029 LEAVE; /* exit outer scope */
1030 (void)POPMARK; /* pop src */
1031 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1032 (void)POPMARK; /* pop dst */
1033 SP = PL_stack_base + POPMARK; /* pop original mark */
1034 if (gimme == G_SCALAR) {
1035 if (PL_op->op_private & OPpGREP_LEX) {
1036 SV* sv = sv_newmortal();
1037 sv_setiv(sv, items);
1045 else if (gimme == G_ARRAY)
1052 ENTER; /* enter inner scope */
1055 /* set $_ to the new source item */
1056 src = PL_stack_base[PL_markstack_ptr[-1]];
1058 if (PL_op->op_private & OPpGREP_LEX)
1059 PAD_SVl(PL_op->op_targ) = src;
1063 RETURNOP(cLOGOP->op_other);
1072 if (GIMME == G_ARRAY)
1074 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1075 return cLOGOP->op_other;
1085 if (GIMME == G_ARRAY) {
1086 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1090 SV * const targ = PAD_SV(PL_op->op_targ);
1093 if (PL_op->op_private & OPpFLIP_LINENUM) {
1094 if (GvIO(PL_last_in_gv)) {
1095 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1098 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1100 flip = SvIV(sv) == SvIV(GvSV(gv));
1106 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1107 if (PL_op->op_flags & OPf_SPECIAL) {
1115 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1118 sv_setpvn(TARG, "", 0);
1124 /* This code tries to decide if "$left .. $right" should use the
1125 magical string increment, or if the range is numeric (we make
1126 an exception for .."0" [#18165]). AMS 20021031. */
1128 #define RANGE_IS_NUMERIC(left,right) ( \
1129 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1130 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1131 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1132 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1133 && (!SvOK(right) || looks_like_number(right))))
1139 if (GIMME == G_ARRAY) {
1145 if (RANGE_IS_NUMERIC(left,right)) {
1148 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1149 (SvOK(right) && SvNV(right) > IV_MAX))
1150 DIE(aTHX_ "Range iterator outside integer range");
1161 SV * const sv = sv_2mortal(newSViv(i++));
1166 SV * const final = sv_mortalcopy(right);
1168 const char * const tmps = SvPV_const(final, len);
1170 SV *sv = sv_mortalcopy(left);
1171 SvPV_force_nolen(sv);
1172 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1174 if (strEQ(SvPVX_const(sv),tmps))
1176 sv = sv_2mortal(newSVsv(sv));
1183 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1187 if (PL_op->op_private & OPpFLIP_LINENUM) {
1188 if (GvIO(PL_last_in_gv)) {
1189 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1192 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1193 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1201 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1202 sv_catpvs(targ, "E0");
1212 static const char * const context_name[] = {
1225 S_dopoptolabel(pTHX_ const char *label)
1230 for (i = cxstack_ix; i >= 0; i--) {
1231 register const PERL_CONTEXT * const cx = &cxstack[i];
1232 switch (CxTYPE(cx)) {
1240 if (ckWARN(WARN_EXITING))
1241 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1242 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1243 if (CxTYPE(cx) == CXt_NULL)
1247 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1248 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1249 (long)i, cx->blk_loop.label));
1252 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1262 Perl_dowantarray(pTHX)
1265 const I32 gimme = block_gimme();
1266 return (gimme == G_VOID) ? G_SCALAR : gimme;
1270 Perl_block_gimme(pTHX)
1273 const I32 cxix = dopoptosub(cxstack_ix);
1277 switch (cxstack[cxix].blk_gimme) {
1285 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1292 Perl_is_lvalue_sub(pTHX)
1295 const I32 cxix = dopoptosub(cxstack_ix);
1296 assert(cxix >= 0); /* We should only be called from inside subs */
1298 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1299 return cxstack[cxix].blk_sub.lval;
1305 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1309 for (i = startingblock; i >= 0; i--) {
1310 register const PERL_CONTEXT * const cx = &cxstk[i];
1311 switch (CxTYPE(cx)) {
1317 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1325 S_dopoptoeval(pTHX_ I32 startingblock)
1329 for (i = startingblock; i >= 0; i--) {
1330 register const PERL_CONTEXT *cx = &cxstack[i];
1331 switch (CxTYPE(cx)) {
1335 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1343 S_dopoptoloop(pTHX_ I32 startingblock)
1347 for (i = startingblock; i >= 0; i--) {
1348 register const PERL_CONTEXT * const cx = &cxstack[i];
1349 switch (CxTYPE(cx)) {
1355 if (ckWARN(WARN_EXITING))
1356 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1357 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1358 if ((CxTYPE(cx)) == CXt_NULL)
1362 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1370 S_dopoptogiven(pTHX_ I32 startingblock)
1374 for (i = startingblock; i >= 0; i--) {
1375 register const PERL_CONTEXT *cx = &cxstack[i];
1376 switch (CxTYPE(cx)) {
1380 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1383 if (CxFOREACHDEF(cx)) {
1384 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1393 S_dopoptowhen(pTHX_ I32 startingblock)
1397 for (i = startingblock; i >= 0; i--) {
1398 register const PERL_CONTEXT *cx = &cxstack[i];
1399 switch (CxTYPE(cx)) {
1403 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1411 Perl_dounwind(pTHX_ I32 cxix)
1416 while (cxstack_ix > cxix) {
1418 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1419 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1420 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1421 /* Note: we don't need to restore the base context info till the end. */
1422 switch (CxTYPE(cx)) {
1425 continue; /* not break */
1444 PERL_UNUSED_VAR(optype);
1448 Perl_qerror(pTHX_ SV *err)
1452 sv_catsv(ERRSV, err);
1454 sv_catsv(PL_errors, err);
1456 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1458 ++PL_parser->error_count;
1462 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1471 if (PL_in_eval & EVAL_KEEPERR) {
1472 static const char prefix[] = "\t(in cleanup) ";
1473 SV * const err = ERRSV;
1474 const char *e = NULL;
1476 sv_setpvn(err,"",0);
1477 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1479 e = SvPV_const(err, len);
1481 if (*e != *message || strNE(e,message))
1485 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1486 sv_catpvn(err, prefix, sizeof(prefix)-1);
1487 sv_catpvn(err, message, msglen);
1488 if (ckWARN(WARN_MISC)) {
1489 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1490 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1495 sv_setpvn(ERRSV, message, msglen);
1499 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1500 && PL_curstackinfo->si_prev)
1508 register PERL_CONTEXT *cx;
1511 if (cxix < cxstack_ix)
1514 POPBLOCK(cx,PL_curpm);
1515 if (CxTYPE(cx) != CXt_EVAL) {
1517 message = SvPVx_const(ERRSV, msglen);
1518 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1519 PerlIO_write(Perl_error_log, message, msglen);
1524 if (gimme == G_SCALAR)
1525 *++newsp = &PL_sv_undef;
1526 PL_stack_sp = newsp;
1530 /* LEAVE could clobber PL_curcop (see save_re_context())
1531 * XXX it might be better to find a way to avoid messing with
1532 * PL_curcop in save_re_context() instead, but this is a more
1533 * minimal fix --GSAR */
1534 PL_curcop = cx->blk_oldcop;
1536 if (optype == OP_REQUIRE) {
1537 const char* const msg = SvPVx_nolen_const(ERRSV);
1538 SV * const nsv = cx->blk_eval.old_namesv;
1539 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1541 DIE(aTHX_ "%sCompilation failed in require",
1542 *msg ? msg : "Unknown error\n");
1544 assert(CxTYPE(cx) == CXt_EVAL);
1545 return cx->blk_eval.retop;
1549 message = SvPVx_const(ERRSV, msglen);
1551 write_to_stderr(message, msglen);
1559 dVAR; dSP; dPOPTOPssrl;
1560 if (SvTRUE(left) != SvTRUE(right))
1570 register I32 cxix = dopoptosub(cxstack_ix);
1571 register const PERL_CONTEXT *cx;
1572 register const PERL_CONTEXT *ccstack = cxstack;
1573 const PERL_SI *top_si = PL_curstackinfo;
1575 const char *stashname;
1582 /* we may be in a higher stacklevel, so dig down deeper */
1583 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1584 top_si = top_si->si_prev;
1585 ccstack = top_si->si_cxstack;
1586 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1589 if (GIMME != G_ARRAY) {
1595 /* caller() should not report the automatic calls to &DB::sub */
1596 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1597 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1601 cxix = dopoptosub_at(ccstack, cxix - 1);
1604 cx = &ccstack[cxix];
1605 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1606 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1607 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1608 field below is defined for any cx. */
1609 /* caller() should not report the automatic calls to &DB::sub */
1610 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1611 cx = &ccstack[dbcxix];
1614 stashname = CopSTASHPV(cx->blk_oldcop);
1615 if (GIMME != G_ARRAY) {
1618 PUSHs(&PL_sv_undef);
1621 sv_setpv(TARG, stashname);
1630 PUSHs(&PL_sv_undef);
1632 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1633 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1634 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1637 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1638 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1639 /* So is ccstack[dbcxix]. */
1641 SV * const sv = newSV(0);
1642 gv_efullname3(sv, cvgv, NULL);
1643 PUSHs(sv_2mortal(sv));
1644 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1647 PUSHs(sv_2mortal(newSVpvs("(unknown)")));
1648 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1652 PUSHs(sv_2mortal(newSVpvs("(eval)")));
1653 PUSHs(sv_2mortal(newSViv(0)));
1655 gimme = (I32)cx->blk_gimme;
1656 if (gimme == G_VOID)
1657 PUSHs(&PL_sv_undef);
1659 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1660 if (CxTYPE(cx) == CXt_EVAL) {
1662 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1663 PUSHs(cx->blk_eval.cur_text);
1667 else if (cx->blk_eval.old_namesv) {
1668 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1671 /* eval BLOCK (try blocks have old_namesv == 0) */
1673 PUSHs(&PL_sv_undef);
1674 PUSHs(&PL_sv_undef);
1678 PUSHs(&PL_sv_undef);
1679 PUSHs(&PL_sv_undef);
1681 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1682 && CopSTASH_eq(PL_curcop, PL_debstash))
1684 AV * const ary = cx->blk_sub.argarray;
1685 const int off = AvARRAY(ary) - AvALLOC(ary);
1688 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1689 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1691 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1694 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1695 av_extend(PL_dbargs, AvFILLp(ary) + off);
1696 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1697 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1699 /* XXX only hints propagated via op_private are currently
1700 * visible (others are not easily accessible, since they
1701 * use the global PL_hints) */
1702 PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
1705 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1707 if (old_warnings == pWARN_NONE ||
1708 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1709 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1710 else if (old_warnings == pWARN_ALL ||
1711 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1712 /* Get the bit mask for $warnings::Bits{all}, because
1713 * it could have been extended by warnings::register */
1715 HV * const bits = get_hv("warnings::Bits", FALSE);
1716 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1717 mask = newSVsv(*bits_all);
1720 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1724 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1725 PUSHs(sv_2mortal(mask));
1728 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1729 sv_2mortal(newRV_noinc(
1730 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1731 cx->blk_oldcop->cop_hints_hash)))
1740 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1741 sv_reset(tmps, CopSTASH(PL_curcop));
1746 /* like pp_nextstate, but used instead when the debugger is active */
1751 PL_curcop = (COP*)PL_op;
1752 TAINT_NOT; /* Each statement is presumed innocent */
1753 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1756 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1757 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1760 register PERL_CONTEXT *cx;
1761 const I32 gimme = G_ARRAY;
1763 GV * const gv = PL_DBgv;
1764 register CV * const cv = GvCV(gv);
1767 DIE(aTHX_ "No DB::DB routine defined");
1769 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1770 /* don't do recursive DB::DB call */
1785 (void)(*CvXSUB(cv))(aTHX_ cv);
1792 PUSHBLOCK(cx, CXt_SUB, SP);
1794 cx->blk_sub.retop = PL_op->op_next;
1797 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1798 RETURNOP(CvSTART(cv));
1808 register PERL_CONTEXT *cx;
1809 const I32 gimme = GIMME_V;
1811 U16 cxtype = CXt_LOOP | CXp_FOREACH;
1819 if (PL_op->op_targ) {
1820 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1821 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1822 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1823 SVs_PADSTALE, SVs_PADSTALE);
1825 #ifndef USE_ITHREADS
1826 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1829 SAVEPADSV(PL_op->op_targ);
1830 iterdata = INT2PTR(void*, PL_op->op_targ);
1831 cxtype |= CXp_PADVAR;
1835 GV * const gv = (GV*)POPs;
1836 svp = &GvSV(gv); /* symbol table variable */
1837 SAVEGENERICSV(*svp);
1840 iterdata = (void*)gv;
1844 if (PL_op->op_private & OPpITER_DEF)
1845 cxtype |= CXp_FOR_DEF;
1849 PUSHBLOCK(cx, cxtype, SP);
1851 PUSHLOOP(cx, iterdata, MARK);
1853 PUSHLOOP(cx, svp, MARK);
1855 if (PL_op->op_flags & OPf_STACKED) {
1856 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1857 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1859 SV * const right = (SV*)cx->blk_loop.iterary;
1862 if (RANGE_IS_NUMERIC(sv,right)) {
1863 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1864 (SvOK(right) && SvNV(right) >= IV_MAX))
1865 DIE(aTHX_ "Range iterator outside integer range");
1866 cx->blk_loop.iterix = SvIV(sv);
1867 cx->blk_loop.itermax = SvIV(right);
1869 /* for correct -Dstv display */
1870 cx->blk_oldsp = sp - PL_stack_base;
1874 cx->blk_loop.iterlval = newSVsv(sv);
1875 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1876 (void) SvPV_nolen_const(right);
1879 else if (PL_op->op_private & OPpITER_REVERSED) {
1880 cx->blk_loop.itermax = 0;
1881 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1886 cx->blk_loop.iterary = PL_curstack;
1887 AvFILLp(PL_curstack) = SP - PL_stack_base;
1888 if (PL_op->op_private & OPpITER_REVERSED) {
1889 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1890 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1893 cx->blk_loop.iterix = MARK - PL_stack_base;
1903 register PERL_CONTEXT *cx;
1904 const I32 gimme = GIMME_V;
1910 PUSHBLOCK(cx, CXt_LOOP, SP);
1911 PUSHLOOP(cx, 0, SP);
1919 register PERL_CONTEXT *cx;
1926 assert(CxTYPE(cx) == CXt_LOOP);
1928 newsp = PL_stack_base + cx->blk_loop.resetsp;
1931 if (gimme == G_VOID)
1933 else if (gimme == G_SCALAR) {
1935 *++newsp = sv_mortalcopy(*SP);
1937 *++newsp = &PL_sv_undef;
1941 *++newsp = sv_mortalcopy(*++mark);
1942 TAINT_NOT; /* Each item is independent */
1948 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1949 PL_curpm = newpm; /* ... and pop $1 et al */
1960 register PERL_CONTEXT *cx;
1961 bool popsub2 = FALSE;
1962 bool clear_errsv = FALSE;
1970 const I32 cxix = dopoptosub(cxstack_ix);
1973 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1974 * sort block, which is a CXt_NULL
1977 PL_stack_base[1] = *PL_stack_sp;
1978 PL_stack_sp = PL_stack_base + 1;
1982 DIE(aTHX_ "Can't return outside a subroutine");
1984 if (cxix < cxstack_ix)
1987 if (CxMULTICALL(&cxstack[cxix])) {
1988 gimme = cxstack[cxix].blk_gimme;
1989 if (gimme == G_VOID)
1990 PL_stack_sp = PL_stack_base;
1991 else if (gimme == G_SCALAR) {
1992 PL_stack_base[1] = *PL_stack_sp;
1993 PL_stack_sp = PL_stack_base + 1;
1999 switch (CxTYPE(cx)) {
2002 retop = cx->blk_sub.retop;
2003 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2006 if (!(PL_in_eval & EVAL_KEEPERR))
2009 retop = cx->blk_eval.retop;
2013 if (optype == OP_REQUIRE &&
2014 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2016 /* Unassume the success we assumed earlier. */
2017 SV * const nsv = cx->blk_eval.old_namesv;
2018 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2019 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2024 retop = cx->blk_sub.retop;
2027 DIE(aTHX_ "panic: return");
2031 if (gimme == G_SCALAR) {
2034 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2036 *++newsp = SvREFCNT_inc(*SP);
2041 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2043 *++newsp = sv_mortalcopy(sv);
2048 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2051 *++newsp = sv_mortalcopy(*SP);
2054 *++newsp = &PL_sv_undef;
2056 else if (gimme == G_ARRAY) {
2057 while (++MARK <= SP) {
2058 *++newsp = (popsub2 && SvTEMP(*MARK))
2059 ? *MARK : sv_mortalcopy(*MARK);
2060 TAINT_NOT; /* Each item is independent */
2063 PL_stack_sp = newsp;
2066 /* Stack values are safe: */
2069 POPSUB(cx,sv); /* release CV and @_ ... */
2073 PL_curpm = newpm; /* ... and pop $1 et al */
2077 sv_setpvn(ERRSV,"",0);
2085 register PERL_CONTEXT *cx;
2096 if (PL_op->op_flags & OPf_SPECIAL) {
2097 cxix = dopoptoloop(cxstack_ix);
2099 DIE(aTHX_ "Can't \"last\" outside a loop block");
2102 cxix = dopoptolabel(cPVOP->op_pv);
2104 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2106 if (cxix < cxstack_ix)
2110 cxstack_ix++; /* temporarily protect top context */
2112 switch (CxTYPE(cx)) {
2115 newsp = PL_stack_base + cx->blk_loop.resetsp;
2116 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2120 nextop = cx->blk_sub.retop;
2124 nextop = cx->blk_eval.retop;
2128 nextop = cx->blk_sub.retop;
2131 DIE(aTHX_ "panic: last");
2135 if (gimme == G_SCALAR) {
2137 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2138 ? *SP : sv_mortalcopy(*SP);
2140 *++newsp = &PL_sv_undef;
2142 else if (gimme == G_ARRAY) {
2143 while (++MARK <= SP) {
2144 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2145 ? *MARK : sv_mortalcopy(*MARK);
2146 TAINT_NOT; /* Each item is independent */
2154 /* Stack values are safe: */
2157 POPLOOP(cx); /* release loop vars ... */
2161 POPSUB(cx,sv); /* release CV and @_ ... */
2164 PL_curpm = newpm; /* ... and pop $1 et al */
2167 PERL_UNUSED_VAR(optype);
2168 PERL_UNUSED_VAR(gimme);
2176 register PERL_CONTEXT *cx;
2179 if (PL_op->op_flags & OPf_SPECIAL) {
2180 cxix = dopoptoloop(cxstack_ix);
2182 DIE(aTHX_ "Can't \"next\" outside a loop block");
2185 cxix = dopoptolabel(cPVOP->op_pv);
2187 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2189 if (cxix < cxstack_ix)
2192 /* clear off anything above the scope we're re-entering, but
2193 * save the rest until after a possible continue block */
2194 inner = PL_scopestack_ix;
2196 if (PL_scopestack_ix < inner)
2197 leave_scope(PL_scopestack[PL_scopestack_ix]);
2198 PL_curcop = cx->blk_oldcop;
2199 return CX_LOOP_NEXTOP_GET(cx);
2206 register PERL_CONTEXT *cx;
2210 if (PL_op->op_flags & OPf_SPECIAL) {
2211 cxix = dopoptoloop(cxstack_ix);
2213 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2216 cxix = dopoptolabel(cPVOP->op_pv);
2218 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2220 if (cxix < cxstack_ix)
2223 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2224 if (redo_op->op_type == OP_ENTER) {
2225 /* pop one less context to avoid $x being freed in while (my $x..) */
2227 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2228 redo_op = redo_op->op_next;
2232 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2233 LEAVE_SCOPE(oldsave);
2235 PL_curcop = cx->blk_oldcop;
2240 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2244 static const char too_deep[] = "Target of goto is too deeply nested";
2247 Perl_croak(aTHX_ too_deep);
2248 if (o->op_type == OP_LEAVE ||
2249 o->op_type == OP_SCOPE ||
2250 o->op_type == OP_LEAVELOOP ||
2251 o->op_type == OP_LEAVESUB ||
2252 o->op_type == OP_LEAVETRY)
2254 *ops++ = cUNOPo->op_first;
2256 Perl_croak(aTHX_ too_deep);
2259 if (o->op_flags & OPf_KIDS) {
2261 /* First try all the kids at this level, since that's likeliest. */
2262 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2263 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2264 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2267 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2268 if (kid == PL_lastgotoprobe)
2270 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2273 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2274 ops[-1]->op_type == OP_DBSTATE)
2279 if ((o = dofindlabel(kid, label, ops, oplimit)))
2292 register PERL_CONTEXT *cx;
2293 #define GOTO_DEPTH 64
2294 OP *enterops[GOTO_DEPTH];
2295 const char *label = NULL;
2296 const bool do_dump = (PL_op->op_type == OP_DUMP);
2297 static const char must_have_label[] = "goto must have label";
2299 if (PL_op->op_flags & OPf_STACKED) {
2300 SV * const sv = POPs;
2302 /* This egregious kludge implements goto &subroutine */
2303 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2305 register PERL_CONTEXT *cx;
2306 CV* cv = (CV*)SvRV(sv);
2313 if (!CvROOT(cv) && !CvXSUB(cv)) {
2314 const GV * const gv = CvGV(cv);
2318 /* autoloaded stub? */
2319 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2321 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2322 GvNAMELEN(gv), FALSE);
2323 if (autogv && (cv = GvCV(autogv)))
2325 tmpstr = sv_newmortal();
2326 gv_efullname3(tmpstr, gv, NULL);
2327 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2329 DIE(aTHX_ "Goto undefined subroutine");
2332 /* First do some returnish stuff. */
2333 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2335 cxix = dopoptosub(cxstack_ix);
2337 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2338 if (cxix < cxstack_ix)
2342 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2343 if (CxTYPE(cx) == CXt_EVAL) {
2345 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2347 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2349 else if (CxMULTICALL(cx))
2350 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2351 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2352 /* put @_ back onto stack */
2353 AV* av = cx->blk_sub.argarray;
2355 items = AvFILLp(av) + 1;
2356 EXTEND(SP, items+1); /* @_ could have been extended. */
2357 Copy(AvARRAY(av), SP + 1, items, SV*);
2358 SvREFCNT_dec(GvAV(PL_defgv));
2359 GvAV(PL_defgv) = cx->blk_sub.savearray;
2361 /* abandon @_ if it got reified */
2366 av_extend(av, items-1);
2368 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2371 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2372 AV* const av = GvAV(PL_defgv);
2373 items = AvFILLp(av) + 1;
2374 EXTEND(SP, items+1); /* @_ could have been extended. */
2375 Copy(AvARRAY(av), SP + 1, items, SV*);
2379 if (CxTYPE(cx) == CXt_SUB &&
2380 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2381 SvREFCNT_dec(cx->blk_sub.cv);
2382 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2383 LEAVE_SCOPE(oldsave);
2385 /* Now do some callish stuff. */
2387 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2389 OP* const retop = cx->blk_sub.retop;
2394 for (index=0; index<items; index++)
2395 sv_2mortal(SP[-index]);
2398 /* XS subs don't have a CxSUB, so pop it */
2399 POPBLOCK(cx, PL_curpm);
2400 /* Push a mark for the start of arglist */
2403 (void)(*CvXSUB(cv))(aTHX_ cv);
2408 AV* const padlist = CvPADLIST(cv);
2409 if (CxTYPE(cx) == CXt_EVAL) {
2410 PL_in_eval = cx->blk_eval.old_in_eval;
2411 PL_eval_root = cx->blk_eval.old_eval_root;
2412 cx->cx_type = CXt_SUB;
2413 cx->blk_sub.hasargs = 0;
2415 cx->blk_sub.cv = cv;
2416 cx->blk_sub.olddepth = CvDEPTH(cv);
2419 if (CvDEPTH(cv) < 2)
2420 SvREFCNT_inc_simple_void_NN(cv);
2422 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2423 sub_crush_depth(cv);
2424 pad_push(padlist, CvDEPTH(cv));
2427 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2428 if (cx->blk_sub.hasargs)
2430 AV* const av = (AV*)PAD_SVl(0);
2432 cx->blk_sub.savearray = GvAV(PL_defgv);
2433 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2434 CX_CURPAD_SAVE(cx->blk_sub);
2435 cx->blk_sub.argarray = av;
2437 if (items >= AvMAX(av) + 1) {
2438 SV **ary = AvALLOC(av);
2439 if (AvARRAY(av) != ary) {
2440 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2443 if (items >= AvMAX(av) + 1) {
2444 AvMAX(av) = items - 1;
2445 Renew(ary,items+1,SV*);
2451 Copy(mark,AvARRAY(av),items,SV*);
2452 AvFILLp(av) = items - 1;
2453 assert(!AvREAL(av));
2455 /* transfer 'ownership' of refcnts to new @_ */
2465 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2466 Perl_get_db_sub(aTHX_ NULL, cv);
2468 CV * const gotocv = get_cv("DB::goto", FALSE);
2470 PUSHMARK( PL_stack_sp );
2471 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2476 RETURNOP(CvSTART(cv));
2480 label = SvPV_nolen_const(sv);
2481 if (!(do_dump || *label))
2482 DIE(aTHX_ must_have_label);
2485 else if (PL_op->op_flags & OPf_SPECIAL) {
2487 DIE(aTHX_ must_have_label);
2490 label = cPVOP->op_pv;
2492 if (label && *label) {
2493 OP *gotoprobe = NULL;
2494 bool leaving_eval = FALSE;
2495 bool in_block = FALSE;
2496 PERL_CONTEXT *last_eval_cx = NULL;
2500 PL_lastgotoprobe = NULL;
2502 for (ix = cxstack_ix; ix >= 0; ix--) {
2504 switch (CxTYPE(cx)) {
2506 leaving_eval = TRUE;
2507 if (!CxTRYBLOCK(cx)) {
2508 gotoprobe = (last_eval_cx ?
2509 last_eval_cx->blk_eval.old_eval_root :
2514 /* else fall through */
2516 gotoprobe = cx->blk_oldcop->op_sibling;
2522 gotoprobe = cx->blk_oldcop->op_sibling;
2525 gotoprobe = PL_main_root;
2528 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2529 gotoprobe = CvROOT(cx->blk_sub.cv);
2535 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2538 DIE(aTHX_ "panic: goto");
2539 gotoprobe = PL_main_root;
2543 retop = dofindlabel(gotoprobe, label,
2544 enterops, enterops + GOTO_DEPTH);
2548 PL_lastgotoprobe = gotoprobe;
2551 DIE(aTHX_ "Can't find label %s", label);
2553 /* if we're leaving an eval, check before we pop any frames
2554 that we're not going to punt, otherwise the error
2557 if (leaving_eval && *enterops && enterops[1]) {
2559 for (i = 1; enterops[i]; i++)
2560 if (enterops[i]->op_type == OP_ENTERITER)
2561 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2564 /* pop unwanted frames */
2566 if (ix < cxstack_ix) {
2573 oldsave = PL_scopestack[PL_scopestack_ix];
2574 LEAVE_SCOPE(oldsave);
2577 /* push wanted frames */
2579 if (*enterops && enterops[1]) {
2580 OP * const oldop = PL_op;
2581 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2582 for (; enterops[ix]; ix++) {
2583 PL_op = enterops[ix];
2584 /* Eventually we may want to stack the needed arguments
2585 * for each op. For now, we punt on the hard ones. */
2586 if (PL_op->op_type == OP_ENTERITER)
2587 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2588 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2596 if (!retop) retop = PL_main_start;
2598 PL_restartop = retop;
2599 PL_do_undump = TRUE;
2603 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2604 PL_do_undump = FALSE;
2621 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2623 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2626 PL_exit_flags |= PERL_EXIT_EXPECTED;
2628 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2629 if (anum || !(PL_minus_c && PL_madskills))
2634 PUSHs(&PL_sv_undef);
2641 S_save_lines(pTHX_ AV *array, SV *sv)
2643 const char *s = SvPVX_const(sv);
2644 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2647 while (s && s < send) {
2649 SV * const tmpstr = newSV_type(SVt_PVMG);
2651 t = strchr(s, '\n');
2657 sv_setpvn(tmpstr, s, t - s);
2658 av_store(array, line++, tmpstr);
2664 S_docatch(pTHX_ OP *o)
2668 OP * const oldop = PL_op;
2672 assert(CATCH_GET == TRUE);
2679 assert(cxstack_ix >= 0);
2680 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2681 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2686 /* die caught by an inner eval - continue inner loop */
2688 /* NB XXX we rely on the old popped CxEVAL still being at the top
2689 * of the stack; the way die_where() currently works, this
2690 * assumption is valid. In theory The cur_top_env value should be
2691 * returned in another global, the way retop (aka PL_restartop)
2693 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2696 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2698 PL_op = PL_restartop;
2715 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2716 /* sv Text to convert to OP tree. */
2717 /* startop op_free() this to undo. */
2718 /* code Short string id of the caller. */
2720 /* FIXME - how much of this code is common with pp_entereval? */
2721 dVAR; dSP; /* Make POPBLOCK work. */
2727 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2728 char *tmpbuf = tbuf;
2731 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2735 lex_start(sv, NULL, FALSE);
2737 /* switch to eval mode */
2739 if (IN_PERL_COMPILETIME) {
2740 SAVECOPSTASH_FREE(&PL_compiling);
2741 CopSTASH_set(&PL_compiling, PL_curstash);
2743 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2744 SV * const sv = sv_newmortal();
2745 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2746 code, (unsigned long)++PL_evalseq,
2747 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2752 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2753 (unsigned long)++PL_evalseq);
2754 SAVECOPFILE_FREE(&PL_compiling);
2755 CopFILE_set(&PL_compiling, tmpbuf+2);
2756 SAVECOPLINE(&PL_compiling);
2757 CopLINE_set(&PL_compiling, 1);
2758 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2759 deleting the eval's FILEGV from the stash before gv_check() runs
2760 (i.e. before run-time proper). To work around the coredump that
2761 ensues, we always turn GvMULTI_on for any globals that were
2762 introduced within evals. See force_ident(). GSAR 96-10-12 */
2763 safestr = savepvn(tmpbuf, len);
2764 SAVEDELETE(PL_defstash, safestr, len);
2766 #ifdef OP_IN_REGISTER
2772 /* we get here either during compilation, or via pp_regcomp at runtime */
2773 runtime = IN_PERL_RUNTIME;
2775 runcv = find_runcv(NULL);
2778 PL_op->op_type = OP_ENTEREVAL;
2779 PL_op->op_flags = 0; /* Avoid uninit warning. */
2780 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2781 PUSHEVAL(cx, 0, NULL);
2784 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2786 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2787 POPBLOCK(cx,PL_curpm);
2790 (*startop)->op_type = OP_NULL;
2791 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2793 /* XXX DAPM do this properly one year */
2794 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2796 if (IN_PERL_COMPILETIME)
2797 CopHINTS_set(&PL_compiling, PL_hints);
2798 #ifdef OP_IN_REGISTER
2801 PERL_UNUSED_VAR(newsp);
2802 PERL_UNUSED_VAR(optype);
2804 return PL_eval_start;
2809 =for apidoc find_runcv
2811 Locate the CV corresponding to the currently executing sub or eval.
2812 If db_seqp is non_null, skip CVs that are in the DB package and populate
2813 *db_seqp with the cop sequence number at the point that the DB:: code was
2814 entered. (allows debuggers to eval in the scope of the breakpoint rather
2815 than in the scope of the debugger itself).
2821 Perl_find_runcv(pTHX_ U32 *db_seqp)
2827 *db_seqp = PL_curcop->cop_seq;
2828 for (si = PL_curstackinfo; si; si = si->si_prev) {
2830 for (ix = si->si_cxix; ix >= 0; ix--) {
2831 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2832 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2833 CV * const cv = cx->blk_sub.cv;
2834 /* skip DB:: code */
2835 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2836 *db_seqp = cx->blk_oldcop->cop_seq;
2841 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2849 /* Compile a require/do, an eval '', or a /(?{...})/.
2850 * In the last case, startop is non-null, and contains the address of
2851 * a pointer that should be set to the just-compiled code.
2852 * outside is the lexically enclosing CV (if any) that invoked us.
2853 * Returns a bool indicating whether the compile was successful; if so,
2854 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2855 * pushes undef (also croaks if startop != NULL).
2859 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2862 OP * const saveop = PL_op;
2864 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2865 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2870 SAVESPTR(PL_compcv);
2871 PL_compcv = (CV*)newSV_type(SVt_PVCV);
2872 CvEVAL_on(PL_compcv);
2873 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2874 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2876 CvOUTSIDE_SEQ(PL_compcv) = seq;
2877 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2879 /* set up a scratch pad */
2881 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2882 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2886 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2888 /* make sure we compile in the right package */
2890 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2891 SAVESPTR(PL_curstash);
2892 PL_curstash = CopSTASH(PL_curcop);
2894 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2895 SAVESPTR(PL_beginav);
2896 PL_beginav = newAV();
2897 SAVEFREESV(PL_beginav);
2898 SAVESPTR(PL_unitcheckav);
2899 PL_unitcheckav = newAV();
2900 SAVEFREESV(PL_unitcheckav);
2903 SAVEBOOL(PL_madskills);
2907 /* try to compile it */
2909 PL_eval_root = NULL;
2910 PL_curcop = &PL_compiling;
2911 CopARYBASE_set(PL_curcop, 0);
2912 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2913 PL_in_eval |= EVAL_KEEPERR;
2915 sv_setpvn(ERRSV,"",0);
2916 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
2917 SV **newsp; /* Used by POPBLOCK. */
2918 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2919 I32 optype = 0; /* Might be reset by POPEVAL. */
2924 op_free(PL_eval_root);
2925 PL_eval_root = NULL;
2927 SP = PL_stack_base + POPMARK; /* pop original mark */
2929 POPBLOCK(cx,PL_curpm);
2935 msg = SvPVx_nolen_const(ERRSV);
2936 if (optype == OP_REQUIRE) {
2937 const SV * const nsv = cx->blk_eval.old_namesv;
2938 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2940 Perl_croak(aTHX_ "%sCompilation failed in require",
2941 *msg ? msg : "Unknown error\n");
2944 POPBLOCK(cx,PL_curpm);
2946 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2947 (*msg ? msg : "Unknown error\n"));
2951 sv_setpvs(ERRSV, "Compilation error");
2954 PERL_UNUSED_VAR(newsp);
2955 PUSHs(&PL_sv_undef);
2959 CopLINE_set(&PL_compiling, 0);
2961 *startop = PL_eval_root;
2963 SAVEFREEOP(PL_eval_root);
2965 /* Set the context for this new optree.
2966 * If the last op is an OP_REQUIRE, force scalar context.
2967 * Otherwise, propagate the context from the eval(). */
2968 if (PL_eval_root->op_type == OP_LEAVEEVAL
2969 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2970 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2972 scalar(PL_eval_root);
2973 else if (gimme & G_VOID)
2974 scalarvoid(PL_eval_root);
2975 else if (gimme & G_ARRAY)
2978 scalar(PL_eval_root);
2980 DEBUG_x(dump_eval());
2982 /* Register with debugger: */
2983 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
2984 CV * const cv = get_cv("DB::postponed", FALSE);
2988 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2990 call_sv((SV*)cv, G_DISCARD);
2995 call_list(PL_scopestack_ix, PL_unitcheckav);
2997 /* compiled okay, so do it */
2999 CvDEPTH(PL_compcv) = 1;
3000 SP = PL_stack_base + POPMARK; /* pop original mark */
3001 PL_op = saveop; /* The caller may need it. */
3002 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3009 S_check_type_and_open(pTHX_ const char *name, const char *mode)
3012 const int st_rc = PerlLIO_stat(name, &st);
3014 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3018 return PerlIO_open(name, mode);
3022 S_doopen_pm(pTHX_ const char *name, const char *mode)
3024 #ifndef PERL_DISABLE_PMC
3025 const STRLEN namelen = strlen(name);
3028 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3029 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3030 const char * const pmc = SvPV_nolen_const(pmcsv);
3032 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3033 fp = check_type_and_open(name, mode);
3036 fp = check_type_and_open(pmc, mode);
3038 SvREFCNT_dec(pmcsv);
3041 fp = check_type_and_open(name, mode);
3045 return check_type_and_open(name, mode);
3046 #endif /* !PERL_DISABLE_PMC */
3052 register PERL_CONTEXT *cx;
3059 int vms_unixname = 0;
3061 const char *tryname = NULL;
3063 const I32 gimme = GIMME_V;
3064 int filter_has_file = 0;
3065 PerlIO *tryrsfp = NULL;
3066 SV *filter_cache = NULL;
3067 SV *filter_state = NULL;
3068 SV *filter_sub = NULL;
3074 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3075 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) { /* require v5.6.1 */
3076 HV * hinthv = GvHV(PL_hintgv);
3078 if (hinthv) ptr = hv_fetchs(hinthv, "v_string", FALSE);
3079 if ( !(ptr && *ptr && SvIOK(*ptr) && SvIV(*ptr)) )
3080 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3081 "v-string in use/require non-portable");
3083 sv = new_version(sv);
3084 if (!sv_derived_from(PL_patchlevel, "version"))
3085 upg_version(PL_patchlevel, TRUE);
3086 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3087 if ( vcmp(sv,PL_patchlevel) <= 0 )
3088 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3089 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3092 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3095 SV * const req = SvRV(sv);
3096 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3098 /* get the left hand term */
3099 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3101 first = SvIV(*av_fetch(lav,0,0));
3102 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3103 || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3104 || av_len(lav) > 1 /* FP with > 3 digits */
3105 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3107 DIE(aTHX_ "Perl %"SVf" required--this is only "
3108 "%"SVf", stopped", SVfARG(vnormal(req)),
3109 SVfARG(vnormal(PL_patchlevel)));
3111 else { /* probably 'use 5.10' or 'use 5.8' */
3112 SV * hintsv = newSV(0);
3116 second = SvIV(*av_fetch(lav,1,0));
3118 second /= second >= 600 ? 100 : 10;
3119 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3120 (int)first, (int)second,0);
3121 upg_version(hintsv, TRUE);
3123 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3124 "--this is only %"SVf", stopped",
3125 SVfARG(vnormal(req)),
3126 SVfARG(vnormal(hintsv)),
3127 SVfARG(vnormal(PL_patchlevel)));
3132 /* We do this only with use, not require. */
3134 /* If we request a version >= 5.6.0, then v-string are OK
3135 so set $^H{v_string} to suppress the v-string warning */
3136 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.006), FALSE))) >= 0) {
3137 HV * hinthv = GvHV(PL_hintgv);
3139 SV *hint = newSViv(1);
3140 (void)hv_stores(hinthv, "v_string", hint);
3141 /* This will call through to Perl_magic_sethint() which in turn
3142 sets PL_hints correctly. */
3145 /* If we request a version >= 5.9.5, load feature.pm with the
3146 * feature bundle that corresponds to the required version. */
3147 if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3148 SV *const importsv = vnormal(sv);
3149 *SvPVX_mutable(importsv) = ':';
3151 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3158 name = SvPV_const(sv, len);
3159 if (!(name && len > 0 && *name))
3160 DIE(aTHX_ "Null filename used");
3161 TAINT_PROPER("require");
3165 /* The key in the %ENV hash is in the syntax of file passed as the argument
3166 * usually this is in UNIX format, but sometimes in VMS format, which
3167 * can result in a module being pulled in more than once.
3168 * To prevent this, the key must be stored in UNIX format if the VMS
3169 * name can be translated to UNIX.
3171 if ((unixname = tounixspec(name, NULL)) != NULL) {
3172 unixlen = strlen(unixname);
3178 /* if not VMS or VMS name can not be translated to UNIX, pass it
3181 unixname = (char *) name;
3184 if (PL_op->op_type == OP_REQUIRE) {
3185 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3186 unixname, unixlen, 0);
3188 if (*svp != &PL_sv_undef)
3191 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3192 "Compilation failed in require", unixname);
3196 /* prepare to compile file */
3198 if (path_is_absolute(name)) {
3200 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3202 #ifdef MACOS_TRADITIONAL
3206 MacPerl_CanonDir(name, newname, 1);
3207 if (path_is_absolute(newname)) {
3209 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3214 AV * const ar = GvAVn(PL_incgv);
3221 for (i = 0; i <= AvFILL(ar); i++) {
3222 SV * const dirsv = *av_fetch(ar, i, TRUE);
3224 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3231 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3232 && !sv_isobject(loader))
3234 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3237 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3238 PTR2UV(SvRV(dirsv)), name);
3239 tryname = SvPVX_const(namesv);
3250 if (sv_isobject(loader))
3251 count = call_method("INC", G_ARRAY);
3253 count = call_sv(loader, G_ARRAY);
3256 /* Adjust file name if the hook has set an %INC entry */
3257 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3259 tryname = SvPVX_const(*svp);
3268 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3269 && !isGV_with_GP(SvRV(arg))) {
3270 filter_cache = SvRV(arg);
3271 SvREFCNT_inc_simple_void_NN(filter_cache);
3278 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3282 if (SvTYPE(arg) == SVt_PVGV) {
3283 IO * const io = GvIO((GV *)arg);
3288 tryrsfp = IoIFP(io);
3289 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3290 PerlIO_close(IoOFP(io));
3301 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3303 SvREFCNT_inc_simple_void_NN(filter_sub);
3306 filter_state = SP[i];
3307 SvREFCNT_inc_simple_void(filter_state);
3311 if (!tryrsfp && (filter_cache || filter_sub)) {
3312 tryrsfp = PerlIO_open(BIT_BUCKET,
3327 filter_has_file = 0;
3329 SvREFCNT_dec(filter_cache);
3330 filter_cache = NULL;
3333 SvREFCNT_dec(filter_state);
3334 filter_state = NULL;
3337 SvREFCNT_dec(filter_sub);
3342 if (!path_is_absolute(name)
3343 #ifdef MACOS_TRADITIONAL
3344 /* We consider paths of the form :a:b ambiguous and interpret them first
3345 as global then as local
3347 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3350 const char *dir = SvOK(dirsv) ? SvPV_nolen_const(dirsv) : "";
3351 #ifdef MACOS_TRADITIONAL
3355 MacPerl_CanonDir(name, buf2, 1);
3356 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3360 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3362 sv_setpv(namesv, unixdir);
3363 sv_catpv(namesv, unixname);
3365 # ifdef __SYMBIAN32__
3366 if (PL_origfilename[0] &&
3367 PL_origfilename[1] == ':' &&
3368 !(dir[0] && dir[1] == ':'))
3369 Perl_sv_setpvf(aTHX_ namesv,
3374 Perl_sv_setpvf(aTHX_ namesv,
3378 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3382 TAINT_PROPER("require");
3383 tryname = SvPVX_const(namesv);
3384 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3386 if (tryname[0] == '.' && tryname[1] == '/')
3390 else if (errno == EMFILE)
3391 /* no point in trying other paths if out of handles */
3398 SAVECOPFILE_FREE(&PL_compiling);
3399 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3400 SvREFCNT_dec(namesv);
3402 if (PL_op->op_type == OP_REQUIRE) {
3403 const char *msgstr = name;
3404 if(errno == EMFILE) {
3406 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3408 msgstr = SvPV_nolen_const(msg);
3410 if (namesv) { /* did we lookup @INC? */
3411 AV * const ar = GvAVn(PL_incgv);
3413 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3414 "%s in @INC%s%s (@INC contains:",
3416 (instr(msgstr, ".h ")
3417 ? " (change .h to .ph maybe?)" : ""),
3418 (instr(msgstr, ".ph ")
3419 ? " (did you run h2ph?)" : "")
3422 for (i = 0; i <= AvFILL(ar); i++) {
3423 sv_catpvs(msg, " ");
3424 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3426 sv_catpvs(msg, ")");
3427 msgstr = SvPV_nolen_const(msg);
3430 DIE(aTHX_ "Can't locate %s", msgstr);
3436 SETERRNO(0, SS_NORMAL);
3438 /* Assume success here to prevent recursive requirement. */
3439 /* name is never assigned to again, so len is still strlen(name) */
3440 /* Check whether a hook in @INC has already filled %INC */
3442 (void)hv_store(GvHVn(PL_incgv),
3443 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3445 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3447 (void)hv_store(GvHVn(PL_incgv),
3448 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3453 lex_start(NULL, tryrsfp, TRUE);
3457 SAVECOMPILEWARNINGS();
3458 if (PL_dowarn & G_WARN_ALL_ON)
3459 PL_compiling.cop_warnings = pWARN_ALL ;
3460 else if (PL_dowarn & G_WARN_ALL_OFF)
3461 PL_compiling.cop_warnings = pWARN_NONE ;
3463 PL_compiling.cop_warnings = pWARN_STD ;
3465 if (filter_sub || filter_cache) {
3466 SV * const datasv = filter_add(S_run_user_filter, NULL);
3467 IoLINES(datasv) = filter_has_file;
3468 IoTOP_GV(datasv) = (GV *)filter_state;
3469 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3470 IoFMT_GV(datasv) = (GV *)filter_cache;
3473 /* switch to eval mode */
3474 PUSHBLOCK(cx, CXt_EVAL, SP);
3475 PUSHEVAL(cx, name, NULL);
3476 cx->blk_eval.retop = PL_op->op_next;
3478 SAVECOPLINE(&PL_compiling);
3479 CopLINE_set(&PL_compiling, 0);
3483 /* Store and reset encoding. */
3484 encoding = PL_encoding;
3487 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3488 op = DOCATCH(PL_eval_start);
3490 op = PL_op->op_next;
3492 /* Restore encoding. */
3493 PL_encoding = encoding;
3501 register PERL_CONTEXT *cx;
3503 const I32 gimme = GIMME_V;
3504 const I32 was = PL_sub_generation;
3505 char tbuf[TYPE_DIGITS(long) + 12];
3506 char *tmpbuf = tbuf;
3512 HV *saved_hh = NULL;
3513 const char * const fakestr = "_<(eval )";
3514 const int fakelen = 9 + 1;
3516 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3517 saved_hh = (HV*) SvREFCNT_inc(POPs);
3521 TAINT_IF(SvTAINTED(sv));
3522 TAINT_PROPER("eval");
3525 lex_start(sv, NULL, FALSE);
3528 /* switch to eval mode */
3530 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3531 SV * const temp_sv = sv_newmortal();
3532 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3533 (unsigned long)++PL_evalseq,
3534 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3535 tmpbuf = SvPVX(temp_sv);
3536 len = SvCUR(temp_sv);
3539 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3540 SAVECOPFILE_FREE(&PL_compiling);
3541 CopFILE_set(&PL_compiling, tmpbuf+2);
3542 SAVECOPLINE(&PL_compiling);
3543 CopLINE_set(&PL_compiling, 1);
3544 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3545 deleting the eval's FILEGV from the stash before gv_check() runs
3546 (i.e. before run-time proper). To work around the coredump that
3547 ensues, we always turn GvMULTI_on for any globals that were
3548 introduced within evals. See force_ident(). GSAR 96-10-12 */
3549 safestr = savepvn(tmpbuf, len);
3550 SAVEDELETE(PL_defstash, safestr, len);
3552 PL_hints = PL_op->op_targ;
3554 GvHV(PL_hintgv) = saved_hh;
3555 SAVECOMPILEWARNINGS();
3556 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3557 if (PL_compiling.cop_hints_hash) {
3558 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3560 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3561 if (PL_compiling.cop_hints_hash) {
3563 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3564 HINTS_REFCNT_UNLOCK;
3566 /* special case: an eval '' executed within the DB package gets lexically
3567 * placed in the first non-DB CV rather than the current CV - this
3568 * allows the debugger to execute code, find lexicals etc, in the
3569 * scope of the code being debugged. Passing &seq gets find_runcv
3570 * to do the dirty work for us */
3571 runcv = find_runcv(&seq);
3573 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3574 PUSHEVAL(cx, 0, NULL);
3575 cx->blk_eval.retop = PL_op->op_next;
3577 /* prepare to compile string */
3579 if (PERLDB_LINE && PL_curstash != PL_debstash)
3580 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3582 ok = doeval(gimme, NULL, runcv, seq);
3583 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3585 /* Copy in anything fake and short. */
3586 my_strlcpy(safestr, fakestr, fakelen);
3588 return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3598 register PERL_CONTEXT *cx;
3600 const U8 save_flags = PL_op -> op_flags;
3605 retop = cx->blk_eval.retop;
3608 if (gimme == G_VOID)
3610 else if (gimme == G_SCALAR) {
3613 if (SvFLAGS(TOPs) & SVs_TEMP)
3616 *MARK = sv_mortalcopy(TOPs);
3620 *MARK = &PL_sv_undef;
3625 /* in case LEAVE wipes old return values */
3626 for (mark = newsp + 1; mark <= SP; mark++) {
3627 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3628 *mark = sv_mortalcopy(*mark);
3629 TAINT_NOT; /* Each item is independent */
3633 PL_curpm = newpm; /* Don't pop $1 et al till now */
3636 assert(CvDEPTH(PL_compcv) == 1);
3638 CvDEPTH(PL_compcv) = 0;
3641 if (optype == OP_REQUIRE &&
3642 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3644 /* Unassume the success we assumed earlier. */
3645 SV * const nsv = cx->blk_eval.old_namesv;
3646 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3647 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3648 /* die_where() did LEAVE, or we won't be here */
3652 if (!(save_flags & OPf_SPECIAL))
3653 sv_setpvn(ERRSV,"",0);
3659 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3660 close to the related Perl_create_eval_scope. */
3662 Perl_delete_eval_scope(pTHX)
3667 register PERL_CONTEXT *cx;
3674 PERL_UNUSED_VAR(newsp);
3675 PERL_UNUSED_VAR(gimme);
3676 PERL_UNUSED_VAR(optype);
3679 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3680 also needed by Perl_fold_constants. */
3682 Perl_create_eval_scope(pTHX_ U32 flags)
3685 const I32 gimme = GIMME_V;
3690 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3693 PL_in_eval = EVAL_INEVAL;
3694 if (flags & G_KEEPERR)
3695 PL_in_eval |= EVAL_KEEPERR;
3697 sv_setpvn(ERRSV,"",0);
3698 if (flags & G_FAKINGEVAL) {
3699 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3707 PERL_CONTEXT * const cx = create_eval_scope(0);
3708 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3709 return DOCATCH(PL_op->op_next);
3718 register PERL_CONTEXT *cx;
3723 PERL_UNUSED_VAR(optype);
3726 if (gimme == G_VOID)
3728 else if (gimme == G_SCALAR) {
3732 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3735 *MARK = sv_mortalcopy(TOPs);
3739 *MARK = &PL_sv_undef;
3744 /* in case LEAVE wipes old return values */
3746 for (mark = newsp + 1; mark <= SP; mark++) {
3747 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3748 *mark = sv_mortalcopy(*mark);
3749 TAINT_NOT; /* Each item is independent */
3753 PL_curpm = newpm; /* Don't pop $1 et al till now */
3756 sv_setpvn(ERRSV,"",0);
3763 register PERL_CONTEXT *cx;
3764 const I32 gimme = GIMME_V;
3769 if (PL_op->op_targ == 0) {
3770 SV ** const defsv_p = &GvSV(PL_defgv);
3771 *defsv_p = newSVsv(POPs);
3772 SAVECLEARSV(*defsv_p);
3775 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3777 PUSHBLOCK(cx, CXt_GIVEN, SP);
3786 register PERL_CONTEXT *cx;
3790 PERL_UNUSED_CONTEXT;
3793 assert(CxTYPE(cx) == CXt_GIVEN);
3798 PL_curpm = newpm; /* pop $1 et al */
3805 /* Helper routines used by pp_smartmatch */
3807 S_make_matcher(pTHX_ regexp *re)
3810 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3811 PM_SETRE(matcher, ReREFCNT_inc(re));
3813 SAVEFREEOP((OP *) matcher);
3820 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3825 PL_op = (OP *) matcher;
3830 return (SvTRUEx(POPs));
3834 S_destroy_matcher(pTHX_ PMOP *matcher)
3837 PERL_UNUSED_ARG(matcher);
3842 /* Do a smart match */
3845 return do_smartmatch(NULL, NULL);
3848 /* This version of do_smartmatch() implements the
3849 * table of smart matches that is found in perlsyn.
3852 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3857 SV *e = TOPs; /* e is for 'expression' */
3858 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3859 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3861 regexp *this_regex, *other_regex;
3863 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3865 # define SM_REF(type) ( \
3866 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3867 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3869 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3870 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
3871 && NOT_EMPTY_PROTO(This) && (Other = e)) \
3872 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
3873 && NOT_EMPTY_PROTO(This) && (Other = d)))
3875 # define SM_REGEX ( \
3876 (SvROK(d) && SvMAGICAL(This = SvRV(d)) \
3877 && (mg = mg_find(This, PERL_MAGIC_qr)) \
3878 && (this_regex = (regexp *)mg->mg_obj) \
3881 (SvROK(e) && SvMAGICAL(This = SvRV(e)) \
3882 && (mg = mg_find(This, PERL_MAGIC_qr)) \
3883 && (this_regex = (regexp *)mg->mg_obj) \
3887 # define SM_OTHER_REF(type) \
3888 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3890 # define SM_OTHER_REGEX (SvROK(Other) && SvMAGICAL(SvRV(Other)) \
3891 && (mg = mg_find(SvRV(Other), PERL_MAGIC_qr)) \
3892 && (other_regex = (regexp *)mg->mg_obj))
3895 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3896 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3898 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3899 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3901 tryAMAGICbinSET(smart, 0);
3903 SP -= 2; /* Pop the values */
3905 /* Take care only to invoke mg_get() once for each argument.
3906 * Currently we do this by copying the SV if it's magical. */
3909 d = sv_mortalcopy(d);
3916 e = sv_mortalcopy(e);
3921 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3923 if (This == SvRV(Other))
3934 c = call_sv(This, G_SCALAR);
3938 else if (SvTEMP(TOPs))
3939 SvREFCNT_inc_void(TOPs);
3944 else if (SM_REF(PVHV)) {
3945 if (SM_OTHER_REF(PVHV)) {
3946 /* Check that the key-sets are identical */
3948 HV *other_hv = (HV *) SvRV(Other);
3950 bool other_tied = FALSE;
3951 U32 this_key_count = 0,
3952 other_key_count = 0;
3954 /* Tied hashes don't know how many keys they have. */
3955 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
3958 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3959 HV * const temp = other_hv;
3960 other_hv = (HV *) This;
3964 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3967 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
3970 /* The hashes have the same number of keys, so it suffices
3971 to check that one is a subset of the other. */
3972 (void) hv_iterinit((HV *) This);
3973 while ( (he = hv_iternext((HV *) This)) ) {
3975 char * const key = hv_iterkey(he, &key_len);
3979 if(!hv_exists(other_hv, key, key_len)) {
3980 (void) hv_iterinit((HV *) This); /* reset iterator */
3986 (void) hv_iterinit(other_hv);
3987 while ( hv_iternext(other_hv) )
3991 other_key_count = HvUSEDKEYS(other_hv);
3993 if (this_key_count != other_key_count)
3998 else if (SM_OTHER_REF(PVAV)) {
3999 AV * const other_av = (AV *) SvRV(Other);
4000 const I32 other_len = av_len(other_av) + 1;
4003 if (HvUSEDKEYS((HV *) This) != other_len)
4006 for(i = 0; i < other_len; ++i) {
4007 SV ** const svp = av_fetch(other_av, i, FALSE);
4011 if (!svp) /* ??? When can this happen? */
4014 key = SvPV(*svp, key_len);
4015 if(!hv_exists((HV *) This, key, key_len))
4020 else if (SM_OTHER_REGEX) {
4021 PMOP * const matcher = make_matcher(other_regex);
4024 (void) hv_iterinit((HV *) This);
4025 while ( (he = hv_iternext((HV *) This)) ) {
4026 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4027 (void) hv_iterinit((HV *) This);
4028 destroy_matcher(matcher);
4032 destroy_matcher(matcher);
4036 if (hv_exists_ent((HV *) This, Other, 0))
4042 else if (SM_REF(PVAV)) {
4043 if (SM_OTHER_REF(PVAV)) {
4044 AV *other_av = (AV *) SvRV(Other);
4045 if (av_len((AV *) This) != av_len(other_av))
4049 const I32 other_len = av_len(other_av);
4051 if (NULL == seen_this) {
4052 seen_this = newHV();
4053 (void) sv_2mortal((SV *) seen_this);
4055 if (NULL == seen_other) {
4056 seen_this = newHV();
4057 (void) sv_2mortal((SV *) seen_other);
4059 for(i = 0; i <= other_len; ++i) {
4060 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4061 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4063 if (!this_elem || !other_elem) {
4064 if (this_elem || other_elem)
4067 else if (SM_SEEN_THIS(*this_elem)
4068 || SM_SEEN_OTHER(*other_elem))
4070 if (*this_elem != *other_elem)
4074 (void)hv_store_ent(seen_this,
4075 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4077 (void)hv_store_ent(seen_other,
4078 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4084 (void) do_smartmatch(seen_this, seen_other);
4094 else if (SM_OTHER_REGEX) {
4095 PMOP * const matcher = make_matcher(other_regex);
4096 const I32 this_len = av_len((AV *) This);
4099 for(i = 0; i <= this_len; ++i) {
4100 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4101 if (svp && matcher_matches_sv(matcher, *svp)) {
4102 destroy_matcher(matcher);
4106 destroy_matcher(matcher);
4109 else if (SvIOK(Other) || SvNOK(Other)) {
4112 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4113 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4120 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4130 else if (SvPOK(Other)) {
4131 const I32 this_len = av_len((AV *) This);
4134 for(i = 0; i <= this_len; ++i) {
4135 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4150 else if (!SvOK(d) || !SvOK(e)) {
4151 if (!SvOK(d) && !SvOK(e))
4156 else if (SM_REGEX) {
4157 PMOP * const matcher = make_matcher(this_regex);
4160 PUSHs(matcher_matches_sv(matcher, Other)
4163 destroy_matcher(matcher);
4166 else if (SM_REF(PVCV)) {
4168 /* This must be a null-prototyped sub, because we
4169 already checked for the other kind. */
4175 c = call_sv(This, G_SCALAR);
4178 PUSHs(&PL_sv_undef);
4179 else if (SvTEMP(TOPs))
4180 SvREFCNT_inc_void(TOPs);
4182 if (SM_OTHER_REF(PVCV)) {
4183 /* This one has to be null-proto'd too.
4184 Call both of 'em, and compare the results */
4186 c = call_sv(SvRV(Other), G_SCALAR);
4189 PUSHs(&PL_sv_undef);
4190 else if (SvTEMP(TOPs))
4191 SvREFCNT_inc_void(TOPs);
4202 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4203 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4205 if (SvPOK(Other) && !looks_like_number(Other)) {
4206 /* String comparison */
4211 /* Otherwise, numeric comparison */
4214 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4225 /* As a last resort, use string comparison */
4234 register PERL_CONTEXT *cx;
4235 const I32 gimme = GIMME_V;
4237 /* This is essentially an optimization: if the match
4238 fails, we don't want to push a context and then
4239 pop it again right away, so we skip straight
4240 to the op that follows the leavewhen.
4242 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4243 return cLOGOP->op_other->op_next;
4248 PUSHBLOCK(cx, CXt_WHEN, SP);
4257 register PERL_CONTEXT *cx;
4263 assert(CxTYPE(cx) == CXt_WHEN);
4268 PL_curpm = newpm; /* pop $1 et al */
4278 register PERL_CONTEXT *cx;
4281 cxix = dopoptowhen(cxstack_ix);
4283 DIE(aTHX_ "Can't \"continue\" outside a when block");
4284 if (cxix < cxstack_ix)
4287 /* clear off anything above the scope we're re-entering */
4288 inner = PL_scopestack_ix;
4290 if (PL_scopestack_ix < inner)
4291 leave_scope(PL_scopestack[PL_scopestack_ix]);
4292 PL_curcop = cx->blk_oldcop;
4293 return cx->blk_givwhen.leave_op;
4300 register PERL_CONTEXT *cx;
4303 cxix = dopoptogiven(cxstack_ix);
4305 if (PL_op->op_flags & OPf_SPECIAL)
4306 DIE(aTHX_ "Can't use when() outside a topicalizer");
4308 DIE(aTHX_ "Can't \"break\" outside a given block");
4310 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4311 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4313 if (cxix < cxstack_ix)
4316 /* clear off anything above the scope we're re-entering */
4317 inner = PL_scopestack_ix;
4319 if (PL_scopestack_ix < inner)
4320 leave_scope(PL_scopestack[PL_scopestack_ix]);
4321 PL_curcop = cx->blk_oldcop;
4324 return CX_LOOP_NEXTOP_GET(cx);
4326 return cx->blk_givwhen.leave_op;
4330 S_doparseform(pTHX_ SV *sv)
4333 register char *s = SvPV_force(sv, len);
4334 register char * const send = s + len;
4335 register char *base = NULL;
4336 register I32 skipspaces = 0;
4337 bool noblank = FALSE;
4338 bool repeat = FALSE;
4339 bool postspace = FALSE;
4345 bool unchopnum = FALSE;
4346 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4349 Perl_croak(aTHX_ "Null picture in formline");
4351 /* estimate the buffer size needed */
4352 for (base = s; s <= send; s++) {
4353 if (*s == '\n' || *s == '@' || *s == '^')
4359 Newx(fops, maxops, U32);
4364 *fpc++ = FF_LINEMARK;
4365 noblank = repeat = FALSE;
4383 case ' ': case '\t':
4390 } /* else FALL THROUGH */
4398 *fpc++ = FF_LITERAL;
4406 *fpc++ = (U16)skipspaces;
4410 *fpc++ = FF_NEWLINE;
4414 arg = fpc - linepc + 1;
4421 *fpc++ = FF_LINEMARK;
4422 noblank = repeat = FALSE;
4431 ischop = s[-1] == '^';
4437 arg = (s - base) - 1;
4439 *fpc++ = FF_LITERAL;
4447 *fpc++ = 2; /* skip the @* or ^* */
4449 *fpc++ = FF_LINESNGL;
4452 *fpc++ = FF_LINEGLOB;
4454 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4455 arg = ischop ? 512 : 0;
4460 const char * const f = ++s;
4463 arg |= 256 + (s - f);
4465 *fpc++ = s - base; /* fieldsize for FETCH */
4466 *fpc++ = FF_DECIMAL;
4468 unchopnum |= ! ischop;
4470 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4471 arg = ischop ? 512 : 0;
4473 s++; /* skip the '0' first */
4477 const char * const f = ++s;
4480 arg |= 256 + (s - f);
4482 *fpc++ = s - base; /* fieldsize for FETCH */
4483 *fpc++ = FF_0DECIMAL;
4485 unchopnum |= ! ischop;
4489 bool ismore = FALSE;
4492 while (*++s == '>') ;
4493 prespace = FF_SPACE;
4495 else if (*s == '|') {
4496 while (*++s == '|') ;
4497 prespace = FF_HALFSPACE;
4502 while (*++s == '<') ;
4505 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4509 *fpc++ = s - base; /* fieldsize for FETCH */
4511 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4514 *fpc++ = (U16)prespace;
4528 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4530 { /* need to jump to the next word */
4532 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4533 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4534 s = SvPVX(sv) + SvCUR(sv) + z;
4536 Copy(fops, s, arg, U32);
4538 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4541 if (unchopnum && repeat)
4542 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4548 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4550 /* Can value be printed in fldsize chars, using %*.*f ? */
4554 int intsize = fldsize - (value < 0 ? 1 : 0);
4561 while (intsize--) pwr *= 10.0;
4562 while (frcsize--) eps /= 10.0;
4565 if (value + eps >= pwr)
4568 if (value - eps <= -pwr)
4575 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4578 SV * const datasv = FILTER_DATA(idx);
4579 const int filter_has_file = IoLINES(datasv);
4580 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4581 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4585 const char *got_p = NULL;
4586 const char *prune_from = NULL;
4587 bool read_from_cache = FALSE;
4590 assert(maxlen >= 0);
4593 /* I was having segfault trouble under Linux 2.2.5 after a
4594 parse error occured. (Had to hack around it with a test
4595 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4596 not sure where the trouble is yet. XXX */
4598 if (IoFMT_GV(datasv)) {
4599 SV *const cache = (SV *)IoFMT_GV(datasv);
4602 const char *cache_p = SvPV(cache, cache_len);
4606 /* Running in block mode and we have some cached data already.
4608 if (cache_len >= umaxlen) {
4609 /* In fact, so much data we don't even need to call
4614 const char *const first_nl =
4615 (const char *)memchr(cache_p, '\n', cache_len);
4617 take = first_nl + 1 - cache_p;
4621 sv_catpvn(buf_sv, cache_p, take);
4622 sv_chop(cache, cache_p + take);
4623 /* Definately not EOF */
4627 sv_catsv(buf_sv, cache);
4629 umaxlen -= cache_len;
4632 read_from_cache = TRUE;
4636 /* Filter API says that the filter appends to the contents of the buffer.
4637 Usually the buffer is "", so the details don't matter. But if it's not,
4638 then clearly what it contains is already filtered by this filter, so we
4639 don't want to pass it in a second time.
4640 I'm going to use a mortal in case the upstream filter croaks. */
4641 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4642 ? sv_newmortal() : buf_sv;
4643 SvUPGRADE(upstream, SVt_PV);
4645 if (filter_has_file) {
4646 status = FILTER_READ(idx+1, upstream, 0);
4649 if (filter_sub && status >= 0) {
4660 PUSHs(sv_2mortal(newSViv(0)));
4662 PUSHs(filter_state);
4665 count = call_sv(filter_sub, G_SCALAR);
4680 if(SvOK(upstream)) {
4681 got_p = SvPV(upstream, got_len);
4683 if (got_len > umaxlen) {
4684 prune_from = got_p + umaxlen;
4687 const char *const first_nl =
4688 (const char *)memchr(got_p, '\n', got_len);
4689 if (first_nl && first_nl + 1 < got_p + got_len) {
4690 /* There's a second line here... */
4691 prune_from = first_nl + 1;
4696 /* Oh. Too long. Stuff some in our cache. */
4697 STRLEN cached_len = got_p + got_len - prune_from;
4698 SV *cache = (SV *)IoFMT_GV(datasv);
4701 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4702 } else if (SvOK(cache)) {
4703 /* Cache should be empty. */
4704 assert(!SvCUR(cache));
4707 sv_setpvn(cache, prune_from, cached_len);
4708 /* If you ask for block mode, you may well split UTF-8 characters.
4709 "If it breaks, you get to keep both parts"
4710 (Your code is broken if you don't put them back together again
4711 before something notices.) */
4712 if (SvUTF8(upstream)) {
4715 SvCUR_set(upstream, got_len - cached_len);
4716 /* Can't yet be EOF */
4721 /* If they are at EOF but buf_sv has something in it, then they may never
4722 have touched the SV upstream, so it may be undefined. If we naively
4723 concatenate it then we get a warning about use of uninitialised value.
4725 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4726 sv_catsv(buf_sv, upstream);
4730 IoLINES(datasv) = 0;
4731 SvREFCNT_dec(IoFMT_GV(datasv));
4733 SvREFCNT_dec(filter_state);
4734 IoTOP_GV(datasv) = NULL;
4737 SvREFCNT_dec(filter_sub);
4738 IoBOTTOM_GV(datasv) = NULL;
4740 filter_del(S_run_user_filter);
4742 if (status == 0 && read_from_cache) {
4743 /* If we read some data from the cache (and by getting here it implies
4744 that we emptied the cache) then we aren't yet at EOF, and mustn't
4745 report that to our caller. */
4751 /* perhaps someone can come up with a better name for
4752 this? it is not really "absolute", per se ... */
4754 S_path_is_absolute(const char *name)
4756 if (PERL_FILE_IS_ABSOLUTE(name)
4757 #ifdef MACOS_TRADITIONAL
4760 || (*name == '.' && (name[1] == '/' ||
4761 (name[1] == '.' && name[2] == '/')))
4773 * c-indentation-style: bsd
4775 * indent-tabs-mode: t
4778 * ex: set ts=8 sts=4 sw=4 noet: