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)
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 PUSHs(boolSV(CxHASARGS(cx)));
1660 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1661 PUSHs(boolSV(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 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1673 if (CxTYPE(cx) == CXt_EVAL) {
1675 if (CxOLD_OP_TYPE(cx) == 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 = CxOLD_IN_EVAL(cx);
2441 PL_eval_root = cx->blk_eval.old_eval_root;
2442 cx->cx_type = CXt_SUB;
2444 cx->blk_sub.cv = cv;
2445 cx->blk_sub.olddepth = CvDEPTH(cv);
2448 if (CvDEPTH(cv) < 2)
2449 SvREFCNT_inc_simple_void_NN(cv);
2451 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2452 sub_crush_depth(cv);
2453 pad_push(padlist, CvDEPTH(cv));
2456 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2459 AV* const av = (AV*)PAD_SVl(0);
2461 cx->blk_sub.savearray = GvAV(PL_defgv);
2462 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2463 CX_CURPAD_SAVE(cx->blk_sub);
2464 cx->blk_sub.argarray = av;
2466 if (items >= AvMAX(av) + 1) {
2467 SV **ary = AvALLOC(av);
2468 if (AvARRAY(av) != ary) {
2469 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2472 if (items >= AvMAX(av) + 1) {
2473 AvMAX(av) = items - 1;
2474 Renew(ary,items+1,SV*);
2480 Copy(mark,AvARRAY(av),items,SV*);
2481 AvFILLp(av) = items - 1;
2482 assert(!AvREAL(av));
2484 /* transfer 'ownership' of refcnts to new @_ */
2494 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2495 Perl_get_db_sub(aTHX_ NULL, cv);
2497 CV * const gotocv = get_cv("DB::goto", FALSE);
2499 PUSHMARK( PL_stack_sp );
2500 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2505 RETURNOP(CvSTART(cv));
2509 label = SvPV_nolen_const(sv);
2510 if (!(do_dump || *label))
2511 DIE(aTHX_ must_have_label);
2514 else if (PL_op->op_flags & OPf_SPECIAL) {
2516 DIE(aTHX_ must_have_label);
2519 label = cPVOP->op_pv;
2521 if (label && *label) {
2522 OP *gotoprobe = NULL;
2523 bool leaving_eval = FALSE;
2524 bool in_block = FALSE;
2525 PERL_CONTEXT *last_eval_cx = NULL;
2529 PL_lastgotoprobe = NULL;
2531 for (ix = cxstack_ix; ix >= 0; ix--) {
2533 switch (CxTYPE(cx)) {
2535 leaving_eval = TRUE;
2536 if (!CxTRYBLOCK(cx)) {
2537 gotoprobe = (last_eval_cx ?
2538 last_eval_cx->blk_eval.old_eval_root :
2543 /* else fall through */
2545 gotoprobe = cx->blk_oldcop->op_sibling;
2551 gotoprobe = cx->blk_oldcop->op_sibling;
2554 gotoprobe = PL_main_root;
2557 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2558 gotoprobe = CvROOT(cx->blk_sub.cv);
2564 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2567 DIE(aTHX_ "panic: goto");
2568 gotoprobe = PL_main_root;
2572 retop = dofindlabel(gotoprobe, label,
2573 enterops, enterops + GOTO_DEPTH);
2577 PL_lastgotoprobe = gotoprobe;
2580 DIE(aTHX_ "Can't find label %s", label);
2582 /* if we're leaving an eval, check before we pop any frames
2583 that we're not going to punt, otherwise the error
2586 if (leaving_eval && *enterops && enterops[1]) {
2588 for (i = 1; enterops[i]; i++)
2589 if (enterops[i]->op_type == OP_ENTERITER)
2590 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2593 /* pop unwanted frames */
2595 if (ix < cxstack_ix) {
2602 oldsave = PL_scopestack[PL_scopestack_ix];
2603 LEAVE_SCOPE(oldsave);
2606 /* push wanted frames */
2608 if (*enterops && enterops[1]) {
2609 OP * const oldop = PL_op;
2610 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2611 for (; enterops[ix]; ix++) {
2612 PL_op = enterops[ix];
2613 /* Eventually we may want to stack the needed arguments
2614 * for each op. For now, we punt on the hard ones. */
2615 if (PL_op->op_type == OP_ENTERITER)
2616 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2617 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2625 if (!retop) retop = PL_main_start;
2627 PL_restartop = retop;
2628 PL_do_undump = TRUE;
2632 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2633 PL_do_undump = FALSE;
2650 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2652 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2655 PL_exit_flags |= PERL_EXIT_EXPECTED;
2657 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2658 if (anum || !(PL_minus_c && PL_madskills))
2663 PUSHs(&PL_sv_undef);
2670 S_save_lines(pTHX_ AV *array, SV *sv)
2672 const char *s = SvPVX_const(sv);
2673 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2676 while (s && s < send) {
2678 SV * const tmpstr = newSV_type(SVt_PVMG);
2680 t = strchr(s, '\n');
2686 sv_setpvn(tmpstr, s, t - s);
2687 av_store(array, line++, tmpstr);
2693 S_docatch(pTHX_ OP *o)
2697 OP * const oldop = PL_op;
2701 assert(CATCH_GET == TRUE);
2708 assert(cxstack_ix >= 0);
2709 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2710 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2715 /* die caught by an inner eval - continue inner loop */
2717 /* NB XXX we rely on the old popped CxEVAL still being at the top
2718 * of the stack; the way die_where() currently works, this
2719 * assumption is valid. In theory The cur_top_env value should be
2720 * returned in another global, the way retop (aka PL_restartop)
2722 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2725 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2727 PL_op = PL_restartop;
2744 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2745 /* sv Text to convert to OP tree. */
2746 /* startop op_free() this to undo. */
2747 /* code Short string id of the caller. */
2749 /* FIXME - how much of this code is common with pp_entereval? */
2750 dVAR; dSP; /* Make POPBLOCK work. */
2756 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2757 char *tmpbuf = tbuf;
2760 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2764 lex_start(sv, NULL, FALSE);
2766 /* switch to eval mode */
2768 if (IN_PERL_COMPILETIME) {
2769 SAVECOPSTASH_FREE(&PL_compiling);
2770 CopSTASH_set(&PL_compiling, PL_curstash);
2772 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2773 SV * const sv = sv_newmortal();
2774 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2775 code, (unsigned long)++PL_evalseq,
2776 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2781 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2782 (unsigned long)++PL_evalseq);
2783 SAVECOPFILE_FREE(&PL_compiling);
2784 CopFILE_set(&PL_compiling, tmpbuf+2);
2785 SAVECOPLINE(&PL_compiling);
2786 CopLINE_set(&PL_compiling, 1);
2787 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2788 deleting the eval's FILEGV from the stash before gv_check() runs
2789 (i.e. before run-time proper). To work around the coredump that
2790 ensues, we always turn GvMULTI_on for any globals that were
2791 introduced within evals. See force_ident(). GSAR 96-10-12 */
2792 safestr = savepvn(tmpbuf, len);
2793 SAVEDELETE(PL_defstash, safestr, len);
2795 #ifdef OP_IN_REGISTER
2801 /* we get here either during compilation, or via pp_regcomp at runtime */
2802 runtime = IN_PERL_RUNTIME;
2804 runcv = find_runcv(NULL);
2807 PL_op->op_type = OP_ENTEREVAL;
2808 PL_op->op_flags = 0; /* Avoid uninit warning. */
2809 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2810 PUSHEVAL(cx, 0, NULL);
2813 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2815 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2816 POPBLOCK(cx,PL_curpm);
2819 (*startop)->op_type = OP_NULL;
2820 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2822 /* XXX DAPM do this properly one year */
2823 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2825 if (IN_PERL_COMPILETIME)
2826 CopHINTS_set(&PL_compiling, PL_hints);
2827 #ifdef OP_IN_REGISTER
2830 PERL_UNUSED_VAR(newsp);
2831 PERL_UNUSED_VAR(optype);
2833 return PL_eval_start;
2838 =for apidoc find_runcv
2840 Locate the CV corresponding to the currently executing sub or eval.
2841 If db_seqp is non_null, skip CVs that are in the DB package and populate
2842 *db_seqp with the cop sequence number at the point that the DB:: code was
2843 entered. (allows debuggers to eval in the scope of the breakpoint rather
2844 than in the scope of the debugger itself).
2850 Perl_find_runcv(pTHX_ U32 *db_seqp)
2856 *db_seqp = PL_curcop->cop_seq;
2857 for (si = PL_curstackinfo; si; si = si->si_prev) {
2859 for (ix = si->si_cxix; ix >= 0; ix--) {
2860 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2861 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2862 CV * const cv = cx->blk_sub.cv;
2863 /* skip DB:: code */
2864 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2865 *db_seqp = cx->blk_oldcop->cop_seq;
2870 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2878 /* Compile a require/do, an eval '', or a /(?{...})/.
2879 * In the last case, startop is non-null, and contains the address of
2880 * a pointer that should be set to the just-compiled code.
2881 * outside is the lexically enclosing CV (if any) that invoked us.
2882 * Returns a bool indicating whether the compile was successful; if so,
2883 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2884 * pushes undef (also croaks if startop != NULL).
2888 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2891 OP * const saveop = PL_op;
2893 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2894 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2899 SAVESPTR(PL_compcv);
2900 PL_compcv = (CV*)newSV_type(SVt_PVCV);
2901 CvEVAL_on(PL_compcv);
2902 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2903 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2905 CvOUTSIDE_SEQ(PL_compcv) = seq;
2906 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2908 /* set up a scratch pad */
2910 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2911 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2915 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2917 /* make sure we compile in the right package */
2919 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2920 SAVESPTR(PL_curstash);
2921 PL_curstash = CopSTASH(PL_curcop);
2923 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2924 SAVESPTR(PL_beginav);
2925 PL_beginav = newAV();
2926 SAVEFREESV(PL_beginav);
2927 SAVESPTR(PL_unitcheckav);
2928 PL_unitcheckav = newAV();
2929 SAVEFREESV(PL_unitcheckav);
2932 SAVEBOOL(PL_madskills);
2936 /* try to compile it */
2938 PL_eval_root = NULL;
2939 PL_curcop = &PL_compiling;
2940 CopARYBASE_set(PL_curcop, 0);
2941 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2942 PL_in_eval |= EVAL_KEEPERR;
2944 sv_setpvn(ERRSV,"",0);
2945 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
2946 SV **newsp; /* Used by POPBLOCK. */
2947 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2948 I32 optype = 0; /* Might be reset by POPEVAL. */
2953 op_free(PL_eval_root);
2954 PL_eval_root = NULL;
2956 SP = PL_stack_base + POPMARK; /* pop original mark */
2958 POPBLOCK(cx,PL_curpm);
2964 msg = SvPVx_nolen_const(ERRSV);
2965 if (optype == OP_REQUIRE) {
2966 const SV * const nsv = cx->blk_eval.old_namesv;
2967 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2969 Perl_croak(aTHX_ "%sCompilation failed in require",
2970 *msg ? msg : "Unknown error\n");
2973 POPBLOCK(cx,PL_curpm);
2975 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2976 (*msg ? msg : "Unknown error\n"));
2980 sv_setpvs(ERRSV, "Compilation error");
2983 PERL_UNUSED_VAR(newsp);
2984 PUSHs(&PL_sv_undef);
2988 CopLINE_set(&PL_compiling, 0);
2990 *startop = PL_eval_root;
2992 SAVEFREEOP(PL_eval_root);
2994 /* Set the context for this new optree.
2995 * If the last op is an OP_REQUIRE, force scalar context.
2996 * Otherwise, propagate the context from the eval(). */
2997 if (PL_eval_root->op_type == OP_LEAVEEVAL
2998 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2999 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3001 scalar(PL_eval_root);
3002 else if ((gimme & G_WANT) == G_VOID)
3003 scalarvoid(PL_eval_root);
3004 else if ((gimme & G_WANT) == G_ARRAY)
3007 scalar(PL_eval_root);
3009 DEBUG_x(dump_eval());
3011 /* Register with debugger: */
3012 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3013 CV * const cv = get_cv("DB::postponed", FALSE);
3017 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3019 call_sv((SV*)cv, G_DISCARD);
3024 call_list(PL_scopestack_ix, PL_unitcheckav);
3026 /* compiled okay, so do it */
3028 CvDEPTH(PL_compcv) = 1;
3029 SP = PL_stack_base + POPMARK; /* pop original mark */
3030 PL_op = saveop; /* The caller may need it. */
3031 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3038 S_check_type_and_open(pTHX_ const char *name)
3041 const int st_rc = PerlLIO_stat(name, &st);
3043 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3047 return PerlIO_open(name, PERL_SCRIPT_MODE);
3050 #ifndef PERL_DISABLE_PMC
3052 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3056 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3057 SV *const pmcsv = newSV(namelen + 2);
3058 char *const pmc = SvPVX(pmcsv);
3061 memcpy(pmc, name, namelen);
3063 pmc[namelen + 1] = '\0';
3065 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3066 fp = check_type_and_open(name);
3069 fp = check_type_and_open(pmc);
3071 SvREFCNT_dec(pmcsv);
3074 fp = check_type_and_open(name);
3079 # define doopen_pm(name, namelen) check_type_and_open(name)
3080 #endif /* !PERL_DISABLE_PMC */
3085 register PERL_CONTEXT *cx;
3092 int vms_unixname = 0;
3094 const char *tryname = NULL;
3096 const I32 gimme = GIMME_V;
3097 int filter_has_file = 0;
3098 PerlIO *tryrsfp = NULL;
3099 SV *filter_cache = NULL;
3100 SV *filter_state = NULL;
3101 SV *filter_sub = NULL;
3107 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3108 sv = new_version(sv);
3109 if (!sv_derived_from(PL_patchlevel, "version"))
3110 upg_version(PL_patchlevel, TRUE);
3111 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3112 if ( vcmp(sv,PL_patchlevel) <= 0 )
3113 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3114 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3117 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3120 SV * const req = SvRV(sv);
3121 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3123 /* get the left hand term */
3124 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3126 first = SvIV(*av_fetch(lav,0,0));
3127 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3128 || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3129 || av_len(lav) > 1 /* FP with > 3 digits */
3130 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3132 DIE(aTHX_ "Perl %"SVf" required--this is only "
3133 "%"SVf", stopped", SVfARG(vnormal(req)),
3134 SVfARG(vnormal(PL_patchlevel)));
3136 else { /* probably 'use 5.10' or 'use 5.8' */
3137 SV * hintsv = newSV(0);
3141 second = SvIV(*av_fetch(lav,1,0));
3143 second /= second >= 600 ? 100 : 10;
3144 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3145 (int)first, (int)second,0);
3146 upg_version(hintsv, TRUE);
3148 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3149 "--this is only %"SVf", stopped",
3150 SVfARG(vnormal(req)),
3151 SVfARG(vnormal(hintsv)),
3152 SVfARG(vnormal(PL_patchlevel)));
3157 /* We do this only with use, not require. */
3159 /* If we request a version >= 5.9.5, load feature.pm with the
3160 * feature bundle that corresponds to the required version. */
3161 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3162 SV *const importsv = vnormal(sv);
3163 *SvPVX_mutable(importsv) = ':';
3165 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3171 name = SvPV_const(sv, len);
3172 if (!(name && len > 0 && *name))
3173 DIE(aTHX_ "Null filename used");
3174 TAINT_PROPER("require");
3178 /* The key in the %ENV hash is in the syntax of file passed as the argument
3179 * usually this is in UNIX format, but sometimes in VMS format, which
3180 * can result in a module being pulled in more than once.
3181 * To prevent this, the key must be stored in UNIX format if the VMS
3182 * name can be translated to UNIX.
3184 if ((unixname = tounixspec(name, NULL)) != NULL) {
3185 unixlen = strlen(unixname);
3191 /* if not VMS or VMS name can not be translated to UNIX, pass it
3194 unixname = (char *) name;
3197 if (PL_op->op_type == OP_REQUIRE) {
3198 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3199 unixname, unixlen, 0);
3201 if (*svp != &PL_sv_undef)
3204 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3205 "Compilation failed in require", unixname);
3209 /* prepare to compile file */
3211 if (path_is_absolute(name)) {
3213 tryrsfp = doopen_pm(name, len);
3215 #ifdef MACOS_TRADITIONAL
3219 MacPerl_CanonDir(name, newname, 1);
3220 if (path_is_absolute(newname)) {
3222 tryrsfp = doopen_pm(newname, strlen(newname));
3227 AV * const ar = GvAVn(PL_incgv);
3233 namesv = newSV_type(SVt_PV);
3234 for (i = 0; i <= AvFILL(ar); i++) {
3235 SV * const dirsv = *av_fetch(ar, i, TRUE);
3237 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3244 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3245 && !sv_isobject(loader))
3247 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3250 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3251 PTR2UV(SvRV(dirsv)), name);
3252 tryname = SvPVX_const(namesv);
3263 if (sv_isobject(loader))
3264 count = call_method("INC", G_ARRAY);
3266 count = call_sv(loader, G_ARRAY);
3269 /* Adjust file name if the hook has set an %INC entry */
3270 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3272 tryname = SvPVX_const(*svp);
3281 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3282 && !isGV_with_GP(SvRV(arg))) {
3283 filter_cache = SvRV(arg);
3284 SvREFCNT_inc_simple_void_NN(filter_cache);
3291 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3295 if (SvTYPE(arg) == SVt_PVGV) {
3296 IO * const io = GvIO((GV *)arg);
3301 tryrsfp = IoIFP(io);
3302 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3303 PerlIO_close(IoOFP(io));
3314 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3316 SvREFCNT_inc_simple_void_NN(filter_sub);
3319 filter_state = SP[i];
3320 SvREFCNT_inc_simple_void(filter_state);
3324 if (!tryrsfp && (filter_cache || filter_sub)) {
3325 tryrsfp = PerlIO_open(BIT_BUCKET,
3340 filter_has_file = 0;
3342 SvREFCNT_dec(filter_cache);
3343 filter_cache = NULL;
3346 SvREFCNT_dec(filter_state);
3347 filter_state = NULL;
3350 SvREFCNT_dec(filter_sub);
3355 if (!path_is_absolute(name)
3356 #ifdef MACOS_TRADITIONAL
3357 /* We consider paths of the form :a:b ambiguous and interpret them first
3358 as global then as local
3360 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3367 dir = SvPV_const(dirsv, dirlen);
3373 #ifdef MACOS_TRADITIONAL
3377 MacPerl_CanonDir(name, buf2, 1);
3378 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3382 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3384 sv_setpv(namesv, unixdir);
3385 sv_catpv(namesv, unixname);
3387 # ifdef __SYMBIAN32__
3388 if (PL_origfilename[0] &&
3389 PL_origfilename[1] == ':' &&
3390 !(dir[0] && dir[1] == ':'))
3391 Perl_sv_setpvf(aTHX_ namesv,
3396 Perl_sv_setpvf(aTHX_ namesv,
3400 /* The equivalent of
3401 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3402 but without the need to parse the format string, or
3403 call strlen on either pointer, and with the correct
3404 allocation up front. */
3406 char *tmp = SvGROW(namesv, dirlen + len + 2);
3408 memcpy(tmp, dir, dirlen);
3411 /* name came from an SV, so it will have a '\0' at the
3412 end that we can copy as part of this memcpy(). */
3413 memcpy(tmp, name, len + 1);
3415 SvCUR_set(namesv, dirlen + len + 1);
3417 /* Don't even actually have to turn SvPOK_on() as we
3418 access it directly with SvPVX() below. */
3423 TAINT_PROPER("require");
3424 tryname = SvPVX_const(namesv);
3425 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3427 if (tryname[0] == '.' && tryname[1] == '/')
3431 else if (errno == EMFILE)
3432 /* no point in trying other paths if out of handles */
3439 SAVECOPFILE_FREE(&PL_compiling);
3440 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3441 SvREFCNT_dec(namesv);
3443 if (PL_op->op_type == OP_REQUIRE) {
3444 const char *msgstr = name;
3445 if(errno == EMFILE) {
3447 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3449 msgstr = SvPV_nolen_const(msg);
3451 if (namesv) { /* did we lookup @INC? */
3452 AV * const ar = GvAVn(PL_incgv);
3454 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3455 "%s in @INC%s%s (@INC contains:",
3457 (instr(msgstr, ".h ")
3458 ? " (change .h to .ph maybe?)" : ""),
3459 (instr(msgstr, ".ph ")
3460 ? " (did you run h2ph?)" : "")
3463 for (i = 0; i <= AvFILL(ar); i++) {
3464 sv_catpvs(msg, " ");
3465 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3467 sv_catpvs(msg, ")");
3468 msgstr = SvPV_nolen_const(msg);
3471 DIE(aTHX_ "Can't locate %s", msgstr);
3477 SETERRNO(0, SS_NORMAL);
3479 /* Assume success here to prevent recursive requirement. */
3480 /* name is never assigned to again, so len is still strlen(name) */
3481 /* Check whether a hook in @INC has already filled %INC */
3483 (void)hv_store(GvHVn(PL_incgv),
3484 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3486 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3488 (void)hv_store(GvHVn(PL_incgv),
3489 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3494 lex_start(NULL, tryrsfp, TRUE);
3498 SAVECOMPILEWARNINGS();
3499 if (PL_dowarn & G_WARN_ALL_ON)
3500 PL_compiling.cop_warnings = pWARN_ALL ;
3501 else if (PL_dowarn & G_WARN_ALL_OFF)
3502 PL_compiling.cop_warnings = pWARN_NONE ;
3504 PL_compiling.cop_warnings = pWARN_STD ;
3506 if (filter_sub || filter_cache) {
3507 SV * const datasv = filter_add(S_run_user_filter, NULL);
3508 IoLINES(datasv) = filter_has_file;
3509 IoTOP_GV(datasv) = (GV *)filter_state;
3510 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3511 IoFMT_GV(datasv) = (GV *)filter_cache;
3514 /* switch to eval mode */
3515 PUSHBLOCK(cx, CXt_EVAL, SP);
3516 PUSHEVAL(cx, name, NULL);
3517 cx->blk_eval.retop = PL_op->op_next;
3519 SAVECOPLINE(&PL_compiling);
3520 CopLINE_set(&PL_compiling, 0);
3524 /* Store and reset encoding. */
3525 encoding = PL_encoding;
3528 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3529 op = DOCATCH(PL_eval_start);
3531 op = PL_op->op_next;
3533 /* Restore encoding. */
3534 PL_encoding = encoding;
3542 register PERL_CONTEXT *cx;
3544 const I32 gimme = GIMME_V;
3545 const I32 was = PL_sub_generation;
3546 char tbuf[TYPE_DIGITS(long) + 12];
3547 char *tmpbuf = tbuf;
3553 HV *saved_hh = NULL;
3554 const char * const fakestr = "_<(eval )";
3555 const int fakelen = 9 + 1;
3557 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3558 saved_hh = (HV*) SvREFCNT_inc(POPs);
3562 TAINT_IF(SvTAINTED(sv));
3563 TAINT_PROPER("eval");
3566 lex_start(sv, NULL, FALSE);
3569 /* switch to eval mode */
3571 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3572 SV * const temp_sv = sv_newmortal();
3573 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3574 (unsigned long)++PL_evalseq,
3575 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3576 tmpbuf = SvPVX(temp_sv);
3577 len = SvCUR(temp_sv);
3580 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3581 SAVECOPFILE_FREE(&PL_compiling);
3582 CopFILE_set(&PL_compiling, tmpbuf+2);
3583 SAVECOPLINE(&PL_compiling);
3584 CopLINE_set(&PL_compiling, 1);
3585 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3586 deleting the eval's FILEGV from the stash before gv_check() runs
3587 (i.e. before run-time proper). To work around the coredump that
3588 ensues, we always turn GvMULTI_on for any globals that were
3589 introduced within evals. See force_ident(). GSAR 96-10-12 */
3590 safestr = savepvn(tmpbuf, len);
3591 SAVEDELETE(PL_defstash, safestr, len);
3593 PL_hints = PL_op->op_targ;
3595 GvHV(PL_hintgv) = saved_hh;
3596 SAVECOMPILEWARNINGS();
3597 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3598 if (PL_compiling.cop_hints_hash) {
3599 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3601 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3602 if (PL_compiling.cop_hints_hash) {
3604 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3605 HINTS_REFCNT_UNLOCK;
3607 /* special case: an eval '' executed within the DB package gets lexically
3608 * placed in the first non-DB CV rather than the current CV - this
3609 * allows the debugger to execute code, find lexicals etc, in the
3610 * scope of the code being debugged. Passing &seq gets find_runcv
3611 * to do the dirty work for us */
3612 runcv = find_runcv(&seq);
3614 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3615 PUSHEVAL(cx, 0, NULL);
3616 cx->blk_eval.retop = PL_op->op_next;
3618 /* prepare to compile string */
3620 if (PERLDB_LINE && PL_curstash != PL_debstash)
3621 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3623 ok = doeval(gimme, NULL, runcv, seq);
3624 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3626 /* Copy in anything fake and short. */
3627 my_strlcpy(safestr, fakestr, fakelen);
3629 return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3639 register PERL_CONTEXT *cx;
3641 const U8 save_flags = PL_op -> op_flags;
3646 retop = cx->blk_eval.retop;
3649 if (gimme == G_VOID)
3651 else if (gimme == G_SCALAR) {
3654 if (SvFLAGS(TOPs) & SVs_TEMP)
3657 *MARK = sv_mortalcopy(TOPs);
3661 *MARK = &PL_sv_undef;
3666 /* in case LEAVE wipes old return values */
3667 for (mark = newsp + 1; mark <= SP; mark++) {
3668 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3669 *mark = sv_mortalcopy(*mark);
3670 TAINT_NOT; /* Each item is independent */
3674 PL_curpm = newpm; /* Don't pop $1 et al till now */
3677 assert(CvDEPTH(PL_compcv) == 1);
3679 CvDEPTH(PL_compcv) = 0;
3682 if (optype == OP_REQUIRE &&
3683 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3685 /* Unassume the success we assumed earlier. */
3686 SV * const nsv = cx->blk_eval.old_namesv;
3687 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3688 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3689 /* die_where() did LEAVE, or we won't be here */
3693 if (!(save_flags & OPf_SPECIAL))
3694 sv_setpvn(ERRSV,"",0);
3700 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3701 close to the related Perl_create_eval_scope. */
3703 Perl_delete_eval_scope(pTHX)
3708 register PERL_CONTEXT *cx;
3715 PERL_UNUSED_VAR(newsp);
3716 PERL_UNUSED_VAR(gimme);
3717 PERL_UNUSED_VAR(optype);
3720 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3721 also needed by Perl_fold_constants. */
3723 Perl_create_eval_scope(pTHX_ U32 flags)
3726 const I32 gimme = GIMME_V;
3731 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3734 PL_in_eval = EVAL_INEVAL;
3735 if (flags & G_KEEPERR)
3736 PL_in_eval |= EVAL_KEEPERR;
3738 sv_setpvn(ERRSV,"",0);
3739 if (flags & G_FAKINGEVAL) {
3740 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3748 PERL_CONTEXT * const cx = create_eval_scope(0);
3749 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3750 return DOCATCH(PL_op->op_next);
3759 register PERL_CONTEXT *cx;
3764 PERL_UNUSED_VAR(optype);
3767 if (gimme == G_VOID)
3769 else if (gimme == G_SCALAR) {
3773 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3776 *MARK = sv_mortalcopy(TOPs);
3780 *MARK = &PL_sv_undef;
3785 /* in case LEAVE wipes old return values */
3787 for (mark = newsp + 1; mark <= SP; mark++) {
3788 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3789 *mark = sv_mortalcopy(*mark);
3790 TAINT_NOT; /* Each item is independent */
3794 PL_curpm = newpm; /* Don't pop $1 et al till now */
3797 sv_setpvn(ERRSV,"",0);
3804 register PERL_CONTEXT *cx;
3805 const I32 gimme = GIMME_V;
3810 if (PL_op->op_targ == 0) {
3811 SV ** const defsv_p = &GvSV(PL_defgv);
3812 *defsv_p = newSVsv(POPs);
3813 SAVECLEARSV(*defsv_p);
3816 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3818 PUSHBLOCK(cx, CXt_GIVEN, SP);
3827 register PERL_CONTEXT *cx;
3831 PERL_UNUSED_CONTEXT;
3834 assert(CxTYPE(cx) == CXt_GIVEN);
3839 PL_curpm = newpm; /* pop $1 et al */
3846 /* Helper routines used by pp_smartmatch */
3848 S_make_matcher(pTHX_ REGEXP *re)
3851 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3852 PM_SETRE(matcher, ReREFCNT_inc(re));
3854 SAVEFREEOP((OP *) matcher);
3861 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3866 PL_op = (OP *) matcher;
3871 return (SvTRUEx(POPs));
3875 S_destroy_matcher(pTHX_ PMOP *matcher)
3878 PERL_UNUSED_ARG(matcher);
3883 /* Do a smart match */
3886 return do_smartmatch(NULL, NULL);
3889 /* This version of do_smartmatch() implements the
3890 * table of smart matches that is found in perlsyn.
3893 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3898 SV *e = TOPs; /* e is for 'expression' */
3899 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3900 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3901 REGEXP *this_regex, *other_regex;
3903 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3905 # define SM_REF(type) ( \
3906 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3907 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3909 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3910 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
3911 && NOT_EMPTY_PROTO(This) && (Other = e)) \
3912 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
3913 && NOT_EMPTY_PROTO(This) && (Other = d)))
3915 # define SM_REGEX ( \
3916 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \
3917 && (this_regex = (REGEXP*) This) \
3920 (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \
3921 && (this_regex = (REGEXP*) This) \
3925 # define SM_OTHER_REF(type) \
3926 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3928 # define SM_OTHER_REGEX (SvROK(Other) \
3929 && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \
3930 && (other_regex = (REGEXP*) SvRV(Other)))
3933 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3934 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3936 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3937 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3939 tryAMAGICbinSET(smart, 0);
3941 SP -= 2; /* Pop the values */
3943 /* Take care only to invoke mg_get() once for each argument.
3944 * Currently we do this by copying the SV if it's magical. */
3947 d = sv_mortalcopy(d);
3954 e = sv_mortalcopy(e);
3959 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3961 if (This == SvRV(Other))
3972 c = call_sv(This, G_SCALAR);
3976 else if (SvTEMP(TOPs))
3977 SvREFCNT_inc_void(TOPs);
3982 else if (SM_REF(PVHV)) {
3983 if (SM_OTHER_REF(PVHV)) {
3984 /* Check that the key-sets are identical */
3986 HV *other_hv = (HV *) SvRV(Other);
3988 bool other_tied = FALSE;
3989 U32 this_key_count = 0,
3990 other_key_count = 0;
3992 /* Tied hashes don't know how many keys they have. */
3993 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
3996 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3997 HV * const temp = other_hv;
3998 other_hv = (HV *) This;
4002 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
4005 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
4008 /* The hashes have the same number of keys, so it suffices
4009 to check that one is a subset of the other. */
4010 (void) hv_iterinit((HV *) This);
4011 while ( (he = hv_iternext((HV *) This)) ) {
4013 char * const key = hv_iterkey(he, &key_len);
4017 if(!hv_exists(other_hv, key, key_len)) {
4018 (void) hv_iterinit((HV *) This); /* reset iterator */
4024 (void) hv_iterinit(other_hv);
4025 while ( hv_iternext(other_hv) )
4029 other_key_count = HvUSEDKEYS(other_hv);
4031 if (this_key_count != other_key_count)
4036 else if (SM_OTHER_REF(PVAV)) {
4037 AV * const other_av = (AV *) SvRV(Other);
4038 const I32 other_len = av_len(other_av) + 1;
4041 for (i = 0; i < other_len; ++i) {
4042 SV ** const svp = av_fetch(other_av, i, FALSE);
4046 if (svp) { /* ??? When can this not happen? */
4047 key = SvPV(*svp, key_len);
4048 if (hv_exists((HV *) This, key, key_len))
4054 else if (SM_OTHER_REGEX) {
4055 PMOP * const matcher = make_matcher(other_regex);
4058 (void) hv_iterinit((HV *) This);
4059 while ( (he = hv_iternext((HV *) This)) ) {
4060 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4061 (void) hv_iterinit((HV *) This);
4062 destroy_matcher(matcher);
4066 destroy_matcher(matcher);
4070 if (hv_exists_ent((HV *) This, Other, 0))
4076 else if (SM_REF(PVAV)) {
4077 if (SM_OTHER_REF(PVAV)) {
4078 AV *other_av = (AV *) SvRV(Other);
4079 if (av_len((AV *) This) != av_len(other_av))
4083 const I32 other_len = av_len(other_av);
4085 if (NULL == seen_this) {
4086 seen_this = newHV();
4087 (void) sv_2mortal((SV *) seen_this);
4089 if (NULL == seen_other) {
4090 seen_this = newHV();
4091 (void) sv_2mortal((SV *) seen_other);
4093 for(i = 0; i <= other_len; ++i) {
4094 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4095 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4097 if (!this_elem || !other_elem) {
4098 if (this_elem || other_elem)
4101 else if (SM_SEEN_THIS(*this_elem)
4102 || SM_SEEN_OTHER(*other_elem))
4104 if (*this_elem != *other_elem)
4108 (void)hv_store_ent(seen_this,
4109 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4111 (void)hv_store_ent(seen_other,
4112 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4118 (void) do_smartmatch(seen_this, seen_other);
4128 else if (SM_OTHER_REGEX) {
4129 PMOP * const matcher = make_matcher(other_regex);
4130 const I32 this_len = av_len((AV *) This);
4133 for(i = 0; i <= this_len; ++i) {
4134 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4135 if (svp && matcher_matches_sv(matcher, *svp)) {
4136 destroy_matcher(matcher);
4140 destroy_matcher(matcher);
4143 else if (SvIOK(Other) || SvNOK(Other)) {
4146 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4147 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4154 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4164 else if (SvPOK(Other)) {
4165 const I32 this_len = av_len((AV *) This);
4168 for(i = 0; i <= this_len; ++i) {
4169 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4184 else if (!SvOK(d) || !SvOK(e)) {
4185 if (!SvOK(d) && !SvOK(e))
4190 else if (SM_REGEX) {
4191 PMOP * const matcher = make_matcher(this_regex);
4194 PUSHs(matcher_matches_sv(matcher, Other)
4197 destroy_matcher(matcher);
4200 else if (SM_REF(PVCV)) {
4202 /* This must be a null-prototyped sub, because we
4203 already checked for the other kind. */
4209 c = call_sv(This, G_SCALAR);
4212 PUSHs(&PL_sv_undef);
4213 else if (SvTEMP(TOPs))
4214 SvREFCNT_inc_void(TOPs);
4216 if (SM_OTHER_REF(PVCV)) {
4217 /* This one has to be null-proto'd too.
4218 Call both of 'em, and compare the results */
4220 c = call_sv(SvRV(Other), G_SCALAR);
4223 PUSHs(&PL_sv_undef);
4224 else if (SvTEMP(TOPs))
4225 SvREFCNT_inc_void(TOPs);
4236 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4237 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4239 if (SvPOK(Other) && !looks_like_number(Other)) {
4240 /* String comparison */
4245 /* Otherwise, numeric comparison */
4248 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4259 /* As a last resort, use string comparison */
4268 register PERL_CONTEXT *cx;
4269 const I32 gimme = GIMME_V;
4271 /* This is essentially an optimization: if the match
4272 fails, we don't want to push a context and then
4273 pop it again right away, so we skip straight
4274 to the op that follows the leavewhen.
4276 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4277 return cLOGOP->op_other->op_next;
4282 PUSHBLOCK(cx, CXt_WHEN, SP);
4291 register PERL_CONTEXT *cx;
4297 assert(CxTYPE(cx) == CXt_WHEN);
4302 PL_curpm = newpm; /* pop $1 et al */
4312 register PERL_CONTEXT *cx;
4315 cxix = dopoptowhen(cxstack_ix);
4317 DIE(aTHX_ "Can't \"continue\" outside a when block");
4318 if (cxix < cxstack_ix)
4321 /* clear off anything above the scope we're re-entering */
4322 inner = PL_scopestack_ix;
4324 if (PL_scopestack_ix < inner)
4325 leave_scope(PL_scopestack[PL_scopestack_ix]);
4326 PL_curcop = cx->blk_oldcop;
4327 return cx->blk_givwhen.leave_op;
4334 register PERL_CONTEXT *cx;
4337 cxix = dopoptogiven(cxstack_ix);
4339 if (PL_op->op_flags & OPf_SPECIAL)
4340 DIE(aTHX_ "Can't use when() outside a topicalizer");
4342 DIE(aTHX_ "Can't \"break\" outside a given block");
4344 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4345 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4347 if (cxix < cxstack_ix)
4350 /* clear off anything above the scope we're re-entering */
4351 inner = PL_scopestack_ix;
4353 if (PL_scopestack_ix < inner)
4354 leave_scope(PL_scopestack[PL_scopestack_ix]);
4355 PL_curcop = cx->blk_oldcop;
4358 return CX_LOOP_NEXTOP_GET(cx);
4360 return cx->blk_givwhen.leave_op;
4364 S_doparseform(pTHX_ SV *sv)
4367 register char *s = SvPV_force(sv, len);
4368 register char * const send = s + len;
4369 register char *base = NULL;
4370 register I32 skipspaces = 0;
4371 bool noblank = FALSE;
4372 bool repeat = FALSE;
4373 bool postspace = FALSE;
4379 bool unchopnum = FALSE;
4380 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4383 Perl_croak(aTHX_ "Null picture in formline");
4385 /* estimate the buffer size needed */
4386 for (base = s; s <= send; s++) {
4387 if (*s == '\n' || *s == '@' || *s == '^')
4393 Newx(fops, maxops, U32);
4398 *fpc++ = FF_LINEMARK;
4399 noblank = repeat = FALSE;
4417 case ' ': case '\t':
4424 } /* else FALL THROUGH */
4432 *fpc++ = FF_LITERAL;
4440 *fpc++ = (U16)skipspaces;
4444 *fpc++ = FF_NEWLINE;
4448 arg = fpc - linepc + 1;
4455 *fpc++ = FF_LINEMARK;
4456 noblank = repeat = FALSE;
4465 ischop = s[-1] == '^';
4471 arg = (s - base) - 1;
4473 *fpc++ = FF_LITERAL;
4481 *fpc++ = 2; /* skip the @* or ^* */
4483 *fpc++ = FF_LINESNGL;
4486 *fpc++ = FF_LINEGLOB;
4488 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4489 arg = ischop ? 512 : 0;
4494 const char * const f = ++s;
4497 arg |= 256 + (s - f);
4499 *fpc++ = s - base; /* fieldsize for FETCH */
4500 *fpc++ = FF_DECIMAL;
4502 unchopnum |= ! ischop;
4504 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4505 arg = ischop ? 512 : 0;
4507 s++; /* skip the '0' first */
4511 const char * const f = ++s;
4514 arg |= 256 + (s - f);
4516 *fpc++ = s - base; /* fieldsize for FETCH */
4517 *fpc++ = FF_0DECIMAL;
4519 unchopnum |= ! ischop;
4523 bool ismore = FALSE;
4526 while (*++s == '>') ;
4527 prespace = FF_SPACE;
4529 else if (*s == '|') {
4530 while (*++s == '|') ;
4531 prespace = FF_HALFSPACE;
4536 while (*++s == '<') ;
4539 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4543 *fpc++ = s - base; /* fieldsize for FETCH */
4545 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4548 *fpc++ = (U16)prespace;
4562 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4564 { /* need to jump to the next word */
4566 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4567 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4568 s = SvPVX(sv) + SvCUR(sv) + z;
4570 Copy(fops, s, arg, U32);
4572 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4575 if (unchopnum && repeat)
4576 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4582 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4584 /* Can value be printed in fldsize chars, using %*.*f ? */
4588 int intsize = fldsize - (value < 0 ? 1 : 0);
4595 while (intsize--) pwr *= 10.0;
4596 while (frcsize--) eps /= 10.0;
4599 if (value + eps >= pwr)
4602 if (value - eps <= -pwr)
4609 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4612 SV * const datasv = FILTER_DATA(idx);
4613 const int filter_has_file = IoLINES(datasv);
4614 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4615 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4619 const char *got_p = NULL;
4620 const char *prune_from = NULL;
4621 bool read_from_cache = FALSE;
4624 assert(maxlen >= 0);
4627 /* I was having segfault trouble under Linux 2.2.5 after a
4628 parse error occured. (Had to hack around it with a test
4629 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4630 not sure where the trouble is yet. XXX */
4632 if (IoFMT_GV(datasv)) {
4633 SV *const cache = (SV *)IoFMT_GV(datasv);
4636 const char *cache_p = SvPV(cache, cache_len);
4640 /* Running in block mode and we have some cached data already.
4642 if (cache_len >= umaxlen) {
4643 /* In fact, so much data we don't even need to call
4648 const char *const first_nl =
4649 (const char *)memchr(cache_p, '\n', cache_len);
4651 take = first_nl + 1 - cache_p;
4655 sv_catpvn(buf_sv, cache_p, take);
4656 sv_chop(cache, cache_p + take);
4657 /* Definately not EOF */
4661 sv_catsv(buf_sv, cache);
4663 umaxlen -= cache_len;
4666 read_from_cache = TRUE;
4670 /* Filter API says that the filter appends to the contents of the buffer.
4671 Usually the buffer is "", so the details don't matter. But if it's not,
4672 then clearly what it contains is already filtered by this filter, so we
4673 don't want to pass it in a second time.
4674 I'm going to use a mortal in case the upstream filter croaks. */
4675 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4676 ? sv_newmortal() : buf_sv;
4677 SvUPGRADE(upstream, SVt_PV);
4679 if (filter_has_file) {
4680 status = FILTER_READ(idx+1, upstream, 0);
4683 if (filter_sub && status >= 0) {
4696 PUSHs(filter_state);
4699 count = call_sv(filter_sub, G_SCALAR);
4714 if(SvOK(upstream)) {
4715 got_p = SvPV(upstream, got_len);
4717 if (got_len > umaxlen) {
4718 prune_from = got_p + umaxlen;
4721 const char *const first_nl =
4722 (const char *)memchr(got_p, '\n', got_len);
4723 if (first_nl && first_nl + 1 < got_p + got_len) {
4724 /* There's a second line here... */
4725 prune_from = first_nl + 1;
4730 /* Oh. Too long. Stuff some in our cache. */
4731 STRLEN cached_len = got_p + got_len - prune_from;
4732 SV *cache = (SV *)IoFMT_GV(datasv);
4735 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4736 } else if (SvOK(cache)) {
4737 /* Cache should be empty. */
4738 assert(!SvCUR(cache));
4741 sv_setpvn(cache, prune_from, cached_len);
4742 /* If you ask for block mode, you may well split UTF-8 characters.
4743 "If it breaks, you get to keep both parts"
4744 (Your code is broken if you don't put them back together again
4745 before something notices.) */
4746 if (SvUTF8(upstream)) {
4749 SvCUR_set(upstream, got_len - cached_len);
4750 /* Can't yet be EOF */
4755 /* If they are at EOF but buf_sv has something in it, then they may never
4756 have touched the SV upstream, so it may be undefined. If we naively
4757 concatenate it then we get a warning about use of uninitialised value.
4759 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4760 sv_catsv(buf_sv, upstream);
4764 IoLINES(datasv) = 0;
4765 SvREFCNT_dec(IoFMT_GV(datasv));
4767 SvREFCNT_dec(filter_state);
4768 IoTOP_GV(datasv) = NULL;
4771 SvREFCNT_dec(filter_sub);
4772 IoBOTTOM_GV(datasv) = NULL;
4774 filter_del(S_run_user_filter);
4776 if (status == 0 && read_from_cache) {
4777 /* If we read some data from the cache (and by getting here it implies
4778 that we emptied the cache) then we aren't yet at EOF, and mustn't
4779 report that to our caller. */
4785 /* perhaps someone can come up with a better name for
4786 this? it is not really "absolute", per se ... */
4788 S_path_is_absolute(const char *name)
4790 if (PERL_FILE_IS_ABSOLUTE(name)
4791 #ifdef MACOS_TRADITIONAL
4794 || (*name == '.' && (name[1] == '/' ||
4795 (name[1] == '.' && name[2] == '/')))
4807 * c-indentation-style: bsd
4809 * indent-tabs-mode: t
4812 * ex: set ts=8 sts=4 sw=4 noet: