3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
19 * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains control-oriented pp ("push/pop") functions that
23 * execute the opcodes that make up a perl program. A typical pp function
24 * expects to find its arguments on the stack, and usually pushes its
25 * results onto the stack, hence the 'pp' terminology. Each OP structure
26 * contains a pointer to the relevant pp_foo() function.
28 * Control-oriented means things like pp_enteriter() and pp_next(), which
29 * alter the flow of control of the program.
34 #define PERL_IN_PP_CTL_C
38 #define WORD_ALIGN sizeof(U32)
41 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
43 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
52 cxix = dopoptosub(cxstack_ix);
56 switch (cxstack[cxix].blk_gimme) {
69 /* XXXX Should store the old value to allow for tie/overload - and
70 restore in regcomp, where marked with XXXX. */
80 register PMOP *pm = (PMOP*)cLOGOP->op_other;
84 /* prevent recompiling under /o and ithreads. */
85 #if defined(USE_ITHREADS)
86 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
87 if (PL_op->op_flags & OPf_STACKED) {
97 #define tryAMAGICregexp(rx) \
99 if (SvROK(rx) && SvAMAGIC(rx)) { \
100 SV *sv = AMG_CALLun(rx, regexp); \
104 if (SvTYPE(sv) != SVt_REGEXP) \
105 Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
112 if (PL_op->op_flags & OPf_STACKED) {
113 /* multiple args; concatentate them */
115 tmpstr = PAD_SV(ARGTARG);
116 sv_setpvs(tmpstr, "");
117 while (++MARK <= SP) {
119 if (PL_amagic_generation) {
122 tryAMAGICregexp(msv);
124 if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
125 (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
127 sv_setsv(tmpstr, sv);
131 sv_catsv(tmpstr, msv);
138 tryAMAGICregexp(tmpstr);
141 #undef tryAMAGICregexp
144 SV * const sv = SvRV(tmpstr);
145 if (SvTYPE(sv) == SVt_REGEXP)
148 else if (SvTYPE(tmpstr) == SVt_REGEXP)
149 re = (REGEXP*) tmpstr;
152 /* The match's LHS's get-magic might need to access this op's reg-
153 exp (as is sometimes the case with $'; see bug 70764). So we
154 must call get-magic now before we replace the regexp. Hopeful-
155 ly this hack can be replaced with the approach described at
156 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
157 /msg122415.html some day. */
158 if(pm->op_type == OP_MATCH) {
160 const bool was_tainted = PL_tainted;
161 if (pm->op_flags & OPf_STACKED)
163 else if (pm->op_private & OPpTARGET_MY)
164 lhs = PAD_SV(pm->op_targ);
167 /* Restore the previous value of PL_tainted (which may have been
168 modified by get-magic), to avoid incorrectly setting the
169 RXf_TAINTED flag further down. */
170 PL_tainted = was_tainted;
173 re = reg_temp_copy(NULL, re);
174 ReREFCNT_dec(PM_GETRE(pm));
179 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
181 assert (re != (REGEXP*) &PL_sv_undef);
183 /* Check against the last compiled regexp. */
184 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
185 memNE(RX_PRECOMP(re), t, len))
187 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
188 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
192 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
194 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
196 } else if (PL_curcop->cop_hints_hash) {
197 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
199 if (ptr && SvIOK(ptr) && SvIV(ptr))
200 eng = INT2PTR(regexp_engine*,SvIV(ptr));
203 if (PL_op->op_flags & OPf_SPECIAL)
204 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
206 if (DO_UTF8(tmpstr)) {
207 assert (SvUTF8(tmpstr));
208 } else if (SvUTF8(tmpstr)) {
209 /* Not doing UTF-8, despite what the SV says. Is this only if
210 we're trapped in use 'bytes'? */
211 /* Make a copy of the octet sequence, but without the flag on,
212 as the compiler now honours the SvUTF8 flag on tmpstr. */
214 const char *const p = SvPV(tmpstr, len);
215 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
219 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
221 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
223 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
224 inside tie/overload accessors. */
230 #ifndef INCOMPLETE_TAINTS
233 RX_EXTFLAGS(re) |= RXf_TAINTED;
235 RX_EXTFLAGS(re) &= ~RXf_TAINTED;
239 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
243 #if !defined(USE_ITHREADS)
244 /* can't change the optree at runtime either */
245 /* PMf_KEEP is handled differently under threads to avoid these problems */
246 if (pm->op_pmflags & PMf_KEEP) {
247 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
248 cLOGOP->op_first->op_next = PL_op->op_next;
258 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
259 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
260 register SV * const dstr = cx->sb_dstr;
261 register char *s = cx->sb_s;
262 register char *m = cx->sb_m;
263 char *orig = cx->sb_orig;
264 register REGEXP * const rx = cx->sb_rx;
266 REGEXP *old = PM_GETRE(pm);
270 PM_SETRE(pm,ReREFCNT_inc(rx));
273 rxres_restore(&cx->sb_rxres, rx);
274 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
276 if (cx->sb_iters++) {
277 const I32 saviters = cx->sb_iters;
278 if (cx->sb_iters > cx->sb_maxiters)
279 DIE(aTHX_ "Substitution loop");
281 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
282 cx->sb_rxtainted |= 2;
283 sv_catsv(dstr, POPs);
284 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
288 if (CxONCE(cx) || s < orig ||
289 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
290 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
291 ((cx->sb_rflags & REXEC_COPY_STR)
292 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
293 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
295 SV * const targ = cx->sb_targ;
297 assert(cx->sb_strend >= s);
298 if(cx->sb_strend > s) {
299 if (DO_UTF8(dstr) && !SvUTF8(targ))
300 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
302 sv_catpvn(dstr, s, cx->sb_strend - s);
304 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
306 #ifdef PERL_OLD_COPY_ON_WRITE
308 sv_force_normal_flags(targ, SV_COW_DROP_PV);
314 SvPV_set(targ, SvPVX(dstr));
315 SvCUR_set(targ, SvCUR(dstr));
316 SvLEN_set(targ, SvLEN(dstr));
319 SvPV_set(dstr, NULL);
321 TAINT_IF(cx->sb_rxtainted & 1);
322 mPUSHi(saviters - 1);
324 (void)SvPOK_only_UTF8(targ);
325 TAINT_IF(cx->sb_rxtainted);
329 LEAVE_SCOPE(cx->sb_oldsave);
331 RETURNOP(pm->op_next);
333 cx->sb_iters = saviters;
335 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
338 cx->sb_orig = orig = RX_SUBBEG(rx);
340 cx->sb_strend = s + (cx->sb_strend - m);
342 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
344 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
345 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
347 sv_catpvn(dstr, s, m-s);
349 cx->sb_s = RX_OFFS(rx)[0].end + orig;
350 { /* Update the pos() information. */
351 SV * const sv = cx->sb_targ;
353 SvUPGRADE(sv, SVt_PVMG);
354 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
355 #ifdef PERL_OLD_COPY_ON_WRITE
357 sv_force_normal_flags(sv, 0);
359 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
362 mg->mg_len = m - orig;
365 (void)ReREFCNT_inc(rx);
366 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
367 rxres_save(&cx->sb_rxres, rx);
368 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
372 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
377 PERL_ARGS_ASSERT_RXRES_SAVE;
380 if (!p || p[1] < RX_NPARENS(rx)) {
381 #ifdef PERL_OLD_COPY_ON_WRITE
382 i = 7 + RX_NPARENS(rx) * 2;
384 i = 6 + RX_NPARENS(rx) * 2;
393 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
394 RX_MATCH_COPIED_off(rx);
396 #ifdef PERL_OLD_COPY_ON_WRITE
397 *p++ = PTR2UV(RX_SAVED_COPY(rx));
398 RX_SAVED_COPY(rx) = NULL;
401 *p++ = RX_NPARENS(rx);
403 *p++ = PTR2UV(RX_SUBBEG(rx));
404 *p++ = (UV)RX_SUBLEN(rx);
405 for (i = 0; i <= RX_NPARENS(rx); ++i) {
406 *p++ = (UV)RX_OFFS(rx)[i].start;
407 *p++ = (UV)RX_OFFS(rx)[i].end;
412 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
417 PERL_ARGS_ASSERT_RXRES_RESTORE;
420 RX_MATCH_COPY_FREE(rx);
421 RX_MATCH_COPIED_set(rx, *p);
424 #ifdef PERL_OLD_COPY_ON_WRITE
425 if (RX_SAVED_COPY(rx))
426 SvREFCNT_dec (RX_SAVED_COPY(rx));
427 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
431 RX_NPARENS(rx) = *p++;
433 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
434 RX_SUBLEN(rx) = (I32)(*p++);
435 for (i = 0; i <= RX_NPARENS(rx); ++i) {
436 RX_OFFS(rx)[i].start = (I32)(*p++);
437 RX_OFFS(rx)[i].end = (I32)(*p++);
442 S_rxres_free(pTHX_ void **rsp)
444 UV * const p = (UV*)*rsp;
446 PERL_ARGS_ASSERT_RXRES_FREE;
451 void *tmp = INT2PTR(char*,*p);
454 PoisonFree(*p, 1, sizeof(*p));
456 Safefree(INT2PTR(char*,*p));
458 #ifdef PERL_OLD_COPY_ON_WRITE
460 SvREFCNT_dec (INT2PTR(SV*,p[1]));
470 dVAR; dSP; dMARK; dORIGMARK;
471 register SV * const tmpForm = *++MARK;
476 register SV *sv = NULL;
477 const char *item = NULL;
481 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
482 const char *chophere = NULL;
483 char *linemark = NULL;
485 bool gotsome = FALSE;
487 const STRLEN fudge = SvPOK(tmpForm)
488 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
489 bool item_is_utf8 = FALSE;
490 bool targ_is_utf8 = FALSE;
492 OP * parseres = NULL;
495 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
496 if (SvREADONLY(tmpForm)) {
497 SvREADONLY_off(tmpForm);
498 parseres = doparseform(tmpForm);
499 SvREADONLY_on(tmpForm);
502 parseres = doparseform(tmpForm);
506 SvPV_force(PL_formtarget, len);
507 if (DO_UTF8(PL_formtarget))
509 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
511 f = SvPV_const(tmpForm, len);
512 /* need to jump to the next word */
513 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
517 const char *name = "???";
520 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
521 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
522 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
523 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
524 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
526 case FF_CHECKNL: name = "CHECKNL"; break;
527 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
528 case FF_SPACE: name = "SPACE"; break;
529 case FF_HALFSPACE: name = "HALFSPACE"; break;
530 case FF_ITEM: name = "ITEM"; break;
531 case FF_CHOP: name = "CHOP"; break;
532 case FF_LINEGLOB: name = "LINEGLOB"; break;
533 case FF_NEWLINE: name = "NEWLINE"; break;
534 case FF_MORE: name = "MORE"; break;
535 case FF_LINEMARK: name = "LINEMARK"; break;
536 case FF_END: name = "END"; break;
537 case FF_0DECIMAL: name = "0DECIMAL"; break;
538 case FF_LINESNGL: name = "LINESNGL"; break;
541 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
543 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
554 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
555 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
557 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
558 t = SvEND(PL_formtarget);
562 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
563 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
565 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
566 t = SvEND(PL_formtarget);
586 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
593 const char *s = item = SvPV_const(sv, len);
596 itemsize = sv_len_utf8(sv);
597 if (itemsize != (I32)len) {
599 if (itemsize > fieldsize) {
600 itemsize = fieldsize;
601 itembytes = itemsize;
602 sv_pos_u2b(sv, &itembytes, 0);
606 send = chophere = s + itembytes;
616 sv_pos_b2u(sv, &itemsize);
620 item_is_utf8 = FALSE;
621 if (itemsize > fieldsize)
622 itemsize = fieldsize;
623 send = chophere = s + itemsize;
637 const char *s = item = SvPV_const(sv, len);
640 itemsize = sv_len_utf8(sv);
641 if (itemsize != (I32)len) {
643 if (itemsize <= fieldsize) {
644 const char *send = chophere = s + itemsize;
657 itemsize = fieldsize;
658 itembytes = itemsize;
659 sv_pos_u2b(sv, &itembytes, 0);
660 send = chophere = s + itembytes;
661 while (s < send || (s == send && isSPACE(*s))) {
671 if (strchr(PL_chopset, *s))
676 itemsize = chophere - item;
677 sv_pos_b2u(sv, &itemsize);
683 item_is_utf8 = FALSE;
684 if (itemsize <= fieldsize) {
685 const char *const send = chophere = s + itemsize;
698 itemsize = fieldsize;
699 send = chophere = s + itemsize;
700 while (s < send || (s == send && isSPACE(*s))) {
710 if (strchr(PL_chopset, *s))
715 itemsize = chophere - item;
721 arg = fieldsize - itemsize;
730 arg = fieldsize - itemsize;
741 const char *s = item;
745 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
747 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
749 t = SvEND(PL_formtarget);
753 if (UTF8_IS_CONTINUED(*s)) {
754 STRLEN skip = UTF8SKIP(s);
771 if ( !((*t++ = *s++) & ~31) )
777 if (targ_is_utf8 && !item_is_utf8) {
778 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
780 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
781 for (; t < SvEND(PL_formtarget); t++) {
794 const int ch = *t++ = *s++;
797 if ( !((*t++ = *s++) & ~31) )
806 const char *s = chophere;
820 const bool oneline = fpc[-1] == FF_LINESNGL;
821 const char *s = item = SvPV_const(sv, len);
822 item_is_utf8 = DO_UTF8(sv);
825 STRLEN to_copy = itemsize;
826 const char *const send = s + len;
827 const U8 *source = (const U8 *) s;
831 chophere = s + itemsize;
835 to_copy = s - SvPVX_const(sv) - 1;
847 if (targ_is_utf8 && !item_is_utf8) {
848 source = tmp = bytes_to_utf8(source, &to_copy);
849 SvCUR_set(PL_formtarget,
850 t - SvPVX_const(PL_formtarget));
852 if (item_is_utf8 && !targ_is_utf8) {
853 /* Upgrade targ to UTF8, and then we reduce it to
854 a problem we have a simple solution for. */
855 SvCUR_set(PL_formtarget,
856 t - SvPVX_const(PL_formtarget));
858 /* Don't need get magic. */
859 sv_utf8_upgrade_nomg(PL_formtarget);
861 SvCUR_set(PL_formtarget,
862 t - SvPVX_const(PL_formtarget));
865 /* Easy. They agree. */
866 assert (item_is_utf8 == targ_is_utf8);
868 SvGROW(PL_formtarget,
869 SvCUR(PL_formtarget) + to_copy + fudge + 1);
870 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
872 Copy(source, t, to_copy, char);
874 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
876 if (SvGMAGICAL(sv)) {
877 /* Mustn't call sv_pos_b2u() as it does a second
878 mg_get(). Is this a bug? Do we need a _flags()
880 itemsize = utf8_length(source, source + itemsize);
882 sv_pos_b2u(sv, &itemsize);
894 #if defined(USE_LONG_DOUBLE)
897 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
901 "%#0*.*f" : "%0*.*f");
906 #if defined(USE_LONG_DOUBLE)
908 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
911 ((arg & 256) ? "%#*.*f" : "%*.*f");
914 /* If the field is marked with ^ and the value is undefined,
916 if ((arg & 512) && !SvOK(sv)) {
924 /* overflow evidence */
925 if (num_overflow(value, fieldsize, arg)) {
931 /* Formats aren't yet marked for locales, so assume "yes". */
933 STORE_NUMERIC_STANDARD_SET_LOCAL();
934 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
935 RESTORE_NUMERIC_STANDARD();
942 while (t-- > linemark && *t == ' ') ;
950 if (arg) { /* repeat until fields exhausted? */
952 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
953 lines += FmLINES(PL_formtarget);
955 SvUTF8_on(PL_formtarget);
956 FmLINES(PL_formtarget) = lines;
958 RETURNOP(cLISTOP->op_first);
969 const char *s = chophere;
970 const char *send = item + len;
972 while (isSPACE(*s) && (s < send))
977 arg = fieldsize - itemsize;
984 if (strnEQ(s1," ",3)) {
985 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
996 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
998 SvUTF8_on(PL_formtarget);
999 FmLINES(PL_formtarget) += lines;
1011 if (PL_stack_base + *PL_markstack_ptr == SP) {
1013 if (GIMME_V == G_SCALAR)
1015 RETURNOP(PL_op->op_next->op_next);
1017 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
1018 pp_pushmark(); /* push dst */
1019 pp_pushmark(); /* push src */
1020 ENTER_with_name("grep"); /* enter outer scope */
1023 if (PL_op->op_private & OPpGREP_LEX)
1024 SAVESPTR(PAD_SVl(PL_op->op_targ));
1027 ENTER_with_name("grep_item"); /* enter inner scope */
1030 src = PL_stack_base[*PL_markstack_ptr];
1032 if (PL_op->op_private & OPpGREP_LEX)
1033 PAD_SVl(PL_op->op_targ) = src;
1038 if (PL_op->op_type == OP_MAPSTART)
1039 pp_pushmark(); /* push top */
1040 return ((LOGOP*)PL_op->op_next)->op_other;
1046 const I32 gimme = GIMME_V;
1047 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1053 /* first, move source pointer to the next item in the source list */
1054 ++PL_markstack_ptr[-1];
1056 /* if there are new items, push them into the destination list */
1057 if (items && gimme != G_VOID) {
1058 /* might need to make room back there first */
1059 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1060 /* XXX this implementation is very pessimal because the stack
1061 * is repeatedly extended for every set of items. Is possible
1062 * to do this without any stack extension or copying at all
1063 * by maintaining a separate list over which the map iterates
1064 * (like foreach does). --gsar */
1066 /* everything in the stack after the destination list moves
1067 * towards the end the stack by the amount of room needed */
1068 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1070 /* items to shift up (accounting for the moved source pointer) */
1071 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1073 /* This optimization is by Ben Tilly and it does
1074 * things differently from what Sarathy (gsar)
1075 * is describing. The downside of this optimization is
1076 * that leaves "holes" (uninitialized and hopefully unused areas)
1077 * to the Perl stack, but on the other hand this
1078 * shouldn't be a problem. If Sarathy's idea gets
1079 * implemented, this optimization should become
1080 * irrelevant. --jhi */
1082 shift = count; /* Avoid shifting too often --Ben Tilly */
1086 dst = (SP += shift);
1087 PL_markstack_ptr[-1] += shift;
1088 *PL_markstack_ptr += shift;
1092 /* copy the new items down to the destination list */
1093 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1094 if (gimme == G_ARRAY) {
1096 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1099 /* scalar context: we don't care about which values map returns
1100 * (we use undef here). And so we certainly don't want to do mortal
1101 * copies of meaningless values. */
1102 while (items-- > 0) {
1104 *dst-- = &PL_sv_undef;
1108 LEAVE_with_name("grep_item"); /* exit inner scope */
1111 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1113 (void)POPMARK; /* pop top */
1114 LEAVE_with_name("grep"); /* exit outer scope */
1115 (void)POPMARK; /* pop src */
1116 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1117 (void)POPMARK; /* pop dst */
1118 SP = PL_stack_base + POPMARK; /* pop original mark */
1119 if (gimme == G_SCALAR) {
1120 if (PL_op->op_private & OPpGREP_LEX) {
1121 SV* sv = sv_newmortal();
1122 sv_setiv(sv, items);
1130 else if (gimme == G_ARRAY)
1137 ENTER_with_name("grep_item"); /* enter inner scope */
1140 /* set $_ to the new source item */
1141 src = PL_stack_base[PL_markstack_ptr[-1]];
1143 if (PL_op->op_private & OPpGREP_LEX)
1144 PAD_SVl(PL_op->op_targ) = src;
1148 RETURNOP(cLOGOP->op_other);
1157 if (GIMME == G_ARRAY)
1159 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1160 return cLOGOP->op_other;
1170 if (GIMME == G_ARRAY) {
1171 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1175 SV * const targ = PAD_SV(PL_op->op_targ);
1178 if (PL_op->op_private & OPpFLIP_LINENUM) {
1179 if (GvIO(PL_last_in_gv)) {
1180 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1183 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1185 flip = SvIV(sv) == SvIV(GvSV(gv));
1191 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1192 if (PL_op->op_flags & OPf_SPECIAL) {
1200 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1203 sv_setpvs(TARG, "");
1209 /* This code tries to decide if "$left .. $right" should use the
1210 magical string increment, or if the range is numeric (we make
1211 an exception for .."0" [#18165]). AMS 20021031. */
1213 #define RANGE_IS_NUMERIC(left,right) ( \
1214 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1215 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1216 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1217 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1218 && (!SvOK(right) || looks_like_number(right))))
1224 if (GIMME == G_ARRAY) {
1230 if (RANGE_IS_NUMERIC(left,right)) {
1233 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1234 (SvOK(right) && SvNV(right) > IV_MAX))
1235 DIE(aTHX_ "Range iterator outside integer range");
1246 SV * const sv = sv_2mortal(newSViv(i++));
1251 SV * const final = sv_mortalcopy(right);
1253 const char * const tmps = SvPV_const(final, len);
1255 SV *sv = sv_mortalcopy(left);
1256 SvPV_force_nolen(sv);
1257 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1259 if (strEQ(SvPVX_const(sv),tmps))
1261 sv = sv_2mortal(newSVsv(sv));
1268 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1272 if (PL_op->op_private & OPpFLIP_LINENUM) {
1273 if (GvIO(PL_last_in_gv)) {
1274 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1277 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1278 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1286 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1287 sv_catpvs(targ, "E0");
1297 static const char * const context_name[] = {
1299 NULL, /* CXt_WHEN never actually needs "block" */
1300 NULL, /* CXt_BLOCK never actually needs "block" */
1301 NULL, /* CXt_GIVEN never actually needs "block" */
1302 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1303 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1304 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1305 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1313 S_dopoptolabel(pTHX_ const char *label)
1318 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1320 for (i = cxstack_ix; i >= 0; i--) {
1321 register const PERL_CONTEXT * const cx = &cxstack[i];
1322 switch (CxTYPE(cx)) {
1328 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1329 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1330 if (CxTYPE(cx) == CXt_NULL)
1333 case CXt_LOOP_LAZYIV:
1334 case CXt_LOOP_LAZYSV:
1336 case CXt_LOOP_PLAIN:
1338 const char *cx_label = CxLABEL(cx);
1339 if (!cx_label || strNE(label, cx_label) ) {
1340 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1341 (long)i, cx_label));
1344 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1355 Perl_dowantarray(pTHX)
1358 const I32 gimme = block_gimme();
1359 return (gimme == G_VOID) ? G_SCALAR : gimme;
1363 Perl_block_gimme(pTHX)
1366 const I32 cxix = dopoptosub(cxstack_ix);
1370 switch (cxstack[cxix].blk_gimme) {
1378 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1385 Perl_is_lvalue_sub(pTHX)
1388 const I32 cxix = dopoptosub(cxstack_ix);
1389 assert(cxix >= 0); /* We should only be called from inside subs */
1391 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1392 return CxLVAL(cxstack + cxix);
1398 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1403 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1405 for (i = startingblock; i >= 0; i--) {
1406 register const PERL_CONTEXT * const cx = &cxstk[i];
1407 switch (CxTYPE(cx)) {
1413 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1421 S_dopoptoeval(pTHX_ I32 startingblock)
1425 for (i = startingblock; i >= 0; i--) {
1426 register const PERL_CONTEXT *cx = &cxstack[i];
1427 switch (CxTYPE(cx)) {
1431 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1439 S_dopoptoloop(pTHX_ I32 startingblock)
1443 for (i = startingblock; i >= 0; i--) {
1444 register const PERL_CONTEXT * const cx = &cxstack[i];
1445 switch (CxTYPE(cx)) {
1451 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1452 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1453 if ((CxTYPE(cx)) == CXt_NULL)
1456 case CXt_LOOP_LAZYIV:
1457 case CXt_LOOP_LAZYSV:
1459 case CXt_LOOP_PLAIN:
1460 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1468 S_dopoptogiven(pTHX_ I32 startingblock)
1472 for (i = startingblock; i >= 0; i--) {
1473 register const PERL_CONTEXT *cx = &cxstack[i];
1474 switch (CxTYPE(cx)) {
1478 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1480 case CXt_LOOP_PLAIN:
1481 assert(!CxFOREACHDEF(cx));
1483 case CXt_LOOP_LAZYIV:
1484 case CXt_LOOP_LAZYSV:
1486 if (CxFOREACHDEF(cx)) {
1487 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1496 S_dopoptowhen(pTHX_ I32 startingblock)
1500 for (i = startingblock; i >= 0; i--) {
1501 register const PERL_CONTEXT *cx = &cxstack[i];
1502 switch (CxTYPE(cx)) {
1506 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1514 Perl_dounwind(pTHX_ I32 cxix)
1519 while (cxstack_ix > cxix) {
1521 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1522 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1523 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1524 /* Note: we don't need to restore the base context info till the end. */
1525 switch (CxTYPE(cx)) {
1528 continue; /* not break */
1536 case CXt_LOOP_LAZYIV:
1537 case CXt_LOOP_LAZYSV:
1539 case CXt_LOOP_PLAIN:
1550 PERL_UNUSED_VAR(optype);
1554 Perl_qerror(pTHX_ SV *err)
1558 PERL_ARGS_ASSERT_QERROR;
1561 sv_catsv(ERRSV, err);
1563 sv_catsv(PL_errors, err);
1565 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1567 ++PL_parser->error_count;
1571 Perl_die_where(pTHX_ SV *msv)
1580 if (PL_in_eval & EVAL_KEEPERR) {
1581 static const char prefix[] = "\t(in cleanup) ";
1582 SV * const err = ERRSV;
1583 const char *e = NULL;
1586 else if (SvCUR(err) >= sizeof(prefix)+SvCUR(msv)-1) {
1589 const char* message = SvPV_const(msv, msglen);
1590 e = SvPV_const(err, len);
1592 if (*e != *message || strNE(e,message))
1597 SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(msv));
1598 sv_catpvn(err, prefix, sizeof(prefix)-1);
1600 start = SvCUR(err)-SvCUR(msv)-sizeof(prefix)+1;
1601 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s",
1602 SvPVX_const(err)+start);
1607 const char* message = SvPV_const(msv, msglen);
1608 sv_setpvn(ERRSV, message, msglen);
1609 SvFLAGS(ERRSV) |= SvFLAGS(msv) & SVf_UTF8;
1613 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1614 && PL_curstackinfo->si_prev)
1622 register PERL_CONTEXT *cx;
1625 if (cxix < cxstack_ix)
1628 POPBLOCK(cx,PL_curpm);
1629 if (CxTYPE(cx) != CXt_EVAL) {
1631 const char* message = SvPVx_const( msv ? msv : ERRSV, msglen);
1632 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1633 PerlIO_write(Perl_error_log, message, msglen);
1638 if (gimme == G_SCALAR)
1639 *++newsp = &PL_sv_undef;
1640 PL_stack_sp = newsp;
1644 /* LEAVE could clobber PL_curcop (see save_re_context())
1645 * XXX it might be better to find a way to avoid messing with
1646 * PL_curcop in save_re_context() instead, but this is a more
1647 * minimal fix --GSAR */
1648 PL_curcop = cx->blk_oldcop;
1650 if (optype == OP_REQUIRE) {
1651 const char* const msg = SvPVx_nolen_const(ERRSV);
1652 SV * const nsv = cx->blk_eval.old_namesv;
1653 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1655 DIE(aTHX_ "%sCompilation failed in require",
1656 *msg ? msg : "Unknown error\n");
1658 assert(CxTYPE(cx) == CXt_EVAL);
1659 PL_restartop = cx->blk_eval.retop;
1665 write_to_stderr( msv ? msv : ERRSV );
1672 dVAR; dSP; dPOPTOPssrl;
1673 if (SvTRUE(left) != SvTRUE(right))
1683 register I32 cxix = dopoptosub(cxstack_ix);
1684 register const PERL_CONTEXT *cx;
1685 register const PERL_CONTEXT *ccstack = cxstack;
1686 const PERL_SI *top_si = PL_curstackinfo;
1688 const char *stashname;
1695 /* we may be in a higher stacklevel, so dig down deeper */
1696 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1697 top_si = top_si->si_prev;
1698 ccstack = top_si->si_cxstack;
1699 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1702 if (GIMME != G_ARRAY) {
1708 /* caller() should not report the automatic calls to &DB::sub */
1709 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1710 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1714 cxix = dopoptosub_at(ccstack, cxix - 1);
1717 cx = &ccstack[cxix];
1718 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1719 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1720 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1721 field below is defined for any cx. */
1722 /* caller() should not report the automatic calls to &DB::sub */
1723 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1724 cx = &ccstack[dbcxix];
1727 stashname = CopSTASHPV(cx->blk_oldcop);
1728 if (GIMME != G_ARRAY) {
1731 PUSHs(&PL_sv_undef);
1734 sv_setpv(TARG, stashname);
1743 PUSHs(&PL_sv_undef);
1745 mPUSHs(newSVpv(stashname, 0));
1746 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1747 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1750 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1751 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1752 /* So is ccstack[dbcxix]. */
1754 SV * const sv = newSV(0);
1755 gv_efullname3(sv, cvgv, NULL);
1757 PUSHs(boolSV(CxHASARGS(cx)));
1760 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1761 PUSHs(boolSV(CxHASARGS(cx)));
1765 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1768 gimme = (I32)cx->blk_gimme;
1769 if (gimme == G_VOID)
1770 PUSHs(&PL_sv_undef);
1772 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1773 if (CxTYPE(cx) == CXt_EVAL) {
1775 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1776 PUSHs(cx->blk_eval.cur_text);
1780 else if (cx->blk_eval.old_namesv) {
1781 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1784 /* eval BLOCK (try blocks have old_namesv == 0) */
1786 PUSHs(&PL_sv_undef);
1787 PUSHs(&PL_sv_undef);
1791 PUSHs(&PL_sv_undef);
1792 PUSHs(&PL_sv_undef);
1794 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1795 && CopSTASH_eq(PL_curcop, PL_debstash))
1797 AV * const ary = cx->blk_sub.argarray;
1798 const int off = AvARRAY(ary) - AvALLOC(ary);
1801 PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
1803 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1806 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1807 av_extend(PL_dbargs, AvFILLp(ary) + off);
1808 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1809 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1811 /* XXX only hints propagated via op_private are currently
1812 * visible (others are not easily accessible, since they
1813 * use the global PL_hints) */
1814 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1817 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1819 if (old_warnings == pWARN_NONE ||
1820 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1821 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1822 else if (old_warnings == pWARN_ALL ||
1823 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1824 /* Get the bit mask for $warnings::Bits{all}, because
1825 * it could have been extended by warnings::register */
1827 HV * const bits = get_hv("warnings::Bits", 0);
1828 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1829 mask = newSVsv(*bits_all);
1832 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1836 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1840 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1841 sv_2mortal(newRV_noinc(
1842 MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1843 cx->blk_oldcop->cop_hints_hash))))
1852 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1853 sv_reset(tmps, CopSTASH(PL_curcop));
1858 /* like pp_nextstate, but used instead when the debugger is active */
1863 PL_curcop = (COP*)PL_op;
1864 TAINT_NOT; /* Each statement is presumed innocent */
1865 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1868 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1869 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1872 register PERL_CONTEXT *cx;
1873 const I32 gimme = G_ARRAY;
1875 GV * const gv = PL_DBgv;
1876 register CV * const cv = GvCV(gv);
1879 DIE(aTHX_ "No DB::DB routine defined");
1881 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1882 /* don't do recursive DB::DB call */
1897 (void)(*CvXSUB(cv))(aTHX_ cv);
1904 PUSHBLOCK(cx, CXt_SUB, SP);
1906 cx->blk_sub.retop = PL_op->op_next;
1909 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1910 RETURNOP(CvSTART(cv));
1920 register PERL_CONTEXT *cx;
1921 const I32 gimme = GIMME_V;
1923 U8 cxtype = CXt_LOOP_FOR;
1928 ENTER_with_name("loop1");
1931 if (PL_op->op_targ) {
1932 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1933 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1934 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1935 SVs_PADSTALE, SVs_PADSTALE);
1937 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1938 #ifndef USE_ITHREADS
1939 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1945 GV * const gv = MUTABLE_GV(POPs);
1946 svp = &GvSV(gv); /* symbol table variable */
1947 SAVEGENERICSV(*svp);
1950 iterdata = (PAD*)gv;
1954 if (PL_op->op_private & OPpITER_DEF)
1955 cxtype |= CXp_FOR_DEF;
1957 ENTER_with_name("loop2");
1959 PUSHBLOCK(cx, cxtype, SP);
1961 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1963 PUSHLOOP_FOR(cx, svp, MARK, 0);
1965 if (PL_op->op_flags & OPf_STACKED) {
1966 SV *maybe_ary = POPs;
1967 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1969 SV * const right = maybe_ary;
1972 if (RANGE_IS_NUMERIC(sv,right)) {
1973 cx->cx_type &= ~CXTYPEMASK;
1974 cx->cx_type |= CXt_LOOP_LAZYIV;
1975 /* Make sure that no-one re-orders cop.h and breaks our
1977 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1978 #ifdef NV_PRESERVES_UV
1979 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1980 (SvNV(sv) > (NV)IV_MAX)))
1982 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1983 (SvNV(right) < (NV)IV_MIN))))
1985 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1988 ((SvUV(sv) > (UV)IV_MAX) ||
1989 (SvNV(sv) > (NV)UV_MAX)))))
1991 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1993 ((SvNV(right) > 0) &&
1994 ((SvUV(right) > (UV)IV_MAX) ||
1995 (SvNV(right) > (NV)UV_MAX))))))
1997 DIE(aTHX_ "Range iterator outside integer range");
1998 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1999 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
2001 /* for correct -Dstv display */
2002 cx->blk_oldsp = sp - PL_stack_base;
2006 cx->cx_type &= ~CXTYPEMASK;
2007 cx->cx_type |= CXt_LOOP_LAZYSV;
2008 /* Make sure that no-one re-orders cop.h and breaks our
2010 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2011 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2012 cx->blk_loop.state_u.lazysv.end = right;
2013 SvREFCNT_inc(right);
2014 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2015 /* This will do the upgrade to SVt_PV, and warn if the value
2016 is uninitialised. */
2017 (void) SvPV_nolen_const(right);
2018 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2019 to replace !SvOK() with a pointer to "". */
2021 SvREFCNT_dec(right);
2022 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2026 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2027 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2028 SvREFCNT_inc(maybe_ary);
2029 cx->blk_loop.state_u.ary.ix =
2030 (PL_op->op_private & OPpITER_REVERSED) ?
2031 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2035 else { /* iterating over items on the stack */
2036 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2037 if (PL_op->op_private & OPpITER_REVERSED) {
2038 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2041 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2051 register PERL_CONTEXT *cx;
2052 const I32 gimme = GIMME_V;
2054 ENTER_with_name("loop1");
2056 ENTER_with_name("loop2");
2058 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2059 PUSHLOOP_PLAIN(cx, SP);
2067 register PERL_CONTEXT *cx;
2074 assert(CxTYPE_is_LOOP(cx));
2076 newsp = PL_stack_base + cx->blk_loop.resetsp;
2079 if (gimme == G_VOID)
2081 else if (gimme == G_SCALAR) {
2083 *++newsp = sv_mortalcopy(*SP);
2085 *++newsp = &PL_sv_undef;
2089 *++newsp = sv_mortalcopy(*++mark);
2090 TAINT_NOT; /* Each item is independent */
2096 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2097 PL_curpm = newpm; /* ... and pop $1 et al */
2099 LEAVE_with_name("loop2");
2100 LEAVE_with_name("loop1");
2108 register PERL_CONTEXT *cx;
2109 bool popsub2 = FALSE;
2110 bool clear_errsv = FALSE;
2118 const I32 cxix = dopoptosub(cxstack_ix);
2121 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2122 * sort block, which is a CXt_NULL
2125 PL_stack_base[1] = *PL_stack_sp;
2126 PL_stack_sp = PL_stack_base + 1;
2130 DIE(aTHX_ "Can't return outside a subroutine");
2132 if (cxix < cxstack_ix)
2135 if (CxMULTICALL(&cxstack[cxix])) {
2136 gimme = cxstack[cxix].blk_gimme;
2137 if (gimme == G_VOID)
2138 PL_stack_sp = PL_stack_base;
2139 else if (gimme == G_SCALAR) {
2140 PL_stack_base[1] = *PL_stack_sp;
2141 PL_stack_sp = PL_stack_base + 1;
2147 switch (CxTYPE(cx)) {
2150 retop = cx->blk_sub.retop;
2151 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2154 if (!(PL_in_eval & EVAL_KEEPERR))
2157 retop = cx->blk_eval.retop;
2161 if (optype == OP_REQUIRE &&
2162 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2164 /* Unassume the success we assumed earlier. */
2165 SV * const nsv = cx->blk_eval.old_namesv;
2166 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2167 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2172 retop = cx->blk_sub.retop;
2175 DIE(aTHX_ "panic: return");
2179 if (gimme == G_SCALAR) {
2182 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2184 *++newsp = SvREFCNT_inc(*SP);
2189 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2191 *++newsp = sv_mortalcopy(sv);
2196 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2199 *++newsp = sv_mortalcopy(*SP);
2202 *++newsp = &PL_sv_undef;
2204 else if (gimme == G_ARRAY) {
2205 while (++MARK <= SP) {
2206 *++newsp = (popsub2 && SvTEMP(*MARK))
2207 ? *MARK : sv_mortalcopy(*MARK);
2208 TAINT_NOT; /* Each item is independent */
2211 PL_stack_sp = newsp;
2214 /* Stack values are safe: */
2217 POPSUB(cx,sv); /* release CV and @_ ... */
2221 PL_curpm = newpm; /* ... and pop $1 et al */
2234 register PERL_CONTEXT *cx;
2245 if (PL_op->op_flags & OPf_SPECIAL) {
2246 cxix = dopoptoloop(cxstack_ix);
2248 DIE(aTHX_ "Can't \"last\" outside a loop block");
2251 cxix = dopoptolabel(cPVOP->op_pv);
2253 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2255 if (cxix < cxstack_ix)
2259 cxstack_ix++; /* temporarily protect top context */
2261 switch (CxTYPE(cx)) {
2262 case CXt_LOOP_LAZYIV:
2263 case CXt_LOOP_LAZYSV:
2265 case CXt_LOOP_PLAIN:
2267 newsp = PL_stack_base + cx->blk_loop.resetsp;
2268 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2272 nextop = cx->blk_sub.retop;
2276 nextop = cx->blk_eval.retop;
2280 nextop = cx->blk_sub.retop;
2283 DIE(aTHX_ "panic: last");
2287 if (gimme == G_SCALAR) {
2289 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2290 ? *SP : sv_mortalcopy(*SP);
2292 *++newsp = &PL_sv_undef;
2294 else if (gimme == G_ARRAY) {
2295 while (++MARK <= SP) {
2296 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2297 ? *MARK : sv_mortalcopy(*MARK);
2298 TAINT_NOT; /* Each item is independent */
2306 /* Stack values are safe: */
2308 case CXt_LOOP_LAZYIV:
2309 case CXt_LOOP_PLAIN:
2310 case CXt_LOOP_LAZYSV:
2312 POPLOOP(cx); /* release loop vars ... */
2316 POPSUB(cx,sv); /* release CV and @_ ... */
2319 PL_curpm = newpm; /* ... and pop $1 et al */
2322 PERL_UNUSED_VAR(optype);
2323 PERL_UNUSED_VAR(gimme);
2331 register PERL_CONTEXT *cx;
2334 if (PL_op->op_flags & OPf_SPECIAL) {
2335 cxix = dopoptoloop(cxstack_ix);
2337 DIE(aTHX_ "Can't \"next\" outside a loop block");
2340 cxix = dopoptolabel(cPVOP->op_pv);
2342 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2344 if (cxix < cxstack_ix)
2347 /* clear off anything above the scope we're re-entering, but
2348 * save the rest until after a possible continue block */
2349 inner = PL_scopestack_ix;
2351 if (PL_scopestack_ix < inner)
2352 leave_scope(PL_scopestack[PL_scopestack_ix]);
2353 PL_curcop = cx->blk_oldcop;
2354 return CX_LOOP_NEXTOP_GET(cx);
2361 register PERL_CONTEXT *cx;
2365 if (PL_op->op_flags & OPf_SPECIAL) {
2366 cxix = dopoptoloop(cxstack_ix);
2368 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2371 cxix = dopoptolabel(cPVOP->op_pv);
2373 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2375 if (cxix < cxstack_ix)
2378 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2379 if (redo_op->op_type == OP_ENTER) {
2380 /* pop one less context to avoid $x being freed in while (my $x..) */
2382 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2383 redo_op = redo_op->op_next;
2387 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2388 LEAVE_SCOPE(oldsave);
2390 PL_curcop = cx->blk_oldcop;
2395 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2399 static const char too_deep[] = "Target of goto is too deeply nested";
2401 PERL_ARGS_ASSERT_DOFINDLABEL;
2404 Perl_croak(aTHX_ too_deep);
2405 if (o->op_type == OP_LEAVE ||
2406 o->op_type == OP_SCOPE ||
2407 o->op_type == OP_LEAVELOOP ||
2408 o->op_type == OP_LEAVESUB ||
2409 o->op_type == OP_LEAVETRY)
2411 *ops++ = cUNOPo->op_first;
2413 Perl_croak(aTHX_ too_deep);
2416 if (o->op_flags & OPf_KIDS) {
2418 /* First try all the kids at this level, since that's likeliest. */
2419 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2420 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2421 const char *kid_label = CopLABEL(kCOP);
2422 if (kid_label && strEQ(kid_label, label))
2426 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2427 if (kid == PL_lastgotoprobe)
2429 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2432 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2433 ops[-1]->op_type == OP_DBSTATE)
2438 if ((o = dofindlabel(kid, label, ops, oplimit)))
2451 register PERL_CONTEXT *cx;
2452 #define GOTO_DEPTH 64
2453 OP *enterops[GOTO_DEPTH];
2454 const char *label = NULL;
2455 const bool do_dump = (PL_op->op_type == OP_DUMP);
2456 static const char must_have_label[] = "goto must have label";
2458 if (PL_op->op_flags & OPf_STACKED) {
2459 SV * const sv = POPs;
2461 /* This egregious kludge implements goto &subroutine */
2462 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2464 register PERL_CONTEXT *cx;
2465 CV *cv = MUTABLE_CV(SvRV(sv));
2472 if (!CvROOT(cv) && !CvXSUB(cv)) {
2473 const GV * const gv = CvGV(cv);
2477 /* autoloaded stub? */
2478 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2480 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2481 GvNAMELEN(gv), FALSE);
2482 if (autogv && (cv = GvCV(autogv)))
2484 tmpstr = sv_newmortal();
2485 gv_efullname3(tmpstr, gv, NULL);
2486 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2488 DIE(aTHX_ "Goto undefined subroutine");
2491 /* First do some returnish stuff. */
2492 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2494 cxix = dopoptosub(cxstack_ix);
2496 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2497 if (cxix < cxstack_ix)
2501 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2502 if (CxTYPE(cx) == CXt_EVAL) {
2504 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2506 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2508 else if (CxMULTICALL(cx))
2509 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2510 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2511 /* put @_ back onto stack */
2512 AV* av = cx->blk_sub.argarray;
2514 items = AvFILLp(av) + 1;
2515 EXTEND(SP, items+1); /* @_ could have been extended. */
2516 Copy(AvARRAY(av), SP + 1, items, SV*);
2517 SvREFCNT_dec(GvAV(PL_defgv));
2518 GvAV(PL_defgv) = cx->blk_sub.savearray;
2520 /* abandon @_ if it got reified */
2525 av_extend(av, items-1);
2527 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2530 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2531 AV* const av = GvAV(PL_defgv);
2532 items = AvFILLp(av) + 1;
2533 EXTEND(SP, items+1); /* @_ could have been extended. */
2534 Copy(AvARRAY(av), SP + 1, items, SV*);
2538 if (CxTYPE(cx) == CXt_SUB &&
2539 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2540 SvREFCNT_dec(cx->blk_sub.cv);
2541 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2542 LEAVE_SCOPE(oldsave);
2544 /* Now do some callish stuff. */
2546 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2548 OP* const retop = cx->blk_sub.retop;
2553 for (index=0; index<items; index++)
2554 sv_2mortal(SP[-index]);
2557 /* XS subs don't have a CxSUB, so pop it */
2558 POPBLOCK(cx, PL_curpm);
2559 /* Push a mark for the start of arglist */
2562 (void)(*CvXSUB(cv))(aTHX_ cv);
2567 AV* const padlist = CvPADLIST(cv);
2568 if (CxTYPE(cx) == CXt_EVAL) {
2569 PL_in_eval = CxOLD_IN_EVAL(cx);
2570 PL_eval_root = cx->blk_eval.old_eval_root;
2571 cx->cx_type = CXt_SUB;
2573 cx->blk_sub.cv = cv;
2574 cx->blk_sub.olddepth = CvDEPTH(cv);
2577 if (CvDEPTH(cv) < 2)
2578 SvREFCNT_inc_simple_void_NN(cv);
2580 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2581 sub_crush_depth(cv);
2582 pad_push(padlist, CvDEPTH(cv));
2585 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2588 AV *const av = MUTABLE_AV(PAD_SVl(0));
2590 cx->blk_sub.savearray = GvAV(PL_defgv);
2591 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2592 CX_CURPAD_SAVE(cx->blk_sub);
2593 cx->blk_sub.argarray = av;
2595 if (items >= AvMAX(av) + 1) {
2596 SV **ary = AvALLOC(av);
2597 if (AvARRAY(av) != ary) {
2598 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2601 if (items >= AvMAX(av) + 1) {
2602 AvMAX(av) = items - 1;
2603 Renew(ary,items+1,SV*);
2609 Copy(mark,AvARRAY(av),items,SV*);
2610 AvFILLp(av) = items - 1;
2611 assert(!AvREAL(av));
2613 /* transfer 'ownership' of refcnts to new @_ */
2623 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2624 Perl_get_db_sub(aTHX_ NULL, cv);
2626 CV * const gotocv = get_cvs("DB::goto", 0);
2628 PUSHMARK( PL_stack_sp );
2629 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2634 RETURNOP(CvSTART(cv));
2638 label = SvPV_nolen_const(sv);
2639 if (!(do_dump || *label))
2640 DIE(aTHX_ must_have_label);
2643 else if (PL_op->op_flags & OPf_SPECIAL) {
2645 DIE(aTHX_ must_have_label);
2648 label = cPVOP->op_pv;
2650 if (label && *label) {
2651 OP *gotoprobe = NULL;
2652 bool leaving_eval = FALSE;
2653 bool in_block = FALSE;
2654 PERL_CONTEXT *last_eval_cx = NULL;
2658 PL_lastgotoprobe = NULL;
2660 for (ix = cxstack_ix; ix >= 0; ix--) {
2662 switch (CxTYPE(cx)) {
2664 leaving_eval = TRUE;
2665 if (!CxTRYBLOCK(cx)) {
2666 gotoprobe = (last_eval_cx ?
2667 last_eval_cx->blk_eval.old_eval_root :
2672 /* else fall through */
2673 case CXt_LOOP_LAZYIV:
2674 case CXt_LOOP_LAZYSV:
2676 case CXt_LOOP_PLAIN:
2679 gotoprobe = cx->blk_oldcop->op_sibling;
2685 gotoprobe = cx->blk_oldcop->op_sibling;
2688 gotoprobe = PL_main_root;
2691 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2692 gotoprobe = CvROOT(cx->blk_sub.cv);
2698 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2701 DIE(aTHX_ "panic: goto");
2702 gotoprobe = PL_main_root;
2706 retop = dofindlabel(gotoprobe, label,
2707 enterops, enterops + GOTO_DEPTH);
2711 PL_lastgotoprobe = gotoprobe;
2714 DIE(aTHX_ "Can't find label %s", label);
2716 /* if we're leaving an eval, check before we pop any frames
2717 that we're not going to punt, otherwise the error
2720 if (leaving_eval && *enterops && enterops[1]) {
2722 for (i = 1; enterops[i]; i++)
2723 if (enterops[i]->op_type == OP_ENTERITER)
2724 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2727 if (*enterops && enterops[1]) {
2728 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2730 deprecate("\"goto\" to jump into a construct");
2733 /* pop unwanted frames */
2735 if (ix < cxstack_ix) {
2742 oldsave = PL_scopestack[PL_scopestack_ix];
2743 LEAVE_SCOPE(oldsave);
2746 /* push wanted frames */
2748 if (*enterops && enterops[1]) {
2749 OP * const oldop = PL_op;
2750 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2751 for (; enterops[ix]; ix++) {
2752 PL_op = enterops[ix];
2753 /* Eventually we may want to stack the needed arguments
2754 * for each op. For now, we punt on the hard ones. */
2755 if (PL_op->op_type == OP_ENTERITER)
2756 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2757 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2765 if (!retop) retop = PL_main_start;
2767 PL_restartop = retop;
2768 PL_do_undump = TRUE;
2772 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2773 PL_do_undump = FALSE;
2790 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2792 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2795 PL_exit_flags |= PERL_EXIT_EXPECTED;
2797 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2798 if (anum || !(PL_minus_c && PL_madskills))
2803 PUSHs(&PL_sv_undef);
2810 S_save_lines(pTHX_ AV *array, SV *sv)
2812 const char *s = SvPVX_const(sv);
2813 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2816 PERL_ARGS_ASSERT_SAVE_LINES;
2818 while (s && s < send) {
2820 SV * const tmpstr = newSV_type(SVt_PVMG);
2822 t = (const char *)memchr(s, '\n', send - s);
2828 sv_setpvn(tmpstr, s, t - s);
2829 av_store(array, line++, tmpstr);
2837 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
2839 0 is used as continue inside eval,
2841 3 is used for a die caught by an inner eval - continue inner loop
2843 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
2844 establish a local jmpenv to handle exception traps.
2849 S_docatch(pTHX_ OP *o)
2853 OP * const oldop = PL_op;
2857 assert(CATCH_GET == TRUE);
2864 assert(cxstack_ix >= 0);
2865 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2866 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2871 /* die caught by an inner eval - continue inner loop */
2873 /* NB XXX we rely on the old popped CxEVAL still being at the top
2874 * of the stack; the way die_where() currently works, this
2875 * assumption is valid. In theory The cur_top_env value should be
2876 * returned in another global, the way retop (aka PL_restartop)
2878 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2881 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2883 PL_op = PL_restartop;
2899 /* James Bond: Do you expect me to talk?
2900 Auric Goldfinger: No, Mr. Bond. I expect you to die.
2902 This code is an ugly hack, doesn't work with lexicals in subroutines that are
2903 called more than once, and is only used by regcomp.c, for (?{}) blocks.
2905 Currently it is not used outside the core code. Best if it stays that way.
2908 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2909 /* sv Text to convert to OP tree. */
2910 /* startop op_free() this to undo. */
2911 /* code Short string id of the caller. */
2913 dVAR; dSP; /* Make POPBLOCK work. */
2919 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2920 char *tmpbuf = tbuf;
2923 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2926 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2928 ENTER_with_name("eval");
2929 lex_start(sv, NULL, FALSE);
2931 /* switch to eval mode */
2933 if (IN_PERL_COMPILETIME) {
2934 SAVECOPSTASH_FREE(&PL_compiling);
2935 CopSTASH_set(&PL_compiling, PL_curstash);
2937 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2938 SV * const sv = sv_newmortal();
2939 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2940 code, (unsigned long)++PL_evalseq,
2941 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2946 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2947 (unsigned long)++PL_evalseq);
2948 SAVECOPFILE_FREE(&PL_compiling);
2949 CopFILE_set(&PL_compiling, tmpbuf+2);
2950 SAVECOPLINE(&PL_compiling);
2951 CopLINE_set(&PL_compiling, 1);
2952 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2953 deleting the eval's FILEGV from the stash before gv_check() runs
2954 (i.e. before run-time proper). To work around the coredump that
2955 ensues, we always turn GvMULTI_on for any globals that were
2956 introduced within evals. See force_ident(). GSAR 96-10-12 */
2957 safestr = savepvn(tmpbuf, len);
2958 SAVEDELETE(PL_defstash, safestr, len);
2960 #ifdef OP_IN_REGISTER
2966 /* we get here either during compilation, or via pp_regcomp at runtime */
2967 runtime = IN_PERL_RUNTIME;
2969 runcv = find_runcv(NULL);
2972 PL_op->op_type = OP_ENTEREVAL;
2973 PL_op->op_flags = 0; /* Avoid uninit warning. */
2974 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2978 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2980 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2981 POPBLOCK(cx,PL_curpm);
2984 (*startop)->op_type = OP_NULL;
2985 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2987 /* XXX DAPM do this properly one year */
2988 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2989 LEAVE_with_name("eval");
2990 if (IN_PERL_COMPILETIME)
2991 CopHINTS_set(&PL_compiling, PL_hints);
2992 #ifdef OP_IN_REGISTER
2995 PERL_UNUSED_VAR(newsp);
2996 PERL_UNUSED_VAR(optype);
2998 return PL_eval_start;
3003 =for apidoc find_runcv
3005 Locate the CV corresponding to the currently executing sub or eval.
3006 If db_seqp is non_null, skip CVs that are in the DB package and populate
3007 *db_seqp with the cop sequence number at the point that the DB:: code was
3008 entered. (allows debuggers to eval in the scope of the breakpoint rather
3009 than in the scope of the debugger itself).
3015 Perl_find_runcv(pTHX_ U32 *db_seqp)
3021 *db_seqp = PL_curcop->cop_seq;
3022 for (si = PL_curstackinfo; si; si = si->si_prev) {
3024 for (ix = si->si_cxix; ix >= 0; ix--) {
3025 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3026 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3027 CV * const cv = cx->blk_sub.cv;
3028 /* skip DB:: code */
3029 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3030 *db_seqp = cx->blk_oldcop->cop_seq;
3035 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3043 /* Compile a require/do, an eval '', or a /(?{...})/.
3044 * In the last case, startop is non-null, and contains the address of
3045 * a pointer that should be set to the just-compiled code.
3046 * outside is the lexically enclosing CV (if any) that invoked us.
3047 * Returns a bool indicating whether the compile was successful; if so,
3048 * PL_eval_start contains the first op of the compiled ocde; otherwise,
3049 * pushes undef (also croaks if startop != NULL).
3053 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3056 OP * const saveop = PL_op;
3058 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
3059 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3064 SAVESPTR(PL_compcv);
3065 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3066 CvEVAL_on(PL_compcv);
3067 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3068 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3070 CvOUTSIDE_SEQ(PL_compcv) = seq;
3071 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3073 /* set up a scratch pad */
3075 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3076 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3080 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3082 /* make sure we compile in the right package */
3084 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3085 SAVESPTR(PL_curstash);
3086 PL_curstash = CopSTASH(PL_curcop);
3088 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3089 SAVESPTR(PL_beginav);
3090 PL_beginav = newAV();
3091 SAVEFREESV(PL_beginav);
3092 SAVESPTR(PL_unitcheckav);
3093 PL_unitcheckav = newAV();
3094 SAVEFREESV(PL_unitcheckav);
3097 SAVEBOOL(PL_madskills);
3101 /* try to compile it */
3103 PL_eval_root = NULL;
3104 PL_curcop = &PL_compiling;
3105 CopARYBASE_set(PL_curcop, 0);
3106 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3107 PL_in_eval |= EVAL_KEEPERR;
3110 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
3111 SV **newsp; /* Used by POPBLOCK. */
3112 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
3113 I32 optype = 0; /* Might be reset by POPEVAL. */
3118 op_free(PL_eval_root);
3119 PL_eval_root = NULL;
3121 SP = PL_stack_base + POPMARK; /* pop original mark */
3123 POPBLOCK(cx,PL_curpm);
3127 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3129 msg = SvPVx_nolen_const(ERRSV);
3130 if (optype == OP_REQUIRE) {
3131 const SV * const nsv = cx->blk_eval.old_namesv;
3132 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3134 Perl_croak(aTHX_ "%sCompilation failed in require",
3135 *msg ? msg : "Unknown error\n");
3138 POPBLOCK(cx,PL_curpm);
3140 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3141 (*msg ? msg : "Unknown error\n"));
3145 sv_setpvs(ERRSV, "Compilation error");
3148 PERL_UNUSED_VAR(newsp);
3149 PUSHs(&PL_sv_undef);
3153 CopLINE_set(&PL_compiling, 0);
3155 *startop = PL_eval_root;
3157 SAVEFREEOP(PL_eval_root);
3159 /* Set the context for this new optree.
3160 * Propagate the context from the eval(). */
3161 if ((gimme & G_WANT) == G_VOID)
3162 scalarvoid(PL_eval_root);
3163 else if ((gimme & G_WANT) == G_ARRAY)
3166 scalar(PL_eval_root);
3168 DEBUG_x(dump_eval());
3170 /* Register with debugger: */
3171 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3172 CV * const cv = get_cvs("DB::postponed", 0);
3176 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3178 call_sv(MUTABLE_SV(cv), G_DISCARD);
3183 call_list(PL_scopestack_ix, PL_unitcheckav);
3185 /* compiled okay, so do it */
3187 CvDEPTH(PL_compcv) = 1;
3188 SP = PL_stack_base + POPMARK; /* pop original mark */
3189 PL_op = saveop; /* The caller may need it. */
3190 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3197 S_check_type_and_open(pTHX_ const char *name)
3200 const int st_rc = PerlLIO_stat(name, &st);
3202 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3204 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3208 return PerlIO_open(name, PERL_SCRIPT_MODE);
3211 #ifndef PERL_DISABLE_PMC
3213 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3217 PERL_ARGS_ASSERT_DOOPEN_PM;
3219 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3220 SV *const pmcsv = newSV(namelen + 2);
3221 char *const pmc = SvPVX(pmcsv);
3224 memcpy(pmc, name, namelen);
3226 pmc[namelen + 1] = '\0';
3228 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3229 fp = check_type_and_open(name);
3232 fp = check_type_and_open(pmc);
3234 SvREFCNT_dec(pmcsv);
3237 fp = check_type_and_open(name);
3242 # define doopen_pm(name, namelen) check_type_and_open(name)
3243 #endif /* !PERL_DISABLE_PMC */
3248 register PERL_CONTEXT *cx;
3255 int vms_unixname = 0;
3257 const char *tryname = NULL;
3259 const I32 gimme = GIMME_V;
3260 int filter_has_file = 0;
3261 PerlIO *tryrsfp = NULL;
3262 SV *filter_cache = NULL;
3263 SV *filter_state = NULL;
3264 SV *filter_sub = NULL;
3270 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3271 sv = new_version(sv);
3272 if (!sv_derived_from(PL_patchlevel, "version"))
3273 upg_version(PL_patchlevel, TRUE);
3274 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3275 if ( vcmp(sv,PL_patchlevel) <= 0 )
3276 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3277 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3280 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3283 SV * const req = SvRV(sv);
3284 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3286 /* get the left hand term */
3287 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3289 first = SvIV(*av_fetch(lav,0,0));
3290 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3291 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3292 || av_len(lav) > 1 /* FP with > 3 digits */
3293 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3295 DIE(aTHX_ "Perl %"SVf" required--this is only "
3296 "%"SVf", stopped", SVfARG(vnormal(req)),
3297 SVfARG(vnormal(PL_patchlevel)));
3299 else { /* probably 'use 5.10' or 'use 5.8' */
3304 second = SvIV(*av_fetch(lav,1,0));
3306 second /= second >= 600 ? 100 : 10;
3307 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3308 (int)first, (int)second);
3309 upg_version(hintsv, TRUE);
3311 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3312 "--this is only %"SVf", stopped",
3313 SVfARG(vnormal(req)),
3314 SVfARG(vnormal(sv_2mortal(hintsv))),
3315 SVfARG(vnormal(PL_patchlevel)));
3320 /* We do this only with use, not require. */
3322 /* If we request a version >= 5.9.5, load feature.pm with the
3323 * feature bundle that corresponds to the required version. */
3324 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3325 SV *const importsv = vnormal(sv);
3326 *SvPVX_mutable(importsv) = ':';
3327 ENTER_with_name("load_feature");
3328 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3329 LEAVE_with_name("load_feature");
3331 /* If a version >= 5.11.0 is requested, strictures are on by default! */
3333 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3334 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3339 name = SvPV_const(sv, len);
3340 if (!(name && len > 0 && *name))
3341 DIE(aTHX_ "Null filename used");
3342 TAINT_PROPER("require");
3346 /* The key in the %ENV hash is in the syntax of file passed as the argument
3347 * usually this is in UNIX format, but sometimes in VMS format, which
3348 * can result in a module being pulled in more than once.
3349 * To prevent this, the key must be stored in UNIX format if the VMS
3350 * name can be translated to UNIX.
3352 if ((unixname = tounixspec(name, NULL)) != NULL) {
3353 unixlen = strlen(unixname);
3359 /* if not VMS or VMS name can not be translated to UNIX, pass it
3362 unixname = (char *) name;
3365 if (PL_op->op_type == OP_REQUIRE) {
3366 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3367 unixname, unixlen, 0);
3369 if (*svp != &PL_sv_undef)
3372 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3373 "Compilation failed in require", unixname);
3377 /* prepare to compile file */
3379 if (path_is_absolute(name)) {
3381 tryrsfp = doopen_pm(name, len);
3384 AV * const ar = GvAVn(PL_incgv);
3390 namesv = newSV_type(SVt_PV);
3391 for (i = 0; i <= AvFILL(ar); i++) {
3392 SV * const dirsv = *av_fetch(ar, i, TRUE);
3394 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3401 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3402 && !sv_isobject(loader))
3404 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3407 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3408 PTR2UV(SvRV(dirsv)), name);
3409 tryname = SvPVX_const(namesv);
3412 ENTER_with_name("call_INC");
3420 if (sv_isobject(loader))
3421 count = call_method("INC", G_ARRAY);
3423 count = call_sv(loader, G_ARRAY);
3426 /* Adjust file name if the hook has set an %INC entry */
3427 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3429 tryname = SvPV_nolen_const(*svp);
3438 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3439 && !isGV_with_GP(SvRV(arg))) {
3440 filter_cache = SvRV(arg);
3441 SvREFCNT_inc_simple_void_NN(filter_cache);
3448 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3452 if (isGV_with_GP(arg)) {
3453 IO * const io = GvIO((const GV *)arg);
3458 tryrsfp = IoIFP(io);
3459 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3460 PerlIO_close(IoOFP(io));
3471 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3473 SvREFCNT_inc_simple_void_NN(filter_sub);
3476 filter_state = SP[i];
3477 SvREFCNT_inc_simple_void(filter_state);
3481 if (!tryrsfp && (filter_cache || filter_sub)) {
3482 tryrsfp = PerlIO_open(BIT_BUCKET,
3490 LEAVE_with_name("call_INC");
3497 filter_has_file = 0;
3499 SvREFCNT_dec(filter_cache);
3500 filter_cache = NULL;
3503 SvREFCNT_dec(filter_state);
3504 filter_state = NULL;
3507 SvREFCNT_dec(filter_sub);
3512 if (!path_is_absolute(name)
3518 dir = SvPV_const(dirsv, dirlen);
3526 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3528 sv_setpv(namesv, unixdir);
3529 sv_catpv(namesv, unixname);
3531 # ifdef __SYMBIAN32__
3532 if (PL_origfilename[0] &&
3533 PL_origfilename[1] == ':' &&
3534 !(dir[0] && dir[1] == ':'))
3535 Perl_sv_setpvf(aTHX_ namesv,
3540 Perl_sv_setpvf(aTHX_ namesv,
3544 /* The equivalent of
3545 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3546 but without the need to parse the format string, or
3547 call strlen on either pointer, and with the correct
3548 allocation up front. */
3550 char *tmp = SvGROW(namesv, dirlen + len + 2);
3552 memcpy(tmp, dir, dirlen);
3555 /* name came from an SV, so it will have a '\0' at the
3556 end that we can copy as part of this memcpy(). */
3557 memcpy(tmp, name, len + 1);
3559 SvCUR_set(namesv, dirlen + len + 1);
3561 /* Don't even actually have to turn SvPOK_on() as we
3562 access it directly with SvPVX() below. */
3566 TAINT_PROPER("require");
3567 tryname = SvPVX_const(namesv);
3568 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3570 if (tryname[0] == '.' && tryname[1] == '/') {
3572 while (*++tryname == '/');
3576 else if (errno == EMFILE)
3577 /* no point in trying other paths if out of handles */
3584 SAVECOPFILE_FREE(&PL_compiling);
3585 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3586 SvREFCNT_dec(namesv);
3588 if (PL_op->op_type == OP_REQUIRE) {
3589 const char *msgstr = name;
3590 if(errno == EMFILE) {
3592 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3594 msgstr = SvPV_nolen_const(msg);
3596 if (namesv) { /* did we lookup @INC? */
3597 AV * const ar = GvAVn(PL_incgv);
3599 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3600 "%s in @INC%s%s (@INC contains:",
3602 (instr(msgstr, ".h ")
3603 ? " (change .h to .ph maybe?)" : ""),
3604 (instr(msgstr, ".ph ")
3605 ? " (did you run h2ph?)" : "")
3608 for (i = 0; i <= AvFILL(ar); i++) {
3609 sv_catpvs(msg, " ");
3610 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3612 sv_catpvs(msg, ")");
3613 msgstr = SvPV_nolen_const(msg);
3616 DIE(aTHX_ "Can't locate %s", msgstr);
3622 SETERRNO(0, SS_NORMAL);
3624 /* Assume success here to prevent recursive requirement. */
3625 /* name is never assigned to again, so len is still strlen(name) */
3626 /* Check whether a hook in @INC has already filled %INC */
3628 (void)hv_store(GvHVn(PL_incgv),
3629 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3631 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3633 (void)hv_store(GvHVn(PL_incgv),
3634 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3637 ENTER_with_name("eval");
3639 lex_start(NULL, tryrsfp, TRUE);
3643 hv_clear(GvHV(PL_hintgv));
3645 SAVECOMPILEWARNINGS();
3646 if (PL_dowarn & G_WARN_ALL_ON)
3647 PL_compiling.cop_warnings = pWARN_ALL ;
3648 else if (PL_dowarn & G_WARN_ALL_OFF)
3649 PL_compiling.cop_warnings = pWARN_NONE ;
3651 PL_compiling.cop_warnings = pWARN_STD ;
3653 if (filter_sub || filter_cache) {
3654 /* We can use the SvPV of the filter PVIO itself as our cache, rather
3655 than hanging another SV from it. In turn, filter_add() optionally
3656 takes the SV to use as the filter (or creates a new SV if passed
3657 NULL), so simply pass in whatever value filter_cache has. */
3658 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3659 IoLINES(datasv) = filter_has_file;
3660 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3661 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3664 /* switch to eval mode */
3665 PUSHBLOCK(cx, CXt_EVAL, SP);
3667 cx->blk_eval.retop = PL_op->op_next;
3669 SAVECOPLINE(&PL_compiling);
3670 CopLINE_set(&PL_compiling, 0);
3674 /* Store and reset encoding. */
3675 encoding = PL_encoding;
3678 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3679 op = DOCATCH(PL_eval_start);
3681 op = PL_op->op_next;
3683 /* Restore encoding. */
3684 PL_encoding = encoding;
3689 /* This is a op added to hold the hints hash for
3690 pp_entereval. The hash can be modified by the code
3691 being eval'ed, so we return a copy instead. */
3697 mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3705 register PERL_CONTEXT *cx;
3707 const I32 gimme = GIMME_V;
3708 const U32 was = PL_breakable_sub_gen;
3709 char tbuf[TYPE_DIGITS(long) + 12];
3710 char *tmpbuf = tbuf;
3714 HV *saved_hh = NULL;
3716 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3717 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3721 TAINT_IF(SvTAINTED(sv));
3722 TAINT_PROPER("eval");
3724 ENTER_with_name("eval");
3725 lex_start(sv, NULL, FALSE);
3728 /* switch to eval mode */
3730 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3731 SV * const temp_sv = sv_newmortal();
3732 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3733 (unsigned long)++PL_evalseq,
3734 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3735 tmpbuf = SvPVX(temp_sv);
3736 len = SvCUR(temp_sv);
3739 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3740 SAVECOPFILE_FREE(&PL_compiling);
3741 CopFILE_set(&PL_compiling, tmpbuf+2);
3742 SAVECOPLINE(&PL_compiling);
3743 CopLINE_set(&PL_compiling, 1);
3744 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3745 deleting the eval's FILEGV from the stash before gv_check() runs
3746 (i.e. before run-time proper). To work around the coredump that
3747 ensues, we always turn GvMULTI_on for any globals that were
3748 introduced within evals. See force_ident(). GSAR 96-10-12 */
3750 PL_hints = PL_op->op_targ;
3752 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3753 SvREFCNT_dec(GvHV(PL_hintgv));
3754 GvHV(PL_hintgv) = saved_hh;
3756 SAVECOMPILEWARNINGS();
3757 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3758 if (PL_compiling.cop_hints_hash) {
3759 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3761 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3762 if (PL_compiling.cop_hints_hash) {
3764 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3765 HINTS_REFCNT_UNLOCK;
3767 /* special case: an eval '' executed within the DB package gets lexically
3768 * placed in the first non-DB CV rather than the current CV - this
3769 * allows the debugger to execute code, find lexicals etc, in the
3770 * scope of the code being debugged. Passing &seq gets find_runcv
3771 * to do the dirty work for us */
3772 runcv = find_runcv(&seq);
3774 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3776 cx->blk_eval.retop = PL_op->op_next;
3778 /* prepare to compile string */
3780 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3781 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3784 if (doeval(gimme, NULL, runcv, seq)) {
3785 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3786 ? (PERLDB_LINE || PERLDB_SAVESRC)
3787 : PERLDB_SAVESRC_NOSUBS) {
3788 /* Retain the filegv we created. */
3790 char *const safestr = savepvn(tmpbuf, len);
3791 SAVEDELETE(PL_defstash, safestr, len);
3793 return DOCATCH(PL_eval_start);
3795 /* We have already left the scope set up earler thanks to the LEAVE
3797 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3798 ? (PERLDB_LINE || PERLDB_SAVESRC)
3799 : PERLDB_SAVESRC_INVALID) {
3800 /* Retain the filegv we created. */
3802 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3804 return PL_op->op_next;
3815 register PERL_CONTEXT *cx;
3817 const U8 save_flags = PL_op -> op_flags;
3822 retop = cx->blk_eval.retop;
3825 if (gimme == G_VOID)
3827 else if (gimme == G_SCALAR) {
3830 if (SvFLAGS(TOPs) & SVs_TEMP)
3833 *MARK = sv_mortalcopy(TOPs);
3837 *MARK = &PL_sv_undef;
3842 /* in case LEAVE wipes old return values */
3843 for (mark = newsp + 1; mark <= SP; mark++) {
3844 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3845 *mark = sv_mortalcopy(*mark);
3846 TAINT_NOT; /* Each item is independent */
3850 PL_curpm = newpm; /* Don't pop $1 et al till now */
3853 assert(CvDEPTH(PL_compcv) == 1);
3855 CvDEPTH(PL_compcv) = 0;
3858 if (optype == OP_REQUIRE &&
3859 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3861 /* Unassume the success we assumed earlier. */
3862 SV * const nsv = cx->blk_eval.old_namesv;
3863 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3864 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3865 /* die_where() did LEAVE, or we won't be here */
3868 LEAVE_with_name("eval");
3869 if (!(save_flags & OPf_SPECIAL)) {
3877 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3878 close to the related Perl_create_eval_scope. */
3880 Perl_delete_eval_scope(pTHX)
3885 register PERL_CONTEXT *cx;
3891 LEAVE_with_name("eval_scope");
3892 PERL_UNUSED_VAR(newsp);
3893 PERL_UNUSED_VAR(gimme);
3894 PERL_UNUSED_VAR(optype);
3897 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3898 also needed by Perl_fold_constants. */
3900 Perl_create_eval_scope(pTHX_ U32 flags)
3903 const I32 gimme = GIMME_V;
3905 ENTER_with_name("eval_scope");
3908 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3911 PL_in_eval = EVAL_INEVAL;
3912 if (flags & G_KEEPERR)
3913 PL_in_eval |= EVAL_KEEPERR;
3916 if (flags & G_FAKINGEVAL) {
3917 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3925 PERL_CONTEXT * const cx = create_eval_scope(0);
3926 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3927 return DOCATCH(PL_op->op_next);
3936 register PERL_CONTEXT *cx;
3941 PERL_UNUSED_VAR(optype);
3944 if (gimme == G_VOID)
3946 else if (gimme == G_SCALAR) {
3950 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3953 *MARK = sv_mortalcopy(TOPs);
3957 *MARK = &PL_sv_undef;
3962 /* in case LEAVE wipes old return values */
3964 for (mark = newsp + 1; mark <= SP; mark++) {
3965 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3966 *mark = sv_mortalcopy(*mark);
3967 TAINT_NOT; /* Each item is independent */
3971 PL_curpm = newpm; /* Don't pop $1 et al till now */
3973 LEAVE_with_name("eval_scope");
3981 register PERL_CONTEXT *cx;
3982 const I32 gimme = GIMME_V;
3984 ENTER_with_name("given");
3987 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3989 PUSHBLOCK(cx, CXt_GIVEN, SP);
3998 register PERL_CONTEXT *cx;
4002 PERL_UNUSED_CONTEXT;
4005 assert(CxTYPE(cx) == CXt_GIVEN);
4010 PL_curpm = newpm; /* pop $1 et al */
4012 LEAVE_with_name("given");
4017 /* Helper routines used by pp_smartmatch */
4019 S_make_matcher(pTHX_ REGEXP *re)
4022 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4024 PERL_ARGS_ASSERT_MAKE_MATCHER;
4026 PM_SETRE(matcher, ReREFCNT_inc(re));
4028 SAVEFREEOP((OP *) matcher);
4029 ENTER_with_name("matcher"); SAVETMPS;
4035 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4040 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4042 PL_op = (OP *) matcher;
4047 return (SvTRUEx(POPs));
4051 S_destroy_matcher(pTHX_ PMOP *matcher)
4055 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4056 PERL_UNUSED_ARG(matcher);
4059 LEAVE_with_name("matcher");
4062 /* Do a smart match */
4065 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4066 return do_smartmatch(NULL, NULL);
4069 /* This version of do_smartmatch() implements the
4070 * table of smart matches that is found in perlsyn.
4073 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4078 bool object_on_left = FALSE;
4079 SV *e = TOPs; /* e is for 'expression' */
4080 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4082 /* First of all, handle overload magic of the rightmost argument */
4085 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4086 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4088 tmpsv = amagic_call(d, e, smart_amg, 0);
4095 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4098 SP -= 2; /* Pop the values */
4100 /* Take care only to invoke mg_get() once for each argument.
4101 * Currently we do this by copying the SV if it's magical. */
4104 d = sv_mortalcopy(d);
4111 e = sv_mortalcopy(e);
4115 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4122 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4123 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4124 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4126 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4127 object_on_left = TRUE;
4130 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4132 if (object_on_left) {
4133 goto sm_any_sub; /* Treat objects like scalars */
4135 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4136 /* Test sub truth for each key */
4138 bool andedresults = TRUE;
4139 HV *hv = (HV*) SvRV(d);
4140 I32 numkeys = hv_iterinit(hv);
4141 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4144 while ( (he = hv_iternext(hv)) ) {
4145 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4146 ENTER_with_name("smartmatch_hash_key_test");
4149 PUSHs(hv_iterkeysv(he));
4151 c = call_sv(e, G_SCALAR);
4154 andedresults = FALSE;
4156 andedresults = SvTRUEx(POPs) && andedresults;
4158 LEAVE_with_name("smartmatch_hash_key_test");
4165 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4166 /* Test sub truth for each element */
4168 bool andedresults = TRUE;
4169 AV *av = (AV*) SvRV(d);
4170 const I32 len = av_len(av);
4171 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4174 for (i = 0; i <= len; ++i) {
4175 SV * const * const svp = av_fetch(av, i, FALSE);
4176 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4177 ENTER_with_name("smartmatch_array_elem_test");
4183 c = call_sv(e, G_SCALAR);
4186 andedresults = FALSE;
4188 andedresults = SvTRUEx(POPs) && andedresults;
4190 LEAVE_with_name("smartmatch_array_elem_test");
4199 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4200 ENTER_with_name("smartmatch_coderef");
4205 c = call_sv(e, G_SCALAR);
4209 else if (SvTEMP(TOPs))
4210 SvREFCNT_inc_void(TOPs);
4212 LEAVE_with_name("smartmatch_coderef");
4217 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4218 if (object_on_left) {
4219 goto sm_any_hash; /* Treat objects like scalars */
4221 else if (!SvOK(d)) {
4222 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4225 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4226 /* Check that the key-sets are identical */
4228 HV *other_hv = MUTABLE_HV(SvRV(d));
4230 bool other_tied = FALSE;
4231 U32 this_key_count = 0,
4232 other_key_count = 0;
4233 HV *hv = MUTABLE_HV(SvRV(e));
4235 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4236 /* Tied hashes don't know how many keys they have. */
4237 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4240 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4241 HV * const temp = other_hv;
4246 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4249 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4252 /* The hashes have the same number of keys, so it suffices
4253 to check that one is a subset of the other. */
4254 (void) hv_iterinit(hv);
4255 while ( (he = hv_iternext(hv)) ) {
4256 SV *key = hv_iterkeysv(he);
4258 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4261 if(!hv_exists_ent(other_hv, key, 0)) {
4262 (void) hv_iterinit(hv); /* reset iterator */
4268 (void) hv_iterinit(other_hv);
4269 while ( hv_iternext(other_hv) )
4273 other_key_count = HvUSEDKEYS(other_hv);
4275 if (this_key_count != other_key_count)
4280 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4281 AV * const other_av = MUTABLE_AV(SvRV(d));
4282 const I32 other_len = av_len(other_av) + 1;
4284 HV *hv = MUTABLE_HV(SvRV(e));
4286 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4287 for (i = 0; i < other_len; ++i) {
4288 SV ** const svp = av_fetch(other_av, i, FALSE);
4289 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4290 if (svp) { /* ??? When can this not happen? */
4291 if (hv_exists_ent(hv, *svp, 0))
4297 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4298 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4301 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4303 HV *hv = MUTABLE_HV(SvRV(e));
4305 (void) hv_iterinit(hv);
4306 while ( (he = hv_iternext(hv)) ) {
4307 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4308 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4309 (void) hv_iterinit(hv);
4310 destroy_matcher(matcher);
4314 destroy_matcher(matcher);
4320 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4321 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4328 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4329 if (object_on_left) {
4330 goto sm_any_array; /* Treat objects like scalars */
4332 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4333 AV * const other_av = MUTABLE_AV(SvRV(e));
4334 const I32 other_len = av_len(other_av) + 1;
4337 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4338 for (i = 0; i < other_len; ++i) {
4339 SV ** const svp = av_fetch(other_av, i, FALSE);
4341 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4342 if (svp) { /* ??? When can this not happen? */
4343 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4349 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4350 AV *other_av = MUTABLE_AV(SvRV(d));
4351 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4352 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4356 const I32 other_len = av_len(other_av);
4358 if (NULL == seen_this) {
4359 seen_this = newHV();
4360 (void) sv_2mortal(MUTABLE_SV(seen_this));
4362 if (NULL == seen_other) {
4363 seen_other = newHV();
4364 (void) sv_2mortal(MUTABLE_SV(seen_other));
4366 for(i = 0; i <= other_len; ++i) {
4367 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4368 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4370 if (!this_elem || !other_elem) {
4371 if ((this_elem && SvOK(*this_elem))
4372 || (other_elem && SvOK(*other_elem)))
4375 else if (hv_exists_ent(seen_this,
4376 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4377 hv_exists_ent(seen_other,
4378 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4380 if (*this_elem != *other_elem)
4384 (void)hv_store_ent(seen_this,
4385 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4387 (void)hv_store_ent(seen_other,
4388 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4394 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4395 (void) do_smartmatch(seen_this, seen_other);
4397 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4406 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4407 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4410 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4411 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4414 for(i = 0; i <= this_len; ++i) {
4415 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4416 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4417 if (svp && matcher_matches_sv(matcher, *svp)) {
4418 destroy_matcher(matcher);
4422 destroy_matcher(matcher);
4426 else if (!SvOK(d)) {
4427 /* undef ~~ array */
4428 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4431 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4432 for (i = 0; i <= this_len; ++i) {
4433 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4434 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4435 if (!svp || !SvOK(*svp))
4444 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4446 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4447 for (i = 0; i <= this_len; ++i) {
4448 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4455 /* infinite recursion isn't supposed to happen here */
4456 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4457 (void) do_smartmatch(NULL, NULL);
4459 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4468 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4469 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4470 SV *t = d; d = e; e = t;
4471 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4474 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4475 SV *t = d; d = e; e = t;
4476 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4477 goto sm_regex_array;
4480 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4482 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4484 PUSHs(matcher_matches_sv(matcher, d)
4487 destroy_matcher(matcher);
4492 /* See if there is overload magic on left */
4493 else if (object_on_left && SvAMAGIC(d)) {
4495 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4496 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4499 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4507 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4510 else if (!SvOK(d)) {
4511 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4512 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4517 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4518 DEBUG_M(if (SvNIOK(e))
4519 Perl_deb(aTHX_ " applying rule Any-Num\n");
4521 Perl_deb(aTHX_ " applying rule Num-numish\n");
4523 /* numeric comparison */
4526 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4537 /* As a last resort, use string comparison */
4538 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4547 register PERL_CONTEXT *cx;
4548 const I32 gimme = GIMME_V;
4550 /* This is essentially an optimization: if the match
4551 fails, we don't want to push a context and then
4552 pop it again right away, so we skip straight
4553 to the op that follows the leavewhen.
4555 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4556 return cLOGOP->op_other->op_next;
4558 ENTER_with_name("eval");
4561 PUSHBLOCK(cx, CXt_WHEN, SP);
4570 register PERL_CONTEXT *cx;
4576 assert(CxTYPE(cx) == CXt_WHEN);
4581 PL_curpm = newpm; /* pop $1 et al */
4583 LEAVE_with_name("eval");
4591 register PERL_CONTEXT *cx;
4594 cxix = dopoptowhen(cxstack_ix);
4596 DIE(aTHX_ "Can't \"continue\" outside a when block");
4597 if (cxix < cxstack_ix)
4600 /* clear off anything above the scope we're re-entering */
4601 inner = PL_scopestack_ix;
4603 if (PL_scopestack_ix < inner)
4604 leave_scope(PL_scopestack[PL_scopestack_ix]);
4605 PL_curcop = cx->blk_oldcop;
4606 return cx->blk_givwhen.leave_op;
4613 register PERL_CONTEXT *cx;
4616 cxix = dopoptogiven(cxstack_ix);
4618 if (PL_op->op_flags & OPf_SPECIAL)
4619 DIE(aTHX_ "Can't use when() outside a topicalizer");
4621 DIE(aTHX_ "Can't \"break\" outside a given block");
4623 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4624 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4626 if (cxix < cxstack_ix)
4629 /* clear off anything above the scope we're re-entering */
4630 inner = PL_scopestack_ix;
4632 if (PL_scopestack_ix < inner)
4633 leave_scope(PL_scopestack[PL_scopestack_ix]);
4634 PL_curcop = cx->blk_oldcop;
4637 return CX_LOOP_NEXTOP_GET(cx);
4639 return cx->blk_givwhen.leave_op;
4643 S_doparseform(pTHX_ SV *sv)
4646 register char *s = SvPV_force(sv, len);
4647 register char * const send = s + len;
4648 register char *base = NULL;
4649 register I32 skipspaces = 0;
4650 bool noblank = FALSE;
4651 bool repeat = FALSE;
4652 bool postspace = FALSE;
4658 bool unchopnum = FALSE;
4659 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4661 PERL_ARGS_ASSERT_DOPARSEFORM;
4664 Perl_croak(aTHX_ "Null picture in formline");
4666 /* estimate the buffer size needed */
4667 for (base = s; s <= send; s++) {
4668 if (*s == '\n' || *s == '@' || *s == '^')
4674 Newx(fops, maxops, U32);
4679 *fpc++ = FF_LINEMARK;
4680 noblank = repeat = FALSE;
4698 case ' ': case '\t':
4705 } /* else FALL THROUGH */
4713 *fpc++ = FF_LITERAL;
4721 *fpc++ = (U16)skipspaces;
4725 *fpc++ = FF_NEWLINE;
4729 arg = fpc - linepc + 1;
4736 *fpc++ = FF_LINEMARK;
4737 noblank = repeat = FALSE;
4746 ischop = s[-1] == '^';
4752 arg = (s - base) - 1;
4754 *fpc++ = FF_LITERAL;
4762 *fpc++ = 2; /* skip the @* or ^* */
4764 *fpc++ = FF_LINESNGL;
4767 *fpc++ = FF_LINEGLOB;
4769 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4770 arg = ischop ? 512 : 0;
4775 const char * const f = ++s;
4778 arg |= 256 + (s - f);
4780 *fpc++ = s - base; /* fieldsize for FETCH */
4781 *fpc++ = FF_DECIMAL;
4783 unchopnum |= ! ischop;
4785 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4786 arg = ischop ? 512 : 0;
4788 s++; /* skip the '0' first */
4792 const char * const f = ++s;
4795 arg |= 256 + (s - f);
4797 *fpc++ = s - base; /* fieldsize for FETCH */
4798 *fpc++ = FF_0DECIMAL;
4800 unchopnum |= ! ischop;
4804 bool ismore = FALSE;
4807 while (*++s == '>') ;
4808 prespace = FF_SPACE;
4810 else if (*s == '|') {
4811 while (*++s == '|') ;
4812 prespace = FF_HALFSPACE;
4817 while (*++s == '<') ;
4820 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4824 *fpc++ = s - base; /* fieldsize for FETCH */
4826 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4829 *fpc++ = (U16)prespace;
4843 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4845 { /* need to jump to the next word */
4847 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4848 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4849 s = SvPVX(sv) + SvCUR(sv) + z;
4851 Copy(fops, s, arg, U32);
4853 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4856 if (unchopnum && repeat)
4857 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4863 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4865 /* Can value be printed in fldsize chars, using %*.*f ? */
4869 int intsize = fldsize - (value < 0 ? 1 : 0);
4876 while (intsize--) pwr *= 10.0;
4877 while (frcsize--) eps /= 10.0;
4880 if (value + eps >= pwr)
4883 if (value - eps <= -pwr)
4890 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4893 SV * const datasv = FILTER_DATA(idx);
4894 const int filter_has_file = IoLINES(datasv);
4895 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4896 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4901 char *prune_from = NULL;
4902 bool read_from_cache = FALSE;
4905 PERL_ARGS_ASSERT_RUN_USER_FILTER;
4907 assert(maxlen >= 0);
4910 /* I was having segfault trouble under Linux 2.2.5 after a
4911 parse error occured. (Had to hack around it with a test
4912 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4913 not sure where the trouble is yet. XXX */
4916 SV *const cache = datasv;
4919 const char *cache_p = SvPV(cache, cache_len);
4923 /* Running in block mode and we have some cached data already.
4925 if (cache_len >= umaxlen) {
4926 /* In fact, so much data we don't even need to call
4931 const char *const first_nl =
4932 (const char *)memchr(cache_p, '\n', cache_len);
4934 take = first_nl + 1 - cache_p;
4938 sv_catpvn(buf_sv, cache_p, take);
4939 sv_chop(cache, cache_p + take);
4940 /* Definately not EOF */
4944 sv_catsv(buf_sv, cache);
4946 umaxlen -= cache_len;
4949 read_from_cache = TRUE;
4953 /* Filter API says that the filter appends to the contents of the buffer.
4954 Usually the buffer is "", so the details don't matter. But if it's not,
4955 then clearly what it contains is already filtered by this filter, so we
4956 don't want to pass it in a second time.
4957 I'm going to use a mortal in case the upstream filter croaks. */
4958 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4959 ? sv_newmortal() : buf_sv;
4960 SvUPGRADE(upstream, SVt_PV);
4962 if (filter_has_file) {
4963 status = FILTER_READ(idx+1, upstream, 0);
4966 if (filter_sub && status >= 0) {
4970 ENTER_with_name("call_filter_sub");
4975 DEFSV_set(upstream);
4979 PUSHs(filter_state);
4982 count = call_sv(filter_sub, G_SCALAR);
4994 LEAVE_with_name("call_filter_sub");
4997 if(SvOK(upstream)) {
4998 got_p = SvPV(upstream, got_len);
5000 if (got_len > umaxlen) {
5001 prune_from = got_p + umaxlen;
5004 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5005 if (first_nl && first_nl + 1 < got_p + got_len) {
5006 /* There's a second line here... */
5007 prune_from = first_nl + 1;
5012 /* Oh. Too long. Stuff some in our cache. */
5013 STRLEN cached_len = got_p + got_len - prune_from;
5014 SV *const cache = datasv;
5017 /* Cache should be empty. */
5018 assert(!SvCUR(cache));
5021 sv_setpvn(cache, prune_from, cached_len);
5022 /* If you ask for block mode, you may well split UTF-8 characters.
5023 "If it breaks, you get to keep both parts"
5024 (Your code is broken if you don't put them back together again
5025 before something notices.) */
5026 if (SvUTF8(upstream)) {
5029 SvCUR_set(upstream, got_len - cached_len);
5031 /* Can't yet be EOF */
5036 /* If they are at EOF but buf_sv has something in it, then they may never
5037 have touched the SV upstream, so it may be undefined. If we naively
5038 concatenate it then we get a warning about use of uninitialised value.
5040 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5041 sv_catsv(buf_sv, upstream);
5045 IoLINES(datasv) = 0;
5047 SvREFCNT_dec(filter_state);
5048 IoTOP_GV(datasv) = NULL;
5051 SvREFCNT_dec(filter_sub);
5052 IoBOTTOM_GV(datasv) = NULL;
5054 filter_del(S_run_user_filter);
5056 if (status == 0 && read_from_cache) {
5057 /* If we read some data from the cache (and by getting here it implies
5058 that we emptied the cache) then we aren't yet at EOF, and mustn't
5059 report that to our caller. */
5065 /* perhaps someone can come up with a better name for
5066 this? it is not really "absolute", per se ... */
5068 S_path_is_absolute(const char *name)
5070 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5072 if (PERL_FILE_IS_ABSOLUTE(name)
5074 || (*name == '.' && ((name[1] == '/' ||
5075 (name[1] == '.' && name[2] == '/'))
5076 || (name[1] == '\\' ||
5077 ( name[1] == '.' && name[2] == '\\')))
5080 || (*name == '.' && (name[1] == '/' ||
5081 (name[1] == '.' && name[2] == '/')))
5093 * c-indentation-style: bsd
5095 * indent-tabs-mode: t
5098 * ex: set ts=8 sts=4 sw=4 noet: