3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
19 * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains control-oriented pp ("push/pop") functions that
23 * execute the opcodes that make up a perl program. A typical pp function
24 * expects to find its arguments on the stack, and usually pushes its
25 * results onto the stack, hence the 'pp' terminology. Each OP structure
26 * contains a pointer to the relevant pp_foo() function.
28 * Control-oriented means things like pp_enteriter() and pp_next(), which
29 * alter the flow of control of the program.
34 #define PERL_IN_PP_CTL_C
38 #define WORD_ALIGN sizeof(U32)
41 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
43 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
52 cxix = dopoptosub(cxstack_ix);
56 switch (cxstack[cxix].blk_gimme) {
69 /* XXXX Should store the old value to allow for tie/overload - and
70 restore in regcomp, where marked with XXXX. */
80 register PMOP *pm = (PMOP*)cLOGOP->op_other;
84 /* prevent recompiling under /o and ithreads. */
85 #if defined(USE_ITHREADS)
86 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
87 if (PL_op->op_flags & OPf_STACKED) {
97 #define tryAMAGICregexp(rx) \
100 if (SvROK(rx) && SvAMAGIC(rx)) { \
101 SV *sv = AMG_CALLun(rx, regexp); \
105 if (SvTYPE(sv) != SVt_REGEXP) \
106 Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
113 if (PL_op->op_flags & OPf_STACKED) {
114 /* multiple args; concatentate them */
116 tmpstr = PAD_SV(ARGTARG);
117 sv_setpvs(tmpstr, "");
118 while (++MARK <= SP) {
120 if (PL_amagic_generation) {
123 tryAMAGICregexp(msv);
125 if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
126 (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
128 sv_setsv(tmpstr, sv);
132 sv_catsv(tmpstr, msv);
139 tryAMAGICregexp(tmpstr);
142 #undef tryAMAGICregexp
145 SV * const sv = SvRV(tmpstr);
146 if (SvTYPE(sv) == SVt_REGEXP)
149 else if (SvTYPE(tmpstr) == SVt_REGEXP)
150 re = (REGEXP*) tmpstr;
153 /* The match's LHS's get-magic might need to access this op's reg-
154 exp (as is sometimes the case with $'; see bug 70764). So we
155 must call get-magic now before we replace the regexp. Hopeful-
156 ly this hack can be replaced with the approach described at
157 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
158 /msg122415.html some day. */
159 if(pm->op_type == OP_MATCH) {
161 const bool was_tainted = PL_tainted;
162 if (pm->op_flags & OPf_STACKED)
164 else if (pm->op_private & OPpTARGET_MY)
165 lhs = PAD_SV(pm->op_targ);
168 /* Restore the previous value of PL_tainted (which may have been
169 modified by get-magic), to avoid incorrectly setting the
170 RXf_TAINTED flag further down. */
171 PL_tainted = was_tainted;
174 re = reg_temp_copy(NULL, re);
175 ReREFCNT_dec(PM_GETRE(pm));
180 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
182 assert (re != (REGEXP*) &PL_sv_undef);
184 /* Check against the last compiled regexp. */
185 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
186 memNE(RX_PRECOMP(re), t, len))
188 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
189 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
193 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
195 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
197 } else if (PL_curcop->cop_hints_hash) {
198 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
200 if (ptr && SvIOK(ptr) && SvIV(ptr))
201 eng = INT2PTR(regexp_engine*,SvIV(ptr));
204 if (PL_op->op_flags & OPf_SPECIAL)
205 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
207 if (DO_UTF8(tmpstr)) {
208 assert (SvUTF8(tmpstr));
209 } else if (SvUTF8(tmpstr)) {
210 /* Not doing UTF-8, despite what the SV says. Is this only if
211 we're trapped in use 'bytes'? */
212 /* Make a copy of the octet sequence, but without the flag on,
213 as the compiler now honours the SvUTF8 flag on tmpstr. */
215 const char *const p = SvPV(tmpstr, len);
216 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
220 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
222 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
224 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
225 inside tie/overload accessors. */
231 #ifndef INCOMPLETE_TAINTS
234 RX_EXTFLAGS(re) |= RXf_TAINTED;
236 RX_EXTFLAGS(re) &= ~RXf_TAINTED;
240 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
244 #if !defined(USE_ITHREADS)
245 /* can't change the optree at runtime either */
246 /* PMf_KEEP is handled differently under threads to avoid these problems */
247 if (pm->op_pmflags & PMf_KEEP) {
248 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
249 cLOGOP->op_first->op_next = PL_op->op_next;
259 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
260 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
261 register SV * const dstr = cx->sb_dstr;
262 register char *s = cx->sb_s;
263 register char *m = cx->sb_m;
264 char *orig = cx->sb_orig;
265 register REGEXP * const rx = cx->sb_rx;
267 REGEXP *old = PM_GETRE(pm);
274 PM_SETRE(pm,ReREFCNT_inc(rx));
277 rxres_restore(&cx->sb_rxres, rx);
278 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
280 if (cx->sb_iters++) {
281 const I32 saviters = cx->sb_iters;
282 if (cx->sb_iters > cx->sb_maxiters)
283 DIE(aTHX_ "Substitution loop");
285 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
287 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
288 cx->sb_rxtainted |= 2;
289 sv_catsv_nomg(dstr, POPs);
290 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
294 if (CxONCE(cx) || s < orig ||
295 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
296 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
297 ((cx->sb_rflags & REXEC_COPY_STR)
298 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
299 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
301 SV * const targ = cx->sb_targ;
303 assert(cx->sb_strend >= s);
304 if(cx->sb_strend > s) {
305 if (DO_UTF8(dstr) && !SvUTF8(targ))
306 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
308 sv_catpvn(dstr, s, cx->sb_strend - s);
310 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
312 #ifdef PERL_OLD_COPY_ON_WRITE
314 sv_force_normal_flags(targ, SV_COW_DROP_PV);
320 SvPV_set(targ, SvPVX(dstr));
321 SvCUR_set(targ, SvCUR(dstr));
322 SvLEN_set(targ, SvLEN(dstr));
325 SvPV_set(dstr, NULL);
327 TAINT_IF(cx->sb_rxtainted & 1);
328 if (pm->op_pmflags & PMf_NONDESTRUCT)
331 mPUSHi(saviters - 1);
333 (void)SvPOK_only_UTF8(targ);
334 TAINT_IF(cx->sb_rxtainted);
338 LEAVE_SCOPE(cx->sb_oldsave);
340 RETURNOP(pm->op_next);
342 cx->sb_iters = saviters;
344 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
347 cx->sb_orig = orig = RX_SUBBEG(rx);
349 cx->sb_strend = s + (cx->sb_strend - m);
351 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
353 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
354 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
356 sv_catpvn(dstr, s, m-s);
358 cx->sb_s = RX_OFFS(rx)[0].end + orig;
359 { /* Update the pos() information. */
360 SV * const sv = cx->sb_targ;
362 SvUPGRADE(sv, SVt_PVMG);
363 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
364 #ifdef PERL_OLD_COPY_ON_WRITE
366 sv_force_normal_flags(sv, 0);
368 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
371 mg->mg_len = m - orig;
374 (void)ReREFCNT_inc(rx);
375 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
376 rxres_save(&cx->sb_rxres, rx);
377 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
381 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
386 PERL_ARGS_ASSERT_RXRES_SAVE;
389 if (!p || p[1] < RX_NPARENS(rx)) {
390 #ifdef PERL_OLD_COPY_ON_WRITE
391 i = 7 + RX_NPARENS(rx) * 2;
393 i = 6 + RX_NPARENS(rx) * 2;
402 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
403 RX_MATCH_COPIED_off(rx);
405 #ifdef PERL_OLD_COPY_ON_WRITE
406 *p++ = PTR2UV(RX_SAVED_COPY(rx));
407 RX_SAVED_COPY(rx) = NULL;
410 *p++ = RX_NPARENS(rx);
412 *p++ = PTR2UV(RX_SUBBEG(rx));
413 *p++ = (UV)RX_SUBLEN(rx);
414 for (i = 0; i <= RX_NPARENS(rx); ++i) {
415 *p++ = (UV)RX_OFFS(rx)[i].start;
416 *p++ = (UV)RX_OFFS(rx)[i].end;
421 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
426 PERL_ARGS_ASSERT_RXRES_RESTORE;
429 RX_MATCH_COPY_FREE(rx);
430 RX_MATCH_COPIED_set(rx, *p);
433 #ifdef PERL_OLD_COPY_ON_WRITE
434 if (RX_SAVED_COPY(rx))
435 SvREFCNT_dec (RX_SAVED_COPY(rx));
436 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
440 RX_NPARENS(rx) = *p++;
442 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
443 RX_SUBLEN(rx) = (I32)(*p++);
444 for (i = 0; i <= RX_NPARENS(rx); ++i) {
445 RX_OFFS(rx)[i].start = (I32)(*p++);
446 RX_OFFS(rx)[i].end = (I32)(*p++);
451 S_rxres_free(pTHX_ void **rsp)
453 UV * const p = (UV*)*rsp;
455 PERL_ARGS_ASSERT_RXRES_FREE;
460 void *tmp = INT2PTR(char*,*p);
463 PoisonFree(*p, 1, sizeof(*p));
465 Safefree(INT2PTR(char*,*p));
467 #ifdef PERL_OLD_COPY_ON_WRITE
469 SvREFCNT_dec (INT2PTR(SV*,p[1]));
479 dVAR; dSP; dMARK; dORIGMARK;
480 register SV * const tmpForm = *++MARK;
485 register SV *sv = NULL;
486 const char *item = NULL;
490 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
491 const char *chophere = NULL;
492 char *linemark = NULL;
494 bool gotsome = FALSE;
496 const STRLEN fudge = SvPOK(tmpForm)
497 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
498 bool item_is_utf8 = FALSE;
499 bool targ_is_utf8 = FALSE;
501 OP * parseres = NULL;
504 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
505 if (SvREADONLY(tmpForm)) {
506 SvREADONLY_off(tmpForm);
507 parseres = doparseform(tmpForm);
508 SvREADONLY_on(tmpForm);
511 parseres = doparseform(tmpForm);
515 SvPV_force(PL_formtarget, len);
516 if (DO_UTF8(PL_formtarget))
518 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
520 f = SvPV_const(tmpForm, len);
521 /* need to jump to the next word */
522 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
526 const char *name = "???";
529 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
530 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
531 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
532 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
533 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
535 case FF_CHECKNL: name = "CHECKNL"; break;
536 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
537 case FF_SPACE: name = "SPACE"; break;
538 case FF_HALFSPACE: name = "HALFSPACE"; break;
539 case FF_ITEM: name = "ITEM"; break;
540 case FF_CHOP: name = "CHOP"; break;
541 case FF_LINEGLOB: name = "LINEGLOB"; break;
542 case FF_NEWLINE: name = "NEWLINE"; break;
543 case FF_MORE: name = "MORE"; break;
544 case FF_LINEMARK: name = "LINEMARK"; break;
545 case FF_END: name = "END"; break;
546 case FF_0DECIMAL: name = "0DECIMAL"; break;
547 case FF_LINESNGL: name = "LINESNGL"; break;
550 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
552 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
563 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
564 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
566 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
567 t = SvEND(PL_formtarget);
571 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
572 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
574 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
575 t = SvEND(PL_formtarget);
595 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
602 const char *s = item = SvPV_const(sv, len);
605 itemsize = sv_len_utf8(sv);
606 if (itemsize != (I32)len) {
608 if (itemsize > fieldsize) {
609 itemsize = fieldsize;
610 itembytes = itemsize;
611 sv_pos_u2b(sv, &itembytes, 0);
615 send = chophere = s + itembytes;
625 sv_pos_b2u(sv, &itemsize);
629 item_is_utf8 = FALSE;
630 if (itemsize > fieldsize)
631 itemsize = fieldsize;
632 send = chophere = s + itemsize;
646 const char *s = item = SvPV_const(sv, len);
649 itemsize = sv_len_utf8(sv);
650 if (itemsize != (I32)len) {
652 if (itemsize <= fieldsize) {
653 const char *send = chophere = s + itemsize;
666 itemsize = fieldsize;
667 itembytes = itemsize;
668 sv_pos_u2b(sv, &itembytes, 0);
669 send = chophere = s + itembytes;
670 while (s < send || (s == send && isSPACE(*s))) {
680 if (strchr(PL_chopset, *s))
685 itemsize = chophere - item;
686 sv_pos_b2u(sv, &itemsize);
692 item_is_utf8 = FALSE;
693 if (itemsize <= fieldsize) {
694 const char *const send = chophere = s + itemsize;
707 itemsize = fieldsize;
708 send = chophere = s + itemsize;
709 while (s < send || (s == send && isSPACE(*s))) {
719 if (strchr(PL_chopset, *s))
724 itemsize = chophere - item;
730 arg = fieldsize - itemsize;
739 arg = fieldsize - itemsize;
750 const char *s = item;
754 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
756 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
758 t = SvEND(PL_formtarget);
762 if (UTF8_IS_CONTINUED(*s)) {
763 STRLEN skip = UTF8SKIP(s);
780 if ( !((*t++ = *s++) & ~31) )
786 if (targ_is_utf8 && !item_is_utf8) {
787 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
789 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
790 for (; t < SvEND(PL_formtarget); t++) {
803 const int ch = *t++ = *s++;
806 if ( !((*t++ = *s++) & ~31) )
815 const char *s = chophere;
829 const bool oneline = fpc[-1] == FF_LINESNGL;
830 const char *s = item = SvPV_const(sv, len);
831 item_is_utf8 = DO_UTF8(sv);
834 STRLEN to_copy = itemsize;
835 const char *const send = s + len;
836 const U8 *source = (const U8 *) s;
840 chophere = s + itemsize;
844 to_copy = s - SvPVX_const(sv) - 1;
856 if (targ_is_utf8 && !item_is_utf8) {
857 source = tmp = bytes_to_utf8(source, &to_copy);
858 SvCUR_set(PL_formtarget,
859 t - SvPVX_const(PL_formtarget));
861 if (item_is_utf8 && !targ_is_utf8) {
862 /* Upgrade targ to UTF8, and then we reduce it to
863 a problem we have a simple solution for. */
864 SvCUR_set(PL_formtarget,
865 t - SvPVX_const(PL_formtarget));
867 /* Don't need get magic. */
868 sv_utf8_upgrade_nomg(PL_formtarget);
870 SvCUR_set(PL_formtarget,
871 t - SvPVX_const(PL_formtarget));
874 /* Easy. They agree. */
875 assert (item_is_utf8 == targ_is_utf8);
877 SvGROW(PL_formtarget,
878 SvCUR(PL_formtarget) + to_copy + fudge + 1);
879 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
881 Copy(source, t, to_copy, char);
883 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
885 if (SvGMAGICAL(sv)) {
886 /* Mustn't call sv_pos_b2u() as it does a second
887 mg_get(). Is this a bug? Do we need a _flags()
889 itemsize = utf8_length(source, source + itemsize);
891 sv_pos_b2u(sv, &itemsize);
903 #if defined(USE_LONG_DOUBLE)
906 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
910 "%#0*.*f" : "%0*.*f");
915 #if defined(USE_LONG_DOUBLE)
917 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
920 ((arg & 256) ? "%#*.*f" : "%*.*f");
923 /* If the field is marked with ^ and the value is undefined,
925 if ((arg & 512) && !SvOK(sv)) {
933 /* overflow evidence */
934 if (num_overflow(value, fieldsize, arg)) {
940 /* Formats aren't yet marked for locales, so assume "yes". */
942 STORE_NUMERIC_STANDARD_SET_LOCAL();
943 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
944 RESTORE_NUMERIC_STANDARD();
951 while (t-- > linemark && *t == ' ') ;
959 if (arg) { /* repeat until fields exhausted? */
961 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
962 lines += FmLINES(PL_formtarget);
964 SvUTF8_on(PL_formtarget);
965 FmLINES(PL_formtarget) = lines;
967 RETURNOP(cLISTOP->op_first);
978 const char *s = chophere;
979 const char *send = item + len;
981 while (isSPACE(*s) && (s < send))
986 arg = fieldsize - itemsize;
993 if (strnEQ(s1," ",3)) {
994 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
1005 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1007 SvUTF8_on(PL_formtarget);
1008 FmLINES(PL_formtarget) += lines;
1020 if (PL_stack_base + *PL_markstack_ptr == SP) {
1022 if (GIMME_V == G_SCALAR)
1024 RETURNOP(PL_op->op_next->op_next);
1026 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
1027 pp_pushmark(); /* push dst */
1028 pp_pushmark(); /* push src */
1029 ENTER_with_name("grep"); /* enter outer scope */
1032 if (PL_op->op_private & OPpGREP_LEX)
1033 SAVESPTR(PAD_SVl(PL_op->op_targ));
1036 ENTER_with_name("grep_item"); /* enter inner scope */
1039 src = PL_stack_base[*PL_markstack_ptr];
1041 if (PL_op->op_private & OPpGREP_LEX)
1042 PAD_SVl(PL_op->op_targ) = src;
1047 if (PL_op->op_type == OP_MAPSTART)
1048 pp_pushmark(); /* push top */
1049 return ((LOGOP*)PL_op->op_next)->op_other;
1055 const I32 gimme = GIMME_V;
1056 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1062 /* first, move source pointer to the next item in the source list */
1063 ++PL_markstack_ptr[-1];
1065 /* if there are new items, push them into the destination list */
1066 if (items && gimme != G_VOID) {
1067 /* might need to make room back there first */
1068 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1069 /* XXX this implementation is very pessimal because the stack
1070 * is repeatedly extended for every set of items. Is possible
1071 * to do this without any stack extension or copying at all
1072 * by maintaining a separate list over which the map iterates
1073 * (like foreach does). --gsar */
1075 /* everything in the stack after the destination list moves
1076 * towards the end the stack by the amount of room needed */
1077 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1079 /* items to shift up (accounting for the moved source pointer) */
1080 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1082 /* This optimization is by Ben Tilly and it does
1083 * things differently from what Sarathy (gsar)
1084 * is describing. The downside of this optimization is
1085 * that leaves "holes" (uninitialized and hopefully unused areas)
1086 * to the Perl stack, but on the other hand this
1087 * shouldn't be a problem. If Sarathy's idea gets
1088 * implemented, this optimization should become
1089 * irrelevant. --jhi */
1091 shift = count; /* Avoid shifting too often --Ben Tilly */
1095 dst = (SP += shift);
1096 PL_markstack_ptr[-1] += shift;
1097 *PL_markstack_ptr += shift;
1101 /* copy the new items down to the destination list */
1102 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1103 if (gimme == G_ARRAY) {
1105 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1108 /* scalar context: we don't care about which values map returns
1109 * (we use undef here). And so we certainly don't want to do mortal
1110 * copies of meaningless values. */
1111 while (items-- > 0) {
1113 *dst-- = &PL_sv_undef;
1117 LEAVE_with_name("grep_item"); /* exit inner scope */
1120 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1122 (void)POPMARK; /* pop top */
1123 LEAVE_with_name("grep"); /* exit outer scope */
1124 (void)POPMARK; /* pop src */
1125 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1126 (void)POPMARK; /* pop dst */
1127 SP = PL_stack_base + POPMARK; /* pop original mark */
1128 if (gimme == G_SCALAR) {
1129 if (PL_op->op_private & OPpGREP_LEX) {
1130 SV* sv = sv_newmortal();
1131 sv_setiv(sv, items);
1139 else if (gimme == G_ARRAY)
1146 ENTER_with_name("grep_item"); /* enter inner scope */
1149 /* set $_ to the new source item */
1150 src = PL_stack_base[PL_markstack_ptr[-1]];
1152 if (PL_op->op_private & OPpGREP_LEX)
1153 PAD_SVl(PL_op->op_targ) = src;
1157 RETURNOP(cLOGOP->op_other);
1166 if (GIMME == G_ARRAY)
1168 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1169 return cLOGOP->op_other;
1179 if (GIMME == G_ARRAY) {
1180 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1184 SV * const targ = PAD_SV(PL_op->op_targ);
1187 if (PL_op->op_private & OPpFLIP_LINENUM) {
1188 if (GvIO(PL_last_in_gv)) {
1189 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1192 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1194 flip = SvIV(sv) == SvIV(GvSV(gv));
1200 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1201 if (PL_op->op_flags & OPf_SPECIAL) {
1209 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1212 sv_setpvs(TARG, "");
1218 /* This code tries to decide if "$left .. $right" should use the
1219 magical string increment, or if the range is numeric (we make
1220 an exception for .."0" [#18165]). AMS 20021031. */
1222 #define RANGE_IS_NUMERIC(left,right) ( \
1223 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1224 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1225 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1226 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1227 && (!SvOK(right) || looks_like_number(right))))
1233 if (GIMME == G_ARRAY) {
1239 if (RANGE_IS_NUMERIC(left,right)) {
1242 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1243 (SvOK(right) && SvNV(right) > IV_MAX))
1244 DIE(aTHX_ "Range iterator outside integer range");
1255 SV * const sv = sv_2mortal(newSViv(i++));
1260 SV * const final = sv_mortalcopy(right);
1262 const char * const tmps = SvPV_const(final, len);
1264 SV *sv = sv_mortalcopy(left);
1265 SvPV_force_nolen(sv);
1266 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1268 if (strEQ(SvPVX_const(sv),tmps))
1270 sv = sv_2mortal(newSVsv(sv));
1277 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1281 if (PL_op->op_private & OPpFLIP_LINENUM) {
1282 if (GvIO(PL_last_in_gv)) {
1283 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1286 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1287 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1295 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1296 sv_catpvs(targ, "E0");
1306 static const char * const context_name[] = {
1308 NULL, /* CXt_WHEN never actually needs "block" */
1309 NULL, /* CXt_BLOCK never actually needs "block" */
1310 NULL, /* CXt_GIVEN never actually needs "block" */
1311 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1312 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1313 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1314 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1322 S_dopoptolabel(pTHX_ const char *label)
1327 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1329 for (i = cxstack_ix; i >= 0; i--) {
1330 register const PERL_CONTEXT * const cx = &cxstack[i];
1331 switch (CxTYPE(cx)) {
1337 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1338 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1339 if (CxTYPE(cx) == CXt_NULL)
1342 case CXt_LOOP_LAZYIV:
1343 case CXt_LOOP_LAZYSV:
1345 case CXt_LOOP_PLAIN:
1347 const char *cx_label = CxLABEL(cx);
1348 if (!cx_label || strNE(label, cx_label) ) {
1349 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1350 (long)i, cx_label));
1353 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1364 Perl_dowantarray(pTHX)
1367 const I32 gimme = block_gimme();
1368 return (gimme == G_VOID) ? G_SCALAR : gimme;
1372 Perl_block_gimme(pTHX)
1375 const I32 cxix = dopoptosub(cxstack_ix);
1379 switch (cxstack[cxix].blk_gimme) {
1387 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1394 Perl_is_lvalue_sub(pTHX)
1397 const I32 cxix = dopoptosub(cxstack_ix);
1398 assert(cxix >= 0); /* We should only be called from inside subs */
1400 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1401 return CxLVAL(cxstack + cxix);
1407 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1412 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1414 for (i = startingblock; i >= 0; i--) {
1415 register const PERL_CONTEXT * const cx = &cxstk[i];
1416 switch (CxTYPE(cx)) {
1422 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1430 S_dopoptoeval(pTHX_ I32 startingblock)
1434 for (i = startingblock; i >= 0; i--) {
1435 register const PERL_CONTEXT *cx = &cxstack[i];
1436 switch (CxTYPE(cx)) {
1440 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1448 S_dopoptoloop(pTHX_ I32 startingblock)
1452 for (i = startingblock; i >= 0; i--) {
1453 register const PERL_CONTEXT * const cx = &cxstack[i];
1454 switch (CxTYPE(cx)) {
1460 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1461 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1462 if ((CxTYPE(cx)) == CXt_NULL)
1465 case CXt_LOOP_LAZYIV:
1466 case CXt_LOOP_LAZYSV:
1468 case CXt_LOOP_PLAIN:
1469 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1477 S_dopoptogiven(pTHX_ I32 startingblock)
1481 for (i = startingblock; i >= 0; i--) {
1482 register const PERL_CONTEXT *cx = &cxstack[i];
1483 switch (CxTYPE(cx)) {
1487 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1489 case CXt_LOOP_PLAIN:
1490 assert(!CxFOREACHDEF(cx));
1492 case CXt_LOOP_LAZYIV:
1493 case CXt_LOOP_LAZYSV:
1495 if (CxFOREACHDEF(cx)) {
1496 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1505 S_dopoptowhen(pTHX_ I32 startingblock)
1509 for (i = startingblock; i >= 0; i--) {
1510 register const PERL_CONTEXT *cx = &cxstack[i];
1511 switch (CxTYPE(cx)) {
1515 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1523 Perl_dounwind(pTHX_ I32 cxix)
1528 while (cxstack_ix > cxix) {
1530 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1531 DEBUG_CX("UNWIND"); \
1532 /* Note: we don't need to restore the base context info till the end. */
1533 switch (CxTYPE(cx)) {
1536 continue; /* not break */
1544 case CXt_LOOP_LAZYIV:
1545 case CXt_LOOP_LAZYSV:
1547 case CXt_LOOP_PLAIN:
1558 PERL_UNUSED_VAR(optype);
1562 Perl_qerror(pTHX_ SV *err)
1566 PERL_ARGS_ASSERT_QERROR;
1569 sv_catsv(ERRSV, err);
1571 sv_catsv(PL_errors, err);
1573 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1575 ++PL_parser->error_count;
1579 Perl_die_unwind(pTHX_ SV *msv)
1582 SV *exceptsv = sv_mortalcopy(msv);
1583 U8 in_eval = PL_in_eval;
1584 PERL_ARGS_ASSERT_DIE_UNWIND;
1590 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1591 && PL_curstackinfo->si_prev)
1600 register PERL_CONTEXT *cx;
1603 if (cxix < cxstack_ix)
1606 POPBLOCK(cx,PL_curpm);
1607 if (CxTYPE(cx) != CXt_EVAL) {
1609 const char* message = SvPVx_const(exceptsv, msglen);
1610 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1611 PerlIO_write(Perl_error_log, message, msglen);
1615 namesv = cx->blk_eval.old_namesv;
1617 if (gimme == G_SCALAR)
1618 *++newsp = &PL_sv_undef;
1619 PL_stack_sp = newsp;
1623 /* LEAVE could clobber PL_curcop (see save_re_context())
1624 * XXX it might be better to find a way to avoid messing with
1625 * PL_curcop in save_re_context() instead, but this is a more
1626 * minimal fix --GSAR */
1627 PL_curcop = cx->blk_oldcop;
1629 if (optype == OP_REQUIRE) {
1630 const char* const msg = SvPVx_nolen_const(exceptsv);
1631 (void)hv_store(GvHVn(PL_incgv),
1632 SvPVX_const(namesv), SvCUR(namesv),
1634 /* note that unlike pp_entereval, pp_require isn't
1635 * supposed to trap errors. So now that we've popped the
1636 * EVAL that pp_require pushed, and processed the error
1637 * message, rethrow the error */
1638 DIE(aTHX_ "%sCompilation failed in require",
1639 *msg ? msg : "Unknown error\n");
1641 if (in_eval & EVAL_KEEPERR) {
1642 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1643 SvPV_nolen_const(exceptsv));
1646 sv_setsv(ERRSV, exceptsv);
1648 assert(CxTYPE(cx) == CXt_EVAL);
1649 PL_restartjmpenv = cx->blk_eval.cur_top_env;
1650 PL_restartop = cx->blk_eval.retop;
1656 write_to_stderr(exceptsv);
1663 dVAR; dSP; dPOPTOPssrl;
1664 if (SvTRUE(left) != SvTRUE(right))
1674 register I32 cxix = dopoptosub(cxstack_ix);
1675 register const PERL_CONTEXT *cx;
1676 register const PERL_CONTEXT *ccstack = cxstack;
1677 const PERL_SI *top_si = PL_curstackinfo;
1679 const char *stashname;
1686 /* we may be in a higher stacklevel, so dig down deeper */
1687 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1688 top_si = top_si->si_prev;
1689 ccstack = top_si->si_cxstack;
1690 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1693 if (GIMME != G_ARRAY) {
1699 /* caller() should not report the automatic calls to &DB::sub */
1700 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1701 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1705 cxix = dopoptosub_at(ccstack, cxix - 1);
1708 cx = &ccstack[cxix];
1709 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1710 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1711 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1712 field below is defined for any cx. */
1713 /* caller() should not report the automatic calls to &DB::sub */
1714 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1715 cx = &ccstack[dbcxix];
1718 stashname = CopSTASHPV(cx->blk_oldcop);
1719 if (GIMME != G_ARRAY) {
1722 PUSHs(&PL_sv_undef);
1725 sv_setpv(TARG, stashname);
1734 PUSHs(&PL_sv_undef);
1736 mPUSHs(newSVpv(stashname, 0));
1737 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1738 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1741 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1742 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1743 /* So is ccstack[dbcxix]. */
1745 SV * const sv = newSV(0);
1746 gv_efullname3(sv, cvgv, NULL);
1748 PUSHs(boolSV(CxHASARGS(cx)));
1751 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1752 PUSHs(boolSV(CxHASARGS(cx)));
1756 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1759 gimme = (I32)cx->blk_gimme;
1760 if (gimme == G_VOID)
1761 PUSHs(&PL_sv_undef);
1763 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1764 if (CxTYPE(cx) == CXt_EVAL) {
1766 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1767 PUSHs(cx->blk_eval.cur_text);
1771 else if (cx->blk_eval.old_namesv) {
1772 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1775 /* eval BLOCK (try blocks have old_namesv == 0) */
1777 PUSHs(&PL_sv_undef);
1778 PUSHs(&PL_sv_undef);
1782 PUSHs(&PL_sv_undef);
1783 PUSHs(&PL_sv_undef);
1785 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1786 && CopSTASH_eq(PL_curcop, PL_debstash))
1788 AV * const ary = cx->blk_sub.argarray;
1789 const int off = AvARRAY(ary) - AvALLOC(ary);
1792 PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
1794 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1797 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1798 av_extend(PL_dbargs, AvFILLp(ary) + off);
1799 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1800 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1802 /* XXX only hints propagated via op_private are currently
1803 * visible (others are not easily accessible, since they
1804 * use the global PL_hints) */
1805 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1808 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1810 if (old_warnings == pWARN_NONE ||
1811 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1812 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1813 else if (old_warnings == pWARN_ALL ||
1814 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1815 /* Get the bit mask for $warnings::Bits{all}, because
1816 * it could have been extended by warnings::register */
1818 HV * const bits = get_hv("warnings::Bits", 0);
1819 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1820 mask = newSVsv(*bits_all);
1823 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1827 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1831 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1832 sv_2mortal(newRV_noinc(
1833 MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1834 cx->blk_oldcop->cop_hints_hash))))
1843 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1844 sv_reset(tmps, CopSTASH(PL_curcop));
1849 /* like pp_nextstate, but used instead when the debugger is active */
1854 PL_curcop = (COP*)PL_op;
1855 TAINT_NOT; /* Each statement is presumed innocent */
1856 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1861 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1862 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1865 register PERL_CONTEXT *cx;
1866 const I32 gimme = G_ARRAY;
1868 GV * const gv = PL_DBgv;
1869 register CV * const cv = GvCV(gv);
1872 DIE(aTHX_ "No DB::DB routine defined");
1874 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1875 /* don't do recursive DB::DB call */
1890 (void)(*CvXSUB(cv))(aTHX_ cv);
1897 PUSHBLOCK(cx, CXt_SUB, SP);
1899 cx->blk_sub.retop = PL_op->op_next;
1902 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1903 RETURNOP(CvSTART(cv));
1913 register PERL_CONTEXT *cx;
1914 const I32 gimme = GIMME_V;
1916 U8 cxtype = CXt_LOOP_FOR;
1921 ENTER_with_name("loop1");
1924 if (PL_op->op_targ) {
1925 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1926 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1927 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1928 SVs_PADSTALE, SVs_PADSTALE);
1930 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1931 #ifndef USE_ITHREADS
1932 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1938 GV * const gv = MUTABLE_GV(POPs);
1939 svp = &GvSV(gv); /* symbol table variable */
1940 SAVEGENERICSV(*svp);
1943 iterdata = (PAD*)gv;
1947 if (PL_op->op_private & OPpITER_DEF)
1948 cxtype |= CXp_FOR_DEF;
1950 ENTER_with_name("loop2");
1952 PUSHBLOCK(cx, cxtype, SP);
1954 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1956 PUSHLOOP_FOR(cx, svp, MARK, 0);
1958 if (PL_op->op_flags & OPf_STACKED) {
1959 SV *maybe_ary = POPs;
1960 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1962 SV * const right = maybe_ary;
1965 if (RANGE_IS_NUMERIC(sv,right)) {
1966 cx->cx_type &= ~CXTYPEMASK;
1967 cx->cx_type |= CXt_LOOP_LAZYIV;
1968 /* Make sure that no-one re-orders cop.h and breaks our
1970 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1971 #ifdef NV_PRESERVES_UV
1972 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1973 (SvNV(sv) > (NV)IV_MAX)))
1975 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1976 (SvNV(right) < (NV)IV_MIN))))
1978 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1981 ((SvUV(sv) > (UV)IV_MAX) ||
1982 (SvNV(sv) > (NV)UV_MAX)))))
1984 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1986 ((SvNV(right) > 0) &&
1987 ((SvUV(right) > (UV)IV_MAX) ||
1988 (SvNV(right) > (NV)UV_MAX))))))
1990 DIE(aTHX_ "Range iterator outside integer range");
1991 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1992 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1994 /* for correct -Dstv display */
1995 cx->blk_oldsp = sp - PL_stack_base;
1999 cx->cx_type &= ~CXTYPEMASK;
2000 cx->cx_type |= CXt_LOOP_LAZYSV;
2001 /* Make sure that no-one re-orders cop.h and breaks our
2003 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2004 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2005 cx->blk_loop.state_u.lazysv.end = right;
2006 SvREFCNT_inc(right);
2007 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2008 /* This will do the upgrade to SVt_PV, and warn if the value
2009 is uninitialised. */
2010 (void) SvPV_nolen_const(right);
2011 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2012 to replace !SvOK() with a pointer to "". */
2014 SvREFCNT_dec(right);
2015 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2019 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2020 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2021 SvREFCNT_inc(maybe_ary);
2022 cx->blk_loop.state_u.ary.ix =
2023 (PL_op->op_private & OPpITER_REVERSED) ?
2024 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2028 else { /* iterating over items on the stack */
2029 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2030 if (PL_op->op_private & OPpITER_REVERSED) {
2031 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2034 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2044 register PERL_CONTEXT *cx;
2045 const I32 gimme = GIMME_V;
2047 ENTER_with_name("loop1");
2049 ENTER_with_name("loop2");
2051 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2052 PUSHLOOP_PLAIN(cx, SP);
2060 register PERL_CONTEXT *cx;
2067 assert(CxTYPE_is_LOOP(cx));
2069 newsp = PL_stack_base + cx->blk_loop.resetsp;
2072 if (gimme == G_VOID)
2074 else if (gimme == G_SCALAR) {
2076 *++newsp = sv_mortalcopy(*SP);
2078 *++newsp = &PL_sv_undef;
2082 *++newsp = sv_mortalcopy(*++mark);
2083 TAINT_NOT; /* Each item is independent */
2089 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2090 PL_curpm = newpm; /* ... and pop $1 et al */
2092 LEAVE_with_name("loop2");
2093 LEAVE_with_name("loop1");
2101 register PERL_CONTEXT *cx;
2102 bool popsub2 = FALSE;
2103 bool clear_errsv = FALSE;
2112 const I32 cxix = dopoptosub(cxstack_ix);
2115 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2116 * sort block, which is a CXt_NULL
2119 PL_stack_base[1] = *PL_stack_sp;
2120 PL_stack_sp = PL_stack_base + 1;
2124 DIE(aTHX_ "Can't return outside a subroutine");
2126 if (cxix < cxstack_ix)
2129 if (CxMULTICALL(&cxstack[cxix])) {
2130 gimme = cxstack[cxix].blk_gimme;
2131 if (gimme == G_VOID)
2132 PL_stack_sp = PL_stack_base;
2133 else if (gimme == G_SCALAR) {
2134 PL_stack_base[1] = *PL_stack_sp;
2135 PL_stack_sp = PL_stack_base + 1;
2141 switch (CxTYPE(cx)) {
2144 retop = cx->blk_sub.retop;
2145 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2148 if (!(PL_in_eval & EVAL_KEEPERR))
2151 namesv = cx->blk_eval.old_namesv;
2152 retop = cx->blk_eval.retop;
2156 if (optype == OP_REQUIRE &&
2157 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2159 /* Unassume the success we assumed earlier. */
2160 (void)hv_delete(GvHVn(PL_incgv),
2161 SvPVX_const(namesv), SvCUR(namesv),
2163 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2168 retop = cx->blk_sub.retop;
2171 DIE(aTHX_ "panic: return");
2175 if (gimme == G_SCALAR) {
2178 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2180 *++newsp = SvREFCNT_inc(*SP);
2185 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2187 *++newsp = sv_mortalcopy(sv);
2192 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2195 *++newsp = sv_mortalcopy(*SP);
2198 *++newsp = &PL_sv_undef;
2200 else if (gimme == G_ARRAY) {
2201 while (++MARK <= SP) {
2202 *++newsp = (popsub2 && SvTEMP(*MARK))
2203 ? *MARK : sv_mortalcopy(*MARK);
2204 TAINT_NOT; /* Each item is independent */
2207 PL_stack_sp = newsp;
2210 /* Stack values are safe: */
2213 POPSUB(cx,sv); /* release CV and @_ ... */
2217 PL_curpm = newpm; /* ... and pop $1 et al */
2230 register PERL_CONTEXT *cx;
2241 if (PL_op->op_flags & OPf_SPECIAL) {
2242 cxix = dopoptoloop(cxstack_ix);
2244 DIE(aTHX_ "Can't \"last\" outside a loop block");
2247 cxix = dopoptolabel(cPVOP->op_pv);
2249 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2251 if (cxix < cxstack_ix)
2255 cxstack_ix++; /* temporarily protect top context */
2257 switch (CxTYPE(cx)) {
2258 case CXt_LOOP_LAZYIV:
2259 case CXt_LOOP_LAZYSV:
2261 case CXt_LOOP_PLAIN:
2263 newsp = PL_stack_base + cx->blk_loop.resetsp;
2264 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2268 nextop = cx->blk_sub.retop;
2272 nextop = cx->blk_eval.retop;
2276 nextop = cx->blk_sub.retop;
2279 DIE(aTHX_ "panic: last");
2283 if (gimme == G_SCALAR) {
2285 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2286 ? *SP : sv_mortalcopy(*SP);
2288 *++newsp = &PL_sv_undef;
2290 else if (gimme == G_ARRAY) {
2291 while (++MARK <= SP) {
2292 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2293 ? *MARK : sv_mortalcopy(*MARK);
2294 TAINT_NOT; /* Each item is independent */
2302 /* Stack values are safe: */
2304 case CXt_LOOP_LAZYIV:
2305 case CXt_LOOP_PLAIN:
2306 case CXt_LOOP_LAZYSV:
2308 POPLOOP(cx); /* release loop vars ... */
2312 POPSUB(cx,sv); /* release CV and @_ ... */
2315 PL_curpm = newpm; /* ... and pop $1 et al */
2318 PERL_UNUSED_VAR(optype);
2319 PERL_UNUSED_VAR(gimme);
2327 register PERL_CONTEXT *cx;
2330 if (PL_op->op_flags & OPf_SPECIAL) {
2331 cxix = dopoptoloop(cxstack_ix);
2333 DIE(aTHX_ "Can't \"next\" outside a loop block");
2336 cxix = dopoptolabel(cPVOP->op_pv);
2338 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2340 if (cxix < cxstack_ix)
2343 /* clear off anything above the scope we're re-entering, but
2344 * save the rest until after a possible continue block */
2345 inner = PL_scopestack_ix;
2347 if (PL_scopestack_ix < inner)
2348 leave_scope(PL_scopestack[PL_scopestack_ix]);
2349 PL_curcop = cx->blk_oldcop;
2350 return CX_LOOP_NEXTOP_GET(cx);
2357 register PERL_CONTEXT *cx;
2361 if (PL_op->op_flags & OPf_SPECIAL) {
2362 cxix = dopoptoloop(cxstack_ix);
2364 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2367 cxix = dopoptolabel(cPVOP->op_pv);
2369 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2371 if (cxix < cxstack_ix)
2374 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2375 if (redo_op->op_type == OP_ENTER) {
2376 /* pop one less context to avoid $x being freed in while (my $x..) */
2378 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2379 redo_op = redo_op->op_next;
2383 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2384 LEAVE_SCOPE(oldsave);
2386 PL_curcop = cx->blk_oldcop;
2391 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2395 static const char too_deep[] = "Target of goto is too deeply nested";
2397 PERL_ARGS_ASSERT_DOFINDLABEL;
2400 Perl_croak(aTHX_ too_deep);
2401 if (o->op_type == OP_LEAVE ||
2402 o->op_type == OP_SCOPE ||
2403 o->op_type == OP_LEAVELOOP ||
2404 o->op_type == OP_LEAVESUB ||
2405 o->op_type == OP_LEAVETRY)
2407 *ops++ = cUNOPo->op_first;
2409 Perl_croak(aTHX_ too_deep);
2412 if (o->op_flags & OPf_KIDS) {
2414 /* First try all the kids at this level, since that's likeliest. */
2415 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2416 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2417 const char *kid_label = CopLABEL(kCOP);
2418 if (kid_label && strEQ(kid_label, label))
2422 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2423 if (kid == PL_lastgotoprobe)
2425 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2428 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2429 ops[-1]->op_type == OP_DBSTATE)
2434 if ((o = dofindlabel(kid, label, ops, oplimit)))
2447 register PERL_CONTEXT *cx;
2448 #define GOTO_DEPTH 64
2449 OP *enterops[GOTO_DEPTH];
2450 const char *label = NULL;
2451 const bool do_dump = (PL_op->op_type == OP_DUMP);
2452 static const char must_have_label[] = "goto must have label";
2454 if (PL_op->op_flags & OPf_STACKED) {
2455 SV * const sv = POPs;
2457 /* This egregious kludge implements goto &subroutine */
2458 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2460 register PERL_CONTEXT *cx;
2461 CV *cv = MUTABLE_CV(SvRV(sv));
2468 if (!CvROOT(cv) && !CvXSUB(cv)) {
2469 const GV * const gv = CvGV(cv);
2473 /* autoloaded stub? */
2474 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2476 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2477 GvNAMELEN(gv), FALSE);
2478 if (autogv && (cv = GvCV(autogv)))
2480 tmpstr = sv_newmortal();
2481 gv_efullname3(tmpstr, gv, NULL);
2482 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2484 DIE(aTHX_ "Goto undefined subroutine");
2487 /* First do some returnish stuff. */
2488 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2490 cxix = dopoptosub(cxstack_ix);
2492 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2493 if (cxix < cxstack_ix)
2497 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2498 if (CxTYPE(cx) == CXt_EVAL) {
2500 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2502 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2504 else if (CxMULTICALL(cx))
2505 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2506 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2507 /* put @_ back onto stack */
2508 AV* av = cx->blk_sub.argarray;
2510 items = AvFILLp(av) + 1;
2511 EXTEND(SP, items+1); /* @_ could have been extended. */
2512 Copy(AvARRAY(av), SP + 1, items, SV*);
2513 SvREFCNT_dec(GvAV(PL_defgv));
2514 GvAV(PL_defgv) = cx->blk_sub.savearray;
2516 /* abandon @_ if it got reified */
2521 av_extend(av, items-1);
2523 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2526 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2527 AV* const av = GvAV(PL_defgv);
2528 items = AvFILLp(av) + 1;
2529 EXTEND(SP, items+1); /* @_ could have been extended. */
2530 Copy(AvARRAY(av), SP + 1, items, SV*);
2534 if (CxTYPE(cx) == CXt_SUB &&
2535 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2536 SvREFCNT_dec(cx->blk_sub.cv);
2537 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2538 LEAVE_SCOPE(oldsave);
2540 /* Now do some callish stuff. */
2542 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2544 OP* const retop = cx->blk_sub.retop;
2549 for (index=0; index<items; index++)
2550 sv_2mortal(SP[-index]);
2553 /* XS subs don't have a CxSUB, so pop it */
2554 POPBLOCK(cx, PL_curpm);
2555 /* Push a mark for the start of arglist */
2558 (void)(*CvXSUB(cv))(aTHX_ cv);
2563 AV* const padlist = CvPADLIST(cv);
2564 if (CxTYPE(cx) == CXt_EVAL) {
2565 PL_in_eval = CxOLD_IN_EVAL(cx);
2566 PL_eval_root = cx->blk_eval.old_eval_root;
2567 cx->cx_type = CXt_SUB;
2569 cx->blk_sub.cv = cv;
2570 cx->blk_sub.olddepth = CvDEPTH(cv);
2573 if (CvDEPTH(cv) < 2)
2574 SvREFCNT_inc_simple_void_NN(cv);
2576 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2577 sub_crush_depth(cv);
2578 pad_push(padlist, CvDEPTH(cv));
2581 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2584 AV *const av = MUTABLE_AV(PAD_SVl(0));
2586 cx->blk_sub.savearray = GvAV(PL_defgv);
2587 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2588 CX_CURPAD_SAVE(cx->blk_sub);
2589 cx->blk_sub.argarray = av;
2591 if (items >= AvMAX(av) + 1) {
2592 SV **ary = AvALLOC(av);
2593 if (AvARRAY(av) != ary) {
2594 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2597 if (items >= AvMAX(av) + 1) {
2598 AvMAX(av) = items - 1;
2599 Renew(ary,items+1,SV*);
2605 Copy(mark,AvARRAY(av),items,SV*);
2606 AvFILLp(av) = items - 1;
2607 assert(!AvREAL(av));
2609 /* transfer 'ownership' of refcnts to new @_ */
2619 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2620 Perl_get_db_sub(aTHX_ NULL, cv);
2622 CV * const gotocv = get_cvs("DB::goto", 0);
2624 PUSHMARK( PL_stack_sp );
2625 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2630 RETURNOP(CvSTART(cv));
2634 label = SvPV_nolen_const(sv);
2635 if (!(do_dump || *label))
2636 DIE(aTHX_ must_have_label);
2639 else if (PL_op->op_flags & OPf_SPECIAL) {
2641 DIE(aTHX_ must_have_label);
2644 label = cPVOP->op_pv;
2648 if (label && *label) {
2649 OP *gotoprobe = NULL;
2650 bool leaving_eval = FALSE;
2651 bool in_block = FALSE;
2652 PERL_CONTEXT *last_eval_cx = NULL;
2656 PL_lastgotoprobe = NULL;
2658 for (ix = cxstack_ix; ix >= 0; ix--) {
2660 switch (CxTYPE(cx)) {
2662 leaving_eval = TRUE;
2663 if (!CxTRYBLOCK(cx)) {
2664 gotoprobe = (last_eval_cx ?
2665 last_eval_cx->blk_eval.old_eval_root :
2670 /* else fall through */
2671 case CXt_LOOP_LAZYIV:
2672 case CXt_LOOP_LAZYSV:
2674 case CXt_LOOP_PLAIN:
2677 gotoprobe = cx->blk_oldcop->op_sibling;
2683 gotoprobe = cx->blk_oldcop->op_sibling;
2686 gotoprobe = PL_main_root;
2689 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2690 gotoprobe = CvROOT(cx->blk_sub.cv);
2696 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2699 DIE(aTHX_ "panic: goto");
2700 gotoprobe = PL_main_root;
2704 retop = dofindlabel(gotoprobe, label,
2705 enterops, enterops + GOTO_DEPTH);
2709 PL_lastgotoprobe = gotoprobe;
2712 DIE(aTHX_ "Can't find label %s", label);
2714 /* if we're leaving an eval, check before we pop any frames
2715 that we're not going to punt, otherwise the error
2718 if (leaving_eval && *enterops && enterops[1]) {
2720 for (i = 1; enterops[i]; i++)
2721 if (enterops[i]->op_type == OP_ENTERITER)
2722 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2725 if (*enterops && enterops[1]) {
2726 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2728 deprecate("\"goto\" to jump into a construct");
2731 /* pop unwanted frames */
2733 if (ix < cxstack_ix) {
2740 oldsave = PL_scopestack[PL_scopestack_ix];
2741 LEAVE_SCOPE(oldsave);
2744 /* push wanted frames */
2746 if (*enterops && enterops[1]) {
2747 OP * const oldop = PL_op;
2748 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2749 for (; enterops[ix]; ix++) {
2750 PL_op = enterops[ix];
2751 /* Eventually we may want to stack the needed arguments
2752 * for each op. For now, we punt on the hard ones. */
2753 if (PL_op->op_type == OP_ENTERITER)
2754 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2755 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2763 if (!retop) retop = PL_main_start;
2765 PL_restartop = retop;
2766 PL_do_undump = TRUE;
2770 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2771 PL_do_undump = FALSE;
2788 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2790 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2793 PL_exit_flags |= PERL_EXIT_EXPECTED;
2795 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2796 if (anum || !(PL_minus_c && PL_madskills))
2801 PUSHs(&PL_sv_undef);
2808 S_save_lines(pTHX_ AV *array, SV *sv)
2810 const char *s = SvPVX_const(sv);
2811 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2814 PERL_ARGS_ASSERT_SAVE_LINES;
2816 while (s && s < send) {
2818 SV * const tmpstr = newSV_type(SVt_PVMG);
2820 t = (const char *)memchr(s, '\n', send - s);
2826 sv_setpvn(tmpstr, s, t - s);
2827 av_store(array, line++, tmpstr);
2835 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
2837 0 is used as continue inside eval,
2839 3 is used for a die caught by an inner eval - continue inner loop
2841 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
2842 establish a local jmpenv to handle exception traps.
2847 S_docatch(pTHX_ OP *o)
2851 OP * const oldop = PL_op;
2855 assert(CATCH_GET == TRUE);
2862 assert(cxstack_ix >= 0);
2863 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2864 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2869 /* die caught by an inner eval - continue inner loop */
2870 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
2871 PL_restartjmpenv = NULL;
2872 PL_op = PL_restartop;
2888 /* James Bond: Do you expect me to talk?
2889 Auric Goldfinger: No, Mr. Bond. I expect you to die.
2891 This code is an ugly hack, doesn't work with lexicals in subroutines that are
2892 called more than once, and is only used by regcomp.c, for (?{}) blocks.
2894 Currently it is not used outside the core code. Best if it stays that way.
2897 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2898 /* sv Text to convert to OP tree. */
2899 /* startop op_free() this to undo. */
2900 /* code Short string id of the caller. */
2902 dVAR; dSP; /* Make POPBLOCK work. */
2908 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2909 char *tmpbuf = tbuf;
2912 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2915 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2917 ENTER_with_name("eval");
2918 lex_start(sv, NULL, FALSE);
2920 /* switch to eval mode */
2922 if (IN_PERL_COMPILETIME) {
2923 SAVECOPSTASH_FREE(&PL_compiling);
2924 CopSTASH_set(&PL_compiling, PL_curstash);
2926 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2927 SV * const sv = sv_newmortal();
2928 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2929 code, (unsigned long)++PL_evalseq,
2930 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2935 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2936 (unsigned long)++PL_evalseq);
2937 SAVECOPFILE_FREE(&PL_compiling);
2938 CopFILE_set(&PL_compiling, tmpbuf+2);
2939 SAVECOPLINE(&PL_compiling);
2940 CopLINE_set(&PL_compiling, 1);
2941 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2942 deleting the eval's FILEGV from the stash before gv_check() runs
2943 (i.e. before run-time proper). To work around the coredump that
2944 ensues, we always turn GvMULTI_on for any globals that were
2945 introduced within evals. See force_ident(). GSAR 96-10-12 */
2946 safestr = savepvn(tmpbuf, len);
2947 SAVEDELETE(PL_defstash, safestr, len);
2949 #ifdef OP_IN_REGISTER
2955 /* we get here either during compilation, or via pp_regcomp at runtime */
2956 runtime = IN_PERL_RUNTIME;
2958 runcv = find_runcv(NULL);
2961 PL_op->op_type = OP_ENTEREVAL;
2962 PL_op->op_flags = 0; /* Avoid uninit warning. */
2963 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2967 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2969 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2970 POPBLOCK(cx,PL_curpm);
2973 (*startop)->op_type = OP_NULL;
2974 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2976 /* XXX DAPM do this properly one year */
2977 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2978 LEAVE_with_name("eval");
2979 if (IN_PERL_COMPILETIME)
2980 CopHINTS_set(&PL_compiling, PL_hints);
2981 #ifdef OP_IN_REGISTER
2984 PERL_UNUSED_VAR(newsp);
2985 PERL_UNUSED_VAR(optype);
2987 return PL_eval_start;
2992 =for apidoc find_runcv
2994 Locate the CV corresponding to the currently executing sub or eval.
2995 If db_seqp is non_null, skip CVs that are in the DB package and populate
2996 *db_seqp with the cop sequence number at the point that the DB:: code was
2997 entered. (allows debuggers to eval in the scope of the breakpoint rather
2998 than in the scope of the debugger itself).
3004 Perl_find_runcv(pTHX_ U32 *db_seqp)
3010 *db_seqp = PL_curcop->cop_seq;
3011 for (si = PL_curstackinfo; si; si = si->si_prev) {
3013 for (ix = si->si_cxix; ix >= 0; ix--) {
3014 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3015 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3016 CV * const cv = cx->blk_sub.cv;
3017 /* skip DB:: code */
3018 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3019 *db_seqp = cx->blk_oldcop->cop_seq;
3024 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3032 /* Run yyparse() in a setjmp wrapper. Returns:
3033 * 0: yyparse() successful
3034 * 1: yyparse() failed
3043 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3047 ret = yyparse() ? 1 : 0;
3061 /* Compile a require/do, an eval '', or a /(?{...})/.
3062 * In the last case, startop is non-null, and contains the address of
3063 * a pointer that should be set to the just-compiled code.
3064 * outside is the lexically enclosing CV (if any) that invoked us.
3065 * Returns a bool indicating whether the compile was successful; if so,
3066 * PL_eval_start contains the first op of the compiled ocde; otherwise,
3067 * pushes undef (also croaks if startop != NULL).
3071 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3074 OP * const saveop = PL_op;
3075 bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3078 PL_in_eval = (in_require
3079 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3084 SAVESPTR(PL_compcv);
3085 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3086 CvEVAL_on(PL_compcv);
3087 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3088 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3090 CvOUTSIDE_SEQ(PL_compcv) = seq;
3091 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3093 /* set up a scratch pad */
3095 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3096 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3100 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3102 /* make sure we compile in the right package */
3104 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3105 SAVESPTR(PL_curstash);
3106 PL_curstash = CopSTASH(PL_curcop);
3108 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3109 SAVESPTR(PL_beginav);
3110 PL_beginav = newAV();
3111 SAVEFREESV(PL_beginav);
3112 SAVESPTR(PL_unitcheckav);
3113 PL_unitcheckav = newAV();
3114 SAVEFREESV(PL_unitcheckav);
3117 SAVEBOOL(PL_madskills);
3121 /* try to compile it */
3123 PL_eval_root = NULL;
3124 PL_curcop = &PL_compiling;
3125 CopARYBASE_set(PL_curcop, 0);
3126 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3127 PL_in_eval |= EVAL_KEEPERR;
3131 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3132 * so honour CATCH_GET and trap it here if necessary */
3134 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX) : yyparse();
3136 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3137 SV **newsp; /* Used by POPBLOCK. */
3138 PERL_CONTEXT *cx = NULL;
3139 I32 optype; /* Used by POPEVAL. */
3143 PERL_UNUSED_VAR(newsp);
3144 PERL_UNUSED_VAR(optype);
3146 /* note that if yystatus == 3, then the EVAL CX block has already
3147 * been popped, and various vars restored */
3149 if (yystatus != 3) {
3151 op_free(PL_eval_root);
3152 PL_eval_root = NULL;
3154 SP = PL_stack_base + POPMARK; /* pop original mark */
3156 POPBLOCK(cx,PL_curpm);
3158 namesv = cx->blk_eval.old_namesv;
3163 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3165 msg = SvPVx_nolen_const(ERRSV);
3168 /* If cx is still NULL, it means that we didn't go in the
3169 * POPEVAL branch. */
3170 cx = &cxstack[cxstack_ix];
3171 assert(CxTYPE(cx) == CXt_EVAL);
3172 namesv = cx->blk_eval.old_namesv;
3174 (void)hv_store(GvHVn(PL_incgv),
3175 SvPVX_const(namesv), SvCUR(namesv),
3177 Perl_croak(aTHX_ "%sCompilation failed in require",
3178 *msg ? msg : "Unknown error\n");
3181 if (yystatus != 3) {
3182 POPBLOCK(cx,PL_curpm);
3185 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3186 (*msg ? msg : "Unknown error\n"));
3190 sv_setpvs(ERRSV, "Compilation error");
3193 PUSHs(&PL_sv_undef);
3197 CopLINE_set(&PL_compiling, 0);
3199 *startop = PL_eval_root;
3201 SAVEFREEOP(PL_eval_root);
3203 /* Set the context for this new optree.
3204 * Propagate the context from the eval(). */
3205 if ((gimme & G_WANT) == G_VOID)
3206 scalarvoid(PL_eval_root);
3207 else if ((gimme & G_WANT) == G_ARRAY)
3210 scalar(PL_eval_root);
3212 DEBUG_x(dump_eval());
3214 /* Register with debugger: */
3215 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3216 CV * const cv = get_cvs("DB::postponed", 0);
3220 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3222 call_sv(MUTABLE_SV(cv), G_DISCARD);
3227 call_list(PL_scopestack_ix, PL_unitcheckav);
3229 /* compiled okay, so do it */
3231 CvDEPTH(PL_compcv) = 1;
3232 SP = PL_stack_base + POPMARK; /* pop original mark */
3233 PL_op = saveop; /* The caller may need it. */
3234 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3241 S_check_type_and_open(pTHX_ const char *name)
3244 const int st_rc = PerlLIO_stat(name, &st);
3246 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3248 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3252 return PerlIO_open(name, PERL_SCRIPT_MODE);
3255 #ifndef PERL_DISABLE_PMC
3257 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3261 PERL_ARGS_ASSERT_DOOPEN_PM;
3263 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3264 SV *const pmcsv = newSV(namelen + 2);
3265 char *const pmc = SvPVX(pmcsv);
3268 memcpy(pmc, name, namelen);
3270 pmc[namelen + 1] = '\0';
3272 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3273 fp = check_type_and_open(name);
3276 fp = check_type_and_open(pmc);
3278 SvREFCNT_dec(pmcsv);
3281 fp = check_type_and_open(name);
3286 # define doopen_pm(name, namelen) check_type_and_open(name)
3287 #endif /* !PERL_DISABLE_PMC */
3292 register PERL_CONTEXT *cx;
3299 int vms_unixname = 0;
3301 const char *tryname = NULL;
3303 const I32 gimme = GIMME_V;
3304 int filter_has_file = 0;
3305 PerlIO *tryrsfp = NULL;
3306 SV *filter_cache = NULL;
3307 SV *filter_state = NULL;
3308 SV *filter_sub = NULL;
3314 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3315 sv = new_version(sv);
3316 if (!sv_derived_from(PL_patchlevel, "version"))
3317 upg_version(PL_patchlevel, TRUE);
3318 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3319 if ( vcmp(sv,PL_patchlevel) <= 0 )
3320 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3321 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3324 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3327 SV * const req = SvRV(sv);
3328 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3330 /* get the left hand term */
3331 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3333 first = SvIV(*av_fetch(lav,0,0));
3334 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3335 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3336 || av_len(lav) > 1 /* FP with > 3 digits */
3337 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3339 DIE(aTHX_ "Perl %"SVf" required--this is only "
3340 "%"SVf", stopped", SVfARG(vnormal(req)),
3341 SVfARG(vnormal(PL_patchlevel)));
3343 else { /* probably 'use 5.10' or 'use 5.8' */
3348 second = SvIV(*av_fetch(lav,1,0));
3350 second /= second >= 600 ? 100 : 10;
3351 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3352 (int)first, (int)second);
3353 upg_version(hintsv, TRUE);
3355 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3356 "--this is only %"SVf", stopped",
3357 SVfARG(vnormal(req)),
3358 SVfARG(vnormal(sv_2mortal(hintsv))),
3359 SVfARG(vnormal(PL_patchlevel)));
3364 /* We do this only with "use", not "require" or "no". */
3366 !(cUNOP->op_first->op_private & OPpCONST_NOVER) &&
3367 /* If we request a version >= 5.9.5, load feature.pm with the
3368 * feature bundle that corresponds to the required version. */
3369 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3370 SV *const importsv = vnormal(sv);
3371 *SvPVX_mutable(importsv) = ':';
3372 ENTER_with_name("load_feature");
3373 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3374 LEAVE_with_name("load_feature");
3376 /* If a version >= 5.11.0 is requested, strictures are on by default! */
3378 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3379 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3384 name = SvPV_const(sv, len);
3385 if (!(name && len > 0 && *name))
3386 DIE(aTHX_ "Null filename used");
3387 TAINT_PROPER("require");
3391 /* The key in the %ENV hash is in the syntax of file passed as the argument
3392 * usually this is in UNIX format, but sometimes in VMS format, which
3393 * can result in a module being pulled in more than once.
3394 * To prevent this, the key must be stored in UNIX format if the VMS
3395 * name can be translated to UNIX.
3397 if ((unixname = tounixspec(name, NULL)) != NULL) {
3398 unixlen = strlen(unixname);
3404 /* if not VMS or VMS name can not be translated to UNIX, pass it
3407 unixname = (char *) name;
3410 if (PL_op->op_type == OP_REQUIRE) {
3411 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3412 unixname, unixlen, 0);
3414 if (*svp != &PL_sv_undef)
3417 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3418 "Compilation failed in require", unixname);
3422 /* prepare to compile file */
3424 if (path_is_absolute(name)) {
3426 tryrsfp = doopen_pm(name, len);
3429 AV * const ar = GvAVn(PL_incgv);
3435 namesv = newSV_type(SVt_PV);
3436 for (i = 0; i <= AvFILL(ar); i++) {
3437 SV * const dirsv = *av_fetch(ar, i, TRUE);
3439 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3446 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3447 && !sv_isobject(loader))
3449 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3452 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3453 PTR2UV(SvRV(dirsv)), name);
3454 tryname = SvPVX_const(namesv);
3457 ENTER_with_name("call_INC");
3465 if (sv_isobject(loader))
3466 count = call_method("INC", G_ARRAY);
3468 count = call_sv(loader, G_ARRAY);
3471 /* Adjust file name if the hook has set an %INC entry */
3472 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3474 tryname = SvPV_nolen_const(*svp);
3483 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3484 && !isGV_with_GP(SvRV(arg))) {
3485 filter_cache = SvRV(arg);
3486 SvREFCNT_inc_simple_void_NN(filter_cache);
3493 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3497 if (isGV_with_GP(arg)) {
3498 IO * const io = GvIO((const GV *)arg);
3503 tryrsfp = IoIFP(io);
3504 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3505 PerlIO_close(IoOFP(io));
3516 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3518 SvREFCNT_inc_simple_void_NN(filter_sub);
3521 filter_state = SP[i];
3522 SvREFCNT_inc_simple_void(filter_state);
3526 if (!tryrsfp && (filter_cache || filter_sub)) {
3527 tryrsfp = PerlIO_open(BIT_BUCKET,
3535 LEAVE_with_name("call_INC");
3542 filter_has_file = 0;
3544 SvREFCNT_dec(filter_cache);
3545 filter_cache = NULL;
3548 SvREFCNT_dec(filter_state);
3549 filter_state = NULL;
3552 SvREFCNT_dec(filter_sub);
3557 if (!path_is_absolute(name)
3563 dir = SvPV_const(dirsv, dirlen);
3571 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3573 sv_setpv(namesv, unixdir);
3574 sv_catpv(namesv, unixname);
3576 # ifdef __SYMBIAN32__
3577 if (PL_origfilename[0] &&
3578 PL_origfilename[1] == ':' &&
3579 !(dir[0] && dir[1] == ':'))
3580 Perl_sv_setpvf(aTHX_ namesv,
3585 Perl_sv_setpvf(aTHX_ namesv,
3589 /* The equivalent of
3590 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3591 but without the need to parse the format string, or
3592 call strlen on either pointer, and with the correct
3593 allocation up front. */
3595 char *tmp = SvGROW(namesv, dirlen + len + 2);
3597 memcpy(tmp, dir, dirlen);
3600 /* name came from an SV, so it will have a '\0' at the
3601 end that we can copy as part of this memcpy(). */
3602 memcpy(tmp, name, len + 1);
3604 SvCUR_set(namesv, dirlen + len + 1);
3606 /* Don't even actually have to turn SvPOK_on() as we
3607 access it directly with SvPVX() below. */
3611 TAINT_PROPER("require");
3612 tryname = SvPVX_const(namesv);
3613 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3615 if (tryname[0] == '.' && tryname[1] == '/') {
3617 while (*++tryname == '/');
3621 else if (errno == EMFILE)
3622 /* no point in trying other paths if out of handles */
3629 SAVECOPFILE_FREE(&PL_compiling);
3630 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3631 SvREFCNT_dec(namesv);
3633 if (PL_op->op_type == OP_REQUIRE) {
3634 const char *msgstr = name;
3635 if(errno == EMFILE) {
3637 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3639 msgstr = SvPV_nolen_const(msg);
3641 if (namesv) { /* did we lookup @INC? */
3642 AV * const ar = GvAVn(PL_incgv);
3644 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3645 "%s in @INC%s%s (@INC contains:",
3647 (instr(msgstr, ".h ")
3648 ? " (change .h to .ph maybe?)" : ""),
3649 (instr(msgstr, ".ph ")
3650 ? " (did you run h2ph?)" : "")
3653 for (i = 0; i <= AvFILL(ar); i++) {
3654 sv_catpvs(msg, " ");
3655 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3657 sv_catpvs(msg, ")");
3658 msgstr = SvPV_nolen_const(msg);
3661 DIE(aTHX_ "Can't locate %s", msgstr);
3667 SETERRNO(0, SS_NORMAL);
3669 /* Assume success here to prevent recursive requirement. */
3670 /* name is never assigned to again, so len is still strlen(name) */
3671 /* Check whether a hook in @INC has already filled %INC */
3673 (void)hv_store(GvHVn(PL_incgv),
3674 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3676 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3678 (void)hv_store(GvHVn(PL_incgv),
3679 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3682 ENTER_with_name("eval");
3684 lex_start(NULL, tryrsfp, TRUE);
3688 hv_clear(GvHV(PL_hintgv));
3690 SAVECOMPILEWARNINGS();
3691 if (PL_dowarn & G_WARN_ALL_ON)
3692 PL_compiling.cop_warnings = pWARN_ALL ;
3693 else if (PL_dowarn & G_WARN_ALL_OFF)
3694 PL_compiling.cop_warnings = pWARN_NONE ;
3696 PL_compiling.cop_warnings = pWARN_STD ;
3698 if (filter_sub || filter_cache) {
3699 /* We can use the SvPV of the filter PVIO itself as our cache, rather
3700 than hanging another SV from it. In turn, filter_add() optionally
3701 takes the SV to use as the filter (or creates a new SV if passed
3702 NULL), so simply pass in whatever value filter_cache has. */
3703 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3704 IoLINES(datasv) = filter_has_file;
3705 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3706 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3709 /* switch to eval mode */
3710 PUSHBLOCK(cx, CXt_EVAL, SP);
3712 cx->blk_eval.retop = PL_op->op_next;
3714 SAVECOPLINE(&PL_compiling);
3715 CopLINE_set(&PL_compiling, 0);
3719 /* Store and reset encoding. */
3720 encoding = PL_encoding;
3723 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3724 op = DOCATCH(PL_eval_start);
3726 op = PL_op->op_next;
3728 /* Restore encoding. */
3729 PL_encoding = encoding;
3734 /* This is a op added to hold the hints hash for
3735 pp_entereval. The hash can be modified by the code
3736 being eval'ed, so we return a copy instead. */
3742 mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3750 register PERL_CONTEXT *cx;
3752 const I32 gimme = GIMME_V;
3753 const U32 was = PL_breakable_sub_gen;
3754 char tbuf[TYPE_DIGITS(long) + 12];
3755 char *tmpbuf = tbuf;
3759 HV *saved_hh = NULL;
3761 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3762 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3766 TAINT_IF(SvTAINTED(sv));
3767 TAINT_PROPER("eval");
3769 ENTER_with_name("eval");
3770 lex_start(sv, NULL, FALSE);
3773 /* switch to eval mode */
3775 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3776 SV * const temp_sv = sv_newmortal();
3777 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3778 (unsigned long)++PL_evalseq,
3779 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3780 tmpbuf = SvPVX(temp_sv);
3781 len = SvCUR(temp_sv);
3784 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3785 SAVECOPFILE_FREE(&PL_compiling);
3786 CopFILE_set(&PL_compiling, tmpbuf+2);
3787 SAVECOPLINE(&PL_compiling);
3788 CopLINE_set(&PL_compiling, 1);
3789 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3790 deleting the eval's FILEGV from the stash before gv_check() runs
3791 (i.e. before run-time proper). To work around the coredump that
3792 ensues, we always turn GvMULTI_on for any globals that were
3793 introduced within evals. See force_ident(). GSAR 96-10-12 */
3795 PL_hints = PL_op->op_targ;
3797 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3798 SvREFCNT_dec(GvHV(PL_hintgv));
3799 GvHV(PL_hintgv) = saved_hh;
3801 SAVECOMPILEWARNINGS();
3802 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3803 if (PL_compiling.cop_hints_hash) {
3804 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3806 if (Perl_fetch_cop_label(aTHX_ PL_curcop->cop_hints_hash, NULL, NULL)) {
3807 /* The label, if present, is the first entry on the chain. So rather
3808 than writing a blank label in front of it (which involves an
3809 allocation), just use the next entry in the chain. */
3810 PL_compiling.cop_hints_hash
3811 = PL_curcop->cop_hints_hash->refcounted_he_next;
3812 /* Check the assumption that this removed the label. */
3813 assert(Perl_fetch_cop_label(aTHX_ PL_compiling.cop_hints_hash, NULL,
3817 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3818 if (PL_compiling.cop_hints_hash) {
3820 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3821 HINTS_REFCNT_UNLOCK;
3823 /* special case: an eval '' executed within the DB package gets lexically
3824 * placed in the first non-DB CV rather than the current CV - this
3825 * allows the debugger to execute code, find lexicals etc, in the
3826 * scope of the code being debugged. Passing &seq gets find_runcv
3827 * to do the dirty work for us */
3828 runcv = find_runcv(&seq);
3830 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3832 cx->blk_eval.retop = PL_op->op_next;
3834 /* prepare to compile string */
3836 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3837 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3840 if (doeval(gimme, NULL, runcv, seq)) {
3841 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3842 ? (PERLDB_LINE || PERLDB_SAVESRC)
3843 : PERLDB_SAVESRC_NOSUBS) {
3844 /* Retain the filegv we created. */
3846 char *const safestr = savepvn(tmpbuf, len);
3847 SAVEDELETE(PL_defstash, safestr, len);
3849 return DOCATCH(PL_eval_start);
3851 /* We have already left the scope set up earler thanks to the LEAVE
3853 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3854 ? (PERLDB_LINE || PERLDB_SAVESRC)
3855 : PERLDB_SAVESRC_INVALID) {
3856 /* Retain the filegv we created. */
3858 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3860 return PL_op->op_next;
3871 register PERL_CONTEXT *cx;
3873 const U8 save_flags = PL_op -> op_flags;
3879 namesv = cx->blk_eval.old_namesv;
3880 retop = cx->blk_eval.retop;
3883 if (gimme == G_VOID)
3885 else if (gimme == G_SCALAR) {
3888 if (SvFLAGS(TOPs) & SVs_TEMP)
3891 *MARK = sv_mortalcopy(TOPs);
3895 *MARK = &PL_sv_undef;
3900 /* in case LEAVE wipes old return values */
3901 for (mark = newsp + 1; mark <= SP; mark++) {
3902 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3903 *mark = sv_mortalcopy(*mark);
3904 TAINT_NOT; /* Each item is independent */
3908 PL_curpm = newpm; /* Don't pop $1 et al till now */
3911 assert(CvDEPTH(PL_compcv) == 1);
3913 CvDEPTH(PL_compcv) = 0;
3916 if (optype == OP_REQUIRE &&
3917 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3919 /* Unassume the success we assumed earlier. */
3920 (void)hv_delete(GvHVn(PL_incgv),
3921 SvPVX_const(namesv), SvCUR(namesv),
3923 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
3925 /* die_unwind() did LEAVE, or we won't be here */
3928 LEAVE_with_name("eval");
3929 if (!(save_flags & OPf_SPECIAL)) {
3937 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3938 close to the related Perl_create_eval_scope. */
3940 Perl_delete_eval_scope(pTHX)
3945 register PERL_CONTEXT *cx;
3951 LEAVE_with_name("eval_scope");
3952 PERL_UNUSED_VAR(newsp);
3953 PERL_UNUSED_VAR(gimme);
3954 PERL_UNUSED_VAR(optype);
3957 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3958 also needed by Perl_fold_constants. */
3960 Perl_create_eval_scope(pTHX_ U32 flags)
3963 const I32 gimme = GIMME_V;
3965 ENTER_with_name("eval_scope");
3968 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3971 PL_in_eval = EVAL_INEVAL;
3972 if (flags & G_KEEPERR)
3973 PL_in_eval |= EVAL_KEEPERR;
3976 if (flags & G_FAKINGEVAL) {
3977 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3985 PERL_CONTEXT * const cx = create_eval_scope(0);
3986 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3987 return DOCATCH(PL_op->op_next);
3996 register PERL_CONTEXT *cx;
4001 PERL_UNUSED_VAR(optype);
4004 if (gimme == G_VOID)
4006 else if (gimme == G_SCALAR) {
4010 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4013 *MARK = sv_mortalcopy(TOPs);
4017 *MARK = &PL_sv_undef;
4022 /* in case LEAVE wipes old return values */
4024 for (mark = newsp + 1; mark <= SP; mark++) {
4025 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4026 *mark = sv_mortalcopy(*mark);
4027 TAINT_NOT; /* Each item is independent */
4031 PL_curpm = newpm; /* Don't pop $1 et al till now */
4033 LEAVE_with_name("eval_scope");
4041 register PERL_CONTEXT *cx;
4042 const I32 gimme = GIMME_V;
4044 ENTER_with_name("given");
4047 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
4049 PUSHBLOCK(cx, CXt_GIVEN, SP);
4058 register PERL_CONTEXT *cx;
4062 PERL_UNUSED_CONTEXT;
4065 assert(CxTYPE(cx) == CXt_GIVEN);
4068 if (gimme == G_VOID)
4070 else if (gimme == G_SCALAR) {
4074 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4077 *MARK = sv_mortalcopy(TOPs);
4081 *MARK = &PL_sv_undef;
4086 /* in case LEAVE wipes old return values */
4088 for (mark = newsp + 1; mark <= SP; mark++) {
4089 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4090 *mark = sv_mortalcopy(*mark);
4091 TAINT_NOT; /* Each item is independent */
4095 PL_curpm = newpm; /* Don't pop $1 et al till now */
4097 LEAVE_with_name("given");
4101 /* Helper routines used by pp_smartmatch */
4103 S_make_matcher(pTHX_ REGEXP *re)
4106 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4108 PERL_ARGS_ASSERT_MAKE_MATCHER;
4110 PM_SETRE(matcher, ReREFCNT_inc(re));
4112 SAVEFREEOP((OP *) matcher);
4113 ENTER_with_name("matcher"); SAVETMPS;
4119 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4124 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4126 PL_op = (OP *) matcher;
4131 return (SvTRUEx(POPs));
4135 S_destroy_matcher(pTHX_ PMOP *matcher)
4139 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4140 PERL_UNUSED_ARG(matcher);
4143 LEAVE_with_name("matcher");
4146 /* Do a smart match */
4149 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4150 return do_smartmatch(NULL, NULL);
4153 /* This version of do_smartmatch() implements the
4154 * table of smart matches that is found in perlsyn.
4157 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4162 bool object_on_left = FALSE;
4163 SV *e = TOPs; /* e is for 'expression' */
4164 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4166 /* Take care only to invoke mg_get() once for each argument.
4167 * Currently we do this by copying the SV if it's magical. */
4170 d = sv_mortalcopy(d);
4177 e = sv_mortalcopy(e);
4179 /* First of all, handle overload magic of the rightmost argument */
4182 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4183 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4185 tmpsv = amagic_call(d, e, smart_amg, 0);
4192 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4195 SP -= 2; /* Pop the values */
4200 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4207 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4208 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4209 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4211 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4212 object_on_left = TRUE;
4215 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4217 if (object_on_left) {
4218 goto sm_any_sub; /* Treat objects like scalars */
4220 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4221 /* Test sub truth for each key */
4223 bool andedresults = TRUE;
4224 HV *hv = (HV*) SvRV(d);
4225 I32 numkeys = hv_iterinit(hv);
4226 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4229 while ( (he = hv_iternext(hv)) ) {
4230 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4231 ENTER_with_name("smartmatch_hash_key_test");
4234 PUSHs(hv_iterkeysv(he));
4236 c = call_sv(e, G_SCALAR);
4239 andedresults = FALSE;
4241 andedresults = SvTRUEx(POPs) && andedresults;
4243 LEAVE_with_name("smartmatch_hash_key_test");
4250 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4251 /* Test sub truth for each element */
4253 bool andedresults = TRUE;
4254 AV *av = (AV*) SvRV(d);
4255 const I32 len = av_len(av);
4256 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4259 for (i = 0; i <= len; ++i) {
4260 SV * const * const svp = av_fetch(av, i, FALSE);
4261 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4262 ENTER_with_name("smartmatch_array_elem_test");
4268 c = call_sv(e, G_SCALAR);
4271 andedresults = FALSE;
4273 andedresults = SvTRUEx(POPs) && andedresults;
4275 LEAVE_with_name("smartmatch_array_elem_test");
4284 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4285 ENTER_with_name("smartmatch_coderef");
4290 c = call_sv(e, G_SCALAR);
4294 else if (SvTEMP(TOPs))
4295 SvREFCNT_inc_void(TOPs);
4297 LEAVE_with_name("smartmatch_coderef");
4302 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4303 if (object_on_left) {
4304 goto sm_any_hash; /* Treat objects like scalars */
4306 else if (!SvOK(d)) {
4307 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4310 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4311 /* Check that the key-sets are identical */
4313 HV *other_hv = MUTABLE_HV(SvRV(d));
4315 bool other_tied = FALSE;
4316 U32 this_key_count = 0,
4317 other_key_count = 0;
4318 HV *hv = MUTABLE_HV(SvRV(e));
4320 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4321 /* Tied hashes don't know how many keys they have. */
4322 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4325 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4326 HV * const temp = other_hv;
4331 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4334 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4337 /* The hashes have the same number of keys, so it suffices
4338 to check that one is a subset of the other. */
4339 (void) hv_iterinit(hv);
4340 while ( (he = hv_iternext(hv)) ) {
4341 SV *key = hv_iterkeysv(he);
4343 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4346 if(!hv_exists_ent(other_hv, key, 0)) {
4347 (void) hv_iterinit(hv); /* reset iterator */
4353 (void) hv_iterinit(other_hv);
4354 while ( hv_iternext(other_hv) )
4358 other_key_count = HvUSEDKEYS(other_hv);
4360 if (this_key_count != other_key_count)
4365 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4366 AV * const other_av = MUTABLE_AV(SvRV(d));
4367 const I32 other_len = av_len(other_av) + 1;
4369 HV *hv = MUTABLE_HV(SvRV(e));
4371 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4372 for (i = 0; i < other_len; ++i) {
4373 SV ** const svp = av_fetch(other_av, i, FALSE);
4374 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4375 if (svp) { /* ??? When can this not happen? */
4376 if (hv_exists_ent(hv, *svp, 0))
4382 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4383 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4386 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4388 HV *hv = MUTABLE_HV(SvRV(e));
4390 (void) hv_iterinit(hv);
4391 while ( (he = hv_iternext(hv)) ) {
4392 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4393 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4394 (void) hv_iterinit(hv);
4395 destroy_matcher(matcher);
4399 destroy_matcher(matcher);
4405 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4406 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4413 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4414 if (object_on_left) {
4415 goto sm_any_array; /* Treat objects like scalars */
4417 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4418 AV * const other_av = MUTABLE_AV(SvRV(e));
4419 const I32 other_len = av_len(other_av) + 1;
4422 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4423 for (i = 0; i < other_len; ++i) {
4424 SV ** const svp = av_fetch(other_av, i, FALSE);
4426 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4427 if (svp) { /* ??? When can this not happen? */
4428 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4434 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4435 AV *other_av = MUTABLE_AV(SvRV(d));
4436 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4437 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4441 const I32 other_len = av_len(other_av);
4443 if (NULL == seen_this) {
4444 seen_this = newHV();
4445 (void) sv_2mortal(MUTABLE_SV(seen_this));
4447 if (NULL == seen_other) {
4448 seen_other = newHV();
4449 (void) sv_2mortal(MUTABLE_SV(seen_other));
4451 for(i = 0; i <= other_len; ++i) {
4452 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4453 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4455 if (!this_elem || !other_elem) {
4456 if ((this_elem && SvOK(*this_elem))
4457 || (other_elem && SvOK(*other_elem)))
4460 else if (hv_exists_ent(seen_this,
4461 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4462 hv_exists_ent(seen_other,
4463 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4465 if (*this_elem != *other_elem)
4469 (void)hv_store_ent(seen_this,
4470 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4472 (void)hv_store_ent(seen_other,
4473 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4479 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4480 (void) do_smartmatch(seen_this, seen_other);
4482 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4491 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4492 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4495 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4496 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4499 for(i = 0; i <= this_len; ++i) {
4500 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4501 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4502 if (svp && matcher_matches_sv(matcher, *svp)) {
4503 destroy_matcher(matcher);
4507 destroy_matcher(matcher);
4511 else if (!SvOK(d)) {
4512 /* undef ~~ array */
4513 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4516 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4517 for (i = 0; i <= this_len; ++i) {
4518 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4519 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4520 if (!svp || !SvOK(*svp))
4529 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4531 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4532 for (i = 0; i <= this_len; ++i) {
4533 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4540 /* infinite recursion isn't supposed to happen here */
4541 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4542 (void) do_smartmatch(NULL, NULL);
4544 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4553 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4554 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4555 SV *t = d; d = e; e = t;
4556 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4559 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4560 SV *t = d; d = e; e = t;
4561 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4562 goto sm_regex_array;
4565 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4567 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4569 PUSHs(matcher_matches_sv(matcher, d)
4572 destroy_matcher(matcher);
4577 /* See if there is overload magic on left */
4578 else if (object_on_left && SvAMAGIC(d)) {
4580 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4581 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4584 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4592 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4595 else if (!SvOK(d)) {
4596 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4597 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4602 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4603 DEBUG_M(if (SvNIOK(e))
4604 Perl_deb(aTHX_ " applying rule Any-Num\n");
4606 Perl_deb(aTHX_ " applying rule Num-numish\n");
4608 /* numeric comparison */
4611 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4622 /* As a last resort, use string comparison */
4623 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4632 register PERL_CONTEXT *cx;
4633 const I32 gimme = GIMME_V;
4635 /* This is essentially an optimization: if the match
4636 fails, we don't want to push a context and then
4637 pop it again right away, so we skip straight
4638 to the op that follows the leavewhen.
4639 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4641 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4642 RETURNOP(cLOGOP->op_other->op_next);
4644 ENTER_with_name("eval");
4647 PUSHBLOCK(cx, CXt_WHEN, SP);
4656 register PERL_CONTEXT *cx;
4662 assert(CxTYPE(cx) == CXt_WHEN);
4667 PL_curpm = newpm; /* pop $1 et al */
4669 LEAVE_with_name("eval");
4677 register PERL_CONTEXT *cx;
4680 cxix = dopoptowhen(cxstack_ix);
4682 DIE(aTHX_ "Can't \"continue\" outside a when block");
4683 if (cxix < cxstack_ix)
4686 /* clear off anything above the scope we're re-entering */
4687 inner = PL_scopestack_ix;
4689 if (PL_scopestack_ix < inner)
4690 leave_scope(PL_scopestack[PL_scopestack_ix]);
4691 PL_curcop = cx->blk_oldcop;
4692 return cx->blk_givwhen.leave_op;
4699 register PERL_CONTEXT *cx;
4703 cxix = dopoptogiven(cxstack_ix);
4705 if (PL_op->op_flags & OPf_SPECIAL)
4706 DIE(aTHX_ "Can't use when() outside a topicalizer");
4708 DIE(aTHX_ "Can't \"break\" outside a given block");
4710 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4711 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4713 if (cxix < cxstack_ix)
4716 /* clear off anything above the scope we're re-entering */
4717 inner = PL_scopestack_ix;
4719 if (PL_scopestack_ix < inner)
4720 leave_scope(PL_scopestack[PL_scopestack_ix]);
4721 PL_curcop = cx->blk_oldcop;
4724 return CX_LOOP_NEXTOP_GET(cx);
4726 /* RETURNOP calls PUTBACK which restores the old old sp */
4727 RETURNOP(cx->blk_givwhen.leave_op);
4731 S_doparseform(pTHX_ SV *sv)
4734 register char *s = SvPV_force(sv, len);
4735 register char * const send = s + len;
4736 register char *base = NULL;
4737 register I32 skipspaces = 0;
4738 bool noblank = FALSE;
4739 bool repeat = FALSE;
4740 bool postspace = FALSE;
4746 bool unchopnum = FALSE;
4747 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4749 PERL_ARGS_ASSERT_DOPARSEFORM;
4752 Perl_croak(aTHX_ "Null picture in formline");
4754 /* estimate the buffer size needed */
4755 for (base = s; s <= send; s++) {
4756 if (*s == '\n' || *s == '@' || *s == '^')
4762 Newx(fops, maxops, U32);
4767 *fpc++ = FF_LINEMARK;
4768 noblank = repeat = FALSE;
4786 case ' ': case '\t':
4793 } /* else FALL THROUGH */
4801 *fpc++ = FF_LITERAL;
4809 *fpc++ = (U16)skipspaces;
4813 *fpc++ = FF_NEWLINE;
4817 arg = fpc - linepc + 1;
4824 *fpc++ = FF_LINEMARK;
4825 noblank = repeat = FALSE;
4834 ischop = s[-1] == '^';
4840 arg = (s - base) - 1;
4842 *fpc++ = FF_LITERAL;
4850 *fpc++ = 2; /* skip the @* or ^* */
4852 *fpc++ = FF_LINESNGL;
4855 *fpc++ = FF_LINEGLOB;
4857 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4858 arg = ischop ? 512 : 0;
4863 const char * const f = ++s;
4866 arg |= 256 + (s - f);
4868 *fpc++ = s - base; /* fieldsize for FETCH */
4869 *fpc++ = FF_DECIMAL;
4871 unchopnum |= ! ischop;
4873 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4874 arg = ischop ? 512 : 0;
4876 s++; /* skip the '0' first */
4880 const char * const f = ++s;
4883 arg |= 256 + (s - f);
4885 *fpc++ = s - base; /* fieldsize for FETCH */
4886 *fpc++ = FF_0DECIMAL;
4888 unchopnum |= ! ischop;
4892 bool ismore = FALSE;
4895 while (*++s == '>') ;
4896 prespace = FF_SPACE;
4898 else if (*s == '|') {
4899 while (*++s == '|') ;
4900 prespace = FF_HALFSPACE;
4905 while (*++s == '<') ;
4908 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4912 *fpc++ = s - base; /* fieldsize for FETCH */
4914 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4917 *fpc++ = (U16)prespace;
4931 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4933 { /* need to jump to the next word */
4935 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4936 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4937 s = SvPVX(sv) + SvCUR(sv) + z;
4939 Copy(fops, s, arg, U32);
4941 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4944 if (unchopnum && repeat)
4945 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4951 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4953 /* Can value be printed in fldsize chars, using %*.*f ? */
4957 int intsize = fldsize - (value < 0 ? 1 : 0);
4964 while (intsize--) pwr *= 10.0;
4965 while (frcsize--) eps /= 10.0;
4968 if (value + eps >= pwr)
4971 if (value - eps <= -pwr)
4978 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4981 SV * const datasv = FILTER_DATA(idx);
4982 const int filter_has_file = IoLINES(datasv);
4983 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4984 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4989 char *prune_from = NULL;
4990 bool read_from_cache = FALSE;
4993 PERL_ARGS_ASSERT_RUN_USER_FILTER;
4995 assert(maxlen >= 0);
4998 /* I was having segfault trouble under Linux 2.2.5 after a
4999 parse error occured. (Had to hack around it with a test
5000 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5001 not sure where the trouble is yet. XXX */
5004 SV *const cache = datasv;
5007 const char *cache_p = SvPV(cache, cache_len);
5011 /* Running in block mode and we have some cached data already.
5013 if (cache_len >= umaxlen) {
5014 /* In fact, so much data we don't even need to call
5019 const char *const first_nl =
5020 (const char *)memchr(cache_p, '\n', cache_len);
5022 take = first_nl + 1 - cache_p;
5026 sv_catpvn(buf_sv, cache_p, take);
5027 sv_chop(cache, cache_p + take);
5028 /* Definately not EOF */
5032 sv_catsv(buf_sv, cache);
5034 umaxlen -= cache_len;
5037 read_from_cache = TRUE;
5041 /* Filter API says that the filter appends to the contents of the buffer.
5042 Usually the buffer is "", so the details don't matter. But if it's not,
5043 then clearly what it contains is already filtered by this filter, so we
5044 don't want to pass it in a second time.
5045 I'm going to use a mortal in case the upstream filter croaks. */
5046 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5047 ? sv_newmortal() : buf_sv;
5048 SvUPGRADE(upstream, SVt_PV);
5050 if (filter_has_file) {
5051 status = FILTER_READ(idx+1, upstream, 0);
5054 if (filter_sub && status >= 0) {
5058 ENTER_with_name("call_filter_sub");
5063 DEFSV_set(upstream);
5067 PUSHs(filter_state);
5070 count = call_sv(filter_sub, G_SCALAR);
5082 LEAVE_with_name("call_filter_sub");
5085 if(SvOK(upstream)) {
5086 got_p = SvPV(upstream, got_len);
5088 if (got_len > umaxlen) {
5089 prune_from = got_p + umaxlen;
5092 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5093 if (first_nl && first_nl + 1 < got_p + got_len) {
5094 /* There's a second line here... */
5095 prune_from = first_nl + 1;
5100 /* Oh. Too long. Stuff some in our cache. */
5101 STRLEN cached_len = got_p + got_len - prune_from;
5102 SV *const cache = datasv;
5105 /* Cache should be empty. */
5106 assert(!SvCUR(cache));
5109 sv_setpvn(cache, prune_from, cached_len);
5110 /* If you ask for block mode, you may well split UTF-8 characters.
5111 "If it breaks, you get to keep both parts"
5112 (Your code is broken if you don't put them back together again
5113 before something notices.) */
5114 if (SvUTF8(upstream)) {
5117 SvCUR_set(upstream, got_len - cached_len);
5119 /* Can't yet be EOF */
5124 /* If they are at EOF but buf_sv has something in it, then they may never
5125 have touched the SV upstream, so it may be undefined. If we naively
5126 concatenate it then we get a warning about use of uninitialised value.
5128 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5129 sv_catsv(buf_sv, upstream);
5133 IoLINES(datasv) = 0;
5135 SvREFCNT_dec(filter_state);
5136 IoTOP_GV(datasv) = NULL;
5139 SvREFCNT_dec(filter_sub);
5140 IoBOTTOM_GV(datasv) = NULL;
5142 filter_del(S_run_user_filter);
5144 if (status == 0 && read_from_cache) {
5145 /* If we read some data from the cache (and by getting here it implies
5146 that we emptied the cache) then we aren't yet at EOF, and mustn't
5147 report that to our caller. */
5153 /* perhaps someone can come up with a better name for
5154 this? it is not really "absolute", per se ... */
5156 S_path_is_absolute(const char *name)
5158 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5160 if (PERL_FILE_IS_ABSOLUTE(name)
5162 || (*name == '.' && ((name[1] == '/' ||
5163 (name[1] == '.' && name[2] == '/'))
5164 || (name[1] == '\\' ||
5165 ( name[1] == '.' && name[2] == '\\')))
5168 || (*name == '.' && (name[1] == '/' ||
5169 (name[1] == '.' && name[2] == '/')))
5181 * c-indentation-style: bsd
5183 * indent-tabs-mode: t
5186 * ex: set ts=8 sts=4 sw=4 noet: