3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 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.
20 /* This file contains control-oriented pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
26 * Control-oriented means things like pp_enteriter() and pp_next(), which
27 * alter the flow of control of the program.
32 #define PERL_IN_PP_CTL_C
36 #define WORD_ALIGN sizeof(U32)
39 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
41 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
50 cxix = dopoptosub(cxstack_ix);
54 switch (cxstack[cxix].blk_gimme) {
67 /* XXXX Should store the old value to allow for tie/overload - and
68 restore in regcomp, where marked with XXXX. */
78 register PMOP *pm = (PMOP*)cLOGOP->op_other;
82 /* prevent recompiling under /o and ithreads. */
83 #if defined(USE_ITHREADS)
84 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
85 if (PL_op->op_flags & OPf_STACKED) {
94 if (PL_op->op_flags & OPf_STACKED) {
95 /* multiple args; concatentate them */
97 tmpstr = PAD_SV(ARGTARG);
98 sv_setpvn(tmpstr, "", 0);
99 while (++MARK <= SP) {
100 if (PL_amagic_generation) {
102 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
103 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
105 sv_setsv(tmpstr, sv);
109 sv_catsv(tmpstr, *MARK);
118 SV * const sv = SvRV(tmpstr);
119 if (SvTYPE(sv) == SVt_REGEXP)
123 re = reg_temp_copy(re);
124 ReREFCNT_dec(PM_GETRE(pm));
129 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
131 assert (re != (REGEXP*) &PL_sv_undef);
133 /* Check against the last compiled regexp. */
134 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
135 memNE(RX_PRECOMP(re), t, len))
137 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
138 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
142 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
144 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
146 } else if (PL_curcop->cop_hints_hash) {
147 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
149 if (ptr && SvIOK(ptr) && SvIV(ptr))
150 eng = INT2PTR(regexp_engine*,SvIV(ptr));
153 if (PL_op->op_flags & OPf_SPECIAL)
154 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
156 if (DO_UTF8(tmpstr)) {
157 assert (SvUTF8(tmpstr));
158 } else if (SvUTF8(tmpstr)) {
159 /* Not doing UTF-8, despite what the SV says. Is this only if
160 we're trapped in use 'bytes'? */
161 /* Make a copy of the octet sequence, but without the flag on,
162 as the compiler now honours the SvUTF8 flag on tmpstr. */
164 const char *const p = SvPV(tmpstr, len);
165 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
169 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
171 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
173 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
174 inside tie/overload accessors. */
180 #ifndef INCOMPLETE_TAINTS
183 RX_EXTFLAGS(re) |= RXf_TAINTED;
185 RX_EXTFLAGS(re) &= ~RXf_TAINTED;
189 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
193 #if !defined(USE_ITHREADS)
194 /* can't change the optree at runtime either */
195 /* PMf_KEEP is handled differently under threads to avoid these problems */
196 if (pm->op_pmflags & PMf_KEEP) {
197 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
198 cLOGOP->op_first->op_next = PL_op->op_next;
208 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
209 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
210 register SV * const dstr = cx->sb_dstr;
211 register char *s = cx->sb_s;
212 register char *m = cx->sb_m;
213 char *orig = cx->sb_orig;
214 register REGEXP * const rx = cx->sb_rx;
216 REGEXP *old = PM_GETRE(pm);
220 PM_SETRE(pm,ReREFCNT_inc(rx));
223 rxres_restore(&cx->sb_rxres, rx);
224 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
226 if (cx->sb_iters++) {
227 const I32 saviters = cx->sb_iters;
228 if (cx->sb_iters > cx->sb_maxiters)
229 DIE(aTHX_ "Substitution loop");
231 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
232 cx->sb_rxtainted |= 2;
233 sv_catsv(dstr, POPs);
234 FREETMPS; /* Prevent excess tmp stack */
237 if (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
238 s == m, cx->sb_targ, NULL,
239 ((cx->sb_rflags & REXEC_COPY_STR)
240 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
241 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
243 SV * const targ = cx->sb_targ;
245 assert(cx->sb_strend >= s);
246 if(cx->sb_strend > s) {
247 if (DO_UTF8(dstr) && !SvUTF8(targ))
248 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
250 sv_catpvn(dstr, s, cx->sb_strend - s);
252 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
254 #ifdef PERL_OLD_COPY_ON_WRITE
256 sv_force_normal_flags(targ, SV_COW_DROP_PV);
262 SvPV_set(targ, SvPVX(dstr));
263 SvCUR_set(targ, SvCUR(dstr));
264 SvLEN_set(targ, SvLEN(dstr));
267 SvPV_set(dstr, NULL);
269 TAINT_IF(cx->sb_rxtainted & 1);
270 mPUSHi(saviters - 1);
272 (void)SvPOK_only_UTF8(targ);
273 TAINT_IF(cx->sb_rxtainted);
277 LEAVE_SCOPE(cx->sb_oldsave);
279 RETURNOP(pm->op_next);
281 cx->sb_iters = saviters;
283 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
286 cx->sb_orig = orig = RX_SUBBEG(rx);
288 cx->sb_strend = s + (cx->sb_strend - m);
290 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
292 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
293 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
295 sv_catpvn(dstr, s, m-s);
297 cx->sb_s = RX_OFFS(rx)[0].end + orig;
298 { /* Update the pos() information. */
299 SV * const sv = cx->sb_targ;
302 SvUPGRADE(sv, SVt_PVMG);
303 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
304 #ifdef PERL_OLD_COPY_ON_WRITE
306 sv_force_normal_flags(sv, 0);
308 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
317 (void)ReREFCNT_inc(rx);
318 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
319 rxres_save(&cx->sb_rxres, rx);
320 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
324 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
330 if (!p || p[1] < RX_NPARENS(rx)) {
331 #ifdef PERL_OLD_COPY_ON_WRITE
332 i = 7 + RX_NPARENS(rx) * 2;
334 i = 6 + RX_NPARENS(rx) * 2;
343 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
344 RX_MATCH_COPIED_off(rx);
346 #ifdef PERL_OLD_COPY_ON_WRITE
347 *p++ = PTR2UV(RX_SAVED_COPY(rx));
348 RX_SAVED_COPY(rx) = NULL;
351 *p++ = RX_NPARENS(rx);
353 *p++ = PTR2UV(RX_SUBBEG(rx));
354 *p++ = (UV)RX_SUBLEN(rx);
355 for (i = 0; i <= RX_NPARENS(rx); ++i) {
356 *p++ = (UV)RX_OFFS(rx)[i].start;
357 *p++ = (UV)RX_OFFS(rx)[i].end;
362 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
368 RX_MATCH_COPY_FREE(rx);
369 RX_MATCH_COPIED_set(rx, *p);
372 #ifdef PERL_OLD_COPY_ON_WRITE
373 if (RX_SAVED_COPY(rx))
374 SvREFCNT_dec (RX_SAVED_COPY(rx));
375 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
379 RX_NPARENS(rx) = *p++;
381 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
382 RX_SUBLEN(rx) = (I32)(*p++);
383 for (i = 0; i <= RX_NPARENS(rx); ++i) {
384 RX_OFFS(rx)[i].start = (I32)(*p++);
385 RX_OFFS(rx)[i].end = (I32)(*p++);
390 Perl_rxres_free(pTHX_ void **rsp)
392 UV * const p = (UV*)*rsp;
397 void *tmp = INT2PTR(char*,*p);
400 PoisonFree(*p, 1, sizeof(*p));
402 Safefree(INT2PTR(char*,*p));
404 #ifdef PERL_OLD_COPY_ON_WRITE
406 SvREFCNT_dec (INT2PTR(SV*,p[1]));
416 dVAR; dSP; dMARK; dORIGMARK;
417 register SV * const tmpForm = *++MARK;
422 register SV *sv = NULL;
423 const char *item = NULL;
427 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
428 const char *chophere = NULL;
429 char *linemark = NULL;
431 bool gotsome = FALSE;
433 const STRLEN fudge = SvPOK(tmpForm)
434 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
435 bool item_is_utf8 = FALSE;
436 bool targ_is_utf8 = FALSE;
438 OP * parseres = NULL;
442 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
443 if (SvREADONLY(tmpForm)) {
444 SvREADONLY_off(tmpForm);
445 parseres = doparseform(tmpForm);
446 SvREADONLY_on(tmpForm);
449 parseres = doparseform(tmpForm);
453 SvPV_force(PL_formtarget, len);
454 if (DO_UTF8(PL_formtarget))
456 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
458 f = SvPV_const(tmpForm, len);
459 /* need to jump to the next word */
460 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
464 const char *name = "???";
467 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
468 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
469 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
470 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
471 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
473 case FF_CHECKNL: name = "CHECKNL"; break;
474 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
475 case FF_SPACE: name = "SPACE"; break;
476 case FF_HALFSPACE: name = "HALFSPACE"; break;
477 case FF_ITEM: name = "ITEM"; break;
478 case FF_CHOP: name = "CHOP"; break;
479 case FF_LINEGLOB: name = "LINEGLOB"; break;
480 case FF_NEWLINE: name = "NEWLINE"; break;
481 case FF_MORE: name = "MORE"; break;
482 case FF_LINEMARK: name = "LINEMARK"; break;
483 case FF_END: name = "END"; break;
484 case FF_0DECIMAL: name = "0DECIMAL"; break;
485 case FF_LINESNGL: name = "LINESNGL"; break;
488 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
490 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
501 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
502 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
504 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
505 t = SvEND(PL_formtarget);
508 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
509 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
511 sv_utf8_upgrade(PL_formtarget);
512 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
513 t = SvEND(PL_formtarget);
533 if (ckWARN(WARN_SYNTAX))
534 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
541 const char *s = item = SvPV_const(sv, len);
544 itemsize = sv_len_utf8(sv);
545 if (itemsize != (I32)len) {
547 if (itemsize > fieldsize) {
548 itemsize = fieldsize;
549 itembytes = itemsize;
550 sv_pos_u2b(sv, &itembytes, 0);
554 send = chophere = s + itembytes;
564 sv_pos_b2u(sv, &itemsize);
568 item_is_utf8 = FALSE;
569 if (itemsize > fieldsize)
570 itemsize = fieldsize;
571 send = chophere = s + itemsize;
585 const char *s = item = SvPV_const(sv, len);
588 itemsize = sv_len_utf8(sv);
589 if (itemsize != (I32)len) {
591 if (itemsize <= fieldsize) {
592 const char *send = chophere = s + itemsize;
605 itemsize = fieldsize;
606 itembytes = itemsize;
607 sv_pos_u2b(sv, &itembytes, 0);
608 send = chophere = s + itembytes;
609 while (s < send || (s == send && isSPACE(*s))) {
619 if (strchr(PL_chopset, *s))
624 itemsize = chophere - item;
625 sv_pos_b2u(sv, &itemsize);
631 item_is_utf8 = FALSE;
632 if (itemsize <= fieldsize) {
633 const char *const send = chophere = s + itemsize;
646 itemsize = fieldsize;
647 send = chophere = s + itemsize;
648 while (s < send || (s == send && isSPACE(*s))) {
658 if (strchr(PL_chopset, *s))
663 itemsize = chophere - item;
669 arg = fieldsize - itemsize;
678 arg = fieldsize - itemsize;
689 const char *s = item;
693 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
695 sv_utf8_upgrade(PL_formtarget);
696 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
697 t = SvEND(PL_formtarget);
701 if (UTF8_IS_CONTINUED(*s)) {
702 STRLEN skip = UTF8SKIP(s);
719 if ( !((*t++ = *s++) & ~31) )
725 if (targ_is_utf8 && !item_is_utf8) {
726 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
728 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
729 for (; t < SvEND(PL_formtarget); t++) {
742 const int ch = *t++ = *s++;
745 if ( !((*t++ = *s++) & ~31) )
754 const char *s = chophere;
772 const char *s = item = SvPV_const(sv, len);
774 if ((item_is_utf8 = DO_UTF8(sv)))
775 itemsize = sv_len_utf8(sv);
777 bool chopped = FALSE;
778 const char *const send = s + len;
780 chophere = s + itemsize;
796 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
798 SvUTF8_on(PL_formtarget);
800 SvCUR_set(sv, chophere - item);
801 sv_catsv(PL_formtarget, sv);
802 SvCUR_set(sv, itemsize);
804 sv_catsv(PL_formtarget, sv);
806 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
807 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
808 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
817 #if defined(USE_LONG_DOUBLE)
820 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
824 "%#0*.*f" : "%0*.*f");
829 #if defined(USE_LONG_DOUBLE)
831 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
834 ((arg & 256) ? "%#*.*f" : "%*.*f");
837 /* If the field is marked with ^ and the value is undefined,
839 if ((arg & 512) && !SvOK(sv)) {
847 /* overflow evidence */
848 if (num_overflow(value, fieldsize, arg)) {
854 /* Formats aren't yet marked for locales, so assume "yes". */
856 STORE_NUMERIC_STANDARD_SET_LOCAL();
857 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
858 RESTORE_NUMERIC_STANDARD();
865 while (t-- > linemark && *t == ' ') ;
873 if (arg) { /* repeat until fields exhausted? */
875 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
876 lines += FmLINES(PL_formtarget);
879 if (strnEQ(linemark, linemark - arg, arg))
880 DIE(aTHX_ "Runaway format");
883 SvUTF8_on(PL_formtarget);
884 FmLINES(PL_formtarget) = lines;
886 RETURNOP(cLISTOP->op_first);
897 const char *s = chophere;
898 const char *send = item + len;
900 while (isSPACE(*s) && (s < send))
905 arg = fieldsize - itemsize;
912 if (strnEQ(s1," ",3)) {
913 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
924 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
926 SvUTF8_on(PL_formtarget);
927 FmLINES(PL_formtarget) += lines;
939 if (PL_stack_base + *PL_markstack_ptr == SP) {
941 if (GIMME_V == G_SCALAR)
943 RETURNOP(PL_op->op_next->op_next);
945 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
946 pp_pushmark(); /* push dst */
947 pp_pushmark(); /* push src */
948 ENTER; /* enter outer scope */
951 if (PL_op->op_private & OPpGREP_LEX)
952 SAVESPTR(PAD_SVl(PL_op->op_targ));
955 ENTER; /* enter inner scope */
958 src = PL_stack_base[*PL_markstack_ptr];
960 if (PL_op->op_private & OPpGREP_LEX)
961 PAD_SVl(PL_op->op_targ) = src;
966 if (PL_op->op_type == OP_MAPSTART)
967 pp_pushmark(); /* push top */
968 return ((LOGOP*)PL_op->op_next)->op_other;
974 const I32 gimme = GIMME_V;
975 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
981 /* first, move source pointer to the next item in the source list */
982 ++PL_markstack_ptr[-1];
984 /* if there are new items, push them into the destination list */
985 if (items && gimme != G_VOID) {
986 /* might need to make room back there first */
987 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
988 /* XXX this implementation is very pessimal because the stack
989 * is repeatedly extended for every set of items. Is possible
990 * to do this without any stack extension or copying at all
991 * by maintaining a separate list over which the map iterates
992 * (like foreach does). --gsar */
994 /* everything in the stack after the destination list moves
995 * towards the end the stack by the amount of room needed */
996 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
998 /* items to shift up (accounting for the moved source pointer) */
999 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1001 /* This optimization is by Ben Tilly and it does
1002 * things differently from what Sarathy (gsar)
1003 * is describing. The downside of this optimization is
1004 * that leaves "holes" (uninitialized and hopefully unused areas)
1005 * to the Perl stack, but on the other hand this
1006 * shouldn't be a problem. If Sarathy's idea gets
1007 * implemented, this optimization should become
1008 * irrelevant. --jhi */
1010 shift = count; /* Avoid shifting too often --Ben Tilly */
1014 dst = (SP += shift);
1015 PL_markstack_ptr[-1] += shift;
1016 *PL_markstack_ptr += shift;
1020 /* copy the new items down to the destination list */
1021 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1022 if (gimme == G_ARRAY) {
1024 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1027 /* scalar context: we don't care about which values map returns
1028 * (we use undef here). And so we certainly don't want to do mortal
1029 * copies of meaningless values. */
1030 while (items-- > 0) {
1032 *dst-- = &PL_sv_undef;
1036 LEAVE; /* exit inner scope */
1039 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1041 (void)POPMARK; /* pop top */
1042 LEAVE; /* exit outer scope */
1043 (void)POPMARK; /* pop src */
1044 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1045 (void)POPMARK; /* pop dst */
1046 SP = PL_stack_base + POPMARK; /* pop original mark */
1047 if (gimme == G_SCALAR) {
1048 if (PL_op->op_private & OPpGREP_LEX) {
1049 SV* sv = sv_newmortal();
1050 sv_setiv(sv, items);
1058 else if (gimme == G_ARRAY)
1065 ENTER; /* enter inner scope */
1068 /* set $_ to the new source item */
1069 src = PL_stack_base[PL_markstack_ptr[-1]];
1071 if (PL_op->op_private & OPpGREP_LEX)
1072 PAD_SVl(PL_op->op_targ) = src;
1076 RETURNOP(cLOGOP->op_other);
1085 if (GIMME == G_ARRAY)
1087 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1088 return cLOGOP->op_other;
1098 if (GIMME == G_ARRAY) {
1099 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1103 SV * const targ = PAD_SV(PL_op->op_targ);
1106 if (PL_op->op_private & OPpFLIP_LINENUM) {
1107 if (GvIO(PL_last_in_gv)) {
1108 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1111 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1113 flip = SvIV(sv) == SvIV(GvSV(gv));
1119 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1120 if (PL_op->op_flags & OPf_SPECIAL) {
1128 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1131 sv_setpvn(TARG, "", 0);
1137 /* This code tries to decide if "$left .. $right" should use the
1138 magical string increment, or if the range is numeric (we make
1139 an exception for .."0" [#18165]). AMS 20021031. */
1141 #define RANGE_IS_NUMERIC(left,right) ( \
1142 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1143 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1144 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1145 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1146 && (!SvOK(right) || looks_like_number(right))))
1152 if (GIMME == G_ARRAY) {
1158 if (RANGE_IS_NUMERIC(left,right)) {
1161 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1162 (SvOK(right) && SvNV(right) > IV_MAX))
1163 DIE(aTHX_ "Range iterator outside integer range");
1174 SV * const sv = sv_2mortal(newSViv(i++));
1179 SV * const final = sv_mortalcopy(right);
1181 const char * const tmps = SvPV_const(final, len);
1183 SV *sv = sv_mortalcopy(left);
1184 SvPV_force_nolen(sv);
1185 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1187 if (strEQ(SvPVX_const(sv),tmps))
1189 sv = sv_2mortal(newSVsv(sv));
1196 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1200 if (PL_op->op_private & OPpFLIP_LINENUM) {
1201 if (GvIO(PL_last_in_gv)) {
1202 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1205 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1206 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1214 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1215 sv_catpvs(targ, "E0");
1225 static const char * const context_name[] = {
1238 S_dopoptolabel(pTHX_ const char *label)
1243 for (i = cxstack_ix; i >= 0; i--) {
1244 register const PERL_CONTEXT * const cx = &cxstack[i];
1245 switch (CxTYPE(cx)) {
1253 if (ckWARN(WARN_EXITING))
1254 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1255 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1256 if (CxTYPE(cx) == CXt_NULL)
1259 case CXt_LOOP_LAZYIV:
1260 case CXt_LOOP_LAZYSV:
1262 case CXt_LOOP_PLAIN:
1263 if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
1264 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1265 (long)i, CxLABEL(cx)));
1268 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1278 Perl_dowantarray(pTHX)
1281 const I32 gimme = block_gimme();
1282 return (gimme == G_VOID) ? G_SCALAR : gimme;
1286 Perl_block_gimme(pTHX)
1289 const I32 cxix = dopoptosub(cxstack_ix);
1293 switch (cxstack[cxix].blk_gimme) {
1301 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1308 Perl_is_lvalue_sub(pTHX)
1311 const I32 cxix = dopoptosub(cxstack_ix);
1312 assert(cxix >= 0); /* We should only be called from inside subs */
1314 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1315 return CxLVAL(cxstack + cxix);
1321 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1325 for (i = startingblock; i >= 0; i--) {
1326 register const PERL_CONTEXT * const cx = &cxstk[i];
1327 switch (CxTYPE(cx)) {
1333 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1341 S_dopoptoeval(pTHX_ I32 startingblock)
1345 for (i = startingblock; i >= 0; i--) {
1346 register const PERL_CONTEXT *cx = &cxstack[i];
1347 switch (CxTYPE(cx)) {
1351 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1359 S_dopoptoloop(pTHX_ I32 startingblock)
1363 for (i = startingblock; i >= 0; i--) {
1364 register const PERL_CONTEXT * const cx = &cxstack[i];
1365 switch (CxTYPE(cx)) {
1371 if (ckWARN(WARN_EXITING))
1372 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1373 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1374 if ((CxTYPE(cx)) == CXt_NULL)
1377 case CXt_LOOP_LAZYIV:
1378 case CXt_LOOP_LAZYSV:
1380 case CXt_LOOP_PLAIN:
1381 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1389 S_dopoptogiven(pTHX_ I32 startingblock)
1393 for (i = startingblock; i >= 0; i--) {
1394 register const PERL_CONTEXT *cx = &cxstack[i];
1395 switch (CxTYPE(cx)) {
1399 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1401 case CXt_LOOP_PLAIN:
1402 assert(!CxFOREACHDEF(cx));
1404 case CXt_LOOP_LAZYIV:
1405 case CXt_LOOP_LAZYSV:
1407 if (CxFOREACHDEF(cx)) {
1408 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1417 S_dopoptowhen(pTHX_ I32 startingblock)
1421 for (i = startingblock; i >= 0; i--) {
1422 register const PERL_CONTEXT *cx = &cxstack[i];
1423 switch (CxTYPE(cx)) {
1427 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1435 Perl_dounwind(pTHX_ I32 cxix)
1440 while (cxstack_ix > cxix) {
1442 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1443 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1444 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1445 /* Note: we don't need to restore the base context info till the end. */
1446 switch (CxTYPE(cx)) {
1449 continue; /* not break */
1457 case CXt_LOOP_LAZYIV:
1458 case CXt_LOOP_LAZYSV:
1460 case CXt_LOOP_PLAIN:
1471 PERL_UNUSED_VAR(optype);
1475 Perl_qerror(pTHX_ SV *err)
1479 sv_catsv(ERRSV, err);
1481 sv_catsv(PL_errors, err);
1483 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1485 ++PL_parser->error_count;
1489 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1498 if (PL_in_eval & EVAL_KEEPERR) {
1499 static const char prefix[] = "\t(in cleanup) ";
1500 SV * const err = ERRSV;
1501 const char *e = NULL;
1503 sv_setpvn(err,"",0);
1504 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1506 e = SvPV_const(err, len);
1508 if (*e != *message || strNE(e,message))
1512 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1513 sv_catpvn(err, prefix, sizeof(prefix)-1);
1514 sv_catpvn(err, message, msglen);
1515 if (ckWARN(WARN_MISC)) {
1516 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1517 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1522 sv_setpvn(ERRSV, message, msglen);
1526 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1527 && PL_curstackinfo->si_prev)
1535 register PERL_CONTEXT *cx;
1538 if (cxix < cxstack_ix)
1541 POPBLOCK(cx,PL_curpm);
1542 if (CxTYPE(cx) != CXt_EVAL) {
1544 message = SvPVx_const(ERRSV, msglen);
1545 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1546 PerlIO_write(Perl_error_log, message, msglen);
1551 if (gimme == G_SCALAR)
1552 *++newsp = &PL_sv_undef;
1553 PL_stack_sp = newsp;
1557 /* LEAVE could clobber PL_curcop (see save_re_context())
1558 * XXX it might be better to find a way to avoid messing with
1559 * PL_curcop in save_re_context() instead, but this is a more
1560 * minimal fix --GSAR */
1561 PL_curcop = cx->blk_oldcop;
1563 if (optype == OP_REQUIRE) {
1564 const char* const msg = SvPVx_nolen_const(ERRSV);
1565 SV * const nsv = cx->blk_eval.old_namesv;
1566 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1568 DIE(aTHX_ "%sCompilation failed in require",
1569 *msg ? msg : "Unknown error\n");
1571 assert(CxTYPE(cx) == CXt_EVAL);
1572 return cx->blk_eval.retop;
1576 message = SvPVx_const(ERRSV, msglen);
1578 write_to_stderr(message, msglen);
1586 dVAR; dSP; dPOPTOPssrl;
1587 if (SvTRUE(left) != SvTRUE(right))
1597 register I32 cxix = dopoptosub(cxstack_ix);
1598 register const PERL_CONTEXT *cx;
1599 register const PERL_CONTEXT *ccstack = cxstack;
1600 const PERL_SI *top_si = PL_curstackinfo;
1602 const char *stashname;
1609 /* we may be in a higher stacklevel, so dig down deeper */
1610 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1611 top_si = top_si->si_prev;
1612 ccstack = top_si->si_cxstack;
1613 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1616 if (GIMME != G_ARRAY) {
1622 /* caller() should not report the automatic calls to &DB::sub */
1623 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1624 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1628 cxix = dopoptosub_at(ccstack, cxix - 1);
1631 cx = &ccstack[cxix];
1632 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1633 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1634 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1635 field below is defined for any cx. */
1636 /* caller() should not report the automatic calls to &DB::sub */
1637 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1638 cx = &ccstack[dbcxix];
1641 stashname = CopSTASHPV(cx->blk_oldcop);
1642 if (GIMME != G_ARRAY) {
1645 PUSHs(&PL_sv_undef);
1648 sv_setpv(TARG, stashname);
1657 PUSHs(&PL_sv_undef);
1659 mPUSHs(newSVpv(stashname, 0));
1660 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1661 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1664 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1665 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1666 /* So is ccstack[dbcxix]. */
1668 SV * const sv = newSV(0);
1669 gv_efullname3(sv, cvgv, NULL);
1671 PUSHs(boolSV(CxHASARGS(cx)));
1674 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1675 PUSHs(boolSV(CxHASARGS(cx)));
1679 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1682 gimme = (I32)cx->blk_gimme;
1683 if (gimme == G_VOID)
1684 PUSHs(&PL_sv_undef);
1686 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1687 if (CxTYPE(cx) == CXt_EVAL) {
1689 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1690 PUSHs(cx->blk_eval.cur_text);
1694 else if (cx->blk_eval.old_namesv) {
1695 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1698 /* eval BLOCK (try blocks have old_namesv == 0) */
1700 PUSHs(&PL_sv_undef);
1701 PUSHs(&PL_sv_undef);
1705 PUSHs(&PL_sv_undef);
1706 PUSHs(&PL_sv_undef);
1708 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1709 && CopSTASH_eq(PL_curcop, PL_debstash))
1711 AV * const ary = cx->blk_sub.argarray;
1712 const int off = AvARRAY(ary) - AvALLOC(ary);
1715 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1716 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1718 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1721 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1722 av_extend(PL_dbargs, AvFILLp(ary) + off);
1723 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1724 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1726 /* XXX only hints propagated via op_private are currently
1727 * visible (others are not easily accessible, since they
1728 * use the global PL_hints) */
1729 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1732 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1734 if (old_warnings == pWARN_NONE ||
1735 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1736 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1737 else if (old_warnings == pWARN_ALL ||
1738 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1739 /* Get the bit mask for $warnings::Bits{all}, because
1740 * it could have been extended by warnings::register */
1742 HV * const bits = get_hv("warnings::Bits", FALSE);
1743 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1744 mask = newSVsv(*bits_all);
1747 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1751 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1755 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1756 sv_2mortal(newRV_noinc(
1757 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1758 cx->blk_oldcop->cop_hints_hash)))
1767 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1768 sv_reset(tmps, CopSTASH(PL_curcop));
1773 /* like pp_nextstate, but used instead when the debugger is active */
1778 PL_curcop = (COP*)PL_op;
1779 TAINT_NOT; /* Each statement is presumed innocent */
1780 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1783 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1784 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1787 register PERL_CONTEXT *cx;
1788 const I32 gimme = G_ARRAY;
1790 GV * const gv = PL_DBgv;
1791 register CV * const cv = GvCV(gv);
1794 DIE(aTHX_ "No DB::DB routine defined");
1796 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1797 /* don't do recursive DB::DB call */
1812 (void)(*CvXSUB(cv))(aTHX_ cv);
1819 PUSHBLOCK(cx, CXt_SUB, SP);
1821 cx->blk_sub.retop = PL_op->op_next;
1824 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1825 RETURNOP(CvSTART(cv));
1835 register PERL_CONTEXT *cx;
1836 const I32 gimme = GIMME_V;
1838 U8 cxtype = CXt_LOOP_FOR;
1846 if (PL_op->op_targ) {
1847 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1848 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1849 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1850 SVs_PADSTALE, SVs_PADSTALE);
1852 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1853 #ifndef USE_ITHREADS
1854 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1860 GV * const gv = (GV*)POPs;
1861 svp = &GvSV(gv); /* symbol table variable */
1862 SAVEGENERICSV(*svp);
1865 iterdata = (PAD*)gv;
1869 if (PL_op->op_private & OPpITER_DEF)
1870 cxtype |= CXp_FOR_DEF;
1874 PUSHBLOCK(cx, cxtype, SP);
1876 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1878 PUSHLOOP_FOR(cx, svp, MARK, 0);
1880 if (PL_op->op_flags & OPf_STACKED) {
1881 SV *maybe_ary = POPs;
1882 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1884 SV * const right = maybe_ary;
1887 if (RANGE_IS_NUMERIC(sv,right)) {
1888 cx->cx_type &= ~CXTYPEMASK;
1889 cx->cx_type |= CXt_LOOP_LAZYIV;
1890 /* Make sure that no-one re-orders cop.h and breaks our
1892 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1893 #ifdef NV_PRESERVES_UV
1894 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1895 (SvNV(sv) > (NV)IV_MAX)))
1897 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1898 (SvNV(right) < (NV)IV_MIN))))
1900 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1903 ((SvUV(sv) > (UV)IV_MAX) ||
1904 (SvNV(sv) > (NV)UV_MAX)))))
1906 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1908 ((SvNV(right) > 0) &&
1909 ((SvUV(right) > (UV)IV_MAX) ||
1910 (SvNV(right) > (NV)UV_MAX))))))
1912 DIE(aTHX_ "Range iterator outside integer range");
1913 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1914 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1916 /* for correct -Dstv display */
1917 cx->blk_oldsp = sp - PL_stack_base;
1921 cx->cx_type &= ~CXTYPEMASK;
1922 cx->cx_type |= CXt_LOOP_LAZYSV;
1923 /* Make sure that no-one re-orders cop.h and breaks our
1925 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
1926 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
1927 cx->blk_loop.state_u.lazysv.end = right;
1928 SvREFCNT_inc(right);
1929 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
1930 /* This will do the upgrade to SVt_PV, and warn if the value
1931 is uninitialised. */
1932 (void) SvPV_nolen_const(right);
1933 /* Doing this avoids a check every time in pp_iter in pp_hot.c
1934 to replace !SvOK() with a pointer to "". */
1936 SvREFCNT_dec(right);
1937 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
1941 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
1942 cx->blk_loop.state_u.ary.ary = (AV*)maybe_ary;
1943 SvREFCNT_inc(maybe_ary);
1944 cx->blk_loop.state_u.ary.ix =
1945 (PL_op->op_private & OPpITER_REVERSED) ?
1946 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
1950 else { /* iterating over items on the stack */
1951 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
1952 if (PL_op->op_private & OPpITER_REVERSED) {
1953 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
1956 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
1966 register PERL_CONTEXT *cx;
1967 const I32 gimme = GIMME_V;
1973 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
1974 PUSHLOOP_PLAIN(cx, SP);
1982 register PERL_CONTEXT *cx;
1989 assert(CxTYPE_is_LOOP(cx));
1991 newsp = PL_stack_base + cx->blk_loop.resetsp;
1994 if (gimme == G_VOID)
1996 else if (gimme == G_SCALAR) {
1998 *++newsp = sv_mortalcopy(*SP);
2000 *++newsp = &PL_sv_undef;
2004 *++newsp = sv_mortalcopy(*++mark);
2005 TAINT_NOT; /* Each item is independent */
2011 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2012 PL_curpm = newpm; /* ... and pop $1 et al */
2023 register PERL_CONTEXT *cx;
2024 bool popsub2 = FALSE;
2025 bool clear_errsv = FALSE;
2033 const I32 cxix = dopoptosub(cxstack_ix);
2036 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2037 * sort block, which is a CXt_NULL
2040 PL_stack_base[1] = *PL_stack_sp;
2041 PL_stack_sp = PL_stack_base + 1;
2045 DIE(aTHX_ "Can't return outside a subroutine");
2047 if (cxix < cxstack_ix)
2050 if (CxMULTICALL(&cxstack[cxix])) {
2051 gimme = cxstack[cxix].blk_gimme;
2052 if (gimme == G_VOID)
2053 PL_stack_sp = PL_stack_base;
2054 else if (gimme == G_SCALAR) {
2055 PL_stack_base[1] = *PL_stack_sp;
2056 PL_stack_sp = PL_stack_base + 1;
2062 switch (CxTYPE(cx)) {
2065 retop = cx->blk_sub.retop;
2066 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2069 if (!(PL_in_eval & EVAL_KEEPERR))
2072 retop = cx->blk_eval.retop;
2076 if (optype == OP_REQUIRE &&
2077 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2079 /* Unassume the success we assumed earlier. */
2080 SV * const nsv = cx->blk_eval.old_namesv;
2081 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2082 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2087 retop = cx->blk_sub.retop;
2090 DIE(aTHX_ "panic: return");
2094 if (gimme == G_SCALAR) {
2097 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2099 *++newsp = SvREFCNT_inc(*SP);
2104 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2106 *++newsp = sv_mortalcopy(sv);
2111 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2114 *++newsp = sv_mortalcopy(*SP);
2117 *++newsp = &PL_sv_undef;
2119 else if (gimme == G_ARRAY) {
2120 while (++MARK <= SP) {
2121 *++newsp = (popsub2 && SvTEMP(*MARK))
2122 ? *MARK : sv_mortalcopy(*MARK);
2123 TAINT_NOT; /* Each item is independent */
2126 PL_stack_sp = newsp;
2129 /* Stack values are safe: */
2132 POPSUB(cx,sv); /* release CV and @_ ... */
2136 PL_curpm = newpm; /* ... and pop $1 et al */
2140 sv_setpvn(ERRSV,"",0);
2148 register PERL_CONTEXT *cx;
2159 if (PL_op->op_flags & OPf_SPECIAL) {
2160 cxix = dopoptoloop(cxstack_ix);
2162 DIE(aTHX_ "Can't \"last\" outside a loop block");
2165 cxix = dopoptolabel(cPVOP->op_pv);
2167 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2169 if (cxix < cxstack_ix)
2173 cxstack_ix++; /* temporarily protect top context */
2175 switch (CxTYPE(cx)) {
2176 case CXt_LOOP_LAZYIV:
2177 case CXt_LOOP_LAZYSV:
2179 case CXt_LOOP_PLAIN:
2181 newsp = PL_stack_base + cx->blk_loop.resetsp;
2182 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2186 nextop = cx->blk_sub.retop;
2190 nextop = cx->blk_eval.retop;
2194 nextop = cx->blk_sub.retop;
2197 DIE(aTHX_ "panic: last");
2201 if (gimme == G_SCALAR) {
2203 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2204 ? *SP : sv_mortalcopy(*SP);
2206 *++newsp = &PL_sv_undef;
2208 else if (gimme == G_ARRAY) {
2209 while (++MARK <= SP) {
2210 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2211 ? *MARK : sv_mortalcopy(*MARK);
2212 TAINT_NOT; /* Each item is independent */
2220 /* Stack values are safe: */
2222 case CXt_LOOP_LAZYIV:
2223 case CXt_LOOP_PLAIN:
2224 case CXt_LOOP_LAZYSV:
2226 POPLOOP(cx); /* release loop vars ... */
2230 POPSUB(cx,sv); /* release CV and @_ ... */
2233 PL_curpm = newpm; /* ... and pop $1 et al */
2236 PERL_UNUSED_VAR(optype);
2237 PERL_UNUSED_VAR(gimme);
2245 register PERL_CONTEXT *cx;
2248 if (PL_op->op_flags & OPf_SPECIAL) {
2249 cxix = dopoptoloop(cxstack_ix);
2251 DIE(aTHX_ "Can't \"next\" outside a loop block");
2254 cxix = dopoptolabel(cPVOP->op_pv);
2256 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2258 if (cxix < cxstack_ix)
2261 /* clear off anything above the scope we're re-entering, but
2262 * save the rest until after a possible continue block */
2263 inner = PL_scopestack_ix;
2265 if (PL_scopestack_ix < inner)
2266 leave_scope(PL_scopestack[PL_scopestack_ix]);
2267 PL_curcop = cx->blk_oldcop;
2268 return CX_LOOP_NEXTOP_GET(cx);
2275 register PERL_CONTEXT *cx;
2279 if (PL_op->op_flags & OPf_SPECIAL) {
2280 cxix = dopoptoloop(cxstack_ix);
2282 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2285 cxix = dopoptolabel(cPVOP->op_pv);
2287 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2289 if (cxix < cxstack_ix)
2292 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2293 if (redo_op->op_type == OP_ENTER) {
2294 /* pop one less context to avoid $x being freed in while (my $x..) */
2296 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2297 redo_op = redo_op->op_next;
2301 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2302 LEAVE_SCOPE(oldsave);
2304 PL_curcop = cx->blk_oldcop;
2309 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2313 static const char too_deep[] = "Target of goto is too deeply nested";
2316 Perl_croak(aTHX_ too_deep);
2317 if (o->op_type == OP_LEAVE ||
2318 o->op_type == OP_SCOPE ||
2319 o->op_type == OP_LEAVELOOP ||
2320 o->op_type == OP_LEAVESUB ||
2321 o->op_type == OP_LEAVETRY)
2323 *ops++ = cUNOPo->op_first;
2325 Perl_croak(aTHX_ too_deep);
2328 if (o->op_flags & OPf_KIDS) {
2330 /* First try all the kids at this level, since that's likeliest. */
2331 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2332 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2333 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2336 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2337 if (kid == PL_lastgotoprobe)
2339 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2342 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2343 ops[-1]->op_type == OP_DBSTATE)
2348 if ((o = dofindlabel(kid, label, ops, oplimit)))
2361 register PERL_CONTEXT *cx;
2362 #define GOTO_DEPTH 64
2363 OP *enterops[GOTO_DEPTH];
2364 const char *label = NULL;
2365 const bool do_dump = (PL_op->op_type == OP_DUMP);
2366 static const char must_have_label[] = "goto must have label";
2368 if (PL_op->op_flags & OPf_STACKED) {
2369 SV * const sv = POPs;
2371 /* This egregious kludge implements goto &subroutine */
2372 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2374 register PERL_CONTEXT *cx;
2375 CV* cv = (CV*)SvRV(sv);
2382 if (!CvROOT(cv) && !CvXSUB(cv)) {
2383 const GV * const gv = CvGV(cv);
2387 /* autoloaded stub? */
2388 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2390 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2391 GvNAMELEN(gv), FALSE);
2392 if (autogv && (cv = GvCV(autogv)))
2394 tmpstr = sv_newmortal();
2395 gv_efullname3(tmpstr, gv, NULL);
2396 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2398 DIE(aTHX_ "Goto undefined subroutine");
2401 /* First do some returnish stuff. */
2402 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2404 cxix = dopoptosub(cxstack_ix);
2406 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2407 if (cxix < cxstack_ix)
2411 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2412 if (CxTYPE(cx) == CXt_EVAL) {
2414 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2416 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2418 else if (CxMULTICALL(cx))
2419 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2420 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2421 /* put @_ back onto stack */
2422 AV* av = cx->blk_sub.argarray;
2424 items = AvFILLp(av) + 1;
2425 EXTEND(SP, items+1); /* @_ could have been extended. */
2426 Copy(AvARRAY(av), SP + 1, items, SV*);
2427 SvREFCNT_dec(GvAV(PL_defgv));
2428 GvAV(PL_defgv) = cx->blk_sub.savearray;
2430 /* abandon @_ if it got reified */
2435 av_extend(av, items-1);
2437 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2440 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2441 AV* const av = GvAV(PL_defgv);
2442 items = AvFILLp(av) + 1;
2443 EXTEND(SP, items+1); /* @_ could have been extended. */
2444 Copy(AvARRAY(av), SP + 1, items, SV*);
2448 if (CxTYPE(cx) == CXt_SUB &&
2449 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2450 SvREFCNT_dec(cx->blk_sub.cv);
2451 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2452 LEAVE_SCOPE(oldsave);
2454 /* Now do some callish stuff. */
2456 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2458 OP* const retop = cx->blk_sub.retop;
2463 for (index=0; index<items; index++)
2464 sv_2mortal(SP[-index]);
2467 /* XS subs don't have a CxSUB, so pop it */
2468 POPBLOCK(cx, PL_curpm);
2469 /* Push a mark for the start of arglist */
2472 (void)(*CvXSUB(cv))(aTHX_ cv);
2477 AV* const padlist = CvPADLIST(cv);
2478 if (CxTYPE(cx) == CXt_EVAL) {
2479 PL_in_eval = CxOLD_IN_EVAL(cx);
2480 PL_eval_root = cx->blk_eval.old_eval_root;
2481 cx->cx_type = CXt_SUB;
2483 cx->blk_sub.cv = cv;
2484 cx->blk_sub.olddepth = CvDEPTH(cv);
2487 if (CvDEPTH(cv) < 2)
2488 SvREFCNT_inc_simple_void_NN(cv);
2490 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2491 sub_crush_depth(cv);
2492 pad_push(padlist, CvDEPTH(cv));
2495 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2498 AV* const av = (AV*)PAD_SVl(0);
2500 cx->blk_sub.savearray = GvAV(PL_defgv);
2501 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2502 CX_CURPAD_SAVE(cx->blk_sub);
2503 cx->blk_sub.argarray = av;
2505 if (items >= AvMAX(av) + 1) {
2506 SV **ary = AvALLOC(av);
2507 if (AvARRAY(av) != ary) {
2508 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2511 if (items >= AvMAX(av) + 1) {
2512 AvMAX(av) = items - 1;
2513 Renew(ary,items+1,SV*);
2519 Copy(mark,AvARRAY(av),items,SV*);
2520 AvFILLp(av) = items - 1;
2521 assert(!AvREAL(av));
2523 /* transfer 'ownership' of refcnts to new @_ */
2533 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2534 Perl_get_db_sub(aTHX_ NULL, cv);
2536 CV * const gotocv = get_cv("DB::goto", FALSE);
2538 PUSHMARK( PL_stack_sp );
2539 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2544 RETURNOP(CvSTART(cv));
2548 label = SvPV_nolen_const(sv);
2549 if (!(do_dump || *label))
2550 DIE(aTHX_ must_have_label);
2553 else if (PL_op->op_flags & OPf_SPECIAL) {
2555 DIE(aTHX_ must_have_label);
2558 label = cPVOP->op_pv;
2560 if (label && *label) {
2561 OP *gotoprobe = NULL;
2562 bool leaving_eval = FALSE;
2563 bool in_block = FALSE;
2564 PERL_CONTEXT *last_eval_cx = NULL;
2568 PL_lastgotoprobe = NULL;
2570 for (ix = cxstack_ix; ix >= 0; ix--) {
2572 switch (CxTYPE(cx)) {
2574 leaving_eval = TRUE;
2575 if (!CxTRYBLOCK(cx)) {
2576 gotoprobe = (last_eval_cx ?
2577 last_eval_cx->blk_eval.old_eval_root :
2582 /* else fall through */
2583 case CXt_LOOP_LAZYIV:
2584 case CXt_LOOP_LAZYSV:
2586 case CXt_LOOP_PLAIN:
2587 gotoprobe = cx->blk_oldcop->op_sibling;
2593 gotoprobe = cx->blk_oldcop->op_sibling;
2596 gotoprobe = PL_main_root;
2599 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2600 gotoprobe = CvROOT(cx->blk_sub.cv);
2606 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2609 DIE(aTHX_ "panic: goto");
2610 gotoprobe = PL_main_root;
2614 retop = dofindlabel(gotoprobe, label,
2615 enterops, enterops + GOTO_DEPTH);
2619 PL_lastgotoprobe = gotoprobe;
2622 DIE(aTHX_ "Can't find label %s", label);
2624 /* if we're leaving an eval, check before we pop any frames
2625 that we're not going to punt, otherwise the error
2628 if (leaving_eval && *enterops && enterops[1]) {
2630 for (i = 1; enterops[i]; i++)
2631 if (enterops[i]->op_type == OP_ENTERITER)
2632 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2635 /* pop unwanted frames */
2637 if (ix < cxstack_ix) {
2644 oldsave = PL_scopestack[PL_scopestack_ix];
2645 LEAVE_SCOPE(oldsave);
2648 /* push wanted frames */
2650 if (*enterops && enterops[1]) {
2651 OP * const oldop = PL_op;
2652 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2653 for (; enterops[ix]; ix++) {
2654 PL_op = enterops[ix];
2655 /* Eventually we may want to stack the needed arguments
2656 * for each op. For now, we punt on the hard ones. */
2657 if (PL_op->op_type == OP_ENTERITER)
2658 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2659 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2667 if (!retop) retop = PL_main_start;
2669 PL_restartop = retop;
2670 PL_do_undump = TRUE;
2674 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2675 PL_do_undump = FALSE;
2692 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2694 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2697 PL_exit_flags |= PERL_EXIT_EXPECTED;
2699 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2700 if (anum || !(PL_minus_c && PL_madskills))
2705 PUSHs(&PL_sv_undef);
2712 S_save_lines(pTHX_ AV *array, SV *sv)
2714 const char *s = SvPVX_const(sv);
2715 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2718 while (s && s < send) {
2720 SV * const tmpstr = newSV_type(SVt_PVMG);
2722 t = strchr(s, '\n');
2728 sv_setpvn(tmpstr, s, t - s);
2729 av_store(array, line++, tmpstr);
2735 S_docatch(pTHX_ OP *o)
2739 OP * const oldop = PL_op;
2743 assert(CATCH_GET == TRUE);
2750 assert(cxstack_ix >= 0);
2751 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2752 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2757 /* die caught by an inner eval - continue inner loop */
2759 /* NB XXX we rely on the old popped CxEVAL still being at the top
2760 * of the stack; the way die_where() currently works, this
2761 * assumption is valid. In theory The cur_top_env value should be
2762 * returned in another global, the way retop (aka PL_restartop)
2764 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2767 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2769 PL_op = PL_restartop;
2786 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2787 /* sv Text to convert to OP tree. */
2788 /* startop op_free() this to undo. */
2789 /* code Short string id of the caller. */
2791 /* FIXME - how much of this code is common with pp_entereval? */
2792 dVAR; dSP; /* Make POPBLOCK work. */
2798 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2799 char *tmpbuf = tbuf;
2802 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2806 lex_start(sv, NULL, FALSE);
2808 /* switch to eval mode */
2810 if (IN_PERL_COMPILETIME) {
2811 SAVECOPSTASH_FREE(&PL_compiling);
2812 CopSTASH_set(&PL_compiling, PL_curstash);
2814 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2815 SV * const sv = sv_newmortal();
2816 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2817 code, (unsigned long)++PL_evalseq,
2818 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2823 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2824 (unsigned long)++PL_evalseq);
2825 SAVECOPFILE_FREE(&PL_compiling);
2826 CopFILE_set(&PL_compiling, tmpbuf+2);
2827 SAVECOPLINE(&PL_compiling);
2828 CopLINE_set(&PL_compiling, 1);
2829 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2830 deleting the eval's FILEGV from the stash before gv_check() runs
2831 (i.e. before run-time proper). To work around the coredump that
2832 ensues, we always turn GvMULTI_on for any globals that were
2833 introduced within evals. See force_ident(). GSAR 96-10-12 */
2834 safestr = savepvn(tmpbuf, len);
2835 SAVEDELETE(PL_defstash, safestr, len);
2837 #ifdef OP_IN_REGISTER
2843 /* we get here either during compilation, or via pp_regcomp at runtime */
2844 runtime = IN_PERL_RUNTIME;
2846 runcv = find_runcv(NULL);
2849 PL_op->op_type = OP_ENTEREVAL;
2850 PL_op->op_flags = 0; /* Avoid uninit warning. */
2851 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2855 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2857 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2858 POPBLOCK(cx,PL_curpm);
2861 (*startop)->op_type = OP_NULL;
2862 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2864 /* XXX DAPM do this properly one year */
2865 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2867 if (IN_PERL_COMPILETIME)
2868 CopHINTS_set(&PL_compiling, PL_hints);
2869 #ifdef OP_IN_REGISTER
2872 PERL_UNUSED_VAR(newsp);
2873 PERL_UNUSED_VAR(optype);
2875 return PL_eval_start;
2880 =for apidoc find_runcv
2882 Locate the CV corresponding to the currently executing sub or eval.
2883 If db_seqp is non_null, skip CVs that are in the DB package and populate
2884 *db_seqp with the cop sequence number at the point that the DB:: code was
2885 entered. (allows debuggers to eval in the scope of the breakpoint rather
2886 than in the scope of the debugger itself).
2892 Perl_find_runcv(pTHX_ U32 *db_seqp)
2898 *db_seqp = PL_curcop->cop_seq;
2899 for (si = PL_curstackinfo; si; si = si->si_prev) {
2901 for (ix = si->si_cxix; ix >= 0; ix--) {
2902 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2903 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2904 CV * const cv = cx->blk_sub.cv;
2905 /* skip DB:: code */
2906 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2907 *db_seqp = cx->blk_oldcop->cop_seq;
2912 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2920 /* Compile a require/do, an eval '', or a /(?{...})/.
2921 * In the last case, startop is non-null, and contains the address of
2922 * a pointer that should be set to the just-compiled code.
2923 * outside is the lexically enclosing CV (if any) that invoked us.
2924 * Returns a bool indicating whether the compile was successful; if so,
2925 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2926 * pushes undef (also croaks if startop != NULL).
2930 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2933 OP * const saveop = PL_op;
2935 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2936 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2941 SAVESPTR(PL_compcv);
2942 PL_compcv = (CV*)newSV_type(SVt_PVCV);
2943 CvEVAL_on(PL_compcv);
2944 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2945 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2947 CvOUTSIDE_SEQ(PL_compcv) = seq;
2948 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2950 /* set up a scratch pad */
2952 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2953 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2957 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2959 /* make sure we compile in the right package */
2961 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2962 SAVESPTR(PL_curstash);
2963 PL_curstash = CopSTASH(PL_curcop);
2965 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2966 SAVESPTR(PL_beginav);
2967 PL_beginav = newAV();
2968 SAVEFREESV(PL_beginav);
2969 SAVESPTR(PL_unitcheckav);
2970 PL_unitcheckav = newAV();
2971 SAVEFREESV(PL_unitcheckav);
2974 SAVEBOOL(PL_madskills);
2978 /* try to compile it */
2980 PL_eval_root = NULL;
2981 PL_curcop = &PL_compiling;
2982 CopARYBASE_set(PL_curcop, 0);
2983 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2984 PL_in_eval |= EVAL_KEEPERR;
2986 sv_setpvn(ERRSV,"",0);
2987 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
2988 SV **newsp; /* Used by POPBLOCK. */
2989 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2990 I32 optype = 0; /* Might be reset by POPEVAL. */
2995 op_free(PL_eval_root);
2996 PL_eval_root = NULL;
2998 SP = PL_stack_base + POPMARK; /* pop original mark */
3000 POPBLOCK(cx,PL_curpm);
3006 msg = SvPVx_nolen_const(ERRSV);
3007 if (optype == OP_REQUIRE) {
3008 const SV * const nsv = cx->blk_eval.old_namesv;
3009 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3011 Perl_croak(aTHX_ "%sCompilation failed in require",
3012 *msg ? msg : "Unknown error\n");
3015 POPBLOCK(cx,PL_curpm);
3017 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3018 (*msg ? msg : "Unknown error\n"));
3022 sv_setpvs(ERRSV, "Compilation error");
3025 PERL_UNUSED_VAR(newsp);
3026 PUSHs(&PL_sv_undef);
3030 CopLINE_set(&PL_compiling, 0);
3032 *startop = PL_eval_root;
3034 SAVEFREEOP(PL_eval_root);
3036 /* Set the context for this new optree.
3037 * If the last op is an OP_REQUIRE, force scalar context.
3038 * Otherwise, propagate the context from the eval(). */
3039 if (PL_eval_root->op_type == OP_LEAVEEVAL
3040 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3041 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3043 scalar(PL_eval_root);
3044 else if ((gimme & G_WANT) == G_VOID)
3045 scalarvoid(PL_eval_root);
3046 else if ((gimme & G_WANT) == G_ARRAY)
3049 scalar(PL_eval_root);
3051 DEBUG_x(dump_eval());
3053 /* Register with debugger: */
3054 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3055 CV * const cv = get_cv("DB::postponed", FALSE);
3059 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3061 call_sv((SV*)cv, G_DISCARD);
3066 call_list(PL_scopestack_ix, PL_unitcheckav);
3068 /* compiled okay, so do it */
3070 CvDEPTH(PL_compcv) = 1;
3071 SP = PL_stack_base + POPMARK; /* pop original mark */
3072 PL_op = saveop; /* The caller may need it. */
3073 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3080 S_check_type_and_open(pTHX_ const char *name)
3083 const int st_rc = PerlLIO_stat(name, &st);
3085 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3089 return PerlIO_open(name, PERL_SCRIPT_MODE);
3092 #ifndef PERL_DISABLE_PMC
3094 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3098 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3099 SV *const pmcsv = newSV(namelen + 2);
3100 char *const pmc = SvPVX(pmcsv);
3103 memcpy(pmc, name, namelen);
3105 pmc[namelen + 1] = '\0';
3107 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3108 fp = check_type_and_open(name);
3111 fp = check_type_and_open(pmc);
3113 SvREFCNT_dec(pmcsv);
3116 fp = check_type_and_open(name);
3121 # define doopen_pm(name, namelen) check_type_and_open(name)
3122 #endif /* !PERL_DISABLE_PMC */
3127 register PERL_CONTEXT *cx;
3134 int vms_unixname = 0;
3136 const char *tryname = NULL;
3138 const I32 gimme = GIMME_V;
3139 int filter_has_file = 0;
3140 PerlIO *tryrsfp = NULL;
3141 SV *filter_cache = NULL;
3142 SV *filter_state = NULL;
3143 SV *filter_sub = NULL;
3149 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3150 sv = new_version(sv);
3151 if (!sv_derived_from(PL_patchlevel, "version"))
3152 upg_version(PL_patchlevel, TRUE);
3153 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3154 if ( vcmp(sv,PL_patchlevel) <= 0 )
3155 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3156 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3159 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3162 SV * const req = SvRV(sv);
3163 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3165 /* get the left hand term */
3166 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3168 first = SvIV(*av_fetch(lav,0,0));
3169 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3170 || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3171 || av_len(lav) > 1 /* FP with > 3 digits */
3172 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3174 DIE(aTHX_ "Perl %"SVf" required--this is only "
3175 "%"SVf", stopped", SVfARG(vnormal(req)),
3176 SVfARG(vnormal(PL_patchlevel)));
3178 else { /* probably 'use 5.10' or 'use 5.8' */
3179 SV * hintsv = newSV(0);
3183 second = SvIV(*av_fetch(lav,1,0));
3185 second /= second >= 600 ? 100 : 10;
3186 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3187 (int)first, (int)second,0);
3188 upg_version(hintsv, TRUE);
3190 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3191 "--this is only %"SVf", stopped",
3192 SVfARG(vnormal(req)),
3193 SVfARG(vnormal(hintsv)),
3194 SVfARG(vnormal(PL_patchlevel)));
3199 /* We do this only with use, not require. */
3201 /* If we request a version >= 5.9.5, load feature.pm with the
3202 * feature bundle that corresponds to the required version. */
3203 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3204 SV *const importsv = vnormal(sv);
3205 *SvPVX_mutable(importsv) = ':';
3207 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3213 name = SvPV_const(sv, len);
3214 if (!(name && len > 0 && *name))
3215 DIE(aTHX_ "Null filename used");
3216 TAINT_PROPER("require");
3220 /* The key in the %ENV hash is in the syntax of file passed as the argument
3221 * usually this is in UNIX format, but sometimes in VMS format, which
3222 * can result in a module being pulled in more than once.
3223 * To prevent this, the key must be stored in UNIX format if the VMS
3224 * name can be translated to UNIX.
3226 if ((unixname = tounixspec(name, NULL)) != NULL) {
3227 unixlen = strlen(unixname);
3233 /* if not VMS or VMS name can not be translated to UNIX, pass it
3236 unixname = (char *) name;
3239 if (PL_op->op_type == OP_REQUIRE) {
3240 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3241 unixname, unixlen, 0);
3243 if (*svp != &PL_sv_undef)
3246 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3247 "Compilation failed in require", unixname);
3251 /* prepare to compile file */
3253 if (path_is_absolute(name)) {
3255 tryrsfp = doopen_pm(name, len);
3257 #ifdef MACOS_TRADITIONAL
3261 MacPerl_CanonDir(name, newname, 1);
3262 if (path_is_absolute(newname)) {
3264 tryrsfp = doopen_pm(newname, strlen(newname));
3269 AV * const ar = GvAVn(PL_incgv);
3275 namesv = newSV_type(SVt_PV);
3276 for (i = 0; i <= AvFILL(ar); i++) {
3277 SV * const dirsv = *av_fetch(ar, i, TRUE);
3279 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3286 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3287 && !sv_isobject(loader))
3289 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3292 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3293 PTR2UV(SvRV(dirsv)), name);
3294 tryname = SvPVX_const(namesv);
3305 if (sv_isobject(loader))
3306 count = call_method("INC", G_ARRAY);
3308 count = call_sv(loader, G_ARRAY);
3311 /* Adjust file name if the hook has set an %INC entry */
3312 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3314 tryname = SvPVX_const(*svp);
3323 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3324 && !isGV_with_GP(SvRV(arg))) {
3325 filter_cache = SvRV(arg);
3326 SvREFCNT_inc_simple_void_NN(filter_cache);
3333 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3337 if (SvTYPE(arg) == SVt_PVGV) {
3338 IO * const io = GvIO((GV *)arg);
3343 tryrsfp = IoIFP(io);
3344 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3345 PerlIO_close(IoOFP(io));
3356 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3358 SvREFCNT_inc_simple_void_NN(filter_sub);
3361 filter_state = SP[i];
3362 SvREFCNT_inc_simple_void(filter_state);
3366 if (!tryrsfp && (filter_cache || filter_sub)) {
3367 tryrsfp = PerlIO_open(BIT_BUCKET,
3382 filter_has_file = 0;
3384 SvREFCNT_dec(filter_cache);
3385 filter_cache = NULL;
3388 SvREFCNT_dec(filter_state);
3389 filter_state = NULL;
3392 SvREFCNT_dec(filter_sub);
3397 if (!path_is_absolute(name)
3398 #ifdef MACOS_TRADITIONAL
3399 /* We consider paths of the form :a:b ambiguous and interpret them first
3400 as global then as local
3402 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3409 dir = SvPV_const(dirsv, dirlen);
3415 #ifdef MACOS_TRADITIONAL
3419 MacPerl_CanonDir(name, buf2, 1);
3420 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3424 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3426 sv_setpv(namesv, unixdir);
3427 sv_catpv(namesv, unixname);
3429 # ifdef __SYMBIAN32__
3430 if (PL_origfilename[0] &&
3431 PL_origfilename[1] == ':' &&
3432 !(dir[0] && dir[1] == ':'))
3433 Perl_sv_setpvf(aTHX_ namesv,
3438 Perl_sv_setpvf(aTHX_ namesv,
3442 /* The equivalent of
3443 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3444 but without the need to parse the format string, or
3445 call strlen on either pointer, and with the correct
3446 allocation up front. */
3448 char *tmp = SvGROW(namesv, dirlen + len + 2);
3450 memcpy(tmp, dir, dirlen);
3453 /* name came from an SV, so it will have a '\0' at the
3454 end that we can copy as part of this memcpy(). */
3455 memcpy(tmp, name, len + 1);
3457 SvCUR_set(namesv, dirlen + len + 1);
3459 /* Don't even actually have to turn SvPOK_on() as we
3460 access it directly with SvPVX() below. */
3465 TAINT_PROPER("require");
3466 tryname = SvPVX_const(namesv);
3467 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3469 if (tryname[0] == '.' && tryname[1] == '/')
3473 else if (errno == EMFILE)
3474 /* no point in trying other paths if out of handles */
3481 SAVECOPFILE_FREE(&PL_compiling);
3482 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3483 SvREFCNT_dec(namesv);
3485 if (PL_op->op_type == OP_REQUIRE) {
3486 const char *msgstr = name;
3487 if(errno == EMFILE) {
3489 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3491 msgstr = SvPV_nolen_const(msg);
3493 if (namesv) { /* did we lookup @INC? */
3494 AV * const ar = GvAVn(PL_incgv);
3496 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3497 "%s in @INC%s%s (@INC contains:",
3499 (instr(msgstr, ".h ")
3500 ? " (change .h to .ph maybe?)" : ""),
3501 (instr(msgstr, ".ph ")
3502 ? " (did you run h2ph?)" : "")
3505 for (i = 0; i <= AvFILL(ar); i++) {
3506 sv_catpvs(msg, " ");
3507 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3509 sv_catpvs(msg, ")");
3510 msgstr = SvPV_nolen_const(msg);
3513 DIE(aTHX_ "Can't locate %s", msgstr);
3519 SETERRNO(0, SS_NORMAL);
3521 /* Assume success here to prevent recursive requirement. */
3522 /* name is never assigned to again, so len is still strlen(name) */
3523 /* Check whether a hook in @INC has already filled %INC */
3525 (void)hv_store(GvHVn(PL_incgv),
3526 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3528 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3530 (void)hv_store(GvHVn(PL_incgv),
3531 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3536 lex_start(NULL, tryrsfp, TRUE);
3540 SAVECOMPILEWARNINGS();
3541 if (PL_dowarn & G_WARN_ALL_ON)
3542 PL_compiling.cop_warnings = pWARN_ALL ;
3543 else if (PL_dowarn & G_WARN_ALL_OFF)
3544 PL_compiling.cop_warnings = pWARN_NONE ;
3546 PL_compiling.cop_warnings = pWARN_STD ;
3548 if (filter_sub || filter_cache) {
3549 SV * const datasv = filter_add(S_run_user_filter, NULL);
3550 IoLINES(datasv) = filter_has_file;
3551 IoTOP_GV(datasv) = (GV *)filter_state;
3552 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3553 IoFMT_GV(datasv) = (GV *)filter_cache;
3556 /* switch to eval mode */
3557 PUSHBLOCK(cx, CXt_EVAL, SP);
3559 cx->blk_eval.retop = PL_op->op_next;
3561 SAVECOPLINE(&PL_compiling);
3562 CopLINE_set(&PL_compiling, 0);
3566 /* Store and reset encoding. */
3567 encoding = PL_encoding;
3570 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3571 op = DOCATCH(PL_eval_start);
3573 op = PL_op->op_next;
3575 /* Restore encoding. */
3576 PL_encoding = encoding;
3584 register PERL_CONTEXT *cx;
3586 const I32 gimme = GIMME_V;
3587 const I32 was = PL_sub_generation;
3588 char tbuf[TYPE_DIGITS(long) + 12];
3589 char *tmpbuf = tbuf;
3595 HV *saved_hh = NULL;
3596 const char * const fakestr = "_<(eval )";
3597 const int fakelen = 9 + 1;
3599 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3600 saved_hh = (HV*) SvREFCNT_inc(POPs);
3604 TAINT_IF(SvTAINTED(sv));
3605 TAINT_PROPER("eval");
3608 lex_start(sv, NULL, FALSE);
3611 /* switch to eval mode */
3613 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3614 SV * const temp_sv = sv_newmortal();
3615 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3616 (unsigned long)++PL_evalseq,
3617 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3618 tmpbuf = SvPVX(temp_sv);
3619 len = SvCUR(temp_sv);
3622 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3623 SAVECOPFILE_FREE(&PL_compiling);
3624 CopFILE_set(&PL_compiling, tmpbuf+2);
3625 SAVECOPLINE(&PL_compiling);
3626 CopLINE_set(&PL_compiling, 1);
3627 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3628 deleting the eval's FILEGV from the stash before gv_check() runs
3629 (i.e. before run-time proper). To work around the coredump that
3630 ensues, we always turn GvMULTI_on for any globals that were
3631 introduced within evals. See force_ident(). GSAR 96-10-12 */
3632 safestr = savepvn(tmpbuf, len);
3633 SAVEDELETE(PL_defstash, safestr, len);
3635 PL_hints = PL_op->op_targ;
3637 GvHV(PL_hintgv) = saved_hh;
3638 SAVECOMPILEWARNINGS();
3639 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3640 if (PL_compiling.cop_hints_hash) {
3641 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3643 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3644 if (PL_compiling.cop_hints_hash) {
3646 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3647 HINTS_REFCNT_UNLOCK;
3649 /* special case: an eval '' executed within the DB package gets lexically
3650 * placed in the first non-DB CV rather than the current CV - this
3651 * allows the debugger to execute code, find lexicals etc, in the
3652 * scope of the code being debugged. Passing &seq gets find_runcv
3653 * to do the dirty work for us */
3654 runcv = find_runcv(&seq);
3656 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3658 cx->blk_eval.retop = PL_op->op_next;
3660 /* prepare to compile string */
3662 if (PERLDB_LINE && PL_curstash != PL_debstash)
3663 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3665 ok = doeval(gimme, NULL, runcv, seq);
3666 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3668 /* Copy in anything fake and short. */
3669 my_strlcpy(safestr, fakestr, fakelen);
3671 return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3681 register PERL_CONTEXT *cx;
3683 const U8 save_flags = PL_op -> op_flags;
3688 retop = cx->blk_eval.retop;
3691 if (gimme == G_VOID)
3693 else if (gimme == G_SCALAR) {
3696 if (SvFLAGS(TOPs) & SVs_TEMP)
3699 *MARK = sv_mortalcopy(TOPs);
3703 *MARK = &PL_sv_undef;
3708 /* in case LEAVE wipes old return values */
3709 for (mark = newsp + 1; mark <= SP; mark++) {
3710 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3711 *mark = sv_mortalcopy(*mark);
3712 TAINT_NOT; /* Each item is independent */
3716 PL_curpm = newpm; /* Don't pop $1 et al till now */
3719 assert(CvDEPTH(PL_compcv) == 1);
3721 CvDEPTH(PL_compcv) = 0;
3724 if (optype == OP_REQUIRE &&
3725 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3727 /* Unassume the success we assumed earlier. */
3728 SV * const nsv = cx->blk_eval.old_namesv;
3729 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3730 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3731 /* die_where() did LEAVE, or we won't be here */
3735 if (!(save_flags & OPf_SPECIAL))
3736 sv_setpvn(ERRSV,"",0);
3742 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3743 close to the related Perl_create_eval_scope. */
3745 Perl_delete_eval_scope(pTHX)
3750 register PERL_CONTEXT *cx;
3757 PERL_UNUSED_VAR(newsp);
3758 PERL_UNUSED_VAR(gimme);
3759 PERL_UNUSED_VAR(optype);
3762 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3763 also needed by Perl_fold_constants. */
3765 Perl_create_eval_scope(pTHX_ U32 flags)
3768 const I32 gimme = GIMME_V;
3773 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3776 PL_in_eval = EVAL_INEVAL;
3777 if (flags & G_KEEPERR)
3778 PL_in_eval |= EVAL_KEEPERR;
3780 sv_setpvn(ERRSV,"",0);
3781 if (flags & G_FAKINGEVAL) {
3782 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3790 PERL_CONTEXT * const cx = create_eval_scope(0);
3791 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3792 return DOCATCH(PL_op->op_next);
3801 register PERL_CONTEXT *cx;
3806 PERL_UNUSED_VAR(optype);
3809 if (gimme == G_VOID)
3811 else if (gimme == G_SCALAR) {
3815 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3818 *MARK = sv_mortalcopy(TOPs);
3822 *MARK = &PL_sv_undef;
3827 /* in case LEAVE wipes old return values */
3829 for (mark = newsp + 1; mark <= SP; mark++) {
3830 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3831 *mark = sv_mortalcopy(*mark);
3832 TAINT_NOT; /* Each item is independent */
3836 PL_curpm = newpm; /* Don't pop $1 et al till now */
3839 sv_setpvn(ERRSV,"",0);
3846 register PERL_CONTEXT *cx;
3847 const I32 gimme = GIMME_V;
3852 if (PL_op->op_targ == 0) {
3853 SV ** const defsv_p = &GvSV(PL_defgv);
3854 *defsv_p = newSVsv(POPs);
3855 SAVECLEARSV(*defsv_p);
3858 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3860 PUSHBLOCK(cx, CXt_GIVEN, SP);
3869 register PERL_CONTEXT *cx;
3873 PERL_UNUSED_CONTEXT;
3876 assert(CxTYPE(cx) == CXt_GIVEN);
3881 PL_curpm = newpm; /* pop $1 et al */
3888 /* Helper routines used by pp_smartmatch */
3890 S_make_matcher(pTHX_ REGEXP *re)
3893 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3894 PM_SETRE(matcher, ReREFCNT_inc(re));
3896 SAVEFREEOP((OP *) matcher);
3903 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3908 PL_op = (OP *) matcher;
3913 return (SvTRUEx(POPs));
3917 S_destroy_matcher(pTHX_ PMOP *matcher)
3920 PERL_UNUSED_ARG(matcher);
3925 /* Do a smart match */
3928 return do_smartmatch(NULL, NULL);
3931 /* This version of do_smartmatch() implements the
3932 * table of smart matches that is found in perlsyn.
3935 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3940 SV *e = TOPs; /* e is for 'expression' */
3941 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3942 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3943 REGEXP *this_regex, *other_regex;
3945 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3947 # define SM_REF(type) ( \
3948 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3949 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3951 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3952 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
3953 && NOT_EMPTY_PROTO(This) && (Other = e)) \
3954 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
3955 && NOT_EMPTY_PROTO(This) && (Other = d)))
3957 # define SM_REGEX ( \
3958 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \
3959 && (this_regex = (REGEXP*) This) \
3962 (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \
3963 && (this_regex = (REGEXP*) This) \
3967 # define SM_OTHER_REF(type) \
3968 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3970 # define SM_OTHER_REGEX (SvROK(Other) \
3971 && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \
3972 && (other_regex = (REGEXP*) SvRV(Other)))
3975 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3976 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3978 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3979 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3981 tryAMAGICbinSET(smart, 0);
3983 SP -= 2; /* Pop the values */
3985 /* Take care only to invoke mg_get() once for each argument.
3986 * Currently we do this by copying the SV if it's magical. */
3989 d = sv_mortalcopy(d);
3996 e = sv_mortalcopy(e);
4001 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
4003 if (This == SvRV(Other))
4014 c = call_sv(This, G_SCALAR);
4018 else if (SvTEMP(TOPs))
4019 SvREFCNT_inc_void(TOPs);
4024 else if (SM_REF(PVHV)) {
4025 if (SM_OTHER_REF(PVHV)) {
4026 /* Check that the key-sets are identical */
4028 HV *other_hv = (HV *) SvRV(Other);
4030 bool other_tied = FALSE;
4031 U32 this_key_count = 0,
4032 other_key_count = 0;
4034 /* Tied hashes don't know how many keys they have. */
4035 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
4038 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
4039 HV * const temp = other_hv;
4040 other_hv = (HV *) This;
4044 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
4047 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
4050 /* The hashes have the same number of keys, so it suffices
4051 to check that one is a subset of the other. */
4052 (void) hv_iterinit((HV *) This);
4053 while ( (he = hv_iternext((HV *) This)) ) {
4055 char * const key = hv_iterkey(he, &key_len);
4059 if(!hv_exists(other_hv, key, key_len)) {
4060 (void) hv_iterinit((HV *) This); /* reset iterator */
4066 (void) hv_iterinit(other_hv);
4067 while ( hv_iternext(other_hv) )
4071 other_key_count = HvUSEDKEYS(other_hv);
4073 if (this_key_count != other_key_count)
4078 else if (SM_OTHER_REF(PVAV)) {
4079 AV * const other_av = (AV *) SvRV(Other);
4080 const I32 other_len = av_len(other_av) + 1;
4083 for (i = 0; i < other_len; ++i) {
4084 SV ** const svp = av_fetch(other_av, i, FALSE);
4088 if (svp) { /* ??? When can this not happen? */
4089 key = SvPV(*svp, key_len);
4090 if (hv_exists((HV *) This, key, key_len))
4096 else if (SM_OTHER_REGEX) {
4097 PMOP * const matcher = make_matcher(other_regex);
4100 (void) hv_iterinit((HV *) This);
4101 while ( (he = hv_iternext((HV *) This)) ) {
4102 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4103 (void) hv_iterinit((HV *) This);
4104 destroy_matcher(matcher);
4108 destroy_matcher(matcher);
4112 if (hv_exists_ent((HV *) This, Other, 0))
4118 else if (SM_REF(PVAV)) {
4119 if (SM_OTHER_REF(PVAV)) {
4120 AV *other_av = (AV *) SvRV(Other);
4121 if (av_len((AV *) This) != av_len(other_av))
4125 const I32 other_len = av_len(other_av);
4127 if (NULL == seen_this) {
4128 seen_this = newHV();
4129 (void) sv_2mortal((SV *) seen_this);
4131 if (NULL == seen_other) {
4132 seen_this = newHV();
4133 (void) sv_2mortal((SV *) seen_other);
4135 for(i = 0; i <= other_len; ++i) {
4136 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4137 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4139 if (!this_elem || !other_elem) {
4140 if (this_elem || other_elem)
4143 else if (SM_SEEN_THIS(*this_elem)
4144 || SM_SEEN_OTHER(*other_elem))
4146 if (*this_elem != *other_elem)
4150 (void)hv_store_ent(seen_this,
4151 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4153 (void)hv_store_ent(seen_other,
4154 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4160 (void) do_smartmatch(seen_this, seen_other);
4170 else if (SM_OTHER_REGEX) {
4171 PMOP * const matcher = make_matcher(other_regex);
4172 const I32 this_len = av_len((AV *) This);
4175 for(i = 0; i <= this_len; ++i) {
4176 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4177 if (svp && matcher_matches_sv(matcher, *svp)) {
4178 destroy_matcher(matcher);
4182 destroy_matcher(matcher);
4185 else if (SvIOK(Other) || SvNOK(Other)) {
4188 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4189 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4196 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4206 else if (SvPOK(Other)) {
4207 const I32 this_len = av_len((AV *) This);
4210 for(i = 0; i <= this_len; ++i) {
4211 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4226 else if (!SvOK(d) || !SvOK(e)) {
4227 if (!SvOK(d) && !SvOK(e))
4232 else if (SM_REGEX) {
4233 PMOP * const matcher = make_matcher(this_regex);
4236 PUSHs(matcher_matches_sv(matcher, Other)
4239 destroy_matcher(matcher);
4242 else if (SM_REF(PVCV)) {
4244 /* This must be a null-prototyped sub, because we
4245 already checked for the other kind. */
4251 c = call_sv(This, G_SCALAR);
4254 PUSHs(&PL_sv_undef);
4255 else if (SvTEMP(TOPs))
4256 SvREFCNT_inc_void(TOPs);
4258 if (SM_OTHER_REF(PVCV)) {
4259 /* This one has to be null-proto'd too.
4260 Call both of 'em, and compare the results */
4262 c = call_sv(SvRV(Other), G_SCALAR);
4265 PUSHs(&PL_sv_undef);
4266 else if (SvTEMP(TOPs))
4267 SvREFCNT_inc_void(TOPs);
4278 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4279 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4281 if (SvPOK(Other) && !looks_like_number(Other)) {
4282 /* String comparison */
4287 /* Otherwise, numeric comparison */
4290 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4301 /* As a last resort, use string comparison */
4310 register PERL_CONTEXT *cx;
4311 const I32 gimme = GIMME_V;
4313 /* This is essentially an optimization: if the match
4314 fails, we don't want to push a context and then
4315 pop it again right away, so we skip straight
4316 to the op that follows the leavewhen.
4318 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4319 return cLOGOP->op_other->op_next;
4324 PUSHBLOCK(cx, CXt_WHEN, SP);
4333 register PERL_CONTEXT *cx;
4339 assert(CxTYPE(cx) == CXt_WHEN);
4344 PL_curpm = newpm; /* pop $1 et al */
4354 register PERL_CONTEXT *cx;
4357 cxix = dopoptowhen(cxstack_ix);
4359 DIE(aTHX_ "Can't \"continue\" outside a when block");
4360 if (cxix < cxstack_ix)
4363 /* clear off anything above the scope we're re-entering */
4364 inner = PL_scopestack_ix;
4366 if (PL_scopestack_ix < inner)
4367 leave_scope(PL_scopestack[PL_scopestack_ix]);
4368 PL_curcop = cx->blk_oldcop;
4369 return cx->blk_givwhen.leave_op;
4376 register PERL_CONTEXT *cx;
4379 cxix = dopoptogiven(cxstack_ix);
4381 if (PL_op->op_flags & OPf_SPECIAL)
4382 DIE(aTHX_ "Can't use when() outside a topicalizer");
4384 DIE(aTHX_ "Can't \"break\" outside a given block");
4386 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4387 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4389 if (cxix < cxstack_ix)
4392 /* clear off anything above the scope we're re-entering */
4393 inner = PL_scopestack_ix;
4395 if (PL_scopestack_ix < inner)
4396 leave_scope(PL_scopestack[PL_scopestack_ix]);
4397 PL_curcop = cx->blk_oldcop;
4400 return CX_LOOP_NEXTOP_GET(cx);
4402 return cx->blk_givwhen.leave_op;
4406 S_doparseform(pTHX_ SV *sv)
4409 register char *s = SvPV_force(sv, len);
4410 register char * const send = s + len;
4411 register char *base = NULL;
4412 register I32 skipspaces = 0;
4413 bool noblank = FALSE;
4414 bool repeat = FALSE;
4415 bool postspace = FALSE;
4421 bool unchopnum = FALSE;
4422 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4425 Perl_croak(aTHX_ "Null picture in formline");
4427 /* estimate the buffer size needed */
4428 for (base = s; s <= send; s++) {
4429 if (*s == '\n' || *s == '@' || *s == '^')
4435 Newx(fops, maxops, U32);
4440 *fpc++ = FF_LINEMARK;
4441 noblank = repeat = FALSE;
4459 case ' ': case '\t':
4466 } /* else FALL THROUGH */
4474 *fpc++ = FF_LITERAL;
4482 *fpc++ = (U16)skipspaces;
4486 *fpc++ = FF_NEWLINE;
4490 arg = fpc - linepc + 1;
4497 *fpc++ = FF_LINEMARK;
4498 noblank = repeat = FALSE;
4507 ischop = s[-1] == '^';
4513 arg = (s - base) - 1;
4515 *fpc++ = FF_LITERAL;
4523 *fpc++ = 2; /* skip the @* or ^* */
4525 *fpc++ = FF_LINESNGL;
4528 *fpc++ = FF_LINEGLOB;
4530 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4531 arg = ischop ? 512 : 0;
4536 const char * const f = ++s;
4539 arg |= 256 + (s - f);
4541 *fpc++ = s - base; /* fieldsize for FETCH */
4542 *fpc++ = FF_DECIMAL;
4544 unchopnum |= ! ischop;
4546 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4547 arg = ischop ? 512 : 0;
4549 s++; /* skip the '0' first */
4553 const char * const f = ++s;
4556 arg |= 256 + (s - f);
4558 *fpc++ = s - base; /* fieldsize for FETCH */
4559 *fpc++ = FF_0DECIMAL;
4561 unchopnum |= ! ischop;
4565 bool ismore = FALSE;
4568 while (*++s == '>') ;
4569 prespace = FF_SPACE;
4571 else if (*s == '|') {
4572 while (*++s == '|') ;
4573 prespace = FF_HALFSPACE;
4578 while (*++s == '<') ;
4581 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4585 *fpc++ = s - base; /* fieldsize for FETCH */
4587 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4590 *fpc++ = (U16)prespace;
4604 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4606 { /* need to jump to the next word */
4608 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4609 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4610 s = SvPVX(sv) + SvCUR(sv) + z;
4612 Copy(fops, s, arg, U32);
4614 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4617 if (unchopnum && repeat)
4618 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4624 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4626 /* Can value be printed in fldsize chars, using %*.*f ? */
4630 int intsize = fldsize - (value < 0 ? 1 : 0);
4637 while (intsize--) pwr *= 10.0;
4638 while (frcsize--) eps /= 10.0;
4641 if (value + eps >= pwr)
4644 if (value - eps <= -pwr)
4651 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4654 SV * const datasv = FILTER_DATA(idx);
4655 const int filter_has_file = IoLINES(datasv);
4656 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4657 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4661 const char *got_p = NULL;
4662 const char *prune_from = NULL;
4663 bool read_from_cache = FALSE;
4666 assert(maxlen >= 0);
4669 /* I was having segfault trouble under Linux 2.2.5 after a
4670 parse error occured. (Had to hack around it with a test
4671 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4672 not sure where the trouble is yet. XXX */
4674 if (IoFMT_GV(datasv)) {
4675 SV *const cache = (SV *)IoFMT_GV(datasv);
4678 const char *cache_p = SvPV(cache, cache_len);
4682 /* Running in block mode and we have some cached data already.
4684 if (cache_len >= umaxlen) {
4685 /* In fact, so much data we don't even need to call
4690 const char *const first_nl =
4691 (const char *)memchr(cache_p, '\n', cache_len);
4693 take = first_nl + 1 - cache_p;
4697 sv_catpvn(buf_sv, cache_p, take);
4698 sv_chop(cache, cache_p + take);
4699 /* Definately not EOF */
4703 sv_catsv(buf_sv, cache);
4705 umaxlen -= cache_len;
4708 read_from_cache = TRUE;
4712 /* Filter API says that the filter appends to the contents of the buffer.
4713 Usually the buffer is "", so the details don't matter. But if it's not,
4714 then clearly what it contains is already filtered by this filter, so we
4715 don't want to pass it in a second time.
4716 I'm going to use a mortal in case the upstream filter croaks. */
4717 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4718 ? sv_newmortal() : buf_sv;
4719 SvUPGRADE(upstream, SVt_PV);
4721 if (filter_has_file) {
4722 status = FILTER_READ(idx+1, upstream, 0);
4725 if (filter_sub && status >= 0) {
4738 PUSHs(filter_state);
4741 count = call_sv(filter_sub, G_SCALAR);
4756 if(SvOK(upstream)) {
4757 got_p = SvPV(upstream, got_len);
4759 if (got_len > umaxlen) {
4760 prune_from = got_p + umaxlen;
4763 const char *const first_nl =
4764 (const char *)memchr(got_p, '\n', got_len);
4765 if (first_nl && first_nl + 1 < got_p + got_len) {
4766 /* There's a second line here... */
4767 prune_from = first_nl + 1;
4772 /* Oh. Too long. Stuff some in our cache. */
4773 STRLEN cached_len = got_p + got_len - prune_from;
4774 SV *cache = (SV *)IoFMT_GV(datasv);
4777 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4778 } else if (SvOK(cache)) {
4779 /* Cache should be empty. */
4780 assert(!SvCUR(cache));
4783 sv_setpvn(cache, prune_from, cached_len);
4784 /* If you ask for block mode, you may well split UTF-8 characters.
4785 "If it breaks, you get to keep both parts"
4786 (Your code is broken if you don't put them back together again
4787 before something notices.) */
4788 if (SvUTF8(upstream)) {
4791 SvCUR_set(upstream, got_len - cached_len);
4792 /* Can't yet be EOF */
4797 /* If they are at EOF but buf_sv has something in it, then they may never
4798 have touched the SV upstream, so it may be undefined. If we naively
4799 concatenate it then we get a warning about use of uninitialised value.
4801 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4802 sv_catsv(buf_sv, upstream);
4806 IoLINES(datasv) = 0;
4807 SvREFCNT_dec(IoFMT_GV(datasv));
4809 SvREFCNT_dec(filter_state);
4810 IoTOP_GV(datasv) = NULL;
4813 SvREFCNT_dec(filter_sub);
4814 IoBOTTOM_GV(datasv) = NULL;
4816 filter_del(S_run_user_filter);
4818 if (status == 0 && read_from_cache) {
4819 /* If we read some data from the cache (and by getting here it implies
4820 that we emptied the cache) then we aren't yet at EOF, and mustn't
4821 report that to our caller. */
4827 /* perhaps someone can come up with a better name for
4828 this? it is not really "absolute", per se ... */
4830 S_path_is_absolute(const char *name)
4832 if (PERL_FILE_IS_ABSOLUTE(name)
4833 #ifdef MACOS_TRADITIONAL
4836 || (*name == '.' && (name[1] == '/' ||
4837 (name[1] == '.' && name[2] == '/')))
4849 * c-indentation-style: bsd
4851 * indent-tabs-mode: t
4854 * ex: set ts=8 sts=4 sw=4 noet: