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 if (PL_op->op_private & OPpITER_REVERSED) {
1918 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1919 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1922 cx->blk_loop.iterix = MARK - PL_stack_base;
1932 register PERL_CONTEXT *cx;
1933 const I32 gimme = GIMME_V;
1939 PUSHBLOCK(cx, CXt_LOOP, SP);
1940 PUSHLOOP(cx, 0, SP);
1948 register PERL_CONTEXT *cx;
1955 assert(CxTYPE(cx) == CXt_LOOP);
1957 newsp = PL_stack_base + cx->blk_loop.resetsp;
1960 if (gimme == G_VOID)
1962 else if (gimme == G_SCALAR) {
1964 *++newsp = sv_mortalcopy(*SP);
1966 *++newsp = &PL_sv_undef;
1970 *++newsp = sv_mortalcopy(*++mark);
1971 TAINT_NOT; /* Each item is independent */
1977 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1978 PL_curpm = newpm; /* ... and pop $1 et al */
1989 register PERL_CONTEXT *cx;
1990 bool popsub2 = FALSE;
1991 bool clear_errsv = FALSE;
1999 const I32 cxix = dopoptosub(cxstack_ix);
2002 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2003 * sort block, which is a CXt_NULL
2006 PL_stack_base[1] = *PL_stack_sp;
2007 PL_stack_sp = PL_stack_base + 1;
2011 DIE(aTHX_ "Can't return outside a subroutine");
2013 if (cxix < cxstack_ix)
2016 if (CxMULTICALL(&cxstack[cxix])) {
2017 gimme = cxstack[cxix].blk_gimme;
2018 if (gimme == G_VOID)
2019 PL_stack_sp = PL_stack_base;
2020 else if (gimme == G_SCALAR) {
2021 PL_stack_base[1] = *PL_stack_sp;
2022 PL_stack_sp = PL_stack_base + 1;
2028 switch (CxTYPE(cx)) {
2031 retop = cx->blk_sub.retop;
2032 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2035 if (!(PL_in_eval & EVAL_KEEPERR))
2038 retop = cx->blk_eval.retop;
2042 if (optype == OP_REQUIRE &&
2043 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2045 /* Unassume the success we assumed earlier. */
2046 SV * const nsv = cx->blk_eval.old_namesv;
2047 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2048 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2053 retop = cx->blk_sub.retop;
2056 DIE(aTHX_ "panic: return");
2060 if (gimme == G_SCALAR) {
2063 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2065 *++newsp = SvREFCNT_inc(*SP);
2070 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2072 *++newsp = sv_mortalcopy(sv);
2077 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2080 *++newsp = sv_mortalcopy(*SP);
2083 *++newsp = &PL_sv_undef;
2085 else if (gimme == G_ARRAY) {
2086 while (++MARK <= SP) {
2087 *++newsp = (popsub2 && SvTEMP(*MARK))
2088 ? *MARK : sv_mortalcopy(*MARK);
2089 TAINT_NOT; /* Each item is independent */
2092 PL_stack_sp = newsp;
2095 /* Stack values are safe: */
2098 POPSUB(cx,sv); /* release CV and @_ ... */
2102 PL_curpm = newpm; /* ... and pop $1 et al */
2106 sv_setpvn(ERRSV,"",0);
2114 register PERL_CONTEXT *cx;
2125 if (PL_op->op_flags & OPf_SPECIAL) {
2126 cxix = dopoptoloop(cxstack_ix);
2128 DIE(aTHX_ "Can't \"last\" outside a loop block");
2131 cxix = dopoptolabel(cPVOP->op_pv);
2133 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2135 if (cxix < cxstack_ix)
2139 cxstack_ix++; /* temporarily protect top context */
2141 switch (CxTYPE(cx)) {
2144 newsp = PL_stack_base + cx->blk_loop.resetsp;
2145 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2149 nextop = cx->blk_sub.retop;
2153 nextop = cx->blk_eval.retop;
2157 nextop = cx->blk_sub.retop;
2160 DIE(aTHX_ "panic: last");
2164 if (gimme == G_SCALAR) {
2166 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2167 ? *SP : sv_mortalcopy(*SP);
2169 *++newsp = &PL_sv_undef;
2171 else if (gimme == G_ARRAY) {
2172 while (++MARK <= SP) {
2173 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2174 ? *MARK : sv_mortalcopy(*MARK);
2175 TAINT_NOT; /* Each item is independent */
2183 /* Stack values are safe: */
2186 POPLOOP(cx); /* release loop vars ... */
2190 POPSUB(cx,sv); /* release CV and @_ ... */
2193 PL_curpm = newpm; /* ... and pop $1 et al */
2196 PERL_UNUSED_VAR(optype);
2197 PERL_UNUSED_VAR(gimme);
2205 register PERL_CONTEXT *cx;
2208 if (PL_op->op_flags & OPf_SPECIAL) {
2209 cxix = dopoptoloop(cxstack_ix);
2211 DIE(aTHX_ "Can't \"next\" outside a loop block");
2214 cxix = dopoptolabel(cPVOP->op_pv);
2216 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2218 if (cxix < cxstack_ix)
2221 /* clear off anything above the scope we're re-entering, but
2222 * save the rest until after a possible continue block */
2223 inner = PL_scopestack_ix;
2225 if (PL_scopestack_ix < inner)
2226 leave_scope(PL_scopestack[PL_scopestack_ix]);
2227 PL_curcop = cx->blk_oldcop;
2228 return CX_LOOP_NEXTOP_GET(cx);
2235 register PERL_CONTEXT *cx;
2239 if (PL_op->op_flags & OPf_SPECIAL) {
2240 cxix = dopoptoloop(cxstack_ix);
2242 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2245 cxix = dopoptolabel(cPVOP->op_pv);
2247 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2249 if (cxix < cxstack_ix)
2252 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2253 if (redo_op->op_type == OP_ENTER) {
2254 /* pop one less context to avoid $x being freed in while (my $x..) */
2256 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2257 redo_op = redo_op->op_next;
2261 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2262 LEAVE_SCOPE(oldsave);
2264 PL_curcop = cx->blk_oldcop;
2269 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2273 static const char too_deep[] = "Target of goto is too deeply nested";
2276 Perl_croak(aTHX_ too_deep);
2277 if (o->op_type == OP_LEAVE ||
2278 o->op_type == OP_SCOPE ||
2279 o->op_type == OP_LEAVELOOP ||
2280 o->op_type == OP_LEAVESUB ||
2281 o->op_type == OP_LEAVETRY)
2283 *ops++ = cUNOPo->op_first;
2285 Perl_croak(aTHX_ too_deep);
2288 if (o->op_flags & OPf_KIDS) {
2290 /* First try all the kids at this level, since that's likeliest. */
2291 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2292 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2293 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2296 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2297 if (kid == PL_lastgotoprobe)
2299 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2302 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2303 ops[-1]->op_type == OP_DBSTATE)
2308 if ((o = dofindlabel(kid, label, ops, oplimit)))
2321 register PERL_CONTEXT *cx;
2322 #define GOTO_DEPTH 64
2323 OP *enterops[GOTO_DEPTH];
2324 const char *label = NULL;
2325 const bool do_dump = (PL_op->op_type == OP_DUMP);
2326 static const char must_have_label[] = "goto must have label";
2328 if (PL_op->op_flags & OPf_STACKED) {
2329 SV * const sv = POPs;
2331 /* This egregious kludge implements goto &subroutine */
2332 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2334 register PERL_CONTEXT *cx;
2335 CV* cv = (CV*)SvRV(sv);
2342 if (!CvROOT(cv) && !CvXSUB(cv)) {
2343 const GV * const gv = CvGV(cv);
2347 /* autoloaded stub? */
2348 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2350 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2351 GvNAMELEN(gv), FALSE);
2352 if (autogv && (cv = GvCV(autogv)))
2354 tmpstr = sv_newmortal();
2355 gv_efullname3(tmpstr, gv, NULL);
2356 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2358 DIE(aTHX_ "Goto undefined subroutine");
2361 /* First do some returnish stuff. */
2362 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2364 cxix = dopoptosub(cxstack_ix);
2366 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2367 if (cxix < cxstack_ix)
2371 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2372 if (CxTYPE(cx) == CXt_EVAL) {
2374 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2376 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2378 else if (CxMULTICALL(cx))
2379 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2380 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2381 /* put @_ back onto stack */
2382 AV* av = cx->blk_sub.argarray;
2384 items = AvFILLp(av) + 1;
2385 EXTEND(SP, items+1); /* @_ could have been extended. */
2386 Copy(AvARRAY(av), SP + 1, items, SV*);
2387 SvREFCNT_dec(GvAV(PL_defgv));
2388 GvAV(PL_defgv) = cx->blk_sub.savearray;
2390 /* abandon @_ if it got reified */
2395 av_extend(av, items-1);
2397 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2400 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2401 AV* const av = GvAV(PL_defgv);
2402 items = AvFILLp(av) + 1;
2403 EXTEND(SP, items+1); /* @_ could have been extended. */
2404 Copy(AvARRAY(av), SP + 1, items, SV*);
2408 if (CxTYPE(cx) == CXt_SUB &&
2409 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2410 SvREFCNT_dec(cx->blk_sub.cv);
2411 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2412 LEAVE_SCOPE(oldsave);
2414 /* Now do some callish stuff. */
2416 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2418 OP* const retop = cx->blk_sub.retop;
2423 for (index=0; index<items; index++)
2424 sv_2mortal(SP[-index]);
2427 /* XS subs don't have a CxSUB, so pop it */
2428 POPBLOCK(cx, PL_curpm);
2429 /* Push a mark for the start of arglist */
2432 (void)(*CvXSUB(cv))(aTHX_ cv);
2437 AV* const padlist = CvPADLIST(cv);
2438 if (CxTYPE(cx) == CXt_EVAL) {
2439 PL_in_eval = CxOLD_IN_EVAL(cx);
2440 PL_eval_root = cx->blk_eval.old_eval_root;
2441 cx->cx_type = CXt_SUB;
2443 cx->blk_sub.cv = cv;
2444 cx->blk_sub.olddepth = CvDEPTH(cv);
2447 if (CvDEPTH(cv) < 2)
2448 SvREFCNT_inc_simple_void_NN(cv);
2450 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2451 sub_crush_depth(cv);
2452 pad_push(padlist, CvDEPTH(cv));
2455 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2458 AV* const av = (AV*)PAD_SVl(0);
2460 cx->blk_sub.savearray = GvAV(PL_defgv);
2461 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2462 CX_CURPAD_SAVE(cx->blk_sub);
2463 cx->blk_sub.argarray = av;
2465 if (items >= AvMAX(av) + 1) {
2466 SV **ary = AvALLOC(av);
2467 if (AvARRAY(av) != ary) {
2468 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2471 if (items >= AvMAX(av) + 1) {
2472 AvMAX(av) = items - 1;
2473 Renew(ary,items+1,SV*);
2479 Copy(mark,AvARRAY(av),items,SV*);
2480 AvFILLp(av) = items - 1;
2481 assert(!AvREAL(av));
2483 /* transfer 'ownership' of refcnts to new @_ */
2493 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2494 Perl_get_db_sub(aTHX_ NULL, cv);
2496 CV * const gotocv = get_cv("DB::goto", FALSE);
2498 PUSHMARK( PL_stack_sp );
2499 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2504 RETURNOP(CvSTART(cv));
2508 label = SvPV_nolen_const(sv);
2509 if (!(do_dump || *label))
2510 DIE(aTHX_ must_have_label);
2513 else if (PL_op->op_flags & OPf_SPECIAL) {
2515 DIE(aTHX_ must_have_label);
2518 label = cPVOP->op_pv;
2520 if (label && *label) {
2521 OP *gotoprobe = NULL;
2522 bool leaving_eval = FALSE;
2523 bool in_block = FALSE;
2524 PERL_CONTEXT *last_eval_cx = NULL;
2528 PL_lastgotoprobe = NULL;
2530 for (ix = cxstack_ix; ix >= 0; ix--) {
2532 switch (CxTYPE(cx)) {
2534 leaving_eval = TRUE;
2535 if (!CxTRYBLOCK(cx)) {
2536 gotoprobe = (last_eval_cx ?
2537 last_eval_cx->blk_eval.old_eval_root :
2542 /* else fall through */
2544 gotoprobe = cx->blk_oldcop->op_sibling;
2550 gotoprobe = cx->blk_oldcop->op_sibling;
2553 gotoprobe = PL_main_root;
2556 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2557 gotoprobe = CvROOT(cx->blk_sub.cv);
2563 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2566 DIE(aTHX_ "panic: goto");
2567 gotoprobe = PL_main_root;
2571 retop = dofindlabel(gotoprobe, label,
2572 enterops, enterops + GOTO_DEPTH);
2576 PL_lastgotoprobe = gotoprobe;
2579 DIE(aTHX_ "Can't find label %s", label);
2581 /* if we're leaving an eval, check before we pop any frames
2582 that we're not going to punt, otherwise the error
2585 if (leaving_eval && *enterops && enterops[1]) {
2587 for (i = 1; enterops[i]; i++)
2588 if (enterops[i]->op_type == OP_ENTERITER)
2589 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2592 /* pop unwanted frames */
2594 if (ix < cxstack_ix) {
2601 oldsave = PL_scopestack[PL_scopestack_ix];
2602 LEAVE_SCOPE(oldsave);
2605 /* push wanted frames */
2607 if (*enterops && enterops[1]) {
2608 OP * const oldop = PL_op;
2609 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2610 for (; enterops[ix]; ix++) {
2611 PL_op = enterops[ix];
2612 /* Eventually we may want to stack the needed arguments
2613 * for each op. For now, we punt on the hard ones. */
2614 if (PL_op->op_type == OP_ENTERITER)
2615 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2616 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2624 if (!retop) retop = PL_main_start;
2626 PL_restartop = retop;
2627 PL_do_undump = TRUE;
2631 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2632 PL_do_undump = FALSE;
2649 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2651 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2654 PL_exit_flags |= PERL_EXIT_EXPECTED;
2656 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2657 if (anum || !(PL_minus_c && PL_madskills))
2662 PUSHs(&PL_sv_undef);
2669 S_save_lines(pTHX_ AV *array, SV *sv)
2671 const char *s = SvPVX_const(sv);
2672 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2675 while (s && s < send) {
2677 SV * const tmpstr = newSV_type(SVt_PVMG);
2679 t = strchr(s, '\n');
2685 sv_setpvn(tmpstr, s, t - s);
2686 av_store(array, line++, tmpstr);
2692 S_docatch(pTHX_ OP *o)
2696 OP * const oldop = PL_op;
2700 assert(CATCH_GET == TRUE);
2707 assert(cxstack_ix >= 0);
2708 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2709 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2714 /* die caught by an inner eval - continue inner loop */
2716 /* NB XXX we rely on the old popped CxEVAL still being at the top
2717 * of the stack; the way die_where() currently works, this
2718 * assumption is valid. In theory The cur_top_env value should be
2719 * returned in another global, the way retop (aka PL_restartop)
2721 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2724 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2726 PL_op = PL_restartop;
2743 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2744 /* sv Text to convert to OP tree. */
2745 /* startop op_free() this to undo. */
2746 /* code Short string id of the caller. */
2748 /* FIXME - how much of this code is common with pp_entereval? */
2749 dVAR; dSP; /* Make POPBLOCK work. */
2755 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2756 char *tmpbuf = tbuf;
2759 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2763 lex_start(sv, NULL, FALSE);
2765 /* switch to eval mode */
2767 if (IN_PERL_COMPILETIME) {
2768 SAVECOPSTASH_FREE(&PL_compiling);
2769 CopSTASH_set(&PL_compiling, PL_curstash);
2771 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2772 SV * const sv = sv_newmortal();
2773 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2774 code, (unsigned long)++PL_evalseq,
2775 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2780 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2781 (unsigned long)++PL_evalseq);
2782 SAVECOPFILE_FREE(&PL_compiling);
2783 CopFILE_set(&PL_compiling, tmpbuf+2);
2784 SAVECOPLINE(&PL_compiling);
2785 CopLINE_set(&PL_compiling, 1);
2786 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2787 deleting the eval's FILEGV from the stash before gv_check() runs
2788 (i.e. before run-time proper). To work around the coredump that
2789 ensues, we always turn GvMULTI_on for any globals that were
2790 introduced within evals. See force_ident(). GSAR 96-10-12 */
2791 safestr = savepvn(tmpbuf, len);
2792 SAVEDELETE(PL_defstash, safestr, len);
2794 #ifdef OP_IN_REGISTER
2800 /* we get here either during compilation, or via pp_regcomp at runtime */
2801 runtime = IN_PERL_RUNTIME;
2803 runcv = find_runcv(NULL);
2806 PL_op->op_type = OP_ENTEREVAL;
2807 PL_op->op_flags = 0; /* Avoid uninit warning. */
2808 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2809 PUSHEVAL(cx, 0, NULL);
2812 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2814 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2815 POPBLOCK(cx,PL_curpm);
2818 (*startop)->op_type = OP_NULL;
2819 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2821 /* XXX DAPM do this properly one year */
2822 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2824 if (IN_PERL_COMPILETIME)
2825 CopHINTS_set(&PL_compiling, PL_hints);
2826 #ifdef OP_IN_REGISTER
2829 PERL_UNUSED_VAR(newsp);
2830 PERL_UNUSED_VAR(optype);
2832 return PL_eval_start;
2837 =for apidoc find_runcv
2839 Locate the CV corresponding to the currently executing sub or eval.
2840 If db_seqp is non_null, skip CVs that are in the DB package and populate
2841 *db_seqp with the cop sequence number at the point that the DB:: code was
2842 entered. (allows debuggers to eval in the scope of the breakpoint rather
2843 than in the scope of the debugger itself).
2849 Perl_find_runcv(pTHX_ U32 *db_seqp)
2855 *db_seqp = PL_curcop->cop_seq;
2856 for (si = PL_curstackinfo; si; si = si->si_prev) {
2858 for (ix = si->si_cxix; ix >= 0; ix--) {
2859 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2860 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2861 CV * const cv = cx->blk_sub.cv;
2862 /* skip DB:: code */
2863 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2864 *db_seqp = cx->blk_oldcop->cop_seq;
2869 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2877 /* Compile a require/do, an eval '', or a /(?{...})/.
2878 * In the last case, startop is non-null, and contains the address of
2879 * a pointer that should be set to the just-compiled code.
2880 * outside is the lexically enclosing CV (if any) that invoked us.
2881 * Returns a bool indicating whether the compile was successful; if so,
2882 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2883 * pushes undef (also croaks if startop != NULL).
2887 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2890 OP * const saveop = PL_op;
2892 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2893 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2898 SAVESPTR(PL_compcv);
2899 PL_compcv = (CV*)newSV_type(SVt_PVCV);
2900 CvEVAL_on(PL_compcv);
2901 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2902 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2904 CvOUTSIDE_SEQ(PL_compcv) = seq;
2905 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2907 /* set up a scratch pad */
2909 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2910 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2914 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2916 /* make sure we compile in the right package */
2918 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2919 SAVESPTR(PL_curstash);
2920 PL_curstash = CopSTASH(PL_curcop);
2922 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2923 SAVESPTR(PL_beginav);
2924 PL_beginav = newAV();
2925 SAVEFREESV(PL_beginav);
2926 SAVESPTR(PL_unitcheckav);
2927 PL_unitcheckav = newAV();
2928 SAVEFREESV(PL_unitcheckav);
2931 SAVEBOOL(PL_madskills);
2935 /* try to compile it */
2937 PL_eval_root = NULL;
2938 PL_curcop = &PL_compiling;
2939 CopARYBASE_set(PL_curcop, 0);
2940 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2941 PL_in_eval |= EVAL_KEEPERR;
2943 sv_setpvn(ERRSV,"",0);
2944 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
2945 SV **newsp; /* Used by POPBLOCK. */
2946 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2947 I32 optype = 0; /* Might be reset by POPEVAL. */
2952 op_free(PL_eval_root);
2953 PL_eval_root = NULL;
2955 SP = PL_stack_base + POPMARK; /* pop original mark */
2957 POPBLOCK(cx,PL_curpm);
2963 msg = SvPVx_nolen_const(ERRSV);
2964 if (optype == OP_REQUIRE) {
2965 const SV * const nsv = cx->blk_eval.old_namesv;
2966 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2968 Perl_croak(aTHX_ "%sCompilation failed in require",
2969 *msg ? msg : "Unknown error\n");
2972 POPBLOCK(cx,PL_curpm);
2974 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2975 (*msg ? msg : "Unknown error\n"));
2979 sv_setpvs(ERRSV, "Compilation error");
2982 PERL_UNUSED_VAR(newsp);
2983 PUSHs(&PL_sv_undef);
2987 CopLINE_set(&PL_compiling, 0);
2989 *startop = PL_eval_root;
2991 SAVEFREEOP(PL_eval_root);
2993 /* Set the context for this new optree.
2994 * If the last op is an OP_REQUIRE, force scalar context.
2995 * Otherwise, propagate the context from the eval(). */
2996 if (PL_eval_root->op_type == OP_LEAVEEVAL
2997 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2998 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3000 scalar(PL_eval_root);
3001 else if ((gimme & G_WANT) == G_VOID)
3002 scalarvoid(PL_eval_root);
3003 else if ((gimme & G_WANT) == G_ARRAY)
3006 scalar(PL_eval_root);
3008 DEBUG_x(dump_eval());
3010 /* Register with debugger: */
3011 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3012 CV * const cv = get_cv("DB::postponed", FALSE);
3016 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3018 call_sv((SV*)cv, G_DISCARD);
3023 call_list(PL_scopestack_ix, PL_unitcheckav);
3025 /* compiled okay, so do it */
3027 CvDEPTH(PL_compcv) = 1;
3028 SP = PL_stack_base + POPMARK; /* pop original mark */
3029 PL_op = saveop; /* The caller may need it. */
3030 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3037 S_check_type_and_open(pTHX_ const char *name)
3040 const int st_rc = PerlLIO_stat(name, &st);
3042 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3046 return PerlIO_open(name, PERL_SCRIPT_MODE);
3049 #ifndef PERL_DISABLE_PMC
3051 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3055 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3056 SV *const pmcsv = newSV(namelen + 2);
3057 char *const pmc = SvPVX(pmcsv);
3060 memcpy(pmc, name, namelen);
3062 pmc[namelen + 1] = '\0';
3064 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3065 fp = check_type_and_open(name);
3068 fp = check_type_and_open(pmc);
3070 SvREFCNT_dec(pmcsv);
3073 fp = check_type_and_open(name);
3078 # define doopen_pm(name, namelen) check_type_and_open(name)
3079 #endif /* !PERL_DISABLE_PMC */
3084 register PERL_CONTEXT *cx;
3091 int vms_unixname = 0;
3093 const char *tryname = NULL;
3095 const I32 gimme = GIMME_V;
3096 int filter_has_file = 0;
3097 PerlIO *tryrsfp = NULL;
3098 SV *filter_cache = NULL;
3099 SV *filter_state = NULL;
3100 SV *filter_sub = NULL;
3106 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3107 sv = new_version(sv);
3108 if (!sv_derived_from(PL_patchlevel, "version"))
3109 upg_version(PL_patchlevel, TRUE);
3110 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3111 if ( vcmp(sv,PL_patchlevel) <= 0 )
3112 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3113 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3116 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3119 SV * const req = SvRV(sv);
3120 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3122 /* get the left hand term */
3123 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3125 first = SvIV(*av_fetch(lav,0,0));
3126 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3127 || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3128 || av_len(lav) > 1 /* FP with > 3 digits */
3129 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3131 DIE(aTHX_ "Perl %"SVf" required--this is only "
3132 "%"SVf", stopped", SVfARG(vnormal(req)),
3133 SVfARG(vnormal(PL_patchlevel)));
3135 else { /* probably 'use 5.10' or 'use 5.8' */
3136 SV * hintsv = newSV(0);
3140 second = SvIV(*av_fetch(lav,1,0));
3142 second /= second >= 600 ? 100 : 10;
3143 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3144 (int)first, (int)second,0);
3145 upg_version(hintsv, TRUE);
3147 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3148 "--this is only %"SVf", stopped",
3149 SVfARG(vnormal(req)),
3150 SVfARG(vnormal(hintsv)),
3151 SVfARG(vnormal(PL_patchlevel)));
3156 /* We do this only with use, not require. */
3158 /* If we request a version >= 5.9.5, load feature.pm with the
3159 * feature bundle that corresponds to the required version. */
3160 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3161 SV *const importsv = vnormal(sv);
3162 *SvPVX_mutable(importsv) = ':';
3164 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3170 name = SvPV_const(sv, len);
3171 if (!(name && len > 0 && *name))
3172 DIE(aTHX_ "Null filename used");
3173 TAINT_PROPER("require");
3177 /* The key in the %ENV hash is in the syntax of file passed as the argument
3178 * usually this is in UNIX format, but sometimes in VMS format, which
3179 * can result in a module being pulled in more than once.
3180 * To prevent this, the key must be stored in UNIX format if the VMS
3181 * name can be translated to UNIX.
3183 if ((unixname = tounixspec(name, NULL)) != NULL) {
3184 unixlen = strlen(unixname);
3190 /* if not VMS or VMS name can not be translated to UNIX, pass it
3193 unixname = (char *) name;
3196 if (PL_op->op_type == OP_REQUIRE) {
3197 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3198 unixname, unixlen, 0);
3200 if (*svp != &PL_sv_undef)
3203 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3204 "Compilation failed in require", unixname);
3208 /* prepare to compile file */
3210 if (path_is_absolute(name)) {
3212 tryrsfp = doopen_pm(name, len);
3214 #ifdef MACOS_TRADITIONAL
3218 MacPerl_CanonDir(name, newname, 1);
3219 if (path_is_absolute(newname)) {
3221 tryrsfp = doopen_pm(newname, strlen(newname));
3226 AV * const ar = GvAVn(PL_incgv);
3232 namesv = newSV_type(SVt_PV);
3233 for (i = 0; i <= AvFILL(ar); i++) {
3234 SV * const dirsv = *av_fetch(ar, i, TRUE);
3236 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3243 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3244 && !sv_isobject(loader))
3246 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3249 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3250 PTR2UV(SvRV(dirsv)), name);
3251 tryname = SvPVX_const(namesv);
3262 if (sv_isobject(loader))
3263 count = call_method("INC", G_ARRAY);
3265 count = call_sv(loader, G_ARRAY);
3268 /* Adjust file name if the hook has set an %INC entry */
3269 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3271 tryname = SvPVX_const(*svp);
3280 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3281 && !isGV_with_GP(SvRV(arg))) {
3282 filter_cache = SvRV(arg);
3283 SvREFCNT_inc_simple_void_NN(filter_cache);
3290 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3294 if (SvTYPE(arg) == SVt_PVGV) {
3295 IO * const io = GvIO((GV *)arg);
3300 tryrsfp = IoIFP(io);
3301 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3302 PerlIO_close(IoOFP(io));
3313 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3315 SvREFCNT_inc_simple_void_NN(filter_sub);
3318 filter_state = SP[i];
3319 SvREFCNT_inc_simple_void(filter_state);
3323 if (!tryrsfp && (filter_cache || filter_sub)) {
3324 tryrsfp = PerlIO_open(BIT_BUCKET,
3339 filter_has_file = 0;
3341 SvREFCNT_dec(filter_cache);
3342 filter_cache = NULL;
3345 SvREFCNT_dec(filter_state);
3346 filter_state = NULL;
3349 SvREFCNT_dec(filter_sub);
3354 if (!path_is_absolute(name)
3355 #ifdef MACOS_TRADITIONAL
3356 /* We consider paths of the form :a:b ambiguous and interpret them first
3357 as global then as local
3359 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3366 dir = SvPV_const(dirsv, dirlen);
3372 #ifdef MACOS_TRADITIONAL
3376 MacPerl_CanonDir(name, buf2, 1);
3377 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3381 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3383 sv_setpv(namesv, unixdir);
3384 sv_catpv(namesv, unixname);
3386 # ifdef __SYMBIAN32__
3387 if (PL_origfilename[0] &&
3388 PL_origfilename[1] == ':' &&
3389 !(dir[0] && dir[1] == ':'))
3390 Perl_sv_setpvf(aTHX_ namesv,
3395 Perl_sv_setpvf(aTHX_ namesv,
3399 /* The equivalent of
3400 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3401 but without the need to parse the format string, or
3402 call strlen on either pointer, and with the correct
3403 allocation up front. */
3405 char *tmp = SvGROW(namesv, dirlen + len + 2);
3407 memcpy(tmp, dir, dirlen);
3410 /* name came from an SV, so it will have a '\0' at the
3411 end that we can copy as part of this memcpy(). */
3412 memcpy(tmp, name, len + 1);
3414 SvCUR_set(namesv, dirlen + len + 1);
3416 /* Don't even actually have to turn SvPOK_on() as we
3417 access it directly with SvPVX() below. */
3422 TAINT_PROPER("require");
3423 tryname = SvPVX_const(namesv);
3424 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3426 if (tryname[0] == '.' && tryname[1] == '/')
3430 else if (errno == EMFILE)
3431 /* no point in trying other paths if out of handles */
3438 SAVECOPFILE_FREE(&PL_compiling);
3439 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3440 SvREFCNT_dec(namesv);
3442 if (PL_op->op_type == OP_REQUIRE) {
3443 const char *msgstr = name;
3444 if(errno == EMFILE) {
3446 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3448 msgstr = SvPV_nolen_const(msg);
3450 if (namesv) { /* did we lookup @INC? */
3451 AV * const ar = GvAVn(PL_incgv);
3453 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3454 "%s in @INC%s%s (@INC contains:",
3456 (instr(msgstr, ".h ")
3457 ? " (change .h to .ph maybe?)" : ""),
3458 (instr(msgstr, ".ph ")
3459 ? " (did you run h2ph?)" : "")
3462 for (i = 0; i <= AvFILL(ar); i++) {
3463 sv_catpvs(msg, " ");
3464 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3466 sv_catpvs(msg, ")");
3467 msgstr = SvPV_nolen_const(msg);
3470 DIE(aTHX_ "Can't locate %s", msgstr);
3476 SETERRNO(0, SS_NORMAL);
3478 /* Assume success here to prevent recursive requirement. */
3479 /* name is never assigned to again, so len is still strlen(name) */
3480 /* Check whether a hook in @INC has already filled %INC */
3482 (void)hv_store(GvHVn(PL_incgv),
3483 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3485 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3487 (void)hv_store(GvHVn(PL_incgv),
3488 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3493 lex_start(NULL, tryrsfp, TRUE);
3497 SAVECOMPILEWARNINGS();
3498 if (PL_dowarn & G_WARN_ALL_ON)
3499 PL_compiling.cop_warnings = pWARN_ALL ;
3500 else if (PL_dowarn & G_WARN_ALL_OFF)
3501 PL_compiling.cop_warnings = pWARN_NONE ;
3503 PL_compiling.cop_warnings = pWARN_STD ;
3505 if (filter_sub || filter_cache) {
3506 SV * const datasv = filter_add(S_run_user_filter, NULL);
3507 IoLINES(datasv) = filter_has_file;
3508 IoTOP_GV(datasv) = (GV *)filter_state;
3509 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3510 IoFMT_GV(datasv) = (GV *)filter_cache;
3513 /* switch to eval mode */
3514 PUSHBLOCK(cx, CXt_EVAL, SP);
3515 PUSHEVAL(cx, name, NULL);
3516 cx->blk_eval.retop = PL_op->op_next;
3518 SAVECOPLINE(&PL_compiling);
3519 CopLINE_set(&PL_compiling, 0);
3523 /* Store and reset encoding. */
3524 encoding = PL_encoding;
3527 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3528 op = DOCATCH(PL_eval_start);
3530 op = PL_op->op_next;
3532 /* Restore encoding. */
3533 PL_encoding = encoding;
3541 register PERL_CONTEXT *cx;
3543 const I32 gimme = GIMME_V;
3544 const I32 was = PL_sub_generation;
3545 char tbuf[TYPE_DIGITS(long) + 12];
3546 char *tmpbuf = tbuf;
3552 HV *saved_hh = NULL;
3553 const char * const fakestr = "_<(eval )";
3554 const int fakelen = 9 + 1;
3556 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3557 saved_hh = (HV*) SvREFCNT_inc(POPs);
3561 TAINT_IF(SvTAINTED(sv));
3562 TAINT_PROPER("eval");
3565 lex_start(sv, NULL, FALSE);
3568 /* switch to eval mode */
3570 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3571 SV * const temp_sv = sv_newmortal();
3572 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3573 (unsigned long)++PL_evalseq,
3574 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3575 tmpbuf = SvPVX(temp_sv);
3576 len = SvCUR(temp_sv);
3579 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3580 SAVECOPFILE_FREE(&PL_compiling);
3581 CopFILE_set(&PL_compiling, tmpbuf+2);
3582 SAVECOPLINE(&PL_compiling);
3583 CopLINE_set(&PL_compiling, 1);
3584 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3585 deleting the eval's FILEGV from the stash before gv_check() runs
3586 (i.e. before run-time proper). To work around the coredump that
3587 ensues, we always turn GvMULTI_on for any globals that were
3588 introduced within evals. See force_ident(). GSAR 96-10-12 */
3589 safestr = savepvn(tmpbuf, len);
3590 SAVEDELETE(PL_defstash, safestr, len);
3592 PL_hints = PL_op->op_targ;
3594 GvHV(PL_hintgv) = saved_hh;
3595 SAVECOMPILEWARNINGS();
3596 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3597 if (PL_compiling.cop_hints_hash) {
3598 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3600 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3601 if (PL_compiling.cop_hints_hash) {
3603 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3604 HINTS_REFCNT_UNLOCK;
3606 /* special case: an eval '' executed within the DB package gets lexically
3607 * placed in the first non-DB CV rather than the current CV - this
3608 * allows the debugger to execute code, find lexicals etc, in the
3609 * scope of the code being debugged. Passing &seq gets find_runcv
3610 * to do the dirty work for us */
3611 runcv = find_runcv(&seq);
3613 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3614 PUSHEVAL(cx, 0, NULL);
3615 cx->blk_eval.retop = PL_op->op_next;
3617 /* prepare to compile string */
3619 if (PERLDB_LINE && PL_curstash != PL_debstash)
3620 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3622 ok = doeval(gimme, NULL, runcv, seq);
3623 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3625 /* Copy in anything fake and short. */
3626 my_strlcpy(safestr, fakestr, fakelen);
3628 return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3638 register PERL_CONTEXT *cx;
3640 const U8 save_flags = PL_op -> op_flags;
3645 retop = cx->blk_eval.retop;
3648 if (gimme == G_VOID)
3650 else if (gimme == G_SCALAR) {
3653 if (SvFLAGS(TOPs) & SVs_TEMP)
3656 *MARK = sv_mortalcopy(TOPs);
3660 *MARK = &PL_sv_undef;
3665 /* in case LEAVE wipes old return values */
3666 for (mark = newsp + 1; mark <= SP; mark++) {
3667 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3668 *mark = sv_mortalcopy(*mark);
3669 TAINT_NOT; /* Each item is independent */
3673 PL_curpm = newpm; /* Don't pop $1 et al till now */
3676 assert(CvDEPTH(PL_compcv) == 1);
3678 CvDEPTH(PL_compcv) = 0;
3681 if (optype == OP_REQUIRE &&
3682 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3684 /* Unassume the success we assumed earlier. */
3685 SV * const nsv = cx->blk_eval.old_namesv;
3686 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3687 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3688 /* die_where() did LEAVE, or we won't be here */
3692 if (!(save_flags & OPf_SPECIAL))
3693 sv_setpvn(ERRSV,"",0);
3699 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3700 close to the related Perl_create_eval_scope. */
3702 Perl_delete_eval_scope(pTHX)
3707 register PERL_CONTEXT *cx;
3714 PERL_UNUSED_VAR(newsp);
3715 PERL_UNUSED_VAR(gimme);
3716 PERL_UNUSED_VAR(optype);
3719 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3720 also needed by Perl_fold_constants. */
3722 Perl_create_eval_scope(pTHX_ U32 flags)
3725 const I32 gimme = GIMME_V;
3730 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3733 PL_in_eval = EVAL_INEVAL;
3734 if (flags & G_KEEPERR)
3735 PL_in_eval |= EVAL_KEEPERR;
3737 sv_setpvn(ERRSV,"",0);
3738 if (flags & G_FAKINGEVAL) {
3739 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3747 PERL_CONTEXT * const cx = create_eval_scope(0);
3748 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3749 return DOCATCH(PL_op->op_next);
3758 register PERL_CONTEXT *cx;
3763 PERL_UNUSED_VAR(optype);
3766 if (gimme == G_VOID)
3768 else if (gimme == G_SCALAR) {
3772 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3775 *MARK = sv_mortalcopy(TOPs);
3779 *MARK = &PL_sv_undef;
3784 /* in case LEAVE wipes old return values */
3786 for (mark = newsp + 1; mark <= SP; mark++) {
3787 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3788 *mark = sv_mortalcopy(*mark);
3789 TAINT_NOT; /* Each item is independent */
3793 PL_curpm = newpm; /* Don't pop $1 et al till now */
3796 sv_setpvn(ERRSV,"",0);
3803 register PERL_CONTEXT *cx;
3804 const I32 gimme = GIMME_V;
3809 if (PL_op->op_targ == 0) {
3810 SV ** const defsv_p = &GvSV(PL_defgv);
3811 *defsv_p = newSVsv(POPs);
3812 SAVECLEARSV(*defsv_p);
3815 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3817 PUSHBLOCK(cx, CXt_GIVEN, SP);
3826 register PERL_CONTEXT *cx;
3830 PERL_UNUSED_CONTEXT;
3833 assert(CxTYPE(cx) == CXt_GIVEN);
3838 PL_curpm = newpm; /* pop $1 et al */
3845 /* Helper routines used by pp_smartmatch */
3847 S_make_matcher(pTHX_ REGEXP *re)
3850 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3851 PM_SETRE(matcher, ReREFCNT_inc(re));
3853 SAVEFREEOP((OP *) matcher);
3860 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3865 PL_op = (OP *) matcher;
3870 return (SvTRUEx(POPs));
3874 S_destroy_matcher(pTHX_ PMOP *matcher)
3877 PERL_UNUSED_ARG(matcher);
3882 /* Do a smart match */
3885 return do_smartmatch(NULL, NULL);
3888 /* This version of do_smartmatch() implements the
3889 * table of smart matches that is found in perlsyn.
3892 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3897 SV *e = TOPs; /* e is for 'expression' */
3898 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3899 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3900 REGEXP *this_regex, *other_regex;
3902 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3904 # define SM_REF(type) ( \
3905 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3906 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3908 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3909 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
3910 && NOT_EMPTY_PROTO(This) && (Other = e)) \
3911 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
3912 && NOT_EMPTY_PROTO(This) && (Other = d)))
3914 # define SM_REGEX ( \
3915 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \
3916 && (this_regex = (REGEXP*) This) \
3919 (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \
3920 && (this_regex = (REGEXP*) This) \
3924 # define SM_OTHER_REF(type) \
3925 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3927 # define SM_OTHER_REGEX (SvROK(Other) \
3928 && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \
3929 && (other_regex = (REGEXP*) SvRV(Other)))
3932 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3933 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3935 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3936 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3938 tryAMAGICbinSET(smart, 0);
3940 SP -= 2; /* Pop the values */
3942 /* Take care only to invoke mg_get() once for each argument.
3943 * Currently we do this by copying the SV if it's magical. */
3946 d = sv_mortalcopy(d);
3953 e = sv_mortalcopy(e);
3958 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3960 if (This == SvRV(Other))
3971 c = call_sv(This, G_SCALAR);
3975 else if (SvTEMP(TOPs))
3976 SvREFCNT_inc_void(TOPs);
3981 else if (SM_REF(PVHV)) {
3982 if (SM_OTHER_REF(PVHV)) {
3983 /* Check that the key-sets are identical */
3985 HV *other_hv = (HV *) SvRV(Other);
3987 bool other_tied = FALSE;
3988 U32 this_key_count = 0,
3989 other_key_count = 0;
3991 /* Tied hashes don't know how many keys they have. */
3992 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
3995 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3996 HV * const temp = other_hv;
3997 other_hv = (HV *) This;
4001 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
4004 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
4007 /* The hashes have the same number of keys, so it suffices
4008 to check that one is a subset of the other. */
4009 (void) hv_iterinit((HV *) This);
4010 while ( (he = hv_iternext((HV *) This)) ) {
4012 char * const key = hv_iterkey(he, &key_len);
4016 if(!hv_exists(other_hv, key, key_len)) {
4017 (void) hv_iterinit((HV *) This); /* reset iterator */
4023 (void) hv_iterinit(other_hv);
4024 while ( hv_iternext(other_hv) )
4028 other_key_count = HvUSEDKEYS(other_hv);
4030 if (this_key_count != other_key_count)
4035 else if (SM_OTHER_REF(PVAV)) {
4036 AV * const other_av = (AV *) SvRV(Other);
4037 const I32 other_len = av_len(other_av) + 1;
4040 for (i = 0; i < other_len; ++i) {
4041 SV ** const svp = av_fetch(other_av, i, FALSE);
4045 if (svp) { /* ??? When can this not happen? */
4046 key = SvPV(*svp, key_len);
4047 if (hv_exists((HV *) This, key, key_len))
4053 else if (SM_OTHER_REGEX) {
4054 PMOP * const matcher = make_matcher(other_regex);
4057 (void) hv_iterinit((HV *) This);
4058 while ( (he = hv_iternext((HV *) This)) ) {
4059 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4060 (void) hv_iterinit((HV *) This);
4061 destroy_matcher(matcher);
4065 destroy_matcher(matcher);
4069 if (hv_exists_ent((HV *) This, Other, 0))
4075 else if (SM_REF(PVAV)) {
4076 if (SM_OTHER_REF(PVAV)) {
4077 AV *other_av = (AV *) SvRV(Other);
4078 if (av_len((AV *) This) != av_len(other_av))
4082 const I32 other_len = av_len(other_av);
4084 if (NULL == seen_this) {
4085 seen_this = newHV();
4086 (void) sv_2mortal((SV *) seen_this);
4088 if (NULL == seen_other) {
4089 seen_this = newHV();
4090 (void) sv_2mortal((SV *) seen_other);
4092 for(i = 0; i <= other_len; ++i) {
4093 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4094 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4096 if (!this_elem || !other_elem) {
4097 if (this_elem || other_elem)
4100 else if (SM_SEEN_THIS(*this_elem)
4101 || SM_SEEN_OTHER(*other_elem))
4103 if (*this_elem != *other_elem)
4107 (void)hv_store_ent(seen_this,
4108 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4110 (void)hv_store_ent(seen_other,
4111 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4117 (void) do_smartmatch(seen_this, seen_other);
4127 else if (SM_OTHER_REGEX) {
4128 PMOP * const matcher = make_matcher(other_regex);
4129 const I32 this_len = av_len((AV *) This);
4132 for(i = 0; i <= this_len; ++i) {
4133 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4134 if (svp && matcher_matches_sv(matcher, *svp)) {
4135 destroy_matcher(matcher);
4139 destroy_matcher(matcher);
4142 else if (SvIOK(Other) || SvNOK(Other)) {
4145 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4146 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4153 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4163 else if (SvPOK(Other)) {
4164 const I32 this_len = av_len((AV *) This);
4167 for(i = 0; i <= this_len; ++i) {
4168 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4183 else if (!SvOK(d) || !SvOK(e)) {
4184 if (!SvOK(d) && !SvOK(e))
4189 else if (SM_REGEX) {
4190 PMOP * const matcher = make_matcher(this_regex);
4193 PUSHs(matcher_matches_sv(matcher, Other)
4196 destroy_matcher(matcher);
4199 else if (SM_REF(PVCV)) {
4201 /* This must be a null-prototyped sub, because we
4202 already checked for the other kind. */
4208 c = call_sv(This, G_SCALAR);
4211 PUSHs(&PL_sv_undef);
4212 else if (SvTEMP(TOPs))
4213 SvREFCNT_inc_void(TOPs);
4215 if (SM_OTHER_REF(PVCV)) {
4216 /* This one has to be null-proto'd too.
4217 Call both of 'em, and compare the results */
4219 c = call_sv(SvRV(Other), G_SCALAR);
4222 PUSHs(&PL_sv_undef);
4223 else if (SvTEMP(TOPs))
4224 SvREFCNT_inc_void(TOPs);
4235 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4236 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4238 if (SvPOK(Other) && !looks_like_number(Other)) {
4239 /* String comparison */
4244 /* Otherwise, numeric comparison */
4247 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4258 /* As a last resort, use string comparison */
4267 register PERL_CONTEXT *cx;
4268 const I32 gimme = GIMME_V;
4270 /* This is essentially an optimization: if the match
4271 fails, we don't want to push a context and then
4272 pop it again right away, so we skip straight
4273 to the op that follows the leavewhen.
4275 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4276 return cLOGOP->op_other->op_next;
4281 PUSHBLOCK(cx, CXt_WHEN, SP);
4290 register PERL_CONTEXT *cx;
4296 assert(CxTYPE(cx) == CXt_WHEN);
4301 PL_curpm = newpm; /* pop $1 et al */
4311 register PERL_CONTEXT *cx;
4314 cxix = dopoptowhen(cxstack_ix);
4316 DIE(aTHX_ "Can't \"continue\" outside a when block");
4317 if (cxix < cxstack_ix)
4320 /* clear off anything above the scope we're re-entering */
4321 inner = PL_scopestack_ix;
4323 if (PL_scopestack_ix < inner)
4324 leave_scope(PL_scopestack[PL_scopestack_ix]);
4325 PL_curcop = cx->blk_oldcop;
4326 return cx->blk_givwhen.leave_op;
4333 register PERL_CONTEXT *cx;
4336 cxix = dopoptogiven(cxstack_ix);
4338 if (PL_op->op_flags & OPf_SPECIAL)
4339 DIE(aTHX_ "Can't use when() outside a topicalizer");
4341 DIE(aTHX_ "Can't \"break\" outside a given block");
4343 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4344 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4346 if (cxix < cxstack_ix)
4349 /* clear off anything above the scope we're re-entering */
4350 inner = PL_scopestack_ix;
4352 if (PL_scopestack_ix < inner)
4353 leave_scope(PL_scopestack[PL_scopestack_ix]);
4354 PL_curcop = cx->blk_oldcop;
4357 return CX_LOOP_NEXTOP_GET(cx);
4359 return cx->blk_givwhen.leave_op;
4363 S_doparseform(pTHX_ SV *sv)
4366 register char *s = SvPV_force(sv, len);
4367 register char * const send = s + len;
4368 register char *base = NULL;
4369 register I32 skipspaces = 0;
4370 bool noblank = FALSE;
4371 bool repeat = FALSE;
4372 bool postspace = FALSE;
4378 bool unchopnum = FALSE;
4379 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4382 Perl_croak(aTHX_ "Null picture in formline");
4384 /* estimate the buffer size needed */
4385 for (base = s; s <= send; s++) {
4386 if (*s == '\n' || *s == '@' || *s == '^')
4392 Newx(fops, maxops, U32);
4397 *fpc++ = FF_LINEMARK;
4398 noblank = repeat = FALSE;
4416 case ' ': case '\t':
4423 } /* else FALL THROUGH */
4431 *fpc++ = FF_LITERAL;
4439 *fpc++ = (U16)skipspaces;
4443 *fpc++ = FF_NEWLINE;
4447 arg = fpc - linepc + 1;
4454 *fpc++ = FF_LINEMARK;
4455 noblank = repeat = FALSE;
4464 ischop = s[-1] == '^';
4470 arg = (s - base) - 1;
4472 *fpc++ = FF_LITERAL;
4480 *fpc++ = 2; /* skip the @* or ^* */
4482 *fpc++ = FF_LINESNGL;
4485 *fpc++ = FF_LINEGLOB;
4487 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4488 arg = ischop ? 512 : 0;
4493 const char * const f = ++s;
4496 arg |= 256 + (s - f);
4498 *fpc++ = s - base; /* fieldsize for FETCH */
4499 *fpc++ = FF_DECIMAL;
4501 unchopnum |= ! ischop;
4503 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4504 arg = ischop ? 512 : 0;
4506 s++; /* skip the '0' first */
4510 const char * const f = ++s;
4513 arg |= 256 + (s - f);
4515 *fpc++ = s - base; /* fieldsize for FETCH */
4516 *fpc++ = FF_0DECIMAL;
4518 unchopnum |= ! ischop;
4522 bool ismore = FALSE;
4525 while (*++s == '>') ;
4526 prespace = FF_SPACE;
4528 else if (*s == '|') {
4529 while (*++s == '|') ;
4530 prespace = FF_HALFSPACE;
4535 while (*++s == '<') ;
4538 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4542 *fpc++ = s - base; /* fieldsize for FETCH */
4544 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4547 *fpc++ = (U16)prespace;
4561 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4563 { /* need to jump to the next word */
4565 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4566 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4567 s = SvPVX(sv) + SvCUR(sv) + z;
4569 Copy(fops, s, arg, U32);
4571 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4574 if (unchopnum && repeat)
4575 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4581 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4583 /* Can value be printed in fldsize chars, using %*.*f ? */
4587 int intsize = fldsize - (value < 0 ? 1 : 0);
4594 while (intsize--) pwr *= 10.0;
4595 while (frcsize--) eps /= 10.0;
4598 if (value + eps >= pwr)
4601 if (value - eps <= -pwr)
4608 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4611 SV * const datasv = FILTER_DATA(idx);
4612 const int filter_has_file = IoLINES(datasv);
4613 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4614 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4618 const char *got_p = NULL;
4619 const char *prune_from = NULL;
4620 bool read_from_cache = FALSE;
4623 assert(maxlen >= 0);
4626 /* I was having segfault trouble under Linux 2.2.5 after a
4627 parse error occured. (Had to hack around it with a test
4628 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4629 not sure where the trouble is yet. XXX */
4631 if (IoFMT_GV(datasv)) {
4632 SV *const cache = (SV *)IoFMT_GV(datasv);
4635 const char *cache_p = SvPV(cache, cache_len);
4639 /* Running in block mode and we have some cached data already.
4641 if (cache_len >= umaxlen) {
4642 /* In fact, so much data we don't even need to call
4647 const char *const first_nl =
4648 (const char *)memchr(cache_p, '\n', cache_len);
4650 take = first_nl + 1 - cache_p;
4654 sv_catpvn(buf_sv, cache_p, take);
4655 sv_chop(cache, cache_p + take);
4656 /* Definately not EOF */
4660 sv_catsv(buf_sv, cache);
4662 umaxlen -= cache_len;
4665 read_from_cache = TRUE;
4669 /* Filter API says that the filter appends to the contents of the buffer.
4670 Usually the buffer is "", so the details don't matter. But if it's not,
4671 then clearly what it contains is already filtered by this filter, so we
4672 don't want to pass it in a second time.
4673 I'm going to use a mortal in case the upstream filter croaks. */
4674 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4675 ? sv_newmortal() : buf_sv;
4676 SvUPGRADE(upstream, SVt_PV);
4678 if (filter_has_file) {
4679 status = FILTER_READ(idx+1, upstream, 0);
4682 if (filter_sub && status >= 0) {
4695 PUSHs(filter_state);
4698 count = call_sv(filter_sub, G_SCALAR);
4713 if(SvOK(upstream)) {
4714 got_p = SvPV(upstream, got_len);
4716 if (got_len > umaxlen) {
4717 prune_from = got_p + umaxlen;
4720 const char *const first_nl =
4721 (const char *)memchr(got_p, '\n', got_len);
4722 if (first_nl && first_nl + 1 < got_p + got_len) {
4723 /* There's a second line here... */
4724 prune_from = first_nl + 1;
4729 /* Oh. Too long. Stuff some in our cache. */
4730 STRLEN cached_len = got_p + got_len - prune_from;
4731 SV *cache = (SV *)IoFMT_GV(datasv);
4734 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4735 } else if (SvOK(cache)) {
4736 /* Cache should be empty. */
4737 assert(!SvCUR(cache));
4740 sv_setpvn(cache, prune_from, cached_len);
4741 /* If you ask for block mode, you may well split UTF-8 characters.
4742 "If it breaks, you get to keep both parts"
4743 (Your code is broken if you don't put them back together again
4744 before something notices.) */
4745 if (SvUTF8(upstream)) {
4748 SvCUR_set(upstream, got_len - cached_len);
4749 /* Can't yet be EOF */
4754 /* If they are at EOF but buf_sv has something in it, then they may never
4755 have touched the SV upstream, so it may be undefined. If we naively
4756 concatenate it then we get a warning about use of uninitialised value.
4758 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4759 sv_catsv(buf_sv, upstream);
4763 IoLINES(datasv) = 0;
4764 SvREFCNT_dec(IoFMT_GV(datasv));
4766 SvREFCNT_dec(filter_state);
4767 IoTOP_GV(datasv) = NULL;
4770 SvREFCNT_dec(filter_sub);
4771 IoBOTTOM_GV(datasv) = NULL;
4773 filter_del(S_run_user_filter);
4775 if (status == 0 && read_from_cache) {
4776 /* If we read some data from the cache (and by getting here it implies
4777 that we emptied the cache) then we aren't yet at EOF, and mustn't
4778 report that to our caller. */
4784 /* perhaps someone can come up with a better name for
4785 this? it is not really "absolute", per se ... */
4787 S_path_is_absolute(const char *name)
4789 if (PERL_FILE_IS_ABSOLUTE(name)
4790 #ifdef MACOS_TRADITIONAL
4793 || (*name == '.' && (name[1] == '/' ||
4794 (name[1] == '.' && name[2] == '/')))
4806 * c-indentation-style: bsd
4808 * indent-tabs-mode: t
4811 * ex: set ts=8 sts=4 sw=4 noet: