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) \
99 if (SvROK(rx) && SvAMAGIC(rx)) { \
100 SV *sv = AMG_CALLun(rx, regexp); \
104 if (SvTYPE(sv) != SVt_REGEXP) \
105 Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
112 if (PL_op->op_flags & OPf_STACKED) {
113 /* multiple args; concatentate them */
115 tmpstr = PAD_SV(ARGTARG);
116 sv_setpvs(tmpstr, "");
117 while (++MARK <= SP) {
119 if (PL_amagic_generation) {
122 tryAMAGICregexp(msv);
124 if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
125 (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
127 sv_setsv(tmpstr, sv);
131 sv_catsv(tmpstr, msv);
138 tryAMAGICregexp(tmpstr);
141 #undef tryAMAGICregexp
144 SV * const sv = SvRV(tmpstr);
145 if (SvTYPE(sv) == SVt_REGEXP)
148 else if (SvTYPE(tmpstr) == SVt_REGEXP)
149 re = (REGEXP*) tmpstr;
152 /* The match's LHS's get-magic might need to access this op's reg-
153 exp (as is sometimes the case with $'; see bug 70764). So we
154 must call get-magic now before we replace the regexp. Hopeful-
155 ly this hack can be replaced with the approach described at
156 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
157 /msg122415.html some day. */
158 OP *matchop = pm->op_next;
160 const bool was_tainted = PL_tainted;
161 if (matchop->op_flags & OPf_STACKED)
163 else if (matchop->op_private & OPpTARGET_MY)
164 lhs = PAD_SV(matchop->op_targ);
167 /* Restore the previous value of PL_tainted (which may have been
168 modified by get-magic), to avoid incorrectly setting the
169 RXf_TAINTED flag further down. */
170 PL_tainted = was_tainted;
172 re = reg_temp_copy(NULL, re);
173 ReREFCNT_dec(PM_GETRE(pm));
178 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
180 assert (re != (REGEXP*) &PL_sv_undef);
182 /* Check against the last compiled regexp. */
183 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
184 memNE(RX_PRECOMP(re), t, len))
186 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
187 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
191 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
193 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
195 } else if (PL_curcop->cop_hints_hash) {
196 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
198 if (ptr && SvIOK(ptr) && SvIV(ptr))
199 eng = INT2PTR(regexp_engine*,SvIV(ptr));
202 if (PL_op->op_flags & OPf_SPECIAL)
203 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
205 if (DO_UTF8(tmpstr)) {
206 assert (SvUTF8(tmpstr));
207 } else if (SvUTF8(tmpstr)) {
208 /* Not doing UTF-8, despite what the SV says. Is this only if
209 we're trapped in use 'bytes'? */
210 /* Make a copy of the octet sequence, but without the flag on,
211 as the compiler now honours the SvUTF8 flag on tmpstr. */
213 const char *const p = SvPV(tmpstr, len);
214 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
218 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
220 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
222 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
223 inside tie/overload accessors. */
229 #ifndef INCOMPLETE_TAINTS
232 RX_EXTFLAGS(re) |= RXf_TAINTED;
234 RX_EXTFLAGS(re) &= ~RXf_TAINTED;
238 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
242 #if !defined(USE_ITHREADS)
243 /* can't change the optree at runtime either */
244 /* PMf_KEEP is handled differently under threads to avoid these problems */
245 if (pm->op_pmflags & PMf_KEEP) {
246 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
247 cLOGOP->op_first->op_next = PL_op->op_next;
257 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
258 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
259 register SV * const dstr = cx->sb_dstr;
260 register char *s = cx->sb_s;
261 register char *m = cx->sb_m;
262 char *orig = cx->sb_orig;
263 register REGEXP * const rx = cx->sb_rx;
265 REGEXP *old = PM_GETRE(pm);
269 PM_SETRE(pm,ReREFCNT_inc(rx));
272 rxres_restore(&cx->sb_rxres, rx);
273 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
275 if (cx->sb_iters++) {
276 const I32 saviters = cx->sb_iters;
277 if (cx->sb_iters > cx->sb_maxiters)
278 DIE(aTHX_ "Substitution loop");
280 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
281 cx->sb_rxtainted |= 2;
282 sv_catsv(dstr, POPs);
283 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
287 if (CxONCE(cx) || s < orig ||
288 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
289 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
290 ((cx->sb_rflags & REXEC_COPY_STR)
291 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
292 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
294 SV * const targ = cx->sb_targ;
296 assert(cx->sb_strend >= s);
297 if(cx->sb_strend > s) {
298 if (DO_UTF8(dstr) && !SvUTF8(targ))
299 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
301 sv_catpvn(dstr, s, cx->sb_strend - s);
303 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
305 #ifdef PERL_OLD_COPY_ON_WRITE
307 sv_force_normal_flags(targ, SV_COW_DROP_PV);
313 SvPV_set(targ, SvPVX(dstr));
314 SvCUR_set(targ, SvCUR(dstr));
315 SvLEN_set(targ, SvLEN(dstr));
318 SvPV_set(dstr, NULL);
320 TAINT_IF(cx->sb_rxtainted & 1);
321 mPUSHi(saviters - 1);
323 (void)SvPOK_only_UTF8(targ);
324 TAINT_IF(cx->sb_rxtainted);
328 LEAVE_SCOPE(cx->sb_oldsave);
330 RETURNOP(pm->op_next);
332 cx->sb_iters = saviters;
334 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
337 cx->sb_orig = orig = RX_SUBBEG(rx);
339 cx->sb_strend = s + (cx->sb_strend - m);
341 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
343 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
344 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
346 sv_catpvn(dstr, s, m-s);
348 cx->sb_s = RX_OFFS(rx)[0].end + orig;
349 { /* Update the pos() information. */
350 SV * const sv = cx->sb_targ;
352 SvUPGRADE(sv, SVt_PVMG);
353 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
354 #ifdef PERL_OLD_COPY_ON_WRITE
356 sv_force_normal_flags(sv, 0);
358 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
361 mg->mg_len = m - orig;
364 (void)ReREFCNT_inc(rx);
365 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
366 rxres_save(&cx->sb_rxres, rx);
367 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
371 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
376 PERL_ARGS_ASSERT_RXRES_SAVE;
379 if (!p || p[1] < RX_NPARENS(rx)) {
380 #ifdef PERL_OLD_COPY_ON_WRITE
381 i = 7 + RX_NPARENS(rx) * 2;
383 i = 6 + RX_NPARENS(rx) * 2;
392 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
393 RX_MATCH_COPIED_off(rx);
395 #ifdef PERL_OLD_COPY_ON_WRITE
396 *p++ = PTR2UV(RX_SAVED_COPY(rx));
397 RX_SAVED_COPY(rx) = NULL;
400 *p++ = RX_NPARENS(rx);
402 *p++ = PTR2UV(RX_SUBBEG(rx));
403 *p++ = (UV)RX_SUBLEN(rx);
404 for (i = 0; i <= RX_NPARENS(rx); ++i) {
405 *p++ = (UV)RX_OFFS(rx)[i].start;
406 *p++ = (UV)RX_OFFS(rx)[i].end;
411 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
416 PERL_ARGS_ASSERT_RXRES_RESTORE;
419 RX_MATCH_COPY_FREE(rx);
420 RX_MATCH_COPIED_set(rx, *p);
423 #ifdef PERL_OLD_COPY_ON_WRITE
424 if (RX_SAVED_COPY(rx))
425 SvREFCNT_dec (RX_SAVED_COPY(rx));
426 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
430 RX_NPARENS(rx) = *p++;
432 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
433 RX_SUBLEN(rx) = (I32)(*p++);
434 for (i = 0; i <= RX_NPARENS(rx); ++i) {
435 RX_OFFS(rx)[i].start = (I32)(*p++);
436 RX_OFFS(rx)[i].end = (I32)(*p++);
441 S_rxres_free(pTHX_ void **rsp)
443 UV * const p = (UV*)*rsp;
445 PERL_ARGS_ASSERT_RXRES_FREE;
450 void *tmp = INT2PTR(char*,*p);
453 PoisonFree(*p, 1, sizeof(*p));
455 Safefree(INT2PTR(char*,*p));
457 #ifdef PERL_OLD_COPY_ON_WRITE
459 SvREFCNT_dec (INT2PTR(SV*,p[1]));
469 dVAR; dSP; dMARK; dORIGMARK;
470 register SV * const tmpForm = *++MARK;
475 register SV *sv = NULL;
476 const char *item = NULL;
480 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
481 const char *chophere = NULL;
482 char *linemark = NULL;
484 bool gotsome = FALSE;
486 const STRLEN fudge = SvPOK(tmpForm)
487 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
488 bool item_is_utf8 = FALSE;
489 bool targ_is_utf8 = FALSE;
491 OP * parseres = NULL;
494 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
495 if (SvREADONLY(tmpForm)) {
496 SvREADONLY_off(tmpForm);
497 parseres = doparseform(tmpForm);
498 SvREADONLY_on(tmpForm);
501 parseres = doparseform(tmpForm);
505 SvPV_force(PL_formtarget, len);
506 if (DO_UTF8(PL_formtarget))
508 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
510 f = SvPV_const(tmpForm, len);
511 /* need to jump to the next word */
512 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
516 const char *name = "???";
519 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
520 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
521 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
522 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
523 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
525 case FF_CHECKNL: name = "CHECKNL"; break;
526 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
527 case FF_SPACE: name = "SPACE"; break;
528 case FF_HALFSPACE: name = "HALFSPACE"; break;
529 case FF_ITEM: name = "ITEM"; break;
530 case FF_CHOP: name = "CHOP"; break;
531 case FF_LINEGLOB: name = "LINEGLOB"; break;
532 case FF_NEWLINE: name = "NEWLINE"; break;
533 case FF_MORE: name = "MORE"; break;
534 case FF_LINEMARK: name = "LINEMARK"; break;
535 case FF_END: name = "END"; break;
536 case FF_0DECIMAL: name = "0DECIMAL"; break;
537 case FF_LINESNGL: name = "LINESNGL"; break;
540 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
542 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
553 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
554 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
556 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
557 t = SvEND(PL_formtarget);
561 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
562 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
564 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
565 t = SvEND(PL_formtarget);
585 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
592 const char *s = item = SvPV_const(sv, len);
595 itemsize = sv_len_utf8(sv);
596 if (itemsize != (I32)len) {
598 if (itemsize > fieldsize) {
599 itemsize = fieldsize;
600 itembytes = itemsize;
601 sv_pos_u2b(sv, &itembytes, 0);
605 send = chophere = s + itembytes;
615 sv_pos_b2u(sv, &itemsize);
619 item_is_utf8 = FALSE;
620 if (itemsize > fieldsize)
621 itemsize = fieldsize;
622 send = chophere = s + itemsize;
636 const char *s = item = SvPV_const(sv, len);
639 itemsize = sv_len_utf8(sv);
640 if (itemsize != (I32)len) {
642 if (itemsize <= fieldsize) {
643 const char *send = chophere = s + itemsize;
656 itemsize = fieldsize;
657 itembytes = itemsize;
658 sv_pos_u2b(sv, &itembytes, 0);
659 send = chophere = s + itembytes;
660 while (s < send || (s == send && isSPACE(*s))) {
670 if (strchr(PL_chopset, *s))
675 itemsize = chophere - item;
676 sv_pos_b2u(sv, &itemsize);
682 item_is_utf8 = FALSE;
683 if (itemsize <= fieldsize) {
684 const char *const send = chophere = s + itemsize;
697 itemsize = fieldsize;
698 send = chophere = s + itemsize;
699 while (s < send || (s == send && isSPACE(*s))) {
709 if (strchr(PL_chopset, *s))
714 itemsize = chophere - item;
720 arg = fieldsize - itemsize;
729 arg = fieldsize - itemsize;
740 const char *s = item;
744 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
746 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
748 t = SvEND(PL_formtarget);
752 if (UTF8_IS_CONTINUED(*s)) {
753 STRLEN skip = UTF8SKIP(s);
770 if ( !((*t++ = *s++) & ~31) )
776 if (targ_is_utf8 && !item_is_utf8) {
777 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
779 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
780 for (; t < SvEND(PL_formtarget); t++) {
793 const int ch = *t++ = *s++;
796 if ( !((*t++ = *s++) & ~31) )
805 const char *s = chophere;
819 const bool oneline = fpc[-1] == FF_LINESNGL;
820 const char *s = item = SvPV_const(sv, len);
821 item_is_utf8 = DO_UTF8(sv);
824 STRLEN to_copy = itemsize;
825 const char *const send = s + len;
826 const U8 *source = (const U8 *) s;
830 chophere = s + itemsize;
834 to_copy = s - SvPVX_const(sv) - 1;
846 if (targ_is_utf8 && !item_is_utf8) {
847 source = tmp = bytes_to_utf8(source, &to_copy);
848 SvCUR_set(PL_formtarget,
849 t - SvPVX_const(PL_formtarget));
851 if (item_is_utf8 && !targ_is_utf8) {
852 /* Upgrade targ to UTF8, and then we reduce it to
853 a problem we have a simple solution for. */
854 SvCUR_set(PL_formtarget,
855 t - SvPVX_const(PL_formtarget));
857 /* Don't need get magic. */
858 sv_utf8_upgrade_nomg(PL_formtarget);
860 SvCUR_set(PL_formtarget,
861 t - SvPVX_const(PL_formtarget));
864 /* Easy. They agree. */
865 assert (item_is_utf8 == targ_is_utf8);
867 SvGROW(PL_formtarget,
868 SvCUR(PL_formtarget) + to_copy + fudge + 1);
869 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
871 Copy(source, t, to_copy, char);
873 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
875 if (SvGMAGICAL(sv)) {
876 /* Mustn't call sv_pos_b2u() as it does a second
877 mg_get(). Is this a bug? Do we need a _flags()
879 itemsize = utf8_length(source, source + itemsize);
881 sv_pos_b2u(sv, &itemsize);
893 #if defined(USE_LONG_DOUBLE)
896 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
900 "%#0*.*f" : "%0*.*f");
905 #if defined(USE_LONG_DOUBLE)
907 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
910 ((arg & 256) ? "%#*.*f" : "%*.*f");
913 /* If the field is marked with ^ and the value is undefined,
915 if ((arg & 512) && !SvOK(sv)) {
923 /* overflow evidence */
924 if (num_overflow(value, fieldsize, arg)) {
930 /* Formats aren't yet marked for locales, so assume "yes". */
932 STORE_NUMERIC_STANDARD_SET_LOCAL();
933 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
934 RESTORE_NUMERIC_STANDARD();
941 while (t-- > linemark && *t == ' ') ;
949 if (arg) { /* repeat until fields exhausted? */
951 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
952 lines += FmLINES(PL_formtarget);
954 SvUTF8_on(PL_formtarget);
955 FmLINES(PL_formtarget) = lines;
957 RETURNOP(cLISTOP->op_first);
968 const char *s = chophere;
969 const char *send = item + len;
971 while (isSPACE(*s) && (s < send))
976 arg = fieldsize - itemsize;
983 if (strnEQ(s1," ",3)) {
984 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
995 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
997 SvUTF8_on(PL_formtarget);
998 FmLINES(PL_formtarget) += lines;
1010 if (PL_stack_base + *PL_markstack_ptr == SP) {
1012 if (GIMME_V == G_SCALAR)
1014 RETURNOP(PL_op->op_next->op_next);
1016 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
1017 pp_pushmark(); /* push dst */
1018 pp_pushmark(); /* push src */
1019 ENTER_with_name("grep"); /* enter outer scope */
1022 if (PL_op->op_private & OPpGREP_LEX)
1023 SAVESPTR(PAD_SVl(PL_op->op_targ));
1026 ENTER_with_name("grep_item"); /* enter inner scope */
1029 src = PL_stack_base[*PL_markstack_ptr];
1031 if (PL_op->op_private & OPpGREP_LEX)
1032 PAD_SVl(PL_op->op_targ) = src;
1037 if (PL_op->op_type == OP_MAPSTART)
1038 pp_pushmark(); /* push top */
1039 return ((LOGOP*)PL_op->op_next)->op_other;
1045 const I32 gimme = GIMME_V;
1046 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1052 /* first, move source pointer to the next item in the source list */
1053 ++PL_markstack_ptr[-1];
1055 /* if there are new items, push them into the destination list */
1056 if (items && gimme != G_VOID) {
1057 /* might need to make room back there first */
1058 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1059 /* XXX this implementation is very pessimal because the stack
1060 * is repeatedly extended for every set of items. Is possible
1061 * to do this without any stack extension or copying at all
1062 * by maintaining a separate list over which the map iterates
1063 * (like foreach does). --gsar */
1065 /* everything in the stack after the destination list moves
1066 * towards the end the stack by the amount of room needed */
1067 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1069 /* items to shift up (accounting for the moved source pointer) */
1070 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1072 /* This optimization is by Ben Tilly and it does
1073 * things differently from what Sarathy (gsar)
1074 * is describing. The downside of this optimization is
1075 * that leaves "holes" (uninitialized and hopefully unused areas)
1076 * to the Perl stack, but on the other hand this
1077 * shouldn't be a problem. If Sarathy's idea gets
1078 * implemented, this optimization should become
1079 * irrelevant. --jhi */
1081 shift = count; /* Avoid shifting too often --Ben Tilly */
1085 dst = (SP += shift);
1086 PL_markstack_ptr[-1] += shift;
1087 *PL_markstack_ptr += shift;
1091 /* copy the new items down to the destination list */
1092 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1093 if (gimme == G_ARRAY) {
1095 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1098 /* scalar context: we don't care about which values map returns
1099 * (we use undef here). And so we certainly don't want to do mortal
1100 * copies of meaningless values. */
1101 while (items-- > 0) {
1103 *dst-- = &PL_sv_undef;
1107 LEAVE_with_name("grep_item"); /* exit inner scope */
1110 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1112 (void)POPMARK; /* pop top */
1113 LEAVE_with_name("grep"); /* exit outer scope */
1114 (void)POPMARK; /* pop src */
1115 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1116 (void)POPMARK; /* pop dst */
1117 SP = PL_stack_base + POPMARK; /* pop original mark */
1118 if (gimme == G_SCALAR) {
1119 if (PL_op->op_private & OPpGREP_LEX) {
1120 SV* sv = sv_newmortal();
1121 sv_setiv(sv, items);
1129 else if (gimme == G_ARRAY)
1136 ENTER_with_name("grep_item"); /* enter inner scope */
1139 /* set $_ to the new source item */
1140 src = PL_stack_base[PL_markstack_ptr[-1]];
1142 if (PL_op->op_private & OPpGREP_LEX)
1143 PAD_SVl(PL_op->op_targ) = src;
1147 RETURNOP(cLOGOP->op_other);
1156 if (GIMME == G_ARRAY)
1158 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1159 return cLOGOP->op_other;
1169 if (GIMME == G_ARRAY) {
1170 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1174 SV * const targ = PAD_SV(PL_op->op_targ);
1177 if (PL_op->op_private & OPpFLIP_LINENUM) {
1178 if (GvIO(PL_last_in_gv)) {
1179 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1182 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1184 flip = SvIV(sv) == SvIV(GvSV(gv));
1190 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1191 if (PL_op->op_flags & OPf_SPECIAL) {
1199 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1202 sv_setpvs(TARG, "");
1208 /* This code tries to decide if "$left .. $right" should use the
1209 magical string increment, or if the range is numeric (we make
1210 an exception for .."0" [#18165]). AMS 20021031. */
1212 #define RANGE_IS_NUMERIC(left,right) ( \
1213 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1214 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1215 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1216 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1217 && (!SvOK(right) || looks_like_number(right))))
1223 if (GIMME == G_ARRAY) {
1229 if (RANGE_IS_NUMERIC(left,right)) {
1232 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1233 (SvOK(right) && SvNV(right) > IV_MAX))
1234 DIE(aTHX_ "Range iterator outside integer range");
1245 SV * const sv = sv_2mortal(newSViv(i++));
1250 SV * const final = sv_mortalcopy(right);
1252 const char * const tmps = SvPV_const(final, len);
1254 SV *sv = sv_mortalcopy(left);
1255 SvPV_force_nolen(sv);
1256 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1258 if (strEQ(SvPVX_const(sv),tmps))
1260 sv = sv_2mortal(newSVsv(sv));
1267 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1271 if (PL_op->op_private & OPpFLIP_LINENUM) {
1272 if (GvIO(PL_last_in_gv)) {
1273 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1276 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1277 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1285 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1286 sv_catpvs(targ, "E0");
1296 static const char * const context_name[] = {
1298 NULL, /* CXt_WHEN never actually needs "block" */
1299 NULL, /* CXt_BLOCK never actually needs "block" */
1300 NULL, /* CXt_GIVEN never actually needs "block" */
1301 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1302 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1303 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1304 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1312 S_dopoptolabel(pTHX_ const char *label)
1317 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1319 for (i = cxstack_ix; i >= 0; i--) {
1320 register const PERL_CONTEXT * const cx = &cxstack[i];
1321 switch (CxTYPE(cx)) {
1327 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1328 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1329 if (CxTYPE(cx) == CXt_NULL)
1332 case CXt_LOOP_LAZYIV:
1333 case CXt_LOOP_LAZYSV:
1335 case CXt_LOOP_PLAIN:
1337 const char *cx_label = CxLABEL(cx);
1338 if (!cx_label || strNE(label, cx_label) ) {
1339 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1340 (long)i, cx_label));
1343 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1354 Perl_dowantarray(pTHX)
1357 const I32 gimme = block_gimme();
1358 return (gimme == G_VOID) ? G_SCALAR : gimme;
1362 Perl_block_gimme(pTHX)
1365 const I32 cxix = dopoptosub(cxstack_ix);
1369 switch (cxstack[cxix].blk_gimme) {
1377 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1384 Perl_is_lvalue_sub(pTHX)
1387 const I32 cxix = dopoptosub(cxstack_ix);
1388 assert(cxix >= 0); /* We should only be called from inside subs */
1390 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1391 return CxLVAL(cxstack + cxix);
1397 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1402 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1404 for (i = startingblock; i >= 0; i--) {
1405 register const PERL_CONTEXT * const cx = &cxstk[i];
1406 switch (CxTYPE(cx)) {
1412 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1420 S_dopoptoeval(pTHX_ I32 startingblock)
1424 for (i = startingblock; i >= 0; i--) {
1425 register const PERL_CONTEXT *cx = &cxstack[i];
1426 switch (CxTYPE(cx)) {
1430 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1438 S_dopoptoloop(pTHX_ I32 startingblock)
1442 for (i = startingblock; i >= 0; i--) {
1443 register const PERL_CONTEXT * const cx = &cxstack[i];
1444 switch (CxTYPE(cx)) {
1450 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1451 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1452 if ((CxTYPE(cx)) == CXt_NULL)
1455 case CXt_LOOP_LAZYIV:
1456 case CXt_LOOP_LAZYSV:
1458 case CXt_LOOP_PLAIN:
1459 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1467 S_dopoptogiven(pTHX_ I32 startingblock)
1471 for (i = startingblock; i >= 0; i--) {
1472 register const PERL_CONTEXT *cx = &cxstack[i];
1473 switch (CxTYPE(cx)) {
1477 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1479 case CXt_LOOP_PLAIN:
1480 assert(!CxFOREACHDEF(cx));
1482 case CXt_LOOP_LAZYIV:
1483 case CXt_LOOP_LAZYSV:
1485 if (CxFOREACHDEF(cx)) {
1486 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1495 S_dopoptowhen(pTHX_ I32 startingblock)
1499 for (i = startingblock; i >= 0; i--) {
1500 register const PERL_CONTEXT *cx = &cxstack[i];
1501 switch (CxTYPE(cx)) {
1505 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1513 Perl_dounwind(pTHX_ I32 cxix)
1518 while (cxstack_ix > cxix) {
1520 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1521 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1522 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1523 /* Note: we don't need to restore the base context info till the end. */
1524 switch (CxTYPE(cx)) {
1527 continue; /* not break */
1535 case CXt_LOOP_LAZYIV:
1536 case CXt_LOOP_LAZYSV:
1538 case CXt_LOOP_PLAIN:
1549 PERL_UNUSED_VAR(optype);
1553 Perl_qerror(pTHX_ SV *err)
1557 PERL_ARGS_ASSERT_QERROR;
1560 sv_catsv(ERRSV, err);
1562 sv_catsv(PL_errors, err);
1564 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1566 ++PL_parser->error_count;
1570 Perl_die_where(pTHX_ SV *msv)
1579 if (PL_in_eval & EVAL_KEEPERR) {
1580 static const char prefix[] = "\t(in cleanup) ";
1581 SV * const err = ERRSV;
1582 const char *e = NULL;
1585 else if (SvCUR(err) >= sizeof(prefix)+SvCUR(msv)-1) {
1588 const char* message = SvPV_const(msv, msglen);
1589 e = SvPV_const(err, len);
1591 if (*e != *message || strNE(e,message))
1596 SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(msv));
1597 sv_catpvn(err, prefix, sizeof(prefix)-1);
1599 start = SvCUR(err)-SvCUR(msv)-sizeof(prefix)+1;
1600 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s",
1601 SvPVX_const(err)+start);
1606 const char* message = SvPV_const(msv, msglen);
1607 sv_setpvn(ERRSV, message, msglen);
1608 SvFLAGS(ERRSV) |= SvFLAGS(msv) & SVf_UTF8;
1612 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1613 && PL_curstackinfo->si_prev)
1621 register PERL_CONTEXT *cx;
1624 if (cxix < cxstack_ix)
1627 POPBLOCK(cx,PL_curpm);
1628 if (CxTYPE(cx) != CXt_EVAL) {
1630 const char* message = SvPVx_const( msv ? msv : ERRSV, msglen);
1631 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1632 PerlIO_write(Perl_error_log, message, msglen);
1637 if (gimme == G_SCALAR)
1638 *++newsp = &PL_sv_undef;
1639 PL_stack_sp = newsp;
1643 /* LEAVE could clobber PL_curcop (see save_re_context())
1644 * XXX it might be better to find a way to avoid messing with
1645 * PL_curcop in save_re_context() instead, but this is a more
1646 * minimal fix --GSAR */
1647 PL_curcop = cx->blk_oldcop;
1649 if (optype == OP_REQUIRE) {
1650 const char* const msg = SvPVx_nolen_const(ERRSV);
1651 SV * const nsv = cx->blk_eval.old_namesv;
1652 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1654 DIE(aTHX_ "%sCompilation failed in require",
1655 *msg ? msg : "Unknown error\n");
1657 assert(CxTYPE(cx) == CXt_EVAL);
1658 PL_restartop = cx->blk_eval.retop;
1664 write_to_stderr( msv ? msv : ERRSV );
1671 dVAR; dSP; dPOPTOPssrl;
1672 if (SvTRUE(left) != SvTRUE(right))
1682 register I32 cxix = dopoptosub(cxstack_ix);
1683 register const PERL_CONTEXT *cx;
1684 register const PERL_CONTEXT *ccstack = cxstack;
1685 const PERL_SI *top_si = PL_curstackinfo;
1687 const char *stashname;
1694 /* we may be in a higher stacklevel, so dig down deeper */
1695 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1696 top_si = top_si->si_prev;
1697 ccstack = top_si->si_cxstack;
1698 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1701 if (GIMME != G_ARRAY) {
1707 /* caller() should not report the automatic calls to &DB::sub */
1708 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1709 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1713 cxix = dopoptosub_at(ccstack, cxix - 1);
1716 cx = &ccstack[cxix];
1717 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1718 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1719 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1720 field below is defined for any cx. */
1721 /* caller() should not report the automatic calls to &DB::sub */
1722 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1723 cx = &ccstack[dbcxix];
1726 stashname = CopSTASHPV(cx->blk_oldcop);
1727 if (GIMME != G_ARRAY) {
1730 PUSHs(&PL_sv_undef);
1733 sv_setpv(TARG, stashname);
1742 PUSHs(&PL_sv_undef);
1744 mPUSHs(newSVpv(stashname, 0));
1745 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1746 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1749 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1750 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1751 /* So is ccstack[dbcxix]. */
1753 SV * const sv = newSV(0);
1754 gv_efullname3(sv, cvgv, NULL);
1756 PUSHs(boolSV(CxHASARGS(cx)));
1759 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1760 PUSHs(boolSV(CxHASARGS(cx)));
1764 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1767 gimme = (I32)cx->blk_gimme;
1768 if (gimme == G_VOID)
1769 PUSHs(&PL_sv_undef);
1771 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1772 if (CxTYPE(cx) == CXt_EVAL) {
1774 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1775 PUSHs(cx->blk_eval.cur_text);
1779 else if (cx->blk_eval.old_namesv) {
1780 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1783 /* eval BLOCK (try blocks have old_namesv == 0) */
1785 PUSHs(&PL_sv_undef);
1786 PUSHs(&PL_sv_undef);
1790 PUSHs(&PL_sv_undef);
1791 PUSHs(&PL_sv_undef);
1793 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1794 && CopSTASH_eq(PL_curcop, PL_debstash))
1796 AV * const ary = cx->blk_sub.argarray;
1797 const int off = AvARRAY(ary) - AvALLOC(ary);
1800 PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
1802 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1805 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1806 av_extend(PL_dbargs, AvFILLp(ary) + off);
1807 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1808 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1810 /* XXX only hints propagated via op_private are currently
1811 * visible (others are not easily accessible, since they
1812 * use the global PL_hints) */
1813 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1816 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1818 if (old_warnings == pWARN_NONE ||
1819 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1820 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1821 else if (old_warnings == pWARN_ALL ||
1822 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1823 /* Get the bit mask for $warnings::Bits{all}, because
1824 * it could have been extended by warnings::register */
1826 HV * const bits = get_hv("warnings::Bits", 0);
1827 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1828 mask = newSVsv(*bits_all);
1831 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1835 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1839 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1840 sv_2mortal(newRV_noinc(
1841 MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1842 cx->blk_oldcop->cop_hints_hash))))
1851 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1852 sv_reset(tmps, CopSTASH(PL_curcop));
1857 /* like pp_nextstate, but used instead when the debugger is active */
1862 PL_curcop = (COP*)PL_op;
1863 TAINT_NOT; /* Each statement is presumed innocent */
1864 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1867 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1868 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1871 register PERL_CONTEXT *cx;
1872 const I32 gimme = G_ARRAY;
1874 GV * const gv = PL_DBgv;
1875 register CV * const cv = GvCV(gv);
1878 DIE(aTHX_ "No DB::DB routine defined");
1880 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1881 /* don't do recursive DB::DB call */
1896 (void)(*CvXSUB(cv))(aTHX_ cv);
1903 PUSHBLOCK(cx, CXt_SUB, SP);
1905 cx->blk_sub.retop = PL_op->op_next;
1908 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1909 RETURNOP(CvSTART(cv));
1919 register PERL_CONTEXT *cx;
1920 const I32 gimme = GIMME_V;
1922 U8 cxtype = CXt_LOOP_FOR;
1927 ENTER_with_name("loop1");
1930 if (PL_op->op_targ) {
1931 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1932 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1933 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1934 SVs_PADSTALE, SVs_PADSTALE);
1936 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1937 #ifndef USE_ITHREADS
1938 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1944 GV * const gv = MUTABLE_GV(POPs);
1945 svp = &GvSV(gv); /* symbol table variable */
1946 SAVEGENERICSV(*svp);
1949 iterdata = (PAD*)gv;
1953 if (PL_op->op_private & OPpITER_DEF)
1954 cxtype |= CXp_FOR_DEF;
1956 ENTER_with_name("loop2");
1958 PUSHBLOCK(cx, cxtype, SP);
1960 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1962 PUSHLOOP_FOR(cx, svp, MARK, 0);
1964 if (PL_op->op_flags & OPf_STACKED) {
1965 SV *maybe_ary = POPs;
1966 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1968 SV * const right = maybe_ary;
1971 if (RANGE_IS_NUMERIC(sv,right)) {
1972 cx->cx_type &= ~CXTYPEMASK;
1973 cx->cx_type |= CXt_LOOP_LAZYIV;
1974 /* Make sure that no-one re-orders cop.h and breaks our
1976 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1977 #ifdef NV_PRESERVES_UV
1978 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1979 (SvNV(sv) > (NV)IV_MAX)))
1981 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1982 (SvNV(right) < (NV)IV_MIN))))
1984 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1987 ((SvUV(sv) > (UV)IV_MAX) ||
1988 (SvNV(sv) > (NV)UV_MAX)))))
1990 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1992 ((SvNV(right) > 0) &&
1993 ((SvUV(right) > (UV)IV_MAX) ||
1994 (SvNV(right) > (NV)UV_MAX))))))
1996 DIE(aTHX_ "Range iterator outside integer range");
1997 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1998 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
2000 /* for correct -Dstv display */
2001 cx->blk_oldsp = sp - PL_stack_base;
2005 cx->cx_type &= ~CXTYPEMASK;
2006 cx->cx_type |= CXt_LOOP_LAZYSV;
2007 /* Make sure that no-one re-orders cop.h and breaks our
2009 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2010 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2011 cx->blk_loop.state_u.lazysv.end = right;
2012 SvREFCNT_inc(right);
2013 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2014 /* This will do the upgrade to SVt_PV, and warn if the value
2015 is uninitialised. */
2016 (void) SvPV_nolen_const(right);
2017 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2018 to replace !SvOK() with a pointer to "". */
2020 SvREFCNT_dec(right);
2021 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2025 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2026 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2027 SvREFCNT_inc(maybe_ary);
2028 cx->blk_loop.state_u.ary.ix =
2029 (PL_op->op_private & OPpITER_REVERSED) ?
2030 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2034 else { /* iterating over items on the stack */
2035 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2036 if (PL_op->op_private & OPpITER_REVERSED) {
2037 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2040 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2050 register PERL_CONTEXT *cx;
2051 const I32 gimme = GIMME_V;
2053 ENTER_with_name("loop1");
2055 ENTER_with_name("loop2");
2057 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2058 PUSHLOOP_PLAIN(cx, SP);
2066 register PERL_CONTEXT *cx;
2073 assert(CxTYPE_is_LOOP(cx));
2075 newsp = PL_stack_base + cx->blk_loop.resetsp;
2078 if (gimme == G_VOID)
2080 else if (gimme == G_SCALAR) {
2082 *++newsp = sv_mortalcopy(*SP);
2084 *++newsp = &PL_sv_undef;
2088 *++newsp = sv_mortalcopy(*++mark);
2089 TAINT_NOT; /* Each item is independent */
2095 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2096 PL_curpm = newpm; /* ... and pop $1 et al */
2098 LEAVE_with_name("loop2");
2099 LEAVE_with_name("loop1");
2107 register PERL_CONTEXT *cx;
2108 bool popsub2 = FALSE;
2109 bool clear_errsv = FALSE;
2117 const I32 cxix = dopoptosub(cxstack_ix);
2120 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2121 * sort block, which is a CXt_NULL
2124 PL_stack_base[1] = *PL_stack_sp;
2125 PL_stack_sp = PL_stack_base + 1;
2129 DIE(aTHX_ "Can't return outside a subroutine");
2131 if (cxix < cxstack_ix)
2134 if (CxMULTICALL(&cxstack[cxix])) {
2135 gimme = cxstack[cxix].blk_gimme;
2136 if (gimme == G_VOID)
2137 PL_stack_sp = PL_stack_base;
2138 else if (gimme == G_SCALAR) {
2139 PL_stack_base[1] = *PL_stack_sp;
2140 PL_stack_sp = PL_stack_base + 1;
2146 switch (CxTYPE(cx)) {
2149 retop = cx->blk_sub.retop;
2150 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2153 if (!(PL_in_eval & EVAL_KEEPERR))
2156 retop = cx->blk_eval.retop;
2160 if (optype == OP_REQUIRE &&
2161 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2163 /* Unassume the success we assumed earlier. */
2164 SV * const nsv = cx->blk_eval.old_namesv;
2165 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2166 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2171 retop = cx->blk_sub.retop;
2174 DIE(aTHX_ "panic: return");
2178 if (gimme == G_SCALAR) {
2181 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2183 *++newsp = SvREFCNT_inc(*SP);
2188 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2190 *++newsp = sv_mortalcopy(sv);
2195 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2198 *++newsp = sv_mortalcopy(*SP);
2201 *++newsp = &PL_sv_undef;
2203 else if (gimme == G_ARRAY) {
2204 while (++MARK <= SP) {
2205 *++newsp = (popsub2 && SvTEMP(*MARK))
2206 ? *MARK : sv_mortalcopy(*MARK);
2207 TAINT_NOT; /* Each item is independent */
2210 PL_stack_sp = newsp;
2213 /* Stack values are safe: */
2216 POPSUB(cx,sv); /* release CV and @_ ... */
2220 PL_curpm = newpm; /* ... and pop $1 et al */
2233 register PERL_CONTEXT *cx;
2244 if (PL_op->op_flags & OPf_SPECIAL) {
2245 cxix = dopoptoloop(cxstack_ix);
2247 DIE(aTHX_ "Can't \"last\" outside a loop block");
2250 cxix = dopoptolabel(cPVOP->op_pv);
2252 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2254 if (cxix < cxstack_ix)
2258 cxstack_ix++; /* temporarily protect top context */
2260 switch (CxTYPE(cx)) {
2261 case CXt_LOOP_LAZYIV:
2262 case CXt_LOOP_LAZYSV:
2264 case CXt_LOOP_PLAIN:
2266 newsp = PL_stack_base + cx->blk_loop.resetsp;
2267 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2271 nextop = cx->blk_sub.retop;
2275 nextop = cx->blk_eval.retop;
2279 nextop = cx->blk_sub.retop;
2282 DIE(aTHX_ "panic: last");
2286 if (gimme == G_SCALAR) {
2288 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2289 ? *SP : sv_mortalcopy(*SP);
2291 *++newsp = &PL_sv_undef;
2293 else if (gimme == G_ARRAY) {
2294 while (++MARK <= SP) {
2295 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2296 ? *MARK : sv_mortalcopy(*MARK);
2297 TAINT_NOT; /* Each item is independent */
2305 /* Stack values are safe: */
2307 case CXt_LOOP_LAZYIV:
2308 case CXt_LOOP_PLAIN:
2309 case CXt_LOOP_LAZYSV:
2311 POPLOOP(cx); /* release loop vars ... */
2315 POPSUB(cx,sv); /* release CV and @_ ... */
2318 PL_curpm = newpm; /* ... and pop $1 et al */
2321 PERL_UNUSED_VAR(optype);
2322 PERL_UNUSED_VAR(gimme);
2330 register PERL_CONTEXT *cx;
2333 if (PL_op->op_flags & OPf_SPECIAL) {
2334 cxix = dopoptoloop(cxstack_ix);
2336 DIE(aTHX_ "Can't \"next\" outside a loop block");
2339 cxix = dopoptolabel(cPVOP->op_pv);
2341 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2343 if (cxix < cxstack_ix)
2346 /* clear off anything above the scope we're re-entering, but
2347 * save the rest until after a possible continue block */
2348 inner = PL_scopestack_ix;
2350 if (PL_scopestack_ix < inner)
2351 leave_scope(PL_scopestack[PL_scopestack_ix]);
2352 PL_curcop = cx->blk_oldcop;
2353 return CX_LOOP_NEXTOP_GET(cx);
2360 register PERL_CONTEXT *cx;
2364 if (PL_op->op_flags & OPf_SPECIAL) {
2365 cxix = dopoptoloop(cxstack_ix);
2367 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2370 cxix = dopoptolabel(cPVOP->op_pv);
2372 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2374 if (cxix < cxstack_ix)
2377 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2378 if (redo_op->op_type == OP_ENTER) {
2379 /* pop one less context to avoid $x being freed in while (my $x..) */
2381 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2382 redo_op = redo_op->op_next;
2386 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2387 LEAVE_SCOPE(oldsave);
2389 PL_curcop = cx->blk_oldcop;
2394 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2398 static const char too_deep[] = "Target of goto is too deeply nested";
2400 PERL_ARGS_ASSERT_DOFINDLABEL;
2403 Perl_croak(aTHX_ too_deep);
2404 if (o->op_type == OP_LEAVE ||
2405 o->op_type == OP_SCOPE ||
2406 o->op_type == OP_LEAVELOOP ||
2407 o->op_type == OP_LEAVESUB ||
2408 o->op_type == OP_LEAVETRY)
2410 *ops++ = cUNOPo->op_first;
2412 Perl_croak(aTHX_ too_deep);
2415 if (o->op_flags & OPf_KIDS) {
2417 /* First try all the kids at this level, since that's likeliest. */
2418 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2419 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2420 const char *kid_label = CopLABEL(kCOP);
2421 if (kid_label && strEQ(kid_label, label))
2425 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2426 if (kid == PL_lastgotoprobe)
2428 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2431 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2432 ops[-1]->op_type == OP_DBSTATE)
2437 if ((o = dofindlabel(kid, label, ops, oplimit)))
2450 register PERL_CONTEXT *cx;
2451 #define GOTO_DEPTH 64
2452 OP *enterops[GOTO_DEPTH];
2453 const char *label = NULL;
2454 const bool do_dump = (PL_op->op_type == OP_DUMP);
2455 static const char must_have_label[] = "goto must have label";
2457 if (PL_op->op_flags & OPf_STACKED) {
2458 SV * const sv = POPs;
2460 /* This egregious kludge implements goto &subroutine */
2461 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2463 register PERL_CONTEXT *cx;
2464 CV *cv = MUTABLE_CV(SvRV(sv));
2471 if (!CvROOT(cv) && !CvXSUB(cv)) {
2472 const GV * const gv = CvGV(cv);
2476 /* autoloaded stub? */
2477 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2479 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2480 GvNAMELEN(gv), FALSE);
2481 if (autogv && (cv = GvCV(autogv)))
2483 tmpstr = sv_newmortal();
2484 gv_efullname3(tmpstr, gv, NULL);
2485 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2487 DIE(aTHX_ "Goto undefined subroutine");
2490 /* First do some returnish stuff. */
2491 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2493 cxix = dopoptosub(cxstack_ix);
2495 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2496 if (cxix < cxstack_ix)
2500 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2501 if (CxTYPE(cx) == CXt_EVAL) {
2503 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2505 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2507 else if (CxMULTICALL(cx))
2508 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2509 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2510 /* put @_ back onto stack */
2511 AV* av = cx->blk_sub.argarray;
2513 items = AvFILLp(av) + 1;
2514 EXTEND(SP, items+1); /* @_ could have been extended. */
2515 Copy(AvARRAY(av), SP + 1, items, SV*);
2516 SvREFCNT_dec(GvAV(PL_defgv));
2517 GvAV(PL_defgv) = cx->blk_sub.savearray;
2519 /* abandon @_ if it got reified */
2524 av_extend(av, items-1);
2526 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2529 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2530 AV* const av = GvAV(PL_defgv);
2531 items = AvFILLp(av) + 1;
2532 EXTEND(SP, items+1); /* @_ could have been extended. */
2533 Copy(AvARRAY(av), SP + 1, items, SV*);
2537 if (CxTYPE(cx) == CXt_SUB &&
2538 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2539 SvREFCNT_dec(cx->blk_sub.cv);
2540 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2541 LEAVE_SCOPE(oldsave);
2543 /* Now do some callish stuff. */
2545 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2547 OP* const retop = cx->blk_sub.retop;
2552 for (index=0; index<items; index++)
2553 sv_2mortal(SP[-index]);
2556 /* XS subs don't have a CxSUB, so pop it */
2557 POPBLOCK(cx, PL_curpm);
2558 /* Push a mark for the start of arglist */
2561 (void)(*CvXSUB(cv))(aTHX_ cv);
2566 AV* const padlist = CvPADLIST(cv);
2567 if (CxTYPE(cx) == CXt_EVAL) {
2568 PL_in_eval = CxOLD_IN_EVAL(cx);
2569 PL_eval_root = cx->blk_eval.old_eval_root;
2570 cx->cx_type = CXt_SUB;
2572 cx->blk_sub.cv = cv;
2573 cx->blk_sub.olddepth = CvDEPTH(cv);
2576 if (CvDEPTH(cv) < 2)
2577 SvREFCNT_inc_simple_void_NN(cv);
2579 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2580 sub_crush_depth(cv);
2581 pad_push(padlist, CvDEPTH(cv));
2584 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2587 AV *const av = MUTABLE_AV(PAD_SVl(0));
2589 cx->blk_sub.savearray = GvAV(PL_defgv);
2590 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2591 CX_CURPAD_SAVE(cx->blk_sub);
2592 cx->blk_sub.argarray = av;
2594 if (items >= AvMAX(av) + 1) {
2595 SV **ary = AvALLOC(av);
2596 if (AvARRAY(av) != ary) {
2597 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2600 if (items >= AvMAX(av) + 1) {
2601 AvMAX(av) = items - 1;
2602 Renew(ary,items+1,SV*);
2608 Copy(mark,AvARRAY(av),items,SV*);
2609 AvFILLp(av) = items - 1;
2610 assert(!AvREAL(av));
2612 /* transfer 'ownership' of refcnts to new @_ */
2622 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2623 Perl_get_db_sub(aTHX_ NULL, cv);
2625 CV * const gotocv = get_cvs("DB::goto", 0);
2627 PUSHMARK( PL_stack_sp );
2628 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2633 RETURNOP(CvSTART(cv));
2637 label = SvPV_nolen_const(sv);
2638 if (!(do_dump || *label))
2639 DIE(aTHX_ must_have_label);
2642 else if (PL_op->op_flags & OPf_SPECIAL) {
2644 DIE(aTHX_ must_have_label);
2647 label = cPVOP->op_pv;
2649 if (label && *label) {
2650 OP *gotoprobe = NULL;
2651 bool leaving_eval = FALSE;
2652 bool in_block = FALSE;
2653 PERL_CONTEXT *last_eval_cx = NULL;
2657 PL_lastgotoprobe = NULL;
2659 for (ix = cxstack_ix; ix >= 0; ix--) {
2661 switch (CxTYPE(cx)) {
2663 leaving_eval = TRUE;
2664 if (!CxTRYBLOCK(cx)) {
2665 gotoprobe = (last_eval_cx ?
2666 last_eval_cx->blk_eval.old_eval_root :
2671 /* else fall through */
2672 case CXt_LOOP_LAZYIV:
2673 case CXt_LOOP_LAZYSV:
2675 case CXt_LOOP_PLAIN:
2678 gotoprobe = cx->blk_oldcop->op_sibling;
2684 gotoprobe = cx->blk_oldcop->op_sibling;
2687 gotoprobe = PL_main_root;
2690 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2691 gotoprobe = CvROOT(cx->blk_sub.cv);
2697 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2700 DIE(aTHX_ "panic: goto");
2701 gotoprobe = PL_main_root;
2705 retop = dofindlabel(gotoprobe, label,
2706 enterops, enterops + GOTO_DEPTH);
2710 PL_lastgotoprobe = gotoprobe;
2713 DIE(aTHX_ "Can't find label %s", label);
2715 /* if we're leaving an eval, check before we pop any frames
2716 that we're not going to punt, otherwise the error
2719 if (leaving_eval && *enterops && enterops[1]) {
2721 for (i = 1; enterops[i]; i++)
2722 if (enterops[i]->op_type == OP_ENTERITER)
2723 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2726 if (*enterops && enterops[1]) {
2727 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2729 deprecate("\"goto\" to jump into a construct");
2732 /* pop unwanted frames */
2734 if (ix < cxstack_ix) {
2741 oldsave = PL_scopestack[PL_scopestack_ix];
2742 LEAVE_SCOPE(oldsave);
2745 /* push wanted frames */
2747 if (*enterops && enterops[1]) {
2748 OP * const oldop = PL_op;
2749 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2750 for (; enterops[ix]; ix++) {
2751 PL_op = enterops[ix];
2752 /* Eventually we may want to stack the needed arguments
2753 * for each op. For now, we punt on the hard ones. */
2754 if (PL_op->op_type == OP_ENTERITER)
2755 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2756 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2764 if (!retop) retop = PL_main_start;
2766 PL_restartop = retop;
2767 PL_do_undump = TRUE;
2771 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2772 PL_do_undump = FALSE;
2789 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2791 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2794 PL_exit_flags |= PERL_EXIT_EXPECTED;
2796 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2797 if (anum || !(PL_minus_c && PL_madskills))
2802 PUSHs(&PL_sv_undef);
2809 S_save_lines(pTHX_ AV *array, SV *sv)
2811 const char *s = SvPVX_const(sv);
2812 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2815 PERL_ARGS_ASSERT_SAVE_LINES;
2817 while (s && s < send) {
2819 SV * const tmpstr = newSV_type(SVt_PVMG);
2821 t = (const char *)memchr(s, '\n', send - s);
2827 sv_setpvn(tmpstr, s, t - s);
2828 av_store(array, line++, tmpstr);
2834 S_docatch(pTHX_ OP *o)
2838 OP * const oldop = PL_op;
2842 assert(CATCH_GET == TRUE);
2849 assert(cxstack_ix >= 0);
2850 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2851 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2856 /* die caught by an inner eval - continue inner loop */
2858 /* NB XXX we rely on the old popped CxEVAL still being at the top
2859 * of the stack; the way die_where() currently works, this
2860 * assumption is valid. In theory The cur_top_env value should be
2861 * returned in another global, the way retop (aka PL_restartop)
2863 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2866 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2868 PL_op = PL_restartop;
2885 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2886 /* sv Text to convert to OP tree. */
2887 /* startop op_free() this to undo. */
2888 /* code Short string id of the caller. */
2890 /* FIXME - how much of this code is common with pp_entereval? */
2891 dVAR; dSP; /* Make POPBLOCK work. */
2897 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2898 char *tmpbuf = tbuf;
2901 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2904 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2906 ENTER_with_name("eval");
2907 lex_start(sv, NULL, FALSE);
2909 /* switch to eval mode */
2911 if (IN_PERL_COMPILETIME) {
2912 SAVECOPSTASH_FREE(&PL_compiling);
2913 CopSTASH_set(&PL_compiling, PL_curstash);
2915 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2916 SV * const sv = sv_newmortal();
2917 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2918 code, (unsigned long)++PL_evalseq,
2919 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2924 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2925 (unsigned long)++PL_evalseq);
2926 SAVECOPFILE_FREE(&PL_compiling);
2927 CopFILE_set(&PL_compiling, tmpbuf+2);
2928 SAVECOPLINE(&PL_compiling);
2929 CopLINE_set(&PL_compiling, 1);
2930 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2931 deleting the eval's FILEGV from the stash before gv_check() runs
2932 (i.e. before run-time proper). To work around the coredump that
2933 ensues, we always turn GvMULTI_on for any globals that were
2934 introduced within evals. See force_ident(). GSAR 96-10-12 */
2935 safestr = savepvn(tmpbuf, len);
2936 SAVEDELETE(PL_defstash, safestr, len);
2938 #ifdef OP_IN_REGISTER
2944 /* we get here either during compilation, or via pp_regcomp at runtime */
2945 runtime = IN_PERL_RUNTIME;
2947 runcv = find_runcv(NULL);
2950 PL_op->op_type = OP_ENTEREVAL;
2951 PL_op->op_flags = 0; /* Avoid uninit warning. */
2952 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2956 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2958 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2959 POPBLOCK(cx,PL_curpm);
2962 (*startop)->op_type = OP_NULL;
2963 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2965 /* XXX DAPM do this properly one year */
2966 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2967 LEAVE_with_name("eval");
2968 if (IN_PERL_COMPILETIME)
2969 CopHINTS_set(&PL_compiling, PL_hints);
2970 #ifdef OP_IN_REGISTER
2973 PERL_UNUSED_VAR(newsp);
2974 PERL_UNUSED_VAR(optype);
2976 return PL_eval_start;
2981 =for apidoc find_runcv
2983 Locate the CV corresponding to the currently executing sub or eval.
2984 If db_seqp is non_null, skip CVs that are in the DB package and populate
2985 *db_seqp with the cop sequence number at the point that the DB:: code was
2986 entered. (allows debuggers to eval in the scope of the breakpoint rather
2987 than in the scope of the debugger itself).
2993 Perl_find_runcv(pTHX_ U32 *db_seqp)
2999 *db_seqp = PL_curcop->cop_seq;
3000 for (si = PL_curstackinfo; si; si = si->si_prev) {
3002 for (ix = si->si_cxix; ix >= 0; ix--) {
3003 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3004 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3005 CV * const cv = cx->blk_sub.cv;
3006 /* skip DB:: code */
3007 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3008 *db_seqp = cx->blk_oldcop->cop_seq;
3013 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3021 /* Compile a require/do, an eval '', or a /(?{...})/.
3022 * In the last case, startop is non-null, and contains the address of
3023 * a pointer that should be set to the just-compiled code.
3024 * outside is the lexically enclosing CV (if any) that invoked us.
3025 * Returns a bool indicating whether the compile was successful; if so,
3026 * PL_eval_start contains the first op of the compiled ocde; otherwise,
3027 * pushes undef (also croaks if startop != NULL).
3031 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3034 OP * const saveop = PL_op;
3036 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
3037 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3042 SAVESPTR(PL_compcv);
3043 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3044 CvEVAL_on(PL_compcv);
3045 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3046 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3048 CvOUTSIDE_SEQ(PL_compcv) = seq;
3049 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3051 /* set up a scratch pad */
3053 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3054 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3058 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3060 /* make sure we compile in the right package */
3062 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3063 SAVESPTR(PL_curstash);
3064 PL_curstash = CopSTASH(PL_curcop);
3066 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3067 SAVESPTR(PL_beginav);
3068 PL_beginav = newAV();
3069 SAVEFREESV(PL_beginav);
3070 SAVESPTR(PL_unitcheckav);
3071 PL_unitcheckav = newAV();
3072 SAVEFREESV(PL_unitcheckav);
3075 SAVEBOOL(PL_madskills);
3079 /* try to compile it */
3081 PL_eval_root = NULL;
3082 PL_curcop = &PL_compiling;
3083 CopARYBASE_set(PL_curcop, 0);
3084 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3085 PL_in_eval |= EVAL_KEEPERR;
3088 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
3089 SV **newsp; /* Used by POPBLOCK. */
3090 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
3091 I32 optype = 0; /* Might be reset by POPEVAL. */
3096 op_free(PL_eval_root);
3097 PL_eval_root = NULL;
3099 SP = PL_stack_base + POPMARK; /* pop original mark */
3101 POPBLOCK(cx,PL_curpm);
3105 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3107 msg = SvPVx_nolen_const(ERRSV);
3108 if (optype == OP_REQUIRE) {
3109 const SV * const nsv = cx->blk_eval.old_namesv;
3110 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3112 Perl_croak(aTHX_ "%sCompilation failed in require",
3113 *msg ? msg : "Unknown error\n");
3116 POPBLOCK(cx,PL_curpm);
3118 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3119 (*msg ? msg : "Unknown error\n"));
3123 sv_setpvs(ERRSV, "Compilation error");
3126 PERL_UNUSED_VAR(newsp);
3127 PUSHs(&PL_sv_undef);
3131 CopLINE_set(&PL_compiling, 0);
3133 *startop = PL_eval_root;
3135 SAVEFREEOP(PL_eval_root);
3137 /* Set the context for this new optree.
3138 * Propagate the context from the eval(). */
3139 if ((gimme & G_WANT) == G_VOID)
3140 scalarvoid(PL_eval_root);
3141 else if ((gimme & G_WANT) == G_ARRAY)
3144 scalar(PL_eval_root);
3146 DEBUG_x(dump_eval());
3148 /* Register with debugger: */
3149 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3150 CV * const cv = get_cvs("DB::postponed", 0);
3154 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3156 call_sv(MUTABLE_SV(cv), G_DISCARD);
3161 call_list(PL_scopestack_ix, PL_unitcheckav);
3163 /* compiled okay, so do it */
3165 CvDEPTH(PL_compcv) = 1;
3166 SP = PL_stack_base + POPMARK; /* pop original mark */
3167 PL_op = saveop; /* The caller may need it. */
3168 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3175 S_check_type_and_open(pTHX_ const char *name)
3178 const int st_rc = PerlLIO_stat(name, &st);
3180 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3182 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3186 return PerlIO_open(name, PERL_SCRIPT_MODE);
3189 #ifndef PERL_DISABLE_PMC
3191 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3195 PERL_ARGS_ASSERT_DOOPEN_PM;
3197 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3198 SV *const pmcsv = newSV(namelen + 2);
3199 char *const pmc = SvPVX(pmcsv);
3202 memcpy(pmc, name, namelen);
3204 pmc[namelen + 1] = '\0';
3206 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3207 fp = check_type_and_open(name);
3210 fp = check_type_and_open(pmc);
3212 SvREFCNT_dec(pmcsv);
3215 fp = check_type_and_open(name);
3220 # define doopen_pm(name, namelen) check_type_and_open(name)
3221 #endif /* !PERL_DISABLE_PMC */
3226 register PERL_CONTEXT *cx;
3233 int vms_unixname = 0;
3235 const char *tryname = NULL;
3237 const I32 gimme = GIMME_V;
3238 int filter_has_file = 0;
3239 PerlIO *tryrsfp = NULL;
3240 SV *filter_cache = NULL;
3241 SV *filter_state = NULL;
3242 SV *filter_sub = NULL;
3248 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3249 sv = new_version(sv);
3250 if (!sv_derived_from(PL_patchlevel, "version"))
3251 upg_version(PL_patchlevel, TRUE);
3252 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3253 if ( vcmp(sv,PL_patchlevel) <= 0 )
3254 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3255 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3258 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3261 SV * const req = SvRV(sv);
3262 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3264 /* get the left hand term */
3265 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3267 first = SvIV(*av_fetch(lav,0,0));
3268 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3269 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3270 || av_len(lav) > 1 /* FP with > 3 digits */
3271 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3273 DIE(aTHX_ "Perl %"SVf" required--this is only "
3274 "%"SVf", stopped", SVfARG(vnormal(req)),
3275 SVfARG(vnormal(PL_patchlevel)));
3277 else { /* probably 'use 5.10' or 'use 5.8' */
3282 second = SvIV(*av_fetch(lav,1,0));
3284 second /= second >= 600 ? 100 : 10;
3285 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3286 (int)first, (int)second);
3287 upg_version(hintsv, TRUE);
3289 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3290 "--this is only %"SVf", stopped",
3291 SVfARG(vnormal(req)),
3292 SVfARG(vnormal(sv_2mortal(hintsv))),
3293 SVfARG(vnormal(PL_patchlevel)));
3298 /* We do this only with use, not require. */
3300 /* If we request a version >= 5.9.5, load feature.pm with the
3301 * feature bundle that corresponds to the required version. */
3302 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3303 SV *const importsv = vnormal(sv);
3304 *SvPVX_mutable(importsv) = ':';
3305 ENTER_with_name("load_feature");
3306 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3307 LEAVE_with_name("load_feature");
3309 /* If a version >= 5.11.0 is requested, strictures are on by default! */
3311 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3312 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3317 name = SvPV_const(sv, len);
3318 if (!(name && len > 0 && *name))
3319 DIE(aTHX_ "Null filename used");
3320 TAINT_PROPER("require");
3324 /* The key in the %ENV hash is in the syntax of file passed as the argument
3325 * usually this is in UNIX format, but sometimes in VMS format, which
3326 * can result in a module being pulled in more than once.
3327 * To prevent this, the key must be stored in UNIX format if the VMS
3328 * name can be translated to UNIX.
3330 if ((unixname = tounixspec(name, NULL)) != NULL) {
3331 unixlen = strlen(unixname);
3337 /* if not VMS or VMS name can not be translated to UNIX, pass it
3340 unixname = (char *) name;
3343 if (PL_op->op_type == OP_REQUIRE) {
3344 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3345 unixname, unixlen, 0);
3347 if (*svp != &PL_sv_undef)
3350 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3351 "Compilation failed in require", unixname);
3355 /* prepare to compile file */
3357 if (path_is_absolute(name)) {
3359 tryrsfp = doopen_pm(name, len);
3362 AV * const ar = GvAVn(PL_incgv);
3368 namesv = newSV_type(SVt_PV);
3369 for (i = 0; i <= AvFILL(ar); i++) {
3370 SV * const dirsv = *av_fetch(ar, i, TRUE);
3372 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3379 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3380 && !sv_isobject(loader))
3382 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3385 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3386 PTR2UV(SvRV(dirsv)), name);
3387 tryname = SvPVX_const(namesv);
3390 ENTER_with_name("call_INC");
3398 if (sv_isobject(loader))
3399 count = call_method("INC", G_ARRAY);
3401 count = call_sv(loader, G_ARRAY);
3404 /* Adjust file name if the hook has set an %INC entry */
3405 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3407 tryname = SvPV_nolen_const(*svp);
3416 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3417 && !isGV_with_GP(SvRV(arg))) {
3418 filter_cache = SvRV(arg);
3419 SvREFCNT_inc_simple_void_NN(filter_cache);
3426 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3430 if (isGV_with_GP(arg)) {
3431 IO * const io = GvIO((const GV *)arg);
3436 tryrsfp = IoIFP(io);
3437 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3438 PerlIO_close(IoOFP(io));
3449 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3451 SvREFCNT_inc_simple_void_NN(filter_sub);
3454 filter_state = SP[i];
3455 SvREFCNT_inc_simple_void(filter_state);
3459 if (!tryrsfp && (filter_cache || filter_sub)) {
3460 tryrsfp = PerlIO_open(BIT_BUCKET,
3468 LEAVE_with_name("call_INC");
3475 filter_has_file = 0;
3477 SvREFCNT_dec(filter_cache);
3478 filter_cache = NULL;
3481 SvREFCNT_dec(filter_state);
3482 filter_state = NULL;
3485 SvREFCNT_dec(filter_sub);
3490 if (!path_is_absolute(name)
3496 dir = SvPV_const(dirsv, dirlen);
3504 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3506 sv_setpv(namesv, unixdir);
3507 sv_catpv(namesv, unixname);
3509 # ifdef __SYMBIAN32__
3510 if (PL_origfilename[0] &&
3511 PL_origfilename[1] == ':' &&
3512 !(dir[0] && dir[1] == ':'))
3513 Perl_sv_setpvf(aTHX_ namesv,
3518 Perl_sv_setpvf(aTHX_ namesv,
3522 /* The equivalent of
3523 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3524 but without the need to parse the format string, or
3525 call strlen on either pointer, and with the correct
3526 allocation up front. */
3528 char *tmp = SvGROW(namesv, dirlen + len + 2);
3530 memcpy(tmp, dir, dirlen);
3533 /* name came from an SV, so it will have a '\0' at the
3534 end that we can copy as part of this memcpy(). */
3535 memcpy(tmp, name, len + 1);
3537 SvCUR_set(namesv, dirlen + len + 1);
3539 /* Don't even actually have to turn SvPOK_on() as we
3540 access it directly with SvPVX() below. */
3544 TAINT_PROPER("require");
3545 tryname = SvPVX_const(namesv);
3546 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3548 if (tryname[0] == '.' && tryname[1] == '/') {
3550 while (*++tryname == '/');
3554 else if (errno == EMFILE)
3555 /* no point in trying other paths if out of handles */
3562 SAVECOPFILE_FREE(&PL_compiling);
3563 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3564 SvREFCNT_dec(namesv);
3566 if (PL_op->op_type == OP_REQUIRE) {
3567 const char *msgstr = name;
3568 if(errno == EMFILE) {
3570 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3572 msgstr = SvPV_nolen_const(msg);
3574 if (namesv) { /* did we lookup @INC? */
3575 AV * const ar = GvAVn(PL_incgv);
3577 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3578 "%s in @INC%s%s (@INC contains:",
3580 (instr(msgstr, ".h ")
3581 ? " (change .h to .ph maybe?)" : ""),
3582 (instr(msgstr, ".ph ")
3583 ? " (did you run h2ph?)" : "")
3586 for (i = 0; i <= AvFILL(ar); i++) {
3587 sv_catpvs(msg, " ");
3588 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3590 sv_catpvs(msg, ")");
3591 msgstr = SvPV_nolen_const(msg);
3594 DIE(aTHX_ "Can't locate %s", msgstr);
3600 SETERRNO(0, SS_NORMAL);
3602 /* Assume success here to prevent recursive requirement. */
3603 /* name is never assigned to again, so len is still strlen(name) */
3604 /* Check whether a hook in @INC has already filled %INC */
3606 (void)hv_store(GvHVn(PL_incgv),
3607 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3609 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3611 (void)hv_store(GvHVn(PL_incgv),
3612 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3615 ENTER_with_name("eval");
3617 lex_start(NULL, tryrsfp, TRUE);
3621 hv_clear(GvHV(PL_hintgv));
3623 SAVECOMPILEWARNINGS();
3624 if (PL_dowarn & G_WARN_ALL_ON)
3625 PL_compiling.cop_warnings = pWARN_ALL ;
3626 else if (PL_dowarn & G_WARN_ALL_OFF)
3627 PL_compiling.cop_warnings = pWARN_NONE ;
3629 PL_compiling.cop_warnings = pWARN_STD ;
3631 if (filter_sub || filter_cache) {
3632 /* We can use the SvPV of the filter PVIO itself as our cache, rather
3633 than hanging another SV from it. In turn, filter_add() optionally
3634 takes the SV to use as the filter (or creates a new SV if passed
3635 NULL), so simply pass in whatever value filter_cache has. */
3636 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3637 IoLINES(datasv) = filter_has_file;
3638 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3639 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3642 /* switch to eval mode */
3643 PUSHBLOCK(cx, CXt_EVAL, SP);
3645 cx->blk_eval.retop = PL_op->op_next;
3647 SAVECOPLINE(&PL_compiling);
3648 CopLINE_set(&PL_compiling, 0);
3652 /* Store and reset encoding. */
3653 encoding = PL_encoding;
3656 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3657 op = DOCATCH(PL_eval_start);
3659 op = PL_op->op_next;
3661 /* Restore encoding. */
3662 PL_encoding = encoding;
3667 /* This is a op added to hold the hints hash for
3668 pp_entereval. The hash can be modified by the code
3669 being eval'ed, so we return a copy instead. */
3675 mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3683 register PERL_CONTEXT *cx;
3685 const I32 gimme = GIMME_V;
3686 const U32 was = PL_breakable_sub_gen;
3687 char tbuf[TYPE_DIGITS(long) + 12];
3688 char *tmpbuf = tbuf;
3692 HV *saved_hh = NULL;
3694 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3695 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3699 TAINT_IF(SvTAINTED(sv));
3700 TAINT_PROPER("eval");
3702 ENTER_with_name("eval");
3703 lex_start(sv, NULL, FALSE);
3706 /* switch to eval mode */
3708 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3709 SV * const temp_sv = sv_newmortal();
3710 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3711 (unsigned long)++PL_evalseq,
3712 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3713 tmpbuf = SvPVX(temp_sv);
3714 len = SvCUR(temp_sv);
3717 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3718 SAVECOPFILE_FREE(&PL_compiling);
3719 CopFILE_set(&PL_compiling, tmpbuf+2);
3720 SAVECOPLINE(&PL_compiling);
3721 CopLINE_set(&PL_compiling, 1);
3722 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3723 deleting the eval's FILEGV from the stash before gv_check() runs
3724 (i.e. before run-time proper). To work around the coredump that
3725 ensues, we always turn GvMULTI_on for any globals that were
3726 introduced within evals. See force_ident(). GSAR 96-10-12 */
3728 PL_hints = PL_op->op_targ;
3730 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3731 SvREFCNT_dec(GvHV(PL_hintgv));
3732 GvHV(PL_hintgv) = saved_hh;
3734 SAVECOMPILEWARNINGS();
3735 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3736 if (PL_compiling.cop_hints_hash) {
3737 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3739 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3740 if (PL_compiling.cop_hints_hash) {
3742 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3743 HINTS_REFCNT_UNLOCK;
3745 /* special case: an eval '' executed within the DB package gets lexically
3746 * placed in the first non-DB CV rather than the current CV - this
3747 * allows the debugger to execute code, find lexicals etc, in the
3748 * scope of the code being debugged. Passing &seq gets find_runcv
3749 * to do the dirty work for us */
3750 runcv = find_runcv(&seq);
3752 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3754 cx->blk_eval.retop = PL_op->op_next;
3756 /* prepare to compile string */
3758 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3759 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3762 if (doeval(gimme, NULL, runcv, seq)) {
3763 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3764 ? (PERLDB_LINE || PERLDB_SAVESRC)
3765 : PERLDB_SAVESRC_NOSUBS) {
3766 /* Retain the filegv we created. */
3768 char *const safestr = savepvn(tmpbuf, len);
3769 SAVEDELETE(PL_defstash, safestr, len);
3771 return DOCATCH(PL_eval_start);
3773 /* We have already left the scope set up earler thanks to the LEAVE
3775 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3776 ? (PERLDB_LINE || PERLDB_SAVESRC)
3777 : PERLDB_SAVESRC_INVALID) {
3778 /* Retain the filegv we created. */
3780 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3782 return PL_op->op_next;
3793 register PERL_CONTEXT *cx;
3795 const U8 save_flags = PL_op -> op_flags;
3800 retop = cx->blk_eval.retop;
3803 if (gimme == G_VOID)
3805 else if (gimme == G_SCALAR) {
3808 if (SvFLAGS(TOPs) & SVs_TEMP)
3811 *MARK = sv_mortalcopy(TOPs);
3815 *MARK = &PL_sv_undef;
3820 /* in case LEAVE wipes old return values */
3821 for (mark = newsp + 1; mark <= SP; mark++) {
3822 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3823 *mark = sv_mortalcopy(*mark);
3824 TAINT_NOT; /* Each item is independent */
3828 PL_curpm = newpm; /* Don't pop $1 et al till now */
3831 assert(CvDEPTH(PL_compcv) == 1);
3833 CvDEPTH(PL_compcv) = 0;
3836 if (optype == OP_REQUIRE &&
3837 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3839 /* Unassume the success we assumed earlier. */
3840 SV * const nsv = cx->blk_eval.old_namesv;
3841 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3842 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3843 /* die_where() did LEAVE, or we won't be here */
3846 LEAVE_with_name("eval");
3847 if (!(save_flags & OPf_SPECIAL)) {
3855 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3856 close to the related Perl_create_eval_scope. */
3858 Perl_delete_eval_scope(pTHX)
3863 register PERL_CONTEXT *cx;
3869 LEAVE_with_name("eval_scope");
3870 PERL_UNUSED_VAR(newsp);
3871 PERL_UNUSED_VAR(gimme);
3872 PERL_UNUSED_VAR(optype);
3875 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3876 also needed by Perl_fold_constants. */
3878 Perl_create_eval_scope(pTHX_ U32 flags)
3881 const I32 gimme = GIMME_V;
3883 ENTER_with_name("eval_scope");
3886 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3889 PL_in_eval = EVAL_INEVAL;
3890 if (flags & G_KEEPERR)
3891 PL_in_eval |= EVAL_KEEPERR;
3894 if (flags & G_FAKINGEVAL) {
3895 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3903 PERL_CONTEXT * const cx = create_eval_scope(0);
3904 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3905 return DOCATCH(PL_op->op_next);
3914 register PERL_CONTEXT *cx;
3919 PERL_UNUSED_VAR(optype);
3922 if (gimme == G_VOID)
3924 else if (gimme == G_SCALAR) {
3928 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3931 *MARK = sv_mortalcopy(TOPs);
3935 *MARK = &PL_sv_undef;
3940 /* in case LEAVE wipes old return values */
3942 for (mark = newsp + 1; mark <= SP; mark++) {
3943 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3944 *mark = sv_mortalcopy(*mark);
3945 TAINT_NOT; /* Each item is independent */
3949 PL_curpm = newpm; /* Don't pop $1 et al till now */
3951 LEAVE_with_name("eval_scope");
3959 register PERL_CONTEXT *cx;
3960 const I32 gimme = GIMME_V;
3962 ENTER_with_name("given");
3965 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3967 PUSHBLOCK(cx, CXt_GIVEN, SP);
3976 register PERL_CONTEXT *cx;
3980 PERL_UNUSED_CONTEXT;
3983 assert(CxTYPE(cx) == CXt_GIVEN);
3988 PL_curpm = newpm; /* pop $1 et al */
3990 LEAVE_with_name("given");
3995 /* Helper routines used by pp_smartmatch */
3997 S_make_matcher(pTHX_ REGEXP *re)
4000 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4002 PERL_ARGS_ASSERT_MAKE_MATCHER;
4004 PM_SETRE(matcher, ReREFCNT_inc(re));
4006 SAVEFREEOP((OP *) matcher);
4007 ENTER_with_name("matcher"); SAVETMPS;
4013 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4018 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4020 PL_op = (OP *) matcher;
4025 return (SvTRUEx(POPs));
4029 S_destroy_matcher(pTHX_ PMOP *matcher)
4033 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4034 PERL_UNUSED_ARG(matcher);
4037 LEAVE_with_name("matcher");
4040 /* Do a smart match */
4043 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4044 return do_smartmatch(NULL, NULL);
4047 /* This version of do_smartmatch() implements the
4048 * table of smart matches that is found in perlsyn.
4051 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4056 bool object_on_left = FALSE;
4057 SV *e = TOPs; /* e is for 'expression' */
4058 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4060 /* First of all, handle overload magic of the rightmost argument */
4063 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4064 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4066 tmpsv = amagic_call(d, e, smart_amg, 0);
4073 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4076 SP -= 2; /* Pop the values */
4078 /* Take care only to invoke mg_get() once for each argument.
4079 * Currently we do this by copying the SV if it's magical. */
4082 d = sv_mortalcopy(d);
4089 e = sv_mortalcopy(e);
4093 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4100 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4101 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4102 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4104 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4105 object_on_left = TRUE;
4108 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4110 if (object_on_left) {
4111 goto sm_any_sub; /* Treat objects like scalars */
4113 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4114 /* Test sub truth for each key */
4116 bool andedresults = TRUE;
4117 HV *hv = (HV*) SvRV(d);
4118 I32 numkeys = hv_iterinit(hv);
4119 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4122 while ( (he = hv_iternext(hv)) ) {
4123 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4124 ENTER_with_name("smartmatch_hash_key_test");
4127 PUSHs(hv_iterkeysv(he));
4129 c = call_sv(e, G_SCALAR);
4132 andedresults = FALSE;
4134 andedresults = SvTRUEx(POPs) && andedresults;
4136 LEAVE_with_name("smartmatch_hash_key_test");
4143 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4144 /* Test sub truth for each element */
4146 bool andedresults = TRUE;
4147 AV *av = (AV*) SvRV(d);
4148 const I32 len = av_len(av);
4149 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4152 for (i = 0; i <= len; ++i) {
4153 SV * const * const svp = av_fetch(av, i, FALSE);
4154 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4155 ENTER_with_name("smartmatch_array_elem_test");
4161 c = call_sv(e, G_SCALAR);
4164 andedresults = FALSE;
4166 andedresults = SvTRUEx(POPs) && andedresults;
4168 LEAVE_with_name("smartmatch_array_elem_test");
4177 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4178 ENTER_with_name("smartmatch_coderef");
4183 c = call_sv(e, G_SCALAR);
4187 else if (SvTEMP(TOPs))
4188 SvREFCNT_inc_void(TOPs);
4190 LEAVE_with_name("smartmatch_coderef");
4195 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4196 if (object_on_left) {
4197 goto sm_any_hash; /* Treat objects like scalars */
4199 else if (!SvOK(d)) {
4200 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4203 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4204 /* Check that the key-sets are identical */
4206 HV *other_hv = MUTABLE_HV(SvRV(d));
4208 bool other_tied = FALSE;
4209 U32 this_key_count = 0,
4210 other_key_count = 0;
4211 HV *hv = MUTABLE_HV(SvRV(e));
4213 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4214 /* Tied hashes don't know how many keys they have. */
4215 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4218 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4219 HV * const temp = other_hv;
4224 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4227 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4230 /* The hashes have the same number of keys, so it suffices
4231 to check that one is a subset of the other. */
4232 (void) hv_iterinit(hv);
4233 while ( (he = hv_iternext(hv)) ) {
4234 SV *key = hv_iterkeysv(he);
4236 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4239 if(!hv_exists_ent(other_hv, key, 0)) {
4240 (void) hv_iterinit(hv); /* reset iterator */
4246 (void) hv_iterinit(other_hv);
4247 while ( hv_iternext(other_hv) )
4251 other_key_count = HvUSEDKEYS(other_hv);
4253 if (this_key_count != other_key_count)
4258 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4259 AV * const other_av = MUTABLE_AV(SvRV(d));
4260 const I32 other_len = av_len(other_av) + 1;
4262 HV *hv = MUTABLE_HV(SvRV(e));
4264 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4265 for (i = 0; i < other_len; ++i) {
4266 SV ** const svp = av_fetch(other_av, i, FALSE);
4267 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4268 if (svp) { /* ??? When can this not happen? */
4269 if (hv_exists_ent(hv, *svp, 0))
4275 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4276 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4279 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4281 HV *hv = MUTABLE_HV(SvRV(e));
4283 (void) hv_iterinit(hv);
4284 while ( (he = hv_iternext(hv)) ) {
4285 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4286 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4287 (void) hv_iterinit(hv);
4288 destroy_matcher(matcher);
4292 destroy_matcher(matcher);
4298 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4299 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4306 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4307 if (object_on_left) {
4308 goto sm_any_array; /* Treat objects like scalars */
4310 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4311 AV * const other_av = MUTABLE_AV(SvRV(e));
4312 const I32 other_len = av_len(other_av) + 1;
4315 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4316 for (i = 0; i < other_len; ++i) {
4317 SV ** const svp = av_fetch(other_av, i, FALSE);
4319 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4320 if (svp) { /* ??? When can this not happen? */
4321 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4327 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4328 AV *other_av = MUTABLE_AV(SvRV(d));
4329 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4330 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4334 const I32 other_len = av_len(other_av);
4336 if (NULL == seen_this) {
4337 seen_this = newHV();
4338 (void) sv_2mortal(MUTABLE_SV(seen_this));
4340 if (NULL == seen_other) {
4341 seen_other = newHV();
4342 (void) sv_2mortal(MUTABLE_SV(seen_other));
4344 for(i = 0; i <= other_len; ++i) {
4345 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4346 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4348 if (!this_elem || !other_elem) {
4349 if ((this_elem && SvOK(*this_elem))
4350 || (other_elem && SvOK(*other_elem)))
4353 else if (hv_exists_ent(seen_this,
4354 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4355 hv_exists_ent(seen_other,
4356 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4358 if (*this_elem != *other_elem)
4362 (void)hv_store_ent(seen_this,
4363 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4365 (void)hv_store_ent(seen_other,
4366 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4372 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4373 (void) do_smartmatch(seen_this, seen_other);
4375 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4384 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4385 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4388 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4389 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4392 for(i = 0; i <= this_len; ++i) {
4393 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4394 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4395 if (svp && matcher_matches_sv(matcher, *svp)) {
4396 destroy_matcher(matcher);
4400 destroy_matcher(matcher);
4404 else if (!SvOK(d)) {
4405 /* undef ~~ array */
4406 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4409 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4410 for (i = 0; i <= this_len; ++i) {
4411 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4412 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4413 if (!svp || !SvOK(*svp))
4422 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4424 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4425 for (i = 0; i <= this_len; ++i) {
4426 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4433 /* infinite recursion isn't supposed to happen here */
4434 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4435 (void) do_smartmatch(NULL, NULL);
4437 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4446 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4447 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4448 SV *t = d; d = e; e = t;
4449 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4452 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4453 SV *t = d; d = e; e = t;
4454 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4455 goto sm_regex_array;
4458 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4460 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4462 PUSHs(matcher_matches_sv(matcher, d)
4465 destroy_matcher(matcher);
4470 /* See if there is overload magic on left */
4471 else if (object_on_left && SvAMAGIC(d)) {
4473 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4474 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4477 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4485 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4488 else if (!SvOK(d)) {
4489 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4490 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4495 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4496 DEBUG_M(if (SvNIOK(e))
4497 Perl_deb(aTHX_ " applying rule Any-Num\n");
4499 Perl_deb(aTHX_ " applying rule Num-numish\n");
4501 /* numeric comparison */
4504 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4515 /* As a last resort, use string comparison */
4516 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4525 register PERL_CONTEXT *cx;
4526 const I32 gimme = GIMME_V;
4528 /* This is essentially an optimization: if the match
4529 fails, we don't want to push a context and then
4530 pop it again right away, so we skip straight
4531 to the op that follows the leavewhen.
4533 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4534 return cLOGOP->op_other->op_next;
4536 ENTER_with_name("eval");
4539 PUSHBLOCK(cx, CXt_WHEN, SP);
4548 register PERL_CONTEXT *cx;
4554 assert(CxTYPE(cx) == CXt_WHEN);
4559 PL_curpm = newpm; /* pop $1 et al */
4561 LEAVE_with_name("eval");
4569 register PERL_CONTEXT *cx;
4572 cxix = dopoptowhen(cxstack_ix);
4574 DIE(aTHX_ "Can't \"continue\" outside a when block");
4575 if (cxix < cxstack_ix)
4578 /* clear off anything above the scope we're re-entering */
4579 inner = PL_scopestack_ix;
4581 if (PL_scopestack_ix < inner)
4582 leave_scope(PL_scopestack[PL_scopestack_ix]);
4583 PL_curcop = cx->blk_oldcop;
4584 return cx->blk_givwhen.leave_op;
4591 register PERL_CONTEXT *cx;
4594 cxix = dopoptogiven(cxstack_ix);
4596 if (PL_op->op_flags & OPf_SPECIAL)
4597 DIE(aTHX_ "Can't use when() outside a topicalizer");
4599 DIE(aTHX_ "Can't \"break\" outside a given block");
4601 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4602 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4604 if (cxix < cxstack_ix)
4607 /* clear off anything above the scope we're re-entering */
4608 inner = PL_scopestack_ix;
4610 if (PL_scopestack_ix < inner)
4611 leave_scope(PL_scopestack[PL_scopestack_ix]);
4612 PL_curcop = cx->blk_oldcop;
4615 return CX_LOOP_NEXTOP_GET(cx);
4617 return cx->blk_givwhen.leave_op;
4621 S_doparseform(pTHX_ SV *sv)
4624 register char *s = SvPV_force(sv, len);
4625 register char * const send = s + len;
4626 register char *base = NULL;
4627 register I32 skipspaces = 0;
4628 bool noblank = FALSE;
4629 bool repeat = FALSE;
4630 bool postspace = FALSE;
4636 bool unchopnum = FALSE;
4637 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4639 PERL_ARGS_ASSERT_DOPARSEFORM;
4642 Perl_croak(aTHX_ "Null picture in formline");
4644 /* estimate the buffer size needed */
4645 for (base = s; s <= send; s++) {
4646 if (*s == '\n' || *s == '@' || *s == '^')
4652 Newx(fops, maxops, U32);
4657 *fpc++ = FF_LINEMARK;
4658 noblank = repeat = FALSE;
4676 case ' ': case '\t':
4683 } /* else FALL THROUGH */
4691 *fpc++ = FF_LITERAL;
4699 *fpc++ = (U16)skipspaces;
4703 *fpc++ = FF_NEWLINE;
4707 arg = fpc - linepc + 1;
4714 *fpc++ = FF_LINEMARK;
4715 noblank = repeat = FALSE;
4724 ischop = s[-1] == '^';
4730 arg = (s - base) - 1;
4732 *fpc++ = FF_LITERAL;
4740 *fpc++ = 2; /* skip the @* or ^* */
4742 *fpc++ = FF_LINESNGL;
4745 *fpc++ = FF_LINEGLOB;
4747 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4748 arg = ischop ? 512 : 0;
4753 const char * const f = ++s;
4756 arg |= 256 + (s - f);
4758 *fpc++ = s - base; /* fieldsize for FETCH */
4759 *fpc++ = FF_DECIMAL;
4761 unchopnum |= ! ischop;
4763 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4764 arg = ischop ? 512 : 0;
4766 s++; /* skip the '0' first */
4770 const char * const f = ++s;
4773 arg |= 256 + (s - f);
4775 *fpc++ = s - base; /* fieldsize for FETCH */
4776 *fpc++ = FF_0DECIMAL;
4778 unchopnum |= ! ischop;
4782 bool ismore = FALSE;
4785 while (*++s == '>') ;
4786 prespace = FF_SPACE;
4788 else if (*s == '|') {
4789 while (*++s == '|') ;
4790 prespace = FF_HALFSPACE;
4795 while (*++s == '<') ;
4798 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4802 *fpc++ = s - base; /* fieldsize for FETCH */
4804 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4807 *fpc++ = (U16)prespace;
4821 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4823 { /* need to jump to the next word */
4825 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4826 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4827 s = SvPVX(sv) + SvCUR(sv) + z;
4829 Copy(fops, s, arg, U32);
4831 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4834 if (unchopnum && repeat)
4835 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4841 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4843 /* Can value be printed in fldsize chars, using %*.*f ? */
4847 int intsize = fldsize - (value < 0 ? 1 : 0);
4854 while (intsize--) pwr *= 10.0;
4855 while (frcsize--) eps /= 10.0;
4858 if (value + eps >= pwr)
4861 if (value - eps <= -pwr)
4868 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4871 SV * const datasv = FILTER_DATA(idx);
4872 const int filter_has_file = IoLINES(datasv);
4873 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4874 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4879 char *prune_from = NULL;
4880 bool read_from_cache = FALSE;
4883 PERL_ARGS_ASSERT_RUN_USER_FILTER;
4885 assert(maxlen >= 0);
4888 /* I was having segfault trouble under Linux 2.2.5 after a
4889 parse error occured. (Had to hack around it with a test
4890 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4891 not sure where the trouble is yet. XXX */
4894 SV *const cache = datasv;
4897 const char *cache_p = SvPV(cache, cache_len);
4901 /* Running in block mode and we have some cached data already.
4903 if (cache_len >= umaxlen) {
4904 /* In fact, so much data we don't even need to call
4909 const char *const first_nl =
4910 (const char *)memchr(cache_p, '\n', cache_len);
4912 take = first_nl + 1 - cache_p;
4916 sv_catpvn(buf_sv, cache_p, take);
4917 sv_chop(cache, cache_p + take);
4918 /* Definately not EOF */
4922 sv_catsv(buf_sv, cache);
4924 umaxlen -= cache_len;
4927 read_from_cache = TRUE;
4931 /* Filter API says that the filter appends to the contents of the buffer.
4932 Usually the buffer is "", so the details don't matter. But if it's not,
4933 then clearly what it contains is already filtered by this filter, so we
4934 don't want to pass it in a second time.
4935 I'm going to use a mortal in case the upstream filter croaks. */
4936 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4937 ? sv_newmortal() : buf_sv;
4938 SvUPGRADE(upstream, SVt_PV);
4940 if (filter_has_file) {
4941 status = FILTER_READ(idx+1, upstream, 0);
4944 if (filter_sub && status >= 0) {
4948 ENTER_with_name("call_filter_sub");
4953 DEFSV_set(upstream);
4957 PUSHs(filter_state);
4960 count = call_sv(filter_sub, G_SCALAR);
4972 LEAVE_with_name("call_filter_sub");
4975 if(SvOK(upstream)) {
4976 got_p = SvPV(upstream, got_len);
4978 if (got_len > umaxlen) {
4979 prune_from = got_p + umaxlen;
4982 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
4983 if (first_nl && first_nl + 1 < got_p + got_len) {
4984 /* There's a second line here... */
4985 prune_from = first_nl + 1;
4990 /* Oh. Too long. Stuff some in our cache. */
4991 STRLEN cached_len = got_p + got_len - prune_from;
4992 SV *const cache = datasv;
4995 /* Cache should be empty. */
4996 assert(!SvCUR(cache));
4999 sv_setpvn(cache, prune_from, cached_len);
5000 /* If you ask for block mode, you may well split UTF-8 characters.
5001 "If it breaks, you get to keep both parts"
5002 (Your code is broken if you don't put them back together again
5003 before something notices.) */
5004 if (SvUTF8(upstream)) {
5007 SvCUR_set(upstream, got_len - cached_len);
5009 /* Can't yet be EOF */
5014 /* If they are at EOF but buf_sv has something in it, then they may never
5015 have touched the SV upstream, so it may be undefined. If we naively
5016 concatenate it then we get a warning about use of uninitialised value.
5018 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5019 sv_catsv(buf_sv, upstream);
5023 IoLINES(datasv) = 0;
5025 SvREFCNT_dec(filter_state);
5026 IoTOP_GV(datasv) = NULL;
5029 SvREFCNT_dec(filter_sub);
5030 IoBOTTOM_GV(datasv) = NULL;
5032 filter_del(S_run_user_filter);
5034 if (status == 0 && read_from_cache) {
5035 /* If we read some data from the cache (and by getting here it implies
5036 that we emptied the cache) then we aren't yet at EOF, and mustn't
5037 report that to our caller. */
5043 /* perhaps someone can come up with a better name for
5044 this? it is not really "absolute", per se ... */
5046 S_path_is_absolute(const char *name)
5048 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5050 if (PERL_FILE_IS_ABSOLUTE(name)
5052 || (*name == '.' && ((name[1] == '/' ||
5053 (name[1] == '.' && name[2] == '/'))
5054 || (name[1] == '\\' ||
5055 ( name[1] == '.' && name[2] == '\\')))
5058 || (*name == '.' && (name[1] == '/' ||
5059 (name[1] == '.' && name[2] == '/')))
5071 * c-indentation-style: bsd
5073 * indent-tabs-mode: t
5076 * ex: set ts=8 sts=4 sw=4 noet: