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 (cx->sb_once || !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)
1260 if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
1261 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1262 (long)i, CxLABEL(cx)));
1265 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1275 Perl_dowantarray(pTHX)
1278 const I32 gimme = block_gimme();
1279 return (gimme == G_VOID) ? G_SCALAR : gimme;
1283 Perl_block_gimme(pTHX)
1286 const I32 cxix = dopoptosub(cxstack_ix);
1290 switch (cxstack[cxix].blk_gimme) {
1298 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1305 Perl_is_lvalue_sub(pTHX)
1308 const I32 cxix = dopoptosub(cxstack_ix);
1309 assert(cxix >= 0); /* We should only be called from inside subs */
1311 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1312 return CxLVAL(cxstack + cxix);
1318 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1322 for (i = startingblock; i >= 0; i--) {
1323 register const PERL_CONTEXT * const cx = &cxstk[i];
1324 switch (CxTYPE(cx)) {
1330 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1338 S_dopoptoeval(pTHX_ I32 startingblock)
1342 for (i = startingblock; i >= 0; i--) {
1343 register const PERL_CONTEXT *cx = &cxstack[i];
1344 switch (CxTYPE(cx)) {
1348 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1356 S_dopoptoloop(pTHX_ I32 startingblock)
1360 for (i = startingblock; i >= 0; i--) {
1361 register const PERL_CONTEXT * const cx = &cxstack[i];
1362 switch (CxTYPE(cx)) {
1368 if (ckWARN(WARN_EXITING))
1369 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1370 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1371 if ((CxTYPE(cx)) == CXt_NULL)
1375 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1383 S_dopoptogiven(pTHX_ I32 startingblock)
1387 for (i = startingblock; i >= 0; i--) {
1388 register const PERL_CONTEXT *cx = &cxstack[i];
1389 switch (CxTYPE(cx)) {
1393 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1396 if (CxFOREACHDEF(cx)) {
1397 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1406 S_dopoptowhen(pTHX_ I32 startingblock)
1410 for (i = startingblock; i >= 0; i--) {
1411 register const PERL_CONTEXT *cx = &cxstack[i];
1412 switch (CxTYPE(cx)) {
1416 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1424 Perl_dounwind(pTHX_ I32 cxix)
1429 while (cxstack_ix > cxix) {
1431 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1432 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1433 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1434 /* Note: we don't need to restore the base context info till the end. */
1435 switch (CxTYPE(cx)) {
1438 continue; /* not break */
1457 PERL_UNUSED_VAR(optype);
1461 Perl_qerror(pTHX_ SV *err)
1465 sv_catsv(ERRSV, err);
1467 sv_catsv(PL_errors, err);
1469 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1471 ++PL_parser->error_count;
1475 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1484 if (PL_in_eval & EVAL_KEEPERR) {
1485 static const char prefix[] = "\t(in cleanup) ";
1486 SV * const err = ERRSV;
1487 const char *e = NULL;
1489 sv_setpvn(err,"",0);
1490 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1492 e = SvPV_const(err, len);
1494 if (*e != *message || strNE(e,message))
1498 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1499 sv_catpvn(err, prefix, sizeof(prefix)-1);
1500 sv_catpvn(err, message, msglen);
1501 if (ckWARN(WARN_MISC)) {
1502 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1503 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1508 sv_setpvn(ERRSV, message, msglen);
1512 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1513 && PL_curstackinfo->si_prev)
1521 register PERL_CONTEXT *cx;
1524 if (cxix < cxstack_ix)
1527 POPBLOCK(cx,PL_curpm);
1528 if (CxTYPE(cx) != CXt_EVAL) {
1530 message = SvPVx_const(ERRSV, msglen);
1531 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1532 PerlIO_write(Perl_error_log, message, msglen);
1537 if (gimme == G_SCALAR)
1538 *++newsp = &PL_sv_undef;
1539 PL_stack_sp = newsp;
1543 /* LEAVE could clobber PL_curcop (see save_re_context())
1544 * XXX it might be better to find a way to avoid messing with
1545 * PL_curcop in save_re_context() instead, but this is a more
1546 * minimal fix --GSAR */
1547 PL_curcop = cx->blk_oldcop;
1549 if (optype == OP_REQUIRE) {
1550 const char* const msg = SvPVx_nolen_const(ERRSV);
1551 SV * const nsv = cx->blk_eval.old_namesv;
1552 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1554 DIE(aTHX_ "%sCompilation failed in require",
1555 *msg ? msg : "Unknown error\n");
1557 assert(CxTYPE(cx) == CXt_EVAL);
1558 return cx->blk_eval.retop;
1562 message = SvPVx_const(ERRSV, msglen);
1564 write_to_stderr(message, msglen);
1572 dVAR; dSP; dPOPTOPssrl;
1573 if (SvTRUE(left) != SvTRUE(right))
1583 register I32 cxix = dopoptosub(cxstack_ix);
1584 register const PERL_CONTEXT *cx;
1585 register const PERL_CONTEXT *ccstack = cxstack;
1586 const PERL_SI *top_si = PL_curstackinfo;
1588 const char *stashname;
1595 /* we may be in a higher stacklevel, so dig down deeper */
1596 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1597 top_si = top_si->si_prev;
1598 ccstack = top_si->si_cxstack;
1599 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1602 if (GIMME != G_ARRAY) {
1608 /* caller() should not report the automatic calls to &DB::sub */
1609 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1610 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1614 cxix = dopoptosub_at(ccstack, cxix - 1);
1617 cx = &ccstack[cxix];
1618 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1619 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1620 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1621 field below is defined for any cx. */
1622 /* caller() should not report the automatic calls to &DB::sub */
1623 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1624 cx = &ccstack[dbcxix];
1627 stashname = CopSTASHPV(cx->blk_oldcop);
1628 if (GIMME != G_ARRAY) {
1631 PUSHs(&PL_sv_undef);
1634 sv_setpv(TARG, stashname);
1643 PUSHs(&PL_sv_undef);
1645 mPUSHs(newSVpv(stashname, 0));
1646 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1647 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1650 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1651 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1652 /* So is ccstack[dbcxix]. */
1654 SV * const sv = newSV(0);
1655 gv_efullname3(sv, cvgv, NULL);
1657 mPUSHi((I32)CxHASARGS(cx));
1660 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1661 mPUSHi((I32)CxHASARGS(cx));
1665 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1668 gimme = (I32)cx->blk_gimme;
1669 if (gimme == G_VOID)
1670 PUSHs(&PL_sv_undef);
1672 mPUSHi(gimme & G_ARRAY);
1673 if (CxTYPE(cx) == CXt_EVAL) {
1675 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1676 PUSHs(cx->blk_eval.cur_text);
1680 else if (cx->blk_eval.old_namesv) {
1681 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1684 /* eval BLOCK (try blocks have old_namesv == 0) */
1686 PUSHs(&PL_sv_undef);
1687 PUSHs(&PL_sv_undef);
1691 PUSHs(&PL_sv_undef);
1692 PUSHs(&PL_sv_undef);
1694 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1695 && CopSTASH_eq(PL_curcop, PL_debstash))
1697 AV * const ary = cx->blk_sub.argarray;
1698 const int off = AvARRAY(ary) - AvALLOC(ary);
1701 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1702 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1704 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1707 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1708 av_extend(PL_dbargs, AvFILLp(ary) + off);
1709 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1710 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1712 /* XXX only hints propagated via op_private are currently
1713 * visible (others are not easily accessible, since they
1714 * use the global PL_hints) */
1715 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1718 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1720 if (old_warnings == pWARN_NONE ||
1721 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1722 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1723 else if (old_warnings == pWARN_ALL ||
1724 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1725 /* Get the bit mask for $warnings::Bits{all}, because
1726 * it could have been extended by warnings::register */
1728 HV * const bits = get_hv("warnings::Bits", FALSE);
1729 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1730 mask = newSVsv(*bits_all);
1733 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1737 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1741 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1742 sv_2mortal(newRV_noinc(
1743 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1744 cx->blk_oldcop->cop_hints_hash)))
1753 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1754 sv_reset(tmps, CopSTASH(PL_curcop));
1759 /* like pp_nextstate, but used instead when the debugger is active */
1764 PL_curcop = (COP*)PL_op;
1765 TAINT_NOT; /* Each statement is presumed innocent */
1766 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1769 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1770 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1773 register PERL_CONTEXT *cx;
1774 const I32 gimme = G_ARRAY;
1776 GV * const gv = PL_DBgv;
1777 register CV * const cv = GvCV(gv);
1780 DIE(aTHX_ "No DB::DB routine defined");
1782 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1783 /* don't do recursive DB::DB call */
1798 (void)(*CvXSUB(cv))(aTHX_ cv);
1805 PUSHBLOCK(cx, CXt_SUB, SP);
1807 cx->blk_sub.retop = PL_op->op_next;
1810 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1811 RETURNOP(CvSTART(cv));
1821 register PERL_CONTEXT *cx;
1822 const I32 gimme = GIMME_V;
1824 U16 cxtype = CXt_LOOP | CXp_FOREACH;
1832 if (PL_op->op_targ) {
1833 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1834 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1835 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1836 SVs_PADSTALE, SVs_PADSTALE);
1838 #ifndef USE_ITHREADS
1839 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1842 SAVEPADSV(PL_op->op_targ);
1843 iterdata = INT2PTR(void*, PL_op->op_targ);
1844 cxtype |= CXp_PADVAR;
1848 GV * const gv = (GV*)POPs;
1849 svp = &GvSV(gv); /* symbol table variable */
1850 SAVEGENERICSV(*svp);
1853 iterdata = (void*)gv;
1857 if (PL_op->op_private & OPpITER_DEF)
1858 cxtype |= CXp_FOR_DEF;
1862 PUSHBLOCK(cx, cxtype, SP);
1864 PUSHLOOP(cx, iterdata, MARK);
1866 PUSHLOOP(cx, svp, MARK);
1868 if (PL_op->op_flags & OPf_STACKED) {
1869 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1870 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1872 SV * const right = (SV*)cx->blk_loop.iterary;
1875 if (RANGE_IS_NUMERIC(sv,right)) {
1876 #ifdef NV_PRESERVES_UV
1877 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1878 (SvNV(sv) > (NV)IV_MAX)))
1880 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1881 (SvNV(right) < (NV)IV_MIN))))
1883 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1886 ((SvUV(sv) > (UV)IV_MAX) ||
1887 (SvNV(sv) > (NV)UV_MAX)))))
1889 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1891 ((SvNV(right) > 0) &&
1892 ((SvUV(right) > (UV)IV_MAX) ||
1893 (SvNV(right) > (NV)UV_MAX))))))
1895 DIE(aTHX_ "Range iterator outside integer range");
1896 cx->blk_loop.iterix = SvIV(sv);
1897 cx->blk_loop.itermax = SvIV(right);
1899 /* for correct -Dstv display */
1900 cx->blk_oldsp = sp - PL_stack_base;
1904 cx->blk_loop.iterlval = newSVsv(sv);
1905 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1906 (void) SvPV_nolen_const(right);
1909 else if (PL_op->op_private & OPpITER_REVERSED) {
1910 cx->blk_loop.itermax = 0;
1911 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1916 cx->blk_loop.iterary = PL_curstack;
1917 AvFILLp(PL_curstack) = SP - PL_stack_base;
1918 if (PL_op->op_private & OPpITER_REVERSED) {
1919 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1920 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1923 cx->blk_loop.iterix = MARK - PL_stack_base;
1933 register PERL_CONTEXT *cx;
1934 const I32 gimme = GIMME_V;
1940 PUSHBLOCK(cx, CXt_LOOP, SP);
1941 PUSHLOOP(cx, 0, SP);
1949 register PERL_CONTEXT *cx;
1956 assert(CxTYPE(cx) == CXt_LOOP);
1958 newsp = PL_stack_base + cx->blk_loop.resetsp;
1961 if (gimme == G_VOID)
1963 else if (gimme == G_SCALAR) {
1965 *++newsp = sv_mortalcopy(*SP);
1967 *++newsp = &PL_sv_undef;
1971 *++newsp = sv_mortalcopy(*++mark);
1972 TAINT_NOT; /* Each item is independent */
1978 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1979 PL_curpm = newpm; /* ... and pop $1 et al */
1990 register PERL_CONTEXT *cx;
1991 bool popsub2 = FALSE;
1992 bool clear_errsv = FALSE;
2000 const I32 cxix = dopoptosub(cxstack_ix);
2003 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2004 * sort block, which is a CXt_NULL
2007 PL_stack_base[1] = *PL_stack_sp;
2008 PL_stack_sp = PL_stack_base + 1;
2012 DIE(aTHX_ "Can't return outside a subroutine");
2014 if (cxix < cxstack_ix)
2017 if (CxMULTICALL(&cxstack[cxix])) {
2018 gimme = cxstack[cxix].blk_gimme;
2019 if (gimme == G_VOID)
2020 PL_stack_sp = PL_stack_base;
2021 else if (gimme == G_SCALAR) {
2022 PL_stack_base[1] = *PL_stack_sp;
2023 PL_stack_sp = PL_stack_base + 1;
2029 switch (CxTYPE(cx)) {
2032 retop = cx->blk_sub.retop;
2033 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2036 if (!(PL_in_eval & EVAL_KEEPERR))
2039 retop = cx->blk_eval.retop;
2043 if (optype == OP_REQUIRE &&
2044 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2046 /* Unassume the success we assumed earlier. */
2047 SV * const nsv = cx->blk_eval.old_namesv;
2048 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2049 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2054 retop = cx->blk_sub.retop;
2057 DIE(aTHX_ "panic: return");
2061 if (gimme == G_SCALAR) {
2064 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2066 *++newsp = SvREFCNT_inc(*SP);
2071 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2073 *++newsp = sv_mortalcopy(sv);
2078 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2081 *++newsp = sv_mortalcopy(*SP);
2084 *++newsp = &PL_sv_undef;
2086 else if (gimme == G_ARRAY) {
2087 while (++MARK <= SP) {
2088 *++newsp = (popsub2 && SvTEMP(*MARK))
2089 ? *MARK : sv_mortalcopy(*MARK);
2090 TAINT_NOT; /* Each item is independent */
2093 PL_stack_sp = newsp;
2096 /* Stack values are safe: */
2099 POPSUB(cx,sv); /* release CV and @_ ... */
2103 PL_curpm = newpm; /* ... and pop $1 et al */
2107 sv_setpvn(ERRSV,"",0);
2115 register PERL_CONTEXT *cx;
2126 if (PL_op->op_flags & OPf_SPECIAL) {
2127 cxix = dopoptoloop(cxstack_ix);
2129 DIE(aTHX_ "Can't \"last\" outside a loop block");
2132 cxix = dopoptolabel(cPVOP->op_pv);
2134 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2136 if (cxix < cxstack_ix)
2140 cxstack_ix++; /* temporarily protect top context */
2142 switch (CxTYPE(cx)) {
2145 newsp = PL_stack_base + cx->blk_loop.resetsp;
2146 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2150 nextop = cx->blk_sub.retop;
2154 nextop = cx->blk_eval.retop;
2158 nextop = cx->blk_sub.retop;
2161 DIE(aTHX_ "panic: last");
2165 if (gimme == G_SCALAR) {
2167 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2168 ? *SP : sv_mortalcopy(*SP);
2170 *++newsp = &PL_sv_undef;
2172 else if (gimme == G_ARRAY) {
2173 while (++MARK <= SP) {
2174 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2175 ? *MARK : sv_mortalcopy(*MARK);
2176 TAINT_NOT; /* Each item is independent */
2184 /* Stack values are safe: */
2187 POPLOOP(cx); /* release loop vars ... */
2191 POPSUB(cx,sv); /* release CV and @_ ... */
2194 PL_curpm = newpm; /* ... and pop $1 et al */
2197 PERL_UNUSED_VAR(optype);
2198 PERL_UNUSED_VAR(gimme);
2206 register PERL_CONTEXT *cx;
2209 if (PL_op->op_flags & OPf_SPECIAL) {
2210 cxix = dopoptoloop(cxstack_ix);
2212 DIE(aTHX_ "Can't \"next\" outside a loop block");
2215 cxix = dopoptolabel(cPVOP->op_pv);
2217 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2219 if (cxix < cxstack_ix)
2222 /* clear off anything above the scope we're re-entering, but
2223 * save the rest until after a possible continue block */
2224 inner = PL_scopestack_ix;
2226 if (PL_scopestack_ix < inner)
2227 leave_scope(PL_scopestack[PL_scopestack_ix]);
2228 PL_curcop = cx->blk_oldcop;
2229 return CX_LOOP_NEXTOP_GET(cx);
2236 register PERL_CONTEXT *cx;
2240 if (PL_op->op_flags & OPf_SPECIAL) {
2241 cxix = dopoptoloop(cxstack_ix);
2243 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2246 cxix = dopoptolabel(cPVOP->op_pv);
2248 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2250 if (cxix < cxstack_ix)
2253 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2254 if (redo_op->op_type == OP_ENTER) {
2255 /* pop one less context to avoid $x being freed in while (my $x..) */
2257 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2258 redo_op = redo_op->op_next;
2262 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2263 LEAVE_SCOPE(oldsave);
2265 PL_curcop = cx->blk_oldcop;
2270 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2274 static const char too_deep[] = "Target of goto is too deeply nested";
2277 Perl_croak(aTHX_ too_deep);
2278 if (o->op_type == OP_LEAVE ||
2279 o->op_type == OP_SCOPE ||
2280 o->op_type == OP_LEAVELOOP ||
2281 o->op_type == OP_LEAVESUB ||
2282 o->op_type == OP_LEAVETRY)
2284 *ops++ = cUNOPo->op_first;
2286 Perl_croak(aTHX_ too_deep);
2289 if (o->op_flags & OPf_KIDS) {
2291 /* First try all the kids at this level, since that's likeliest. */
2292 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2293 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2294 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2297 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2298 if (kid == PL_lastgotoprobe)
2300 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2303 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2304 ops[-1]->op_type == OP_DBSTATE)
2309 if ((o = dofindlabel(kid, label, ops, oplimit)))
2322 register PERL_CONTEXT *cx;
2323 #define GOTO_DEPTH 64
2324 OP *enterops[GOTO_DEPTH];
2325 const char *label = NULL;
2326 const bool do_dump = (PL_op->op_type == OP_DUMP);
2327 static const char must_have_label[] = "goto must have label";
2329 if (PL_op->op_flags & OPf_STACKED) {
2330 SV * const sv = POPs;
2332 /* This egregious kludge implements goto &subroutine */
2333 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2335 register PERL_CONTEXT *cx;
2336 CV* cv = (CV*)SvRV(sv);
2343 if (!CvROOT(cv) && !CvXSUB(cv)) {
2344 const GV * const gv = CvGV(cv);
2348 /* autoloaded stub? */
2349 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2351 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2352 GvNAMELEN(gv), FALSE);
2353 if (autogv && (cv = GvCV(autogv)))
2355 tmpstr = sv_newmortal();
2356 gv_efullname3(tmpstr, gv, NULL);
2357 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2359 DIE(aTHX_ "Goto undefined subroutine");
2362 /* First do some returnish stuff. */
2363 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2365 cxix = dopoptosub(cxstack_ix);
2367 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2368 if (cxix < cxstack_ix)
2372 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2373 if (CxTYPE(cx) == CXt_EVAL) {
2375 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2377 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2379 else if (CxMULTICALL(cx))
2380 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2381 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2382 /* put @_ back onto stack */
2383 AV* av = cx->blk_sub.argarray;
2385 items = AvFILLp(av) + 1;
2386 EXTEND(SP, items+1); /* @_ could have been extended. */
2387 Copy(AvARRAY(av), SP + 1, items, SV*);
2388 SvREFCNT_dec(GvAV(PL_defgv));
2389 GvAV(PL_defgv) = cx->blk_sub.savearray;
2391 /* abandon @_ if it got reified */
2396 av_extend(av, items-1);
2398 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2401 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2402 AV* const av = GvAV(PL_defgv);
2403 items = AvFILLp(av) + 1;
2404 EXTEND(SP, items+1); /* @_ could have been extended. */
2405 Copy(AvARRAY(av), SP + 1, items, SV*);
2409 if (CxTYPE(cx) == CXt_SUB &&
2410 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2411 SvREFCNT_dec(cx->blk_sub.cv);
2412 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2413 LEAVE_SCOPE(oldsave);
2415 /* Now do some callish stuff. */
2417 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2419 OP* const retop = cx->blk_sub.retop;
2424 for (index=0; index<items; index++)
2425 sv_2mortal(SP[-index]);
2428 /* XS subs don't have a CxSUB, so pop it */
2429 POPBLOCK(cx, PL_curpm);
2430 /* Push a mark for the start of arglist */
2433 (void)(*CvXSUB(cv))(aTHX_ cv);
2438 AV* const padlist = CvPADLIST(cv);
2439 if (CxTYPE(cx) == CXt_EVAL) {
2440 PL_in_eval = cx->blk_eval.old_in_eval;
2441 PL_eval_root = cx->blk_eval.old_eval_root;
2442 cx->cx_type = CXt_SUB;
2443 cx->blk_sub.hasargs = 0;
2445 cx->blk_sub.cv = cv;
2446 cx->blk_sub.olddepth = CvDEPTH(cv);
2449 if (CvDEPTH(cv) < 2)
2450 SvREFCNT_inc_simple_void_NN(cv);
2452 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2453 sub_crush_depth(cv);
2454 pad_push(padlist, CvDEPTH(cv));
2457 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2460 AV* const av = (AV*)PAD_SVl(0);
2462 cx->blk_sub.savearray = GvAV(PL_defgv);
2463 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2464 CX_CURPAD_SAVE(cx->blk_sub);
2465 cx->blk_sub.argarray = av;
2467 if (items >= AvMAX(av) + 1) {
2468 SV **ary = AvALLOC(av);
2469 if (AvARRAY(av) != ary) {
2470 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2473 if (items >= AvMAX(av) + 1) {
2474 AvMAX(av) = items - 1;
2475 Renew(ary,items+1,SV*);
2481 Copy(mark,AvARRAY(av),items,SV*);
2482 AvFILLp(av) = items - 1;
2483 assert(!AvREAL(av));
2485 /* transfer 'ownership' of refcnts to new @_ */
2495 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2496 Perl_get_db_sub(aTHX_ NULL, cv);
2498 CV * const gotocv = get_cv("DB::goto", FALSE);
2500 PUSHMARK( PL_stack_sp );
2501 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2506 RETURNOP(CvSTART(cv));
2510 label = SvPV_nolen_const(sv);
2511 if (!(do_dump || *label))
2512 DIE(aTHX_ must_have_label);
2515 else if (PL_op->op_flags & OPf_SPECIAL) {
2517 DIE(aTHX_ must_have_label);
2520 label = cPVOP->op_pv;
2522 if (label && *label) {
2523 OP *gotoprobe = NULL;
2524 bool leaving_eval = FALSE;
2525 bool in_block = FALSE;
2526 PERL_CONTEXT *last_eval_cx = NULL;
2530 PL_lastgotoprobe = NULL;
2532 for (ix = cxstack_ix; ix >= 0; ix--) {
2534 switch (CxTYPE(cx)) {
2536 leaving_eval = TRUE;
2537 if (!CxTRYBLOCK(cx)) {
2538 gotoprobe = (last_eval_cx ?
2539 last_eval_cx->blk_eval.old_eval_root :
2544 /* else fall through */
2546 gotoprobe = cx->blk_oldcop->op_sibling;
2552 gotoprobe = cx->blk_oldcop->op_sibling;
2555 gotoprobe = PL_main_root;
2558 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2559 gotoprobe = CvROOT(cx->blk_sub.cv);
2565 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2568 DIE(aTHX_ "panic: goto");
2569 gotoprobe = PL_main_root;
2573 retop = dofindlabel(gotoprobe, label,
2574 enterops, enterops + GOTO_DEPTH);
2578 PL_lastgotoprobe = gotoprobe;
2581 DIE(aTHX_ "Can't find label %s", label);
2583 /* if we're leaving an eval, check before we pop any frames
2584 that we're not going to punt, otherwise the error
2587 if (leaving_eval && *enterops && enterops[1]) {
2589 for (i = 1; enterops[i]; i++)
2590 if (enterops[i]->op_type == OP_ENTERITER)
2591 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2594 /* pop unwanted frames */
2596 if (ix < cxstack_ix) {
2603 oldsave = PL_scopestack[PL_scopestack_ix];
2604 LEAVE_SCOPE(oldsave);
2607 /* push wanted frames */
2609 if (*enterops && enterops[1]) {
2610 OP * const oldop = PL_op;
2611 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2612 for (; enterops[ix]; ix++) {
2613 PL_op = enterops[ix];
2614 /* Eventually we may want to stack the needed arguments
2615 * for each op. For now, we punt on the hard ones. */
2616 if (PL_op->op_type == OP_ENTERITER)
2617 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2618 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2626 if (!retop) retop = PL_main_start;
2628 PL_restartop = retop;
2629 PL_do_undump = TRUE;
2633 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2634 PL_do_undump = FALSE;
2651 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2653 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2656 PL_exit_flags |= PERL_EXIT_EXPECTED;
2658 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2659 if (anum || !(PL_minus_c && PL_madskills))
2664 PUSHs(&PL_sv_undef);
2671 S_save_lines(pTHX_ AV *array, SV *sv)
2673 const char *s = SvPVX_const(sv);
2674 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2677 while (s && s < send) {
2679 SV * const tmpstr = newSV_type(SVt_PVMG);
2681 t = strchr(s, '\n');
2687 sv_setpvn(tmpstr, s, t - s);
2688 av_store(array, line++, tmpstr);
2694 S_docatch(pTHX_ OP *o)
2698 OP * const oldop = PL_op;
2702 assert(CATCH_GET == TRUE);
2709 assert(cxstack_ix >= 0);
2710 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2711 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2716 /* die caught by an inner eval - continue inner loop */
2718 /* NB XXX we rely on the old popped CxEVAL still being at the top
2719 * of the stack; the way die_where() currently works, this
2720 * assumption is valid. In theory The cur_top_env value should be
2721 * returned in another global, the way retop (aka PL_restartop)
2723 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2726 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2728 PL_op = PL_restartop;
2745 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2746 /* sv Text to convert to OP tree. */
2747 /* startop op_free() this to undo. */
2748 /* code Short string id of the caller. */
2750 /* FIXME - how much of this code is common with pp_entereval? */
2751 dVAR; dSP; /* Make POPBLOCK work. */
2757 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2758 char *tmpbuf = tbuf;
2761 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2765 lex_start(sv, NULL, FALSE);
2767 /* switch to eval mode */
2769 if (IN_PERL_COMPILETIME) {
2770 SAVECOPSTASH_FREE(&PL_compiling);
2771 CopSTASH_set(&PL_compiling, PL_curstash);
2773 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2774 SV * const sv = sv_newmortal();
2775 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2776 code, (unsigned long)++PL_evalseq,
2777 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2782 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2783 (unsigned long)++PL_evalseq);
2784 SAVECOPFILE_FREE(&PL_compiling);
2785 CopFILE_set(&PL_compiling, tmpbuf+2);
2786 SAVECOPLINE(&PL_compiling);
2787 CopLINE_set(&PL_compiling, 1);
2788 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2789 deleting the eval's FILEGV from the stash before gv_check() runs
2790 (i.e. before run-time proper). To work around the coredump that
2791 ensues, we always turn GvMULTI_on for any globals that were
2792 introduced within evals. See force_ident(). GSAR 96-10-12 */
2793 safestr = savepvn(tmpbuf, len);
2794 SAVEDELETE(PL_defstash, safestr, len);
2796 #ifdef OP_IN_REGISTER
2802 /* we get here either during compilation, or via pp_regcomp at runtime */
2803 runtime = IN_PERL_RUNTIME;
2805 runcv = find_runcv(NULL);
2808 PL_op->op_type = OP_ENTEREVAL;
2809 PL_op->op_flags = 0; /* Avoid uninit warning. */
2810 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2811 PUSHEVAL(cx, 0, NULL);
2814 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2816 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2817 POPBLOCK(cx,PL_curpm);
2820 (*startop)->op_type = OP_NULL;
2821 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2823 /* XXX DAPM do this properly one year */
2824 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2826 if (IN_PERL_COMPILETIME)
2827 CopHINTS_set(&PL_compiling, PL_hints);
2828 #ifdef OP_IN_REGISTER
2831 PERL_UNUSED_VAR(newsp);
2832 PERL_UNUSED_VAR(optype);
2834 return PL_eval_start;
2839 =for apidoc find_runcv
2841 Locate the CV corresponding to the currently executing sub or eval.
2842 If db_seqp is non_null, skip CVs that are in the DB package and populate
2843 *db_seqp with the cop sequence number at the point that the DB:: code was
2844 entered. (allows debuggers to eval in the scope of the breakpoint rather
2845 than in the scope of the debugger itself).
2851 Perl_find_runcv(pTHX_ U32 *db_seqp)
2857 *db_seqp = PL_curcop->cop_seq;
2858 for (si = PL_curstackinfo; si; si = si->si_prev) {
2860 for (ix = si->si_cxix; ix >= 0; ix--) {
2861 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2862 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2863 CV * const cv = cx->blk_sub.cv;
2864 /* skip DB:: code */
2865 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2866 *db_seqp = cx->blk_oldcop->cop_seq;
2871 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2879 /* Compile a require/do, an eval '', or a /(?{...})/.
2880 * In the last case, startop is non-null, and contains the address of
2881 * a pointer that should be set to the just-compiled code.
2882 * outside is the lexically enclosing CV (if any) that invoked us.
2883 * Returns a bool indicating whether the compile was successful; if so,
2884 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2885 * pushes undef (also croaks if startop != NULL).
2889 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2892 OP * const saveop = PL_op;
2894 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2895 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2900 SAVESPTR(PL_compcv);
2901 PL_compcv = (CV*)newSV_type(SVt_PVCV);
2902 CvEVAL_on(PL_compcv);
2903 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2904 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2906 CvOUTSIDE_SEQ(PL_compcv) = seq;
2907 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2909 /* set up a scratch pad */
2911 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2912 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2916 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2918 /* make sure we compile in the right package */
2920 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2921 SAVESPTR(PL_curstash);
2922 PL_curstash = CopSTASH(PL_curcop);
2924 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2925 SAVESPTR(PL_beginav);
2926 PL_beginav = newAV();
2927 SAVEFREESV(PL_beginav);
2928 SAVESPTR(PL_unitcheckav);
2929 PL_unitcheckav = newAV();
2930 SAVEFREESV(PL_unitcheckav);
2933 SAVEBOOL(PL_madskills);
2937 /* try to compile it */
2939 PL_eval_root = NULL;
2940 PL_curcop = &PL_compiling;
2941 CopARYBASE_set(PL_curcop, 0);
2942 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2943 PL_in_eval |= EVAL_KEEPERR;
2945 sv_setpvn(ERRSV,"",0);
2946 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
2947 SV **newsp; /* Used by POPBLOCK. */
2948 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2949 I32 optype = 0; /* Might be reset by POPEVAL. */
2954 op_free(PL_eval_root);
2955 PL_eval_root = NULL;
2957 SP = PL_stack_base + POPMARK; /* pop original mark */
2959 POPBLOCK(cx,PL_curpm);
2965 msg = SvPVx_nolen_const(ERRSV);
2966 if (optype == OP_REQUIRE) {
2967 const SV * const nsv = cx->blk_eval.old_namesv;
2968 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2970 Perl_croak(aTHX_ "%sCompilation failed in require",
2971 *msg ? msg : "Unknown error\n");
2974 POPBLOCK(cx,PL_curpm);
2976 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2977 (*msg ? msg : "Unknown error\n"));
2981 sv_setpvs(ERRSV, "Compilation error");
2984 PERL_UNUSED_VAR(newsp);
2985 PUSHs(&PL_sv_undef);
2989 CopLINE_set(&PL_compiling, 0);
2991 *startop = PL_eval_root;
2993 SAVEFREEOP(PL_eval_root);
2995 /* Set the context for this new optree.
2996 * If the last op is an OP_REQUIRE, force scalar context.
2997 * Otherwise, propagate the context from the eval(). */
2998 if (PL_eval_root->op_type == OP_LEAVEEVAL
2999 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3000 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3002 scalar(PL_eval_root);
3003 else if (gimme & G_VOID)
3004 scalarvoid(PL_eval_root);
3005 else if (gimme & G_ARRAY)
3008 scalar(PL_eval_root);
3010 DEBUG_x(dump_eval());
3012 /* Register with debugger: */
3013 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3014 CV * const cv = get_cv("DB::postponed", FALSE);
3018 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3020 call_sv((SV*)cv, G_DISCARD);
3025 call_list(PL_scopestack_ix, PL_unitcheckav);
3027 /* compiled okay, so do it */
3029 CvDEPTH(PL_compcv) = 1;
3030 SP = PL_stack_base + POPMARK; /* pop original mark */
3031 PL_op = saveop; /* The caller may need it. */
3032 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3039 S_check_type_and_open(pTHX_ const char *name)
3042 const int st_rc = PerlLIO_stat(name, &st);
3044 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3048 return PerlIO_open(name, PERL_SCRIPT_MODE);
3051 #ifndef PERL_DISABLE_PMC
3053 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3057 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3058 SV *const pmcsv = newSV(namelen + 2);
3059 char *const pmc = SvPVX(pmcsv);
3062 memcpy(pmc, name, namelen);
3064 pmc[namelen + 1] = '\0';
3066 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3067 fp = check_type_and_open(name);
3070 fp = check_type_and_open(pmc);
3072 SvREFCNT_dec(pmcsv);
3075 fp = check_type_and_open(name);
3080 # define doopen_pm(name, namelen) check_type_and_open(name)
3081 #endif /* !PERL_DISABLE_PMC */
3086 register PERL_CONTEXT *cx;
3093 int vms_unixname = 0;
3095 const char *tryname = NULL;
3097 const I32 gimme = GIMME_V;
3098 int filter_has_file = 0;
3099 PerlIO *tryrsfp = NULL;
3100 SV *filter_cache = NULL;
3101 SV *filter_state = NULL;
3102 SV *filter_sub = NULL;
3108 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3109 sv = new_version(sv);
3110 if (!sv_derived_from(PL_patchlevel, "version"))
3111 upg_version(PL_patchlevel, TRUE);
3112 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3113 if ( vcmp(sv,PL_patchlevel) <= 0 )
3114 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3115 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3118 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3121 SV * const req = SvRV(sv);
3122 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3124 /* get the left hand term */
3125 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3127 first = SvIV(*av_fetch(lav,0,0));
3128 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3129 || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3130 || av_len(lav) > 1 /* FP with > 3 digits */
3131 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3133 DIE(aTHX_ "Perl %"SVf" required--this is only "
3134 "%"SVf", stopped", SVfARG(vnormal(req)),
3135 SVfARG(vnormal(PL_patchlevel)));
3137 else { /* probably 'use 5.10' or 'use 5.8' */
3138 SV * hintsv = newSV(0);
3142 second = SvIV(*av_fetch(lav,1,0));
3144 second /= second >= 600 ? 100 : 10;
3145 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3146 (int)first, (int)second,0);
3147 upg_version(hintsv, TRUE);
3149 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3150 "--this is only %"SVf", stopped",
3151 SVfARG(vnormal(req)),
3152 SVfARG(vnormal(hintsv)),
3153 SVfARG(vnormal(PL_patchlevel)));
3158 /* We do this only with use, not require. */
3160 /* If we request a version >= 5.9.5, load feature.pm with the
3161 * feature bundle that corresponds to the required version. */
3162 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3163 SV *const importsv = vnormal(sv);
3164 *SvPVX_mutable(importsv) = ':';
3166 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3172 name = SvPV_const(sv, len);
3173 if (!(name && len > 0 && *name))
3174 DIE(aTHX_ "Null filename used");
3175 TAINT_PROPER("require");
3179 /* The key in the %ENV hash is in the syntax of file passed as the argument
3180 * usually this is in UNIX format, but sometimes in VMS format, which
3181 * can result in a module being pulled in more than once.
3182 * To prevent this, the key must be stored in UNIX format if the VMS
3183 * name can be translated to UNIX.
3185 if ((unixname = tounixspec(name, NULL)) != NULL) {
3186 unixlen = strlen(unixname);
3192 /* if not VMS or VMS name can not be translated to UNIX, pass it
3195 unixname = (char *) name;
3198 if (PL_op->op_type == OP_REQUIRE) {
3199 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3200 unixname, unixlen, 0);
3202 if (*svp != &PL_sv_undef)
3205 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3206 "Compilation failed in require", unixname);
3210 /* prepare to compile file */
3212 if (path_is_absolute(name)) {
3214 tryrsfp = doopen_pm(name, len);
3216 #ifdef MACOS_TRADITIONAL
3220 MacPerl_CanonDir(name, newname, 1);
3221 if (path_is_absolute(newname)) {
3223 tryrsfp = doopen_pm(newname, strlen(newname));
3228 AV * const ar = GvAVn(PL_incgv);
3234 namesv = newSV_type(SVt_PV);
3235 for (i = 0; i <= AvFILL(ar); i++) {
3236 SV * const dirsv = *av_fetch(ar, i, TRUE);
3238 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3245 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3246 && !sv_isobject(loader))
3248 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3251 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3252 PTR2UV(SvRV(dirsv)), name);
3253 tryname = SvPVX_const(namesv);
3264 if (sv_isobject(loader))
3265 count = call_method("INC", G_ARRAY);
3267 count = call_sv(loader, G_ARRAY);
3270 /* Adjust file name if the hook has set an %INC entry */
3271 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3273 tryname = SvPVX_const(*svp);
3282 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3283 && !isGV_with_GP(SvRV(arg))) {
3284 filter_cache = SvRV(arg);
3285 SvREFCNT_inc_simple_void_NN(filter_cache);
3292 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3296 if (SvTYPE(arg) == SVt_PVGV) {
3297 IO * const io = GvIO((GV *)arg);
3302 tryrsfp = IoIFP(io);
3303 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3304 PerlIO_close(IoOFP(io));
3315 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3317 SvREFCNT_inc_simple_void_NN(filter_sub);
3320 filter_state = SP[i];
3321 SvREFCNT_inc_simple_void(filter_state);
3325 if (!tryrsfp && (filter_cache || filter_sub)) {
3326 tryrsfp = PerlIO_open(BIT_BUCKET,
3341 filter_has_file = 0;
3343 SvREFCNT_dec(filter_cache);
3344 filter_cache = NULL;
3347 SvREFCNT_dec(filter_state);
3348 filter_state = NULL;
3351 SvREFCNT_dec(filter_sub);
3356 if (!path_is_absolute(name)
3357 #ifdef MACOS_TRADITIONAL
3358 /* We consider paths of the form :a:b ambiguous and interpret them first
3359 as global then as local
3361 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3368 dir = SvPV_const(dirsv, dirlen);
3374 #ifdef MACOS_TRADITIONAL
3378 MacPerl_CanonDir(name, buf2, 1);
3379 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3383 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3385 sv_setpv(namesv, unixdir);
3386 sv_catpv(namesv, unixname);
3388 # ifdef __SYMBIAN32__
3389 if (PL_origfilename[0] &&
3390 PL_origfilename[1] == ':' &&
3391 !(dir[0] && dir[1] == ':'))
3392 Perl_sv_setpvf(aTHX_ namesv,
3397 Perl_sv_setpvf(aTHX_ namesv,
3401 /* The equivalent of
3402 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3403 but without the need to parse the format string, or
3404 call strlen on either pointer, and with the correct
3405 allocation up front. */
3407 char *tmp = SvGROW(namesv, dirlen + len + 2);
3409 memcpy(tmp, dir, dirlen);
3412 /* name came from an SV, so it will have a '\0' at the
3413 end that we can copy as part of this memcpy(). */
3414 memcpy(tmp, name, len + 1);
3416 SvCUR_set(namesv, dirlen + len + 1);
3418 /* Don't even actually have to turn SvPOK_on() as we
3419 access it directly with SvPVX() below. */
3424 TAINT_PROPER("require");
3425 tryname = SvPVX_const(namesv);
3426 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3428 if (tryname[0] == '.' && tryname[1] == '/')
3432 else if (errno == EMFILE)
3433 /* no point in trying other paths if out of handles */
3440 SAVECOPFILE_FREE(&PL_compiling);
3441 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3442 SvREFCNT_dec(namesv);
3444 if (PL_op->op_type == OP_REQUIRE) {
3445 const char *msgstr = name;
3446 if(errno == EMFILE) {
3448 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3450 msgstr = SvPV_nolen_const(msg);
3452 if (namesv) { /* did we lookup @INC? */
3453 AV * const ar = GvAVn(PL_incgv);
3455 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3456 "%s in @INC%s%s (@INC contains:",
3458 (instr(msgstr, ".h ")
3459 ? " (change .h to .ph maybe?)" : ""),
3460 (instr(msgstr, ".ph ")
3461 ? " (did you run h2ph?)" : "")
3464 for (i = 0; i <= AvFILL(ar); i++) {
3465 sv_catpvs(msg, " ");
3466 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3468 sv_catpvs(msg, ")");
3469 msgstr = SvPV_nolen_const(msg);
3472 DIE(aTHX_ "Can't locate %s", msgstr);
3478 SETERRNO(0, SS_NORMAL);
3480 /* Assume success here to prevent recursive requirement. */
3481 /* name is never assigned to again, so len is still strlen(name) */
3482 /* Check whether a hook in @INC has already filled %INC */
3484 (void)hv_store(GvHVn(PL_incgv),
3485 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3487 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3489 (void)hv_store(GvHVn(PL_incgv),
3490 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3495 lex_start(NULL, tryrsfp, TRUE);
3499 SAVECOMPILEWARNINGS();
3500 if (PL_dowarn & G_WARN_ALL_ON)
3501 PL_compiling.cop_warnings = pWARN_ALL ;
3502 else if (PL_dowarn & G_WARN_ALL_OFF)
3503 PL_compiling.cop_warnings = pWARN_NONE ;
3505 PL_compiling.cop_warnings = pWARN_STD ;
3507 if (filter_sub || filter_cache) {
3508 SV * const datasv = filter_add(S_run_user_filter, NULL);
3509 IoLINES(datasv) = filter_has_file;
3510 IoTOP_GV(datasv) = (GV *)filter_state;
3511 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3512 IoFMT_GV(datasv) = (GV *)filter_cache;
3515 /* switch to eval mode */
3516 PUSHBLOCK(cx, CXt_EVAL, SP);
3517 PUSHEVAL(cx, name, NULL);
3518 cx->blk_eval.retop = PL_op->op_next;
3520 SAVECOPLINE(&PL_compiling);
3521 CopLINE_set(&PL_compiling, 0);
3525 /* Store and reset encoding. */
3526 encoding = PL_encoding;
3529 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3530 op = DOCATCH(PL_eval_start);
3532 op = PL_op->op_next;
3534 /* Restore encoding. */
3535 PL_encoding = encoding;
3543 register PERL_CONTEXT *cx;
3545 const I32 gimme = GIMME_V;
3546 const I32 was = PL_sub_generation;
3547 char tbuf[TYPE_DIGITS(long) + 12];
3548 char *tmpbuf = tbuf;
3554 HV *saved_hh = NULL;
3555 const char * const fakestr = "_<(eval )";
3556 const int fakelen = 9 + 1;
3558 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3559 saved_hh = (HV*) SvREFCNT_inc(POPs);
3563 TAINT_IF(SvTAINTED(sv));
3564 TAINT_PROPER("eval");
3567 lex_start(sv, NULL, FALSE);
3570 /* switch to eval mode */
3572 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3573 SV * const temp_sv = sv_newmortal();
3574 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3575 (unsigned long)++PL_evalseq,
3576 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3577 tmpbuf = SvPVX(temp_sv);
3578 len = SvCUR(temp_sv);
3581 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3582 SAVECOPFILE_FREE(&PL_compiling);
3583 CopFILE_set(&PL_compiling, tmpbuf+2);
3584 SAVECOPLINE(&PL_compiling);
3585 CopLINE_set(&PL_compiling, 1);
3586 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3587 deleting the eval's FILEGV from the stash before gv_check() runs
3588 (i.e. before run-time proper). To work around the coredump that
3589 ensues, we always turn GvMULTI_on for any globals that were
3590 introduced within evals. See force_ident(). GSAR 96-10-12 */
3591 safestr = savepvn(tmpbuf, len);
3592 SAVEDELETE(PL_defstash, safestr, len);
3594 PL_hints = PL_op->op_targ;
3596 GvHV(PL_hintgv) = saved_hh;
3597 SAVECOMPILEWARNINGS();
3598 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3599 if (PL_compiling.cop_hints_hash) {
3600 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3602 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3603 if (PL_compiling.cop_hints_hash) {
3605 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3606 HINTS_REFCNT_UNLOCK;
3608 /* special case: an eval '' executed within the DB package gets lexically
3609 * placed in the first non-DB CV rather than the current CV - this
3610 * allows the debugger to execute code, find lexicals etc, in the
3611 * scope of the code being debugged. Passing &seq gets find_runcv
3612 * to do the dirty work for us */
3613 runcv = find_runcv(&seq);
3615 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3616 PUSHEVAL(cx, 0, NULL);
3617 cx->blk_eval.retop = PL_op->op_next;
3619 /* prepare to compile string */
3621 if (PERLDB_LINE && PL_curstash != PL_debstash)
3622 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3624 ok = doeval(gimme, NULL, runcv, seq);
3625 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3627 /* Copy in anything fake and short. */
3628 my_strlcpy(safestr, fakestr, fakelen);
3630 return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3640 register PERL_CONTEXT *cx;
3642 const U8 save_flags = PL_op -> op_flags;
3647 retop = cx->blk_eval.retop;
3650 if (gimme == G_VOID)
3652 else if (gimme == G_SCALAR) {
3655 if (SvFLAGS(TOPs) & SVs_TEMP)
3658 *MARK = sv_mortalcopy(TOPs);
3662 *MARK = &PL_sv_undef;
3667 /* in case LEAVE wipes old return values */
3668 for (mark = newsp + 1; mark <= SP; mark++) {
3669 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3670 *mark = sv_mortalcopy(*mark);
3671 TAINT_NOT; /* Each item is independent */
3675 PL_curpm = newpm; /* Don't pop $1 et al till now */
3678 assert(CvDEPTH(PL_compcv) == 1);
3680 CvDEPTH(PL_compcv) = 0;
3683 if (optype == OP_REQUIRE &&
3684 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3686 /* Unassume the success we assumed earlier. */
3687 SV * const nsv = cx->blk_eval.old_namesv;
3688 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3689 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3690 /* die_where() did LEAVE, or we won't be here */
3694 if (!(save_flags & OPf_SPECIAL))
3695 sv_setpvn(ERRSV,"",0);
3701 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3702 close to the related Perl_create_eval_scope. */
3704 Perl_delete_eval_scope(pTHX)
3709 register PERL_CONTEXT *cx;
3716 PERL_UNUSED_VAR(newsp);
3717 PERL_UNUSED_VAR(gimme);
3718 PERL_UNUSED_VAR(optype);
3721 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3722 also needed by Perl_fold_constants. */
3724 Perl_create_eval_scope(pTHX_ U32 flags)
3727 const I32 gimme = GIMME_V;
3732 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3735 PL_in_eval = EVAL_INEVAL;
3736 if (flags & G_KEEPERR)
3737 PL_in_eval |= EVAL_KEEPERR;
3739 sv_setpvn(ERRSV,"",0);
3740 if (flags & G_FAKINGEVAL) {
3741 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3749 PERL_CONTEXT * const cx = create_eval_scope(0);
3750 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3751 return DOCATCH(PL_op->op_next);
3760 register PERL_CONTEXT *cx;
3765 PERL_UNUSED_VAR(optype);
3768 if (gimme == G_VOID)
3770 else if (gimme == G_SCALAR) {
3774 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3777 *MARK = sv_mortalcopy(TOPs);
3781 *MARK = &PL_sv_undef;
3786 /* in case LEAVE wipes old return values */
3788 for (mark = newsp + 1; mark <= SP; mark++) {
3789 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3790 *mark = sv_mortalcopy(*mark);
3791 TAINT_NOT; /* Each item is independent */
3795 PL_curpm = newpm; /* Don't pop $1 et al till now */
3798 sv_setpvn(ERRSV,"",0);
3805 register PERL_CONTEXT *cx;
3806 const I32 gimme = GIMME_V;
3811 if (PL_op->op_targ == 0) {
3812 SV ** const defsv_p = &GvSV(PL_defgv);
3813 *defsv_p = newSVsv(POPs);
3814 SAVECLEARSV(*defsv_p);
3817 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3819 PUSHBLOCK(cx, CXt_GIVEN, SP);
3828 register PERL_CONTEXT *cx;
3832 PERL_UNUSED_CONTEXT;
3835 assert(CxTYPE(cx) == CXt_GIVEN);
3840 PL_curpm = newpm; /* pop $1 et al */
3847 /* Helper routines used by pp_smartmatch */
3849 S_make_matcher(pTHX_ REGEXP *re)
3852 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3853 PM_SETRE(matcher, ReREFCNT_inc(re));
3855 SAVEFREEOP((OP *) matcher);
3862 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3867 PL_op = (OP *) matcher;
3872 return (SvTRUEx(POPs));
3876 S_destroy_matcher(pTHX_ PMOP *matcher)
3879 PERL_UNUSED_ARG(matcher);
3884 /* Do a smart match */
3887 return do_smartmatch(NULL, NULL);
3890 /* This version of do_smartmatch() implements the
3891 * table of smart matches that is found in perlsyn.
3894 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3899 SV *e = TOPs; /* e is for 'expression' */
3900 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3901 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3902 REGEXP *this_regex, *other_regex;
3904 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3906 # define SM_REF(type) ( \
3907 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3908 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3910 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3911 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
3912 && NOT_EMPTY_PROTO(This) && (Other = e)) \
3913 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
3914 && NOT_EMPTY_PROTO(This) && (Other = d)))
3916 # define SM_REGEX ( \
3917 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \
3918 && (this_regex = (REGEXP*) This) \
3921 (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \
3922 && (this_regex = (REGEXP*) This) \
3926 # define SM_OTHER_REF(type) \
3927 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3929 # define SM_OTHER_REGEX (SvROK(Other) \
3930 && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \
3931 && (other_regex = (REGEXP*) SvRV(Other)))
3934 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3935 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3937 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3938 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3940 tryAMAGICbinSET(smart, 0);
3942 SP -= 2; /* Pop the values */
3944 /* Take care only to invoke mg_get() once for each argument.
3945 * Currently we do this by copying the SV if it's magical. */
3948 d = sv_mortalcopy(d);
3955 e = sv_mortalcopy(e);
3960 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3962 if (This == SvRV(Other))
3973 c = call_sv(This, G_SCALAR);
3977 else if (SvTEMP(TOPs))
3978 SvREFCNT_inc_void(TOPs);
3983 else if (SM_REF(PVHV)) {
3984 if (SM_OTHER_REF(PVHV)) {
3985 /* Check that the key-sets are identical */
3987 HV *other_hv = (HV *) SvRV(Other);
3989 bool other_tied = FALSE;
3990 U32 this_key_count = 0,
3991 other_key_count = 0;
3993 /* Tied hashes don't know how many keys they have. */
3994 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
3997 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3998 HV * const temp = other_hv;
3999 other_hv = (HV *) This;
4003 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
4006 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
4009 /* The hashes have the same number of keys, so it suffices
4010 to check that one is a subset of the other. */
4011 (void) hv_iterinit((HV *) This);
4012 while ( (he = hv_iternext((HV *) This)) ) {
4014 char * const key = hv_iterkey(he, &key_len);
4018 if(!hv_exists(other_hv, key, key_len)) {
4019 (void) hv_iterinit((HV *) This); /* reset iterator */
4025 (void) hv_iterinit(other_hv);
4026 while ( hv_iternext(other_hv) )
4030 other_key_count = HvUSEDKEYS(other_hv);
4032 if (this_key_count != other_key_count)
4037 else if (SM_OTHER_REF(PVAV)) {
4038 AV * const other_av = (AV *) SvRV(Other);
4039 const I32 other_len = av_len(other_av) + 1;
4042 for (i = 0; i < other_len; ++i) {
4043 SV ** const svp = av_fetch(other_av, i, FALSE);
4047 if (svp) { /* ??? When can this not happen? */
4048 key = SvPV(*svp, key_len);
4049 if (hv_exists((HV *) This, key, key_len))
4055 else if (SM_OTHER_REGEX) {
4056 PMOP * const matcher = make_matcher(other_regex);
4059 (void) hv_iterinit((HV *) This);
4060 while ( (he = hv_iternext((HV *) This)) ) {
4061 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4062 (void) hv_iterinit((HV *) This);
4063 destroy_matcher(matcher);
4067 destroy_matcher(matcher);
4071 if (hv_exists_ent((HV *) This, Other, 0))
4077 else if (SM_REF(PVAV)) {
4078 if (SM_OTHER_REF(PVAV)) {
4079 AV *other_av = (AV *) SvRV(Other);
4080 if (av_len((AV *) This) != av_len(other_av))
4084 const I32 other_len = av_len(other_av);
4086 if (NULL == seen_this) {
4087 seen_this = newHV();
4088 (void) sv_2mortal((SV *) seen_this);
4090 if (NULL == seen_other) {
4091 seen_this = newHV();
4092 (void) sv_2mortal((SV *) seen_other);
4094 for(i = 0; i <= other_len; ++i) {
4095 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4096 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4098 if (!this_elem || !other_elem) {
4099 if (this_elem || other_elem)
4102 else if (SM_SEEN_THIS(*this_elem)
4103 || SM_SEEN_OTHER(*other_elem))
4105 if (*this_elem != *other_elem)
4109 (void)hv_store_ent(seen_this,
4110 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4112 (void)hv_store_ent(seen_other,
4113 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4119 (void) do_smartmatch(seen_this, seen_other);
4129 else if (SM_OTHER_REGEX) {
4130 PMOP * const matcher = make_matcher(other_regex);
4131 const I32 this_len = av_len((AV *) This);
4134 for(i = 0; i <= this_len; ++i) {
4135 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4136 if (svp && matcher_matches_sv(matcher, *svp)) {
4137 destroy_matcher(matcher);
4141 destroy_matcher(matcher);
4144 else if (SvIOK(Other) || SvNOK(Other)) {
4147 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4148 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4155 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4165 else if (SvPOK(Other)) {
4166 const I32 this_len = av_len((AV *) This);
4169 for(i = 0; i <= this_len; ++i) {
4170 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4185 else if (!SvOK(d) || !SvOK(e)) {
4186 if (!SvOK(d) && !SvOK(e))
4191 else if (SM_REGEX) {
4192 PMOP * const matcher = make_matcher(this_regex);
4195 PUSHs(matcher_matches_sv(matcher, Other)
4198 destroy_matcher(matcher);
4201 else if (SM_REF(PVCV)) {
4203 /* This must be a null-prototyped sub, because we
4204 already checked for the other kind. */
4210 c = call_sv(This, G_SCALAR);
4213 PUSHs(&PL_sv_undef);
4214 else if (SvTEMP(TOPs))
4215 SvREFCNT_inc_void(TOPs);
4217 if (SM_OTHER_REF(PVCV)) {
4218 /* This one has to be null-proto'd too.
4219 Call both of 'em, and compare the results */
4221 c = call_sv(SvRV(Other), G_SCALAR);
4224 PUSHs(&PL_sv_undef);
4225 else if (SvTEMP(TOPs))
4226 SvREFCNT_inc_void(TOPs);
4237 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4238 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4240 if (SvPOK(Other) && !looks_like_number(Other)) {
4241 /* String comparison */
4246 /* Otherwise, numeric comparison */
4249 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4260 /* As a last resort, use string comparison */
4269 register PERL_CONTEXT *cx;
4270 const I32 gimme = GIMME_V;
4272 /* This is essentially an optimization: if the match
4273 fails, we don't want to push a context and then
4274 pop it again right away, so we skip straight
4275 to the op that follows the leavewhen.
4277 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4278 return cLOGOP->op_other->op_next;
4283 PUSHBLOCK(cx, CXt_WHEN, SP);
4292 register PERL_CONTEXT *cx;
4298 assert(CxTYPE(cx) == CXt_WHEN);
4303 PL_curpm = newpm; /* pop $1 et al */
4313 register PERL_CONTEXT *cx;
4316 cxix = dopoptowhen(cxstack_ix);
4318 DIE(aTHX_ "Can't \"continue\" outside a when block");
4319 if (cxix < cxstack_ix)
4322 /* clear off anything above the scope we're re-entering */
4323 inner = PL_scopestack_ix;
4325 if (PL_scopestack_ix < inner)
4326 leave_scope(PL_scopestack[PL_scopestack_ix]);
4327 PL_curcop = cx->blk_oldcop;
4328 return cx->blk_givwhen.leave_op;
4335 register PERL_CONTEXT *cx;
4338 cxix = dopoptogiven(cxstack_ix);
4340 if (PL_op->op_flags & OPf_SPECIAL)
4341 DIE(aTHX_ "Can't use when() outside a topicalizer");
4343 DIE(aTHX_ "Can't \"break\" outside a given block");
4345 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4346 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4348 if (cxix < cxstack_ix)
4351 /* clear off anything above the scope we're re-entering */
4352 inner = PL_scopestack_ix;
4354 if (PL_scopestack_ix < inner)
4355 leave_scope(PL_scopestack[PL_scopestack_ix]);
4356 PL_curcop = cx->blk_oldcop;
4359 return CX_LOOP_NEXTOP_GET(cx);
4361 return cx->blk_givwhen.leave_op;
4365 S_doparseform(pTHX_ SV *sv)
4368 register char *s = SvPV_force(sv, len);
4369 register char * const send = s + len;
4370 register char *base = NULL;
4371 register I32 skipspaces = 0;
4372 bool noblank = FALSE;
4373 bool repeat = FALSE;
4374 bool postspace = FALSE;
4380 bool unchopnum = FALSE;
4381 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4384 Perl_croak(aTHX_ "Null picture in formline");
4386 /* estimate the buffer size needed */
4387 for (base = s; s <= send; s++) {
4388 if (*s == '\n' || *s == '@' || *s == '^')
4394 Newx(fops, maxops, U32);
4399 *fpc++ = FF_LINEMARK;
4400 noblank = repeat = FALSE;
4418 case ' ': case '\t':
4425 } /* else FALL THROUGH */
4433 *fpc++ = FF_LITERAL;
4441 *fpc++ = (U16)skipspaces;
4445 *fpc++ = FF_NEWLINE;
4449 arg = fpc - linepc + 1;
4456 *fpc++ = FF_LINEMARK;
4457 noblank = repeat = FALSE;
4466 ischop = s[-1] == '^';
4472 arg = (s - base) - 1;
4474 *fpc++ = FF_LITERAL;
4482 *fpc++ = 2; /* skip the @* or ^* */
4484 *fpc++ = FF_LINESNGL;
4487 *fpc++ = FF_LINEGLOB;
4489 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4490 arg = ischop ? 512 : 0;
4495 const char * const f = ++s;
4498 arg |= 256 + (s - f);
4500 *fpc++ = s - base; /* fieldsize for FETCH */
4501 *fpc++ = FF_DECIMAL;
4503 unchopnum |= ! ischop;
4505 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4506 arg = ischop ? 512 : 0;
4508 s++; /* skip the '0' first */
4512 const char * const f = ++s;
4515 arg |= 256 + (s - f);
4517 *fpc++ = s - base; /* fieldsize for FETCH */
4518 *fpc++ = FF_0DECIMAL;
4520 unchopnum |= ! ischop;
4524 bool ismore = FALSE;
4527 while (*++s == '>') ;
4528 prespace = FF_SPACE;
4530 else if (*s == '|') {
4531 while (*++s == '|') ;
4532 prespace = FF_HALFSPACE;
4537 while (*++s == '<') ;
4540 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4544 *fpc++ = s - base; /* fieldsize for FETCH */
4546 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4549 *fpc++ = (U16)prespace;
4563 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4565 { /* need to jump to the next word */
4567 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4568 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4569 s = SvPVX(sv) + SvCUR(sv) + z;
4571 Copy(fops, s, arg, U32);
4573 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4576 if (unchopnum && repeat)
4577 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4583 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4585 /* Can value be printed in fldsize chars, using %*.*f ? */
4589 int intsize = fldsize - (value < 0 ? 1 : 0);
4596 while (intsize--) pwr *= 10.0;
4597 while (frcsize--) eps /= 10.0;
4600 if (value + eps >= pwr)
4603 if (value - eps <= -pwr)
4610 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4613 SV * const datasv = FILTER_DATA(idx);
4614 const int filter_has_file = IoLINES(datasv);
4615 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4616 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4620 const char *got_p = NULL;
4621 const char *prune_from = NULL;
4622 bool read_from_cache = FALSE;
4625 assert(maxlen >= 0);
4628 /* I was having segfault trouble under Linux 2.2.5 after a
4629 parse error occured. (Had to hack around it with a test
4630 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4631 not sure where the trouble is yet. XXX */
4633 if (IoFMT_GV(datasv)) {
4634 SV *const cache = (SV *)IoFMT_GV(datasv);
4637 const char *cache_p = SvPV(cache, cache_len);
4641 /* Running in block mode and we have some cached data already.
4643 if (cache_len >= umaxlen) {
4644 /* In fact, so much data we don't even need to call
4649 const char *const first_nl =
4650 (const char *)memchr(cache_p, '\n', cache_len);
4652 take = first_nl + 1 - cache_p;
4656 sv_catpvn(buf_sv, cache_p, take);
4657 sv_chop(cache, cache_p + take);
4658 /* Definately not EOF */
4662 sv_catsv(buf_sv, cache);
4664 umaxlen -= cache_len;
4667 read_from_cache = TRUE;
4671 /* Filter API says that the filter appends to the contents of the buffer.
4672 Usually the buffer is "", so the details don't matter. But if it's not,
4673 then clearly what it contains is already filtered by this filter, so we
4674 don't want to pass it in a second time.
4675 I'm going to use a mortal in case the upstream filter croaks. */
4676 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4677 ? sv_newmortal() : buf_sv;
4678 SvUPGRADE(upstream, SVt_PV);
4680 if (filter_has_file) {
4681 status = FILTER_READ(idx+1, upstream, 0);
4684 if (filter_sub && status >= 0) {
4697 PUSHs(filter_state);
4700 count = call_sv(filter_sub, G_SCALAR);
4715 if(SvOK(upstream)) {
4716 got_p = SvPV(upstream, got_len);
4718 if (got_len > umaxlen) {
4719 prune_from = got_p + umaxlen;
4722 const char *const first_nl =
4723 (const char *)memchr(got_p, '\n', got_len);
4724 if (first_nl && first_nl + 1 < got_p + got_len) {
4725 /* There's a second line here... */
4726 prune_from = first_nl + 1;
4731 /* Oh. Too long. Stuff some in our cache. */
4732 STRLEN cached_len = got_p + got_len - prune_from;
4733 SV *cache = (SV *)IoFMT_GV(datasv);
4736 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4737 } else if (SvOK(cache)) {
4738 /* Cache should be empty. */
4739 assert(!SvCUR(cache));
4742 sv_setpvn(cache, prune_from, cached_len);
4743 /* If you ask for block mode, you may well split UTF-8 characters.
4744 "If it breaks, you get to keep both parts"
4745 (Your code is broken if you don't put them back together again
4746 before something notices.) */
4747 if (SvUTF8(upstream)) {
4750 SvCUR_set(upstream, got_len - cached_len);
4751 /* Can't yet be EOF */
4756 /* If they are at EOF but buf_sv has something in it, then they may never
4757 have touched the SV upstream, so it may be undefined. If we naively
4758 concatenate it then we get a warning about use of uninitialised value.
4760 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4761 sv_catsv(buf_sv, upstream);
4765 IoLINES(datasv) = 0;
4766 SvREFCNT_dec(IoFMT_GV(datasv));
4768 SvREFCNT_dec(filter_state);
4769 IoTOP_GV(datasv) = NULL;
4772 SvREFCNT_dec(filter_sub);
4773 IoBOTTOM_GV(datasv) = NULL;
4775 filter_del(S_run_user_filter);
4777 if (status == 0 && read_from_cache) {
4778 /* If we read some data from the cache (and by getting here it implies
4779 that we emptied the cache) then we aren't yet at EOF, and mustn't
4780 report that to our caller. */
4786 /* perhaps someone can come up with a better name for
4787 this? it is not really "absolute", per se ... */
4789 S_path_is_absolute(const char *name)
4791 if (PERL_FILE_IS_ABSOLUTE(name)
4792 #ifdef MACOS_TRADITIONAL
4795 || (*name == '.' && (name[1] == '/' ||
4796 (name[1] == '.' && name[2] == '/')))
4808 * c-indentation-style: bsd
4810 * indent-tabs-mode: t
4813 * ex: set ts=8 sts=4 sw=4 noet: