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 if(pm->op_type == OP_MATCH) {
160 const bool was_tainted = PL_tainted;
161 if (pm->op_flags & OPf_STACKED)
163 else if (pm->op_private & OPpTARGET_MY)
164 lhs = PAD_SV(pm->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;
173 re = reg_temp_copy(NULL, re);
174 ReREFCNT_dec(PM_GETRE(pm));
179 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
181 assert (re != (REGEXP*) &PL_sv_undef);
183 /* Check against the last compiled regexp. */
184 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
185 memNE(RX_PRECOMP(re), t, len))
187 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
188 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
192 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
194 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
196 } else if (PL_curcop->cop_hints_hash) {
197 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
199 if (ptr && SvIOK(ptr) && SvIV(ptr))
200 eng = INT2PTR(regexp_engine*,SvIV(ptr));
203 if (PL_op->op_flags & OPf_SPECIAL)
204 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
206 if (DO_UTF8(tmpstr)) {
207 assert (SvUTF8(tmpstr));
208 } else if (SvUTF8(tmpstr)) {
209 /* Not doing UTF-8, despite what the SV says. Is this only if
210 we're trapped in use 'bytes'? */
211 /* Make a copy of the octet sequence, but without the flag on,
212 as the compiler now honours the SvUTF8 flag on tmpstr. */
214 const char *const p = SvPV(tmpstr, len);
215 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
219 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
221 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
223 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
224 inside tie/overload accessors. */
230 #ifndef INCOMPLETE_TAINTS
233 RX_EXTFLAGS(re) |= RXf_TAINTED;
235 RX_EXTFLAGS(re) &= ~RXf_TAINTED;
239 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
243 #if !defined(USE_ITHREADS)
244 /* can't change the optree at runtime either */
245 /* PMf_KEEP is handled differently under threads to avoid these problems */
246 if (pm->op_pmflags & PMf_KEEP) {
247 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
248 cLOGOP->op_first->op_next = PL_op->op_next;
258 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
259 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
260 register SV * const dstr = cx->sb_dstr;
261 register char *s = cx->sb_s;
262 register char *m = cx->sb_m;
263 char *orig = cx->sb_orig;
264 register REGEXP * const rx = cx->sb_rx;
266 REGEXP *old = PM_GETRE(pm);
270 PM_SETRE(pm,ReREFCNT_inc(rx));
273 rxres_restore(&cx->sb_rxres, rx);
274 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
276 if (cx->sb_iters++) {
277 const I32 saviters = cx->sb_iters;
278 if (cx->sb_iters > cx->sb_maxiters)
279 DIE(aTHX_ "Substitution loop");
281 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
282 cx->sb_rxtainted |= 2;
283 sv_catsv(dstr, POPs);
284 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
288 if (CxONCE(cx) || s < orig ||
289 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
290 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
291 ((cx->sb_rflags & REXEC_COPY_STR)
292 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
293 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
295 SV * const targ = cx->sb_targ;
297 assert(cx->sb_strend >= s);
298 if(cx->sb_strend > s) {
299 if (DO_UTF8(dstr) && !SvUTF8(targ))
300 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
302 sv_catpvn(dstr, s, cx->sb_strend - s);
304 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
306 #ifdef PERL_OLD_COPY_ON_WRITE
308 sv_force_normal_flags(targ, SV_COW_DROP_PV);
314 SvPV_set(targ, SvPVX(dstr));
315 SvCUR_set(targ, SvCUR(dstr));
316 SvLEN_set(targ, SvLEN(dstr));
319 SvPV_set(dstr, NULL);
321 TAINT_IF(cx->sb_rxtainted & 1);
322 mPUSHi(saviters - 1);
324 (void)SvPOK_only_UTF8(targ);
325 TAINT_IF(cx->sb_rxtainted);
329 LEAVE_SCOPE(cx->sb_oldsave);
331 RETURNOP(pm->op_next);
333 cx->sb_iters = saviters;
335 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
338 cx->sb_orig = orig = RX_SUBBEG(rx);
340 cx->sb_strend = s + (cx->sb_strend - m);
342 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
344 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
345 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
347 sv_catpvn(dstr, s, m-s);
349 cx->sb_s = RX_OFFS(rx)[0].end + orig;
350 { /* Update the pos() information. */
351 SV * const sv = cx->sb_targ;
353 SvUPGRADE(sv, SVt_PVMG);
354 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
355 #ifdef PERL_OLD_COPY_ON_WRITE
357 sv_force_normal_flags(sv, 0);
359 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
362 mg->mg_len = m - orig;
365 (void)ReREFCNT_inc(rx);
366 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
367 rxres_save(&cx->sb_rxres, rx);
368 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
372 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
377 PERL_ARGS_ASSERT_RXRES_SAVE;
380 if (!p || p[1] < RX_NPARENS(rx)) {
381 #ifdef PERL_OLD_COPY_ON_WRITE
382 i = 7 + RX_NPARENS(rx) * 2;
384 i = 6 + RX_NPARENS(rx) * 2;
393 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
394 RX_MATCH_COPIED_off(rx);
396 #ifdef PERL_OLD_COPY_ON_WRITE
397 *p++ = PTR2UV(RX_SAVED_COPY(rx));
398 RX_SAVED_COPY(rx) = NULL;
401 *p++ = RX_NPARENS(rx);
403 *p++ = PTR2UV(RX_SUBBEG(rx));
404 *p++ = (UV)RX_SUBLEN(rx);
405 for (i = 0; i <= RX_NPARENS(rx); ++i) {
406 *p++ = (UV)RX_OFFS(rx)[i].start;
407 *p++ = (UV)RX_OFFS(rx)[i].end;
412 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
417 PERL_ARGS_ASSERT_RXRES_RESTORE;
420 RX_MATCH_COPY_FREE(rx);
421 RX_MATCH_COPIED_set(rx, *p);
424 #ifdef PERL_OLD_COPY_ON_WRITE
425 if (RX_SAVED_COPY(rx))
426 SvREFCNT_dec (RX_SAVED_COPY(rx));
427 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
431 RX_NPARENS(rx) = *p++;
433 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
434 RX_SUBLEN(rx) = (I32)(*p++);
435 for (i = 0; i <= RX_NPARENS(rx); ++i) {
436 RX_OFFS(rx)[i].start = (I32)(*p++);
437 RX_OFFS(rx)[i].end = (I32)(*p++);
442 S_rxres_free(pTHX_ void **rsp)
444 UV * const p = (UV*)*rsp;
446 PERL_ARGS_ASSERT_RXRES_FREE;
451 void *tmp = INT2PTR(char*,*p);
454 PoisonFree(*p, 1, sizeof(*p));
456 Safefree(INT2PTR(char*,*p));
458 #ifdef PERL_OLD_COPY_ON_WRITE
460 SvREFCNT_dec (INT2PTR(SV*,p[1]));
470 dVAR; dSP; dMARK; dORIGMARK;
471 register SV * const tmpForm = *++MARK;
476 register SV *sv = NULL;
477 const char *item = NULL;
481 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
482 const char *chophere = NULL;
483 char *linemark = NULL;
485 bool gotsome = FALSE;
487 const STRLEN fudge = SvPOK(tmpForm)
488 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
489 bool item_is_utf8 = FALSE;
490 bool targ_is_utf8 = FALSE;
492 OP * parseres = NULL;
495 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
496 if (SvREADONLY(tmpForm)) {
497 SvREADONLY_off(tmpForm);
498 parseres = doparseform(tmpForm);
499 SvREADONLY_on(tmpForm);
502 parseres = doparseform(tmpForm);
506 SvPV_force(PL_formtarget, len);
507 if (DO_UTF8(PL_formtarget))
509 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
511 f = SvPV_const(tmpForm, len);
512 /* need to jump to the next word */
513 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
517 const char *name = "???";
520 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
521 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
522 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
523 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
524 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
526 case FF_CHECKNL: name = "CHECKNL"; break;
527 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
528 case FF_SPACE: name = "SPACE"; break;
529 case FF_HALFSPACE: name = "HALFSPACE"; break;
530 case FF_ITEM: name = "ITEM"; break;
531 case FF_CHOP: name = "CHOP"; break;
532 case FF_LINEGLOB: name = "LINEGLOB"; break;
533 case FF_NEWLINE: name = "NEWLINE"; break;
534 case FF_MORE: name = "MORE"; break;
535 case FF_LINEMARK: name = "LINEMARK"; break;
536 case FF_END: name = "END"; break;
537 case FF_0DECIMAL: name = "0DECIMAL"; break;
538 case FF_LINESNGL: name = "LINESNGL"; break;
541 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
543 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
554 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
555 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
557 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
558 t = SvEND(PL_formtarget);
562 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
563 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
565 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
566 t = SvEND(PL_formtarget);
586 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
593 const char *s = item = SvPV_const(sv, len);
596 itemsize = sv_len_utf8(sv);
597 if (itemsize != (I32)len) {
599 if (itemsize > fieldsize) {
600 itemsize = fieldsize;
601 itembytes = itemsize;
602 sv_pos_u2b(sv, &itembytes, 0);
606 send = chophere = s + itembytes;
616 sv_pos_b2u(sv, &itemsize);
620 item_is_utf8 = FALSE;
621 if (itemsize > fieldsize)
622 itemsize = fieldsize;
623 send = chophere = s + itemsize;
637 const char *s = item = SvPV_const(sv, len);
640 itemsize = sv_len_utf8(sv);
641 if (itemsize != (I32)len) {
643 if (itemsize <= fieldsize) {
644 const char *send = chophere = s + itemsize;
657 itemsize = fieldsize;
658 itembytes = itemsize;
659 sv_pos_u2b(sv, &itembytes, 0);
660 send = chophere = s + itembytes;
661 while (s < send || (s == send && isSPACE(*s))) {
671 if (strchr(PL_chopset, *s))
676 itemsize = chophere - item;
677 sv_pos_b2u(sv, &itemsize);
683 item_is_utf8 = FALSE;
684 if (itemsize <= fieldsize) {
685 const char *const send = chophere = s + itemsize;
698 itemsize = fieldsize;
699 send = chophere = s + itemsize;
700 while (s < send || (s == send && isSPACE(*s))) {
710 if (strchr(PL_chopset, *s))
715 itemsize = chophere - item;
721 arg = fieldsize - itemsize;
730 arg = fieldsize - itemsize;
741 const char *s = item;
745 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
747 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
749 t = SvEND(PL_formtarget);
753 if (UTF8_IS_CONTINUED(*s)) {
754 STRLEN skip = UTF8SKIP(s);
771 if ( !((*t++ = *s++) & ~31) )
777 if (targ_is_utf8 && !item_is_utf8) {
778 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
780 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
781 for (; t < SvEND(PL_formtarget); t++) {
794 const int ch = *t++ = *s++;
797 if ( !((*t++ = *s++) & ~31) )
806 const char *s = chophere;
820 const bool oneline = fpc[-1] == FF_LINESNGL;
821 const char *s = item = SvPV_const(sv, len);
822 item_is_utf8 = DO_UTF8(sv);
825 STRLEN to_copy = itemsize;
826 const char *const send = s + len;
827 const U8 *source = (const U8 *) s;
831 chophere = s + itemsize;
835 to_copy = s - SvPVX_const(sv) - 1;
847 if (targ_is_utf8 && !item_is_utf8) {
848 source = tmp = bytes_to_utf8(source, &to_copy);
849 SvCUR_set(PL_formtarget,
850 t - SvPVX_const(PL_formtarget));
852 if (item_is_utf8 && !targ_is_utf8) {
853 /* Upgrade targ to UTF8, and then we reduce it to
854 a problem we have a simple solution for. */
855 SvCUR_set(PL_formtarget,
856 t - SvPVX_const(PL_formtarget));
858 /* Don't need get magic. */
859 sv_utf8_upgrade_nomg(PL_formtarget);
861 SvCUR_set(PL_formtarget,
862 t - SvPVX_const(PL_formtarget));
865 /* Easy. They agree. */
866 assert (item_is_utf8 == targ_is_utf8);
868 SvGROW(PL_formtarget,
869 SvCUR(PL_formtarget) + to_copy + fudge + 1);
870 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
872 Copy(source, t, to_copy, char);
874 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
876 if (SvGMAGICAL(sv)) {
877 /* Mustn't call sv_pos_b2u() as it does a second
878 mg_get(). Is this a bug? Do we need a _flags()
880 itemsize = utf8_length(source, source + itemsize);
882 sv_pos_b2u(sv, &itemsize);
894 #if defined(USE_LONG_DOUBLE)
897 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
901 "%#0*.*f" : "%0*.*f");
906 #if defined(USE_LONG_DOUBLE)
908 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
911 ((arg & 256) ? "%#*.*f" : "%*.*f");
914 /* If the field is marked with ^ and the value is undefined,
916 if ((arg & 512) && !SvOK(sv)) {
924 /* overflow evidence */
925 if (num_overflow(value, fieldsize, arg)) {
931 /* Formats aren't yet marked for locales, so assume "yes". */
933 STORE_NUMERIC_STANDARD_SET_LOCAL();
934 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
935 RESTORE_NUMERIC_STANDARD();
942 while (t-- > linemark && *t == ' ') ;
950 if (arg) { /* repeat until fields exhausted? */
952 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
953 lines += FmLINES(PL_formtarget);
955 SvUTF8_on(PL_formtarget);
956 FmLINES(PL_formtarget) = lines;
958 RETURNOP(cLISTOP->op_first);
969 const char *s = chophere;
970 const char *send = item + len;
972 while (isSPACE(*s) && (s < send))
977 arg = fieldsize - itemsize;
984 if (strnEQ(s1," ",3)) {
985 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
996 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
998 SvUTF8_on(PL_formtarget);
999 FmLINES(PL_formtarget) += lines;
1011 if (PL_stack_base + *PL_markstack_ptr == SP) {
1013 if (GIMME_V == G_SCALAR)
1015 RETURNOP(PL_op->op_next->op_next);
1017 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
1018 pp_pushmark(); /* push dst */
1019 pp_pushmark(); /* push src */
1020 ENTER_with_name("grep"); /* enter outer scope */
1023 if (PL_op->op_private & OPpGREP_LEX)
1024 SAVESPTR(PAD_SVl(PL_op->op_targ));
1027 ENTER_with_name("grep_item"); /* enter inner scope */
1030 src = PL_stack_base[*PL_markstack_ptr];
1032 if (PL_op->op_private & OPpGREP_LEX)
1033 PAD_SVl(PL_op->op_targ) = src;
1038 if (PL_op->op_type == OP_MAPSTART)
1039 pp_pushmark(); /* push top */
1040 return ((LOGOP*)PL_op->op_next)->op_other;
1046 const I32 gimme = GIMME_V;
1047 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1053 /* first, move source pointer to the next item in the source list */
1054 ++PL_markstack_ptr[-1];
1056 /* if there are new items, push them into the destination list */
1057 if (items && gimme != G_VOID) {
1058 /* might need to make room back there first */
1059 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1060 /* XXX this implementation is very pessimal because the stack
1061 * is repeatedly extended for every set of items. Is possible
1062 * to do this without any stack extension or copying at all
1063 * by maintaining a separate list over which the map iterates
1064 * (like foreach does). --gsar */
1066 /* everything in the stack after the destination list moves
1067 * towards the end the stack by the amount of room needed */
1068 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1070 /* items to shift up (accounting for the moved source pointer) */
1071 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1073 /* This optimization is by Ben Tilly and it does
1074 * things differently from what Sarathy (gsar)
1075 * is describing. The downside of this optimization is
1076 * that leaves "holes" (uninitialized and hopefully unused areas)
1077 * to the Perl stack, but on the other hand this
1078 * shouldn't be a problem. If Sarathy's idea gets
1079 * implemented, this optimization should become
1080 * irrelevant. --jhi */
1082 shift = count; /* Avoid shifting too often --Ben Tilly */
1086 dst = (SP += shift);
1087 PL_markstack_ptr[-1] += shift;
1088 *PL_markstack_ptr += shift;
1092 /* copy the new items down to the destination list */
1093 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1094 if (gimme == G_ARRAY) {
1096 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1099 /* scalar context: we don't care about which values map returns
1100 * (we use undef here). And so we certainly don't want to do mortal
1101 * copies of meaningless values. */
1102 while (items-- > 0) {
1104 *dst-- = &PL_sv_undef;
1108 LEAVE_with_name("grep_item"); /* exit inner scope */
1111 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1113 (void)POPMARK; /* pop top */
1114 LEAVE_with_name("grep"); /* exit outer scope */
1115 (void)POPMARK; /* pop src */
1116 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1117 (void)POPMARK; /* pop dst */
1118 SP = PL_stack_base + POPMARK; /* pop original mark */
1119 if (gimme == G_SCALAR) {
1120 if (PL_op->op_private & OPpGREP_LEX) {
1121 SV* sv = sv_newmortal();
1122 sv_setiv(sv, items);
1130 else if (gimme == G_ARRAY)
1137 ENTER_with_name("grep_item"); /* enter inner scope */
1140 /* set $_ to the new source item */
1141 src = PL_stack_base[PL_markstack_ptr[-1]];
1143 if (PL_op->op_private & OPpGREP_LEX)
1144 PAD_SVl(PL_op->op_targ) = src;
1148 RETURNOP(cLOGOP->op_other);
1157 if (GIMME == G_ARRAY)
1159 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1160 return cLOGOP->op_other;
1170 if (GIMME == G_ARRAY) {
1171 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1175 SV * const targ = PAD_SV(PL_op->op_targ);
1178 if (PL_op->op_private & OPpFLIP_LINENUM) {
1179 if (GvIO(PL_last_in_gv)) {
1180 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1183 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1185 flip = SvIV(sv) == SvIV(GvSV(gv));
1191 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1192 if (PL_op->op_flags & OPf_SPECIAL) {
1200 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1203 sv_setpvs(TARG, "");
1209 /* This code tries to decide if "$left .. $right" should use the
1210 magical string increment, or if the range is numeric (we make
1211 an exception for .."0" [#18165]). AMS 20021031. */
1213 #define RANGE_IS_NUMERIC(left,right) ( \
1214 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1215 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1216 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1217 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1218 && (!SvOK(right) || looks_like_number(right))))
1224 if (GIMME == G_ARRAY) {
1230 if (RANGE_IS_NUMERIC(left,right)) {
1233 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1234 (SvOK(right) && SvNV(right) > IV_MAX))
1235 DIE(aTHX_ "Range iterator outside integer range");
1246 SV * const sv = sv_2mortal(newSViv(i++));
1251 SV * const final = sv_mortalcopy(right);
1253 const char * const tmps = SvPV_const(final, len);
1255 SV *sv = sv_mortalcopy(left);
1256 SvPV_force_nolen(sv);
1257 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1259 if (strEQ(SvPVX_const(sv),tmps))
1261 sv = sv_2mortal(newSVsv(sv));
1268 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1272 if (PL_op->op_private & OPpFLIP_LINENUM) {
1273 if (GvIO(PL_last_in_gv)) {
1274 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1277 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1278 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1286 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1287 sv_catpvs(targ, "E0");
1297 static const char * const context_name[] = {
1299 NULL, /* CXt_WHEN never actually needs "block" */
1300 NULL, /* CXt_BLOCK never actually needs "block" */
1301 NULL, /* CXt_GIVEN never actually needs "block" */
1302 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1303 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1304 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1305 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1313 S_dopoptolabel(pTHX_ const char *label)
1318 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1320 for (i = cxstack_ix; i >= 0; i--) {
1321 register const PERL_CONTEXT * const cx = &cxstack[i];
1322 switch (CxTYPE(cx)) {
1328 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1329 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1330 if (CxTYPE(cx) == CXt_NULL)
1333 case CXt_LOOP_LAZYIV:
1334 case CXt_LOOP_LAZYSV:
1336 case CXt_LOOP_PLAIN:
1338 const char *cx_label = CxLABEL(cx);
1339 if (!cx_label || strNE(label, cx_label) ) {
1340 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1341 (long)i, cx_label));
1344 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1355 Perl_dowantarray(pTHX)
1358 const I32 gimme = block_gimme();
1359 return (gimme == G_VOID) ? G_SCALAR : gimme;
1363 Perl_block_gimme(pTHX)
1366 const I32 cxix = dopoptosub(cxstack_ix);
1370 switch (cxstack[cxix].blk_gimme) {
1378 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1385 Perl_is_lvalue_sub(pTHX)
1388 const I32 cxix = dopoptosub(cxstack_ix);
1389 assert(cxix >= 0); /* We should only be called from inside subs */
1391 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1392 return CxLVAL(cxstack + cxix);
1398 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1403 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1405 for (i = startingblock; i >= 0; i--) {
1406 register const PERL_CONTEXT * const cx = &cxstk[i];
1407 switch (CxTYPE(cx)) {
1413 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1421 S_dopoptoeval(pTHX_ I32 startingblock)
1425 for (i = startingblock; i >= 0; i--) {
1426 register const PERL_CONTEXT *cx = &cxstack[i];
1427 switch (CxTYPE(cx)) {
1431 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1439 S_dopoptoloop(pTHX_ I32 startingblock)
1443 for (i = startingblock; i >= 0; i--) {
1444 register const PERL_CONTEXT * const cx = &cxstack[i];
1445 switch (CxTYPE(cx)) {
1451 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1452 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1453 if ((CxTYPE(cx)) == CXt_NULL)
1456 case CXt_LOOP_LAZYIV:
1457 case CXt_LOOP_LAZYSV:
1459 case CXt_LOOP_PLAIN:
1460 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1468 S_dopoptogiven(pTHX_ I32 startingblock)
1472 for (i = startingblock; i >= 0; i--) {
1473 register const PERL_CONTEXT *cx = &cxstack[i];
1474 switch (CxTYPE(cx)) {
1478 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1480 case CXt_LOOP_PLAIN:
1481 assert(!CxFOREACHDEF(cx));
1483 case CXt_LOOP_LAZYIV:
1484 case CXt_LOOP_LAZYSV:
1486 if (CxFOREACHDEF(cx)) {
1487 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1496 S_dopoptowhen(pTHX_ I32 startingblock)
1500 for (i = startingblock; i >= 0; i--) {
1501 register const PERL_CONTEXT *cx = &cxstack[i];
1502 switch (CxTYPE(cx)) {
1506 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1514 Perl_dounwind(pTHX_ I32 cxix)
1519 while (cxstack_ix > cxix) {
1521 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1522 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1523 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1524 /* Note: we don't need to restore the base context info till the end. */
1525 switch (CxTYPE(cx)) {
1528 continue; /* not break */
1536 case CXt_LOOP_LAZYIV:
1537 case CXt_LOOP_LAZYSV:
1539 case CXt_LOOP_PLAIN:
1550 PERL_UNUSED_VAR(optype);
1554 Perl_qerror(pTHX_ SV *err)
1558 PERL_ARGS_ASSERT_QERROR;
1561 sv_catsv(ERRSV, err);
1563 sv_catsv(PL_errors, err);
1565 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1567 ++PL_parser->error_count;
1571 Perl_die_where(pTHX_ SV *msv)
1580 if (PL_in_eval & EVAL_KEEPERR) {
1581 static const char prefix[] = "\t(in cleanup) ";
1582 SV * const err = ERRSV;
1583 const char *e = NULL;
1586 else if (SvCUR(err) >= sizeof(prefix)+SvCUR(msv)-1) {
1589 const char* message = SvPV_const(msv, msglen);
1590 e = SvPV_const(err, len);
1592 if (*e != *message || strNE(e,message))
1597 SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(msv));
1598 sv_catpvn(err, prefix, sizeof(prefix)-1);
1600 start = SvCUR(err)-SvCUR(msv)-sizeof(prefix)+1;
1601 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s",
1602 SvPVX_const(err)+start);
1607 const char* message = SvPV_const(msv, msglen);
1608 sv_setpvn(ERRSV, message, msglen);
1609 SvFLAGS(ERRSV) |= SvFLAGS(msv) & SVf_UTF8;
1613 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1614 && PL_curstackinfo->si_prev)
1622 register PERL_CONTEXT *cx;
1625 if (cxix < cxstack_ix)
1628 POPBLOCK(cx,PL_curpm);
1629 if (CxTYPE(cx) != CXt_EVAL) {
1631 const char* message = SvPVx_const( msv ? msv : ERRSV, msglen);
1632 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1633 PerlIO_write(Perl_error_log, message, msglen);
1638 if (gimme == G_SCALAR)
1639 *++newsp = &PL_sv_undef;
1640 PL_stack_sp = newsp;
1644 /* LEAVE could clobber PL_curcop (see save_re_context())
1645 * XXX it might be better to find a way to avoid messing with
1646 * PL_curcop in save_re_context() instead, but this is a more
1647 * minimal fix --GSAR */
1648 PL_curcop = cx->blk_oldcop;
1650 if (optype == OP_REQUIRE) {
1651 const char* const msg = SvPVx_nolen_const(ERRSV);
1652 SV * const nsv = cx->blk_eval.old_namesv;
1653 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1655 DIE(aTHX_ "%sCompilation failed in require",
1656 *msg ? msg : "Unknown error\n");
1658 assert(CxTYPE(cx) == CXt_EVAL);
1659 PL_restartop = cx->blk_eval.retop;
1665 write_to_stderr( msv ? msv : ERRSV );
1672 dVAR; dSP; dPOPTOPssrl;
1673 if (SvTRUE(left) != SvTRUE(right))
1683 register I32 cxix = dopoptosub(cxstack_ix);
1684 register const PERL_CONTEXT *cx;
1685 register const PERL_CONTEXT *ccstack = cxstack;
1686 const PERL_SI *top_si = PL_curstackinfo;
1688 const char *stashname;
1695 /* we may be in a higher stacklevel, so dig down deeper */
1696 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1697 top_si = top_si->si_prev;
1698 ccstack = top_si->si_cxstack;
1699 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1702 if (GIMME != G_ARRAY) {
1708 /* caller() should not report the automatic calls to &DB::sub */
1709 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1710 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1714 cxix = dopoptosub_at(ccstack, cxix - 1);
1717 cx = &ccstack[cxix];
1718 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1719 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1720 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1721 field below is defined for any cx. */
1722 /* caller() should not report the automatic calls to &DB::sub */
1723 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1724 cx = &ccstack[dbcxix];
1727 stashname = CopSTASHPV(cx->blk_oldcop);
1728 if (GIMME != G_ARRAY) {
1731 PUSHs(&PL_sv_undef);
1734 sv_setpv(TARG, stashname);
1743 PUSHs(&PL_sv_undef);
1745 mPUSHs(newSVpv(stashname, 0));
1746 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1747 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1750 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1751 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1752 /* So is ccstack[dbcxix]. */
1754 SV * const sv = newSV(0);
1755 gv_efullname3(sv, cvgv, NULL);
1757 PUSHs(boolSV(CxHASARGS(cx)));
1760 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1761 PUSHs(boolSV(CxHASARGS(cx)));
1765 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1768 gimme = (I32)cx->blk_gimme;
1769 if (gimme == G_VOID)
1770 PUSHs(&PL_sv_undef);
1772 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1773 if (CxTYPE(cx) == CXt_EVAL) {
1775 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1776 PUSHs(cx->blk_eval.cur_text);
1780 else if (cx->blk_eval.old_namesv) {
1781 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1784 /* eval BLOCK (try blocks have old_namesv == 0) */
1786 PUSHs(&PL_sv_undef);
1787 PUSHs(&PL_sv_undef);
1791 PUSHs(&PL_sv_undef);
1792 PUSHs(&PL_sv_undef);
1794 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1795 && CopSTASH_eq(PL_curcop, PL_debstash))
1797 AV * const ary = cx->blk_sub.argarray;
1798 const int off = AvARRAY(ary) - AvALLOC(ary);
1801 PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
1803 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1806 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1807 av_extend(PL_dbargs, AvFILLp(ary) + off);
1808 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1809 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1811 /* XXX only hints propagated via op_private are currently
1812 * visible (others are not easily accessible, since they
1813 * use the global PL_hints) */
1814 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1817 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1819 if (old_warnings == pWARN_NONE ||
1820 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1821 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1822 else if (old_warnings == pWARN_ALL ||
1823 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1824 /* Get the bit mask for $warnings::Bits{all}, because
1825 * it could have been extended by warnings::register */
1827 HV * const bits = get_hv("warnings::Bits", 0);
1828 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1829 mask = newSVsv(*bits_all);
1832 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1836 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1840 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1841 sv_2mortal(newRV_noinc(
1842 MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1843 cx->blk_oldcop->cop_hints_hash))))
1852 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1853 sv_reset(tmps, CopSTASH(PL_curcop));
1858 /* like pp_nextstate, but used instead when the debugger is active */
1863 PL_curcop = (COP*)PL_op;
1864 TAINT_NOT; /* Each statement is presumed innocent */
1865 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1868 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1869 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1872 register PERL_CONTEXT *cx;
1873 const I32 gimme = G_ARRAY;
1875 GV * const gv = PL_DBgv;
1876 register CV * const cv = GvCV(gv);
1879 DIE(aTHX_ "No DB::DB routine defined");
1881 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1882 /* don't do recursive DB::DB call */
1897 (void)(*CvXSUB(cv))(aTHX_ cv);
1904 PUSHBLOCK(cx, CXt_SUB, SP);
1906 cx->blk_sub.retop = PL_op->op_next;
1909 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1910 RETURNOP(CvSTART(cv));
1920 register PERL_CONTEXT *cx;
1921 const I32 gimme = GIMME_V;
1923 U8 cxtype = CXt_LOOP_FOR;
1928 ENTER_with_name("loop1");
1931 if (PL_op->op_targ) {
1932 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1933 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1934 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1935 SVs_PADSTALE, SVs_PADSTALE);
1937 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1938 #ifndef USE_ITHREADS
1939 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1945 GV * const gv = MUTABLE_GV(POPs);
1946 svp = &GvSV(gv); /* symbol table variable */
1947 SAVEGENERICSV(*svp);
1950 iterdata = (PAD*)gv;
1954 if (PL_op->op_private & OPpITER_DEF)
1955 cxtype |= CXp_FOR_DEF;
1957 ENTER_with_name("loop2");
1959 PUSHBLOCK(cx, cxtype, SP);
1961 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1963 PUSHLOOP_FOR(cx, svp, MARK, 0);
1965 if (PL_op->op_flags & OPf_STACKED) {
1966 SV *maybe_ary = POPs;
1967 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1969 SV * const right = maybe_ary;
1972 if (RANGE_IS_NUMERIC(sv,right)) {
1973 cx->cx_type &= ~CXTYPEMASK;
1974 cx->cx_type |= CXt_LOOP_LAZYIV;
1975 /* Make sure that no-one re-orders cop.h and breaks our
1977 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1978 #ifdef NV_PRESERVES_UV
1979 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1980 (SvNV(sv) > (NV)IV_MAX)))
1982 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1983 (SvNV(right) < (NV)IV_MIN))))
1985 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1988 ((SvUV(sv) > (UV)IV_MAX) ||
1989 (SvNV(sv) > (NV)UV_MAX)))))
1991 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1993 ((SvNV(right) > 0) &&
1994 ((SvUV(right) > (UV)IV_MAX) ||
1995 (SvNV(right) > (NV)UV_MAX))))))
1997 DIE(aTHX_ "Range iterator outside integer range");
1998 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1999 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
2001 /* for correct -Dstv display */
2002 cx->blk_oldsp = sp - PL_stack_base;
2006 cx->cx_type &= ~CXTYPEMASK;
2007 cx->cx_type |= CXt_LOOP_LAZYSV;
2008 /* Make sure that no-one re-orders cop.h and breaks our
2010 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2011 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2012 cx->blk_loop.state_u.lazysv.end = right;
2013 SvREFCNT_inc(right);
2014 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2015 /* This will do the upgrade to SVt_PV, and warn if the value
2016 is uninitialised. */
2017 (void) SvPV_nolen_const(right);
2018 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2019 to replace !SvOK() with a pointer to "". */
2021 SvREFCNT_dec(right);
2022 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2026 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2027 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2028 SvREFCNT_inc(maybe_ary);
2029 cx->blk_loop.state_u.ary.ix =
2030 (PL_op->op_private & OPpITER_REVERSED) ?
2031 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2035 else { /* iterating over items on the stack */
2036 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2037 if (PL_op->op_private & OPpITER_REVERSED) {
2038 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2041 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2051 register PERL_CONTEXT *cx;
2052 const I32 gimme = GIMME_V;
2054 ENTER_with_name("loop1");
2056 ENTER_with_name("loop2");
2058 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2059 PUSHLOOP_PLAIN(cx, SP);
2067 register PERL_CONTEXT *cx;
2074 assert(CxTYPE_is_LOOP(cx));
2076 newsp = PL_stack_base + cx->blk_loop.resetsp;
2079 if (gimme == G_VOID)
2081 else if (gimme == G_SCALAR) {
2083 *++newsp = sv_mortalcopy(*SP);
2085 *++newsp = &PL_sv_undef;
2089 *++newsp = sv_mortalcopy(*++mark);
2090 TAINT_NOT; /* Each item is independent */
2096 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2097 PL_curpm = newpm; /* ... and pop $1 et al */
2099 LEAVE_with_name("loop2");
2100 LEAVE_with_name("loop1");
2108 register PERL_CONTEXT *cx;
2109 bool popsub2 = FALSE;
2110 bool clear_errsv = FALSE;
2118 const I32 cxix = dopoptosub(cxstack_ix);
2121 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2122 * sort block, which is a CXt_NULL
2125 PL_stack_base[1] = *PL_stack_sp;
2126 PL_stack_sp = PL_stack_base + 1;
2130 DIE(aTHX_ "Can't return outside a subroutine");
2132 if (cxix < cxstack_ix)
2135 if (CxMULTICALL(&cxstack[cxix])) {
2136 gimme = cxstack[cxix].blk_gimme;
2137 if (gimme == G_VOID)
2138 PL_stack_sp = PL_stack_base;
2139 else if (gimme == G_SCALAR) {
2140 PL_stack_base[1] = *PL_stack_sp;
2141 PL_stack_sp = PL_stack_base + 1;
2147 switch (CxTYPE(cx)) {
2150 retop = cx->blk_sub.retop;
2151 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2154 if (!(PL_in_eval & EVAL_KEEPERR))
2157 retop = cx->blk_eval.retop;
2161 if (optype == OP_REQUIRE &&
2162 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2164 /* Unassume the success we assumed earlier. */
2165 SV * const nsv = cx->blk_eval.old_namesv;
2166 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2167 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2172 retop = cx->blk_sub.retop;
2175 DIE(aTHX_ "panic: return");
2179 if (gimme == G_SCALAR) {
2182 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2184 *++newsp = SvREFCNT_inc(*SP);
2189 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2191 *++newsp = sv_mortalcopy(sv);
2196 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2199 *++newsp = sv_mortalcopy(*SP);
2202 *++newsp = &PL_sv_undef;
2204 else if (gimme == G_ARRAY) {
2205 while (++MARK <= SP) {
2206 *++newsp = (popsub2 && SvTEMP(*MARK))
2207 ? *MARK : sv_mortalcopy(*MARK);
2208 TAINT_NOT; /* Each item is independent */
2211 PL_stack_sp = newsp;
2214 /* Stack values are safe: */
2217 POPSUB(cx,sv); /* release CV and @_ ... */
2221 PL_curpm = newpm; /* ... and pop $1 et al */
2234 register PERL_CONTEXT *cx;
2245 if (PL_op->op_flags & OPf_SPECIAL) {
2246 cxix = dopoptoloop(cxstack_ix);
2248 DIE(aTHX_ "Can't \"last\" outside a loop block");
2251 cxix = dopoptolabel(cPVOP->op_pv);
2253 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2255 if (cxix < cxstack_ix)
2259 cxstack_ix++; /* temporarily protect top context */
2261 switch (CxTYPE(cx)) {
2262 case CXt_LOOP_LAZYIV:
2263 case CXt_LOOP_LAZYSV:
2265 case CXt_LOOP_PLAIN:
2267 newsp = PL_stack_base + cx->blk_loop.resetsp;
2268 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2272 nextop = cx->blk_sub.retop;
2276 nextop = cx->blk_eval.retop;
2280 nextop = cx->blk_sub.retop;
2283 DIE(aTHX_ "panic: last");
2287 if (gimme == G_SCALAR) {
2289 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2290 ? *SP : sv_mortalcopy(*SP);
2292 *++newsp = &PL_sv_undef;
2294 else if (gimme == G_ARRAY) {
2295 while (++MARK <= SP) {
2296 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2297 ? *MARK : sv_mortalcopy(*MARK);
2298 TAINT_NOT; /* Each item is independent */
2306 /* Stack values are safe: */
2308 case CXt_LOOP_LAZYIV:
2309 case CXt_LOOP_PLAIN:
2310 case CXt_LOOP_LAZYSV:
2312 POPLOOP(cx); /* release loop vars ... */
2316 POPSUB(cx,sv); /* release CV and @_ ... */
2319 PL_curpm = newpm; /* ... and pop $1 et al */
2322 PERL_UNUSED_VAR(optype);
2323 PERL_UNUSED_VAR(gimme);
2331 register PERL_CONTEXT *cx;
2334 if (PL_op->op_flags & OPf_SPECIAL) {
2335 cxix = dopoptoloop(cxstack_ix);
2337 DIE(aTHX_ "Can't \"next\" outside a loop block");
2340 cxix = dopoptolabel(cPVOP->op_pv);
2342 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2344 if (cxix < cxstack_ix)
2347 /* clear off anything above the scope we're re-entering, but
2348 * save the rest until after a possible continue block */
2349 inner = PL_scopestack_ix;
2351 if (PL_scopestack_ix < inner)
2352 leave_scope(PL_scopestack[PL_scopestack_ix]);
2353 PL_curcop = cx->blk_oldcop;
2354 return CX_LOOP_NEXTOP_GET(cx);
2361 register PERL_CONTEXT *cx;
2365 if (PL_op->op_flags & OPf_SPECIAL) {
2366 cxix = dopoptoloop(cxstack_ix);
2368 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2371 cxix = dopoptolabel(cPVOP->op_pv);
2373 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2375 if (cxix < cxstack_ix)
2378 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2379 if (redo_op->op_type == OP_ENTER) {
2380 /* pop one less context to avoid $x being freed in while (my $x..) */
2382 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2383 redo_op = redo_op->op_next;
2387 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2388 LEAVE_SCOPE(oldsave);
2390 PL_curcop = cx->blk_oldcop;
2395 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2399 static const char too_deep[] = "Target of goto is too deeply nested";
2401 PERL_ARGS_ASSERT_DOFINDLABEL;
2404 Perl_croak(aTHX_ too_deep);
2405 if (o->op_type == OP_LEAVE ||
2406 o->op_type == OP_SCOPE ||
2407 o->op_type == OP_LEAVELOOP ||
2408 o->op_type == OP_LEAVESUB ||
2409 o->op_type == OP_LEAVETRY)
2411 *ops++ = cUNOPo->op_first;
2413 Perl_croak(aTHX_ too_deep);
2416 if (o->op_flags & OPf_KIDS) {
2418 /* First try all the kids at this level, since that's likeliest. */
2419 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2420 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2421 const char *kid_label = CopLABEL(kCOP);
2422 if (kid_label && strEQ(kid_label, label))
2426 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2427 if (kid == PL_lastgotoprobe)
2429 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2432 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2433 ops[-1]->op_type == OP_DBSTATE)
2438 if ((o = dofindlabel(kid, label, ops, oplimit)))
2451 register PERL_CONTEXT *cx;
2452 #define GOTO_DEPTH 64
2453 OP *enterops[GOTO_DEPTH];
2454 const char *label = NULL;
2455 const bool do_dump = (PL_op->op_type == OP_DUMP);
2456 static const char must_have_label[] = "goto must have label";
2458 if (PL_op->op_flags & OPf_STACKED) {
2459 SV * const sv = POPs;
2461 /* This egregious kludge implements goto &subroutine */
2462 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2464 register PERL_CONTEXT *cx;
2465 CV *cv = MUTABLE_CV(SvRV(sv));
2472 if (!CvROOT(cv) && !CvXSUB(cv)) {
2473 const GV * const gv = CvGV(cv);
2477 /* autoloaded stub? */
2478 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2480 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2481 GvNAMELEN(gv), FALSE);
2482 if (autogv && (cv = GvCV(autogv)))
2484 tmpstr = sv_newmortal();
2485 gv_efullname3(tmpstr, gv, NULL);
2486 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2488 DIE(aTHX_ "Goto undefined subroutine");
2491 /* First do some returnish stuff. */
2492 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2494 cxix = dopoptosub(cxstack_ix);
2496 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2497 if (cxix < cxstack_ix)
2501 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2502 if (CxTYPE(cx) == CXt_EVAL) {
2504 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2506 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2508 else if (CxMULTICALL(cx))
2509 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2510 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2511 /* put @_ back onto stack */
2512 AV* av = cx->blk_sub.argarray;
2514 items = AvFILLp(av) + 1;
2515 EXTEND(SP, items+1); /* @_ could have been extended. */
2516 Copy(AvARRAY(av), SP + 1, items, SV*);
2517 SvREFCNT_dec(GvAV(PL_defgv));
2518 GvAV(PL_defgv) = cx->blk_sub.savearray;
2520 /* abandon @_ if it got reified */
2525 av_extend(av, items-1);
2527 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2530 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2531 AV* const av = GvAV(PL_defgv);
2532 items = AvFILLp(av) + 1;
2533 EXTEND(SP, items+1); /* @_ could have been extended. */
2534 Copy(AvARRAY(av), SP + 1, items, SV*);
2538 if (CxTYPE(cx) == CXt_SUB &&
2539 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2540 SvREFCNT_dec(cx->blk_sub.cv);
2541 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2542 LEAVE_SCOPE(oldsave);
2544 /* Now do some callish stuff. */
2546 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2548 OP* const retop = cx->blk_sub.retop;
2553 for (index=0; index<items; index++)
2554 sv_2mortal(SP[-index]);
2557 /* XS subs don't have a CxSUB, so pop it */
2558 POPBLOCK(cx, PL_curpm);
2559 /* Push a mark for the start of arglist */
2562 (void)(*CvXSUB(cv))(aTHX_ cv);
2567 AV* const padlist = CvPADLIST(cv);
2568 if (CxTYPE(cx) == CXt_EVAL) {
2569 PL_in_eval = CxOLD_IN_EVAL(cx);
2570 PL_eval_root = cx->blk_eval.old_eval_root;
2571 cx->cx_type = CXt_SUB;
2573 cx->blk_sub.cv = cv;
2574 cx->blk_sub.olddepth = CvDEPTH(cv);
2577 if (CvDEPTH(cv) < 2)
2578 SvREFCNT_inc_simple_void_NN(cv);
2580 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2581 sub_crush_depth(cv);
2582 pad_push(padlist, CvDEPTH(cv));
2585 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2588 AV *const av = MUTABLE_AV(PAD_SVl(0));
2590 cx->blk_sub.savearray = GvAV(PL_defgv);
2591 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2592 CX_CURPAD_SAVE(cx->blk_sub);
2593 cx->blk_sub.argarray = av;
2595 if (items >= AvMAX(av) + 1) {
2596 SV **ary = AvALLOC(av);
2597 if (AvARRAY(av) != ary) {
2598 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2601 if (items >= AvMAX(av) + 1) {
2602 AvMAX(av) = items - 1;
2603 Renew(ary,items+1,SV*);
2609 Copy(mark,AvARRAY(av),items,SV*);
2610 AvFILLp(av) = items - 1;
2611 assert(!AvREAL(av));
2613 /* transfer 'ownership' of refcnts to new @_ */
2623 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2624 Perl_get_db_sub(aTHX_ NULL, cv);
2626 CV * const gotocv = get_cvs("DB::goto", 0);
2628 PUSHMARK( PL_stack_sp );
2629 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2634 RETURNOP(CvSTART(cv));
2638 label = SvPV_nolen_const(sv);
2639 if (!(do_dump || *label))
2640 DIE(aTHX_ must_have_label);
2643 else if (PL_op->op_flags & OPf_SPECIAL) {
2645 DIE(aTHX_ must_have_label);
2648 label = cPVOP->op_pv;
2650 if (label && *label) {
2651 OP *gotoprobe = NULL;
2652 bool leaving_eval = FALSE;
2653 bool in_block = FALSE;
2654 PERL_CONTEXT *last_eval_cx = NULL;
2658 PL_lastgotoprobe = NULL;
2660 for (ix = cxstack_ix; ix >= 0; ix--) {
2662 switch (CxTYPE(cx)) {
2664 leaving_eval = TRUE;
2665 if (!CxTRYBLOCK(cx)) {
2666 gotoprobe = (last_eval_cx ?
2667 last_eval_cx->blk_eval.old_eval_root :
2672 /* else fall through */
2673 case CXt_LOOP_LAZYIV:
2674 case CXt_LOOP_LAZYSV:
2676 case CXt_LOOP_PLAIN:
2679 gotoprobe = cx->blk_oldcop->op_sibling;
2685 gotoprobe = cx->blk_oldcop->op_sibling;
2688 gotoprobe = PL_main_root;
2691 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2692 gotoprobe = CvROOT(cx->blk_sub.cv);
2698 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2701 DIE(aTHX_ "panic: goto");
2702 gotoprobe = PL_main_root;
2706 retop = dofindlabel(gotoprobe, label,
2707 enterops, enterops + GOTO_DEPTH);
2711 PL_lastgotoprobe = gotoprobe;
2714 DIE(aTHX_ "Can't find label %s", label);
2716 /* if we're leaving an eval, check before we pop any frames
2717 that we're not going to punt, otherwise the error
2720 if (leaving_eval && *enterops && enterops[1]) {
2722 for (i = 1; enterops[i]; i++)
2723 if (enterops[i]->op_type == OP_ENTERITER)
2724 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2727 if (*enterops && enterops[1]) {
2728 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2730 deprecate("\"goto\" to jump into a construct");
2733 /* pop unwanted frames */
2735 if (ix < cxstack_ix) {
2742 oldsave = PL_scopestack[PL_scopestack_ix];
2743 LEAVE_SCOPE(oldsave);
2746 /* push wanted frames */
2748 if (*enterops && enterops[1]) {
2749 OP * const oldop = PL_op;
2750 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2751 for (; enterops[ix]; ix++) {
2752 PL_op = enterops[ix];
2753 /* Eventually we may want to stack the needed arguments
2754 * for each op. For now, we punt on the hard ones. */
2755 if (PL_op->op_type == OP_ENTERITER)
2756 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2757 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2765 if (!retop) retop = PL_main_start;
2767 PL_restartop = retop;
2768 PL_do_undump = TRUE;
2772 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2773 PL_do_undump = FALSE;
2790 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2792 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2795 PL_exit_flags |= PERL_EXIT_EXPECTED;
2797 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2798 if (anum || !(PL_minus_c && PL_madskills))
2803 PUSHs(&PL_sv_undef);
2810 S_save_lines(pTHX_ AV *array, SV *sv)
2812 const char *s = SvPVX_const(sv);
2813 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2816 PERL_ARGS_ASSERT_SAVE_LINES;
2818 while (s && s < send) {
2820 SV * const tmpstr = newSV_type(SVt_PVMG);
2822 t = (const char *)memchr(s, '\n', send - s);
2828 sv_setpvn(tmpstr, s, t - s);
2829 av_store(array, line++, tmpstr);
2835 S_docatch(pTHX_ OP *o)
2839 OP * const oldop = PL_op;
2843 assert(CATCH_GET == TRUE);
2850 assert(cxstack_ix >= 0);
2851 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2852 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2857 /* die caught by an inner eval - continue inner loop */
2859 /* NB XXX we rely on the old popped CxEVAL still being at the top
2860 * of the stack; the way die_where() currently works, this
2861 * assumption is valid. In theory The cur_top_env value should be
2862 * returned in another global, the way retop (aka PL_restartop)
2864 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2867 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2869 PL_op = PL_restartop;
2886 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2887 /* sv Text to convert to OP tree. */
2888 /* startop op_free() this to undo. */
2889 /* code Short string id of the caller. */
2891 /* FIXME - how much of this code is common with pp_entereval? */
2892 dVAR; dSP; /* Make POPBLOCK work. */
2898 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2899 char *tmpbuf = tbuf;
2902 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2905 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2907 ENTER_with_name("eval");
2908 lex_start(sv, NULL, FALSE);
2910 /* switch to eval mode */
2912 if (IN_PERL_COMPILETIME) {
2913 SAVECOPSTASH_FREE(&PL_compiling);
2914 CopSTASH_set(&PL_compiling, PL_curstash);
2916 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2917 SV * const sv = sv_newmortal();
2918 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2919 code, (unsigned long)++PL_evalseq,
2920 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2925 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2926 (unsigned long)++PL_evalseq);
2927 SAVECOPFILE_FREE(&PL_compiling);
2928 CopFILE_set(&PL_compiling, tmpbuf+2);
2929 SAVECOPLINE(&PL_compiling);
2930 CopLINE_set(&PL_compiling, 1);
2931 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2932 deleting the eval's FILEGV from the stash before gv_check() runs
2933 (i.e. before run-time proper). To work around the coredump that
2934 ensues, we always turn GvMULTI_on for any globals that were
2935 introduced within evals. See force_ident(). GSAR 96-10-12 */
2936 safestr = savepvn(tmpbuf, len);
2937 SAVEDELETE(PL_defstash, safestr, len);
2939 #ifdef OP_IN_REGISTER
2945 /* we get here either during compilation, or via pp_regcomp at runtime */
2946 runtime = IN_PERL_RUNTIME;
2948 runcv = find_runcv(NULL);
2951 PL_op->op_type = OP_ENTEREVAL;
2952 PL_op->op_flags = 0; /* Avoid uninit warning. */
2953 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2957 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2959 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2960 POPBLOCK(cx,PL_curpm);
2963 (*startop)->op_type = OP_NULL;
2964 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2966 /* XXX DAPM do this properly one year */
2967 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2968 LEAVE_with_name("eval");
2969 if (IN_PERL_COMPILETIME)
2970 CopHINTS_set(&PL_compiling, PL_hints);
2971 #ifdef OP_IN_REGISTER
2974 PERL_UNUSED_VAR(newsp);
2975 PERL_UNUSED_VAR(optype);
2977 return PL_eval_start;
2982 =for apidoc find_runcv
2984 Locate the CV corresponding to the currently executing sub or eval.
2985 If db_seqp is non_null, skip CVs that are in the DB package and populate
2986 *db_seqp with the cop sequence number at the point that the DB:: code was
2987 entered. (allows debuggers to eval in the scope of the breakpoint rather
2988 than in the scope of the debugger itself).
2994 Perl_find_runcv(pTHX_ U32 *db_seqp)
3000 *db_seqp = PL_curcop->cop_seq;
3001 for (si = PL_curstackinfo; si; si = si->si_prev) {
3003 for (ix = si->si_cxix; ix >= 0; ix--) {
3004 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3005 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3006 CV * const cv = cx->blk_sub.cv;
3007 /* skip DB:: code */
3008 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3009 *db_seqp = cx->blk_oldcop->cop_seq;
3014 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3022 /* Compile a require/do, an eval '', or a /(?{...})/.
3023 * In the last case, startop is non-null, and contains the address of
3024 * a pointer that should be set to the just-compiled code.
3025 * outside is the lexically enclosing CV (if any) that invoked us.
3026 * Returns a bool indicating whether the compile was successful; if so,
3027 * PL_eval_start contains the first op of the compiled ocde; otherwise,
3028 * pushes undef (also croaks if startop != NULL).
3032 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3035 OP * const saveop = PL_op;
3037 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
3038 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3043 SAVESPTR(PL_compcv);
3044 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3045 CvEVAL_on(PL_compcv);
3046 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3047 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3049 CvOUTSIDE_SEQ(PL_compcv) = seq;
3050 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3052 /* set up a scratch pad */
3054 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3055 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3059 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3061 /* make sure we compile in the right package */
3063 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3064 SAVESPTR(PL_curstash);
3065 PL_curstash = CopSTASH(PL_curcop);
3067 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3068 SAVESPTR(PL_beginav);
3069 PL_beginav = newAV();
3070 SAVEFREESV(PL_beginav);
3071 SAVESPTR(PL_unitcheckav);
3072 PL_unitcheckav = newAV();
3073 SAVEFREESV(PL_unitcheckav);
3076 SAVEBOOL(PL_madskills);
3080 /* try to compile it */
3082 PL_eval_root = NULL;
3083 PL_curcop = &PL_compiling;
3084 CopARYBASE_set(PL_curcop, 0);
3085 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3086 PL_in_eval |= EVAL_KEEPERR;
3089 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
3090 SV **newsp; /* Used by POPBLOCK. */
3091 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
3092 I32 optype = 0; /* Might be reset by POPEVAL. */
3097 op_free(PL_eval_root);
3098 PL_eval_root = NULL;
3100 SP = PL_stack_base + POPMARK; /* pop original mark */
3102 POPBLOCK(cx,PL_curpm);
3106 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3108 msg = SvPVx_nolen_const(ERRSV);
3109 if (optype == OP_REQUIRE) {
3110 const SV * const nsv = cx->blk_eval.old_namesv;
3111 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3113 Perl_croak(aTHX_ "%sCompilation failed in require",
3114 *msg ? msg : "Unknown error\n");
3117 POPBLOCK(cx,PL_curpm);
3119 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3120 (*msg ? msg : "Unknown error\n"));
3124 sv_setpvs(ERRSV, "Compilation error");
3127 PERL_UNUSED_VAR(newsp);
3128 PUSHs(&PL_sv_undef);
3132 CopLINE_set(&PL_compiling, 0);
3134 *startop = PL_eval_root;
3136 SAVEFREEOP(PL_eval_root);
3138 /* Set the context for this new optree.
3139 * Propagate the context from the eval(). */
3140 if ((gimme & G_WANT) == G_VOID)
3141 scalarvoid(PL_eval_root);
3142 else if ((gimme & G_WANT) == G_ARRAY)
3145 scalar(PL_eval_root);
3147 DEBUG_x(dump_eval());
3149 /* Register with debugger: */
3150 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3151 CV * const cv = get_cvs("DB::postponed", 0);
3155 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3157 call_sv(MUTABLE_SV(cv), G_DISCARD);
3162 call_list(PL_scopestack_ix, PL_unitcheckav);
3164 /* compiled okay, so do it */
3166 CvDEPTH(PL_compcv) = 1;
3167 SP = PL_stack_base + POPMARK; /* pop original mark */
3168 PL_op = saveop; /* The caller may need it. */
3169 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3176 S_check_type_and_open(pTHX_ const char *name)
3179 const int st_rc = PerlLIO_stat(name, &st);
3181 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3183 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3187 return PerlIO_open(name, PERL_SCRIPT_MODE);
3190 #ifndef PERL_DISABLE_PMC
3192 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3196 PERL_ARGS_ASSERT_DOOPEN_PM;
3198 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3199 SV *const pmcsv = newSV(namelen + 2);
3200 char *const pmc = SvPVX(pmcsv);
3203 memcpy(pmc, name, namelen);
3205 pmc[namelen + 1] = '\0';
3207 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3208 fp = check_type_and_open(name);
3211 fp = check_type_and_open(pmc);
3213 SvREFCNT_dec(pmcsv);
3216 fp = check_type_and_open(name);
3221 # define doopen_pm(name, namelen) check_type_and_open(name)
3222 #endif /* !PERL_DISABLE_PMC */
3227 register PERL_CONTEXT *cx;
3234 int vms_unixname = 0;
3236 const char *tryname = NULL;
3238 const I32 gimme = GIMME_V;
3239 int filter_has_file = 0;
3240 PerlIO *tryrsfp = NULL;
3241 SV *filter_cache = NULL;
3242 SV *filter_state = NULL;
3243 SV *filter_sub = NULL;
3249 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3250 sv = new_version(sv);
3251 if (!sv_derived_from(PL_patchlevel, "version"))
3252 upg_version(PL_patchlevel, TRUE);
3253 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3254 if ( vcmp(sv,PL_patchlevel) <= 0 )
3255 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3256 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3259 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3262 SV * const req = SvRV(sv);
3263 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3265 /* get the left hand term */
3266 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3268 first = SvIV(*av_fetch(lav,0,0));
3269 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3270 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3271 || av_len(lav) > 1 /* FP with > 3 digits */
3272 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3274 DIE(aTHX_ "Perl %"SVf" required--this is only "
3275 "%"SVf", stopped", SVfARG(vnormal(req)),
3276 SVfARG(vnormal(PL_patchlevel)));
3278 else { /* probably 'use 5.10' or 'use 5.8' */
3283 second = SvIV(*av_fetch(lav,1,0));
3285 second /= second >= 600 ? 100 : 10;
3286 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3287 (int)first, (int)second);
3288 upg_version(hintsv, TRUE);
3290 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3291 "--this is only %"SVf", stopped",
3292 SVfARG(vnormal(req)),
3293 SVfARG(vnormal(sv_2mortal(hintsv))),
3294 SVfARG(vnormal(PL_patchlevel)));
3299 /* We do this only with use, not require. */
3301 /* If we request a version >= 5.9.5, load feature.pm with the
3302 * feature bundle that corresponds to the required version. */
3303 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3304 SV *const importsv = vnormal(sv);
3305 *SvPVX_mutable(importsv) = ':';
3306 ENTER_with_name("load_feature");
3307 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3308 LEAVE_with_name("load_feature");
3310 /* If a version >= 5.11.0 is requested, strictures are on by default! */
3312 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3313 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3318 name = SvPV_const(sv, len);
3319 if (!(name && len > 0 && *name))
3320 DIE(aTHX_ "Null filename used");
3321 TAINT_PROPER("require");
3325 /* The key in the %ENV hash is in the syntax of file passed as the argument
3326 * usually this is in UNIX format, but sometimes in VMS format, which
3327 * can result in a module being pulled in more than once.
3328 * To prevent this, the key must be stored in UNIX format if the VMS
3329 * name can be translated to UNIX.
3331 if ((unixname = tounixspec(name, NULL)) != NULL) {
3332 unixlen = strlen(unixname);
3338 /* if not VMS or VMS name can not be translated to UNIX, pass it
3341 unixname = (char *) name;
3344 if (PL_op->op_type == OP_REQUIRE) {
3345 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3346 unixname, unixlen, 0);
3348 if (*svp != &PL_sv_undef)
3351 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3352 "Compilation failed in require", unixname);
3356 /* prepare to compile file */
3358 if (path_is_absolute(name)) {
3360 tryrsfp = doopen_pm(name, len);
3363 AV * const ar = GvAVn(PL_incgv);
3369 namesv = newSV_type(SVt_PV);
3370 for (i = 0; i <= AvFILL(ar); i++) {
3371 SV * const dirsv = *av_fetch(ar, i, TRUE);
3373 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3380 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3381 && !sv_isobject(loader))
3383 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3386 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3387 PTR2UV(SvRV(dirsv)), name);
3388 tryname = SvPVX_const(namesv);
3391 ENTER_with_name("call_INC");
3399 if (sv_isobject(loader))
3400 count = call_method("INC", G_ARRAY);
3402 count = call_sv(loader, G_ARRAY);
3405 /* Adjust file name if the hook has set an %INC entry */
3406 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3408 tryname = SvPV_nolen_const(*svp);
3417 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3418 && !isGV_with_GP(SvRV(arg))) {
3419 filter_cache = SvRV(arg);
3420 SvREFCNT_inc_simple_void_NN(filter_cache);
3427 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3431 if (isGV_with_GP(arg)) {
3432 IO * const io = GvIO((const GV *)arg);
3437 tryrsfp = IoIFP(io);
3438 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3439 PerlIO_close(IoOFP(io));
3450 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3452 SvREFCNT_inc_simple_void_NN(filter_sub);
3455 filter_state = SP[i];
3456 SvREFCNT_inc_simple_void(filter_state);
3460 if (!tryrsfp && (filter_cache || filter_sub)) {
3461 tryrsfp = PerlIO_open(BIT_BUCKET,
3469 LEAVE_with_name("call_INC");
3476 filter_has_file = 0;
3478 SvREFCNT_dec(filter_cache);
3479 filter_cache = NULL;
3482 SvREFCNT_dec(filter_state);
3483 filter_state = NULL;
3486 SvREFCNT_dec(filter_sub);
3491 if (!path_is_absolute(name)
3497 dir = SvPV_const(dirsv, dirlen);
3505 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3507 sv_setpv(namesv, unixdir);
3508 sv_catpv(namesv, unixname);
3510 # ifdef __SYMBIAN32__
3511 if (PL_origfilename[0] &&
3512 PL_origfilename[1] == ':' &&
3513 !(dir[0] && dir[1] == ':'))
3514 Perl_sv_setpvf(aTHX_ namesv,
3519 Perl_sv_setpvf(aTHX_ namesv,
3523 /* The equivalent of
3524 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3525 but without the need to parse the format string, or
3526 call strlen on either pointer, and with the correct
3527 allocation up front. */
3529 char *tmp = SvGROW(namesv, dirlen + len + 2);
3531 memcpy(tmp, dir, dirlen);
3534 /* name came from an SV, so it will have a '\0' at the
3535 end that we can copy as part of this memcpy(). */
3536 memcpy(tmp, name, len + 1);
3538 SvCUR_set(namesv, dirlen + len + 1);
3540 /* Don't even actually have to turn SvPOK_on() as we
3541 access it directly with SvPVX() below. */
3545 TAINT_PROPER("require");
3546 tryname = SvPVX_const(namesv);
3547 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3549 if (tryname[0] == '.' && tryname[1] == '/') {
3551 while (*++tryname == '/');
3555 else if (errno == EMFILE)
3556 /* no point in trying other paths if out of handles */
3563 SAVECOPFILE_FREE(&PL_compiling);
3564 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3565 SvREFCNT_dec(namesv);
3567 if (PL_op->op_type == OP_REQUIRE) {
3568 const char *msgstr = name;
3569 if(errno == EMFILE) {
3571 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3573 msgstr = SvPV_nolen_const(msg);
3575 if (namesv) { /* did we lookup @INC? */
3576 AV * const ar = GvAVn(PL_incgv);
3578 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3579 "%s in @INC%s%s (@INC contains:",
3581 (instr(msgstr, ".h ")
3582 ? " (change .h to .ph maybe?)" : ""),
3583 (instr(msgstr, ".ph ")
3584 ? " (did you run h2ph?)" : "")
3587 for (i = 0; i <= AvFILL(ar); i++) {
3588 sv_catpvs(msg, " ");
3589 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3591 sv_catpvs(msg, ")");
3592 msgstr = SvPV_nolen_const(msg);
3595 DIE(aTHX_ "Can't locate %s", msgstr);
3601 SETERRNO(0, SS_NORMAL);
3603 /* Assume success here to prevent recursive requirement. */
3604 /* name is never assigned to again, so len is still strlen(name) */
3605 /* Check whether a hook in @INC has already filled %INC */
3607 (void)hv_store(GvHVn(PL_incgv),
3608 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3610 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3612 (void)hv_store(GvHVn(PL_incgv),
3613 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3616 ENTER_with_name("eval");
3618 lex_start(NULL, tryrsfp, TRUE);
3622 hv_clear(GvHV(PL_hintgv));
3624 SAVECOMPILEWARNINGS();
3625 if (PL_dowarn & G_WARN_ALL_ON)
3626 PL_compiling.cop_warnings = pWARN_ALL ;
3627 else if (PL_dowarn & G_WARN_ALL_OFF)
3628 PL_compiling.cop_warnings = pWARN_NONE ;
3630 PL_compiling.cop_warnings = pWARN_STD ;
3632 if (filter_sub || filter_cache) {
3633 /* We can use the SvPV of the filter PVIO itself as our cache, rather
3634 than hanging another SV from it. In turn, filter_add() optionally
3635 takes the SV to use as the filter (or creates a new SV if passed
3636 NULL), so simply pass in whatever value filter_cache has. */
3637 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3638 IoLINES(datasv) = filter_has_file;
3639 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3640 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3643 /* switch to eval mode */
3644 PUSHBLOCK(cx, CXt_EVAL, SP);
3646 cx->blk_eval.retop = PL_op->op_next;
3648 SAVECOPLINE(&PL_compiling);
3649 CopLINE_set(&PL_compiling, 0);
3653 /* Store and reset encoding. */
3654 encoding = PL_encoding;
3657 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3658 op = DOCATCH(PL_eval_start);
3660 op = PL_op->op_next;
3662 /* Restore encoding. */
3663 PL_encoding = encoding;
3668 /* This is a op added to hold the hints hash for
3669 pp_entereval. The hash can be modified by the code
3670 being eval'ed, so we return a copy instead. */
3676 mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3684 register PERL_CONTEXT *cx;
3686 const I32 gimme = GIMME_V;
3687 const U32 was = PL_breakable_sub_gen;
3688 char tbuf[TYPE_DIGITS(long) + 12];
3689 char *tmpbuf = tbuf;
3693 HV *saved_hh = NULL;
3695 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3696 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3700 TAINT_IF(SvTAINTED(sv));
3701 TAINT_PROPER("eval");
3703 ENTER_with_name("eval");
3704 lex_start(sv, NULL, FALSE);
3707 /* switch to eval mode */
3709 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3710 SV * const temp_sv = sv_newmortal();
3711 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3712 (unsigned long)++PL_evalseq,
3713 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3714 tmpbuf = SvPVX(temp_sv);
3715 len = SvCUR(temp_sv);
3718 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3719 SAVECOPFILE_FREE(&PL_compiling);
3720 CopFILE_set(&PL_compiling, tmpbuf+2);
3721 SAVECOPLINE(&PL_compiling);
3722 CopLINE_set(&PL_compiling, 1);
3723 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3724 deleting the eval's FILEGV from the stash before gv_check() runs
3725 (i.e. before run-time proper). To work around the coredump that
3726 ensues, we always turn GvMULTI_on for any globals that were
3727 introduced within evals. See force_ident(). GSAR 96-10-12 */
3729 PL_hints = PL_op->op_targ;
3731 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3732 SvREFCNT_dec(GvHV(PL_hintgv));
3733 GvHV(PL_hintgv) = saved_hh;
3735 SAVECOMPILEWARNINGS();
3736 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3737 if (PL_compiling.cop_hints_hash) {
3738 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3740 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3741 if (PL_compiling.cop_hints_hash) {
3743 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3744 HINTS_REFCNT_UNLOCK;
3746 /* special case: an eval '' executed within the DB package gets lexically
3747 * placed in the first non-DB CV rather than the current CV - this
3748 * allows the debugger to execute code, find lexicals etc, in the
3749 * scope of the code being debugged. Passing &seq gets find_runcv
3750 * to do the dirty work for us */
3751 runcv = find_runcv(&seq);
3753 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3755 cx->blk_eval.retop = PL_op->op_next;
3757 /* prepare to compile string */
3759 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3760 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3763 if (doeval(gimme, NULL, runcv, seq)) {
3764 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3765 ? (PERLDB_LINE || PERLDB_SAVESRC)
3766 : PERLDB_SAVESRC_NOSUBS) {
3767 /* Retain the filegv we created. */
3769 char *const safestr = savepvn(tmpbuf, len);
3770 SAVEDELETE(PL_defstash, safestr, len);
3772 return DOCATCH(PL_eval_start);
3774 /* We have already left the scope set up earler thanks to the LEAVE
3776 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3777 ? (PERLDB_LINE || PERLDB_SAVESRC)
3778 : PERLDB_SAVESRC_INVALID) {
3779 /* Retain the filegv we created. */
3781 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3783 return PL_op->op_next;
3794 register PERL_CONTEXT *cx;
3796 const U8 save_flags = PL_op -> op_flags;
3801 retop = cx->blk_eval.retop;
3804 if (gimme == G_VOID)
3806 else if (gimme == G_SCALAR) {
3809 if (SvFLAGS(TOPs) & SVs_TEMP)
3812 *MARK = sv_mortalcopy(TOPs);
3816 *MARK = &PL_sv_undef;
3821 /* in case LEAVE wipes old return values */
3822 for (mark = newsp + 1; mark <= SP; mark++) {
3823 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3824 *mark = sv_mortalcopy(*mark);
3825 TAINT_NOT; /* Each item is independent */
3829 PL_curpm = newpm; /* Don't pop $1 et al till now */
3832 assert(CvDEPTH(PL_compcv) == 1);
3834 CvDEPTH(PL_compcv) = 0;
3837 if (optype == OP_REQUIRE &&
3838 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3840 /* Unassume the success we assumed earlier. */
3841 SV * const nsv = cx->blk_eval.old_namesv;
3842 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3843 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3844 /* die_where() did LEAVE, or we won't be here */
3847 LEAVE_with_name("eval");
3848 if (!(save_flags & OPf_SPECIAL)) {
3856 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3857 close to the related Perl_create_eval_scope. */
3859 Perl_delete_eval_scope(pTHX)
3864 register PERL_CONTEXT *cx;
3870 LEAVE_with_name("eval_scope");
3871 PERL_UNUSED_VAR(newsp);
3872 PERL_UNUSED_VAR(gimme);
3873 PERL_UNUSED_VAR(optype);
3876 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3877 also needed by Perl_fold_constants. */
3879 Perl_create_eval_scope(pTHX_ U32 flags)
3882 const I32 gimme = GIMME_V;
3884 ENTER_with_name("eval_scope");
3887 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3890 PL_in_eval = EVAL_INEVAL;
3891 if (flags & G_KEEPERR)
3892 PL_in_eval |= EVAL_KEEPERR;
3895 if (flags & G_FAKINGEVAL) {
3896 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3904 PERL_CONTEXT * const cx = create_eval_scope(0);
3905 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3906 return DOCATCH(PL_op->op_next);
3915 register PERL_CONTEXT *cx;
3920 PERL_UNUSED_VAR(optype);
3923 if (gimme == G_VOID)
3925 else if (gimme == G_SCALAR) {
3929 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3932 *MARK = sv_mortalcopy(TOPs);
3936 *MARK = &PL_sv_undef;
3941 /* in case LEAVE wipes old return values */
3943 for (mark = newsp + 1; mark <= SP; mark++) {
3944 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3945 *mark = sv_mortalcopy(*mark);
3946 TAINT_NOT; /* Each item is independent */
3950 PL_curpm = newpm; /* Don't pop $1 et al till now */
3952 LEAVE_with_name("eval_scope");
3960 register PERL_CONTEXT *cx;
3961 const I32 gimme = GIMME_V;
3963 ENTER_with_name("given");
3966 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3968 PUSHBLOCK(cx, CXt_GIVEN, SP);
3977 register PERL_CONTEXT *cx;
3981 PERL_UNUSED_CONTEXT;
3984 assert(CxTYPE(cx) == CXt_GIVEN);
3989 PL_curpm = newpm; /* pop $1 et al */
3991 LEAVE_with_name("given");
3996 /* Helper routines used by pp_smartmatch */
3998 S_make_matcher(pTHX_ REGEXP *re)
4001 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4003 PERL_ARGS_ASSERT_MAKE_MATCHER;
4005 PM_SETRE(matcher, ReREFCNT_inc(re));
4007 SAVEFREEOP((OP *) matcher);
4008 ENTER_with_name("matcher"); SAVETMPS;
4014 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4019 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4021 PL_op = (OP *) matcher;
4026 return (SvTRUEx(POPs));
4030 S_destroy_matcher(pTHX_ PMOP *matcher)
4034 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4035 PERL_UNUSED_ARG(matcher);
4038 LEAVE_with_name("matcher");
4041 /* Do a smart match */
4044 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4045 return do_smartmatch(NULL, NULL);
4048 /* This version of do_smartmatch() implements the
4049 * table of smart matches that is found in perlsyn.
4052 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4057 bool object_on_left = FALSE;
4058 SV *e = TOPs; /* e is for 'expression' */
4059 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4061 /* First of all, handle overload magic of the rightmost argument */
4064 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4065 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4067 tmpsv = amagic_call(d, e, smart_amg, 0);
4074 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4077 SP -= 2; /* Pop the values */
4079 /* Take care only to invoke mg_get() once for each argument.
4080 * Currently we do this by copying the SV if it's magical. */
4083 d = sv_mortalcopy(d);
4090 e = sv_mortalcopy(e);
4094 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4101 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4102 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4103 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4105 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4106 object_on_left = TRUE;
4109 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4111 if (object_on_left) {
4112 goto sm_any_sub; /* Treat objects like scalars */
4114 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4115 /* Test sub truth for each key */
4117 bool andedresults = TRUE;
4118 HV *hv = (HV*) SvRV(d);
4119 I32 numkeys = hv_iterinit(hv);
4120 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4123 while ( (he = hv_iternext(hv)) ) {
4124 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4125 ENTER_with_name("smartmatch_hash_key_test");
4128 PUSHs(hv_iterkeysv(he));
4130 c = call_sv(e, G_SCALAR);
4133 andedresults = FALSE;
4135 andedresults = SvTRUEx(POPs) && andedresults;
4137 LEAVE_with_name("smartmatch_hash_key_test");
4144 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4145 /* Test sub truth for each element */
4147 bool andedresults = TRUE;
4148 AV *av = (AV*) SvRV(d);
4149 const I32 len = av_len(av);
4150 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4153 for (i = 0; i <= len; ++i) {
4154 SV * const * const svp = av_fetch(av, i, FALSE);
4155 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4156 ENTER_with_name("smartmatch_array_elem_test");
4162 c = call_sv(e, G_SCALAR);
4165 andedresults = FALSE;
4167 andedresults = SvTRUEx(POPs) && andedresults;
4169 LEAVE_with_name("smartmatch_array_elem_test");
4178 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4179 ENTER_with_name("smartmatch_coderef");
4184 c = call_sv(e, G_SCALAR);
4188 else if (SvTEMP(TOPs))
4189 SvREFCNT_inc_void(TOPs);
4191 LEAVE_with_name("smartmatch_coderef");
4196 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4197 if (object_on_left) {
4198 goto sm_any_hash; /* Treat objects like scalars */
4200 else if (!SvOK(d)) {
4201 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4204 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4205 /* Check that the key-sets are identical */
4207 HV *other_hv = MUTABLE_HV(SvRV(d));
4209 bool other_tied = FALSE;
4210 U32 this_key_count = 0,
4211 other_key_count = 0;
4212 HV *hv = MUTABLE_HV(SvRV(e));
4214 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4215 /* Tied hashes don't know how many keys they have. */
4216 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4219 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4220 HV * const temp = other_hv;
4225 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4228 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4231 /* The hashes have the same number of keys, so it suffices
4232 to check that one is a subset of the other. */
4233 (void) hv_iterinit(hv);
4234 while ( (he = hv_iternext(hv)) ) {
4235 SV *key = hv_iterkeysv(he);
4237 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4240 if(!hv_exists_ent(other_hv, key, 0)) {
4241 (void) hv_iterinit(hv); /* reset iterator */
4247 (void) hv_iterinit(other_hv);
4248 while ( hv_iternext(other_hv) )
4252 other_key_count = HvUSEDKEYS(other_hv);
4254 if (this_key_count != other_key_count)
4259 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4260 AV * const other_av = MUTABLE_AV(SvRV(d));
4261 const I32 other_len = av_len(other_av) + 1;
4263 HV *hv = MUTABLE_HV(SvRV(e));
4265 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4266 for (i = 0; i < other_len; ++i) {
4267 SV ** const svp = av_fetch(other_av, i, FALSE);
4268 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4269 if (svp) { /* ??? When can this not happen? */
4270 if (hv_exists_ent(hv, *svp, 0))
4276 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4277 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4280 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4282 HV *hv = MUTABLE_HV(SvRV(e));
4284 (void) hv_iterinit(hv);
4285 while ( (he = hv_iternext(hv)) ) {
4286 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4287 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4288 (void) hv_iterinit(hv);
4289 destroy_matcher(matcher);
4293 destroy_matcher(matcher);
4299 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4300 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4307 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4308 if (object_on_left) {
4309 goto sm_any_array; /* Treat objects like scalars */
4311 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4312 AV * const other_av = MUTABLE_AV(SvRV(e));
4313 const I32 other_len = av_len(other_av) + 1;
4316 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4317 for (i = 0; i < other_len; ++i) {
4318 SV ** const svp = av_fetch(other_av, i, FALSE);
4320 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4321 if (svp) { /* ??? When can this not happen? */
4322 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4328 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4329 AV *other_av = MUTABLE_AV(SvRV(d));
4330 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4331 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4335 const I32 other_len = av_len(other_av);
4337 if (NULL == seen_this) {
4338 seen_this = newHV();
4339 (void) sv_2mortal(MUTABLE_SV(seen_this));
4341 if (NULL == seen_other) {
4342 seen_other = newHV();
4343 (void) sv_2mortal(MUTABLE_SV(seen_other));
4345 for(i = 0; i <= other_len; ++i) {
4346 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4347 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4349 if (!this_elem || !other_elem) {
4350 if ((this_elem && SvOK(*this_elem))
4351 || (other_elem && SvOK(*other_elem)))
4354 else if (hv_exists_ent(seen_this,
4355 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4356 hv_exists_ent(seen_other,
4357 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4359 if (*this_elem != *other_elem)
4363 (void)hv_store_ent(seen_this,
4364 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4366 (void)hv_store_ent(seen_other,
4367 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4373 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4374 (void) do_smartmatch(seen_this, seen_other);
4376 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4385 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4386 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4389 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4390 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4393 for(i = 0; i <= this_len; ++i) {
4394 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4395 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4396 if (svp && matcher_matches_sv(matcher, *svp)) {
4397 destroy_matcher(matcher);
4401 destroy_matcher(matcher);
4405 else if (!SvOK(d)) {
4406 /* undef ~~ array */
4407 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4410 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4411 for (i = 0; i <= this_len; ++i) {
4412 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4413 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4414 if (!svp || !SvOK(*svp))
4423 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4425 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4426 for (i = 0; i <= this_len; ++i) {
4427 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4434 /* infinite recursion isn't supposed to happen here */
4435 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4436 (void) do_smartmatch(NULL, NULL);
4438 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4447 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4448 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4449 SV *t = d; d = e; e = t;
4450 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4453 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4454 SV *t = d; d = e; e = t;
4455 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4456 goto sm_regex_array;
4459 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4461 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4463 PUSHs(matcher_matches_sv(matcher, d)
4466 destroy_matcher(matcher);
4471 /* See if there is overload magic on left */
4472 else if (object_on_left && SvAMAGIC(d)) {
4474 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4475 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4478 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4486 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4489 else if (!SvOK(d)) {
4490 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4491 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4496 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4497 DEBUG_M(if (SvNIOK(e))
4498 Perl_deb(aTHX_ " applying rule Any-Num\n");
4500 Perl_deb(aTHX_ " applying rule Num-numish\n");
4502 /* numeric comparison */
4505 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4516 /* As a last resort, use string comparison */
4517 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4526 register PERL_CONTEXT *cx;
4527 const I32 gimme = GIMME_V;
4529 /* This is essentially an optimization: if the match
4530 fails, we don't want to push a context and then
4531 pop it again right away, so we skip straight
4532 to the op that follows the leavewhen.
4534 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4535 return cLOGOP->op_other->op_next;
4537 ENTER_with_name("eval");
4540 PUSHBLOCK(cx, CXt_WHEN, SP);
4549 register PERL_CONTEXT *cx;
4555 assert(CxTYPE(cx) == CXt_WHEN);
4560 PL_curpm = newpm; /* pop $1 et al */
4562 LEAVE_with_name("eval");
4570 register PERL_CONTEXT *cx;
4573 cxix = dopoptowhen(cxstack_ix);
4575 DIE(aTHX_ "Can't \"continue\" outside a when block");
4576 if (cxix < cxstack_ix)
4579 /* clear off anything above the scope we're re-entering */
4580 inner = PL_scopestack_ix;
4582 if (PL_scopestack_ix < inner)
4583 leave_scope(PL_scopestack[PL_scopestack_ix]);
4584 PL_curcop = cx->blk_oldcop;
4585 return cx->blk_givwhen.leave_op;
4592 register PERL_CONTEXT *cx;
4595 cxix = dopoptogiven(cxstack_ix);
4597 if (PL_op->op_flags & OPf_SPECIAL)
4598 DIE(aTHX_ "Can't use when() outside a topicalizer");
4600 DIE(aTHX_ "Can't \"break\" outside a given block");
4602 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4603 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4605 if (cxix < cxstack_ix)
4608 /* clear off anything above the scope we're re-entering */
4609 inner = PL_scopestack_ix;
4611 if (PL_scopestack_ix < inner)
4612 leave_scope(PL_scopestack[PL_scopestack_ix]);
4613 PL_curcop = cx->blk_oldcop;
4616 return CX_LOOP_NEXTOP_GET(cx);
4618 return cx->blk_givwhen.leave_op;
4622 S_doparseform(pTHX_ SV *sv)
4625 register char *s = SvPV_force(sv, len);
4626 register char * const send = s + len;
4627 register char *base = NULL;
4628 register I32 skipspaces = 0;
4629 bool noblank = FALSE;
4630 bool repeat = FALSE;
4631 bool postspace = FALSE;
4637 bool unchopnum = FALSE;
4638 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4640 PERL_ARGS_ASSERT_DOPARSEFORM;
4643 Perl_croak(aTHX_ "Null picture in formline");
4645 /* estimate the buffer size needed */
4646 for (base = s; s <= send; s++) {
4647 if (*s == '\n' || *s == '@' || *s == '^')
4653 Newx(fops, maxops, U32);
4658 *fpc++ = FF_LINEMARK;
4659 noblank = repeat = FALSE;
4677 case ' ': case '\t':
4684 } /* else FALL THROUGH */
4692 *fpc++ = FF_LITERAL;
4700 *fpc++ = (U16)skipspaces;
4704 *fpc++ = FF_NEWLINE;
4708 arg = fpc - linepc + 1;
4715 *fpc++ = FF_LINEMARK;
4716 noblank = repeat = FALSE;
4725 ischop = s[-1] == '^';
4731 arg = (s - base) - 1;
4733 *fpc++ = FF_LITERAL;
4741 *fpc++ = 2; /* skip the @* or ^* */
4743 *fpc++ = FF_LINESNGL;
4746 *fpc++ = FF_LINEGLOB;
4748 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4749 arg = ischop ? 512 : 0;
4754 const char * const f = ++s;
4757 arg |= 256 + (s - f);
4759 *fpc++ = s - base; /* fieldsize for FETCH */
4760 *fpc++ = FF_DECIMAL;
4762 unchopnum |= ! ischop;
4764 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4765 arg = ischop ? 512 : 0;
4767 s++; /* skip the '0' first */
4771 const char * const f = ++s;
4774 arg |= 256 + (s - f);
4776 *fpc++ = s - base; /* fieldsize for FETCH */
4777 *fpc++ = FF_0DECIMAL;
4779 unchopnum |= ! ischop;
4783 bool ismore = FALSE;
4786 while (*++s == '>') ;
4787 prespace = FF_SPACE;
4789 else if (*s == '|') {
4790 while (*++s == '|') ;
4791 prespace = FF_HALFSPACE;
4796 while (*++s == '<') ;
4799 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4803 *fpc++ = s - base; /* fieldsize for FETCH */
4805 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4808 *fpc++ = (U16)prespace;
4822 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4824 { /* need to jump to the next word */
4826 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4827 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4828 s = SvPVX(sv) + SvCUR(sv) + z;
4830 Copy(fops, s, arg, U32);
4832 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4835 if (unchopnum && repeat)
4836 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4842 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4844 /* Can value be printed in fldsize chars, using %*.*f ? */
4848 int intsize = fldsize - (value < 0 ? 1 : 0);
4855 while (intsize--) pwr *= 10.0;
4856 while (frcsize--) eps /= 10.0;
4859 if (value + eps >= pwr)
4862 if (value - eps <= -pwr)
4869 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4872 SV * const datasv = FILTER_DATA(idx);
4873 const int filter_has_file = IoLINES(datasv);
4874 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4875 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4880 char *prune_from = NULL;
4881 bool read_from_cache = FALSE;
4884 PERL_ARGS_ASSERT_RUN_USER_FILTER;
4886 assert(maxlen >= 0);
4889 /* I was having segfault trouble under Linux 2.2.5 after a
4890 parse error occured. (Had to hack around it with a test
4891 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4892 not sure where the trouble is yet. XXX */
4895 SV *const cache = datasv;
4898 const char *cache_p = SvPV(cache, cache_len);
4902 /* Running in block mode and we have some cached data already.
4904 if (cache_len >= umaxlen) {
4905 /* In fact, so much data we don't even need to call
4910 const char *const first_nl =
4911 (const char *)memchr(cache_p, '\n', cache_len);
4913 take = first_nl + 1 - cache_p;
4917 sv_catpvn(buf_sv, cache_p, take);
4918 sv_chop(cache, cache_p + take);
4919 /* Definately not EOF */
4923 sv_catsv(buf_sv, cache);
4925 umaxlen -= cache_len;
4928 read_from_cache = TRUE;
4932 /* Filter API says that the filter appends to the contents of the buffer.
4933 Usually the buffer is "", so the details don't matter. But if it's not,
4934 then clearly what it contains is already filtered by this filter, so we
4935 don't want to pass it in a second time.
4936 I'm going to use a mortal in case the upstream filter croaks. */
4937 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4938 ? sv_newmortal() : buf_sv;
4939 SvUPGRADE(upstream, SVt_PV);
4941 if (filter_has_file) {
4942 status = FILTER_READ(idx+1, upstream, 0);
4945 if (filter_sub && status >= 0) {
4949 ENTER_with_name("call_filter_sub");
4954 DEFSV_set(upstream);
4958 PUSHs(filter_state);
4961 count = call_sv(filter_sub, G_SCALAR);
4973 LEAVE_with_name("call_filter_sub");
4976 if(SvOK(upstream)) {
4977 got_p = SvPV(upstream, got_len);
4979 if (got_len > umaxlen) {
4980 prune_from = got_p + umaxlen;
4983 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
4984 if (first_nl && first_nl + 1 < got_p + got_len) {
4985 /* There's a second line here... */
4986 prune_from = first_nl + 1;
4991 /* Oh. Too long. Stuff some in our cache. */
4992 STRLEN cached_len = got_p + got_len - prune_from;
4993 SV *const cache = datasv;
4996 /* Cache should be empty. */
4997 assert(!SvCUR(cache));
5000 sv_setpvn(cache, prune_from, cached_len);
5001 /* If you ask for block mode, you may well split UTF-8 characters.
5002 "If it breaks, you get to keep both parts"
5003 (Your code is broken if you don't put them back together again
5004 before something notices.) */
5005 if (SvUTF8(upstream)) {
5008 SvCUR_set(upstream, got_len - cached_len);
5010 /* Can't yet be EOF */
5015 /* If they are at EOF but buf_sv has something in it, then they may never
5016 have touched the SV upstream, so it may be undefined. If we naively
5017 concatenate it then we get a warning about use of uninitialised value.
5019 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5020 sv_catsv(buf_sv, upstream);
5024 IoLINES(datasv) = 0;
5026 SvREFCNT_dec(filter_state);
5027 IoTOP_GV(datasv) = NULL;
5030 SvREFCNT_dec(filter_sub);
5031 IoBOTTOM_GV(datasv) = NULL;
5033 filter_del(S_run_user_filter);
5035 if (status == 0 && read_from_cache) {
5036 /* If we read some data from the cache (and by getting here it implies
5037 that we emptied the cache) then we aren't yet at EOF, and mustn't
5038 report that to our caller. */
5044 /* perhaps someone can come up with a better name for
5045 this? it is not really "absolute", per se ... */
5047 S_path_is_absolute(const char *name)
5049 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5051 if (PERL_FILE_IS_ABSOLUTE(name)
5053 || (*name == '.' && ((name[1] == '/' ||
5054 (name[1] == '.' && name[2] == '/'))
5055 || (name[1] == '\\' ||
5056 ( name[1] == '.' && name[2] == '\\')))
5059 || (*name == '.' && (name[1] == '/' ||
5060 (name[1] == '.' && name[2] == '/')))
5072 * c-indentation-style: bsd
5074 * indent-tabs-mode: t
5077 * ex: set ts=8 sts=4 sw=4 noet: