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
38 #define WORD_ALIGN sizeof(U32)
41 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
43 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
52 cxix = dopoptosub(cxstack_ix);
56 switch (cxstack[cxix].blk_gimme) {
69 /* XXXX Should store the old value to allow for tie/overload - and
70 restore in regcomp, where marked with XXXX. */
80 register PMOP *pm = (PMOP*)cLOGOP->op_other;
84 /* prevent recompiling under /o and ithreads. */
85 #if defined(USE_ITHREADS)
86 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
87 if (PL_op->op_flags & OPf_STACKED) {
97 #define tryAMAGICregexp(rx) \
100 if (SvROK(rx) && SvAMAGIC(rx)) { \
101 SV *sv = AMG_CALLunary(rx, regexp_amg); \
105 if (SvTYPE(sv) != SVt_REGEXP) \
106 Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
113 if (PL_op->op_flags & OPf_STACKED) {
114 /* multiple args; concatenate them */
116 tmpstr = PAD_SV(ARGTARG);
117 sv_setpvs(tmpstr, "");
118 while (++MARK <= SP) {
122 tryAMAGICregexp(msv);
124 if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
125 (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
127 sv_setsv(tmpstr, sv);
130 sv_catsv_nomg(tmpstr, msv);
137 tryAMAGICregexp(tmpstr);
140 #undef tryAMAGICregexp
143 SV * const sv = SvRV(tmpstr);
144 if (SvTYPE(sv) == SVt_REGEXP)
147 else if (SvTYPE(tmpstr) == SVt_REGEXP)
148 re = (REGEXP*) tmpstr;
151 /* The match's LHS's get-magic might need to access this op's reg-
152 exp (as is sometimes the case with $'; see bug 70764). So we
153 must call get-magic now before we replace the regexp. Hopeful-
154 ly this hack can be replaced with the approach described at
155 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
156 /msg122415.html some day. */
157 if(pm->op_type == OP_MATCH) {
159 const bool was_tainted = PL_tainted;
160 if (pm->op_flags & OPf_STACKED)
162 else if (pm->op_private & OPpTARGET_MY)
163 lhs = PAD_SV(pm->op_targ);
166 /* Restore the previous value of PL_tainted (which may have been
167 modified by get-magic), to avoid incorrectly setting the
168 RXf_TAINTED flag further down. */
169 PL_tainted = was_tainted;
172 re = reg_temp_copy(NULL, re);
173 ReREFCNT_dec(PM_GETRE(pm));
178 const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : "";
181 assert (re != (REGEXP*) &PL_sv_undef);
183 /* Check against the last compiled regexp. */
184 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
185 memNE(RX_PRECOMP(re), t, len))
187 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
188 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
192 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
194 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
196 } else if (PL_curcop->cop_hints_hash) {
197 SV *ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
198 if (ptr && SvIOK(ptr) && SvIV(ptr))
199 eng = INT2PTR(regexp_engine*,SvIV(ptr));
202 if (PL_op->op_flags & OPf_SPECIAL)
203 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
205 if (DO_UTF8(tmpstr)) {
206 assert (SvUTF8(tmpstr));
207 } else if (SvUTF8(tmpstr)) {
208 /* Not doing UTF-8, despite what the SV says. Is this only if
209 we're trapped in use 'bytes'? */
210 /* Make a copy of the octet sequence, but without the flag on,
211 as the compiler now honours the SvUTF8 flag on tmpstr. */
213 const char *const p = SvPV(tmpstr, len);
214 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
216 else if (SvAMAGIC(tmpstr)) {
217 /* make a copy to avoid extra stringifies */
218 tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
221 /* If it is gmagical, create a mortal copy, but without calling
222 get-magic, as we have already done that. */
223 if(SvGMAGICAL(tmpstr)) {
224 SV *mortalcopy = sv_newmortal();
225 sv_setsv_flags(mortalcopy, tmpstr, 0);
230 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
232 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
234 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
235 inside tie/overload accessors. */
241 #ifndef INCOMPLETE_TAINTS
244 RX_EXTFLAGS(re) |= RXf_TAINTED;
246 RX_EXTFLAGS(re) &= ~RXf_TAINTED;
250 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
254 #if !defined(USE_ITHREADS)
255 /* can't change the optree at runtime either */
256 /* PMf_KEEP is handled differently under threads to avoid these problems */
257 if (pm->op_pmflags & PMf_KEEP) {
258 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
259 cLOGOP->op_first->op_next = PL_op->op_next;
269 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
270 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
271 register SV * const dstr = cx->sb_dstr;
272 register char *s = cx->sb_s;
273 register char *m = cx->sb_m;
274 char *orig = cx->sb_orig;
275 register REGEXP * const rx = cx->sb_rx;
277 REGEXP *old = PM_GETRE(pm);
284 PM_SETRE(pm,ReREFCNT_inc(rx));
287 rxres_restore(&cx->sb_rxres, rx);
288 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
290 if (cx->sb_iters++) {
291 const I32 saviters = cx->sb_iters;
292 if (cx->sb_iters > cx->sb_maxiters)
293 DIE(aTHX_ "Substitution loop");
295 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
297 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
298 cx->sb_rxtainted |= 2;
299 sv_catsv_nomg(dstr, POPs);
300 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
304 if (CxONCE(cx) || s < orig ||
305 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
306 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
307 ((cx->sb_rflags & REXEC_COPY_STR)
308 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
309 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
311 SV * const targ = cx->sb_targ;
313 assert(cx->sb_strend >= s);
314 if(cx->sb_strend > s) {
315 if (DO_UTF8(dstr) && !SvUTF8(targ))
316 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
318 sv_catpvn(dstr, s, cx->sb_strend - s);
320 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
322 #ifdef PERL_OLD_COPY_ON_WRITE
324 sv_force_normal_flags(targ, SV_COW_DROP_PV);
330 SvPV_set(targ, SvPVX(dstr));
331 SvCUR_set(targ, SvCUR(dstr));
332 SvLEN_set(targ, SvLEN(dstr));
335 SvPV_set(dstr, NULL);
337 TAINT_IF(cx->sb_rxtainted & 1);
338 if (pm->op_pmflags & PMf_NONDESTRUCT)
341 mPUSHi(saviters - 1);
343 (void)SvPOK_only_UTF8(targ);
344 TAINT_IF(cx->sb_rxtainted);
348 LEAVE_SCOPE(cx->sb_oldsave);
350 RETURNOP(pm->op_next);
352 cx->sb_iters = saviters;
354 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
357 cx->sb_orig = orig = RX_SUBBEG(rx);
359 cx->sb_strend = s + (cx->sb_strend - m);
361 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
363 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
364 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
366 sv_catpvn(dstr, s, m-s);
368 cx->sb_s = RX_OFFS(rx)[0].end + orig;
369 { /* Update the pos() information. */
370 SV * const sv = cx->sb_targ;
372 SvUPGRADE(sv, SVt_PVMG);
373 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
374 #ifdef PERL_OLD_COPY_ON_WRITE
376 sv_force_normal_flags(sv, 0);
378 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
381 mg->mg_len = m - orig;
384 (void)ReREFCNT_inc(rx);
385 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
386 rxres_save(&cx->sb_rxres, rx);
388 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
392 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
397 PERL_ARGS_ASSERT_RXRES_SAVE;
400 if (!p || p[1] < RX_NPARENS(rx)) {
401 #ifdef PERL_OLD_COPY_ON_WRITE
402 i = 7 + RX_NPARENS(rx) * 2;
404 i = 6 + RX_NPARENS(rx) * 2;
413 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
414 RX_MATCH_COPIED_off(rx);
416 #ifdef PERL_OLD_COPY_ON_WRITE
417 *p++ = PTR2UV(RX_SAVED_COPY(rx));
418 RX_SAVED_COPY(rx) = NULL;
421 *p++ = RX_NPARENS(rx);
423 *p++ = PTR2UV(RX_SUBBEG(rx));
424 *p++ = (UV)RX_SUBLEN(rx);
425 for (i = 0; i <= RX_NPARENS(rx); ++i) {
426 *p++ = (UV)RX_OFFS(rx)[i].start;
427 *p++ = (UV)RX_OFFS(rx)[i].end;
432 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
437 PERL_ARGS_ASSERT_RXRES_RESTORE;
440 RX_MATCH_COPY_FREE(rx);
441 RX_MATCH_COPIED_set(rx, *p);
444 #ifdef PERL_OLD_COPY_ON_WRITE
445 if (RX_SAVED_COPY(rx))
446 SvREFCNT_dec (RX_SAVED_COPY(rx));
447 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
451 RX_NPARENS(rx) = *p++;
453 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
454 RX_SUBLEN(rx) = (I32)(*p++);
455 for (i = 0; i <= RX_NPARENS(rx); ++i) {
456 RX_OFFS(rx)[i].start = (I32)(*p++);
457 RX_OFFS(rx)[i].end = (I32)(*p++);
462 S_rxres_free(pTHX_ void **rsp)
464 UV * const p = (UV*)*rsp;
466 PERL_ARGS_ASSERT_RXRES_FREE;
471 void *tmp = INT2PTR(char*,*p);
474 PoisonFree(*p, 1, sizeof(*p));
476 Safefree(INT2PTR(char*,*p));
478 #ifdef PERL_OLD_COPY_ON_WRITE
480 SvREFCNT_dec (INT2PTR(SV*,p[1]));
490 dVAR; dSP; dMARK; dORIGMARK;
491 register SV * const tmpForm = *++MARK;
496 register SV *sv = NULL;
497 const char *item = NULL;
501 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
502 const char *chophere = NULL;
503 char *linemark = NULL;
505 bool gotsome = FALSE;
507 const STRLEN fudge = SvPOKp(tmpForm)
508 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
509 bool item_is_utf8 = FALSE;
510 bool targ_is_utf8 = FALSE;
512 OP * parseres = NULL;
515 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
516 if (SvREADONLY(tmpForm)) {
517 SvREADONLY_off(tmpForm);
518 parseres = doparseform(tmpForm);
519 SvREADONLY_on(tmpForm);
522 parseres = doparseform(tmpForm);
526 SvPV_force(PL_formtarget, len);
527 if (SvTAINTED(tmpForm))
528 SvTAINTED_on(PL_formtarget);
529 if (DO_UTF8(PL_formtarget))
531 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
533 f = SvPV_const(tmpForm, len);
534 /* need to jump to the next word */
535 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
539 const char *name = "???";
542 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
543 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
544 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
545 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
546 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
548 case FF_CHECKNL: name = "CHECKNL"; break;
549 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
550 case FF_SPACE: name = "SPACE"; break;
551 case FF_HALFSPACE: name = "HALFSPACE"; break;
552 case FF_ITEM: name = "ITEM"; break;
553 case FF_CHOP: name = "CHOP"; break;
554 case FF_LINEGLOB: name = "LINEGLOB"; break;
555 case FF_NEWLINE: name = "NEWLINE"; break;
556 case FF_MORE: name = "MORE"; break;
557 case FF_LINEMARK: name = "LINEMARK"; break;
558 case FF_END: name = "END"; break;
559 case FF_0DECIMAL: name = "0DECIMAL"; break;
560 case FF_LINESNGL: name = "LINESNGL"; break;
563 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
565 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
576 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
577 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
579 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
580 t = SvEND(PL_formtarget);
584 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
585 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
587 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
588 t = SvEND(PL_formtarget);
608 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
611 SvTAINTED_on(PL_formtarget);
617 const char *s = item = SvPV_const(sv, len);
620 itemsize = sv_len_utf8(sv);
621 if (itemsize != (I32)len) {
623 if (itemsize > fieldsize) {
624 itemsize = fieldsize;
625 itembytes = itemsize;
626 sv_pos_u2b(sv, &itembytes, 0);
630 send = chophere = s + itembytes;
640 sv_pos_b2u(sv, &itemsize);
644 item_is_utf8 = FALSE;
645 if (itemsize > fieldsize)
646 itemsize = fieldsize;
647 send = chophere = s + itemsize;
661 const char *s = item = SvPV_const(sv, len);
664 itemsize = sv_len_utf8(sv);
665 if (itemsize != (I32)len) {
667 if (itemsize <= fieldsize) {
668 const char *send = chophere = s + itemsize;
681 itemsize = fieldsize;
682 itembytes = itemsize;
683 sv_pos_u2b(sv, &itembytes, 0);
684 send = chophere = s + itembytes;
685 while (s < send || (s == send && isSPACE(*s))) {
695 if (strchr(PL_chopset, *s))
700 itemsize = chophere - item;
701 sv_pos_b2u(sv, &itemsize);
707 item_is_utf8 = FALSE;
708 if (itemsize <= fieldsize) {
709 const char *const send = chophere = s + itemsize;
722 itemsize = fieldsize;
723 send = chophere = s + itemsize;
724 while (s < send || (s == send && isSPACE(*s))) {
734 if (strchr(PL_chopset, *s))
739 itemsize = chophere - item;
745 arg = fieldsize - itemsize;
754 arg = fieldsize - itemsize;
765 const char *s = item;
769 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
771 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
773 t = SvEND(PL_formtarget);
777 if (UTF8_IS_CONTINUED(*s)) {
778 STRLEN skip = UTF8SKIP(s);
795 if ( !((*t++ = *s++) & ~31) )
801 if (targ_is_utf8 && !item_is_utf8) {
802 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
804 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
805 for (; t < SvEND(PL_formtarget); t++) {
818 const int ch = *t++ = *s++;
821 if ( !((*t++ = *s++) & ~31) )
830 const char *s = chophere;
844 const bool oneline = fpc[-1] == FF_LINESNGL;
845 const char *s = item = SvPV_const(sv, len);
846 item_is_utf8 = DO_UTF8(sv);
849 STRLEN to_copy = itemsize;
850 const char *const send = s + len;
851 const U8 *source = (const U8 *) s;
855 chophere = s + itemsize;
859 to_copy = s - SvPVX_const(sv) - 1;
871 if (targ_is_utf8 && !item_is_utf8) {
872 source = tmp = bytes_to_utf8(source, &to_copy);
873 SvCUR_set(PL_formtarget,
874 t - SvPVX_const(PL_formtarget));
876 if (item_is_utf8 && !targ_is_utf8) {
877 /* Upgrade targ to UTF8, and then we reduce it to
878 a problem we have a simple solution for. */
879 SvCUR_set(PL_formtarget,
880 t - SvPVX_const(PL_formtarget));
882 /* Don't need get magic. */
883 sv_utf8_upgrade_nomg(PL_formtarget);
885 SvCUR_set(PL_formtarget,
886 t - SvPVX_const(PL_formtarget));
889 /* Easy. They agree. */
890 assert (item_is_utf8 == targ_is_utf8);
892 SvGROW(PL_formtarget,
893 SvCUR(PL_formtarget) + to_copy + fudge + 1);
894 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
896 Copy(source, t, to_copy, char);
898 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
900 if (SvGMAGICAL(sv)) {
901 /* Mustn't call sv_pos_b2u() as it does a second
902 mg_get(). Is this a bug? Do we need a _flags()
904 itemsize = utf8_length(source, source + itemsize);
906 sv_pos_b2u(sv, &itemsize);
918 #if defined(USE_LONG_DOUBLE)
921 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
925 "%#0*.*f" : "%0*.*f");
930 #if defined(USE_LONG_DOUBLE)
932 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
935 ((arg & 256) ? "%#*.*f" : "%*.*f");
938 /* If the field is marked with ^ and the value is undefined,
940 if ((arg & 512) && !SvOK(sv)) {
948 /* overflow evidence */
949 if (num_overflow(value, fieldsize, arg)) {
955 /* Formats aren't yet marked for locales, so assume "yes". */
957 STORE_NUMERIC_STANDARD_SET_LOCAL();
958 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
959 RESTORE_NUMERIC_STANDARD();
966 while (t-- > linemark && *t == ' ') ;
974 if (arg) { /* repeat until fields exhausted? */
976 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
977 lines += FmLINES(PL_formtarget);
979 SvUTF8_on(PL_formtarget);
980 FmLINES(PL_formtarget) = lines;
982 RETURNOP(cLISTOP->op_first);
993 const char *s = chophere;
994 const char *send = item + len;
996 while (isSPACE(*s) && (s < send))
1001 arg = fieldsize - itemsize;
1008 if (strnEQ(s1," ",3)) {
1009 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
1020 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1022 SvUTF8_on(PL_formtarget);
1023 FmLINES(PL_formtarget) += lines;
1035 if (PL_stack_base + *PL_markstack_ptr == SP) {
1037 if (GIMME_V == G_SCALAR)
1039 RETURNOP(PL_op->op_next->op_next);
1041 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
1042 Perl_pp_pushmark(aTHX); /* push dst */
1043 Perl_pp_pushmark(aTHX); /* push src */
1044 ENTER_with_name("grep"); /* enter outer scope */
1047 if (PL_op->op_private & OPpGREP_LEX)
1048 SAVESPTR(PAD_SVl(PL_op->op_targ));
1051 ENTER_with_name("grep_item"); /* enter inner scope */
1054 src = PL_stack_base[*PL_markstack_ptr];
1056 if (PL_op->op_private & OPpGREP_LEX)
1057 PAD_SVl(PL_op->op_targ) = src;
1062 if (PL_op->op_type == OP_MAPSTART)
1063 Perl_pp_pushmark(aTHX); /* push top */
1064 return ((LOGOP*)PL_op->op_next)->op_other;
1070 const I32 gimme = GIMME_V;
1071 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1077 /* first, move source pointer to the next item in the source list */
1078 ++PL_markstack_ptr[-1];
1080 /* if there are new items, push them into the destination list */
1081 if (items && gimme != G_VOID) {
1082 /* might need to make room back there first */
1083 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1084 /* XXX this implementation is very pessimal because the stack
1085 * is repeatedly extended for every set of items. Is possible
1086 * to do this without any stack extension or copying at all
1087 * by maintaining a separate list over which the map iterates
1088 * (like foreach does). --gsar */
1090 /* everything in the stack after the destination list moves
1091 * towards the end the stack by the amount of room needed */
1092 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1094 /* items to shift up (accounting for the moved source pointer) */
1095 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1097 /* This optimization is by Ben Tilly and it does
1098 * things differently from what Sarathy (gsar)
1099 * is describing. The downside of this optimization is
1100 * that leaves "holes" (uninitialized and hopefully unused areas)
1101 * to the Perl stack, but on the other hand this
1102 * shouldn't be a problem. If Sarathy's idea gets
1103 * implemented, this optimization should become
1104 * irrelevant. --jhi */
1106 shift = count; /* Avoid shifting too often --Ben Tilly */
1110 dst = (SP += shift);
1111 PL_markstack_ptr[-1] += shift;
1112 *PL_markstack_ptr += shift;
1116 /* copy the new items down to the destination list */
1117 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1118 if (gimme == G_ARRAY) {
1119 /* add returned items to the collection (making mortal copies
1120 * if necessary), then clear the current temps stack frame
1121 * *except* for those items. We do this splicing the items
1122 * into the start of the tmps frame (so some items may be on
1123 * the tmps stack twice), then moving PL_tmps_floor above
1124 * them, then freeing the frame. That way, the only tmps that
1125 * accumulate over iterations are the return values for map.
1126 * We have to do to this way so that everything gets correctly
1127 * freed if we die during the map.
1131 /* make space for the slice */
1132 EXTEND_MORTAL(items);
1133 tmpsbase = PL_tmps_floor + 1;
1134 Move(PL_tmps_stack + tmpsbase,
1135 PL_tmps_stack + tmpsbase + items,
1136 PL_tmps_ix - PL_tmps_floor,
1138 PL_tmps_ix += items;
1143 sv = sv_mortalcopy(sv);
1145 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1147 /* clear the stack frame except for the items */
1148 PL_tmps_floor += items;
1150 /* FREETMPS may have cleared the TEMP flag on some of the items */
1153 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1156 /* scalar context: we don't care about which values map returns
1157 * (we use undef here). And so we certainly don't want to do mortal
1158 * copies of meaningless values. */
1159 while (items-- > 0) {
1161 *dst-- = &PL_sv_undef;
1169 LEAVE_with_name("grep_item"); /* exit inner scope */
1172 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1174 (void)POPMARK; /* pop top */
1175 LEAVE_with_name("grep"); /* exit outer scope */
1176 (void)POPMARK; /* pop src */
1177 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1178 (void)POPMARK; /* pop dst */
1179 SP = PL_stack_base + POPMARK; /* pop original mark */
1180 if (gimme == G_SCALAR) {
1181 if (PL_op->op_private & OPpGREP_LEX) {
1182 SV* sv = sv_newmortal();
1183 sv_setiv(sv, items);
1191 else if (gimme == G_ARRAY)
1198 ENTER_with_name("grep_item"); /* enter inner scope */
1201 /* set $_ to the new source item */
1202 src = PL_stack_base[PL_markstack_ptr[-1]];
1204 if (PL_op->op_private & OPpGREP_LEX)
1205 PAD_SVl(PL_op->op_targ) = src;
1209 RETURNOP(cLOGOP->op_other);
1218 if (GIMME == G_ARRAY)
1220 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1221 return cLOGOP->op_other;
1231 if (GIMME == G_ARRAY) {
1232 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1236 SV * const targ = PAD_SV(PL_op->op_targ);
1239 if (PL_op->op_private & OPpFLIP_LINENUM) {
1240 if (GvIO(PL_last_in_gv)) {
1241 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1244 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1246 flip = SvIV(sv) == SvIV(GvSV(gv));
1252 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1253 if (PL_op->op_flags & OPf_SPECIAL) {
1261 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1264 sv_setpvs(TARG, "");
1270 /* This code tries to decide if "$left .. $right" should use the
1271 magical string increment, or if the range is numeric (we make
1272 an exception for .."0" [#18165]). AMS 20021031. */
1274 #define RANGE_IS_NUMERIC(left,right) ( \
1275 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1276 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1277 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1278 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1279 && (!SvOK(right) || looks_like_number(right))))
1285 if (GIMME == G_ARRAY) {
1291 if (RANGE_IS_NUMERIC(left,right)) {
1294 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1295 (SvOK(right) && SvNV(right) > IV_MAX))
1296 DIE(aTHX_ "Range iterator outside integer range");
1307 SV * const sv = sv_2mortal(newSViv(i++));
1312 SV * const final = sv_mortalcopy(right);
1314 const char * const tmps = SvPV_const(final, len);
1316 SV *sv = sv_mortalcopy(left);
1317 SvPV_force_nolen(sv);
1318 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1320 if (strEQ(SvPVX_const(sv),tmps))
1322 sv = sv_2mortal(newSVsv(sv));
1329 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1333 if (PL_op->op_private & OPpFLIP_LINENUM) {
1334 if (GvIO(PL_last_in_gv)) {
1335 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1338 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1339 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1347 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1348 sv_catpvs(targ, "E0");
1358 static const char * const context_name[] = {
1360 NULL, /* CXt_WHEN never actually needs "block" */
1361 NULL, /* CXt_BLOCK never actually needs "block" */
1362 NULL, /* CXt_GIVEN never actually needs "block" */
1363 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1364 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1365 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1366 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1374 S_dopoptolabel(pTHX_ const char *label)
1379 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1381 for (i = cxstack_ix; i >= 0; i--) {
1382 register const PERL_CONTEXT * const cx = &cxstack[i];
1383 switch (CxTYPE(cx)) {
1389 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1390 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1391 if (CxTYPE(cx) == CXt_NULL)
1394 case CXt_LOOP_LAZYIV:
1395 case CXt_LOOP_LAZYSV:
1397 case CXt_LOOP_PLAIN:
1399 const char *cx_label = CxLABEL(cx);
1400 if (!cx_label || strNE(label, cx_label) ) {
1401 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1402 (long)i, cx_label));
1405 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1416 Perl_dowantarray(pTHX)
1419 const I32 gimme = block_gimme();
1420 return (gimme == G_VOID) ? G_SCALAR : gimme;
1424 Perl_block_gimme(pTHX)
1427 const I32 cxix = dopoptosub(cxstack_ix);
1431 switch (cxstack[cxix].blk_gimme) {
1439 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1446 Perl_is_lvalue_sub(pTHX)
1449 const I32 cxix = dopoptosub(cxstack_ix);
1450 assert(cxix >= 0); /* We should only be called from inside subs */
1452 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1453 return CxLVAL(cxstack + cxix);
1459 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1464 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1466 for (i = startingblock; i >= 0; i--) {
1467 register const PERL_CONTEXT * const cx = &cxstk[i];
1468 switch (CxTYPE(cx)) {
1474 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1482 S_dopoptoeval(pTHX_ I32 startingblock)
1486 for (i = startingblock; i >= 0; i--) {
1487 register const PERL_CONTEXT *cx = &cxstack[i];
1488 switch (CxTYPE(cx)) {
1492 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1500 S_dopoptoloop(pTHX_ I32 startingblock)
1504 for (i = startingblock; i >= 0; i--) {
1505 register const PERL_CONTEXT * const cx = &cxstack[i];
1506 switch (CxTYPE(cx)) {
1512 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1513 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1514 if ((CxTYPE(cx)) == CXt_NULL)
1517 case CXt_LOOP_LAZYIV:
1518 case CXt_LOOP_LAZYSV:
1520 case CXt_LOOP_PLAIN:
1521 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1529 S_dopoptogiven(pTHX_ I32 startingblock)
1533 for (i = startingblock; i >= 0; i--) {
1534 register const PERL_CONTEXT *cx = &cxstack[i];
1535 switch (CxTYPE(cx)) {
1539 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1541 case CXt_LOOP_PLAIN:
1542 assert(!CxFOREACHDEF(cx));
1544 case CXt_LOOP_LAZYIV:
1545 case CXt_LOOP_LAZYSV:
1547 if (CxFOREACHDEF(cx)) {
1548 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1557 S_dopoptowhen(pTHX_ I32 startingblock)
1561 for (i = startingblock; i >= 0; i--) {
1562 register const PERL_CONTEXT *cx = &cxstack[i];
1563 switch (CxTYPE(cx)) {
1567 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1575 Perl_dounwind(pTHX_ I32 cxix)
1580 while (cxstack_ix > cxix) {
1582 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1583 DEBUG_CX("UNWIND"); \
1584 /* Note: we don't need to restore the base context info till the end. */
1585 switch (CxTYPE(cx)) {
1588 continue; /* not break */
1596 case CXt_LOOP_LAZYIV:
1597 case CXt_LOOP_LAZYSV:
1599 case CXt_LOOP_PLAIN:
1610 PERL_UNUSED_VAR(optype);
1614 Perl_qerror(pTHX_ SV *err)
1618 PERL_ARGS_ASSERT_QERROR;
1621 if (PL_in_eval & EVAL_KEEPERR) {
1622 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1623 SvPV_nolen_const(err));
1626 sv_catsv(ERRSV, err);
1629 sv_catsv(PL_errors, err);
1631 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1633 ++PL_parser->error_count;
1637 Perl_die_unwind(pTHX_ SV *msv)
1640 SV *exceptsv = sv_mortalcopy(msv);
1641 U8 in_eval = PL_in_eval;
1642 PERL_ARGS_ASSERT_DIE_UNWIND;
1649 * Historically, perl used to set ERRSV ($@) early in the die
1650 * process and rely on it not getting clobbered during unwinding.
1651 * That sucked, because it was liable to get clobbered, so the
1652 * setting of ERRSV used to emit the exception from eval{} has
1653 * been moved to much later, after unwinding (see just before
1654 * JMPENV_JUMP below). However, some modules were relying on the
1655 * early setting, by examining $@ during unwinding to use it as
1656 * a flag indicating whether the current unwinding was caused by
1657 * an exception. It was never a reliable flag for that purpose,
1658 * being totally open to false positives even without actual
1659 * clobberage, but was useful enough for production code to
1660 * semantically rely on it.
1662 * We'd like to have a proper introspective interface that
1663 * explicitly describes the reason for whatever unwinding
1664 * operations are currently in progress, so that those modules
1665 * work reliably and $@ isn't further overloaded. But we don't
1666 * have one yet. In its absence, as a stopgap measure, ERRSV is
1667 * now *additionally* set here, before unwinding, to serve as the
1668 * (unreliable) flag that it used to.
1670 * This behaviour is temporary, and should be removed when a
1671 * proper way to detect exceptional unwinding has been developed.
1672 * As of 2010-12, the authors of modules relying on the hack
1673 * are aware of the issue, because the modules failed on
1674 * perls 5.13.{1..7} which had late setting of $@ without this
1675 * early-setting hack.
1677 if (!(in_eval & EVAL_KEEPERR)) {
1678 SvTEMP_off(exceptsv);
1679 sv_setsv(ERRSV, exceptsv);
1682 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1683 && PL_curstackinfo->si_prev)
1692 register PERL_CONTEXT *cx;
1695 JMPENV *restartjmpenv;
1698 if (cxix < cxstack_ix)
1701 POPBLOCK(cx,PL_curpm);
1702 if (CxTYPE(cx) != CXt_EVAL) {
1704 const char* message = SvPVx_const(exceptsv, msglen);
1705 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1706 PerlIO_write(Perl_error_log, message, msglen);
1710 namesv = cx->blk_eval.old_namesv;
1711 oldcop = cx->blk_oldcop;
1712 restartjmpenv = cx->blk_eval.cur_top_env;
1713 restartop = cx->blk_eval.retop;
1715 if (gimme == G_SCALAR)
1716 *++newsp = &PL_sv_undef;
1717 PL_stack_sp = newsp;
1721 /* LEAVE could clobber PL_curcop (see save_re_context())
1722 * XXX it might be better to find a way to avoid messing with
1723 * PL_curcop in save_re_context() instead, but this is a more
1724 * minimal fix --GSAR */
1727 if (optype == OP_REQUIRE) {
1728 const char* const msg = SvPVx_nolen_const(exceptsv);
1729 (void)hv_store(GvHVn(PL_incgv),
1730 SvPVX_const(namesv), SvCUR(namesv),
1732 /* note that unlike pp_entereval, pp_require isn't
1733 * supposed to trap errors. So now that we've popped the
1734 * EVAL that pp_require pushed, and processed the error
1735 * message, rethrow the error */
1736 Perl_croak(aTHX_ "%sCompilation failed in require",
1737 *msg ? msg : "Unknown error\n");
1739 if (in_eval & EVAL_KEEPERR) {
1740 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1741 SvPV_nolen_const(exceptsv));
1744 sv_setsv(ERRSV, exceptsv);
1746 PL_restartjmpenv = restartjmpenv;
1747 PL_restartop = restartop;
1753 write_to_stderr(exceptsv);
1760 dVAR; dSP; dPOPTOPssrl;
1761 if (SvTRUE(left) != SvTRUE(right))
1768 =for apidoc caller_cx
1770 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1771 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1772 information returned to Perl by C<caller>. Note that XSUBs don't get a
1773 stack frame, so C<caller_cx(0, NULL)> will return information for the
1774 immediately-surrounding Perl code.
1776 This function skips over the automatic calls to C<&DB::sub> made on the
1777 behalf of the debugger. If the stack frame requested was a sub called by
1778 C<DB::sub>, the return value will be the frame for the call to
1779 C<DB::sub>, since that has the correct line number/etc. for the call
1780 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1781 frame for the sub call itself.
1786 const PERL_CONTEXT *
1787 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1789 register I32 cxix = dopoptosub(cxstack_ix);
1790 register const PERL_CONTEXT *cx;
1791 register const PERL_CONTEXT *ccstack = cxstack;
1792 const PERL_SI *top_si = PL_curstackinfo;
1795 /* we may be in a higher stacklevel, so dig down deeper */
1796 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1797 top_si = top_si->si_prev;
1798 ccstack = top_si->si_cxstack;
1799 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1803 /* caller() should not report the automatic calls to &DB::sub */
1804 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1805 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1809 cxix = dopoptosub_at(ccstack, cxix - 1);
1812 cx = &ccstack[cxix];
1813 if (dbcxp) *dbcxp = cx;
1815 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1816 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1817 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1818 field below is defined for any cx. */
1819 /* caller() should not report the automatic calls to &DB::sub */
1820 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1821 cx = &ccstack[dbcxix];
1831 register const PERL_CONTEXT *cx;
1832 const PERL_CONTEXT *dbcx;
1834 const char *stashname;
1840 cx = caller_cx(count, &dbcx);
1842 if (GIMME != G_ARRAY) {
1849 stashname = CopSTASHPV(cx->blk_oldcop);
1850 if (GIMME != G_ARRAY) {
1853 PUSHs(&PL_sv_undef);
1856 sv_setpv(TARG, stashname);
1865 PUSHs(&PL_sv_undef);
1867 mPUSHs(newSVpv(stashname, 0));
1868 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1869 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1872 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1873 GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1874 /* So is ccstack[dbcxix]. */
1876 SV * const sv = newSV(0);
1877 gv_efullname3(sv, cvgv, NULL);
1879 PUSHs(boolSV(CxHASARGS(cx)));
1882 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1883 PUSHs(boolSV(CxHASARGS(cx)));
1887 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1890 gimme = (I32)cx->blk_gimme;
1891 if (gimme == G_VOID)
1892 PUSHs(&PL_sv_undef);
1894 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1895 if (CxTYPE(cx) == CXt_EVAL) {
1897 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1898 PUSHs(cx->blk_eval.cur_text);
1902 else if (cx->blk_eval.old_namesv) {
1903 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1906 /* eval BLOCK (try blocks have old_namesv == 0) */
1908 PUSHs(&PL_sv_undef);
1909 PUSHs(&PL_sv_undef);
1913 PUSHs(&PL_sv_undef);
1914 PUSHs(&PL_sv_undef);
1916 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1917 && CopSTASH_eq(PL_curcop, PL_debstash))
1919 AV * const ary = cx->blk_sub.argarray;
1920 const int off = AvARRAY(ary) - AvALLOC(ary);
1923 Perl_init_dbargs(aTHX);
1925 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1926 av_extend(PL_dbargs, AvFILLp(ary) + off);
1927 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1928 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1930 /* XXX only hints propagated via op_private are currently
1931 * visible (others are not easily accessible, since they
1932 * use the global PL_hints) */
1933 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1936 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1938 if (old_warnings == pWARN_NONE ||
1939 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1940 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1941 else if (old_warnings == pWARN_ALL ||
1942 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1943 /* Get the bit mask for $warnings::Bits{all}, because
1944 * it could have been extended by warnings::register */
1946 HV * const bits = get_hv("warnings::Bits", 0);
1947 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1948 mask = newSVsv(*bits_all);
1951 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1955 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1959 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1960 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1969 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1970 sv_reset(tmps, CopSTASH(PL_curcop));
1975 /* like pp_nextstate, but used instead when the debugger is active */
1980 PL_curcop = (COP*)PL_op;
1981 TAINT_NOT; /* Each statement is presumed innocent */
1982 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1987 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1988 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1991 register PERL_CONTEXT *cx;
1992 const I32 gimme = G_ARRAY;
1994 GV * const gv = PL_DBgv;
1995 register CV * const cv = GvCV(gv);
1998 DIE(aTHX_ "No DB::DB routine defined");
2000 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2001 /* don't do recursive DB::DB call */
2016 (void)(*CvXSUB(cv))(aTHX_ cv);
2023 PUSHBLOCK(cx, CXt_SUB, SP);
2025 cx->blk_sub.retop = PL_op->op_next;
2028 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
2029 RETURNOP(CvSTART(cv));
2039 register PERL_CONTEXT *cx;
2040 const I32 gimme = GIMME_V;
2041 void *itervar; /* location of the iteration variable */
2042 U8 cxtype = CXt_LOOP_FOR;
2044 ENTER_with_name("loop1");
2047 if (PL_op->op_targ) { /* "my" variable */
2048 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2049 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2050 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2051 SVs_PADSTALE, SVs_PADSTALE);
2053 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2055 itervar = PL_comppad;
2057 itervar = &PAD_SVl(PL_op->op_targ);
2060 else { /* symbol table variable */
2061 GV * const gv = MUTABLE_GV(POPs);
2062 SV** svp = &GvSV(gv);
2063 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2065 itervar = (void *)gv;
2068 if (PL_op->op_private & OPpITER_DEF)
2069 cxtype |= CXp_FOR_DEF;
2071 ENTER_with_name("loop2");
2073 PUSHBLOCK(cx, cxtype, SP);
2074 PUSHLOOP_FOR(cx, itervar, MARK);
2075 if (PL_op->op_flags & OPf_STACKED) {
2076 SV *maybe_ary = POPs;
2077 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2079 SV * const right = maybe_ary;
2082 if (RANGE_IS_NUMERIC(sv,right)) {
2083 cx->cx_type &= ~CXTYPEMASK;
2084 cx->cx_type |= CXt_LOOP_LAZYIV;
2085 /* Make sure that no-one re-orders cop.h and breaks our
2087 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2088 #ifdef NV_PRESERVES_UV
2089 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
2090 (SvNV(sv) > (NV)IV_MAX)))
2092 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
2093 (SvNV(right) < (NV)IV_MIN))))
2095 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
2098 ((SvUV(sv) > (UV)IV_MAX) ||
2099 (SvNV(sv) > (NV)UV_MAX)))))
2101 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
2103 ((SvNV(right) > 0) &&
2104 ((SvUV(right) > (UV)IV_MAX) ||
2105 (SvNV(right) > (NV)UV_MAX))))))
2107 DIE(aTHX_ "Range iterator outside integer range");
2108 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
2109 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
2111 /* for correct -Dstv display */
2112 cx->blk_oldsp = sp - PL_stack_base;
2116 cx->cx_type &= ~CXTYPEMASK;
2117 cx->cx_type |= CXt_LOOP_LAZYSV;
2118 /* Make sure that no-one re-orders cop.h and breaks our
2120 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2121 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2122 cx->blk_loop.state_u.lazysv.end = right;
2123 SvREFCNT_inc(right);
2124 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2125 /* This will do the upgrade to SVt_PV, and warn if the value
2126 is uninitialised. */
2127 (void) SvPV_nolen_const(right);
2128 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2129 to replace !SvOK() with a pointer to "". */
2131 SvREFCNT_dec(right);
2132 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2136 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2137 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2138 SvREFCNT_inc(maybe_ary);
2139 cx->blk_loop.state_u.ary.ix =
2140 (PL_op->op_private & OPpITER_REVERSED) ?
2141 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2145 else { /* iterating over items on the stack */
2146 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2147 if (PL_op->op_private & OPpITER_REVERSED) {
2148 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2151 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2161 register PERL_CONTEXT *cx;
2162 const I32 gimme = GIMME_V;
2164 ENTER_with_name("loop1");
2166 ENTER_with_name("loop2");
2168 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2169 PUSHLOOP_PLAIN(cx, SP);
2177 register PERL_CONTEXT *cx;
2184 assert(CxTYPE_is_LOOP(cx));
2186 newsp = PL_stack_base + cx->blk_loop.resetsp;
2189 if (gimme == G_VOID)
2191 else if (gimme == G_SCALAR) {
2193 *++newsp = sv_mortalcopy(*SP);
2195 *++newsp = &PL_sv_undef;
2199 *++newsp = sv_mortalcopy(*++mark);
2200 TAINT_NOT; /* Each item is independent */
2206 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2207 PL_curpm = newpm; /* ... and pop $1 et al */
2209 LEAVE_with_name("loop2");
2210 LEAVE_with_name("loop1");
2218 register PERL_CONTEXT *cx;
2219 bool popsub2 = FALSE;
2220 bool clear_errsv = FALSE;
2229 const I32 cxix = dopoptosub(cxstack_ix);
2232 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2233 * sort block, which is a CXt_NULL
2236 PL_stack_base[1] = *PL_stack_sp;
2237 PL_stack_sp = PL_stack_base + 1;
2241 DIE(aTHX_ "Can't return outside a subroutine");
2243 if (cxix < cxstack_ix)
2246 if (CxMULTICALL(&cxstack[cxix])) {
2247 gimme = cxstack[cxix].blk_gimme;
2248 if (gimme == G_VOID)
2249 PL_stack_sp = PL_stack_base;
2250 else if (gimme == G_SCALAR) {
2251 PL_stack_base[1] = *PL_stack_sp;
2252 PL_stack_sp = PL_stack_base + 1;
2258 switch (CxTYPE(cx)) {
2261 retop = cx->blk_sub.retop;
2262 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2265 if (!(PL_in_eval & EVAL_KEEPERR))
2268 namesv = cx->blk_eval.old_namesv;
2269 retop = cx->blk_eval.retop;
2272 if (optype == OP_REQUIRE &&
2273 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2275 /* Unassume the success we assumed earlier. */
2276 (void)hv_delete(GvHVn(PL_incgv),
2277 SvPVX_const(namesv), SvCUR(namesv),
2279 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2284 retop = cx->blk_sub.retop;
2287 DIE(aTHX_ "panic: return");
2291 if (gimme == G_SCALAR) {
2294 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2296 *++newsp = SvREFCNT_inc(*SP);
2301 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2303 *++newsp = sv_mortalcopy(sv);
2308 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2311 *++newsp = sv_mortalcopy(*SP);
2314 *++newsp = &PL_sv_undef;
2316 else if (gimme == G_ARRAY) {
2317 while (++MARK <= SP) {
2318 *++newsp = (popsub2 && SvTEMP(*MARK))
2319 ? *MARK : sv_mortalcopy(*MARK);
2320 TAINT_NOT; /* Each item is independent */
2323 PL_stack_sp = newsp;
2326 /* Stack values are safe: */
2329 POPSUB(cx,sv); /* release CV and @_ ... */
2333 PL_curpm = newpm; /* ... and pop $1 et al */
2346 register PERL_CONTEXT *cx;
2357 if (PL_op->op_flags & OPf_SPECIAL) {
2358 cxix = dopoptoloop(cxstack_ix);
2360 DIE(aTHX_ "Can't \"last\" outside a loop block");
2363 cxix = dopoptolabel(cPVOP->op_pv);
2365 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2367 if (cxix < cxstack_ix)
2371 cxstack_ix++; /* temporarily protect top context */
2373 switch (CxTYPE(cx)) {
2374 case CXt_LOOP_LAZYIV:
2375 case CXt_LOOP_LAZYSV:
2377 case CXt_LOOP_PLAIN:
2379 newsp = PL_stack_base + cx->blk_loop.resetsp;
2380 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2384 nextop = cx->blk_sub.retop;
2388 nextop = cx->blk_eval.retop;
2392 nextop = cx->blk_sub.retop;
2395 DIE(aTHX_ "panic: last");
2399 if (gimme == G_SCALAR) {
2401 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2402 ? *SP : sv_mortalcopy(*SP);
2404 *++newsp = &PL_sv_undef;
2406 else if (gimme == G_ARRAY) {
2407 while (++MARK <= SP) {
2408 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2409 ? *MARK : sv_mortalcopy(*MARK);
2410 TAINT_NOT; /* Each item is independent */
2418 /* Stack values are safe: */
2420 case CXt_LOOP_LAZYIV:
2421 case CXt_LOOP_PLAIN:
2422 case CXt_LOOP_LAZYSV:
2424 POPLOOP(cx); /* release loop vars ... */
2428 POPSUB(cx,sv); /* release CV and @_ ... */
2431 PL_curpm = newpm; /* ... and pop $1 et al */
2434 PERL_UNUSED_VAR(optype);
2435 PERL_UNUSED_VAR(gimme);
2443 register PERL_CONTEXT *cx;
2446 if (PL_op->op_flags & OPf_SPECIAL) {
2447 cxix = dopoptoloop(cxstack_ix);
2449 DIE(aTHX_ "Can't \"next\" outside a loop block");
2452 cxix = dopoptolabel(cPVOP->op_pv);
2454 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2456 if (cxix < cxstack_ix)
2459 /* clear off anything above the scope we're re-entering, but
2460 * save the rest until after a possible continue block */
2461 inner = PL_scopestack_ix;
2463 if (PL_scopestack_ix < inner)
2464 leave_scope(PL_scopestack[PL_scopestack_ix]);
2465 PL_curcop = cx->blk_oldcop;
2466 return (cx)->blk_loop.my_op->op_nextop;
2473 register PERL_CONTEXT *cx;
2477 if (PL_op->op_flags & OPf_SPECIAL) {
2478 cxix = dopoptoloop(cxstack_ix);
2480 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2483 cxix = dopoptolabel(cPVOP->op_pv);
2485 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2487 if (cxix < cxstack_ix)
2490 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2491 if (redo_op->op_type == OP_ENTER) {
2492 /* pop one less context to avoid $x being freed in while (my $x..) */
2494 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2495 redo_op = redo_op->op_next;
2499 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2500 LEAVE_SCOPE(oldsave);
2502 PL_curcop = cx->blk_oldcop;
2507 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2511 static const char too_deep[] = "Target of goto is too deeply nested";
2513 PERL_ARGS_ASSERT_DOFINDLABEL;
2516 Perl_croak(aTHX_ too_deep);
2517 if (o->op_type == OP_LEAVE ||
2518 o->op_type == OP_SCOPE ||
2519 o->op_type == OP_LEAVELOOP ||
2520 o->op_type == OP_LEAVESUB ||
2521 o->op_type == OP_LEAVETRY)
2523 *ops++ = cUNOPo->op_first;
2525 Perl_croak(aTHX_ too_deep);
2528 if (o->op_flags & OPf_KIDS) {
2530 /* First try all the kids at this level, since that's likeliest. */
2531 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2532 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2533 const char *kid_label = CopLABEL(kCOP);
2534 if (kid_label && strEQ(kid_label, label))
2538 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2539 if (kid == PL_lastgotoprobe)
2541 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2544 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2545 ops[-1]->op_type == OP_DBSTATE)
2550 if ((o = dofindlabel(kid, label, ops, oplimit)))
2563 register PERL_CONTEXT *cx;
2564 #define GOTO_DEPTH 64
2565 OP *enterops[GOTO_DEPTH];
2566 const char *label = NULL;
2567 const bool do_dump = (PL_op->op_type == OP_DUMP);
2568 static const char must_have_label[] = "goto must have label";
2570 if (PL_op->op_flags & OPf_STACKED) {
2571 SV * const sv = POPs;
2573 /* This egregious kludge implements goto &subroutine */
2574 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2576 register PERL_CONTEXT *cx;
2577 CV *cv = MUTABLE_CV(SvRV(sv));
2584 if (!CvROOT(cv) && !CvXSUB(cv)) {
2585 const GV * const gv = CvGV(cv);
2589 /* autoloaded stub? */
2590 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2592 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2593 GvNAMELEN(gv), FALSE);
2594 if (autogv && (cv = GvCV(autogv)))
2596 tmpstr = sv_newmortal();
2597 gv_efullname3(tmpstr, gv, NULL);
2598 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2600 DIE(aTHX_ "Goto undefined subroutine");
2603 /* First do some returnish stuff. */
2604 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2606 cxix = dopoptosub(cxstack_ix);
2608 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2609 if (cxix < cxstack_ix)
2613 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2614 if (CxTYPE(cx) == CXt_EVAL) {
2616 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2618 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2620 else if (CxMULTICALL(cx))
2621 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2622 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2623 /* put @_ back onto stack */
2624 AV* av = cx->blk_sub.argarray;
2626 items = AvFILLp(av) + 1;
2627 EXTEND(SP, items+1); /* @_ could have been extended. */
2628 Copy(AvARRAY(av), SP + 1, items, SV*);
2629 SvREFCNT_dec(GvAV(PL_defgv));
2630 GvAV(PL_defgv) = cx->blk_sub.savearray;
2632 /* abandon @_ if it got reified */
2637 av_extend(av, items-1);
2639 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2642 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2643 AV* const av = GvAV(PL_defgv);
2644 items = AvFILLp(av) + 1;
2645 EXTEND(SP, items+1); /* @_ could have been extended. */
2646 Copy(AvARRAY(av), SP + 1, items, SV*);
2650 if (CxTYPE(cx) == CXt_SUB &&
2651 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2652 SvREFCNT_dec(cx->blk_sub.cv);
2653 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2654 LEAVE_SCOPE(oldsave);
2656 /* Now do some callish stuff. */
2658 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2660 OP* const retop = cx->blk_sub.retop;
2665 for (index=0; index<items; index++)
2666 sv_2mortal(SP[-index]);
2669 /* XS subs don't have a CxSUB, so pop it */
2670 POPBLOCK(cx, PL_curpm);
2671 /* Push a mark for the start of arglist */
2674 (void)(*CvXSUB(cv))(aTHX_ cv);
2679 AV* const padlist = CvPADLIST(cv);
2680 if (CxTYPE(cx) == CXt_EVAL) {
2681 PL_in_eval = CxOLD_IN_EVAL(cx);
2682 PL_eval_root = cx->blk_eval.old_eval_root;
2683 cx->cx_type = CXt_SUB;
2685 cx->blk_sub.cv = cv;
2686 cx->blk_sub.olddepth = CvDEPTH(cv);
2689 if (CvDEPTH(cv) < 2)
2690 SvREFCNT_inc_simple_void_NN(cv);
2692 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2693 sub_crush_depth(cv);
2694 pad_push(padlist, CvDEPTH(cv));
2697 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2700 AV *const av = MUTABLE_AV(PAD_SVl(0));
2702 cx->blk_sub.savearray = GvAV(PL_defgv);
2703 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2704 CX_CURPAD_SAVE(cx->blk_sub);
2705 cx->blk_sub.argarray = av;
2707 if (items >= AvMAX(av) + 1) {
2708 SV **ary = AvALLOC(av);
2709 if (AvARRAY(av) != ary) {
2710 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2713 if (items >= AvMAX(av) + 1) {
2714 AvMAX(av) = items - 1;
2715 Renew(ary,items+1,SV*);
2721 Copy(mark,AvARRAY(av),items,SV*);
2722 AvFILLp(av) = items - 1;
2723 assert(!AvREAL(av));
2725 /* transfer 'ownership' of refcnts to new @_ */
2735 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2736 Perl_get_db_sub(aTHX_ NULL, cv);
2738 CV * const gotocv = get_cvs("DB::goto", 0);
2740 PUSHMARK( PL_stack_sp );
2741 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2746 RETURNOP(CvSTART(cv));
2750 label = SvPV_nolen_const(sv);
2751 if (!(do_dump || *label))
2752 DIE(aTHX_ must_have_label);
2755 else if (PL_op->op_flags & OPf_SPECIAL) {
2757 DIE(aTHX_ must_have_label);
2760 label = cPVOP->op_pv;
2764 if (label && *label) {
2765 OP *gotoprobe = NULL;
2766 bool leaving_eval = FALSE;
2767 bool in_block = FALSE;
2768 PERL_CONTEXT *last_eval_cx = NULL;
2772 PL_lastgotoprobe = NULL;
2774 for (ix = cxstack_ix; ix >= 0; ix--) {
2776 switch (CxTYPE(cx)) {
2778 leaving_eval = TRUE;
2779 if (!CxTRYBLOCK(cx)) {
2780 gotoprobe = (last_eval_cx ?
2781 last_eval_cx->blk_eval.old_eval_root :
2786 /* else fall through */
2787 case CXt_LOOP_LAZYIV:
2788 case CXt_LOOP_LAZYSV:
2790 case CXt_LOOP_PLAIN:
2793 gotoprobe = cx->blk_oldcop->op_sibling;
2799 gotoprobe = cx->blk_oldcop->op_sibling;
2802 gotoprobe = PL_main_root;
2805 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2806 gotoprobe = CvROOT(cx->blk_sub.cv);
2812 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2815 DIE(aTHX_ "panic: goto");
2816 gotoprobe = PL_main_root;
2820 retop = dofindlabel(gotoprobe, label,
2821 enterops, enterops + GOTO_DEPTH);
2824 if (gotoprobe->op_sibling &&
2825 gotoprobe->op_sibling->op_type == OP_UNSTACK &&
2826 gotoprobe->op_sibling->op_sibling) {
2827 retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
2828 label, enterops, enterops + GOTO_DEPTH);
2833 PL_lastgotoprobe = gotoprobe;
2836 DIE(aTHX_ "Can't find label %s", label);
2838 /* if we're leaving an eval, check before we pop any frames
2839 that we're not going to punt, otherwise the error
2842 if (leaving_eval && *enterops && enterops[1]) {
2844 for (i = 1; enterops[i]; i++)
2845 if (enterops[i]->op_type == OP_ENTERITER)
2846 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2849 if (*enterops && enterops[1]) {
2850 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2852 deprecate("\"goto\" to jump into a construct");
2855 /* pop unwanted frames */
2857 if (ix < cxstack_ix) {
2864 oldsave = PL_scopestack[PL_scopestack_ix];
2865 LEAVE_SCOPE(oldsave);
2868 /* push wanted frames */
2870 if (*enterops && enterops[1]) {
2871 OP * const oldop = PL_op;
2872 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2873 for (; enterops[ix]; ix++) {
2874 PL_op = enterops[ix];
2875 /* Eventually we may want to stack the needed arguments
2876 * for each op. For now, we punt on the hard ones. */
2877 if (PL_op->op_type == OP_ENTERITER)
2878 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2879 PL_op->op_ppaddr(aTHX);
2887 if (!retop) retop = PL_main_start;
2889 PL_restartop = retop;
2890 PL_do_undump = TRUE;
2894 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2895 PL_do_undump = FALSE;
2912 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2914 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2917 PL_exit_flags |= PERL_EXIT_EXPECTED;
2919 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2920 if (anum || !(PL_minus_c && PL_madskills))
2925 PUSHs(&PL_sv_undef);
2932 S_save_lines(pTHX_ AV *array, SV *sv)
2934 const char *s = SvPVX_const(sv);
2935 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2938 PERL_ARGS_ASSERT_SAVE_LINES;
2940 while (s && s < send) {
2942 SV * const tmpstr = newSV_type(SVt_PVMG);
2944 t = (const char *)memchr(s, '\n', send - s);
2950 sv_setpvn(tmpstr, s, t - s);
2951 av_store(array, line++, tmpstr);
2959 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
2961 0 is used as continue inside eval,
2963 3 is used for a die caught by an inner eval - continue inner loop
2965 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
2966 establish a local jmpenv to handle exception traps.
2971 S_docatch(pTHX_ OP *o)
2975 OP * const oldop = PL_op;
2979 assert(CATCH_GET == TRUE);
2986 assert(cxstack_ix >= 0);
2987 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2988 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2993 /* die caught by an inner eval - continue inner loop */
2994 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
2995 PL_restartjmpenv = NULL;
2996 PL_op = PL_restartop;
3012 /* James Bond: Do you expect me to talk?
3013 Auric Goldfinger: No, Mr. Bond. I expect you to die.
3015 This code is an ugly hack, doesn't work with lexicals in subroutines that are
3016 called more than once, and is only used by regcomp.c, for (?{}) blocks.
3018 Currently it is not used outside the core code. Best if it stays that way.
3020 Hence it's now deprecated, and will be removed.
3023 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
3024 /* sv Text to convert to OP tree. */
3025 /* startop op_free() this to undo. */
3026 /* code Short string id of the caller. */
3028 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
3029 return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
3032 /* Don't use this. It will go away without warning once the regexp engine is
3033 refactored not to use it. */
3035 Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
3038 dVAR; dSP; /* Make POPBLOCK work. */
3044 char tbuf[TYPE_DIGITS(long) + 12 + 10];
3045 char *tmpbuf = tbuf;
3048 CV* runcv = NULL; /* initialise to avoid compiler warnings */
3052 PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
3054 ENTER_with_name("eval");
3055 lex_start(sv, NULL, 0);
3057 /* switch to eval mode */
3059 if (IN_PERL_COMPILETIME) {
3060 SAVECOPSTASH_FREE(&PL_compiling);
3061 CopSTASH_set(&PL_compiling, PL_curstash);
3063 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3064 SV * const sv = sv_newmortal();
3065 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
3066 code, (unsigned long)++PL_evalseq,
3067 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3072 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
3073 (unsigned long)++PL_evalseq);
3074 SAVECOPFILE_FREE(&PL_compiling);
3075 CopFILE_set(&PL_compiling, tmpbuf+2);
3076 SAVECOPLINE(&PL_compiling);
3077 CopLINE_set(&PL_compiling, 1);
3078 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3079 deleting the eval's FILEGV from the stash before gv_check() runs
3080 (i.e. before run-time proper). To work around the coredump that
3081 ensues, we always turn GvMULTI_on for any globals that were
3082 introduced within evals. See force_ident(). GSAR 96-10-12 */
3083 safestr = savepvn(tmpbuf, len);
3084 SAVEDELETE(PL_defstash, safestr, len);
3086 #ifdef OP_IN_REGISTER
3092 /* we get here either during compilation, or via pp_regcomp at runtime */
3093 runtime = IN_PERL_RUNTIME;
3096 runcv = find_runcv(NULL);
3098 /* At run time, we have to fetch the hints from PL_curcop. */
3099 PL_hints = PL_curcop->cop_hints;
3100 if (PL_hints & HINT_LOCALIZE_HH) {
3101 /* SAVEHINTS created a new HV in PL_hintgv, which we
3103 SvREFCNT_dec(GvHV(PL_hintgv));
3105 refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
3106 hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
3108 SAVECOMPILEWARNINGS();
3109 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3110 cophh_free(CopHINTHASH_get(&PL_compiling));
3111 /* XXX Does this need to avoid copying a label? */
3112 PL_compiling.cop_hints_hash
3113 = cophh_copy(PL_curcop->cop_hints_hash);
3117 PL_op->op_type = OP_ENTEREVAL;
3118 PL_op->op_flags = 0; /* Avoid uninit warning. */
3119 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
3121 need_catch = CATCH_GET;
3125 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
3127 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
3128 CATCH_SET(need_catch);
3129 POPBLOCK(cx,PL_curpm);
3132 (*startop)->op_type = OP_NULL;
3133 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
3134 /* XXX DAPM do this properly one year */
3135 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
3136 LEAVE_with_name("eval");
3137 if (IN_PERL_COMPILETIME)
3138 CopHINTS_set(&PL_compiling, PL_hints);
3139 #ifdef OP_IN_REGISTER
3142 PERL_UNUSED_VAR(newsp);
3143 PERL_UNUSED_VAR(optype);
3145 return PL_eval_start;
3150 =for apidoc find_runcv
3152 Locate the CV corresponding to the currently executing sub or eval.
3153 If db_seqp is non_null, skip CVs that are in the DB package and populate
3154 *db_seqp with the cop sequence number at the point that the DB:: code was
3155 entered. (allows debuggers to eval in the scope of the breakpoint rather
3156 than in the scope of the debugger itself).
3162 Perl_find_runcv(pTHX_ U32 *db_seqp)
3168 *db_seqp = PL_curcop->cop_seq;
3169 for (si = PL_curstackinfo; si; si = si->si_prev) {
3171 for (ix = si->si_cxix; ix >= 0; ix--) {
3172 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3173 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3174 CV * const cv = cx->blk_sub.cv;
3175 /* skip DB:: code */
3176 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3177 *db_seqp = cx->blk_oldcop->cop_seq;
3182 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3190 /* Run yyparse() in a setjmp wrapper. Returns:
3191 * 0: yyparse() successful
3192 * 1: yyparse() failed
3196 S_try_yyparse(pTHX_ int gramtype)
3201 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3205 ret = yyparse(gramtype) ? 1 : 0;
3219 /* Compile a require/do, an eval '', or a /(?{...})/.
3220 * In the last case, startop is non-null, and contains the address of
3221 * a pointer that should be set to the just-compiled code.
3222 * outside is the lexically enclosing CV (if any) that invoked us.
3223 * Returns a bool indicating whether the compile was successful; if so,
3224 * PL_eval_start contains the first op of the compiled ocde; otherwise,
3225 * pushes undef (also croaks if startop != NULL).
3229 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3232 OP * const saveop = PL_op;
3233 bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3236 PL_in_eval = (in_require
3237 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3242 SAVESPTR(PL_compcv);
3243 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3244 CvEVAL_on(PL_compcv);
3245 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3246 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3248 CvOUTSIDE_SEQ(PL_compcv) = seq;
3249 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3251 /* set up a scratch pad */
3253 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3254 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3258 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3260 /* make sure we compile in the right package */
3262 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3263 SAVESPTR(PL_curstash);
3264 PL_curstash = CopSTASH(PL_curcop);
3266 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3267 SAVESPTR(PL_beginav);
3268 PL_beginav = newAV();
3269 SAVEFREESV(PL_beginav);
3270 SAVESPTR(PL_unitcheckav);
3271 PL_unitcheckav = newAV();
3272 SAVEFREESV(PL_unitcheckav);
3275 SAVEBOOL(PL_madskills);
3279 /* try to compile it */
3281 PL_eval_root = NULL;
3282 PL_curcop = &PL_compiling;
3283 CopARYBASE_set(PL_curcop, 0);
3284 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3285 PL_in_eval |= EVAL_KEEPERR;
3289 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3291 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3292 * so honour CATCH_GET and trap it here if necessary */
3294 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3296 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3297 SV **newsp; /* Used by POPBLOCK. */
3298 PERL_CONTEXT *cx = NULL;
3299 I32 optype; /* Used by POPEVAL. */
3303 PERL_UNUSED_VAR(newsp);
3304 PERL_UNUSED_VAR(optype);
3306 /* note that if yystatus == 3, then the EVAL CX block has already
3307 * been popped, and various vars restored */
3309 if (yystatus != 3) {
3311 op_free(PL_eval_root);
3312 PL_eval_root = NULL;
3314 SP = PL_stack_base + POPMARK; /* pop original mark */
3316 POPBLOCK(cx,PL_curpm);
3318 namesv = cx->blk_eval.old_namesv;
3322 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3324 msg = SvPVx_nolen_const(ERRSV);
3327 /* If cx is still NULL, it means that we didn't go in the
3328 * POPEVAL branch. */
3329 cx = &cxstack[cxstack_ix];
3330 assert(CxTYPE(cx) == CXt_EVAL);
3331 namesv = cx->blk_eval.old_namesv;
3333 (void)hv_store(GvHVn(PL_incgv),
3334 SvPVX_const(namesv), SvCUR(namesv),
3336 Perl_croak(aTHX_ "%sCompilation failed in require",
3337 *msg ? msg : "Unknown error\n");
3340 if (yystatus != 3) {
3341 POPBLOCK(cx,PL_curpm);
3344 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3345 (*msg ? msg : "Unknown error\n"));
3349 sv_setpvs(ERRSV, "Compilation error");
3352 PUSHs(&PL_sv_undef);
3356 CopLINE_set(&PL_compiling, 0);
3358 *startop = PL_eval_root;
3360 SAVEFREEOP(PL_eval_root);
3362 /* Set the context for this new optree.
3363 * Propagate the context from the eval(). */
3364 if ((gimme & G_WANT) == G_VOID)
3365 scalarvoid(PL_eval_root);
3366 else if ((gimme & G_WANT) == G_ARRAY)
3369 scalar(PL_eval_root);
3371 DEBUG_x(dump_eval());
3373 /* Register with debugger: */
3374 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3375 CV * const cv = get_cvs("DB::postponed", 0);
3379 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3381 call_sv(MUTABLE_SV(cv), G_DISCARD);
3385 if (PL_unitcheckav) {
3386 OP *es = PL_eval_start;
3387 call_list(PL_scopestack_ix, PL_unitcheckav);
3391 /* compiled okay, so do it */
3393 CvDEPTH(PL_compcv) = 1;
3394 SP = PL_stack_base + POPMARK; /* pop original mark */
3395 PL_op = saveop; /* The caller may need it. */
3396 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3403 S_check_type_and_open(pTHX_ SV *name)
3406 const char *p = SvPV_nolen_const(name);
3407 const int st_rc = PerlLIO_stat(p, &st);
3409 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3411 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3415 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3416 return PerlIO_openn(aTHX_ NULL, PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3418 return PerlIO_open(p, PERL_SCRIPT_MODE);
3422 #ifndef PERL_DISABLE_PMC
3424 S_doopen_pm(pTHX_ SV *name)
3427 const char *p = SvPV_const(name, namelen);
3429 PERL_ARGS_ASSERT_DOOPEN_PM;
3431 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3432 SV *const pmcsv = sv_mortalcopy(name);
3435 sv_catpvn(pmcsv, "c", 1);
3437 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3438 return check_type_and_open(pmcsv);
3440 return check_type_and_open(name);
3443 # define doopen_pm(name) check_type_and_open(name)
3444 #endif /* !PERL_DISABLE_PMC */
3449 register PERL_CONTEXT *cx;
3456 int vms_unixname = 0;
3458 const char *tryname = NULL;
3460 const I32 gimme = GIMME_V;
3461 int filter_has_file = 0;
3462 PerlIO *tryrsfp = NULL;
3463 SV *filter_cache = NULL;
3464 SV *filter_state = NULL;
3465 SV *filter_sub = NULL;
3471 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3472 sv = sv_2mortal(new_version(sv));
3473 if (!sv_derived_from(PL_patchlevel, "version"))
3474 upg_version(PL_patchlevel, TRUE);
3475 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3476 if ( vcmp(sv,PL_patchlevel) <= 0 )
3477 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3478 SVfARG(sv_2mortal(vnormal(sv))),
3479 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3483 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3486 SV * const req = SvRV(sv);
3487 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3489 /* get the left hand term */
3490 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3492 first = SvIV(*av_fetch(lav,0,0));
3493 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3494 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3495 || av_len(lav) > 1 /* FP with > 3 digits */
3496 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3498 DIE(aTHX_ "Perl %"SVf" required--this is only "
3500 SVfARG(sv_2mortal(vnormal(req))),
3501 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3504 else { /* probably 'use 5.10' or 'use 5.8' */
3509 second = SvIV(*av_fetch(lav,1,0));
3511 second /= second >= 600 ? 100 : 10;
3512 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3513 (int)first, (int)second);
3514 upg_version(hintsv, TRUE);
3516 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3517 "--this is only %"SVf", stopped",
3518 SVfARG(sv_2mortal(vnormal(req))),
3519 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3520 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3528 name = SvPV_const(sv, len);
3529 if (!(name && len > 0 && *name))
3530 DIE(aTHX_ "Null filename used");
3531 TAINT_PROPER("require");
3535 /* The key in the %ENV hash is in the syntax of file passed as the argument
3536 * usually this is in UNIX format, but sometimes in VMS format, which
3537 * can result in a module being pulled in more than once.
3538 * To prevent this, the key must be stored in UNIX format if the VMS
3539 * name can be translated to UNIX.
3541 if ((unixname = tounixspec(name, NULL)) != NULL) {
3542 unixlen = strlen(unixname);
3548 /* if not VMS or VMS name can not be translated to UNIX, pass it
3551 unixname = (char *) name;
3554 if (PL_op->op_type == OP_REQUIRE) {
3555 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3556 unixname, unixlen, 0);
3558 if (*svp != &PL_sv_undef)
3561 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3562 "Compilation failed in require", unixname);
3566 /* prepare to compile file */
3568 if (path_is_absolute(name)) {
3569 /* At this point, name is SvPVX(sv) */
3571 tryrsfp = doopen_pm(sv);
3574 AV * const ar = GvAVn(PL_incgv);
3580 namesv = newSV_type(SVt_PV);
3581 for (i = 0; i <= AvFILL(ar); i++) {
3582 SV * const dirsv = *av_fetch(ar, i, TRUE);
3584 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3591 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3592 && !sv_isobject(loader))
3594 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3597 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3598 PTR2UV(SvRV(dirsv)), name);
3599 tryname = SvPVX_const(namesv);
3602 ENTER_with_name("call_INC");
3610 if (sv_isobject(loader))
3611 count = call_method("INC", G_ARRAY);
3613 count = call_sv(loader, G_ARRAY);
3623 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3624 && !isGV_with_GP(SvRV(arg))) {
3625 filter_cache = SvRV(arg);
3626 SvREFCNT_inc_simple_void_NN(filter_cache);
3633 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3637 if (isGV_with_GP(arg)) {
3638 IO * const io = GvIO((const GV *)arg);
3643 tryrsfp = IoIFP(io);
3644 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3645 PerlIO_close(IoOFP(io));
3656 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3658 SvREFCNT_inc_simple_void_NN(filter_sub);
3661 filter_state = SP[i];
3662 SvREFCNT_inc_simple_void(filter_state);
3666 if (!tryrsfp && (filter_cache || filter_sub)) {
3667 tryrsfp = PerlIO_open(BIT_BUCKET,
3675 LEAVE_with_name("call_INC");
3677 /* Adjust file name if the hook has set an %INC entry.
3678 This needs to happen after the FREETMPS above. */
3679 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3681 tryname = SvPV_nolen_const(*svp);
3688 filter_has_file = 0;
3690 SvREFCNT_dec(filter_cache);
3691 filter_cache = NULL;
3694 SvREFCNT_dec(filter_state);
3695 filter_state = NULL;
3698 SvREFCNT_dec(filter_sub);
3703 if (!path_is_absolute(name)
3709 dir = SvPV_const(dirsv, dirlen);
3717 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3719 sv_setpv(namesv, unixdir);
3720 sv_catpv(namesv, unixname);
3722 # ifdef __SYMBIAN32__
3723 if (PL_origfilename[0] &&
3724 PL_origfilename[1] == ':' &&
3725 !(dir[0] && dir[1] == ':'))
3726 Perl_sv_setpvf(aTHX_ namesv,
3731 Perl_sv_setpvf(aTHX_ namesv,
3735 /* The equivalent of
3736 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3737 but without the need to parse the format string, or
3738 call strlen on either pointer, and with the correct
3739 allocation up front. */
3741 char *tmp = SvGROW(namesv, dirlen + len + 2);
3743 memcpy(tmp, dir, dirlen);
3746 /* name came from an SV, so it will have a '\0' at the
3747 end that we can copy as part of this memcpy(). */
3748 memcpy(tmp, name, len + 1);
3750 SvCUR_set(namesv, dirlen + len + 1);
3755 TAINT_PROPER("require");
3756 tryname = SvPVX_const(namesv);
3757 tryrsfp = doopen_pm(namesv);
3759 if (tryname[0] == '.' && tryname[1] == '/') {
3761 while (*++tryname == '/');
3765 else if (errno == EMFILE)
3766 /* no point in trying other paths if out of handles */
3775 if (PL_op->op_type == OP_REQUIRE) {
3776 if(errno == EMFILE) {
3777 /* diag_listed_as: Can't locate %s */
3778 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(errno));
3780 if (namesv) { /* did we lookup @INC? */
3781 AV * const ar = GvAVn(PL_incgv);
3783 SV *const inc = newSVpvs_flags("", SVs_TEMP);
3784 for (i = 0; i <= AvFILL(ar); i++) {
3785 sv_catpvs(inc, " ");
3786 sv_catsv(inc, *av_fetch(ar, i, TRUE));
3789 /* diag_listed_as: Can't locate %s */
3791 "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
3793 (memEQ(name + len - 2, ".h", 3)
3794 ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
3795 (memEQ(name + len - 3, ".ph", 4)
3796 ? " (did you run h2ph?)" : ""),
3801 DIE(aTHX_ "Can't locate %s", name);
3807 SETERRNO(0, SS_NORMAL);
3809 /* Assume success here to prevent recursive requirement. */
3810 /* name is never assigned to again, so len is still strlen(name) */
3811 /* Check whether a hook in @INC has already filled %INC */
3813 (void)hv_store(GvHVn(PL_incgv),
3814 unixname, unixlen, newSVpv(tryname,0),0);
3816 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3818 (void)hv_store(GvHVn(PL_incgv),
3819 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3822 ENTER_with_name("eval");
3824 SAVECOPFILE_FREE(&PL_compiling);
3825 CopFILE_set(&PL_compiling, tryname);
3826 lex_start(NULL, tryrsfp, 0);
3830 hv_clear(GvHV(PL_hintgv));
3832 SAVECOMPILEWARNINGS();
3833 if (PL_dowarn & G_WARN_ALL_ON)
3834 PL_compiling.cop_warnings = pWARN_ALL ;
3835 else if (PL_dowarn & G_WARN_ALL_OFF)
3836 PL_compiling.cop_warnings = pWARN_NONE ;
3838 PL_compiling.cop_warnings = pWARN_STD ;
3840 if (filter_sub || filter_cache) {
3841 /* We can use the SvPV of the filter PVIO itself as our cache, rather
3842 than hanging another SV from it. In turn, filter_add() optionally
3843 takes the SV to use as the filter (or creates a new SV if passed
3844 NULL), so simply pass in whatever value filter_cache has. */
3845 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3846 IoLINES(datasv) = filter_has_file;
3847 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3848 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3851 /* switch to eval mode */
3852 PUSHBLOCK(cx, CXt_EVAL, SP);
3854 cx->blk_eval.retop = PL_op->op_next;
3856 SAVECOPLINE(&PL_compiling);
3857 CopLINE_set(&PL_compiling, 0);
3861 /* Store and reset encoding. */
3862 encoding = PL_encoding;
3865 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3866 op = DOCATCH(PL_eval_start);
3868 op = PL_op->op_next;
3870 /* Restore encoding. */
3871 PL_encoding = encoding;
3876 /* This is a op added to hold the hints hash for
3877 pp_entereval. The hash can be modified by the code
3878 being eval'ed, so we return a copy instead. */
3884 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
3892 register PERL_CONTEXT *cx;
3894 const I32 gimme = GIMME_V;
3895 const U32 was = PL_breakable_sub_gen;
3896 char tbuf[TYPE_DIGITS(long) + 12];
3897 bool saved_delete = FALSE;
3898 char *tmpbuf = tbuf;
3902 HV *saved_hh = NULL;
3904 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3905 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3909 /* make sure we've got a plain PV (no overload etc) before testing
3910 * for taint. Making a copy here is probably overkill, but better
3911 * safe than sorry */
3913 const char * const p = SvPV_const(sv, len);
3915 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
3918 TAINT_IF(SvTAINTED(sv));
3919 TAINT_PROPER("eval");
3921 ENTER_with_name("eval");
3922 lex_start(sv, NULL, 0);
3925 /* switch to eval mode */
3927 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3928 SV * const temp_sv = sv_newmortal();
3929 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3930 (unsigned long)++PL_evalseq,
3931 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3932 tmpbuf = SvPVX(temp_sv);
3933 len = SvCUR(temp_sv);
3936 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3937 SAVECOPFILE_FREE(&PL_compiling);
3938 CopFILE_set(&PL_compiling, tmpbuf+2);
3939 SAVECOPLINE(&PL_compiling);
3940 CopLINE_set(&PL_compiling, 1);
3941 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3942 deleting the eval's FILEGV from the stash before gv_check() runs
3943 (i.e. before run-time proper). To work around the coredump that
3944 ensues, we always turn GvMULTI_on for any globals that were
3945 introduced within evals. See force_ident(). GSAR 96-10-12 */
3947 PL_hints = PL_op->op_targ;
3949 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3950 SvREFCNT_dec(GvHV(PL_hintgv));
3951 GvHV(PL_hintgv) = saved_hh;
3953 SAVECOMPILEWARNINGS();
3954 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3955 cophh_free(CopHINTHASH_get(&PL_compiling));
3956 if (Perl_fetch_cop_label(aTHX_ PL_curcop, NULL, NULL)) {
3957 /* The label, if present, is the first entry on the chain. So rather
3958 than writing a blank label in front of it (which involves an
3959 allocation), just use the next entry in the chain. */
3960 PL_compiling.cop_hints_hash
3961 = cophh_copy(PL_curcop->cop_hints_hash->refcounted_he_next);
3962 /* Check the assumption that this removed the label. */
3963 assert(Perl_fetch_cop_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3966 PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash);
3967 /* special case: an eval '' executed within the DB package gets lexically
3968 * placed in the first non-DB CV rather than the current CV - this
3969 * allows the debugger to execute code, find lexicals etc, in the
3970 * scope of the code being debugged. Passing &seq gets find_runcv
3971 * to do the dirty work for us */
3972 runcv = find_runcv(&seq);
3974 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3976 cx->blk_eval.retop = PL_op->op_next;
3978 /* prepare to compile string */
3980 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3981 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3983 char *const safestr = savepvn(tmpbuf, len);
3984 SAVEDELETE(PL_defstash, safestr, len);
3985 saved_delete = TRUE;
3990 if (doeval(gimme, NULL, runcv, seq)) {
3991 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3992 ? (PERLDB_LINE || PERLDB_SAVESRC)
3993 : PERLDB_SAVESRC_NOSUBS) {
3994 /* Retain the filegv we created. */
3995 } else if (!saved_delete) {
3996 char *const safestr = savepvn(tmpbuf, len);
3997 SAVEDELETE(PL_defstash, safestr, len);
3999 return DOCATCH(PL_eval_start);
4001 /* We have already left the scope set up earlier thanks to the LEAVE
4003 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4004 ? (PERLDB_LINE || PERLDB_SAVESRC)
4005 : PERLDB_SAVESRC_INVALID) {
4006 /* Retain the filegv we created. */
4007 } else if (!saved_delete) {
4008 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4010 return PL_op->op_next;
4021 register PERL_CONTEXT *cx;
4023 const U8 save_flags = PL_op -> op_flags;
4029 namesv = cx->blk_eval.old_namesv;
4030 retop = cx->blk_eval.retop;
4033 if (gimme == G_VOID)
4035 else if (gimme == G_SCALAR) {
4038 if (SvFLAGS(TOPs) & SVs_TEMP)
4041 *MARK = sv_mortalcopy(TOPs);
4045 *MARK = &PL_sv_undef;
4050 /* in case LEAVE wipes old return values */
4051 for (mark = newsp + 1; mark <= SP; mark++) {
4052 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
4053 *mark = sv_mortalcopy(*mark);
4054 TAINT_NOT; /* Each item is independent */
4058 PL_curpm = newpm; /* Don't pop $1 et al till now */
4061 assert(CvDEPTH(PL_compcv) == 1);
4063 CvDEPTH(PL_compcv) = 0;
4065 if (optype == OP_REQUIRE &&
4066 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4068 /* Unassume the success we assumed earlier. */
4069 (void)hv_delete(GvHVn(PL_incgv),
4070 SvPVX_const(namesv), SvCUR(namesv),
4072 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4074 /* die_unwind() did LEAVE, or we won't be here */
4077 LEAVE_with_name("eval");
4078 if (!(save_flags & OPf_SPECIAL)) {
4086 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4087 close to the related Perl_create_eval_scope. */
4089 Perl_delete_eval_scope(pTHX)
4094 register PERL_CONTEXT *cx;
4100 LEAVE_with_name("eval_scope");
4101 PERL_UNUSED_VAR(newsp);
4102 PERL_UNUSED_VAR(gimme);
4103 PERL_UNUSED_VAR(optype);
4106 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4107 also needed by Perl_fold_constants. */
4109 Perl_create_eval_scope(pTHX_ U32 flags)
4112 const I32 gimme = GIMME_V;
4114 ENTER_with_name("eval_scope");
4117 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4120 PL_in_eval = EVAL_INEVAL;
4121 if (flags & G_KEEPERR)
4122 PL_in_eval |= EVAL_KEEPERR;
4125 if (flags & G_FAKINGEVAL) {
4126 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4134 PERL_CONTEXT * const cx = create_eval_scope(0);
4135 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4136 return DOCATCH(PL_op->op_next);
4145 register PERL_CONTEXT *cx;
4150 PERL_UNUSED_VAR(optype);
4153 if (gimme == G_VOID)
4155 else if (gimme == G_SCALAR) {
4159 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4162 *MARK = sv_mortalcopy(TOPs);
4166 *MARK = &PL_sv_undef;
4171 /* in case LEAVE wipes old return values */
4173 for (mark = newsp + 1; mark <= SP; mark++) {
4174 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4175 *mark = sv_mortalcopy(*mark);
4176 TAINT_NOT; /* Each item is independent */
4180 PL_curpm = newpm; /* Don't pop $1 et al till now */
4182 LEAVE_with_name("eval_scope");
4190 register PERL_CONTEXT *cx;
4191 const I32 gimme = GIMME_V;
4193 ENTER_with_name("given");
4196 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
4198 PUSHBLOCK(cx, CXt_GIVEN, SP);
4207 register PERL_CONTEXT *cx;
4211 PERL_UNUSED_CONTEXT;
4214 assert(CxTYPE(cx) == CXt_GIVEN);
4217 if (gimme == G_VOID)
4219 else if (gimme == G_SCALAR) {
4223 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4226 *MARK = sv_mortalcopy(TOPs);
4230 *MARK = &PL_sv_undef;
4235 /* in case LEAVE wipes old return values */
4237 for (mark = newsp + 1; mark <= SP; mark++) {
4238 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4239 *mark = sv_mortalcopy(*mark);
4240 TAINT_NOT; /* Each item is independent */
4244 PL_curpm = newpm; /* Don't pop $1 et al till now */
4246 LEAVE_with_name("given");
4250 /* Helper routines used by pp_smartmatch */
4252 S_make_matcher(pTHX_ REGEXP *re)
4255 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4257 PERL_ARGS_ASSERT_MAKE_MATCHER;
4259 PM_SETRE(matcher, ReREFCNT_inc(re));
4261 SAVEFREEOP((OP *) matcher);
4262 ENTER_with_name("matcher"); SAVETMPS;
4268 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4273 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4275 PL_op = (OP *) matcher;
4278 (void) Perl_pp_match(aTHX);
4280 return (SvTRUEx(POPs));
4284 S_destroy_matcher(pTHX_ PMOP *matcher)
4288 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4289 PERL_UNUSED_ARG(matcher);
4292 LEAVE_with_name("matcher");
4295 /* Do a smart match */
4298 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4299 return do_smartmatch(NULL, NULL);
4302 /* This version of do_smartmatch() implements the
4303 * table of smart matches that is found in perlsyn.
4306 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4311 bool object_on_left = FALSE;
4312 SV *e = TOPs; /* e is for 'expression' */
4313 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4315 /* Take care only to invoke mg_get() once for each argument.
4316 * Currently we do this by copying the SV if it's magical. */
4319 d = sv_mortalcopy(d);
4326 e = sv_mortalcopy(e);
4328 /* First of all, handle overload magic of the rightmost argument */
4331 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4332 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4334 tmpsv = amagic_call(d, e, smart_amg, 0);
4341 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4344 SP -= 2; /* Pop the values */
4349 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4356 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4357 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4358 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4360 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4361 object_on_left = TRUE;
4364 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4366 if (object_on_left) {
4367 goto sm_any_sub; /* Treat objects like scalars */
4369 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4370 /* Test sub truth for each key */
4372 bool andedresults = TRUE;
4373 HV *hv = (HV*) SvRV(d);
4374 I32 numkeys = hv_iterinit(hv);
4375 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4378 while ( (he = hv_iternext(hv)) ) {
4379 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4380 ENTER_with_name("smartmatch_hash_key_test");
4383 PUSHs(hv_iterkeysv(he));
4385 c = call_sv(e, G_SCALAR);
4388 andedresults = FALSE;
4390 andedresults = SvTRUEx(POPs) && andedresults;
4392 LEAVE_with_name("smartmatch_hash_key_test");
4399 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4400 /* Test sub truth for each element */
4402 bool andedresults = TRUE;
4403 AV *av = (AV*) SvRV(d);
4404 const I32 len = av_len(av);
4405 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4408 for (i = 0; i <= len; ++i) {
4409 SV * const * const svp = av_fetch(av, i, FALSE);
4410 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4411 ENTER_with_name("smartmatch_array_elem_test");
4417 c = call_sv(e, G_SCALAR);
4420 andedresults = FALSE;
4422 andedresults = SvTRUEx(POPs) && andedresults;
4424 LEAVE_with_name("smartmatch_array_elem_test");
4433 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4434 ENTER_with_name("smartmatch_coderef");
4439 c = call_sv(e, G_SCALAR);
4443 else if (SvTEMP(TOPs))
4444 SvREFCNT_inc_void(TOPs);
4446 LEAVE_with_name("smartmatch_coderef");
4451 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4452 if (object_on_left) {
4453 goto sm_any_hash; /* Treat objects like scalars */
4455 else if (!SvOK(d)) {
4456 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4459 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4460 /* Check that the key-sets are identical */
4462 HV *other_hv = MUTABLE_HV(SvRV(d));
4464 bool other_tied = FALSE;
4465 U32 this_key_count = 0,
4466 other_key_count = 0;
4467 HV *hv = MUTABLE_HV(SvRV(e));
4469 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4470 /* Tied hashes don't know how many keys they have. */
4471 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4474 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4475 HV * const temp = other_hv;
4480 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4483 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4486 /* The hashes have the same number of keys, so it suffices
4487 to check that one is a subset of the other. */
4488 (void) hv_iterinit(hv);
4489 while ( (he = hv_iternext(hv)) ) {
4490 SV *key = hv_iterkeysv(he);
4492 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4495 if(!hv_exists_ent(other_hv, key, 0)) {
4496 (void) hv_iterinit(hv); /* reset iterator */
4502 (void) hv_iterinit(other_hv);
4503 while ( hv_iternext(other_hv) )
4507 other_key_count = HvUSEDKEYS(other_hv);
4509 if (this_key_count != other_key_count)
4514 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4515 AV * const other_av = MUTABLE_AV(SvRV(d));
4516 const I32 other_len = av_len(other_av) + 1;
4518 HV *hv = MUTABLE_HV(SvRV(e));
4520 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4521 for (i = 0; i < other_len; ++i) {
4522 SV ** const svp = av_fetch(other_av, i, FALSE);
4523 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4524 if (svp) { /* ??? When can this not happen? */
4525 if (hv_exists_ent(hv, *svp, 0))
4531 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4532 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4535 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4537 HV *hv = MUTABLE_HV(SvRV(e));
4539 (void) hv_iterinit(hv);
4540 while ( (he = hv_iternext(hv)) ) {
4541 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4542 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4543 (void) hv_iterinit(hv);
4544 destroy_matcher(matcher);
4548 destroy_matcher(matcher);
4554 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4555 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4562 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4563 if (object_on_left) {
4564 goto sm_any_array; /* Treat objects like scalars */
4566 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4567 AV * const other_av = MUTABLE_AV(SvRV(e));
4568 const I32 other_len = av_len(other_av) + 1;
4571 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4572 for (i = 0; i < other_len; ++i) {
4573 SV ** const svp = av_fetch(other_av, i, FALSE);
4575 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4576 if (svp) { /* ??? When can this not happen? */
4577 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4583 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4584 AV *other_av = MUTABLE_AV(SvRV(d));
4585 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4586 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4590 const I32 other_len = av_len(other_av);
4592 if (NULL == seen_this) {
4593 seen_this = newHV();
4594 (void) sv_2mortal(MUTABLE_SV(seen_this));
4596 if (NULL == seen_other) {
4597 seen_other = newHV();
4598 (void) sv_2mortal(MUTABLE_SV(seen_other));
4600 for(i = 0; i <= other_len; ++i) {
4601 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4602 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4604 if (!this_elem || !other_elem) {
4605 if ((this_elem && SvOK(*this_elem))
4606 || (other_elem && SvOK(*other_elem)))
4609 else if (hv_exists_ent(seen_this,
4610 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4611 hv_exists_ent(seen_other,
4612 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4614 if (*this_elem != *other_elem)
4618 (void)hv_store_ent(seen_this,
4619 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4621 (void)hv_store_ent(seen_other,
4622 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4628 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4629 (void) do_smartmatch(seen_this, seen_other);
4631 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4640 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4641 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4644 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4645 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4648 for(i = 0; i <= this_len; ++i) {
4649 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4650 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4651 if (svp && matcher_matches_sv(matcher, *svp)) {
4652 destroy_matcher(matcher);
4656 destroy_matcher(matcher);
4660 else if (!SvOK(d)) {
4661 /* undef ~~ array */
4662 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4665 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4666 for (i = 0; i <= this_len; ++i) {
4667 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4668 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4669 if (!svp || !SvOK(*svp))
4678 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4680 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4681 for (i = 0; i <= this_len; ++i) {
4682 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4689 /* infinite recursion isn't supposed to happen here */
4690 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4691 (void) do_smartmatch(NULL, NULL);
4693 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4702 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4703 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4704 SV *t = d; d = e; e = t;
4705 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4708 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4709 SV *t = d; d = e; e = t;
4710 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4711 goto sm_regex_array;
4714 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4716 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4718 PUSHs(matcher_matches_sv(matcher, d)
4721 destroy_matcher(matcher);
4726 /* See if there is overload magic on left */
4727 else if (object_on_left && SvAMAGIC(d)) {
4729 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4730 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4733 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4741 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4744 else if (!SvOK(d)) {
4745 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4746 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4751 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4752 DEBUG_M(if (SvNIOK(e))
4753 Perl_deb(aTHX_ " applying rule Any-Num\n");
4755 Perl_deb(aTHX_ " applying rule Num-numish\n");
4757 /* numeric comparison */
4760 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4761 (void) Perl_pp_i_eq(aTHX);
4763 (void) Perl_pp_eq(aTHX);
4771 /* As a last resort, use string comparison */
4772 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4775 return Perl_pp_seq(aTHX);
4781 register PERL_CONTEXT *cx;
4782 const I32 gimme = GIMME_V;
4784 /* This is essentially an optimization: if the match
4785 fails, we don't want to push a context and then
4786 pop it again right away, so we skip straight
4787 to the op that follows the leavewhen.
4788 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4790 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4791 RETURNOP(cLOGOP->op_other->op_next);
4793 ENTER_with_name("eval");
4796 PUSHBLOCK(cx, CXt_WHEN, SP);
4805 register PERL_CONTEXT *cx;
4811 assert(CxTYPE(cx) == CXt_WHEN);
4816 PL_curpm = newpm; /* pop $1 et al */
4818 LEAVE_with_name("eval");
4826 register PERL_CONTEXT *cx;
4829 cxix = dopoptowhen(cxstack_ix);
4831 DIE(aTHX_ "Can't \"continue\" outside a when block");
4832 if (cxix < cxstack_ix)
4835 /* clear off anything above the scope we're re-entering */
4836 inner = PL_scopestack_ix;
4838 if (PL_scopestack_ix < inner)
4839 leave_scope(PL_scopestack[PL_scopestack_ix]);
4840 PL_curcop = cx->blk_oldcop;
4841 return cx->blk_givwhen.leave_op;
4848 register PERL_CONTEXT *cx;
4852 cxix = dopoptogiven(cxstack_ix);
4854 if (PL_op->op_flags & OPf_SPECIAL)
4855 DIE(aTHX_ "Can't use when() outside a topicalizer");
4857 DIE(aTHX_ "Can't \"break\" outside a given block");
4859 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4860 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4862 if (cxix < cxstack_ix)
4865 /* clear off anything above the scope we're re-entering */
4866 inner = PL_scopestack_ix;
4868 if (PL_scopestack_ix < inner)
4869 leave_scope(PL_scopestack[PL_scopestack_ix]);
4870 PL_curcop = cx->blk_oldcop;
4873 return (cx)->blk_loop.my_op->op_nextop;
4875 /* RETURNOP calls PUTBACK which restores the old old sp */
4876 RETURNOP(cx->blk_givwhen.leave_op);
4880 S_doparseform(pTHX_ SV *sv)
4883 register char *s = SvPV_force(sv, len);
4884 register char * const send = s + len;
4885 register char *base = NULL;
4886 register I32 skipspaces = 0;
4887 bool noblank = FALSE;
4888 bool repeat = FALSE;
4889 bool postspace = FALSE;
4895 bool unchopnum = FALSE;
4896 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4898 PERL_ARGS_ASSERT_DOPARSEFORM;
4901 Perl_croak(aTHX_ "Null picture in formline");
4903 /* estimate the buffer size needed */
4904 for (base = s; s <= send; s++) {
4905 if (*s == '\n' || *s == '@' || *s == '^')
4911 Newx(fops, maxops, U32);
4916 *fpc++ = FF_LINEMARK;
4917 noblank = repeat = FALSE;
4935 case ' ': case '\t':
4942 } /* else FALL THROUGH */
4950 *fpc++ = FF_LITERAL;
4958 *fpc++ = (U16)skipspaces;
4962 *fpc++ = FF_NEWLINE;
4966 arg = fpc - linepc + 1;
4973 *fpc++ = FF_LINEMARK;
4974 noblank = repeat = FALSE;
4983 ischop = s[-1] == '^';
4989 arg = (s - base) - 1;
4991 *fpc++ = FF_LITERAL;
4999 *fpc++ = 2; /* skip the @* or ^* */
5001 *fpc++ = FF_LINESNGL;
5004 *fpc++ = FF_LINEGLOB;
5006 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
5007 arg = ischop ? 512 : 0;
5012 const char * const f = ++s;
5015 arg |= 256 + (s - f);
5017 *fpc++ = s - base; /* fieldsize for FETCH */
5018 *fpc++ = FF_DECIMAL;
5020 unchopnum |= ! ischop;
5022 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5023 arg = ischop ? 512 : 0;
5025 s++; /* skip the '0' first */
5029 const char * const f = ++s;
5032 arg |= 256 + (s - f);
5034 *fpc++ = s - base; /* fieldsize for FETCH */
5035 *fpc++ = FF_0DECIMAL;
5037 unchopnum |= ! ischop;
5041 bool ismore = FALSE;
5044 while (*++s == '>') ;
5045 prespace = FF_SPACE;
5047 else if (*s == '|') {
5048 while (*++s == '|') ;
5049 prespace = FF_HALFSPACE;
5054 while (*++s == '<') ;
5057 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5061 *fpc++ = s - base; /* fieldsize for FETCH */
5063 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5066 *fpc++ = (U16)prespace;
5080 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5082 { /* need to jump to the next word */
5084 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
5085 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
5086 s = SvPVX(sv) + SvCUR(sv) + z;
5088 Copy(fops, s, arg, U32);
5090 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
5093 if (unchopnum && repeat)
5094 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5100 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5102 /* Can value be printed in fldsize chars, using %*.*f ? */
5106 int intsize = fldsize - (value < 0 ? 1 : 0);
5113 while (intsize--) pwr *= 10.0;
5114 while (frcsize--) eps /= 10.0;
5117 if (value + eps >= pwr)
5120 if (value - eps <= -pwr)
5127 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5130 SV * const datasv = FILTER_DATA(idx);
5131 const int filter_has_file = IoLINES(datasv);
5132 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5133 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5138 char *prune_from = NULL;
5139 bool read_from_cache = FALSE;
5142 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5144 assert(maxlen >= 0);
5147 /* I was having segfault trouble under Linux 2.2.5 after a
5148 parse error occured. (Had to hack around it with a test
5149 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5150 not sure where the trouble is yet. XXX */
5153 SV *const cache = datasv;
5156 const char *cache_p = SvPV(cache, cache_len);
5160 /* Running in block mode and we have some cached data already.
5162 if (cache_len >= umaxlen) {
5163 /* In fact, so much data we don't even need to call
5168 const char *const first_nl =
5169 (const char *)memchr(cache_p, '\n', cache_len);
5171 take = first_nl + 1 - cache_p;
5175 sv_catpvn(buf_sv, cache_p, take);
5176 sv_chop(cache, cache_p + take);
5177 /* Definitely not EOF */
5181 sv_catsv(buf_sv, cache);
5183 umaxlen -= cache_len;
5186 read_from_cache = TRUE;
5190 /* Filter API says that the filter appends to the contents of the buffer.
5191 Usually the buffer is "", so the details don't matter. But if it's not,
5192 then clearly what it contains is already filtered by this filter, so we
5193 don't want to pass it in a second time.
5194 I'm going to use a mortal in case the upstream filter croaks. */
5195 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5196 ? sv_newmortal() : buf_sv;
5197 SvUPGRADE(upstream, SVt_PV);
5199 if (filter_has_file) {
5200 status = FILTER_READ(idx+1, upstream, 0);
5203 if (filter_sub && status >= 0) {
5207 ENTER_with_name("call_filter_sub");
5212 DEFSV_set(upstream);
5216 PUSHs(filter_state);
5219 count = call_sv(filter_sub, G_SCALAR);
5231 LEAVE_with_name("call_filter_sub");
5234 if(SvOK(upstream)) {
5235 got_p = SvPV(upstream, got_len);
5237 if (got_len > umaxlen) {
5238 prune_from = got_p + umaxlen;
5241 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5242 if (first_nl && first_nl + 1 < got_p + got_len) {
5243 /* There's a second line here... */
5244 prune_from = first_nl + 1;
5249 /* Oh. Too long. Stuff some in our cache. */
5250 STRLEN cached_len = got_p + got_len - prune_from;
5251 SV *const cache = datasv;
5254 /* Cache should be empty. */
5255 assert(!SvCUR(cache));
5258 sv_setpvn(cache, prune_from, cached_len);
5259 /* If you ask for block mode, you may well split UTF-8 characters.
5260 "If it breaks, you get to keep both parts"
5261 (Your code is broken if you don't put them back together again
5262 before something notices.) */
5263 if (SvUTF8(upstream)) {
5266 SvCUR_set(upstream, got_len - cached_len);
5268 /* Can't yet be EOF */
5273 /* If they are at EOF but buf_sv has something in it, then they may never
5274 have touched the SV upstream, so it may be undefined. If we naively
5275 concatenate it then we get a warning about use of uninitialised value.
5277 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5278 sv_catsv(buf_sv, upstream);
5282 IoLINES(datasv) = 0;
5284 SvREFCNT_dec(filter_state);
5285 IoTOP_GV(datasv) = NULL;
5288 SvREFCNT_dec(filter_sub);
5289 IoBOTTOM_GV(datasv) = NULL;
5291 filter_del(S_run_user_filter);
5293 if (status == 0 && read_from_cache) {
5294 /* If we read some data from the cache (and by getting here it implies
5295 that we emptied the cache) then we aren't yet at EOF, and mustn't
5296 report that to our caller. */
5302 /* perhaps someone can come up with a better name for
5303 this? it is not really "absolute", per se ... */
5305 S_path_is_absolute(const char *name)
5307 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5309 if (PERL_FILE_IS_ABSOLUTE(name)
5311 || (*name == '.' && ((name[1] == '/' ||
5312 (name[1] == '.' && name[2] == '/'))
5313 || (name[1] == '\\' ||
5314 ( name[1] == '.' && name[2] == '\\')))
5317 || (*name == '.' && (name[1] == '/' ||
5318 (name[1] == '.' && name[2] == '/')))
5330 * c-indentation-style: bsd
5332 * indent-tabs-mode: t
5335 * ex: set ts=8 sts=4 sw=4 noet: