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);
238 if (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
239 s == m, cx->sb_targ, NULL,
240 ((cx->sb_rflags & REXEC_COPY_STR)
241 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
242 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
244 SV * const targ = cx->sb_targ;
246 assert(cx->sb_strend >= s);
247 if(cx->sb_strend > s) {
248 if (DO_UTF8(dstr) && !SvUTF8(targ))
249 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
251 sv_catpvn(dstr, s, cx->sb_strend - s);
253 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
255 #ifdef PERL_OLD_COPY_ON_WRITE
257 sv_force_normal_flags(targ, SV_COW_DROP_PV);
263 SvPV_set(targ, SvPVX(dstr));
264 SvCUR_set(targ, SvCUR(dstr));
265 SvLEN_set(targ, SvLEN(dstr));
268 SvPV_set(dstr, NULL);
270 TAINT_IF(cx->sb_rxtainted & 1);
271 mPUSHi(saviters - 1);
273 (void)SvPOK_only_UTF8(targ);
274 TAINT_IF(cx->sb_rxtainted);
278 LEAVE_SCOPE(cx->sb_oldsave);
280 RETURNOP(pm->op_next);
282 cx->sb_iters = saviters;
284 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
287 cx->sb_orig = orig = RX_SUBBEG(rx);
289 cx->sb_strend = s + (cx->sb_strend - m);
291 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
293 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
294 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
296 sv_catpvn(dstr, s, m-s);
298 cx->sb_s = RX_OFFS(rx)[0].end + orig;
299 { /* Update the pos() information. */
300 SV * const sv = cx->sb_targ;
302 SvUPGRADE(sv, SVt_PVMG);
303 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
304 #ifdef PERL_OLD_COPY_ON_WRITE
306 sv_force_normal_flags(sv, 0);
308 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
311 mg->mg_len = m - orig;
314 (void)ReREFCNT_inc(rx);
315 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
316 rxres_save(&cx->sb_rxres, rx);
317 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
321 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
326 PERL_ARGS_ASSERT_RXRES_SAVE;
329 if (!p || p[1] < RX_NPARENS(rx)) {
330 #ifdef PERL_OLD_COPY_ON_WRITE
331 i = 7 + RX_NPARENS(rx) * 2;
333 i = 6 + RX_NPARENS(rx) * 2;
342 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
343 RX_MATCH_COPIED_off(rx);
345 #ifdef PERL_OLD_COPY_ON_WRITE
346 *p++ = PTR2UV(RX_SAVED_COPY(rx));
347 RX_SAVED_COPY(rx) = NULL;
350 *p++ = RX_NPARENS(rx);
352 *p++ = PTR2UV(RX_SUBBEG(rx));
353 *p++ = (UV)RX_SUBLEN(rx);
354 for (i = 0; i <= RX_NPARENS(rx); ++i) {
355 *p++ = (UV)RX_OFFS(rx)[i].start;
356 *p++ = (UV)RX_OFFS(rx)[i].end;
361 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
366 PERL_ARGS_ASSERT_RXRES_RESTORE;
369 RX_MATCH_COPY_FREE(rx);
370 RX_MATCH_COPIED_set(rx, *p);
373 #ifdef PERL_OLD_COPY_ON_WRITE
374 if (RX_SAVED_COPY(rx))
375 SvREFCNT_dec (RX_SAVED_COPY(rx));
376 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
380 RX_NPARENS(rx) = *p++;
382 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
383 RX_SUBLEN(rx) = (I32)(*p++);
384 for (i = 0; i <= RX_NPARENS(rx); ++i) {
385 RX_OFFS(rx)[i].start = (I32)(*p++);
386 RX_OFFS(rx)[i].end = (I32)(*p++);
391 S_rxres_free(pTHX_ void **rsp)
393 UV * const p = (UV*)*rsp;
395 PERL_ARGS_ASSERT_RXRES_FREE;
400 void *tmp = INT2PTR(char*,*p);
403 PoisonFree(*p, 1, sizeof(*p));
405 Safefree(INT2PTR(char*,*p));
407 #ifdef PERL_OLD_COPY_ON_WRITE
409 SvREFCNT_dec (INT2PTR(SV*,p[1]));
419 dVAR; dSP; dMARK; dORIGMARK;
420 register SV * const tmpForm = *++MARK;
425 register SV *sv = NULL;
426 const char *item = NULL;
430 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
431 const char *chophere = NULL;
432 char *linemark = NULL;
434 bool gotsome = FALSE;
436 const STRLEN fudge = SvPOK(tmpForm)
437 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
438 bool item_is_utf8 = FALSE;
439 bool targ_is_utf8 = FALSE;
441 OP * parseres = NULL;
444 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
445 if (SvREADONLY(tmpForm)) {
446 SvREADONLY_off(tmpForm);
447 parseres = doparseform(tmpForm);
448 SvREADONLY_on(tmpForm);
451 parseres = doparseform(tmpForm);
455 SvPV_force(PL_formtarget, len);
456 if (DO_UTF8(PL_formtarget))
458 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
460 f = SvPV_const(tmpForm, len);
461 /* need to jump to the next word */
462 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
466 const char *name = "???";
469 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
470 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
471 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
472 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
473 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
475 case FF_CHECKNL: name = "CHECKNL"; break;
476 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
477 case FF_SPACE: name = "SPACE"; break;
478 case FF_HALFSPACE: name = "HALFSPACE"; break;
479 case FF_ITEM: name = "ITEM"; break;
480 case FF_CHOP: name = "CHOP"; break;
481 case FF_LINEGLOB: name = "LINEGLOB"; break;
482 case FF_NEWLINE: name = "NEWLINE"; break;
483 case FF_MORE: name = "MORE"; break;
484 case FF_LINEMARK: name = "LINEMARK"; break;
485 case FF_END: name = "END"; break;
486 case FF_0DECIMAL: name = "0DECIMAL"; break;
487 case FF_LINESNGL: name = "LINESNGL"; break;
490 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
492 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
503 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
504 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
506 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
507 t = SvEND(PL_formtarget);
511 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
512 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
514 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
515 t = SvEND(PL_formtarget);
535 if (ckWARN(WARN_SYNTAX))
536 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
543 const char *s = item = SvPV_const(sv, len);
546 itemsize = sv_len_utf8(sv);
547 if (itemsize != (I32)len) {
549 if (itemsize > fieldsize) {
550 itemsize = fieldsize;
551 itembytes = itemsize;
552 sv_pos_u2b(sv, &itembytes, 0);
556 send = chophere = s + itembytes;
566 sv_pos_b2u(sv, &itemsize);
570 item_is_utf8 = FALSE;
571 if (itemsize > fieldsize)
572 itemsize = fieldsize;
573 send = chophere = s + itemsize;
587 const char *s = item = SvPV_const(sv, len);
590 itemsize = sv_len_utf8(sv);
591 if (itemsize != (I32)len) {
593 if (itemsize <= fieldsize) {
594 const char *send = chophere = s + itemsize;
607 itemsize = fieldsize;
608 itembytes = itemsize;
609 sv_pos_u2b(sv, &itembytes, 0);
610 send = chophere = s + itembytes;
611 while (s < send || (s == send && isSPACE(*s))) {
621 if (strchr(PL_chopset, *s))
626 itemsize = chophere - item;
627 sv_pos_b2u(sv, &itemsize);
633 item_is_utf8 = FALSE;
634 if (itemsize <= fieldsize) {
635 const char *const send = chophere = s + itemsize;
648 itemsize = fieldsize;
649 send = chophere = s + itemsize;
650 while (s < send || (s == send && isSPACE(*s))) {
660 if (strchr(PL_chopset, *s))
665 itemsize = chophere - item;
671 arg = fieldsize - itemsize;
680 arg = fieldsize - itemsize;
691 const char *s = item;
695 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
697 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
699 t = SvEND(PL_formtarget);
703 if (UTF8_IS_CONTINUED(*s)) {
704 STRLEN skip = UTF8SKIP(s);
721 if ( !((*t++ = *s++) & ~31) )
727 if (targ_is_utf8 && !item_is_utf8) {
728 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
730 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
731 for (; t < SvEND(PL_formtarget); t++) {
744 const int ch = *t++ = *s++;
747 if ( !((*t++ = *s++) & ~31) )
756 const char *s = chophere;
770 const bool oneline = fpc[-1] == FF_LINESNGL;
771 const char *s = item = SvPV_const(sv, len);
772 item_is_utf8 = DO_UTF8(sv);
775 STRLEN to_copy = itemsize;
776 const char *const send = s + len;
777 const U8 *source = (const U8 *) s;
781 chophere = s + itemsize;
785 to_copy = s - SvPVX_const(sv) - 1;
797 if (targ_is_utf8 && !item_is_utf8) {
798 source = tmp = bytes_to_utf8(source, &to_copy);
799 SvCUR_set(PL_formtarget,
800 t - SvPVX_const(PL_formtarget));
802 if (item_is_utf8 && !targ_is_utf8) {
803 /* Upgrade targ to UTF8, and then we reduce it to
804 a problem we have a simple solution for. */
805 SvCUR_set(PL_formtarget,
806 t - SvPVX_const(PL_formtarget));
808 /* Don't need get magic. */
809 sv_utf8_upgrade_nomg(PL_formtarget);
811 SvCUR_set(PL_formtarget,
812 t - SvPVX_const(PL_formtarget));
815 /* Easy. They agree. */
816 assert (item_is_utf8 == targ_is_utf8);
818 SvGROW(PL_formtarget,
819 SvCUR(PL_formtarget) + to_copy + fudge + 1);
820 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
822 Copy(source, t, to_copy, char);
824 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
826 if (SvGMAGICAL(sv)) {
827 /* Mustn't call sv_pos_b2u() as it does a second
828 mg_get(). Is this a bug? Do we need a _flags()
830 itemsize = utf8_length(source, source + itemsize);
832 sv_pos_b2u(sv, &itemsize);
844 #if defined(USE_LONG_DOUBLE)
847 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
851 "%#0*.*f" : "%0*.*f");
856 #if defined(USE_LONG_DOUBLE)
858 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
861 ((arg & 256) ? "%#*.*f" : "%*.*f");
864 /* If the field is marked with ^ and the value is undefined,
866 if ((arg & 512) && !SvOK(sv)) {
874 /* overflow evidence */
875 if (num_overflow(value, fieldsize, arg)) {
881 /* Formats aren't yet marked for locales, so assume "yes". */
883 STORE_NUMERIC_STANDARD_SET_LOCAL();
884 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
885 RESTORE_NUMERIC_STANDARD();
892 while (t-- > linemark && *t == ' ') ;
900 if (arg) { /* repeat until fields exhausted? */
902 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
903 lines += FmLINES(PL_formtarget);
906 if (strnEQ(linemark, linemark - arg, arg))
907 DIE(aTHX_ "Runaway format");
910 SvUTF8_on(PL_formtarget);
911 FmLINES(PL_formtarget) = lines;
913 RETURNOP(cLISTOP->op_first);
924 const char *s = chophere;
925 const char *send = item + len;
927 while (isSPACE(*s) && (s < send))
932 arg = fieldsize - itemsize;
939 if (strnEQ(s1," ",3)) {
940 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
951 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
953 SvUTF8_on(PL_formtarget);
954 FmLINES(PL_formtarget) += lines;
966 if (PL_stack_base + *PL_markstack_ptr == SP) {
968 if (GIMME_V == G_SCALAR)
970 RETURNOP(PL_op->op_next->op_next);
972 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
973 pp_pushmark(); /* push dst */
974 pp_pushmark(); /* push src */
975 ENTER; /* enter outer scope */
978 if (PL_op->op_private & OPpGREP_LEX)
979 SAVESPTR(PAD_SVl(PL_op->op_targ));
982 ENTER; /* enter inner scope */
985 src = PL_stack_base[*PL_markstack_ptr];
987 if (PL_op->op_private & OPpGREP_LEX)
988 PAD_SVl(PL_op->op_targ) = src;
993 if (PL_op->op_type == OP_MAPSTART)
994 pp_pushmark(); /* push top */
995 return ((LOGOP*)PL_op->op_next)->op_other;
1001 const I32 gimme = GIMME_V;
1002 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1008 /* first, move source pointer to the next item in the source list */
1009 ++PL_markstack_ptr[-1];
1011 /* if there are new items, push them into the destination list */
1012 if (items && gimme != G_VOID) {
1013 /* might need to make room back there first */
1014 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1015 /* XXX this implementation is very pessimal because the stack
1016 * is repeatedly extended for every set of items. Is possible
1017 * to do this without any stack extension or copying at all
1018 * by maintaining a separate list over which the map iterates
1019 * (like foreach does). --gsar */
1021 /* everything in the stack after the destination list moves
1022 * towards the end the stack by the amount of room needed */
1023 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1025 /* items to shift up (accounting for the moved source pointer) */
1026 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1028 /* This optimization is by Ben Tilly and it does
1029 * things differently from what Sarathy (gsar)
1030 * is describing. The downside of this optimization is
1031 * that leaves "holes" (uninitialized and hopefully unused areas)
1032 * to the Perl stack, but on the other hand this
1033 * shouldn't be a problem. If Sarathy's idea gets
1034 * implemented, this optimization should become
1035 * irrelevant. --jhi */
1037 shift = count; /* Avoid shifting too often --Ben Tilly */
1041 dst = (SP += shift);
1042 PL_markstack_ptr[-1] += shift;
1043 *PL_markstack_ptr += shift;
1047 /* copy the new items down to the destination list */
1048 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1049 if (gimme == G_ARRAY) {
1051 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1054 /* scalar context: we don't care about which values map returns
1055 * (we use undef here). And so we certainly don't want to do mortal
1056 * copies of meaningless values. */
1057 while (items-- > 0) {
1059 *dst-- = &PL_sv_undef;
1063 LEAVE; /* exit inner scope */
1066 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1068 (void)POPMARK; /* pop top */
1069 LEAVE; /* exit outer scope */
1070 (void)POPMARK; /* pop src */
1071 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1072 (void)POPMARK; /* pop dst */
1073 SP = PL_stack_base + POPMARK; /* pop original mark */
1074 if (gimme == G_SCALAR) {
1075 if (PL_op->op_private & OPpGREP_LEX) {
1076 SV* sv = sv_newmortal();
1077 sv_setiv(sv, items);
1085 else if (gimme == G_ARRAY)
1092 ENTER; /* enter inner scope */
1095 /* set $_ to the new source item */
1096 src = PL_stack_base[PL_markstack_ptr[-1]];
1098 if (PL_op->op_private & OPpGREP_LEX)
1099 PAD_SVl(PL_op->op_targ) = src;
1103 RETURNOP(cLOGOP->op_other);
1112 if (GIMME == G_ARRAY)
1114 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1115 return cLOGOP->op_other;
1125 if (GIMME == G_ARRAY) {
1126 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1130 SV * const targ = PAD_SV(PL_op->op_targ);
1133 if (PL_op->op_private & OPpFLIP_LINENUM) {
1134 if (GvIO(PL_last_in_gv)) {
1135 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1138 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1140 flip = SvIV(sv) == SvIV(GvSV(gv));
1146 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1147 if (PL_op->op_flags & OPf_SPECIAL) {
1155 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1158 sv_setpvs(TARG, "");
1164 /* This code tries to decide if "$left .. $right" should use the
1165 magical string increment, or if the range is numeric (we make
1166 an exception for .."0" [#18165]). AMS 20021031. */
1168 #define RANGE_IS_NUMERIC(left,right) ( \
1169 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1170 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1171 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1172 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1173 && (!SvOK(right) || looks_like_number(right))))
1179 if (GIMME == G_ARRAY) {
1185 if (RANGE_IS_NUMERIC(left,right)) {
1188 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1189 (SvOK(right) && SvNV(right) > IV_MAX))
1190 DIE(aTHX_ "Range iterator outside integer range");
1201 SV * const sv = sv_2mortal(newSViv(i++));
1206 SV * const final = sv_mortalcopy(right);
1208 const char * const tmps = SvPV_const(final, len);
1210 SV *sv = sv_mortalcopy(left);
1211 SvPV_force_nolen(sv);
1212 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1214 if (strEQ(SvPVX_const(sv),tmps))
1216 sv = sv_2mortal(newSVsv(sv));
1223 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1227 if (PL_op->op_private & OPpFLIP_LINENUM) {
1228 if (GvIO(PL_last_in_gv)) {
1229 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1232 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1233 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1241 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1242 sv_catpvs(targ, "E0");
1252 static const char * const context_name[] = {
1254 NULL, /* CXt_WHEN never actually needs "block" */
1255 NULL, /* CXt_BLOCK never actually needs "block" */
1256 NULL, /* CXt_GIVEN never actually needs "block" */
1257 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1258 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1259 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1260 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1268 S_dopoptolabel(pTHX_ const char *label)
1273 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1275 for (i = cxstack_ix; i >= 0; i--) {
1276 register const PERL_CONTEXT * const cx = &cxstack[i];
1277 switch (CxTYPE(cx)) {
1283 if (ckWARN(WARN_EXITING))
1284 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1285 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1286 if (CxTYPE(cx) == CXt_NULL)
1289 case CXt_LOOP_LAZYIV:
1290 case CXt_LOOP_LAZYSV:
1292 case CXt_LOOP_PLAIN:
1293 if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
1294 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1295 (long)i, CxLABEL(cx)));
1298 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1308 Perl_dowantarray(pTHX)
1311 const I32 gimme = block_gimme();
1312 return (gimme == G_VOID) ? G_SCALAR : gimme;
1316 Perl_block_gimme(pTHX)
1319 const I32 cxix = dopoptosub(cxstack_ix);
1323 switch (cxstack[cxix].blk_gimme) {
1331 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1338 Perl_is_lvalue_sub(pTHX)
1341 const I32 cxix = dopoptosub(cxstack_ix);
1342 assert(cxix >= 0); /* We should only be called from inside subs */
1344 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1345 return CxLVAL(cxstack + cxix);
1351 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1356 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1358 for (i = startingblock; i >= 0; i--) {
1359 register const PERL_CONTEXT * const cx = &cxstk[i];
1360 switch (CxTYPE(cx)) {
1366 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1374 S_dopoptoeval(pTHX_ I32 startingblock)
1378 for (i = startingblock; i >= 0; i--) {
1379 register const PERL_CONTEXT *cx = &cxstack[i];
1380 switch (CxTYPE(cx)) {
1384 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1392 S_dopoptoloop(pTHX_ I32 startingblock)
1396 for (i = startingblock; i >= 0; i--) {
1397 register const PERL_CONTEXT * const cx = &cxstack[i];
1398 switch (CxTYPE(cx)) {
1404 if (ckWARN(WARN_EXITING))
1405 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1406 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1407 if ((CxTYPE(cx)) == CXt_NULL)
1410 case CXt_LOOP_LAZYIV:
1411 case CXt_LOOP_LAZYSV:
1413 case CXt_LOOP_PLAIN:
1414 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1422 S_dopoptogiven(pTHX_ I32 startingblock)
1426 for (i = startingblock; i >= 0; i--) {
1427 register const PERL_CONTEXT *cx = &cxstack[i];
1428 switch (CxTYPE(cx)) {
1432 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1434 case CXt_LOOP_PLAIN:
1435 assert(!CxFOREACHDEF(cx));
1437 case CXt_LOOP_LAZYIV:
1438 case CXt_LOOP_LAZYSV:
1440 if (CxFOREACHDEF(cx)) {
1441 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1450 S_dopoptowhen(pTHX_ I32 startingblock)
1454 for (i = startingblock; i >= 0; i--) {
1455 register const PERL_CONTEXT *cx = &cxstack[i];
1456 switch (CxTYPE(cx)) {
1460 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1468 Perl_dounwind(pTHX_ I32 cxix)
1473 while (cxstack_ix > cxix) {
1475 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1476 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1477 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1478 /* Note: we don't need to restore the base context info till the end. */
1479 switch (CxTYPE(cx)) {
1482 continue; /* not break */
1490 case CXt_LOOP_LAZYIV:
1491 case CXt_LOOP_LAZYSV:
1493 case CXt_LOOP_PLAIN:
1504 PERL_UNUSED_VAR(optype);
1508 Perl_qerror(pTHX_ SV *err)
1512 PERL_ARGS_ASSERT_QERROR;
1515 sv_catsv(ERRSV, err);
1517 sv_catsv(PL_errors, err);
1519 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1521 ++PL_parser->error_count;
1525 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1534 if (PL_in_eval & EVAL_KEEPERR) {
1535 static const char prefix[] = "\t(in cleanup) ";
1536 SV * const err = ERRSV;
1537 const char *e = NULL;
1540 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1542 e = SvPV_const(err, len);
1544 if (*e != *message || strNE(e,message))
1548 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1549 sv_catpvn(err, prefix, sizeof(prefix)-1);
1550 sv_catpvn(err, message, msglen);
1551 if (ckWARN(WARN_MISC)) {
1552 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1553 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s",
1554 SvPVX_const(err)+start);
1559 sv_setpvn(ERRSV, message, msglen);
1563 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1564 && PL_curstackinfo->si_prev)
1572 register PERL_CONTEXT *cx;
1575 if (cxix < cxstack_ix)
1578 POPBLOCK(cx,PL_curpm);
1579 if (CxTYPE(cx) != CXt_EVAL) {
1581 message = SvPVx_const(ERRSV, msglen);
1582 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1583 PerlIO_write(Perl_error_log, message, msglen);
1588 if (gimme == G_SCALAR)
1589 *++newsp = &PL_sv_undef;
1590 PL_stack_sp = newsp;
1594 /* LEAVE could clobber PL_curcop (see save_re_context())
1595 * XXX it might be better to find a way to avoid messing with
1596 * PL_curcop in save_re_context() instead, but this is a more
1597 * minimal fix --GSAR */
1598 PL_curcop = cx->blk_oldcop;
1600 if (optype == OP_REQUIRE) {
1601 const char* const msg = SvPVx_nolen_const(ERRSV);
1602 SV * const nsv = cx->blk_eval.old_namesv;
1603 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1605 DIE(aTHX_ "%sCompilation failed in require",
1606 *msg ? msg : "Unknown error\n");
1608 assert(CxTYPE(cx) == CXt_EVAL);
1609 return cx->blk_eval.retop;
1613 message = SvPVx_const(ERRSV, msglen);
1615 write_to_stderr(message, msglen);
1623 dVAR; dSP; dPOPTOPssrl;
1624 if (SvTRUE(left) != SvTRUE(right))
1634 register I32 cxix = dopoptosub(cxstack_ix);
1635 register const PERL_CONTEXT *cx;
1636 register const PERL_CONTEXT *ccstack = cxstack;
1637 const PERL_SI *top_si = PL_curstackinfo;
1639 const char *stashname;
1646 /* we may be in a higher stacklevel, so dig down deeper */
1647 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1648 top_si = top_si->si_prev;
1649 ccstack = top_si->si_cxstack;
1650 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1653 if (GIMME != G_ARRAY) {
1659 /* caller() should not report the automatic calls to &DB::sub */
1660 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1661 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1665 cxix = dopoptosub_at(ccstack, cxix - 1);
1668 cx = &ccstack[cxix];
1669 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1670 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1671 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1672 field below is defined for any cx. */
1673 /* caller() should not report the automatic calls to &DB::sub */
1674 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1675 cx = &ccstack[dbcxix];
1678 stashname = CopSTASHPV(cx->blk_oldcop);
1679 if (GIMME != G_ARRAY) {
1682 PUSHs(&PL_sv_undef);
1685 sv_setpv(TARG, stashname);
1694 PUSHs(&PL_sv_undef);
1696 mPUSHs(newSVpv(stashname, 0));
1697 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1698 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1701 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1702 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1703 /* So is ccstack[dbcxix]. */
1705 SV * const sv = newSV(0);
1706 gv_efullname3(sv, cvgv, NULL);
1708 PUSHs(boolSV(CxHASARGS(cx)));
1711 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1712 PUSHs(boolSV(CxHASARGS(cx)));
1716 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1719 gimme = (I32)cx->blk_gimme;
1720 if (gimme == G_VOID)
1721 PUSHs(&PL_sv_undef);
1723 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1724 if (CxTYPE(cx) == CXt_EVAL) {
1726 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1727 PUSHs(cx->blk_eval.cur_text);
1731 else if (cx->blk_eval.old_namesv) {
1732 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1735 /* eval BLOCK (try blocks have old_namesv == 0) */
1737 PUSHs(&PL_sv_undef);
1738 PUSHs(&PL_sv_undef);
1742 PUSHs(&PL_sv_undef);
1743 PUSHs(&PL_sv_undef);
1745 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1746 && CopSTASH_eq(PL_curcop, PL_debstash))
1748 AV * const ary = cx->blk_sub.argarray;
1749 const int off = AvARRAY(ary) - AvALLOC(ary);
1752 PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
1754 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1757 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1758 av_extend(PL_dbargs, AvFILLp(ary) + off);
1759 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1760 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1762 /* XXX only hints propagated via op_private are currently
1763 * visible (others are not easily accessible, since they
1764 * use the global PL_hints) */
1765 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1768 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1770 if (old_warnings == pWARN_NONE ||
1771 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1772 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1773 else if (old_warnings == pWARN_ALL ||
1774 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1775 /* Get the bit mask for $warnings::Bits{all}, because
1776 * it could have been extended by warnings::register */
1778 HV * const bits = get_hv("warnings::Bits", 0);
1779 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1780 mask = newSVsv(*bits_all);
1783 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1787 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1791 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1792 sv_2mortal(newRV_noinc(
1793 MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1794 cx->blk_oldcop->cop_hints_hash))))
1803 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1804 sv_reset(tmps, CopSTASH(PL_curcop));
1809 /* like pp_nextstate, but used instead when the debugger is active */
1814 PL_curcop = (COP*)PL_op;
1815 TAINT_NOT; /* Each statement is presumed innocent */
1816 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1819 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1820 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1823 register PERL_CONTEXT *cx;
1824 const I32 gimme = G_ARRAY;
1826 GV * const gv = PL_DBgv;
1827 register CV * const cv = GvCV(gv);
1830 DIE(aTHX_ "No DB::DB routine defined");
1832 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1833 /* don't do recursive DB::DB call */
1848 (void)(*CvXSUB(cv))(aTHX_ cv);
1855 PUSHBLOCK(cx, CXt_SUB, SP);
1857 cx->blk_sub.retop = PL_op->op_next;
1860 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1861 RETURNOP(CvSTART(cv));
1871 register PERL_CONTEXT *cx;
1872 const I32 gimme = GIMME_V;
1874 U8 cxtype = CXt_LOOP_FOR;
1882 if (PL_op->op_targ) {
1883 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1884 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1885 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1886 SVs_PADSTALE, SVs_PADSTALE);
1888 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1889 #ifndef USE_ITHREADS
1890 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1896 GV * const gv = MUTABLE_GV(POPs);
1897 svp = &GvSV(gv); /* symbol table variable */
1898 SAVEGENERICSV(*svp);
1901 iterdata = (PAD*)gv;
1905 if (PL_op->op_private & OPpITER_DEF)
1906 cxtype |= CXp_FOR_DEF;
1910 PUSHBLOCK(cx, cxtype, SP);
1912 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1914 PUSHLOOP_FOR(cx, svp, MARK, 0);
1916 if (PL_op->op_flags & OPf_STACKED) {
1917 SV *maybe_ary = POPs;
1918 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1920 SV * const right = maybe_ary;
1923 if (RANGE_IS_NUMERIC(sv,right)) {
1924 cx->cx_type &= ~CXTYPEMASK;
1925 cx->cx_type |= CXt_LOOP_LAZYIV;
1926 /* Make sure that no-one re-orders cop.h and breaks our
1928 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1929 #ifdef NV_PRESERVES_UV
1930 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1931 (SvNV(sv) > (NV)IV_MAX)))
1933 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1934 (SvNV(right) < (NV)IV_MIN))))
1936 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1939 ((SvUV(sv) > (UV)IV_MAX) ||
1940 (SvNV(sv) > (NV)UV_MAX)))))
1942 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1944 ((SvNV(right) > 0) &&
1945 ((SvUV(right) > (UV)IV_MAX) ||
1946 (SvNV(right) > (NV)UV_MAX))))))
1948 DIE(aTHX_ "Range iterator outside integer range");
1949 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1950 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1952 /* for correct -Dstv display */
1953 cx->blk_oldsp = sp - PL_stack_base;
1957 cx->cx_type &= ~CXTYPEMASK;
1958 cx->cx_type |= CXt_LOOP_LAZYSV;
1959 /* Make sure that no-one re-orders cop.h and breaks our
1961 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
1962 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
1963 cx->blk_loop.state_u.lazysv.end = right;
1964 SvREFCNT_inc(right);
1965 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
1966 /* This will do the upgrade to SVt_PV, and warn if the value
1967 is uninitialised. */
1968 (void) SvPV_nolen_const(right);
1969 /* Doing this avoids a check every time in pp_iter in pp_hot.c
1970 to replace !SvOK() with a pointer to "". */
1972 SvREFCNT_dec(right);
1973 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
1977 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
1978 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
1979 SvREFCNT_inc(maybe_ary);
1980 cx->blk_loop.state_u.ary.ix =
1981 (PL_op->op_private & OPpITER_REVERSED) ?
1982 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
1986 else { /* iterating over items on the stack */
1987 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
1988 if (PL_op->op_private & OPpITER_REVERSED) {
1989 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
1992 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2002 register PERL_CONTEXT *cx;
2003 const I32 gimme = GIMME_V;
2009 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2010 PUSHLOOP_PLAIN(cx, SP);
2018 register PERL_CONTEXT *cx;
2025 assert(CxTYPE_is_LOOP(cx));
2027 newsp = PL_stack_base + cx->blk_loop.resetsp;
2030 if (gimme == G_VOID)
2032 else if (gimme == G_SCALAR) {
2034 *++newsp = sv_mortalcopy(*SP);
2036 *++newsp = &PL_sv_undef;
2040 *++newsp = sv_mortalcopy(*++mark);
2041 TAINT_NOT; /* Each item is independent */
2047 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2048 PL_curpm = newpm; /* ... and pop $1 et al */
2059 register PERL_CONTEXT *cx;
2060 bool popsub2 = FALSE;
2061 bool clear_errsv = FALSE;
2069 const I32 cxix = dopoptosub(cxstack_ix);
2072 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2073 * sort block, which is a CXt_NULL
2076 PL_stack_base[1] = *PL_stack_sp;
2077 PL_stack_sp = PL_stack_base + 1;
2081 DIE(aTHX_ "Can't return outside a subroutine");
2083 if (cxix < cxstack_ix)
2086 if (CxMULTICALL(&cxstack[cxix])) {
2087 gimme = cxstack[cxix].blk_gimme;
2088 if (gimme == G_VOID)
2089 PL_stack_sp = PL_stack_base;
2090 else if (gimme == G_SCALAR) {
2091 PL_stack_base[1] = *PL_stack_sp;
2092 PL_stack_sp = PL_stack_base + 1;
2098 switch (CxTYPE(cx)) {
2101 retop = cx->blk_sub.retop;
2102 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2105 if (!(PL_in_eval & EVAL_KEEPERR))
2108 retop = cx->blk_eval.retop;
2112 if (optype == OP_REQUIRE &&
2113 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2115 /* Unassume the success we assumed earlier. */
2116 SV * const nsv = cx->blk_eval.old_namesv;
2117 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2118 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2123 retop = cx->blk_sub.retop;
2126 DIE(aTHX_ "panic: return");
2130 if (gimme == G_SCALAR) {
2133 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2135 *++newsp = SvREFCNT_inc(*SP);
2140 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2142 *++newsp = sv_mortalcopy(sv);
2147 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2150 *++newsp = sv_mortalcopy(*SP);
2153 *++newsp = &PL_sv_undef;
2155 else if (gimme == G_ARRAY) {
2156 while (++MARK <= SP) {
2157 *++newsp = (popsub2 && SvTEMP(*MARK))
2158 ? *MARK : sv_mortalcopy(*MARK);
2159 TAINT_NOT; /* Each item is independent */
2162 PL_stack_sp = newsp;
2165 /* Stack values are safe: */
2168 POPSUB(cx,sv); /* release CV and @_ ... */
2172 PL_curpm = newpm; /* ... and pop $1 et al */
2185 register PERL_CONTEXT *cx;
2196 if (PL_op->op_flags & OPf_SPECIAL) {
2197 cxix = dopoptoloop(cxstack_ix);
2199 DIE(aTHX_ "Can't \"last\" outside a loop block");
2202 cxix = dopoptolabel(cPVOP->op_pv);
2204 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2206 if (cxix < cxstack_ix)
2210 cxstack_ix++; /* temporarily protect top context */
2212 switch (CxTYPE(cx)) {
2213 case CXt_LOOP_LAZYIV:
2214 case CXt_LOOP_LAZYSV:
2216 case CXt_LOOP_PLAIN:
2218 newsp = PL_stack_base + cx->blk_loop.resetsp;
2219 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2223 nextop = cx->blk_sub.retop;
2227 nextop = cx->blk_eval.retop;
2231 nextop = cx->blk_sub.retop;
2234 DIE(aTHX_ "panic: last");
2238 if (gimme == G_SCALAR) {
2240 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2241 ? *SP : sv_mortalcopy(*SP);
2243 *++newsp = &PL_sv_undef;
2245 else if (gimme == G_ARRAY) {
2246 while (++MARK <= SP) {
2247 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2248 ? *MARK : sv_mortalcopy(*MARK);
2249 TAINT_NOT; /* Each item is independent */
2257 /* Stack values are safe: */
2259 case CXt_LOOP_LAZYIV:
2260 case CXt_LOOP_PLAIN:
2261 case CXt_LOOP_LAZYSV:
2263 POPLOOP(cx); /* release loop vars ... */
2267 POPSUB(cx,sv); /* release CV and @_ ... */
2270 PL_curpm = newpm; /* ... and pop $1 et al */
2273 PERL_UNUSED_VAR(optype);
2274 PERL_UNUSED_VAR(gimme);
2282 register PERL_CONTEXT *cx;
2285 if (PL_op->op_flags & OPf_SPECIAL) {
2286 cxix = dopoptoloop(cxstack_ix);
2288 DIE(aTHX_ "Can't \"next\" outside a loop block");
2291 cxix = dopoptolabel(cPVOP->op_pv);
2293 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2295 if (cxix < cxstack_ix)
2298 /* clear off anything above the scope we're re-entering, but
2299 * save the rest until after a possible continue block */
2300 inner = PL_scopestack_ix;
2302 if (PL_scopestack_ix < inner)
2303 leave_scope(PL_scopestack[PL_scopestack_ix]);
2304 PL_curcop = cx->blk_oldcop;
2305 return CX_LOOP_NEXTOP_GET(cx);
2312 register PERL_CONTEXT *cx;
2316 if (PL_op->op_flags & OPf_SPECIAL) {
2317 cxix = dopoptoloop(cxstack_ix);
2319 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2322 cxix = dopoptolabel(cPVOP->op_pv);
2324 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2326 if (cxix < cxstack_ix)
2329 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2330 if (redo_op->op_type == OP_ENTER) {
2331 /* pop one less context to avoid $x being freed in while (my $x..) */
2333 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2334 redo_op = redo_op->op_next;
2338 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2339 LEAVE_SCOPE(oldsave);
2341 PL_curcop = cx->blk_oldcop;
2346 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2350 static const char too_deep[] = "Target of goto is too deeply nested";
2352 PERL_ARGS_ASSERT_DOFINDLABEL;
2355 Perl_croak(aTHX_ too_deep);
2356 if (o->op_type == OP_LEAVE ||
2357 o->op_type == OP_SCOPE ||
2358 o->op_type == OP_LEAVELOOP ||
2359 o->op_type == OP_LEAVESUB ||
2360 o->op_type == OP_LEAVETRY)
2362 *ops++ = cUNOPo->op_first;
2364 Perl_croak(aTHX_ too_deep);
2367 if (o->op_flags & OPf_KIDS) {
2369 /* First try all the kids at this level, since that's likeliest. */
2370 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2371 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2372 CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label))
2375 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2376 if (kid == PL_lastgotoprobe)
2378 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2381 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2382 ops[-1]->op_type == OP_DBSTATE)
2387 if ((o = dofindlabel(kid, label, ops, oplimit)))
2400 register PERL_CONTEXT *cx;
2401 #define GOTO_DEPTH 64
2402 OP *enterops[GOTO_DEPTH];
2403 const char *label = NULL;
2404 const bool do_dump = (PL_op->op_type == OP_DUMP);
2405 static const char must_have_label[] = "goto must have label";
2407 if (PL_op->op_flags & OPf_STACKED) {
2408 SV * const sv = POPs;
2410 /* This egregious kludge implements goto &subroutine */
2411 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2413 register PERL_CONTEXT *cx;
2414 CV *cv = MUTABLE_CV(SvRV(sv));
2421 if (!CvROOT(cv) && !CvXSUB(cv)) {
2422 const GV * const gv = CvGV(cv);
2426 /* autoloaded stub? */
2427 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2429 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2430 GvNAMELEN(gv), FALSE);
2431 if (autogv && (cv = GvCV(autogv)))
2433 tmpstr = sv_newmortal();
2434 gv_efullname3(tmpstr, gv, NULL);
2435 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2437 DIE(aTHX_ "Goto undefined subroutine");
2440 /* First do some returnish stuff. */
2441 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2443 cxix = dopoptosub(cxstack_ix);
2445 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2446 if (cxix < cxstack_ix)
2450 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2451 if (CxTYPE(cx) == CXt_EVAL) {
2453 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2455 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2457 else if (CxMULTICALL(cx))
2458 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2459 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2460 /* put @_ back onto stack */
2461 AV* av = cx->blk_sub.argarray;
2463 items = AvFILLp(av) + 1;
2464 EXTEND(SP, items+1); /* @_ could have been extended. */
2465 Copy(AvARRAY(av), SP + 1, items, SV*);
2466 SvREFCNT_dec(GvAV(PL_defgv));
2467 GvAV(PL_defgv) = cx->blk_sub.savearray;
2469 /* abandon @_ if it got reified */
2474 av_extend(av, items-1);
2476 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2479 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2480 AV* const av = GvAV(PL_defgv);
2481 items = AvFILLp(av) + 1;
2482 EXTEND(SP, items+1); /* @_ could have been extended. */
2483 Copy(AvARRAY(av), SP + 1, items, SV*);
2487 if (CxTYPE(cx) == CXt_SUB &&
2488 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2489 SvREFCNT_dec(cx->blk_sub.cv);
2490 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2491 LEAVE_SCOPE(oldsave);
2493 /* Now do some callish stuff. */
2495 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2497 OP* const retop = cx->blk_sub.retop;
2502 for (index=0; index<items; index++)
2503 sv_2mortal(SP[-index]);
2506 /* XS subs don't have a CxSUB, so pop it */
2507 POPBLOCK(cx, PL_curpm);
2508 /* Push a mark for the start of arglist */
2511 (void)(*CvXSUB(cv))(aTHX_ cv);
2516 AV* const padlist = CvPADLIST(cv);
2517 if (CxTYPE(cx) == CXt_EVAL) {
2518 PL_in_eval = CxOLD_IN_EVAL(cx);
2519 PL_eval_root = cx->blk_eval.old_eval_root;
2520 cx->cx_type = CXt_SUB;
2522 cx->blk_sub.cv = cv;
2523 cx->blk_sub.olddepth = CvDEPTH(cv);
2526 if (CvDEPTH(cv) < 2)
2527 SvREFCNT_inc_simple_void_NN(cv);
2529 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2530 sub_crush_depth(cv);
2531 pad_push(padlist, CvDEPTH(cv));
2534 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2537 AV *const av = MUTABLE_AV(PAD_SVl(0));
2539 cx->blk_sub.savearray = GvAV(PL_defgv);
2540 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2541 CX_CURPAD_SAVE(cx->blk_sub);
2542 cx->blk_sub.argarray = av;
2544 if (items >= AvMAX(av) + 1) {
2545 SV **ary = AvALLOC(av);
2546 if (AvARRAY(av) != ary) {
2547 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2550 if (items >= AvMAX(av) + 1) {
2551 AvMAX(av) = items - 1;
2552 Renew(ary,items+1,SV*);
2558 Copy(mark,AvARRAY(av),items,SV*);
2559 AvFILLp(av) = items - 1;
2560 assert(!AvREAL(av));
2562 /* transfer 'ownership' of refcnts to new @_ */
2572 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2573 Perl_get_db_sub(aTHX_ NULL, cv);
2575 CV * const gotocv = get_cvs("DB::goto", 0);
2577 PUSHMARK( PL_stack_sp );
2578 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2583 RETURNOP(CvSTART(cv));
2587 label = SvPV_nolen_const(sv);
2588 if (!(do_dump || *label))
2589 DIE(aTHX_ must_have_label);
2592 else if (PL_op->op_flags & OPf_SPECIAL) {
2594 DIE(aTHX_ must_have_label);
2597 label = cPVOP->op_pv;
2599 if (label && *label) {
2600 OP *gotoprobe = NULL;
2601 bool leaving_eval = FALSE;
2602 bool in_block = FALSE;
2603 PERL_CONTEXT *last_eval_cx = NULL;
2607 PL_lastgotoprobe = NULL;
2609 for (ix = cxstack_ix; ix >= 0; ix--) {
2611 switch (CxTYPE(cx)) {
2613 leaving_eval = TRUE;
2614 if (!CxTRYBLOCK(cx)) {
2615 gotoprobe = (last_eval_cx ?
2616 last_eval_cx->blk_eval.old_eval_root :
2621 /* else fall through */
2622 case CXt_LOOP_LAZYIV:
2623 case CXt_LOOP_LAZYSV:
2625 case CXt_LOOP_PLAIN:
2628 gotoprobe = cx->blk_oldcop->op_sibling;
2634 gotoprobe = cx->blk_oldcop->op_sibling;
2637 gotoprobe = PL_main_root;
2640 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2641 gotoprobe = CvROOT(cx->blk_sub.cv);
2647 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2650 DIE(aTHX_ "panic: goto");
2651 gotoprobe = PL_main_root;
2655 retop = dofindlabel(gotoprobe, label,
2656 enterops, enterops + GOTO_DEPTH);
2660 PL_lastgotoprobe = gotoprobe;
2663 DIE(aTHX_ "Can't find label %s", label);
2665 /* if we're leaving an eval, check before we pop any frames
2666 that we're not going to punt, otherwise the error
2669 if (leaving_eval && *enterops && enterops[1]) {
2671 for (i = 1; enterops[i]; i++)
2672 if (enterops[i]->op_type == OP_ENTERITER)
2673 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2676 /* pop unwanted frames */
2678 if (ix < cxstack_ix) {
2685 oldsave = PL_scopestack[PL_scopestack_ix];
2686 LEAVE_SCOPE(oldsave);
2689 /* push wanted frames */
2691 if (*enterops && enterops[1]) {
2692 OP * const oldop = PL_op;
2693 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2694 for (; enterops[ix]; ix++) {
2695 PL_op = enterops[ix];
2696 /* Eventually we may want to stack the needed arguments
2697 * for each op. For now, we punt on the hard ones. */
2698 if (PL_op->op_type == OP_ENTERITER)
2699 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2700 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2708 if (!retop) retop = PL_main_start;
2710 PL_restartop = retop;
2711 PL_do_undump = TRUE;
2715 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2716 PL_do_undump = FALSE;
2733 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2735 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2738 PL_exit_flags |= PERL_EXIT_EXPECTED;
2740 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2741 if (anum || !(PL_minus_c && PL_madskills))
2746 PUSHs(&PL_sv_undef);
2753 S_save_lines(pTHX_ AV *array, SV *sv)
2755 const char *s = SvPVX_const(sv);
2756 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2759 PERL_ARGS_ASSERT_SAVE_LINES;
2761 while (s && s < send) {
2763 SV * const tmpstr = newSV_type(SVt_PVMG);
2765 t = (const char *)memchr(s, '\n', send - s);
2771 sv_setpvn(tmpstr, s, t - s);
2772 av_store(array, line++, tmpstr);
2778 S_docatch(pTHX_ OP *o)
2782 OP * const oldop = PL_op;
2786 assert(CATCH_GET == TRUE);
2793 assert(cxstack_ix >= 0);
2794 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2795 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2800 /* die caught by an inner eval - continue inner loop */
2802 /* NB XXX we rely on the old popped CxEVAL still being at the top
2803 * of the stack; the way die_where() currently works, this
2804 * assumption is valid. In theory The cur_top_env value should be
2805 * returned in another global, the way retop (aka PL_restartop)
2807 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2810 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2812 PL_op = PL_restartop;
2829 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2830 /* sv Text to convert to OP tree. */
2831 /* startop op_free() this to undo. */
2832 /* code Short string id of the caller. */
2834 /* FIXME - how much of this code is common with pp_entereval? */
2835 dVAR; dSP; /* Make POPBLOCK work. */
2841 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2842 char *tmpbuf = tbuf;
2845 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2848 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2851 lex_start(sv, NULL, FALSE);
2853 /* switch to eval mode */
2855 if (IN_PERL_COMPILETIME) {
2856 SAVECOPSTASH_FREE(&PL_compiling);
2857 CopSTASH_set(&PL_compiling, PL_curstash);
2859 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2860 SV * const sv = sv_newmortal();
2861 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2862 code, (unsigned long)++PL_evalseq,
2863 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2868 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2869 (unsigned long)++PL_evalseq);
2870 SAVECOPFILE_FREE(&PL_compiling);
2871 CopFILE_set(&PL_compiling, tmpbuf+2);
2872 SAVECOPLINE(&PL_compiling);
2873 CopLINE_set(&PL_compiling, 1);
2874 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2875 deleting the eval's FILEGV from the stash before gv_check() runs
2876 (i.e. before run-time proper). To work around the coredump that
2877 ensues, we always turn GvMULTI_on for any globals that were
2878 introduced within evals. See force_ident(). GSAR 96-10-12 */
2879 safestr = savepvn(tmpbuf, len);
2880 SAVEDELETE(PL_defstash, safestr, len);
2882 #ifdef OP_IN_REGISTER
2888 /* we get here either during compilation, or via pp_regcomp at runtime */
2889 runtime = IN_PERL_RUNTIME;
2891 runcv = find_runcv(NULL);
2894 PL_op->op_type = OP_ENTEREVAL;
2895 PL_op->op_flags = 0; /* Avoid uninit warning. */
2896 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2900 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2902 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2903 POPBLOCK(cx,PL_curpm);
2906 (*startop)->op_type = OP_NULL;
2907 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2909 /* XXX DAPM do this properly one year */
2910 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2912 if (IN_PERL_COMPILETIME)
2913 CopHINTS_set(&PL_compiling, PL_hints);
2914 #ifdef OP_IN_REGISTER
2917 PERL_UNUSED_VAR(newsp);
2918 PERL_UNUSED_VAR(optype);
2920 return PL_eval_start;
2925 =for apidoc find_runcv
2927 Locate the CV corresponding to the currently executing sub or eval.
2928 If db_seqp is non_null, skip CVs that are in the DB package and populate
2929 *db_seqp with the cop sequence number at the point that the DB:: code was
2930 entered. (allows debuggers to eval in the scope of the breakpoint rather
2931 than in the scope of the debugger itself).
2937 Perl_find_runcv(pTHX_ U32 *db_seqp)
2943 *db_seqp = PL_curcop->cop_seq;
2944 for (si = PL_curstackinfo; si; si = si->si_prev) {
2946 for (ix = si->si_cxix; ix >= 0; ix--) {
2947 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2948 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2949 CV * const cv = cx->blk_sub.cv;
2950 /* skip DB:: code */
2951 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2952 *db_seqp = cx->blk_oldcop->cop_seq;
2957 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2965 /* Compile a require/do, an eval '', or a /(?{...})/.
2966 * In the last case, startop is non-null, and contains the address of
2967 * a pointer that should be set to the just-compiled code.
2968 * outside is the lexically enclosing CV (if any) that invoked us.
2969 * Returns a bool indicating whether the compile was successful; if so,
2970 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2971 * pushes undef (also croaks if startop != NULL).
2975 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2978 OP * const saveop = PL_op;
2980 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2981 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2986 SAVESPTR(PL_compcv);
2987 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2988 CvEVAL_on(PL_compcv);
2989 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2990 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2992 CvOUTSIDE_SEQ(PL_compcv) = seq;
2993 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2995 /* set up a scratch pad */
2997 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2998 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3002 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3004 /* make sure we compile in the right package */
3006 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3007 SAVESPTR(PL_curstash);
3008 PL_curstash = CopSTASH(PL_curcop);
3010 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3011 SAVESPTR(PL_beginav);
3012 PL_beginav = newAV();
3013 SAVEFREESV(PL_beginav);
3014 SAVESPTR(PL_unitcheckav);
3015 PL_unitcheckav = newAV();
3016 SAVEFREESV(PL_unitcheckav);
3019 SAVEBOOL(PL_madskills);
3023 /* try to compile it */
3025 PL_eval_root = NULL;
3026 PL_curcop = &PL_compiling;
3027 CopARYBASE_set(PL_curcop, 0);
3028 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3029 PL_in_eval |= EVAL_KEEPERR;
3032 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
3033 SV **newsp; /* Used by POPBLOCK. */
3034 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
3035 I32 optype = 0; /* Might be reset by POPEVAL. */
3040 op_free(PL_eval_root);
3041 PL_eval_root = NULL;
3043 SP = PL_stack_base + POPMARK; /* pop original mark */
3045 POPBLOCK(cx,PL_curpm);
3049 LEAVE; /* pp_entereval knows about this LEAVE. */
3051 msg = SvPVx_nolen_const(ERRSV);
3052 if (optype == OP_REQUIRE) {
3053 const SV * const nsv = cx->blk_eval.old_namesv;
3054 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3056 Perl_croak(aTHX_ "%sCompilation failed in require",
3057 *msg ? msg : "Unknown error\n");
3060 POPBLOCK(cx,PL_curpm);
3062 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3063 (*msg ? msg : "Unknown error\n"));
3067 sv_setpvs(ERRSV, "Compilation error");
3070 PERL_UNUSED_VAR(newsp);
3071 PUSHs(&PL_sv_undef);
3075 CopLINE_set(&PL_compiling, 0);
3077 *startop = PL_eval_root;
3079 SAVEFREEOP(PL_eval_root);
3081 /* Set the context for this new optree.
3082 * If the last op is an OP_REQUIRE, force scalar context.
3083 * Otherwise, propagate the context from the eval(). */
3084 if (PL_eval_root->op_type == OP_LEAVEEVAL
3085 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3086 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3088 scalar(PL_eval_root);
3089 else if ((gimme & G_WANT) == G_VOID)
3090 scalarvoid(PL_eval_root);
3091 else if ((gimme & G_WANT) == G_ARRAY)
3094 scalar(PL_eval_root);
3096 DEBUG_x(dump_eval());
3098 /* Register with debugger: */
3099 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3100 CV * const cv = get_cvs("DB::postponed", 0);
3104 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3106 call_sv(MUTABLE_SV(cv), G_DISCARD);
3111 call_list(PL_scopestack_ix, PL_unitcheckav);
3113 /* compiled okay, so do it */
3115 CvDEPTH(PL_compcv) = 1;
3116 SP = PL_stack_base + POPMARK; /* pop original mark */
3117 PL_op = saveop; /* The caller may need it. */
3118 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3125 S_check_type_and_open(pTHX_ const char *name)
3128 const int st_rc = PerlLIO_stat(name, &st);
3130 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3132 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3136 return PerlIO_open(name, PERL_SCRIPT_MODE);
3139 #ifndef PERL_DISABLE_PMC
3141 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3145 PERL_ARGS_ASSERT_DOOPEN_PM;
3147 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3148 SV *const pmcsv = newSV(namelen + 2);
3149 char *const pmc = SvPVX(pmcsv);
3152 memcpy(pmc, name, namelen);
3154 pmc[namelen + 1] = '\0';
3156 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3157 fp = check_type_and_open(name);
3160 fp = check_type_and_open(pmc);
3162 SvREFCNT_dec(pmcsv);
3165 fp = check_type_and_open(name);
3170 # define doopen_pm(name, namelen) check_type_and_open(name)
3171 #endif /* !PERL_DISABLE_PMC */
3176 register PERL_CONTEXT *cx;
3183 int vms_unixname = 0;
3185 const char *tryname = NULL;
3187 const I32 gimme = GIMME_V;
3188 int filter_has_file = 0;
3189 PerlIO *tryrsfp = NULL;
3190 SV *filter_cache = NULL;
3191 SV *filter_state = NULL;
3192 SV *filter_sub = NULL;
3198 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3199 sv = new_version(sv);
3200 if (!sv_derived_from(PL_patchlevel, "version"))
3201 upg_version(PL_patchlevel, TRUE);
3202 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3203 if ( vcmp(sv,PL_patchlevel) <= 0 )
3204 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3205 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3208 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3211 SV * const req = SvRV(sv);
3212 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3214 /* get the left hand term */
3215 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3217 first = SvIV(*av_fetch(lav,0,0));
3218 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3219 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3220 || av_len(lav) > 1 /* FP with > 3 digits */
3221 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3223 DIE(aTHX_ "Perl %"SVf" required--this is only "
3224 "%"SVf", stopped", SVfARG(vnormal(req)),
3225 SVfARG(vnormal(PL_patchlevel)));
3227 else { /* probably 'use 5.10' or 'use 5.8' */
3228 SV * hintsv = newSV(0);
3232 second = SvIV(*av_fetch(lav,1,0));
3234 second /= second >= 600 ? 100 : 10;
3235 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3236 (int)first, (int)second,0);
3237 upg_version(hintsv, TRUE);
3239 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3240 "--this is only %"SVf", stopped",
3241 SVfARG(vnormal(req)),
3242 SVfARG(vnormal(hintsv)),
3243 SVfARG(vnormal(PL_patchlevel)));
3248 /* We do this only with use, not require. */
3250 /* If we request a version >= 5.9.5, load feature.pm with the
3251 * feature bundle that corresponds to the required version. */
3252 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3253 SV *const importsv = vnormal(sv);
3254 *SvPVX_mutable(importsv) = ':';
3256 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3259 /* If a version >= 5.11.0 is requested, strictures are on by default! */
3261 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3262 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3267 name = SvPV_const(sv, len);
3268 if (!(name && len > 0 && *name))
3269 DIE(aTHX_ "Null filename used");
3270 TAINT_PROPER("require");
3274 /* The key in the %ENV hash is in the syntax of file passed as the argument
3275 * usually this is in UNIX format, but sometimes in VMS format, which
3276 * can result in a module being pulled in more than once.
3277 * To prevent this, the key must be stored in UNIX format if the VMS
3278 * name can be translated to UNIX.
3280 if ((unixname = tounixspec(name, NULL)) != NULL) {
3281 unixlen = strlen(unixname);
3287 /* if not VMS or VMS name can not be translated to UNIX, pass it
3290 unixname = (char *) name;
3293 if (PL_op->op_type == OP_REQUIRE) {
3294 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3295 unixname, unixlen, 0);
3297 if (*svp != &PL_sv_undef)
3300 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3301 "Compilation failed in require", unixname);
3305 /* prepare to compile file */
3307 if (path_is_absolute(name)) {
3309 tryrsfp = doopen_pm(name, len);
3312 AV * const ar = GvAVn(PL_incgv);
3318 namesv = newSV_type(SVt_PV);
3319 for (i = 0; i <= AvFILL(ar); i++) {
3320 SV * const dirsv = *av_fetch(ar, i, TRUE);
3322 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3329 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3330 && !sv_isobject(loader))
3332 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3335 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3336 PTR2UV(SvRV(dirsv)), name);
3337 tryname = SvPVX_const(namesv);
3348 if (sv_isobject(loader))
3349 count = call_method("INC", G_ARRAY);
3351 count = call_sv(loader, G_ARRAY);
3354 /* Adjust file name if the hook has set an %INC entry */
3355 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3357 tryname = SvPVX_const(*svp);
3366 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3367 && !isGV_with_GP(SvRV(arg))) {
3368 filter_cache = SvRV(arg);
3369 SvREFCNT_inc_simple_void_NN(filter_cache);
3376 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3380 if (isGV_with_GP(arg)) {
3381 IO * const io = GvIO((const GV *)arg);
3386 tryrsfp = IoIFP(io);
3387 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3388 PerlIO_close(IoOFP(io));
3399 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3401 SvREFCNT_inc_simple_void_NN(filter_sub);
3404 filter_state = SP[i];
3405 SvREFCNT_inc_simple_void(filter_state);
3409 if (!tryrsfp && (filter_cache || filter_sub)) {
3410 tryrsfp = PerlIO_open(BIT_BUCKET,
3425 filter_has_file = 0;
3427 SvREFCNT_dec(filter_cache);
3428 filter_cache = NULL;
3431 SvREFCNT_dec(filter_state);
3432 filter_state = NULL;
3435 SvREFCNT_dec(filter_sub);
3440 if (!path_is_absolute(name)
3446 dir = SvPV_const(dirsv, dirlen);
3454 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3456 sv_setpv(namesv, unixdir);
3457 sv_catpv(namesv, unixname);
3459 # ifdef __SYMBIAN32__
3460 if (PL_origfilename[0] &&
3461 PL_origfilename[1] == ':' &&
3462 !(dir[0] && dir[1] == ':'))
3463 Perl_sv_setpvf(aTHX_ namesv,
3468 Perl_sv_setpvf(aTHX_ namesv,
3472 /* The equivalent of
3473 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3474 but without the need to parse the format string, or
3475 call strlen on either pointer, and with the correct
3476 allocation up front. */
3478 char *tmp = SvGROW(namesv, dirlen + len + 2);
3480 memcpy(tmp, dir, dirlen);
3483 /* name came from an SV, so it will have a '\0' at the
3484 end that we can copy as part of this memcpy(). */
3485 memcpy(tmp, name, len + 1);
3487 SvCUR_set(namesv, dirlen + len + 1);
3489 /* Don't even actually have to turn SvPOK_on() as we
3490 access it directly with SvPVX() below. */
3494 TAINT_PROPER("require");
3495 tryname = SvPVX_const(namesv);
3496 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3498 if (tryname[0] == '.' && tryname[1] == '/') {
3500 while (*++tryname == '/');
3504 else if (errno == EMFILE)
3505 /* no point in trying other paths if out of handles */
3512 SAVECOPFILE_FREE(&PL_compiling);
3513 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3514 SvREFCNT_dec(namesv);
3516 if (PL_op->op_type == OP_REQUIRE) {
3517 const char *msgstr = name;
3518 if(errno == EMFILE) {
3520 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3522 msgstr = SvPV_nolen_const(msg);
3524 if (namesv) { /* did we lookup @INC? */
3525 AV * const ar = GvAVn(PL_incgv);
3527 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3528 "%s in @INC%s%s (@INC contains:",
3530 (instr(msgstr, ".h ")
3531 ? " (change .h to .ph maybe?)" : ""),
3532 (instr(msgstr, ".ph ")
3533 ? " (did you run h2ph?)" : "")
3536 for (i = 0; i <= AvFILL(ar); i++) {
3537 sv_catpvs(msg, " ");
3538 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3540 sv_catpvs(msg, ")");
3541 msgstr = SvPV_nolen_const(msg);
3544 DIE(aTHX_ "Can't locate %s", msgstr);
3550 SETERRNO(0, SS_NORMAL);
3552 /* Assume success here to prevent recursive requirement. */
3553 /* name is never assigned to again, so len is still strlen(name) */
3554 /* Check whether a hook in @INC has already filled %INC */
3556 (void)hv_store(GvHVn(PL_incgv),
3557 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3559 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3561 (void)hv_store(GvHVn(PL_incgv),
3562 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3567 lex_start(NULL, tryrsfp, TRUE);
3571 hv_clear(GvHV(PL_hintgv));
3573 SAVECOMPILEWARNINGS();
3574 if (PL_dowarn & G_WARN_ALL_ON)
3575 PL_compiling.cop_warnings = pWARN_ALL ;
3576 else if (PL_dowarn & G_WARN_ALL_OFF)
3577 PL_compiling.cop_warnings = pWARN_NONE ;
3579 PL_compiling.cop_warnings = pWARN_STD ;
3581 if (filter_sub || filter_cache) {
3582 SV * const datasv = filter_add(S_run_user_filter, NULL);
3583 IoLINES(datasv) = filter_has_file;
3584 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3585 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3586 IoFMT_GV(datasv) = MUTABLE_GV(filter_cache);
3589 /* switch to eval mode */
3590 PUSHBLOCK(cx, CXt_EVAL, SP);
3592 cx->blk_eval.retop = PL_op->op_next;
3594 SAVECOPLINE(&PL_compiling);
3595 CopLINE_set(&PL_compiling, 0);
3599 /* Store and reset encoding. */
3600 encoding = PL_encoding;
3603 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3604 op = DOCATCH(PL_eval_start);
3606 op = PL_op->op_next;
3608 /* Restore encoding. */
3609 PL_encoding = encoding;
3614 /* This is a op added to hold the hints hash for
3615 pp_entereval. The hash can be modified by the code
3616 being eval'ed, so we return a copy instead. */
3622 mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3630 register PERL_CONTEXT *cx;
3632 const I32 gimme = GIMME_V;
3633 const U32 was = PL_breakable_sub_gen;
3634 char tbuf[TYPE_DIGITS(long) + 12];
3635 char *tmpbuf = tbuf;
3639 HV *saved_hh = NULL;
3641 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3642 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3646 TAINT_IF(SvTAINTED(sv));
3647 TAINT_PROPER("eval");
3650 lex_start(sv, NULL, FALSE);
3653 /* switch to eval mode */
3655 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3656 SV * const temp_sv = sv_newmortal();
3657 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3658 (unsigned long)++PL_evalseq,
3659 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3660 tmpbuf = SvPVX(temp_sv);
3661 len = SvCUR(temp_sv);
3664 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3665 SAVECOPFILE_FREE(&PL_compiling);
3666 CopFILE_set(&PL_compiling, tmpbuf+2);
3667 SAVECOPLINE(&PL_compiling);
3668 CopLINE_set(&PL_compiling, 1);
3669 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3670 deleting the eval's FILEGV from the stash before gv_check() runs
3671 (i.e. before run-time proper). To work around the coredump that
3672 ensues, we always turn GvMULTI_on for any globals that were
3673 introduced within evals. See force_ident(). GSAR 96-10-12 */
3675 PL_hints = PL_op->op_targ;
3677 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3678 SvREFCNT_dec(GvHV(PL_hintgv));
3679 GvHV(PL_hintgv) = saved_hh;
3681 SAVECOMPILEWARNINGS();
3682 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3683 if (PL_compiling.cop_hints_hash) {
3684 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3686 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3687 if (PL_compiling.cop_hints_hash) {
3689 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3690 HINTS_REFCNT_UNLOCK;
3692 /* special case: an eval '' executed within the DB package gets lexically
3693 * placed in the first non-DB CV rather than the current CV - this
3694 * allows the debugger to execute code, find lexicals etc, in the
3695 * scope of the code being debugged. Passing &seq gets find_runcv
3696 * to do the dirty work for us */
3697 runcv = find_runcv(&seq);
3699 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3701 cx->blk_eval.retop = PL_op->op_next;
3703 /* prepare to compile string */
3705 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3706 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3709 if (doeval(gimme, NULL, runcv, seq)) {
3710 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3711 ? (PERLDB_LINE || PERLDB_SAVESRC)
3712 : PERLDB_SAVESRC_NOSUBS) {
3713 /* Retain the filegv we created. */
3715 char *const safestr = savepvn(tmpbuf, len);
3716 SAVEDELETE(PL_defstash, safestr, len);
3718 return DOCATCH(PL_eval_start);
3720 /* We have already left the scope set up earler thanks to the LEAVE
3722 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3723 ? (PERLDB_LINE || PERLDB_SAVESRC)
3724 : PERLDB_SAVESRC_INVALID) {
3725 /* Retain the filegv we created. */
3727 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3729 return PL_op->op_next;
3740 register PERL_CONTEXT *cx;
3742 const U8 save_flags = PL_op -> op_flags;
3747 retop = cx->blk_eval.retop;
3750 if (gimme == G_VOID)
3752 else if (gimme == G_SCALAR) {
3755 if (SvFLAGS(TOPs) & SVs_TEMP)
3758 *MARK = sv_mortalcopy(TOPs);
3762 *MARK = &PL_sv_undef;
3767 /* in case LEAVE wipes old return values */
3768 for (mark = newsp + 1; mark <= SP; mark++) {
3769 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3770 *mark = sv_mortalcopy(*mark);
3771 TAINT_NOT; /* Each item is independent */
3775 PL_curpm = newpm; /* Don't pop $1 et al till now */
3778 assert(CvDEPTH(PL_compcv) == 1);
3780 CvDEPTH(PL_compcv) = 0;
3783 if (optype == OP_REQUIRE &&
3784 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3786 /* Unassume the success we assumed earlier. */
3787 SV * const nsv = cx->blk_eval.old_namesv;
3788 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3789 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3790 /* die_where() did LEAVE, or we won't be here */
3794 if (!(save_flags & OPf_SPECIAL)) {
3802 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3803 close to the related Perl_create_eval_scope. */
3805 Perl_delete_eval_scope(pTHX)
3810 register PERL_CONTEXT *cx;
3817 PERL_UNUSED_VAR(newsp);
3818 PERL_UNUSED_VAR(gimme);
3819 PERL_UNUSED_VAR(optype);
3822 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3823 also needed by Perl_fold_constants. */
3825 Perl_create_eval_scope(pTHX_ U32 flags)
3828 const I32 gimme = GIMME_V;
3833 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3836 PL_in_eval = EVAL_INEVAL;
3837 if (flags & G_KEEPERR)
3838 PL_in_eval |= EVAL_KEEPERR;
3841 if (flags & G_FAKINGEVAL) {
3842 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3850 PERL_CONTEXT * const cx = create_eval_scope(0);
3851 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3852 return DOCATCH(PL_op->op_next);
3861 register PERL_CONTEXT *cx;
3866 PERL_UNUSED_VAR(optype);
3869 if (gimme == G_VOID)
3871 else if (gimme == G_SCALAR) {
3875 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3878 *MARK = sv_mortalcopy(TOPs);
3882 *MARK = &PL_sv_undef;
3887 /* in case LEAVE wipes old return values */
3889 for (mark = newsp + 1; mark <= SP; mark++) {
3890 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3891 *mark = sv_mortalcopy(*mark);
3892 TAINT_NOT; /* Each item is independent */
3896 PL_curpm = newpm; /* Don't pop $1 et al till now */
3906 register PERL_CONTEXT *cx;
3907 const I32 gimme = GIMME_V;
3912 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3914 PUSHBLOCK(cx, CXt_GIVEN, SP);
3923 register PERL_CONTEXT *cx;
3927 PERL_UNUSED_CONTEXT;
3930 assert(CxTYPE(cx) == CXt_GIVEN);
3935 PL_curpm = newpm; /* pop $1 et al */
3942 /* Helper routines used by pp_smartmatch */
3944 S_make_matcher(pTHX_ REGEXP *re)
3947 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3949 PERL_ARGS_ASSERT_MAKE_MATCHER;
3951 PM_SETRE(matcher, ReREFCNT_inc(re));
3953 SAVEFREEOP((OP *) matcher);
3960 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3965 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
3967 PL_op = (OP *) matcher;
3972 return (SvTRUEx(POPs));
3976 S_destroy_matcher(pTHX_ PMOP *matcher)
3980 PERL_ARGS_ASSERT_DESTROY_MATCHER;
3981 PERL_UNUSED_ARG(matcher);
3987 /* Do a smart match */
3990 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
3991 return do_smartmatch(NULL, NULL);
3994 /* This version of do_smartmatch() implements the
3995 * table of smart matches that is found in perlsyn.
3998 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4003 bool object_on_left = FALSE;
4004 SV *e = TOPs; /* e is for 'expression' */
4005 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4007 /* First of all, handle overload magic of the rightmost argument */
4010 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4011 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4013 tmpsv = amagic_call(d, e, smart_amg, 0);
4020 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4023 SP -= 2; /* Pop the values */
4025 /* Take care only to invoke mg_get() once for each argument.
4026 * Currently we do this by copying the SV if it's magical. */
4029 d = sv_mortalcopy(d);
4036 e = sv_mortalcopy(e);
4040 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4047 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4048 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4049 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4051 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4052 object_on_left = TRUE;
4055 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4057 if (object_on_left) {
4058 goto sm_any_sub; /* Treat objects like scalars */
4060 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4061 /* Test sub truth for each key */
4063 bool andedresults = TRUE;
4064 HV *hv = (HV*) SvRV(d);
4065 I32 numkeys = hv_iterinit(hv);
4066 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4069 while ( (he = hv_iternext(hv)) ) {
4070 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4074 PUSHs(hv_iterkeysv(he));
4076 c = call_sv(e, G_SCALAR);
4079 andedresults = FALSE;
4081 andedresults = SvTRUEx(POPs) && andedresults;
4090 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4091 /* Test sub truth for each element */
4093 bool andedresults = TRUE;
4094 AV *av = (AV*) SvRV(d);
4095 const I32 len = av_len(av);
4096 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4099 for (i = 0; i <= len; ++i) {
4100 SV * const * const svp = av_fetch(av, i, FALSE);
4101 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4108 c = call_sv(e, G_SCALAR);
4111 andedresults = FALSE;
4113 andedresults = SvTRUEx(POPs) && andedresults;
4124 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4130 c = call_sv(e, G_SCALAR);
4134 else if (SvTEMP(TOPs))
4135 SvREFCNT_inc_void(TOPs);
4142 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4143 if (object_on_left) {
4144 goto sm_any_hash; /* Treat objects like scalars */
4146 else if (!SvOK(d)) {
4147 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4150 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4151 /* Check that the key-sets are identical */
4153 HV *other_hv = MUTABLE_HV(SvRV(d));
4155 bool other_tied = FALSE;
4156 U32 this_key_count = 0,
4157 other_key_count = 0;
4158 HV *hv = MUTABLE_HV(SvRV(e));
4160 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4161 /* Tied hashes don't know how many keys they have. */
4162 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4165 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4166 HV * const temp = other_hv;
4171 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4174 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4177 /* The hashes have the same number of keys, so it suffices
4178 to check that one is a subset of the other. */
4179 (void) hv_iterinit(hv);
4180 while ( (he = hv_iternext(hv)) ) {
4181 SV *key = hv_iterkeysv(he);
4183 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4186 if(!hv_exists_ent(other_hv, key, 0)) {
4187 (void) hv_iterinit(hv); /* reset iterator */
4193 (void) hv_iterinit(other_hv);
4194 while ( hv_iternext(other_hv) )
4198 other_key_count = HvUSEDKEYS(other_hv);
4200 if (this_key_count != other_key_count)
4205 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4206 AV * const other_av = MUTABLE_AV(SvRV(d));
4207 const I32 other_len = av_len(other_av) + 1;
4209 HV *hv = MUTABLE_HV(SvRV(e));
4211 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4212 for (i = 0; i < other_len; ++i) {
4213 SV ** const svp = av_fetch(other_av, i, FALSE);
4214 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4215 if (svp) { /* ??? When can this not happen? */
4216 if (hv_exists_ent(hv, *svp, 0))
4222 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4223 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4226 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4228 HV *hv = MUTABLE_HV(SvRV(e));
4230 (void) hv_iterinit(hv);
4231 while ( (he = hv_iternext(hv)) ) {
4232 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4233 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4234 (void) hv_iterinit(hv);
4235 destroy_matcher(matcher);
4239 destroy_matcher(matcher);
4245 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4246 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4253 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4254 if (object_on_left) {
4255 goto sm_any_array; /* Treat objects like scalars */
4257 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4258 AV * const other_av = MUTABLE_AV(SvRV(e));
4259 const I32 other_len = av_len(other_av) + 1;
4262 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4263 for (i = 0; i < other_len; ++i) {
4264 SV ** const svp = av_fetch(other_av, i, FALSE);
4266 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4267 if (svp) { /* ??? When can this not happen? */
4268 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4274 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4275 AV *other_av = MUTABLE_AV(SvRV(d));
4276 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4277 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4281 const I32 other_len = av_len(other_av);
4283 if (NULL == seen_this) {
4284 seen_this = newHV();
4285 (void) sv_2mortal(MUTABLE_SV(seen_this));
4287 if (NULL == seen_other) {
4288 seen_this = newHV();
4289 (void) sv_2mortal(MUTABLE_SV(seen_other));
4291 for(i = 0; i <= other_len; ++i) {
4292 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4293 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4295 if (!this_elem || !other_elem) {
4296 if (this_elem || other_elem)
4299 else if (hv_exists_ent(seen_this,
4300 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4301 hv_exists_ent(seen_other,
4302 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4304 if (*this_elem != *other_elem)
4308 (void)hv_store_ent(seen_this,
4309 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4311 (void)hv_store_ent(seen_other,
4312 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4318 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4319 (void) do_smartmatch(seen_this, seen_other);
4321 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4330 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4331 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4334 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4335 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4338 for(i = 0; i <= this_len; ++i) {
4339 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4340 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4341 if (svp && matcher_matches_sv(matcher, *svp)) {
4342 destroy_matcher(matcher);
4346 destroy_matcher(matcher);
4350 else if (!SvOK(d)) {
4351 /* undef ~~ array */
4352 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4355 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4356 for (i = 0; i <= this_len; ++i) {
4357 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4358 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4359 if (!svp || !SvOK(*svp))
4368 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4370 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4371 for (i = 0; i <= this_len; ++i) {
4372 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4379 /* infinite recursion isn't supposed to happen here */
4380 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4381 (void) do_smartmatch(NULL, NULL);
4383 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4392 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4393 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4394 SV *t = d; d = e; e = t;
4395 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4398 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4399 SV *t = d; d = e; e = t;
4400 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4401 goto sm_regex_array;
4404 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4406 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4408 PUSHs(matcher_matches_sv(matcher, d)
4411 destroy_matcher(matcher);
4416 /* See if there is overload magic on left */
4417 else if (object_on_left && SvAMAGIC(d)) {
4419 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4420 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4423 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4431 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4434 else if (!SvOK(d)) {
4435 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4436 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4441 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4442 DEBUG_M(if (SvNIOK(e))
4443 Perl_deb(aTHX_ " applying rule Any-Num\n");
4445 Perl_deb(aTHX_ " applying rule Num-numish\n");
4447 /* numeric comparison */
4450 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4461 /* As a last resort, use string comparison */
4462 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4471 register PERL_CONTEXT *cx;
4472 const I32 gimme = GIMME_V;
4474 /* This is essentially an optimization: if the match
4475 fails, we don't want to push a context and then
4476 pop it again right away, so we skip straight
4477 to the op that follows the leavewhen.
4479 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4480 return cLOGOP->op_other->op_next;
4485 PUSHBLOCK(cx, CXt_WHEN, SP);
4494 register PERL_CONTEXT *cx;
4500 assert(CxTYPE(cx) == CXt_WHEN);
4505 PL_curpm = newpm; /* pop $1 et al */
4515 register PERL_CONTEXT *cx;
4518 cxix = dopoptowhen(cxstack_ix);
4520 DIE(aTHX_ "Can't \"continue\" outside a when block");
4521 if (cxix < cxstack_ix)
4524 /* clear off anything above the scope we're re-entering */
4525 inner = PL_scopestack_ix;
4527 if (PL_scopestack_ix < inner)
4528 leave_scope(PL_scopestack[PL_scopestack_ix]);
4529 PL_curcop = cx->blk_oldcop;
4530 return cx->blk_givwhen.leave_op;
4537 register PERL_CONTEXT *cx;
4540 cxix = dopoptogiven(cxstack_ix);
4542 if (PL_op->op_flags & OPf_SPECIAL)
4543 DIE(aTHX_ "Can't use when() outside a topicalizer");
4545 DIE(aTHX_ "Can't \"break\" outside a given block");
4547 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4548 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4550 if (cxix < cxstack_ix)
4553 /* clear off anything above the scope we're re-entering */
4554 inner = PL_scopestack_ix;
4556 if (PL_scopestack_ix < inner)
4557 leave_scope(PL_scopestack[PL_scopestack_ix]);
4558 PL_curcop = cx->blk_oldcop;
4561 return CX_LOOP_NEXTOP_GET(cx);
4563 return cx->blk_givwhen.leave_op;
4567 S_doparseform(pTHX_ SV *sv)
4570 register char *s = SvPV_force(sv, len);
4571 register char * const send = s + len;
4572 register char *base = NULL;
4573 register I32 skipspaces = 0;
4574 bool noblank = FALSE;
4575 bool repeat = FALSE;
4576 bool postspace = FALSE;
4582 bool unchopnum = FALSE;
4583 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4585 PERL_ARGS_ASSERT_DOPARSEFORM;
4588 Perl_croak(aTHX_ "Null picture in formline");
4590 /* estimate the buffer size needed */
4591 for (base = s; s <= send; s++) {
4592 if (*s == '\n' || *s == '@' || *s == '^')
4598 Newx(fops, maxops, U32);
4603 *fpc++ = FF_LINEMARK;
4604 noblank = repeat = FALSE;
4622 case ' ': case '\t':
4629 } /* else FALL THROUGH */
4637 *fpc++ = FF_LITERAL;
4645 *fpc++ = (U16)skipspaces;
4649 *fpc++ = FF_NEWLINE;
4653 arg = fpc - linepc + 1;
4660 *fpc++ = FF_LINEMARK;
4661 noblank = repeat = FALSE;
4670 ischop = s[-1] == '^';
4676 arg = (s - base) - 1;
4678 *fpc++ = FF_LITERAL;
4686 *fpc++ = 2; /* skip the @* or ^* */
4688 *fpc++ = FF_LINESNGL;
4691 *fpc++ = FF_LINEGLOB;
4693 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4694 arg = ischop ? 512 : 0;
4699 const char * const f = ++s;
4702 arg |= 256 + (s - f);
4704 *fpc++ = s - base; /* fieldsize for FETCH */
4705 *fpc++ = FF_DECIMAL;
4707 unchopnum |= ! ischop;
4709 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4710 arg = ischop ? 512 : 0;
4712 s++; /* skip the '0' first */
4716 const char * const f = ++s;
4719 arg |= 256 + (s - f);
4721 *fpc++ = s - base; /* fieldsize for FETCH */
4722 *fpc++ = FF_0DECIMAL;
4724 unchopnum |= ! ischop;
4728 bool ismore = FALSE;
4731 while (*++s == '>') ;
4732 prespace = FF_SPACE;
4734 else if (*s == '|') {
4735 while (*++s == '|') ;
4736 prespace = FF_HALFSPACE;
4741 while (*++s == '<') ;
4744 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4748 *fpc++ = s - base; /* fieldsize for FETCH */
4750 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4753 *fpc++ = (U16)prespace;
4767 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4769 { /* need to jump to the next word */
4771 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4772 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4773 s = SvPVX(sv) + SvCUR(sv) + z;
4775 Copy(fops, s, arg, U32);
4777 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4780 if (unchopnum && repeat)
4781 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4787 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4789 /* Can value be printed in fldsize chars, using %*.*f ? */
4793 int intsize = fldsize - (value < 0 ? 1 : 0);
4800 while (intsize--) pwr *= 10.0;
4801 while (frcsize--) eps /= 10.0;
4804 if (value + eps >= pwr)
4807 if (value - eps <= -pwr)
4814 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4817 SV * const datasv = FILTER_DATA(idx);
4818 const int filter_has_file = IoLINES(datasv);
4819 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4820 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4824 const char *got_p = NULL;
4825 const char *prune_from = NULL;
4826 bool read_from_cache = FALSE;
4829 PERL_ARGS_ASSERT_RUN_USER_FILTER;
4831 assert(maxlen >= 0);
4834 /* I was having segfault trouble under Linux 2.2.5 after a
4835 parse error occured. (Had to hack around it with a test
4836 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4837 not sure where the trouble is yet. XXX */
4839 if (IoFMT_GV(datasv)) {
4840 SV *const cache = MUTABLE_SV(IoFMT_GV(datasv));
4843 const char *cache_p = SvPV(cache, cache_len);
4847 /* Running in block mode and we have some cached data already.
4849 if (cache_len >= umaxlen) {
4850 /* In fact, so much data we don't even need to call
4855 const char *const first_nl =
4856 (const char *)memchr(cache_p, '\n', cache_len);
4858 take = first_nl + 1 - cache_p;
4862 sv_catpvn(buf_sv, cache_p, take);
4863 sv_chop(cache, cache_p + take);
4864 /* Definately not EOF */
4868 sv_catsv(buf_sv, cache);
4870 umaxlen -= cache_len;
4873 read_from_cache = TRUE;
4877 /* Filter API says that the filter appends to the contents of the buffer.
4878 Usually the buffer is "", so the details don't matter. But if it's not,
4879 then clearly what it contains is already filtered by this filter, so we
4880 don't want to pass it in a second time.
4881 I'm going to use a mortal in case the upstream filter croaks. */
4882 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4883 ? sv_newmortal() : buf_sv;
4884 SvUPGRADE(upstream, SVt_PV);
4886 if (filter_has_file) {
4887 status = FILTER_READ(idx+1, upstream, 0);
4890 if (filter_sub && status >= 0) {
4899 DEFSV_set(upstream);
4903 PUSHs(filter_state);
4906 count = call_sv(filter_sub, G_SCALAR);
4921 if(SvOK(upstream)) {
4922 got_p = SvPV(upstream, got_len);
4924 if (got_len > umaxlen) {
4925 prune_from = got_p + umaxlen;
4928 const char *const first_nl =
4929 (const char *)memchr(got_p, '\n', got_len);
4930 if (first_nl && first_nl + 1 < got_p + got_len) {
4931 /* There's a second line here... */
4932 prune_from = first_nl + 1;
4937 /* Oh. Too long. Stuff some in our cache. */
4938 STRLEN cached_len = got_p + got_len - prune_from;
4939 SV *cache = MUTABLE_SV(IoFMT_GV(datasv));
4942 IoFMT_GV(datasv) = MUTABLE_GV((cache = newSV(got_len - umaxlen)));
4943 } else if (SvOK(cache)) {
4944 /* Cache should be empty. */
4945 assert(!SvCUR(cache));
4948 sv_setpvn(cache, prune_from, cached_len);
4949 /* If you ask for block mode, you may well split UTF-8 characters.
4950 "If it breaks, you get to keep both parts"
4951 (Your code is broken if you don't put them back together again
4952 before something notices.) */
4953 if (SvUTF8(upstream)) {
4956 SvCUR_set(upstream, got_len - cached_len);
4957 /* Can't yet be EOF */
4962 /* If they are at EOF but buf_sv has something in it, then they may never
4963 have touched the SV upstream, so it may be undefined. If we naively
4964 concatenate it then we get a warning about use of uninitialised value.
4966 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4967 sv_catsv(buf_sv, upstream);
4971 IoLINES(datasv) = 0;
4972 SvREFCNT_dec(IoFMT_GV(datasv));
4974 SvREFCNT_dec(filter_state);
4975 IoTOP_GV(datasv) = NULL;
4978 SvREFCNT_dec(filter_sub);
4979 IoBOTTOM_GV(datasv) = NULL;
4981 filter_del(S_run_user_filter);
4983 if (status == 0 && read_from_cache) {
4984 /* If we read some data from the cache (and by getting here it implies
4985 that we emptied the cache) then we aren't yet at EOF, and mustn't
4986 report that to our caller. */
4992 /* perhaps someone can come up with a better name for
4993 this? it is not really "absolute", per se ... */
4995 S_path_is_absolute(const char *name)
4997 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
4999 if (PERL_FILE_IS_ABSOLUTE(name)
5001 || (*name == '.' && ((name[1] == '/' ||
5002 (name[1] == '.' && name[2] == '/'))
5003 || (name[1] == '\\' ||
5004 ( name[1] == '.' && name[2] == '\\')))
5007 || (*name == '.' && (name[1] == '/' ||
5008 (name[1] == '.' && name[2] == '/')))
5020 * c-indentation-style: bsd
5022 * indent-tabs-mode: t
5025 * ex: set ts=8 sts=4 sw=4 noet: