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