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) \
100 if (SvROK(rx) && SvAMAGIC(rx)) { \
101 SV *sv = AMG_CALLun(rx, regexp); \
105 if (SvTYPE(sv) != SVt_REGEXP) \
106 Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
113 if (PL_op->op_flags & OPf_STACKED) {
114 /* multiple args; concatentate them */
116 tmpstr = PAD_SV(ARGTARG);
117 sv_setpvs(tmpstr, "");
118 while (++MARK <= SP) {
122 tryAMAGICregexp(msv);
124 if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
125 (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
127 sv_setsv(tmpstr, sv);
130 sv_catsv(tmpstr, msv);
137 tryAMAGICregexp(tmpstr);
140 #undef tryAMAGICregexp
143 SV * const sv = SvRV(tmpstr);
144 if (SvTYPE(sv) == SVt_REGEXP)
147 else if (SvTYPE(tmpstr) == SVt_REGEXP)
148 re = (REGEXP*) tmpstr;
151 /* The match's LHS's get-magic might need to access this op's reg-
152 exp (as is sometimes the case with $'; see bug 70764). So we
153 must call get-magic now before we replace the regexp. Hopeful-
154 ly this hack can be replaced with the approach described at
155 http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
156 /msg122415.html some day. */
157 if(pm->op_type == OP_MATCH) {
159 const bool was_tainted = PL_tainted;
160 if (pm->op_flags & OPf_STACKED)
162 else if (pm->op_private & OPpTARGET_MY)
163 lhs = PAD_SV(pm->op_targ);
166 /* Restore the previous value of PL_tainted (which may have been
167 modified by get-magic), to avoid incorrectly setting the
168 RXf_TAINTED flag further down. */
169 PL_tainted = was_tainted;
172 re = reg_temp_copy(NULL, re);
173 ReREFCNT_dec(PM_GETRE(pm));
178 const char *t = SvOK(tmpstr) ? SvPV_nomg_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);
217 else if (SvAMAGIC(tmpstr)) {
218 /* make a copy to avoid extra stringifies */
219 tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
223 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
225 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
227 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
228 inside tie/overload accessors. */
234 #ifndef INCOMPLETE_TAINTS
237 RX_EXTFLAGS(re) |= RXf_TAINTED;
239 RX_EXTFLAGS(re) &= ~RXf_TAINTED;
243 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
247 #if !defined(USE_ITHREADS)
248 /* can't change the optree at runtime either */
249 /* PMf_KEEP is handled differently under threads to avoid these problems */
250 if (pm->op_pmflags & PMf_KEEP) {
251 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
252 cLOGOP->op_first->op_next = PL_op->op_next;
262 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
263 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
264 register SV * const dstr = cx->sb_dstr;
265 register char *s = cx->sb_s;
266 register char *m = cx->sb_m;
267 char *orig = cx->sb_orig;
268 register REGEXP * const rx = cx->sb_rx;
270 REGEXP *old = PM_GETRE(pm);
277 PM_SETRE(pm,ReREFCNT_inc(rx));
280 rxres_restore(&cx->sb_rxres, rx);
281 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
283 if (cx->sb_iters++) {
284 const I32 saviters = cx->sb_iters;
285 if (cx->sb_iters > cx->sb_maxiters)
286 DIE(aTHX_ "Substitution loop");
288 SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
290 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
291 cx->sb_rxtainted |= 2;
292 sv_catsv_nomg(dstr, POPs);
293 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
297 if (CxONCE(cx) || s < orig ||
298 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
299 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
300 ((cx->sb_rflags & REXEC_COPY_STR)
301 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
302 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
304 SV * const targ = cx->sb_targ;
306 assert(cx->sb_strend >= s);
307 if(cx->sb_strend > s) {
308 if (DO_UTF8(dstr) && !SvUTF8(targ))
309 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
311 sv_catpvn(dstr, s, cx->sb_strend - s);
313 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
315 #ifdef PERL_OLD_COPY_ON_WRITE
317 sv_force_normal_flags(targ, SV_COW_DROP_PV);
323 SvPV_set(targ, SvPVX(dstr));
324 SvCUR_set(targ, SvCUR(dstr));
325 SvLEN_set(targ, SvLEN(dstr));
328 SvPV_set(dstr, NULL);
330 TAINT_IF(cx->sb_rxtainted & 1);
331 if (pm->op_pmflags & PMf_NONDESTRUCT)
334 mPUSHi(saviters - 1);
336 (void)SvPOK_only_UTF8(targ);
337 TAINT_IF(cx->sb_rxtainted);
341 LEAVE_SCOPE(cx->sb_oldsave);
343 RETURNOP(pm->op_next);
345 cx->sb_iters = saviters;
347 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
350 cx->sb_orig = orig = RX_SUBBEG(rx);
352 cx->sb_strend = s + (cx->sb_strend - m);
354 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
356 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
357 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
359 sv_catpvn(dstr, s, m-s);
361 cx->sb_s = RX_OFFS(rx)[0].end + orig;
362 { /* Update the pos() information. */
363 SV * const sv = cx->sb_targ;
365 SvUPGRADE(sv, SVt_PVMG);
366 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
367 #ifdef PERL_OLD_COPY_ON_WRITE
369 sv_force_normal_flags(sv, 0);
371 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
374 mg->mg_len = m - orig;
377 (void)ReREFCNT_inc(rx);
378 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
379 rxres_save(&cx->sb_rxres, rx);
381 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
385 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
390 PERL_ARGS_ASSERT_RXRES_SAVE;
393 if (!p || p[1] < RX_NPARENS(rx)) {
394 #ifdef PERL_OLD_COPY_ON_WRITE
395 i = 7 + RX_NPARENS(rx) * 2;
397 i = 6 + RX_NPARENS(rx) * 2;
406 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
407 RX_MATCH_COPIED_off(rx);
409 #ifdef PERL_OLD_COPY_ON_WRITE
410 *p++ = PTR2UV(RX_SAVED_COPY(rx));
411 RX_SAVED_COPY(rx) = NULL;
414 *p++ = RX_NPARENS(rx);
416 *p++ = PTR2UV(RX_SUBBEG(rx));
417 *p++ = (UV)RX_SUBLEN(rx);
418 for (i = 0; i <= RX_NPARENS(rx); ++i) {
419 *p++ = (UV)RX_OFFS(rx)[i].start;
420 *p++ = (UV)RX_OFFS(rx)[i].end;
425 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
430 PERL_ARGS_ASSERT_RXRES_RESTORE;
433 RX_MATCH_COPY_FREE(rx);
434 RX_MATCH_COPIED_set(rx, *p);
437 #ifdef PERL_OLD_COPY_ON_WRITE
438 if (RX_SAVED_COPY(rx))
439 SvREFCNT_dec (RX_SAVED_COPY(rx));
440 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
444 RX_NPARENS(rx) = *p++;
446 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
447 RX_SUBLEN(rx) = (I32)(*p++);
448 for (i = 0; i <= RX_NPARENS(rx); ++i) {
449 RX_OFFS(rx)[i].start = (I32)(*p++);
450 RX_OFFS(rx)[i].end = (I32)(*p++);
455 S_rxres_free(pTHX_ void **rsp)
457 UV * const p = (UV*)*rsp;
459 PERL_ARGS_ASSERT_RXRES_FREE;
464 void *tmp = INT2PTR(char*,*p);
467 PoisonFree(*p, 1, sizeof(*p));
469 Safefree(INT2PTR(char*,*p));
471 #ifdef PERL_OLD_COPY_ON_WRITE
473 SvREFCNT_dec (INT2PTR(SV*,p[1]));
483 dVAR; dSP; dMARK; dORIGMARK;
484 register SV * const tmpForm = *++MARK;
489 register SV *sv = NULL;
490 const char *item = NULL;
494 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
495 const char *chophere = NULL;
496 char *linemark = NULL;
498 bool gotsome = FALSE;
500 const STRLEN fudge = SvPOK(tmpForm)
501 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
502 bool item_is_utf8 = FALSE;
503 bool targ_is_utf8 = FALSE;
505 OP * parseres = NULL;
508 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
509 if (SvREADONLY(tmpForm)) {
510 SvREADONLY_off(tmpForm);
511 parseres = doparseform(tmpForm);
512 SvREADONLY_on(tmpForm);
515 parseres = doparseform(tmpForm);
519 SvPV_force(PL_formtarget, len);
520 if (DO_UTF8(PL_formtarget))
522 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
524 f = SvPV_const(tmpForm, len);
525 /* need to jump to the next word */
526 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
530 const char *name = "???";
533 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
534 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
535 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
536 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
537 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
539 case FF_CHECKNL: name = "CHECKNL"; break;
540 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
541 case FF_SPACE: name = "SPACE"; break;
542 case FF_HALFSPACE: name = "HALFSPACE"; break;
543 case FF_ITEM: name = "ITEM"; break;
544 case FF_CHOP: name = "CHOP"; break;
545 case FF_LINEGLOB: name = "LINEGLOB"; break;
546 case FF_NEWLINE: name = "NEWLINE"; break;
547 case FF_MORE: name = "MORE"; break;
548 case FF_LINEMARK: name = "LINEMARK"; break;
549 case FF_END: name = "END"; break;
550 case FF_0DECIMAL: name = "0DECIMAL"; break;
551 case FF_LINESNGL: name = "LINESNGL"; break;
554 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
556 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
567 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
568 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
570 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
571 t = SvEND(PL_formtarget);
575 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
576 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
578 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
579 t = SvEND(PL_formtarget);
599 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
606 const char *s = item = SvPV_const(sv, len);
609 itemsize = sv_len_utf8(sv);
610 if (itemsize != (I32)len) {
612 if (itemsize > fieldsize) {
613 itemsize = fieldsize;
614 itembytes = itemsize;
615 sv_pos_u2b(sv, &itembytes, 0);
619 send = chophere = s + itembytes;
629 sv_pos_b2u(sv, &itemsize);
633 item_is_utf8 = FALSE;
634 if (itemsize > fieldsize)
635 itemsize = fieldsize;
636 send = chophere = s + itemsize;
650 const char *s = item = SvPV_const(sv, len);
653 itemsize = sv_len_utf8(sv);
654 if (itemsize != (I32)len) {
656 if (itemsize <= fieldsize) {
657 const char *send = chophere = s + itemsize;
670 itemsize = fieldsize;
671 itembytes = itemsize;
672 sv_pos_u2b(sv, &itembytes, 0);
673 send = chophere = s + itembytes;
674 while (s < send || (s == send && isSPACE(*s))) {
684 if (strchr(PL_chopset, *s))
689 itemsize = chophere - item;
690 sv_pos_b2u(sv, &itemsize);
696 item_is_utf8 = FALSE;
697 if (itemsize <= fieldsize) {
698 const char *const send = chophere = s + itemsize;
711 itemsize = fieldsize;
712 send = chophere = s + itemsize;
713 while (s < send || (s == send && isSPACE(*s))) {
723 if (strchr(PL_chopset, *s))
728 itemsize = chophere - item;
734 arg = fieldsize - itemsize;
743 arg = fieldsize - itemsize;
754 const char *s = item;
758 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
760 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
762 t = SvEND(PL_formtarget);
766 if (UTF8_IS_CONTINUED(*s)) {
767 STRLEN skip = UTF8SKIP(s);
784 if ( !((*t++ = *s++) & ~31) )
790 if (targ_is_utf8 && !item_is_utf8) {
791 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
793 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
794 for (; t < SvEND(PL_formtarget); t++) {
807 const int ch = *t++ = *s++;
810 if ( !((*t++ = *s++) & ~31) )
819 const char *s = chophere;
833 const bool oneline = fpc[-1] == FF_LINESNGL;
834 const char *s = item = SvPV_const(sv, len);
835 item_is_utf8 = DO_UTF8(sv);
838 STRLEN to_copy = itemsize;
839 const char *const send = s + len;
840 const U8 *source = (const U8 *) s;
844 chophere = s + itemsize;
848 to_copy = s - SvPVX_const(sv) - 1;
860 if (targ_is_utf8 && !item_is_utf8) {
861 source = tmp = bytes_to_utf8(source, &to_copy);
862 SvCUR_set(PL_formtarget,
863 t - SvPVX_const(PL_formtarget));
865 if (item_is_utf8 && !targ_is_utf8) {
866 /* Upgrade targ to UTF8, and then we reduce it to
867 a problem we have a simple solution for. */
868 SvCUR_set(PL_formtarget,
869 t - SvPVX_const(PL_formtarget));
871 /* Don't need get magic. */
872 sv_utf8_upgrade_nomg(PL_formtarget);
874 SvCUR_set(PL_formtarget,
875 t - SvPVX_const(PL_formtarget));
878 /* Easy. They agree. */
879 assert (item_is_utf8 == targ_is_utf8);
881 SvGROW(PL_formtarget,
882 SvCUR(PL_formtarget) + to_copy + fudge + 1);
883 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
885 Copy(source, t, to_copy, char);
887 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
889 if (SvGMAGICAL(sv)) {
890 /* Mustn't call sv_pos_b2u() as it does a second
891 mg_get(). Is this a bug? Do we need a _flags()
893 itemsize = utf8_length(source, source + itemsize);
895 sv_pos_b2u(sv, &itemsize);
907 #if defined(USE_LONG_DOUBLE)
910 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
914 "%#0*.*f" : "%0*.*f");
919 #if defined(USE_LONG_DOUBLE)
921 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
924 ((arg & 256) ? "%#*.*f" : "%*.*f");
927 /* If the field is marked with ^ and the value is undefined,
929 if ((arg & 512) && !SvOK(sv)) {
937 /* overflow evidence */
938 if (num_overflow(value, fieldsize, arg)) {
944 /* Formats aren't yet marked for locales, so assume "yes". */
946 STORE_NUMERIC_STANDARD_SET_LOCAL();
947 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
948 RESTORE_NUMERIC_STANDARD();
955 while (t-- > linemark && *t == ' ') ;
963 if (arg) { /* repeat until fields exhausted? */
965 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
966 lines += FmLINES(PL_formtarget);
968 SvUTF8_on(PL_formtarget);
969 FmLINES(PL_formtarget) = lines;
971 RETURNOP(cLISTOP->op_first);
982 const char *s = chophere;
983 const char *send = item + len;
985 while (isSPACE(*s) && (s < send))
990 arg = fieldsize - itemsize;
997 if (strnEQ(s1," ",3)) {
998 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
1009 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1011 SvUTF8_on(PL_formtarget);
1012 FmLINES(PL_formtarget) += lines;
1024 if (PL_stack_base + *PL_markstack_ptr == SP) {
1026 if (GIMME_V == G_SCALAR)
1028 RETURNOP(PL_op->op_next->op_next);
1030 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
1031 pp_pushmark(); /* push dst */
1032 pp_pushmark(); /* push src */
1033 ENTER_with_name("grep"); /* enter outer scope */
1036 if (PL_op->op_private & OPpGREP_LEX)
1037 SAVESPTR(PAD_SVl(PL_op->op_targ));
1040 ENTER_with_name("grep_item"); /* enter inner scope */
1043 src = PL_stack_base[*PL_markstack_ptr];
1045 if (PL_op->op_private & OPpGREP_LEX)
1046 PAD_SVl(PL_op->op_targ) = src;
1051 if (PL_op->op_type == OP_MAPSTART)
1052 pp_pushmark(); /* push top */
1053 return ((LOGOP*)PL_op->op_next)->op_other;
1059 const I32 gimme = GIMME_V;
1060 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1066 /* first, move source pointer to the next item in the source list */
1067 ++PL_markstack_ptr[-1];
1069 /* if there are new items, push them into the destination list */
1070 if (items && gimme != G_VOID) {
1071 /* might need to make room back there first */
1072 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1073 /* XXX this implementation is very pessimal because the stack
1074 * is repeatedly extended for every set of items. Is possible
1075 * to do this without any stack extension or copying at all
1076 * by maintaining a separate list over which the map iterates
1077 * (like foreach does). --gsar */
1079 /* everything in the stack after the destination list moves
1080 * towards the end the stack by the amount of room needed */
1081 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1083 /* items to shift up (accounting for the moved source pointer) */
1084 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1086 /* This optimization is by Ben Tilly and it does
1087 * things differently from what Sarathy (gsar)
1088 * is describing. The downside of this optimization is
1089 * that leaves "holes" (uninitialized and hopefully unused areas)
1090 * to the Perl stack, but on the other hand this
1091 * shouldn't be a problem. If Sarathy's idea gets
1092 * implemented, this optimization should become
1093 * irrelevant. --jhi */
1095 shift = count; /* Avoid shifting too often --Ben Tilly */
1099 dst = (SP += shift);
1100 PL_markstack_ptr[-1] += shift;
1101 *PL_markstack_ptr += shift;
1105 /* copy the new items down to the destination list */
1106 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1107 if (gimme == G_ARRAY) {
1109 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1112 /* scalar context: we don't care about which values map returns
1113 * (we use undef here). And so we certainly don't want to do mortal
1114 * copies of meaningless values. */
1115 while (items-- > 0) {
1117 *dst-- = &PL_sv_undef;
1121 LEAVE_with_name("grep_item"); /* exit inner scope */
1124 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1126 (void)POPMARK; /* pop top */
1127 LEAVE_with_name("grep"); /* exit outer scope */
1128 (void)POPMARK; /* pop src */
1129 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1130 (void)POPMARK; /* pop dst */
1131 SP = PL_stack_base + POPMARK; /* pop original mark */
1132 if (gimme == G_SCALAR) {
1133 if (PL_op->op_private & OPpGREP_LEX) {
1134 SV* sv = sv_newmortal();
1135 sv_setiv(sv, items);
1143 else if (gimme == G_ARRAY)
1150 ENTER_with_name("grep_item"); /* enter inner scope */
1153 /* set $_ to the new source item */
1154 src = PL_stack_base[PL_markstack_ptr[-1]];
1156 if (PL_op->op_private & OPpGREP_LEX)
1157 PAD_SVl(PL_op->op_targ) = src;
1161 RETURNOP(cLOGOP->op_other);
1170 if (GIMME == G_ARRAY)
1172 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1173 return cLOGOP->op_other;
1183 if (GIMME == G_ARRAY) {
1184 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1188 SV * const targ = PAD_SV(PL_op->op_targ);
1191 if (PL_op->op_private & OPpFLIP_LINENUM) {
1192 if (GvIO(PL_last_in_gv)) {
1193 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1196 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1198 flip = SvIV(sv) == SvIV(GvSV(gv));
1204 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1205 if (PL_op->op_flags & OPf_SPECIAL) {
1213 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1216 sv_setpvs(TARG, "");
1222 /* This code tries to decide if "$left .. $right" should use the
1223 magical string increment, or if the range is numeric (we make
1224 an exception for .."0" [#18165]). AMS 20021031. */
1226 #define RANGE_IS_NUMERIC(left,right) ( \
1227 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1228 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1229 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1230 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1231 && (!SvOK(right) || looks_like_number(right))))
1237 if (GIMME == G_ARRAY) {
1243 if (RANGE_IS_NUMERIC(left,right)) {
1246 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1247 (SvOK(right) && SvNV(right) > IV_MAX))
1248 DIE(aTHX_ "Range iterator outside integer range");
1259 SV * const sv = sv_2mortal(newSViv(i++));
1264 SV * const final = sv_mortalcopy(right);
1266 const char * const tmps = SvPV_const(final, len);
1268 SV *sv = sv_mortalcopy(left);
1269 SvPV_force_nolen(sv);
1270 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1272 if (strEQ(SvPVX_const(sv),tmps))
1274 sv = sv_2mortal(newSVsv(sv));
1281 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1285 if (PL_op->op_private & OPpFLIP_LINENUM) {
1286 if (GvIO(PL_last_in_gv)) {
1287 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1290 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1291 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1299 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1300 sv_catpvs(targ, "E0");
1310 static const char * const context_name[] = {
1312 NULL, /* CXt_WHEN never actually needs "block" */
1313 NULL, /* CXt_BLOCK never actually needs "block" */
1314 NULL, /* CXt_GIVEN never actually needs "block" */
1315 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1316 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1317 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1318 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1326 S_dopoptolabel(pTHX_ const char *label)
1331 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1333 for (i = cxstack_ix; i >= 0; i--) {
1334 register const PERL_CONTEXT * const cx = &cxstack[i];
1335 switch (CxTYPE(cx)) {
1341 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1342 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1343 if (CxTYPE(cx) == CXt_NULL)
1346 case CXt_LOOP_LAZYIV:
1347 case CXt_LOOP_LAZYSV:
1349 case CXt_LOOP_PLAIN:
1351 const char *cx_label = CxLABEL(cx);
1352 if (!cx_label || strNE(label, cx_label) ) {
1353 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1354 (long)i, cx_label));
1357 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1368 Perl_dowantarray(pTHX)
1371 const I32 gimme = block_gimme();
1372 return (gimme == G_VOID) ? G_SCALAR : gimme;
1376 Perl_block_gimme(pTHX)
1379 const I32 cxix = dopoptosub(cxstack_ix);
1383 switch (cxstack[cxix].blk_gimme) {
1391 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1398 Perl_is_lvalue_sub(pTHX)
1401 const I32 cxix = dopoptosub(cxstack_ix);
1402 assert(cxix >= 0); /* We should only be called from inside subs */
1404 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1405 return CxLVAL(cxstack + cxix);
1411 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1416 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1418 for (i = startingblock; i >= 0; i--) {
1419 register const PERL_CONTEXT * const cx = &cxstk[i];
1420 switch (CxTYPE(cx)) {
1426 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1434 S_dopoptoeval(pTHX_ I32 startingblock)
1438 for (i = startingblock; i >= 0; i--) {
1439 register const PERL_CONTEXT *cx = &cxstack[i];
1440 switch (CxTYPE(cx)) {
1444 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1452 S_dopoptoloop(pTHX_ I32 startingblock)
1456 for (i = startingblock; i >= 0; i--) {
1457 register const PERL_CONTEXT * const cx = &cxstack[i];
1458 switch (CxTYPE(cx)) {
1464 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1465 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1466 if ((CxTYPE(cx)) == CXt_NULL)
1469 case CXt_LOOP_LAZYIV:
1470 case CXt_LOOP_LAZYSV:
1472 case CXt_LOOP_PLAIN:
1473 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1481 S_dopoptogiven(pTHX_ I32 startingblock)
1485 for (i = startingblock; i >= 0; i--) {
1486 register const PERL_CONTEXT *cx = &cxstack[i];
1487 switch (CxTYPE(cx)) {
1491 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1493 case CXt_LOOP_PLAIN:
1494 assert(!CxFOREACHDEF(cx));
1496 case CXt_LOOP_LAZYIV:
1497 case CXt_LOOP_LAZYSV:
1499 if (CxFOREACHDEF(cx)) {
1500 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1509 S_dopoptowhen(pTHX_ I32 startingblock)
1513 for (i = startingblock; i >= 0; i--) {
1514 register const PERL_CONTEXT *cx = &cxstack[i];
1515 switch (CxTYPE(cx)) {
1519 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1527 Perl_dounwind(pTHX_ I32 cxix)
1532 while (cxstack_ix > cxix) {
1534 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1535 DEBUG_CX("UNWIND"); \
1536 /* Note: we don't need to restore the base context info till the end. */
1537 switch (CxTYPE(cx)) {
1540 continue; /* not break */
1548 case CXt_LOOP_LAZYIV:
1549 case CXt_LOOP_LAZYSV:
1551 case CXt_LOOP_PLAIN:
1562 PERL_UNUSED_VAR(optype);
1566 Perl_qerror(pTHX_ SV *err)
1570 PERL_ARGS_ASSERT_QERROR;
1573 sv_catsv(ERRSV, err);
1575 sv_catsv(PL_errors, err);
1577 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1579 ++PL_parser->error_count;
1583 Perl_die_unwind(pTHX_ SV *msv)
1586 SV *exceptsv = sv_mortalcopy(msv);
1587 U8 in_eval = PL_in_eval;
1588 PERL_ARGS_ASSERT_DIE_UNWIND;
1594 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1595 && PL_curstackinfo->si_prev)
1604 register PERL_CONTEXT *cx;
1607 if (cxix < cxstack_ix)
1610 POPBLOCK(cx,PL_curpm);
1611 if (CxTYPE(cx) != CXt_EVAL) {
1613 const char* message = SvPVx_const(exceptsv, msglen);
1614 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1615 PerlIO_write(Perl_error_log, message, msglen);
1619 namesv = cx->blk_eval.old_namesv;
1621 if (gimme == G_SCALAR)
1622 *++newsp = &PL_sv_undef;
1623 PL_stack_sp = newsp;
1627 /* LEAVE could clobber PL_curcop (see save_re_context())
1628 * XXX it might be better to find a way to avoid messing with
1629 * PL_curcop in save_re_context() instead, but this is a more
1630 * minimal fix --GSAR */
1631 PL_curcop = cx->blk_oldcop;
1633 if (optype == OP_REQUIRE) {
1634 const char* const msg = SvPVx_nolen_const(exceptsv);
1635 (void)hv_store(GvHVn(PL_incgv),
1636 SvPVX_const(namesv), SvCUR(namesv),
1638 /* note that unlike pp_entereval, pp_require isn't
1639 * supposed to trap errors. So now that we've popped the
1640 * EVAL that pp_require pushed, and processed the error
1641 * message, rethrow the error */
1642 Perl_croak(aTHX_ "%sCompilation failed in require",
1643 *msg ? msg : "Unknown error\n");
1645 if (in_eval & EVAL_KEEPERR) {
1646 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1647 SvPV_nolen_const(exceptsv));
1650 sv_setsv(ERRSV, exceptsv);
1652 assert(CxTYPE(cx) == CXt_EVAL);
1653 PL_restartjmpenv = cx->blk_eval.cur_top_env;
1654 PL_restartop = cx->blk_eval.retop;
1660 write_to_stderr(exceptsv);
1667 dVAR; dSP; dPOPTOPssrl;
1668 if (SvTRUE(left) != SvTRUE(right))
1675 =for apidoc caller_cx
1677 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1678 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1679 information returned to Perl by C<caller>. Note that XSUBs don't get a
1680 stack frame, so C<caller_cx(0, NULL)> will return information for the
1681 immediately-surrounding Perl code.
1683 This function skips over the automatic calls to C<&DB::sub> made on the
1684 behalf of the debugger. If the stack frame requested was a sub called by
1685 C<DB::sub>, the return value will be the frame for the call to
1686 C<DB::sub>, since that has the correct line number/etc. for the call
1687 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1688 frame for the sub call itself.
1693 const PERL_CONTEXT *
1694 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1696 register I32 cxix = dopoptosub(cxstack_ix);
1697 register const PERL_CONTEXT *cx;
1698 register const PERL_CONTEXT *ccstack = cxstack;
1699 const PERL_SI *top_si = PL_curstackinfo;
1702 /* we may be in a higher stacklevel, so dig down deeper */
1703 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1704 top_si = top_si->si_prev;
1705 ccstack = top_si->si_cxstack;
1706 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1710 /* caller() should not report the automatic calls to &DB::sub */
1711 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1712 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1716 cxix = dopoptosub_at(ccstack, cxix - 1);
1719 cx = &ccstack[cxix];
1720 if (dbcxp) *dbcxp = cx;
1722 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1723 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1724 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1725 field below is defined for any cx. */
1726 /* caller() should not report the automatic calls to &DB::sub */
1727 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1728 cx = &ccstack[dbcxix];
1738 register const PERL_CONTEXT *cx;
1739 const PERL_CONTEXT *dbcx;
1741 const char *stashname;
1747 cx = caller_cx(count, &dbcx);
1749 if (GIMME != G_ARRAY) {
1756 stashname = CopSTASHPV(cx->blk_oldcop);
1757 if (GIMME != G_ARRAY) {
1760 PUSHs(&PL_sv_undef);
1763 sv_setpv(TARG, stashname);
1772 PUSHs(&PL_sv_undef);
1774 mPUSHs(newSVpv(stashname, 0));
1775 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1776 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1779 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1780 GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1781 /* So is ccstack[dbcxix]. */
1783 SV * const sv = newSV(0);
1784 gv_efullname3(sv, cvgv, NULL);
1786 PUSHs(boolSV(CxHASARGS(cx)));
1789 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1790 PUSHs(boolSV(CxHASARGS(cx)));
1794 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1797 gimme = (I32)cx->blk_gimme;
1798 if (gimme == G_VOID)
1799 PUSHs(&PL_sv_undef);
1801 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1802 if (CxTYPE(cx) == CXt_EVAL) {
1804 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1805 PUSHs(cx->blk_eval.cur_text);
1809 else if (cx->blk_eval.old_namesv) {
1810 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1813 /* eval BLOCK (try blocks have old_namesv == 0) */
1815 PUSHs(&PL_sv_undef);
1816 PUSHs(&PL_sv_undef);
1820 PUSHs(&PL_sv_undef);
1821 PUSHs(&PL_sv_undef);
1823 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1824 && CopSTASH_eq(PL_curcop, PL_debstash))
1826 AV * const ary = cx->blk_sub.argarray;
1827 const int off = AvARRAY(ary) - AvALLOC(ary);
1830 Perl_init_dbargs(aTHX);
1832 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1833 av_extend(PL_dbargs, AvFILLp(ary) + off);
1834 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1835 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1837 /* XXX only hints propagated via op_private are currently
1838 * visible (others are not easily accessible, since they
1839 * use the global PL_hints) */
1840 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1843 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1845 if (old_warnings == pWARN_NONE ||
1846 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1847 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1848 else if (old_warnings == pWARN_ALL ||
1849 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1850 /* Get the bit mask for $warnings::Bits{all}, because
1851 * it could have been extended by warnings::register */
1853 HV * const bits = get_hv("warnings::Bits", 0);
1854 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1855 mask = newSVsv(*bits_all);
1858 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1862 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1866 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1867 sv_2mortal(newRV_noinc(
1868 MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1869 cx->blk_oldcop->cop_hints_hash))))
1878 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1879 sv_reset(tmps, CopSTASH(PL_curcop));
1884 /* like pp_nextstate, but used instead when the debugger is active */
1889 PL_curcop = (COP*)PL_op;
1890 TAINT_NOT; /* Each statement is presumed innocent */
1891 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1896 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1897 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1900 register PERL_CONTEXT *cx;
1901 const I32 gimme = G_ARRAY;
1903 GV * const gv = PL_DBgv;
1904 register CV * const cv = GvCV(gv);
1907 DIE(aTHX_ "No DB::DB routine defined");
1909 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1910 /* don't do recursive DB::DB call */
1925 (void)(*CvXSUB(cv))(aTHX_ cv);
1932 PUSHBLOCK(cx, CXt_SUB, SP);
1934 cx->blk_sub.retop = PL_op->op_next;
1937 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1938 RETURNOP(CvSTART(cv));
1948 register PERL_CONTEXT *cx;
1949 const I32 gimme = GIMME_V;
1950 void *itervar; /* location of the iteration variable */
1951 U8 cxtype = CXt_LOOP_FOR;
1953 ENTER_with_name("loop1");
1956 if (PL_op->op_targ) { /* "my" variable */
1957 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1958 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1959 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1960 SVs_PADSTALE, SVs_PADSTALE);
1962 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1964 itervar = PL_comppad;
1966 itervar = &PAD_SVl(PL_op->op_targ);
1969 else { /* symbol table variable */
1970 GV * const gv = MUTABLE_GV(POPs);
1971 SV** svp = &GvSV(gv);
1972 save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
1974 itervar = (void *)gv;
1977 if (PL_op->op_private & OPpITER_DEF)
1978 cxtype |= CXp_FOR_DEF;
1980 ENTER_with_name("loop2");
1982 PUSHBLOCK(cx, cxtype, SP);
1983 PUSHLOOP_FOR(cx, itervar, MARK);
1984 if (PL_op->op_flags & OPf_STACKED) {
1985 SV *maybe_ary = POPs;
1986 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1988 SV * const right = maybe_ary;
1991 if (RANGE_IS_NUMERIC(sv,right)) {
1992 cx->cx_type &= ~CXTYPEMASK;
1993 cx->cx_type |= CXt_LOOP_LAZYIV;
1994 /* Make sure that no-one re-orders cop.h and breaks our
1996 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1997 #ifdef NV_PRESERVES_UV
1998 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1999 (SvNV(sv) > (NV)IV_MAX)))
2001 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
2002 (SvNV(right) < (NV)IV_MIN))))
2004 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
2007 ((SvUV(sv) > (UV)IV_MAX) ||
2008 (SvNV(sv) > (NV)UV_MAX)))))
2010 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
2012 ((SvNV(right) > 0) &&
2013 ((SvUV(right) > (UV)IV_MAX) ||
2014 (SvNV(right) > (NV)UV_MAX))))))
2016 DIE(aTHX_ "Range iterator outside integer range");
2017 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
2018 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
2020 /* for correct -Dstv display */
2021 cx->blk_oldsp = sp - PL_stack_base;
2025 cx->cx_type &= ~CXTYPEMASK;
2026 cx->cx_type |= CXt_LOOP_LAZYSV;
2027 /* Make sure that no-one re-orders cop.h and breaks our
2029 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2030 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2031 cx->blk_loop.state_u.lazysv.end = right;
2032 SvREFCNT_inc(right);
2033 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2034 /* This will do the upgrade to SVt_PV, and warn if the value
2035 is uninitialised. */
2036 (void) SvPV_nolen_const(right);
2037 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2038 to replace !SvOK() with a pointer to "". */
2040 SvREFCNT_dec(right);
2041 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2045 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2046 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2047 SvREFCNT_inc(maybe_ary);
2048 cx->blk_loop.state_u.ary.ix =
2049 (PL_op->op_private & OPpITER_REVERSED) ?
2050 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2054 else { /* iterating over items on the stack */
2055 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2056 if (PL_op->op_private & OPpITER_REVERSED) {
2057 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2060 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2070 register PERL_CONTEXT *cx;
2071 const I32 gimme = GIMME_V;
2073 ENTER_with_name("loop1");
2075 ENTER_with_name("loop2");
2077 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2078 PUSHLOOP_PLAIN(cx, SP);
2086 register PERL_CONTEXT *cx;
2093 assert(CxTYPE_is_LOOP(cx));
2095 newsp = PL_stack_base + cx->blk_loop.resetsp;
2098 if (gimme == G_VOID)
2100 else if (gimme == G_SCALAR) {
2102 *++newsp = sv_mortalcopy(*SP);
2104 *++newsp = &PL_sv_undef;
2108 *++newsp = sv_mortalcopy(*++mark);
2109 TAINT_NOT; /* Each item is independent */
2115 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2116 PL_curpm = newpm; /* ... and pop $1 et al */
2118 LEAVE_with_name("loop2");
2119 LEAVE_with_name("loop1");
2127 register PERL_CONTEXT *cx;
2128 bool popsub2 = FALSE;
2129 bool clear_errsv = FALSE;
2138 const I32 cxix = dopoptosub(cxstack_ix);
2141 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2142 * sort block, which is a CXt_NULL
2145 PL_stack_base[1] = *PL_stack_sp;
2146 PL_stack_sp = PL_stack_base + 1;
2150 DIE(aTHX_ "Can't return outside a subroutine");
2152 if (cxix < cxstack_ix)
2155 if (CxMULTICALL(&cxstack[cxix])) {
2156 gimme = cxstack[cxix].blk_gimme;
2157 if (gimme == G_VOID)
2158 PL_stack_sp = PL_stack_base;
2159 else if (gimme == G_SCALAR) {
2160 PL_stack_base[1] = *PL_stack_sp;
2161 PL_stack_sp = PL_stack_base + 1;
2167 switch (CxTYPE(cx)) {
2170 retop = cx->blk_sub.retop;
2171 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2174 if (!(PL_in_eval & EVAL_KEEPERR))
2177 namesv = cx->blk_eval.old_namesv;
2178 retop = cx->blk_eval.retop;
2182 if (optype == OP_REQUIRE &&
2183 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2185 /* Unassume the success we assumed earlier. */
2186 (void)hv_delete(GvHVn(PL_incgv),
2187 SvPVX_const(namesv), SvCUR(namesv),
2189 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2194 retop = cx->blk_sub.retop;
2197 DIE(aTHX_ "panic: return");
2201 if (gimme == G_SCALAR) {
2204 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2206 *++newsp = SvREFCNT_inc(*SP);
2211 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2213 *++newsp = sv_mortalcopy(sv);
2218 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2221 *++newsp = sv_mortalcopy(*SP);
2224 *++newsp = &PL_sv_undef;
2226 else if (gimme == G_ARRAY) {
2227 while (++MARK <= SP) {
2228 *++newsp = (popsub2 && SvTEMP(*MARK))
2229 ? *MARK : sv_mortalcopy(*MARK);
2230 TAINT_NOT; /* Each item is independent */
2233 PL_stack_sp = newsp;
2236 /* Stack values are safe: */
2239 POPSUB(cx,sv); /* release CV and @_ ... */
2243 PL_curpm = newpm; /* ... and pop $1 et al */
2256 register PERL_CONTEXT *cx;
2267 if (PL_op->op_flags & OPf_SPECIAL) {
2268 cxix = dopoptoloop(cxstack_ix);
2270 DIE(aTHX_ "Can't \"last\" outside a loop block");
2273 cxix = dopoptolabel(cPVOP->op_pv);
2275 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2277 if (cxix < cxstack_ix)
2281 cxstack_ix++; /* temporarily protect top context */
2283 switch (CxTYPE(cx)) {
2284 case CXt_LOOP_LAZYIV:
2285 case CXt_LOOP_LAZYSV:
2287 case CXt_LOOP_PLAIN:
2289 newsp = PL_stack_base + cx->blk_loop.resetsp;
2290 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2294 nextop = cx->blk_sub.retop;
2298 nextop = cx->blk_eval.retop;
2302 nextop = cx->blk_sub.retop;
2305 DIE(aTHX_ "panic: last");
2309 if (gimme == G_SCALAR) {
2311 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2312 ? *SP : sv_mortalcopy(*SP);
2314 *++newsp = &PL_sv_undef;
2316 else if (gimme == G_ARRAY) {
2317 while (++MARK <= SP) {
2318 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2319 ? *MARK : sv_mortalcopy(*MARK);
2320 TAINT_NOT; /* Each item is independent */
2328 /* Stack values are safe: */
2330 case CXt_LOOP_LAZYIV:
2331 case CXt_LOOP_PLAIN:
2332 case CXt_LOOP_LAZYSV:
2334 POPLOOP(cx); /* release loop vars ... */
2338 POPSUB(cx,sv); /* release CV and @_ ... */
2341 PL_curpm = newpm; /* ... and pop $1 et al */
2344 PERL_UNUSED_VAR(optype);
2345 PERL_UNUSED_VAR(gimme);
2353 register PERL_CONTEXT *cx;
2356 if (PL_op->op_flags & OPf_SPECIAL) {
2357 cxix = dopoptoloop(cxstack_ix);
2359 DIE(aTHX_ "Can't \"next\" outside a loop block");
2362 cxix = dopoptolabel(cPVOP->op_pv);
2364 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2366 if (cxix < cxstack_ix)
2369 /* clear off anything above the scope we're re-entering, but
2370 * save the rest until after a possible continue block */
2371 inner = PL_scopestack_ix;
2373 if (PL_scopestack_ix < inner)
2374 leave_scope(PL_scopestack[PL_scopestack_ix]);
2375 PL_curcop = cx->blk_oldcop;
2376 return (cx)->blk_loop.my_op->op_nextop;
2383 register PERL_CONTEXT *cx;
2387 if (PL_op->op_flags & OPf_SPECIAL) {
2388 cxix = dopoptoloop(cxstack_ix);
2390 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2393 cxix = dopoptolabel(cPVOP->op_pv);
2395 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2397 if (cxix < cxstack_ix)
2400 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2401 if (redo_op->op_type == OP_ENTER) {
2402 /* pop one less context to avoid $x being freed in while (my $x..) */
2404 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2405 redo_op = redo_op->op_next;
2409 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2410 LEAVE_SCOPE(oldsave);
2412 PL_curcop = cx->blk_oldcop;
2417 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2421 static const char too_deep[] = "Target of goto is too deeply nested";
2423 PERL_ARGS_ASSERT_DOFINDLABEL;
2426 Perl_croak(aTHX_ too_deep);
2427 if (o->op_type == OP_LEAVE ||
2428 o->op_type == OP_SCOPE ||
2429 o->op_type == OP_LEAVELOOP ||
2430 o->op_type == OP_LEAVESUB ||
2431 o->op_type == OP_LEAVETRY)
2433 *ops++ = cUNOPo->op_first;
2435 Perl_croak(aTHX_ too_deep);
2438 if (o->op_flags & OPf_KIDS) {
2440 /* First try all the kids at this level, since that's likeliest. */
2441 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2442 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2443 const char *kid_label = CopLABEL(kCOP);
2444 if (kid_label && strEQ(kid_label, label))
2448 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2449 if (kid == PL_lastgotoprobe)
2451 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2454 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2455 ops[-1]->op_type == OP_DBSTATE)
2460 if ((o = dofindlabel(kid, label, ops, oplimit)))
2473 register PERL_CONTEXT *cx;
2474 #define GOTO_DEPTH 64
2475 OP *enterops[GOTO_DEPTH];
2476 const char *label = NULL;
2477 const bool do_dump = (PL_op->op_type == OP_DUMP);
2478 static const char must_have_label[] = "goto must have label";
2480 if (PL_op->op_flags & OPf_STACKED) {
2481 SV * const sv = POPs;
2483 /* This egregious kludge implements goto &subroutine */
2484 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2486 register PERL_CONTEXT *cx;
2487 CV *cv = MUTABLE_CV(SvRV(sv));
2494 if (!CvROOT(cv) && !CvXSUB(cv)) {
2495 const GV * const gv = CvGV(cv);
2499 /* autoloaded stub? */
2500 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2502 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2503 GvNAMELEN(gv), FALSE);
2504 if (autogv && (cv = GvCV(autogv)))
2506 tmpstr = sv_newmortal();
2507 gv_efullname3(tmpstr, gv, NULL);
2508 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2510 DIE(aTHX_ "Goto undefined subroutine");
2513 /* First do some returnish stuff. */
2514 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2516 cxix = dopoptosub(cxstack_ix);
2518 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2519 if (cxix < cxstack_ix)
2523 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2524 if (CxTYPE(cx) == CXt_EVAL) {
2526 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2528 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2530 else if (CxMULTICALL(cx))
2531 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2532 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2533 /* put @_ back onto stack */
2534 AV* av = cx->blk_sub.argarray;
2536 items = AvFILLp(av) + 1;
2537 EXTEND(SP, items+1); /* @_ could have been extended. */
2538 Copy(AvARRAY(av), SP + 1, items, SV*);
2539 SvREFCNT_dec(GvAV(PL_defgv));
2540 GvAV(PL_defgv) = cx->blk_sub.savearray;
2542 /* abandon @_ if it got reified */
2547 av_extend(av, items-1);
2549 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2552 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2553 AV* const av = GvAV(PL_defgv);
2554 items = AvFILLp(av) + 1;
2555 EXTEND(SP, items+1); /* @_ could have been extended. */
2556 Copy(AvARRAY(av), SP + 1, items, SV*);
2560 if (CxTYPE(cx) == CXt_SUB &&
2561 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2562 SvREFCNT_dec(cx->blk_sub.cv);
2563 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2564 LEAVE_SCOPE(oldsave);
2566 /* Now do some callish stuff. */
2568 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2570 OP* const retop = cx->blk_sub.retop;
2575 for (index=0; index<items; index++)
2576 sv_2mortal(SP[-index]);
2579 /* XS subs don't have a CxSUB, so pop it */
2580 POPBLOCK(cx, PL_curpm);
2581 /* Push a mark for the start of arglist */
2584 (void)(*CvXSUB(cv))(aTHX_ cv);
2589 AV* const padlist = CvPADLIST(cv);
2590 if (CxTYPE(cx) == CXt_EVAL) {
2591 PL_in_eval = CxOLD_IN_EVAL(cx);
2592 PL_eval_root = cx->blk_eval.old_eval_root;
2593 cx->cx_type = CXt_SUB;
2595 cx->blk_sub.cv = cv;
2596 cx->blk_sub.olddepth = CvDEPTH(cv);
2599 if (CvDEPTH(cv) < 2)
2600 SvREFCNT_inc_simple_void_NN(cv);
2602 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2603 sub_crush_depth(cv);
2604 pad_push(padlist, CvDEPTH(cv));
2607 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2610 AV *const av = MUTABLE_AV(PAD_SVl(0));
2612 cx->blk_sub.savearray = GvAV(PL_defgv);
2613 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2614 CX_CURPAD_SAVE(cx->blk_sub);
2615 cx->blk_sub.argarray = av;
2617 if (items >= AvMAX(av) + 1) {
2618 SV **ary = AvALLOC(av);
2619 if (AvARRAY(av) != ary) {
2620 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2623 if (items >= AvMAX(av) + 1) {
2624 AvMAX(av) = items - 1;
2625 Renew(ary,items+1,SV*);
2631 Copy(mark,AvARRAY(av),items,SV*);
2632 AvFILLp(av) = items - 1;
2633 assert(!AvREAL(av));
2635 /* transfer 'ownership' of refcnts to new @_ */
2645 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2646 Perl_get_db_sub(aTHX_ NULL, cv);
2648 CV * const gotocv = get_cvs("DB::goto", 0);
2650 PUSHMARK( PL_stack_sp );
2651 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2656 RETURNOP(CvSTART(cv));
2660 label = SvPV_nolen_const(sv);
2661 if (!(do_dump || *label))
2662 DIE(aTHX_ must_have_label);
2665 else if (PL_op->op_flags & OPf_SPECIAL) {
2667 DIE(aTHX_ must_have_label);
2670 label = cPVOP->op_pv;
2674 if (label && *label) {
2675 OP *gotoprobe = NULL;
2676 bool leaving_eval = FALSE;
2677 bool in_block = FALSE;
2678 PERL_CONTEXT *last_eval_cx = NULL;
2682 PL_lastgotoprobe = NULL;
2684 for (ix = cxstack_ix; ix >= 0; ix--) {
2686 switch (CxTYPE(cx)) {
2688 leaving_eval = TRUE;
2689 if (!CxTRYBLOCK(cx)) {
2690 gotoprobe = (last_eval_cx ?
2691 last_eval_cx->blk_eval.old_eval_root :
2696 /* else fall through */
2697 case CXt_LOOP_LAZYIV:
2698 case CXt_LOOP_LAZYSV:
2700 case CXt_LOOP_PLAIN:
2703 gotoprobe = cx->blk_oldcop->op_sibling;
2709 gotoprobe = cx->blk_oldcop->op_sibling;
2712 gotoprobe = PL_main_root;
2715 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2716 gotoprobe = CvROOT(cx->blk_sub.cv);
2722 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2725 DIE(aTHX_ "panic: goto");
2726 gotoprobe = PL_main_root;
2730 retop = dofindlabel(gotoprobe, label,
2731 enterops, enterops + GOTO_DEPTH);
2735 PL_lastgotoprobe = gotoprobe;
2738 DIE(aTHX_ "Can't find label %s", label);
2740 /* if we're leaving an eval, check before we pop any frames
2741 that we're not going to punt, otherwise the error
2744 if (leaving_eval && *enterops && enterops[1]) {
2746 for (i = 1; enterops[i]; i++)
2747 if (enterops[i]->op_type == OP_ENTERITER)
2748 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2751 if (*enterops && enterops[1]) {
2752 I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2754 deprecate("\"goto\" to jump into a construct");
2757 /* pop unwanted frames */
2759 if (ix < cxstack_ix) {
2766 oldsave = PL_scopestack[PL_scopestack_ix];
2767 LEAVE_SCOPE(oldsave);
2770 /* push wanted frames */
2772 if (*enterops && enterops[1]) {
2773 OP * const oldop = PL_op;
2774 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2775 for (; enterops[ix]; ix++) {
2776 PL_op = enterops[ix];
2777 /* Eventually we may want to stack the needed arguments
2778 * for each op. For now, we punt on the hard ones. */
2779 if (PL_op->op_type == OP_ENTERITER)
2780 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2781 PL_op->op_ppaddr(aTHX);
2789 if (!retop) retop = PL_main_start;
2791 PL_restartop = retop;
2792 PL_do_undump = TRUE;
2796 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2797 PL_do_undump = FALSE;
2814 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2816 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2819 PL_exit_flags |= PERL_EXIT_EXPECTED;
2821 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2822 if (anum || !(PL_minus_c && PL_madskills))
2827 PUSHs(&PL_sv_undef);
2834 S_save_lines(pTHX_ AV *array, SV *sv)
2836 const char *s = SvPVX_const(sv);
2837 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2840 PERL_ARGS_ASSERT_SAVE_LINES;
2842 while (s && s < send) {
2844 SV * const tmpstr = newSV_type(SVt_PVMG);
2846 t = (const char *)memchr(s, '\n', send - s);
2852 sv_setpvn(tmpstr, s, t - s);
2853 av_store(array, line++, tmpstr);
2861 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
2863 0 is used as continue inside eval,
2865 3 is used for a die caught by an inner eval - continue inner loop
2867 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
2868 establish a local jmpenv to handle exception traps.
2873 S_docatch(pTHX_ OP *o)
2877 OP * const oldop = PL_op;
2881 assert(CATCH_GET == TRUE);
2888 assert(cxstack_ix >= 0);
2889 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2890 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2895 /* die caught by an inner eval - continue inner loop */
2896 if (PL_restartop && PL_restartjmpenv == PL_top_env) {
2897 PL_restartjmpenv = NULL;
2898 PL_op = PL_restartop;
2914 /* James Bond: Do you expect me to talk?
2915 Auric Goldfinger: No, Mr. Bond. I expect you to die.
2917 This code is an ugly hack, doesn't work with lexicals in subroutines that are
2918 called more than once, and is only used by regcomp.c, for (?{}) blocks.
2920 Currently it is not used outside the core code. Best if it stays that way.
2923 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2924 /* sv Text to convert to OP tree. */
2925 /* startop op_free() this to undo. */
2926 /* code Short string id of the caller. */
2928 dVAR; dSP; /* Make POPBLOCK work. */
2934 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2935 char *tmpbuf = tbuf;
2938 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2942 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2944 ENTER_with_name("eval");
2945 lex_start(sv, NULL, FALSE);
2947 /* switch to eval mode */
2949 if (IN_PERL_COMPILETIME) {
2950 SAVECOPSTASH_FREE(&PL_compiling);
2951 CopSTASH_set(&PL_compiling, PL_curstash);
2953 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2954 SV * const sv = sv_newmortal();
2955 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2956 code, (unsigned long)++PL_evalseq,
2957 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2962 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2963 (unsigned long)++PL_evalseq);
2964 SAVECOPFILE_FREE(&PL_compiling);
2965 CopFILE_set(&PL_compiling, tmpbuf+2);
2966 SAVECOPLINE(&PL_compiling);
2967 CopLINE_set(&PL_compiling, 1);
2968 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2969 deleting the eval's FILEGV from the stash before gv_check() runs
2970 (i.e. before run-time proper). To work around the coredump that
2971 ensues, we always turn GvMULTI_on for any globals that were
2972 introduced within evals. See force_ident(). GSAR 96-10-12 */
2973 safestr = savepvn(tmpbuf, len);
2974 SAVEDELETE(PL_defstash, safestr, len);
2976 #ifdef OP_IN_REGISTER
2982 /* we get here either during compilation, or via pp_regcomp at runtime */
2983 runtime = IN_PERL_RUNTIME;
2985 runcv = find_runcv(NULL);
2988 PL_op->op_type = OP_ENTEREVAL;
2989 PL_op->op_flags = 0; /* Avoid uninit warning. */
2990 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2992 need_catch = CATCH_GET;
2996 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2998 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2999 CATCH_SET(need_catch);
3000 POPBLOCK(cx,PL_curpm);
3003 (*startop)->op_type = OP_NULL;
3004 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
3006 /* XXX DAPM do this properly one year */
3007 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
3008 LEAVE_with_name("eval");
3009 if (IN_PERL_COMPILETIME)
3010 CopHINTS_set(&PL_compiling, PL_hints);
3011 #ifdef OP_IN_REGISTER
3014 PERL_UNUSED_VAR(newsp);
3015 PERL_UNUSED_VAR(optype);
3017 return PL_eval_start;
3022 =for apidoc find_runcv
3024 Locate the CV corresponding to the currently executing sub or eval.
3025 If db_seqp is non_null, skip CVs that are in the DB package and populate
3026 *db_seqp with the cop sequence number at the point that the DB:: code was
3027 entered. (allows debuggers to eval in the scope of the breakpoint rather
3028 than in the scope of the debugger itself).
3034 Perl_find_runcv(pTHX_ U32 *db_seqp)
3040 *db_seqp = PL_curcop->cop_seq;
3041 for (si = PL_curstackinfo; si; si = si->si_prev) {
3043 for (ix = si->si_cxix; ix >= 0; ix--) {
3044 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3045 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3046 CV * const cv = cx->blk_sub.cv;
3047 /* skip DB:: code */
3048 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3049 *db_seqp = cx->blk_oldcop->cop_seq;
3054 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3062 /* Run yyparse() in a setjmp wrapper. Returns:
3063 * 0: yyparse() successful
3064 * 1: yyparse() failed
3068 S_try_yyparse(pTHX_ int gramtype)
3073 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3077 ret = yyparse(gramtype) ? 1 : 0;
3091 /* Compile a require/do, an eval '', or a /(?{...})/.
3092 * In the last case, startop is non-null, and contains the address of
3093 * a pointer that should be set to the just-compiled code.
3094 * outside is the lexically enclosing CV (if any) that invoked us.
3095 * Returns a bool indicating whether the compile was successful; if so,
3096 * PL_eval_start contains the first op of the compiled ocde; otherwise,
3097 * pushes undef (also croaks if startop != NULL).
3101 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3104 OP * const saveop = PL_op;
3105 bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3108 PL_in_eval = (in_require
3109 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3114 SAVESPTR(PL_compcv);
3115 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3116 CvEVAL_on(PL_compcv);
3117 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3118 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3120 CvOUTSIDE_SEQ(PL_compcv) = seq;
3121 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3123 /* set up a scratch pad */
3125 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3126 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3130 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3132 /* make sure we compile in the right package */
3134 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3135 SAVESPTR(PL_curstash);
3136 PL_curstash = CopSTASH(PL_curcop);
3138 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3139 SAVESPTR(PL_beginav);
3140 PL_beginav = newAV();
3141 SAVEFREESV(PL_beginav);
3142 SAVESPTR(PL_unitcheckav);
3143 PL_unitcheckav = newAV();
3144 SAVEFREESV(PL_unitcheckav);
3147 SAVEBOOL(PL_madskills);
3151 /* try to compile it */
3153 PL_eval_root = NULL;
3154 PL_curcop = &PL_compiling;
3155 CopARYBASE_set(PL_curcop, 0);
3156 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3157 PL_in_eval |= EVAL_KEEPERR;
3161 CALL_BLOCK_HOOKS(eval, saveop);
3163 /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3164 * so honour CATCH_GET and trap it here if necessary */
3166 yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3168 if (yystatus || PL_parser->error_count || !PL_eval_root) {
3169 SV **newsp; /* Used by POPBLOCK. */
3170 PERL_CONTEXT *cx = NULL;
3171 I32 optype; /* Used by POPEVAL. */
3175 PERL_UNUSED_VAR(newsp);
3176 PERL_UNUSED_VAR(optype);
3178 /* note that if yystatus == 3, then the EVAL CX block has already
3179 * been popped, and various vars restored */
3181 if (yystatus != 3) {
3183 op_free(PL_eval_root);
3184 PL_eval_root = NULL;
3186 SP = PL_stack_base + POPMARK; /* pop original mark */
3188 POPBLOCK(cx,PL_curpm);
3190 namesv = cx->blk_eval.old_namesv;
3195 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3197 msg = SvPVx_nolen_const(ERRSV);
3200 /* If cx is still NULL, it means that we didn't go in the
3201 * POPEVAL branch. */
3202 cx = &cxstack[cxstack_ix];
3203 assert(CxTYPE(cx) == CXt_EVAL);
3204 namesv = cx->blk_eval.old_namesv;
3206 (void)hv_store(GvHVn(PL_incgv),
3207 SvPVX_const(namesv), SvCUR(namesv),
3209 Perl_croak(aTHX_ "%sCompilation failed in require",
3210 *msg ? msg : "Unknown error\n");
3213 if (yystatus != 3) {
3214 POPBLOCK(cx,PL_curpm);
3217 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3218 (*msg ? msg : "Unknown error\n"));
3222 sv_setpvs(ERRSV, "Compilation error");
3225 PUSHs(&PL_sv_undef);
3229 CopLINE_set(&PL_compiling, 0);
3231 *startop = PL_eval_root;
3233 SAVEFREEOP(PL_eval_root);
3235 /* Set the context for this new optree.
3236 * Propagate the context from the eval(). */
3237 if ((gimme & G_WANT) == G_VOID)
3238 scalarvoid(PL_eval_root);
3239 else if ((gimme & G_WANT) == G_ARRAY)
3242 scalar(PL_eval_root);
3244 DEBUG_x(dump_eval());
3246 /* Register with debugger: */
3247 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3248 CV * const cv = get_cvs("DB::postponed", 0);
3252 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3254 call_sv(MUTABLE_SV(cv), G_DISCARD);
3258 if (PL_unitcheckav) {
3259 OP *es = PL_eval_start;
3260 call_list(PL_scopestack_ix, PL_unitcheckav);
3264 /* compiled okay, so do it */
3266 CvDEPTH(PL_compcv) = 1;
3267 SP = PL_stack_base + POPMARK; /* pop original mark */
3268 PL_op = saveop; /* The caller may need it. */
3269 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3276 S_check_type_and_open(pTHX_ const char *name)
3279 const int st_rc = PerlLIO_stat(name, &st);
3281 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3283 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3287 return PerlIO_open(name, PERL_SCRIPT_MODE);
3290 #ifndef PERL_DISABLE_PMC
3292 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3296 PERL_ARGS_ASSERT_DOOPEN_PM;
3298 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3299 SV *const pmcsv = newSV(namelen + 2);
3300 char *const pmc = SvPVX(pmcsv);
3303 memcpy(pmc, name, namelen);
3305 pmc[namelen + 1] = '\0';
3307 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3308 fp = check_type_and_open(name);
3311 fp = check_type_and_open(pmc);
3313 SvREFCNT_dec(pmcsv);
3316 fp = check_type_and_open(name);
3321 # define doopen_pm(name, namelen) check_type_and_open(name)
3322 #endif /* !PERL_DISABLE_PMC */
3327 register PERL_CONTEXT *cx;
3334 int vms_unixname = 0;
3336 const char *tryname = NULL;
3338 const I32 gimme = GIMME_V;
3339 int filter_has_file = 0;
3340 PerlIO *tryrsfp = NULL;
3341 SV *filter_cache = NULL;
3342 SV *filter_state = NULL;
3343 SV *filter_sub = NULL;
3349 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3350 sv = new_version(sv);
3351 if (!sv_derived_from(PL_patchlevel, "version"))
3352 upg_version(PL_patchlevel, TRUE);
3353 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3354 if ( vcmp(sv,PL_patchlevel) <= 0 )
3355 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3356 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3359 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3362 SV * const req = SvRV(sv);
3363 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3365 /* get the left hand term */
3366 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3368 first = SvIV(*av_fetch(lav,0,0));
3369 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3370 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3371 || av_len(lav) > 1 /* FP with > 3 digits */
3372 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3374 DIE(aTHX_ "Perl %"SVf" required--this is only "
3375 "%"SVf", stopped", SVfARG(vnormal(req)),
3376 SVfARG(vnormal(PL_patchlevel)));
3378 else { /* probably 'use 5.10' or 'use 5.8' */
3383 second = SvIV(*av_fetch(lav,1,0));
3385 second /= second >= 600 ? 100 : 10;
3386 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3387 (int)first, (int)second);
3388 upg_version(hintsv, TRUE);
3390 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3391 "--this is only %"SVf", stopped",
3392 SVfARG(vnormal(req)),
3393 SVfARG(vnormal(sv_2mortal(hintsv))),
3394 SVfARG(vnormal(PL_patchlevel)));
3399 /* We do this only with "use", not "require" or "no". */
3400 if (PL_compcv && !(cUNOP->op_first->op_private & OPpCONST_NOVER)) {
3401 /* If we request a version >= 5.9.5, load feature.pm with the
3402 * feature bundle that corresponds to the required version. */
3403 if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3404 SV *const importsv = vnormal(sv);
3405 *SvPVX_mutable(importsv) = ':';
3406 ENTER_with_name("load_feature");
3407 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3408 LEAVE_with_name("load_feature");
3410 /* If a version >= 5.11.0 is requested, strictures are on by default! */
3411 if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3412 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3418 name = SvPV_const(sv, len);
3419 if (!(name && len > 0 && *name))
3420 DIE(aTHX_ "Null filename used");
3421 TAINT_PROPER("require");
3425 /* The key in the %ENV hash is in the syntax of file passed as the argument
3426 * usually this is in UNIX format, but sometimes in VMS format, which
3427 * can result in a module being pulled in more than once.
3428 * To prevent this, the key must be stored in UNIX format if the VMS
3429 * name can be translated to UNIX.
3431 if ((unixname = tounixspec(name, NULL)) != NULL) {
3432 unixlen = strlen(unixname);
3438 /* if not VMS or VMS name can not be translated to UNIX, pass it
3441 unixname = (char *) name;
3444 if (PL_op->op_type == OP_REQUIRE) {
3445 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3446 unixname, unixlen, 0);
3448 if (*svp != &PL_sv_undef)
3451 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3452 "Compilation failed in require", unixname);
3456 /* prepare to compile file */
3458 if (path_is_absolute(name)) {
3460 tryrsfp = doopen_pm(name, len);
3463 AV * const ar = GvAVn(PL_incgv);
3469 namesv = newSV_type(SVt_PV);
3470 for (i = 0; i <= AvFILL(ar); i++) {
3471 SV * const dirsv = *av_fetch(ar, i, TRUE);
3473 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3480 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3481 && !sv_isobject(loader))
3483 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3486 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3487 PTR2UV(SvRV(dirsv)), name);
3488 tryname = SvPVX_const(namesv);
3491 ENTER_with_name("call_INC");
3499 if (sv_isobject(loader))
3500 count = call_method("INC", G_ARRAY);
3502 count = call_sv(loader, G_ARRAY);
3512 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3513 && !isGV_with_GP(SvRV(arg))) {
3514 filter_cache = SvRV(arg);
3515 SvREFCNT_inc_simple_void_NN(filter_cache);
3522 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3526 if (isGV_with_GP(arg)) {
3527 IO * const io = GvIO((const GV *)arg);
3532 tryrsfp = IoIFP(io);
3533 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3534 PerlIO_close(IoOFP(io));
3545 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3547 SvREFCNT_inc_simple_void_NN(filter_sub);
3550 filter_state = SP[i];
3551 SvREFCNT_inc_simple_void(filter_state);
3555 if (!tryrsfp && (filter_cache || filter_sub)) {
3556 tryrsfp = PerlIO_open(BIT_BUCKET,
3564 LEAVE_with_name("call_INC");
3566 /* Adjust file name if the hook has set an %INC entry.
3567 This needs to happen after the FREETMPS above. */
3568 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3570 tryname = SvPV_nolen_const(*svp);
3577 filter_has_file = 0;
3579 SvREFCNT_dec(filter_cache);
3580 filter_cache = NULL;
3583 SvREFCNT_dec(filter_state);
3584 filter_state = NULL;
3587 SvREFCNT_dec(filter_sub);
3592 if (!path_is_absolute(name)
3598 dir = SvPV_const(dirsv, dirlen);
3606 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3608 sv_setpv(namesv, unixdir);
3609 sv_catpv(namesv, unixname);
3611 # ifdef __SYMBIAN32__
3612 if (PL_origfilename[0] &&
3613 PL_origfilename[1] == ':' &&
3614 !(dir[0] && dir[1] == ':'))
3615 Perl_sv_setpvf(aTHX_ namesv,
3620 Perl_sv_setpvf(aTHX_ namesv,
3624 /* The equivalent of
3625 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3626 but without the need to parse the format string, or
3627 call strlen on either pointer, and with the correct
3628 allocation up front. */
3630 char *tmp = SvGROW(namesv, dirlen + len + 2);
3632 memcpy(tmp, dir, dirlen);
3635 /* name came from an SV, so it will have a '\0' at the
3636 end that we can copy as part of this memcpy(). */
3637 memcpy(tmp, name, len + 1);
3639 SvCUR_set(namesv, dirlen + len + 1);
3641 /* Don't even actually have to turn SvPOK_on() as we
3642 access it directly with SvPVX() below. */
3646 TAINT_PROPER("require");
3647 tryname = SvPVX_const(namesv);
3648 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3650 if (tryname[0] == '.' && tryname[1] == '/') {
3652 while (*++tryname == '/');
3656 else if (errno == EMFILE)
3657 /* no point in trying other paths if out of handles */
3665 SAVECOPFILE_FREE(&PL_compiling);
3666 CopFILE_set(&PL_compiling, tryname);
3668 SvREFCNT_dec(namesv);
3670 if (PL_op->op_type == OP_REQUIRE) {
3671 if(errno == EMFILE) {
3672 /* diag_listed_as: Can't locate %s */
3673 DIE(aTHX_ "Can't locate %s: %s", name, Strerror(errno));
3675 if (namesv) { /* did we lookup @INC? */
3676 AV * const ar = GvAVn(PL_incgv);
3678 SV *const inc = newSVpvs_flags("", SVs_TEMP);
3679 for (i = 0; i <= AvFILL(ar); i++) {
3680 sv_catpvs(inc, " ");
3681 sv_catsv(inc, *av_fetch(ar, i, TRUE));
3684 /* diag_listed_as: Can't locate %s */
3686 "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
3688 (memEQ(name + len - 2, ".h", 3)
3689 ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
3690 (memEQ(name + len - 3, ".ph", 4)
3691 ? " (did you run h2ph?)" : ""),
3696 DIE(aTHX_ "Can't locate %s", name);
3702 SETERRNO(0, SS_NORMAL);
3704 /* Assume success here to prevent recursive requirement. */
3705 /* name is never assigned to again, so len is still strlen(name) */
3706 /* Check whether a hook in @INC has already filled %INC */
3708 (void)hv_store(GvHVn(PL_incgv),
3709 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3711 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3713 (void)hv_store(GvHVn(PL_incgv),
3714 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3717 ENTER_with_name("eval");
3719 lex_start(NULL, tryrsfp, TRUE);
3723 hv_clear(GvHV(PL_hintgv));
3725 SAVECOMPILEWARNINGS();
3726 if (PL_dowarn & G_WARN_ALL_ON)
3727 PL_compiling.cop_warnings = pWARN_ALL ;
3728 else if (PL_dowarn & G_WARN_ALL_OFF)
3729 PL_compiling.cop_warnings = pWARN_NONE ;
3731 PL_compiling.cop_warnings = pWARN_STD ;
3733 if (filter_sub || filter_cache) {
3734 /* We can use the SvPV of the filter PVIO itself as our cache, rather
3735 than hanging another SV from it. In turn, filter_add() optionally
3736 takes the SV to use as the filter (or creates a new SV if passed
3737 NULL), so simply pass in whatever value filter_cache has. */
3738 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3739 IoLINES(datasv) = filter_has_file;
3740 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3741 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3744 /* switch to eval mode */
3745 PUSHBLOCK(cx, CXt_EVAL, SP);
3747 cx->blk_eval.retop = PL_op->op_next;
3749 SAVECOPLINE(&PL_compiling);
3750 CopLINE_set(&PL_compiling, 0);
3754 /* Store and reset encoding. */
3755 encoding = PL_encoding;
3758 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3759 op = DOCATCH(PL_eval_start);
3761 op = PL_op->op_next;
3763 /* Restore encoding. */
3764 PL_encoding = encoding;
3769 /* This is a op added to hold the hints hash for
3770 pp_entereval. The hash can be modified by the code
3771 being eval'ed, so we return a copy instead. */
3777 mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
3785 register PERL_CONTEXT *cx;
3787 const I32 gimme = GIMME_V;
3788 const U32 was = PL_breakable_sub_gen;
3789 char tbuf[TYPE_DIGITS(long) + 12];
3790 char *tmpbuf = tbuf;
3794 HV *saved_hh = NULL;
3796 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3797 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3801 /* make sure we've got a plain PV (no overload etc) before testing
3802 * for taint. Making a copy here is probably overkill, but better
3803 * safe than sorry */
3805 const char * const p = SvPV_const(sv, len);
3807 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
3810 TAINT_IF(SvTAINTED(sv));
3811 TAINT_PROPER("eval");
3813 ENTER_with_name("eval");
3814 lex_start(sv, NULL, FALSE);
3817 /* switch to eval mode */
3819 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3820 SV * const temp_sv = sv_newmortal();
3821 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3822 (unsigned long)++PL_evalseq,
3823 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3824 tmpbuf = SvPVX(temp_sv);
3825 len = SvCUR(temp_sv);
3828 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3829 SAVECOPFILE_FREE(&PL_compiling);
3830 CopFILE_set(&PL_compiling, tmpbuf+2);
3831 SAVECOPLINE(&PL_compiling);
3832 CopLINE_set(&PL_compiling, 1);
3833 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3834 deleting the eval's FILEGV from the stash before gv_check() runs
3835 (i.e. before run-time proper). To work around the coredump that
3836 ensues, we always turn GvMULTI_on for any globals that were
3837 introduced within evals. See force_ident(). GSAR 96-10-12 */
3839 PL_hints = PL_op->op_targ;
3841 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3842 SvREFCNT_dec(GvHV(PL_hintgv));
3843 GvHV(PL_hintgv) = saved_hh;
3845 SAVECOMPILEWARNINGS();
3846 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3847 if (PL_compiling.cop_hints_hash) {
3848 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3850 if (Perl_fetch_cop_label(aTHX_ PL_curcop, NULL, NULL)) {
3851 /* The label, if present, is the first entry on the chain. So rather
3852 than writing a blank label in front of it (which involves an
3853 allocation), just use the next entry in the chain. */
3854 PL_compiling.cop_hints_hash
3855 = PL_curcop->cop_hints_hash->refcounted_he_next;
3856 /* Check the assumption that this removed the label. */
3857 assert(Perl_fetch_cop_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3860 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3861 if (PL_compiling.cop_hints_hash) {
3863 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3864 HINTS_REFCNT_UNLOCK;
3866 /* special case: an eval '' executed within the DB package gets lexically
3867 * placed in the first non-DB CV rather than the current CV - this
3868 * allows the debugger to execute code, find lexicals etc, in the
3869 * scope of the code being debugged. Passing &seq gets find_runcv
3870 * to do the dirty work for us */
3871 runcv = find_runcv(&seq);
3873 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3875 cx->blk_eval.retop = PL_op->op_next;
3877 /* prepare to compile string */
3879 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3880 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3883 if (doeval(gimme, NULL, runcv, seq)) {
3884 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3885 ? (PERLDB_LINE || PERLDB_SAVESRC)
3886 : PERLDB_SAVESRC_NOSUBS) {
3887 /* Retain the filegv we created. */
3889 char *const safestr = savepvn(tmpbuf, len);
3890 SAVEDELETE(PL_defstash, safestr, len);
3892 return DOCATCH(PL_eval_start);
3894 /* We have already left the scope set up earler thanks to the LEAVE
3896 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3897 ? (PERLDB_LINE || PERLDB_SAVESRC)
3898 : PERLDB_SAVESRC_INVALID) {
3899 /* Retain the filegv we created. */
3901 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3903 return PL_op->op_next;
3914 register PERL_CONTEXT *cx;
3916 const U8 save_flags = PL_op -> op_flags;
3922 namesv = cx->blk_eval.old_namesv;
3923 retop = cx->blk_eval.retop;
3926 if (gimme == G_VOID)
3928 else if (gimme == G_SCALAR) {
3931 if (SvFLAGS(TOPs) & SVs_TEMP)
3934 *MARK = sv_mortalcopy(TOPs);
3938 *MARK = &PL_sv_undef;
3943 /* in case LEAVE wipes old return values */
3944 for (mark = newsp + 1; mark <= SP; mark++) {
3945 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3946 *mark = sv_mortalcopy(*mark);
3947 TAINT_NOT; /* Each item is independent */
3951 PL_curpm = newpm; /* Don't pop $1 et al till now */
3954 assert(CvDEPTH(PL_compcv) == 1);
3956 CvDEPTH(PL_compcv) = 0;
3959 if (optype == OP_REQUIRE &&
3960 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3962 /* Unassume the success we assumed earlier. */
3963 (void)hv_delete(GvHVn(PL_incgv),
3964 SvPVX_const(namesv), SvCUR(namesv),
3966 retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
3968 /* die_unwind() did LEAVE, or we won't be here */
3971 LEAVE_with_name("eval");
3972 if (!(save_flags & OPf_SPECIAL)) {
3980 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3981 close to the related Perl_create_eval_scope. */
3983 Perl_delete_eval_scope(pTHX)
3988 register PERL_CONTEXT *cx;
3994 LEAVE_with_name("eval_scope");
3995 PERL_UNUSED_VAR(newsp);
3996 PERL_UNUSED_VAR(gimme);
3997 PERL_UNUSED_VAR(optype);
4000 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4001 also needed by Perl_fold_constants. */
4003 Perl_create_eval_scope(pTHX_ U32 flags)
4006 const I32 gimme = GIMME_V;
4008 ENTER_with_name("eval_scope");
4011 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4014 PL_in_eval = EVAL_INEVAL;
4015 if (flags & G_KEEPERR)
4016 PL_in_eval |= EVAL_KEEPERR;
4019 if (flags & G_FAKINGEVAL) {
4020 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4028 PERL_CONTEXT * const cx = create_eval_scope(0);
4029 cx->blk_eval.retop = cLOGOP->op_other->op_next;
4030 return DOCATCH(PL_op->op_next);
4039 register PERL_CONTEXT *cx;
4044 PERL_UNUSED_VAR(optype);
4047 if (gimme == G_VOID)
4049 else if (gimme == G_SCALAR) {
4053 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4056 *MARK = sv_mortalcopy(TOPs);
4060 *MARK = &PL_sv_undef;
4065 /* in case LEAVE wipes old return values */
4067 for (mark = newsp + 1; mark <= SP; mark++) {
4068 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4069 *mark = sv_mortalcopy(*mark);
4070 TAINT_NOT; /* Each item is independent */
4074 PL_curpm = newpm; /* Don't pop $1 et al till now */
4076 LEAVE_with_name("eval_scope");
4084 register PERL_CONTEXT *cx;
4085 const I32 gimme = GIMME_V;
4087 ENTER_with_name("given");
4090 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
4092 PUSHBLOCK(cx, CXt_GIVEN, SP);
4101 register PERL_CONTEXT *cx;
4105 PERL_UNUSED_CONTEXT;
4108 assert(CxTYPE(cx) == CXt_GIVEN);
4111 if (gimme == G_VOID)
4113 else if (gimme == G_SCALAR) {
4117 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4120 *MARK = sv_mortalcopy(TOPs);
4124 *MARK = &PL_sv_undef;
4129 /* in case LEAVE wipes old return values */
4131 for (mark = newsp + 1; mark <= SP; mark++) {
4132 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4133 *mark = sv_mortalcopy(*mark);
4134 TAINT_NOT; /* Each item is independent */
4138 PL_curpm = newpm; /* Don't pop $1 et al till now */
4140 LEAVE_with_name("given");
4144 /* Helper routines used by pp_smartmatch */
4146 S_make_matcher(pTHX_ REGEXP *re)
4149 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4151 PERL_ARGS_ASSERT_MAKE_MATCHER;
4153 PM_SETRE(matcher, ReREFCNT_inc(re));
4155 SAVEFREEOP((OP *) matcher);
4156 ENTER_with_name("matcher"); SAVETMPS;
4162 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4167 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4169 PL_op = (OP *) matcher;
4174 return (SvTRUEx(POPs));
4178 S_destroy_matcher(pTHX_ PMOP *matcher)
4182 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4183 PERL_UNUSED_ARG(matcher);
4186 LEAVE_with_name("matcher");
4189 /* Do a smart match */
4192 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4193 return do_smartmatch(NULL, NULL);
4196 /* This version of do_smartmatch() implements the
4197 * table of smart matches that is found in perlsyn.
4200 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4205 bool object_on_left = FALSE;
4206 SV *e = TOPs; /* e is for 'expression' */
4207 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4209 /* Take care only to invoke mg_get() once for each argument.
4210 * Currently we do this by copying the SV if it's magical. */
4213 d = sv_mortalcopy(d);
4220 e = sv_mortalcopy(e);
4222 /* First of all, handle overload magic of the rightmost argument */
4225 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4226 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4228 tmpsv = amagic_call(d, e, smart_amg, 0);
4235 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4238 SP -= 2; /* Pop the values */
4243 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4250 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4251 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4252 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4254 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4255 object_on_left = TRUE;
4258 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4260 if (object_on_left) {
4261 goto sm_any_sub; /* Treat objects like scalars */
4263 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4264 /* Test sub truth for each key */
4266 bool andedresults = TRUE;
4267 HV *hv = (HV*) SvRV(d);
4268 I32 numkeys = hv_iterinit(hv);
4269 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4272 while ( (he = hv_iternext(hv)) ) {
4273 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4274 ENTER_with_name("smartmatch_hash_key_test");
4277 PUSHs(hv_iterkeysv(he));
4279 c = call_sv(e, G_SCALAR);
4282 andedresults = FALSE;
4284 andedresults = SvTRUEx(POPs) && andedresults;
4286 LEAVE_with_name("smartmatch_hash_key_test");
4293 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4294 /* Test sub truth for each element */
4296 bool andedresults = TRUE;
4297 AV *av = (AV*) SvRV(d);
4298 const I32 len = av_len(av);
4299 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4302 for (i = 0; i <= len; ++i) {
4303 SV * const * const svp = av_fetch(av, i, FALSE);
4304 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4305 ENTER_with_name("smartmatch_array_elem_test");
4311 c = call_sv(e, G_SCALAR);
4314 andedresults = FALSE;
4316 andedresults = SvTRUEx(POPs) && andedresults;
4318 LEAVE_with_name("smartmatch_array_elem_test");
4327 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4328 ENTER_with_name("smartmatch_coderef");
4333 c = call_sv(e, G_SCALAR);
4337 else if (SvTEMP(TOPs))
4338 SvREFCNT_inc_void(TOPs);
4340 LEAVE_with_name("smartmatch_coderef");
4345 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4346 if (object_on_left) {
4347 goto sm_any_hash; /* Treat objects like scalars */
4349 else if (!SvOK(d)) {
4350 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4353 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4354 /* Check that the key-sets are identical */
4356 HV *other_hv = MUTABLE_HV(SvRV(d));
4358 bool other_tied = FALSE;
4359 U32 this_key_count = 0,
4360 other_key_count = 0;
4361 HV *hv = MUTABLE_HV(SvRV(e));
4363 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4364 /* Tied hashes don't know how many keys they have. */
4365 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4368 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4369 HV * const temp = other_hv;
4374 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4377 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4380 /* The hashes have the same number of keys, so it suffices
4381 to check that one is a subset of the other. */
4382 (void) hv_iterinit(hv);
4383 while ( (he = hv_iternext(hv)) ) {
4384 SV *key = hv_iterkeysv(he);
4386 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4389 if(!hv_exists_ent(other_hv, key, 0)) {
4390 (void) hv_iterinit(hv); /* reset iterator */
4396 (void) hv_iterinit(other_hv);
4397 while ( hv_iternext(other_hv) )
4401 other_key_count = HvUSEDKEYS(other_hv);
4403 if (this_key_count != other_key_count)
4408 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4409 AV * const other_av = MUTABLE_AV(SvRV(d));
4410 const I32 other_len = av_len(other_av) + 1;
4412 HV *hv = MUTABLE_HV(SvRV(e));
4414 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4415 for (i = 0; i < other_len; ++i) {
4416 SV ** const svp = av_fetch(other_av, i, FALSE);
4417 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4418 if (svp) { /* ??? When can this not happen? */
4419 if (hv_exists_ent(hv, *svp, 0))
4425 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4426 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4429 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4431 HV *hv = MUTABLE_HV(SvRV(e));
4433 (void) hv_iterinit(hv);
4434 while ( (he = hv_iternext(hv)) ) {
4435 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4436 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4437 (void) hv_iterinit(hv);
4438 destroy_matcher(matcher);
4442 destroy_matcher(matcher);
4448 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4449 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4456 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4457 if (object_on_left) {
4458 goto sm_any_array; /* Treat objects like scalars */
4460 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4461 AV * const other_av = MUTABLE_AV(SvRV(e));
4462 const I32 other_len = av_len(other_av) + 1;
4465 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4466 for (i = 0; i < other_len; ++i) {
4467 SV ** const svp = av_fetch(other_av, i, FALSE);
4469 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4470 if (svp) { /* ??? When can this not happen? */
4471 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4477 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4478 AV *other_av = MUTABLE_AV(SvRV(d));
4479 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4480 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4484 const I32 other_len = av_len(other_av);
4486 if (NULL == seen_this) {
4487 seen_this = newHV();
4488 (void) sv_2mortal(MUTABLE_SV(seen_this));
4490 if (NULL == seen_other) {
4491 seen_other = newHV();
4492 (void) sv_2mortal(MUTABLE_SV(seen_other));
4494 for(i = 0; i <= other_len; ++i) {
4495 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4496 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4498 if (!this_elem || !other_elem) {
4499 if ((this_elem && SvOK(*this_elem))
4500 || (other_elem && SvOK(*other_elem)))
4503 else if (hv_exists_ent(seen_this,
4504 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4505 hv_exists_ent(seen_other,
4506 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4508 if (*this_elem != *other_elem)
4512 (void)hv_store_ent(seen_this,
4513 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4515 (void)hv_store_ent(seen_other,
4516 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4522 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4523 (void) do_smartmatch(seen_this, seen_other);
4525 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4534 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4535 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4538 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4539 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4542 for(i = 0; i <= this_len; ++i) {
4543 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4544 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4545 if (svp && matcher_matches_sv(matcher, *svp)) {
4546 destroy_matcher(matcher);
4550 destroy_matcher(matcher);
4554 else if (!SvOK(d)) {
4555 /* undef ~~ array */
4556 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4559 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4560 for (i = 0; i <= this_len; ++i) {
4561 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4562 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4563 if (!svp || !SvOK(*svp))
4572 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4574 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4575 for (i = 0; i <= this_len; ++i) {
4576 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4583 /* infinite recursion isn't supposed to happen here */
4584 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4585 (void) do_smartmatch(NULL, NULL);
4587 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4596 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4597 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4598 SV *t = d; d = e; e = t;
4599 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4602 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4603 SV *t = d; d = e; e = t;
4604 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4605 goto sm_regex_array;
4608 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4610 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4612 PUSHs(matcher_matches_sv(matcher, d)
4615 destroy_matcher(matcher);
4620 /* See if there is overload magic on left */
4621 else if (object_on_left && SvAMAGIC(d)) {
4623 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4624 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4627 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4635 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4638 else if (!SvOK(d)) {
4639 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4640 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4645 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4646 DEBUG_M(if (SvNIOK(e))
4647 Perl_deb(aTHX_ " applying rule Any-Num\n");
4649 Perl_deb(aTHX_ " applying rule Num-numish\n");
4651 /* numeric comparison */
4654 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4665 /* As a last resort, use string comparison */
4666 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4675 register PERL_CONTEXT *cx;
4676 const I32 gimme = GIMME_V;
4678 /* This is essentially an optimization: if the match
4679 fails, we don't want to push a context and then
4680 pop it again right away, so we skip straight
4681 to the op that follows the leavewhen.
4682 RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4684 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4685 RETURNOP(cLOGOP->op_other->op_next);
4687 ENTER_with_name("eval");
4690 PUSHBLOCK(cx, CXt_WHEN, SP);
4699 register PERL_CONTEXT *cx;
4705 assert(CxTYPE(cx) == CXt_WHEN);
4710 PL_curpm = newpm; /* pop $1 et al */
4712 LEAVE_with_name("eval");
4720 register PERL_CONTEXT *cx;
4723 cxix = dopoptowhen(cxstack_ix);
4725 DIE(aTHX_ "Can't \"continue\" outside a when block");
4726 if (cxix < cxstack_ix)
4729 /* clear off anything above the scope we're re-entering */
4730 inner = PL_scopestack_ix;
4732 if (PL_scopestack_ix < inner)
4733 leave_scope(PL_scopestack[PL_scopestack_ix]);
4734 PL_curcop = cx->blk_oldcop;
4735 return cx->blk_givwhen.leave_op;
4742 register PERL_CONTEXT *cx;
4746 cxix = dopoptogiven(cxstack_ix);
4748 if (PL_op->op_flags & OPf_SPECIAL)
4749 DIE(aTHX_ "Can't use when() outside a topicalizer");
4751 DIE(aTHX_ "Can't \"break\" outside a given block");
4753 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4754 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4756 if (cxix < cxstack_ix)
4759 /* clear off anything above the scope we're re-entering */
4760 inner = PL_scopestack_ix;
4762 if (PL_scopestack_ix < inner)
4763 leave_scope(PL_scopestack[PL_scopestack_ix]);
4764 PL_curcop = cx->blk_oldcop;
4767 return (cx)->blk_loop.my_op->op_nextop;
4769 /* RETURNOP calls PUTBACK which restores the old old sp */
4770 RETURNOP(cx->blk_givwhen.leave_op);
4774 S_doparseform(pTHX_ SV *sv)
4777 register char *s = SvPV_force(sv, len);
4778 register char * const send = s + len;
4779 register char *base = NULL;
4780 register I32 skipspaces = 0;
4781 bool noblank = FALSE;
4782 bool repeat = FALSE;
4783 bool postspace = FALSE;
4789 bool unchopnum = FALSE;
4790 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4792 PERL_ARGS_ASSERT_DOPARSEFORM;
4795 Perl_croak(aTHX_ "Null picture in formline");
4797 /* estimate the buffer size needed */
4798 for (base = s; s <= send; s++) {
4799 if (*s == '\n' || *s == '@' || *s == '^')
4805 Newx(fops, maxops, U32);
4810 *fpc++ = FF_LINEMARK;
4811 noblank = repeat = FALSE;
4829 case ' ': case '\t':
4836 } /* else FALL THROUGH */
4844 *fpc++ = FF_LITERAL;
4852 *fpc++ = (U16)skipspaces;
4856 *fpc++ = FF_NEWLINE;
4860 arg = fpc - linepc + 1;
4867 *fpc++ = FF_LINEMARK;
4868 noblank = repeat = FALSE;
4877 ischop = s[-1] == '^';
4883 arg = (s - base) - 1;
4885 *fpc++ = FF_LITERAL;
4893 *fpc++ = 2; /* skip the @* or ^* */
4895 *fpc++ = FF_LINESNGL;
4898 *fpc++ = FF_LINEGLOB;
4900 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4901 arg = ischop ? 512 : 0;
4906 const char * const f = ++s;
4909 arg |= 256 + (s - f);
4911 *fpc++ = s - base; /* fieldsize for FETCH */
4912 *fpc++ = FF_DECIMAL;
4914 unchopnum |= ! ischop;
4916 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4917 arg = ischop ? 512 : 0;
4919 s++; /* skip the '0' first */
4923 const char * const f = ++s;
4926 arg |= 256 + (s - f);
4928 *fpc++ = s - base; /* fieldsize for FETCH */
4929 *fpc++ = FF_0DECIMAL;
4931 unchopnum |= ! ischop;
4935 bool ismore = FALSE;
4938 while (*++s == '>') ;
4939 prespace = FF_SPACE;
4941 else if (*s == '|') {
4942 while (*++s == '|') ;
4943 prespace = FF_HALFSPACE;
4948 while (*++s == '<') ;
4951 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4955 *fpc++ = s - base; /* fieldsize for FETCH */
4957 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4960 *fpc++ = (U16)prespace;
4974 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4976 { /* need to jump to the next word */
4978 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4979 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4980 s = SvPVX(sv) + SvCUR(sv) + z;
4982 Copy(fops, s, arg, U32);
4984 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4987 if (unchopnum && repeat)
4988 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4994 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4996 /* Can value be printed in fldsize chars, using %*.*f ? */
5000 int intsize = fldsize - (value < 0 ? 1 : 0);
5007 while (intsize--) pwr *= 10.0;
5008 while (frcsize--) eps /= 10.0;
5011 if (value + eps >= pwr)
5014 if (value - eps <= -pwr)
5021 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5024 SV * const datasv = FILTER_DATA(idx);
5025 const int filter_has_file = IoLINES(datasv);
5026 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5027 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5032 char *prune_from = NULL;
5033 bool read_from_cache = FALSE;
5036 PERL_ARGS_ASSERT_RUN_USER_FILTER;
5038 assert(maxlen >= 0);
5041 /* I was having segfault trouble under Linux 2.2.5 after a
5042 parse error occured. (Had to hack around it with a test
5043 for PL_parser->error_count == 0.) Solaris doesn't segfault --
5044 not sure where the trouble is yet. XXX */
5047 SV *const cache = datasv;
5050 const char *cache_p = SvPV(cache, cache_len);
5054 /* Running in block mode and we have some cached data already.
5056 if (cache_len >= umaxlen) {
5057 /* In fact, so much data we don't even need to call
5062 const char *const first_nl =
5063 (const char *)memchr(cache_p, '\n', cache_len);
5065 take = first_nl + 1 - cache_p;
5069 sv_catpvn(buf_sv, cache_p, take);
5070 sv_chop(cache, cache_p + take);
5071 /* Definately not EOF */
5075 sv_catsv(buf_sv, cache);
5077 umaxlen -= cache_len;
5080 read_from_cache = TRUE;
5084 /* Filter API says that the filter appends to the contents of the buffer.
5085 Usually the buffer is "", so the details don't matter. But if it's not,
5086 then clearly what it contains is already filtered by this filter, so we
5087 don't want to pass it in a second time.
5088 I'm going to use a mortal in case the upstream filter croaks. */
5089 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5090 ? sv_newmortal() : buf_sv;
5091 SvUPGRADE(upstream, SVt_PV);
5093 if (filter_has_file) {
5094 status = FILTER_READ(idx+1, upstream, 0);
5097 if (filter_sub && status >= 0) {
5101 ENTER_with_name("call_filter_sub");
5106 DEFSV_set(upstream);
5110 PUSHs(filter_state);
5113 count = call_sv(filter_sub, G_SCALAR);
5125 LEAVE_with_name("call_filter_sub");
5128 if(SvOK(upstream)) {
5129 got_p = SvPV(upstream, got_len);
5131 if (got_len > umaxlen) {
5132 prune_from = got_p + umaxlen;
5135 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5136 if (first_nl && first_nl + 1 < got_p + got_len) {
5137 /* There's a second line here... */
5138 prune_from = first_nl + 1;
5143 /* Oh. Too long. Stuff some in our cache. */
5144 STRLEN cached_len = got_p + got_len - prune_from;
5145 SV *const cache = datasv;
5148 /* Cache should be empty. */
5149 assert(!SvCUR(cache));
5152 sv_setpvn(cache, prune_from, cached_len);
5153 /* If you ask for block mode, you may well split UTF-8 characters.
5154 "If it breaks, you get to keep both parts"
5155 (Your code is broken if you don't put them back together again
5156 before something notices.) */
5157 if (SvUTF8(upstream)) {
5160 SvCUR_set(upstream, got_len - cached_len);
5162 /* Can't yet be EOF */
5167 /* If they are at EOF but buf_sv has something in it, then they may never
5168 have touched the SV upstream, so it may be undefined. If we naively
5169 concatenate it then we get a warning about use of uninitialised value.
5171 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5172 sv_catsv(buf_sv, upstream);
5176 IoLINES(datasv) = 0;
5178 SvREFCNT_dec(filter_state);
5179 IoTOP_GV(datasv) = NULL;
5182 SvREFCNT_dec(filter_sub);
5183 IoBOTTOM_GV(datasv) = NULL;
5185 filter_del(S_run_user_filter);
5187 if (status == 0 && read_from_cache) {
5188 /* If we read some data from the cache (and by getting here it implies
5189 that we emptied the cache) then we aren't yet at EOF, and mustn't
5190 report that to our caller. */
5196 /* perhaps someone can come up with a better name for
5197 this? it is not really "absolute", per se ... */
5199 S_path_is_absolute(const char *name)
5201 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5203 if (PERL_FILE_IS_ABSOLUTE(name)
5205 || (*name == '.' && ((name[1] == '/' ||
5206 (name[1] == '.' && name[2] == '/'))
5207 || (name[1] == '\\' ||
5208 ( name[1] == '.' && name[2] == '\\')))
5211 || (*name == '.' && (name[1] == '/' ||
5212 (name[1] == '.' && name[2] == '/')))
5224 * c-indentation-style: bsd
5226 * indent-tabs-mode: t
5229 * ex: set ts=8 sts=4 sw=4 noet: