3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
19 * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains control-oriented pp ("push/pop") functions that
23 * execute the opcodes that make up a perl program. A typical pp function
24 * expects to find its arguments on the stack, and usually pushes its
25 * results onto the stack, hence the 'pp' terminology. Each OP structure
26 * contains a pointer to the relevant pp_foo() function.
28 * Control-oriented means things like pp_enteriter() and pp_next(), which
29 * alter the flow of control of the program.
34 #define PERL_IN_PP_CTL_C
38 #define WORD_ALIGN sizeof(U32)
41 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
43 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
52 cxix = dopoptosub(cxstack_ix);
56 switch (cxstack[cxix].blk_gimme) {
69 /* XXXX Should store the old value to allow for tie/overload - and
70 restore in regcomp, where marked with XXXX. */
80 register PMOP *pm = (PMOP*)cLOGOP->op_other;
84 /* prevent recompiling under /o and ithreads. */
85 #if defined(USE_ITHREADS)
86 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
87 if (PL_op->op_flags & OPf_STACKED) {
97 #define tryAMAGICregexp(rx) \
99 if (SvROK(rx) && SvAMAGIC(rx)) { \
100 SV *sv = AMG_CALLun(rx, regexp); \
104 if (SvTYPE(sv) != SVt_REGEXP) \
105 Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
112 if (PL_op->op_flags & OPf_STACKED) {
113 /* multiple args; concatentate them */
115 tmpstr = PAD_SV(ARGTARG);
116 sv_setpvs(tmpstr, "");
117 while (++MARK <= SP) {
119 if (PL_amagic_generation) {
122 tryAMAGICregexp(msv);
124 if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
125 (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
127 sv_setsv(tmpstr, sv);
131 sv_catsv(tmpstr, msv);
138 tryAMAGICregexp(tmpstr);
141 #undef tryAMAGICregexp
144 SV * const sv = SvRV(tmpstr);
145 if (SvTYPE(sv) == SVt_REGEXP)
148 else if (SvTYPE(tmpstr) == SVt_REGEXP)
149 re = (REGEXP*) tmpstr;
152 re = reg_temp_copy(NULL, re);
153 ReREFCNT_dec(PM_GETRE(pm));
158 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
160 assert (re != (REGEXP*) &PL_sv_undef);
162 /* Check against the last compiled regexp. */
163 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
164 memNE(RX_PRECOMP(re), t, len))
166 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
167 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
171 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
173 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
175 } else if (PL_curcop->cop_hints_hash) {
176 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
178 if (ptr && SvIOK(ptr) && SvIV(ptr))
179 eng = INT2PTR(regexp_engine*,SvIV(ptr));
182 if (PL_op->op_flags & OPf_SPECIAL)
183 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
185 if (DO_UTF8(tmpstr)) {
186 assert (SvUTF8(tmpstr));
187 } else if (SvUTF8(tmpstr)) {
188 /* Not doing UTF-8, despite what the SV says. Is this only if
189 we're trapped in use 'bytes'? */
190 /* Make a copy of the octet sequence, but without the flag on,
191 as the compiler now honours the SvUTF8 flag on tmpstr. */
193 const char *const p = SvPV(tmpstr, len);
194 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
198 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
200 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
202 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
203 inside tie/overload accessors. */
209 #ifndef INCOMPLETE_TAINTS
212 RX_EXTFLAGS(re) |= RXf_TAINTED;
214 RX_EXTFLAGS(re) &= ~RXf_TAINTED;
218 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
222 #if !defined(USE_ITHREADS)
223 /* can't change the optree at runtime either */
224 /* PMf_KEEP is handled differently under threads to avoid these problems */
225 if (pm->op_pmflags & PMf_KEEP) {
226 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
227 cLOGOP->op_first->op_next = PL_op->op_next;
237 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
238 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
239 register SV * const dstr = cx->sb_dstr;
240 register char *s = cx->sb_s;
241 register char *m = cx->sb_m;
242 char *orig = cx->sb_orig;
243 register REGEXP * const rx = cx->sb_rx;
245 REGEXP *old = PM_GETRE(pm);
249 PM_SETRE(pm,ReREFCNT_inc(rx));
252 rxres_restore(&cx->sb_rxres, rx);
253 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
255 if (cx->sb_iters++) {
256 const I32 saviters = cx->sb_iters;
257 if (cx->sb_iters > cx->sb_maxiters)
258 DIE(aTHX_ "Substitution loop");
260 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
261 cx->sb_rxtainted |= 2;
262 sv_catsv(dstr, POPs);
263 /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
267 if (CxONCE(cx) || s < orig ||
268 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
269 (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
270 ((cx->sb_rflags & REXEC_COPY_STR)
271 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
272 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
274 SV * const targ = cx->sb_targ;
276 assert(cx->sb_strend >= s);
277 if(cx->sb_strend > s) {
278 if (DO_UTF8(dstr) && !SvUTF8(targ))
279 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
281 sv_catpvn(dstr, s, cx->sb_strend - s);
283 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
285 #ifdef PERL_OLD_COPY_ON_WRITE
287 sv_force_normal_flags(targ, SV_COW_DROP_PV);
293 SvPV_set(targ, SvPVX(dstr));
294 SvCUR_set(targ, SvCUR(dstr));
295 SvLEN_set(targ, SvLEN(dstr));
298 SvPV_set(dstr, NULL);
300 TAINT_IF(cx->sb_rxtainted & 1);
301 mPUSHi(saviters - 1);
303 (void)SvPOK_only_UTF8(targ);
304 TAINT_IF(cx->sb_rxtainted);
308 LEAVE_SCOPE(cx->sb_oldsave);
310 RETURNOP(pm->op_next);
312 cx->sb_iters = saviters;
314 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
317 cx->sb_orig = orig = RX_SUBBEG(rx);
319 cx->sb_strend = s + (cx->sb_strend - m);
321 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
323 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
324 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
326 sv_catpvn(dstr, s, m-s);
328 cx->sb_s = RX_OFFS(rx)[0].end + orig;
329 { /* Update the pos() information. */
330 SV * const sv = cx->sb_targ;
332 SvUPGRADE(sv, SVt_PVMG);
333 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
334 #ifdef PERL_OLD_COPY_ON_WRITE
336 sv_force_normal_flags(sv, 0);
338 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
341 mg->mg_len = m - orig;
344 (void)ReREFCNT_inc(rx);
345 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
346 rxres_save(&cx->sb_rxres, rx);
347 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
351 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
356 PERL_ARGS_ASSERT_RXRES_SAVE;
359 if (!p || p[1] < RX_NPARENS(rx)) {
360 #ifdef PERL_OLD_COPY_ON_WRITE
361 i = 7 + RX_NPARENS(rx) * 2;
363 i = 6 + RX_NPARENS(rx) * 2;
372 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
373 RX_MATCH_COPIED_off(rx);
375 #ifdef PERL_OLD_COPY_ON_WRITE
376 *p++ = PTR2UV(RX_SAVED_COPY(rx));
377 RX_SAVED_COPY(rx) = NULL;
380 *p++ = RX_NPARENS(rx);
382 *p++ = PTR2UV(RX_SUBBEG(rx));
383 *p++ = (UV)RX_SUBLEN(rx);
384 for (i = 0; i <= RX_NPARENS(rx); ++i) {
385 *p++ = (UV)RX_OFFS(rx)[i].start;
386 *p++ = (UV)RX_OFFS(rx)[i].end;
391 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
396 PERL_ARGS_ASSERT_RXRES_RESTORE;
399 RX_MATCH_COPY_FREE(rx);
400 RX_MATCH_COPIED_set(rx, *p);
403 #ifdef PERL_OLD_COPY_ON_WRITE
404 if (RX_SAVED_COPY(rx))
405 SvREFCNT_dec (RX_SAVED_COPY(rx));
406 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
410 RX_NPARENS(rx) = *p++;
412 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
413 RX_SUBLEN(rx) = (I32)(*p++);
414 for (i = 0; i <= RX_NPARENS(rx); ++i) {
415 RX_OFFS(rx)[i].start = (I32)(*p++);
416 RX_OFFS(rx)[i].end = (I32)(*p++);
421 S_rxres_free(pTHX_ void **rsp)
423 UV * const p = (UV*)*rsp;
425 PERL_ARGS_ASSERT_RXRES_FREE;
430 void *tmp = INT2PTR(char*,*p);
433 PoisonFree(*p, 1, sizeof(*p));
435 Safefree(INT2PTR(char*,*p));
437 #ifdef PERL_OLD_COPY_ON_WRITE
439 SvREFCNT_dec (INT2PTR(SV*,p[1]));
449 dVAR; dSP; dMARK; dORIGMARK;
450 register SV * const tmpForm = *++MARK;
455 register SV *sv = NULL;
456 const char *item = NULL;
460 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
461 const char *chophere = NULL;
462 char *linemark = NULL;
464 bool gotsome = FALSE;
466 const STRLEN fudge = SvPOK(tmpForm)
467 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
468 bool item_is_utf8 = FALSE;
469 bool targ_is_utf8 = FALSE;
471 OP * parseres = NULL;
474 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
475 if (SvREADONLY(tmpForm)) {
476 SvREADONLY_off(tmpForm);
477 parseres = doparseform(tmpForm);
478 SvREADONLY_on(tmpForm);
481 parseres = doparseform(tmpForm);
485 SvPV_force(PL_formtarget, len);
486 if (DO_UTF8(PL_formtarget))
488 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
490 f = SvPV_const(tmpForm, len);
491 /* need to jump to the next word */
492 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
496 const char *name = "???";
499 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
500 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
501 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
502 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
503 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
505 case FF_CHECKNL: name = "CHECKNL"; break;
506 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
507 case FF_SPACE: name = "SPACE"; break;
508 case FF_HALFSPACE: name = "HALFSPACE"; break;
509 case FF_ITEM: name = "ITEM"; break;
510 case FF_CHOP: name = "CHOP"; break;
511 case FF_LINEGLOB: name = "LINEGLOB"; break;
512 case FF_NEWLINE: name = "NEWLINE"; break;
513 case FF_MORE: name = "MORE"; break;
514 case FF_LINEMARK: name = "LINEMARK"; break;
515 case FF_END: name = "END"; break;
516 case FF_0DECIMAL: name = "0DECIMAL"; break;
517 case FF_LINESNGL: name = "LINESNGL"; break;
520 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
522 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
533 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
534 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
536 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
537 t = SvEND(PL_formtarget);
541 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
542 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
544 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
545 t = SvEND(PL_formtarget);
565 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
572 const char *s = item = SvPV_const(sv, len);
575 itemsize = sv_len_utf8(sv);
576 if (itemsize != (I32)len) {
578 if (itemsize > fieldsize) {
579 itemsize = fieldsize;
580 itembytes = itemsize;
581 sv_pos_u2b(sv, &itembytes, 0);
585 send = chophere = s + itembytes;
595 sv_pos_b2u(sv, &itemsize);
599 item_is_utf8 = FALSE;
600 if (itemsize > fieldsize)
601 itemsize = fieldsize;
602 send = chophere = s + itemsize;
616 const char *s = item = SvPV_const(sv, len);
619 itemsize = sv_len_utf8(sv);
620 if (itemsize != (I32)len) {
622 if (itemsize <= fieldsize) {
623 const char *send = chophere = s + itemsize;
636 itemsize = fieldsize;
637 itembytes = itemsize;
638 sv_pos_u2b(sv, &itembytes, 0);
639 send = chophere = s + itembytes;
640 while (s < send || (s == send && isSPACE(*s))) {
650 if (strchr(PL_chopset, *s))
655 itemsize = chophere - item;
656 sv_pos_b2u(sv, &itemsize);
662 item_is_utf8 = FALSE;
663 if (itemsize <= fieldsize) {
664 const char *const send = chophere = s + itemsize;
677 itemsize = fieldsize;
678 send = chophere = s + itemsize;
679 while (s < send || (s == send && isSPACE(*s))) {
689 if (strchr(PL_chopset, *s))
694 itemsize = chophere - item;
700 arg = fieldsize - itemsize;
709 arg = fieldsize - itemsize;
720 const char *s = item;
724 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
726 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
728 t = SvEND(PL_formtarget);
732 if (UTF8_IS_CONTINUED(*s)) {
733 STRLEN skip = UTF8SKIP(s);
750 if ( !((*t++ = *s++) & ~31) )
756 if (targ_is_utf8 && !item_is_utf8) {
757 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
759 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
760 for (; t < SvEND(PL_formtarget); t++) {
773 const int ch = *t++ = *s++;
776 if ( !((*t++ = *s++) & ~31) )
785 const char *s = chophere;
799 const bool oneline = fpc[-1] == FF_LINESNGL;
800 const char *s = item = SvPV_const(sv, len);
801 item_is_utf8 = DO_UTF8(sv);
804 STRLEN to_copy = itemsize;
805 const char *const send = s + len;
806 const U8 *source = (const U8 *) s;
810 chophere = s + itemsize;
814 to_copy = s - SvPVX_const(sv) - 1;
826 if (targ_is_utf8 && !item_is_utf8) {
827 source = tmp = bytes_to_utf8(source, &to_copy);
828 SvCUR_set(PL_formtarget,
829 t - SvPVX_const(PL_formtarget));
831 if (item_is_utf8 && !targ_is_utf8) {
832 /* Upgrade targ to UTF8, and then we reduce it to
833 a problem we have a simple solution for. */
834 SvCUR_set(PL_formtarget,
835 t - SvPVX_const(PL_formtarget));
837 /* Don't need get magic. */
838 sv_utf8_upgrade_nomg(PL_formtarget);
840 SvCUR_set(PL_formtarget,
841 t - SvPVX_const(PL_formtarget));
844 /* Easy. They agree. */
845 assert (item_is_utf8 == targ_is_utf8);
847 SvGROW(PL_formtarget,
848 SvCUR(PL_formtarget) + to_copy + fudge + 1);
849 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
851 Copy(source, t, to_copy, char);
853 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
855 if (SvGMAGICAL(sv)) {
856 /* Mustn't call sv_pos_b2u() as it does a second
857 mg_get(). Is this a bug? Do we need a _flags()
859 itemsize = utf8_length(source, source + itemsize);
861 sv_pos_b2u(sv, &itemsize);
873 #if defined(USE_LONG_DOUBLE)
876 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
880 "%#0*.*f" : "%0*.*f");
885 #if defined(USE_LONG_DOUBLE)
887 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
890 ((arg & 256) ? "%#*.*f" : "%*.*f");
893 /* If the field is marked with ^ and the value is undefined,
895 if ((arg & 512) && !SvOK(sv)) {
903 /* overflow evidence */
904 if (num_overflow(value, fieldsize, arg)) {
910 /* Formats aren't yet marked for locales, so assume "yes". */
912 STORE_NUMERIC_STANDARD_SET_LOCAL();
913 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
914 RESTORE_NUMERIC_STANDARD();
921 while (t-- > linemark && *t == ' ') ;
929 if (arg) { /* repeat until fields exhausted? */
931 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
932 lines += FmLINES(PL_formtarget);
934 SvUTF8_on(PL_formtarget);
935 FmLINES(PL_formtarget) = lines;
937 RETURNOP(cLISTOP->op_first);
948 const char *s = chophere;
949 const char *send = item + len;
951 while (isSPACE(*s) && (s < send))
956 arg = fieldsize - itemsize;
963 if (strnEQ(s1," ",3)) {
964 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
975 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
977 SvUTF8_on(PL_formtarget);
978 FmLINES(PL_formtarget) += lines;
990 if (PL_stack_base + *PL_markstack_ptr == SP) {
992 if (GIMME_V == G_SCALAR)
994 RETURNOP(PL_op->op_next->op_next);
996 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
997 pp_pushmark(); /* push dst */
998 pp_pushmark(); /* push src */
999 ENTER_with_name("grep"); /* enter outer scope */
1002 if (PL_op->op_private & OPpGREP_LEX)
1003 SAVESPTR(PAD_SVl(PL_op->op_targ));
1006 ENTER_with_name("grep_item"); /* enter inner scope */
1009 src = PL_stack_base[*PL_markstack_ptr];
1011 if (PL_op->op_private & OPpGREP_LEX)
1012 PAD_SVl(PL_op->op_targ) = src;
1017 if (PL_op->op_type == OP_MAPSTART)
1018 pp_pushmark(); /* push top */
1019 return ((LOGOP*)PL_op->op_next)->op_other;
1025 const I32 gimme = GIMME_V;
1026 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1032 /* first, move source pointer to the next item in the source list */
1033 ++PL_markstack_ptr[-1];
1035 /* if there are new items, push them into the destination list */
1036 if (items && gimme != G_VOID) {
1037 /* might need to make room back there first */
1038 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1039 /* XXX this implementation is very pessimal because the stack
1040 * is repeatedly extended for every set of items. Is possible
1041 * to do this without any stack extension or copying at all
1042 * by maintaining a separate list over which the map iterates
1043 * (like foreach does). --gsar */
1045 /* everything in the stack after the destination list moves
1046 * towards the end the stack by the amount of room needed */
1047 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1049 /* items to shift up (accounting for the moved source pointer) */
1050 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1052 /* This optimization is by Ben Tilly and it does
1053 * things differently from what Sarathy (gsar)
1054 * is describing. The downside of this optimization is
1055 * that leaves "holes" (uninitialized and hopefully unused areas)
1056 * to the Perl stack, but on the other hand this
1057 * shouldn't be a problem. If Sarathy's idea gets
1058 * implemented, this optimization should become
1059 * irrelevant. --jhi */
1061 shift = count; /* Avoid shifting too often --Ben Tilly */
1065 dst = (SP += shift);
1066 PL_markstack_ptr[-1] += shift;
1067 *PL_markstack_ptr += shift;
1071 /* copy the new items down to the destination list */
1072 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1073 if (gimme == G_ARRAY) {
1075 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1078 /* scalar context: we don't care about which values map returns
1079 * (we use undef here). And so we certainly don't want to do mortal
1080 * copies of meaningless values. */
1081 while (items-- > 0) {
1083 *dst-- = &PL_sv_undef;
1087 LEAVE_with_name("grep_item"); /* exit inner scope */
1090 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1092 (void)POPMARK; /* pop top */
1093 LEAVE_with_name("grep"); /* exit outer scope */
1094 (void)POPMARK; /* pop src */
1095 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1096 (void)POPMARK; /* pop dst */
1097 SP = PL_stack_base + POPMARK; /* pop original mark */
1098 if (gimme == G_SCALAR) {
1099 if (PL_op->op_private & OPpGREP_LEX) {
1100 SV* sv = sv_newmortal();
1101 sv_setiv(sv, items);
1109 else if (gimme == G_ARRAY)
1116 ENTER_with_name("grep_item"); /* enter inner scope */
1119 /* set $_ to the new source item */
1120 src = PL_stack_base[PL_markstack_ptr[-1]];
1122 if (PL_op->op_private & OPpGREP_LEX)
1123 PAD_SVl(PL_op->op_targ) = src;
1127 RETURNOP(cLOGOP->op_other);
1136 if (GIMME == G_ARRAY)
1138 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1139 return cLOGOP->op_other;
1149 if (GIMME == G_ARRAY) {
1150 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1154 SV * const targ = PAD_SV(PL_op->op_targ);
1157 if (PL_op->op_private & OPpFLIP_LINENUM) {
1158 if (GvIO(PL_last_in_gv)) {
1159 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1162 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1164 flip = SvIV(sv) == SvIV(GvSV(gv));
1170 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1171 if (PL_op->op_flags & OPf_SPECIAL) {
1179 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1182 sv_setpvs(TARG, "");
1188 /* This code tries to decide if "$left .. $right" should use the
1189 magical string increment, or if the range is numeric (we make
1190 an exception for .."0" [#18165]). AMS 20021031. */
1192 #define RANGE_IS_NUMERIC(left,right) ( \
1193 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1194 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1195 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1196 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1197 && (!SvOK(right) || looks_like_number(right))))
1203 if (GIMME == G_ARRAY) {
1209 if (RANGE_IS_NUMERIC(left,right)) {
1212 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1213 (SvOK(right) && SvNV(right) > IV_MAX))
1214 DIE(aTHX_ "Range iterator outside integer range");
1225 SV * const sv = sv_2mortal(newSViv(i++));
1230 SV * const final = sv_mortalcopy(right);
1232 const char * const tmps = SvPV_const(final, len);
1234 SV *sv = sv_mortalcopy(left);
1235 SvPV_force_nolen(sv);
1236 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1238 if (strEQ(SvPVX_const(sv),tmps))
1240 sv = sv_2mortal(newSVsv(sv));
1247 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1251 if (PL_op->op_private & OPpFLIP_LINENUM) {
1252 if (GvIO(PL_last_in_gv)) {
1253 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1256 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1257 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1265 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1266 sv_catpvs(targ, "E0");
1276 static const char * const context_name[] = {
1278 NULL, /* CXt_WHEN never actually needs "block" */
1279 NULL, /* CXt_BLOCK never actually needs "block" */
1280 NULL, /* CXt_GIVEN never actually needs "block" */
1281 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1282 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1283 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1284 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1292 S_dopoptolabel(pTHX_ const char *label)
1297 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1299 for (i = cxstack_ix; i >= 0; i--) {
1300 register const PERL_CONTEXT * const cx = &cxstack[i];
1301 switch (CxTYPE(cx)) {
1307 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1308 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1309 if (CxTYPE(cx) == CXt_NULL)
1312 case CXt_LOOP_LAZYIV:
1313 case CXt_LOOP_LAZYSV:
1315 case CXt_LOOP_PLAIN:
1316 if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
1317 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1318 (long)i, CxLABEL(cx)));
1321 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1331 Perl_dowantarray(pTHX)
1334 const I32 gimme = block_gimme();
1335 return (gimme == G_VOID) ? G_SCALAR : gimme;
1339 Perl_block_gimme(pTHX)
1342 const I32 cxix = dopoptosub(cxstack_ix);
1346 switch (cxstack[cxix].blk_gimme) {
1354 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1361 Perl_is_lvalue_sub(pTHX)
1364 const I32 cxix = dopoptosub(cxstack_ix);
1365 assert(cxix >= 0); /* We should only be called from inside subs */
1367 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1368 return CxLVAL(cxstack + cxix);
1374 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1379 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1381 for (i = startingblock; i >= 0; i--) {
1382 register const PERL_CONTEXT * const cx = &cxstk[i];
1383 switch (CxTYPE(cx)) {
1389 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1397 S_dopoptoeval(pTHX_ I32 startingblock)
1401 for (i = startingblock; i >= 0; i--) {
1402 register const PERL_CONTEXT *cx = &cxstack[i];
1403 switch (CxTYPE(cx)) {
1407 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1415 S_dopoptoloop(pTHX_ I32 startingblock)
1419 for (i = startingblock; i >= 0; i--) {
1420 register const PERL_CONTEXT * const cx = &cxstack[i];
1421 switch (CxTYPE(cx)) {
1427 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1428 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1429 if ((CxTYPE(cx)) == CXt_NULL)
1432 case CXt_LOOP_LAZYIV:
1433 case CXt_LOOP_LAZYSV:
1435 case CXt_LOOP_PLAIN:
1436 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1444 S_dopoptogiven(pTHX_ I32 startingblock)
1448 for (i = startingblock; i >= 0; i--) {
1449 register const PERL_CONTEXT *cx = &cxstack[i];
1450 switch (CxTYPE(cx)) {
1454 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1456 case CXt_LOOP_PLAIN:
1457 assert(!CxFOREACHDEF(cx));
1459 case CXt_LOOP_LAZYIV:
1460 case CXt_LOOP_LAZYSV:
1462 if (CxFOREACHDEF(cx)) {
1463 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1472 S_dopoptowhen(pTHX_ I32 startingblock)
1476 for (i = startingblock; i >= 0; i--) {
1477 register const PERL_CONTEXT *cx = &cxstack[i];
1478 switch (CxTYPE(cx)) {
1482 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1490 Perl_dounwind(pTHX_ I32 cxix)
1495 while (cxstack_ix > cxix) {
1497 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1498 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1499 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1500 /* Note: we don't need to restore the base context info till the end. */
1501 switch (CxTYPE(cx)) {
1504 continue; /* not break */
1512 case CXt_LOOP_LAZYIV:
1513 case CXt_LOOP_LAZYSV:
1515 case CXt_LOOP_PLAIN:
1526 PERL_UNUSED_VAR(optype);
1530 Perl_qerror(pTHX_ SV *err)
1534 PERL_ARGS_ASSERT_QERROR;
1537 sv_catsv(ERRSV, err);
1539 sv_catsv(PL_errors, err);
1541 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1543 ++PL_parser->error_count;
1547 Perl_die_where(pTHX_ SV *msv)
1556 if (PL_in_eval & EVAL_KEEPERR) {
1557 static const char prefix[] = "\t(in cleanup) ";
1558 SV * const err = ERRSV;
1559 const char *e = NULL;
1562 else if (SvCUR(err) >= sizeof(prefix)+SvCUR(msv)-1) {
1565 const char* message = SvPV_const(msv, msglen);
1566 e = SvPV_const(err, len);
1568 if (*e != *message || strNE(e,message))
1573 SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(msv));
1574 sv_catpvn(err, prefix, sizeof(prefix)-1);
1576 start = SvCUR(err)-SvCUR(msv)-sizeof(prefix)+1;
1577 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s",
1578 SvPVX_const(err)+start);
1583 const char* message = SvPV_const(msv, msglen);
1584 sv_setpvn(ERRSV, message, msglen);
1585 SvFLAGS(ERRSV) |= SvFLAGS(msv) & SVf_UTF8;
1589 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1590 && PL_curstackinfo->si_prev)
1598 register PERL_CONTEXT *cx;
1601 if (cxix < cxstack_ix)
1604 POPBLOCK(cx,PL_curpm);
1605 if (CxTYPE(cx) != CXt_EVAL) {
1607 const char* message = SvPVx_const( msv ? msv : ERRSV, msglen);
1608 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1609 PerlIO_write(Perl_error_log, message, msglen);
1614 if (gimme == G_SCALAR)
1615 *++newsp = &PL_sv_undef;
1616 PL_stack_sp = newsp;
1620 /* LEAVE could clobber PL_curcop (see save_re_context())
1621 * XXX it might be better to find a way to avoid messing with
1622 * PL_curcop in save_re_context() instead, but this is a more
1623 * minimal fix --GSAR */
1624 PL_curcop = cx->blk_oldcop;
1626 if (optype == OP_REQUIRE) {
1627 const char* const msg = SvPVx_nolen_const(ERRSV);
1628 SV * const nsv = cx->blk_eval.old_namesv;
1629 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1631 DIE(aTHX_ "%sCompilation failed in require",
1632 *msg ? msg : "Unknown error\n");
1634 assert(CxTYPE(cx) == CXt_EVAL);
1635 PL_restartop = cx->blk_eval.retop;
1641 write_to_stderr( msv ? msv : ERRSV );
1648 dVAR; dSP; dPOPTOPssrl;
1649 if (SvTRUE(left) != SvTRUE(right))
1659 register I32 cxix = dopoptosub(cxstack_ix);
1660 register const PERL_CONTEXT *cx;
1661 register const PERL_CONTEXT *ccstack = cxstack;
1662 const PERL_SI *top_si = PL_curstackinfo;
1664 const char *stashname;
1671 /* we may be in a higher stacklevel, so dig down deeper */
1672 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1673 top_si = top_si->si_prev;
1674 ccstack = top_si->si_cxstack;
1675 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1678 if (GIMME != G_ARRAY) {
1684 /* caller() should not report the automatic calls to &DB::sub */
1685 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1686 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1690 cxix = dopoptosub_at(ccstack, cxix - 1);
1693 cx = &ccstack[cxix];
1694 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1695 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1696 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1697 field below is defined for any cx. */
1698 /* caller() should not report the automatic calls to &DB::sub */
1699 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1700 cx = &ccstack[dbcxix];
1703 stashname = CopSTASHPV(cx->blk_oldcop);
1704 if (GIMME != G_ARRAY) {
1707 PUSHs(&PL_sv_undef);
1710 sv_setpv(TARG, stashname);
1719 PUSHs(&PL_sv_undef);
1721 mPUSHs(newSVpv(stashname, 0));
1722 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1723 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1726 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1727 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1728 /* So is ccstack[dbcxix]. */
1730 SV * const sv = newSV(0);
1731 gv_efullname3(sv, cvgv, NULL);
1733 PUSHs(boolSV(CxHASARGS(cx)));
1736 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1737 PUSHs(boolSV(CxHASARGS(cx)));
1741 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1744 gimme = (I32)cx->blk_gimme;
1745 if (gimme == G_VOID)
1746 PUSHs(&PL_sv_undef);
1748 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1749 if (CxTYPE(cx) == CXt_EVAL) {
1751 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1752 PUSHs(cx->blk_eval.cur_text);
1756 else if (cx->blk_eval.old_namesv) {
1757 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1760 /* eval BLOCK (try blocks have old_namesv == 0) */
1762 PUSHs(&PL_sv_undef);
1763 PUSHs(&PL_sv_undef);
1767 PUSHs(&PL_sv_undef);
1768 PUSHs(&PL_sv_undef);
1770 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1771 && CopSTASH_eq(PL_curcop, PL_debstash))
1773 AV * const ary = cx->blk_sub.argarray;
1774 const int off = AvARRAY(ary) - AvALLOC(ary);
1777 PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
1779 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1782 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1783 av_extend(PL_dbargs, AvFILLp(ary) + off);
1784 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1785 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1787 /* XXX only hints propagated via op_private are currently
1788 * visible (others are not easily accessible, since they
1789 * use the global PL_hints) */
1790 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1793 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1795 if (old_warnings == pWARN_NONE ||
1796 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1797 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1798 else if (old_warnings == pWARN_ALL ||
1799 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1800 /* Get the bit mask for $warnings::Bits{all}, because
1801 * it could have been extended by warnings::register */
1803 HV * const bits = get_hv("warnings::Bits", 0);
1804 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1805 mask = newSVsv(*bits_all);
1808 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1812 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1816 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1817 sv_2mortal(newRV_noinc(
1818 MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1819 cx->blk_oldcop->cop_hints_hash))))
1828 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1829 sv_reset(tmps, CopSTASH(PL_curcop));
1834 /* like pp_nextstate, but used instead when the debugger is active */
1839 PL_curcop = (COP*)PL_op;
1840 TAINT_NOT; /* Each statement is presumed innocent */
1841 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1844 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1845 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1848 register PERL_CONTEXT *cx;
1849 const I32 gimme = G_ARRAY;
1851 GV * const gv = PL_DBgv;
1852 register CV * const cv = GvCV(gv);
1855 DIE(aTHX_ "No DB::DB routine defined");
1857 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1858 /* don't do recursive DB::DB call */
1861 ENTER_with_name("sub");
1873 (void)(*CvXSUB(cv))(aTHX_ cv);
1876 LEAVE_with_name("sub");
1880 PUSHBLOCK(cx, CXt_SUB, SP);
1882 cx->blk_sub.retop = PL_op->op_next;
1885 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1886 RETURNOP(CvSTART(cv));
1896 register PERL_CONTEXT *cx;
1897 const I32 gimme = GIMME_V;
1899 U8 cxtype = CXt_LOOP_FOR;
1904 ENTER_with_name("loop1");
1907 if (PL_op->op_targ) {
1908 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1909 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1910 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1911 SVs_PADSTALE, SVs_PADSTALE);
1913 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1914 #ifndef USE_ITHREADS
1915 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1921 GV * const gv = MUTABLE_GV(POPs);
1922 svp = &GvSV(gv); /* symbol table variable */
1923 SAVEGENERICSV(*svp);
1926 iterdata = (PAD*)gv;
1930 if (PL_op->op_private & OPpITER_DEF)
1931 cxtype |= CXp_FOR_DEF;
1933 ENTER_with_name("loop2");
1935 PUSHBLOCK(cx, cxtype, SP);
1937 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1939 PUSHLOOP_FOR(cx, svp, MARK, 0);
1941 if (PL_op->op_flags & OPf_STACKED) {
1942 SV *maybe_ary = POPs;
1943 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1945 SV * const right = maybe_ary;
1948 if (RANGE_IS_NUMERIC(sv,right)) {
1949 cx->cx_type &= ~CXTYPEMASK;
1950 cx->cx_type |= CXt_LOOP_LAZYIV;
1951 /* Make sure that no-one re-orders cop.h and breaks our
1953 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1954 #ifdef NV_PRESERVES_UV
1955 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1956 (SvNV(sv) > (NV)IV_MAX)))
1958 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1959 (SvNV(right) < (NV)IV_MIN))))
1961 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1964 ((SvUV(sv) > (UV)IV_MAX) ||
1965 (SvNV(sv) > (NV)UV_MAX)))))
1967 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1969 ((SvNV(right) > 0) &&
1970 ((SvUV(right) > (UV)IV_MAX) ||
1971 (SvNV(right) > (NV)UV_MAX))))))
1973 DIE(aTHX_ "Range iterator outside integer range");
1974 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1975 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1977 /* for correct -Dstv display */
1978 cx->blk_oldsp = sp - PL_stack_base;
1982 cx->cx_type &= ~CXTYPEMASK;
1983 cx->cx_type |= CXt_LOOP_LAZYSV;
1984 /* Make sure that no-one re-orders cop.h and breaks our
1986 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
1987 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
1988 cx->blk_loop.state_u.lazysv.end = right;
1989 SvREFCNT_inc(right);
1990 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
1991 /* This will do the upgrade to SVt_PV, and warn if the value
1992 is uninitialised. */
1993 (void) SvPV_nolen_const(right);
1994 /* Doing this avoids a check every time in pp_iter in pp_hot.c
1995 to replace !SvOK() with a pointer to "". */
1997 SvREFCNT_dec(right);
1998 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2002 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2003 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2004 SvREFCNT_inc(maybe_ary);
2005 cx->blk_loop.state_u.ary.ix =
2006 (PL_op->op_private & OPpITER_REVERSED) ?
2007 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2011 else { /* iterating over items on the stack */
2012 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2013 if (PL_op->op_private & OPpITER_REVERSED) {
2014 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2017 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2027 register PERL_CONTEXT *cx;
2028 const I32 gimme = GIMME_V;
2030 ENTER_with_name("loop1");
2032 ENTER_with_name("loop2");
2034 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2035 PUSHLOOP_PLAIN(cx, SP);
2043 register PERL_CONTEXT *cx;
2050 assert(CxTYPE_is_LOOP(cx));
2052 newsp = PL_stack_base + cx->blk_loop.resetsp;
2055 if (gimme == G_VOID)
2057 else if (gimme == G_SCALAR) {
2059 *++newsp = sv_mortalcopy(*SP);
2061 *++newsp = &PL_sv_undef;
2065 *++newsp = sv_mortalcopy(*++mark);
2066 TAINT_NOT; /* Each item is independent */
2072 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2073 PL_curpm = newpm; /* ... and pop $1 et al */
2075 LEAVE_with_name("loop2");
2076 LEAVE_with_name("loop1");
2084 register PERL_CONTEXT *cx;
2085 bool popsub2 = FALSE;
2086 bool clear_errsv = FALSE;
2094 const I32 cxix = dopoptosub(cxstack_ix);
2097 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2098 * sort block, which is a CXt_NULL
2101 PL_stack_base[1] = *PL_stack_sp;
2102 PL_stack_sp = PL_stack_base + 1;
2106 DIE(aTHX_ "Can't return outside a subroutine");
2108 if (cxix < cxstack_ix)
2111 if (CxMULTICALL(&cxstack[cxix])) {
2112 gimme = cxstack[cxix].blk_gimme;
2113 if (gimme == G_VOID)
2114 PL_stack_sp = PL_stack_base;
2115 else if (gimme == G_SCALAR) {
2116 PL_stack_base[1] = *PL_stack_sp;
2117 PL_stack_sp = PL_stack_base + 1;
2123 switch (CxTYPE(cx)) {
2126 retop = cx->blk_sub.retop;
2127 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2130 if (!(PL_in_eval & EVAL_KEEPERR))
2133 retop = cx->blk_eval.retop;
2137 if (optype == OP_REQUIRE &&
2138 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2140 /* Unassume the success we assumed earlier. */
2141 SV * const nsv = cx->blk_eval.old_namesv;
2142 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2143 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2148 retop = cx->blk_sub.retop;
2151 DIE(aTHX_ "panic: return");
2155 if (gimme == G_SCALAR) {
2158 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2160 *++newsp = SvREFCNT_inc(*SP);
2165 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2167 *++newsp = sv_mortalcopy(sv);
2172 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2175 *++newsp = sv_mortalcopy(*SP);
2178 *++newsp = &PL_sv_undef;
2180 else if (gimme == G_ARRAY) {
2181 while (++MARK <= SP) {
2182 *++newsp = (popsub2 && SvTEMP(*MARK))
2183 ? *MARK : sv_mortalcopy(*MARK);
2184 TAINT_NOT; /* Each item is independent */
2187 PL_stack_sp = newsp;
2190 /* Stack values are safe: */
2193 POPSUB(cx,sv); /* release CV and @_ ... */
2197 PL_curpm = newpm; /* ... and pop $1 et al */
2210 register PERL_CONTEXT *cx;
2221 if (PL_op->op_flags & OPf_SPECIAL) {
2222 cxix = dopoptoloop(cxstack_ix);
2224 DIE(aTHX_ "Can't \"last\" outside a loop block");
2227 cxix = dopoptolabel(cPVOP->op_pv);
2229 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2231 if (cxix < cxstack_ix)
2235 cxstack_ix++; /* temporarily protect top context */
2237 switch (CxTYPE(cx)) {
2238 case CXt_LOOP_LAZYIV:
2239 case CXt_LOOP_LAZYSV:
2241 case CXt_LOOP_PLAIN:
2243 newsp = PL_stack_base + cx->blk_loop.resetsp;
2244 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2248 nextop = cx->blk_sub.retop;
2252 nextop = cx->blk_eval.retop;
2256 nextop = cx->blk_sub.retop;
2259 DIE(aTHX_ "panic: last");
2263 if (gimme == G_SCALAR) {
2265 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2266 ? *SP : sv_mortalcopy(*SP);
2268 *++newsp = &PL_sv_undef;
2270 else if (gimme == G_ARRAY) {
2271 while (++MARK <= SP) {
2272 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2273 ? *MARK : sv_mortalcopy(*MARK);
2274 TAINT_NOT; /* Each item is independent */
2282 /* Stack values are safe: */
2284 case CXt_LOOP_LAZYIV:
2285 case CXt_LOOP_PLAIN:
2286 case CXt_LOOP_LAZYSV:
2288 POPLOOP(cx); /* release loop vars ... */
2292 POPSUB(cx,sv); /* release CV and @_ ... */
2295 PL_curpm = newpm; /* ... and pop $1 et al */
2298 PERL_UNUSED_VAR(optype);
2299 PERL_UNUSED_VAR(gimme);
2307 register PERL_CONTEXT *cx;
2310 if (PL_op->op_flags & OPf_SPECIAL) {
2311 cxix = dopoptoloop(cxstack_ix);
2313 DIE(aTHX_ "Can't \"next\" outside a loop block");
2316 cxix = dopoptolabel(cPVOP->op_pv);
2318 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2320 if (cxix < cxstack_ix)
2323 /* clear off anything above the scope we're re-entering, but
2324 * save the rest until after a possible continue block */
2325 inner = PL_scopestack_ix;
2327 if (PL_scopestack_ix < inner)
2328 leave_scope(PL_scopestack[PL_scopestack_ix]);
2329 PL_curcop = cx->blk_oldcop;
2330 return CX_LOOP_NEXTOP_GET(cx);
2337 register PERL_CONTEXT *cx;
2341 if (PL_op->op_flags & OPf_SPECIAL) {
2342 cxix = dopoptoloop(cxstack_ix);
2344 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2347 cxix = dopoptolabel(cPVOP->op_pv);
2349 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2351 if (cxix < cxstack_ix)
2354 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2355 if (redo_op->op_type == OP_ENTER) {
2356 /* pop one less context to avoid $x being freed in while (my $x..) */
2358 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2359 redo_op = redo_op->op_next;
2363 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2364 LEAVE_SCOPE(oldsave);
2366 PL_curcop = cx->blk_oldcop;
2371 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2375 static const char too_deep[] = "Target of goto is too deeply nested";
2377 PERL_ARGS_ASSERT_DOFINDLABEL;
2380 Perl_croak(aTHX_ too_deep);
2381 if (o->op_type == OP_LEAVE ||
2382 o->op_type == OP_SCOPE ||
2383 o->op_type == OP_LEAVELOOP ||
2384 o->op_type == OP_LEAVESUB ||
2385 o->op_type == OP_LEAVETRY)
2387 *ops++ = cUNOPo->op_first;
2389 Perl_croak(aTHX_ too_deep);
2392 if (o->op_flags & OPf_KIDS) {
2394 /* First try all the kids at this level, since that's likeliest. */
2395 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2396 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2397 CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label))
2400 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2401 if (kid == PL_lastgotoprobe)
2403 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2406 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2407 ops[-1]->op_type == OP_DBSTATE)
2412 if ((o = dofindlabel(kid, label, ops, oplimit)))
2425 register PERL_CONTEXT *cx;
2426 #define GOTO_DEPTH 64
2427 OP *enterops[GOTO_DEPTH];
2428 const char *label = NULL;
2429 const bool do_dump = (PL_op->op_type == OP_DUMP);
2430 static const char must_have_label[] = "goto must have label";
2432 if (PL_op->op_flags & OPf_STACKED) {
2433 SV * const sv = POPs;
2435 /* This egregious kludge implements goto &subroutine */
2436 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2438 register PERL_CONTEXT *cx;
2439 CV *cv = MUTABLE_CV(SvRV(sv));
2446 if (!CvROOT(cv) && !CvXSUB(cv)) {
2447 const GV * const gv = CvGV(cv);
2451 /* autoloaded stub? */
2452 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2454 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2455 GvNAMELEN(gv), FALSE);
2456 if (autogv && (cv = GvCV(autogv)))
2458 tmpstr = sv_newmortal();
2459 gv_efullname3(tmpstr, gv, NULL);
2460 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2462 DIE(aTHX_ "Goto undefined subroutine");
2465 /* First do some returnish stuff. */
2466 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2468 cxix = dopoptosub(cxstack_ix);
2470 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2471 if (cxix < cxstack_ix)
2475 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2476 if (CxTYPE(cx) == CXt_EVAL) {
2478 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2480 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2482 else if (CxMULTICALL(cx))
2483 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2484 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2485 /* put @_ back onto stack */
2486 AV* av = cx->blk_sub.argarray;
2488 items = AvFILLp(av) + 1;
2489 EXTEND(SP, items+1); /* @_ could have been extended. */
2490 Copy(AvARRAY(av), SP + 1, items, SV*);
2491 SvREFCNT_dec(GvAV(PL_defgv));
2492 GvAV(PL_defgv) = cx->blk_sub.savearray;
2494 /* abandon @_ if it got reified */
2499 av_extend(av, items-1);
2501 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2504 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2505 AV* const av = GvAV(PL_defgv);
2506 items = AvFILLp(av) + 1;
2507 EXTEND(SP, items+1); /* @_ could have been extended. */
2508 Copy(AvARRAY(av), SP + 1, items, SV*);
2512 if (CxTYPE(cx) == CXt_SUB &&
2513 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2514 SvREFCNT_dec(cx->blk_sub.cv);
2515 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2516 LEAVE_SCOPE(oldsave);
2518 /* Now do some callish stuff. */
2520 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2522 OP* const retop = cx->blk_sub.retop;
2527 for (index=0; index<items; index++)
2528 sv_2mortal(SP[-index]);
2531 /* XS subs don't have a CxSUB, so pop it */
2532 POPBLOCK(cx, PL_curpm);
2533 /* Push a mark for the start of arglist */
2536 (void)(*CvXSUB(cv))(aTHX_ cv);
2537 LEAVE_with_name("sub");
2541 AV* const padlist = CvPADLIST(cv);
2542 if (CxTYPE(cx) == CXt_EVAL) {
2543 PL_in_eval = CxOLD_IN_EVAL(cx);
2544 PL_eval_root = cx->blk_eval.old_eval_root;
2545 cx->cx_type = CXt_SUB;
2547 cx->blk_sub.cv = cv;
2548 cx->blk_sub.olddepth = CvDEPTH(cv);
2551 if (CvDEPTH(cv) < 2)
2552 SvREFCNT_inc_simple_void_NN(cv);
2554 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2555 sub_crush_depth(cv);
2556 pad_push(padlist, CvDEPTH(cv));
2559 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2562 AV *const av = MUTABLE_AV(PAD_SVl(0));
2564 cx->blk_sub.savearray = GvAV(PL_defgv);
2565 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2566 CX_CURPAD_SAVE(cx->blk_sub);
2567 cx->blk_sub.argarray = av;
2569 if (items >= AvMAX(av) + 1) {
2570 SV **ary = AvALLOC(av);
2571 if (AvARRAY(av) != ary) {
2572 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2575 if (items >= AvMAX(av) + 1) {
2576 AvMAX(av) = items - 1;
2577 Renew(ary,items+1,SV*);
2583 Copy(mark,AvARRAY(av),items,SV*);
2584 AvFILLp(av) = items - 1;
2585 assert(!AvREAL(av));
2587 /* transfer 'ownership' of refcnts to new @_ */
2597 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2598 Perl_get_db_sub(aTHX_ NULL, cv);
2600 CV * const gotocv = get_cvs("DB::goto", 0);
2602 PUSHMARK( PL_stack_sp );
2603 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2608 RETURNOP(CvSTART(cv));
2612 label = SvPV_nolen_const(sv);
2613 if (!(do_dump || *label))
2614 DIE(aTHX_ must_have_label);
2617 else if (PL_op->op_flags & OPf_SPECIAL) {
2619 DIE(aTHX_ must_have_label);
2622 label = cPVOP->op_pv;
2624 if (label && *label) {
2625 OP *gotoprobe = NULL;
2626 bool leaving_eval = FALSE;
2627 bool in_block = FALSE;
2628 PERL_CONTEXT *last_eval_cx = NULL;
2632 PL_lastgotoprobe = NULL;
2634 for (ix = cxstack_ix; ix >= 0; ix--) {
2636 switch (CxTYPE(cx)) {
2638 leaving_eval = TRUE;
2639 if (!CxTRYBLOCK(cx)) {
2640 gotoprobe = (last_eval_cx ?
2641 last_eval_cx->blk_eval.old_eval_root :
2646 /* else fall through */
2647 case CXt_LOOP_LAZYIV:
2648 case CXt_LOOP_LAZYSV:
2650 case CXt_LOOP_PLAIN:
2653 gotoprobe = cx->blk_oldcop->op_sibling;
2659 gotoprobe = cx->blk_oldcop->op_sibling;
2662 gotoprobe = PL_main_root;
2665 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2666 gotoprobe = CvROOT(cx->blk_sub.cv);
2672 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2675 DIE(aTHX_ "panic: goto");
2676 gotoprobe = PL_main_root;
2680 retop = dofindlabel(gotoprobe, label,
2681 enterops, enterops + GOTO_DEPTH);
2685 PL_lastgotoprobe = gotoprobe;
2688 DIE(aTHX_ "Can't find label %s", label);
2690 /* if we're leaving an eval, check before we pop any frames
2691 that we're not going to punt, otherwise the error
2694 if (leaving_eval && *enterops && enterops[1]) {
2696 for (i = 1; enterops[i]; i++)
2697 if (enterops[i]->op_type == OP_ENTERITER)
2698 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2701 /* pop unwanted frames */
2703 if (ix < cxstack_ix) {
2710 oldsave = PL_scopestack[PL_scopestack_ix];
2711 LEAVE_SCOPE(oldsave);
2714 /* push wanted frames */
2716 if (*enterops && enterops[1]) {
2717 OP * const oldop = PL_op;
2718 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2719 for (; enterops[ix]; ix++) {
2720 PL_op = enterops[ix];
2721 /* Eventually we may want to stack the needed arguments
2722 * for each op. For now, we punt on the hard ones. */
2723 if (PL_op->op_type == OP_ENTERITER)
2724 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2725 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2733 if (!retop) retop = PL_main_start;
2735 PL_restartop = retop;
2736 PL_do_undump = TRUE;
2740 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2741 PL_do_undump = FALSE;
2758 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2760 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2763 PL_exit_flags |= PERL_EXIT_EXPECTED;
2765 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2766 if (anum || !(PL_minus_c && PL_madskills))
2771 PUSHs(&PL_sv_undef);
2778 S_save_lines(pTHX_ AV *array, SV *sv)
2780 const char *s = SvPVX_const(sv);
2781 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2784 PERL_ARGS_ASSERT_SAVE_LINES;
2786 while (s && s < send) {
2788 SV * const tmpstr = newSV_type(SVt_PVMG);
2790 t = (const char *)memchr(s, '\n', send - s);
2796 sv_setpvn(tmpstr, s, t - s);
2797 av_store(array, line++, tmpstr);
2803 S_docatch(pTHX_ OP *o)
2807 OP * const oldop = PL_op;
2811 assert(CATCH_GET == TRUE);
2818 assert(cxstack_ix >= 0);
2819 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2820 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2825 /* die caught by an inner eval - continue inner loop */
2827 /* NB XXX we rely on the old popped CxEVAL still being at the top
2828 * of the stack; the way die_where() currently works, this
2829 * assumption is valid. In theory The cur_top_env value should be
2830 * returned in another global, the way retop (aka PL_restartop)
2832 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2835 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2837 PL_op = PL_restartop;
2854 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2855 /* sv Text to convert to OP tree. */
2856 /* startop op_free() this to undo. */
2857 /* code Short string id of the caller. */
2859 /* FIXME - how much of this code is common with pp_entereval? */
2860 dVAR; dSP; /* Make POPBLOCK work. */
2866 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2867 char *tmpbuf = tbuf;
2870 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2873 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2875 ENTER_with_name("eval");
2876 lex_start(sv, NULL, FALSE);
2878 /* switch to eval mode */
2880 if (IN_PERL_COMPILETIME) {
2881 SAVECOPSTASH_FREE(&PL_compiling);
2882 CopSTASH_set(&PL_compiling, PL_curstash);
2884 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2885 SV * const sv = sv_newmortal();
2886 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2887 code, (unsigned long)++PL_evalseq,
2888 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2893 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2894 (unsigned long)++PL_evalseq);
2895 SAVECOPFILE_FREE(&PL_compiling);
2896 CopFILE_set(&PL_compiling, tmpbuf+2);
2897 SAVECOPLINE(&PL_compiling);
2898 CopLINE_set(&PL_compiling, 1);
2899 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2900 deleting the eval's FILEGV from the stash before gv_check() runs
2901 (i.e. before run-time proper). To work around the coredump that
2902 ensues, we always turn GvMULTI_on for any globals that were
2903 introduced within evals. See force_ident(). GSAR 96-10-12 */
2904 safestr = savepvn(tmpbuf, len);
2905 SAVEDELETE(PL_defstash, safestr, len);
2907 #ifdef OP_IN_REGISTER
2913 /* we get here either during compilation, or via pp_regcomp at runtime */
2914 runtime = IN_PERL_RUNTIME;
2916 runcv = find_runcv(NULL);
2919 PL_op->op_type = OP_ENTEREVAL;
2920 PL_op->op_flags = 0; /* Avoid uninit warning. */
2921 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2925 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2927 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2928 POPBLOCK(cx,PL_curpm);
2931 (*startop)->op_type = OP_NULL;
2932 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2934 /* XXX DAPM do this properly one year */
2935 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2936 LEAVE_with_name("eval");
2937 if (IN_PERL_COMPILETIME)
2938 CopHINTS_set(&PL_compiling, PL_hints);
2939 #ifdef OP_IN_REGISTER
2942 PERL_UNUSED_VAR(newsp);
2943 PERL_UNUSED_VAR(optype);
2945 return PL_eval_start;
2950 =for apidoc find_runcv
2952 Locate the CV corresponding to the currently executing sub or eval.
2953 If db_seqp is non_null, skip CVs that are in the DB package and populate
2954 *db_seqp with the cop sequence number at the point that the DB:: code was
2955 entered. (allows debuggers to eval in the scope of the breakpoint rather
2956 than in the scope of the debugger itself).
2962 Perl_find_runcv(pTHX_ U32 *db_seqp)
2968 *db_seqp = PL_curcop->cop_seq;
2969 for (si = PL_curstackinfo; si; si = si->si_prev) {
2971 for (ix = si->si_cxix; ix >= 0; ix--) {
2972 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2973 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2974 CV * const cv = cx->blk_sub.cv;
2975 /* skip DB:: code */
2976 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2977 *db_seqp = cx->blk_oldcop->cop_seq;
2982 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2990 /* Compile a require/do, an eval '', or a /(?{...})/.
2991 * In the last case, startop is non-null, and contains the address of
2992 * a pointer that should be set to the just-compiled code.
2993 * outside is the lexically enclosing CV (if any) that invoked us.
2994 * Returns a bool indicating whether the compile was successful; if so,
2995 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2996 * pushes undef (also croaks if startop != NULL).
3000 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3003 OP * const saveop = PL_op;
3005 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
3006 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3011 SAVESPTR(PL_compcv);
3012 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3013 CvEVAL_on(PL_compcv);
3014 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3015 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3017 CvOUTSIDE_SEQ(PL_compcv) = seq;
3018 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3020 /* set up a scratch pad */
3022 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3023 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3027 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3029 /* make sure we compile in the right package */
3031 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3032 SAVESPTR(PL_curstash);
3033 PL_curstash = CopSTASH(PL_curcop);
3035 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3036 SAVESPTR(PL_beginav);
3037 PL_beginav = newAV();
3038 SAVEFREESV(PL_beginav);
3039 SAVESPTR(PL_unitcheckav);
3040 PL_unitcheckav = newAV();
3041 SAVEFREESV(PL_unitcheckav);
3044 SAVEBOOL(PL_madskills);
3048 /* try to compile it */
3050 PL_eval_root = NULL;
3051 PL_curcop = &PL_compiling;
3052 CopARYBASE_set(PL_curcop, 0);
3053 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3054 PL_in_eval |= EVAL_KEEPERR;
3057 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
3058 SV **newsp; /* Used by POPBLOCK. */
3059 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
3060 I32 optype = 0; /* Might be reset by POPEVAL. */
3065 op_free(PL_eval_root);
3066 PL_eval_root = NULL;
3068 SP = PL_stack_base + POPMARK; /* pop original mark */
3070 POPBLOCK(cx,PL_curpm);
3074 LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3076 msg = SvPVx_nolen_const(ERRSV);
3077 if (optype == OP_REQUIRE) {
3078 const SV * const nsv = cx->blk_eval.old_namesv;
3079 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3081 Perl_croak(aTHX_ "%sCompilation failed in require",
3082 *msg ? msg : "Unknown error\n");
3085 POPBLOCK(cx,PL_curpm);
3087 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3088 (*msg ? msg : "Unknown error\n"));
3092 sv_setpvs(ERRSV, "Compilation error");
3095 PERL_UNUSED_VAR(newsp);
3096 PUSHs(&PL_sv_undef);
3100 CopLINE_set(&PL_compiling, 0);
3102 *startop = PL_eval_root;
3104 SAVEFREEOP(PL_eval_root);
3106 /* Set the context for this new optree.
3107 * If the last op is an OP_REQUIRE, force scalar context.
3108 * Otherwise, propagate the context from the eval(). */
3109 if (PL_eval_root->op_type == OP_LEAVEEVAL
3110 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3111 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3113 scalar(PL_eval_root);
3114 else if ((gimme & G_WANT) == G_VOID)
3115 scalarvoid(PL_eval_root);
3116 else if ((gimme & G_WANT) == G_ARRAY)
3119 scalar(PL_eval_root);
3121 DEBUG_x(dump_eval());
3123 /* Register with debugger: */
3124 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3125 CV * const cv = get_cvs("DB::postponed", 0);
3129 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3131 call_sv(MUTABLE_SV(cv), G_DISCARD);
3136 call_list(PL_scopestack_ix, PL_unitcheckav);
3138 /* compiled okay, so do it */
3140 CvDEPTH(PL_compcv) = 1;
3141 SP = PL_stack_base + POPMARK; /* pop original mark */
3142 PL_op = saveop; /* The caller may need it. */
3143 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3150 S_check_type_and_open(pTHX_ const char *name)
3153 const int st_rc = PerlLIO_stat(name, &st);
3155 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3157 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3161 return PerlIO_open(name, PERL_SCRIPT_MODE);
3164 #ifndef PERL_DISABLE_PMC
3166 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3170 PERL_ARGS_ASSERT_DOOPEN_PM;
3172 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3173 SV *const pmcsv = newSV(namelen + 2);
3174 char *const pmc = SvPVX(pmcsv);
3177 memcpy(pmc, name, namelen);
3179 pmc[namelen + 1] = '\0';
3181 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3182 fp = check_type_and_open(name);
3185 fp = check_type_and_open(pmc);
3187 SvREFCNT_dec(pmcsv);
3190 fp = check_type_and_open(name);
3195 # define doopen_pm(name, namelen) check_type_and_open(name)
3196 #endif /* !PERL_DISABLE_PMC */
3201 register PERL_CONTEXT *cx;
3208 int vms_unixname = 0;
3210 const char *tryname = NULL;
3212 const I32 gimme = GIMME_V;
3213 int filter_has_file = 0;
3214 PerlIO *tryrsfp = NULL;
3215 SV *filter_cache = NULL;
3216 SV *filter_state = NULL;
3217 SV *filter_sub = NULL;
3223 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3224 sv = new_version(sv);
3225 if (!sv_derived_from(PL_patchlevel, "version"))
3226 upg_version(PL_patchlevel, TRUE);
3227 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3228 if ( vcmp(sv,PL_patchlevel) <= 0 )
3229 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3230 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3233 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3236 SV * const req = SvRV(sv);
3237 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3239 /* get the left hand term */
3240 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3242 first = SvIV(*av_fetch(lav,0,0));
3243 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3244 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3245 || av_len(lav) > 1 /* FP with > 3 digits */
3246 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3248 DIE(aTHX_ "Perl %"SVf" required--this is only "
3249 "%"SVf", stopped", SVfARG(vnormal(req)),
3250 SVfARG(vnormal(PL_patchlevel)));
3252 else { /* probably 'use 5.10' or 'use 5.8' */
3253 SV * hintsv = newSV(0);
3257 second = SvIV(*av_fetch(lav,1,0));
3259 second /= second >= 600 ? 100 : 10;
3260 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3261 (int)first, (int)second,0);
3262 upg_version(hintsv, TRUE);
3264 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3265 "--this is only %"SVf", stopped",
3266 SVfARG(vnormal(req)),
3267 SVfARG(vnormal(hintsv)),
3268 SVfARG(vnormal(PL_patchlevel)));
3273 /* We do this only with use, not require. */
3275 /* If we request a version >= 5.9.5, load feature.pm with the
3276 * feature bundle that corresponds to the required version. */
3277 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3278 SV *const importsv = vnormal(sv);
3279 *SvPVX_mutable(importsv) = ':';
3280 ENTER_with_name("load_feature");
3281 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3282 LEAVE_with_name("load_feature");
3284 /* If a version >= 5.11.0 is requested, strictures are on by default! */
3286 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3287 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3292 name = SvPV_const(sv, len);
3293 if (!(name && len > 0 && *name))
3294 DIE(aTHX_ "Null filename used");
3295 TAINT_PROPER("require");
3299 /* The key in the %ENV hash is in the syntax of file passed as the argument
3300 * usually this is in UNIX format, but sometimes in VMS format, which
3301 * can result in a module being pulled in more than once.
3302 * To prevent this, the key must be stored in UNIX format if the VMS
3303 * name can be translated to UNIX.
3305 if ((unixname = tounixspec(name, NULL)) != NULL) {
3306 unixlen = strlen(unixname);
3312 /* if not VMS or VMS name can not be translated to UNIX, pass it
3315 unixname = (char *) name;
3318 if (PL_op->op_type == OP_REQUIRE) {
3319 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3320 unixname, unixlen, 0);
3322 if (*svp != &PL_sv_undef)
3325 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3326 "Compilation failed in require", unixname);
3330 /* prepare to compile file */
3332 if (path_is_absolute(name)) {
3334 tryrsfp = doopen_pm(name, len);
3337 AV * const ar = GvAVn(PL_incgv);
3343 namesv = newSV_type(SVt_PV);
3344 for (i = 0; i <= AvFILL(ar); i++) {
3345 SV * const dirsv = *av_fetch(ar, i, TRUE);
3347 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3354 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3355 && !sv_isobject(loader))
3357 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3360 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3361 PTR2UV(SvRV(dirsv)), name);
3362 tryname = SvPVX_const(namesv);
3365 ENTER_with_name("call_INC");
3373 if (sv_isobject(loader))
3374 count = call_method("INC", G_ARRAY);
3376 count = call_sv(loader, G_ARRAY);
3379 /* Adjust file name if the hook has set an %INC entry */
3380 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3382 tryname = SvPV_nolen_const(*svp);
3391 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3392 && !isGV_with_GP(SvRV(arg))) {
3393 filter_cache = SvRV(arg);
3394 SvREFCNT_inc_simple_void_NN(filter_cache);
3401 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3405 if (isGV_with_GP(arg)) {
3406 IO * const io = GvIO((const GV *)arg);
3411 tryrsfp = IoIFP(io);
3412 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3413 PerlIO_close(IoOFP(io));
3424 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3426 SvREFCNT_inc_simple_void_NN(filter_sub);
3429 filter_state = SP[i];
3430 SvREFCNT_inc_simple_void(filter_state);
3434 if (!tryrsfp && (filter_cache || filter_sub)) {
3435 tryrsfp = PerlIO_open(BIT_BUCKET,
3443 LEAVE_with_name("call_INC");
3450 filter_has_file = 0;
3452 SvREFCNT_dec(filter_cache);
3453 filter_cache = NULL;
3456 SvREFCNT_dec(filter_state);
3457 filter_state = NULL;
3460 SvREFCNT_dec(filter_sub);
3465 if (!path_is_absolute(name)
3471 dir = SvPV_const(dirsv, dirlen);
3479 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3481 sv_setpv(namesv, unixdir);
3482 sv_catpv(namesv, unixname);
3484 # ifdef __SYMBIAN32__
3485 if (PL_origfilename[0] &&
3486 PL_origfilename[1] == ':' &&
3487 !(dir[0] && dir[1] == ':'))
3488 Perl_sv_setpvf(aTHX_ namesv,
3493 Perl_sv_setpvf(aTHX_ namesv,
3497 /* The equivalent of
3498 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3499 but without the need to parse the format string, or
3500 call strlen on either pointer, and with the correct
3501 allocation up front. */
3503 char *tmp = SvGROW(namesv, dirlen + len + 2);
3505 memcpy(tmp, dir, dirlen);
3508 /* name came from an SV, so it will have a '\0' at the
3509 end that we can copy as part of this memcpy(). */
3510 memcpy(tmp, name, len + 1);
3512 SvCUR_set(namesv, dirlen + len + 1);
3514 /* Don't even actually have to turn SvPOK_on() as we
3515 access it directly with SvPVX() below. */
3519 TAINT_PROPER("require");
3520 tryname = SvPVX_const(namesv);
3521 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3523 if (tryname[0] == '.' && tryname[1] == '/') {
3525 while (*++tryname == '/');
3529 else if (errno == EMFILE)
3530 /* no point in trying other paths if out of handles */
3537 SAVECOPFILE_FREE(&PL_compiling);
3538 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3539 SvREFCNT_dec(namesv);
3541 if (PL_op->op_type == OP_REQUIRE) {
3542 const char *msgstr = name;
3543 if(errno == EMFILE) {
3545 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3547 msgstr = SvPV_nolen_const(msg);
3549 if (namesv) { /* did we lookup @INC? */
3550 AV * const ar = GvAVn(PL_incgv);
3552 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3553 "%s in @INC%s%s (@INC contains:",
3555 (instr(msgstr, ".h ")
3556 ? " (change .h to .ph maybe?)" : ""),
3557 (instr(msgstr, ".ph ")
3558 ? " (did you run h2ph?)" : "")
3561 for (i = 0; i <= AvFILL(ar); i++) {
3562 sv_catpvs(msg, " ");
3563 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3565 sv_catpvs(msg, ")");
3566 msgstr = SvPV_nolen_const(msg);
3569 DIE(aTHX_ "Can't locate %s", msgstr);
3575 SETERRNO(0, SS_NORMAL);
3577 /* Assume success here to prevent recursive requirement. */
3578 /* name is never assigned to again, so len is still strlen(name) */
3579 /* Check whether a hook in @INC has already filled %INC */
3581 (void)hv_store(GvHVn(PL_incgv),
3582 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3584 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3586 (void)hv_store(GvHVn(PL_incgv),
3587 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3590 ENTER_with_name("eval");
3592 lex_start(NULL, tryrsfp, TRUE);
3596 hv_clear(GvHV(PL_hintgv));
3598 SAVECOMPILEWARNINGS();
3599 if (PL_dowarn & G_WARN_ALL_ON)
3600 PL_compiling.cop_warnings = pWARN_ALL ;
3601 else if (PL_dowarn & G_WARN_ALL_OFF)
3602 PL_compiling.cop_warnings = pWARN_NONE ;
3604 PL_compiling.cop_warnings = pWARN_STD ;
3606 if (filter_sub || filter_cache) {
3607 /* We can use the SvPV of the filter PVIO itself as our cache, rather
3608 than hanging another SV from it. In turn, filter_add() optionally
3609 takes the SV to use as the filter (or creates a new SV if passed
3610 NULL), so simply pass in whatever value filter_cache has. */
3611 SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3612 IoLINES(datasv) = filter_has_file;
3613 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3614 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3617 /* switch to eval mode */
3618 PUSHBLOCK(cx, CXt_EVAL, SP);
3620 cx->blk_eval.retop = PL_op->op_next;
3622 SAVECOPLINE(&PL_compiling);
3623 CopLINE_set(&PL_compiling, 0);
3627 /* Store and reset encoding. */
3628 encoding = PL_encoding;
3631 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3632 op = DOCATCH(PL_eval_start);
3634 op = PL_op->op_next;
3636 /* Restore encoding. */
3637 PL_encoding = encoding;
3642 /* This is a op added to hold the hints hash for
3643 pp_entereval. The hash can be modified by the code
3644 being eval'ed, so we return a copy instead. */
3650 mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3658 register PERL_CONTEXT *cx;
3660 const I32 gimme = GIMME_V;
3661 const U32 was = PL_breakable_sub_gen;
3662 char tbuf[TYPE_DIGITS(long) + 12];
3663 char *tmpbuf = tbuf;
3667 HV *saved_hh = NULL;
3669 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3670 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3674 TAINT_IF(SvTAINTED(sv));
3675 TAINT_PROPER("eval");
3677 ENTER_with_name("eval");
3678 lex_start(sv, NULL, FALSE);
3681 /* switch to eval mode */
3683 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3684 SV * const temp_sv = sv_newmortal();
3685 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3686 (unsigned long)++PL_evalseq,
3687 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3688 tmpbuf = SvPVX(temp_sv);
3689 len = SvCUR(temp_sv);
3692 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3693 SAVECOPFILE_FREE(&PL_compiling);
3694 CopFILE_set(&PL_compiling, tmpbuf+2);
3695 SAVECOPLINE(&PL_compiling);
3696 CopLINE_set(&PL_compiling, 1);
3697 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3698 deleting the eval's FILEGV from the stash before gv_check() runs
3699 (i.e. before run-time proper). To work around the coredump that
3700 ensues, we always turn GvMULTI_on for any globals that were
3701 introduced within evals. See force_ident(). GSAR 96-10-12 */
3703 PL_hints = PL_op->op_targ;
3705 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3706 SvREFCNT_dec(GvHV(PL_hintgv));
3707 GvHV(PL_hintgv) = saved_hh;
3709 SAVECOMPILEWARNINGS();
3710 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3711 if (PL_compiling.cop_hints_hash) {
3712 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3714 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3715 if (PL_compiling.cop_hints_hash) {
3717 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3718 HINTS_REFCNT_UNLOCK;
3720 /* special case: an eval '' executed within the DB package gets lexically
3721 * placed in the first non-DB CV rather than the current CV - this
3722 * allows the debugger to execute code, find lexicals etc, in the
3723 * scope of the code being debugged. Passing &seq gets find_runcv
3724 * to do the dirty work for us */
3725 runcv = find_runcv(&seq);
3727 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3729 cx->blk_eval.retop = PL_op->op_next;
3731 /* prepare to compile string */
3733 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3734 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3737 if (doeval(gimme, NULL, runcv, seq)) {
3738 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3739 ? (PERLDB_LINE || PERLDB_SAVESRC)
3740 : PERLDB_SAVESRC_NOSUBS) {
3741 /* Retain the filegv we created. */
3743 char *const safestr = savepvn(tmpbuf, len);
3744 SAVEDELETE(PL_defstash, safestr, len);
3746 return DOCATCH(PL_eval_start);
3748 /* We have already left the scope set up earler thanks to the LEAVE
3750 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3751 ? (PERLDB_LINE || PERLDB_SAVESRC)
3752 : PERLDB_SAVESRC_INVALID) {
3753 /* Retain the filegv we created. */
3755 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3757 return PL_op->op_next;
3768 register PERL_CONTEXT *cx;
3770 const U8 save_flags = PL_op -> op_flags;
3775 retop = cx->blk_eval.retop;
3778 if (gimme == G_VOID)
3780 else if (gimme == G_SCALAR) {
3783 if (SvFLAGS(TOPs) & SVs_TEMP)
3786 *MARK = sv_mortalcopy(TOPs);
3790 *MARK = &PL_sv_undef;
3795 /* in case LEAVE wipes old return values */
3796 for (mark = newsp + 1; mark <= SP; mark++) {
3797 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3798 *mark = sv_mortalcopy(*mark);
3799 TAINT_NOT; /* Each item is independent */
3803 PL_curpm = newpm; /* Don't pop $1 et al till now */
3806 assert(CvDEPTH(PL_compcv) == 1);
3808 CvDEPTH(PL_compcv) = 0;
3811 if (optype == OP_REQUIRE &&
3812 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3814 /* Unassume the success we assumed earlier. */
3815 SV * const nsv = cx->blk_eval.old_namesv;
3816 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3817 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3818 /* die_where() did LEAVE, or we won't be here */
3821 LEAVE_with_name("eval");
3822 if (!(save_flags & OPf_SPECIAL)) {
3830 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3831 close to the related Perl_create_eval_scope. */
3833 Perl_delete_eval_scope(pTHX)
3838 register PERL_CONTEXT *cx;
3844 LEAVE_with_name("eval_scope");
3845 PERL_UNUSED_VAR(newsp);
3846 PERL_UNUSED_VAR(gimme);
3847 PERL_UNUSED_VAR(optype);
3850 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3851 also needed by Perl_fold_constants. */
3853 Perl_create_eval_scope(pTHX_ U32 flags)
3856 const I32 gimme = GIMME_V;
3858 ENTER_with_name("eval_scope");
3861 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3864 PL_in_eval = EVAL_INEVAL;
3865 if (flags & G_KEEPERR)
3866 PL_in_eval |= EVAL_KEEPERR;
3869 if (flags & G_FAKINGEVAL) {
3870 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3878 PERL_CONTEXT * const cx = create_eval_scope(0);
3879 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3880 return DOCATCH(PL_op->op_next);
3889 register PERL_CONTEXT *cx;
3894 PERL_UNUSED_VAR(optype);
3897 if (gimme == G_VOID)
3899 else if (gimme == G_SCALAR) {
3903 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3906 *MARK = sv_mortalcopy(TOPs);
3910 *MARK = &PL_sv_undef;
3915 /* in case LEAVE wipes old return values */
3917 for (mark = newsp + 1; mark <= SP; mark++) {
3918 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3919 *mark = sv_mortalcopy(*mark);
3920 TAINT_NOT; /* Each item is independent */
3924 PL_curpm = newpm; /* Don't pop $1 et al till now */
3926 LEAVE_with_name("eval_scope");
3934 register PERL_CONTEXT *cx;
3935 const I32 gimme = GIMME_V;
3937 ENTER_with_name("given");
3940 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3942 PUSHBLOCK(cx, CXt_GIVEN, SP);
3951 register PERL_CONTEXT *cx;
3955 PERL_UNUSED_CONTEXT;
3958 assert(CxTYPE(cx) == CXt_GIVEN);
3963 PL_curpm = newpm; /* pop $1 et al */
3965 LEAVE_with_name("given");
3970 /* Helper routines used by pp_smartmatch */
3972 S_make_matcher(pTHX_ REGEXP *re)
3975 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3977 PERL_ARGS_ASSERT_MAKE_MATCHER;
3979 PM_SETRE(matcher, ReREFCNT_inc(re));
3981 SAVEFREEOP((OP *) matcher);
3982 ENTER_with_name("matcher"); SAVETMPS;
3988 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3993 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
3995 PL_op = (OP *) matcher;
4000 return (SvTRUEx(POPs));
4004 S_destroy_matcher(pTHX_ PMOP *matcher)
4008 PERL_ARGS_ASSERT_DESTROY_MATCHER;
4009 PERL_UNUSED_ARG(matcher);
4012 LEAVE_with_name("matcher");
4015 /* Do a smart match */
4018 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4019 return do_smartmatch(NULL, NULL);
4022 /* This version of do_smartmatch() implements the
4023 * table of smart matches that is found in perlsyn.
4026 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4031 bool object_on_left = FALSE;
4032 SV *e = TOPs; /* e is for 'expression' */
4033 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4035 /* First of all, handle overload magic of the rightmost argument */
4038 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4039 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4041 tmpsv = amagic_call(d, e, smart_amg, 0);
4048 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4051 SP -= 2; /* Pop the values */
4053 /* Take care only to invoke mg_get() once for each argument.
4054 * Currently we do this by copying the SV if it's magical. */
4057 d = sv_mortalcopy(d);
4064 e = sv_mortalcopy(e);
4068 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4075 if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4076 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4077 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4079 if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4080 object_on_left = TRUE;
4083 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4085 if (object_on_left) {
4086 goto sm_any_sub; /* Treat objects like scalars */
4088 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4089 /* Test sub truth for each key */
4091 bool andedresults = TRUE;
4092 HV *hv = (HV*) SvRV(d);
4093 I32 numkeys = hv_iterinit(hv);
4094 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4097 while ( (he = hv_iternext(hv)) ) {
4098 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4099 ENTER_with_name("smartmatch_hash_key_test");
4102 PUSHs(hv_iterkeysv(he));
4104 c = call_sv(e, G_SCALAR);
4107 andedresults = FALSE;
4109 andedresults = SvTRUEx(POPs) && andedresults;
4111 LEAVE_with_name("smartmatch_hash_key_test");
4118 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4119 /* Test sub truth for each element */
4121 bool andedresults = TRUE;
4122 AV *av = (AV*) SvRV(d);
4123 const I32 len = av_len(av);
4124 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4127 for (i = 0; i <= len; ++i) {
4128 SV * const * const svp = av_fetch(av, i, FALSE);
4129 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4130 ENTER_with_name("smartmatch_array_elem_test");
4136 c = call_sv(e, G_SCALAR);
4139 andedresults = FALSE;
4141 andedresults = SvTRUEx(POPs) && andedresults;
4143 LEAVE_with_name("smartmatch_array_elem_test");
4152 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4153 ENTER_with_name("smartmatch_coderef");
4158 c = call_sv(e, G_SCALAR);
4162 else if (SvTEMP(TOPs))
4163 SvREFCNT_inc_void(TOPs);
4165 LEAVE_with_name("smartmatch_coderef");
4170 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4171 if (object_on_left) {
4172 goto sm_any_hash; /* Treat objects like scalars */
4174 else if (!SvOK(d)) {
4175 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4178 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4179 /* Check that the key-sets are identical */
4181 HV *other_hv = MUTABLE_HV(SvRV(d));
4183 bool other_tied = FALSE;
4184 U32 this_key_count = 0,
4185 other_key_count = 0;
4186 HV *hv = MUTABLE_HV(SvRV(e));
4188 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4189 /* Tied hashes don't know how many keys they have. */
4190 if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4193 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4194 HV * const temp = other_hv;
4199 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4202 if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4205 /* The hashes have the same number of keys, so it suffices
4206 to check that one is a subset of the other. */
4207 (void) hv_iterinit(hv);
4208 while ( (he = hv_iternext(hv)) ) {
4209 SV *key = hv_iterkeysv(he);
4211 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4214 if(!hv_exists_ent(other_hv, key, 0)) {
4215 (void) hv_iterinit(hv); /* reset iterator */
4221 (void) hv_iterinit(other_hv);
4222 while ( hv_iternext(other_hv) )
4226 other_key_count = HvUSEDKEYS(other_hv);
4228 if (this_key_count != other_key_count)
4233 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4234 AV * const other_av = MUTABLE_AV(SvRV(d));
4235 const I32 other_len = av_len(other_av) + 1;
4237 HV *hv = MUTABLE_HV(SvRV(e));
4239 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4240 for (i = 0; i < other_len; ++i) {
4241 SV ** const svp = av_fetch(other_av, i, FALSE);
4242 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4243 if (svp) { /* ??? When can this not happen? */
4244 if (hv_exists_ent(hv, *svp, 0))
4250 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4251 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4254 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4256 HV *hv = MUTABLE_HV(SvRV(e));
4258 (void) hv_iterinit(hv);
4259 while ( (he = hv_iternext(hv)) ) {
4260 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4261 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4262 (void) hv_iterinit(hv);
4263 destroy_matcher(matcher);
4267 destroy_matcher(matcher);
4273 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4274 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4281 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4282 if (object_on_left) {
4283 goto sm_any_array; /* Treat objects like scalars */
4285 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4286 AV * const other_av = MUTABLE_AV(SvRV(e));
4287 const I32 other_len = av_len(other_av) + 1;
4290 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4291 for (i = 0; i < other_len; ++i) {
4292 SV ** const svp = av_fetch(other_av, i, FALSE);
4294 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4295 if (svp) { /* ??? When can this not happen? */
4296 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4302 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4303 AV *other_av = MUTABLE_AV(SvRV(d));
4304 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4305 if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4309 const I32 other_len = av_len(other_av);
4311 if (NULL == seen_this) {
4312 seen_this = newHV();
4313 (void) sv_2mortal(MUTABLE_SV(seen_this));
4315 if (NULL == seen_other) {
4316 seen_this = newHV();
4317 (void) sv_2mortal(MUTABLE_SV(seen_other));
4319 for(i = 0; i <= other_len; ++i) {
4320 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4321 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4323 if (!this_elem || !other_elem) {
4324 if (this_elem || other_elem)
4327 else if (hv_exists_ent(seen_this,
4328 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4329 hv_exists_ent(seen_other,
4330 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4332 if (*this_elem != *other_elem)
4336 (void)hv_store_ent(seen_this,
4337 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4339 (void)hv_store_ent(seen_other,
4340 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4346 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4347 (void) do_smartmatch(seen_this, seen_other);
4349 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4358 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4359 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4362 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4363 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4366 for(i = 0; i <= this_len; ++i) {
4367 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4368 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4369 if (svp && matcher_matches_sv(matcher, *svp)) {
4370 destroy_matcher(matcher);
4374 destroy_matcher(matcher);
4378 else if (!SvOK(d)) {
4379 /* undef ~~ array */
4380 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4383 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4384 for (i = 0; i <= this_len; ++i) {
4385 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4386 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4387 if (!svp || !SvOK(*svp))
4396 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4398 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4399 for (i = 0; i <= this_len; ++i) {
4400 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4407 /* infinite recursion isn't supposed to happen here */
4408 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4409 (void) do_smartmatch(NULL, NULL);
4411 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4420 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4421 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4422 SV *t = d; d = e; e = t;
4423 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4426 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4427 SV *t = d; d = e; e = t;
4428 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4429 goto sm_regex_array;
4432 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4434 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4436 PUSHs(matcher_matches_sv(matcher, d)
4439 destroy_matcher(matcher);
4444 /* See if there is overload magic on left */
4445 else if (object_on_left && SvAMAGIC(d)) {
4447 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4448 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4451 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4459 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4462 else if (!SvOK(d)) {
4463 /* undef ~~ scalar ; we already know that the scalar is SvOK */
4464 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4469 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4470 DEBUG_M(if (SvNIOK(e))
4471 Perl_deb(aTHX_ " applying rule Any-Num\n");
4473 Perl_deb(aTHX_ " applying rule Num-numish\n");
4475 /* numeric comparison */
4478 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4489 /* As a last resort, use string comparison */
4490 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4499 register PERL_CONTEXT *cx;
4500 const I32 gimme = GIMME_V;
4502 /* This is essentially an optimization: if the match
4503 fails, we don't want to push a context and then
4504 pop it again right away, so we skip straight
4505 to the op that follows the leavewhen.
4507 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4508 return cLOGOP->op_other->op_next;
4510 ENTER_with_name("eval");
4513 PUSHBLOCK(cx, CXt_WHEN, SP);
4522 register PERL_CONTEXT *cx;
4528 assert(CxTYPE(cx) == CXt_WHEN);
4533 PL_curpm = newpm; /* pop $1 et al */
4535 LEAVE_with_name("eval");
4543 register PERL_CONTEXT *cx;
4546 cxix = dopoptowhen(cxstack_ix);
4548 DIE(aTHX_ "Can't \"continue\" outside a when block");
4549 if (cxix < cxstack_ix)
4552 /* clear off anything above the scope we're re-entering */
4553 inner = PL_scopestack_ix;
4555 if (PL_scopestack_ix < inner)
4556 leave_scope(PL_scopestack[PL_scopestack_ix]);
4557 PL_curcop = cx->blk_oldcop;
4558 return cx->blk_givwhen.leave_op;
4565 register PERL_CONTEXT *cx;
4568 cxix = dopoptogiven(cxstack_ix);
4570 if (PL_op->op_flags & OPf_SPECIAL)
4571 DIE(aTHX_ "Can't use when() outside a topicalizer");
4573 DIE(aTHX_ "Can't \"break\" outside a given block");
4575 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4576 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4578 if (cxix < cxstack_ix)
4581 /* clear off anything above the scope we're re-entering */
4582 inner = PL_scopestack_ix;
4584 if (PL_scopestack_ix < inner)
4585 leave_scope(PL_scopestack[PL_scopestack_ix]);
4586 PL_curcop = cx->blk_oldcop;
4589 return CX_LOOP_NEXTOP_GET(cx);
4591 return cx->blk_givwhen.leave_op;
4595 S_doparseform(pTHX_ SV *sv)
4598 register char *s = SvPV_force(sv, len);
4599 register char * const send = s + len;
4600 register char *base = NULL;
4601 register I32 skipspaces = 0;
4602 bool noblank = FALSE;
4603 bool repeat = FALSE;
4604 bool postspace = FALSE;
4610 bool unchopnum = FALSE;
4611 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4613 PERL_ARGS_ASSERT_DOPARSEFORM;
4616 Perl_croak(aTHX_ "Null picture in formline");
4618 /* estimate the buffer size needed */
4619 for (base = s; s <= send; s++) {
4620 if (*s == '\n' || *s == '@' || *s == '^')
4626 Newx(fops, maxops, U32);
4631 *fpc++ = FF_LINEMARK;
4632 noblank = repeat = FALSE;
4650 case ' ': case '\t':
4657 } /* else FALL THROUGH */
4665 *fpc++ = FF_LITERAL;
4673 *fpc++ = (U16)skipspaces;
4677 *fpc++ = FF_NEWLINE;
4681 arg = fpc - linepc + 1;
4688 *fpc++ = FF_LINEMARK;
4689 noblank = repeat = FALSE;
4698 ischop = s[-1] == '^';
4704 arg = (s - base) - 1;
4706 *fpc++ = FF_LITERAL;
4714 *fpc++ = 2; /* skip the @* or ^* */
4716 *fpc++ = FF_LINESNGL;
4719 *fpc++ = FF_LINEGLOB;
4721 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4722 arg = ischop ? 512 : 0;
4727 const char * const f = ++s;
4730 arg |= 256 + (s - f);
4732 *fpc++ = s - base; /* fieldsize for FETCH */
4733 *fpc++ = FF_DECIMAL;
4735 unchopnum |= ! ischop;
4737 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4738 arg = ischop ? 512 : 0;
4740 s++; /* skip the '0' first */
4744 const char * const f = ++s;
4747 arg |= 256 + (s - f);
4749 *fpc++ = s - base; /* fieldsize for FETCH */
4750 *fpc++ = FF_0DECIMAL;
4752 unchopnum |= ! ischop;
4756 bool ismore = FALSE;
4759 while (*++s == '>') ;
4760 prespace = FF_SPACE;
4762 else if (*s == '|') {
4763 while (*++s == '|') ;
4764 prespace = FF_HALFSPACE;
4769 while (*++s == '<') ;
4772 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4776 *fpc++ = s - base; /* fieldsize for FETCH */
4778 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4781 *fpc++ = (U16)prespace;
4795 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4797 { /* need to jump to the next word */
4799 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4800 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4801 s = SvPVX(sv) + SvCUR(sv) + z;
4803 Copy(fops, s, arg, U32);
4805 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4808 if (unchopnum && repeat)
4809 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4815 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4817 /* Can value be printed in fldsize chars, using %*.*f ? */
4821 int intsize = fldsize - (value < 0 ? 1 : 0);
4828 while (intsize--) pwr *= 10.0;
4829 while (frcsize--) eps /= 10.0;
4832 if (value + eps >= pwr)
4835 if (value - eps <= -pwr)
4842 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4845 SV * const datasv = FILTER_DATA(idx);
4846 const int filter_has_file = IoLINES(datasv);
4847 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4848 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4852 const char *got_p = NULL;
4853 const char *prune_from = NULL;
4854 bool read_from_cache = FALSE;
4857 PERL_ARGS_ASSERT_RUN_USER_FILTER;
4859 assert(maxlen >= 0);
4862 /* I was having segfault trouble under Linux 2.2.5 after a
4863 parse error occured. (Had to hack around it with a test
4864 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4865 not sure where the trouble is yet. XXX */
4868 SV *const cache = datasv;
4871 const char *cache_p = SvPV(cache, cache_len);
4875 /* Running in block mode and we have some cached data already.
4877 if (cache_len >= umaxlen) {
4878 /* In fact, so much data we don't even need to call
4883 const char *const first_nl =
4884 (const char *)memchr(cache_p, '\n', cache_len);
4886 take = first_nl + 1 - cache_p;
4890 sv_catpvn(buf_sv, cache_p, take);
4891 sv_chop(cache, cache_p + take);
4892 /* Definately not EOF */
4896 sv_catsv(buf_sv, cache);
4898 umaxlen -= cache_len;
4901 read_from_cache = TRUE;
4905 /* Filter API says that the filter appends to the contents of the buffer.
4906 Usually the buffer is "", so the details don't matter. But if it's not,
4907 then clearly what it contains is already filtered by this filter, so we
4908 don't want to pass it in a second time.
4909 I'm going to use a mortal in case the upstream filter croaks. */
4910 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4911 ? sv_newmortal() : buf_sv;
4912 SvUPGRADE(upstream, SVt_PV);
4914 if (filter_has_file) {
4915 status = FILTER_READ(idx+1, upstream, 0);
4918 if (filter_sub && status >= 0) {
4922 ENTER_with_name("call_filter_sub");
4927 DEFSV_set(upstream);
4931 PUSHs(filter_state);
4934 count = call_sv(filter_sub, G_SCALAR);
4946 LEAVE_with_name("call_filter_sub");
4949 if(SvOK(upstream)) {
4950 got_p = SvPV(upstream, got_len);
4952 if (got_len > umaxlen) {
4953 prune_from = got_p + umaxlen;
4956 const char *const first_nl =
4957 (const char *)memchr(got_p, '\n', got_len);
4958 if (first_nl && first_nl + 1 < got_p + got_len) {
4959 /* There's a second line here... */
4960 prune_from = first_nl + 1;
4965 /* Oh. Too long. Stuff some in our cache. */
4966 STRLEN cached_len = got_p + got_len - prune_from;
4967 SV *const cache = datasv;
4970 /* Cache should be empty. */
4971 assert(!SvCUR(cache));
4974 sv_setpvn(cache, prune_from, cached_len);
4975 /* If you ask for block mode, you may well split UTF-8 characters.
4976 "If it breaks, you get to keep both parts"
4977 (Your code is broken if you don't put them back together again
4978 before something notices.) */
4979 if (SvUTF8(upstream)) {
4982 SvCUR_set(upstream, got_len - cached_len);
4983 /* Can't yet be EOF */
4988 /* If they are at EOF but buf_sv has something in it, then they may never
4989 have touched the SV upstream, so it may be undefined. If we naively
4990 concatenate it then we get a warning about use of uninitialised value.
4992 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4993 sv_catsv(buf_sv, upstream);
4997 IoLINES(datasv) = 0;
4999 SvREFCNT_dec(filter_state);
5000 IoTOP_GV(datasv) = NULL;
5003 SvREFCNT_dec(filter_sub);
5004 IoBOTTOM_GV(datasv) = NULL;
5006 filter_del(S_run_user_filter);
5008 if (status == 0 && read_from_cache) {
5009 /* If we read some data from the cache (and by getting here it implies
5010 that we emptied the cache) then we aren't yet at EOF, and mustn't
5011 report that to our caller. */
5017 /* perhaps someone can come up with a better name for
5018 this? it is not really "absolute", per se ... */
5020 S_path_is_absolute(const char *name)
5022 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5024 if (PERL_FILE_IS_ABSOLUTE(name)
5026 || (*name == '.' && ((name[1] == '/' ||
5027 (name[1] == '.' && name[2] == '/'))
5028 || (name[1] == '\\' ||
5029 ( name[1] == '.' && name[2] == '\\')))
5032 || (*name == '.' && (name[1] == '/' ||
5033 (name[1] == '.' && name[2] == '/')))
5045 * c-indentation-style: bsd
5047 * indent-tabs-mode: t
5050 * ex: set ts=8 sts=4 sw=4 noet: