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;
1848 if (PL_op->op_targ) {
1849 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1850 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1851 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1852 SVs_PADSTALE, SVs_PADSTALE);
1854 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1855 #ifndef USE_ITHREADS
1856 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1862 GV * const gv = (GV*)POPs;
1863 svp = &GvSV(gv); /* symbol table variable */
1864 SAVEGENERICSV(*svp);
1867 iterdata = (PAD*)gv;
1871 if (PL_op->op_private & OPpITER_DEF)
1872 cxtype |= CXp_FOR_DEF;
1876 PUSHBLOCK(cx, cxtype, SP);
1878 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1880 PERL_UNUSED_VAR(op);
1881 PUSHLOOP_FOR(cx, svp, MARK, op/*Not used*/);
1883 if (PL_op->op_flags & OPf_STACKED) {
1884 SV *maybe_ary = POPs;
1885 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1887 SV * const right = maybe_ary;
1890 if (RANGE_IS_NUMERIC(sv,right)) {
1891 cx->cx_type &= ~CXTYPEMASK;
1892 cx->cx_type |= CXt_LOOP_LAZYIV;
1893 /* Make sure that no-one re-orders cop.h and breaks our
1895 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1896 #ifdef NV_PRESERVES_UV
1897 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1898 (SvNV(sv) > (NV)IV_MAX)))
1900 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1901 (SvNV(right) < (NV)IV_MIN))))
1903 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1906 ((SvUV(sv) > (UV)IV_MAX) ||
1907 (SvNV(sv) > (NV)UV_MAX)))))
1909 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1911 ((SvNV(right) > 0) &&
1912 ((SvUV(right) > (UV)IV_MAX) ||
1913 (SvNV(right) > (NV)UV_MAX))))))
1915 DIE(aTHX_ "Range iterator outside integer range");
1916 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1917 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1919 /* for correct -Dstv display */
1920 cx->blk_oldsp = sp - PL_stack_base;
1924 cx->cx_type &= ~CXTYPEMASK;
1925 cx->cx_type |= CXt_LOOP_LAZYSV;
1926 /* Make sure that no-one re-orders cop.h and breaks our
1928 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
1929 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
1930 cx->blk_loop.state_u.lazysv.end = right;
1931 SvREFCNT_inc(right);
1932 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
1933 /* This will do the upgrade to SVt_PV, and warn if the value
1934 is uninitialised. */
1935 (void) SvPV_nolen_const(right);
1936 /* Doing this avoids a check every time in pp_iter in pp_hot.c
1937 to replace !SvOK() with a pointer to "". */
1939 SvREFCNT_dec(right);
1940 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
1944 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
1945 cx->blk_loop.state_u.ary.ary = (AV*)maybe_ary;
1946 SvREFCNT_inc(maybe_ary);
1947 cx->blk_loop.state_u.ary.ix =
1948 (PL_op->op_private & OPpITER_REVERSED) ?
1949 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
1953 else { /* iterating over items on the stack */
1954 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
1955 if (PL_op->op_private & OPpITER_REVERSED) {
1956 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
1959 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
1969 register PERL_CONTEXT *cx;
1970 const I32 gimme = GIMME_V;
1976 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
1977 PUSHLOOP_PLAIN(cx, SP);
1985 register PERL_CONTEXT *cx;
1992 assert(CxTYPE_is_LOOP(cx));
1994 newsp = PL_stack_base + cx->blk_loop.resetsp;
1997 if (gimme == G_VOID)
1999 else if (gimme == G_SCALAR) {
2001 *++newsp = sv_mortalcopy(*SP);
2003 *++newsp = &PL_sv_undef;
2007 *++newsp = sv_mortalcopy(*++mark);
2008 TAINT_NOT; /* Each item is independent */
2014 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2015 PL_curpm = newpm; /* ... and pop $1 et al */
2026 register PERL_CONTEXT *cx;
2027 bool popsub2 = FALSE;
2028 bool clear_errsv = FALSE;
2036 const I32 cxix = dopoptosub(cxstack_ix);
2039 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2040 * sort block, which is a CXt_NULL
2043 PL_stack_base[1] = *PL_stack_sp;
2044 PL_stack_sp = PL_stack_base + 1;
2048 DIE(aTHX_ "Can't return outside a subroutine");
2050 if (cxix < cxstack_ix)
2053 if (CxMULTICALL(&cxstack[cxix])) {
2054 gimme = cxstack[cxix].blk_gimme;
2055 if (gimme == G_VOID)
2056 PL_stack_sp = PL_stack_base;
2057 else if (gimme == G_SCALAR) {
2058 PL_stack_base[1] = *PL_stack_sp;
2059 PL_stack_sp = PL_stack_base + 1;
2065 switch (CxTYPE(cx)) {
2068 retop = cx->blk_sub.retop;
2069 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2072 if (!(PL_in_eval & EVAL_KEEPERR))
2075 retop = cx->blk_eval.retop;
2079 if (optype == OP_REQUIRE &&
2080 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2082 /* Unassume the success we assumed earlier. */
2083 SV * const nsv = cx->blk_eval.old_namesv;
2084 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2085 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2090 retop = cx->blk_sub.retop;
2093 DIE(aTHX_ "panic: return");
2097 if (gimme == G_SCALAR) {
2100 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2102 *++newsp = SvREFCNT_inc(*SP);
2107 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2109 *++newsp = sv_mortalcopy(sv);
2114 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2117 *++newsp = sv_mortalcopy(*SP);
2120 *++newsp = &PL_sv_undef;
2122 else if (gimme == G_ARRAY) {
2123 while (++MARK <= SP) {
2124 *++newsp = (popsub2 && SvTEMP(*MARK))
2125 ? *MARK : sv_mortalcopy(*MARK);
2126 TAINT_NOT; /* Each item is independent */
2129 PL_stack_sp = newsp;
2132 /* Stack values are safe: */
2135 POPSUB(cx,sv); /* release CV and @_ ... */
2139 PL_curpm = newpm; /* ... and pop $1 et al */
2143 sv_setpvn(ERRSV,"",0);
2151 register PERL_CONTEXT *cx;
2162 if (PL_op->op_flags & OPf_SPECIAL) {
2163 cxix = dopoptoloop(cxstack_ix);
2165 DIE(aTHX_ "Can't \"last\" outside a loop block");
2168 cxix = dopoptolabel(cPVOP->op_pv);
2170 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2172 if (cxix < cxstack_ix)
2176 cxstack_ix++; /* temporarily protect top context */
2178 switch (CxTYPE(cx)) {
2179 case CXt_LOOP_LAZYIV:
2180 case CXt_LOOP_LAZYSV:
2182 case CXt_LOOP_PLAIN:
2184 newsp = PL_stack_base + cx->blk_loop.resetsp;
2185 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2189 nextop = cx->blk_sub.retop;
2193 nextop = cx->blk_eval.retop;
2197 nextop = cx->blk_sub.retop;
2200 DIE(aTHX_ "panic: last");
2204 if (gimme == G_SCALAR) {
2206 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2207 ? *SP : sv_mortalcopy(*SP);
2209 *++newsp = &PL_sv_undef;
2211 else if (gimme == G_ARRAY) {
2212 while (++MARK <= SP) {
2213 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2214 ? *MARK : sv_mortalcopy(*MARK);
2215 TAINT_NOT; /* Each item is independent */
2223 /* Stack values are safe: */
2225 case CXt_LOOP_LAZYIV:
2226 case CXt_LOOP_PLAIN:
2227 case CXt_LOOP_LAZYSV:
2229 POPLOOP(cx); /* release loop vars ... */
2233 POPSUB(cx,sv); /* release CV and @_ ... */
2236 PL_curpm = newpm; /* ... and pop $1 et al */
2239 PERL_UNUSED_VAR(optype);
2240 PERL_UNUSED_VAR(gimme);
2248 register PERL_CONTEXT *cx;
2251 if (PL_op->op_flags & OPf_SPECIAL) {
2252 cxix = dopoptoloop(cxstack_ix);
2254 DIE(aTHX_ "Can't \"next\" outside a loop block");
2257 cxix = dopoptolabel(cPVOP->op_pv);
2259 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2261 if (cxix < cxstack_ix)
2264 /* clear off anything above the scope we're re-entering, but
2265 * save the rest until after a possible continue block */
2266 inner = PL_scopestack_ix;
2268 if (PL_scopestack_ix < inner)
2269 leave_scope(PL_scopestack[PL_scopestack_ix]);
2270 PL_curcop = cx->blk_oldcop;
2271 return CX_LOOP_NEXTOP_GET(cx);
2278 register PERL_CONTEXT *cx;
2282 if (PL_op->op_flags & OPf_SPECIAL) {
2283 cxix = dopoptoloop(cxstack_ix);
2285 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2288 cxix = dopoptolabel(cPVOP->op_pv);
2290 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2292 if (cxix < cxstack_ix)
2295 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2296 if (redo_op->op_type == OP_ENTER) {
2297 /* pop one less context to avoid $x being freed in while (my $x..) */
2299 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2300 redo_op = redo_op->op_next;
2304 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2305 LEAVE_SCOPE(oldsave);
2307 PL_curcop = cx->blk_oldcop;
2312 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2316 static const char too_deep[] = "Target of goto is too deeply nested";
2319 Perl_croak(aTHX_ too_deep);
2320 if (o->op_type == OP_LEAVE ||
2321 o->op_type == OP_SCOPE ||
2322 o->op_type == OP_LEAVELOOP ||
2323 o->op_type == OP_LEAVESUB ||
2324 o->op_type == OP_LEAVETRY)
2326 *ops++ = cUNOPo->op_first;
2328 Perl_croak(aTHX_ too_deep);
2331 if (o->op_flags & OPf_KIDS) {
2333 /* First try all the kids at this level, since that's likeliest. */
2334 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2335 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2336 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2339 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2340 if (kid == PL_lastgotoprobe)
2342 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2345 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2346 ops[-1]->op_type == OP_DBSTATE)
2351 if ((o = dofindlabel(kid, label, ops, oplimit)))
2364 register PERL_CONTEXT *cx;
2365 #define GOTO_DEPTH 64
2366 OP *enterops[GOTO_DEPTH];
2367 const char *label = NULL;
2368 const bool do_dump = (PL_op->op_type == OP_DUMP);
2369 static const char must_have_label[] = "goto must have label";
2371 if (PL_op->op_flags & OPf_STACKED) {
2372 SV * const sv = POPs;
2374 /* This egregious kludge implements goto &subroutine */
2375 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2377 register PERL_CONTEXT *cx;
2378 CV* cv = (CV*)SvRV(sv);
2385 if (!CvROOT(cv) && !CvXSUB(cv)) {
2386 const GV * const gv = CvGV(cv);
2390 /* autoloaded stub? */
2391 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2393 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2394 GvNAMELEN(gv), FALSE);
2395 if (autogv && (cv = GvCV(autogv)))
2397 tmpstr = sv_newmortal();
2398 gv_efullname3(tmpstr, gv, NULL);
2399 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2401 DIE(aTHX_ "Goto undefined subroutine");
2404 /* First do some returnish stuff. */
2405 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2407 cxix = dopoptosub(cxstack_ix);
2409 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2410 if (cxix < cxstack_ix)
2414 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2415 if (CxTYPE(cx) == CXt_EVAL) {
2417 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2419 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2421 else if (CxMULTICALL(cx))
2422 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2423 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2424 /* put @_ back onto stack */
2425 AV* av = cx->blk_sub.argarray;
2427 items = AvFILLp(av) + 1;
2428 EXTEND(SP, items+1); /* @_ could have been extended. */
2429 Copy(AvARRAY(av), SP + 1, items, SV*);
2430 SvREFCNT_dec(GvAV(PL_defgv));
2431 GvAV(PL_defgv) = cx->blk_sub.savearray;
2433 /* abandon @_ if it got reified */
2438 av_extend(av, items-1);
2440 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2443 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2444 AV* const av = GvAV(PL_defgv);
2445 items = AvFILLp(av) + 1;
2446 EXTEND(SP, items+1); /* @_ could have been extended. */
2447 Copy(AvARRAY(av), SP + 1, items, SV*);
2451 if (CxTYPE(cx) == CXt_SUB &&
2452 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2453 SvREFCNT_dec(cx->blk_sub.cv);
2454 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2455 LEAVE_SCOPE(oldsave);
2457 /* Now do some callish stuff. */
2459 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2461 OP* const retop = cx->blk_sub.retop;
2466 for (index=0; index<items; index++)
2467 sv_2mortal(SP[-index]);
2470 /* XS subs don't have a CxSUB, so pop it */
2471 POPBLOCK(cx, PL_curpm);
2472 /* Push a mark for the start of arglist */
2475 (void)(*CvXSUB(cv))(aTHX_ cv);
2480 AV* const padlist = CvPADLIST(cv);
2481 if (CxTYPE(cx) == CXt_EVAL) {
2482 PL_in_eval = CxOLD_IN_EVAL(cx);
2483 PL_eval_root = cx->blk_eval.old_eval_root;
2484 cx->cx_type = CXt_SUB;
2486 cx->blk_sub.cv = cv;
2487 cx->blk_sub.olddepth = CvDEPTH(cv);
2490 if (CvDEPTH(cv) < 2)
2491 SvREFCNT_inc_simple_void_NN(cv);
2493 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2494 sub_crush_depth(cv);
2495 pad_push(padlist, CvDEPTH(cv));
2498 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2501 AV* const av = (AV*)PAD_SVl(0);
2503 cx->blk_sub.savearray = GvAV(PL_defgv);
2504 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2505 CX_CURPAD_SAVE(cx->blk_sub);
2506 cx->blk_sub.argarray = av;
2508 if (items >= AvMAX(av) + 1) {
2509 SV **ary = AvALLOC(av);
2510 if (AvARRAY(av) != ary) {
2511 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2514 if (items >= AvMAX(av) + 1) {
2515 AvMAX(av) = items - 1;
2516 Renew(ary,items+1,SV*);
2522 Copy(mark,AvARRAY(av),items,SV*);
2523 AvFILLp(av) = items - 1;
2524 assert(!AvREAL(av));
2526 /* transfer 'ownership' of refcnts to new @_ */
2536 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2537 Perl_get_db_sub(aTHX_ NULL, cv);
2539 CV * const gotocv = get_cv("DB::goto", FALSE);
2541 PUSHMARK( PL_stack_sp );
2542 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2547 RETURNOP(CvSTART(cv));
2551 label = SvPV_nolen_const(sv);
2552 if (!(do_dump || *label))
2553 DIE(aTHX_ must_have_label);
2556 else if (PL_op->op_flags & OPf_SPECIAL) {
2558 DIE(aTHX_ must_have_label);
2561 label = cPVOP->op_pv;
2563 if (label && *label) {
2564 OP *gotoprobe = NULL;
2565 bool leaving_eval = FALSE;
2566 bool in_block = FALSE;
2567 PERL_CONTEXT *last_eval_cx = NULL;
2571 PL_lastgotoprobe = NULL;
2573 for (ix = cxstack_ix; ix >= 0; ix--) {
2575 switch (CxTYPE(cx)) {
2577 leaving_eval = TRUE;
2578 if (!CxTRYBLOCK(cx)) {
2579 gotoprobe = (last_eval_cx ?
2580 last_eval_cx->blk_eval.old_eval_root :
2585 /* else fall through */
2586 case CXt_LOOP_LAZYIV:
2587 case CXt_LOOP_LAZYSV:
2589 case CXt_LOOP_PLAIN:
2590 gotoprobe = cx->blk_oldcop->op_sibling;
2596 gotoprobe = cx->blk_oldcop->op_sibling;
2599 gotoprobe = PL_main_root;
2602 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2603 gotoprobe = CvROOT(cx->blk_sub.cv);
2609 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2612 DIE(aTHX_ "panic: goto");
2613 gotoprobe = PL_main_root;
2617 retop = dofindlabel(gotoprobe, label,
2618 enterops, enterops + GOTO_DEPTH);
2622 PL_lastgotoprobe = gotoprobe;
2625 DIE(aTHX_ "Can't find label %s", label);
2627 /* if we're leaving an eval, check before we pop any frames
2628 that we're not going to punt, otherwise the error
2631 if (leaving_eval && *enterops && enterops[1]) {
2633 for (i = 1; enterops[i]; i++)
2634 if (enterops[i]->op_type == OP_ENTERITER)
2635 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2638 /* pop unwanted frames */
2640 if (ix < cxstack_ix) {
2647 oldsave = PL_scopestack[PL_scopestack_ix];
2648 LEAVE_SCOPE(oldsave);
2651 /* push wanted frames */
2653 if (*enterops && enterops[1]) {
2654 OP * const oldop = PL_op;
2655 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2656 for (; enterops[ix]; ix++) {
2657 PL_op = enterops[ix];
2658 /* Eventually we may want to stack the needed arguments
2659 * for each op. For now, we punt on the hard ones. */
2660 if (PL_op->op_type == OP_ENTERITER)
2661 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2662 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2670 if (!retop) retop = PL_main_start;
2672 PL_restartop = retop;
2673 PL_do_undump = TRUE;
2677 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2678 PL_do_undump = FALSE;
2695 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2697 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2700 PL_exit_flags |= PERL_EXIT_EXPECTED;
2702 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2703 if (anum || !(PL_minus_c && PL_madskills))
2708 PUSHs(&PL_sv_undef);
2715 S_save_lines(pTHX_ AV *array, SV *sv)
2717 const char *s = SvPVX_const(sv);
2718 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2721 while (s && s < send) {
2723 SV * const tmpstr = newSV_type(SVt_PVMG);
2725 t = strchr(s, '\n');
2731 sv_setpvn(tmpstr, s, t - s);
2732 av_store(array, line++, tmpstr);
2738 S_docatch(pTHX_ OP *o)
2742 OP * const oldop = PL_op;
2746 assert(CATCH_GET == TRUE);
2753 assert(cxstack_ix >= 0);
2754 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2755 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2760 /* die caught by an inner eval - continue inner loop */
2762 /* NB XXX we rely on the old popped CxEVAL still being at the top
2763 * of the stack; the way die_where() currently works, this
2764 * assumption is valid. In theory The cur_top_env value should be
2765 * returned in another global, the way retop (aka PL_restartop)
2767 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2770 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2772 PL_op = PL_restartop;
2789 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2790 /* sv Text to convert to OP tree. */
2791 /* startop op_free() this to undo. */
2792 /* code Short string id of the caller. */
2794 /* FIXME - how much of this code is common with pp_entereval? */
2795 dVAR; dSP; /* Make POPBLOCK work. */
2801 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2802 char *tmpbuf = tbuf;
2805 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2809 lex_start(sv, NULL, FALSE);
2811 /* switch to eval mode */
2813 if (IN_PERL_COMPILETIME) {
2814 SAVECOPSTASH_FREE(&PL_compiling);
2815 CopSTASH_set(&PL_compiling, PL_curstash);
2817 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2818 SV * const sv = sv_newmortal();
2819 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2820 code, (unsigned long)++PL_evalseq,
2821 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2826 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2827 (unsigned long)++PL_evalseq);
2828 SAVECOPFILE_FREE(&PL_compiling);
2829 CopFILE_set(&PL_compiling, tmpbuf+2);
2830 SAVECOPLINE(&PL_compiling);
2831 CopLINE_set(&PL_compiling, 1);
2832 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2833 deleting the eval's FILEGV from the stash before gv_check() runs
2834 (i.e. before run-time proper). To work around the coredump that
2835 ensues, we always turn GvMULTI_on for any globals that were
2836 introduced within evals. See force_ident(). GSAR 96-10-12 */
2837 safestr = savepvn(tmpbuf, len);
2838 SAVEDELETE(PL_defstash, safestr, len);
2840 #ifdef OP_IN_REGISTER
2846 /* we get here either during compilation, or via pp_regcomp at runtime */
2847 runtime = IN_PERL_RUNTIME;
2849 runcv = find_runcv(NULL);
2852 PL_op->op_type = OP_ENTEREVAL;
2853 PL_op->op_flags = 0; /* Avoid uninit warning. */
2854 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2858 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2860 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2861 POPBLOCK(cx,PL_curpm);
2864 (*startop)->op_type = OP_NULL;
2865 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2867 /* XXX DAPM do this properly one year */
2868 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2870 if (IN_PERL_COMPILETIME)
2871 CopHINTS_set(&PL_compiling, PL_hints);
2872 #ifdef OP_IN_REGISTER
2875 PERL_UNUSED_VAR(newsp);
2876 PERL_UNUSED_VAR(optype);
2878 return PL_eval_start;
2883 =for apidoc find_runcv
2885 Locate the CV corresponding to the currently executing sub or eval.
2886 If db_seqp is non_null, skip CVs that are in the DB package and populate
2887 *db_seqp with the cop sequence number at the point that the DB:: code was
2888 entered. (allows debuggers to eval in the scope of the breakpoint rather
2889 than in the scope of the debugger itself).
2895 Perl_find_runcv(pTHX_ U32 *db_seqp)
2901 *db_seqp = PL_curcop->cop_seq;
2902 for (si = PL_curstackinfo; si; si = si->si_prev) {
2904 for (ix = si->si_cxix; ix >= 0; ix--) {
2905 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2906 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2907 CV * const cv = cx->blk_sub.cv;
2908 /* skip DB:: code */
2909 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2910 *db_seqp = cx->blk_oldcop->cop_seq;
2915 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2923 /* Compile a require/do, an eval '', or a /(?{...})/.
2924 * In the last case, startop is non-null, and contains the address of
2925 * a pointer that should be set to the just-compiled code.
2926 * outside is the lexically enclosing CV (if any) that invoked us.
2927 * Returns a bool indicating whether the compile was successful; if so,
2928 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2929 * pushes undef (also croaks if startop != NULL).
2933 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2936 OP * const saveop = PL_op;
2938 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2939 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2944 SAVESPTR(PL_compcv);
2945 PL_compcv = (CV*)newSV_type(SVt_PVCV);
2946 CvEVAL_on(PL_compcv);
2947 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2948 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2950 CvOUTSIDE_SEQ(PL_compcv) = seq;
2951 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2953 /* set up a scratch pad */
2955 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2956 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2960 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2962 /* make sure we compile in the right package */
2964 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2965 SAVESPTR(PL_curstash);
2966 PL_curstash = CopSTASH(PL_curcop);
2968 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2969 SAVESPTR(PL_beginav);
2970 PL_beginav = newAV();
2971 SAVEFREESV(PL_beginav);
2972 SAVESPTR(PL_unitcheckav);
2973 PL_unitcheckav = newAV();
2974 SAVEFREESV(PL_unitcheckav);
2977 SAVEBOOL(PL_madskills);
2981 /* try to compile it */
2983 PL_eval_root = NULL;
2984 PL_curcop = &PL_compiling;
2985 CopARYBASE_set(PL_curcop, 0);
2986 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2987 PL_in_eval |= EVAL_KEEPERR;
2989 sv_setpvn(ERRSV,"",0);
2990 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
2991 SV **newsp; /* Used by POPBLOCK. */
2992 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2993 I32 optype = 0; /* Might be reset by POPEVAL. */
2998 op_free(PL_eval_root);
2999 PL_eval_root = NULL;
3001 SP = PL_stack_base + POPMARK; /* pop original mark */
3003 POPBLOCK(cx,PL_curpm);
3009 msg = SvPVx_nolen_const(ERRSV);
3010 if (optype == OP_REQUIRE) {
3011 const SV * const nsv = cx->blk_eval.old_namesv;
3012 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3014 Perl_croak(aTHX_ "%sCompilation failed in require",
3015 *msg ? msg : "Unknown error\n");
3018 POPBLOCK(cx,PL_curpm);
3020 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3021 (*msg ? msg : "Unknown error\n"));
3025 sv_setpvs(ERRSV, "Compilation error");
3028 PERL_UNUSED_VAR(newsp);
3029 PUSHs(&PL_sv_undef);
3033 CopLINE_set(&PL_compiling, 0);
3035 *startop = PL_eval_root;
3037 SAVEFREEOP(PL_eval_root);
3039 /* Set the context for this new optree.
3040 * If the last op is an OP_REQUIRE, force scalar context.
3041 * Otherwise, propagate the context from the eval(). */
3042 if (PL_eval_root->op_type == OP_LEAVEEVAL
3043 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3044 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3046 scalar(PL_eval_root);
3047 else if ((gimme & G_WANT) == G_VOID)
3048 scalarvoid(PL_eval_root);
3049 else if ((gimme & G_WANT) == G_ARRAY)
3052 scalar(PL_eval_root);
3054 DEBUG_x(dump_eval());
3056 /* Register with debugger: */
3057 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3058 CV * const cv = get_cv("DB::postponed", FALSE);
3062 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3064 call_sv((SV*)cv, G_DISCARD);
3069 call_list(PL_scopestack_ix, PL_unitcheckav);
3071 /* compiled okay, so do it */
3073 CvDEPTH(PL_compcv) = 1;
3074 SP = PL_stack_base + POPMARK; /* pop original mark */
3075 PL_op = saveop; /* The caller may need it. */
3076 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3083 S_check_type_and_open(pTHX_ const char *name)
3086 const int st_rc = PerlLIO_stat(name, &st);
3088 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3092 return PerlIO_open(name, PERL_SCRIPT_MODE);
3095 #ifndef PERL_DISABLE_PMC
3097 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3101 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3102 SV *const pmcsv = newSV(namelen + 2);
3103 char *const pmc = SvPVX(pmcsv);
3106 memcpy(pmc, name, namelen);
3108 pmc[namelen + 1] = '\0';
3110 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3111 fp = check_type_and_open(name);
3114 fp = check_type_and_open(pmc);
3116 SvREFCNT_dec(pmcsv);
3119 fp = check_type_and_open(name);
3124 # define doopen_pm(name, namelen) check_type_and_open(name)
3125 #endif /* !PERL_DISABLE_PMC */
3130 register PERL_CONTEXT *cx;
3137 int vms_unixname = 0;
3139 const char *tryname = NULL;
3141 const I32 gimme = GIMME_V;
3142 int filter_has_file = 0;
3143 PerlIO *tryrsfp = NULL;
3144 SV *filter_cache = NULL;
3145 SV *filter_state = NULL;
3146 SV *filter_sub = NULL;
3152 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3153 sv = new_version(sv);
3154 if (!sv_derived_from(PL_patchlevel, "version"))
3155 upg_version(PL_patchlevel, TRUE);
3156 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3157 if ( vcmp(sv,PL_patchlevel) <= 0 )
3158 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3159 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3162 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3165 SV * const req = SvRV(sv);
3166 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3168 /* get the left hand term */
3169 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3171 first = SvIV(*av_fetch(lav,0,0));
3172 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3173 || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3174 || av_len(lav) > 1 /* FP with > 3 digits */
3175 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3177 DIE(aTHX_ "Perl %"SVf" required--this is only "
3178 "%"SVf", stopped", SVfARG(vnormal(req)),
3179 SVfARG(vnormal(PL_patchlevel)));
3181 else { /* probably 'use 5.10' or 'use 5.8' */
3182 SV * hintsv = newSV(0);
3186 second = SvIV(*av_fetch(lav,1,0));
3188 second /= second >= 600 ? 100 : 10;
3189 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3190 (int)first, (int)second,0);
3191 upg_version(hintsv, TRUE);
3193 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3194 "--this is only %"SVf", stopped",
3195 SVfARG(vnormal(req)),
3196 SVfARG(vnormal(hintsv)),
3197 SVfARG(vnormal(PL_patchlevel)));
3202 /* We do this only with use, not require. */
3204 /* If we request a version >= 5.9.5, load feature.pm with the
3205 * feature bundle that corresponds to the required version. */
3206 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3207 SV *const importsv = vnormal(sv);
3208 *SvPVX_mutable(importsv) = ':';
3210 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3216 name = SvPV_const(sv, len);
3217 if (!(name && len > 0 && *name))
3218 DIE(aTHX_ "Null filename used");
3219 TAINT_PROPER("require");
3223 /* The key in the %ENV hash is in the syntax of file passed as the argument
3224 * usually this is in UNIX format, but sometimes in VMS format, which
3225 * can result in a module being pulled in more than once.
3226 * To prevent this, the key must be stored in UNIX format if the VMS
3227 * name can be translated to UNIX.
3229 if ((unixname = tounixspec(name, NULL)) != NULL) {
3230 unixlen = strlen(unixname);
3236 /* if not VMS or VMS name can not be translated to UNIX, pass it
3239 unixname = (char *) name;
3242 if (PL_op->op_type == OP_REQUIRE) {
3243 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3244 unixname, unixlen, 0);
3246 if (*svp != &PL_sv_undef)
3249 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3250 "Compilation failed in require", unixname);
3254 /* prepare to compile file */
3256 if (path_is_absolute(name)) {
3258 tryrsfp = doopen_pm(name, len);
3260 #ifdef MACOS_TRADITIONAL
3264 MacPerl_CanonDir(name, newname, 1);
3265 if (path_is_absolute(newname)) {
3267 tryrsfp = doopen_pm(newname, strlen(newname));
3272 AV * const ar = GvAVn(PL_incgv);
3278 namesv = newSV_type(SVt_PV);
3279 for (i = 0; i <= AvFILL(ar); i++) {
3280 SV * const dirsv = *av_fetch(ar, i, TRUE);
3282 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3289 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3290 && !sv_isobject(loader))
3292 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3295 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3296 PTR2UV(SvRV(dirsv)), name);
3297 tryname = SvPVX_const(namesv);
3308 if (sv_isobject(loader))
3309 count = call_method("INC", G_ARRAY);
3311 count = call_sv(loader, G_ARRAY);
3314 /* Adjust file name if the hook has set an %INC entry */
3315 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3317 tryname = SvPVX_const(*svp);
3326 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3327 && !isGV_with_GP(SvRV(arg))) {
3328 filter_cache = SvRV(arg);
3329 SvREFCNT_inc_simple_void_NN(filter_cache);
3336 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3340 if (SvTYPE(arg) == SVt_PVGV) {
3341 IO * const io = GvIO((GV *)arg);
3346 tryrsfp = IoIFP(io);
3347 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3348 PerlIO_close(IoOFP(io));
3359 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3361 SvREFCNT_inc_simple_void_NN(filter_sub);
3364 filter_state = SP[i];
3365 SvREFCNT_inc_simple_void(filter_state);
3369 if (!tryrsfp && (filter_cache || filter_sub)) {
3370 tryrsfp = PerlIO_open(BIT_BUCKET,
3385 filter_has_file = 0;
3387 SvREFCNT_dec(filter_cache);
3388 filter_cache = NULL;
3391 SvREFCNT_dec(filter_state);
3392 filter_state = NULL;
3395 SvREFCNT_dec(filter_sub);
3400 if (!path_is_absolute(name)
3401 #ifdef MACOS_TRADITIONAL
3402 /* We consider paths of the form :a:b ambiguous and interpret them first
3403 as global then as local
3405 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3412 dir = SvPV_const(dirsv, dirlen);
3418 #ifdef MACOS_TRADITIONAL
3422 MacPerl_CanonDir(name, buf2, 1);
3423 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3427 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3429 sv_setpv(namesv, unixdir);
3430 sv_catpv(namesv, unixname);
3432 # ifdef __SYMBIAN32__
3433 if (PL_origfilename[0] &&
3434 PL_origfilename[1] == ':' &&
3435 !(dir[0] && dir[1] == ':'))
3436 Perl_sv_setpvf(aTHX_ namesv,
3441 Perl_sv_setpvf(aTHX_ namesv,
3445 /* The equivalent of
3446 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3447 but without the need to parse the format string, or
3448 call strlen on either pointer, and with the correct
3449 allocation up front. */
3451 char *tmp = SvGROW(namesv, dirlen + len + 2);
3453 memcpy(tmp, dir, dirlen);
3456 /* name came from an SV, so it will have a '\0' at the
3457 end that we can copy as part of this memcpy(). */
3458 memcpy(tmp, name, len + 1);
3460 SvCUR_set(namesv, dirlen + len + 1);
3462 /* Don't even actually have to turn SvPOK_on() as we
3463 access it directly with SvPVX() below. */
3468 TAINT_PROPER("require");
3469 tryname = SvPVX_const(namesv);
3470 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3472 if (tryname[0] == '.' && tryname[1] == '/')
3476 else if (errno == EMFILE)
3477 /* no point in trying other paths if out of handles */
3484 SAVECOPFILE_FREE(&PL_compiling);
3485 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3486 SvREFCNT_dec(namesv);
3488 if (PL_op->op_type == OP_REQUIRE) {
3489 const char *msgstr = name;
3490 if(errno == EMFILE) {
3492 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3494 msgstr = SvPV_nolen_const(msg);
3496 if (namesv) { /* did we lookup @INC? */
3497 AV * const ar = GvAVn(PL_incgv);
3499 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3500 "%s in @INC%s%s (@INC contains:",
3502 (instr(msgstr, ".h ")
3503 ? " (change .h to .ph maybe?)" : ""),
3504 (instr(msgstr, ".ph ")
3505 ? " (did you run h2ph?)" : "")
3508 for (i = 0; i <= AvFILL(ar); i++) {
3509 sv_catpvs(msg, " ");
3510 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3512 sv_catpvs(msg, ")");
3513 msgstr = SvPV_nolen_const(msg);
3516 DIE(aTHX_ "Can't locate %s", msgstr);
3522 SETERRNO(0, SS_NORMAL);
3524 /* Assume success here to prevent recursive requirement. */
3525 /* name is never assigned to again, so len is still strlen(name) */
3526 /* Check whether a hook in @INC has already filled %INC */
3528 (void)hv_store(GvHVn(PL_incgv),
3529 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3531 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3533 (void)hv_store(GvHVn(PL_incgv),
3534 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3539 lex_start(NULL, tryrsfp, TRUE);
3543 SAVECOMPILEWARNINGS();
3544 if (PL_dowarn & G_WARN_ALL_ON)
3545 PL_compiling.cop_warnings = pWARN_ALL ;
3546 else if (PL_dowarn & G_WARN_ALL_OFF)
3547 PL_compiling.cop_warnings = pWARN_NONE ;
3549 PL_compiling.cop_warnings = pWARN_STD ;
3551 if (filter_sub || filter_cache) {
3552 SV * const datasv = filter_add(S_run_user_filter, NULL);
3553 IoLINES(datasv) = filter_has_file;
3554 IoTOP_GV(datasv) = (GV *)filter_state;
3555 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3556 IoFMT_GV(datasv) = (GV *)filter_cache;
3559 /* switch to eval mode */
3560 PUSHBLOCK(cx, CXt_EVAL, SP);
3562 cx->blk_eval.retop = PL_op->op_next;
3564 SAVECOPLINE(&PL_compiling);
3565 CopLINE_set(&PL_compiling, 0);
3569 /* Store and reset encoding. */
3570 encoding = PL_encoding;
3573 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3574 op = DOCATCH(PL_eval_start);
3576 op = PL_op->op_next;
3578 /* Restore encoding. */
3579 PL_encoding = encoding;
3587 register PERL_CONTEXT *cx;
3589 const I32 gimme = GIMME_V;
3590 const I32 was = PL_sub_generation;
3591 char tbuf[TYPE_DIGITS(long) + 12];
3592 char *tmpbuf = tbuf;
3598 HV *saved_hh = NULL;
3599 const char * const fakestr = "_<(eval )";
3600 const int fakelen = 9 + 1;
3602 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3603 saved_hh = (HV*) SvREFCNT_inc(POPs);
3607 TAINT_IF(SvTAINTED(sv));
3608 TAINT_PROPER("eval");
3611 lex_start(sv, NULL, FALSE);
3614 /* switch to eval mode */
3616 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3617 SV * const temp_sv = sv_newmortal();
3618 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3619 (unsigned long)++PL_evalseq,
3620 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3621 tmpbuf = SvPVX(temp_sv);
3622 len = SvCUR(temp_sv);
3625 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3626 SAVECOPFILE_FREE(&PL_compiling);
3627 CopFILE_set(&PL_compiling, tmpbuf+2);
3628 SAVECOPLINE(&PL_compiling);
3629 CopLINE_set(&PL_compiling, 1);
3630 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3631 deleting the eval's FILEGV from the stash before gv_check() runs
3632 (i.e. before run-time proper). To work around the coredump that
3633 ensues, we always turn GvMULTI_on for any globals that were
3634 introduced within evals. See force_ident(). GSAR 96-10-12 */
3635 safestr = savepvn(tmpbuf, len);
3636 SAVEDELETE(PL_defstash, safestr, len);
3638 PL_hints = PL_op->op_targ;
3640 GvHV(PL_hintgv) = saved_hh;
3641 SAVECOMPILEWARNINGS();
3642 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3643 if (PL_compiling.cop_hints_hash) {
3644 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3646 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3647 if (PL_compiling.cop_hints_hash) {
3649 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3650 HINTS_REFCNT_UNLOCK;
3652 /* special case: an eval '' executed within the DB package gets lexically
3653 * placed in the first non-DB CV rather than the current CV - this
3654 * allows the debugger to execute code, find lexicals etc, in the
3655 * scope of the code being debugged. Passing &seq gets find_runcv
3656 * to do the dirty work for us */
3657 runcv = find_runcv(&seq);
3659 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3661 cx->blk_eval.retop = PL_op->op_next;
3663 /* prepare to compile string */
3665 if (PERLDB_LINE && PL_curstash != PL_debstash)
3666 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3668 ok = doeval(gimme, NULL, runcv, seq);
3669 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3671 /* Copy in anything fake and short. */
3672 my_strlcpy(safestr, fakestr, fakelen);
3674 return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3684 register PERL_CONTEXT *cx;
3686 const U8 save_flags = PL_op -> op_flags;
3691 retop = cx->blk_eval.retop;
3694 if (gimme == G_VOID)
3696 else if (gimme == G_SCALAR) {
3699 if (SvFLAGS(TOPs) & SVs_TEMP)
3702 *MARK = sv_mortalcopy(TOPs);
3706 *MARK = &PL_sv_undef;
3711 /* in case LEAVE wipes old return values */
3712 for (mark = newsp + 1; mark <= SP; mark++) {
3713 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3714 *mark = sv_mortalcopy(*mark);
3715 TAINT_NOT; /* Each item is independent */
3719 PL_curpm = newpm; /* Don't pop $1 et al till now */
3722 assert(CvDEPTH(PL_compcv) == 1);
3724 CvDEPTH(PL_compcv) = 0;
3727 if (optype == OP_REQUIRE &&
3728 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3730 /* Unassume the success we assumed earlier. */
3731 SV * const nsv = cx->blk_eval.old_namesv;
3732 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3733 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3734 /* die_where() did LEAVE, or we won't be here */
3738 if (!(save_flags & OPf_SPECIAL))
3739 sv_setpvn(ERRSV,"",0);
3745 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3746 close to the related Perl_create_eval_scope. */
3748 Perl_delete_eval_scope(pTHX)
3753 register PERL_CONTEXT *cx;
3760 PERL_UNUSED_VAR(newsp);
3761 PERL_UNUSED_VAR(gimme);
3762 PERL_UNUSED_VAR(optype);
3765 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3766 also needed by Perl_fold_constants. */
3768 Perl_create_eval_scope(pTHX_ U32 flags)
3771 const I32 gimme = GIMME_V;
3776 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3779 PL_in_eval = EVAL_INEVAL;
3780 if (flags & G_KEEPERR)
3781 PL_in_eval |= EVAL_KEEPERR;
3783 sv_setpvn(ERRSV,"",0);
3784 if (flags & G_FAKINGEVAL) {
3785 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3793 PERL_CONTEXT * const cx = create_eval_scope(0);
3794 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3795 return DOCATCH(PL_op->op_next);
3804 register PERL_CONTEXT *cx;
3809 PERL_UNUSED_VAR(optype);
3812 if (gimme == G_VOID)
3814 else if (gimme == G_SCALAR) {
3818 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3821 *MARK = sv_mortalcopy(TOPs);
3825 *MARK = &PL_sv_undef;
3830 /* in case LEAVE wipes old return values */
3832 for (mark = newsp + 1; mark <= SP; mark++) {
3833 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3834 *mark = sv_mortalcopy(*mark);
3835 TAINT_NOT; /* Each item is independent */
3839 PL_curpm = newpm; /* Don't pop $1 et al till now */
3842 sv_setpvn(ERRSV,"",0);
3849 register PERL_CONTEXT *cx;
3850 const I32 gimme = GIMME_V;
3855 if (PL_op->op_targ == 0) {
3856 SV ** const defsv_p = &GvSV(PL_defgv);
3857 *defsv_p = newSVsv(POPs);
3858 SAVECLEARSV(*defsv_p);
3861 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3863 PUSHBLOCK(cx, CXt_GIVEN, SP);
3872 register PERL_CONTEXT *cx;
3876 PERL_UNUSED_CONTEXT;
3879 assert(CxTYPE(cx) == CXt_GIVEN);
3884 PL_curpm = newpm; /* pop $1 et al */
3891 /* Helper routines used by pp_smartmatch */
3893 S_make_matcher(pTHX_ REGEXP *re)
3896 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3897 PM_SETRE(matcher, ReREFCNT_inc(re));
3899 SAVEFREEOP((OP *) matcher);
3906 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3911 PL_op = (OP *) matcher;
3916 return (SvTRUEx(POPs));
3920 S_destroy_matcher(pTHX_ PMOP *matcher)
3923 PERL_UNUSED_ARG(matcher);
3928 /* Do a smart match */
3931 return do_smartmatch(NULL, NULL);
3934 /* This version of do_smartmatch() implements the
3935 * table of smart matches that is found in perlsyn.
3938 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3943 SV *e = TOPs; /* e is for 'expression' */
3944 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3945 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3946 REGEXP *this_regex, *other_regex;
3948 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3950 # define SM_REF(type) ( \
3951 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3952 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3954 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3955 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
3956 && NOT_EMPTY_PROTO(This) && (Other = e)) \
3957 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
3958 && NOT_EMPTY_PROTO(This) && (Other = d)))
3960 # define SM_REGEX ( \
3961 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \
3962 && (this_regex = (REGEXP*) This) \
3965 (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \
3966 && (this_regex = (REGEXP*) This) \
3970 # define SM_OTHER_REF(type) \
3971 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3973 # define SM_OTHER_REGEX (SvROK(Other) \
3974 && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \
3975 && (other_regex = (REGEXP*) SvRV(Other)))
3978 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3979 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3981 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3982 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3984 tryAMAGICbinSET(smart, 0);
3986 SP -= 2; /* Pop the values */
3988 /* Take care only to invoke mg_get() once for each argument.
3989 * Currently we do this by copying the SV if it's magical. */
3992 d = sv_mortalcopy(d);
3999 e = sv_mortalcopy(e);
4004 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
4006 if (This == SvRV(Other))
4017 c = call_sv(This, G_SCALAR);
4021 else if (SvTEMP(TOPs))
4022 SvREFCNT_inc_void(TOPs);
4027 else if (SM_REF(PVHV)) {
4028 if (SM_OTHER_REF(PVHV)) {
4029 /* Check that the key-sets are identical */
4031 HV *other_hv = (HV *) SvRV(Other);
4033 bool other_tied = FALSE;
4034 U32 this_key_count = 0,
4035 other_key_count = 0;
4037 /* Tied hashes don't know how many keys they have. */
4038 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
4041 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
4042 HV * const temp = other_hv;
4043 other_hv = (HV *) This;
4047 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
4050 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
4053 /* The hashes have the same number of keys, so it suffices
4054 to check that one is a subset of the other. */
4055 (void) hv_iterinit((HV *) This);
4056 while ( (he = hv_iternext((HV *) This)) ) {
4058 char * const key = hv_iterkey(he, &key_len);
4062 if(!hv_exists(other_hv, key, key_len)) {
4063 (void) hv_iterinit((HV *) This); /* reset iterator */
4069 (void) hv_iterinit(other_hv);
4070 while ( hv_iternext(other_hv) )
4074 other_key_count = HvUSEDKEYS(other_hv);
4076 if (this_key_count != other_key_count)
4081 else if (SM_OTHER_REF(PVAV)) {
4082 AV * const other_av = (AV *) SvRV(Other);
4083 const I32 other_len = av_len(other_av) + 1;
4086 for (i = 0; i < other_len; ++i) {
4087 SV ** const svp = av_fetch(other_av, i, FALSE);
4091 if (svp) { /* ??? When can this not happen? */
4092 key = SvPV(*svp, key_len);
4093 if (hv_exists((HV *) This, key, key_len))
4099 else if (SM_OTHER_REGEX) {
4100 PMOP * const matcher = make_matcher(other_regex);
4103 (void) hv_iterinit((HV *) This);
4104 while ( (he = hv_iternext((HV *) This)) ) {
4105 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4106 (void) hv_iterinit((HV *) This);
4107 destroy_matcher(matcher);
4111 destroy_matcher(matcher);
4115 if (hv_exists_ent((HV *) This, Other, 0))
4121 else if (SM_REF(PVAV)) {
4122 if (SM_OTHER_REF(PVAV)) {
4123 AV *other_av = (AV *) SvRV(Other);
4124 if (av_len((AV *) This) != av_len(other_av))
4128 const I32 other_len = av_len(other_av);
4130 if (NULL == seen_this) {
4131 seen_this = newHV();
4132 (void) sv_2mortal((SV *) seen_this);
4134 if (NULL == seen_other) {
4135 seen_this = newHV();
4136 (void) sv_2mortal((SV *) seen_other);
4138 for(i = 0; i <= other_len; ++i) {
4139 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4140 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4142 if (!this_elem || !other_elem) {
4143 if (this_elem || other_elem)
4146 else if (SM_SEEN_THIS(*this_elem)
4147 || SM_SEEN_OTHER(*other_elem))
4149 if (*this_elem != *other_elem)
4153 (void)hv_store_ent(seen_this,
4154 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4156 (void)hv_store_ent(seen_other,
4157 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4163 (void) do_smartmatch(seen_this, seen_other);
4173 else if (SM_OTHER_REGEX) {
4174 PMOP * const matcher = make_matcher(other_regex);
4175 const I32 this_len = av_len((AV *) This);
4178 for(i = 0; i <= this_len; ++i) {
4179 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4180 if (svp && matcher_matches_sv(matcher, *svp)) {
4181 destroy_matcher(matcher);
4185 destroy_matcher(matcher);
4188 else if (SvIOK(Other) || SvNOK(Other)) {
4191 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4192 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4199 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4209 else if (SvPOK(Other)) {
4210 const I32 this_len = av_len((AV *) This);
4213 for(i = 0; i <= this_len; ++i) {
4214 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4229 else if (!SvOK(d) || !SvOK(e)) {
4230 if (!SvOK(d) && !SvOK(e))
4235 else if (SM_REGEX) {
4236 PMOP * const matcher = make_matcher(this_regex);
4239 PUSHs(matcher_matches_sv(matcher, Other)
4242 destroy_matcher(matcher);
4245 else if (SM_REF(PVCV)) {
4247 /* This must be a null-prototyped sub, because we
4248 already checked for the other kind. */
4254 c = call_sv(This, G_SCALAR);
4257 PUSHs(&PL_sv_undef);
4258 else if (SvTEMP(TOPs))
4259 SvREFCNT_inc_void(TOPs);
4261 if (SM_OTHER_REF(PVCV)) {
4262 /* This one has to be null-proto'd too.
4263 Call both of 'em, and compare the results */
4265 c = call_sv(SvRV(Other), G_SCALAR);
4268 PUSHs(&PL_sv_undef);
4269 else if (SvTEMP(TOPs))
4270 SvREFCNT_inc_void(TOPs);
4281 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4282 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4284 if (SvPOK(Other) && !looks_like_number(Other)) {
4285 /* String comparison */
4290 /* Otherwise, numeric comparison */
4293 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4304 /* As a last resort, use string comparison */
4313 register PERL_CONTEXT *cx;
4314 const I32 gimme = GIMME_V;
4316 /* This is essentially an optimization: if the match
4317 fails, we don't want to push a context and then
4318 pop it again right away, so we skip straight
4319 to the op that follows the leavewhen.
4321 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4322 return cLOGOP->op_other->op_next;
4327 PUSHBLOCK(cx, CXt_WHEN, SP);
4336 register PERL_CONTEXT *cx;
4342 assert(CxTYPE(cx) == CXt_WHEN);
4347 PL_curpm = newpm; /* pop $1 et al */
4357 register PERL_CONTEXT *cx;
4360 cxix = dopoptowhen(cxstack_ix);
4362 DIE(aTHX_ "Can't \"continue\" outside a when block");
4363 if (cxix < cxstack_ix)
4366 /* clear off anything above the scope we're re-entering */
4367 inner = PL_scopestack_ix;
4369 if (PL_scopestack_ix < inner)
4370 leave_scope(PL_scopestack[PL_scopestack_ix]);
4371 PL_curcop = cx->blk_oldcop;
4372 return cx->blk_givwhen.leave_op;
4379 register PERL_CONTEXT *cx;
4382 cxix = dopoptogiven(cxstack_ix);
4384 if (PL_op->op_flags & OPf_SPECIAL)
4385 DIE(aTHX_ "Can't use when() outside a topicalizer");
4387 DIE(aTHX_ "Can't \"break\" outside a given block");
4389 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4390 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4392 if (cxix < cxstack_ix)
4395 /* clear off anything above the scope we're re-entering */
4396 inner = PL_scopestack_ix;
4398 if (PL_scopestack_ix < inner)
4399 leave_scope(PL_scopestack[PL_scopestack_ix]);
4400 PL_curcop = cx->blk_oldcop;
4403 return CX_LOOP_NEXTOP_GET(cx);
4405 return cx->blk_givwhen.leave_op;
4409 S_doparseform(pTHX_ SV *sv)
4412 register char *s = SvPV_force(sv, len);
4413 register char * const send = s + len;
4414 register char *base = NULL;
4415 register I32 skipspaces = 0;
4416 bool noblank = FALSE;
4417 bool repeat = FALSE;
4418 bool postspace = FALSE;
4424 bool unchopnum = FALSE;
4425 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4428 Perl_croak(aTHX_ "Null picture in formline");
4430 /* estimate the buffer size needed */
4431 for (base = s; s <= send; s++) {
4432 if (*s == '\n' || *s == '@' || *s == '^')
4438 Newx(fops, maxops, U32);
4443 *fpc++ = FF_LINEMARK;
4444 noblank = repeat = FALSE;
4462 case ' ': case '\t':
4469 } /* else FALL THROUGH */
4477 *fpc++ = FF_LITERAL;
4485 *fpc++ = (U16)skipspaces;
4489 *fpc++ = FF_NEWLINE;
4493 arg = fpc - linepc + 1;
4500 *fpc++ = FF_LINEMARK;
4501 noblank = repeat = FALSE;
4510 ischop = s[-1] == '^';
4516 arg = (s - base) - 1;
4518 *fpc++ = FF_LITERAL;
4526 *fpc++ = 2; /* skip the @* or ^* */
4528 *fpc++ = FF_LINESNGL;
4531 *fpc++ = FF_LINEGLOB;
4533 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4534 arg = ischop ? 512 : 0;
4539 const char * const f = ++s;
4542 arg |= 256 + (s - f);
4544 *fpc++ = s - base; /* fieldsize for FETCH */
4545 *fpc++ = FF_DECIMAL;
4547 unchopnum |= ! ischop;
4549 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4550 arg = ischop ? 512 : 0;
4552 s++; /* skip the '0' first */
4556 const char * const f = ++s;
4559 arg |= 256 + (s - f);
4561 *fpc++ = s - base; /* fieldsize for FETCH */
4562 *fpc++ = FF_0DECIMAL;
4564 unchopnum |= ! ischop;
4568 bool ismore = FALSE;
4571 while (*++s == '>') ;
4572 prespace = FF_SPACE;
4574 else if (*s == '|') {
4575 while (*++s == '|') ;
4576 prespace = FF_HALFSPACE;
4581 while (*++s == '<') ;
4584 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4588 *fpc++ = s - base; /* fieldsize for FETCH */
4590 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4593 *fpc++ = (U16)prespace;
4607 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4609 { /* need to jump to the next word */
4611 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4612 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4613 s = SvPVX(sv) + SvCUR(sv) + z;
4615 Copy(fops, s, arg, U32);
4617 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4620 if (unchopnum && repeat)
4621 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4627 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4629 /* Can value be printed in fldsize chars, using %*.*f ? */
4633 int intsize = fldsize - (value < 0 ? 1 : 0);
4640 while (intsize--) pwr *= 10.0;
4641 while (frcsize--) eps /= 10.0;
4644 if (value + eps >= pwr)
4647 if (value - eps <= -pwr)
4654 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4657 SV * const datasv = FILTER_DATA(idx);
4658 const int filter_has_file = IoLINES(datasv);
4659 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4660 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4664 const char *got_p = NULL;
4665 const char *prune_from = NULL;
4666 bool read_from_cache = FALSE;
4669 assert(maxlen >= 0);
4672 /* I was having segfault trouble under Linux 2.2.5 after a
4673 parse error occured. (Had to hack around it with a test
4674 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4675 not sure where the trouble is yet. XXX */
4677 if (IoFMT_GV(datasv)) {
4678 SV *const cache = (SV *)IoFMT_GV(datasv);
4681 const char *cache_p = SvPV(cache, cache_len);
4685 /* Running in block mode and we have some cached data already.
4687 if (cache_len >= umaxlen) {
4688 /* In fact, so much data we don't even need to call
4693 const char *const first_nl =
4694 (const char *)memchr(cache_p, '\n', cache_len);
4696 take = first_nl + 1 - cache_p;
4700 sv_catpvn(buf_sv, cache_p, take);
4701 sv_chop(cache, cache_p + take);
4702 /* Definately not EOF */
4706 sv_catsv(buf_sv, cache);
4708 umaxlen -= cache_len;
4711 read_from_cache = TRUE;
4715 /* Filter API says that the filter appends to the contents of the buffer.
4716 Usually the buffer is "", so the details don't matter. But if it's not,
4717 then clearly what it contains is already filtered by this filter, so we
4718 don't want to pass it in a second time.
4719 I'm going to use a mortal in case the upstream filter croaks. */
4720 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4721 ? sv_newmortal() : buf_sv;
4722 SvUPGRADE(upstream, SVt_PV);
4724 if (filter_has_file) {
4725 status = FILTER_READ(idx+1, upstream, 0);
4728 if (filter_sub && status >= 0) {
4741 PUSHs(filter_state);
4744 count = call_sv(filter_sub, G_SCALAR);
4759 if(SvOK(upstream)) {
4760 got_p = SvPV(upstream, got_len);
4762 if (got_len > umaxlen) {
4763 prune_from = got_p + umaxlen;
4766 const char *const first_nl =
4767 (const char *)memchr(got_p, '\n', got_len);
4768 if (first_nl && first_nl + 1 < got_p + got_len) {
4769 /* There's a second line here... */
4770 prune_from = first_nl + 1;
4775 /* Oh. Too long. Stuff some in our cache. */
4776 STRLEN cached_len = got_p + got_len - prune_from;
4777 SV *cache = (SV *)IoFMT_GV(datasv);
4780 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4781 } else if (SvOK(cache)) {
4782 /* Cache should be empty. */
4783 assert(!SvCUR(cache));
4786 sv_setpvn(cache, prune_from, cached_len);
4787 /* If you ask for block mode, you may well split UTF-8 characters.
4788 "If it breaks, you get to keep both parts"
4789 (Your code is broken if you don't put them back together again
4790 before something notices.) */
4791 if (SvUTF8(upstream)) {
4794 SvCUR_set(upstream, got_len - cached_len);
4795 /* Can't yet be EOF */
4800 /* If they are at EOF but buf_sv has something in it, then they may never
4801 have touched the SV upstream, so it may be undefined. If we naively
4802 concatenate it then we get a warning about use of uninitialised value.
4804 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4805 sv_catsv(buf_sv, upstream);
4809 IoLINES(datasv) = 0;
4810 SvREFCNT_dec(IoFMT_GV(datasv));
4812 SvREFCNT_dec(filter_state);
4813 IoTOP_GV(datasv) = NULL;
4816 SvREFCNT_dec(filter_sub);
4817 IoBOTTOM_GV(datasv) = NULL;
4819 filter_del(S_run_user_filter);
4821 if (status == 0 && read_from_cache) {
4822 /* If we read some data from the cache (and by getting here it implies
4823 that we emptied the cache) then we aren't yet at EOF, and mustn't
4824 report that to our caller. */
4830 /* perhaps someone can come up with a better name for
4831 this? it is not really "absolute", per se ... */
4833 S_path_is_absolute(const char *name)
4835 if (PERL_FILE_IS_ABSOLUTE(name)
4836 #ifdef MACOS_TRADITIONAL
4839 || (*name == '.' && (name[1] == '/' ||
4840 (name[1] == '.' && name[2] == '/')))
4852 * c-indentation-style: bsd
4854 * indent-tabs-mode: t
4857 * ex: set ts=8 sts=4 sw=4 noet: