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) {
96 if (PL_op->op_flags & OPf_STACKED) {
97 /* multiple args; concatentate them */
99 tmpstr = PAD_SV(ARGTARG);
100 sv_setpvs(tmpstr, "");
101 while (++MARK <= SP) {
102 if (PL_amagic_generation) {
104 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
105 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
107 sv_setsv(tmpstr, sv);
111 sv_catsv(tmpstr, *MARK);
120 SV * const sv = SvRV(tmpstr);
121 if (SvTYPE(sv) == SVt_REGEXP)
125 re = reg_temp_copy(re);
126 ReREFCNT_dec(PM_GETRE(pm));
131 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
133 assert (re != (REGEXP*) &PL_sv_undef);
135 /* Check against the last compiled regexp. */
136 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
137 memNE(RX_PRECOMP(re), t, len))
139 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
140 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
144 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
146 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
148 } else if (PL_curcop->cop_hints_hash) {
149 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
151 if (ptr && SvIOK(ptr) && SvIV(ptr))
152 eng = INT2PTR(regexp_engine*,SvIV(ptr));
155 if (PL_op->op_flags & OPf_SPECIAL)
156 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
158 if (DO_UTF8(tmpstr)) {
159 assert (SvUTF8(tmpstr));
160 } else if (SvUTF8(tmpstr)) {
161 /* Not doing UTF-8, despite what the SV says. Is this only if
162 we're trapped in use 'bytes'? */
163 /* Make a copy of the octet sequence, but without the flag on,
164 as the compiler now honours the SvUTF8 flag on tmpstr. */
166 const char *const p = SvPV(tmpstr, len);
167 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
171 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
173 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
175 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
176 inside tie/overload accessors. */
182 #ifndef INCOMPLETE_TAINTS
185 RX_EXTFLAGS(re) |= RXf_TAINTED;
187 RX_EXTFLAGS(re) &= ~RXf_TAINTED;
191 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
195 #if !defined(USE_ITHREADS)
196 /* can't change the optree at runtime either */
197 /* PMf_KEEP is handled differently under threads to avoid these problems */
198 if (pm->op_pmflags & PMf_KEEP) {
199 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
200 cLOGOP->op_first->op_next = PL_op->op_next;
210 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
211 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
212 register SV * const dstr = cx->sb_dstr;
213 register char *s = cx->sb_s;
214 register char *m = cx->sb_m;
215 char *orig = cx->sb_orig;
216 register REGEXP * const rx = cx->sb_rx;
218 REGEXP *old = PM_GETRE(pm);
222 PM_SETRE(pm,ReREFCNT_inc(rx));
225 rxres_restore(&cx->sb_rxres, rx);
226 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
228 if (cx->sb_iters++) {
229 const I32 saviters = cx->sb_iters;
230 if (cx->sb_iters > cx->sb_maxiters)
231 DIE(aTHX_ "Substitution loop");
233 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
234 cx->sb_rxtainted |= 2;
235 sv_catsv(dstr, POPs);
236 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
240 if (CxONCE(cx) || s < orig ||
241 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
242 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
243 ((cx->sb_rflags & REXEC_COPY_STR)
244 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
245 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
247 SV * const targ = cx->sb_targ;
249 assert(cx->sb_strend >= s);
250 if(cx->sb_strend > s) {
251 if (DO_UTF8(dstr) && !SvUTF8(targ))
252 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
254 sv_catpvn(dstr, s, cx->sb_strend - s);
256 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
258 #ifdef PERL_OLD_COPY_ON_WRITE
260 sv_force_normal_flags(targ, SV_COW_DROP_PV);
266 SvPV_set(targ, SvPVX(dstr));
267 SvCUR_set(targ, SvCUR(dstr));
268 SvLEN_set(targ, SvLEN(dstr));
271 SvPV_set(dstr, NULL);
273 TAINT_IF(cx->sb_rxtainted & 1);
274 mPUSHi(saviters - 1);
276 (void)SvPOK_only_UTF8(targ);
277 TAINT_IF(cx->sb_rxtainted);
281 LEAVE_SCOPE(cx->sb_oldsave);
283 RETURNOP(pm->op_next);
285 cx->sb_iters = saviters;
287 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
290 cx->sb_orig = orig = RX_SUBBEG(rx);
292 cx->sb_strend = s + (cx->sb_strend - m);
294 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
296 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
297 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
299 sv_catpvn(dstr, s, m-s);
301 cx->sb_s = RX_OFFS(rx)[0].end + orig;
302 { /* Update the pos() information. */
303 SV * const sv = cx->sb_targ;
305 SvUPGRADE(sv, SVt_PVMG);
306 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
307 #ifdef PERL_OLD_COPY_ON_WRITE
309 sv_force_normal_flags(sv, 0);
311 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
314 mg->mg_len = m - orig;
317 (void)ReREFCNT_inc(rx);
318 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
319 rxres_save(&cx->sb_rxres, rx);
320 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
324 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
329 PERL_ARGS_ASSERT_RXRES_SAVE;
332 if (!p || p[1] < RX_NPARENS(rx)) {
333 #ifdef PERL_OLD_COPY_ON_WRITE
334 i = 7 + RX_NPARENS(rx) * 2;
336 i = 6 + RX_NPARENS(rx) * 2;
345 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
346 RX_MATCH_COPIED_off(rx);
348 #ifdef PERL_OLD_COPY_ON_WRITE
349 *p++ = PTR2UV(RX_SAVED_COPY(rx));
350 RX_SAVED_COPY(rx) = NULL;
353 *p++ = RX_NPARENS(rx);
355 *p++ = PTR2UV(RX_SUBBEG(rx));
356 *p++ = (UV)RX_SUBLEN(rx);
357 for (i = 0; i <= RX_NPARENS(rx); ++i) {
358 *p++ = (UV)RX_OFFS(rx)[i].start;
359 *p++ = (UV)RX_OFFS(rx)[i].end;
364 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
369 PERL_ARGS_ASSERT_RXRES_RESTORE;
372 RX_MATCH_COPY_FREE(rx);
373 RX_MATCH_COPIED_set(rx, *p);
376 #ifdef PERL_OLD_COPY_ON_WRITE
377 if (RX_SAVED_COPY(rx))
378 SvREFCNT_dec (RX_SAVED_COPY(rx));
379 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
383 RX_NPARENS(rx) = *p++;
385 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
386 RX_SUBLEN(rx) = (I32)(*p++);
387 for (i = 0; i <= RX_NPARENS(rx); ++i) {
388 RX_OFFS(rx)[i].start = (I32)(*p++);
389 RX_OFFS(rx)[i].end = (I32)(*p++);
394 S_rxres_free(pTHX_ void **rsp)
396 UV * const p = (UV*)*rsp;
398 PERL_ARGS_ASSERT_RXRES_FREE;
403 void *tmp = INT2PTR(char*,*p);
406 PoisonFree(*p, 1, sizeof(*p));
408 Safefree(INT2PTR(char*,*p));
410 #ifdef PERL_OLD_COPY_ON_WRITE
412 SvREFCNT_dec (INT2PTR(SV*,p[1]));
422 dVAR; dSP; dMARK; dORIGMARK;
423 register SV * const tmpForm = *++MARK;
428 register SV *sv = NULL;
429 const char *item = NULL;
433 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
434 const char *chophere = NULL;
435 char *linemark = NULL;
437 bool gotsome = FALSE;
439 const STRLEN fudge = SvPOK(tmpForm)
440 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
441 bool item_is_utf8 = FALSE;
442 bool targ_is_utf8 = FALSE;
444 OP * parseres = NULL;
447 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
448 if (SvREADONLY(tmpForm)) {
449 SvREADONLY_off(tmpForm);
450 parseres = doparseform(tmpForm);
451 SvREADONLY_on(tmpForm);
454 parseres = doparseform(tmpForm);
458 SvPV_force(PL_formtarget, len);
459 if (DO_UTF8(PL_formtarget))
461 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
463 f = SvPV_const(tmpForm, len);
464 /* need to jump to the next word */
465 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
469 const char *name = "???";
472 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
473 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
474 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
475 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
476 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
478 case FF_CHECKNL: name = "CHECKNL"; break;
479 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
480 case FF_SPACE: name = "SPACE"; break;
481 case FF_HALFSPACE: name = "HALFSPACE"; break;
482 case FF_ITEM: name = "ITEM"; break;
483 case FF_CHOP: name = "CHOP"; break;
484 case FF_LINEGLOB: name = "LINEGLOB"; break;
485 case FF_NEWLINE: name = "NEWLINE"; break;
486 case FF_MORE: name = "MORE"; break;
487 case FF_LINEMARK: name = "LINEMARK"; break;
488 case FF_END: name = "END"; break;
489 case FF_0DECIMAL: name = "0DECIMAL"; break;
490 case FF_LINESNGL: name = "LINESNGL"; break;
493 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
495 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
506 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
507 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
509 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
510 t = SvEND(PL_formtarget);
514 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
515 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
517 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
518 t = SvEND(PL_formtarget);
538 if (ckWARN(WARN_SYNTAX))
539 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
546 const char *s = item = SvPV_const(sv, len);
549 itemsize = sv_len_utf8(sv);
550 if (itemsize != (I32)len) {
552 if (itemsize > fieldsize) {
553 itemsize = fieldsize;
554 itembytes = itemsize;
555 sv_pos_u2b(sv, &itembytes, 0);
559 send = chophere = s + itembytes;
569 sv_pos_b2u(sv, &itemsize);
573 item_is_utf8 = FALSE;
574 if (itemsize > fieldsize)
575 itemsize = fieldsize;
576 send = chophere = s + itemsize;
590 const char *s = item = SvPV_const(sv, len);
593 itemsize = sv_len_utf8(sv);
594 if (itemsize != (I32)len) {
596 if (itemsize <= fieldsize) {
597 const char *send = chophere = s + itemsize;
610 itemsize = fieldsize;
611 itembytes = itemsize;
612 sv_pos_u2b(sv, &itembytes, 0);
613 send = chophere = s + itembytes;
614 while (s < send || (s == send && isSPACE(*s))) {
624 if (strchr(PL_chopset, *s))
629 itemsize = chophere - item;
630 sv_pos_b2u(sv, &itemsize);
636 item_is_utf8 = FALSE;
637 if (itemsize <= fieldsize) {
638 const char *const send = chophere = s + itemsize;
651 itemsize = fieldsize;
652 send = chophere = s + itemsize;
653 while (s < send || (s == send && isSPACE(*s))) {
663 if (strchr(PL_chopset, *s))
668 itemsize = chophere - item;
674 arg = fieldsize - itemsize;
683 arg = fieldsize - itemsize;
694 const char *s = item;
698 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
700 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
702 t = SvEND(PL_formtarget);
706 if (UTF8_IS_CONTINUED(*s)) {
707 STRLEN skip = UTF8SKIP(s);
724 if ( !((*t++ = *s++) & ~31) )
730 if (targ_is_utf8 && !item_is_utf8) {
731 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
733 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
734 for (; t < SvEND(PL_formtarget); t++) {
747 const int ch = *t++ = *s++;
750 if ( !((*t++ = *s++) & ~31) )
759 const char *s = chophere;
773 const bool oneline = fpc[-1] == FF_LINESNGL;
774 const char *s = item = SvPV_const(sv, len);
775 item_is_utf8 = DO_UTF8(sv);
778 STRLEN to_copy = itemsize;
779 const char *const send = s + len;
780 const U8 *source = (const U8 *) s;
784 chophere = s + itemsize;
788 to_copy = s - SvPVX_const(sv) - 1;
800 if (targ_is_utf8 && !item_is_utf8) {
801 source = tmp = bytes_to_utf8(source, &to_copy);
802 SvCUR_set(PL_formtarget,
803 t - SvPVX_const(PL_formtarget));
805 if (item_is_utf8 && !targ_is_utf8) {
806 /* Upgrade targ to UTF8, and then we reduce it to
807 a problem we have a simple solution for. */
808 SvCUR_set(PL_formtarget,
809 t - SvPVX_const(PL_formtarget));
811 /* Don't need get magic. */
812 sv_utf8_upgrade_nomg(PL_formtarget);
814 SvCUR_set(PL_formtarget,
815 t - SvPVX_const(PL_formtarget));
818 /* Easy. They agree. */
819 assert (item_is_utf8 == targ_is_utf8);
821 SvGROW(PL_formtarget,
822 SvCUR(PL_formtarget) + to_copy + fudge + 1);
823 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
825 Copy(source, t, to_copy, char);
827 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
829 if (SvGMAGICAL(sv)) {
830 /* Mustn't call sv_pos_b2u() as it does a second
831 mg_get(). Is this a bug? Do we need a _flags()
833 itemsize = utf8_length(source, source + itemsize);
835 sv_pos_b2u(sv, &itemsize);
847 #if defined(USE_LONG_DOUBLE)
850 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
854 "%#0*.*f" : "%0*.*f");
859 #if defined(USE_LONG_DOUBLE)
861 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
864 ((arg & 256) ? "%#*.*f" : "%*.*f");
867 /* If the field is marked with ^ and the value is undefined,
869 if ((arg & 512) && !SvOK(sv)) {
877 /* overflow evidence */
878 if (num_overflow(value, fieldsize, arg)) {
884 /* Formats aren't yet marked for locales, so assume "yes". */
886 STORE_NUMERIC_STANDARD_SET_LOCAL();
887 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
888 RESTORE_NUMERIC_STANDARD();
895 while (t-- > linemark && *t == ' ') ;
903 if (arg) { /* repeat until fields exhausted? */
905 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
906 lines += FmLINES(PL_formtarget);
909 if (strnEQ(linemark, linemark - arg, arg))
910 DIE(aTHX_ "Runaway format");
913 SvUTF8_on(PL_formtarget);
914 FmLINES(PL_formtarget) = lines;
916 RETURNOP(cLISTOP->op_first);
927 const char *s = chophere;
928 const char *send = item + len;
930 while (isSPACE(*s) && (s < send))
935 arg = fieldsize - itemsize;
942 if (strnEQ(s1," ",3)) {
943 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
954 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
956 SvUTF8_on(PL_formtarget);
957 FmLINES(PL_formtarget) += lines;
969 if (PL_stack_base + *PL_markstack_ptr == SP) {
971 if (GIMME_V == G_SCALAR)
973 RETURNOP(PL_op->op_next->op_next);
975 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
976 pp_pushmark(); /* push dst */
977 pp_pushmark(); /* push src */
978 ENTER; /* enter outer scope */
981 if (PL_op->op_private & OPpGREP_LEX)
982 SAVESPTR(PAD_SVl(PL_op->op_targ));
985 ENTER; /* enter inner scope */
988 src = PL_stack_base[*PL_markstack_ptr];
990 if (PL_op->op_private & OPpGREP_LEX)
991 PAD_SVl(PL_op->op_targ) = src;
996 if (PL_op->op_type == OP_MAPSTART)
997 pp_pushmark(); /* push top */
998 return ((LOGOP*)PL_op->op_next)->op_other;
1004 const I32 gimme = GIMME_V;
1005 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1011 /* first, move source pointer to the next item in the source list */
1012 ++PL_markstack_ptr[-1];
1014 /* if there are new items, push them into the destination list */
1015 if (items && gimme != G_VOID) {
1016 /* might need to make room back there first */
1017 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1018 /* XXX this implementation is very pessimal because the stack
1019 * is repeatedly extended for every set of items. Is possible
1020 * to do this without any stack extension or copying at all
1021 * by maintaining a separate list over which the map iterates
1022 * (like foreach does). --gsar */
1024 /* everything in the stack after the destination list moves
1025 * towards the end the stack by the amount of room needed */
1026 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1028 /* items to shift up (accounting for the moved source pointer) */
1029 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1031 /* This optimization is by Ben Tilly and it does
1032 * things differently from what Sarathy (gsar)
1033 * is describing. The downside of this optimization is
1034 * that leaves "holes" (uninitialized and hopefully unused areas)
1035 * to the Perl stack, but on the other hand this
1036 * shouldn't be a problem. If Sarathy's idea gets
1037 * implemented, this optimization should become
1038 * irrelevant. --jhi */
1040 shift = count; /* Avoid shifting too often --Ben Tilly */
1044 dst = (SP += shift);
1045 PL_markstack_ptr[-1] += shift;
1046 *PL_markstack_ptr += shift;
1050 /* copy the new items down to the destination list */
1051 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1052 if (gimme == G_ARRAY) {
1054 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1057 /* scalar context: we don't care about which values map returns
1058 * (we use undef here). And so we certainly don't want to do mortal
1059 * copies of meaningless values. */
1060 while (items-- > 0) {
1062 *dst-- = &PL_sv_undef;
1066 LEAVE; /* exit inner scope */
1069 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1071 (void)POPMARK; /* pop top */
1072 LEAVE; /* exit outer scope */
1073 (void)POPMARK; /* pop src */
1074 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1075 (void)POPMARK; /* pop dst */
1076 SP = PL_stack_base + POPMARK; /* pop original mark */
1077 if (gimme == G_SCALAR) {
1078 if (PL_op->op_private & OPpGREP_LEX) {
1079 SV* sv = sv_newmortal();
1080 sv_setiv(sv, items);
1088 else if (gimme == G_ARRAY)
1095 ENTER; /* enter inner scope */
1098 /* set $_ to the new source item */
1099 src = PL_stack_base[PL_markstack_ptr[-1]];
1101 if (PL_op->op_private & OPpGREP_LEX)
1102 PAD_SVl(PL_op->op_targ) = src;
1106 RETURNOP(cLOGOP->op_other);
1115 if (GIMME == G_ARRAY)
1117 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1118 return cLOGOP->op_other;
1128 if (GIMME == G_ARRAY) {
1129 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1133 SV * const targ = PAD_SV(PL_op->op_targ);
1136 if (PL_op->op_private & OPpFLIP_LINENUM) {
1137 if (GvIO(PL_last_in_gv)) {
1138 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1141 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1143 flip = SvIV(sv) == SvIV(GvSV(gv));
1149 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1150 if (PL_op->op_flags & OPf_SPECIAL) {
1158 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1161 sv_setpvs(TARG, "");
1167 /* This code tries to decide if "$left .. $right" should use the
1168 magical string increment, or if the range is numeric (we make
1169 an exception for .."0" [#18165]). AMS 20021031. */
1171 #define RANGE_IS_NUMERIC(left,right) ( \
1172 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1173 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1174 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1175 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1176 && (!SvOK(right) || looks_like_number(right))))
1182 if (GIMME == G_ARRAY) {
1188 if (RANGE_IS_NUMERIC(left,right)) {
1191 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1192 (SvOK(right) && SvNV(right) > IV_MAX))
1193 DIE(aTHX_ "Range iterator outside integer range");
1204 SV * const sv = sv_2mortal(newSViv(i++));
1209 SV * const final = sv_mortalcopy(right);
1211 const char * const tmps = SvPV_const(final, len);
1213 SV *sv = sv_mortalcopy(left);
1214 SvPV_force_nolen(sv);
1215 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1217 if (strEQ(SvPVX_const(sv),tmps))
1219 sv = sv_2mortal(newSVsv(sv));
1226 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1230 if (PL_op->op_private & OPpFLIP_LINENUM) {
1231 if (GvIO(PL_last_in_gv)) {
1232 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1235 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1236 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1244 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1245 sv_catpvs(targ, "E0");
1255 static const char * const context_name[] = {
1257 NULL, /* CXt_WHEN never actually needs "block" */
1258 NULL, /* CXt_BLOCK never actually needs "block" */
1259 NULL, /* CXt_GIVEN never actually needs "block" */
1260 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1261 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1262 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1263 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1271 S_dopoptolabel(pTHX_ const char *label)
1276 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1278 for (i = cxstack_ix; i >= 0; i--) {
1279 register const PERL_CONTEXT * const cx = &cxstack[i];
1280 switch (CxTYPE(cx)) {
1286 if (ckWARN(WARN_EXITING))
1287 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1288 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1289 if (CxTYPE(cx) == CXt_NULL)
1292 case CXt_LOOP_LAZYIV:
1293 case CXt_LOOP_LAZYSV:
1295 case CXt_LOOP_PLAIN:
1296 if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
1297 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1298 (long)i, CxLABEL(cx)));
1301 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1311 Perl_dowantarray(pTHX)
1314 const I32 gimme = block_gimme();
1315 return (gimme == G_VOID) ? G_SCALAR : gimme;
1319 Perl_block_gimme(pTHX)
1322 const I32 cxix = dopoptosub(cxstack_ix);
1326 switch (cxstack[cxix].blk_gimme) {
1334 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1341 Perl_is_lvalue_sub(pTHX)
1344 const I32 cxix = dopoptosub(cxstack_ix);
1345 assert(cxix >= 0); /* We should only be called from inside subs */
1347 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1348 return CxLVAL(cxstack + cxix);
1354 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1359 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1361 for (i = startingblock; i >= 0; i--) {
1362 register const PERL_CONTEXT * const cx = &cxstk[i];
1363 switch (CxTYPE(cx)) {
1369 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1377 S_dopoptoeval(pTHX_ I32 startingblock)
1381 for (i = startingblock; i >= 0; i--) {
1382 register const PERL_CONTEXT *cx = &cxstack[i];
1383 switch (CxTYPE(cx)) {
1387 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1395 S_dopoptoloop(pTHX_ I32 startingblock)
1399 for (i = startingblock; i >= 0; i--) {
1400 register const PERL_CONTEXT * const cx = &cxstack[i];
1401 switch (CxTYPE(cx)) {
1407 if (ckWARN(WARN_EXITING))
1408 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1409 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1410 if ((CxTYPE(cx)) == CXt_NULL)
1413 case CXt_LOOP_LAZYIV:
1414 case CXt_LOOP_LAZYSV:
1416 case CXt_LOOP_PLAIN:
1417 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1425 S_dopoptogiven(pTHX_ I32 startingblock)
1429 for (i = startingblock; i >= 0; i--) {
1430 register const PERL_CONTEXT *cx = &cxstack[i];
1431 switch (CxTYPE(cx)) {
1435 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1437 case CXt_LOOP_PLAIN:
1438 assert(!CxFOREACHDEF(cx));
1440 case CXt_LOOP_LAZYIV:
1441 case CXt_LOOP_LAZYSV:
1443 if (CxFOREACHDEF(cx)) {
1444 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1453 S_dopoptowhen(pTHX_ I32 startingblock)
1457 for (i = startingblock; i >= 0; i--) {
1458 register const PERL_CONTEXT *cx = &cxstack[i];
1459 switch (CxTYPE(cx)) {
1463 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1471 Perl_dounwind(pTHX_ I32 cxix)
1476 while (cxstack_ix > cxix) {
1478 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1479 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1480 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1481 /* Note: we don't need to restore the base context info till the end. */
1482 switch (CxTYPE(cx)) {
1485 continue; /* not break */
1493 case CXt_LOOP_LAZYIV:
1494 case CXt_LOOP_LAZYSV:
1496 case CXt_LOOP_PLAIN:
1507 PERL_UNUSED_VAR(optype);
1511 Perl_qerror(pTHX_ SV *err)
1515 PERL_ARGS_ASSERT_QERROR;
1518 sv_catsv(ERRSV, err);
1520 sv_catsv(PL_errors, err);
1522 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1524 ++PL_parser->error_count;
1528 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1537 if (PL_in_eval & EVAL_KEEPERR) {
1538 static const char prefix[] = "\t(in cleanup) ";
1539 SV * const err = ERRSV;
1540 const char *e = NULL;
1543 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1545 e = SvPV_const(err, len);
1547 if (*e != *message || strNE(e,message))
1551 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1552 sv_catpvn(err, prefix, sizeof(prefix)-1);
1553 sv_catpvn(err, message, msglen);
1554 if (ckWARN(WARN_MISC)) {
1555 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1556 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s",
1557 SvPVX_const(err)+start);
1562 sv_setpvn(ERRSV, message, msglen);
1566 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1567 && PL_curstackinfo->si_prev)
1575 register PERL_CONTEXT *cx;
1578 if (cxix < cxstack_ix)
1581 POPBLOCK(cx,PL_curpm);
1582 if (CxTYPE(cx) != CXt_EVAL) {
1584 message = SvPVx_const(ERRSV, msglen);
1585 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1586 PerlIO_write(Perl_error_log, message, msglen);
1591 if (gimme == G_SCALAR)
1592 *++newsp = &PL_sv_undef;
1593 PL_stack_sp = newsp;
1597 /* LEAVE could clobber PL_curcop (see save_re_context())
1598 * XXX it might be better to find a way to avoid messing with
1599 * PL_curcop in save_re_context() instead, but this is a more
1600 * minimal fix --GSAR */
1601 PL_curcop = cx->blk_oldcop;
1603 if (optype == OP_REQUIRE) {
1604 const char* const msg = SvPVx_nolen_const(ERRSV);
1605 SV * const nsv = cx->blk_eval.old_namesv;
1606 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1608 DIE(aTHX_ "%sCompilation failed in require",
1609 *msg ? msg : "Unknown error\n");
1611 assert(CxTYPE(cx) == CXt_EVAL);
1612 return cx->blk_eval.retop;
1616 message = SvPVx_const(ERRSV, msglen);
1618 write_to_stderr(message, msglen);
1626 dVAR; dSP; dPOPTOPssrl;
1627 if (SvTRUE(left) != SvTRUE(right))
1637 register I32 cxix = dopoptosub(cxstack_ix);
1638 register const PERL_CONTEXT *cx;
1639 register const PERL_CONTEXT *ccstack = cxstack;
1640 const PERL_SI *top_si = PL_curstackinfo;
1642 const char *stashname;
1649 /* we may be in a higher stacklevel, so dig down deeper */
1650 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1651 top_si = top_si->si_prev;
1652 ccstack = top_si->si_cxstack;
1653 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1656 if (GIMME != G_ARRAY) {
1662 /* caller() should not report the automatic calls to &DB::sub */
1663 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1664 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1668 cxix = dopoptosub_at(ccstack, cxix - 1);
1671 cx = &ccstack[cxix];
1672 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1673 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1674 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1675 field below is defined for any cx. */
1676 /* caller() should not report the automatic calls to &DB::sub */
1677 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1678 cx = &ccstack[dbcxix];
1681 stashname = CopSTASHPV(cx->blk_oldcop);
1682 if (GIMME != G_ARRAY) {
1685 PUSHs(&PL_sv_undef);
1688 sv_setpv(TARG, stashname);
1697 PUSHs(&PL_sv_undef);
1699 mPUSHs(newSVpv(stashname, 0));
1700 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1701 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1704 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1705 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1706 /* So is ccstack[dbcxix]. */
1708 SV * const sv = newSV(0);
1709 gv_efullname3(sv, cvgv, NULL);
1711 PUSHs(boolSV(CxHASARGS(cx)));
1714 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1715 PUSHs(boolSV(CxHASARGS(cx)));
1719 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1722 gimme = (I32)cx->blk_gimme;
1723 if (gimme == G_VOID)
1724 PUSHs(&PL_sv_undef);
1726 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1727 if (CxTYPE(cx) == CXt_EVAL) {
1729 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1730 PUSHs(cx->blk_eval.cur_text);
1734 else if (cx->blk_eval.old_namesv) {
1735 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1738 /* eval BLOCK (try blocks have old_namesv == 0) */
1740 PUSHs(&PL_sv_undef);
1741 PUSHs(&PL_sv_undef);
1745 PUSHs(&PL_sv_undef);
1746 PUSHs(&PL_sv_undef);
1748 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1749 && CopSTASH_eq(PL_curcop, PL_debstash))
1751 AV * const ary = cx->blk_sub.argarray;
1752 const int off = AvARRAY(ary) - AvALLOC(ary);
1755 PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
1757 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1760 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1761 av_extend(PL_dbargs, AvFILLp(ary) + off);
1762 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1763 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1765 /* XXX only hints propagated via op_private are currently
1766 * visible (others are not easily accessible, since they
1767 * use the global PL_hints) */
1768 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1771 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1773 if (old_warnings == pWARN_NONE ||
1774 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1775 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1776 else if (old_warnings == pWARN_ALL ||
1777 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1778 /* Get the bit mask for $warnings::Bits{all}, because
1779 * it could have been extended by warnings::register */
1781 HV * const bits = get_hv("warnings::Bits", 0);
1782 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1783 mask = newSVsv(*bits_all);
1786 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1790 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1794 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1795 sv_2mortal(newRV_noinc(
1796 MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1797 cx->blk_oldcop->cop_hints_hash))))
1806 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1807 sv_reset(tmps, CopSTASH(PL_curcop));
1812 /* like pp_nextstate, but used instead when the debugger is active */
1817 PL_curcop = (COP*)PL_op;
1818 TAINT_NOT; /* Each statement is presumed innocent */
1819 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1822 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1823 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1826 register PERL_CONTEXT *cx;
1827 const I32 gimme = G_ARRAY;
1829 GV * const gv = PL_DBgv;
1830 register CV * const cv = GvCV(gv);
1833 DIE(aTHX_ "No DB::DB routine defined");
1835 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1836 /* don't do recursive DB::DB call */
1851 (void)(*CvXSUB(cv))(aTHX_ cv);
1858 PUSHBLOCK(cx, CXt_SUB, SP);
1860 cx->blk_sub.retop = PL_op->op_next;
1863 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1864 RETURNOP(CvSTART(cv));
1874 register PERL_CONTEXT *cx;
1875 const I32 gimme = GIMME_V;
1877 U8 cxtype = CXt_LOOP_FOR;
1885 if (PL_op->op_targ) {
1886 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1887 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1888 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1889 SVs_PADSTALE, SVs_PADSTALE);
1891 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1892 #ifndef USE_ITHREADS
1893 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1899 GV * const gv = MUTABLE_GV(POPs);
1900 svp = &GvSV(gv); /* symbol table variable */
1901 SAVEGENERICSV(*svp);
1904 iterdata = (PAD*)gv;
1908 if (PL_op->op_private & OPpITER_DEF)
1909 cxtype |= CXp_FOR_DEF;
1913 PUSHBLOCK(cx, cxtype, SP);
1915 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1917 PUSHLOOP_FOR(cx, svp, MARK, 0);
1919 if (PL_op->op_flags & OPf_STACKED) {
1920 SV *maybe_ary = POPs;
1921 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1923 SV * const right = maybe_ary;
1926 if (RANGE_IS_NUMERIC(sv,right)) {
1927 cx->cx_type &= ~CXTYPEMASK;
1928 cx->cx_type |= CXt_LOOP_LAZYIV;
1929 /* Make sure that no-one re-orders cop.h and breaks our
1931 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1932 #ifdef NV_PRESERVES_UV
1933 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1934 (SvNV(sv) > (NV)IV_MAX)))
1936 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1937 (SvNV(right) < (NV)IV_MIN))))
1939 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1942 ((SvUV(sv) > (UV)IV_MAX) ||
1943 (SvNV(sv) > (NV)UV_MAX)))))
1945 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1947 ((SvNV(right) > 0) &&
1948 ((SvUV(right) > (UV)IV_MAX) ||
1949 (SvNV(right) > (NV)UV_MAX))))))
1951 DIE(aTHX_ "Range iterator outside integer range");
1952 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1953 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1955 /* for correct -Dstv display */
1956 cx->blk_oldsp = sp - PL_stack_base;
1960 cx->cx_type &= ~CXTYPEMASK;
1961 cx->cx_type |= CXt_LOOP_LAZYSV;
1962 /* Make sure that no-one re-orders cop.h and breaks our
1964 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
1965 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
1966 cx->blk_loop.state_u.lazysv.end = right;
1967 SvREFCNT_inc(right);
1968 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
1969 /* This will do the upgrade to SVt_PV, and warn if the value
1970 is uninitialised. */
1971 (void) SvPV_nolen_const(right);
1972 /* Doing this avoids a check every time in pp_iter in pp_hot.c
1973 to replace !SvOK() with a pointer to "". */
1975 SvREFCNT_dec(right);
1976 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
1980 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
1981 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
1982 SvREFCNT_inc(maybe_ary);
1983 cx->blk_loop.state_u.ary.ix =
1984 (PL_op->op_private & OPpITER_REVERSED) ?
1985 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
1989 else { /* iterating over items on the stack */
1990 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
1991 if (PL_op->op_private & OPpITER_REVERSED) {
1992 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
1995 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2005 register PERL_CONTEXT *cx;
2006 const I32 gimme = GIMME_V;
2012 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2013 PUSHLOOP_PLAIN(cx, SP);
2021 register PERL_CONTEXT *cx;
2028 assert(CxTYPE_is_LOOP(cx));
2030 newsp = PL_stack_base + cx->blk_loop.resetsp;
2033 if (gimme == G_VOID)
2035 else if (gimme == G_SCALAR) {
2037 *++newsp = sv_mortalcopy(*SP);
2039 *++newsp = &PL_sv_undef;
2043 *++newsp = sv_mortalcopy(*++mark);
2044 TAINT_NOT; /* Each item is independent */
2050 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2051 PL_curpm = newpm; /* ... and pop $1 et al */
2062 register PERL_CONTEXT *cx;
2063 bool popsub2 = FALSE;
2064 bool clear_errsv = FALSE;
2072 const I32 cxix = dopoptosub(cxstack_ix);
2075 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2076 * sort block, which is a CXt_NULL
2079 PL_stack_base[1] = *PL_stack_sp;
2080 PL_stack_sp = PL_stack_base + 1;
2084 DIE(aTHX_ "Can't return outside a subroutine");
2086 if (cxix < cxstack_ix)
2089 if (CxMULTICALL(&cxstack[cxix])) {
2090 gimme = cxstack[cxix].blk_gimme;
2091 if (gimme == G_VOID)
2092 PL_stack_sp = PL_stack_base;
2093 else if (gimme == G_SCALAR) {
2094 PL_stack_base[1] = *PL_stack_sp;
2095 PL_stack_sp = PL_stack_base + 1;
2101 switch (CxTYPE(cx)) {
2104 retop = cx->blk_sub.retop;
2105 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2108 if (!(PL_in_eval & EVAL_KEEPERR))
2111 retop = cx->blk_eval.retop;
2115 if (optype == OP_REQUIRE &&
2116 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2118 /* Unassume the success we assumed earlier. */
2119 SV * const nsv = cx->blk_eval.old_namesv;
2120 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2121 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2126 retop = cx->blk_sub.retop;
2129 DIE(aTHX_ "panic: return");
2133 if (gimme == G_SCALAR) {
2136 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2138 *++newsp = SvREFCNT_inc(*SP);
2143 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2145 *++newsp = sv_mortalcopy(sv);
2150 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2153 *++newsp = sv_mortalcopy(*SP);
2156 *++newsp = &PL_sv_undef;
2158 else if (gimme == G_ARRAY) {
2159 while (++MARK <= SP) {
2160 *++newsp = (popsub2 && SvTEMP(*MARK))
2161 ? *MARK : sv_mortalcopy(*MARK);
2162 TAINT_NOT; /* Each item is independent */
2165 PL_stack_sp = newsp;
2168 /* Stack values are safe: */
2171 POPSUB(cx,sv); /* release CV and @_ ... */
2175 PL_curpm = newpm; /* ... and pop $1 et al */
2188 register PERL_CONTEXT *cx;
2199 if (PL_op->op_flags & OPf_SPECIAL) {
2200 cxix = dopoptoloop(cxstack_ix);
2202 DIE(aTHX_ "Can't \"last\" outside a loop block");
2205 cxix = dopoptolabel(cPVOP->op_pv);
2207 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2209 if (cxix < cxstack_ix)
2213 cxstack_ix++; /* temporarily protect top context */
2215 switch (CxTYPE(cx)) {
2216 case CXt_LOOP_LAZYIV:
2217 case CXt_LOOP_LAZYSV:
2219 case CXt_LOOP_PLAIN:
2221 newsp = PL_stack_base + cx->blk_loop.resetsp;
2222 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2226 nextop = cx->blk_sub.retop;
2230 nextop = cx->blk_eval.retop;
2234 nextop = cx->blk_sub.retop;
2237 DIE(aTHX_ "panic: last");
2241 if (gimme == G_SCALAR) {
2243 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2244 ? *SP : sv_mortalcopy(*SP);
2246 *++newsp = &PL_sv_undef;
2248 else if (gimme == G_ARRAY) {
2249 while (++MARK <= SP) {
2250 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2251 ? *MARK : sv_mortalcopy(*MARK);
2252 TAINT_NOT; /* Each item is independent */
2260 /* Stack values are safe: */
2262 case CXt_LOOP_LAZYIV:
2263 case CXt_LOOP_PLAIN:
2264 case CXt_LOOP_LAZYSV:
2266 POPLOOP(cx); /* release loop vars ... */
2270 POPSUB(cx,sv); /* release CV and @_ ... */
2273 PL_curpm = newpm; /* ... and pop $1 et al */
2276 PERL_UNUSED_VAR(optype);
2277 PERL_UNUSED_VAR(gimme);
2285 register PERL_CONTEXT *cx;
2288 if (PL_op->op_flags & OPf_SPECIAL) {
2289 cxix = dopoptoloop(cxstack_ix);
2291 DIE(aTHX_ "Can't \"next\" outside a loop block");
2294 cxix = dopoptolabel(cPVOP->op_pv);
2296 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2298 if (cxix < cxstack_ix)
2301 /* clear off anything above the scope we're re-entering, but
2302 * save the rest until after a possible continue block */
2303 inner = PL_scopestack_ix;
2305 if (PL_scopestack_ix < inner)
2306 leave_scope(PL_scopestack[PL_scopestack_ix]);
2307 PL_curcop = cx->blk_oldcop;
2308 return CX_LOOP_NEXTOP_GET(cx);
2315 register PERL_CONTEXT *cx;
2319 if (PL_op->op_flags & OPf_SPECIAL) {
2320 cxix = dopoptoloop(cxstack_ix);
2322 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2325 cxix = dopoptolabel(cPVOP->op_pv);
2327 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2329 if (cxix < cxstack_ix)
2332 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2333 if (redo_op->op_type == OP_ENTER) {
2334 /* pop one less context to avoid $x being freed in while (my $x..) */
2336 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2337 redo_op = redo_op->op_next;
2341 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2342 LEAVE_SCOPE(oldsave);
2344 PL_curcop = cx->blk_oldcop;
2349 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2353 static const char too_deep[] = "Target of goto is too deeply nested";
2355 PERL_ARGS_ASSERT_DOFINDLABEL;
2358 Perl_croak(aTHX_ too_deep);
2359 if (o->op_type == OP_LEAVE ||
2360 o->op_type == OP_SCOPE ||
2361 o->op_type == OP_LEAVELOOP ||
2362 o->op_type == OP_LEAVESUB ||
2363 o->op_type == OP_LEAVETRY)
2365 *ops++ = cUNOPo->op_first;
2367 Perl_croak(aTHX_ too_deep);
2370 if (o->op_flags & OPf_KIDS) {
2372 /* First try all the kids at this level, since that's likeliest. */
2373 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2374 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2375 CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label))
2378 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2379 if (kid == PL_lastgotoprobe)
2381 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2384 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2385 ops[-1]->op_type == OP_DBSTATE)
2390 if ((o = dofindlabel(kid, label, ops, oplimit)))
2403 register PERL_CONTEXT *cx;
2404 #define GOTO_DEPTH 64
2405 OP *enterops[GOTO_DEPTH];
2406 const char *label = NULL;
2407 const bool do_dump = (PL_op->op_type == OP_DUMP);
2408 static const char must_have_label[] = "goto must have label";
2410 if (PL_op->op_flags & OPf_STACKED) {
2411 SV * const sv = POPs;
2413 /* This egregious kludge implements goto &subroutine */
2414 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2416 register PERL_CONTEXT *cx;
2417 CV *cv = MUTABLE_CV(SvRV(sv));
2424 if (!CvROOT(cv) && !CvXSUB(cv)) {
2425 const GV * const gv = CvGV(cv);
2429 /* autoloaded stub? */
2430 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2432 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2433 GvNAMELEN(gv), FALSE);
2434 if (autogv && (cv = GvCV(autogv)))
2436 tmpstr = sv_newmortal();
2437 gv_efullname3(tmpstr, gv, NULL);
2438 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2440 DIE(aTHX_ "Goto undefined subroutine");
2443 /* First do some returnish stuff. */
2444 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2446 cxix = dopoptosub(cxstack_ix);
2448 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2449 if (cxix < cxstack_ix)
2453 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2454 if (CxTYPE(cx) == CXt_EVAL) {
2456 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2458 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2460 else if (CxMULTICALL(cx))
2461 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2462 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2463 /* put @_ back onto stack */
2464 AV* av = cx->blk_sub.argarray;
2466 items = AvFILLp(av) + 1;
2467 EXTEND(SP, items+1); /* @_ could have been extended. */
2468 Copy(AvARRAY(av), SP + 1, items, SV*);
2469 SvREFCNT_dec(GvAV(PL_defgv));
2470 GvAV(PL_defgv) = cx->blk_sub.savearray;
2472 /* abandon @_ if it got reified */
2477 av_extend(av, items-1);
2479 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2482 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2483 AV* const av = GvAV(PL_defgv);
2484 items = AvFILLp(av) + 1;
2485 EXTEND(SP, items+1); /* @_ could have been extended. */
2486 Copy(AvARRAY(av), SP + 1, items, SV*);
2490 if (CxTYPE(cx) == CXt_SUB &&
2491 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2492 SvREFCNT_dec(cx->blk_sub.cv);
2493 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2494 LEAVE_SCOPE(oldsave);
2496 /* Now do some callish stuff. */
2498 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2500 OP* const retop = cx->blk_sub.retop;
2505 for (index=0; index<items; index++)
2506 sv_2mortal(SP[-index]);
2509 /* XS subs don't have a CxSUB, so pop it */
2510 POPBLOCK(cx, PL_curpm);
2511 /* Push a mark for the start of arglist */
2514 (void)(*CvXSUB(cv))(aTHX_ cv);
2519 AV* const padlist = CvPADLIST(cv);
2520 if (CxTYPE(cx) == CXt_EVAL) {
2521 PL_in_eval = CxOLD_IN_EVAL(cx);
2522 PL_eval_root = cx->blk_eval.old_eval_root;
2523 cx->cx_type = CXt_SUB;
2525 cx->blk_sub.cv = cv;
2526 cx->blk_sub.olddepth = CvDEPTH(cv);
2529 if (CvDEPTH(cv) < 2)
2530 SvREFCNT_inc_simple_void_NN(cv);
2532 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2533 sub_crush_depth(cv);
2534 pad_push(padlist, CvDEPTH(cv));
2537 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2540 AV *const av = MUTABLE_AV(PAD_SVl(0));
2542 cx->blk_sub.savearray = GvAV(PL_defgv);
2543 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2544 CX_CURPAD_SAVE(cx->blk_sub);
2545 cx->blk_sub.argarray = av;
2547 if (items >= AvMAX(av) + 1) {
2548 SV **ary = AvALLOC(av);
2549 if (AvARRAY(av) != ary) {
2550 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2553 if (items >= AvMAX(av) + 1) {
2554 AvMAX(av) = items - 1;
2555 Renew(ary,items+1,SV*);
2561 Copy(mark,AvARRAY(av),items,SV*);
2562 AvFILLp(av) = items - 1;
2563 assert(!AvREAL(av));
2565 /* transfer 'ownership' of refcnts to new @_ */
2575 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2576 Perl_get_db_sub(aTHX_ NULL, cv);
2578 CV * const gotocv = get_cvs("DB::goto", 0);
2580 PUSHMARK( PL_stack_sp );
2581 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2586 RETURNOP(CvSTART(cv));
2590 label = SvPV_nolen_const(sv);
2591 if (!(do_dump || *label))
2592 DIE(aTHX_ must_have_label);
2595 else if (PL_op->op_flags & OPf_SPECIAL) {
2597 DIE(aTHX_ must_have_label);
2600 label = cPVOP->op_pv;
2602 if (label && *label) {
2603 OP *gotoprobe = NULL;
2604 bool leaving_eval = FALSE;
2605 bool in_block = FALSE;
2606 PERL_CONTEXT *last_eval_cx = NULL;
2610 PL_lastgotoprobe = NULL;
2612 for (ix = cxstack_ix; ix >= 0; ix--) {
2614 switch (CxTYPE(cx)) {
2616 leaving_eval = TRUE;
2617 if (!CxTRYBLOCK(cx)) {
2618 gotoprobe = (last_eval_cx ?
2619 last_eval_cx->blk_eval.old_eval_root :
2624 /* else fall through */
2625 case CXt_LOOP_LAZYIV:
2626 case CXt_LOOP_LAZYSV:
2628 case CXt_LOOP_PLAIN:
2631 gotoprobe = cx->blk_oldcop->op_sibling;
2637 gotoprobe = cx->blk_oldcop->op_sibling;
2640 gotoprobe = PL_main_root;
2643 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2644 gotoprobe = CvROOT(cx->blk_sub.cv);
2650 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2653 DIE(aTHX_ "panic: goto");
2654 gotoprobe = PL_main_root;
2658 retop = dofindlabel(gotoprobe, label,
2659 enterops, enterops + GOTO_DEPTH);
2663 PL_lastgotoprobe = gotoprobe;
2666 DIE(aTHX_ "Can't find label %s", label);
2668 /* if we're leaving an eval, check before we pop any frames
2669 that we're not going to punt, otherwise the error
2672 if (leaving_eval && *enterops && enterops[1]) {
2674 for (i = 1; enterops[i]; i++)
2675 if (enterops[i]->op_type == OP_ENTERITER)
2676 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2679 /* pop unwanted frames */
2681 if (ix < cxstack_ix) {
2688 oldsave = PL_scopestack[PL_scopestack_ix];
2689 LEAVE_SCOPE(oldsave);
2692 /* push wanted frames */
2694 if (*enterops && enterops[1]) {
2695 OP * const oldop = PL_op;
2696 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2697 for (; enterops[ix]; ix++) {
2698 PL_op = enterops[ix];
2699 /* Eventually we may want to stack the needed arguments
2700 * for each op. For now, we punt on the hard ones. */
2701 if (PL_op->op_type == OP_ENTERITER)
2702 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2703 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2711 if (!retop) retop = PL_main_start;
2713 PL_restartop = retop;
2714 PL_do_undump = TRUE;
2718 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2719 PL_do_undump = FALSE;
2736 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2738 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2741 PL_exit_flags |= PERL_EXIT_EXPECTED;
2743 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2744 if (anum || !(PL_minus_c && PL_madskills))
2749 PUSHs(&PL_sv_undef);
2756 S_save_lines(pTHX_ AV *array, SV *sv)
2758 const char *s = SvPVX_const(sv);
2759 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2762 PERL_ARGS_ASSERT_SAVE_LINES;
2764 while (s && s < send) {
2766 SV * const tmpstr = newSV_type(SVt_PVMG);
2768 t = (const char *)memchr(s, '\n', send - s);
2774 sv_setpvn(tmpstr, s, t - s);
2775 av_store(array, line++, tmpstr);
2781 S_docatch(pTHX_ OP *o)
2785 OP * const oldop = PL_op;
2789 assert(CATCH_GET == TRUE);
2796 assert(cxstack_ix >= 0);
2797 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2798 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2803 /* die caught by an inner eval - continue inner loop */
2805 /* NB XXX we rely on the old popped CxEVAL still being at the top
2806 * of the stack; the way die_where() currently works, this
2807 * assumption is valid. In theory The cur_top_env value should be
2808 * returned in another global, the way retop (aka PL_restartop)
2810 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2813 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2815 PL_op = PL_restartop;
2832 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2833 /* sv Text to convert to OP tree. */
2834 /* startop op_free() this to undo. */
2835 /* code Short string id of the caller. */
2837 /* FIXME - how much of this code is common with pp_entereval? */
2838 dVAR; dSP; /* Make POPBLOCK work. */
2844 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2845 char *tmpbuf = tbuf;
2848 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2851 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2854 lex_start(sv, NULL, FALSE);
2856 /* switch to eval mode */
2858 if (IN_PERL_COMPILETIME) {
2859 SAVECOPSTASH_FREE(&PL_compiling);
2860 CopSTASH_set(&PL_compiling, PL_curstash);
2862 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2863 SV * const sv = sv_newmortal();
2864 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2865 code, (unsigned long)++PL_evalseq,
2866 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2871 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2872 (unsigned long)++PL_evalseq);
2873 SAVECOPFILE_FREE(&PL_compiling);
2874 CopFILE_set(&PL_compiling, tmpbuf+2);
2875 SAVECOPLINE(&PL_compiling);
2876 CopLINE_set(&PL_compiling, 1);
2877 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2878 deleting the eval's FILEGV from the stash before gv_check() runs
2879 (i.e. before run-time proper). To work around the coredump that
2880 ensues, we always turn GvMULTI_on for any globals that were
2881 introduced within evals. See force_ident(). GSAR 96-10-12 */
2882 safestr = savepvn(tmpbuf, len);
2883 SAVEDELETE(PL_defstash, safestr, len);
2885 #ifdef OP_IN_REGISTER
2891 /* we get here either during compilation, or via pp_regcomp at runtime */
2892 runtime = IN_PERL_RUNTIME;
2894 runcv = find_runcv(NULL);
2897 PL_op->op_type = OP_ENTEREVAL;
2898 PL_op->op_flags = 0; /* Avoid uninit warning. */
2899 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2903 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2905 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2906 POPBLOCK(cx,PL_curpm);
2909 (*startop)->op_type = OP_NULL;
2910 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2912 /* XXX DAPM do this properly one year */
2913 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2915 if (IN_PERL_COMPILETIME)
2916 CopHINTS_set(&PL_compiling, PL_hints);
2917 #ifdef OP_IN_REGISTER
2920 PERL_UNUSED_VAR(newsp);
2921 PERL_UNUSED_VAR(optype);
2923 return PL_eval_start;
2928 =for apidoc find_runcv
2930 Locate the CV corresponding to the currently executing sub or eval.
2931 If db_seqp is non_null, skip CVs that are in the DB package and populate
2932 *db_seqp with the cop sequence number at the point that the DB:: code was
2933 entered. (allows debuggers to eval in the scope of the breakpoint rather
2934 than in the scope of the debugger itself).
2940 Perl_find_runcv(pTHX_ U32 *db_seqp)
2946 *db_seqp = PL_curcop->cop_seq;
2947 for (si = PL_curstackinfo; si; si = si->si_prev) {
2949 for (ix = si->si_cxix; ix >= 0; ix--) {
2950 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2951 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2952 CV * const cv = cx->blk_sub.cv;
2953 /* skip DB:: code */
2954 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2955 *db_seqp = cx->blk_oldcop->cop_seq;
2960 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2968 /* Compile a require/do, an eval '', or a /(?{...})/.
2969 * In the last case, startop is non-null, and contains the address of
2970 * a pointer that should be set to the just-compiled code.
2971 * outside is the lexically enclosing CV (if any) that invoked us.
2972 * Returns a bool indicating whether the compile was successful; if so,
2973 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2974 * pushes undef (also croaks if startop != NULL).
2978 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2981 OP * const saveop = PL_op;
2983 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2984 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2989 SAVESPTR(PL_compcv);
2990 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2991 CvEVAL_on(PL_compcv);
2992 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2993 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2995 CvOUTSIDE_SEQ(PL_compcv) = seq;
2996 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2998 /* set up a scratch pad */
3000 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3001 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3005 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3007 /* make sure we compile in the right package */
3009 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3010 SAVESPTR(PL_curstash);
3011 PL_curstash = CopSTASH(PL_curcop);
3013 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3014 SAVESPTR(PL_beginav);
3015 PL_beginav = newAV();
3016 SAVEFREESV(PL_beginav);
3017 SAVESPTR(PL_unitcheckav);
3018 PL_unitcheckav = newAV();
3019 SAVEFREESV(PL_unitcheckav);
3022 SAVEBOOL(PL_madskills);
3026 /* try to compile it */
3028 PL_eval_root = NULL;
3029 PL_curcop = &PL_compiling;
3030 CopARYBASE_set(PL_curcop, 0);
3031 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3032 PL_in_eval |= EVAL_KEEPERR;
3035 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
3036 SV **newsp; /* Used by POPBLOCK. */
3037 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
3038 I32 optype = 0; /* Might be reset by POPEVAL. */
3043 op_free(PL_eval_root);
3044 PL_eval_root = NULL;
3046 SP = PL_stack_base + POPMARK; /* pop original mark */
3048 POPBLOCK(cx,PL_curpm);
3052 LEAVE; /* pp_entereval knows about this LEAVE. */
3054 msg = SvPVx_nolen_const(ERRSV);
3055 if (optype == OP_REQUIRE) {
3056 const SV * const nsv = cx->blk_eval.old_namesv;
3057 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3059 Perl_croak(aTHX_ "%sCompilation failed in require",
3060 *msg ? msg : "Unknown error\n");
3063 POPBLOCK(cx,PL_curpm);
3065 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3066 (*msg ? msg : "Unknown error\n"));
3070 sv_setpvs(ERRSV, "Compilation error");
3073 PERL_UNUSED_VAR(newsp);
3074 PUSHs(&PL_sv_undef);
3078 CopLINE_set(&PL_compiling, 0);
3080 *startop = PL_eval_root;
3082 SAVEFREEOP(PL_eval_root);
3084 /* Set the context for this new optree.
3085 * If the last op is an OP_REQUIRE, force scalar context.
3086 * Otherwise, propagate the context from the eval(). */
3087 if (PL_eval_root->op_type == OP_LEAVEEVAL
3088 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3089 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3091 scalar(PL_eval_root);
3092 else if ((gimme & G_WANT) == G_VOID)
3093 scalarvoid(PL_eval_root);
3094 else if ((gimme & G_WANT) == G_ARRAY)
3097 scalar(PL_eval_root);
3099 DEBUG_x(dump_eval());
3101 /* Register with debugger: */
3102 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3103 CV * const cv = get_cvs("DB::postponed", 0);
3107 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3109 call_sv(MUTABLE_SV(cv), G_DISCARD);
3114 call_list(PL_scopestack_ix, PL_unitcheckav);
3116 /* compiled okay, so do it */
3118 CvDEPTH(PL_compcv) = 1;
3119 SP = PL_stack_base + POPMARK; /* pop original mark */
3120 PL_op = saveop; /* The caller may need it. */
3121 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3128 S_check_type_and_open(pTHX_ const char *name)
3131 const int st_rc = PerlLIO_stat(name, &st);
3133 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3135 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3139 return PerlIO_open(name, PERL_SCRIPT_MODE);
3142 #ifndef PERL_DISABLE_PMC
3144 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3148 PERL_ARGS_ASSERT_DOOPEN_PM;
3150 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3151 SV *const pmcsv = newSV(namelen + 2);
3152 char *const pmc = SvPVX(pmcsv);
3155 memcpy(pmc, name, namelen);
3157 pmc[namelen + 1] = '\0';
3159 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3160 fp = check_type_and_open(name);
3163 fp = check_type_and_open(pmc);
3165 SvREFCNT_dec(pmcsv);
3168 fp = check_type_and_open(name);
3173 # define doopen_pm(name, namelen) check_type_and_open(name)
3174 #endif /* !PERL_DISABLE_PMC */
3179 register PERL_CONTEXT *cx;
3186 int vms_unixname = 0;
3188 const char *tryname = NULL;
3190 const I32 gimme = GIMME_V;
3191 int filter_has_file = 0;
3192 PerlIO *tryrsfp = NULL;
3193 SV *filter_cache = NULL;
3194 SV *filter_state = NULL;
3195 SV *filter_sub = NULL;
3201 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3202 sv = new_version(sv);
3203 if (!sv_derived_from(PL_patchlevel, "version"))
3204 upg_version(PL_patchlevel, TRUE);
3205 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3206 if ( vcmp(sv,PL_patchlevel) <= 0 )
3207 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3208 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3211 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3214 SV * const req = SvRV(sv);
3215 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3217 /* get the left hand term */
3218 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3220 first = SvIV(*av_fetch(lav,0,0));
3221 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3222 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3223 || av_len(lav) > 1 /* FP with > 3 digits */
3224 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3226 DIE(aTHX_ "Perl %"SVf" required--this is only "
3227 "%"SVf", stopped", SVfARG(vnormal(req)),
3228 SVfARG(vnormal(PL_patchlevel)));
3230 else { /* probably 'use 5.10' or 'use 5.8' */
3231 SV * hintsv = newSV(0);
3235 second = SvIV(*av_fetch(lav,1,0));
3237 second /= second >= 600 ? 100 : 10;
3238 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3239 (int)first, (int)second,0);
3240 upg_version(hintsv, TRUE);
3242 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3243 "--this is only %"SVf", stopped",
3244 SVfARG(vnormal(req)),
3245 SVfARG(vnormal(hintsv)),
3246 SVfARG(vnormal(PL_patchlevel)));
3251 /* We do this only with use, not require. */
3253 /* If we request a version >= 5.9.5, load feature.pm with the
3254 * feature bundle that corresponds to the required version. */
3255 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3256 SV *const importsv = vnormal(sv);
3257 *SvPVX_mutable(importsv) = ':';
3259 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3262 /* If a version >= 5.11.0 is requested, strictures are on by default! */
3264 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3265 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3270 name = SvPV_const(sv, len);
3271 if (!(name && len > 0 && *name))
3272 DIE(aTHX_ "Null filename used");
3273 TAINT_PROPER("require");
3277 /* The key in the %ENV hash is in the syntax of file passed as the argument
3278 * usually this is in UNIX format, but sometimes in VMS format, which
3279 * can result in a module being pulled in more than once.
3280 * To prevent this, the key must be stored in UNIX format if the VMS
3281 * name can be translated to UNIX.
3283 if ((unixname = tounixspec(name, NULL)) != NULL) {
3284 unixlen = strlen(unixname);
3290 /* if not VMS or VMS name can not be translated to UNIX, pass it
3293 unixname = (char *) name;
3296 if (PL_op->op_type == OP_REQUIRE) {
3297 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3298 unixname, unixlen, 0);
3300 if (*svp != &PL_sv_undef)
3303 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3304 "Compilation failed in require", unixname);
3308 /* prepare to compile file */
3310 if (path_is_absolute(name)) {
3312 tryrsfp = doopen_pm(name, len);
3315 AV * const ar = GvAVn(PL_incgv);
3321 namesv = newSV_type(SVt_PV);
3322 for (i = 0; i <= AvFILL(ar); i++) {
3323 SV * const dirsv = *av_fetch(ar, i, TRUE);
3325 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3332 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3333 && !sv_isobject(loader))
3335 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3338 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3339 PTR2UV(SvRV(dirsv)), name);
3340 tryname = SvPVX_const(namesv);
3351 if (sv_isobject(loader))
3352 count = call_method("INC", G_ARRAY);
3354 count = call_sv(loader, G_ARRAY);
3357 /* Adjust file name if the hook has set an %INC entry */
3358 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3360 tryname = SvPV_nolen_const(*svp);
3369 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3370 && !isGV_with_GP(SvRV(arg))) {
3371 filter_cache = SvRV(arg);
3372 SvREFCNT_inc_simple_void_NN(filter_cache);
3379 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3383 if (isGV_with_GP(arg)) {
3384 IO * const io = GvIO((const GV *)arg);
3389 tryrsfp = IoIFP(io);
3390 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3391 PerlIO_close(IoOFP(io));
3402 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3404 SvREFCNT_inc_simple_void_NN(filter_sub);
3407 filter_state = SP[i];
3408 SvREFCNT_inc_simple_void(filter_state);
3412 if (!tryrsfp && (filter_cache || filter_sub)) {
3413 tryrsfp = PerlIO_open(BIT_BUCKET,
3428 filter_has_file = 0;
3430 SvREFCNT_dec(filter_cache);
3431 filter_cache = NULL;
3434 SvREFCNT_dec(filter_state);
3435 filter_state = NULL;
3438 SvREFCNT_dec(filter_sub);
3443 if (!path_is_absolute(name)
3449 dir = SvPV_const(dirsv, dirlen);
3457 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3459 sv_setpv(namesv, unixdir);
3460 sv_catpv(namesv, unixname);
3462 # ifdef __SYMBIAN32__
3463 if (PL_origfilename[0] &&
3464 PL_origfilename[1] == ':' &&
3465 !(dir[0] && dir[1] == ':'))
3466 Perl_sv_setpvf(aTHX_ namesv,
3471 Perl_sv_setpvf(aTHX_ namesv,
3475 /* The equivalent of
3476 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3477 but without the need to parse the format string, or
3478 call strlen on either pointer, and with the correct
3479 allocation up front. */
3481 char *tmp = SvGROW(namesv, dirlen + len + 2);
3483 memcpy(tmp, dir, dirlen);
3486 /* name came from an SV, so it will have a '\0' at the
3487 end that we can copy as part of this memcpy(). */
3488 memcpy(tmp, name, len + 1);
3490 SvCUR_set(namesv, dirlen + len + 1);
3492 /* Don't even actually have to turn SvPOK_on() as we
3493 access it directly with SvPVX() below. */
3497 TAINT_PROPER("require");
3498 tryname = SvPVX_const(namesv);
3499 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3501 if (tryname[0] == '.' && tryname[1] == '/') {
3503 while (*++tryname == '/');
3507 else if (errno == EMFILE)
3508 /* no point in trying other paths if out of handles */
3515 SAVECOPFILE_FREE(&PL_compiling);
3516 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3517 SvREFCNT_dec(namesv);
3519 if (PL_op->op_type == OP_REQUIRE) {
3520 const char *msgstr = name;
3521 if(errno == EMFILE) {
3523 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3525 msgstr = SvPV_nolen_const(msg);
3527 if (namesv) { /* did we lookup @INC? */
3528 AV * const ar = GvAVn(PL_incgv);
3530 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3531 "%s in @INC%s%s (@INC contains:",
3533 (instr(msgstr, ".h ")
3534 ? " (change .h to .ph maybe?)" : ""),
3535 (instr(msgstr, ".ph ")
3536 ? " (did you run h2ph?)" : "")
3539 for (i = 0; i <= AvFILL(ar); i++) {
3540 sv_catpvs(msg, " ");
3541 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3543 sv_catpvs(msg, ")");
3544 msgstr = SvPV_nolen_const(msg);
3547 DIE(aTHX_ "Can't locate %s", msgstr);
3553 SETERRNO(0, SS_NORMAL);
3555 /* Assume success here to prevent recursive requirement. */
3556 /* name is never assigned to again, so len is still strlen(name) */
3557 /* Check whether a hook in @INC has already filled %INC */
3559 (void)hv_store(GvHVn(PL_incgv),
3560 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3562 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3564 (void)hv_store(GvHVn(PL_incgv),
3565 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3570 lex_start(NULL, tryrsfp, TRUE);
3574 hv_clear(GvHV(PL_hintgv));
3576 SAVECOMPILEWARNINGS();
3577 if (PL_dowarn & G_WARN_ALL_ON)
3578 PL_compiling.cop_warnings = pWARN_ALL ;
3579 else if (PL_dowarn & G_WARN_ALL_OFF)
3580 PL_compiling.cop_warnings = pWARN_NONE ;
3582 PL_compiling.cop_warnings = pWARN_STD ;
3584 if (filter_sub || filter_cache) {
3585 SV * const datasv = filter_add(S_run_user_filter, NULL);
3586 IoLINES(datasv) = filter_has_file;
3587 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3588 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3589 IoFMT_GV(datasv) = MUTABLE_GV(filter_cache);
3592 /* switch to eval mode */
3593 PUSHBLOCK(cx, CXt_EVAL, SP);
3595 cx->blk_eval.retop = PL_op->op_next;
3597 SAVECOPLINE(&PL_compiling);
3598 CopLINE_set(&PL_compiling, 0);
3602 /* Store and reset encoding. */
3603 encoding = PL_encoding;
3606 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3607 op = DOCATCH(PL_eval_start);
3609 op = PL_op->op_next;
3611 /* Restore encoding. */
3612 PL_encoding = encoding;
3617 /* This is a op added to hold the hints hash for
3618 pp_entereval. The hash can be modified by the code
3619 being eval'ed, so we return a copy instead. */
3625 mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3633 register PERL_CONTEXT *cx;
3635 const I32 gimme = GIMME_V;
3636 const U32 was = PL_breakable_sub_gen;
3637 char tbuf[TYPE_DIGITS(long) + 12];
3638 char *tmpbuf = tbuf;
3642 HV *saved_hh = NULL;
3644 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3645 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3649 TAINT_IF(SvTAINTED(sv));
3650 TAINT_PROPER("eval");
3653 lex_start(sv, NULL, FALSE);
3656 /* switch to eval mode */
3658 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3659 SV * const temp_sv = sv_newmortal();
3660 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3661 (unsigned long)++PL_evalseq,
3662 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3663 tmpbuf = SvPVX(temp_sv);
3664 len = SvCUR(temp_sv);
3667 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3668 SAVECOPFILE_FREE(&PL_compiling);
3669 CopFILE_set(&PL_compiling, tmpbuf+2);
3670 SAVECOPLINE(&PL_compiling);
3671 CopLINE_set(&PL_compiling, 1);
3672 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3673 deleting the eval's FILEGV from the stash before gv_check() runs
3674 (i.e. before run-time proper). To work around the coredump that
3675 ensues, we always turn GvMULTI_on for any globals that were
3676 introduced within evals. See force_ident(). GSAR 96-10-12 */
3678 PL_hints = PL_op->op_targ;
3680 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3681 SvREFCNT_dec(GvHV(PL_hintgv));
3682 GvHV(PL_hintgv) = saved_hh;
3684 SAVECOMPILEWARNINGS();
3685 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3686 if (PL_compiling.cop_hints_hash) {
3687 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3689 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3690 if (PL_compiling.cop_hints_hash) {
3692 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3693 HINTS_REFCNT_UNLOCK;
3695 /* special case: an eval '' executed within the DB package gets lexically
3696 * placed in the first non-DB CV rather than the current CV - this
3697 * allows the debugger to execute code, find lexicals etc, in the
3698 * scope of the code being debugged. Passing &seq gets find_runcv
3699 * to do the dirty work for us */
3700 runcv = find_runcv(&seq);
3702 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3704 cx->blk_eval.retop = PL_op->op_next;
3706 /* prepare to compile string */
3708 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3709 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3712 if (doeval(gimme, NULL, runcv, seq)) {
3713 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3714 ? (PERLDB_LINE || PERLDB_SAVESRC)
3715 : PERLDB_SAVESRC_NOSUBS) {
3716 /* Retain the filegv we created. */
3718 char *const safestr = savepvn(tmpbuf, len);
3719 SAVEDELETE(PL_defstash, safestr, len);
3721 return DOCATCH(PL_eval_start);
3723 /* We have already left the scope set up earler thanks to the LEAVE
3725 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3726 ? (PERLDB_LINE || PERLDB_SAVESRC)
3727 : PERLDB_SAVESRC_INVALID) {
3728 /* Retain the filegv we created. */
3730 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3732 return PL_op->op_next;
3743 register PERL_CONTEXT *cx;
3745 const U8 save_flags = PL_op -> op_flags;
3750 retop = cx->blk_eval.retop;
3753 if (gimme == G_VOID)
3755 else if (gimme == G_SCALAR) {
3758 if (SvFLAGS(TOPs) & SVs_TEMP)
3761 *MARK = sv_mortalcopy(TOPs);
3765 *MARK = &PL_sv_undef;
3770 /* in case LEAVE wipes old return values */
3771 for (mark = newsp + 1; mark <= SP; mark++) {
3772 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3773 *mark = sv_mortalcopy(*mark);
3774 TAINT_NOT; /* Each item is independent */
3778 PL_curpm = newpm; /* Don't pop $1 et al till now */
3781 assert(CvDEPTH(PL_compcv) == 1);
3783 CvDEPTH(PL_compcv) = 0;
3786 if (optype == OP_REQUIRE &&
3787 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3789 /* Unassume the success we assumed earlier. */
3790 SV * const nsv = cx->blk_eval.old_namesv;
3791 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3792 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3793 /* die_where() did LEAVE, or we won't be here */
3797 if (!(save_flags & OPf_SPECIAL)) {
3805 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3806 close to the related Perl_create_eval_scope. */
3808 Perl_delete_eval_scope(pTHX)
3813 register PERL_CONTEXT *cx;
3820 PERL_UNUSED_VAR(newsp);
3821 PERL_UNUSED_VAR(gimme);
3822 PERL_UNUSED_VAR(optype);
3825 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3826 also needed by Perl_fold_constants. */
3828 Perl_create_eval_scope(pTHX_ U32 flags)
3831 const I32 gimme = GIMME_V;
3836 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3839 PL_in_eval = EVAL_INEVAL;
3840 if (flags & G_KEEPERR)
3841 PL_in_eval |= EVAL_KEEPERR;
3844 if (flags & G_FAKINGEVAL) {
3845 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3853 PERL_CONTEXT * const cx = create_eval_scope(0);
3854 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3855 return DOCATCH(PL_op->op_next);
3864 register PERL_CONTEXT *cx;
3869 PERL_UNUSED_VAR(optype);
3872 if (gimme == G_VOID)
3874 else if (gimme == G_SCALAR) {
3878 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3881 *MARK = sv_mortalcopy(TOPs);
3885 *MARK = &PL_sv_undef;
3890 /* in case LEAVE wipes old return values */
3892 for (mark = newsp + 1; mark <= SP; mark++) {
3893 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3894 *mark = sv_mortalcopy(*mark);
3895 TAINT_NOT; /* Each item is independent */
3899 PL_curpm = newpm; /* Don't pop $1 et al till now */
3909 register PERL_CONTEXT *cx;
3910 const I32 gimme = GIMME_V;
3915 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3917 PUSHBLOCK(cx, CXt_GIVEN, SP);
3926 register PERL_CONTEXT *cx;
3930 PERL_UNUSED_CONTEXT;
3933 assert(CxTYPE(cx) == CXt_GIVEN);
3938 PL_curpm = newpm; /* pop $1 et al */
3945 /* Helper routines used by pp_smartmatch */
3947 S_make_matcher(pTHX_ REGEXP *re)
3950 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3952 PERL_ARGS_ASSERT_MAKE_MATCHER;
3954 PM_SETRE(matcher, ReREFCNT_inc(re));
3956 SAVEFREEOP((OP *) matcher);
3963 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3968 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
3970 PL_op = (OP *) matcher;
3975 return (SvTRUEx(POPs));
3979 S_destroy_matcher(pTHX_ PMOP *matcher)
3983 PERL_ARGS_ASSERT_DESTROY_MATCHER;
3984 PERL_UNUSED_ARG(matcher);
3990 /* Do a smart match */
3993 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
3994 return do_smartmatch(NULL, NULL);
3997 /* This version of do_smartmatch() implements the
3998 * table of smart matches that is found in perlsyn.
4001 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4006 bool object_on_left = FALSE;
4007 SV *e = TOPs; /* e is for 'expression' */
4008 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4010 /* First of all, handle overload magic of the rightmost argument */
4013 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4014 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4016 tmpsv = amagic_call(d, e, smart_amg, 0);
4023 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4026 SP -= 2; /* Pop the values */
4028 /* Take care only to invoke mg_get() once for each argument.
4029 * Currently we do this by copying the SV if it's magical. */
4032 d = sv_mortalcopy(d);
4039 e = sv_mortalcopy(e);
4043 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4050 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4051 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4052 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4054 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4055 object_on_left = TRUE;
4058 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4060 if (object_on_left) {
4061 goto sm_any_sub; /* Treat objects like scalars */
4063 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4064 /* Test sub truth for each key */
4066 bool andedresults = TRUE;
4067 HV *hv = (HV*) SvRV(d);
4068 I32 numkeys = hv_iterinit(hv);
4069 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4072 while ( (he = hv_iternext(hv)) ) {
4073 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4077 PUSHs(hv_iterkeysv(he));
4079 c = call_sv(e, G_SCALAR);
4082 andedresults = FALSE;
4084 andedresults = SvTRUEx(POPs) && andedresults;
4093 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4094 /* Test sub truth for each element */
4096 bool andedresults = TRUE;
4097 AV *av = (AV*) SvRV(d);
4098 const I32 len = av_len(av);
4099 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4102 for (i = 0; i <= len; ++i) {
4103 SV * const * const svp = av_fetch(av, i, FALSE);
4104 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4111 c = call_sv(e, G_SCALAR);
4114 andedresults = FALSE;
4116 andedresults = SvTRUEx(POPs) && andedresults;
4127 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4133 c = call_sv(e, G_SCALAR);
4137 else if (SvTEMP(TOPs))
4138 SvREFCNT_inc_void(TOPs);
4145 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4146 if (object_on_left) {
4147 goto sm_any_hash; /* Treat objects like scalars */
4149 else if (!SvOK(d)) {
4150 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4153 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4154 /* Check that the key-sets are identical */
4156 HV *other_hv = MUTABLE_HV(SvRV(d));
4158 bool other_tied = FALSE;
4159 U32 this_key_count = 0,
4160 other_key_count = 0;
4161 HV *hv = MUTABLE_HV(SvRV(e));
4163 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4164 /* Tied hashes don't know how many keys they have. */
4165 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4168 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4169 HV * const temp = other_hv;
4174 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4177 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4180 /* The hashes have the same number of keys, so it suffices
4181 to check that one is a subset of the other. */
4182 (void) hv_iterinit(hv);
4183 while ( (he = hv_iternext(hv)) ) {
4184 SV *key = hv_iterkeysv(he);
4186 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4189 if(!hv_exists_ent(other_hv, key, 0)) {
4190 (void) hv_iterinit(hv); /* reset iterator */
4196 (void) hv_iterinit(other_hv);
4197 while ( hv_iternext(other_hv) )
4201 other_key_count = HvUSEDKEYS(other_hv);
4203 if (this_key_count != other_key_count)
4208 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4209 AV * const other_av = MUTABLE_AV(SvRV(d));
4210 const I32 other_len = av_len(other_av) + 1;
4212 HV *hv = MUTABLE_HV(SvRV(e));
4214 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4215 for (i = 0; i < other_len; ++i) {
4216 SV ** const svp = av_fetch(other_av, i, FALSE);
4217 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4218 if (svp) { /* ??? When can this not happen? */
4219 if (hv_exists_ent(hv, *svp, 0))
4225 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4226 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4229 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4231 HV *hv = MUTABLE_HV(SvRV(e));
4233 (void) hv_iterinit(hv);
4234 while ( (he = hv_iternext(hv)) ) {
4235 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4236 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4237 (void) hv_iterinit(hv);
4238 destroy_matcher(matcher);
4242 destroy_matcher(matcher);
4248 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4249 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4256 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4257 if (object_on_left) {
4258 goto sm_any_array; /* Treat objects like scalars */
4260 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4261 AV * const other_av = MUTABLE_AV(SvRV(e));
4262 const I32 other_len = av_len(other_av) + 1;
4265 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4266 for (i = 0; i < other_len; ++i) {
4267 SV ** const svp = av_fetch(other_av, i, FALSE);
4269 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4270 if (svp) { /* ??? When can this not happen? */
4271 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4277 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4278 AV *other_av = MUTABLE_AV(SvRV(d));
4279 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4280 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4284 const I32 other_len = av_len(other_av);
4286 if (NULL == seen_this) {
4287 seen_this = newHV();
4288 (void) sv_2mortal(MUTABLE_SV(seen_this));
4290 if (NULL == seen_other) {
4291 seen_this = newHV();
4292 (void) sv_2mortal(MUTABLE_SV(seen_other));
4294 for(i = 0; i <= other_len; ++i) {
4295 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4296 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4298 if (!this_elem || !other_elem) {
4299 if (this_elem || other_elem)
4302 else if (hv_exists_ent(seen_this,
4303 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4304 hv_exists_ent(seen_other,
4305 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4307 if (*this_elem != *other_elem)
4311 (void)hv_store_ent(seen_this,
4312 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4314 (void)hv_store_ent(seen_other,
4315 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4321 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4322 (void) do_smartmatch(seen_this, seen_other);
4324 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4333 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4334 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4337 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4338 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4341 for(i = 0; i <= this_len; ++i) {
4342 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4343 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4344 if (svp && matcher_matches_sv(matcher, *svp)) {
4345 destroy_matcher(matcher);
4349 destroy_matcher(matcher);
4353 else if (!SvOK(d)) {
4354 /* undef ~~ array */
4355 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4358 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4359 for (i = 0; i <= this_len; ++i) {
4360 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4361 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4362 if (!svp || !SvOK(*svp))
4371 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4373 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4374 for (i = 0; i <= this_len; ++i) {
4375 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4382 /* infinite recursion isn't supposed to happen here */
4383 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4384 (void) do_smartmatch(NULL, NULL);
4386 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4395 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4396 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4397 SV *t = d; d = e; e = t;
4398 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4401 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4402 SV *t = d; d = e; e = t;
4403 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4404 goto sm_regex_array;
4407 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4409 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4411 PUSHs(matcher_matches_sv(matcher, d)
4414 destroy_matcher(matcher);
4419 /* See if there is overload magic on left */
4420 else if (object_on_left && SvAMAGIC(d)) {
4422 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4423 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4426 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4434 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4437 else if (!SvOK(d)) {
4438 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4439 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4444 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4445 DEBUG_M(if (SvNIOK(e))
4446 Perl_deb(aTHX_ " applying rule Any-Num\n");
4448 Perl_deb(aTHX_ " applying rule Num-numish\n");
4450 /* numeric comparison */
4453 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4464 /* As a last resort, use string comparison */
4465 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4474 register PERL_CONTEXT *cx;
4475 const I32 gimme = GIMME_V;
4477 /* This is essentially an optimization: if the match
4478 fails, we don't want to push a context and then
4479 pop it again right away, so we skip straight
4480 to the op that follows the leavewhen.
4482 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4483 return cLOGOP->op_other->op_next;
4488 PUSHBLOCK(cx, CXt_WHEN, SP);
4497 register PERL_CONTEXT *cx;
4503 assert(CxTYPE(cx) == CXt_WHEN);
4508 PL_curpm = newpm; /* pop $1 et al */
4518 register PERL_CONTEXT *cx;
4521 cxix = dopoptowhen(cxstack_ix);
4523 DIE(aTHX_ "Can't \"continue\" outside a when block");
4524 if (cxix < cxstack_ix)
4527 /* clear off anything above the scope we're re-entering */
4528 inner = PL_scopestack_ix;
4530 if (PL_scopestack_ix < inner)
4531 leave_scope(PL_scopestack[PL_scopestack_ix]);
4532 PL_curcop = cx->blk_oldcop;
4533 return cx->blk_givwhen.leave_op;
4540 register PERL_CONTEXT *cx;
4543 cxix = dopoptogiven(cxstack_ix);
4545 if (PL_op->op_flags & OPf_SPECIAL)
4546 DIE(aTHX_ "Can't use when() outside a topicalizer");
4548 DIE(aTHX_ "Can't \"break\" outside a given block");
4550 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4551 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4553 if (cxix < cxstack_ix)
4556 /* clear off anything above the scope we're re-entering */
4557 inner = PL_scopestack_ix;
4559 if (PL_scopestack_ix < inner)
4560 leave_scope(PL_scopestack[PL_scopestack_ix]);
4561 PL_curcop = cx->blk_oldcop;
4564 return CX_LOOP_NEXTOP_GET(cx);
4566 return cx->blk_givwhen.leave_op;
4570 S_doparseform(pTHX_ SV *sv)
4573 register char *s = SvPV_force(sv, len);
4574 register char * const send = s + len;
4575 register char *base = NULL;
4576 register I32 skipspaces = 0;
4577 bool noblank = FALSE;
4578 bool repeat = FALSE;
4579 bool postspace = FALSE;
4585 bool unchopnum = FALSE;
4586 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4588 PERL_ARGS_ASSERT_DOPARSEFORM;
4591 Perl_croak(aTHX_ "Null picture in formline");
4593 /* estimate the buffer size needed */
4594 for (base = s; s <= send; s++) {
4595 if (*s == '\n' || *s == '@' || *s == '^')
4601 Newx(fops, maxops, U32);
4606 *fpc++ = FF_LINEMARK;
4607 noblank = repeat = FALSE;
4625 case ' ': case '\t':
4632 } /* else FALL THROUGH */
4640 *fpc++ = FF_LITERAL;
4648 *fpc++ = (U16)skipspaces;
4652 *fpc++ = FF_NEWLINE;
4656 arg = fpc - linepc + 1;
4663 *fpc++ = FF_LINEMARK;
4664 noblank = repeat = FALSE;
4673 ischop = s[-1] == '^';
4679 arg = (s - base) - 1;
4681 *fpc++ = FF_LITERAL;
4689 *fpc++ = 2; /* skip the @* or ^* */
4691 *fpc++ = FF_LINESNGL;
4694 *fpc++ = FF_LINEGLOB;
4696 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4697 arg = ischop ? 512 : 0;
4702 const char * const f = ++s;
4705 arg |= 256 + (s - f);
4707 *fpc++ = s - base; /* fieldsize for FETCH */
4708 *fpc++ = FF_DECIMAL;
4710 unchopnum |= ! ischop;
4712 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4713 arg = ischop ? 512 : 0;
4715 s++; /* skip the '0' first */
4719 const char * const f = ++s;
4722 arg |= 256 + (s - f);
4724 *fpc++ = s - base; /* fieldsize for FETCH */
4725 *fpc++ = FF_0DECIMAL;
4727 unchopnum |= ! ischop;
4731 bool ismore = FALSE;
4734 while (*++s == '>') ;
4735 prespace = FF_SPACE;
4737 else if (*s == '|') {
4738 while (*++s == '|') ;
4739 prespace = FF_HALFSPACE;
4744 while (*++s == '<') ;
4747 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4751 *fpc++ = s - base; /* fieldsize for FETCH */
4753 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4756 *fpc++ = (U16)prespace;
4770 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4772 { /* need to jump to the next word */
4774 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4775 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4776 s = SvPVX(sv) + SvCUR(sv) + z;
4778 Copy(fops, s, arg, U32);
4780 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4783 if (unchopnum && repeat)
4784 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4790 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4792 /* Can value be printed in fldsize chars, using %*.*f ? */
4796 int intsize = fldsize - (value < 0 ? 1 : 0);
4803 while (intsize--) pwr *= 10.0;
4804 while (frcsize--) eps /= 10.0;
4807 if (value + eps >= pwr)
4810 if (value - eps <= -pwr)
4817 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4820 SV * const datasv = FILTER_DATA(idx);
4821 const int filter_has_file = IoLINES(datasv);
4822 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4823 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4827 const char *got_p = NULL;
4828 const char *prune_from = NULL;
4829 bool read_from_cache = FALSE;
4832 PERL_ARGS_ASSERT_RUN_USER_FILTER;
4834 assert(maxlen >= 0);
4837 /* I was having segfault trouble under Linux 2.2.5 after a
4838 parse error occured. (Had to hack around it with a test
4839 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4840 not sure where the trouble is yet. XXX */
4842 if (IoFMT_GV(datasv)) {
4843 SV *const cache = MUTABLE_SV(IoFMT_GV(datasv));
4846 const char *cache_p = SvPV(cache, cache_len);
4850 /* Running in block mode and we have some cached data already.
4852 if (cache_len >= umaxlen) {
4853 /* In fact, so much data we don't even need to call
4858 const char *const first_nl =
4859 (const char *)memchr(cache_p, '\n', cache_len);
4861 take = first_nl + 1 - cache_p;
4865 sv_catpvn(buf_sv, cache_p, take);
4866 sv_chop(cache, cache_p + take);
4867 /* Definately not EOF */
4871 sv_catsv(buf_sv, cache);
4873 umaxlen -= cache_len;
4876 read_from_cache = TRUE;
4880 /* Filter API says that the filter appends to the contents of the buffer.
4881 Usually the buffer is "", so the details don't matter. But if it's not,
4882 then clearly what it contains is already filtered by this filter, so we
4883 don't want to pass it in a second time.
4884 I'm going to use a mortal in case the upstream filter croaks. */
4885 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4886 ? sv_newmortal() : buf_sv;
4887 SvUPGRADE(upstream, SVt_PV);
4889 if (filter_has_file) {
4890 status = FILTER_READ(idx+1, upstream, 0);
4893 if (filter_sub && status >= 0) {
4902 DEFSV_set(upstream);
4906 PUSHs(filter_state);
4909 count = call_sv(filter_sub, G_SCALAR);
4924 if(SvOK(upstream)) {
4925 got_p = SvPV(upstream, got_len);
4927 if (got_len > umaxlen) {
4928 prune_from = got_p + umaxlen;
4931 const char *const first_nl =
4932 (const char *)memchr(got_p, '\n', got_len);
4933 if (first_nl && first_nl + 1 < got_p + got_len) {
4934 /* There's a second line here... */
4935 prune_from = first_nl + 1;
4940 /* Oh. Too long. Stuff some in our cache. */
4941 STRLEN cached_len = got_p + got_len - prune_from;
4942 SV *cache = MUTABLE_SV(IoFMT_GV(datasv));
4945 IoFMT_GV(datasv) = MUTABLE_GV((cache = newSV(got_len - umaxlen)));
4946 } else if (SvOK(cache)) {
4947 /* Cache should be empty. */
4948 assert(!SvCUR(cache));
4951 sv_setpvn(cache, prune_from, cached_len);
4952 /* If you ask for block mode, you may well split UTF-8 characters.
4953 "If it breaks, you get to keep both parts"
4954 (Your code is broken if you don't put them back together again
4955 before something notices.) */
4956 if (SvUTF8(upstream)) {
4959 SvCUR_set(upstream, got_len - cached_len);
4960 /* Can't yet be EOF */
4965 /* If they are at EOF but buf_sv has something in it, then they may never
4966 have touched the SV upstream, so it may be undefined. If we naively
4967 concatenate it then we get a warning about use of uninitialised value.
4969 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4970 sv_catsv(buf_sv, upstream);
4974 IoLINES(datasv) = 0;
4975 SvREFCNT_dec(IoFMT_GV(datasv));
4977 SvREFCNT_dec(filter_state);
4978 IoTOP_GV(datasv) = NULL;
4981 SvREFCNT_dec(filter_sub);
4982 IoBOTTOM_GV(datasv) = NULL;
4984 filter_del(S_run_user_filter);
4986 if (status == 0 && read_from_cache) {
4987 /* If we read some data from the cache (and by getting here it implies
4988 that we emptied the cache) then we aren't yet at EOF, and mustn't
4989 report that to our caller. */
4995 /* perhaps someone can come up with a better name for
4996 this? it is not really "absolute", per se ... */
4998 S_path_is_absolute(const char *name)
5000 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5002 if (PERL_FILE_IS_ABSOLUTE(name)
5004 || (*name == '.' && ((name[1] == '/' ||
5005 (name[1] == '.' && name[2] == '/'))
5006 || (name[1] == '\\' ||
5007 ( name[1] == '.' && name[2] == '\\')))
5010 || (*name == '.' && (name[1] == '/' ||
5011 (name[1] == '.' && name[2] == '/')))
5023 * c-indentation-style: bsd
5025 * indent-tabs-mode: t
5028 * ex: set ts=8 sts=4 sw=4 noet: