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))
46 const PERL_CONTEXT *cx;
49 if (PL_op->op_private & OPpOFFBYONE) {
50 if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
53 cxix = dopoptosub(cxstack_ix);
59 switch (cx->blk_gimme) {
80 PMOP *pm = (PMOP*)cLOGOP->op_other;
85 const regexp_engine *eng;
86 bool is_bare_re= FALSE;
88 if (PL_op->op_flags & OPf_STACKED) {
98 /* prevent recompiling under /o and ithreads. */
99 #if defined(USE_ITHREADS)
100 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
107 assert (re != (REGEXP*) &PL_sv_undef);
108 eng = re ? RX_ENGINE(re) : current_re_engine();
111 In the below logic: these are basically the same - check if this regcomp is part of a split.
113 (PL_op->op_pmflags & PMf_split )
114 (PL_op->op_next->op_type == OP_PUSHRE)
116 We could add a new mask for this and copy the PMf_split, if we did
117 some bit definition fiddling first.
119 For now we leave this
122 new_re = (eng->op_comp
124 : &Perl_re_op_compile
125 )(aTHX_ args, nargs, pm->op_code_list, eng, re,
127 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
129 (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
131 if (pm->op_pmflags & PMf_HAS_CV)
132 ReANY(new_re)->qr_anoncv
133 = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
137 /* The match's LHS's get-magic might need to access this op's regexp
138 (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
139 get-magic now before we replace the regexp. Hopefully this hack can
140 be replaced with the approach described at
141 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
143 if (pm->op_type == OP_MATCH) {
145 const bool was_tainted = TAINT_get;
146 if (pm->op_flags & OPf_STACKED)
148 else if (pm->op_private & OPpTARGET_MY)
149 lhs = PAD_SV(pm->op_targ);
152 /* Restore the previous value of PL_tainted (which may have been
153 modified by get-magic), to avoid incorrectly setting the
154 RXf_TAINTED flag with RX_TAINT_on further down. */
155 TAINT_set(was_tainted);
157 PERL_UNUSED_VAR(was_tainted);
160 tmp = reg_temp_copy(NULL, new_re);
161 ReREFCNT_dec(new_re);
167 PM_SETRE(pm, new_re);
171 #ifndef INCOMPLETE_TAINTS
172 if (TAINTING_get && TAINT_get) {
173 SvTAINTED_on((SV*)new_re);
178 #if !defined(USE_ITHREADS)
179 /* can't change the optree at runtime either */
180 /* PMf_KEEP is handled differently under threads to avoid these problems */
181 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
183 if (pm->op_pmflags & PMf_KEEP) {
184 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
185 cLOGOP->op_first->op_next = PL_op->op_next;
198 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
199 PMOP * const pm = (PMOP*) cLOGOP->op_other;
200 SV * const dstr = cx->sb_dstr;
203 char *orig = cx->sb_orig;
204 REGEXP * const rx = cx->sb_rx;
206 REGEXP *old = PM_GETRE(pm);
213 PM_SETRE(pm,ReREFCNT_inc(rx));
216 rxres_restore(&cx->sb_rxres, rx);
218 if (cx->sb_iters++) {
219 const I32 saviters = cx->sb_iters;
220 if (cx->sb_iters > cx->sb_maxiters)
221 DIE(aTHX_ "Substitution loop");
223 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
225 /* See "how taint works" above pp_subst() */
227 cx->sb_rxtainted |= SUBST_TAINT_REPL;
228 sv_catsv_nomg(dstr, POPs);
229 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
233 if (CxONCE(cx) || s < orig ||
234 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
235 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
236 (REXEC_IGNOREPOS|REXEC_NOT_FIRST)))
238 SV *targ = cx->sb_targ;
240 assert(cx->sb_strend >= s);
241 if(cx->sb_strend > s) {
242 if (DO_UTF8(dstr) && !SvUTF8(targ))
243 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
245 sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
247 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
248 cx->sb_rxtainted |= SUBST_TAINT_PAT;
250 if (pm->op_pmflags & PMf_NONDESTRUCT) {
252 /* From here on down we're using the copy, and leaving the
253 original untouched. */
258 sv_force_normal_flags(targ, SV_COW_DROP_PV);
263 SvPV_set(targ, SvPVX(dstr));
264 SvCUR_set(targ, SvCUR(dstr));
265 SvLEN_set(targ, SvLEN(dstr));
268 SvPV_set(dstr, NULL);
271 mPUSHi(saviters - 1);
273 (void)SvPOK_only_UTF8(targ);
276 /* update the taint state of various various variables in
277 * preparation for final exit.
278 * See "how taint works" above pp_subst() */
280 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
281 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
282 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
284 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
286 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
287 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
289 SvTAINTED_on(TOPs); /* taint return value */
290 /* needed for mg_set below */
292 cBOOL(cx->sb_rxtainted &
293 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
297 /* PL_tainted must be correctly set for this mg_set */
300 LEAVE_SCOPE(cx->sb_oldsave);
303 RETURNOP(pm->op_next);
304 assert(0); /* NOTREACHED */
306 cx->sb_iters = saviters;
308 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
311 assert(!RX_SUBOFFSET(rx));
312 cx->sb_orig = orig = RX_SUBBEG(rx);
314 cx->sb_strend = s + (cx->sb_strend - m);
316 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
318 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
319 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
321 sv_catpvn_nomg(dstr, s, m-s);
323 cx->sb_s = RX_OFFS(rx)[0].end + orig;
324 { /* Update the pos() information. */
326 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
328 SvUPGRADE(sv, SVt_PVMG);
329 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
330 #ifdef PERL_OLD_COPY_ON_WRITE
332 sv_force_normal_flags(sv, 0);
334 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
337 mg->mg_len = m - orig;
340 (void)ReREFCNT_inc(rx);
341 /* update the taint state of various various variables in preparation
342 * for calling the code block.
343 * See "how taint works" above pp_subst() */
345 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
346 cx->sb_rxtainted |= SUBST_TAINT_PAT;
348 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
349 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
350 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
352 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
354 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
355 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
356 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
357 ? cx->sb_dstr : cx->sb_targ);
360 rxres_save(&cx->sb_rxres, rx);
362 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
366 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
371 PERL_ARGS_ASSERT_RXRES_SAVE;
374 if (!p || p[1] < RX_NPARENS(rx)) {
376 i = 7 + (RX_NPARENS(rx)+1) * 2;
378 i = 6 + (RX_NPARENS(rx)+1) * 2;
387 /* what (if anything) to free on croak */
388 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
389 RX_MATCH_COPIED_off(rx);
390 *p++ = RX_NPARENS(rx);
393 *p++ = PTR2UV(RX_SAVED_COPY(rx));
394 RX_SAVED_COPY(rx) = NULL;
397 *p++ = PTR2UV(RX_SUBBEG(rx));
398 *p++ = (UV)RX_SUBLEN(rx);
399 *p++ = (UV)RX_SUBOFFSET(rx);
400 *p++ = (UV)RX_SUBCOFFSET(rx);
401 for (i = 0; i <= RX_NPARENS(rx); ++i) {
402 *p++ = (UV)RX_OFFS(rx)[i].start;
403 *p++ = (UV)RX_OFFS(rx)[i].end;
408 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
413 PERL_ARGS_ASSERT_RXRES_RESTORE;
416 RX_MATCH_COPY_FREE(rx);
417 RX_MATCH_COPIED_set(rx, *p);
419 RX_NPARENS(rx) = *p++;
422 if (RX_SAVED_COPY(rx))
423 SvREFCNT_dec (RX_SAVED_COPY(rx));
424 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
428 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
429 RX_SUBLEN(rx) = (I32)(*p++);
430 RX_SUBOFFSET(rx) = (I32)*p++;
431 RX_SUBCOFFSET(rx) = (I32)*p++;
432 for (i = 0; i <= RX_NPARENS(rx); ++i) {
433 RX_OFFS(rx)[i].start = (I32)(*p++);
434 RX_OFFS(rx)[i].end = (I32)(*p++);
439 S_rxres_free(pTHX_ void **rsp)
441 UV * const p = (UV*)*rsp;
443 PERL_ARGS_ASSERT_RXRES_FREE;
447 void *tmp = INT2PTR(char*,*p);
450 U32 i = 9 + p[1] * 2;
452 U32 i = 8 + p[1] * 2;
457 SvREFCNT_dec (INT2PTR(SV*,p[2]));
460 PoisonFree(p, i, sizeof(UV));
469 #define FORM_NUM_BLANK (1<<30)
470 #define FORM_NUM_POINT (1<<29)
474 dVAR; dSP; dMARK; dORIGMARK;
475 SV * const tmpForm = *++MARK;
476 SV *formsv; /* contains text of original format */
477 U32 *fpc; /* format ops program counter */
478 char *t; /* current append position in target string */
479 const char *f; /* current position in format string */
481 SV *sv = NULL; /* current item */
482 const char *item = NULL;/* string value of current item */
483 I32 itemsize = 0; /* length of current item, possibly truncated */
484 I32 fieldsize = 0; /* width of current field */
485 I32 lines = 0; /* number of lines that have been output */
486 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
487 const char *chophere = NULL; /* where to chop current item */
488 STRLEN linemark = 0; /* pos of start of line in output */
490 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
492 STRLEN linemax; /* estimate of output size in bytes */
493 bool item_is_utf8 = FALSE;
494 bool targ_is_utf8 = FALSE;
497 U8 *source; /* source of bytes to append */
498 STRLEN to_copy; /* how may bytes to append */
499 char trans; /* what chars to translate */
501 mg = doparseform(tmpForm);
503 fpc = (U32*)mg->mg_ptr;
504 /* the actual string the format was compiled from.
505 * with overload etc, this may not match tmpForm */
509 SvPV_force(PL_formtarget, len);
510 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
511 SvTAINTED_on(PL_formtarget);
512 if (DO_UTF8(PL_formtarget))
514 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
515 t = SvGROW(PL_formtarget, len + linemax + 1);
516 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
518 f = SvPV_const(formsv, len);
522 const char *name = "???";
525 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
526 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
527 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
528 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
529 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
531 case FF_CHECKNL: name = "CHECKNL"; break;
532 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
533 case FF_SPACE: name = "SPACE"; break;
534 case FF_HALFSPACE: name = "HALFSPACE"; break;
535 case FF_ITEM: name = "ITEM"; break;
536 case FF_CHOP: name = "CHOP"; break;
537 case FF_LINEGLOB: name = "LINEGLOB"; break;
538 case FF_NEWLINE: name = "NEWLINE"; break;
539 case FF_MORE: name = "MORE"; break;
540 case FF_LINEMARK: name = "LINEMARK"; break;
541 case FF_END: name = "END"; break;
542 case FF_0DECIMAL: name = "0DECIMAL"; break;
543 case FF_LINESNGL: name = "LINESNGL"; break;
546 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
548 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
552 linemark = t - SvPVX(PL_formtarget);
562 item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
578 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
581 SvTAINTED_on(PL_formtarget);
587 const char *s = item = SvPV_const(sv, len);
590 itemsize = sv_len_utf8(sv);
591 if (itemsize != (I32)len) {
593 if (itemsize > fieldsize) {
594 itemsize = fieldsize;
595 itembytes = itemsize;
596 sv_pos_u2b(sv, &itembytes, 0);
600 send = chophere = s + itembytes;
610 sv_pos_b2u(sv, &itemsize);
614 item_is_utf8 = FALSE;
615 if (itemsize > fieldsize)
616 itemsize = fieldsize;
617 send = chophere = s + itemsize;
631 const char *s = item = SvPV_const(sv, len);
634 itemsize = sv_len_utf8(sv);
635 if (itemsize != (I32)len) {
637 if (itemsize <= fieldsize) {
638 const char *send = chophere = s + itemsize;
651 itemsize = fieldsize;
652 itembytes = itemsize;
653 sv_pos_u2b(sv, &itembytes, 0);
654 send = chophere = s + itembytes;
655 while (s < send || (s == send && isSPACE(*s))) {
665 if (strchr(PL_chopset, *s))
670 itemsize = chophere - item;
671 sv_pos_b2u(sv, &itemsize);
677 item_is_utf8 = FALSE;
678 if (itemsize <= fieldsize) {
679 const char *const send = chophere = s + itemsize;
692 itemsize = fieldsize;
693 send = chophere = s + itemsize;
694 while (s < send || (s == send && isSPACE(*s))) {
704 if (strchr(PL_chopset, *s))
709 itemsize = chophere - item;
715 arg = fieldsize - itemsize;
724 arg = fieldsize - itemsize;
738 /* convert to_copy from chars to bytes */
742 to_copy = s - source;
748 const char *s = chophere;
762 const bool oneline = fpc[-1] == FF_LINESNGL;
763 const char *s = item = SvPV_const(sv, len);
764 const char *const send = s + len;
766 item_is_utf8 = DO_UTF8(sv);
777 to_copy = s - SvPVX_const(sv) - 1;
791 /* append to_copy bytes from source to PL_formstring.
792 * item_is_utf8 implies source is utf8.
793 * if trans, translate certain characters during the copy */
798 SvCUR_set(PL_formtarget,
799 t - SvPVX_const(PL_formtarget));
801 if (targ_is_utf8 && !item_is_utf8) {
802 source = tmp = bytes_to_utf8(source, &to_copy);
804 if (item_is_utf8 && !targ_is_utf8) {
806 /* Upgrade targ to UTF8, and then we reduce it to
807 a problem we have a simple solution for.
808 Don't need get magic. */
809 sv_utf8_upgrade_nomg(PL_formtarget);
811 /* re-calculate linemark */
812 s = (U8*)SvPVX(PL_formtarget);
813 /* the bytes we initially allocated to append the
814 * whole line may have been gobbled up during the
815 * upgrade, so allocate a whole new line's worth
820 linemark = s - (U8*)SvPVX(PL_formtarget);
822 /* Easy. They agree. */
823 assert (item_is_utf8 == targ_is_utf8);
826 /* @* and ^* are the only things that can exceed
827 * the linemax, so grow by the output size, plus
828 * a whole new form's worth in case of any further
830 grow = linemax + to_copy;
832 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
833 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
835 Copy(source, t, to_copy, char);
837 /* blank out ~ or control chars, depending on trans.
838 * works on bytes not chars, so relies on not
839 * matching utf8 continuation bytes */
841 U8 *send = s + to_copy;
844 if (trans == '~' ? (ch == '~') :
857 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
865 #if defined(USE_LONG_DOUBLE)
867 ((arg & FORM_NUM_POINT) ?
868 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
871 ((arg & FORM_NUM_POINT) ?
872 "%#0*.*f" : "%0*.*f");
877 #if defined(USE_LONG_DOUBLE)
879 ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
882 ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f");
885 /* If the field is marked with ^ and the value is undefined,
887 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
895 /* overflow evidence */
896 if (num_overflow(value, fieldsize, arg)) {
902 /* Formats aren't yet marked for locales, so assume "yes". */
904 STORE_NUMERIC_STANDARD_SET_LOCAL();
905 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
906 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value);
907 RESTORE_NUMERIC_STANDARD();
914 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
922 if (arg) { /* repeat until fields exhausted? */
928 t = SvPVX(PL_formtarget) + linemark;
935 const char *s = chophere;
936 const char *send = item + len;
938 while (isSPACE(*s) && (s < send))
943 arg = fieldsize - itemsize;
950 if (strnEQ(s1," ",3)) {
951 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
962 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
964 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
966 SvUTF8_on(PL_formtarget);
967 FmLINES(PL_formtarget) += lines;
969 if (fpc[-1] == FF_BLANK)
970 RETURNOP(cLISTOP->op_first);
982 if (PL_stack_base + *PL_markstack_ptr == SP) {
984 if (GIMME_V == G_SCALAR)
986 RETURNOP(PL_op->op_next->op_next);
988 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
989 Perl_pp_pushmark(aTHX); /* push dst */
990 Perl_pp_pushmark(aTHX); /* push src */
991 ENTER_with_name("grep"); /* enter outer scope */
994 if (PL_op->op_private & OPpGREP_LEX)
995 SAVESPTR(PAD_SVl(PL_op->op_targ));
998 ENTER_with_name("grep_item"); /* enter inner scope */
1001 src = PL_stack_base[*PL_markstack_ptr];
1003 if (PL_op->op_private & OPpGREP_LEX)
1004 PAD_SVl(PL_op->op_targ) = src;
1009 if (PL_op->op_type == OP_MAPSTART)
1010 Perl_pp_pushmark(aTHX); /* push top */
1011 return ((LOGOP*)PL_op->op_next)->op_other;
1017 const I32 gimme = GIMME_V;
1018 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1024 /* first, move source pointer to the next item in the source list */
1025 ++PL_markstack_ptr[-1];
1027 /* if there are new items, push them into the destination list */
1028 if (items && gimme != G_VOID) {
1029 /* might need to make room back there first */
1030 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1031 /* XXX this implementation is very pessimal because the stack
1032 * is repeatedly extended for every set of items. Is possible
1033 * to do this without any stack extension or copying at all
1034 * by maintaining a separate list over which the map iterates
1035 * (like foreach does). --gsar */
1037 /* everything in the stack after the destination list moves
1038 * towards the end the stack by the amount of room needed */
1039 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1041 /* items to shift up (accounting for the moved source pointer) */
1042 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1044 /* This optimization is by Ben Tilly and it does
1045 * things differently from what Sarathy (gsar)
1046 * is describing. The downside of this optimization is
1047 * that leaves "holes" (uninitialized and hopefully unused areas)
1048 * to the Perl stack, but on the other hand this
1049 * shouldn't be a problem. If Sarathy's idea gets
1050 * implemented, this optimization should become
1051 * irrelevant. --jhi */
1053 shift = count; /* Avoid shifting too often --Ben Tilly */
1057 dst = (SP += shift);
1058 PL_markstack_ptr[-1] += shift;
1059 *PL_markstack_ptr += shift;
1063 /* copy the new items down to the destination list */
1064 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1065 if (gimme == G_ARRAY) {
1066 /* add returned items to the collection (making mortal copies
1067 * if necessary), then clear the current temps stack frame
1068 * *except* for those items. We do this splicing the items
1069 * into the start of the tmps frame (so some items may be on
1070 * the tmps stack twice), then moving PL_tmps_floor above
1071 * them, then freeing the frame. That way, the only tmps that
1072 * accumulate over iterations are the return values for map.
1073 * We have to do to this way so that everything gets correctly
1074 * freed if we die during the map.
1078 /* make space for the slice */
1079 EXTEND_MORTAL(items);
1080 tmpsbase = PL_tmps_floor + 1;
1081 Move(PL_tmps_stack + tmpsbase,
1082 PL_tmps_stack + tmpsbase + items,
1083 PL_tmps_ix - PL_tmps_floor,
1085 PL_tmps_ix += items;
1090 sv = sv_mortalcopy(sv);
1092 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1094 /* clear the stack frame except for the items */
1095 PL_tmps_floor += items;
1097 /* FREETMPS may have cleared the TEMP flag on some of the items */
1100 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1103 /* scalar context: we don't care about which values map returns
1104 * (we use undef here). And so we certainly don't want to do mortal
1105 * copies of meaningless values. */
1106 while (items-- > 0) {
1108 *dst-- = &PL_sv_undef;
1116 LEAVE_with_name("grep_item"); /* exit inner scope */
1119 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1121 (void)POPMARK; /* pop top */
1122 LEAVE_with_name("grep"); /* exit outer scope */
1123 (void)POPMARK; /* pop src */
1124 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1125 (void)POPMARK; /* pop dst */
1126 SP = PL_stack_base + POPMARK; /* pop original mark */
1127 if (gimme == G_SCALAR) {
1128 if (PL_op->op_private & OPpGREP_LEX) {
1129 SV* sv = sv_newmortal();
1130 sv_setiv(sv, items);
1138 else if (gimme == G_ARRAY)
1145 ENTER_with_name("grep_item"); /* enter inner scope */
1148 /* set $_ to the new source item */
1149 src = PL_stack_base[PL_markstack_ptr[-1]];
1151 if (PL_op->op_private & OPpGREP_LEX)
1152 PAD_SVl(PL_op->op_targ) = src;
1156 RETURNOP(cLOGOP->op_other);
1165 if (GIMME == G_ARRAY)
1167 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1168 return cLOGOP->op_other;
1178 if (GIMME == G_ARRAY) {
1179 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1183 SV * const targ = PAD_SV(PL_op->op_targ);
1186 if (PL_op->op_private & OPpFLIP_LINENUM) {
1187 if (GvIO(PL_last_in_gv)) {
1188 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1191 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1193 flip = SvIV(sv) == SvIV(GvSV(gv));
1199 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1200 if (PL_op->op_flags & OPf_SPECIAL) {
1208 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1211 sv_setpvs(TARG, "");
1217 /* This code tries to decide if "$left .. $right" should use the
1218 magical string increment, or if the range is numeric (we make
1219 an exception for .."0" [#18165]). AMS 20021031. */
1221 #define RANGE_IS_NUMERIC(left,right) ( \
1222 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1223 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1224 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1225 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1226 && (!SvOK(right) || looks_like_number(right))))
1232 if (GIMME == G_ARRAY) {
1238 if (RANGE_IS_NUMERIC(left,right)) {
1241 if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) ||
1242 (SvOK(right) && SvNV_nomg(right) > IV_MAX))
1243 DIE(aTHX_ "Range iterator outside integer range");
1244 i = SvIV_nomg(left);
1245 max = SvIV_nomg(right);
1254 SV * const sv = sv_2mortal(newSViv(i++));
1260 const char * const lpv = SvPV_nomg_const(left, llen);
1261 const char * const tmps = SvPV_nomg_const(right, len);
1263 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1264 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1266 if (strEQ(SvPVX_const(sv),tmps))
1268 sv = sv_2mortal(newSVsv(sv));
1275 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1279 if (PL_op->op_private & OPpFLIP_LINENUM) {
1280 if (GvIO(PL_last_in_gv)) {
1281 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1284 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1285 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1293 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1294 sv_catpvs(targ, "E0");
1304 static const char * const context_name[] = {
1306 NULL, /* CXt_WHEN never actually needs "block" */
1307 NULL, /* CXt_BLOCK never actually needs "block" */
1308 NULL, /* CXt_GIVEN never actually needs "block" */
1309 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1310 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1311 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1312 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1320 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1325 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1327 for (i = cxstack_ix; i >= 0; i--) {
1328 const PERL_CONTEXT * const cx = &cxstack[i];
1329 switch (CxTYPE(cx)) {
1335 /* diag_listed_as: Exiting subroutine via %s */
1336 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1337 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1338 if (CxTYPE(cx) == CXt_NULL)
1341 case CXt_LOOP_LAZYIV:
1342 case CXt_LOOP_LAZYSV:
1344 case CXt_LOOP_PLAIN:
1346 STRLEN cx_label_len = 0;
1347 U32 cx_label_flags = 0;
1348 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1350 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1353 (const U8*)cx_label, cx_label_len,
1354 (const U8*)label, len) == 0)
1356 (const U8*)label, len,
1357 (const U8*)cx_label, cx_label_len) == 0)
1358 : (len == cx_label_len && ((cx_label == label)
1359 || memEQ(cx_label, label, len))) )) {
1360 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1361 (long)i, cx_label));
1364 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1375 Perl_dowantarray(pTHX)
1378 const I32 gimme = block_gimme();
1379 return (gimme == G_VOID) ? G_SCALAR : gimme;
1383 Perl_block_gimme(pTHX)
1386 const I32 cxix = dopoptosub(cxstack_ix);
1390 switch (cxstack[cxix].blk_gimme) {
1398 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1399 assert(0); /* NOTREACHED */
1405 Perl_is_lvalue_sub(pTHX)
1408 const I32 cxix = dopoptosub(cxstack_ix);
1409 assert(cxix >= 0); /* We should only be called from inside subs */
1411 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1412 return CxLVAL(cxstack + cxix);
1417 /* only used by PUSHSUB */
1419 Perl_was_lvalue_sub(pTHX)
1422 const I32 cxix = dopoptosub(cxstack_ix-1);
1423 assert(cxix >= 0); /* We should only be called from inside subs */
1425 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1426 return CxLVAL(cxstack + cxix);
1432 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1437 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1439 for (i = startingblock; i >= 0; i--) {
1440 const PERL_CONTEXT * const cx = &cxstk[i];
1441 switch (CxTYPE(cx)) {
1445 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1446 * twice; the first for the normal foo() call, and the second
1447 * for a faked up re-entry into the sub to execute the
1448 * code block. Hide this faked entry from the world. */
1449 if (cx->cx_type & CXp_SUB_RE_FAKE)
1453 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1461 S_dopoptoeval(pTHX_ I32 startingblock)
1465 for (i = startingblock; i >= 0; i--) {
1466 const PERL_CONTEXT *cx = &cxstack[i];
1467 switch (CxTYPE(cx)) {
1471 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1479 S_dopoptoloop(pTHX_ I32 startingblock)
1483 for (i = startingblock; i >= 0; i--) {
1484 const PERL_CONTEXT * const cx = &cxstack[i];
1485 switch (CxTYPE(cx)) {
1491 /* diag_listed_as: Exiting subroutine via %s */
1492 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1493 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1494 if ((CxTYPE(cx)) == CXt_NULL)
1497 case CXt_LOOP_LAZYIV:
1498 case CXt_LOOP_LAZYSV:
1500 case CXt_LOOP_PLAIN:
1501 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1509 S_dopoptogiven(pTHX_ I32 startingblock)
1513 for (i = startingblock; i >= 0; i--) {
1514 const PERL_CONTEXT *cx = &cxstack[i];
1515 switch (CxTYPE(cx)) {
1519 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1521 case CXt_LOOP_PLAIN:
1522 assert(!CxFOREACHDEF(cx));
1524 case CXt_LOOP_LAZYIV:
1525 case CXt_LOOP_LAZYSV:
1527 if (CxFOREACHDEF(cx)) {
1528 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1537 S_dopoptowhen(pTHX_ I32 startingblock)
1541 for (i = startingblock; i >= 0; i--) {
1542 const PERL_CONTEXT *cx = &cxstack[i];
1543 switch (CxTYPE(cx)) {
1547 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1555 Perl_dounwind(pTHX_ I32 cxix)
1560 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1563 while (cxstack_ix > cxix) {
1565 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1566 DEBUG_CX("UNWIND"); \
1567 /* Note: we don't need to restore the base context info till the end. */
1568 switch (CxTYPE(cx)) {
1571 continue; /* not break */
1579 case CXt_LOOP_LAZYIV:
1580 case CXt_LOOP_LAZYSV:
1582 case CXt_LOOP_PLAIN:
1593 PERL_UNUSED_VAR(optype);
1597 Perl_qerror(pTHX_ SV *err)
1601 PERL_ARGS_ASSERT_QERROR;
1604 if (PL_in_eval & EVAL_KEEPERR) {
1605 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1609 sv_catsv(ERRSV, err);
1612 sv_catsv(PL_errors, err);
1614 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1616 ++PL_parser->error_count;
1620 Perl_die_unwind(pTHX_ SV *msv)
1623 SV *exceptsv = sv_mortalcopy(msv);
1624 U8 in_eval = PL_in_eval;
1625 PERL_ARGS_ASSERT_DIE_UNWIND;
1632 * Historically, perl used to set ERRSV ($@) early in the die
1633 * process and rely on it not getting clobbered during unwinding.
1634 * That sucked, because it was liable to get clobbered, so the
1635 * setting of ERRSV used to emit the exception from eval{} has
1636 * been moved to much later, after unwinding (see just before
1637 * JMPENV_JUMP below). However, some modules were relying on the
1638 * early setting, by examining $@ during unwinding to use it as
1639 * a flag indicating whether the current unwinding was caused by
1640 * an exception. It was never a reliable flag for that purpose,
1641 * being totally open to false positives even without actual
1642 * clobberage, but was useful enough for production code to
1643 * semantically rely on it.
1645 * We'd like to have a proper introspective interface that
1646 * explicitly describes the reason for whatever unwinding
1647 * operations are currently in progress, so that those modules
1648 * work reliably and $@ isn't further overloaded. But we don't
1649 * have one yet. In its absence, as a stopgap measure, ERRSV is
1650 * now *additionally* set here, before unwinding, to serve as the
1651 * (unreliable) flag that it used to.
1653 * This behaviour is temporary, and should be removed when a
1654 * proper way to detect exceptional unwinding has been developed.
1655 * As of 2010-12, the authors of modules relying on the hack
1656 * are aware of the issue, because the modules failed on
1657 * perls 5.13.{1..7} which had late setting of $@ without this
1658 * early-setting hack.
1660 if (!(in_eval & EVAL_KEEPERR)) {
1661 SvTEMP_off(exceptsv);
1662 sv_setsv(ERRSV, exceptsv);
1665 if (in_eval & EVAL_KEEPERR) {
1666 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1670 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1671 && PL_curstackinfo->si_prev)
1683 JMPENV *restartjmpenv;
1686 if (cxix < cxstack_ix)
1689 POPBLOCK(cx,PL_curpm);
1690 if (CxTYPE(cx) != CXt_EVAL) {
1692 const char* message = SvPVx_const(exceptsv, msglen);
1693 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1694 PerlIO_write(Perl_error_log, message, msglen);
1698 namesv = cx->blk_eval.old_namesv;
1699 oldcop = cx->blk_oldcop;
1700 restartjmpenv = cx->blk_eval.cur_top_env;
1701 restartop = cx->blk_eval.retop;
1703 if (gimme == G_SCALAR)
1704 *++newsp = &PL_sv_undef;
1705 PL_stack_sp = newsp;
1709 /* LEAVE could clobber PL_curcop (see save_re_context())
1710 * XXX it might be better to find a way to avoid messing with
1711 * PL_curcop in save_re_context() instead, but this is a more
1712 * minimal fix --GSAR */
1715 if (optype == OP_REQUIRE) {
1716 (void)hv_store(GvHVn(PL_incgv),
1717 SvPVX_const(namesv),
1718 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1720 /* note that unlike pp_entereval, pp_require isn't
1721 * supposed to trap errors. So now that we've popped the
1722 * EVAL that pp_require pushed, and processed the error
1723 * message, rethrow the error */
1724 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1725 SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1728 if (!(in_eval & EVAL_KEEPERR))
1729 sv_setsv(ERRSV, exceptsv);
1730 PL_restartjmpenv = restartjmpenv;
1731 PL_restartop = restartop;
1733 assert(0); /* NOTREACHED */
1737 write_to_stderr(exceptsv);
1739 assert(0); /* NOTREACHED */
1744 dVAR; dSP; dPOPTOPssrl;
1745 if (SvTRUE(left) != SvTRUE(right))
1752 =for apidoc caller_cx
1754 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1755 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1756 information returned to Perl by C<caller>. Note that XSUBs don't get a
1757 stack frame, so C<caller_cx(0, NULL)> will return information for the
1758 immediately-surrounding Perl code.
1760 This function skips over the automatic calls to C<&DB::sub> made on the
1761 behalf of the debugger. If the stack frame requested was a sub called by
1762 C<DB::sub>, the return value will be the frame for the call to
1763 C<DB::sub>, since that has the correct line number/etc. for the call
1764 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1765 frame for the sub call itself.
1770 const PERL_CONTEXT *
1771 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1773 I32 cxix = dopoptosub(cxstack_ix);
1774 const PERL_CONTEXT *cx;
1775 const PERL_CONTEXT *ccstack = cxstack;
1776 const PERL_SI *top_si = PL_curstackinfo;
1779 /* we may be in a higher stacklevel, so dig down deeper */
1780 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1781 top_si = top_si->si_prev;
1782 ccstack = top_si->si_cxstack;
1783 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1787 /* caller() should not report the automatic calls to &DB::sub */
1788 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1789 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1793 cxix = dopoptosub_at(ccstack, cxix - 1);
1796 cx = &ccstack[cxix];
1797 if (dbcxp) *dbcxp = cx;
1799 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1800 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1801 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1802 field below is defined for any cx. */
1803 /* caller() should not report the automatic calls to &DB::sub */
1804 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1805 cx = &ccstack[dbcxix];
1815 const PERL_CONTEXT *cx;
1816 const PERL_CONTEXT *dbcx;
1818 const HEK *stash_hek;
1820 bool has_arg = MAXARG && TOPs;
1828 cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1830 if (GIMME != G_ARRAY) {
1838 assert(CopSTASH(cx->blk_oldcop));
1839 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1840 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1842 if (GIMME != G_ARRAY) {
1845 PUSHs(&PL_sv_undef);
1848 sv_sethek(TARG, stash_hek);
1857 PUSHs(&PL_sv_undef);
1860 sv_sethek(TARG, stash_hek);
1863 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1864 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1867 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1868 GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1869 /* So is ccstack[dbcxix]. */
1870 if (cvgv && isGV(cvgv)) {
1871 SV * const sv = newSV(0);
1872 gv_efullname3(sv, cvgv, NULL);
1874 PUSHs(boolSV(CxHASARGS(cx)));
1877 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1878 PUSHs(boolSV(CxHASARGS(cx)));
1882 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1885 gimme = (I32)cx->blk_gimme;
1886 if (gimme == G_VOID)
1887 PUSHs(&PL_sv_undef);
1889 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1890 if (CxTYPE(cx) == CXt_EVAL) {
1892 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1893 PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text),
1894 SvCUR(cx->blk_eval.cur_text)-2,
1895 SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP));
1899 else if (cx->blk_eval.old_namesv) {
1900 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1903 /* eval BLOCK (try blocks have old_namesv == 0) */
1905 PUSHs(&PL_sv_undef);
1906 PUSHs(&PL_sv_undef);
1910 PUSHs(&PL_sv_undef);
1911 PUSHs(&PL_sv_undef);
1913 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1914 && CopSTASH_eq(PL_curcop, PL_debstash))
1916 AV * const ary = cx->blk_sub.argarray;
1917 const int off = AvARRAY(ary) - AvALLOC(ary);
1919 Perl_init_dbargs(aTHX);
1921 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1922 av_extend(PL_dbargs, AvFILLp(ary) + off);
1923 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1924 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1926 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1929 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1931 if (old_warnings == pWARN_NONE)
1932 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1933 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
1934 mask = &PL_sv_undef ;
1935 else if (old_warnings == pWARN_ALL ||
1936 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1937 /* Get the bit mask for $warnings::Bits{all}, because
1938 * it could have been extended by warnings::register */
1940 HV * const bits = get_hv("warnings::Bits", 0);
1941 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1942 mask = newSVsv(*bits_all);
1945 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1949 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1953 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1954 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1965 if (MAXARG < 1 || (!TOPs && !POPs))
1966 tmps = NULL, len = 0;
1968 tmps = SvPVx_const(POPs, len);
1969 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1974 /* like pp_nextstate, but used instead when the debugger is active */
1979 PL_curcop = (COP*)PL_op;
1980 TAINT_NOT; /* Each statement is presumed innocent */
1981 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1986 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1987 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1991 const I32 gimme = G_ARRAY;
1993 GV * const gv = PL_DBgv;
1996 if (gv && isGV_with_GP(gv))
1999 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
2000 DIE(aTHX_ "No DB::DB routine defined");
2002 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2003 /* don't do recursive DB::DB call */
2017 (void)(*CvXSUB(cv))(aTHX_ cv);
2023 PUSHBLOCK(cx, CXt_SUB, SP);
2025 cx->blk_sub.retop = PL_op->op_next;
2027 if (CvDEPTH(cv) >= 2) {
2028 PERL_STACK_OVERFLOW_CHECK();
2029 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2032 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2033 RETURNOP(CvSTART(cv));
2041 S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
2044 PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
2046 if (flags & SVs_PADTMP) {
2047 flags &= ~SVs_PADTMP;
2050 if (gimme == G_SCALAR) {
2052 *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2053 ? *SP : sv_mortalcopy(*SP);
2055 /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2058 *++MARK = &PL_sv_undef;
2062 else if (gimme == G_ARRAY) {
2063 /* in case LEAVE wipes old return values */
2064 while (++MARK <= SP) {
2065 if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2068 *++newsp = sv_mortalcopy(*MARK);
2069 TAINT_NOT; /* Each item is independent */
2072 /* When this function was called with MARK == newsp, we reach this
2073 * point with SP == newsp. */
2083 I32 gimme = GIMME_V;
2085 ENTER_with_name("block");
2088 PUSHBLOCK(cx, CXt_BLOCK, SP);
2101 if (PL_op->op_flags & OPf_SPECIAL) {
2102 cx = &cxstack[cxstack_ix];
2103 cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2108 gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2111 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
2112 PL_curpm = newpm; /* Don't pop $1 et al till now */
2114 LEAVE_with_name("block");
2123 const I32 gimme = GIMME_V;
2124 void *itervar; /* location of the iteration variable */
2125 U8 cxtype = CXt_LOOP_FOR;
2127 ENTER_with_name("loop1");
2130 if (PL_op->op_targ) { /* "my" variable */
2131 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2132 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2133 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2134 SVs_PADSTALE, SVs_PADSTALE);
2136 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2138 itervar = PL_comppad;
2140 itervar = &PAD_SVl(PL_op->op_targ);
2143 else { /* symbol table variable */
2144 GV * const gv = MUTABLE_GV(POPs);
2145 SV** svp = &GvSV(gv);
2146 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2148 itervar = (void *)gv;
2151 if (PL_op->op_private & OPpITER_DEF)
2152 cxtype |= CXp_FOR_DEF;
2154 ENTER_with_name("loop2");
2156 PUSHBLOCK(cx, cxtype, SP);
2157 PUSHLOOP_FOR(cx, itervar, MARK);
2158 if (PL_op->op_flags & OPf_STACKED) {
2159 SV *maybe_ary = POPs;
2160 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2162 SV * const right = maybe_ary;
2165 if (RANGE_IS_NUMERIC(sv,right)) {
2166 cx->cx_type &= ~CXTYPEMASK;
2167 cx->cx_type |= CXt_LOOP_LAZYIV;
2168 /* Make sure that no-one re-orders cop.h and breaks our
2170 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2171 #ifdef NV_PRESERVES_UV
2172 if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
2173 (SvNV_nomg(sv) > (NV)IV_MAX)))
2175 (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
2176 (SvNV_nomg(right) < (NV)IV_MIN))))
2178 if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
2180 ((SvNV_nomg(sv) > 0) &&
2181 ((SvUV_nomg(sv) > (UV)IV_MAX) ||
2182 (SvNV_nomg(sv) > (NV)UV_MAX)))))
2184 (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
2186 ((SvNV_nomg(right) > 0) &&
2187 ((SvUV_nomg(right) > (UV)IV_MAX) ||
2188 (SvNV_nomg(right) > (NV)UV_MAX))
2191 DIE(aTHX_ "Range iterator outside integer range");
2192 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2193 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2195 /* for correct -Dstv display */
2196 cx->blk_oldsp = sp - PL_stack_base;
2200 cx->cx_type &= ~CXTYPEMASK;
2201 cx->cx_type |= CXt_LOOP_LAZYSV;
2202 /* Make sure that no-one re-orders cop.h and breaks our
2204 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2205 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2206 cx->blk_loop.state_u.lazysv.end = right;
2207 SvREFCNT_inc(right);
2208 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2209 /* This will do the upgrade to SVt_PV, and warn if the value
2210 is uninitialised. */
2211 (void) SvPV_nolen_const(right);
2212 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2213 to replace !SvOK() with a pointer to "". */
2215 SvREFCNT_dec(right);
2216 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2220 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2221 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2222 SvREFCNT_inc(maybe_ary);
2223 cx->blk_loop.state_u.ary.ix =
2224 (PL_op->op_private & OPpITER_REVERSED) ?
2225 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2229 else { /* iterating over items on the stack */
2230 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2231 if (PL_op->op_private & OPpITER_REVERSED) {
2232 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2235 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2246 const I32 gimme = GIMME_V;
2248 ENTER_with_name("loop1");
2250 ENTER_with_name("loop2");
2252 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2253 PUSHLOOP_PLAIN(cx, SP);
2268 assert(CxTYPE_is_LOOP(cx));
2270 newsp = PL_stack_base + cx->blk_loop.resetsp;
2273 SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0);
2276 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2277 PL_curpm = newpm; /* ... and pop $1 et al */
2279 LEAVE_with_name("loop2");
2280 LEAVE_with_name("loop1");
2286 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2287 PERL_CONTEXT *cx, PMOP *newpm)
2289 const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2290 if (gimme == G_SCALAR) {
2291 if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
2293 const char *what = NULL;
2295 assert(MARK+1 == SP);
2296 if ((SvPADTMP(TOPs) ||
2297 (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2300 !SvSMAGICAL(TOPs)) {
2302 SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2303 : "a readonly value" : "a temporary";
2308 /* sub:lvalue{} will take us here. */
2317 "Can't return %s from lvalue subroutine", what
2322 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2323 if (!SvPADTMP(*SP)) {
2324 *++newsp = SvREFCNT_inc(*SP);
2329 /* FREETMPS could clobber it */
2330 SV *sv = SvREFCNT_inc(*SP);
2332 *++newsp = sv_mortalcopy(sv);
2339 ? sv_mortalcopy(*SP)
2341 ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2346 *++newsp = &PL_sv_undef;
2348 if (CxLVAL(cx) & OPpDEREF) {
2351 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2355 else if (gimme == G_ARRAY) {
2356 assert (!(CxLVAL(cx) & OPpDEREF));
2357 if (ref || !CxLVAL(cx))
2358 while (++MARK <= SP)
2360 SvFLAGS(*MARK) & SVs_PADTMP
2361 ? sv_mortalcopy(*MARK)
2364 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2365 else while (++MARK <= SP) {
2366 if (*MARK != &PL_sv_undef
2368 || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2373 /* Might be flattened array after $#array = */
2380 /* diag_listed_as: Can't return %s from lvalue subroutine */
2382 "Can't return a %s from lvalue subroutine",
2383 SvREADONLY(TOPs) ? "readonly value" : "temporary");
2389 : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2392 PL_stack_sp = newsp;
2399 bool popsub2 = FALSE;
2400 bool clear_errsv = FALSE;
2410 const I32 cxix = dopoptosub(cxstack_ix);
2413 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2414 * sort block, which is a CXt_NULL
2417 PL_stack_base[1] = *PL_stack_sp;
2418 PL_stack_sp = PL_stack_base + 1;
2422 DIE(aTHX_ "Can't return outside a subroutine");
2424 if (cxix < cxstack_ix)
2427 if (CxMULTICALL(&cxstack[cxix])) {
2428 gimme = cxstack[cxix].blk_gimme;
2429 if (gimme == G_VOID)
2430 PL_stack_sp = PL_stack_base;
2431 else if (gimme == G_SCALAR) {
2432 PL_stack_base[1] = *PL_stack_sp;
2433 PL_stack_sp = PL_stack_base + 1;
2439 switch (CxTYPE(cx)) {
2442 lval = !!CvLVALUE(cx->blk_sub.cv);
2443 retop = cx->blk_sub.retop;
2444 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2447 if (!(PL_in_eval & EVAL_KEEPERR))
2450 namesv = cx->blk_eval.old_namesv;
2451 retop = cx->blk_eval.retop;
2454 if (optype == OP_REQUIRE &&
2455 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2457 /* Unassume the success we assumed earlier. */
2458 (void)hv_delete(GvHVn(PL_incgv),
2459 SvPVX_const(namesv),
2460 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2462 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2467 retop = cx->blk_sub.retop;
2470 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2474 if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2476 if (gimme == G_SCALAR) {
2479 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2480 if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2481 && !SvMAGICAL(TOPs)) {
2482 *++newsp = SvREFCNT_inc(*SP);
2487 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2489 *++newsp = sv_mortalcopy(sv);
2493 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2494 && !SvMAGICAL(*SP)) {
2498 *++newsp = sv_mortalcopy(*SP);
2501 *++newsp = sv_mortalcopy(*SP);
2504 *++newsp = &PL_sv_undef;
2506 else if (gimme == G_ARRAY) {
2507 while (++MARK <= SP) {
2508 *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2509 && !SvGMAGICAL(*MARK)
2510 ? *MARK : sv_mortalcopy(*MARK);
2511 TAINT_NOT; /* Each item is independent */
2514 PL_stack_sp = newsp;
2518 /* Stack values are safe: */
2521 POPSUB(cx,sv); /* release CV and @_ ... */
2525 PL_curpm = newpm; /* ... and pop $1 et al */
2534 /* This duplicates parts of pp_leavesub, so that it can share code with
2545 if (CxMULTICALL(&cxstack[cxstack_ix]))
2549 cxstack_ix++; /* temporarily protect top context */
2553 S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2557 POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
2558 PL_curpm = newpm; /* ... and pop $1 et al */
2561 return cx->blk_sub.retop;
2565 S_unwind_loop(pTHX_ const char * const opname)
2569 if (PL_op->op_flags & OPf_SPECIAL) {
2570 cxix = dopoptoloop(cxstack_ix);
2572 /* diag_listed_as: Can't "last" outside a loop block */
2573 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2578 const char * const label =
2579 PL_op->op_flags & OPf_STACKED
2580 ? SvPV(TOPs,label_len)
2581 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2582 const U32 label_flags =
2583 PL_op->op_flags & OPf_STACKED
2585 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2587 cxix = dopoptolabel(label, label_len, label_flags);
2589 /* diag_listed_as: Label not found for "last %s" */
2590 Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2592 SVfARG(PL_op->op_flags & OPf_STACKED
2593 && !SvGMAGICAL(TOPp1s)
2595 : newSVpvn_flags(label,
2597 label_flags | SVs_TEMP)));
2599 if (cxix < cxstack_ix)
2617 S_unwind_loop(aTHX_ "last");
2620 cxstack_ix++; /* temporarily protect top context */
2622 switch (CxTYPE(cx)) {
2623 case CXt_LOOP_LAZYIV:
2624 case CXt_LOOP_LAZYSV:
2626 case CXt_LOOP_PLAIN:
2628 newsp = PL_stack_base + cx->blk_loop.resetsp;
2629 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2633 nextop = cx->blk_sub.retop;
2637 nextop = cx->blk_eval.retop;
2641 nextop = cx->blk_sub.retop;
2644 DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2648 PL_stack_sp = adjust_stack_on_leave(newsp, PL_stack_sp, MARK, gimme,
2649 pop2 == CXt_SUB ? SVs_TEMP : 0);
2653 /* Stack values are safe: */
2655 case CXt_LOOP_LAZYIV:
2656 case CXt_LOOP_PLAIN:
2657 case CXt_LOOP_LAZYSV:
2659 POPLOOP(cx); /* release loop vars ... */
2663 POPSUB(cx,sv); /* release CV and @_ ... */
2666 PL_curpm = newpm; /* ... and pop $1 et al */
2669 PERL_UNUSED_VAR(optype);
2670 PERL_UNUSED_VAR(gimme);
2678 const I32 inner = PL_scopestack_ix;
2680 S_unwind_loop(aTHX_ "next");
2682 /* clear off anything above the scope we're re-entering, but
2683 * save the rest until after a possible continue block */
2685 if (PL_scopestack_ix < inner)
2686 leave_scope(PL_scopestack[PL_scopestack_ix]);
2687 PL_curcop = cx->blk_oldcop;
2689 return (cx)->blk_loop.my_op->op_nextop;
2695 const I32 cxix = S_unwind_loop(aTHX_ "redo");
2698 OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2700 if (redo_op->op_type == OP_ENTER) {
2701 /* pop one less context to avoid $x being freed in while (my $x..) */
2703 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2704 redo_op = redo_op->op_next;
2708 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2709 LEAVE_SCOPE(oldsave);
2711 PL_curcop = cx->blk_oldcop;
2717 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2721 static const char* const too_deep = "Target of goto is too deeply nested";
2723 PERL_ARGS_ASSERT_DOFINDLABEL;
2726 Perl_croak(aTHX_ "%s", too_deep);
2727 if (o->op_type == OP_LEAVE ||
2728 o->op_type == OP_SCOPE ||
2729 o->op_type == OP_LEAVELOOP ||
2730 o->op_type == OP_LEAVESUB ||
2731 o->op_type == OP_LEAVETRY)
2733 *ops++ = cUNOPo->op_first;
2735 Perl_croak(aTHX_ "%s", too_deep);
2738 if (o->op_flags & OPf_KIDS) {
2740 /* First try all the kids at this level, since that's likeliest. */
2741 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2742 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2743 STRLEN kid_label_len;
2744 U32 kid_label_flags;
2745 const char *kid_label = CopLABEL_len_flags(kCOP,
2746 &kid_label_len, &kid_label_flags);
2748 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2751 (const U8*)kid_label, kid_label_len,
2752 (const U8*)label, len) == 0)
2754 (const U8*)label, len,
2755 (const U8*)kid_label, kid_label_len) == 0)
2756 : ( len == kid_label_len && ((kid_label == label)
2757 || memEQ(kid_label, label, len)))))
2761 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2762 if (kid == PL_lastgotoprobe)
2764 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2767 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2768 ops[-1]->op_type == OP_DBSTATE)
2773 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2787 #define GOTO_DEPTH 64
2788 OP *enterops[GOTO_DEPTH];
2789 const char *label = NULL;
2790 STRLEN label_len = 0;
2791 U32 label_flags = 0;
2792 const bool do_dump = (PL_op->op_type == OP_DUMP);
2793 static const char* const must_have_label = "goto must have label";
2795 if (PL_op->op_flags & OPf_STACKED) {
2796 SV * const sv = POPs;
2799 /* This egregious kludge implements goto &subroutine */
2800 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2803 CV *cv = MUTABLE_CV(SvRV(sv));
2804 AV *arg = GvAV(PL_defgv);
2808 if (!CvROOT(cv) && !CvXSUB(cv)) {
2809 const GV * const gv = CvGV(cv);
2813 /* autoloaded stub? */
2814 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2816 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2818 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2819 if (autogv && (cv = GvCV(autogv)))
2821 tmpstr = sv_newmortal();
2822 gv_efullname3(tmpstr, gv, NULL);
2823 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2825 DIE(aTHX_ "Goto undefined subroutine");
2828 /* First do some returnish stuff. */
2829 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2831 cxix = dopoptosub(cxstack_ix);
2832 if (cxix < cxstack_ix) {
2835 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2841 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2842 if (CxTYPE(cx) == CXt_EVAL) {
2845 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2846 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2848 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2849 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2851 else if (CxMULTICALL(cx))
2854 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2856 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2857 AV* av = cx->blk_sub.argarray;
2859 /* abandon the original @_ if it got reified or if it is
2860 the same as the current @_ */
2861 if (AvREAL(av) || av == arg) {
2865 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2867 else CLEAR_ARGARRAY(av);
2869 /* We donate this refcount later to the callee’s pad. */
2870 SvREFCNT_inc_simple_void(arg);
2871 if (CxTYPE(cx) == CXt_SUB &&
2872 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2873 SvREFCNT_dec(cx->blk_sub.cv);
2874 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2875 LEAVE_SCOPE(oldsave);
2877 /* A destructor called during LEAVE_SCOPE could have undefined
2878 * our precious cv. See bug #99850. */
2879 if (!CvROOT(cv) && !CvXSUB(cv)) {
2880 const GV * const gv = CvGV(cv);
2883 SV * const tmpstr = sv_newmortal();
2884 gv_efullname3(tmpstr, gv, NULL);
2885 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2888 DIE(aTHX_ "Goto undefined subroutine");
2891 /* Now do some callish stuff. */
2893 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2895 OP* const retop = cx->blk_sub.retop;
2898 const SSize_t items = AvFILLp(arg) + 1;
2901 PERL_UNUSED_VAR(newsp);
2902 PERL_UNUSED_VAR(gimme);
2904 /* put GvAV(defgv) back onto stack */
2905 EXTEND(SP, items+1); /* @_ could have been extended. */
2906 Copy(AvARRAY(arg), SP + 1, items, SV*);
2911 for (index=0; index<items; index++)
2912 SvREFCNT_inc_void(sv_2mortal(SP[-index]));
2915 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2916 /* Restore old @_ */
2917 arg = GvAV(PL_defgv);
2918 GvAV(PL_defgv) = cx->blk_sub.savearray;
2922 /* XS subs don't have a CxSUB, so pop it */
2923 POPBLOCK(cx, PL_curpm);
2924 /* Push a mark for the start of arglist */
2927 (void)(*CvXSUB(cv))(aTHX_ cv);
2933 PADLIST * const padlist = CvPADLIST(cv);
2934 cx->blk_sub.cv = cv;
2935 cx->blk_sub.olddepth = CvDEPTH(cv);
2938 if (CvDEPTH(cv) < 2)
2939 SvREFCNT_inc_simple_void_NN(cv);
2941 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2942 sub_crush_depth(cv);
2943 pad_push(padlist, CvDEPTH(cv));
2945 PL_curcop = cx->blk_oldcop;
2947 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2950 CX_CURPAD_SAVE(cx->blk_sub);
2952 /* cx->blk_sub.argarray has no reference count, so we
2953 need something to hang on to our argument array so
2954 that cx->blk_sub.argarray does not end up pointing
2955 to freed memory as the result of undef *_. So put
2956 it in the callee’s pad, donating our refer-
2958 SvREFCNT_dec(PAD_SVl(0));
2959 PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2961 /* GvAV(PL_defgv) might have been modified on scope
2962 exit, so restore it. */
2963 if (arg != GvAV(PL_defgv)) {
2964 AV * const av = GvAV(PL_defgv);
2965 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2969 else SvREFCNT_dec(arg);
2970 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2971 Perl_get_db_sub(aTHX_ NULL, cv);
2973 CV * const gotocv = get_cvs("DB::goto", 0);
2975 PUSHMARK( PL_stack_sp );
2976 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2982 RETURNOP(CvSTART(cv));
2986 label = SvPV_nomg_const(sv, label_len);
2987 label_flags = SvUTF8(sv);
2990 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2991 label = cPVOP->op_pv;
2992 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2993 label_len = strlen(label);
2995 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
3000 OP *gotoprobe = NULL;
3001 bool leaving_eval = FALSE;
3002 bool in_block = FALSE;
3003 PERL_CONTEXT *last_eval_cx = NULL;
3007 PL_lastgotoprobe = NULL;
3009 for (ix = cxstack_ix; ix >= 0; ix--) {
3011 switch (CxTYPE(cx)) {
3013 leaving_eval = TRUE;
3014 if (!CxTRYBLOCK(cx)) {
3015 gotoprobe = (last_eval_cx ?
3016 last_eval_cx->blk_eval.old_eval_root :
3021 /* else fall through */
3022 case CXt_LOOP_LAZYIV:
3023 case CXt_LOOP_LAZYSV:
3025 case CXt_LOOP_PLAIN:
3028 gotoprobe = cx->blk_oldcop->op_sibling;
3034 gotoprobe = cx->blk_oldcop->op_sibling;
3037 gotoprobe = PL_main_root;
3040 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3041 gotoprobe = CvROOT(cx->blk_sub.cv);
3047 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3050 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3051 CxTYPE(cx), (long) ix);
3052 gotoprobe = PL_main_root;
3056 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3057 enterops, enterops + GOTO_DEPTH);
3060 if (gotoprobe->op_sibling &&
3061 gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3062 gotoprobe->op_sibling->op_sibling) {
3063 retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3064 label, label_len, label_flags, enterops,
3065 enterops + GOTO_DEPTH);
3070 PL_lastgotoprobe = gotoprobe;
3073 DIE(aTHX_ "Can't find label %"UTF8f,
3074 UTF8fARG(label_flags, label_len, label));
3076 /* if we're leaving an eval, check before we pop any frames
3077 that we're not going to punt, otherwise the error
3080 if (leaving_eval && *enterops && enterops[1]) {
3082 for (i = 1; enterops[i]; i++)
3083 if (enterops[i]->op_type == OP_ENTERITER)
3084 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3087 if (*enterops && enterops[1]) {
3088 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3090 deprecate("\"goto\" to jump into a construct");
3093 /* pop unwanted frames */
3095 if (ix < cxstack_ix) {
3102 oldsave = PL_scopestack[PL_scopestack_ix];
3103 LEAVE_SCOPE(oldsave);
3106 /* push wanted frames */
3108 if (*enterops && enterops[1]) {
3109 OP * const oldop = PL_op;
3110 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3111 for (; enterops[ix]; ix++) {
3112 PL_op = enterops[ix];
3113 /* Eventually we may want to stack the needed arguments
3114 * for each op. For now, we punt on the hard ones. */
3115 if (PL_op->op_type == OP_ENTERITER)
3116 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3117 PL_op->op_ppaddr(aTHX);
3125 if (!retop) retop = PL_main_start;
3127 PL_restartop = retop;
3128 PL_do_undump = TRUE;
3132 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3133 PL_do_undump = FALSE;
3149 anum = 0; (void)POPs;
3154 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
3156 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
3159 PL_exit_flags |= PERL_EXIT_EXPECTED;
3161 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3162 if (anum || !(PL_minus_c && PL_madskills))
3167 PUSHs(&PL_sv_undef);
3174 S_save_lines(pTHX_ AV *array, SV *sv)
3176 const char *s = SvPVX_const(sv);
3177 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3180 PERL_ARGS_ASSERT_SAVE_LINES;
3182 while (s && s < send) {
3184 SV * const tmpstr = newSV_type(SVt_PVMG);
3186 t = (const char *)memchr(s, '\n', send - s);
3192 sv_setpvn(tmpstr, s, t - s);
3193 av_store(array, line++, tmpstr);
3201 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3203 0 is used as continue inside eval,
3205 3 is used for a die caught by an inner eval - continue inner loop
3207 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3208 establish a local jmpenv to handle exception traps.
3213 S_docatch(pTHX_ OP *o)
3217 OP * const oldop = PL_op;
3221 assert(CATCH_GET == TRUE);
3228 assert(cxstack_ix >= 0);
3229 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3230 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3235 /* die caught by an inner eval - continue inner loop */
3236 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3237 PL_restartjmpenv = NULL;
3238 PL_op = PL_restartop;
3247 assert(0); /* NOTREACHED */
3256 =for apidoc find_runcv
3258 Locate the CV corresponding to the currently executing sub or eval.
3259 If db_seqp is non_null, skip CVs that are in the DB package and populate
3260 *db_seqp with the cop sequence number at the point that the DB:: code was
3261 entered. (allows debuggers to eval in the scope of the breakpoint rather
3262 than in the scope of the debugger itself).
3268 Perl_find_runcv(pTHX_ U32 *db_seqp)
3270 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3273 /* If this becomes part of the API, it might need a better name. */
3275 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3282 *db_seqp = PL_curcop->cop_seq;
3283 for (si = PL_curstackinfo; si; si = si->si_prev) {
3285 for (ix = si->si_cxix; ix >= 0; ix--) {
3286 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3288 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3289 cv = cx->blk_sub.cv;
3290 /* skip DB:: code */
3291 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3292 *db_seqp = cx->blk_oldcop->cop_seq;
3295 if (cx->cx_type & CXp_SUB_RE)
3298 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3299 cv = cx->blk_eval.cv;
3302 case FIND_RUNCV_padid_eq:
3304 || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg))
3307 case FIND_RUNCV_level_eq:
3308 if (level++ != arg) continue;
3316 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3320 /* Run yyparse() in a setjmp wrapper. Returns:
3321 * 0: yyparse() successful
3322 * 1: yyparse() failed
3326 S_try_yyparse(pTHX_ int gramtype)
3331 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3335 ret = yyparse(gramtype) ? 1 : 0;
3342 assert(0); /* NOTREACHED */
3349 /* Compile a require/do or an eval ''.
3351 * outside is the lexically enclosing CV (if any) that invoked us.
3352 * seq is the current COP scope value.
3353 * hh is the saved hints hash, if any.
3355 * Returns a bool indicating whether the compile was successful; if so,
3356 * PL_eval_start contains the first op of the compiled code; otherwise,
3359 * This function is called from two places: pp_require and pp_entereval.
3360 * These can be distinguished by whether PL_op is entereval.
3364 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3367 OP * const saveop = PL_op;
3368 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3369 COP * const oldcurcop = PL_curcop;
3370 bool in_require = (saveop->op_type == OP_REQUIRE);
3374 PL_in_eval = (in_require
3375 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3377 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3378 ? EVAL_RE_REPARSING : 0)));
3382 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3384 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3385 cxstack[cxstack_ix].blk_eval.cv = evalcv;
3386 cxstack[cxstack_ix].blk_gimme = gimme;
3388 CvOUTSIDE_SEQ(evalcv) = seq;
3389 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3391 /* set up a scratch pad */
3393 CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3394 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3398 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3400 /* make sure we compile in the right package */
3402 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3403 SAVEGENERICSV(PL_curstash);
3404 PL_curstash = (HV *)CopSTASH(PL_curcop);
3405 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3406 else SvREFCNT_inc_simple_void(PL_curstash);
3408 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3409 SAVESPTR(PL_beginav);
3410 PL_beginav = newAV();
3411 SAVEFREESV(PL_beginav);
3412 SAVESPTR(PL_unitcheckav);
3413 PL_unitcheckav = newAV();
3414 SAVEFREESV(PL_unitcheckav);
3417 SAVEBOOL(PL_madskills);
3421 ENTER_with_name("evalcomp");
3422 SAVESPTR(PL_compcv);
3425 /* try to compile it */
3427 PL_eval_root = NULL;
3428 PL_curcop = &PL_compiling;
3429 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3430 PL_in_eval |= EVAL_KEEPERR;
3437 hv_clear(GvHV(PL_hintgv));
3440 PL_hints = saveop->op_private & OPpEVAL_COPHH
3441 ? oldcurcop->cop_hints : saveop->op_targ;
3443 /* making 'use re eval' not be in scope when compiling the
3444 * qr/mabye_has_runtime_code_block/ ensures that we don't get
3445 * infinite recursion when S_has_runtime_code() gives a false
3446 * positive: the second time round, HINT_RE_EVAL isn't set so we
3447 * don't bother calling S_has_runtime_code() */
3448 if (PL_in_eval & EVAL_RE_REPARSING)
3449 PL_hints &= ~HINT_RE_EVAL;
3452 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3453 SvREFCNT_dec(GvHV(PL_hintgv));
3454 GvHV(PL_hintgv) = hh;
3457 SAVECOMPILEWARNINGS();
3459 if (PL_dowarn & G_WARN_ALL_ON)
3460 PL_compiling.cop_warnings = pWARN_ALL ;
3461 else if (PL_dowarn & G_WARN_ALL_OFF)
3462 PL_compiling.cop_warnings = pWARN_NONE ;
3464 PL_compiling.cop_warnings = pWARN_STD ;
3467 PL_compiling.cop_warnings =
3468 DUP_WARNINGS(oldcurcop->cop_warnings);
3469 cophh_free(CopHINTHASH_get(&PL_compiling));
3470 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3471 /* The label, if present, is the first entry on the chain. So rather
3472 than writing a blank label in front of it (which involves an
3473 allocation), just use the next entry in the chain. */
3474 PL_compiling.cop_hints_hash
3475 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3476 /* Check the assumption that this removed the label. */
3477 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3480 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3483 CALL_BLOCK_HOOKS(bhk_eval, saveop);
3485 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3486 * so honour CATCH_GET and trap it here if necessary */
3488 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3490 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3491 SV **newsp; /* Used by POPBLOCK. */
3493 I32 optype; /* Used by POPEVAL. */
3499 PERL_UNUSED_VAR(newsp);
3500 PERL_UNUSED_VAR(optype);
3502 /* note that if yystatus == 3, then the EVAL CX block has already
3503 * been popped, and various vars restored */
3505 if (yystatus != 3) {
3507 op_free(PL_eval_root);
3508 PL_eval_root = NULL;
3510 SP = PL_stack_base + POPMARK; /* pop original mark */
3511 POPBLOCK(cx,PL_curpm);
3513 namesv = cx->blk_eval.old_namesv;
3514 /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3515 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3521 /* If cx is still NULL, it means that we didn't go in the
3522 * POPEVAL branch. */
3523 cx = &cxstack[cxstack_ix];
3524 assert(CxTYPE(cx) == CXt_EVAL);
3525 namesv = cx->blk_eval.old_namesv;
3527 (void)hv_store(GvHVn(PL_incgv),
3528 SvPVX_const(namesv),
3529 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3531 Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3534 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3537 if (!*(SvPV_nolen_const(errsv))) {
3538 sv_setpvs(errsv, "Compilation error");
3541 if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3546 LEAVE_with_name("evalcomp");
3548 CopLINE_set(&PL_compiling, 0);
3549 SAVEFREEOP(PL_eval_root);
3550 cv_forget_slab(evalcv);
3552 DEBUG_x(dump_eval());
3554 /* Register with debugger: */
3555 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3556 CV * const cv = get_cvs("DB::postponed", 0);
3560 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3562 call_sv(MUTABLE_SV(cv), G_DISCARD);
3566 if (PL_unitcheckav) {
3567 OP *es = PL_eval_start;
3568 call_list(PL_scopestack_ix, PL_unitcheckav);
3572 /* compiled okay, so do it */
3574 CvDEPTH(evalcv) = 1;
3575 SP = PL_stack_base + POPMARK; /* pop original mark */
3576 PL_op = saveop; /* The caller may need it. */
3577 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3584 S_check_type_and_open(pTHX_ SV *name)
3587 const char *p = SvPV_nolen_const(name);
3588 const int st_rc = PerlLIO_stat(p, &st);
3590 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3592 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3596 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3597 return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3599 return PerlIO_open(p, PERL_SCRIPT_MODE);
3603 #ifndef PERL_DISABLE_PMC
3605 S_doopen_pm(pTHX_ SV *name)
3608 const char *p = SvPV_const(name, namelen);
3610 PERL_ARGS_ASSERT_DOOPEN_PM;
3612 if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3613 SV *const pmcsv = sv_newmortal();
3616 SvSetSV_nosteal(pmcsv,name);
3617 sv_catpvn(pmcsv, "c", 1);
3619 if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3620 return check_type_and_open(pmcsv);
3622 return check_type_and_open(name);
3625 # define doopen_pm(name) check_type_and_open(name)
3626 #endif /* !PERL_DISABLE_PMC */
3628 /* require doesn't search for absolute names, or when the name is
3629 explicity relative the current directory */
3630 PERL_STATIC_INLINE bool
3631 S_path_is_searchable(const char *name)
3633 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3635 if (PERL_FILE_IS_ABSOLUTE(name)
3637 || (*name == '.' && ((name[1] == '/' ||
3638 (name[1] == '.' && name[2] == '/'))
3639 || (name[1] == '\\' ||
3640 ( name[1] == '.' && name[2] == '\\')))
3643 || (*name == '.' && (name[1] == '/' ||
3644 (name[1] == '.' && name[2] == '/')))
3664 int vms_unixname = 0;
3669 const char *tryname = NULL;
3671 const I32 gimme = GIMME_V;
3672 int filter_has_file = 0;
3673 PerlIO *tryrsfp = NULL;
3674 SV *filter_cache = NULL;
3675 SV *filter_state = NULL;
3676 SV *filter_sub = NULL;
3681 bool path_searchable;
3684 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3685 sv = sv_2mortal(new_version(sv));
3686 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3687 upg_version(PL_patchlevel, TRUE);
3688 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3689 if ( vcmp(sv,PL_patchlevel) <= 0 )
3690 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3691 SVfARG(sv_2mortal(vnormal(sv))),
3692 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3696 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3699 SV * const req = SvRV(sv);
3700 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3702 /* get the left hand term */
3703 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3705 first = SvIV(*av_fetch(lav,0,0));
3706 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3707 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3708 || av_len(lav) > 1 /* FP with > 3 digits */
3709 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3711 DIE(aTHX_ "Perl %"SVf" required--this is only "
3713 SVfARG(sv_2mortal(vnormal(req))),
3714 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3717 else { /* probably 'use 5.10' or 'use 5.8' */
3722 second = SvIV(*av_fetch(lav,1,0));
3724 second /= second >= 600 ? 100 : 10;
3725 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3726 (int)first, (int)second);
3727 upg_version(hintsv, TRUE);
3729 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3730 "--this is only %"SVf", stopped",
3731 SVfARG(sv_2mortal(vnormal(req))),
3732 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3733 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3741 name = SvPV_const(sv, len);
3742 if (!(name && len > 0 && *name))
3743 DIE(aTHX_ "Null filename used");
3744 TAINT_PROPER("require");
3746 path_searchable = path_is_searchable(name);
3749 /* The key in the %ENV hash is in the syntax of file passed as the argument
3750 * usually this is in UNIX format, but sometimes in VMS format, which
3751 * can result in a module being pulled in more than once.
3752 * To prevent this, the key must be stored in UNIX format if the VMS
3753 * name can be translated to UNIX.
3756 if ((unixnamebuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))
3757 && (unixname = tounixspec(name, unixnamebuf)) != NULL) {
3758 unixlen = strlen(unixname);
3764 /* if not VMS or VMS name can not be translated to UNIX, pass it
3767 unixname = (char *) name;
3770 if (PL_op->op_type == OP_REQUIRE) {
3771 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3772 unixname, unixlen, 0);
3774 if (*svp != &PL_sv_undef)
3777 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3778 "Compilation failed in require", unixname);
3782 LOADING_FILE_PROBE(unixname);
3784 /* prepare to compile file */
3786 if (!path_searchable) {
3787 /* At this point, name is SvPVX(sv) */
3789 tryrsfp = doopen_pm(sv);
3791 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3792 AV * const ar = GvAVn(PL_incgv);
3798 namesv = newSV_type(SVt_PV);
3799 for (i = 0; i <= AvFILL(ar); i++) {
3800 SV * const dirsv = *av_fetch(ar, i, TRUE);
3802 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3809 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3810 && !sv_isobject(loader))
3812 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3815 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3816 PTR2UV(SvRV(dirsv)), name);
3817 tryname = SvPVX_const(namesv);
3820 ENTER_with_name("call_INC");
3828 if (sv_isobject(loader))
3829 count = call_method("INC", G_ARRAY);
3831 count = call_sv(loader, G_ARRAY);
3841 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3842 && !isGV_with_GP(SvRV(arg))) {
3843 filter_cache = SvRV(arg);
3850 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3854 if (isGV_with_GP(arg)) {
3855 IO * const io = GvIO((const GV *)arg);
3860 tryrsfp = IoIFP(io);
3861 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3862 PerlIO_close(IoOFP(io));
3873 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3875 SvREFCNT_inc_simple_void_NN(filter_sub);
3878 filter_state = SP[i];
3879 SvREFCNT_inc_simple_void(filter_state);
3883 if (!tryrsfp && (filter_cache || filter_sub)) {
3884 tryrsfp = PerlIO_open(BIT_BUCKET,
3892 LEAVE_with_name("call_INC");
3894 /* Adjust file name if the hook has set an %INC entry.
3895 This needs to happen after the FREETMPS above. */
3896 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3898 tryname = SvPV_nolen_const(*svp);
3905 filter_has_file = 0;
3906 filter_cache = NULL;
3908 SvREFCNT_dec(filter_state);
3909 filter_state = NULL;
3912 SvREFCNT_dec(filter_sub);
3917 if (path_searchable) {
3922 dir = SvPV_const(dirsv, dirlen);
3929 if (((unixdirbuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) == NULL)
3930 || ((unixdir = tounixpath(dir, unixdirbuf)) == NULL))
3932 sv_setpv(namesv, unixdir);
3933 sv_catpv(namesv, unixname);
3935 # ifdef __SYMBIAN32__
3936 if (PL_origfilename[0] &&
3937 PL_origfilename[1] == ':' &&
3938 !(dir[0] && dir[1] == ':'))
3939 Perl_sv_setpvf(aTHX_ namesv,
3944 Perl_sv_setpvf(aTHX_ namesv,
3948 /* The equivalent of
3949 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3950 but without the need to parse the format string, or
3951 call strlen on either pointer, and with the correct
3952 allocation up front. */
3954 char *tmp = SvGROW(namesv, dirlen + len + 2);
3956 memcpy(tmp, dir, dirlen);
3959 /* Avoid '<dir>//<file>' */
3960 if (!dirlen || *(tmp-1) != '/') {
3964 /* name came from an SV, so it will have a '\0' at the
3965 end that we can copy as part of this memcpy(). */
3966 memcpy(tmp, name, len + 1);
3968 SvCUR_set(namesv, dirlen + len + 1);
3973 TAINT_PROPER("require");
3974 tryname = SvPVX_const(namesv);
3975 tryrsfp = doopen_pm(namesv);
3977 if (tryname[0] == '.' && tryname[1] == '/') {
3979 while (*++tryname == '/') {}
3983 else if (errno == EMFILE || errno == EACCES) {
3984 /* no point in trying other paths if out of handles;
3985 * on the other hand, if we couldn't open one of the
3986 * files, then going on with the search could lead to
3987 * unexpected results; see perl #113422
3996 saved_errno = errno; /* sv_2mortal can realloc things */
3999 if (PL_op->op_type == OP_REQUIRE) {
4000 if(saved_errno == EMFILE || saved_errno == EACCES) {
4001 /* diag_listed_as: Can't locate %s */
4002 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(saved_errno));
4004 if (namesv) { /* did we lookup @INC? */
4005 AV * const ar = GvAVn(PL_incgv);
4007 SV *const msg = newSVpvs_flags("", SVs_TEMP);
4008 SV *const inc = newSVpvs_flags("", SVs_TEMP);
4009 for (i = 0; i <= AvFILL(ar); i++) {
4010 sv_catpvs(inc, " ");
4011 sv_catsv(inc, *av_fetch(ar, i, TRUE));
4013 if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4014 const char *c, *e = name + len - 3;
4015 sv_catpv(msg, " (you may need to install the ");
4016 for (c = name; c < e; c++) {
4018 sv_catpvn(msg, "::", 2);
4021 sv_catpvn(msg, c, 1);
4024 sv_catpv(msg, " module)");
4026 else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4027 sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4029 else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4030 sv_catpv(msg, " (did you run h2ph?)");
4033 /* diag_listed_as: Can't locate %s */
4035 "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4039 DIE(aTHX_ "Can't locate %s", name);
4046 SETERRNO(0, SS_NORMAL);
4048 /* Assume success here to prevent recursive requirement. */
4049 /* name is never assigned to again, so len is still strlen(name) */
4050 /* Check whether a hook in @INC has already filled %INC */
4052 (void)hv_store(GvHVn(PL_incgv),
4053 unixname, unixlen, newSVpv(tryname,0),0);
4055 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4057 (void)hv_store(GvHVn(PL_incgv),
4058 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4061 ENTER_with_name("eval");
4063 SAVECOPFILE_FREE(&PL_compiling);
4064 CopFILE_set(&PL_compiling, tryname);
4065 lex_start(NULL, tryrsfp, 0);
4067 if (filter_sub || filter_cache) {
4068 /* We can use the SvPV of the filter PVIO itself as our cache, rather
4069 than hanging another SV from it. In turn, filter_add() optionally
4070 takes the SV to use as the filter (or creates a new SV if passed
4071 NULL), so simply pass in whatever value filter_cache has. */
4072 SV * const fc = filter_cache ? newSV(0) : NULL;
4074 if (fc) sv_copypv(fc, filter_cache);
4075 datasv = filter_add(S_run_user_filter, fc);
4076 IoLINES(datasv) = filter_has_file;
4077 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4078 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4081 /* switch to eval mode */
4082 PUSHBLOCK(cx, CXt_EVAL, SP);
4084 cx->blk_eval.retop = PL_op->op_next;
4086 SAVECOPLINE(&PL_compiling);
4087 CopLINE_set(&PL_compiling, 0);
4091 /* Store and reset encoding. */
4092 encoding = PL_encoding;
4095 if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4096 op = DOCATCH(PL_eval_start);
4098 op = PL_op->op_next;
4100 /* Restore encoding. */
4101 PL_encoding = encoding;
4103 LOADED_FILE_PROBE(unixname);
4108 /* This is a op added to hold the hints hash for
4109 pp_entereval. The hash can be modified by the code
4110 being eval'ed, so we return a copy instead. */
4116 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4126 const I32 gimme = GIMME_V;
4127 const U32 was = PL_breakable_sub_gen;
4128 char tbuf[TYPE_DIGITS(long) + 12];
4129 bool saved_delete = FALSE;
4130 char *tmpbuf = tbuf;
4133 U32 seq, lex_flags = 0;
4134 HV *saved_hh = NULL;
4135 const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4137 if (PL_op->op_private & OPpEVAL_HAS_HH) {
4138 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4140 else if (PL_hints & HINT_LOCALIZE_HH || (
4141 PL_op->op_private & OPpEVAL_COPHH
4142 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4144 saved_hh = cop_hints_2hv(PL_curcop, 0);
4145 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4149 /* make sure we've got a plain PV (no overload etc) before testing
4150 * for taint. Making a copy here is probably overkill, but better
4151 * safe than sorry */
4153 const char * const p = SvPV_const(sv, len);
4155 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4156 lex_flags |= LEX_START_COPIED;
4158 if (bytes && SvUTF8(sv))
4159 SvPVbyte_force(sv, len);
4161 else if (bytes && SvUTF8(sv)) {
4162 /* Don't modify someone else's scalar */
4165 (void)sv_2mortal(sv);
4166 SvPVbyte_force(sv,len);
4167 lex_flags |= LEX_START_COPIED;
4170 TAINT_IF(SvTAINTED(sv));
4171 TAINT_PROPER("eval");
4173 ENTER_with_name("eval");
4174 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4175 ? LEX_IGNORE_UTF8_HINTS
4176 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4181 /* switch to eval mode */
4183 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4184 SV * const temp_sv = sv_newmortal();
4185 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4186 (unsigned long)++PL_evalseq,
4187 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4188 tmpbuf = SvPVX(temp_sv);
4189 len = SvCUR(temp_sv);
4192 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4193 SAVECOPFILE_FREE(&PL_compiling);
4194 CopFILE_set(&PL_compiling, tmpbuf+2);
4195 SAVECOPLINE(&PL_compiling);
4196 CopLINE_set(&PL_compiling, 1);
4197 /* special case: an eval '' executed within the DB package gets lexically
4198 * placed in the first non-DB CV rather than the current CV - this
4199 * allows the debugger to execute code, find lexicals etc, in the
4200 * scope of the code being debugged. Passing &seq gets find_runcv
4201 * to do the dirty work for us */
4202 runcv = find_runcv(&seq);
4204 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4206 cx->blk_eval.retop = PL_op->op_next;
4208 /* prepare to compile string */
4210 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4211 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4213 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4214 deleting the eval's FILEGV from the stash before gv_check() runs
4215 (i.e. before run-time proper). To work around the coredump that
4216 ensues, we always turn GvMULTI_on for any globals that were
4217 introduced within evals. See force_ident(). GSAR 96-10-12 */
4218 char *const safestr = savepvn(tmpbuf, len);
4219 SAVEDELETE(PL_defstash, safestr, len);
4220 saved_delete = TRUE;
4225 if (doeval(gimme, runcv, seq, saved_hh)) {
4226 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4227 ? (PERLDB_LINE || PERLDB_SAVESRC)
4228 : PERLDB_SAVESRC_NOSUBS) {
4229 /* Retain the filegv we created. */
4230 } else if (!saved_delete) {
4231 char *const safestr = savepvn(tmpbuf, len);
4232 SAVEDELETE(PL_defstash, safestr, len);
4234 return DOCATCH(PL_eval_start);
4236 /* We have already left the scope set up earlier thanks to the LEAVE
4238 if (was != PL_breakable_sub_gen /* Some subs defined here. */
4239 ? (PERLDB_LINE || PERLDB_SAVESRC)
4240 : PERLDB_SAVESRC_INVALID) {
4241 /* Retain the filegv we created. */
4242 } else if (!saved_delete) {
4243 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4245 return PL_op->op_next;
4257 const U8 save_flags = PL_op -> op_flags;
4265 namesv = cx->blk_eval.old_namesv;
4266 retop = cx->blk_eval.retop;
4267 evalcv = cx->blk_eval.cv;
4270 SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4272 PL_curpm = newpm; /* Don't pop $1 et al till now */
4275 assert(CvDEPTH(evalcv) == 1);
4277 CvDEPTH(evalcv) = 0;
4279 if (optype == OP_REQUIRE &&
4280 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4282 /* Unassume the success we assumed earlier. */
4283 (void)hv_delete(GvHVn(PL_incgv),
4284 SvPVX_const(namesv),
4285 SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4287 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4289 /* die_unwind() did LEAVE, or we won't be here */
4292 LEAVE_with_name("eval");
4293 if (!(save_flags & OPf_SPECIAL)) {
4301 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4302 close to the related Perl_create_eval_scope. */
4304 Perl_delete_eval_scope(pTHX)
4315 LEAVE_with_name("eval_scope");
4316 PERL_UNUSED_VAR(newsp);
4317 PERL_UNUSED_VAR(gimme);
4318 PERL_UNUSED_VAR(optype);
4321 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4322 also needed by Perl_fold_constants. */
4324 Perl_create_eval_scope(pTHX_ U32 flags)
4327 const I32 gimme = GIMME_V;
4329 ENTER_with_name("eval_scope");
4332 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4335 PL_in_eval = EVAL_INEVAL;
4336 if (flags & G_KEEPERR)
4337 PL_in_eval |= EVAL_KEEPERR;
4340 if (flags & G_FAKINGEVAL) {
4341 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4349 PERL_CONTEXT * const cx = create_eval_scope(0);
4350 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4351 return DOCATCH(PL_op->op_next);
4366 PERL_UNUSED_VAR(optype);
4369 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4370 PL_curpm = newpm; /* Don't pop $1 et al till now */
4372 LEAVE_with_name("eval_scope");
4381 const I32 gimme = GIMME_V;
4383 ENTER_with_name("given");
4386 if (PL_op->op_targ) {
4387 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4388 SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4389 PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4396 PUSHBLOCK(cx, CXt_GIVEN, SP);
4409 PERL_UNUSED_CONTEXT;
4412 assert(CxTYPE(cx) == CXt_GIVEN);
4415 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4416 PL_curpm = newpm; /* Don't pop $1 et al till now */
4418 LEAVE_with_name("given");
4422 /* Helper routines used by pp_smartmatch */
4424 S_make_matcher(pTHX_ REGEXP *re)
4427 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4429 PERL_ARGS_ASSERT_MAKE_MATCHER;
4431 PM_SETRE(matcher, ReREFCNT_inc(re));
4433 SAVEFREEOP((OP *) matcher);
4434 ENTER_with_name("matcher"); SAVETMPS;
4440 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4445 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4447 PL_op = (OP *) matcher;
4450 (void) Perl_pp_match(aTHX);
4452 return (SvTRUEx(POPs));
4456 S_destroy_matcher(pTHX_ PMOP *matcher)
4460 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4461 PERL_UNUSED_ARG(matcher);
4464 LEAVE_with_name("matcher");
4467 /* Do a smart match */
4470 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4471 return do_smartmatch(NULL, NULL, 0);
4474 /* This version of do_smartmatch() implements the
4475 * table of smart matches that is found in perlsyn.
4478 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4483 bool object_on_left = FALSE;
4484 SV *e = TOPs; /* e is for 'expression' */
4485 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4487 /* Take care only to invoke mg_get() once for each argument.
4488 * Currently we do this by copying the SV if it's magical. */
4490 if (!copied && SvGMAGICAL(d))
4491 d = sv_mortalcopy(d);
4498 e = sv_mortalcopy(e);
4500 /* First of all, handle overload magic of the rightmost argument */
4503 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4504 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4506 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4513 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4516 SP -= 2; /* Pop the values */
4521 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4528 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4529 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4530 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4532 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4533 object_on_left = TRUE;
4536 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4538 if (object_on_left) {
4539 goto sm_any_sub; /* Treat objects like scalars */
4541 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4542 /* Test sub truth for each key */
4544 bool andedresults = TRUE;
4545 HV *hv = (HV*) SvRV(d);
4546 I32 numkeys = hv_iterinit(hv);
4547 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4550 while ( (he = hv_iternext(hv)) ) {
4551 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4552 ENTER_with_name("smartmatch_hash_key_test");
4555 PUSHs(hv_iterkeysv(he));
4557 c = call_sv(e, G_SCALAR);
4560 andedresults = FALSE;
4562 andedresults = SvTRUEx(POPs) && andedresults;
4564 LEAVE_with_name("smartmatch_hash_key_test");
4571 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4572 /* Test sub truth for each element */
4574 bool andedresults = TRUE;
4575 AV *av = (AV*) SvRV(d);
4576 const I32 len = av_len(av);
4577 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4580 for (i = 0; i <= len; ++i) {
4581 SV * const * const svp = av_fetch(av, i, FALSE);
4582 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4583 ENTER_with_name("smartmatch_array_elem_test");
4589 c = call_sv(e, G_SCALAR);
4592 andedresults = FALSE;
4594 andedresults = SvTRUEx(POPs) && andedresults;
4596 LEAVE_with_name("smartmatch_array_elem_test");
4605 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4606 ENTER_with_name("smartmatch_coderef");
4611 c = call_sv(e, G_SCALAR);
4615 else if (SvTEMP(TOPs))
4616 SvREFCNT_inc_void(TOPs);
4618 LEAVE_with_name("smartmatch_coderef");
4623 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4624 if (object_on_left) {
4625 goto sm_any_hash; /* Treat objects like scalars */
4627 else if (!SvOK(d)) {
4628 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4631 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4632 /* Check that the key-sets are identical */
4634 HV *other_hv = MUTABLE_HV(SvRV(d));
4636 bool other_tied = FALSE;
4637 U32 this_key_count = 0,
4638 other_key_count = 0;
4639 HV *hv = MUTABLE_HV(SvRV(e));
4641 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4642 /* Tied hashes don't know how many keys they have. */
4643 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4646 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4647 HV * const temp = other_hv;
4652 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4655 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4658 /* The hashes have the same number of keys, so it suffices
4659 to check that one is a subset of the other. */
4660 (void) hv_iterinit(hv);
4661 while ( (he = hv_iternext(hv)) ) {
4662 SV *key = hv_iterkeysv(he);
4664 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4667 if(!hv_exists_ent(other_hv, key, 0)) {
4668 (void) hv_iterinit(hv); /* reset iterator */
4674 (void) hv_iterinit(other_hv);
4675 while ( hv_iternext(other_hv) )
4679 other_key_count = HvUSEDKEYS(other_hv);
4681 if (this_key_count != other_key_count)
4686 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4687 AV * const other_av = MUTABLE_AV(SvRV(d));
4688 const I32 other_len = av_len(other_av) + 1;
4690 HV *hv = MUTABLE_HV(SvRV(e));
4692 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4693 for (i = 0; i < other_len; ++i) {
4694 SV ** const svp = av_fetch(other_av, i, FALSE);
4695 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4696 if (svp) { /* ??? When can this not happen? */
4697 if (hv_exists_ent(hv, *svp, 0))
4703 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4704 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4707 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4709 HV *hv = MUTABLE_HV(SvRV(e));
4711 (void) hv_iterinit(hv);
4712 while ( (he = hv_iternext(hv)) ) {
4713 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4714 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4715 (void) hv_iterinit(hv);
4716 destroy_matcher(matcher);
4720 destroy_matcher(matcher);
4726 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4727 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4734 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4735 if (object_on_left) {
4736 goto sm_any_array; /* Treat objects like scalars */
4738 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4739 AV * const other_av = MUTABLE_AV(SvRV(e));
4740 const I32 other_len = av_len(other_av) + 1;
4743 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4744 for (i = 0; i < other_len; ++i) {
4745 SV ** const svp = av_fetch(other_av, i, FALSE);
4747 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4748 if (svp) { /* ??? When can this not happen? */
4749 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4755 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4756 AV *other_av = MUTABLE_AV(SvRV(d));
4757 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4758 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4762 const I32 other_len = av_len(other_av);
4764 if (NULL == seen_this) {
4765 seen_this = newHV();
4766 (void) sv_2mortal(MUTABLE_SV(seen_this));
4768 if (NULL == seen_other) {
4769 seen_other = newHV();
4770 (void) sv_2mortal(MUTABLE_SV(seen_other));
4772 for(i = 0; i <= other_len; ++i) {
4773 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4774 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4776 if (!this_elem || !other_elem) {
4777 if ((this_elem && SvOK(*this_elem))
4778 || (other_elem && SvOK(*other_elem)))
4781 else if (hv_exists_ent(seen_this,
4782 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4783 hv_exists_ent(seen_other,
4784 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4786 if (*this_elem != *other_elem)
4790 (void)hv_store_ent(seen_this,
4791 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4793 (void)hv_store_ent(seen_other,
4794 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4800 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4801 (void) do_smartmatch(seen_this, seen_other, 0);
4803 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4812 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4813 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4816 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4817 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4820 for(i = 0; i <= this_len; ++i) {
4821 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4822 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4823 if (svp && matcher_matches_sv(matcher, *svp)) {
4824 destroy_matcher(matcher);
4828 destroy_matcher(matcher);
4832 else if (!SvOK(d)) {
4833 /* undef ~~ array */
4834 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4837 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4838 for (i = 0; i <= this_len; ++i) {
4839 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4840 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4841 if (!svp || !SvOK(*svp))
4850 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4852 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4853 for (i = 0; i <= this_len; ++i) {
4854 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4861 /* infinite recursion isn't supposed to happen here */
4862 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4863 (void) do_smartmatch(NULL, NULL, 1);
4865 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4874 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4875 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4876 SV *t = d; d = e; e = t;
4877 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4880 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4881 SV *t = d; d = e; e = t;
4882 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4883 goto sm_regex_array;
4886 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4888 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4890 PUSHs(matcher_matches_sv(matcher, d)
4893 destroy_matcher(matcher);
4898 /* See if there is overload magic on left */
4899 else if (object_on_left && SvAMAGIC(d)) {
4901 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4902 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4905 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4913 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4916 else if (!SvOK(d)) {
4917 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4918 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4923 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4924 DEBUG_M(if (SvNIOK(e))
4925 Perl_deb(aTHX_ " applying rule Any-Num\n");
4927 Perl_deb(aTHX_ " applying rule Num-numish\n");
4929 /* numeric comparison */
4932 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4933 (void) Perl_pp_i_eq(aTHX);
4935 (void) Perl_pp_eq(aTHX);
4943 /* As a last resort, use string comparison */
4944 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4947 return Perl_pp_seq(aTHX);
4954 const I32 gimme = GIMME_V;
4956 /* This is essentially an optimization: if the match
4957 fails, we don't want to push a context and then
4958 pop it again right away, so we skip straight
4959 to the op that follows the leavewhen.
4960 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4962 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4963 RETURNOP(cLOGOP->op_other->op_next);
4965 ENTER_with_name("when");
4968 PUSHBLOCK(cx, CXt_WHEN, SP);
4983 cxix = dopoptogiven(cxstack_ix);
4985 /* diag_listed_as: Can't "when" outside a topicalizer */
4986 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
4987 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
4990 assert(CxTYPE(cx) == CXt_WHEN);
4993 SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4994 PL_curpm = newpm; /* pop $1 et al */
4996 LEAVE_with_name("when");
4998 if (cxix < cxstack_ix)
5001 cx = &cxstack[cxix];
5003 if (CxFOREACH(cx)) {
5004 /* clear off anything above the scope we're re-entering */
5005 I32 inner = PL_scopestack_ix;
5008 if (PL_scopestack_ix < inner)
5009 leave_scope(PL_scopestack[PL_scopestack_ix]);
5010 PL_curcop = cx->blk_oldcop;
5013 return cx->blk_loop.my_op->op_nextop;
5017 RETURNOP(cx->blk_givwhen.leave_op);
5030 PERL_UNUSED_VAR(gimme);
5032 cxix = dopoptowhen(cxstack_ix);
5034 DIE(aTHX_ "Can't \"continue\" outside a when block");
5036 if (cxix < cxstack_ix)
5040 assert(CxTYPE(cx) == CXt_WHEN);
5043 PL_curpm = newpm; /* pop $1 et al */
5045 LEAVE_with_name("when");
5046 RETURNOP(cx->blk_givwhen.leave_op->op_next);
5055 cxix = dopoptogiven(cxstack_ix);
5057 DIE(aTHX_ "Can't \"break\" outside a given block");
5059 cx = &cxstack[cxix];
5061 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5063 if (cxix < cxstack_ix)
5066 /* Restore the sp at the time we entered the given block */
5069 return cx->blk_givwhen.leave_op;
5073 S_doparseform(pTHX_ SV *sv)
5076 char *s = SvPV(sv, len);
5078 char *base = NULL; /* start of current field */
5079 I32 skipspaces = 0; /* number of contiguous spaces seen */
5080 bool noblank = FALSE; /* ~ or ~~ seen on this line */
5081 bool repeat = FALSE; /* ~~ seen on this line */
5082 bool postspace = FALSE; /* a text field may need right padding */
5085 U32 *linepc = NULL; /* position of last FF_LINEMARK */
5087 bool ischop; /* it's a ^ rather than a @ */
5088 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5089 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5093 PERL_ARGS_ASSERT_DOPARSEFORM;
5096 Perl_croak(aTHX_ "Null picture in formline");
5098 if (SvTYPE(sv) >= SVt_PVMG) {
5099 /* This might, of course, still return NULL. */
5100 mg = mg_find(sv, PERL_MAGIC_fm);
5102 sv_upgrade(sv, SVt_PVMG);
5106 /* still the same as previously-compiled string? */
5107 SV *old = mg->mg_obj;
5108 if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5109 && len == SvCUR(old)
5110 && strnEQ(SvPVX(old), SvPVX(sv), len)
5112 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5116 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5117 Safefree(mg->mg_ptr);
5123 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5124 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5127 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5128 s = SvPV(sv_copy, len); /* work on the copy, not the original */
5132 /* estimate the buffer size needed */
5133 for (base = s; s <= send; s++) {
5134 if (*s == '\n' || *s == '@' || *s == '^')
5140 Newx(fops, maxops, U32);
5145 *fpc++ = FF_LINEMARK;
5146 noblank = repeat = FALSE;
5164 case ' ': case '\t':
5171 } /* else FALL THROUGH */
5179 *fpc++ = FF_LITERAL;
5187 *fpc++ = (U32)skipspaces;
5191 *fpc++ = FF_NEWLINE;
5195 arg = fpc - linepc + 1;
5202 *fpc++ = FF_LINEMARK;
5203 noblank = repeat = FALSE;
5212 ischop = s[-1] == '^';
5218 arg = (s - base) - 1;
5220 *fpc++ = FF_LITERAL;
5226 if (*s == '*') { /* @* or ^* */
5228 *fpc++ = 2; /* skip the @* or ^* */
5230 *fpc++ = FF_LINESNGL;
5233 *fpc++ = FF_LINEGLOB;
5235 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5236 arg = ischop ? FORM_NUM_BLANK : 0;
5241 const char * const f = ++s;
5244 arg |= FORM_NUM_POINT + (s - f);
5246 *fpc++ = s - base; /* fieldsize for FETCH */
5247 *fpc++ = FF_DECIMAL;
5249 unchopnum |= ! ischop;
5251 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
5252 arg = ischop ? FORM_NUM_BLANK : 0;
5254 s++; /* skip the '0' first */
5258 const char * const f = ++s;
5261 arg |= FORM_NUM_POINT + (s - f);
5263 *fpc++ = s - base; /* fieldsize for FETCH */
5264 *fpc++ = FF_0DECIMAL;
5266 unchopnum |= ! ischop;
5268 else { /* text field */
5270 bool ismore = FALSE;
5273 while (*++s == '>') ;
5274 prespace = FF_SPACE;
5276 else if (*s == '|') {
5277 while (*++s == '|') ;
5278 prespace = FF_HALFSPACE;
5283 while (*++s == '<') ;
5286 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5290 *fpc++ = s - base; /* fieldsize for FETCH */
5292 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5295 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5309 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5312 mg->mg_ptr = (char *) fops;
5313 mg->mg_len = arg * sizeof(U32);
5314 mg->mg_obj = sv_copy;
5315 mg->mg_flags |= MGf_REFCOUNTED;
5317 if (unchopnum && repeat)
5318 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5325 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5327 /* Can value be printed in fldsize chars, using %*.*f ? */
5331 int intsize = fldsize - (value < 0 ? 1 : 0);
5333 if (frcsize & FORM_NUM_POINT)
5335 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5338 while (intsize--) pwr *= 10.0;
5339 while (frcsize--) eps /= 10.0;
5342 if (value + eps >= pwr)
5345 if (value - eps <= -pwr)
5352 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5355 SV * const datasv = FILTER_DATA(idx);
5356 const int filter_has_file = IoLINES(datasv);
5357 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5358 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5363 char *prune_from = NULL;
5364 bool read_from_cache = FALSE;
5368 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5370 assert(maxlen >= 0);
5373 /* I was having segfault trouble under Linux 2.2.5 after a
5374 parse error occured. (Had to hack around it with a test
5375 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5376 not sure where the trouble is yet. XXX */
5379 SV *const cache = datasv;
5382 const char *cache_p = SvPV(cache, cache_len);
5386 /* Running in block mode and we have some cached data already.
5388 if (cache_len >= umaxlen) {
5389 /* In fact, so much data we don't even need to call
5394 const char *const first_nl =
5395 (const char *)memchr(cache_p, '\n', cache_len);
5397 take = first_nl + 1 - cache_p;
5401 sv_catpvn(buf_sv, cache_p, take);
5402 sv_chop(cache, cache_p + take);
5403 /* Definitely not EOF */
5407 sv_catsv(buf_sv, cache);
5409 umaxlen -= cache_len;
5412 read_from_cache = TRUE;
5416 /* Filter API says that the filter appends to the contents of the buffer.
5417 Usually the buffer is "", so the details don't matter. But if it's not,
5418 then clearly what it contains is already filtered by this filter, so we
5419 don't want to pass it in a second time.
5420 I'm going to use a mortal in case the upstream filter croaks. */
5421 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5422 ? sv_newmortal() : buf_sv;
5423 SvUPGRADE(upstream, SVt_PV);
5425 if (filter_has_file) {
5426 status = FILTER_READ(idx+1, upstream, 0);
5429 if (filter_sub && status >= 0) {
5433 ENTER_with_name("call_filter_sub");
5438 DEFSV_set(upstream);
5442 PUSHs(filter_state);
5445 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5454 SV * const errsv = ERRSV;
5455 if (SvTRUE_NN(errsv))
5456 err = newSVsv(errsv);
5462 LEAVE_with_name("call_filter_sub");
5465 if (SvIsCOW(upstream)) sv_force_normal(upstream);
5466 if(!err && SvOK(upstream)) {
5467 got_p = SvPV(upstream, got_len);
5469 if (got_len > umaxlen) {
5470 prune_from = got_p + umaxlen;
5473 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5474 if (first_nl && first_nl + 1 < got_p + got_len) {
5475 /* There's a second line here... */
5476 prune_from = first_nl + 1;
5480 if (!err && prune_from) {
5481 /* Oh. Too long. Stuff some in our cache. */
5482 STRLEN cached_len = got_p + got_len - prune_from;
5483 SV *const cache = datasv;
5486 /* Cache should be empty. */
5487 assert(!SvCUR(cache));
5490 sv_setpvn(cache, prune_from, cached_len);
5491 /* If you ask for block mode, you may well split UTF-8 characters.
5492 "If it breaks, you get to keep both parts"
5493 (Your code is broken if you don't put them back together again
5494 before something notices.) */
5495 if (SvUTF8(upstream)) {
5498 SvCUR_set(upstream, got_len - cached_len);
5500 /* Can't yet be EOF */
5505 /* If they are at EOF but buf_sv has something in it, then they may never
5506 have touched the SV upstream, so it may be undefined. If we naively
5507 concatenate it then we get a warning about use of uninitialised value.
5509 if (!err && upstream != buf_sv &&
5510 (SvOK(upstream) || SvGMAGICAL(upstream))) {
5511 sv_catsv(buf_sv, upstream);
5515 IoLINES(datasv) = 0;
5517 SvREFCNT_dec(filter_state);
5518 IoTOP_GV(datasv) = NULL;
5521 SvREFCNT_dec(filter_sub);
5522 IoBOTTOM_GV(datasv) = NULL;
5524 filter_del(S_run_user_filter);
5530 if (status == 0 && read_from_cache) {
5531 /* If we read some data from the cache (and by getting here it implies
5532 that we emptied the cache) then we aren't yet at EOF, and mustn't
5533 report that to our caller. */
5541 * c-indentation-style: bsd
5543 * indent-tabs-mode: nil
5546 * ex: set ts=8 sts=4 sw=4 et: