3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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.
19 * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains control-oriented pp ("push/pop") functions that
23 * execute the opcodes that make up a perl program. A typical pp function
24 * expects to find its arguments on the stack, and usually pushes its
25 * results onto the stack, hence the 'pp' terminology. Each OP structure
26 * contains a pointer to the relevant pp_foo() function.
28 * Control-oriented means things like pp_enteriter() and pp_next(), which
29 * alter the flow of control of the program.
34 #define PERL_IN_PP_CTL_C
37 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
39 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
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) {
93 #define tryAMAGICregexp(rx) \
96 if (SvROK(rx) && SvAMAGIC(rx)) { \
97 SV *sv = AMG_CALLunary(rx, regexp_amg); \
101 if (SvTYPE(sv) != SVt_REGEXP) \
102 Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
109 if (PL_op->op_flags & OPf_STACKED) {
110 /* multiple args; concatenate them */
112 tmpstr = PAD_SV(ARGTARG);
113 sv_setpvs(tmpstr, "");
114 while (++MARK <= SP) {
118 tryAMAGICregexp(msv);
120 if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
121 (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
123 sv_setsv(tmpstr, sv);
126 sv_catsv_nomg(tmpstr, msv);
133 tryAMAGICregexp(tmpstr);
136 #undef tryAMAGICregexp
139 SV * const sv = SvRV(tmpstr);
140 if (SvTYPE(sv) == SVt_REGEXP)
143 else if (SvTYPE(tmpstr) == SVt_REGEXP)
144 re = (REGEXP*) tmpstr;
147 /* The match's LHS's get-magic might need to access this op's reg-
148 exp (as is sometimes the case with $'; see bug 70764). So we
149 must call get-magic now before we replace the regexp. Hopeful-
150 ly this hack can be replaced with the approach described at
151 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
152 /msg122415.html some day. */
153 if(pm->op_type == OP_MATCH) {
155 const bool was_tainted = PL_tainted;
156 if (pm->op_flags & OPf_STACKED)
158 else if (pm->op_private & OPpTARGET_MY)
159 lhs = PAD_SV(pm->op_targ);
162 /* Restore the previous value of PL_tainted (which may have been
163 modified by get-magic), to avoid incorrectly setting the
164 RXf_TAINTED flag further down. */
165 PL_tainted = was_tainted;
168 re = reg_temp_copy(NULL, re);
169 ReREFCNT_dec(PM_GETRE(pm));
174 const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : "";
177 assert (re != (REGEXP*) &PL_sv_undef);
179 /* Check against the last compiled regexp. */
180 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
181 memNE(RX_PRECOMP(re), t, len))
183 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
184 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
188 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
190 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
192 } else if (PL_curcop->cop_hints_hash) {
193 SV *ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
194 if (ptr && SvIOK(ptr) && SvIV(ptr))
195 eng = INT2PTR(regexp_engine*,SvIV(ptr));
198 if (PL_op->op_flags & OPf_SPECIAL)
199 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
201 if (DO_UTF8(tmpstr)) {
202 assert (SvUTF8(tmpstr));
203 } else if (SvUTF8(tmpstr)) {
204 /* Not doing UTF-8, despite what the SV says. Is this only if
205 we're trapped in use 'bytes'? */
206 /* Make a copy of the octet sequence, but without the flag on,
207 as the compiler now honours the SvUTF8 flag on tmpstr. */
209 const char *const p = SvPV(tmpstr, len);
210 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
212 else if (SvAMAGIC(tmpstr)) {
213 /* make a copy to avoid extra stringifies */
214 tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
217 /* If it is gmagical, create a mortal copy, but without calling
218 get-magic, as we have already done that. */
219 if(SvGMAGICAL(tmpstr)) {
220 SV *mortalcopy = sv_newmortal();
221 sv_setsv_flags(mortalcopy, tmpstr, 0);
226 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
228 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
230 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
231 inside tie/overload accessors. */
237 #ifndef INCOMPLETE_TAINTS
240 SvTAINTED_on((SV*)re);
241 RX_EXTFLAGS(re) |= RXf_TAINTED;
246 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
250 #if !defined(USE_ITHREADS)
251 /* can't change the optree at runtime either */
252 /* PMf_KEEP is handled differently under threads to avoid these problems */
253 if (pm->op_pmflags & PMf_KEEP) {
254 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
255 cLOGOP->op_first->op_next = PL_op->op_next;
265 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
266 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
267 register SV * const dstr = cx->sb_dstr;
268 register char *s = cx->sb_s;
269 register char *m = cx->sb_m;
270 char *orig = cx->sb_orig;
271 register REGEXP * const rx = cx->sb_rx;
273 REGEXP *old = PM_GETRE(pm);
280 PM_SETRE(pm,ReREFCNT_inc(rx));
283 rxres_restore(&cx->sb_rxres, rx);
284 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
286 if (cx->sb_iters++) {
287 const I32 saviters = cx->sb_iters;
288 if (cx->sb_iters > cx->sb_maxiters)
289 DIE(aTHX_ "Substitution loop");
291 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
293 /* See "how taint works" above pp_subst() */
295 cx->sb_rxtainted |= SUBST_TAINT_REPL;
296 sv_catsv_nomg(dstr, POPs);
297 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
301 if (CxONCE(cx) || s < orig ||
302 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
303 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
304 ((cx->sb_rflags & REXEC_COPY_STR)
305 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
306 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
308 SV * const targ = cx->sb_targ;
310 assert(cx->sb_strend >= s);
311 if(cx->sb_strend > s) {
312 if (DO_UTF8(dstr) && !SvUTF8(targ))
313 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
315 sv_catpvn(dstr, s, cx->sb_strend - s);
317 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
318 cx->sb_rxtainted |= SUBST_TAINT_PAT;
320 #ifdef PERL_OLD_COPY_ON_WRITE
322 sv_force_normal_flags(targ, SV_COW_DROP_PV);
328 SvPV_set(targ, SvPVX(dstr));
329 SvCUR_set(targ, SvCUR(dstr));
330 SvLEN_set(targ, SvLEN(dstr));
333 SvPV_set(dstr, NULL);
335 if (pm->op_pmflags & PMf_NONDESTRUCT)
338 mPUSHi(saviters - 1);
340 (void)SvPOK_only_UTF8(targ);
342 /* update the taint state of various various variables in
343 * preparation for final exit.
344 * See "how taint works" above pp_subst() */
346 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
347 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
348 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
350 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
352 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
353 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
355 SvTAINTED_on(TOPs); /* taint return value */
356 /* needed for mg_set below */
357 PL_tainted = cBOOL(cx->sb_rxtainted &
358 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
361 /* PL_tainted must be correctly set for this mg_set */
364 LEAVE_SCOPE(cx->sb_oldsave);
366 RETURNOP(pm->op_next);
369 cx->sb_iters = saviters;
371 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
374 cx->sb_orig = orig = RX_SUBBEG(rx);
376 cx->sb_strend = s + (cx->sb_strend - m);
378 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
380 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
381 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
383 sv_catpvn(dstr, s, m-s);
385 cx->sb_s = RX_OFFS(rx)[0].end + orig;
386 { /* Update the pos() information. */
387 SV * const sv = cx->sb_targ;
389 SvUPGRADE(sv, SVt_PVMG);
390 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
391 #ifdef PERL_OLD_COPY_ON_WRITE
393 sv_force_normal_flags(sv, 0);
395 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
398 mg->mg_len = m - orig;
401 (void)ReREFCNT_inc(rx);
402 /* update the taint state of various various variables in preparation
403 * for calling the code block.
404 * See "how taint works" above pp_subst() */
406 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
407 cx->sb_rxtainted |= SUBST_TAINT_PAT;
409 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
410 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
411 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
413 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
415 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
416 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
417 SvTAINTED_on(cx->sb_targ);
420 rxres_save(&cx->sb_rxres, rx);
422 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
426 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
431 PERL_ARGS_ASSERT_RXRES_SAVE;
434 if (!p || p[1] < RX_NPARENS(rx)) {
435 #ifdef PERL_OLD_COPY_ON_WRITE
436 i = 7 + RX_NPARENS(rx) * 2;
438 i = 6 + RX_NPARENS(rx) * 2;
447 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
448 RX_MATCH_COPIED_off(rx);
450 #ifdef PERL_OLD_COPY_ON_WRITE
451 *p++ = PTR2UV(RX_SAVED_COPY(rx));
452 RX_SAVED_COPY(rx) = NULL;
455 *p++ = RX_NPARENS(rx);
457 *p++ = PTR2UV(RX_SUBBEG(rx));
458 *p++ = (UV)RX_SUBLEN(rx);
459 for (i = 0; i <= RX_NPARENS(rx); ++i) {
460 *p++ = (UV)RX_OFFS(rx)[i].start;
461 *p++ = (UV)RX_OFFS(rx)[i].end;
466 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
471 PERL_ARGS_ASSERT_RXRES_RESTORE;
474 RX_MATCH_COPY_FREE(rx);
475 RX_MATCH_COPIED_set(rx, *p);
478 #ifdef PERL_OLD_COPY_ON_WRITE
479 if (RX_SAVED_COPY(rx))
480 SvREFCNT_dec (RX_SAVED_COPY(rx));
481 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
485 RX_NPARENS(rx) = *p++;
487 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
488 RX_SUBLEN(rx) = (I32)(*p++);
489 for (i = 0; i <= RX_NPARENS(rx); ++i) {
490 RX_OFFS(rx)[i].start = (I32)(*p++);
491 RX_OFFS(rx)[i].end = (I32)(*p++);
496 S_rxres_free(pTHX_ void **rsp)
498 UV * const p = (UV*)*rsp;
500 PERL_ARGS_ASSERT_RXRES_FREE;
505 void *tmp = INT2PTR(char*,*p);
508 PoisonFree(*p, 1, sizeof(*p));
510 Safefree(INT2PTR(char*,*p));
512 #ifdef PERL_OLD_COPY_ON_WRITE
514 SvREFCNT_dec (INT2PTR(SV*,p[1]));
524 dVAR; dSP; dMARK; dORIGMARK;
525 register SV * const tmpForm = *++MARK;
530 register SV *sv = NULL;
531 const char *item = NULL;
535 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
536 const char *chophere = NULL;
537 char *linemark = NULL;
539 bool gotsome = FALSE;
541 const STRLEN fudge = SvPOKp(tmpForm)
542 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
543 bool item_is_utf8 = FALSE;
544 bool targ_is_utf8 = FALSE;
549 if (SvTYPE(tmpForm) >= SVt_PVMG) {
550 /* This might, of course, still return NULL. */
551 mg = mg_find(tmpForm, PERL_MAGIC_fm);
553 sv_upgrade(tmpForm, SVt_PVMG);
557 mg = doparseform(tmpForm);
560 fpc = (U32*)mg->mg_ptr;
562 SvPV_force(PL_formtarget, len);
563 if (SvTAINTED(tmpForm))
564 SvTAINTED_on(PL_formtarget);
565 if (DO_UTF8(PL_formtarget))
567 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
569 f = SvPV_const(tmpForm, len);
573 const char *name = "???";
576 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
577 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
578 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
579 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
580 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
582 case FF_CHECKNL: name = "CHECKNL"; break;
583 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
584 case FF_SPACE: name = "SPACE"; break;
585 case FF_HALFSPACE: name = "HALFSPACE"; break;
586 case FF_ITEM: name = "ITEM"; break;
587 case FF_CHOP: name = "CHOP"; break;
588 case FF_LINEGLOB: name = "LINEGLOB"; break;
589 case FF_NEWLINE: name = "NEWLINE"; break;
590 case FF_MORE: name = "MORE"; break;
591 case FF_LINEMARK: name = "LINEMARK"; break;
592 case FF_END: name = "END"; break;
593 case FF_0DECIMAL: name = "0DECIMAL"; break;
594 case FF_LINESNGL: name = "LINESNGL"; break;
597 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
599 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
610 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
611 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
613 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
614 t = SvEND(PL_formtarget);
618 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
619 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
621 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
622 t = SvEND(PL_formtarget);
642 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
645 SvTAINTED_on(PL_formtarget);
651 const char *s = item = SvPV_const(sv, len);
654 itemsize = sv_len_utf8(sv);
655 if (itemsize != (I32)len) {
657 if (itemsize > fieldsize) {
658 itemsize = fieldsize;
659 itembytes = itemsize;
660 sv_pos_u2b(sv, &itembytes, 0);
664 send = chophere = s + itembytes;
674 sv_pos_b2u(sv, &itemsize);
678 item_is_utf8 = FALSE;
679 if (itemsize > fieldsize)
680 itemsize = fieldsize;
681 send = chophere = s + itemsize;
695 const char *s = item = SvPV_const(sv, len);
698 itemsize = sv_len_utf8(sv);
699 if (itemsize != (I32)len) {
701 if (itemsize <= fieldsize) {
702 const char *send = chophere = s + itemsize;
715 itemsize = fieldsize;
716 itembytes = itemsize;
717 sv_pos_u2b(sv, &itembytes, 0);
718 send = chophere = s + itembytes;
719 while (s < send || (s == send && isSPACE(*s))) {
729 if (strchr(PL_chopset, *s))
734 itemsize = chophere - item;
735 sv_pos_b2u(sv, &itemsize);
741 item_is_utf8 = FALSE;
742 if (itemsize <= fieldsize) {
743 const char *const send = chophere = s + itemsize;
756 itemsize = fieldsize;
757 send = chophere = s + itemsize;
758 while (s < send || (s == send && isSPACE(*s))) {
768 if (strchr(PL_chopset, *s))
773 itemsize = chophere - item;
779 arg = fieldsize - itemsize;
788 arg = fieldsize - itemsize;
799 const char *s = item;
803 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
805 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
807 t = SvEND(PL_formtarget);
811 if (UTF8_IS_CONTINUED(*s)) {
812 STRLEN skip = UTF8SKIP(s);
829 if ( !((*t++ = *s++) & ~31) )
835 if (targ_is_utf8 && !item_is_utf8) {
836 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
838 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
839 for (; t < SvEND(PL_formtarget); t++) {
852 const int ch = *t++ = *s++;
855 if ( !((*t++ = *s++) & ~31) )
864 const char *s = chophere;
878 const bool oneline = fpc[-1] == FF_LINESNGL;
879 const char *s = item = SvPV_const(sv, len);
880 item_is_utf8 = DO_UTF8(sv);
883 STRLEN to_copy = itemsize;
884 const char *const send = s + len;
885 const U8 *source = (const U8 *) s;
889 chophere = s + itemsize;
893 to_copy = s - SvPVX_const(sv) - 1;
905 if (targ_is_utf8 && !item_is_utf8) {
906 source = tmp = bytes_to_utf8(source, &to_copy);
907 SvCUR_set(PL_formtarget,
908 t - SvPVX_const(PL_formtarget));
910 if (item_is_utf8 && !targ_is_utf8) {
911 /* Upgrade targ to UTF8, and then we reduce it to
912 a problem we have a simple solution for. */
913 SvCUR_set(PL_formtarget,
914 t - SvPVX_const(PL_formtarget));
916 /* Don't need get magic. */
917 sv_utf8_upgrade_nomg(PL_formtarget);
919 SvCUR_set(PL_formtarget,
920 t - SvPVX_const(PL_formtarget));
923 /* Easy. They agree. */
924 assert (item_is_utf8 == targ_is_utf8);
926 SvGROW(PL_formtarget,
927 SvCUR(PL_formtarget) + to_copy + fudge + 1);
928 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
930 Copy(source, t, to_copy, char);
932 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
934 if (SvGMAGICAL(sv)) {
935 /* Mustn't call sv_pos_b2u() as it does a second
936 mg_get(). Is this a bug? Do we need a _flags()
938 itemsize = utf8_length(source, source + itemsize);
940 sv_pos_b2u(sv, &itemsize);
952 #if defined(USE_LONG_DOUBLE)
955 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
959 "%#0*.*f" : "%0*.*f");
964 #if defined(USE_LONG_DOUBLE)
966 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
969 ((arg & 256) ? "%#*.*f" : "%*.*f");
972 /* If the field is marked with ^ and the value is undefined,
974 if ((arg & 512) && !SvOK(sv)) {
982 /* overflow evidence */
983 if (num_overflow(value, fieldsize, arg)) {
989 /* Formats aren't yet marked for locales, so assume "yes". */
991 STORE_NUMERIC_STANDARD_SET_LOCAL();
992 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
993 RESTORE_NUMERIC_STANDARD();
1000 while (t-- > linemark && *t == ' ') ;
1008 if (arg) { /* repeat until fields exhausted? */
1010 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1011 lines += FmLINES(PL_formtarget);
1013 SvUTF8_on(PL_formtarget);
1014 FmLINES(PL_formtarget) = lines;
1016 RETURNOP(cLISTOP->op_first);
1027 const char *s = chophere;
1028 const char *send = item + len;
1030 while (isSPACE(*s) && (s < send))
1035 arg = fieldsize - itemsize;
1042 if (strnEQ(s1," ",3)) {
1043 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
1054 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1056 SvUTF8_on(PL_formtarget);
1057 FmLINES(PL_formtarget) += lines;
1069 if (PL_stack_base + *PL_markstack_ptr == SP) {
1071 if (GIMME_V == G_SCALAR)
1073 RETURNOP(PL_op->op_next->op_next);
1075 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
1076 Perl_pp_pushmark(aTHX); /* push dst */
1077 Perl_pp_pushmark(aTHX); /* push src */
1078 ENTER_with_name("grep"); /* enter outer scope */
1081 if (PL_op->op_private & OPpGREP_LEX)
1082 SAVESPTR(PAD_SVl(PL_op->op_targ));
1085 ENTER_with_name("grep_item"); /* enter inner scope */
1088 src = PL_stack_base[*PL_markstack_ptr];
1090 if (PL_op->op_private & OPpGREP_LEX)
1091 PAD_SVl(PL_op->op_targ) = src;
1096 if (PL_op->op_type == OP_MAPSTART)
1097 Perl_pp_pushmark(aTHX); /* push top */
1098 return ((LOGOP*)PL_op->op_next)->op_other;
1104 const I32 gimme = GIMME_V;
1105 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1111 /* first, move source pointer to the next item in the source list */
1112 ++PL_markstack_ptr[-1];
1114 /* if there are new items, push them into the destination list */
1115 if (items && gimme != G_VOID) {
1116 /* might need to make room back there first */
1117 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1118 /* XXX this implementation is very pessimal because the stack
1119 * is repeatedly extended for every set of items. Is possible
1120 * to do this without any stack extension or copying at all
1121 * by maintaining a separate list over which the map iterates
1122 * (like foreach does). --gsar */
1124 /* everything in the stack after the destination list moves
1125 * towards the end the stack by the amount of room needed */
1126 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1128 /* items to shift up (accounting for the moved source pointer) */
1129 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1131 /* This optimization is by Ben Tilly and it does
1132 * things differently from what Sarathy (gsar)
1133 * is describing. The downside of this optimization is
1134 * that leaves "holes" (uninitialized and hopefully unused areas)
1135 * to the Perl stack, but on the other hand this
1136 * shouldn't be a problem. If Sarathy's idea gets
1137 * implemented, this optimization should become
1138 * irrelevant. --jhi */
1140 shift = count; /* Avoid shifting too often --Ben Tilly */
1144 dst = (SP += shift);
1145 PL_markstack_ptr[-1] += shift;
1146 *PL_markstack_ptr += shift;
1150 /* copy the new items down to the destination list */
1151 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1152 if (gimme == G_ARRAY) {
1153 /* add returned items to the collection (making mortal copies
1154 * if necessary), then clear the current temps stack frame
1155 * *except* for those items. We do this splicing the items
1156 * into the start of the tmps frame (so some items may be on
1157 * the tmps stack twice), then moving PL_tmps_floor above
1158 * them, then freeing the frame. That way, the only tmps that
1159 * accumulate over iterations are the return values for map.
1160 * We have to do to this way so that everything gets correctly
1161 * freed if we die during the map.
1165 /* make space for the slice */
1166 EXTEND_MORTAL(items);
1167 tmpsbase = PL_tmps_floor + 1;
1168 Move(PL_tmps_stack + tmpsbase,
1169 PL_tmps_stack + tmpsbase + items,
1170 PL_tmps_ix - PL_tmps_floor,
1172 PL_tmps_ix += items;
1177 sv = sv_mortalcopy(sv);
1179 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1181 /* clear the stack frame except for the items */
1182 PL_tmps_floor += items;
1184 /* FREETMPS may have cleared the TEMP flag on some of the items */
1187 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1190 /* scalar context: we don't care about which values map returns
1191 * (we use undef here). And so we certainly don't want to do mortal
1192 * copies of meaningless values. */
1193 while (items-- > 0) {
1195 *dst-- = &PL_sv_undef;
1203 LEAVE_with_name("grep_item"); /* exit inner scope */
1206 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1208 (void)POPMARK; /* pop top */
1209 LEAVE_with_name("grep"); /* exit outer scope */
1210 (void)POPMARK; /* pop src */
1211 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1212 (void)POPMARK; /* pop dst */
1213 SP = PL_stack_base + POPMARK; /* pop original mark */
1214 if (gimme == G_SCALAR) {
1215 if (PL_op->op_private & OPpGREP_LEX) {
1216 SV* sv = sv_newmortal();
1217 sv_setiv(sv, items);
1225 else if (gimme == G_ARRAY)
1232 ENTER_with_name("grep_item"); /* enter inner scope */
1235 /* set $_ to the new source item */
1236 src = PL_stack_base[PL_markstack_ptr[-1]];
1238 if (PL_op->op_private & OPpGREP_LEX)
1239 PAD_SVl(PL_op->op_targ) = src;
1243 RETURNOP(cLOGOP->op_other);
1252 if (GIMME == G_ARRAY)
1254 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1255 return cLOGOP->op_other;
1265 if (GIMME == G_ARRAY) {
1266 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1270 SV * const targ = PAD_SV(PL_op->op_targ);
1273 if (PL_op->op_private & OPpFLIP_LINENUM) {
1274 if (GvIO(PL_last_in_gv)) {
1275 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1278 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1280 flip = SvIV(sv) == SvIV(GvSV(gv));
1286 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1287 if (PL_op->op_flags & OPf_SPECIAL) {
1295 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1298 sv_setpvs(TARG, "");
1304 /* This code tries to decide if "$left .. $right" should use the
1305 magical string increment, or if the range is numeric (we make
1306 an exception for .."0" [#18165]). AMS 20021031. */
1308 #define RANGE_IS_NUMERIC(left,right) ( \
1309 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1310 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1311 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1312 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1313 && (!SvOK(right) || looks_like_number(right))))
1319 if (GIMME == G_ARRAY) {
1325 if (RANGE_IS_NUMERIC(left,right)) {
1328 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1329 (SvOK(right) && SvNV(right) > IV_MAX))
1330 DIE(aTHX_ "Range iterator outside integer range");
1341 SV * const sv = sv_2mortal(newSViv(i++));
1346 SV * const final = sv_mortalcopy(right);
1348 const char * const tmps = SvPV_const(final, len);
1350 SV *sv = sv_mortalcopy(left);
1351 SvPV_force_nolen(sv);
1352 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1354 if (strEQ(SvPVX_const(sv),tmps))
1356 sv = sv_2mortal(newSVsv(sv));
1363 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1367 if (PL_op->op_private & OPpFLIP_LINENUM) {
1368 if (GvIO(PL_last_in_gv)) {
1369 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1372 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1373 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1381 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1382 sv_catpvs(targ, "E0");
1392 static const char * const context_name[] = {
1394 NULL, /* CXt_WHEN never actually needs "block" */
1395 NULL, /* CXt_BLOCK never actually needs "block" */
1396 NULL, /* CXt_GIVEN never actually needs "block" */
1397 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1398 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1399 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1400 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1408 S_dopoptolabel(pTHX_ const char *label)
1413 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1415 for (i = cxstack_ix; i >= 0; i--) {
1416 register const PERL_CONTEXT * const cx = &cxstack[i];
1417 switch (CxTYPE(cx)) {
1423 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1424 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1425 if (CxTYPE(cx) == CXt_NULL)
1428 case CXt_LOOP_LAZYIV:
1429 case CXt_LOOP_LAZYSV:
1431 case CXt_LOOP_PLAIN:
1433 const char *cx_label = CxLABEL(cx);
1434 if (!cx_label || strNE(label, cx_label) ) {
1435 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1436 (long)i, cx_label));
1439 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1450 Perl_dowantarray(pTHX)
1453 const I32 gimme = block_gimme();
1454 return (gimme == G_VOID) ? G_SCALAR : gimme;
1458 Perl_block_gimme(pTHX)
1461 const I32 cxix = dopoptosub(cxstack_ix);
1465 switch (cxstack[cxix].blk_gimme) {
1473 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1480 Perl_is_lvalue_sub(pTHX)
1483 const I32 cxix = dopoptosub(cxstack_ix);
1484 assert(cxix >= 0); /* We should only be called from inside subs */
1486 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1487 return CxLVAL(cxstack + cxix);
1493 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1498 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1500 for (i = startingblock; i >= 0; i--) {
1501 register const PERL_CONTEXT * const cx = &cxstk[i];
1502 switch (CxTYPE(cx)) {
1508 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1516 S_dopoptoeval(pTHX_ I32 startingblock)
1520 for (i = startingblock; i >= 0; i--) {
1521 register const PERL_CONTEXT *cx = &cxstack[i];
1522 switch (CxTYPE(cx)) {
1526 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1534 S_dopoptoloop(pTHX_ I32 startingblock)
1538 for (i = startingblock; i >= 0; i--) {
1539 register const PERL_CONTEXT * const cx = &cxstack[i];
1540 switch (CxTYPE(cx)) {
1546 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1547 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1548 if ((CxTYPE(cx)) == CXt_NULL)
1551 case CXt_LOOP_LAZYIV:
1552 case CXt_LOOP_LAZYSV:
1554 case CXt_LOOP_PLAIN:
1555 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1563 S_dopoptogiven(pTHX_ I32 startingblock)
1567 for (i = startingblock; i >= 0; i--) {
1568 register const PERL_CONTEXT *cx = &cxstack[i];
1569 switch (CxTYPE(cx)) {
1573 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1575 case CXt_LOOP_PLAIN:
1576 assert(!CxFOREACHDEF(cx));
1578 case CXt_LOOP_LAZYIV:
1579 case CXt_LOOP_LAZYSV:
1581 if (CxFOREACHDEF(cx)) {
1582 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1591 S_dopoptowhen(pTHX_ I32 startingblock)
1595 for (i = startingblock; i >= 0; i--) {
1596 register const PERL_CONTEXT *cx = &cxstack[i];
1597 switch (CxTYPE(cx)) {
1601 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1609 Perl_dounwind(pTHX_ I32 cxix)
1614 while (cxstack_ix > cxix) {
1616 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1617 DEBUG_CX("UNWIND"); \
1618 /* Note: we don't need to restore the base context info till the end. */
1619 switch (CxTYPE(cx)) {
1622 continue; /* not break */
1630 case CXt_LOOP_LAZYIV:
1631 case CXt_LOOP_LAZYSV:
1633 case CXt_LOOP_PLAIN:
1644 PERL_UNUSED_VAR(optype);
1648 Perl_qerror(pTHX_ SV *err)
1652 PERL_ARGS_ASSERT_QERROR;
1655 if (PL_in_eval & EVAL_KEEPERR) {
1656 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1657 SvPV_nolen_const(err));
1660 sv_catsv(ERRSV, err);
1663 sv_catsv(PL_errors, err);
1665 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1667 ++PL_parser->error_count;
1671 Perl_die_unwind(pTHX_ SV *msv)
1674 SV *exceptsv = sv_mortalcopy(msv);
1675 U8 in_eval = PL_in_eval;
1676 PERL_ARGS_ASSERT_DIE_UNWIND;
1683 * Historically, perl used to set ERRSV ($@) early in the die
1684 * process and rely on it not getting clobbered during unwinding.
1685 * That sucked, because it was liable to get clobbered, so the
1686 * setting of ERRSV used to emit the exception from eval{} has
1687 * been moved to much later, after unwinding (see just before
1688 * JMPENV_JUMP below). However, some modules were relying on the
1689 * early setting, by examining $@ during unwinding to use it as
1690 * a flag indicating whether the current unwinding was caused by
1691 * an exception. It was never a reliable flag for that purpose,
1692 * being totally open to false positives even without actual
1693 * clobberage, but was useful enough for production code to
1694 * semantically rely on it.
1696 * We'd like to have a proper introspective interface that
1697 * explicitly describes the reason for whatever unwinding
1698 * operations are currently in progress, so that those modules
1699 * work reliably and $@ isn't further overloaded. But we don't
1700 * have one yet. In its absence, as a stopgap measure, ERRSV is
1701 * now *additionally* set here, before unwinding, to serve as the
1702 * (unreliable) flag that it used to.
1704 * This behaviour is temporary, and should be removed when a
1705 * proper way to detect exceptional unwinding has been developed.
1706 * As of 2010-12, the authors of modules relying on the hack
1707 * are aware of the issue, because the modules failed on
1708 * perls 5.13.{1..7} which had late setting of $@ without this
1709 * early-setting hack.
1711 if (!(in_eval & EVAL_KEEPERR)) {
1712 SvTEMP_off(exceptsv);
1713 sv_setsv(ERRSV, exceptsv);
1716 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1717 && PL_curstackinfo->si_prev)
1726 register PERL_CONTEXT *cx;
1729 JMPENV *restartjmpenv;
1732 if (cxix < cxstack_ix)
1735 POPBLOCK(cx,PL_curpm);
1736 if (CxTYPE(cx) != CXt_EVAL) {
1738 const char* message = SvPVx_const(exceptsv, msglen);
1739 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1740 PerlIO_write(Perl_error_log, message, msglen);
1744 namesv = cx->blk_eval.old_namesv;
1745 oldcop = cx->blk_oldcop;
1746 restartjmpenv = cx->blk_eval.cur_top_env;
1747 restartop = cx->blk_eval.retop;
1749 if (gimme == G_SCALAR)
1750 *++newsp = &PL_sv_undef;
1751 PL_stack_sp = newsp;
1755 /* LEAVE could clobber PL_curcop (see save_re_context())
1756 * XXX it might be better to find a way to avoid messing with
1757 * PL_curcop in save_re_context() instead, but this is a more
1758 * minimal fix --GSAR */
1761 if (optype == OP_REQUIRE) {
1762 const char* const msg = SvPVx_nolen_const(exceptsv);
1763 (void)hv_store(GvHVn(PL_incgv),
1764 SvPVX_const(namesv), SvCUR(namesv),
1766 /* note that unlike pp_entereval, pp_require isn't
1767 * supposed to trap errors. So now that we've popped the
1768 * EVAL that pp_require pushed, and processed the error
1769 * message, rethrow the error */
1770 Perl_croak(aTHX_ "%sCompilation failed in require",
1771 *msg ? msg : "Unknown error\n");
1773 if (in_eval & EVAL_KEEPERR) {
1774 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1775 SvPV_nolen_const(exceptsv));
1778 sv_setsv(ERRSV, exceptsv);
1780 PL_restartjmpenv = restartjmpenv;
1781 PL_restartop = restartop;
1787 write_to_stderr(exceptsv);
1794 dVAR; dSP; dPOPTOPssrl;
1795 if (SvTRUE(left) != SvTRUE(right))
1802 =for apidoc caller_cx
1804 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1805 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1806 information returned to Perl by C<caller>. Note that XSUBs don't get a
1807 stack frame, so C<caller_cx(0, NULL)> will return information for the
1808 immediately-surrounding Perl code.
1810 This function skips over the automatic calls to C<&DB::sub> made on the
1811 behalf of the debugger. If the stack frame requested was a sub called by
1812 C<DB::sub>, the return value will be the frame for the call to
1813 C<DB::sub>, since that has the correct line number/etc. for the call
1814 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1815 frame for the sub call itself.
1820 const PERL_CONTEXT *
1821 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1823 register I32 cxix = dopoptosub(cxstack_ix);
1824 register const PERL_CONTEXT *cx;
1825 register const PERL_CONTEXT *ccstack = cxstack;
1826 const PERL_SI *top_si = PL_curstackinfo;
1829 /* we may be in a higher stacklevel, so dig down deeper */
1830 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1831 top_si = top_si->si_prev;
1832 ccstack = top_si->si_cxstack;
1833 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1837 /* caller() should not report the automatic calls to &DB::sub */
1838 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1839 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1843 cxix = dopoptosub_at(ccstack, cxix - 1);
1846 cx = &ccstack[cxix];
1847 if (dbcxp) *dbcxp = cx;
1849 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1850 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1851 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1852 field below is defined for any cx. */
1853 /* caller() should not report the automatic calls to &DB::sub */
1854 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1855 cx = &ccstack[dbcxix];
1865 register const PERL_CONTEXT *cx;
1866 const PERL_CONTEXT *dbcx;
1868 const char *stashname;
1874 cx = caller_cx(count, &dbcx);
1876 if (GIMME != G_ARRAY) {
1883 stashname = CopSTASHPV(cx->blk_oldcop);
1884 if (GIMME != G_ARRAY) {
1887 PUSHs(&PL_sv_undef);
1890 sv_setpv(TARG, stashname);
1899 PUSHs(&PL_sv_undef);
1901 mPUSHs(newSVpv(stashname, 0));
1902 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1903 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1906 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1907 GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1908 /* So is ccstack[dbcxix]. */
1910 SV * const sv = newSV(0);
1911 gv_efullname3(sv, cvgv, NULL);
1913 PUSHs(boolSV(CxHASARGS(cx)));
1916 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1917 PUSHs(boolSV(CxHASARGS(cx)));
1921 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1924 gimme = (I32)cx->blk_gimme;
1925 if (gimme == G_VOID)
1926 PUSHs(&PL_sv_undef);
1928 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1929 if (CxTYPE(cx) == CXt_EVAL) {
1931 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1932 PUSHs(cx->blk_eval.cur_text);
1936 else if (cx->blk_eval.old_namesv) {
1937 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1940 /* eval BLOCK (try blocks have old_namesv == 0) */
1942 PUSHs(&PL_sv_undef);
1943 PUSHs(&PL_sv_undef);
1947 PUSHs(&PL_sv_undef);
1948 PUSHs(&PL_sv_undef);
1950 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1951 && CopSTASH_eq(PL_curcop, PL_debstash))
1953 AV * const ary = cx->blk_sub.argarray;
1954 const int off = AvARRAY(ary) - AvALLOC(ary);
1957 Perl_init_dbargs(aTHX);
1959 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1960 av_extend(PL_dbargs, AvFILLp(ary) + off);
1961 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1962 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1964 /* XXX only hints propagated via op_private are currently
1965 * visible (others are not easily accessible, since they
1966 * use the global PL_hints) */
1967 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1970 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1972 if (old_warnings == pWARN_NONE ||
1973 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1974 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1975 else if (old_warnings == pWARN_ALL ||
1976 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1977 /* Get the bit mask for $warnings::Bits{all}, because
1978 * it could have been extended by warnings::register */
1980 HV * const bits = get_hv("warnings::Bits", 0);
1981 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1982 mask = newSVsv(*bits_all);
1985 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1989 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1993 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1994 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
2003 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
2004 sv_reset(tmps, CopSTASH(PL_curcop));
2009 /* like pp_nextstate, but used instead when the debugger is active */
2014 PL_curcop = (COP*)PL_op;
2015 TAINT_NOT; /* Each statement is presumed innocent */
2016 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
2021 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2022 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
2025 register PERL_CONTEXT *cx;
2026 const I32 gimme = G_ARRAY;
2028 GV * const gv = PL_DBgv;
2029 register CV * const cv = GvCV(gv);
2032 DIE(aTHX_ "No DB::DB routine defined");
2034 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2035 /* don't do recursive DB::DB call */
2050 (void)(*CvXSUB(cv))(aTHX_ cv);
2057 PUSHBLOCK(cx, CXt_SUB, SP);
2059 cx->blk_sub.retop = PL_op->op_next;
2062 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
2063 RETURNOP(CvSTART(cv));
2073 register PERL_CONTEXT *cx;
2074 const I32 gimme = GIMME_V;
2075 void *itervar; /* location of the iteration variable */
2076 U8 cxtype = CXt_LOOP_FOR;
2078 ENTER_with_name("loop1");
2081 if (PL_op->op_targ) { /* "my" variable */
2082 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2083 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2084 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2085 SVs_PADSTALE, SVs_PADSTALE);
2087 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2089 itervar = PL_comppad;
2091 itervar = &PAD_SVl(PL_op->op_targ);
2094 else { /* symbol table variable */
2095 GV * const gv = MUTABLE_GV(POPs);
2096 SV** svp = &GvSV(gv);
2097 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2099 itervar = (void *)gv;
2102 if (PL_op->op_private & OPpITER_DEF)
2103 cxtype |= CXp_FOR_DEF;
2105 ENTER_with_name("loop2");
2107 PUSHBLOCK(cx, cxtype, SP);
2108 PUSHLOOP_FOR(cx, itervar, MARK);
2109 if (PL_op->op_flags & OPf_STACKED) {
2110 SV *maybe_ary = POPs;
2111 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2113 SV * const right = maybe_ary;
2116 if (RANGE_IS_NUMERIC(sv,right)) {
2117 cx->cx_type &= ~CXTYPEMASK;
2118 cx->cx_type |= CXt_LOOP_LAZYIV;
2119 /* Make sure that no-one re-orders cop.h and breaks our
2121 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2122 #ifdef NV_PRESERVES_UV
2123 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
2124 (SvNV(sv) > (NV)IV_MAX)))
2126 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
2127 (SvNV(right) < (NV)IV_MIN))))
2129 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
2132 ((SvUV(sv) > (UV)IV_MAX) ||
2133 (SvNV(sv) > (NV)UV_MAX)))))
2135 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
2137 ((SvNV(right) > 0) &&
2138 ((SvUV(right) > (UV)IV_MAX) ||
2139 (SvNV(right) > (NV)UV_MAX))))))
2141 DIE(aTHX_ "Range iterator outside integer range");
2142 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
2143 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
2145 /* for correct -Dstv display */
2146 cx->blk_oldsp = sp - PL_stack_base;
2150 cx->cx_type &= ~CXTYPEMASK;
2151 cx->cx_type |= CXt_LOOP_LAZYSV;
2152 /* Make sure that no-one re-orders cop.h and breaks our
2154 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2155 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2156 cx->blk_loop.state_u.lazysv.end = right;
2157 SvREFCNT_inc(right);
2158 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2159 /* This will do the upgrade to SVt_PV, and warn if the value
2160 is uninitialised. */
2161 (void) SvPV_nolen_const(right);
2162 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2163 to replace !SvOK() with a pointer to "". */
2165 SvREFCNT_dec(right);
2166 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2170 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2171 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2172 SvREFCNT_inc(maybe_ary);
2173 cx->blk_loop.state_u.ary.ix =
2174 (PL_op->op_private & OPpITER_REVERSED) ?
2175 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2179 else { /* iterating over items on the stack */
2180 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2181 if (PL_op->op_private & OPpITER_REVERSED) {
2182 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2185 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2195 register PERL_CONTEXT *cx;
2196 const I32 gimme = GIMME_V;
2198 ENTER_with_name("loop1");
2200 ENTER_with_name("loop2");
2202 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2203 PUSHLOOP_PLAIN(cx, SP);
2211 register PERL_CONTEXT *cx;
2218 assert(CxTYPE_is_LOOP(cx));
2220 newsp = PL_stack_base + cx->blk_loop.resetsp;
2223 if (gimme == G_VOID)
2225 else if (gimme == G_SCALAR) {
2227 *++newsp = sv_mortalcopy(*SP);
2229 *++newsp = &PL_sv_undef;
2233 *++newsp = sv_mortalcopy(*++mark);
2234 TAINT_NOT; /* Each item is independent */
2240 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2241 PL_curpm = newpm; /* ... and pop $1 et al */
2243 LEAVE_with_name("loop2");
2244 LEAVE_with_name("loop1");
2252 register PERL_CONTEXT *cx;
2253 bool popsub2 = FALSE;
2254 bool clear_errsv = FALSE;
2263 const I32 cxix = dopoptosub(cxstack_ix);
2266 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2267 * sort block, which is a CXt_NULL
2270 PL_stack_base[1] = *PL_stack_sp;
2271 PL_stack_sp = PL_stack_base + 1;
2275 DIE(aTHX_ "Can't return outside a subroutine");
2277 if (cxix < cxstack_ix)
2280 if (CxMULTICALL(&cxstack[cxix])) {
2281 gimme = cxstack[cxix].blk_gimme;
2282 if (gimme == G_VOID)
2283 PL_stack_sp = PL_stack_base;
2284 else if (gimme == G_SCALAR) {
2285 PL_stack_base[1] = *PL_stack_sp;
2286 PL_stack_sp = PL_stack_base + 1;
2292 switch (CxTYPE(cx)) {
2295 retop = cx->blk_sub.retop;
2296 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2299 if (!(PL_in_eval & EVAL_KEEPERR))
2302 namesv = cx->blk_eval.old_namesv;
2303 retop = cx->blk_eval.retop;
2306 if (optype == OP_REQUIRE &&
2307 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2309 /* Unassume the success we assumed earlier. */
2310 (void)hv_delete(GvHVn(PL_incgv),
2311 SvPVX_const(namesv), SvCUR(namesv),
2313 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2318 retop = cx->blk_sub.retop;
2321 DIE(aTHX_ "panic: return");
2325 if (gimme == G_SCALAR) {
2328 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2330 *++newsp = SvREFCNT_inc(*SP);
2335 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2337 *++newsp = sv_mortalcopy(sv);
2342 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2345 *++newsp = sv_mortalcopy(*SP);
2348 *++newsp = &PL_sv_undef;
2350 else if (gimme == G_ARRAY) {
2351 while (++MARK <= SP) {
2352 *++newsp = (popsub2 && SvTEMP(*MARK))
2353 ? *MARK : sv_mortalcopy(*MARK);
2354 TAINT_NOT; /* Each item is independent */
2357 PL_stack_sp = newsp;
2360 /* Stack values are safe: */
2363 POPSUB(cx,sv); /* release CV and @_ ... */
2367 PL_curpm = newpm; /* ... and pop $1 et al */
2380 register PERL_CONTEXT *cx;
2391 if (PL_op->op_flags & OPf_SPECIAL) {
2392 cxix = dopoptoloop(cxstack_ix);
2394 DIE(aTHX_ "Can't \"last\" outside a loop block");
2397 cxix = dopoptolabel(cPVOP->op_pv);
2399 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2401 if (cxix < cxstack_ix)
2405 cxstack_ix++; /* temporarily protect top context */
2407 switch (CxTYPE(cx)) {
2408 case CXt_LOOP_LAZYIV:
2409 case CXt_LOOP_LAZYSV:
2411 case CXt_LOOP_PLAIN:
2413 newsp = PL_stack_base + cx->blk_loop.resetsp;
2414 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2418 nextop = cx->blk_sub.retop;
2422 nextop = cx->blk_eval.retop;
2426 nextop = cx->blk_sub.retop;
2429 DIE(aTHX_ "panic: last");
2433 if (gimme == G_SCALAR) {
2435 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2436 ? *SP : sv_mortalcopy(*SP);
2438 *++newsp = &PL_sv_undef;
2440 else if (gimme == G_ARRAY) {
2441 while (++MARK <= SP) {
2442 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2443 ? *MARK : sv_mortalcopy(*MARK);
2444 TAINT_NOT; /* Each item is independent */
2452 /* Stack values are safe: */
2454 case CXt_LOOP_LAZYIV:
2455 case CXt_LOOP_PLAIN:
2456 case CXt_LOOP_LAZYSV:
2458 POPLOOP(cx); /* release loop vars ... */
2462 POPSUB(cx,sv); /* release CV and @_ ... */
2465 PL_curpm = newpm; /* ... and pop $1 et al */
2468 PERL_UNUSED_VAR(optype);
2469 PERL_UNUSED_VAR(gimme);
2477 register PERL_CONTEXT *cx;
2480 if (PL_op->op_flags & OPf_SPECIAL) {
2481 cxix = dopoptoloop(cxstack_ix);
2483 DIE(aTHX_ "Can't \"next\" outside a loop block");
2486 cxix = dopoptolabel(cPVOP->op_pv);
2488 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2490 if (cxix < cxstack_ix)
2493 /* clear off anything above the scope we're re-entering, but
2494 * save the rest until after a possible continue block */
2495 inner = PL_scopestack_ix;
2497 if (PL_scopestack_ix < inner)
2498 leave_scope(PL_scopestack[PL_scopestack_ix]);
2499 PL_curcop = cx->blk_oldcop;
2500 return (cx)->blk_loop.my_op->op_nextop;
2507 register PERL_CONTEXT *cx;
2511 if (PL_op->op_flags & OPf_SPECIAL) {
2512 cxix = dopoptoloop(cxstack_ix);
2514 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2517 cxix = dopoptolabel(cPVOP->op_pv);
2519 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2521 if (cxix < cxstack_ix)
2524 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2525 if (redo_op->op_type == OP_ENTER) {
2526 /* pop one less context to avoid $x being freed in while (my $x..) */
2528 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2529 redo_op = redo_op->op_next;
2533 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2534 LEAVE_SCOPE(oldsave);
2536 PL_curcop = cx->blk_oldcop;
2541 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2545 static const char too_deep[] = "Target of goto is too deeply nested";
2547 PERL_ARGS_ASSERT_DOFINDLABEL;
2550 Perl_croak(aTHX_ too_deep);
2551 if (o->op_type == OP_LEAVE ||
2552 o->op_type == OP_SCOPE ||
2553 o->op_type == OP_LEAVELOOP ||
2554 o->op_type == OP_LEAVESUB ||
2555 o->op_type == OP_LEAVETRY)
2557 *ops++ = cUNOPo->op_first;
2559 Perl_croak(aTHX_ too_deep);
2562 if (o->op_flags & OPf_KIDS) {
2564 /* First try all the kids at this level, since that's likeliest. */
2565 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2566 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2567 const char *kid_label = CopLABEL(kCOP);
2568 if (kid_label && strEQ(kid_label, label))
2572 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2573 if (kid == PL_lastgotoprobe)
2575 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2578 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2579 ops[-1]->op_type == OP_DBSTATE)
2584 if ((o = dofindlabel(kid, label, ops, oplimit)))
2597 register PERL_CONTEXT *cx;
2598 #define GOTO_DEPTH 64
2599 OP *enterops[GOTO_DEPTH];
2600 const char *label = NULL;
2601 const bool do_dump = (PL_op->op_type == OP_DUMP);
2602 static const char must_have_label[] = "goto must have label";
2604 if (PL_op->op_flags & OPf_STACKED) {
2605 SV * const sv = POPs;
2607 /* This egregious kludge implements goto &subroutine */
2608 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2610 register PERL_CONTEXT *cx;
2611 CV *cv = MUTABLE_CV(SvRV(sv));
2618 if (!CvROOT(cv) && !CvXSUB(cv)) {
2619 const GV * const gv = CvGV(cv);
2623 /* autoloaded stub? */
2624 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2626 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2627 GvNAMELEN(gv), FALSE);
2628 if (autogv && (cv = GvCV(autogv)))
2630 tmpstr = sv_newmortal();
2631 gv_efullname3(tmpstr, gv, NULL);
2632 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2634 DIE(aTHX_ "Goto undefined subroutine");
2637 /* First do some returnish stuff. */
2638 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2640 cxix = dopoptosub(cxstack_ix);
2642 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2643 if (cxix < cxstack_ix)
2647 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2648 if (CxTYPE(cx) == CXt_EVAL) {
2650 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2652 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2654 else if (CxMULTICALL(cx))
2655 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2656 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2657 /* put @_ back onto stack */
2658 AV* av = cx->blk_sub.argarray;
2660 items = AvFILLp(av) + 1;
2661 EXTEND(SP, items+1); /* @_ could have been extended. */
2662 Copy(AvARRAY(av), SP + 1, items, SV*);
2663 SvREFCNT_dec(GvAV(PL_defgv));
2664 GvAV(PL_defgv) = cx->blk_sub.savearray;
2666 /* abandon @_ if it got reified */
2671 av_extend(av, items-1);
2673 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2676 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2677 AV* const av = GvAV(PL_defgv);
2678 items = AvFILLp(av) + 1;
2679 EXTEND(SP, items+1); /* @_ could have been extended. */
2680 Copy(AvARRAY(av), SP + 1, items, SV*);
2684 if (CxTYPE(cx) == CXt_SUB &&
2685 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2686 SvREFCNT_dec(cx->blk_sub.cv);
2687 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2688 LEAVE_SCOPE(oldsave);
2690 /* Now do some callish stuff. */
2692 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2694 OP* const retop = cx->blk_sub.retop;
2699 for (index=0; index<items; index++)
2700 sv_2mortal(SP[-index]);
2703 /* XS subs don't have a CxSUB, so pop it */
2704 POPBLOCK(cx, PL_curpm);
2705 /* Push a mark for the start of arglist */
2708 (void)(*CvXSUB(cv))(aTHX_ cv);
2713 AV* const padlist = CvPADLIST(cv);
2714 if (CxTYPE(cx) == CXt_EVAL) {
2715 PL_in_eval = CxOLD_IN_EVAL(cx);
2716 PL_eval_root = cx->blk_eval.old_eval_root;
2717 cx->cx_type = CXt_SUB;
2719 cx->blk_sub.cv = cv;
2720 cx->blk_sub.olddepth = CvDEPTH(cv);
2723 if (CvDEPTH(cv) < 2)
2724 SvREFCNT_inc_simple_void_NN(cv);
2726 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2727 sub_crush_depth(cv);
2728 pad_push(padlist, CvDEPTH(cv));
2731 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2734 AV *const av = MUTABLE_AV(PAD_SVl(0));
2736 cx->blk_sub.savearray = GvAV(PL_defgv);
2737 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2738 CX_CURPAD_SAVE(cx->blk_sub);
2739 cx->blk_sub.argarray = av;
2741 if (items >= AvMAX(av) + 1) {
2742 SV **ary = AvALLOC(av);
2743 if (AvARRAY(av) != ary) {
2744 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2747 if (items >= AvMAX(av) + 1) {
2748 AvMAX(av) = items - 1;
2749 Renew(ary,items+1,SV*);
2755 Copy(mark,AvARRAY(av),items,SV*);
2756 AvFILLp(av) = items - 1;
2757 assert(!AvREAL(av));
2759 /* transfer 'ownership' of refcnts to new @_ */
2769 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2770 Perl_get_db_sub(aTHX_ NULL, cv);
2772 CV * const gotocv = get_cvs("DB::goto", 0);
2774 PUSHMARK( PL_stack_sp );
2775 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2780 RETURNOP(CvSTART(cv));
2784 label = SvPV_nolen_const(sv);
2785 if (!(do_dump || *label))
2786 DIE(aTHX_ must_have_label);
2789 else if (PL_op->op_flags & OPf_SPECIAL) {
2791 DIE(aTHX_ must_have_label);
2794 label = cPVOP->op_pv;
2798 if (label && *label) {
2799 OP *gotoprobe = NULL;
2800 bool leaving_eval = FALSE;
2801 bool in_block = FALSE;
2802 PERL_CONTEXT *last_eval_cx = NULL;
2806 PL_lastgotoprobe = NULL;
2808 for (ix = cxstack_ix; ix >= 0; ix--) {
2810 switch (CxTYPE(cx)) {
2812 leaving_eval = TRUE;
2813 if (!CxTRYBLOCK(cx)) {
2814 gotoprobe = (last_eval_cx ?
2815 last_eval_cx->blk_eval.old_eval_root :
2820 /* else fall through */
2821 case CXt_LOOP_LAZYIV:
2822 case CXt_LOOP_LAZYSV:
2824 case CXt_LOOP_PLAIN:
2827 gotoprobe = cx->blk_oldcop->op_sibling;
2833 gotoprobe = cx->blk_oldcop->op_sibling;
2836 gotoprobe = PL_main_root;
2839 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2840 gotoprobe = CvROOT(cx->blk_sub.cv);
2846 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2849 DIE(aTHX_ "panic: goto");
2850 gotoprobe = PL_main_root;
2854 retop = dofindlabel(gotoprobe, label,
2855 enterops, enterops + GOTO_DEPTH);
2858 if (gotoprobe->op_sibling &&
2859 gotoprobe->op_sibling->op_type == OP_UNSTACK &&
2860 gotoprobe->op_sibling->op_sibling) {
2861 retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
2862 label, enterops, enterops + GOTO_DEPTH);
2867 PL_lastgotoprobe = gotoprobe;
2870 DIE(aTHX_ "Can't find label %s", label);
2872 /* if we're leaving an eval, check before we pop any frames
2873 that we're not going to punt, otherwise the error
2876 if (leaving_eval && *enterops && enterops[1]) {
2878 for (i = 1; enterops[i]; i++)
2879 if (enterops[i]->op_type == OP_ENTERITER)
2880 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2883 if (*enterops && enterops[1]) {
2884 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2886 deprecate("\"goto\" to jump into a construct");
2889 /* pop unwanted frames */
2891 if (ix < cxstack_ix) {
2898 oldsave = PL_scopestack[PL_scopestack_ix];
2899 LEAVE_SCOPE(oldsave);
2902 /* push wanted frames */
2904 if (*enterops && enterops[1]) {
2905 OP * const oldop = PL_op;
2906 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2907 for (; enterops[ix]; ix++) {
2908 PL_op = enterops[ix];
2909 /* Eventually we may want to stack the needed arguments
2910 * for each op. For now, we punt on the hard ones. */
2911 if (PL_op->op_type == OP_ENTERITER)
2912 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2913 PL_op->op_ppaddr(aTHX);
2921 if (!retop) retop = PL_main_start;
2923 PL_restartop = retop;
2924 PL_do_undump = TRUE;
2928 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2929 PL_do_undump = FALSE;
2946 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2948 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2951 PL_exit_flags |= PERL_EXIT_EXPECTED;
2953 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2954 if (anum || !(PL_minus_c && PL_madskills))
2959 PUSHs(&PL_sv_undef);
2966 S_save_lines(pTHX_ AV *array, SV *sv)
2968 const char *s = SvPVX_const(sv);
2969 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2972 PERL_ARGS_ASSERT_SAVE_LINES;
2974 while (s && s < send) {
2976 SV * const tmpstr = newSV_type(SVt_PVMG);
2978 t = (const char *)memchr(s, '\n', send - s);
2984 sv_setpvn(tmpstr, s, t - s);
2985 av_store(array, line++, tmpstr);
2993 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
2995 0 is used as continue inside eval,
2997 3 is used for a die caught by an inner eval - continue inner loop
2999 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3000 establish a local jmpenv to handle exception traps.
3005 S_docatch(pTHX_ OP *o)
3009 OP * const oldop = PL_op;
3013 assert(CATCH_GET == TRUE);
3020 assert(cxstack_ix >= 0);
3021 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3022 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3027 /* die caught by an inner eval - continue inner loop */
3028 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3029 PL_restartjmpenv = NULL;
3030 PL_op = PL_restartop;
3046 /* James Bond: Do you expect me to talk?
3047 Auric Goldfinger: No, Mr. Bond. I expect you to die.
3049 This code is an ugly hack, doesn't work with lexicals in subroutines that are
3050 called more than once, and is only used by regcomp.c, for (?{}) blocks.
3052 Currently it is not used outside the core code. Best if it stays that way.
3054 Hence it's now deprecated, and will be removed.
3057 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
3058 /* sv Text to convert to OP tree. */
3059 /* startop op_free() this to undo. */
3060 /* code Short string id of the caller. */
3062 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
3063 return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
3066 /* Don't use this. It will go away without warning once the regexp engine is
3067 refactored not to use it. */
3069 Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
3072 dVAR; dSP; /* Make POPBLOCK work. */
3078 char tbuf[TYPE_DIGITS(long) + 12 + 10];
3079 char *tmpbuf = tbuf;
3082 CV* runcv = NULL; /* initialise to avoid compiler warnings */
3086 PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
3088 ENTER_with_name("eval");
3089 lex_start(sv, NULL, LEX_START_SAME_FILTER);
3091 /* switch to eval mode */
3093 if (IN_PERL_COMPILETIME) {
3094 SAVECOPSTASH_FREE(&PL_compiling);
3095 CopSTASH_set(&PL_compiling, PL_curstash);
3097 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3098 SV * const sv = sv_newmortal();
3099 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
3100 code, (unsigned long)++PL_evalseq,
3101 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3106 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
3107 (unsigned long)++PL_evalseq);
3108 SAVECOPFILE_FREE(&PL_compiling);
3109 CopFILE_set(&PL_compiling, tmpbuf+2);
3110 SAVECOPLINE(&PL_compiling);
3111 CopLINE_set(&PL_compiling, 1);
3112 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3113 deleting the eval's FILEGV from the stash before gv_check() runs
3114 (i.e. before run-time proper). To work around the coredump that
3115 ensues, we always turn GvMULTI_on for any globals that were
3116 introduced within evals. See force_ident(). GSAR 96-10-12 */
3117 safestr = savepvn(tmpbuf, len);
3118 SAVEDELETE(PL_defstash, safestr, len);
3120 #ifdef OP_IN_REGISTER
3126 /* we get here either during compilation, or via pp_regcomp at runtime */
3127 runtime = IN_PERL_RUNTIME;
3130 runcv = find_runcv(NULL);
3132 /* At run time, we have to fetch the hints from PL_curcop. */
3133 PL_hints = PL_curcop->cop_hints;
3134 if (PL_hints & HINT_LOCALIZE_HH) {
3135 /* SAVEHINTS created a new HV in PL_hintgv, which we
3137 SvREFCNT_dec(GvHV(PL_hintgv));
3139 refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
3140 hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
3142 SAVECOMPILEWARNINGS();
3143 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3144 cophh_free(CopHINTHASH_get(&PL_compiling));
3145 /* XXX Does this need to avoid copying a label? */
3146 PL_compiling.cop_hints_hash
3147 = cophh_copy(PL_curcop->cop_hints_hash);
3151 PL_op->op_type = OP_ENTEREVAL;
3152 PL_op->op_flags = 0; /* Avoid uninit warning. */
3153 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
3155 need_catch = CATCH_GET;
3159 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
3161 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
3162 CATCH_SET(need_catch);
3163 POPBLOCK(cx,PL_curpm);
3166 (*startop)->op_type = OP_NULL;
3167 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
3168 /* XXX DAPM do this properly one year */
3169 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
3170 LEAVE_with_name("eval");
3171 if (IN_PERL_COMPILETIME)
3172 CopHINTS_set(&PL_compiling, PL_hints);
3173 #ifdef OP_IN_REGISTER
3176 PERL_UNUSED_VAR(newsp);
3177 PERL_UNUSED_VAR(optype);
3179 return PL_eval_start;
3184 =for apidoc find_runcv
3186 Locate the CV corresponding to the currently executing sub or eval.
3187 If db_seqp is non_null, skip CVs that are in the DB package and populate
3188 *db_seqp with the cop sequence number at the point that the DB:: code was
3189 entered. (allows debuggers to eval in the scope of the breakpoint rather
3190 than in the scope of the debugger itself).
3196 Perl_find_runcv(pTHX_ U32 *db_seqp)
3202 *db_seqp = PL_curcop->cop_seq;
3203 for (si = PL_curstackinfo; si; si = si->si_prev) {
3205 for (ix = si->si_cxix; ix >= 0; ix--) {
3206 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3207 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3208 CV * const cv = cx->blk_sub.cv;
3209 /* skip DB:: code */
3210 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3211 *db_seqp = cx->blk_oldcop->cop_seq;
3216 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3224 /* Run yyparse() in a setjmp wrapper. Returns:
3225 * 0: yyparse() successful
3226 * 1: yyparse() failed
3230 S_try_yyparse(pTHX_ int gramtype)
3235 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3239 ret = yyparse(gramtype) ? 1 : 0;
3253 /* Compile a require/do, an eval '', or a /(?{...})/.
3254 * In the last case, startop is non-null, and contains the address of
3255 * a pointer that should be set to the just-compiled code.
3256 * outside is the lexically enclosing CV (if any) that invoked us.
3257 * Returns a bool indicating whether the compile was successful; if so,
3258 * PL_eval_start contains the first op of the compiled ocde; otherwise,
3259 * pushes undef (also croaks if startop != NULL).
3263 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3266 OP * const saveop = PL_op;
3267 bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3270 PL_in_eval = (in_require
3271 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3276 SAVESPTR(PL_compcv);
3277 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3278 CvEVAL_on(PL_compcv);
3279 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3280 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3282 CvOUTSIDE_SEQ(PL_compcv) = seq;
3283 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3285 /* set up a scratch pad */
3287 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3288 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3292 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3294 /* make sure we compile in the right package */
3296 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3297 SAVESPTR(PL_curstash);
3298 PL_curstash = CopSTASH(PL_curcop);
3300 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3301 SAVESPTR(PL_beginav);
3302 PL_beginav = newAV();
3303 SAVEFREESV(PL_beginav);
3304 SAVESPTR(PL_unitcheckav);
3305 PL_unitcheckav = newAV();
3306 SAVEFREESV(PL_unitcheckav);
3309 SAVEBOOL(PL_madskills);
3313 /* try to compile it */
3315 PL_eval_root = NULL;
3316 PL_curcop = &PL_compiling;
3317 CopARYBASE_set(PL_curcop, 0);
3318 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3319 PL_in_eval |= EVAL_KEEPERR;
3323 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3325 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3326 * so honour CATCH_GET and trap it here if necessary */
3328 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3330 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3331 SV **newsp; /* Used by POPBLOCK. */
3332 PERL_CONTEXT *cx = NULL;
3333 I32 optype; /* Used by POPEVAL. */
3337 PERL_UNUSED_VAR(newsp);
3338 PERL_UNUSED_VAR(optype);
3340 /* note that if yystatus == 3, then the EVAL CX block has already
3341 * been popped, and various vars restored */
3343 if (yystatus != 3) {
3345 op_free(PL_eval_root);
3346 PL_eval_root = NULL;
3348 SP = PL_stack_base + POPMARK; /* pop original mark */
3350 POPBLOCK(cx,PL_curpm);
3352 namesv = cx->blk_eval.old_namesv;
3356 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3358 msg = SvPVx_nolen_const(ERRSV);
3361 /* If cx is still NULL, it means that we didn't go in the
3362 * POPEVAL branch. */
3363 cx = &cxstack[cxstack_ix];
3364 assert(CxTYPE(cx) == CXt_EVAL);
3365 namesv = cx->blk_eval.old_namesv;
3367 (void)hv_store(GvHVn(PL_incgv),
3368 SvPVX_const(namesv), SvCUR(namesv),
3370 Perl_croak(aTHX_ "%sCompilation failed in require",
3371 *msg ? msg : "Unknown error\n");
3374 if (yystatus != 3) {
3375 POPBLOCK(cx,PL_curpm);
3378 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3379 (*msg ? msg : "Unknown error\n"));
3383 sv_setpvs(ERRSV, "Compilation error");
3386 PUSHs(&PL_sv_undef);
3390 CopLINE_set(&PL_compiling, 0);
3392 *startop = PL_eval_root;
3394 SAVEFREEOP(PL_eval_root);
3396 /* Set the context for this new optree.
3397 * Propagate the context from the eval(). */
3398 if ((gimme & G_WANT) == G_VOID)
3399 scalarvoid(PL_eval_root);
3400 else if ((gimme & G_WANT) == G_ARRAY)
3403 scalar(PL_eval_root);
3405 DEBUG_x(dump_eval());
3407 /* Register with debugger: */
3408 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3409 CV * const cv = get_cvs("DB::postponed", 0);
3413 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3415 call_sv(MUTABLE_SV(cv), G_DISCARD);
3419 if (PL_unitcheckav) {
3420 OP *es = PL_eval_start;
3421 call_list(PL_scopestack_ix, PL_unitcheckav);
3425 /* compiled okay, so do it */
3427 CvDEPTH(PL_compcv) = 1;
3428 SP = PL_stack_base + POPMARK; /* pop original mark */
3429 PL_op = saveop; /* The caller may need it. */
3430 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3437 S_check_type_and_open(pTHX_ SV *name)
3440 const char *p = SvPV_nolen_const(name);
3441 const int st_rc = PerlLIO_stat(p, &st);
3443 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3445 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3449 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3450 return PerlIO_openn(aTHX_ NULL, PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3452 return PerlIO_open(p, PERL_SCRIPT_MODE);
3456 #ifndef PERL_DISABLE_PMC
3458 S_doopen_pm(pTHX_ SV *name)
3461 const char *p = SvPV_const(name, namelen);
3463 PERL_ARGS_ASSERT_DOOPEN_PM;
3465 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3466 SV *const pmcsv = sv_newmortal();
3469 SvSetSV_nosteal(pmcsv,name);
3470 sv_catpvn(pmcsv, "c", 1);
3472 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3473 return check_type_and_open(pmcsv);
3475 return check_type_and_open(name);
3478 # define doopen_pm(name) check_type_and_open(name)
3479 #endif /* !PERL_DISABLE_PMC */
3484 register PERL_CONTEXT *cx;
3491 int vms_unixname = 0;
3493 const char *tryname = NULL;
3495 const I32 gimme = GIMME_V;
3496 int filter_has_file = 0;
3497 PerlIO *tryrsfp = NULL;
3498 SV *filter_cache = NULL;
3499 SV *filter_state = NULL;
3500 SV *filter_sub = NULL;
3506 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3507 sv = sv_2mortal(new_version(sv));
3508 if (!sv_derived_from(PL_patchlevel, "version"))
3509 upg_version(PL_patchlevel, TRUE);
3510 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3511 if ( vcmp(sv,PL_patchlevel) <= 0 )
3512 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3513 SVfARG(sv_2mortal(vnormal(sv))),
3514 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3518 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3521 SV * const req = SvRV(sv);
3522 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3524 /* get the left hand term */
3525 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3527 first = SvIV(*av_fetch(lav,0,0));
3528 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3529 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3530 || av_len(lav) > 1 /* FP with > 3 digits */
3531 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3533 DIE(aTHX_ "Perl %"SVf" required--this is only "
3535 SVfARG(sv_2mortal(vnormal(req))),
3536 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3539 else { /* probably 'use 5.10' or 'use 5.8' */
3544 second = SvIV(*av_fetch(lav,1,0));
3546 second /= second >= 600 ? 100 : 10;
3547 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3548 (int)first, (int)second);
3549 upg_version(hintsv, TRUE);
3551 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3552 "--this is only %"SVf", stopped",
3553 SVfARG(sv_2mortal(vnormal(req))),
3554 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3555 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3563 name = SvPV_const(sv, len);
3564 if (!(name && len > 0 && *name))
3565 DIE(aTHX_ "Null filename used");
3566 TAINT_PROPER("require");
3570 /* The key in the %ENV hash is in the syntax of file passed as the argument
3571 * usually this is in UNIX format, but sometimes in VMS format, which
3572 * can result in a module being pulled in more than once.
3573 * To prevent this, the key must be stored in UNIX format if the VMS
3574 * name can be translated to UNIX.
3576 if ((unixname = tounixspec(name, NULL)) != NULL) {
3577 unixlen = strlen(unixname);
3583 /* if not VMS or VMS name can not be translated to UNIX, pass it
3586 unixname = (char *) name;
3589 if (PL_op->op_type == OP_REQUIRE) {
3590 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3591 unixname, unixlen, 0);
3593 if (*svp != &PL_sv_undef)
3596 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3597 "Compilation failed in require", unixname);
3601 /* prepare to compile file */
3603 if (path_is_absolute(name)) {
3604 /* At this point, name is SvPVX(sv) */
3606 tryrsfp = doopen_pm(sv);
3609 AV * const ar = GvAVn(PL_incgv);
3615 namesv = newSV_type(SVt_PV);
3616 for (i = 0; i <= AvFILL(ar); i++) {
3617 SV * const dirsv = *av_fetch(ar, i, TRUE);
3619 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3626 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3627 && !sv_isobject(loader))
3629 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3632 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3633 PTR2UV(SvRV(dirsv)), name);
3634 tryname = SvPVX_const(namesv);
3637 ENTER_with_name("call_INC");
3645 if (sv_isobject(loader))
3646 count = call_method("INC", G_ARRAY);
3648 count = call_sv(loader, G_ARRAY);
3658 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3659 && !isGV_with_GP(SvRV(arg))) {
3660 filter_cache = SvRV(arg);
3661 SvREFCNT_inc_simple_void_NN(filter_cache);
3668 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3672 if (isGV_with_GP(arg)) {
3673 IO * const io = GvIO((const GV *)arg);
3678 tryrsfp = IoIFP(io);
3679 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3680 PerlIO_close(IoOFP(io));
3691 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3693 SvREFCNT_inc_simple_void_NN(filter_sub);
3696 filter_state = SP[i];
3697 SvREFCNT_inc_simple_void(filter_state);
3701 if (!tryrsfp && (filter_cache || filter_sub)) {
3702 tryrsfp = PerlIO_open(BIT_BUCKET,
3710 LEAVE_with_name("call_INC");
3712 /* Adjust file name if the hook has set an %INC entry.
3713 This needs to happen after the FREETMPS above. */
3714 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3716 tryname = SvPV_nolen_const(*svp);
3723 filter_has_file = 0;
3725 SvREFCNT_dec(filter_cache);
3726 filter_cache = NULL;
3729 SvREFCNT_dec(filter_state);
3730 filter_state = NULL;
3733 SvREFCNT_dec(filter_sub);
3738 if (!path_is_absolute(name)
3744 dir = SvPV_const(dirsv, dirlen);
3752 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3754 sv_setpv(namesv, unixdir);
3755 sv_catpv(namesv, unixname);
3757 # ifdef __SYMBIAN32__
3758 if (PL_origfilename[0] &&
3759 PL_origfilename[1] == ':' &&
3760 !(dir[0] && dir[1] == ':'))
3761 Perl_sv_setpvf(aTHX_ namesv,
3766 Perl_sv_setpvf(aTHX_ namesv,
3770 /* The equivalent of
3771 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3772 but without the need to parse the format string, or
3773 call strlen on either pointer, and with the correct
3774 allocation up front. */
3776 char *tmp = SvGROW(namesv, dirlen + len + 2);
3778 memcpy(tmp, dir, dirlen);
3781 /* name came from an SV, so it will have a '\0' at the
3782 end that we can copy as part of this memcpy(). */
3783 memcpy(tmp, name, len + 1);
3785 SvCUR_set(namesv, dirlen + len + 1);
3790 TAINT_PROPER("require");
3791 tryname = SvPVX_const(namesv);
3792 tryrsfp = doopen_pm(namesv);
3794 if (tryname[0] == '.' && tryname[1] == '/') {
3796 while (*++tryname == '/');
3800 else if (errno == EMFILE)
3801 /* no point in trying other paths if out of handles */
3810 if (PL_op->op_type == OP_REQUIRE) {
3811 if(errno == EMFILE) {
3812 /* diag_listed_as: Can't locate %s */
3813 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(errno));
3815 if (namesv) { /* did we lookup @INC? */
3816 AV * const ar = GvAVn(PL_incgv);
3818 SV *const inc = newSVpvs_flags("", SVs_TEMP);
3819 for (i = 0; i <= AvFILL(ar); i++) {
3820 sv_catpvs(inc, " ");
3821 sv_catsv(inc, *av_fetch(ar, i, TRUE));
3824 /* diag_listed_as: Can't locate %s */
3826 "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
3828 (memEQ(name + len - 2, ".h", 3)
3829 ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
3830 (memEQ(name + len - 3, ".ph", 4)
3831 ? " (did you run h2ph?)" : ""),
3836 DIE(aTHX_ "Can't locate %s", name);
3842 SETERRNO(0, SS_NORMAL);
3844 /* Assume success here to prevent recursive requirement. */
3845 /* name is never assigned to again, so len is still strlen(name) */
3846 /* Check whether a hook in @INC has already filled %INC */
3848 (void)hv_store(GvHVn(PL_incgv),
3849 unixname, unixlen, newSVpv(tryname,0),0);
3851 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3853 (void)hv_store(GvHVn(PL_incgv),
3854 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3857 ENTER_with_name("eval");
3859 SAVECOPFILE_FREE(&PL_compiling);
3860 CopFILE_set(&PL_compiling, tryname);
3861 lex_start(NULL, tryrsfp, 0);
3865 hv_clear(GvHV(PL_hintgv));
3867 SAVECOMPILEWARNINGS();
3868 if (PL_dowarn & G_WARN_ALL_ON)
3869 PL_compiling.cop_warnings = pWARN_ALL ;
3870 else if (PL_dowarn & G_WARN_ALL_OFF)
3871 PL_compiling.cop_warnings = pWARN_NONE ;
3873 PL_compiling.cop_warnings = pWARN_STD ;
3875 if (filter_sub || filter_cache) {
3876 /* We can use the SvPV of the filter PVIO itself as our cache, rather
3877 than hanging another SV from it. In turn, filter_add() optionally
3878 takes the SV to use as the filter (or creates a new SV if passed
3879 NULL), so simply pass in whatever value filter_cache has. */
3880 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3881 IoLINES(datasv) = filter_has_file;
3882 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3883 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3886 /* switch to eval mode */
3887 PUSHBLOCK(cx, CXt_EVAL, SP);
3889 cx->blk_eval.retop = PL_op->op_next;
3891 SAVECOPLINE(&PL_compiling);
3892 CopLINE_set(&PL_compiling, 0);
3896 /* Store and reset encoding. */
3897 encoding = PL_encoding;
3900 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3901 op = DOCATCH(PL_eval_start);
3903 op = PL_op->op_next;
3905 /* Restore encoding. */
3906 PL_encoding = encoding;
3911 /* This is a op added to hold the hints hash for
3912 pp_entereval. The hash can be modified by the code
3913 being eval'ed, so we return a copy instead. */
3919 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
3927 register PERL_CONTEXT *cx;
3929 const I32 gimme = GIMME_V;
3930 const U32 was = PL_breakable_sub_gen;
3931 char tbuf[TYPE_DIGITS(long) + 12];
3932 bool saved_delete = FALSE;
3933 char *tmpbuf = tbuf;
3937 HV *saved_hh = NULL;
3939 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3940 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3944 /* make sure we've got a plain PV (no overload etc) before testing
3945 * for taint. Making a copy here is probably overkill, but better
3946 * safe than sorry */
3948 const char * const p = SvPV_const(sv, len);
3950 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
3953 TAINT_IF(SvTAINTED(sv));
3954 TAINT_PROPER("eval");
3956 ENTER_with_name("eval");
3957 lex_start(sv, NULL, LEX_START_SAME_FILTER);
3960 /* switch to eval mode */
3962 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3963 SV * const temp_sv = sv_newmortal();
3964 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3965 (unsigned long)++PL_evalseq,
3966 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3967 tmpbuf = SvPVX(temp_sv);
3968 len = SvCUR(temp_sv);
3971 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3972 SAVECOPFILE_FREE(&PL_compiling);
3973 CopFILE_set(&PL_compiling, tmpbuf+2);
3974 SAVECOPLINE(&PL_compiling);
3975 CopLINE_set(&PL_compiling, 1);
3976 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3977 deleting the eval's FILEGV from the stash before gv_check() runs
3978 (i.e. before run-time proper). To work around the coredump that
3979 ensues, we always turn GvMULTI_on for any globals that were
3980 introduced within evals. See force_ident(). GSAR 96-10-12 */
3982 PL_hints = PL_op->op_targ;
3984 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3985 SvREFCNT_dec(GvHV(PL_hintgv));
3986 GvHV(PL_hintgv) = saved_hh;
3988 SAVECOMPILEWARNINGS();
3989 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3990 cophh_free(CopHINTHASH_get(&PL_compiling));
3991 if (Perl_fetch_cop_label(aTHX_ PL_curcop, NULL, NULL)) {
3992 /* The label, if present, is the first entry on the chain. So rather
3993 than writing a blank label in front of it (which involves an
3994 allocation), just use the next entry in the chain. */
3995 PL_compiling.cop_hints_hash
3996 = cophh_copy(PL_curcop->cop_hints_hash->refcounted_he_next);
3997 /* Check the assumption that this removed the label. */
3998 assert(Perl_fetch_cop_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
4001 PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash);
4002 /* special case: an eval '' executed within the DB package gets lexically
4003 * placed in the first non-DB CV rather than the current CV - this
4004 * allows the debugger to execute code, find lexicals etc, in the
4005 * scope of the code being debugged. Passing &seq gets find_runcv
4006 * to do the dirty work for us */
4007 runcv = find_runcv(&seq);
4009 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4011 cx->blk_eval.retop = PL_op->op_next;
4013 /* prepare to compile string */
4015 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4016 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4018 char *const safestr = savepvn(tmpbuf, len);
4019 SAVEDELETE(PL_defstash, safestr, len);
4020 saved_delete = TRUE;
4025 if (doeval(gimme, NULL, runcv, seq)) {
4026 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4027 ? (PERLDB_LINE || PERLDB_SAVESRC)
4028 : PERLDB_SAVESRC_NOSUBS) {
4029 /* Retain the filegv we created. */
4030 } else if (!saved_delete) {
4031 char *const safestr = savepvn(tmpbuf, len);
4032 SAVEDELETE(PL_defstash, safestr, len);
4034 return DOCATCH(PL_eval_start);
4036 /* We have already left the scope set up earlier thanks to the LEAVE
4038 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4039 ? (PERLDB_LINE || PERLDB_SAVESRC)
4040 : PERLDB_SAVESRC_INVALID) {
4041 /* Retain the filegv we created. */
4042 } else if (!saved_delete) {
4043 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4045 return PL_op->op_next;
4056 register PERL_CONTEXT *cx;
4058 const U8 save_flags = PL_op -> op_flags;
4065 namesv = cx->blk_eval.old_namesv;
4066 retop = cx->blk_eval.retop;
4069 if (gimme == G_VOID)
4071 else if (gimme == G_SCALAR) {
4074 if (SvFLAGS(TOPs) & SVs_TEMP)
4077 *MARK = sv_mortalcopy(TOPs);
4081 *MARK = &PL_sv_undef;
4086 /* in case LEAVE wipes old return values */
4087 for (mark = newsp + 1; mark <= SP; mark++) {
4088 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
4089 *mark = sv_mortalcopy(*mark);
4090 TAINT_NOT; /* Each item is independent */
4094 PL_curpm = newpm; /* Don't pop $1 et al till now */
4097 assert(CvDEPTH(PL_compcv) == 1);
4099 CvDEPTH(PL_compcv) = 0;
4101 if (optype == OP_REQUIRE &&
4102 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4104 /* Unassume the success we assumed earlier. */
4105 (void)hv_delete(GvHVn(PL_incgv),
4106 SvPVX_const(namesv), SvCUR(namesv),
4108 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4110 /* die_unwind() did LEAVE, or we won't be here */
4113 LEAVE_with_name("eval");
4114 if (!(save_flags & OPf_SPECIAL)) {
4122 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4123 close to the related Perl_create_eval_scope. */
4125 Perl_delete_eval_scope(pTHX)
4130 register PERL_CONTEXT *cx;
4136 LEAVE_with_name("eval_scope");
4137 PERL_UNUSED_VAR(newsp);
4138 PERL_UNUSED_VAR(gimme);
4139 PERL_UNUSED_VAR(optype);
4142 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4143 also needed by Perl_fold_constants. */
4145 Perl_create_eval_scope(pTHX_ U32 flags)
4148 const I32 gimme = GIMME_V;
4150 ENTER_with_name("eval_scope");
4153 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4156 PL_in_eval = EVAL_INEVAL;
4157 if (flags & G_KEEPERR)
4158 PL_in_eval |= EVAL_KEEPERR;
4161 if (flags & G_FAKINGEVAL) {
4162 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4170 PERL_CONTEXT * const cx = create_eval_scope(0);
4171 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4172 return DOCATCH(PL_op->op_next);
4181 register PERL_CONTEXT *cx;
4187 PERL_UNUSED_VAR(optype);
4190 if (gimme == G_VOID)
4192 else if (gimme == G_SCALAR) {
4196 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4199 *MARK = sv_mortalcopy(TOPs);
4203 *MARK = &PL_sv_undef;
4208 /* in case LEAVE wipes old return values */
4210 for (mark = newsp + 1; mark <= SP; mark++) {
4211 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4212 *mark = sv_mortalcopy(*mark);
4213 TAINT_NOT; /* Each item is independent */
4217 PL_curpm = newpm; /* Don't pop $1 et al till now */
4219 LEAVE_with_name("eval_scope");
4227 register PERL_CONTEXT *cx;
4228 const I32 gimme = GIMME_V;
4230 ENTER_with_name("given");
4233 sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs);
4235 PUSHBLOCK(cx, CXt_GIVEN, SP);
4244 register PERL_CONTEXT *cx;
4248 PERL_UNUSED_CONTEXT;
4251 assert(CxTYPE(cx) == CXt_GIVEN);
4254 if (gimme == G_VOID)
4256 else if (gimme == G_SCALAR) {
4260 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4263 *MARK = sv_mortalcopy(TOPs);
4267 *MARK = &PL_sv_undef;
4272 /* in case LEAVE wipes old return values */
4274 for (mark = newsp + 1; mark <= SP; mark++) {
4275 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4276 *mark = sv_mortalcopy(*mark);
4277 TAINT_NOT; /* Each item is independent */
4281 PL_curpm = newpm; /* Don't pop $1 et al till now */
4283 LEAVE_with_name("given");
4287 /* Helper routines used by pp_smartmatch */
4289 S_make_matcher(pTHX_ REGEXP *re)
4292 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4294 PERL_ARGS_ASSERT_MAKE_MATCHER;
4296 PM_SETRE(matcher, ReREFCNT_inc(re));
4298 SAVEFREEOP((OP *) matcher);
4299 ENTER_with_name("matcher"); SAVETMPS;
4305 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4310 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4312 PL_op = (OP *) matcher;
4315 (void) Perl_pp_match(aTHX);
4317 return (SvTRUEx(POPs));
4321 S_destroy_matcher(pTHX_ PMOP *matcher)
4325 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4326 PERL_UNUSED_ARG(matcher);
4329 LEAVE_with_name("matcher");
4332 /* Do a smart match */
4335 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4336 return do_smartmatch(NULL, NULL);
4339 /* This version of do_smartmatch() implements the
4340 * table of smart matches that is found in perlsyn.
4343 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4348 bool object_on_left = FALSE;
4349 SV *e = TOPs; /* e is for 'expression' */
4350 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4352 /* Take care only to invoke mg_get() once for each argument.
4353 * Currently we do this by copying the SV if it's magical. */
4356 d = sv_mortalcopy(d);
4363 e = sv_mortalcopy(e);
4365 /* First of all, handle overload magic of the rightmost argument */
4368 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4369 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4371 tmpsv = amagic_call(d, e, smart_amg, 0);
4378 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4381 SP -= 2; /* Pop the values */
4386 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4393 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4394 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4395 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4397 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4398 object_on_left = TRUE;
4401 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4403 if (object_on_left) {
4404 goto sm_any_sub; /* Treat objects like scalars */
4406 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4407 /* Test sub truth for each key */
4409 bool andedresults = TRUE;
4410 HV *hv = (HV*) SvRV(d);
4411 I32 numkeys = hv_iterinit(hv);
4412 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4415 while ( (he = hv_iternext(hv)) ) {
4416 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4417 ENTER_with_name("smartmatch_hash_key_test");
4420 PUSHs(hv_iterkeysv(he));
4422 c = call_sv(e, G_SCALAR);
4425 andedresults = FALSE;
4427 andedresults = SvTRUEx(POPs) && andedresults;
4429 LEAVE_with_name("smartmatch_hash_key_test");
4436 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4437 /* Test sub truth for each element */
4439 bool andedresults = TRUE;
4440 AV *av = (AV*) SvRV(d);
4441 const I32 len = av_len(av);
4442 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4445 for (i = 0; i <= len; ++i) {
4446 SV * const * const svp = av_fetch(av, i, FALSE);
4447 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4448 ENTER_with_name("smartmatch_array_elem_test");
4454 c = call_sv(e, G_SCALAR);
4457 andedresults = FALSE;
4459 andedresults = SvTRUEx(POPs) && andedresults;
4461 LEAVE_with_name("smartmatch_array_elem_test");
4470 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4471 ENTER_with_name("smartmatch_coderef");
4476 c = call_sv(e, G_SCALAR);
4480 else if (SvTEMP(TOPs))
4481 SvREFCNT_inc_void(TOPs);
4483 LEAVE_with_name("smartmatch_coderef");
4488 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4489 if (object_on_left) {
4490 goto sm_any_hash; /* Treat objects like scalars */
4492 else if (!SvOK(d)) {
4493 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4496 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4497 /* Check that the key-sets are identical */
4499 HV *other_hv = MUTABLE_HV(SvRV(d));
4501 bool other_tied = FALSE;
4502 U32 this_key_count = 0,
4503 other_key_count = 0;
4504 HV *hv = MUTABLE_HV(SvRV(e));
4506 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4507 /* Tied hashes don't know how many keys they have. */
4508 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4511 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4512 HV * const temp = other_hv;
4517 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4520 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4523 /* The hashes have the same number of keys, so it suffices
4524 to check that one is a subset of the other. */
4525 (void) hv_iterinit(hv);
4526 while ( (he = hv_iternext(hv)) ) {
4527 SV *key = hv_iterkeysv(he);
4529 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4532 if(!hv_exists_ent(other_hv, key, 0)) {
4533 (void) hv_iterinit(hv); /* reset iterator */
4539 (void) hv_iterinit(other_hv);
4540 while ( hv_iternext(other_hv) )
4544 other_key_count = HvUSEDKEYS(other_hv);
4546 if (this_key_count != other_key_count)
4551 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4552 AV * const other_av = MUTABLE_AV(SvRV(d));
4553 const I32 other_len = av_len(other_av) + 1;
4555 HV *hv = MUTABLE_HV(SvRV(e));
4557 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4558 for (i = 0; i < other_len; ++i) {
4559 SV ** const svp = av_fetch(other_av, i, FALSE);
4560 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4561 if (svp) { /* ??? When can this not happen? */
4562 if (hv_exists_ent(hv, *svp, 0))
4568 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4569 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4572 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4574 HV *hv = MUTABLE_HV(SvRV(e));
4576 (void) hv_iterinit(hv);
4577 while ( (he = hv_iternext(hv)) ) {
4578 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4579 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4580 (void) hv_iterinit(hv);
4581 destroy_matcher(matcher);
4585 destroy_matcher(matcher);
4591 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4592 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4599 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4600 if (object_on_left) {
4601 goto sm_any_array; /* Treat objects like scalars */
4603 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4604 AV * const other_av = MUTABLE_AV(SvRV(e));
4605 const I32 other_len = av_len(other_av) + 1;
4608 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4609 for (i = 0; i < other_len; ++i) {
4610 SV ** const svp = av_fetch(other_av, i, FALSE);
4612 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4613 if (svp) { /* ??? When can this not happen? */
4614 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4620 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4621 AV *other_av = MUTABLE_AV(SvRV(d));
4622 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4623 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4627 const I32 other_len = av_len(other_av);
4629 if (NULL == seen_this) {
4630 seen_this = newHV();
4631 (void) sv_2mortal(MUTABLE_SV(seen_this));
4633 if (NULL == seen_other) {
4634 seen_other = newHV();
4635 (void) sv_2mortal(MUTABLE_SV(seen_other));
4637 for(i = 0; i <= other_len; ++i) {
4638 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4639 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4641 if (!this_elem || !other_elem) {
4642 if ((this_elem && SvOK(*this_elem))
4643 || (other_elem && SvOK(*other_elem)))
4646 else if (hv_exists_ent(seen_this,
4647 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4648 hv_exists_ent(seen_other,
4649 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4651 if (*this_elem != *other_elem)
4655 (void)hv_store_ent(seen_this,
4656 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4658 (void)hv_store_ent(seen_other,
4659 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4665 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4666 (void) do_smartmatch(seen_this, seen_other);
4668 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4677 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4678 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4681 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4682 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4685 for(i = 0; i <= this_len; ++i) {
4686 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4687 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4688 if (svp && matcher_matches_sv(matcher, *svp)) {
4689 destroy_matcher(matcher);
4693 destroy_matcher(matcher);
4697 else if (!SvOK(d)) {
4698 /* undef ~~ array */
4699 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4702 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4703 for (i = 0; i <= this_len; ++i) {
4704 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4705 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4706 if (!svp || !SvOK(*svp))
4715 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4717 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4718 for (i = 0; i <= this_len; ++i) {
4719 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4726 /* infinite recursion isn't supposed to happen here */
4727 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4728 (void) do_smartmatch(NULL, NULL);
4730 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4739 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4740 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4741 SV *t = d; d = e; e = t;
4742 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4745 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4746 SV *t = d; d = e; e = t;
4747 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4748 goto sm_regex_array;
4751 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4753 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4755 PUSHs(matcher_matches_sv(matcher, d)
4758 destroy_matcher(matcher);
4763 /* See if there is overload magic on left */
4764 else if (object_on_left && SvAMAGIC(d)) {
4766 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4767 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4770 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4778 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4781 else if (!SvOK(d)) {
4782 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4783 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4788 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4789 DEBUG_M(if (SvNIOK(e))
4790 Perl_deb(aTHX_ " applying rule Any-Num\n");
4792 Perl_deb(aTHX_ " applying rule Num-numish\n");
4794 /* numeric comparison */
4797 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4798 (void) Perl_pp_i_eq(aTHX);
4800 (void) Perl_pp_eq(aTHX);
4808 /* As a last resort, use string comparison */
4809 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4812 return Perl_pp_seq(aTHX);
4818 register PERL_CONTEXT *cx;
4819 const I32 gimme = GIMME_V;
4821 /* This is essentially an optimization: if the match
4822 fails, we don't want to push a context and then
4823 pop it again right away, so we skip straight
4824 to the op that follows the leavewhen.
4825 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4827 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4828 RETURNOP(cLOGOP->op_other->op_next);
4830 ENTER_with_name("eval");
4833 PUSHBLOCK(cx, CXt_WHEN, SP);
4842 register PERL_CONTEXT *cx;
4848 assert(CxTYPE(cx) == CXt_WHEN);
4853 PL_curpm = newpm; /* pop $1 et al */
4855 LEAVE_with_name("eval");
4863 register PERL_CONTEXT *cx;
4866 cxix = dopoptowhen(cxstack_ix);
4868 DIE(aTHX_ "Can't \"continue\" outside a when block");
4869 if (cxix < cxstack_ix)
4872 /* clear off anything above the scope we're re-entering */
4873 inner = PL_scopestack_ix;
4875 if (PL_scopestack_ix < inner)
4876 leave_scope(PL_scopestack[PL_scopestack_ix]);
4877 PL_curcop = cx->blk_oldcop;
4878 return cx->blk_givwhen.leave_op;
4885 register PERL_CONTEXT *cx;
4889 cxix = dopoptogiven(cxstack_ix);
4891 if (PL_op->op_flags & OPf_SPECIAL)
4892 DIE(aTHX_ "Can't use when() outside a topicalizer");
4894 DIE(aTHX_ "Can't \"break\" outside a given block");
4896 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4897 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4899 if (cxix < cxstack_ix)
4902 /* clear off anything above the scope we're re-entering */
4903 inner = PL_scopestack_ix;
4905 if (PL_scopestack_ix < inner)
4906 leave_scope(PL_scopestack[PL_scopestack_ix]);
4907 PL_curcop = cx->blk_oldcop;
4910 return (cx)->blk_loop.my_op->op_nextop;
4912 /* RETURNOP calls PUTBACK which restores the old old sp */
4913 RETURNOP(cx->blk_givwhen.leave_op);
4917 S_doparseform(pTHX_ SV *sv)
4920 register char *s = SvPV(sv, len);
4921 register char * const send = s + len;
4922 register char *base = NULL;
4923 register I32 skipspaces = 0;
4924 bool noblank = FALSE;
4925 bool repeat = FALSE;
4926 bool postspace = FALSE;
4932 bool unchopnum = FALSE;
4933 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4936 PERL_ARGS_ASSERT_DOPARSEFORM;
4939 Perl_croak(aTHX_ "Null picture in formline");
4941 /* estimate the buffer size needed */
4942 for (base = s; s <= send; s++) {
4943 if (*s == '\n' || *s == '@' || *s == '^')
4949 Newx(fops, maxops, U32);
4954 *fpc++ = FF_LINEMARK;
4955 noblank = repeat = FALSE;
4973 case ' ': case '\t':
4980 } /* else FALL THROUGH */
4988 *fpc++ = FF_LITERAL;
4996 *fpc++ = (U16)skipspaces;
5000 *fpc++ = FF_NEWLINE;
5004 arg = fpc - linepc + 1;
5011 *fpc++ = FF_LINEMARK;
5012 noblank = repeat = FALSE;
5021 ischop = s[-1] == '^';
5027 arg = (s - base) - 1;
5029 *fpc++ = FF_LITERAL;
5037 *fpc++ = 2; /* skip the @* or ^* */
5039 *fpc++ = FF_LINESNGL;
5042 *fpc++ = FF_LINEGLOB;
5044 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
5045 arg = ischop ? 512 : 0;
5050 const char * const f = ++s;
5053 arg |= 256 + (s - f);
5055 *fpc++ = s - base; /* fieldsize for FETCH */
5056 *fpc++ = FF_DECIMAL;
5058 unchopnum |= ! ischop;
5060 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5061 arg = ischop ? 512 : 0;
5063 s++; /* skip the '0' first */
5067 const char * const f = ++s;
5070 arg |= 256 + (s - f);
5072 *fpc++ = s - base; /* fieldsize for FETCH */
5073 *fpc++ = FF_0DECIMAL;
5075 unchopnum |= ! ischop;
5079 bool ismore = FALSE;
5082 while (*++s == '>') ;
5083 prespace = FF_SPACE;
5085 else if (*s == '|') {
5086 while (*++s == '|') ;
5087 prespace = FF_HALFSPACE;
5092 while (*++s == '<') ;
5095 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5099 *fpc++ = s - base; /* fieldsize for FETCH */
5101 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5104 *fpc++ = (U16)prespace;
5118 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5121 /* If we pass the length in to sv_magicext() it will copy the buffer for us.
5122 We don't need that, so by setting the length on return we "donate" the
5123 buffer to the magic, avoiding an allocation. We could realloc() the
5124 buffer to the exact size used, but that feels like it's not worth it
5125 (particularly if the rumours are true and some realloc() implementations
5126 don't shrink blocks). However, set the true length used in mg_len so that
5127 mg_dup only allocates and copies what's actually needed. */
5128 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm,
5129 (const char *const) fops, 0);
5130 mg->mg_len = arg * sizeof(U32);
5132 if (unchopnum && repeat)
5133 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5140 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5142 /* Can value be printed in fldsize chars, using %*.*f ? */
5146 int intsize = fldsize - (value < 0 ? 1 : 0);
5153 while (intsize--) pwr *= 10.0;
5154 while (frcsize--) eps /= 10.0;
5157 if (value + eps >= pwr)
5160 if (value - eps <= -pwr)
5167 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5170 SV * const datasv = FILTER_DATA(idx);
5171 const int filter_has_file = IoLINES(datasv);
5172 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5173 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5178 char *prune_from = NULL;
5179 bool read_from_cache = FALSE;
5182 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5184 assert(maxlen >= 0);
5187 /* I was having segfault trouble under Linux 2.2.5 after a
5188 parse error occured. (Had to hack around it with a test
5189 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5190 not sure where the trouble is yet. XXX */
5193 SV *const cache = datasv;
5196 const char *cache_p = SvPV(cache, cache_len);
5200 /* Running in block mode and we have some cached data already.
5202 if (cache_len >= umaxlen) {
5203 /* In fact, so much data we don't even need to call
5208 const char *const first_nl =
5209 (const char *)memchr(cache_p, '\n', cache_len);
5211 take = first_nl + 1 - cache_p;
5215 sv_catpvn(buf_sv, cache_p, take);
5216 sv_chop(cache, cache_p + take);
5217 /* Definitely not EOF */
5221 sv_catsv(buf_sv, cache);
5223 umaxlen -= cache_len;
5226 read_from_cache = TRUE;
5230 /* Filter API says that the filter appends to the contents of the buffer.
5231 Usually the buffer is "", so the details don't matter. But if it's not,
5232 then clearly what it contains is already filtered by this filter, so we
5233 don't want to pass it in a second time.
5234 I'm going to use a mortal in case the upstream filter croaks. */
5235 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5236 ? sv_newmortal() : buf_sv;
5237 SvUPGRADE(upstream, SVt_PV);
5239 if (filter_has_file) {
5240 status = FILTER_READ(idx+1, upstream, 0);
5243 if (filter_sub && status >= 0) {
5247 ENTER_with_name("call_filter_sub");
5252 DEFSV_set(upstream);
5256 PUSHs(filter_state);
5259 count = call_sv(filter_sub, G_SCALAR);
5271 LEAVE_with_name("call_filter_sub");
5274 if(SvOK(upstream)) {
5275 got_p = SvPV(upstream, got_len);
5277 if (got_len > umaxlen) {
5278 prune_from = got_p + umaxlen;
5281 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5282 if (first_nl && first_nl + 1 < got_p + got_len) {
5283 /* There's a second line here... */
5284 prune_from = first_nl + 1;
5289 /* Oh. Too long. Stuff some in our cache. */
5290 STRLEN cached_len = got_p + got_len - prune_from;
5291 SV *const cache = datasv;
5294 /* Cache should be empty. */
5295 assert(!SvCUR(cache));
5298 sv_setpvn(cache, prune_from, cached_len);
5299 /* If you ask for block mode, you may well split UTF-8 characters.
5300 "If it breaks, you get to keep both parts"
5301 (Your code is broken if you don't put them back together again
5302 before something notices.) */
5303 if (SvUTF8(upstream)) {
5306 SvCUR_set(upstream, got_len - cached_len);
5308 /* Can't yet be EOF */
5313 /* If they are at EOF but buf_sv has something in it, then they may never
5314 have touched the SV upstream, so it may be undefined. If we naively
5315 concatenate it then we get a warning about use of uninitialised value.
5317 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5318 sv_catsv(buf_sv, upstream);
5322 IoLINES(datasv) = 0;
5324 SvREFCNT_dec(filter_state);
5325 IoTOP_GV(datasv) = NULL;
5328 SvREFCNT_dec(filter_sub);
5329 IoBOTTOM_GV(datasv) = NULL;
5331 filter_del(S_run_user_filter);
5333 if (status == 0 && read_from_cache) {
5334 /* If we read some data from the cache (and by getting here it implies
5335 that we emptied the cache) then we aren't yet at EOF, and mustn't
5336 report that to our caller. */
5342 /* perhaps someone can come up with a better name for
5343 this? it is not really "absolute", per se ... */
5345 S_path_is_absolute(const char *name)
5347 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5349 if (PERL_FILE_IS_ABSOLUTE(name)
5351 || (*name == '.' && ((name[1] == '/' ||
5352 (name[1] == '.' && name[2] == '/'))
5353 || (name[1] == '\\' ||
5354 ( name[1] == '.' && name[2] == '\\')))
5357 || (*name == '.' && (name[1] == '/' ||
5358 (name[1] == '.' && name[2] == '/')))
5370 * c-indentation-style: bsd
5372 * indent-tabs-mode: t
5375 * ex: set ts=8 sts=4 sw=4 noet: