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