3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
19 * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains control-oriented pp ("push/pop") functions that
23 * execute the opcodes that make up a perl program. A typical pp function
24 * expects to find its arguments on the stack, and usually pushes its
25 * results onto the stack, hence the 'pp' terminology. Each OP structure
26 * contains a pointer to the relevant pp_foo() function.
28 * Control-oriented means things like pp_enteriter() and pp_next(), which
29 * alter the flow of control of the program.
34 #define PERL_IN_PP_CTL_C
37 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
39 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
48 cxix = dopoptosub(cxstack_ix);
52 switch (cxstack[cxix].blk_gimme) {
65 /* XXXX Should store the old value to allow for tie/overload - and
66 restore in regcomp, where marked with XXXX. */
76 register PMOP *pm = (PMOP*)cLOGOP->op_other;
80 /* prevent recompiling under /o and ithreads. */
81 #if defined(USE_ITHREADS)
82 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
83 if (PL_op->op_flags & OPf_STACKED) {
93 #define tryAMAGICregexp(rx) \
96 if (SvROK(rx) && SvAMAGIC(rx)) { \
97 SV *sv = AMG_CALLunary(rx, regexp_amg); \
101 if (SvTYPE(sv) != SVt_REGEXP) \
102 Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
109 if (PL_op->op_flags & OPf_STACKED) {
110 /* multiple args; concatenate them */
112 tmpstr = PAD_SV(ARGTARG);
113 sv_setpvs(tmpstr, "");
114 while (++MARK <= SP) {
118 tryAMAGICregexp(msv);
120 if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
121 (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
123 sv_setsv(tmpstr, sv);
126 sv_catsv_nomg(tmpstr, msv);
133 tryAMAGICregexp(tmpstr);
136 #undef tryAMAGICregexp
139 SV * const sv = SvRV(tmpstr);
140 if (SvTYPE(sv) == SVt_REGEXP)
143 else if (SvTYPE(tmpstr) == SVt_REGEXP)
144 re = (REGEXP*) tmpstr;
147 /* The match's LHS's get-magic might need to access this op's reg-
148 exp (as is sometimes the case with $'; see bug 70764). So we
149 must call get-magic now before we replace the regexp. Hopeful-
150 ly this hack can be replaced with the approach described at
151 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
152 /msg122415.html some day. */
153 if(pm->op_type == OP_MATCH) {
155 const bool was_tainted = PL_tainted;
156 if (pm->op_flags & OPf_STACKED)
158 else if (pm->op_private & OPpTARGET_MY)
159 lhs = PAD_SV(pm->op_targ);
162 /* Restore the previous value of PL_tainted (which may have been
163 modified by get-magic), to avoid incorrectly setting the
164 RXf_TAINTED flag further down. */
165 PL_tainted = was_tainted;
168 re = reg_temp_copy(NULL, re);
169 ReREFCNT_dec(PM_GETRE(pm));
174 const char *t = SvOK(tmpstr) ? SvPV_nomg_const(tmpstr, len) : "";
177 assert (re != (REGEXP*) &PL_sv_undef);
179 /* Check against the last compiled regexp. */
180 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
181 memNE(RX_PRECOMP(re), t, len))
183 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
184 U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
188 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
190 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
192 } else if (PL_curcop->cop_hints_hash) {
193 SV *ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
194 if (ptr && SvIOK(ptr) && SvIV(ptr))
195 eng = INT2PTR(regexp_engine*,SvIV(ptr));
198 if (PL_op->op_flags & OPf_SPECIAL)
199 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
201 if (DO_UTF8(tmpstr)) {
202 assert (SvUTF8(tmpstr));
203 } else if (SvUTF8(tmpstr)) {
204 /* Not doing UTF-8, despite what the SV says. Is this only if
205 we're trapped in use 'bytes'? */
206 /* Make a copy of the octet sequence, but without the flag on,
207 as the compiler now honours the SvUTF8 flag on tmpstr. */
209 const char *const p = SvPV(tmpstr, len);
210 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
212 else if (SvAMAGIC(tmpstr)) {
213 /* make a copy to avoid extra stringifies */
214 tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
217 /* If it is gmagical, create a mortal copy, but without calling
218 get-magic, as we have already done that. */
219 if(SvGMAGICAL(tmpstr)) {
220 SV *mortalcopy = sv_newmortal();
221 sv_setsv_flags(mortalcopy, tmpstr, 0);
226 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
228 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
230 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
231 inside tie/overload accessors. */
237 #ifndef INCOMPLETE_TAINTS
240 SvTAINTED_on((SV*)re);
241 RX_EXTFLAGS(re) |= RXf_TAINTED;
246 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
250 #if !defined(USE_ITHREADS)
251 /* can't change the optree at runtime either */
252 /* PMf_KEEP is handled differently under threads to avoid these problems */
253 if (pm->op_pmflags & PMf_KEEP) {
254 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
255 cLOGOP->op_first->op_next = PL_op->op_next;
265 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
266 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
267 register SV * const dstr = cx->sb_dstr;
268 register char *s = cx->sb_s;
269 register char *m = cx->sb_m;
270 char *orig = cx->sb_orig;
271 register REGEXP * const rx = cx->sb_rx;
273 REGEXP *old = PM_GETRE(pm);
280 PM_SETRE(pm,ReREFCNT_inc(rx));
283 rxres_restore(&cx->sb_rxres, rx);
284 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
286 if (cx->sb_iters++) {
287 const I32 saviters = cx->sb_iters;
288 if (cx->sb_iters > cx->sb_maxiters)
289 DIE(aTHX_ "Substitution loop");
291 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
293 /* See "how taint works" above pp_subst() */
295 cx->sb_rxtainted |= SUBST_TAINT_REPL;
296 sv_catsv_nomg(dstr, POPs);
297 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
301 if (CxONCE(cx) || s < orig ||
302 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
303 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
304 ((cx->sb_rflags & REXEC_COPY_STR)
305 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
306 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
308 SV * const targ = cx->sb_targ;
310 assert(cx->sb_strend >= s);
311 if(cx->sb_strend > s) {
312 if (DO_UTF8(dstr) && !SvUTF8(targ))
313 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
315 sv_catpvn(dstr, s, cx->sb_strend - s);
317 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
318 cx->sb_rxtainted |= SUBST_TAINT_PAT;
320 #ifdef PERL_OLD_COPY_ON_WRITE
322 sv_force_normal_flags(targ, SV_COW_DROP_PV);
328 SvPV_set(targ, SvPVX(dstr));
329 SvCUR_set(targ, SvCUR(dstr));
330 SvLEN_set(targ, SvLEN(dstr));
333 SvPV_set(dstr, NULL);
335 if (pm->op_pmflags & PMf_NONDESTRUCT)
338 mPUSHi(saviters - 1);
340 (void)SvPOK_only_UTF8(targ);
342 /* update the taint state of various various variables in
343 * preparation for final exit.
344 * See "how taint works" above pp_subst() */
346 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
347 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
348 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
350 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
352 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
353 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
355 SvTAINTED_on(TOPs); /* taint return value */
356 /* needed for mg_set below */
357 PL_tainted = cBOOL(cx->sb_rxtainted &
358 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
361 /* PL_tainted must be correctly set for this mg_set */
364 LEAVE_SCOPE(cx->sb_oldsave);
366 RETURNOP(pm->op_next);
369 cx->sb_iters = saviters;
371 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
374 cx->sb_orig = orig = RX_SUBBEG(rx);
376 cx->sb_strend = s + (cx->sb_strend - m);
378 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
380 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
381 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
383 sv_catpvn(dstr, s, m-s);
385 cx->sb_s = RX_OFFS(rx)[0].end + orig;
386 { /* Update the pos() information. */
387 SV * const sv = cx->sb_targ;
389 SvUPGRADE(sv, SVt_PVMG);
390 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
391 #ifdef PERL_OLD_COPY_ON_WRITE
393 sv_force_normal_flags(sv, 0);
395 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
398 mg->mg_len = m - orig;
401 (void)ReREFCNT_inc(rx);
402 /* update the taint state of various various variables in preparation
403 * for calling the code block.
404 * See "how taint works" above pp_subst() */
406 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
407 cx->sb_rxtainted |= SUBST_TAINT_PAT;
409 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
410 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
411 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
413 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
415 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
416 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
417 SvTAINTED_on(cx->sb_targ);
420 rxres_save(&cx->sb_rxres, rx);
422 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
426 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
431 PERL_ARGS_ASSERT_RXRES_SAVE;
434 if (!p || p[1] < RX_NPARENS(rx)) {
435 #ifdef PERL_OLD_COPY_ON_WRITE
436 i = 7 + RX_NPARENS(rx) * 2;
438 i = 6 + RX_NPARENS(rx) * 2;
447 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
448 RX_MATCH_COPIED_off(rx);
450 #ifdef PERL_OLD_COPY_ON_WRITE
451 *p++ = PTR2UV(RX_SAVED_COPY(rx));
452 RX_SAVED_COPY(rx) = NULL;
455 *p++ = RX_NPARENS(rx);
457 *p++ = PTR2UV(RX_SUBBEG(rx));
458 *p++ = (UV)RX_SUBLEN(rx);
459 for (i = 0; i <= RX_NPARENS(rx); ++i) {
460 *p++ = (UV)RX_OFFS(rx)[i].start;
461 *p++ = (UV)RX_OFFS(rx)[i].end;
466 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
471 PERL_ARGS_ASSERT_RXRES_RESTORE;
474 RX_MATCH_COPY_FREE(rx);
475 RX_MATCH_COPIED_set(rx, *p);
478 #ifdef PERL_OLD_COPY_ON_WRITE
479 if (RX_SAVED_COPY(rx))
480 SvREFCNT_dec (RX_SAVED_COPY(rx));
481 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
485 RX_NPARENS(rx) = *p++;
487 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
488 RX_SUBLEN(rx) = (I32)(*p++);
489 for (i = 0; i <= RX_NPARENS(rx); ++i) {
490 RX_OFFS(rx)[i].start = (I32)(*p++);
491 RX_OFFS(rx)[i].end = (I32)(*p++);
496 S_rxres_free(pTHX_ void **rsp)
498 UV * const p = (UV*)*rsp;
500 PERL_ARGS_ASSERT_RXRES_FREE;
505 void *tmp = INT2PTR(char*,*p);
508 PoisonFree(*p, 1, sizeof(*p));
510 Safefree(INT2PTR(char*,*p));
512 #ifdef PERL_OLD_COPY_ON_WRITE
514 SvREFCNT_dec (INT2PTR(SV*,p[1]));
522 #define FORM_NUM_BLANK (1<<30)
523 #define FORM_NUM_POINT (1<<29)
527 dVAR; dSP; dMARK; dORIGMARK;
528 register SV * const tmpForm = *++MARK;
529 SV *formsv; /* contains text of original format */
530 register U32 *fpc; /* format ops program counter */
531 register char *t; /* current append position in target string */
532 const char *f; /* current position in format string */
534 register SV *sv = NULL; /* current item */
535 const char *item = NULL;/* string value of current item */
536 I32 itemsize = 0; /* length of current item, possibly truncated */
537 I32 fieldsize = 0; /* width of current field */
538 I32 lines = 0; /* number of lines that have been output */
539 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
540 const char *chophere = NULL; /* where to chop current item */
541 STRLEN linemark = 0; /* pos of start of line in output */
543 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
545 STRLEN linemax; /* estimate of output size in bytes */
546 bool item_is_utf8 = FALSE;
547 bool targ_is_utf8 = FALSE;
550 U8 *source; /* source of bytes to append */
551 STRLEN to_copy; /* how may bytes to append */
552 char trans; /* what chars to translate */
554 mg = doparseform(tmpForm);
556 fpc = (U32*)mg->mg_ptr;
557 /* the actual string the format was compiled from.
558 * with overload etc, this may not match tmpForm */
562 SvPV_force(PL_formtarget, len);
563 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
564 SvTAINTED_on(PL_formtarget);
565 if (DO_UTF8(PL_formtarget))
567 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
568 t = SvGROW(PL_formtarget, len + linemax + 1);
569 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
571 f = SvPV_const(formsv, len);
575 const char *name = "???";
578 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
579 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
580 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
581 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
582 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
584 case FF_CHECKNL: name = "CHECKNL"; break;
585 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
586 case FF_SPACE: name = "SPACE"; break;
587 case FF_HALFSPACE: name = "HALFSPACE"; break;
588 case FF_ITEM: name = "ITEM"; break;
589 case FF_CHOP: name = "CHOP"; break;
590 case FF_LINEGLOB: name = "LINEGLOB"; break;
591 case FF_NEWLINE: name = "NEWLINE"; break;
592 case FF_MORE: name = "MORE"; break;
593 case FF_LINEMARK: name = "LINEMARK"; break;
594 case FF_END: name = "END"; break;
595 case FF_0DECIMAL: name = "0DECIMAL"; break;
596 case FF_LINESNGL: name = "LINESNGL"; break;
599 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
601 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
605 linemark = t - SvPVX(PL_formtarget);
615 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
631 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
634 SvTAINTED_on(PL_formtarget);
640 const char *s = item = SvPV_const(sv, len);
643 itemsize = sv_len_utf8(sv);
644 if (itemsize != (I32)len) {
646 if (itemsize > fieldsize) {
647 itemsize = fieldsize;
648 itembytes = itemsize;
649 sv_pos_u2b(sv, &itembytes, 0);
653 send = chophere = s + itembytes;
663 sv_pos_b2u(sv, &itemsize);
667 item_is_utf8 = FALSE;
668 if (itemsize > fieldsize)
669 itemsize = fieldsize;
670 send = chophere = s + itemsize;
684 const char *s = item = SvPV_const(sv, len);
687 itemsize = sv_len_utf8(sv);
688 if (itemsize != (I32)len) {
690 if (itemsize <= fieldsize) {
691 const char *send = chophere = s + itemsize;
704 itemsize = fieldsize;
705 itembytes = itemsize;
706 sv_pos_u2b(sv, &itembytes, 0);
707 send = chophere = s + itembytes;
708 while (s < send || (s == send && isSPACE(*s))) {
718 if (strchr(PL_chopset, *s))
723 itemsize = chophere - item;
724 sv_pos_b2u(sv, &itemsize);
730 item_is_utf8 = FALSE;
731 if (itemsize <= fieldsize) {
732 const char *const send = chophere = s + itemsize;
745 itemsize = fieldsize;
746 send = chophere = s + itemsize;
747 while (s < send || (s == send && isSPACE(*s))) {
757 if (strchr(PL_chopset, *s))
762 itemsize = chophere - item;
768 arg = fieldsize - itemsize;
777 arg = fieldsize - itemsize;
791 /* convert to_copy from chars to bytes */
795 to_copy = s - source;
801 const char *s = chophere;
815 const bool oneline = fpc[-1] == FF_LINESNGL;
816 const char *s = item = SvPV_const(sv, len);
817 const char *const send = s + len;
819 item_is_utf8 = DO_UTF8(sv);
830 to_copy = s - SvPVX_const(sv) - 1;
844 /* append to_copy bytes from source to PL_formstring.
845 * item_is_utf8 implies source is utf8.
846 * if trans, translate certain characters during the copy */
851 SvCUR_set(PL_formtarget,
852 t - SvPVX_const(PL_formtarget));
854 if (targ_is_utf8 && !item_is_utf8) {
855 source = tmp = bytes_to_utf8(source, &to_copy);
857 if (item_is_utf8 && !targ_is_utf8) {
859 /* Upgrade targ to UTF8, and then we reduce it to
860 a problem we have a simple solution for.
861 Don't need get magic. */
862 sv_utf8_upgrade_nomg(PL_formtarget);
864 /* re-calculate linemark */
865 s = (U8*)SvPVX(PL_formtarget);
866 /* the bytes we initially allocated to append the
867 * whole line may have been gobbled up during the
868 * upgrade, so allocate a whole new line's worth
873 linemark = s - (U8*)SvPVX(PL_formtarget);
875 /* Easy. They agree. */
876 assert (item_is_utf8 == targ_is_utf8);
879 /* @* and ^* are the only things that can exceed
880 * the linemax, so grow by the output size, plus
881 * a whole new form's worth in case of any further
883 grow = linemax + to_copy;
885 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
886 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
888 Copy(source, t, to_copy, char);
890 /* blank out ~ or control chars, depending on trans.
891 * works on bytes not chars, so relies on not
892 * matching utf8 continuation bytes */
894 U8 *send = s + to_copy;
897 if (trans == '~' ? (ch == '~') :
910 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
918 #if defined(USE_LONG_DOUBLE)
920 ((arg & FORM_NUM_POINT) ?
921 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
924 ((arg & FORM_NUM_POINT) ?
925 "%#0*.*f" : "%0*.*f");
930 #if defined(USE_LONG_DOUBLE)
932 ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
935 ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f");
938 /* If the field is marked with ^ and the value is undefined,
940 if ((arg & FORM_NUM_BLANK) && !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 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
959 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value);
960 RESTORE_NUMERIC_STANDARD();
967 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
975 if (arg) { /* repeat until fields exhausted? */
981 t = SvPVX(PL_formtarget) + linemark;
988 const char *s = chophere;
989 const char *send = item + len;
991 while (isSPACE(*s) && (s < send))
996 arg = fieldsize - itemsize;
1003 if (strnEQ(s1," ",3)) {
1004 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
1015 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
1017 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1019 SvUTF8_on(PL_formtarget);
1020 FmLINES(PL_formtarget) += lines;
1022 if (fpc[-1] == FF_BLANK)
1023 RETURNOP(cLISTOP->op_first);
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 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1583 while (cxstack_ix > cxix) {
1585 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1586 DEBUG_CX("UNWIND"); \
1587 /* Note: we don't need to restore the base context info till the end. */
1588 switch (CxTYPE(cx)) {
1591 continue; /* not break */
1599 case CXt_LOOP_LAZYIV:
1600 case CXt_LOOP_LAZYSV:
1602 case CXt_LOOP_PLAIN:
1613 PERL_UNUSED_VAR(optype);
1617 Perl_qerror(pTHX_ SV *err)
1621 PERL_ARGS_ASSERT_QERROR;
1624 if (PL_in_eval & EVAL_KEEPERR) {
1625 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1626 SvPV_nolen_const(err));
1629 sv_catsv(ERRSV, err);
1632 sv_catsv(PL_errors, err);
1634 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1636 ++PL_parser->error_count;
1640 Perl_die_unwind(pTHX_ SV *msv)
1643 SV *exceptsv = sv_mortalcopy(msv);
1644 U8 in_eval = PL_in_eval;
1645 PERL_ARGS_ASSERT_DIE_UNWIND;
1652 * Historically, perl used to set ERRSV ($@) early in the die
1653 * process and rely on it not getting clobbered during unwinding.
1654 * That sucked, because it was liable to get clobbered, so the
1655 * setting of ERRSV used to emit the exception from eval{} has
1656 * been moved to much later, after unwinding (see just before
1657 * JMPENV_JUMP below). However, some modules were relying on the
1658 * early setting, by examining $@ during unwinding to use it as
1659 * a flag indicating whether the current unwinding was caused by
1660 * an exception. It was never a reliable flag for that purpose,
1661 * being totally open to false positives even without actual
1662 * clobberage, but was useful enough for production code to
1663 * semantically rely on it.
1665 * We'd like to have a proper introspective interface that
1666 * explicitly describes the reason for whatever unwinding
1667 * operations are currently in progress, so that those modules
1668 * work reliably and $@ isn't further overloaded. But we don't
1669 * have one yet. In its absence, as a stopgap measure, ERRSV is
1670 * now *additionally* set here, before unwinding, to serve as the
1671 * (unreliable) flag that it used to.
1673 * This behaviour is temporary, and should be removed when a
1674 * proper way to detect exceptional unwinding has been developed.
1675 * As of 2010-12, the authors of modules relying on the hack
1676 * are aware of the issue, because the modules failed on
1677 * perls 5.13.{1..7} which had late setting of $@ without this
1678 * early-setting hack.
1680 if (!(in_eval & EVAL_KEEPERR)) {
1681 SvTEMP_off(exceptsv);
1682 sv_setsv(ERRSV, exceptsv);
1685 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1686 && PL_curstackinfo->si_prev)
1695 register PERL_CONTEXT *cx;
1698 JMPENV *restartjmpenv;
1701 if (cxix < cxstack_ix)
1704 POPBLOCK(cx,PL_curpm);
1705 if (CxTYPE(cx) != CXt_EVAL) {
1707 const char* message = SvPVx_const(exceptsv, msglen);
1708 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1709 PerlIO_write(Perl_error_log, message, msglen);
1713 namesv = cx->blk_eval.old_namesv;
1714 oldcop = cx->blk_oldcop;
1715 restartjmpenv = cx->blk_eval.cur_top_env;
1716 restartop = cx->blk_eval.retop;
1718 if (gimme == G_SCALAR)
1719 *++newsp = &PL_sv_undef;
1720 PL_stack_sp = newsp;
1724 /* LEAVE could clobber PL_curcop (see save_re_context())
1725 * XXX it might be better to find a way to avoid messing with
1726 * PL_curcop in save_re_context() instead, but this is a more
1727 * minimal fix --GSAR */
1730 if (optype == OP_REQUIRE) {
1731 const char* const msg = SvPVx_nolen_const(exceptsv);
1732 (void)hv_store(GvHVn(PL_incgv),
1733 SvPVX_const(namesv), SvCUR(namesv),
1735 /* note that unlike pp_entereval, pp_require isn't
1736 * supposed to trap errors. So now that we've popped the
1737 * EVAL that pp_require pushed, and processed the error
1738 * message, rethrow the error */
1739 Perl_croak(aTHX_ "%sCompilation failed in require",
1740 *msg ? msg : "Unknown error\n");
1742 if (in_eval & EVAL_KEEPERR) {
1743 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1744 SvPV_nolen_const(exceptsv));
1747 sv_setsv(ERRSV, exceptsv);
1749 PL_restartjmpenv = restartjmpenv;
1750 PL_restartop = restartop;
1756 write_to_stderr(exceptsv);
1763 dVAR; dSP; dPOPTOPssrl;
1764 if (SvTRUE(left) != SvTRUE(right))
1771 =for apidoc caller_cx
1773 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1774 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1775 information returned to Perl by C<caller>. Note that XSUBs don't get a
1776 stack frame, so C<caller_cx(0, NULL)> will return information for the
1777 immediately-surrounding Perl code.
1779 This function skips over the automatic calls to C<&DB::sub> made on the
1780 behalf of the debugger. If the stack frame requested was a sub called by
1781 C<DB::sub>, the return value will be the frame for the call to
1782 C<DB::sub>, since that has the correct line number/etc. for the call
1783 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1784 frame for the sub call itself.
1789 const PERL_CONTEXT *
1790 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1792 register I32 cxix = dopoptosub(cxstack_ix);
1793 register const PERL_CONTEXT *cx;
1794 register const PERL_CONTEXT *ccstack = cxstack;
1795 const PERL_SI *top_si = PL_curstackinfo;
1798 /* we may be in a higher stacklevel, so dig down deeper */
1799 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1800 top_si = top_si->si_prev;
1801 ccstack = top_si->si_cxstack;
1802 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1806 /* caller() should not report the automatic calls to &DB::sub */
1807 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1808 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1812 cxix = dopoptosub_at(ccstack, cxix - 1);
1815 cx = &ccstack[cxix];
1816 if (dbcxp) *dbcxp = cx;
1818 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1819 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1820 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1821 field below is defined for any cx. */
1822 /* caller() should not report the automatic calls to &DB::sub */
1823 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1824 cx = &ccstack[dbcxix];
1834 register const PERL_CONTEXT *cx;
1835 const PERL_CONTEXT *dbcx;
1837 const char *stashname;
1843 cx = caller_cx(count, &dbcx);
1845 if (GIMME != G_ARRAY) {
1852 stashname = CopSTASHPV(cx->blk_oldcop);
1853 if (GIMME != G_ARRAY) {
1856 PUSHs(&PL_sv_undef);
1859 sv_setpv(TARG, stashname);
1868 PUSHs(&PL_sv_undef);
1870 mPUSHs(newSVpv(stashname, 0));
1871 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1872 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1875 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1876 GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1877 /* So is ccstack[dbcxix]. */
1879 SV * const sv = newSV(0);
1880 gv_efullname3(sv, cvgv, NULL);
1882 PUSHs(boolSV(CxHASARGS(cx)));
1885 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1886 PUSHs(boolSV(CxHASARGS(cx)));
1890 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1893 gimme = (I32)cx->blk_gimme;
1894 if (gimme == G_VOID)
1895 PUSHs(&PL_sv_undef);
1897 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1898 if (CxTYPE(cx) == CXt_EVAL) {
1900 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1901 PUSHs(cx->blk_eval.cur_text);
1905 else if (cx->blk_eval.old_namesv) {
1906 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1909 /* eval BLOCK (try blocks have old_namesv == 0) */
1911 PUSHs(&PL_sv_undef);
1912 PUSHs(&PL_sv_undef);
1916 PUSHs(&PL_sv_undef);
1917 PUSHs(&PL_sv_undef);
1919 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1920 && CopSTASH_eq(PL_curcop, PL_debstash))
1922 AV * const ary = cx->blk_sub.argarray;
1923 const int off = AvARRAY(ary) - AvALLOC(ary);
1926 Perl_init_dbargs(aTHX);
1928 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1929 av_extend(PL_dbargs, AvFILLp(ary) + off);
1930 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1931 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1933 /* XXX only hints propagated via op_private are currently
1934 * visible (others are not easily accessible, since they
1935 * use the global PL_hints) */
1936 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1939 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1941 if (old_warnings == pWARN_NONE ||
1942 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1943 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1944 else if (old_warnings == pWARN_ALL ||
1945 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1946 /* Get the bit mask for $warnings::Bits{all}, because
1947 * it could have been extended by warnings::register */
1949 HV * const bits = get_hv("warnings::Bits", 0);
1950 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1951 mask = newSVsv(*bits_all);
1954 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1958 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1962 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1963 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1972 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1973 sv_reset(tmps, CopSTASH(PL_curcop));
1978 /* like pp_nextstate, but used instead when the debugger is active */
1983 PL_curcop = (COP*)PL_op;
1984 TAINT_NOT; /* Each statement is presumed innocent */
1985 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1990 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1991 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1994 register PERL_CONTEXT *cx;
1995 const I32 gimme = G_ARRAY;
1997 GV * const gv = PL_DBgv;
1998 register CV * const cv = GvCV(gv);
2001 DIE(aTHX_ "No DB::DB routine defined");
2003 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2004 /* don't do recursive DB::DB call */
2019 (void)(*CvXSUB(cv))(aTHX_ cv);
2026 PUSHBLOCK(cx, CXt_SUB, SP);
2028 cx->blk_sub.retop = PL_op->op_next;
2031 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
2032 RETURNOP(CvSTART(cv));
2042 register PERL_CONTEXT *cx;
2043 const I32 gimme = GIMME_V;
2044 void *itervar; /* location of the iteration variable */
2045 U8 cxtype = CXt_LOOP_FOR;
2047 ENTER_with_name("loop1");
2050 if (PL_op->op_targ) { /* "my" variable */
2051 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2052 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2053 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2054 SVs_PADSTALE, SVs_PADSTALE);
2056 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2058 itervar = PL_comppad;
2060 itervar = &PAD_SVl(PL_op->op_targ);
2063 else { /* symbol table variable */
2064 GV * const gv = MUTABLE_GV(POPs);
2065 SV** svp = &GvSV(gv);
2066 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2068 itervar = (void *)gv;
2071 if (PL_op->op_private & OPpITER_DEF)
2072 cxtype |= CXp_FOR_DEF;
2074 ENTER_with_name("loop2");
2076 PUSHBLOCK(cx, cxtype, SP);
2077 PUSHLOOP_FOR(cx, itervar, MARK);
2078 if (PL_op->op_flags & OPf_STACKED) {
2079 SV *maybe_ary = POPs;
2080 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2082 SV * const right = maybe_ary;
2085 if (RANGE_IS_NUMERIC(sv,right)) {
2086 cx->cx_type &= ~CXTYPEMASK;
2087 cx->cx_type |= CXt_LOOP_LAZYIV;
2088 /* Make sure that no-one re-orders cop.h and breaks our
2090 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2091 #ifdef NV_PRESERVES_UV
2092 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
2093 (SvNV(sv) > (NV)IV_MAX)))
2095 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
2096 (SvNV(right) < (NV)IV_MIN))))
2098 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
2101 ((SvUV(sv) > (UV)IV_MAX) ||
2102 (SvNV(sv) > (NV)UV_MAX)))))
2104 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
2106 ((SvNV(right) > 0) &&
2107 ((SvUV(right) > (UV)IV_MAX) ||
2108 (SvNV(right) > (NV)UV_MAX))))))
2110 DIE(aTHX_ "Range iterator outside integer range");
2111 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
2112 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
2114 /* for correct -Dstv display */
2115 cx->blk_oldsp = sp - PL_stack_base;
2119 cx->cx_type &= ~CXTYPEMASK;
2120 cx->cx_type |= CXt_LOOP_LAZYSV;
2121 /* Make sure that no-one re-orders cop.h and breaks our
2123 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2124 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2125 cx->blk_loop.state_u.lazysv.end = right;
2126 SvREFCNT_inc(right);
2127 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2128 /* This will do the upgrade to SVt_PV, and warn if the value
2129 is uninitialised. */
2130 (void) SvPV_nolen_const(right);
2131 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2132 to replace !SvOK() with a pointer to "". */
2134 SvREFCNT_dec(right);
2135 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2139 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2140 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2141 SvREFCNT_inc(maybe_ary);
2142 cx->blk_loop.state_u.ary.ix =
2143 (PL_op->op_private & OPpITER_REVERSED) ?
2144 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2148 else { /* iterating over items on the stack */
2149 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2150 if (PL_op->op_private & OPpITER_REVERSED) {
2151 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2154 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2164 register PERL_CONTEXT *cx;
2165 const I32 gimme = GIMME_V;
2167 ENTER_with_name("loop1");
2169 ENTER_with_name("loop2");
2171 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2172 PUSHLOOP_PLAIN(cx, SP);
2180 register PERL_CONTEXT *cx;
2187 assert(CxTYPE_is_LOOP(cx));
2189 newsp = PL_stack_base + cx->blk_loop.resetsp;
2192 if (gimme == G_VOID)
2194 else if (gimme == G_SCALAR) {
2196 *++newsp = sv_mortalcopy(*SP);
2198 *++newsp = &PL_sv_undef;
2202 *++newsp = sv_mortalcopy(*++mark);
2203 TAINT_NOT; /* Each item is independent */
2209 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2210 PL_curpm = newpm; /* ... and pop $1 et al */
2212 LEAVE_with_name("loop2");
2213 LEAVE_with_name("loop1");
2219 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2222 if (gimme == G_SCALAR) {
2224 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2225 *++newsp = SvREFCNT_inc(*SP);
2231 (!CxLVAL(cx) || CxLVAL(cx) & OPpENTERSUB_INARGS) &&
2233 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2237 *++newsp = &PL_sv_undef;
2238 if (CxLVAL(cx) & OPpENTERSUB_DEREF) {
2242 if (cx->blk_sub.retop->op_type == OP_RV2SV)
2243 deref_type = OPpDEREF_SV;
2244 else if (cx->blk_sub.retop->op_type == OP_RV2AV)
2245 deref_type = OPpDEREF_AV;
2247 assert(cx->blk_sub.retop->op_type == OP_RV2HV);
2248 deref_type = OPpDEREF_HV;
2250 vivify_ref(TOPs, deref_type);
2254 else if (gimme == G_ARRAY) {
2255 assert (!(CxLVAL(cx) & OPpENTERSUB_DEREF));
2256 if (!CxLVAL(cx) || CxLVAL(cx) & OPpENTERSUB_INARGS)
2257 while (++MARK <= SP)
2261 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2262 else while (++MARK <= SP) {
2266 PL_stack_sp = newsp;
2272 register PERL_CONTEXT *cx;
2273 bool popsub2 = FALSE;
2274 bool clear_errsv = FALSE;
2276 bool gmagic = FALSE;
2285 const I32 cxix = dopoptosub(cxstack_ix);
2288 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2289 * sort block, which is a CXt_NULL
2292 PL_stack_base[1] = *PL_stack_sp;
2293 PL_stack_sp = PL_stack_base + 1;
2297 DIE(aTHX_ "Can't return outside a subroutine");
2299 if (cxix < cxstack_ix)
2302 if (CxMULTICALL(&cxstack[cxix])) {
2303 gimme = cxstack[cxix].blk_gimme;
2304 if (gimme == G_VOID)
2305 PL_stack_sp = PL_stack_base;
2306 else if (gimme == G_SCALAR) {
2307 PL_stack_base[1] = *PL_stack_sp;
2308 PL_stack_sp = PL_stack_base + 1;
2314 switch (CxTYPE(cx)) {
2317 lval = !!CvLVALUE(cx->blk_sub.cv);
2318 retop = cx->blk_sub.retop;
2319 gmagic = CxLVAL(cx) & OPpENTERSUB_DEREF;
2320 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2323 if (!(PL_in_eval & EVAL_KEEPERR))
2326 namesv = cx->blk_eval.old_namesv;
2327 retop = cx->blk_eval.retop;
2330 if (optype == OP_REQUIRE &&
2331 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2333 /* Unassume the success we assumed earlier. */
2334 (void)hv_delete(GvHVn(PL_incgv),
2335 SvPVX_const(namesv), SvCUR(namesv),
2337 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2342 retop = cx->blk_sub.retop;
2345 DIE(aTHX_ "panic: return");
2349 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx);
2351 if (gimme == G_SCALAR) {
2354 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2355 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1) {
2356 *++newsp = SvREFCNT_inc(*SP);
2361 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2363 *++newsp = sv_mortalcopy(sv);
2365 if (gmagic) SvGETMAGIC(sv);
2368 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1) {
2370 if (gmagic) SvGETMAGIC(*SP);
2373 *++newsp = sv_mortalcopy(*SP);
2376 *++newsp = sv_mortalcopy(*SP);
2379 *++newsp = &PL_sv_undef;
2381 else if (gimme == G_ARRAY) {
2382 while (++MARK <= SP) {
2383 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2384 ? *MARK : sv_mortalcopy(*MARK);
2385 TAINT_NOT; /* Each item is independent */
2388 PL_stack_sp = newsp;
2392 /* Stack values are safe: */
2395 POPSUB(cx,sv); /* release CV and @_ ... */
2399 PL_curpm = newpm; /* ... and pop $1 et al */
2412 register PERL_CONTEXT *cx;
2423 if (PL_op->op_flags & OPf_SPECIAL) {
2424 cxix = dopoptoloop(cxstack_ix);
2426 DIE(aTHX_ "Can't \"last\" outside a loop block");
2429 cxix = dopoptolabel(cPVOP->op_pv);
2431 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2433 if (cxix < cxstack_ix)
2437 cxstack_ix++; /* temporarily protect top context */
2439 switch (CxTYPE(cx)) {
2440 case CXt_LOOP_LAZYIV:
2441 case CXt_LOOP_LAZYSV:
2443 case CXt_LOOP_PLAIN:
2445 newsp = PL_stack_base + cx->blk_loop.resetsp;
2446 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2450 nextop = cx->blk_sub.retop;
2454 nextop = cx->blk_eval.retop;
2458 nextop = cx->blk_sub.retop;
2461 DIE(aTHX_ "panic: last");
2465 if (gimme == G_SCALAR) {
2467 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2468 ? *SP : sv_mortalcopy(*SP);
2470 *++newsp = &PL_sv_undef;
2472 else if (gimme == G_ARRAY) {
2473 while (++MARK <= SP) {
2474 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2475 ? *MARK : sv_mortalcopy(*MARK);
2476 TAINT_NOT; /* Each item is independent */
2484 /* Stack values are safe: */
2486 case CXt_LOOP_LAZYIV:
2487 case CXt_LOOP_PLAIN:
2488 case CXt_LOOP_LAZYSV:
2490 POPLOOP(cx); /* release loop vars ... */
2494 POPSUB(cx,sv); /* release CV and @_ ... */
2497 PL_curpm = newpm; /* ... and pop $1 et al */
2500 PERL_UNUSED_VAR(optype);
2501 PERL_UNUSED_VAR(gimme);
2509 register PERL_CONTEXT *cx;
2512 if (PL_op->op_flags & OPf_SPECIAL) {
2513 cxix = dopoptoloop(cxstack_ix);
2515 DIE(aTHX_ "Can't \"next\" outside a loop block");
2518 cxix = dopoptolabel(cPVOP->op_pv);
2520 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2522 if (cxix < cxstack_ix)
2525 /* clear off anything above the scope we're re-entering, but
2526 * save the rest until after a possible continue block */
2527 inner = PL_scopestack_ix;
2529 if (PL_scopestack_ix < inner)
2530 leave_scope(PL_scopestack[PL_scopestack_ix]);
2531 PL_curcop = cx->blk_oldcop;
2532 return (cx)->blk_loop.my_op->op_nextop;
2539 register PERL_CONTEXT *cx;
2543 if (PL_op->op_flags & OPf_SPECIAL) {
2544 cxix = dopoptoloop(cxstack_ix);
2546 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2549 cxix = dopoptolabel(cPVOP->op_pv);
2551 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2553 if (cxix < cxstack_ix)
2556 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2557 if (redo_op->op_type == OP_ENTER) {
2558 /* pop one less context to avoid $x being freed in while (my $x..) */
2560 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2561 redo_op = redo_op->op_next;
2565 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2566 LEAVE_SCOPE(oldsave);
2568 PL_curcop = cx->blk_oldcop;
2573 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2577 static const char too_deep[] = "Target of goto is too deeply nested";
2579 PERL_ARGS_ASSERT_DOFINDLABEL;
2582 Perl_croak(aTHX_ too_deep);
2583 if (o->op_type == OP_LEAVE ||
2584 o->op_type == OP_SCOPE ||
2585 o->op_type == OP_LEAVELOOP ||
2586 o->op_type == OP_LEAVESUB ||
2587 o->op_type == OP_LEAVETRY)
2589 *ops++ = cUNOPo->op_first;
2591 Perl_croak(aTHX_ too_deep);
2594 if (o->op_flags & OPf_KIDS) {
2596 /* First try all the kids at this level, since that's likeliest. */
2597 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2598 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2599 const char *kid_label = CopLABEL(kCOP);
2600 if (kid_label && strEQ(kid_label, label))
2604 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2605 if (kid == PL_lastgotoprobe)
2607 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2610 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2611 ops[-1]->op_type == OP_DBSTATE)
2616 if ((o = dofindlabel(kid, label, ops, oplimit)))
2629 register PERL_CONTEXT *cx;
2630 #define GOTO_DEPTH 64
2631 OP *enterops[GOTO_DEPTH];
2632 const char *label = NULL;
2633 const bool do_dump = (PL_op->op_type == OP_DUMP);
2634 static const char must_have_label[] = "goto must have label";
2636 if (PL_op->op_flags & OPf_STACKED) {
2637 SV * const sv = POPs;
2639 /* This egregious kludge implements goto &subroutine */
2640 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2642 register PERL_CONTEXT *cx;
2643 CV *cv = MUTABLE_CV(SvRV(sv));
2650 if (!CvROOT(cv) && !CvXSUB(cv)) {
2651 const GV * const gv = CvGV(cv);
2655 /* autoloaded stub? */
2656 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2658 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2659 GvNAMELEN(gv), FALSE);
2660 if (autogv && (cv = GvCV(autogv)))
2662 tmpstr = sv_newmortal();
2663 gv_efullname3(tmpstr, gv, NULL);
2664 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2666 DIE(aTHX_ "Goto undefined subroutine");
2669 /* First do some returnish stuff. */
2670 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2672 cxix = dopoptosub(cxstack_ix);
2674 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2675 if (cxix < cxstack_ix)
2679 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2680 if (CxTYPE(cx) == CXt_EVAL) {
2682 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2684 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2686 else if (CxMULTICALL(cx))
2687 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2688 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2689 /* put @_ back onto stack */
2690 AV* av = cx->blk_sub.argarray;
2692 items = AvFILLp(av) + 1;
2693 EXTEND(SP, items+1); /* @_ could have been extended. */
2694 Copy(AvARRAY(av), SP + 1, items, SV*);
2695 SvREFCNT_dec(GvAV(PL_defgv));
2696 GvAV(PL_defgv) = cx->blk_sub.savearray;
2698 /* abandon @_ if it got reified */
2703 av_extend(av, items-1);
2705 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2708 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2709 AV* const av = GvAV(PL_defgv);
2710 items = AvFILLp(av) + 1;
2711 EXTEND(SP, items+1); /* @_ could have been extended. */
2712 Copy(AvARRAY(av), SP + 1, items, SV*);
2716 if (CxTYPE(cx) == CXt_SUB &&
2717 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2718 SvREFCNT_dec(cx->blk_sub.cv);
2719 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2720 LEAVE_SCOPE(oldsave);
2722 /* Now do some callish stuff. */
2724 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2726 OP* const retop = cx->blk_sub.retop;
2727 SV **newsp __attribute__unused__;
2728 I32 gimme __attribute__unused__;
2731 for (index=0; index<items; index++)
2732 sv_2mortal(SP[-index]);
2735 /* XS subs don't have a CxSUB, so pop it */
2736 POPBLOCK(cx, PL_curpm);
2737 /* Push a mark for the start of arglist */
2740 (void)(*CvXSUB(cv))(aTHX_ cv);
2745 AV* const padlist = CvPADLIST(cv);
2746 if (CxTYPE(cx) == CXt_EVAL) {
2747 PL_in_eval = CxOLD_IN_EVAL(cx);
2748 PL_eval_root = cx->blk_eval.old_eval_root;
2749 cx->cx_type = CXt_SUB;
2751 cx->blk_sub.cv = cv;
2752 cx->blk_sub.olddepth = CvDEPTH(cv);
2755 if (CvDEPTH(cv) < 2)
2756 SvREFCNT_inc_simple_void_NN(cv);
2758 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2759 sub_crush_depth(cv);
2760 pad_push(padlist, CvDEPTH(cv));
2763 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2766 AV *const av = MUTABLE_AV(PAD_SVl(0));
2768 cx->blk_sub.savearray = GvAV(PL_defgv);
2769 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2770 CX_CURPAD_SAVE(cx->blk_sub);
2771 cx->blk_sub.argarray = av;
2773 if (items >= AvMAX(av) + 1) {
2774 SV **ary = AvALLOC(av);
2775 if (AvARRAY(av) != ary) {
2776 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2779 if (items >= AvMAX(av) + 1) {
2780 AvMAX(av) = items - 1;
2781 Renew(ary,items+1,SV*);
2787 Copy(mark,AvARRAY(av),items,SV*);
2788 AvFILLp(av) = items - 1;
2789 assert(!AvREAL(av));
2791 /* transfer 'ownership' of refcnts to new @_ */
2801 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2802 Perl_get_db_sub(aTHX_ NULL, cv);
2804 CV * const gotocv = get_cvs("DB::goto", 0);
2806 PUSHMARK( PL_stack_sp );
2807 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2812 RETURNOP(CvSTART(cv));
2816 label = SvPV_nolen_const(sv);
2817 if (!(do_dump || *label))
2818 DIE(aTHX_ must_have_label);
2821 else if (PL_op->op_flags & OPf_SPECIAL) {
2823 DIE(aTHX_ must_have_label);
2826 label = cPVOP->op_pv;
2830 if (label && *label) {
2831 OP *gotoprobe = NULL;
2832 bool leaving_eval = FALSE;
2833 bool in_block = FALSE;
2834 PERL_CONTEXT *last_eval_cx = NULL;
2838 PL_lastgotoprobe = NULL;
2840 for (ix = cxstack_ix; ix >= 0; ix--) {
2842 switch (CxTYPE(cx)) {
2844 leaving_eval = TRUE;
2845 if (!CxTRYBLOCK(cx)) {
2846 gotoprobe = (last_eval_cx ?
2847 last_eval_cx->blk_eval.old_eval_root :
2852 /* else fall through */
2853 case CXt_LOOP_LAZYIV:
2854 case CXt_LOOP_LAZYSV:
2856 case CXt_LOOP_PLAIN:
2859 gotoprobe = cx->blk_oldcop->op_sibling;
2865 gotoprobe = cx->blk_oldcop->op_sibling;
2868 gotoprobe = PL_main_root;
2871 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2872 gotoprobe = CvROOT(cx->blk_sub.cv);
2878 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2881 DIE(aTHX_ "panic: goto");
2882 gotoprobe = PL_main_root;
2886 retop = dofindlabel(gotoprobe, label,
2887 enterops, enterops + GOTO_DEPTH);
2890 if (gotoprobe->op_sibling &&
2891 gotoprobe->op_sibling->op_type == OP_UNSTACK &&
2892 gotoprobe->op_sibling->op_sibling) {
2893 retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
2894 label, enterops, enterops + GOTO_DEPTH);
2899 PL_lastgotoprobe = gotoprobe;
2902 DIE(aTHX_ "Can't find label %s", label);
2904 /* if we're leaving an eval, check before we pop any frames
2905 that we're not going to punt, otherwise the error
2908 if (leaving_eval && *enterops && enterops[1]) {
2910 for (i = 1; enterops[i]; i++)
2911 if (enterops[i]->op_type == OP_ENTERITER)
2912 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2915 if (*enterops && enterops[1]) {
2916 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2918 deprecate("\"goto\" to jump into a construct");
2921 /* pop unwanted frames */
2923 if (ix < cxstack_ix) {
2930 oldsave = PL_scopestack[PL_scopestack_ix];
2931 LEAVE_SCOPE(oldsave);
2934 /* push wanted frames */
2936 if (*enterops && enterops[1]) {
2937 OP * const oldop = PL_op;
2938 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2939 for (; enterops[ix]; ix++) {
2940 PL_op = enterops[ix];
2941 /* Eventually we may want to stack the needed arguments
2942 * for each op. For now, we punt on the hard ones. */
2943 if (PL_op->op_type == OP_ENTERITER)
2944 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2945 PL_op->op_ppaddr(aTHX);
2953 if (!retop) retop = PL_main_start;
2955 PL_restartop = retop;
2956 PL_do_undump = TRUE;
2960 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2961 PL_do_undump = FALSE;
2978 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2980 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2983 PL_exit_flags |= PERL_EXIT_EXPECTED;
2985 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2986 if (anum || !(PL_minus_c && PL_madskills))
2991 PUSHs(&PL_sv_undef);
2998 S_save_lines(pTHX_ AV *array, SV *sv)
3000 const char *s = SvPVX_const(sv);
3001 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3004 PERL_ARGS_ASSERT_SAVE_LINES;
3006 while (s && s < send) {
3008 SV * const tmpstr = newSV_type(SVt_PVMG);
3010 t = (const char *)memchr(s, '\n', send - s);
3016 sv_setpvn(tmpstr, s, t - s);
3017 av_store(array, line++, tmpstr);
3025 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3027 0 is used as continue inside eval,
3029 3 is used for a die caught by an inner eval - continue inner loop
3031 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3032 establish a local jmpenv to handle exception traps.
3037 S_docatch(pTHX_ OP *o)
3041 OP * const oldop = PL_op;
3045 assert(CATCH_GET == TRUE);
3052 assert(cxstack_ix >= 0);
3053 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3054 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3059 /* die caught by an inner eval - continue inner loop */
3060 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3061 PL_restartjmpenv = NULL;
3062 PL_op = PL_restartop;
3078 /* James Bond: Do you expect me to talk?
3079 Auric Goldfinger: No, Mr. Bond. I expect you to die.
3081 This code is an ugly hack, doesn't work with lexicals in subroutines that are
3082 called more than once, and is only used by regcomp.c, for (?{}) blocks.
3084 Currently it is not used outside the core code. Best if it stays that way.
3086 Hence it's now deprecated, and will be removed.
3089 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
3090 /* sv Text to convert to OP tree. */
3091 /* startop op_free() this to undo. */
3092 /* code Short string id of the caller. */
3094 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
3095 return Perl_sv_compile_2op_is_broken(aTHX_ sv, startop, code, padp);
3098 /* Don't use this. It will go away without warning once the regexp engine is
3099 refactored not to use it. */
3101 Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code,
3104 dVAR; dSP; /* Make POPBLOCK work. */
3110 char tbuf[TYPE_DIGITS(long) + 12 + 10];
3111 char *tmpbuf = tbuf;
3114 CV* runcv = NULL; /* initialise to avoid compiler warnings */
3118 PERL_ARGS_ASSERT_SV_COMPILE_2OP_IS_BROKEN;
3120 ENTER_with_name("eval");
3121 lex_start(sv, NULL, LEX_START_SAME_FILTER);
3123 /* switch to eval mode */
3125 if (IN_PERL_COMPILETIME) {
3126 SAVECOPSTASH_FREE(&PL_compiling);
3127 CopSTASH_set(&PL_compiling, PL_curstash);
3129 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3130 SV * const sv = sv_newmortal();
3131 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
3132 code, (unsigned long)++PL_evalseq,
3133 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3138 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
3139 (unsigned long)++PL_evalseq);
3140 SAVECOPFILE_FREE(&PL_compiling);
3141 CopFILE_set(&PL_compiling, tmpbuf+2);
3142 SAVECOPLINE(&PL_compiling);
3143 CopLINE_set(&PL_compiling, 1);
3144 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3145 deleting the eval's FILEGV from the stash before gv_check() runs
3146 (i.e. before run-time proper). To work around the coredump that
3147 ensues, we always turn GvMULTI_on for any globals that were
3148 introduced within evals. See force_ident(). GSAR 96-10-12 */
3149 safestr = savepvn(tmpbuf, len);
3150 SAVEDELETE(PL_defstash, safestr, len);
3152 #ifdef OP_IN_REGISTER
3158 /* we get here either during compilation, or via pp_regcomp at runtime */
3159 runtime = IN_PERL_RUNTIME;
3162 runcv = find_runcv(NULL);
3164 /* At run time, we have to fetch the hints from PL_curcop. */
3165 PL_hints = PL_curcop->cop_hints;
3166 if (PL_hints & HINT_LOCALIZE_HH) {
3167 /* SAVEHINTS created a new HV in PL_hintgv, which we
3169 SvREFCNT_dec(GvHV(PL_hintgv));
3171 refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0);
3172 hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints);
3174 SAVECOMPILEWARNINGS();
3175 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3176 cophh_free(CopHINTHASH_get(&PL_compiling));
3177 /* XXX Does this need to avoid copying a label? */
3178 PL_compiling.cop_hints_hash
3179 = cophh_copy(PL_curcop->cop_hints_hash);
3183 PL_op->op_type = OP_ENTEREVAL;
3184 PL_op->op_flags = 0; /* Avoid uninit warning. */
3185 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
3187 need_catch = CATCH_GET;
3191 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
3193 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
3194 CATCH_SET(need_catch);
3195 POPBLOCK(cx,PL_curpm);
3198 (*startop)->op_type = OP_NULL;
3199 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
3200 /* XXX DAPM do this properly one year */
3201 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
3202 LEAVE_with_name("eval");
3203 if (IN_PERL_COMPILETIME)
3204 CopHINTS_set(&PL_compiling, PL_hints);
3205 #ifdef OP_IN_REGISTER
3208 PERL_UNUSED_VAR(newsp);
3209 PERL_UNUSED_VAR(optype);
3211 return PL_eval_start;
3216 =for apidoc find_runcv
3218 Locate the CV corresponding to the currently executing sub or eval.
3219 If db_seqp is non_null, skip CVs that are in the DB package and populate
3220 *db_seqp with the cop sequence number at the point that the DB:: code was
3221 entered. (allows debuggers to eval in the scope of the breakpoint rather
3222 than in the scope of the debugger itself).
3228 Perl_find_runcv(pTHX_ U32 *db_seqp)
3234 *db_seqp = PL_curcop->cop_seq;
3235 for (si = PL_curstackinfo; si; si = si->si_prev) {
3237 for (ix = si->si_cxix; ix >= 0; ix--) {
3238 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3239 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3240 CV * const cv = cx->blk_sub.cv;
3241 /* skip DB:: code */
3242 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3243 *db_seqp = cx->blk_oldcop->cop_seq;
3248 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3256 /* Run yyparse() in a setjmp wrapper. Returns:
3257 * 0: yyparse() successful
3258 * 1: yyparse() failed
3262 S_try_yyparse(pTHX_ int gramtype)
3267 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3271 ret = yyparse(gramtype) ? 1 : 0;
3285 /* Compile a require/do, an eval '', or a /(?{...})/.
3286 * In the last case, startop is non-null, and contains the address of
3287 * a pointer that should be set to the just-compiled code.
3288 * outside is the lexically enclosing CV (if any) that invoked us.
3289 * Returns a bool indicating whether the compile was successful; if so,
3290 * PL_eval_start contains the first op of the compiled ocde; otherwise,
3291 * pushes undef (also croaks if startop != NULL).
3295 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3298 OP * const saveop = PL_op;
3299 bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3302 PL_in_eval = (in_require
3303 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3308 SAVESPTR(PL_compcv);
3309 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3310 CvEVAL_on(PL_compcv);
3311 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3312 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3314 CvOUTSIDE_SEQ(PL_compcv) = seq;
3315 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3317 /* set up a scratch pad */
3319 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3320 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3324 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3326 /* make sure we compile in the right package */
3328 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3329 SAVESPTR(PL_curstash);
3330 PL_curstash = CopSTASH(PL_curcop);
3332 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3333 SAVESPTR(PL_beginav);
3334 PL_beginav = newAV();
3335 SAVEFREESV(PL_beginav);
3336 SAVESPTR(PL_unitcheckav);
3337 PL_unitcheckav = newAV();
3338 SAVEFREESV(PL_unitcheckav);
3341 SAVEBOOL(PL_madskills);
3345 /* try to compile it */
3347 PL_eval_root = NULL;
3348 PL_curcop = &PL_compiling;
3349 CopARYBASE_set(PL_curcop, 0);
3350 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3351 PL_in_eval |= EVAL_KEEPERR;
3355 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3357 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3358 * so honour CATCH_GET and trap it here if necessary */
3360 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3362 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3363 SV **newsp; /* Used by POPBLOCK. */
3364 PERL_CONTEXT *cx = NULL;
3365 I32 optype; /* Used by POPEVAL. */
3369 PERL_UNUSED_VAR(newsp);
3370 PERL_UNUSED_VAR(optype);
3372 /* note that if yystatus == 3, then the EVAL CX block has already
3373 * been popped, and various vars restored */
3375 if (yystatus != 3) {
3377 op_free(PL_eval_root);
3378 PL_eval_root = NULL;
3380 SP = PL_stack_base + POPMARK; /* pop original mark */
3382 POPBLOCK(cx,PL_curpm);
3384 namesv = cx->blk_eval.old_namesv;
3388 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3390 msg = SvPVx_nolen_const(ERRSV);
3393 /* If cx is still NULL, it means that we didn't go in the
3394 * POPEVAL branch. */
3395 cx = &cxstack[cxstack_ix];
3396 assert(CxTYPE(cx) == CXt_EVAL);
3397 namesv = cx->blk_eval.old_namesv;
3399 (void)hv_store(GvHVn(PL_incgv),
3400 SvPVX_const(namesv), SvCUR(namesv),
3402 Perl_croak(aTHX_ "%sCompilation failed in require",
3403 *msg ? msg : "Unknown error\n");
3406 if (yystatus != 3) {
3407 POPBLOCK(cx,PL_curpm);
3410 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3411 (*msg ? msg : "Unknown error\n"));
3415 sv_setpvs(ERRSV, "Compilation error");
3418 PUSHs(&PL_sv_undef);
3422 CopLINE_set(&PL_compiling, 0);
3424 *startop = PL_eval_root;
3426 SAVEFREEOP(PL_eval_root);
3428 /* Set the context for this new optree.
3429 * Propagate the context from the eval(). */
3430 if ((gimme & G_WANT) == G_VOID)
3431 scalarvoid(PL_eval_root);
3432 else if ((gimme & G_WANT) == G_ARRAY)
3435 scalar(PL_eval_root);
3437 DEBUG_x(dump_eval());
3439 /* Register with debugger: */
3440 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3441 CV * const cv = get_cvs("DB::postponed", 0);
3445 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3447 call_sv(MUTABLE_SV(cv), G_DISCARD);
3451 if (PL_unitcheckav) {
3452 OP *es = PL_eval_start;
3453 call_list(PL_scopestack_ix, PL_unitcheckav);
3457 /* compiled okay, so do it */
3459 CvDEPTH(PL_compcv) = 1;
3460 SP = PL_stack_base + POPMARK; /* pop original mark */
3461 PL_op = saveop; /* The caller may need it. */
3462 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3469 S_check_type_and_open(pTHX_ SV *name)
3472 const char *p = SvPV_nolen_const(name);
3473 const int st_rc = PerlLIO_stat(p, &st);
3475 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3477 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3481 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3482 return PerlIO_openn(aTHX_ NULL, PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3484 return PerlIO_open(p, PERL_SCRIPT_MODE);
3488 #ifndef PERL_DISABLE_PMC
3490 S_doopen_pm(pTHX_ SV *name)
3493 const char *p = SvPV_const(name, namelen);
3495 PERL_ARGS_ASSERT_DOOPEN_PM;
3497 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3498 SV *const pmcsv = sv_newmortal();
3501 SvSetSV_nosteal(pmcsv,name);
3502 sv_catpvn(pmcsv, "c", 1);
3504 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3505 return check_type_and_open(pmcsv);
3507 return check_type_and_open(name);
3510 # define doopen_pm(name) check_type_and_open(name)
3511 #endif /* !PERL_DISABLE_PMC */
3516 register PERL_CONTEXT *cx;
3523 int vms_unixname = 0;
3525 const char *tryname = NULL;
3527 const I32 gimme = GIMME_V;
3528 int filter_has_file = 0;
3529 PerlIO *tryrsfp = NULL;
3530 SV *filter_cache = NULL;
3531 SV *filter_state = NULL;
3532 SV *filter_sub = NULL;
3538 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3539 sv = sv_2mortal(new_version(sv));
3540 if (!sv_derived_from(PL_patchlevel, "version"))
3541 upg_version(PL_patchlevel, TRUE);
3542 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3543 if ( vcmp(sv,PL_patchlevel) <= 0 )
3544 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3545 SVfARG(sv_2mortal(vnormal(sv))),
3546 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3550 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3553 SV * const req = SvRV(sv);
3554 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3556 /* get the left hand term */
3557 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3559 first = SvIV(*av_fetch(lav,0,0));
3560 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3561 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3562 || av_len(lav) > 1 /* FP with > 3 digits */
3563 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3565 DIE(aTHX_ "Perl %"SVf" required--this is only "
3567 SVfARG(sv_2mortal(vnormal(req))),
3568 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3571 else { /* probably 'use 5.10' or 'use 5.8' */
3576 second = SvIV(*av_fetch(lav,1,0));
3578 second /= second >= 600 ? 100 : 10;
3579 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3580 (int)first, (int)second);
3581 upg_version(hintsv, TRUE);
3583 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3584 "--this is only %"SVf", stopped",
3585 SVfARG(sv_2mortal(vnormal(req))),
3586 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3587 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3595 name = SvPV_const(sv, len);
3596 if (!(name && len > 0 && *name))
3597 DIE(aTHX_ "Null filename used");
3598 TAINT_PROPER("require");
3602 /* The key in the %ENV hash is in the syntax of file passed as the argument
3603 * usually this is in UNIX format, but sometimes in VMS format, which
3604 * can result in a module being pulled in more than once.
3605 * To prevent this, the key must be stored in UNIX format if the VMS
3606 * name can be translated to UNIX.
3608 if ((unixname = tounixspec(name, NULL)) != NULL) {
3609 unixlen = strlen(unixname);
3615 /* if not VMS or VMS name can not be translated to UNIX, pass it
3618 unixname = (char *) name;
3621 if (PL_op->op_type == OP_REQUIRE) {
3622 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3623 unixname, unixlen, 0);
3625 if (*svp != &PL_sv_undef)
3628 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3629 "Compilation failed in require", unixname);
3633 /* prepare to compile file */
3635 if (path_is_absolute(name)) {
3636 /* At this point, name is SvPVX(sv) */
3638 tryrsfp = doopen_pm(sv);
3641 AV * const ar = GvAVn(PL_incgv);
3647 namesv = newSV_type(SVt_PV);
3648 for (i = 0; i <= AvFILL(ar); i++) {
3649 SV * const dirsv = *av_fetch(ar, i, TRUE);
3651 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3658 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3659 && !sv_isobject(loader))
3661 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3664 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3665 PTR2UV(SvRV(dirsv)), name);
3666 tryname = SvPVX_const(namesv);
3669 ENTER_with_name("call_INC");
3677 if (sv_isobject(loader))
3678 count = call_method("INC", G_ARRAY);
3680 count = call_sv(loader, G_ARRAY);
3690 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3691 && !isGV_with_GP(SvRV(arg))) {
3692 filter_cache = SvRV(arg);
3693 SvREFCNT_inc_simple_void_NN(filter_cache);
3700 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3704 if (isGV_with_GP(arg)) {
3705 IO * const io = GvIO((const GV *)arg);
3710 tryrsfp = IoIFP(io);
3711 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3712 PerlIO_close(IoOFP(io));
3723 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3725 SvREFCNT_inc_simple_void_NN(filter_sub);
3728 filter_state = SP[i];
3729 SvREFCNT_inc_simple_void(filter_state);
3733 if (!tryrsfp && (filter_cache || filter_sub)) {
3734 tryrsfp = PerlIO_open(BIT_BUCKET,
3742 LEAVE_with_name("call_INC");
3744 /* Adjust file name if the hook has set an %INC entry.
3745 This needs to happen after the FREETMPS above. */
3746 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3748 tryname = SvPV_nolen_const(*svp);
3755 filter_has_file = 0;
3757 SvREFCNT_dec(filter_cache);
3758 filter_cache = NULL;
3761 SvREFCNT_dec(filter_state);
3762 filter_state = NULL;
3765 SvREFCNT_dec(filter_sub);
3770 if (!path_is_absolute(name)
3776 dir = SvPV_const(dirsv, dirlen);
3784 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3786 sv_setpv(namesv, unixdir);
3787 sv_catpv(namesv, unixname);
3789 # ifdef __SYMBIAN32__
3790 if (PL_origfilename[0] &&
3791 PL_origfilename[1] == ':' &&
3792 !(dir[0] && dir[1] == ':'))
3793 Perl_sv_setpvf(aTHX_ namesv,
3798 Perl_sv_setpvf(aTHX_ namesv,
3802 /* The equivalent of
3803 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3804 but without the need to parse the format string, or
3805 call strlen on either pointer, and with the correct
3806 allocation up front. */
3808 char *tmp = SvGROW(namesv, dirlen + len + 2);
3810 memcpy(tmp, dir, dirlen);
3813 /* name came from an SV, so it will have a '\0' at the
3814 end that we can copy as part of this memcpy(). */
3815 memcpy(tmp, name, len + 1);
3817 SvCUR_set(namesv, dirlen + len + 1);
3822 TAINT_PROPER("require");
3823 tryname = SvPVX_const(namesv);
3824 tryrsfp = doopen_pm(namesv);
3826 if (tryname[0] == '.' && tryname[1] == '/') {
3828 while (*++tryname == '/');
3832 else if (errno == EMFILE)
3833 /* no point in trying other paths if out of handles */
3842 if (PL_op->op_type == OP_REQUIRE) {
3843 if(errno == EMFILE) {
3844 /* diag_listed_as: Can't locate %s */
3845 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(errno));
3847 if (namesv) { /* did we lookup @INC? */
3848 AV * const ar = GvAVn(PL_incgv);
3850 SV *const inc = newSVpvs_flags("", SVs_TEMP);
3851 for (i = 0; i <= AvFILL(ar); i++) {
3852 sv_catpvs(inc, " ");
3853 sv_catsv(inc, *av_fetch(ar, i, TRUE));
3856 /* diag_listed_as: Can't locate %s */
3858 "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
3860 (memEQ(name + len - 2, ".h", 3)
3861 ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
3862 (memEQ(name + len - 3, ".ph", 4)
3863 ? " (did you run h2ph?)" : ""),
3868 DIE(aTHX_ "Can't locate %s", name);
3874 SETERRNO(0, SS_NORMAL);
3876 /* Assume success here to prevent recursive requirement. */
3877 /* name is never assigned to again, so len is still strlen(name) */
3878 /* Check whether a hook in @INC has already filled %INC */
3880 (void)hv_store(GvHVn(PL_incgv),
3881 unixname, unixlen, newSVpv(tryname,0),0);
3883 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3885 (void)hv_store(GvHVn(PL_incgv),
3886 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3889 ENTER_with_name("eval");
3891 SAVECOPFILE_FREE(&PL_compiling);
3892 CopFILE_set(&PL_compiling, tryname);
3893 lex_start(NULL, tryrsfp, 0);
3897 hv_clear(GvHV(PL_hintgv));
3899 SAVECOMPILEWARNINGS();
3900 if (PL_dowarn & G_WARN_ALL_ON)
3901 PL_compiling.cop_warnings = pWARN_ALL ;
3902 else if (PL_dowarn & G_WARN_ALL_OFF)
3903 PL_compiling.cop_warnings = pWARN_NONE ;
3905 PL_compiling.cop_warnings = pWARN_STD ;
3907 if (filter_sub || filter_cache) {
3908 /* We can use the SvPV of the filter PVIO itself as our cache, rather
3909 than hanging another SV from it. In turn, filter_add() optionally
3910 takes the SV to use as the filter (or creates a new SV if passed
3911 NULL), so simply pass in whatever value filter_cache has. */
3912 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3913 IoLINES(datasv) = filter_has_file;
3914 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3915 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3918 /* switch to eval mode */
3919 PUSHBLOCK(cx, CXt_EVAL, SP);
3921 cx->blk_eval.retop = PL_op->op_next;
3923 SAVECOPLINE(&PL_compiling);
3924 CopLINE_set(&PL_compiling, 0);
3928 /* Store and reset encoding. */
3929 encoding = PL_encoding;
3932 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3933 op = DOCATCH(PL_eval_start);
3935 op = PL_op->op_next;
3937 /* Restore encoding. */
3938 PL_encoding = encoding;
3943 /* This is a op added to hold the hints hash for
3944 pp_entereval. The hash can be modified by the code
3945 being eval'ed, so we return a copy instead. */
3951 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
3959 register PERL_CONTEXT *cx;
3961 const I32 gimme = GIMME_V;
3962 const U32 was = PL_breakable_sub_gen;
3963 char tbuf[TYPE_DIGITS(long) + 12];
3964 bool saved_delete = FALSE;
3965 char *tmpbuf = tbuf;
3969 HV *saved_hh = NULL;
3971 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3972 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3976 /* make sure we've got a plain PV (no overload etc) before testing
3977 * for taint. Making a copy here is probably overkill, but better
3978 * safe than sorry */
3980 const char * const p = SvPV_const(sv, len);
3982 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
3985 TAINT_IF(SvTAINTED(sv));
3986 TAINT_PROPER("eval");
3988 ENTER_with_name("eval");
3989 lex_start(sv, NULL, LEX_START_SAME_FILTER);
3992 /* switch to eval mode */
3994 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3995 SV * const temp_sv = sv_newmortal();
3996 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3997 (unsigned long)++PL_evalseq,
3998 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3999 tmpbuf = SvPVX(temp_sv);
4000 len = SvCUR(temp_sv);
4003 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4004 SAVECOPFILE_FREE(&PL_compiling);
4005 CopFILE_set(&PL_compiling, tmpbuf+2);
4006 SAVECOPLINE(&PL_compiling);
4007 CopLINE_set(&PL_compiling, 1);
4008 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4009 deleting the eval's FILEGV from the stash before gv_check() runs
4010 (i.e. before run-time proper). To work around the coredump that
4011 ensues, we always turn GvMULTI_on for any globals that were
4012 introduced within evals. See force_ident(). GSAR 96-10-12 */
4014 PL_hints = PL_op->op_targ;
4016 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
4017 SvREFCNT_dec(GvHV(PL_hintgv));
4018 GvHV(PL_hintgv) = saved_hh;
4020 SAVECOMPILEWARNINGS();
4021 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4022 cophh_free(CopHINTHASH_get(&PL_compiling));
4023 if (Perl_fetch_cop_label(aTHX_ PL_curcop, NULL, NULL)) {
4024 /* The label, if present, is the first entry on the chain. So rather
4025 than writing a blank label in front of it (which involves an
4026 allocation), just use the next entry in the chain. */
4027 PL_compiling.cop_hints_hash
4028 = cophh_copy(PL_curcop->cop_hints_hash->refcounted_he_next);
4029 /* Check the assumption that this removed the label. */
4030 assert(Perl_fetch_cop_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
4033 PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash);
4034 /* special case: an eval '' executed within the DB package gets lexically
4035 * placed in the first non-DB CV rather than the current CV - this
4036 * allows the debugger to execute code, find lexicals etc, in the
4037 * scope of the code being debugged. Passing &seq gets find_runcv
4038 * to do the dirty work for us */
4039 runcv = find_runcv(&seq);
4041 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4043 cx->blk_eval.retop = PL_op->op_next;
4045 /* prepare to compile string */
4047 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4048 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4050 char *const safestr = savepvn(tmpbuf, len);
4051 SAVEDELETE(PL_defstash, safestr, len);
4052 saved_delete = TRUE;
4057 if (doeval(gimme, NULL, runcv, seq)) {
4058 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4059 ? (PERLDB_LINE || PERLDB_SAVESRC)
4060 : PERLDB_SAVESRC_NOSUBS) {
4061 /* Retain the filegv we created. */
4062 } else if (!saved_delete) {
4063 char *const safestr = savepvn(tmpbuf, len);
4064 SAVEDELETE(PL_defstash, safestr, len);
4066 return DOCATCH(PL_eval_start);
4068 /* We have already left the scope set up earlier thanks to the LEAVE
4070 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4071 ? (PERLDB_LINE || PERLDB_SAVESRC)
4072 : PERLDB_SAVESRC_INVALID) {
4073 /* Retain the filegv we created. */
4074 } else if (!saved_delete) {
4075 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4077 return PL_op->op_next;
4088 register PERL_CONTEXT *cx;
4090 const U8 save_flags = PL_op -> op_flags;
4097 namesv = cx->blk_eval.old_namesv;
4098 retop = cx->blk_eval.retop;
4101 if (gimme == G_VOID)
4103 else if (gimme == G_SCALAR) {
4106 if (SvFLAGS(TOPs) & SVs_TEMP)
4109 *MARK = sv_mortalcopy(TOPs);
4113 *MARK = &PL_sv_undef;
4118 /* in case LEAVE wipes old return values */
4119 for (mark = newsp + 1; mark <= SP; mark++) {
4120 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
4121 *mark = sv_mortalcopy(*mark);
4122 TAINT_NOT; /* Each item is independent */
4126 PL_curpm = newpm; /* Don't pop $1 et al till now */
4129 assert(CvDEPTH(PL_compcv) == 1);
4131 CvDEPTH(PL_compcv) = 0;
4133 if (optype == OP_REQUIRE &&
4134 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4136 /* Unassume the success we assumed earlier. */
4137 (void)hv_delete(GvHVn(PL_incgv),
4138 SvPVX_const(namesv), SvCUR(namesv),
4140 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4142 /* die_unwind() did LEAVE, or we won't be here */
4145 LEAVE_with_name("eval");
4146 if (!(save_flags & OPf_SPECIAL)) {
4154 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4155 close to the related Perl_create_eval_scope. */
4157 Perl_delete_eval_scope(pTHX)
4162 register PERL_CONTEXT *cx;
4168 LEAVE_with_name("eval_scope");
4169 PERL_UNUSED_VAR(newsp);
4170 PERL_UNUSED_VAR(gimme);
4171 PERL_UNUSED_VAR(optype);
4174 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4175 also needed by Perl_fold_constants. */
4177 Perl_create_eval_scope(pTHX_ U32 flags)
4180 const I32 gimme = GIMME_V;
4182 ENTER_with_name("eval_scope");
4185 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4188 PL_in_eval = EVAL_INEVAL;
4189 if (flags & G_KEEPERR)
4190 PL_in_eval |= EVAL_KEEPERR;
4193 if (flags & G_FAKINGEVAL) {
4194 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4202 PERL_CONTEXT * const cx = create_eval_scope(0);
4203 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4204 return DOCATCH(PL_op->op_next);
4213 register PERL_CONTEXT *cx;
4219 PERL_UNUSED_VAR(optype);
4222 if (gimme == G_VOID)
4224 else if (gimme == G_SCALAR) {
4228 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4231 *MARK = sv_mortalcopy(TOPs);
4235 *MARK = &PL_sv_undef;
4240 /* in case LEAVE wipes old return values */
4242 for (mark = newsp + 1; mark <= SP; mark++) {
4243 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4244 *mark = sv_mortalcopy(*mark);
4245 TAINT_NOT; /* Each item is independent */
4249 PL_curpm = newpm; /* Don't pop $1 et al till now */
4251 LEAVE_with_name("eval_scope");
4259 register PERL_CONTEXT *cx;
4260 const I32 gimme = GIMME_V;
4262 ENTER_with_name("given");
4265 sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs);
4267 PUSHBLOCK(cx, CXt_GIVEN, SP);
4276 register PERL_CONTEXT *cx;
4280 PERL_UNUSED_CONTEXT;
4283 assert(CxTYPE(cx) == CXt_GIVEN);
4286 if (gimme == G_VOID)
4288 else if (gimme == G_SCALAR) {
4292 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4295 *MARK = sv_mortalcopy(TOPs);
4299 *MARK = &PL_sv_undef;
4304 /* in case LEAVE wipes old return values */
4306 for (mark = newsp + 1; mark <= SP; mark++) {
4307 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4308 *mark = sv_mortalcopy(*mark);
4309 TAINT_NOT; /* Each item is independent */
4313 PL_curpm = newpm; /* Don't pop $1 et al till now */
4315 LEAVE_with_name("given");
4319 /* Helper routines used by pp_smartmatch */
4321 S_make_matcher(pTHX_ REGEXP *re)
4324 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4326 PERL_ARGS_ASSERT_MAKE_MATCHER;
4328 PM_SETRE(matcher, ReREFCNT_inc(re));
4330 SAVEFREEOP((OP *) matcher);
4331 ENTER_with_name("matcher"); SAVETMPS;
4337 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4342 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4344 PL_op = (OP *) matcher;
4347 (void) Perl_pp_match(aTHX);
4349 return (SvTRUEx(POPs));
4353 S_destroy_matcher(pTHX_ PMOP *matcher)
4357 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4358 PERL_UNUSED_ARG(matcher);
4361 LEAVE_with_name("matcher");
4364 /* Do a smart match */
4367 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4368 return do_smartmatch(NULL, NULL);
4371 /* This version of do_smartmatch() implements the
4372 * table of smart matches that is found in perlsyn.
4375 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4380 bool object_on_left = FALSE;
4381 SV *e = TOPs; /* e is for 'expression' */
4382 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4384 /* Take care only to invoke mg_get() once for each argument.
4385 * Currently we do this by copying the SV if it's magical. */
4388 d = sv_mortalcopy(d);
4395 e = sv_mortalcopy(e);
4397 /* First of all, handle overload magic of the rightmost argument */
4400 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4401 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4403 tmpsv = amagic_call(d, e, smart_amg, 0);
4410 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4413 SP -= 2; /* Pop the values */
4418 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4425 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4426 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4427 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4429 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4430 object_on_left = TRUE;
4433 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4435 if (object_on_left) {
4436 goto sm_any_sub; /* Treat objects like scalars */
4438 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4439 /* Test sub truth for each key */
4441 bool andedresults = TRUE;
4442 HV *hv = (HV*) SvRV(d);
4443 I32 numkeys = hv_iterinit(hv);
4444 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4447 while ( (he = hv_iternext(hv)) ) {
4448 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4449 ENTER_with_name("smartmatch_hash_key_test");
4452 PUSHs(hv_iterkeysv(he));
4454 c = call_sv(e, G_SCALAR);
4457 andedresults = FALSE;
4459 andedresults = SvTRUEx(POPs) && andedresults;
4461 LEAVE_with_name("smartmatch_hash_key_test");
4468 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4469 /* Test sub truth for each element */
4471 bool andedresults = TRUE;
4472 AV *av = (AV*) SvRV(d);
4473 const I32 len = av_len(av);
4474 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4477 for (i = 0; i <= len; ++i) {
4478 SV * const * const svp = av_fetch(av, i, FALSE);
4479 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4480 ENTER_with_name("smartmatch_array_elem_test");
4486 c = call_sv(e, G_SCALAR);
4489 andedresults = FALSE;
4491 andedresults = SvTRUEx(POPs) && andedresults;
4493 LEAVE_with_name("smartmatch_array_elem_test");
4502 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4503 ENTER_with_name("smartmatch_coderef");
4508 c = call_sv(e, G_SCALAR);
4512 else if (SvTEMP(TOPs))
4513 SvREFCNT_inc_void(TOPs);
4515 LEAVE_with_name("smartmatch_coderef");
4520 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4521 if (object_on_left) {
4522 goto sm_any_hash; /* Treat objects like scalars */
4524 else if (!SvOK(d)) {
4525 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4528 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4529 /* Check that the key-sets are identical */
4531 HV *other_hv = MUTABLE_HV(SvRV(d));
4533 bool other_tied = FALSE;
4534 U32 this_key_count = 0,
4535 other_key_count = 0;
4536 HV *hv = MUTABLE_HV(SvRV(e));
4538 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4539 /* Tied hashes don't know how many keys they have. */
4540 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4543 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4544 HV * const temp = other_hv;
4549 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4552 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4555 /* The hashes have the same number of keys, so it suffices
4556 to check that one is a subset of the other. */
4557 (void) hv_iterinit(hv);
4558 while ( (he = hv_iternext(hv)) ) {
4559 SV *key = hv_iterkeysv(he);
4561 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4564 if(!hv_exists_ent(other_hv, key, 0)) {
4565 (void) hv_iterinit(hv); /* reset iterator */
4571 (void) hv_iterinit(other_hv);
4572 while ( hv_iternext(other_hv) )
4576 other_key_count = HvUSEDKEYS(other_hv);
4578 if (this_key_count != other_key_count)
4583 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4584 AV * const other_av = MUTABLE_AV(SvRV(d));
4585 const I32 other_len = av_len(other_av) + 1;
4587 HV *hv = MUTABLE_HV(SvRV(e));
4589 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4590 for (i = 0; i < other_len; ++i) {
4591 SV ** const svp = av_fetch(other_av, i, FALSE);
4592 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4593 if (svp) { /* ??? When can this not happen? */
4594 if (hv_exists_ent(hv, *svp, 0))
4600 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4601 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4604 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4606 HV *hv = MUTABLE_HV(SvRV(e));
4608 (void) hv_iterinit(hv);
4609 while ( (he = hv_iternext(hv)) ) {
4610 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4611 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4612 (void) hv_iterinit(hv);
4613 destroy_matcher(matcher);
4617 destroy_matcher(matcher);
4623 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4624 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4631 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4632 if (object_on_left) {
4633 goto sm_any_array; /* Treat objects like scalars */
4635 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4636 AV * const other_av = MUTABLE_AV(SvRV(e));
4637 const I32 other_len = av_len(other_av) + 1;
4640 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4641 for (i = 0; i < other_len; ++i) {
4642 SV ** const svp = av_fetch(other_av, i, FALSE);
4644 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4645 if (svp) { /* ??? When can this not happen? */
4646 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4652 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4653 AV *other_av = MUTABLE_AV(SvRV(d));
4654 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4655 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4659 const I32 other_len = av_len(other_av);
4661 if (NULL == seen_this) {
4662 seen_this = newHV();
4663 (void) sv_2mortal(MUTABLE_SV(seen_this));
4665 if (NULL == seen_other) {
4666 seen_other = newHV();
4667 (void) sv_2mortal(MUTABLE_SV(seen_other));
4669 for(i = 0; i <= other_len; ++i) {
4670 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4671 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4673 if (!this_elem || !other_elem) {
4674 if ((this_elem && SvOK(*this_elem))
4675 || (other_elem && SvOK(*other_elem)))
4678 else if (hv_exists_ent(seen_this,
4679 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4680 hv_exists_ent(seen_other,
4681 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4683 if (*this_elem != *other_elem)
4687 (void)hv_store_ent(seen_this,
4688 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4690 (void)hv_store_ent(seen_other,
4691 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4697 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4698 (void) do_smartmatch(seen_this, seen_other);
4700 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4709 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4710 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4713 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4714 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4717 for(i = 0; i <= this_len; ++i) {
4718 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4719 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4720 if (svp && matcher_matches_sv(matcher, *svp)) {
4721 destroy_matcher(matcher);
4725 destroy_matcher(matcher);
4729 else if (!SvOK(d)) {
4730 /* undef ~~ array */
4731 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4734 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4735 for (i = 0; i <= this_len; ++i) {
4736 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4737 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4738 if (!svp || !SvOK(*svp))
4747 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4749 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4750 for (i = 0; i <= this_len; ++i) {
4751 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4758 /* infinite recursion isn't supposed to happen here */
4759 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4760 (void) do_smartmatch(NULL, NULL);
4762 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4771 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4772 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4773 SV *t = d; d = e; e = t;
4774 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4777 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4778 SV *t = d; d = e; e = t;
4779 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4780 goto sm_regex_array;
4783 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4785 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4787 PUSHs(matcher_matches_sv(matcher, d)
4790 destroy_matcher(matcher);
4795 /* See if there is overload magic on left */
4796 else if (object_on_left && SvAMAGIC(d)) {
4798 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4799 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4802 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4810 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4813 else if (!SvOK(d)) {
4814 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4815 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4820 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4821 DEBUG_M(if (SvNIOK(e))
4822 Perl_deb(aTHX_ " applying rule Any-Num\n");
4824 Perl_deb(aTHX_ " applying rule Num-numish\n");
4826 /* numeric comparison */
4829 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4830 (void) Perl_pp_i_eq(aTHX);
4832 (void) Perl_pp_eq(aTHX);
4840 /* As a last resort, use string comparison */
4841 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4844 return Perl_pp_seq(aTHX);
4850 register PERL_CONTEXT *cx;
4851 const I32 gimme = GIMME_V;
4853 /* This is essentially an optimization: if the match
4854 fails, we don't want to push a context and then
4855 pop it again right away, so we skip straight
4856 to the op that follows the leavewhen.
4857 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4859 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4860 RETURNOP(cLOGOP->op_other->op_next);
4862 ENTER_with_name("eval");
4865 PUSHBLOCK(cx, CXt_WHEN, SP);
4874 register PERL_CONTEXT *cx;
4875 I32 gimme __attribute__unused__;
4880 assert(CxTYPE(cx) == CXt_WHEN);
4885 PL_curpm = newpm; /* pop $1 et al */
4887 LEAVE_with_name("eval");
4895 register PERL_CONTEXT *cx;
4898 cxix = dopoptowhen(cxstack_ix);
4900 DIE(aTHX_ "Can't \"continue\" outside a when block");
4901 if (cxix < cxstack_ix)
4904 /* clear off anything above the scope we're re-entering */
4905 inner = PL_scopestack_ix;
4907 if (PL_scopestack_ix < inner)
4908 leave_scope(PL_scopestack[PL_scopestack_ix]);
4909 PL_curcop = cx->blk_oldcop;
4910 return cx->blk_givwhen.leave_op;
4917 register PERL_CONTEXT *cx;
4921 cxix = dopoptogiven(cxstack_ix);
4923 if (PL_op->op_flags & OPf_SPECIAL)
4924 DIE(aTHX_ "Can't use when() outside a topicalizer");
4926 DIE(aTHX_ "Can't \"break\" outside a given block");
4928 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4929 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4931 if (cxix < cxstack_ix)
4934 /* clear off anything above the scope we're re-entering */
4935 inner = PL_scopestack_ix;
4937 if (PL_scopestack_ix < inner)
4938 leave_scope(PL_scopestack[PL_scopestack_ix]);
4939 PL_curcop = cx->blk_oldcop;
4942 return (cx)->blk_loop.my_op->op_nextop;
4944 /* RETURNOP calls PUTBACK which restores the old old sp */
4945 RETURNOP(cx->blk_givwhen.leave_op);
4949 S_doparseform(pTHX_ SV *sv)
4952 register char *s = SvPV(sv, len);
4953 register char *send;
4954 register char *base = NULL; /* start of current field */
4955 register I32 skipspaces = 0; /* number of contiguous spaces seen */
4956 bool noblank = FALSE; /* ~ or ~~ seen on this line */
4957 bool repeat = FALSE; /* ~~ seen on this line */
4958 bool postspace = FALSE; /* a text field may need right padding */
4961 U32 *linepc = NULL; /* position of last FF_LINEMARK */
4963 bool ischop; /* it's a ^ rather than a @ */
4964 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
4965 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4969 PERL_ARGS_ASSERT_DOPARSEFORM;
4972 Perl_croak(aTHX_ "Null picture in formline");
4974 if (SvTYPE(sv) >= SVt_PVMG) {
4975 /* This might, of course, still return NULL. */
4976 mg = mg_find(sv, PERL_MAGIC_fm);
4978 sv_upgrade(sv, SVt_PVMG);
4982 /* still the same as previously-compiled string? */
4983 SV *old = mg->mg_obj;
4984 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
4985 && len == SvCUR(old)
4986 && strnEQ(SvPVX(old), SvPVX(sv), len)
4988 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
4992 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
4993 Safefree(mg->mg_ptr);
4999 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5000 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5003 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5004 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5008 /* estimate the buffer size needed */
5009 for (base = s; s <= send; s++) {
5010 if (*s == '\n' || *s == '@' || *s == '^')
5016 Newx(fops, maxops, U32);
5021 *fpc++ = FF_LINEMARK;
5022 noblank = repeat = FALSE;
5040 case ' ': case '\t':
5047 } /* else FALL THROUGH */
5055 *fpc++ = FF_LITERAL;
5063 *fpc++ = (U32)skipspaces;
5067 *fpc++ = FF_NEWLINE;
5071 arg = fpc - linepc + 1;
5078 *fpc++ = FF_LINEMARK;
5079 noblank = repeat = FALSE;
5088 ischop = s[-1] == '^';
5094 arg = (s - base) - 1;
5096 *fpc++ = FF_LITERAL;
5102 if (*s == '*') { /* @* or ^* */
5104 *fpc++ = 2; /* skip the @* or ^* */
5106 *fpc++ = FF_LINESNGL;
5109 *fpc++ = FF_LINEGLOB;
5111 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5112 arg = ischop ? FORM_NUM_BLANK : 0;
5117 const char * const f = ++s;
5120 arg |= FORM_NUM_POINT + (s - f);
5122 *fpc++ = s - base; /* fieldsize for FETCH */
5123 *fpc++ = FF_DECIMAL;
5125 unchopnum |= ! ischop;
5127 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5128 arg = ischop ? FORM_NUM_BLANK : 0;
5130 s++; /* skip the '0' first */
5134 const char * const f = ++s;
5137 arg |= FORM_NUM_POINT + (s - f);
5139 *fpc++ = s - base; /* fieldsize for FETCH */
5140 *fpc++ = FF_0DECIMAL;
5142 unchopnum |= ! ischop;
5144 else { /* text field */
5146 bool ismore = FALSE;
5149 while (*++s == '>') ;
5150 prespace = FF_SPACE;
5152 else if (*s == '|') {
5153 while (*++s == '|') ;
5154 prespace = FF_HALFSPACE;
5159 while (*++s == '<') ;
5162 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5166 *fpc++ = s - base; /* fieldsize for FETCH */
5168 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5171 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5185 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5188 mg->mg_ptr = (char *) fops;
5189 mg->mg_len = arg * sizeof(U32);
5190 mg->mg_obj = sv_copy;
5191 mg->mg_flags |= MGf_REFCOUNTED;
5193 if (unchopnum && repeat)
5194 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5201 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5203 /* Can value be printed in fldsize chars, using %*.*f ? */
5207 int intsize = fldsize - (value < 0 ? 1 : 0);
5209 if (frcsize & FORM_NUM_POINT)
5211 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5214 while (intsize--) pwr *= 10.0;
5215 while (frcsize--) eps /= 10.0;
5218 if (value + eps >= pwr)
5221 if (value - eps <= -pwr)
5228 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5231 SV * const datasv = FILTER_DATA(idx);
5232 const int filter_has_file = IoLINES(datasv);
5233 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5234 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5239 char *prune_from = NULL;
5240 bool read_from_cache = FALSE;
5243 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5245 assert(maxlen >= 0);
5248 /* I was having segfault trouble under Linux 2.2.5 after a
5249 parse error occured. (Had to hack around it with a test
5250 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5251 not sure where the trouble is yet. XXX */
5254 SV *const cache = datasv;
5257 const char *cache_p = SvPV(cache, cache_len);
5261 /* Running in block mode and we have some cached data already.
5263 if (cache_len >= umaxlen) {
5264 /* In fact, so much data we don't even need to call
5269 const char *const first_nl =
5270 (const char *)memchr(cache_p, '\n', cache_len);
5272 take = first_nl + 1 - cache_p;
5276 sv_catpvn(buf_sv, cache_p, take);
5277 sv_chop(cache, cache_p + take);
5278 /* Definitely not EOF */
5282 sv_catsv(buf_sv, cache);
5284 umaxlen -= cache_len;
5287 read_from_cache = TRUE;
5291 /* Filter API says that the filter appends to the contents of the buffer.
5292 Usually the buffer is "", so the details don't matter. But if it's not,
5293 then clearly what it contains is already filtered by this filter, so we
5294 don't want to pass it in a second time.
5295 I'm going to use a mortal in case the upstream filter croaks. */
5296 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5297 ? sv_newmortal() : buf_sv;
5298 SvTEMP_off(upstream);
5299 SvUPGRADE(upstream, SVt_PV);
5301 if (filter_has_file) {
5302 status = FILTER_READ(idx+1, upstream, 0);
5305 if (filter_sub && status >= 0) {
5309 ENTER_with_name("call_filter_sub");
5310 save_gp(PL_defgv, 0);
5311 GvINTRO_off(PL_defgv);
5312 SAVEGENERICSV(GvSV(PL_defgv));
5316 DEFSV_set(upstream);
5317 SvREFCNT_inc_simple_void_NN(upstream);
5321 PUSHs(filter_state);
5324 count = call_sv(filter_sub, G_SCALAR);
5336 LEAVE_with_name("call_filter_sub");
5339 if(SvOK(upstream)) {
5340 got_p = SvPV(upstream, got_len);
5342 if (got_len > umaxlen) {
5343 prune_from = got_p + umaxlen;
5346 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5347 if (first_nl && first_nl + 1 < got_p + got_len) {
5348 /* There's a second line here... */
5349 prune_from = first_nl + 1;
5354 /* Oh. Too long. Stuff some in our cache. */
5355 STRLEN cached_len = got_p + got_len - prune_from;
5356 SV *const cache = datasv;
5359 /* Cache should be empty. */
5360 assert(!SvCUR(cache));
5363 sv_setpvn(cache, prune_from, cached_len);
5364 /* If you ask for block mode, you may well split UTF-8 characters.
5365 "If it breaks, you get to keep both parts"
5366 (Your code is broken if you don't put them back together again
5367 before something notices.) */
5368 if (SvUTF8(upstream)) {
5371 SvCUR_set(upstream, got_len - cached_len);
5373 /* Can't yet be EOF */
5378 /* If they are at EOF but buf_sv has something in it, then they may never
5379 have touched the SV upstream, so it may be undefined. If we naively
5380 concatenate it then we get a warning about use of uninitialised value.
5382 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5383 sv_catsv(buf_sv, upstream);
5387 IoLINES(datasv) = 0;
5389 SvREFCNT_dec(filter_state);
5390 IoTOP_GV(datasv) = NULL;
5393 SvREFCNT_dec(filter_sub);
5394 IoBOTTOM_GV(datasv) = NULL;
5396 filter_del(S_run_user_filter);
5398 if (status == 0 && read_from_cache) {
5399 /* If we read some data from the cache (and by getting here it implies
5400 that we emptied the cache) then we aren't yet at EOF, and mustn't
5401 report that to our caller. */
5407 /* perhaps someone can come up with a better name for
5408 this? it is not really "absolute", per se ... */
5410 S_path_is_absolute(const char *name)
5412 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5414 if (PERL_FILE_IS_ABSOLUTE(name)
5416 || (*name == '.' && ((name[1] == '/' ||
5417 (name[1] == '.' && name[2] == '/'))
5418 || (name[1] == '\\' ||
5419 ( name[1] == '.' && name[2] == '\\')))
5422 || (*name == '.' && (name[1] == '/' ||
5423 (name[1] == '.' && name[2] == '/')))
5435 * c-indentation-style: bsd
5437 * indent-tabs-mode: t
5440 * ex: set ts=8 sts=4 sw=4 noet: