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.
2878 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2881 OP * const saveop = PL_op;
2883 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2884 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2889 SAVESPTR(PL_compcv);
2890 PL_compcv = (CV*)newSV(0);
2891 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2892 CvEVAL_on(PL_compcv);
2893 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2894 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2896 CvOUTSIDE_SEQ(PL_compcv) = seq;
2897 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2899 /* set up a scratch pad */
2901 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2902 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2906 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2908 /* make sure we compile in the right package */
2910 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2911 SAVESPTR(PL_curstash);
2912 PL_curstash = CopSTASH(PL_curcop);
2914 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2915 SAVESPTR(PL_beginav);
2916 PL_beginav = newAV();
2917 SAVEFREESV(PL_beginav);
2918 SAVESPTR(PL_unitcheckav);
2919 PL_unitcheckav = newAV();
2920 SAVEFREESV(PL_unitcheckav);
2921 SAVEI32(PL_error_count);
2924 SAVEI32(PL_madskills);
2928 /* try to compile it */
2930 PL_eval_root = NULL;
2932 PL_curcop = &PL_compiling;
2933 CopARYBASE_set(PL_curcop, 0);
2934 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2935 PL_in_eval |= EVAL_KEEPERR;
2937 sv_setpvn(ERRSV,"",0);
2938 if (yyparse() || PL_error_count || !PL_eval_root) {
2939 SV **newsp; /* Used by POPBLOCK. */
2940 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2941 I32 optype = 0; /* Might be reset by POPEVAL. */
2946 op_free(PL_eval_root);
2947 PL_eval_root = NULL;
2949 SP = PL_stack_base + POPMARK; /* pop original mark */
2951 POPBLOCK(cx,PL_curpm);
2957 msg = SvPVx_nolen_const(ERRSV);
2958 if (optype == OP_REQUIRE) {
2959 const SV * const nsv = cx->blk_eval.old_namesv;
2960 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2962 DIE(aTHX_ "%sCompilation failed in require",
2963 *msg ? msg : "Unknown error\n");
2966 POPBLOCK(cx,PL_curpm);
2968 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2969 (*msg ? msg : "Unknown error\n"));
2973 sv_setpvs(ERRSV, "Compilation error");
2976 PERL_UNUSED_VAR(newsp);
2979 CopLINE_set(&PL_compiling, 0);
2981 *startop = PL_eval_root;
2983 SAVEFREEOP(PL_eval_root);
2985 /* Set the context for this new optree.
2986 * If the last op is an OP_REQUIRE, force scalar context.
2987 * Otherwise, propagate the context from the eval(). */
2988 if (PL_eval_root->op_type == OP_LEAVEEVAL
2989 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2990 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2992 scalar(PL_eval_root);
2993 else if (gimme & G_VOID)
2994 scalarvoid(PL_eval_root);
2995 else if (gimme & G_ARRAY)
2998 scalar(PL_eval_root);
3000 DEBUG_x(dump_eval());
3002 /* Register with debugger: */
3003 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3004 CV * const cv = get_cv("DB::postponed", FALSE);
3008 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3010 call_sv((SV*)cv, G_DISCARD);
3015 call_list(PL_scopestack_ix, PL_unitcheckav);
3017 /* compiled okay, so do it */
3019 CvDEPTH(PL_compcv) = 1;
3020 SP = PL_stack_base + POPMARK; /* pop original mark */
3021 PL_op = saveop; /* The caller may need it. */
3022 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3024 RETURNOP(PL_eval_start);
3028 S_check_type_and_open(pTHX_ const char *name, const char *mode)
3031 const int st_rc = PerlLIO_stat(name, &st);
3033 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3037 return PerlIO_open(name, mode);
3041 S_doopen_pm(pTHX_ const char *name, const char *mode)
3043 #ifndef PERL_DISABLE_PMC
3044 const STRLEN namelen = strlen(name);
3047 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3048 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3049 const char * const pmc = SvPV_nolen_const(pmcsv);
3051 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3052 fp = check_type_and_open(name, mode);
3055 fp = check_type_and_open(pmc, mode);
3057 SvREFCNT_dec(pmcsv);
3060 fp = check_type_and_open(name, mode);
3064 return check_type_and_open(name, mode);
3065 #endif /* !PERL_DISABLE_PMC */
3071 register PERL_CONTEXT *cx;
3075 const char *tryname = NULL;
3077 const I32 gimme = GIMME_V;
3078 int filter_has_file = 0;
3079 PerlIO *tryrsfp = NULL;
3080 SV *filter_cache = NULL;
3081 SV *filter_state = NULL;
3082 SV *filter_sub = NULL;
3088 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3089 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3090 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3091 "v-string in use/require non-portable");
3093 sv = new_version(sv);
3094 if (!sv_derived_from(PL_patchlevel, "version"))
3095 upg_version(PL_patchlevel);
3096 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3097 if ( vcmp(sv,PL_patchlevel) <= 0 )
3098 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3099 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3102 if ( vcmp(sv,PL_patchlevel) > 0 )
3103 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3104 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3109 name = SvPV_const(sv, len);
3110 if (!(name && len > 0 && *name))
3111 DIE(aTHX_ "Null filename used");
3112 TAINT_PROPER("require");
3113 if (PL_op->op_type == OP_REQUIRE) {
3114 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3116 if (*svp != &PL_sv_undef)
3119 DIE(aTHX_ "Compilation failed in require");
3123 /* prepare to compile file */
3125 if (path_is_absolute(name)) {
3127 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3129 #ifdef MACOS_TRADITIONAL
3133 MacPerl_CanonDir(name, newname, 1);
3134 if (path_is_absolute(newname)) {
3136 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3141 AV * const ar = GvAVn(PL_incgv);
3145 if ((unixname = tounixspec(name, NULL)) != NULL)
3149 for (i = 0; i <= AvFILL(ar); i++) {
3150 SV * const dirsv = *av_fetch(ar, i, TRUE);
3152 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3159 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3160 && !sv_isobject(loader))
3162 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3165 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3166 PTR2UV(SvRV(dirsv)), name);
3167 tryname = SvPVX_const(namesv);
3178 if (sv_isobject(loader))
3179 count = call_method("INC", G_ARRAY);
3181 count = call_sv(loader, G_ARRAY);
3184 /* Adjust file name if the hook has set an %INC entry */
3185 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3187 tryname = SvPVX_const(*svp);
3196 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3197 && !isGV_with_GP(SvRV(arg))) {
3198 filter_cache = SvRV(arg);
3199 SvREFCNT_inc_simple_void_NN(filter_cache);
3206 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3210 if (SvTYPE(arg) == SVt_PVGV) {
3211 IO * const io = GvIO((GV *)arg);
3216 tryrsfp = IoIFP(io);
3217 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3218 PerlIO_close(IoOFP(io));
3229 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3231 SvREFCNT_inc_simple_void_NN(filter_sub);
3234 filter_state = SP[i];
3235 SvREFCNT_inc_simple_void(filter_state);
3239 if (!tryrsfp && (filter_cache || filter_sub)) {
3240 tryrsfp = PerlIO_open(BIT_BUCKET,
3255 filter_has_file = 0;
3257 SvREFCNT_dec(filter_cache);
3258 filter_cache = NULL;
3261 SvREFCNT_dec(filter_state);
3262 filter_state = NULL;
3265 SvREFCNT_dec(filter_sub);
3270 if (!path_is_absolute(name)
3271 #ifdef MACOS_TRADITIONAL
3272 /* We consider paths of the form :a:b ambiguous and interpret them first
3273 as global then as local
3275 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3278 const char *dir = SvPVx_nolen_const(dirsv);
3279 #ifdef MACOS_TRADITIONAL
3283 MacPerl_CanonDir(name, buf2, 1);
3284 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3288 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3290 sv_setpv(namesv, unixdir);
3291 sv_catpv(namesv, unixname);
3293 # ifdef __SYMBIAN32__
3294 if (PL_origfilename[0] &&
3295 PL_origfilename[1] == ':' &&
3296 !(dir[0] && dir[1] == ':'))
3297 Perl_sv_setpvf(aTHX_ namesv,
3302 Perl_sv_setpvf(aTHX_ namesv,
3306 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3310 TAINT_PROPER("require");
3311 tryname = SvPVX_const(namesv);
3312 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3314 if (tryname[0] == '.' && tryname[1] == '/')
3318 else if (errno == EMFILE)
3319 /* no point in trying other paths if out of handles */
3326 SAVECOPFILE_FREE(&PL_compiling);
3327 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3328 SvREFCNT_dec(namesv);
3330 if (PL_op->op_type == OP_REQUIRE) {
3331 const char *msgstr = name;
3332 if(errno == EMFILE) {
3334 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3336 msgstr = SvPV_nolen_const(msg);
3338 if (namesv) { /* did we lookup @INC? */
3339 AV * const ar = GvAVn(PL_incgv);
3341 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3342 "%s in @INC%s%s (@INC contains:",
3344 (instr(msgstr, ".h ")
3345 ? " (change .h to .ph maybe?)" : ""),
3346 (instr(msgstr, ".ph ")
3347 ? " (did you run h2ph?)" : "")
3350 for (i = 0; i <= AvFILL(ar); i++) {
3351 sv_catpvs(msg, " ");
3352 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3354 sv_catpvs(msg, ")");
3355 msgstr = SvPV_nolen_const(msg);
3358 DIE(aTHX_ "Can't locate %s", msgstr);
3364 SETERRNO(0, SS_NORMAL);
3366 /* Assume success here to prevent recursive requirement. */
3367 /* name is never assigned to again, so len is still strlen(name) */
3368 /* Check whether a hook in @INC has already filled %INC */
3370 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3372 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3374 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc_simple(hook_sv), 0 );
3380 SAVEGENERICSV(PL_rsfp_filters);
3381 PL_rsfp_filters = NULL;
3386 SAVECOMPILEWARNINGS();
3387 if (PL_dowarn & G_WARN_ALL_ON)
3388 PL_compiling.cop_warnings = pWARN_ALL ;
3389 else if (PL_dowarn & G_WARN_ALL_OFF)
3390 PL_compiling.cop_warnings = pWARN_NONE ;
3392 PL_compiling.cop_warnings = pWARN_STD ;
3394 if (filter_sub || filter_cache) {
3395 SV * const datasv = filter_add(S_run_user_filter, NULL);
3396 IoLINES(datasv) = filter_has_file;
3397 IoTOP_GV(datasv) = (GV *)filter_state;
3398 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3399 IoFMT_GV(datasv) = (GV *)filter_cache;
3402 /* switch to eval mode */
3403 PUSHBLOCK(cx, CXt_EVAL, SP);
3404 PUSHEVAL(cx, name, NULL);
3405 cx->blk_eval.retop = PL_op->op_next;
3407 SAVECOPLINE(&PL_compiling);
3408 CopLINE_set(&PL_compiling, 0);
3412 /* Store and reset encoding. */
3413 encoding = PL_encoding;
3416 op = DOCATCH(doeval(gimme, NULL, NULL, PL_curcop->cop_seq));
3418 /* Restore encoding. */
3419 PL_encoding = encoding;
3427 register PERL_CONTEXT *cx;
3429 const I32 gimme = GIMME_V;
3430 const I32 was = PL_sub_generation;
3431 char tbuf[TYPE_DIGITS(long) + 12];
3432 char *tmpbuf = tbuf;
3438 HV *saved_hh = NULL;
3439 const char * const fakestr = "_<(eval )";
3440 const int fakelen = 9 + 1;
3442 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3443 saved_hh = (HV*) SvREFCNT_inc(POPs);
3447 TAINT_PROPER("eval");
3453 /* switch to eval mode */
3455 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3456 SV * const temp_sv = sv_newmortal();
3457 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3458 (unsigned long)++PL_evalseq,
3459 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3460 tmpbuf = SvPVX(temp_sv);
3461 len = SvCUR(temp_sv);
3464 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3465 SAVECOPFILE_FREE(&PL_compiling);
3466 CopFILE_set(&PL_compiling, tmpbuf+2);
3467 SAVECOPLINE(&PL_compiling);
3468 CopLINE_set(&PL_compiling, 1);
3469 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3470 deleting the eval's FILEGV from the stash before gv_check() runs
3471 (i.e. before run-time proper). To work around the coredump that
3472 ensues, we always turn GvMULTI_on for any globals that were
3473 introduced within evals. See force_ident(). GSAR 96-10-12 */
3474 safestr = savepvn(tmpbuf, len);
3475 SAVEDELETE(PL_defstash, safestr, len);
3477 PL_hints = PL_op->op_targ;
3479 GvHV(PL_hintgv) = saved_hh;
3480 SAVECOMPILEWARNINGS();
3481 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3482 if (PL_compiling.cop_hints_hash) {
3483 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3485 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3486 if (PL_compiling.cop_hints_hash) {
3488 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3489 HINTS_REFCNT_UNLOCK;
3491 /* special case: an eval '' executed within the DB package gets lexically
3492 * placed in the first non-DB CV rather than the current CV - this
3493 * allows the debugger to execute code, find lexicals etc, in the
3494 * scope of the code being debugged. Passing &seq gets find_runcv
3495 * to do the dirty work for us */
3496 runcv = find_runcv(&seq);
3498 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3499 PUSHEVAL(cx, 0, NULL);
3500 cx->blk_eval.retop = PL_op->op_next;
3502 /* prepare to compile string */
3504 if (PERLDB_LINE && PL_curstash != PL_debstash)
3505 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3507 ret = doeval(gimme, NULL, runcv, seq);
3508 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3509 && ret != PL_op->op_next) { /* Successive compilation. */
3510 /* Copy in anything fake and short. */
3511 my_strlcpy(safestr, fakestr, fakelen);
3513 return DOCATCH(ret);
3523 register PERL_CONTEXT *cx;
3525 const U8 save_flags = PL_op -> op_flags;
3530 retop = cx->blk_eval.retop;
3533 if (gimme == G_VOID)
3535 else if (gimme == G_SCALAR) {
3538 if (SvFLAGS(TOPs) & SVs_TEMP)
3541 *MARK = sv_mortalcopy(TOPs);
3545 *MARK = &PL_sv_undef;
3550 /* in case LEAVE wipes old return values */
3551 for (mark = newsp + 1; mark <= SP; mark++) {
3552 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3553 *mark = sv_mortalcopy(*mark);
3554 TAINT_NOT; /* Each item is independent */
3558 PL_curpm = newpm; /* Don't pop $1 et al till now */
3561 assert(CvDEPTH(PL_compcv) == 1);
3563 CvDEPTH(PL_compcv) = 0;
3566 if (optype == OP_REQUIRE &&
3567 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3569 /* Unassume the success we assumed earlier. */
3570 SV * const nsv = cx->blk_eval.old_namesv;
3571 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3572 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3573 /* die_where() did LEAVE, or we won't be here */
3577 if (!(save_flags & OPf_SPECIAL))
3578 sv_setpvn(ERRSV,"",0);
3584 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3585 close to the related Perl_create_eval_scope. */
3587 Perl_delete_eval_scope(pTHX)
3592 register PERL_CONTEXT *cx;
3599 PERL_UNUSED_VAR(newsp);
3600 PERL_UNUSED_VAR(gimme);
3601 PERL_UNUSED_VAR(optype);
3604 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3605 also needed by Perl_fold_constants. */
3607 Perl_create_eval_scope(pTHX_ U32 flags)
3610 const I32 gimme = GIMME_V;
3615 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3618 PL_in_eval = EVAL_INEVAL;
3619 if (flags & G_KEEPERR)
3620 PL_in_eval |= EVAL_KEEPERR;
3622 sv_setpvn(ERRSV,"",0);
3623 if (flags & G_FAKINGEVAL) {
3624 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3632 PERL_CONTEXT * const cx = create_eval_scope(0);
3633 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3634 return DOCATCH(PL_op->op_next);
3643 register PERL_CONTEXT *cx;
3648 PERL_UNUSED_VAR(optype);
3651 if (gimme == G_VOID)
3653 else if (gimme == G_SCALAR) {
3657 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3660 *MARK = sv_mortalcopy(TOPs);
3664 *MARK = &PL_sv_undef;
3669 /* in case LEAVE wipes old return values */
3671 for (mark = newsp + 1; mark <= SP; mark++) {
3672 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3673 *mark = sv_mortalcopy(*mark);
3674 TAINT_NOT; /* Each item is independent */
3678 PL_curpm = newpm; /* Don't pop $1 et al till now */
3681 sv_setpvn(ERRSV,"",0);
3688 register PERL_CONTEXT *cx;
3689 const I32 gimme = GIMME_V;
3694 if (PL_op->op_targ == 0) {
3695 SV ** const defsv_p = &GvSV(PL_defgv);
3696 *defsv_p = newSVsv(POPs);
3697 SAVECLEARSV(*defsv_p);
3700 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3702 PUSHBLOCK(cx, CXt_GIVEN, SP);
3711 register PERL_CONTEXT *cx;
3715 PERL_UNUSED_CONTEXT;
3718 assert(CxTYPE(cx) == CXt_GIVEN);
3723 PL_curpm = newpm; /* pop $1 et al */
3730 /* Helper routines used by pp_smartmatch */
3733 S_make_matcher(pTHX_ regexp *re)
3736 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3737 PM_SETRE(matcher, ReREFCNT_inc(re));
3739 SAVEFREEOP((OP *) matcher);
3747 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3752 PL_op = (OP *) matcher;
3757 return (SvTRUEx(POPs));
3762 S_destroy_matcher(pTHX_ PMOP *matcher)
3765 PERL_UNUSED_ARG(matcher);
3770 /* Do a smart match */
3773 return do_smartmatch(NULL, NULL);
3776 /* This version of do_smartmatch() implements the
3777 * table of smart matches that is found in perlsyn.
3781 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3786 SV *e = TOPs; /* e is for 'expression' */
3787 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3788 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3790 regexp *this_regex, *other_regex;
3792 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3794 # define SM_REF(type) ( \
3795 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3796 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3798 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3799 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
3800 && NOT_EMPTY_PROTO(This) && (Other = e)) \
3801 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
3802 && NOT_EMPTY_PROTO(This) && (Other = d)))
3804 # define SM_REGEX ( \
3805 (SvROK(d) && SvMAGICAL(This = SvRV(d)) \
3806 && (mg = mg_find(This, PERL_MAGIC_qr)) \
3807 && (this_regex = (regexp *)mg->mg_obj) \
3810 (SvROK(e) && SvMAGICAL(This = SvRV(e)) \
3811 && (mg = mg_find(This, PERL_MAGIC_qr)) \
3812 && (this_regex = (regexp *)mg->mg_obj) \
3816 # define SM_OTHER_REF(type) \
3817 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3819 # define SM_OTHER_REGEX (SvROK(Other) && SvMAGICAL(SvRV(Other)) \
3820 && (mg = mg_find(SvRV(Other), PERL_MAGIC_qr)) \
3821 && (other_regex = (regexp *)mg->mg_obj))
3824 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3825 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3827 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3828 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3830 tryAMAGICbinSET(smart, 0);
3832 SP -= 2; /* Pop the values */
3834 /* Take care only to invoke mg_get() once for each argument.
3835 * Currently we do this by copying the SV if it's magical. */
3838 d = sv_mortalcopy(d);
3845 e = sv_mortalcopy(e);
3850 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3852 if (This == SvRV(Other))
3863 c = call_sv(This, G_SCALAR);
3867 else if (SvTEMP(TOPs))
3868 SvREFCNT_inc_void(TOPs);
3873 else if (SM_REF(PVHV)) {
3874 if (SM_OTHER_REF(PVHV)) {
3875 /* Check that the key-sets are identical */
3877 HV *other_hv = (HV *) SvRV(Other);
3879 bool other_tied = FALSE;
3880 U32 this_key_count = 0,
3881 other_key_count = 0;
3883 /* Tied hashes don't know how many keys they have. */
3884 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
3887 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3888 HV * const temp = other_hv;
3889 other_hv = (HV *) This;
3893 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3896 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
3899 /* The hashes have the same number of keys, so it suffices
3900 to check that one is a subset of the other. */
3901 (void) hv_iterinit((HV *) This);
3902 while ( (he = hv_iternext((HV *) This)) ) {
3904 char * const key = hv_iterkey(he, &key_len);
3908 if(!hv_exists(other_hv, key, key_len)) {
3909 (void) hv_iterinit((HV *) This); /* reset iterator */
3915 (void) hv_iterinit(other_hv);
3916 while ( hv_iternext(other_hv) )
3920 other_key_count = HvUSEDKEYS(other_hv);
3922 if (this_key_count != other_key_count)
3927 else if (SM_OTHER_REF(PVAV)) {
3928 AV * const other_av = (AV *) SvRV(Other);
3929 const I32 other_len = av_len(other_av) + 1;
3932 if (HvUSEDKEYS((HV *) This) != other_len)
3935 for(i = 0; i < other_len; ++i) {
3936 SV ** const svp = av_fetch(other_av, i, FALSE);
3940 if (!svp) /* ??? When can this happen? */
3943 key = SvPV(*svp, key_len);
3944 if(!hv_exists((HV *) This, key, key_len))
3949 else if (SM_OTHER_REGEX) {
3950 PMOP * const matcher = make_matcher(other_regex);
3953 (void) hv_iterinit((HV *) This);
3954 while ( (he = hv_iternext((HV *) This)) ) {
3955 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
3956 (void) hv_iterinit((HV *) This);
3957 destroy_matcher(matcher);
3961 destroy_matcher(matcher);
3965 if (hv_exists_ent((HV *) This, Other, 0))
3971 else if (SM_REF(PVAV)) {
3972 if (SM_OTHER_REF(PVAV)) {
3973 AV *other_av = (AV *) SvRV(Other);
3974 if (av_len((AV *) This) != av_len(other_av))
3978 const I32 other_len = av_len(other_av);
3980 if (NULL == seen_this) {
3981 seen_this = newHV();
3982 (void) sv_2mortal((SV *) seen_this);
3984 if (NULL == seen_other) {
3985 seen_this = newHV();
3986 (void) sv_2mortal((SV *) seen_other);
3988 for(i = 0; i <= other_len; ++i) {
3989 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
3990 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
3992 if (!this_elem || !other_elem) {
3993 if (this_elem || other_elem)
3996 else if (SM_SEEN_THIS(*this_elem)
3997 || SM_SEEN_OTHER(*other_elem))
3999 if (*this_elem != *other_elem)
4003 hv_store_ent(seen_this,
4004 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4006 hv_store_ent(seen_other,
4007 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4013 (void) do_smartmatch(seen_this, seen_other);
4023 else if (SM_OTHER_REGEX) {
4024 PMOP * const matcher = make_matcher(other_regex);
4025 const I32 this_len = av_len((AV *) This);
4028 for(i = 0; i <= this_len; ++i) {
4029 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4030 if (svp && matcher_matches_sv(matcher, *svp)) {
4031 destroy_matcher(matcher);
4035 destroy_matcher(matcher);
4038 else if (SvIOK(Other) || SvNOK(Other)) {
4041 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4042 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4049 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4059 else if (SvPOK(Other)) {
4060 const I32 this_len = av_len((AV *) This);
4063 for(i = 0; i <= this_len; ++i) {
4064 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4079 else if (!SvOK(d) || !SvOK(e)) {
4080 if (!SvOK(d) && !SvOK(e))
4085 else if (SM_REGEX) {
4086 PMOP * const matcher = make_matcher(this_regex);
4089 PUSHs(matcher_matches_sv(matcher, Other)
4092 destroy_matcher(matcher);
4095 else if (SM_REF(PVCV)) {
4097 /* This must be a null-prototyped sub, because we
4098 already checked for the other kind. */
4104 c = call_sv(This, G_SCALAR);
4107 PUSHs(&PL_sv_undef);
4108 else if (SvTEMP(TOPs))
4109 SvREFCNT_inc_void(TOPs);
4111 if (SM_OTHER_REF(PVCV)) {
4112 /* This one has to be null-proto'd too.
4113 Call both of 'em, and compare the results */
4115 c = call_sv(SvRV(Other), G_SCALAR);
4118 PUSHs(&PL_sv_undef);
4119 else if (SvTEMP(TOPs))
4120 SvREFCNT_inc_void(TOPs);
4131 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4132 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4134 if (SvPOK(Other) && !looks_like_number(Other)) {
4135 /* String comparison */
4140 /* Otherwise, numeric comparison */
4143 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4154 /* As a last resort, use string comparison */
4163 register PERL_CONTEXT *cx;
4164 const I32 gimme = GIMME_V;
4166 /* This is essentially an optimization: if the match
4167 fails, we don't want to push a context and then
4168 pop it again right away, so we skip straight
4169 to the op that follows the leavewhen.
4171 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4172 return cLOGOP->op_other->op_next;
4177 PUSHBLOCK(cx, CXt_WHEN, SP);
4186 register PERL_CONTEXT *cx;
4192 assert(CxTYPE(cx) == CXt_WHEN);
4197 PL_curpm = newpm; /* pop $1 et al */
4207 register PERL_CONTEXT *cx;
4210 cxix = dopoptowhen(cxstack_ix);
4212 DIE(aTHX_ "Can't \"continue\" outside a when block");
4213 if (cxix < cxstack_ix)
4216 /* clear off anything above the scope we're re-entering */
4217 inner = PL_scopestack_ix;
4219 if (PL_scopestack_ix < inner)
4220 leave_scope(PL_scopestack[PL_scopestack_ix]);
4221 PL_curcop = cx->blk_oldcop;
4222 return cx->blk_givwhen.leave_op;
4229 register PERL_CONTEXT *cx;
4232 cxix = dopoptogiven(cxstack_ix);
4234 if (PL_op->op_flags & OPf_SPECIAL)
4235 DIE(aTHX_ "Can't use when() outside a topicalizer");
4237 DIE(aTHX_ "Can't \"break\" outside a given block");
4239 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4240 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4242 if (cxix < cxstack_ix)
4245 /* clear off anything above the scope we're re-entering */
4246 inner = PL_scopestack_ix;
4248 if (PL_scopestack_ix < inner)
4249 leave_scope(PL_scopestack[PL_scopestack_ix]);
4250 PL_curcop = cx->blk_oldcop;
4253 return CX_LOOP_NEXTOP_GET(cx);
4255 return cx->blk_givwhen.leave_op;
4259 S_doparseform(pTHX_ SV *sv)
4262 register char *s = SvPV_force(sv, len);
4263 register char * const send = s + len;
4264 register char *base = NULL;
4265 register I32 skipspaces = 0;
4266 bool noblank = FALSE;
4267 bool repeat = FALSE;
4268 bool postspace = FALSE;
4274 bool unchopnum = FALSE;
4275 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4278 Perl_croak(aTHX_ "Null picture in formline");
4280 /* estimate the buffer size needed */
4281 for (base = s; s <= send; s++) {
4282 if (*s == '\n' || *s == '@' || *s == '^')
4288 Newx(fops, maxops, U32);
4293 *fpc++ = FF_LINEMARK;
4294 noblank = repeat = FALSE;
4312 case ' ': case '\t':
4319 } /* else FALL THROUGH */
4327 *fpc++ = FF_LITERAL;
4335 *fpc++ = (U16)skipspaces;
4339 *fpc++ = FF_NEWLINE;
4343 arg = fpc - linepc + 1;
4350 *fpc++ = FF_LINEMARK;
4351 noblank = repeat = FALSE;
4360 ischop = s[-1] == '^';
4366 arg = (s - base) - 1;
4368 *fpc++ = FF_LITERAL;
4376 *fpc++ = 2; /* skip the @* or ^* */
4378 *fpc++ = FF_LINESNGL;
4381 *fpc++ = FF_LINEGLOB;
4383 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4384 arg = ischop ? 512 : 0;
4389 const char * const f = ++s;
4392 arg |= 256 + (s - f);
4394 *fpc++ = s - base; /* fieldsize for FETCH */
4395 *fpc++ = FF_DECIMAL;
4397 unchopnum |= ! ischop;
4399 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4400 arg = ischop ? 512 : 0;
4402 s++; /* skip the '0' first */
4406 const char * const f = ++s;
4409 arg |= 256 + (s - f);
4411 *fpc++ = s - base; /* fieldsize for FETCH */
4412 *fpc++ = FF_0DECIMAL;
4414 unchopnum |= ! ischop;
4418 bool ismore = FALSE;
4421 while (*++s == '>') ;
4422 prespace = FF_SPACE;
4424 else if (*s == '|') {
4425 while (*++s == '|') ;
4426 prespace = FF_HALFSPACE;
4431 while (*++s == '<') ;
4434 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4438 *fpc++ = s - base; /* fieldsize for FETCH */
4440 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4443 *fpc++ = (U16)prespace;
4457 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4459 { /* need to jump to the next word */
4461 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4462 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4463 s = SvPVX(sv) + SvCUR(sv) + z;
4465 Copy(fops, s, arg, U32);
4467 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4470 if (unchopnum && repeat)
4471 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4477 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4479 /* Can value be printed in fldsize chars, using %*.*f ? */
4483 int intsize = fldsize - (value < 0 ? 1 : 0);
4490 while (intsize--) pwr *= 10.0;
4491 while (frcsize--) eps /= 10.0;
4494 if (value + eps >= pwr)
4497 if (value - eps <= -pwr)
4504 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4507 SV * const datasv = FILTER_DATA(idx);
4508 const int filter_has_file = IoLINES(datasv);
4509 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4510 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4514 const char *got_p = NULL;
4515 const char *prune_from = NULL;
4516 bool read_from_cache = FALSE;
4519 assert(maxlen >= 0);
4522 /* I was having segfault trouble under Linux 2.2.5 after a
4523 parse error occured. (Had to hack around it with a test
4524 for PL_error_count == 0.) Solaris doesn't segfault --
4525 not sure where the trouble is yet. XXX */
4527 if (IoFMT_GV(datasv)) {
4528 SV *const cache = (SV *)IoFMT_GV(datasv);
4531 const char *cache_p = SvPV(cache, cache_len);
4535 /* Running in block mode and we have some cached data already.
4537 if (cache_len >= umaxlen) {
4538 /* In fact, so much data we don't even need to call
4543 const char *const first_nl =
4544 (const char *)memchr(cache_p, '\n', cache_len);
4546 take = first_nl + 1 - cache_p;
4550 sv_catpvn(buf_sv, cache_p, take);
4551 sv_chop(cache, cache_p + take);
4552 /* Definately not EOF */
4556 sv_catsv(buf_sv, cache);
4558 umaxlen -= cache_len;
4561 read_from_cache = TRUE;
4565 /* Filter API says that the filter appends to the contents of the buffer.
4566 Usually the buffer is "", so the details don't matter. But if it's not,
4567 then clearly what it contains is already filtered by this filter, so we
4568 don't want to pass it in a second time.
4569 I'm going to use a mortal in case the upstream filter croaks. */
4570 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4571 ? sv_newmortal() : buf_sv;
4572 SvUPGRADE(upstream, SVt_PV);
4574 if (filter_has_file) {
4575 status = FILTER_READ(idx+1, upstream, 0);
4578 if (filter_sub && status >= 0) {
4589 PUSHs(sv_2mortal(newSViv(0)));
4591 PUSHs(filter_state);
4594 count = call_sv(filter_sub, G_SCALAR);
4609 if(SvOK(upstream)) {
4610 got_p = SvPV(upstream, got_len);
4612 if (got_len > umaxlen) {
4613 prune_from = got_p + umaxlen;
4616 const char *const first_nl =
4617 (const char *)memchr(got_p, '\n', got_len);
4618 if (first_nl && first_nl + 1 < got_p + got_len) {
4619 /* There's a second line here... */
4620 prune_from = first_nl + 1;
4625 /* Oh. Too long. Stuff some in our cache. */
4626 STRLEN cached_len = got_p + got_len - prune_from;
4627 SV *cache = (SV *)IoFMT_GV(datasv);
4630 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4631 } else if (SvOK(cache)) {
4632 /* Cache should be empty. */
4633 assert(!SvCUR(cache));
4636 sv_setpvn(cache, prune_from, cached_len);
4637 /* If you ask for block mode, you may well split UTF-8 characters.
4638 "If it breaks, you get to keep both parts"
4639 (Your code is broken if you don't put them back together again
4640 before something notices.) */
4641 if (SvUTF8(upstream)) {
4644 SvCUR_set(upstream, got_len - cached_len);
4645 /* Can't yet be EOF */
4650 /* If they are at EOF but buf_sv has something in it, then they may never
4651 have touched the SV upstream, so it may be undefined. If we naively
4652 concatenate it then we get a warning about use of uninitialised value.
4654 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4655 sv_catsv(buf_sv, upstream);
4659 IoLINES(datasv) = 0;
4660 SvREFCNT_dec(IoFMT_GV(datasv));
4662 SvREFCNT_dec(filter_state);
4663 IoTOP_GV(datasv) = NULL;
4666 SvREFCNT_dec(filter_sub);
4667 IoBOTTOM_GV(datasv) = NULL;
4669 filter_del(S_run_user_filter);
4671 if (status == 0 && read_from_cache) {
4672 /* If we read some data from the cache (and by getting here it implies
4673 that we emptied the cache) then we aren't yet at EOF, and mustn't
4674 report that to our caller. */
4680 /* perhaps someone can come up with a better name for
4681 this? it is not really "absolute", per se ... */
4683 S_path_is_absolute(const char *name)
4685 if (PERL_FILE_IS_ABSOLUTE(name)
4686 #ifdef MACOS_TRADITIONAL
4689 || (*name == '.' && (name[1] == '/' ||
4690 (name[1] == '.' && name[2] == '/')))
4702 * c-indentation-style: bsd
4704 * indent-tabs-mode: t
4707 * ex: set ts=8 sts=4 sw=4 noet: