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;
80 /* prevent recompiling under /o and ithreads. */
81 #if defined(USE_ITHREADS)
82 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
83 if (PL_op->op_flags & OPf_STACKED) {
92 if (PL_op->op_flags & OPf_STACKED) {
93 /* multiple args; concatentate them */
95 tmpstr = PAD_SV(ARGTARG);
96 sv_setpvn(tmpstr, "", 0);
97 while (++MARK <= SP) {
98 if (PL_amagic_generation) {
100 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
101 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
103 sv_setsv(tmpstr, sv);
107 sv_catsv(tmpstr, *MARK);
116 SV * const sv = SvRV(tmpstr);
118 mg = mg_find(sv, PERL_MAGIC_qr);
121 regexp * const re = (regexp *)mg->mg_obj;
122 ReREFCNT_dec(PM_GETRE(pm));
123 PM_SETRE(pm, ReREFCNT_inc(re));
127 const char *t = SvPV_const(tmpstr, len);
128 regexp * const re = PM_GETRE(pm);
130 /* Check against the last compiled regexp. */
131 if (!re || !re->precomp || re->prelen != (I32)len ||
132 memNE(re->precomp, t, len))
134 const regexp_engine *eng = re ? re->engine : NULL;
138 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
139 } else if (PL_curcop->cop_hints_hash) {
140 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
142 if (ptr && SvIOK(ptr) && SvIV(ptr))
143 eng = INT2PTR(regexp_engine*,SvIV(ptr));
146 if (PL_op->op_flags & OPf_SPECIAL)
147 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
149 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
151 pm->op_pmdynflags |= PMdf_DYN_UTF8;
153 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
154 if (pm->op_pmdynflags & PMdf_UTF8)
155 t = (char*)bytes_to_utf8((U8*)t, &len);
158 PM_SETRE(pm, CALLREGCOMP_ENG(eng,(char *)t, (char *)t + len, pm));
160 PM_SETRE(pm, CALLREGCOMP((char *)t, (char *)t + len, pm));
162 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
164 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
165 inside tie/overload accessors. */
169 #ifndef INCOMPLETE_TAINTS
172 pm->op_pmdynflags |= PMdf_TAINTED;
174 pm->op_pmdynflags &= ~PMdf_TAINTED;
178 if (!PM_GETRE(pm)->prelen && PL_curpm)
180 else if (PM_GETRE(pm)->extflags & RXf_WHITE)
181 pm->op_pmflags |= PMf_WHITE;
183 pm->op_pmflags &= ~PMf_WHITE;
185 /* XXX runtime compiled output needs to move to the pad */
186 if (pm->op_pmflags & PMf_KEEP) {
187 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
188 #if !defined(USE_ITHREADS)
189 /* XXX can't change the optree at runtime either */
190 cLOGOP->op_first->op_next = PL_op->op_next;
200 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
201 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
202 register SV * const dstr = cx->sb_dstr;
203 register char *s = cx->sb_s;
204 register char *m = cx->sb_m;
205 char *orig = cx->sb_orig;
206 register REGEXP * const rx = cx->sb_rx;
208 REGEXP *old = PM_GETRE(pm);
212 PM_SETRE(pm,ReREFCNT_inc(rx));
215 rxres_restore(&cx->sb_rxres, rx);
216 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
218 if (cx->sb_iters++) {
219 const I32 saviters = cx->sb_iters;
220 if (cx->sb_iters > cx->sb_maxiters)
221 DIE(aTHX_ "Substitution loop");
223 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
224 cx->sb_rxtainted |= 2;
225 sv_catsv(dstr, POPs);
226 FREETMPS; /* Prevent excess tmp stack */
229 if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
230 s == m, cx->sb_targ, NULL,
231 ((cx->sb_rflags & REXEC_COPY_STR)
232 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
233 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
235 SV * const targ = cx->sb_targ;
237 assert(cx->sb_strend >= s);
238 if(cx->sb_strend > s) {
239 if (DO_UTF8(dstr) && !SvUTF8(targ))
240 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
242 sv_catpvn(dstr, s, cx->sb_strend - s);
244 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
246 #ifdef PERL_OLD_COPY_ON_WRITE
248 sv_force_normal_flags(targ, SV_COW_DROP_PV);
254 SvPV_set(targ, SvPVX(dstr));
255 SvCUR_set(targ, SvCUR(dstr));
256 SvLEN_set(targ, SvLEN(dstr));
259 SvPV_set(dstr, NULL);
261 TAINT_IF(cx->sb_rxtainted & 1);
262 PUSHs(sv_2mortal(newSViv(saviters - 1)));
264 (void)SvPOK_only_UTF8(targ);
265 TAINT_IF(cx->sb_rxtainted);
269 LEAVE_SCOPE(cx->sb_oldsave);
271 RETURNOP(pm->op_next);
273 cx->sb_iters = saviters;
275 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
278 cx->sb_orig = orig = rx->subbeg;
280 cx->sb_strend = s + (cx->sb_strend - m);
282 cx->sb_m = m = rx->startp[0] + orig;
284 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
285 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
287 sv_catpvn(dstr, s, m-s);
289 cx->sb_s = rx->endp[0] + orig;
290 { /* Update the pos() information. */
291 SV * const sv = cx->sb_targ;
294 if (SvTYPE(sv) < SVt_PVMG)
295 SvUPGRADE(sv, SVt_PVMG);
296 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
297 #ifdef PERL_OLD_COPY_ON_WRITE
299 sv_force_normal_flags(sv, 0);
301 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
310 (void)ReREFCNT_inc(rx);
311 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
312 rxres_save(&cx->sb_rxres, rx);
313 RETURNOP(pm->op_pmreplstart);
317 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
323 if (!p || p[1] < rx->nparens) {
324 #ifdef PERL_OLD_COPY_ON_WRITE
325 i = 7 + rx->nparens * 2;
327 i = 6 + rx->nparens * 2;
336 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : NULL);
337 RX_MATCH_COPIED_off(rx);
339 #ifdef PERL_OLD_COPY_ON_WRITE
340 *p++ = PTR2UV(rx->saved_copy);
341 rx->saved_copy = NULL;
346 *p++ = PTR2UV(rx->subbeg);
347 *p++ = (UV)rx->sublen;
348 for (i = 0; i <= rx->nparens; ++i) {
349 *p++ = (UV)rx->startp[i];
350 *p++ = (UV)rx->endp[i];
355 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
361 RX_MATCH_COPY_FREE(rx);
362 RX_MATCH_COPIED_set(rx, *p);
365 #ifdef PERL_OLD_COPY_ON_WRITE
367 SvREFCNT_dec (rx->saved_copy);
368 rx->saved_copy = INT2PTR(SV*,*p);
374 rx->subbeg = INT2PTR(char*,*p++);
375 rx->sublen = (I32)(*p++);
376 for (i = 0; i <= rx->nparens; ++i) {
377 rx->startp[i] = (I32)(*p++);
378 rx->endp[i] = (I32)(*p++);
383 Perl_rxres_free(pTHX_ void **rsp)
385 UV * const p = (UV*)*rsp;
390 void *tmp = INT2PTR(char*,*p);
393 PoisonFree(*p, 1, sizeof(*p));
395 Safefree(INT2PTR(char*,*p));
397 #ifdef PERL_OLD_COPY_ON_WRITE
399 SvREFCNT_dec (INT2PTR(SV*,p[1]));
409 dVAR; dSP; dMARK; dORIGMARK;
410 register SV * const tmpForm = *++MARK;
415 register SV *sv = NULL;
416 const char *item = NULL;
420 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
421 const char *chophere = NULL;
422 char *linemark = NULL;
424 bool gotsome = FALSE;
426 const STRLEN fudge = SvPOK(tmpForm)
427 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
428 bool item_is_utf8 = FALSE;
429 bool targ_is_utf8 = FALSE;
431 OP * parseres = NULL;
435 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
436 if (SvREADONLY(tmpForm)) {
437 SvREADONLY_off(tmpForm);
438 parseres = doparseform(tmpForm);
439 SvREADONLY_on(tmpForm);
442 parseres = doparseform(tmpForm);
446 SvPV_force(PL_formtarget, len);
447 if (DO_UTF8(PL_formtarget))
449 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
451 f = SvPV_const(tmpForm, len);
452 /* need to jump to the next word */
453 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
457 const char *name = "???";
460 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
461 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
462 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
463 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
464 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
466 case FF_CHECKNL: name = "CHECKNL"; break;
467 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
468 case FF_SPACE: name = "SPACE"; break;
469 case FF_HALFSPACE: name = "HALFSPACE"; break;
470 case FF_ITEM: name = "ITEM"; break;
471 case FF_CHOP: name = "CHOP"; break;
472 case FF_LINEGLOB: name = "LINEGLOB"; break;
473 case FF_NEWLINE: name = "NEWLINE"; break;
474 case FF_MORE: name = "MORE"; break;
475 case FF_LINEMARK: name = "LINEMARK"; break;
476 case FF_END: name = "END"; break;
477 case FF_0DECIMAL: name = "0DECIMAL"; break;
478 case FF_LINESNGL: name = "LINESNGL"; break;
481 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
483 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
494 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
495 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
497 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
498 t = SvEND(PL_formtarget);
501 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
502 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
504 sv_utf8_upgrade(PL_formtarget);
505 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
506 t = SvEND(PL_formtarget);
526 if (ckWARN(WARN_SYNTAX))
527 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
534 const char *s = item = SvPV_const(sv, len);
537 itemsize = sv_len_utf8(sv);
538 if (itemsize != (I32)len) {
540 if (itemsize > fieldsize) {
541 itemsize = fieldsize;
542 itembytes = itemsize;
543 sv_pos_u2b(sv, &itembytes, 0);
547 send = chophere = s + itembytes;
557 sv_pos_b2u(sv, &itemsize);
561 item_is_utf8 = FALSE;
562 if (itemsize > fieldsize)
563 itemsize = fieldsize;
564 send = chophere = s + itemsize;
578 const char *s = item = SvPV_const(sv, len);
581 itemsize = sv_len_utf8(sv);
582 if (itemsize != (I32)len) {
584 if (itemsize <= fieldsize) {
585 const char *send = chophere = s + itemsize;
598 itemsize = fieldsize;
599 itembytes = itemsize;
600 sv_pos_u2b(sv, &itembytes, 0);
601 send = chophere = s + itembytes;
602 while (s < send || (s == send && isSPACE(*s))) {
612 if (strchr(PL_chopset, *s))
617 itemsize = chophere - item;
618 sv_pos_b2u(sv, &itemsize);
624 item_is_utf8 = FALSE;
625 if (itemsize <= fieldsize) {
626 const char *const send = chophere = s + itemsize;
639 itemsize = fieldsize;
640 send = chophere = s + itemsize;
641 while (s < send || (s == send && isSPACE(*s))) {
651 if (strchr(PL_chopset, *s))
656 itemsize = chophere - item;
662 arg = fieldsize - itemsize;
671 arg = fieldsize - itemsize;
682 const char *s = item;
686 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
688 sv_utf8_upgrade(PL_formtarget);
689 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
690 t = SvEND(PL_formtarget);
694 if (UTF8_IS_CONTINUED(*s)) {
695 STRLEN skip = UTF8SKIP(s);
712 if ( !((*t++ = *s++) & ~31) )
718 if (targ_is_utf8 && !item_is_utf8) {
719 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
721 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
722 for (; t < SvEND(PL_formtarget); t++) {
735 const int ch = *t++ = *s++;
738 if ( !((*t++ = *s++) & ~31) )
747 const char *s = chophere;
765 const char *s = item = SvPV_const(sv, len);
767 if ((item_is_utf8 = DO_UTF8(sv)))
768 itemsize = sv_len_utf8(sv);
770 bool chopped = FALSE;
771 const char *const send = s + len;
773 chophere = s + itemsize;
789 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
791 SvUTF8_on(PL_formtarget);
793 SvCUR_set(sv, chophere - item);
794 sv_catsv(PL_formtarget, sv);
795 SvCUR_set(sv, itemsize);
797 sv_catsv(PL_formtarget, sv);
799 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
800 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
801 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
810 #if defined(USE_LONG_DOUBLE)
813 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
817 "%#0*.*f" : "%0*.*f");
822 #if defined(USE_LONG_DOUBLE)
824 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
827 ((arg & 256) ? "%#*.*f" : "%*.*f");
830 /* If the field is marked with ^ and the value is undefined,
832 if ((arg & 512) && !SvOK(sv)) {
840 /* overflow evidence */
841 if (num_overflow(value, fieldsize, arg)) {
847 /* Formats aren't yet marked for locales, so assume "yes". */
849 STORE_NUMERIC_STANDARD_SET_LOCAL();
850 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
851 RESTORE_NUMERIC_STANDARD();
858 while (t-- > linemark && *t == ' ') ;
866 if (arg) { /* repeat until fields exhausted? */
868 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
869 lines += FmLINES(PL_formtarget);
872 if (strnEQ(linemark, linemark - arg, arg))
873 DIE(aTHX_ "Runaway format");
876 SvUTF8_on(PL_formtarget);
877 FmLINES(PL_formtarget) = lines;
879 RETURNOP(cLISTOP->op_first);
890 const char *s = chophere;
891 const char *send = item + len;
893 while (isSPACE(*s) && (s < send))
898 arg = fieldsize - itemsize;
905 if (strnEQ(s1," ",3)) {
906 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
917 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
919 SvUTF8_on(PL_formtarget);
920 FmLINES(PL_formtarget) += lines;
932 if (PL_stack_base + *PL_markstack_ptr == SP) {
934 if (GIMME_V == G_SCALAR)
935 XPUSHs(sv_2mortal(newSViv(0)));
936 RETURNOP(PL_op->op_next->op_next);
938 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
939 pp_pushmark(); /* push dst */
940 pp_pushmark(); /* push src */
941 ENTER; /* enter outer scope */
944 if (PL_op->op_private & OPpGREP_LEX)
945 SAVESPTR(PAD_SVl(PL_op->op_targ));
948 ENTER; /* enter inner scope */
951 src = PL_stack_base[*PL_markstack_ptr];
953 if (PL_op->op_private & OPpGREP_LEX)
954 PAD_SVl(PL_op->op_targ) = src;
959 if (PL_op->op_type == OP_MAPSTART)
960 pp_pushmark(); /* push top */
961 return ((LOGOP*)PL_op->op_next)->op_other;
967 const I32 gimme = GIMME_V;
968 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
974 /* first, move source pointer to the next item in the source list */
975 ++PL_markstack_ptr[-1];
977 /* if there are new items, push them into the destination list */
978 if (items && gimme != G_VOID) {
979 /* might need to make room back there first */
980 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
981 /* XXX this implementation is very pessimal because the stack
982 * is repeatedly extended for every set of items. Is possible
983 * to do this without any stack extension or copying at all
984 * by maintaining a separate list over which the map iterates
985 * (like foreach does). --gsar */
987 /* everything in the stack after the destination list moves
988 * towards the end the stack by the amount of room needed */
989 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
991 /* items to shift up (accounting for the moved source pointer) */
992 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
994 /* This optimization is by Ben Tilly and it does
995 * things differently from what Sarathy (gsar)
996 * is describing. The downside of this optimization is
997 * that leaves "holes" (uninitialized and hopefully unused areas)
998 * to the Perl stack, but on the other hand this
999 * shouldn't be a problem. If Sarathy's idea gets
1000 * implemented, this optimization should become
1001 * irrelevant. --jhi */
1003 shift = count; /* Avoid shifting too often --Ben Tilly */
1007 dst = (SP += shift);
1008 PL_markstack_ptr[-1] += shift;
1009 *PL_markstack_ptr += shift;
1013 /* copy the new items down to the destination list */
1014 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1015 if (gimme == G_ARRAY) {
1017 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1020 /* scalar context: we don't care about which values map returns
1021 * (we use undef here). And so we certainly don't want to do mortal
1022 * copies of meaningless values. */
1023 while (items-- > 0) {
1025 *dst-- = &PL_sv_undef;
1029 LEAVE; /* exit inner scope */
1032 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1034 (void)POPMARK; /* pop top */
1035 LEAVE; /* exit outer scope */
1036 (void)POPMARK; /* pop src */
1037 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1038 (void)POPMARK; /* pop dst */
1039 SP = PL_stack_base + POPMARK; /* pop original mark */
1040 if (gimme == G_SCALAR) {
1041 if (PL_op->op_private & OPpGREP_LEX) {
1042 SV* sv = sv_newmortal();
1043 sv_setiv(sv, items);
1051 else if (gimme == G_ARRAY)
1058 ENTER; /* enter inner scope */
1061 /* set $_ to the new source item */
1062 src = PL_stack_base[PL_markstack_ptr[-1]];
1064 if (PL_op->op_private & OPpGREP_LEX)
1065 PAD_SVl(PL_op->op_targ) = src;
1069 RETURNOP(cLOGOP->op_other);
1078 if (GIMME == G_ARRAY)
1080 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1081 return cLOGOP->op_other;
1091 if (GIMME == G_ARRAY) {
1092 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1096 SV * const targ = PAD_SV(PL_op->op_targ);
1099 if (PL_op->op_private & OPpFLIP_LINENUM) {
1100 if (GvIO(PL_last_in_gv)) {
1101 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1104 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1106 flip = SvIV(sv) == SvIV(GvSV(gv));
1112 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1113 if (PL_op->op_flags & OPf_SPECIAL) {
1121 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1124 sv_setpvn(TARG, "", 0);
1130 /* This code tries to decide if "$left .. $right" should use the
1131 magical string increment, or if the range is numeric (we make
1132 an exception for .."0" [#18165]). AMS 20021031. */
1134 #define RANGE_IS_NUMERIC(left,right) ( \
1135 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1136 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1137 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1138 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1139 && (!SvOK(right) || looks_like_number(right))))
1145 if (GIMME == G_ARRAY) {
1151 if (RANGE_IS_NUMERIC(left,right)) {
1154 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1155 (SvOK(right) && SvNV(right) > IV_MAX))
1156 DIE(aTHX_ "Range iterator outside integer range");
1167 SV * const sv = sv_2mortal(newSViv(i++));
1172 SV * const final = sv_mortalcopy(right);
1174 const char * const tmps = SvPV_const(final, len);
1176 SV *sv = sv_mortalcopy(left);
1177 SvPV_force_nolen(sv);
1178 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1180 if (strEQ(SvPVX_const(sv),tmps))
1182 sv = sv_2mortal(newSVsv(sv));
1189 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1193 if (PL_op->op_private & OPpFLIP_LINENUM) {
1194 if (GvIO(PL_last_in_gv)) {
1195 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1198 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1199 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1207 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1208 sv_catpvs(targ, "E0");
1218 static const char * const context_name[] = {
1231 S_dopoptolabel(pTHX_ const char *label)
1236 for (i = cxstack_ix; i >= 0; i--) {
1237 register const PERL_CONTEXT * const cx = &cxstack[i];
1238 switch (CxTYPE(cx)) {
1246 if (ckWARN(WARN_EXITING))
1247 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1248 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1249 if (CxTYPE(cx) == CXt_NULL)
1253 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1254 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1255 (long)i, cx->blk_loop.label));
1258 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1268 Perl_dowantarray(pTHX)
1271 const I32 gimme = block_gimme();
1272 return (gimme == G_VOID) ? G_SCALAR : gimme;
1276 Perl_block_gimme(pTHX)
1279 const I32 cxix = dopoptosub(cxstack_ix);
1283 switch (cxstack[cxix].blk_gimme) {
1291 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1298 Perl_is_lvalue_sub(pTHX)
1301 const I32 cxix = dopoptosub(cxstack_ix);
1302 assert(cxix >= 0); /* We should only be called from inside subs */
1304 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1305 return cxstack[cxix].blk_sub.lval;
1311 S_dopoptosub(pTHX_ I32 startingblock)
1314 return dopoptosub_at(cxstack, startingblock);
1318 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1322 for (i = startingblock; i >= 0; i--) {
1323 register const PERL_CONTEXT * const cx = &cxstk[i];
1324 switch (CxTYPE(cx)) {
1330 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1338 S_dopoptoeval(pTHX_ I32 startingblock)
1342 for (i = startingblock; i >= 0; i--) {
1343 register const PERL_CONTEXT *cx = &cxstack[i];
1344 switch (CxTYPE(cx)) {
1348 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1356 S_dopoptoloop(pTHX_ I32 startingblock)
1360 for (i = startingblock; i >= 0; i--) {
1361 register const PERL_CONTEXT * const cx = &cxstack[i];
1362 switch (CxTYPE(cx)) {
1368 if (ckWARN(WARN_EXITING))
1369 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1370 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1371 if ((CxTYPE(cx)) == CXt_NULL)
1375 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1383 S_dopoptogiven(pTHX_ I32 startingblock)
1387 for (i = startingblock; i >= 0; i--) {
1388 register const PERL_CONTEXT *cx = &cxstack[i];
1389 switch (CxTYPE(cx)) {
1393 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1396 if (CxFOREACHDEF(cx)) {
1397 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1406 S_dopoptowhen(pTHX_ I32 startingblock)
1410 for (i = startingblock; i >= 0; i--) {
1411 register const PERL_CONTEXT *cx = &cxstack[i];
1412 switch (CxTYPE(cx)) {
1416 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1424 Perl_dounwind(pTHX_ I32 cxix)
1429 while (cxstack_ix > cxix) {
1431 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1432 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1433 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1434 /* Note: we don't need to restore the base context info till the end. */
1435 switch (CxTYPE(cx)) {
1438 continue; /* not break */
1457 PERL_UNUSED_VAR(optype);
1461 Perl_qerror(pTHX_ SV *err)
1465 sv_catsv(ERRSV, err);
1467 sv_catsv(PL_errors, err);
1469 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1474 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1483 if (PL_in_eval & EVAL_KEEPERR) {
1484 static const char prefix[] = "\t(in cleanup) ";
1485 SV * const err = ERRSV;
1486 const char *e = NULL;
1488 sv_setpvn(err,"",0);
1489 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1491 e = SvPV_const(err, len);
1493 if (*e != *message || strNE(e,message))
1497 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1498 sv_catpvn(err, prefix, sizeof(prefix)-1);
1499 sv_catpvn(err, message, msglen);
1500 if (ckWARN(WARN_MISC)) {
1501 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1502 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1507 sv_setpvn(ERRSV, message, msglen);
1511 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1512 && PL_curstackinfo->si_prev)
1520 register PERL_CONTEXT *cx;
1523 if (cxix < cxstack_ix)
1526 POPBLOCK(cx,PL_curpm);
1527 if (CxTYPE(cx) != CXt_EVAL) {
1529 message = SvPVx_const(ERRSV, msglen);
1530 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1531 PerlIO_write(Perl_error_log, message, msglen);
1536 if (gimme == G_SCALAR)
1537 *++newsp = &PL_sv_undef;
1538 PL_stack_sp = newsp;
1542 /* LEAVE could clobber PL_curcop (see save_re_context())
1543 * XXX it might be better to find a way to avoid messing with
1544 * PL_curcop in save_re_context() instead, but this is a more
1545 * minimal fix --GSAR */
1546 PL_curcop = cx->blk_oldcop;
1548 if (optype == OP_REQUIRE) {
1549 const char* const msg = SvPVx_nolen_const(ERRSV);
1550 SV * const nsv = cx->blk_eval.old_namesv;
1551 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1553 DIE(aTHX_ "%sCompilation failed in require",
1554 *msg ? msg : "Unknown error\n");
1556 assert(CxTYPE(cx) == CXt_EVAL);
1557 return cx->blk_eval.retop;
1561 message = SvPVx_const(ERRSV, msglen);
1563 write_to_stderr(message, msglen);
1571 dVAR; dSP; dPOPTOPssrl;
1572 if (SvTRUE(left) != SvTRUE(right))
1582 register I32 cxix = dopoptosub(cxstack_ix);
1583 register const PERL_CONTEXT *cx;
1584 register const PERL_CONTEXT *ccstack = cxstack;
1585 const PERL_SI *top_si = PL_curstackinfo;
1587 const char *stashname;
1594 /* we may be in a higher stacklevel, so dig down deeper */
1595 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1596 top_si = top_si->si_prev;
1597 ccstack = top_si->si_cxstack;
1598 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1601 if (GIMME != G_ARRAY) {
1607 /* caller() should not report the automatic calls to &DB::sub */
1608 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1609 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1613 cxix = dopoptosub_at(ccstack, cxix - 1);
1616 cx = &ccstack[cxix];
1617 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1618 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1619 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1620 field below is defined for any cx. */
1621 /* caller() should not report the automatic calls to &DB::sub */
1622 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1623 cx = &ccstack[dbcxix];
1626 stashname = CopSTASHPV(cx->blk_oldcop);
1627 if (GIMME != G_ARRAY) {
1630 PUSHs(&PL_sv_undef);
1633 sv_setpv(TARG, stashname);
1642 PUSHs(&PL_sv_undef);
1644 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1645 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1646 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1649 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1650 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1651 /* So is ccstack[dbcxix]. */
1653 SV * const sv = newSV(0);
1654 gv_efullname3(sv, cvgv, NULL);
1655 PUSHs(sv_2mortal(sv));
1656 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1659 PUSHs(sv_2mortal(newSVpvs("(unknown)")));
1660 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1664 PUSHs(sv_2mortal(newSVpvs("(eval)")));
1665 PUSHs(sv_2mortal(newSViv(0)));
1667 gimme = (I32)cx->blk_gimme;
1668 if (gimme == G_VOID)
1669 PUSHs(&PL_sv_undef);
1671 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1672 if (CxTYPE(cx) == CXt_EVAL) {
1674 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1675 PUSHs(cx->blk_eval.cur_text);
1679 else if (cx->blk_eval.old_namesv) {
1680 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1683 /* eval BLOCK (try blocks have old_namesv == 0) */
1685 PUSHs(&PL_sv_undef);
1686 PUSHs(&PL_sv_undef);
1690 PUSHs(&PL_sv_undef);
1691 PUSHs(&PL_sv_undef);
1693 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1694 && CopSTASH_eq(PL_curcop, PL_debstash))
1696 AV * const ary = cx->blk_sub.argarray;
1697 const int off = AvARRAY(ary) - AvALLOC(ary);
1700 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1701 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1703 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1706 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1707 av_extend(PL_dbargs, AvFILLp(ary) + off);
1708 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1709 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1711 /* XXX only hints propagated via op_private are currently
1712 * visible (others are not easily accessible, since they
1713 * use the global PL_hints) */
1714 PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
1717 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1719 if (old_warnings == pWARN_NONE ||
1720 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1721 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1722 else if (old_warnings == pWARN_ALL ||
1723 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1724 /* Get the bit mask for $warnings::Bits{all}, because
1725 * it could have been extended by warnings::register */
1727 HV * const bits = get_hv("warnings::Bits", FALSE);
1728 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1729 mask = newSVsv(*bits_all);
1732 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1736 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1737 PUSHs(sv_2mortal(mask));
1740 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1741 sv_2mortal(newRV_noinc(
1742 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1743 cx->blk_oldcop->cop_hints_hash)))
1752 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1753 sv_reset(tmps, CopSTASH(PL_curcop));
1758 /* like pp_nextstate, but used instead when the debugger is active */
1763 PL_curcop = (COP*)PL_op;
1764 TAINT_NOT; /* Each statement is presumed innocent */
1765 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1768 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1769 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1772 register PERL_CONTEXT *cx;
1773 const I32 gimme = G_ARRAY;
1775 GV * const gv = PL_DBgv;
1776 register CV * const cv = GvCV(gv);
1779 DIE(aTHX_ "No DB::DB routine defined");
1781 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1782 /* don't do recursive DB::DB call */
1797 (void)(*CvXSUB(cv))(aTHX_ cv);
1804 PUSHBLOCK(cx, CXt_SUB, SP);
1806 cx->blk_sub.retop = PL_op->op_next;
1809 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1810 RETURNOP(CvSTART(cv));
1820 register PERL_CONTEXT *cx;
1821 const I32 gimme = GIMME_V;
1823 U16 cxtype = CXt_LOOP | CXp_FOREACH;
1831 if (PL_op->op_targ) {
1832 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1833 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1834 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1835 SVs_PADSTALE, SVs_PADSTALE);
1837 #ifndef USE_ITHREADS
1838 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1841 SAVEPADSV(PL_op->op_targ);
1842 iterdata = INT2PTR(void*, PL_op->op_targ);
1843 cxtype |= CXp_PADVAR;
1847 GV * const gv = (GV*)POPs;
1848 svp = &GvSV(gv); /* symbol table variable */
1849 SAVEGENERICSV(*svp);
1852 iterdata = (void*)gv;
1856 if (PL_op->op_private & OPpITER_DEF)
1857 cxtype |= CXp_FOR_DEF;
1861 PUSHBLOCK(cx, cxtype, SP);
1863 PUSHLOOP(cx, iterdata, MARK);
1865 PUSHLOOP(cx, svp, MARK);
1867 if (PL_op->op_flags & OPf_STACKED) {
1868 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1869 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1871 SV * const right = (SV*)cx->blk_loop.iterary;
1874 if (RANGE_IS_NUMERIC(sv,right)) {
1875 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1876 (SvOK(right) && SvNV(right) >= IV_MAX))
1877 DIE(aTHX_ "Range iterator outside integer range");
1878 cx->blk_loop.iterix = SvIV(sv);
1879 cx->blk_loop.itermax = SvIV(right);
1881 /* for correct -Dstv display */
1882 cx->blk_oldsp = sp - PL_stack_base;
1886 cx->blk_loop.iterlval = newSVsv(sv);
1887 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1888 (void) SvPV_nolen_const(right);
1891 else if (PL_op->op_private & OPpITER_REVERSED) {
1892 cx->blk_loop.itermax = 0;
1893 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1898 cx->blk_loop.iterary = PL_curstack;
1899 AvFILLp(PL_curstack) = SP - PL_stack_base;
1900 if (PL_op->op_private & OPpITER_REVERSED) {
1901 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1902 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1905 cx->blk_loop.iterix = MARK - PL_stack_base;
1915 register PERL_CONTEXT *cx;
1916 const I32 gimme = GIMME_V;
1922 PUSHBLOCK(cx, CXt_LOOP, SP);
1923 PUSHLOOP(cx, 0, SP);
1931 register PERL_CONTEXT *cx;
1938 assert(CxTYPE(cx) == CXt_LOOP);
1940 newsp = PL_stack_base + cx->blk_loop.resetsp;
1943 if (gimme == G_VOID)
1945 else if (gimme == G_SCALAR) {
1947 *++newsp = sv_mortalcopy(*SP);
1949 *++newsp = &PL_sv_undef;
1953 *++newsp = sv_mortalcopy(*++mark);
1954 TAINT_NOT; /* Each item is independent */
1960 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1961 PL_curpm = newpm; /* ... and pop $1 et al */
1972 register PERL_CONTEXT *cx;
1973 bool popsub2 = FALSE;
1974 bool clear_errsv = FALSE;
1982 const I32 cxix = dopoptosub(cxstack_ix);
1985 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1986 * sort block, which is a CXt_NULL
1989 PL_stack_base[1] = *PL_stack_sp;
1990 PL_stack_sp = PL_stack_base + 1;
1994 DIE(aTHX_ "Can't return outside a subroutine");
1996 if (cxix < cxstack_ix)
1999 if (CxMULTICALL(&cxstack[cxix])) {
2000 gimme = cxstack[cxix].blk_gimme;
2001 if (gimme == G_VOID)
2002 PL_stack_sp = PL_stack_base;
2003 else if (gimme == G_SCALAR) {
2004 PL_stack_base[1] = *PL_stack_sp;
2005 PL_stack_sp = PL_stack_base + 1;
2011 switch (CxTYPE(cx)) {
2014 retop = cx->blk_sub.retop;
2015 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2018 if (!(PL_in_eval & EVAL_KEEPERR))
2021 retop = cx->blk_eval.retop;
2025 if (optype == OP_REQUIRE &&
2026 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2028 /* Unassume the success we assumed earlier. */
2029 SV * const nsv = cx->blk_eval.old_namesv;
2030 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2031 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2036 retop = cx->blk_sub.retop;
2039 DIE(aTHX_ "panic: return");
2043 if (gimme == G_SCALAR) {
2046 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2048 *++newsp = SvREFCNT_inc(*SP);
2053 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2055 *++newsp = sv_mortalcopy(sv);
2060 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2063 *++newsp = sv_mortalcopy(*SP);
2066 *++newsp = &PL_sv_undef;
2068 else if (gimme == G_ARRAY) {
2069 while (++MARK <= SP) {
2070 *++newsp = (popsub2 && SvTEMP(*MARK))
2071 ? *MARK : sv_mortalcopy(*MARK);
2072 TAINT_NOT; /* Each item is independent */
2075 PL_stack_sp = newsp;
2078 /* Stack values are safe: */
2081 POPSUB(cx,sv); /* release CV and @_ ... */
2085 PL_curpm = newpm; /* ... and pop $1 et al */
2089 sv_setpvn(ERRSV,"",0);
2097 register PERL_CONTEXT *cx;
2108 if (PL_op->op_flags & OPf_SPECIAL) {
2109 cxix = dopoptoloop(cxstack_ix);
2111 DIE(aTHX_ "Can't \"last\" outside a loop block");
2114 cxix = dopoptolabel(cPVOP->op_pv);
2116 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2118 if (cxix < cxstack_ix)
2122 cxstack_ix++; /* temporarily protect top context */
2124 switch (CxTYPE(cx)) {
2127 newsp = PL_stack_base + cx->blk_loop.resetsp;
2128 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2132 nextop = cx->blk_sub.retop;
2136 nextop = cx->blk_eval.retop;
2140 nextop = cx->blk_sub.retop;
2143 DIE(aTHX_ "panic: last");
2147 if (gimme == G_SCALAR) {
2149 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2150 ? *SP : sv_mortalcopy(*SP);
2152 *++newsp = &PL_sv_undef;
2154 else if (gimme == G_ARRAY) {
2155 while (++MARK <= SP) {
2156 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2157 ? *MARK : sv_mortalcopy(*MARK);
2158 TAINT_NOT; /* Each item is independent */
2166 /* Stack values are safe: */
2169 POPLOOP(cx); /* release loop vars ... */
2173 POPSUB(cx,sv); /* release CV and @_ ... */
2176 PL_curpm = newpm; /* ... and pop $1 et al */
2179 PERL_UNUSED_VAR(optype);
2180 PERL_UNUSED_VAR(gimme);
2188 register PERL_CONTEXT *cx;
2191 if (PL_op->op_flags & OPf_SPECIAL) {
2192 cxix = dopoptoloop(cxstack_ix);
2194 DIE(aTHX_ "Can't \"next\" outside a loop block");
2197 cxix = dopoptolabel(cPVOP->op_pv);
2199 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2201 if (cxix < cxstack_ix)
2204 /* clear off anything above the scope we're re-entering, but
2205 * save the rest until after a possible continue block */
2206 inner = PL_scopestack_ix;
2208 if (PL_scopestack_ix < inner)
2209 leave_scope(PL_scopestack[PL_scopestack_ix]);
2210 PL_curcop = cx->blk_oldcop;
2211 return CX_LOOP_NEXTOP_GET(cx);
2218 register PERL_CONTEXT *cx;
2222 if (PL_op->op_flags & OPf_SPECIAL) {
2223 cxix = dopoptoloop(cxstack_ix);
2225 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2228 cxix = dopoptolabel(cPVOP->op_pv);
2230 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2232 if (cxix < cxstack_ix)
2235 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2236 if (redo_op->op_type == OP_ENTER) {
2237 /* pop one less context to avoid $x being freed in while (my $x..) */
2239 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2240 redo_op = redo_op->op_next;
2244 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2245 LEAVE_SCOPE(oldsave);
2247 PL_curcop = cx->blk_oldcop;
2252 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2256 static const char too_deep[] = "Target of goto is too deeply nested";
2259 Perl_croak(aTHX_ too_deep);
2260 if (o->op_type == OP_LEAVE ||
2261 o->op_type == OP_SCOPE ||
2262 o->op_type == OP_LEAVELOOP ||
2263 o->op_type == OP_LEAVESUB ||
2264 o->op_type == OP_LEAVETRY)
2266 *ops++ = cUNOPo->op_first;
2268 Perl_croak(aTHX_ too_deep);
2271 if (o->op_flags & OPf_KIDS) {
2273 /* First try all the kids at this level, since that's likeliest. */
2274 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2275 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2276 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2279 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2280 if (kid == PL_lastgotoprobe)
2282 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2285 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2286 ops[-1]->op_type == OP_DBSTATE)
2291 if ((o = dofindlabel(kid, label, ops, oplimit)))
2304 register PERL_CONTEXT *cx;
2305 #define GOTO_DEPTH 64
2306 OP *enterops[GOTO_DEPTH];
2307 const char *label = NULL;
2308 const bool do_dump = (PL_op->op_type == OP_DUMP);
2309 static const char must_have_label[] = "goto must have label";
2311 if (PL_op->op_flags & OPf_STACKED) {
2312 SV * const sv = POPs;
2314 /* This egregious kludge implements goto &subroutine */
2315 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2317 register PERL_CONTEXT *cx;
2318 CV* cv = (CV*)SvRV(sv);
2325 if (!CvROOT(cv) && !CvXSUB(cv)) {
2326 const GV * const gv = CvGV(cv);
2330 /* autoloaded stub? */
2331 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2333 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2334 GvNAMELEN(gv), FALSE);
2335 if (autogv && (cv = GvCV(autogv)))
2337 tmpstr = sv_newmortal();
2338 gv_efullname3(tmpstr, gv, NULL);
2339 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2341 DIE(aTHX_ "Goto undefined subroutine");
2344 /* First do some returnish stuff. */
2345 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2347 cxix = dopoptosub(cxstack_ix);
2349 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2350 if (cxix < cxstack_ix)
2354 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2355 if (CxTYPE(cx) == CXt_EVAL) {
2357 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2359 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2361 else if (CxMULTICALL(cx))
2362 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2363 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2364 /* put @_ back onto stack */
2365 AV* av = cx->blk_sub.argarray;
2367 items = AvFILLp(av) + 1;
2368 EXTEND(SP, items+1); /* @_ could have been extended. */
2369 Copy(AvARRAY(av), SP + 1, items, SV*);
2370 SvREFCNT_dec(GvAV(PL_defgv));
2371 GvAV(PL_defgv) = cx->blk_sub.savearray;
2373 /* abandon @_ if it got reified */
2378 av_extend(av, items-1);
2380 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2383 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2384 AV* const av = GvAV(PL_defgv);
2385 items = AvFILLp(av) + 1;
2386 EXTEND(SP, items+1); /* @_ could have been extended. */
2387 Copy(AvARRAY(av), SP + 1, items, SV*);
2391 if (CxTYPE(cx) == CXt_SUB &&
2392 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2393 SvREFCNT_dec(cx->blk_sub.cv);
2394 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2395 LEAVE_SCOPE(oldsave);
2397 /* Now do some callish stuff. */
2399 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2401 OP* const retop = cx->blk_sub.retop;
2406 for (index=0; index<items; index++)
2407 sv_2mortal(SP[-index]);
2410 /* XS subs don't have a CxSUB, so pop it */
2411 POPBLOCK(cx, PL_curpm);
2412 /* Push a mark for the start of arglist */
2415 (void)(*CvXSUB(cv))(aTHX_ cv);
2420 AV* const padlist = CvPADLIST(cv);
2421 if (CxTYPE(cx) == CXt_EVAL) {
2422 PL_in_eval = cx->blk_eval.old_in_eval;
2423 PL_eval_root = cx->blk_eval.old_eval_root;
2424 cx->cx_type = CXt_SUB;
2425 cx->blk_sub.hasargs = 0;
2427 cx->blk_sub.cv = cv;
2428 cx->blk_sub.olddepth = CvDEPTH(cv);
2431 if (CvDEPTH(cv) < 2)
2432 SvREFCNT_inc_simple_void_NN(cv);
2434 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2435 sub_crush_depth(cv);
2436 pad_push(padlist, CvDEPTH(cv));
2439 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2440 if (cx->blk_sub.hasargs)
2442 AV* const av = (AV*)PAD_SVl(0);
2444 cx->blk_sub.savearray = GvAV(PL_defgv);
2445 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2446 CX_CURPAD_SAVE(cx->blk_sub);
2447 cx->blk_sub.argarray = av;
2449 if (items >= AvMAX(av) + 1) {
2450 SV **ary = AvALLOC(av);
2451 if (AvARRAY(av) != ary) {
2452 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2455 if (items >= AvMAX(av) + 1) {
2456 AvMAX(av) = items - 1;
2457 Renew(ary,items+1,SV*);
2463 Copy(mark,AvARRAY(av),items,SV*);
2464 AvFILLp(av) = items - 1;
2465 assert(!AvREAL(av));
2467 /* transfer 'ownership' of refcnts to new @_ */
2477 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2478 Perl_get_db_sub(aTHX_ NULL, cv);
2480 CV * const gotocv = get_cv("DB::goto", FALSE);
2482 PUSHMARK( PL_stack_sp );
2483 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2488 RETURNOP(CvSTART(cv));
2492 label = SvPV_nolen_const(sv);
2493 if (!(do_dump || *label))
2494 DIE(aTHX_ must_have_label);
2497 else if (PL_op->op_flags & OPf_SPECIAL) {
2499 DIE(aTHX_ must_have_label);
2502 label = cPVOP->op_pv;
2504 if (label && *label) {
2505 OP *gotoprobe = NULL;
2506 bool leaving_eval = FALSE;
2507 bool in_block = FALSE;
2508 PERL_CONTEXT *last_eval_cx = NULL;
2512 PL_lastgotoprobe = NULL;
2514 for (ix = cxstack_ix; ix >= 0; ix--) {
2516 switch (CxTYPE(cx)) {
2518 leaving_eval = TRUE;
2519 if (!CxTRYBLOCK(cx)) {
2520 gotoprobe = (last_eval_cx ?
2521 last_eval_cx->blk_eval.old_eval_root :
2526 /* else fall through */
2528 gotoprobe = cx->blk_oldcop->op_sibling;
2534 gotoprobe = cx->blk_oldcop->op_sibling;
2537 gotoprobe = PL_main_root;
2540 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2541 gotoprobe = CvROOT(cx->blk_sub.cv);
2547 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2550 DIE(aTHX_ "panic: goto");
2551 gotoprobe = PL_main_root;
2555 retop = dofindlabel(gotoprobe, label,
2556 enterops, enterops + GOTO_DEPTH);
2560 PL_lastgotoprobe = gotoprobe;
2563 DIE(aTHX_ "Can't find label %s", label);
2565 /* if we're leaving an eval, check before we pop any frames
2566 that we're not going to punt, otherwise the error
2569 if (leaving_eval && *enterops && enterops[1]) {
2571 for (i = 1; enterops[i]; i++)
2572 if (enterops[i]->op_type == OP_ENTERITER)
2573 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2576 /* pop unwanted frames */
2578 if (ix < cxstack_ix) {
2585 oldsave = PL_scopestack[PL_scopestack_ix];
2586 LEAVE_SCOPE(oldsave);
2589 /* push wanted frames */
2591 if (*enterops && enterops[1]) {
2592 OP * const oldop = PL_op;
2593 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2594 for (; enterops[ix]; ix++) {
2595 PL_op = enterops[ix];
2596 /* Eventually we may want to stack the needed arguments
2597 * for each op. For now, we punt on the hard ones. */
2598 if (PL_op->op_type == OP_ENTERITER)
2599 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2600 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2608 if (!retop) retop = PL_main_start;
2610 PL_restartop = retop;
2611 PL_do_undump = TRUE;
2615 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2616 PL_do_undump = FALSE;
2633 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2635 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2638 PL_exit_flags |= PERL_EXIT_EXPECTED;
2640 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2641 if (anum || !(PL_minus_c && PL_madskills))
2646 PUSHs(&PL_sv_undef);
2653 S_save_lines(pTHX_ AV *array, SV *sv)
2655 const char *s = SvPVX_const(sv);
2656 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2659 while (s && s < send) {
2661 SV * const tmpstr = newSV(0);
2663 sv_upgrade(tmpstr, SVt_PVMG);
2664 t = strchr(s, '\n');
2670 sv_setpvn(tmpstr, s, t - s);
2671 av_store(array, line++, tmpstr);
2677 S_docatch_body(pTHX)
2685 S_docatch(pTHX_ OP *o)
2689 OP * const oldop = PL_op;
2693 assert(CATCH_GET == TRUE);
2700 assert(cxstack_ix >= 0);
2701 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2702 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2707 /* die caught by an inner eval - continue inner loop */
2709 /* NB XXX we rely on the old popped CxEVAL still being at the top
2710 * of the stack; the way die_where() currently works, this
2711 * assumption is valid. In theory The cur_top_env value should be
2712 * returned in another global, the way retop (aka PL_restartop)
2714 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2717 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2719 PL_op = PL_restartop;
2736 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2737 /* sv Text to convert to OP tree. */
2738 /* startop op_free() this to undo. */
2739 /* code Short string id of the caller. */
2741 /* FIXME - how much of this code is common with pp_entereval? */
2742 dVAR; dSP; /* Make POPBLOCK work. */
2749 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2750 char *tmpbuf = tbuf;
2753 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2759 /* switch to eval mode */
2761 if (IN_PERL_COMPILETIME) {
2762 SAVECOPSTASH_FREE(&PL_compiling);
2763 CopSTASH_set(&PL_compiling, PL_curstash);
2765 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2766 SV * const sv = sv_newmortal();
2767 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2768 code, (unsigned long)++PL_evalseq,
2769 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2774 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2775 (unsigned long)++PL_evalseq);
2776 SAVECOPFILE_FREE(&PL_compiling);
2777 CopFILE_set(&PL_compiling, tmpbuf+2);
2778 SAVECOPLINE(&PL_compiling);
2779 CopLINE_set(&PL_compiling, 1);
2780 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2781 deleting the eval's FILEGV from the stash before gv_check() runs
2782 (i.e. before run-time proper). To work around the coredump that
2783 ensues, we always turn GvMULTI_on for any globals that were
2784 introduced within evals. See force_ident(). GSAR 96-10-12 */
2785 safestr = savepvn(tmpbuf, len);
2786 SAVEDELETE(PL_defstash, safestr, len);
2788 #ifdef OP_IN_REGISTER
2794 /* we get here either during compilation, or via pp_regcomp at runtime */
2795 runtime = IN_PERL_RUNTIME;
2797 runcv = find_runcv(NULL);
2800 PL_op->op_type = OP_ENTEREVAL;
2801 PL_op->op_flags = 0; /* Avoid uninit warning. */
2802 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2803 PUSHEVAL(cx, 0, NULL);
2806 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2808 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2809 POPBLOCK(cx,PL_curpm);
2812 (*startop)->op_type = OP_NULL;
2813 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2815 /* XXX DAPM do this properly one year */
2816 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2818 if (IN_PERL_COMPILETIME)
2819 CopHINTS_set(&PL_compiling, PL_hints);
2820 #ifdef OP_IN_REGISTER
2823 PERL_UNUSED_VAR(newsp);
2824 PERL_UNUSED_VAR(optype);
2831 =for apidoc find_runcv
2833 Locate the CV corresponding to the currently executing sub or eval.
2834 If db_seqp is non_null, skip CVs that are in the DB package and populate
2835 *db_seqp with the cop sequence number at the point that the DB:: code was
2836 entered. (allows debuggers to eval in the scope of the breakpoint rather
2837 than in the scope of the debugger itself).
2843 Perl_find_runcv(pTHX_ U32 *db_seqp)
2849 *db_seqp = PL_curcop->cop_seq;
2850 for (si = PL_curstackinfo; si; si = si->si_prev) {
2852 for (ix = si->si_cxix; ix >= 0; ix--) {
2853 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2854 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2855 CV * const cv = cx->blk_sub.cv;
2856 /* skip DB:: code */
2857 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2858 *db_seqp = cx->blk_oldcop->cop_seq;
2863 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2871 /* Compile a require/do, an eval '', or a /(?{...})/.
2872 * In the last case, startop is non-null, and contains the address of
2873 * a pointer that should be set to the just-compiled code.
2874 * outside is the lexically enclosing CV (if any) that invoked us.
2877 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2879 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2882 OP * const saveop = PL_op;
2884 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2885 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2890 SAVESPTR(PL_compcv);
2891 PL_compcv = (CV*)newSV(0);
2892 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2893 CvEVAL_on(PL_compcv);
2894 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2895 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2897 CvOUTSIDE_SEQ(PL_compcv) = seq;
2898 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2900 /* set up a scratch pad */
2902 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2903 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2907 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2909 /* make sure we compile in the right package */
2911 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2912 SAVESPTR(PL_curstash);
2913 PL_curstash = CopSTASH(PL_curcop);
2915 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2916 SAVESPTR(PL_beginav);
2917 PL_beginav = newAV();
2918 SAVEFREESV(PL_beginav);
2919 SAVESPTR(PL_unitcheckav);
2920 PL_unitcheckav = newAV();
2921 SAVEFREESV(PL_unitcheckav);
2922 SAVEI32(PL_error_count);
2925 SAVEI32(PL_madskills);
2929 /* try to compile it */
2931 PL_eval_root = NULL;
2933 PL_curcop = &PL_compiling;
2934 CopARYBASE_set(PL_curcop, 0);
2935 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2936 PL_in_eval |= EVAL_KEEPERR;
2938 sv_setpvn(ERRSV,"",0);
2939 if (yyparse() || PL_error_count || !PL_eval_root) {
2940 SV **newsp; /* Used by POPBLOCK. */
2941 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2942 I32 optype = 0; /* Might be reset by POPEVAL. */
2947 op_free(PL_eval_root);
2948 PL_eval_root = NULL;
2950 SP = PL_stack_base + POPMARK; /* pop original mark */
2952 POPBLOCK(cx,PL_curpm);
2958 msg = SvPVx_nolen_const(ERRSV);
2959 if (optype == OP_REQUIRE) {
2960 const SV * const nsv = cx->blk_eval.old_namesv;
2961 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2963 DIE(aTHX_ "%sCompilation failed in require",
2964 *msg ? msg : "Unknown error\n");
2967 POPBLOCK(cx,PL_curpm);
2969 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2970 (*msg ? msg : "Unknown error\n"));
2974 sv_setpv(ERRSV, "Compilation error");
2977 PERL_UNUSED_VAR(newsp);
2980 CopLINE_set(&PL_compiling, 0);
2982 *startop = PL_eval_root;
2984 SAVEFREEOP(PL_eval_root);
2986 /* Set the context for this new optree.
2987 * If the last op is an OP_REQUIRE, force scalar context.
2988 * Otherwise, propagate the context from the eval(). */
2989 if (PL_eval_root->op_type == OP_LEAVEEVAL
2990 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2991 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2993 scalar(PL_eval_root);
2994 else if (gimme & G_VOID)
2995 scalarvoid(PL_eval_root);
2996 else if (gimme & G_ARRAY)
2999 scalar(PL_eval_root);
3001 DEBUG_x(dump_eval());
3003 /* Register with debugger: */
3004 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3005 CV * const cv = get_cv("DB::postponed", FALSE);
3009 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3011 call_sv((SV*)cv, G_DISCARD);
3016 call_list(PL_scopestack_ix, PL_unitcheckav);
3018 /* compiled okay, so do it */
3020 CvDEPTH(PL_compcv) = 1;
3021 SP = PL_stack_base + POPMARK; /* pop original mark */
3022 PL_op = saveop; /* The caller may need it. */
3023 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3025 RETURNOP(PL_eval_start);
3029 S_check_type_and_open(pTHX_ const char *name, const char *mode)
3032 const int st_rc = PerlLIO_stat(name, &st);
3034 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3038 return PerlIO_open(name, mode);
3042 S_doopen_pm(pTHX_ const char *name, const char *mode)
3044 #ifndef PERL_DISABLE_PMC
3045 const STRLEN namelen = strlen(name);
3048 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3049 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3050 const char * const pmc = SvPV_nolen_const(pmcsv);
3052 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3053 fp = check_type_and_open(name, mode);
3056 fp = check_type_and_open(pmc, mode);
3058 SvREFCNT_dec(pmcsv);
3061 fp = check_type_and_open(name, mode);
3065 return check_type_and_open(name, mode);
3066 #endif /* !PERL_DISABLE_PMC */
3072 register PERL_CONTEXT *cx;
3076 const char *tryname = NULL;
3078 const I32 gimme = GIMME_V;
3079 int filter_has_file = 0;
3080 PerlIO *tryrsfp = NULL;
3081 SV *filter_cache = NULL;
3082 SV *filter_state = NULL;
3083 SV *filter_sub = NULL;
3089 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3090 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3091 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3092 "v-string in use/require non-portable");
3094 sv = new_version(sv);
3095 if (!sv_derived_from(PL_patchlevel, "version"))
3096 upg_version(PL_patchlevel);
3097 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3098 if ( vcmp(sv,PL_patchlevel) <= 0 )
3099 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3100 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3103 if ( vcmp(sv,PL_patchlevel) > 0 )
3104 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3105 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
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_PROPER("eval");
3454 /* switch to eval mode */
3456 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3457 SV * const temp_sv = sv_newmortal();
3458 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3459 (unsigned long)++PL_evalseq,
3460 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3461 tmpbuf = SvPVX(temp_sv);
3462 len = SvCUR(temp_sv);
3465 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3466 SAVECOPFILE_FREE(&PL_compiling);
3467 CopFILE_set(&PL_compiling, tmpbuf+2);
3468 SAVECOPLINE(&PL_compiling);
3469 CopLINE_set(&PL_compiling, 1);
3470 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3471 deleting the eval's FILEGV from the stash before gv_check() runs
3472 (i.e. before run-time proper). To work around the coredump that
3473 ensues, we always turn GvMULTI_on for any globals that were
3474 introduced within evals. See force_ident(). GSAR 96-10-12 */
3475 safestr = savepvn(tmpbuf, len);
3476 SAVEDELETE(PL_defstash, safestr, len);
3478 PL_hints = PL_op->op_targ;
3480 GvHV(PL_hintgv) = saved_hh;
3481 SAVECOMPILEWARNINGS();
3482 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3483 if (PL_compiling.cop_hints_hash) {
3484 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3486 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3487 if (PL_compiling.cop_hints_hash) {
3489 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3490 HINTS_REFCNT_UNLOCK;
3492 /* special case: an eval '' executed within the DB package gets lexically
3493 * placed in the first non-DB CV rather than the current CV - this
3494 * allows the debugger to execute code, find lexicals etc, in the
3495 * scope of the code being debugged. Passing &seq gets find_runcv
3496 * to do the dirty work for us */
3497 runcv = find_runcv(&seq);
3499 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3500 PUSHEVAL(cx, 0, NULL);
3501 cx->blk_eval.retop = PL_op->op_next;
3503 /* prepare to compile string */
3505 if (PERLDB_LINE && PL_curstash != PL_debstash)
3506 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3508 ret = doeval(gimme, NULL, runcv, seq);
3509 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3510 && ret != PL_op->op_next) { /* Successive compilation. */
3511 /* Copy in anything fake and short. */
3512 my_strlcpy(safestr, fakestr, fakelen);
3514 return DOCATCH(ret);
3524 register PERL_CONTEXT *cx;
3526 const U8 save_flags = PL_op -> op_flags;
3531 retop = cx->blk_eval.retop;
3534 if (gimme == G_VOID)
3536 else if (gimme == G_SCALAR) {
3539 if (SvFLAGS(TOPs) & SVs_TEMP)
3542 *MARK = sv_mortalcopy(TOPs);
3546 *MARK = &PL_sv_undef;
3551 /* in case LEAVE wipes old return values */
3552 for (mark = newsp + 1; mark <= SP; mark++) {
3553 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3554 *mark = sv_mortalcopy(*mark);
3555 TAINT_NOT; /* Each item is independent */
3559 PL_curpm = newpm; /* Don't pop $1 et al till now */
3562 assert(CvDEPTH(PL_compcv) == 1);
3564 CvDEPTH(PL_compcv) = 0;
3567 if (optype == OP_REQUIRE &&
3568 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3570 /* Unassume the success we assumed earlier. */
3571 SV * const nsv = cx->blk_eval.old_namesv;
3572 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3573 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3574 /* die_where() did LEAVE, or we won't be here */
3578 if (!(save_flags & OPf_SPECIAL))
3579 sv_setpvn(ERRSV,"",0);
3585 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3586 close to the related Perl_create_eval_scope. */
3588 Perl_delete_eval_scope(pTHX)
3593 register PERL_CONTEXT *cx;
3600 PERL_UNUSED_VAR(newsp);
3601 PERL_UNUSED_VAR(gimme);
3602 PERL_UNUSED_VAR(optype);
3605 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3606 also needed by Perl_fold_constants. */
3608 Perl_create_eval_scope(pTHX_ U32 flags)
3611 const I32 gimme = GIMME_V;
3616 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3619 PL_in_eval = EVAL_INEVAL;
3620 if (flags & G_KEEPERR)
3621 PL_in_eval |= EVAL_KEEPERR;
3623 sv_setpvn(ERRSV,"",0);
3624 if (flags & G_FAKINGEVAL) {
3625 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3633 PERL_CONTEXT * const cx = create_eval_scope(0);
3634 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3635 return DOCATCH(PL_op->op_next);
3644 register PERL_CONTEXT *cx;
3649 PERL_UNUSED_VAR(optype);
3652 if (gimme == G_VOID)
3654 else if (gimme == G_SCALAR) {
3658 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3661 *MARK = sv_mortalcopy(TOPs);
3665 *MARK = &PL_sv_undef;
3670 /* in case LEAVE wipes old return values */
3672 for (mark = newsp + 1; mark <= SP; mark++) {
3673 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3674 *mark = sv_mortalcopy(*mark);
3675 TAINT_NOT; /* Each item is independent */
3679 PL_curpm = newpm; /* Don't pop $1 et al till now */
3682 sv_setpvn(ERRSV,"",0);
3689 register PERL_CONTEXT *cx;
3690 const I32 gimme = GIMME_V;
3695 if (PL_op->op_targ == 0) {
3696 SV ** const defsv_p = &GvSV(PL_defgv);
3697 *defsv_p = newSVsv(POPs);
3698 SAVECLEARSV(*defsv_p);
3701 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3703 PUSHBLOCK(cx, CXt_GIVEN, SP);
3712 register PERL_CONTEXT *cx;
3716 PERL_UNUSED_CONTEXT;
3719 assert(CxTYPE(cx) == CXt_GIVEN);
3724 PL_curpm = newpm; /* pop $1 et al */
3731 /* 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);
3748 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3753 PL_op = (OP *) matcher;
3758 return (SvTRUEx(POPs));
3763 S_destroy_matcher(pTHX_ PMOP *matcher)
3766 PERL_UNUSED_ARG(matcher);
3771 /* Do a smart match */
3774 return do_smartmatch(NULL, NULL);
3777 /* This version of do_smartmatch() implements the
3778 * table of smart matches that is found in perlsyn.
3782 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3787 SV *e = TOPs; /* e is for 'expression' */
3788 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3789 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3791 regexp *this_regex, *other_regex;
3793 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3795 # define SM_REF(type) ( \
3796 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3797 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3799 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3800 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
3801 && NOT_EMPTY_PROTO(This) && (Other = e)) \
3802 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
3803 && NOT_EMPTY_PROTO(This) && (Other = d)))
3805 # define SM_REGEX ( \
3806 (SvROK(d) && SvMAGICAL(This = SvRV(d)) \
3807 && (mg = mg_find(This, PERL_MAGIC_qr)) \
3808 && (this_regex = (regexp *)mg->mg_obj) \
3811 (SvROK(e) && SvMAGICAL(This = SvRV(e)) \
3812 && (mg = mg_find(This, PERL_MAGIC_qr)) \
3813 && (this_regex = (regexp *)mg->mg_obj) \
3817 # define SM_OTHER_REF(type) \
3818 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3820 # define SM_OTHER_REGEX (SvROK(Other) && SvMAGICAL(SvRV(Other)) \
3821 && (mg = mg_find(SvRV(Other), PERL_MAGIC_qr)) \
3822 && (other_regex = (regexp *)mg->mg_obj))
3825 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3826 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3828 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3829 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3831 tryAMAGICbinSET(smart, 0);
3833 SP -= 2; /* Pop the values */
3835 /* Take care only to invoke mg_get() once for each argument.
3836 * Currently we do this by copying the SV if it's magical. */
3839 d = sv_mortalcopy(d);
3846 e = sv_mortalcopy(e);
3851 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3853 if (This == SvRV(Other))
3864 c = call_sv(This, G_SCALAR);
3868 else if (SvTEMP(TOPs))
3869 SvREFCNT_inc_void(TOPs);
3874 else if (SM_REF(PVHV)) {
3875 if (SM_OTHER_REF(PVHV)) {
3876 /* Check that the key-sets are identical */
3878 HV *other_hv = (HV *) SvRV(Other);
3880 bool other_tied = FALSE;
3881 U32 this_key_count = 0,
3882 other_key_count = 0;
3884 /* Tied hashes don't know how many keys they have. */
3885 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
3888 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3889 HV * const temp = other_hv;
3890 other_hv = (HV *) This;
3894 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3897 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
3900 /* The hashes have the same number of keys, so it suffices
3901 to check that one is a subset of the other. */
3902 (void) hv_iterinit((HV *) This);
3903 while ( (he = hv_iternext((HV *) This)) ) {
3905 char * const key = hv_iterkey(he, &key_len);
3909 if(!hv_exists(other_hv, key, key_len)) {
3910 (void) hv_iterinit((HV *) This); /* reset iterator */
3916 (void) hv_iterinit(other_hv);
3917 while ( hv_iternext(other_hv) )
3921 other_key_count = HvUSEDKEYS(other_hv);
3923 if (this_key_count != other_key_count)
3928 else if (SM_OTHER_REF(PVAV)) {
3929 AV * const other_av = (AV *) SvRV(Other);
3930 const I32 other_len = av_len(other_av) + 1;
3933 if (HvUSEDKEYS((HV *) This) != other_len)
3936 for(i = 0; i < other_len; ++i) {
3937 SV ** const svp = av_fetch(other_av, i, FALSE);
3941 if (!svp) /* ??? When can this happen? */
3944 key = SvPV(*svp, key_len);
3945 if(!hv_exists((HV *) This, key, key_len))
3950 else if (SM_OTHER_REGEX) {
3951 PMOP * const matcher = make_matcher(other_regex);
3954 (void) hv_iterinit((HV *) This);
3955 while ( (he = hv_iternext((HV *) This)) ) {
3956 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
3957 (void) hv_iterinit((HV *) This);
3958 destroy_matcher(matcher);
3962 destroy_matcher(matcher);
3966 if (hv_exists_ent((HV *) This, Other, 0))
3972 else if (SM_REF(PVAV)) {
3973 if (SM_OTHER_REF(PVAV)) {
3974 AV *other_av = (AV *) SvRV(Other);
3975 if (av_len((AV *) This) != av_len(other_av))
3979 const I32 other_len = av_len(other_av);
3981 if (NULL == seen_this) {
3982 seen_this = newHV();
3983 (void) sv_2mortal((SV *) seen_this);
3985 if (NULL == seen_other) {
3986 seen_this = newHV();
3987 (void) sv_2mortal((SV *) seen_other);
3989 for(i = 0; i <= other_len; ++i) {
3990 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
3991 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
3993 if (!this_elem || !other_elem) {
3994 if (this_elem || other_elem)
3997 else if (SM_SEEN_THIS(*this_elem)
3998 || SM_SEEN_OTHER(*other_elem))
4000 if (*this_elem != *other_elem)
4004 hv_store_ent(seen_this,
4005 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4007 hv_store_ent(seen_other,
4008 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4014 (void) do_smartmatch(seen_this, seen_other);
4024 else if (SM_OTHER_REGEX) {
4025 PMOP * const matcher = make_matcher(other_regex);
4026 const I32 this_len = av_len((AV *) This);
4029 for(i = 0; i <= this_len; ++i) {
4030 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4031 if (svp && matcher_matches_sv(matcher, *svp)) {
4032 destroy_matcher(matcher);
4036 destroy_matcher(matcher);
4039 else if (SvIOK(Other) || SvNOK(Other)) {
4042 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4043 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4050 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4060 else if (SvPOK(Other)) {
4061 const I32 this_len = av_len((AV *) This);
4064 for(i = 0; i <= this_len; ++i) {
4065 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4080 else if (!SvOK(d) || !SvOK(e)) {
4081 if (!SvOK(d) && !SvOK(e))
4086 else if (SM_REGEX) {
4087 PMOP * const matcher = make_matcher(this_regex);
4090 PUSHs(matcher_matches_sv(matcher, Other)
4093 destroy_matcher(matcher);
4096 else if (SM_REF(PVCV)) {
4098 /* This must be a null-prototyped sub, because we
4099 already checked for the other kind. */
4105 c = call_sv(This, G_SCALAR);
4108 PUSHs(&PL_sv_undef);
4109 else if (SvTEMP(TOPs))
4110 SvREFCNT_inc_void(TOPs);
4112 if (SM_OTHER_REF(PVCV)) {
4113 /* This one has to be null-proto'd too.
4114 Call both of 'em, and compare the results */
4116 c = call_sv(SvRV(Other), G_SCALAR);
4119 PUSHs(&PL_sv_undef);
4120 else if (SvTEMP(TOPs))
4121 SvREFCNT_inc_void(TOPs);
4132 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4133 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4135 if (SvPOK(Other) && !looks_like_number(Other)) {
4136 /* String comparison */
4141 /* Otherwise, numeric comparison */
4144 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4155 /* As a last resort, use string comparison */
4164 register PERL_CONTEXT *cx;
4165 const I32 gimme = GIMME_V;
4167 /* This is essentially an optimization: if the match
4168 fails, we don't want to push a context and then
4169 pop it again right away, so we skip straight
4170 to the op that follows the leavewhen.
4172 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4173 return cLOGOP->op_other->op_next;
4178 PUSHBLOCK(cx, CXt_WHEN, SP);
4187 register PERL_CONTEXT *cx;
4193 assert(CxTYPE(cx) == CXt_WHEN);
4198 PL_curpm = newpm; /* pop $1 et al */
4208 register PERL_CONTEXT *cx;
4211 cxix = dopoptowhen(cxstack_ix);
4213 DIE(aTHX_ "Can't \"continue\" outside a when block");
4214 if (cxix < cxstack_ix)
4217 /* clear off anything above the scope we're re-entering */
4218 inner = PL_scopestack_ix;
4220 if (PL_scopestack_ix < inner)
4221 leave_scope(PL_scopestack[PL_scopestack_ix]);
4222 PL_curcop = cx->blk_oldcop;
4223 return cx->blk_givwhen.leave_op;
4230 register PERL_CONTEXT *cx;
4233 cxix = dopoptogiven(cxstack_ix);
4235 if (PL_op->op_flags & OPf_SPECIAL)
4236 DIE(aTHX_ "Can't use when() outside a topicalizer");
4238 DIE(aTHX_ "Can't \"break\" outside a given block");
4240 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4241 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4243 if (cxix < cxstack_ix)
4246 /* clear off anything above the scope we're re-entering */
4247 inner = PL_scopestack_ix;
4249 if (PL_scopestack_ix < inner)
4250 leave_scope(PL_scopestack[PL_scopestack_ix]);
4251 PL_curcop = cx->blk_oldcop;
4254 return CX_LOOP_NEXTOP_GET(cx);
4256 return cx->blk_givwhen.leave_op;
4260 S_doparseform(pTHX_ SV *sv)
4263 register char *s = SvPV_force(sv, len);
4264 register char * const send = s + len;
4265 register char *base = NULL;
4266 register I32 skipspaces = 0;
4267 bool noblank = FALSE;
4268 bool repeat = FALSE;
4269 bool postspace = FALSE;
4275 bool unchopnum = FALSE;
4276 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4279 Perl_croak(aTHX_ "Null picture in formline");
4281 /* estimate the buffer size needed */
4282 for (base = s; s <= send; s++) {
4283 if (*s == '\n' || *s == '@' || *s == '^')
4289 Newx(fops, maxops, U32);
4294 *fpc++ = FF_LINEMARK;
4295 noblank = repeat = FALSE;
4313 case ' ': case '\t':
4320 } /* else FALL THROUGH */
4328 *fpc++ = FF_LITERAL;
4336 *fpc++ = (U16)skipspaces;
4340 *fpc++ = FF_NEWLINE;
4344 arg = fpc - linepc + 1;
4351 *fpc++ = FF_LINEMARK;
4352 noblank = repeat = FALSE;
4361 ischop = s[-1] == '^';
4367 arg = (s - base) - 1;
4369 *fpc++ = FF_LITERAL;
4377 *fpc++ = 2; /* skip the @* or ^* */
4379 *fpc++ = FF_LINESNGL;
4382 *fpc++ = FF_LINEGLOB;
4384 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4385 arg = ischop ? 512 : 0;
4390 const char * const f = ++s;
4393 arg |= 256 + (s - f);
4395 *fpc++ = s - base; /* fieldsize for FETCH */
4396 *fpc++ = FF_DECIMAL;
4398 unchopnum |= ! ischop;
4400 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4401 arg = ischop ? 512 : 0;
4403 s++; /* skip the '0' first */
4407 const char * const f = ++s;
4410 arg |= 256 + (s - f);
4412 *fpc++ = s - base; /* fieldsize for FETCH */
4413 *fpc++ = FF_0DECIMAL;
4415 unchopnum |= ! ischop;
4419 bool ismore = FALSE;
4422 while (*++s == '>') ;
4423 prespace = FF_SPACE;
4425 else if (*s == '|') {
4426 while (*++s == '|') ;
4427 prespace = FF_HALFSPACE;
4432 while (*++s == '<') ;
4435 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4439 *fpc++ = s - base; /* fieldsize for FETCH */
4441 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4444 *fpc++ = (U16)prespace;
4458 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4460 { /* need to jump to the next word */
4462 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4463 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4464 s = SvPVX(sv) + SvCUR(sv) + z;
4466 Copy(fops, s, arg, U32);
4468 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4471 if (unchopnum && repeat)
4472 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4478 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4480 /* Can value be printed in fldsize chars, using %*.*f ? */
4484 int intsize = fldsize - (value < 0 ? 1 : 0);
4491 while (intsize--) pwr *= 10.0;
4492 while (frcsize--) eps /= 10.0;
4495 if (value + eps >= pwr)
4498 if (value - eps <= -pwr)
4505 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4508 SV * const datasv = FILTER_DATA(idx);
4509 const int filter_has_file = IoLINES(datasv);
4510 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4511 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4515 const char *got_p = NULL;
4516 const char *prune_from = NULL;
4517 bool read_from_cache = FALSE;
4520 assert(maxlen >= 0);
4523 /* I was having segfault trouble under Linux 2.2.5 after a
4524 parse error occured. (Had to hack around it with a test
4525 for PL_error_count == 0.) Solaris doesn't segfault --
4526 not sure where the trouble is yet. XXX */
4528 if (IoFMT_GV(datasv)) {
4529 SV *const cache = (SV *)IoFMT_GV(datasv);
4532 const char *cache_p = SvPV(cache, cache_len);
4536 /* Running in block mode and we have some cached data already.
4538 if (cache_len >= umaxlen) {
4539 /* In fact, so much data we don't even need to call
4544 const char *const first_nl =
4545 (const char *)memchr(cache_p, '\n', cache_len);
4547 take = first_nl + 1 - cache_p;
4551 sv_catpvn(buf_sv, cache_p, take);
4552 sv_chop(cache, cache_p + take);
4553 /* Definately not EOF */
4557 sv_catsv(buf_sv, cache);
4559 umaxlen -= cache_len;
4562 read_from_cache = TRUE;
4566 /* Filter API says that the filter appends to the contents of the buffer.
4567 Usually the buffer is "", so the details don't matter. But if it's not,
4568 then clearly what it contains is already filtered by this filter, so we
4569 don't want to pass it in a second time.
4570 I'm going to use a mortal in case the upstream filter croaks. */
4571 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4572 ? sv_newmortal() : buf_sv;
4573 SvUPGRADE(upstream, SVt_PV);
4575 if (filter_has_file) {
4576 status = FILTER_READ(idx+1, upstream, 0);
4579 if (filter_sub && status >= 0) {
4590 PUSHs(sv_2mortal(newSViv(0)));
4592 PUSHs(filter_state);
4595 count = call_sv(filter_sub, G_SCALAR);
4610 if(SvOK(upstream)) {
4611 got_p = SvPV(upstream, got_len);
4613 if (got_len > umaxlen) {
4614 prune_from = got_p + umaxlen;
4617 const char *const first_nl =
4618 (const char *)memchr(got_p, '\n', got_len);
4619 if (first_nl && first_nl + 1 < got_p + got_len) {
4620 /* There's a second line here... */
4621 prune_from = first_nl + 1;
4626 /* Oh. Too long. Stuff some in our cache. */
4627 STRLEN cached_len = got_p + got_len - prune_from;
4628 SV *cache = (SV *)IoFMT_GV(datasv);
4631 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4632 } else if (SvOK(cache)) {
4633 /* Cache should be empty. */
4634 assert(!SvCUR(cache));
4637 sv_setpvn(cache, prune_from, cached_len);
4638 /* If you ask for block mode, you may well split UTF-8 characters.
4639 "If it breaks, you get to keep both parts"
4640 (Your code is broken if you don't put them back together again
4641 before something notices.) */
4642 if (SvUTF8(upstream)) {
4645 SvCUR_set(upstream, got_len - cached_len);
4646 /* Can't yet be EOF */
4651 /* If they are at EOF but buf_sv has something in it, then they may never
4652 have touched the SV upstream, so it may be undefined. If we naively
4653 concatenate it then we get a warning about use of uninitialised value.
4655 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4656 sv_catsv(buf_sv, upstream);
4660 IoLINES(datasv) = 0;
4661 SvREFCNT_dec(IoFMT_GV(datasv));
4663 SvREFCNT_dec(filter_state);
4664 IoTOP_GV(datasv) = NULL;
4667 SvREFCNT_dec(filter_sub);
4668 IoBOTTOM_GV(datasv) = NULL;
4670 filter_del(S_run_user_filter);
4672 if (status == 0 && read_from_cache) {
4673 /* If we read some data from the cache (and by getting here it implies
4674 that we emptied the cache) then we aren't yet at EOF, and mustn't
4675 report that to our caller. */
4681 /* perhaps someone can come up with a better name for
4682 this? it is not really "absolute", per se ... */
4684 S_path_is_absolute(const char *name)
4686 if (PERL_FILE_IS_ABSOLUTE(name)
4687 #ifdef MACOS_TRADITIONAL
4690 || (*name == '.' && (name[1] == '/' ||
4691 (name[1] == '.' && name[2] == '/')))
4703 * c-indentation-style: bsd
4705 * indent-tabs-mode: t
4708 * ex: set ts=8 sts=4 sw=4 noet: