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_type(SVt_PVMG);
2663 t = strchr(s, '\n');
2669 sv_setpvn(tmpstr, s, t - s);
2670 av_store(array, line++, tmpstr);
2676 S_docatch_body(pTHX)
2684 S_docatch(pTHX_ OP *o)
2688 OP * const oldop = PL_op;
2692 assert(CATCH_GET == TRUE);
2699 assert(cxstack_ix >= 0);
2700 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2701 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2706 /* die caught by an inner eval - continue inner loop */
2708 /* NB XXX we rely on the old popped CxEVAL still being at the top
2709 * of the stack; the way die_where() currently works, this
2710 * assumption is valid. In theory The cur_top_env value should be
2711 * returned in another global, the way retop (aka PL_restartop)
2713 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2716 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2718 PL_op = PL_restartop;
2735 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2736 /* sv Text to convert to OP tree. */
2737 /* startop op_free() this to undo. */
2738 /* code Short string id of the caller. */
2740 /* FIXME - how much of this code is common with pp_entereval? */
2741 dVAR; dSP; /* Make POPBLOCK work. */
2748 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2749 char *tmpbuf = tbuf;
2752 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2758 /* switch to eval mode */
2760 if (IN_PERL_COMPILETIME) {
2761 SAVECOPSTASH_FREE(&PL_compiling);
2762 CopSTASH_set(&PL_compiling, PL_curstash);
2764 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2765 SV * const sv = sv_newmortal();
2766 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2767 code, (unsigned long)++PL_evalseq,
2768 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2773 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2774 (unsigned long)++PL_evalseq);
2775 SAVECOPFILE_FREE(&PL_compiling);
2776 CopFILE_set(&PL_compiling, tmpbuf+2);
2777 SAVECOPLINE(&PL_compiling);
2778 CopLINE_set(&PL_compiling, 1);
2779 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2780 deleting the eval's FILEGV from the stash before gv_check() runs
2781 (i.e. before run-time proper). To work around the coredump that
2782 ensues, we always turn GvMULTI_on for any globals that were
2783 introduced within evals. See force_ident(). GSAR 96-10-12 */
2784 safestr = savepvn(tmpbuf, len);
2785 SAVEDELETE(PL_defstash, safestr, len);
2787 #ifdef OP_IN_REGISTER
2793 /* we get here either during compilation, or via pp_regcomp at runtime */
2794 runtime = IN_PERL_RUNTIME;
2796 runcv = find_runcv(NULL);
2799 PL_op->op_type = OP_ENTEREVAL;
2800 PL_op->op_flags = 0; /* Avoid uninit warning. */
2801 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2802 PUSHEVAL(cx, 0, NULL);
2805 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2807 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2808 POPBLOCK(cx,PL_curpm);
2811 (*startop)->op_type = OP_NULL;
2812 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2814 /* XXX DAPM do this properly one year */
2815 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2817 if (IN_PERL_COMPILETIME)
2818 CopHINTS_set(&PL_compiling, PL_hints);
2819 #ifdef OP_IN_REGISTER
2822 PERL_UNUSED_VAR(newsp);
2823 PERL_UNUSED_VAR(optype);
2830 =for apidoc find_runcv
2832 Locate the CV corresponding to the currently executing sub or eval.
2833 If db_seqp is non_null, skip CVs that are in the DB package and populate
2834 *db_seqp with the cop sequence number at the point that the DB:: code was
2835 entered. (allows debuggers to eval in the scope of the breakpoint rather
2836 than in the scope of the debugger itself).
2842 Perl_find_runcv(pTHX_ U32 *db_seqp)
2848 *db_seqp = PL_curcop->cop_seq;
2849 for (si = PL_curstackinfo; si; si = si->si_prev) {
2851 for (ix = si->si_cxix; ix >= 0; ix--) {
2852 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2853 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2854 CV * const cv = cx->blk_sub.cv;
2855 /* skip DB:: code */
2856 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2857 *db_seqp = cx->blk_oldcop->cop_seq;
2862 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2870 /* Compile a require/do, an eval '', or a /(?{...})/.
2871 * In the last case, startop is non-null, and contains the address of
2872 * a pointer that should be set to the just-compiled code.
2873 * outside is the lexically enclosing CV (if any) that invoked us.
2877 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2880 OP * const saveop = PL_op;
2882 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2883 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2888 SAVESPTR(PL_compcv);
2889 PL_compcv = (CV*)newSV_type(SVt_PVCV);
2890 CvEVAL_on(PL_compcv);
2891 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2892 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2894 CvOUTSIDE_SEQ(PL_compcv) = seq;
2895 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2897 /* set up a scratch pad */
2899 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2900 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2904 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2906 /* make sure we compile in the right package */
2908 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2909 SAVESPTR(PL_curstash);
2910 PL_curstash = CopSTASH(PL_curcop);
2912 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2913 SAVESPTR(PL_beginav);
2914 PL_beginav = newAV();
2915 SAVEFREESV(PL_beginav);
2916 SAVESPTR(PL_unitcheckav);
2917 PL_unitcheckav = newAV();
2918 SAVEFREESV(PL_unitcheckav);
2919 SAVEI32(PL_error_count);
2922 SAVEI32(PL_madskills);
2926 /* try to compile it */
2928 PL_eval_root = NULL;
2930 PL_curcop = &PL_compiling;
2931 CopARYBASE_set(PL_curcop, 0);
2932 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2933 PL_in_eval |= EVAL_KEEPERR;
2935 sv_setpvn(ERRSV,"",0);
2936 if (yyparse() || PL_error_count || !PL_eval_root) {
2937 SV **newsp; /* Used by POPBLOCK. */
2938 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2939 I32 optype = 0; /* Might be reset by POPEVAL. */
2944 op_free(PL_eval_root);
2945 PL_eval_root = NULL;
2947 SP = PL_stack_base + POPMARK; /* pop original mark */
2949 POPBLOCK(cx,PL_curpm);
2955 msg = SvPVx_nolen_const(ERRSV);
2956 if (optype == OP_REQUIRE) {
2957 const SV * const nsv = cx->blk_eval.old_namesv;
2958 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2960 DIE(aTHX_ "%sCompilation failed in require",
2961 *msg ? msg : "Unknown error\n");
2964 POPBLOCK(cx,PL_curpm);
2966 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2967 (*msg ? msg : "Unknown error\n"));
2971 sv_setpvs(ERRSV, "Compilation error");
2974 PERL_UNUSED_VAR(newsp);
2977 CopLINE_set(&PL_compiling, 0);
2979 *startop = PL_eval_root;
2981 SAVEFREEOP(PL_eval_root);
2983 /* Set the context for this new optree.
2984 * If the last op is an OP_REQUIRE, force scalar context.
2985 * Otherwise, propagate the context from the eval(). */
2986 if (PL_eval_root->op_type == OP_LEAVEEVAL
2987 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2988 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2990 scalar(PL_eval_root);
2991 else if (gimme & G_VOID)
2992 scalarvoid(PL_eval_root);
2993 else if (gimme & G_ARRAY)
2996 scalar(PL_eval_root);
2998 DEBUG_x(dump_eval());
3000 /* Register with debugger: */
3001 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3002 CV * const cv = get_cv("DB::postponed", FALSE);
3006 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3008 call_sv((SV*)cv, G_DISCARD);
3013 call_list(PL_scopestack_ix, PL_unitcheckav);
3015 /* compiled okay, so do it */
3017 CvDEPTH(PL_compcv) = 1;
3018 SP = PL_stack_base + POPMARK; /* pop original mark */
3019 PL_op = saveop; /* The caller may need it. */
3020 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3022 RETURNOP(PL_eval_start);
3026 S_check_type_and_open(pTHX_ const char *name, const char *mode)
3029 const int st_rc = PerlLIO_stat(name, &st);
3031 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3035 return PerlIO_open(name, mode);
3039 S_doopen_pm(pTHX_ const char *name, const char *mode)
3041 #ifndef PERL_DISABLE_PMC
3042 const STRLEN namelen = strlen(name);
3045 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3046 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3047 const char * const pmc = SvPV_nolen_const(pmcsv);
3049 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3050 fp = check_type_and_open(name, mode);
3053 fp = check_type_and_open(pmc, mode);
3055 SvREFCNT_dec(pmcsv);
3058 fp = check_type_and_open(name, mode);
3062 return check_type_and_open(name, mode);
3063 #endif /* !PERL_DISABLE_PMC */
3069 register PERL_CONTEXT *cx;
3073 const char *tryname = NULL;
3075 const I32 gimme = GIMME_V;
3076 int filter_has_file = 0;
3077 PerlIO *tryrsfp = NULL;
3078 SV *filter_cache = NULL;
3079 SV *filter_state = NULL;
3080 SV *filter_sub = NULL;
3086 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3087 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3088 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3089 "v-string in use/require non-portable");
3091 sv = new_version(sv);
3092 if (!sv_derived_from(PL_patchlevel, "version"))
3093 upg_version(PL_patchlevel);
3094 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3095 if ( vcmp(sv,PL_patchlevel) <= 0 )
3096 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3097 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3100 if ( vcmp(sv,PL_patchlevel) > 0 )
3101 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3102 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3107 name = SvPV_const(sv, len);
3108 if (!(name && len > 0 && *name))
3109 DIE(aTHX_ "Null filename used");
3110 TAINT_PROPER("require");
3111 if (PL_op->op_type == OP_REQUIRE) {
3112 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3114 if (*svp != &PL_sv_undef)
3117 DIE(aTHX_ "Compilation failed in require");
3121 /* prepare to compile file */
3123 if (path_is_absolute(name)) {
3125 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3127 #ifdef MACOS_TRADITIONAL
3131 MacPerl_CanonDir(name, newname, 1);
3132 if (path_is_absolute(newname)) {
3134 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3139 AV * const ar = GvAVn(PL_incgv);
3143 if ((unixname = tounixspec(name, NULL)) != NULL)
3147 for (i = 0; i <= AvFILL(ar); i++) {
3148 SV * const dirsv = *av_fetch(ar, i, TRUE);
3150 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3157 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3158 && !sv_isobject(loader))
3160 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3163 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3164 PTR2UV(SvRV(dirsv)), name);
3165 tryname = SvPVX_const(namesv);
3176 if (sv_isobject(loader))
3177 count = call_method("INC", G_ARRAY);
3179 count = call_sv(loader, G_ARRAY);
3182 /* Adjust file name if the hook has set an %INC entry */
3183 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3185 tryname = SvPVX_const(*svp);
3194 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3195 && !isGV_with_GP(SvRV(arg))) {
3196 filter_cache = SvRV(arg);
3197 SvREFCNT_inc_simple_void_NN(filter_cache);
3204 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3208 if (SvTYPE(arg) == SVt_PVGV) {
3209 IO * const io = GvIO((GV *)arg);
3214 tryrsfp = IoIFP(io);
3215 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3216 PerlIO_close(IoOFP(io));
3227 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3229 SvREFCNT_inc_simple_void_NN(filter_sub);
3232 filter_state = SP[i];
3233 SvREFCNT_inc_simple_void(filter_state);
3237 if (!tryrsfp && (filter_cache || filter_sub)) {
3238 tryrsfp = PerlIO_open(BIT_BUCKET,
3253 filter_has_file = 0;
3255 SvREFCNT_dec(filter_cache);
3256 filter_cache = NULL;
3259 SvREFCNT_dec(filter_state);
3260 filter_state = NULL;
3263 SvREFCNT_dec(filter_sub);
3268 if (!path_is_absolute(name)
3269 #ifdef MACOS_TRADITIONAL
3270 /* We consider paths of the form :a:b ambiguous and interpret them first
3271 as global then as local
3273 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3276 const char *dir = SvPVx_nolen_const(dirsv);
3277 #ifdef MACOS_TRADITIONAL
3281 MacPerl_CanonDir(name, buf2, 1);
3282 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3286 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3288 sv_setpv(namesv, unixdir);
3289 sv_catpv(namesv, unixname);
3291 # ifdef __SYMBIAN32__
3292 if (PL_origfilename[0] &&
3293 PL_origfilename[1] == ':' &&
3294 !(dir[0] && dir[1] == ':'))
3295 Perl_sv_setpvf(aTHX_ namesv,
3300 Perl_sv_setpvf(aTHX_ namesv,
3304 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3308 TAINT_PROPER("require");
3309 tryname = SvPVX_const(namesv);
3310 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3312 if (tryname[0] == '.' && tryname[1] == '/')
3316 else if (errno == EMFILE)
3317 /* no point in trying other paths if out of handles */
3324 SAVECOPFILE_FREE(&PL_compiling);
3325 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3326 SvREFCNT_dec(namesv);
3328 if (PL_op->op_type == OP_REQUIRE) {
3329 const char *msgstr = name;
3330 if(errno == EMFILE) {
3332 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3334 msgstr = SvPV_nolen_const(msg);
3336 if (namesv) { /* did we lookup @INC? */
3337 AV * const ar = GvAVn(PL_incgv);
3339 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3340 "%s in @INC%s%s (@INC contains:",
3342 (instr(msgstr, ".h ")
3343 ? " (change .h to .ph maybe?)" : ""),
3344 (instr(msgstr, ".ph ")
3345 ? " (did you run h2ph?)" : "")
3348 for (i = 0; i <= AvFILL(ar); i++) {
3349 sv_catpvs(msg, " ");
3350 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3352 sv_catpvs(msg, ")");
3353 msgstr = SvPV_nolen_const(msg);
3356 DIE(aTHX_ "Can't locate %s", msgstr);
3362 SETERRNO(0, SS_NORMAL);
3364 /* Assume success here to prevent recursive requirement. */
3365 /* name is never assigned to again, so len is still strlen(name) */
3366 /* Check whether a hook in @INC has already filled %INC */
3368 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3370 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3372 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc_simple(hook_sv), 0 );
3378 SAVEGENERICSV(PL_rsfp_filters);
3379 PL_rsfp_filters = NULL;
3384 SAVECOMPILEWARNINGS();
3385 if (PL_dowarn & G_WARN_ALL_ON)
3386 PL_compiling.cop_warnings = pWARN_ALL ;
3387 else if (PL_dowarn & G_WARN_ALL_OFF)
3388 PL_compiling.cop_warnings = pWARN_NONE ;
3390 PL_compiling.cop_warnings = pWARN_STD ;
3392 if (filter_sub || filter_cache) {
3393 SV * const datasv = filter_add(S_run_user_filter, NULL);
3394 IoLINES(datasv) = filter_has_file;
3395 IoTOP_GV(datasv) = (GV *)filter_state;
3396 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3397 IoFMT_GV(datasv) = (GV *)filter_cache;
3400 /* switch to eval mode */
3401 PUSHBLOCK(cx, CXt_EVAL, SP);
3402 PUSHEVAL(cx, name, NULL);
3403 cx->blk_eval.retop = PL_op->op_next;
3405 SAVECOPLINE(&PL_compiling);
3406 CopLINE_set(&PL_compiling, 0);
3410 /* Store and reset encoding. */
3411 encoding = PL_encoding;
3414 op = DOCATCH(doeval(gimme, NULL, NULL, PL_curcop->cop_seq));
3416 /* Restore encoding. */
3417 PL_encoding = encoding;
3425 register PERL_CONTEXT *cx;
3427 const I32 gimme = GIMME_V;
3428 const I32 was = PL_sub_generation;
3429 char tbuf[TYPE_DIGITS(long) + 12];
3430 char *tmpbuf = tbuf;
3436 HV *saved_hh = NULL;
3437 const char * const fakestr = "_<(eval )";
3438 const int fakelen = 9 + 1;
3440 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3441 saved_hh = (HV*) SvREFCNT_inc(POPs);
3445 TAINT_IF(SvTAINTED(sv));
3446 TAINT_PROPER("eval");
3452 /* switch to eval mode */
3454 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3455 SV * const temp_sv = sv_newmortal();
3456 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3457 (unsigned long)++PL_evalseq,
3458 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3459 tmpbuf = SvPVX(temp_sv);
3460 len = SvCUR(temp_sv);
3463 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3464 SAVECOPFILE_FREE(&PL_compiling);
3465 CopFILE_set(&PL_compiling, tmpbuf+2);
3466 SAVECOPLINE(&PL_compiling);
3467 CopLINE_set(&PL_compiling, 1);
3468 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3469 deleting the eval's FILEGV from the stash before gv_check() runs
3470 (i.e. before run-time proper). To work around the coredump that
3471 ensues, we always turn GvMULTI_on for any globals that were
3472 introduced within evals. See force_ident(). GSAR 96-10-12 */
3473 safestr = savepvn(tmpbuf, len);
3474 SAVEDELETE(PL_defstash, safestr, len);
3476 PL_hints = PL_op->op_targ;
3478 GvHV(PL_hintgv) = saved_hh;
3479 SAVECOMPILEWARNINGS();
3480 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3481 if (PL_compiling.cop_hints_hash) {
3482 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3484 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3485 if (PL_compiling.cop_hints_hash) {
3487 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3488 HINTS_REFCNT_UNLOCK;
3490 /* special case: an eval '' executed within the DB package gets lexically
3491 * placed in the first non-DB CV rather than the current CV - this
3492 * allows the debugger to execute code, find lexicals etc, in the
3493 * scope of the code being debugged. Passing &seq gets find_runcv
3494 * to do the dirty work for us */
3495 runcv = find_runcv(&seq);
3497 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3498 PUSHEVAL(cx, 0, NULL);
3499 cx->blk_eval.retop = PL_op->op_next;
3501 /* prepare to compile string */
3503 if (PERLDB_LINE && PL_curstash != PL_debstash)
3504 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3506 ret = doeval(gimme, NULL, runcv, seq);
3507 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3508 && ret != PL_op->op_next) { /* Successive compilation. */
3509 /* Copy in anything fake and short. */
3510 my_strlcpy(safestr, fakestr, fakelen);
3512 return DOCATCH(ret);
3522 register PERL_CONTEXT *cx;
3524 const U8 save_flags = PL_op -> op_flags;
3529 retop = cx->blk_eval.retop;
3532 if (gimme == G_VOID)
3534 else if (gimme == G_SCALAR) {
3537 if (SvFLAGS(TOPs) & SVs_TEMP)
3540 *MARK = sv_mortalcopy(TOPs);
3544 *MARK = &PL_sv_undef;
3549 /* in case LEAVE wipes old return values */
3550 for (mark = newsp + 1; mark <= SP; mark++) {
3551 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3552 *mark = sv_mortalcopy(*mark);
3553 TAINT_NOT; /* Each item is independent */
3557 PL_curpm = newpm; /* Don't pop $1 et al till now */
3560 assert(CvDEPTH(PL_compcv) == 1);
3562 CvDEPTH(PL_compcv) = 0;
3565 if (optype == OP_REQUIRE &&
3566 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3568 /* Unassume the success we assumed earlier. */
3569 SV * const nsv = cx->blk_eval.old_namesv;
3570 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3571 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3572 /* die_where() did LEAVE, or we won't be here */
3576 if (!(save_flags & OPf_SPECIAL))
3577 sv_setpvn(ERRSV,"",0);
3583 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3584 close to the related Perl_create_eval_scope. */
3586 Perl_delete_eval_scope(pTHX)
3591 register PERL_CONTEXT *cx;
3598 PERL_UNUSED_VAR(newsp);
3599 PERL_UNUSED_VAR(gimme);
3600 PERL_UNUSED_VAR(optype);
3603 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3604 also needed by Perl_fold_constants. */
3606 Perl_create_eval_scope(pTHX_ U32 flags)
3609 const I32 gimme = GIMME_V;
3614 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3617 PL_in_eval = EVAL_INEVAL;
3618 if (flags & G_KEEPERR)
3619 PL_in_eval |= EVAL_KEEPERR;
3621 sv_setpvn(ERRSV,"",0);
3622 if (flags & G_FAKINGEVAL) {
3623 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3631 PERL_CONTEXT * const cx = create_eval_scope(0);
3632 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3633 return DOCATCH(PL_op->op_next);
3642 register PERL_CONTEXT *cx;
3647 PERL_UNUSED_VAR(optype);
3650 if (gimme == G_VOID)
3652 else if (gimme == G_SCALAR) {
3656 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3659 *MARK = sv_mortalcopy(TOPs);
3663 *MARK = &PL_sv_undef;
3668 /* in case LEAVE wipes old return values */
3670 for (mark = newsp + 1; mark <= SP; mark++) {
3671 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3672 *mark = sv_mortalcopy(*mark);
3673 TAINT_NOT; /* Each item is independent */
3677 PL_curpm = newpm; /* Don't pop $1 et al till now */
3680 sv_setpvn(ERRSV,"",0);
3687 register PERL_CONTEXT *cx;
3688 const I32 gimme = GIMME_V;
3693 if (PL_op->op_targ == 0) {
3694 SV ** const defsv_p = &GvSV(PL_defgv);
3695 *defsv_p = newSVsv(POPs);
3696 SAVECLEARSV(*defsv_p);
3699 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3701 PUSHBLOCK(cx, CXt_GIVEN, SP);
3710 register PERL_CONTEXT *cx;
3714 PERL_UNUSED_CONTEXT;
3717 assert(CxTYPE(cx) == CXt_GIVEN);
3722 PL_curpm = newpm; /* pop $1 et al */
3729 /* Helper routines used by pp_smartmatch */
3732 S_make_matcher(pTHX_ regexp *re)
3735 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3736 PM_SETRE(matcher, ReREFCNT_inc(re));
3738 SAVEFREEOP((OP *) matcher);
3746 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3751 PL_op = (OP *) matcher;
3756 return (SvTRUEx(POPs));
3761 S_destroy_matcher(pTHX_ PMOP *matcher)
3764 PERL_UNUSED_ARG(matcher);
3769 /* Do a smart match */
3772 return do_smartmatch(NULL, NULL);
3775 /* This version of do_smartmatch() implements the
3776 * table of smart matches that is found in perlsyn.
3780 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3785 SV *e = TOPs; /* e is for 'expression' */
3786 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3787 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3789 regexp *this_regex, *other_regex;
3791 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3793 # define SM_REF(type) ( \
3794 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3795 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3797 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3798 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
3799 && NOT_EMPTY_PROTO(This) && (Other = e)) \
3800 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
3801 && NOT_EMPTY_PROTO(This) && (Other = d)))
3803 # define SM_REGEX ( \
3804 (SvROK(d) && SvMAGICAL(This = SvRV(d)) \
3805 && (mg = mg_find(This, PERL_MAGIC_qr)) \
3806 && (this_regex = (regexp *)mg->mg_obj) \
3809 (SvROK(e) && SvMAGICAL(This = SvRV(e)) \
3810 && (mg = mg_find(This, PERL_MAGIC_qr)) \
3811 && (this_regex = (regexp *)mg->mg_obj) \
3815 # define SM_OTHER_REF(type) \
3816 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3818 # define SM_OTHER_REGEX (SvROK(Other) && SvMAGICAL(SvRV(Other)) \
3819 && (mg = mg_find(SvRV(Other), PERL_MAGIC_qr)) \
3820 && (other_regex = (regexp *)mg->mg_obj))
3823 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3824 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3826 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3827 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3829 tryAMAGICbinSET(smart, 0);
3831 SP -= 2; /* Pop the values */
3833 /* Take care only to invoke mg_get() once for each argument.
3834 * Currently we do this by copying the SV if it's magical. */
3837 d = sv_mortalcopy(d);
3844 e = sv_mortalcopy(e);
3849 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3851 if (This == SvRV(Other))
3862 c = call_sv(This, G_SCALAR);
3866 else if (SvTEMP(TOPs))
3867 SvREFCNT_inc_void(TOPs);
3872 else if (SM_REF(PVHV)) {
3873 if (SM_OTHER_REF(PVHV)) {
3874 /* Check that the key-sets are identical */
3876 HV *other_hv = (HV *) SvRV(Other);
3878 bool other_tied = FALSE;
3879 U32 this_key_count = 0,
3880 other_key_count = 0;
3882 /* Tied hashes don't know how many keys they have. */
3883 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
3886 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3887 HV * const temp = other_hv;
3888 other_hv = (HV *) This;
3892 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3895 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
3898 /* The hashes have the same number of keys, so it suffices
3899 to check that one is a subset of the other. */
3900 (void) hv_iterinit((HV *) This);
3901 while ( (he = hv_iternext((HV *) This)) ) {
3903 char * const key = hv_iterkey(he, &key_len);
3907 if(!hv_exists(other_hv, key, key_len)) {
3908 (void) hv_iterinit((HV *) This); /* reset iterator */
3914 (void) hv_iterinit(other_hv);
3915 while ( hv_iternext(other_hv) )
3919 other_key_count = HvUSEDKEYS(other_hv);
3921 if (this_key_count != other_key_count)
3926 else if (SM_OTHER_REF(PVAV)) {
3927 AV * const other_av = (AV *) SvRV(Other);
3928 const I32 other_len = av_len(other_av) + 1;
3931 if (HvUSEDKEYS((HV *) This) != other_len)
3934 for(i = 0; i < other_len; ++i) {
3935 SV ** const svp = av_fetch(other_av, i, FALSE);
3939 if (!svp) /* ??? When can this happen? */
3942 key = SvPV(*svp, key_len);
3943 if(!hv_exists((HV *) This, key, key_len))
3948 else if (SM_OTHER_REGEX) {
3949 PMOP * const matcher = make_matcher(other_regex);
3952 (void) hv_iterinit((HV *) This);
3953 while ( (he = hv_iternext((HV *) This)) ) {
3954 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
3955 (void) hv_iterinit((HV *) This);
3956 destroy_matcher(matcher);
3960 destroy_matcher(matcher);
3964 if (hv_exists_ent((HV *) This, Other, 0))
3970 else if (SM_REF(PVAV)) {
3971 if (SM_OTHER_REF(PVAV)) {
3972 AV *other_av = (AV *) SvRV(Other);
3973 if (av_len((AV *) This) != av_len(other_av))
3977 const I32 other_len = av_len(other_av);
3979 if (NULL == seen_this) {
3980 seen_this = newHV();
3981 (void) sv_2mortal((SV *) seen_this);
3983 if (NULL == seen_other) {
3984 seen_this = newHV();
3985 (void) sv_2mortal((SV *) seen_other);
3987 for(i = 0; i <= other_len; ++i) {
3988 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
3989 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
3991 if (!this_elem || !other_elem) {
3992 if (this_elem || other_elem)
3995 else if (SM_SEEN_THIS(*this_elem)
3996 || SM_SEEN_OTHER(*other_elem))
3998 if (*this_elem != *other_elem)
4002 hv_store_ent(seen_this,
4003 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4005 hv_store_ent(seen_other,
4006 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4012 (void) do_smartmatch(seen_this, seen_other);
4022 else if (SM_OTHER_REGEX) {
4023 PMOP * const matcher = make_matcher(other_regex);
4024 const I32 this_len = av_len((AV *) This);
4027 for(i = 0; i <= this_len; ++i) {
4028 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4029 if (svp && matcher_matches_sv(matcher, *svp)) {
4030 destroy_matcher(matcher);
4034 destroy_matcher(matcher);
4037 else if (SvIOK(Other) || SvNOK(Other)) {
4040 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4041 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4048 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4058 else if (SvPOK(Other)) {
4059 const I32 this_len = av_len((AV *) This);
4062 for(i = 0; i <= this_len; ++i) {
4063 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4078 else if (!SvOK(d) || !SvOK(e)) {
4079 if (!SvOK(d) && !SvOK(e))
4084 else if (SM_REGEX) {
4085 PMOP * const matcher = make_matcher(this_regex);
4088 PUSHs(matcher_matches_sv(matcher, Other)
4091 destroy_matcher(matcher);
4094 else if (SM_REF(PVCV)) {
4096 /* This must be a null-prototyped sub, because we
4097 already checked for the other kind. */
4103 c = call_sv(This, G_SCALAR);
4106 PUSHs(&PL_sv_undef);
4107 else if (SvTEMP(TOPs))
4108 SvREFCNT_inc_void(TOPs);
4110 if (SM_OTHER_REF(PVCV)) {
4111 /* This one has to be null-proto'd too.
4112 Call both of 'em, and compare the results */
4114 c = call_sv(SvRV(Other), G_SCALAR);
4117 PUSHs(&PL_sv_undef);
4118 else if (SvTEMP(TOPs))
4119 SvREFCNT_inc_void(TOPs);
4130 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4131 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4133 if (SvPOK(Other) && !looks_like_number(Other)) {
4134 /* String comparison */
4139 /* Otherwise, numeric comparison */
4142 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4153 /* As a last resort, use string comparison */
4162 register PERL_CONTEXT *cx;
4163 const I32 gimme = GIMME_V;
4165 /* This is essentially an optimization: if the match
4166 fails, we don't want to push a context and then
4167 pop it again right away, so we skip straight
4168 to the op that follows the leavewhen.
4170 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4171 return cLOGOP->op_other->op_next;
4176 PUSHBLOCK(cx, CXt_WHEN, SP);
4185 register PERL_CONTEXT *cx;
4191 assert(CxTYPE(cx) == CXt_WHEN);
4196 PL_curpm = newpm; /* pop $1 et al */
4206 register PERL_CONTEXT *cx;
4209 cxix = dopoptowhen(cxstack_ix);
4211 DIE(aTHX_ "Can't \"continue\" outside a when block");
4212 if (cxix < cxstack_ix)
4215 /* clear off anything above the scope we're re-entering */
4216 inner = PL_scopestack_ix;
4218 if (PL_scopestack_ix < inner)
4219 leave_scope(PL_scopestack[PL_scopestack_ix]);
4220 PL_curcop = cx->blk_oldcop;
4221 return cx->blk_givwhen.leave_op;
4228 register PERL_CONTEXT *cx;
4231 cxix = dopoptogiven(cxstack_ix);
4233 if (PL_op->op_flags & OPf_SPECIAL)
4234 DIE(aTHX_ "Can't use when() outside a topicalizer");
4236 DIE(aTHX_ "Can't \"break\" outside a given block");
4238 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4239 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4241 if (cxix < cxstack_ix)
4244 /* clear off anything above the scope we're re-entering */
4245 inner = PL_scopestack_ix;
4247 if (PL_scopestack_ix < inner)
4248 leave_scope(PL_scopestack[PL_scopestack_ix]);
4249 PL_curcop = cx->blk_oldcop;
4252 return CX_LOOP_NEXTOP_GET(cx);
4254 return cx->blk_givwhen.leave_op;
4258 S_doparseform(pTHX_ SV *sv)
4261 register char *s = SvPV_force(sv, len);
4262 register char * const send = s + len;
4263 register char *base = NULL;
4264 register I32 skipspaces = 0;
4265 bool noblank = FALSE;
4266 bool repeat = FALSE;
4267 bool postspace = FALSE;
4273 bool unchopnum = FALSE;
4274 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4277 Perl_croak(aTHX_ "Null picture in formline");
4279 /* estimate the buffer size needed */
4280 for (base = s; s <= send; s++) {
4281 if (*s == '\n' || *s == '@' || *s == '^')
4287 Newx(fops, maxops, U32);
4292 *fpc++ = FF_LINEMARK;
4293 noblank = repeat = FALSE;
4311 case ' ': case '\t':
4318 } /* else FALL THROUGH */
4326 *fpc++ = FF_LITERAL;
4334 *fpc++ = (U16)skipspaces;
4338 *fpc++ = FF_NEWLINE;
4342 arg = fpc - linepc + 1;
4349 *fpc++ = FF_LINEMARK;
4350 noblank = repeat = FALSE;
4359 ischop = s[-1] == '^';
4365 arg = (s - base) - 1;
4367 *fpc++ = FF_LITERAL;
4375 *fpc++ = 2; /* skip the @* or ^* */
4377 *fpc++ = FF_LINESNGL;
4380 *fpc++ = FF_LINEGLOB;
4382 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4383 arg = ischop ? 512 : 0;
4388 const char * const f = ++s;
4391 arg |= 256 + (s - f);
4393 *fpc++ = s - base; /* fieldsize for FETCH */
4394 *fpc++ = FF_DECIMAL;
4396 unchopnum |= ! ischop;
4398 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4399 arg = ischop ? 512 : 0;
4401 s++; /* skip the '0' first */
4405 const char * const f = ++s;
4408 arg |= 256 + (s - f);
4410 *fpc++ = s - base; /* fieldsize for FETCH */
4411 *fpc++ = FF_0DECIMAL;
4413 unchopnum |= ! ischop;
4417 bool ismore = FALSE;
4420 while (*++s == '>') ;
4421 prespace = FF_SPACE;
4423 else if (*s == '|') {
4424 while (*++s == '|') ;
4425 prespace = FF_HALFSPACE;
4430 while (*++s == '<') ;
4433 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4437 *fpc++ = s - base; /* fieldsize for FETCH */
4439 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4442 *fpc++ = (U16)prespace;
4456 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4458 { /* need to jump to the next word */
4460 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4461 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4462 s = SvPVX(sv) + SvCUR(sv) + z;
4464 Copy(fops, s, arg, U32);
4466 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4469 if (unchopnum && repeat)
4470 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4476 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4478 /* Can value be printed in fldsize chars, using %*.*f ? */
4482 int intsize = fldsize - (value < 0 ? 1 : 0);
4489 while (intsize--) pwr *= 10.0;
4490 while (frcsize--) eps /= 10.0;
4493 if (value + eps >= pwr)
4496 if (value - eps <= -pwr)
4503 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4506 SV * const datasv = FILTER_DATA(idx);
4507 const int filter_has_file = IoLINES(datasv);
4508 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4509 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4513 const char *got_p = NULL;
4514 const char *prune_from = NULL;
4515 bool read_from_cache = FALSE;
4518 assert(maxlen >= 0);
4521 /* I was having segfault trouble under Linux 2.2.5 after a
4522 parse error occured. (Had to hack around it with a test
4523 for PL_error_count == 0.) Solaris doesn't segfault --
4524 not sure where the trouble is yet. XXX */
4526 if (IoFMT_GV(datasv)) {
4527 SV *const cache = (SV *)IoFMT_GV(datasv);
4530 const char *cache_p = SvPV(cache, cache_len);
4534 /* Running in block mode and we have some cached data already.
4536 if (cache_len >= umaxlen) {
4537 /* In fact, so much data we don't even need to call
4542 const char *const first_nl =
4543 (const char *)memchr(cache_p, '\n', cache_len);
4545 take = first_nl + 1 - cache_p;
4549 sv_catpvn(buf_sv, cache_p, take);
4550 sv_chop(cache, cache_p + take);
4551 /* Definately not EOF */
4555 sv_catsv(buf_sv, cache);
4557 umaxlen -= cache_len;
4560 read_from_cache = TRUE;
4564 /* Filter API says that the filter appends to the contents of the buffer.
4565 Usually the buffer is "", so the details don't matter. But if it's not,
4566 then clearly what it contains is already filtered by this filter, so we
4567 don't want to pass it in a second time.
4568 I'm going to use a mortal in case the upstream filter croaks. */
4569 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4570 ? sv_newmortal() : buf_sv;
4571 SvUPGRADE(upstream, SVt_PV);
4573 if (filter_has_file) {
4574 status = FILTER_READ(idx+1, upstream, 0);
4577 if (filter_sub && status >= 0) {
4588 PUSHs(sv_2mortal(newSViv(0)));
4590 PUSHs(filter_state);
4593 count = call_sv(filter_sub, G_SCALAR);
4608 if(SvOK(upstream)) {
4609 got_p = SvPV(upstream, got_len);
4611 if (got_len > umaxlen) {
4612 prune_from = got_p + umaxlen;
4615 const char *const first_nl =
4616 (const char *)memchr(got_p, '\n', got_len);
4617 if (first_nl && first_nl + 1 < got_p + got_len) {
4618 /* There's a second line here... */
4619 prune_from = first_nl + 1;
4624 /* Oh. Too long. Stuff some in our cache. */
4625 STRLEN cached_len = got_p + got_len - prune_from;
4626 SV *cache = (SV *)IoFMT_GV(datasv);
4629 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4630 } else if (SvOK(cache)) {
4631 /* Cache should be empty. */
4632 assert(!SvCUR(cache));
4635 sv_setpvn(cache, prune_from, cached_len);
4636 /* If you ask for block mode, you may well split UTF-8 characters.
4637 "If it breaks, you get to keep both parts"
4638 (Your code is broken if you don't put them back together again
4639 before something notices.) */
4640 if (SvUTF8(upstream)) {
4643 SvCUR_set(upstream, got_len - cached_len);
4644 /* Can't yet be EOF */
4649 /* If they are at EOF but buf_sv has something in it, then they may never
4650 have touched the SV upstream, so it may be undefined. If we naively
4651 concatenate it then we get a warning about use of uninitialised value.
4653 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4654 sv_catsv(buf_sv, upstream);
4658 IoLINES(datasv) = 0;
4659 SvREFCNT_dec(IoFMT_GV(datasv));
4661 SvREFCNT_dec(filter_state);
4662 IoTOP_GV(datasv) = NULL;
4665 SvREFCNT_dec(filter_sub);
4666 IoBOTTOM_GV(datasv) = NULL;
4668 filter_del(S_run_user_filter);
4670 if (status == 0 && read_from_cache) {
4671 /* If we read some data from the cache (and by getting here it implies
4672 that we emptied the cache) then we aren't yet at EOF, and mustn't
4673 report that to our caller. */
4679 /* perhaps someone can come up with a better name for
4680 this? it is not really "absolute", per se ... */
4682 S_path_is_absolute(const char *name)
4684 if (PERL_FILE_IS_ABSOLUTE(name)
4685 #ifdef MACOS_TRADITIONAL
4688 || (*name == '.' && (name[1] == '/' ||
4689 (name[1] == '.' && name[2] == '/')))
4701 * c-indentation-style: bsd
4703 * indent-tabs-mode: t
4706 * ex: set ts=8 sts=4 sw=4 noet: