3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
20 /* This file contains control-oriented pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
26 * Control-oriented means things like pp_enteriter() and pp_next(), which
27 * alter the flow of control of the program.
32 #define PERL_IN_PP_CTL_C
36 #define WORD_ALIGN sizeof(U32)
39 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
41 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
50 cxix = dopoptosub(cxstack_ix);
54 switch (cxstack[cxix].blk_gimme) {
67 /* XXXX Should store the old value to allow for tie/overload - and
68 restore in regcomp, where marked with XXXX. */
78 register PMOP *pm = (PMOP*)cLOGOP->op_other;
82 /* prevent recompiling under /o and ithreads. */
83 #if defined(USE_ITHREADS)
84 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
85 if (PL_op->op_flags & OPf_STACKED) {
94 if (PL_op->op_flags & OPf_STACKED) {
95 /* multiple args; concatentate them */
97 tmpstr = PAD_SV(ARGTARG);
98 sv_setpvn(tmpstr, "", 0);
99 while (++MARK <= SP) {
100 if (PL_amagic_generation) {
102 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
103 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
105 sv_setsv(tmpstr, sv);
109 sv_catsv(tmpstr, *MARK);
118 SV * const sv = SvRV(tmpstr);
119 if (SvTYPE(sv) == SVt_REGEXP)
123 re = reg_temp_copy(re);
124 ReREFCNT_dec(PM_GETRE(pm));
129 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
131 assert (re != (REGEXP*) &PL_sv_undef);
133 /* Check against the last compiled regexp. */
134 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
135 memNE(RX_PRECOMP(re), t, len))
137 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
138 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
142 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
144 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
146 } else if (PL_curcop->cop_hints_hash) {
147 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
149 if (ptr && SvIOK(ptr) && SvIV(ptr))
150 eng = INT2PTR(regexp_engine*,SvIV(ptr));
153 if (PL_op->op_flags & OPf_SPECIAL)
154 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
156 if (DO_UTF8(tmpstr)) {
157 assert (SvUTF8(tmpstr));
158 } else if (SvUTF8(tmpstr)) {
159 /* Not doing UTF-8, despite what the SV says. Is this only if
160 we're trapped in use 'bytes'? */
161 /* Make a copy of the octet sequence, but without the flag on,
162 as the compiler now honours the SvUTF8 flag on tmpstr. */
164 const char *const p = SvPV(tmpstr, len);
165 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
169 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
171 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
173 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
174 inside tie/overload accessors. */
180 #ifndef INCOMPLETE_TAINTS
183 RX_EXTFLAGS(re) |= RXf_TAINTED;
185 RX_EXTFLAGS(re) &= ~RXf_TAINTED;
189 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
193 #if !defined(USE_ITHREADS)
194 /* can't change the optree at runtime either */
195 /* PMf_KEEP is handled differently under threads to avoid these problems */
196 if (pm->op_pmflags & PMf_KEEP) {
197 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
198 cLOGOP->op_first->op_next = PL_op->op_next;
208 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
209 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
210 register SV * const dstr = cx->sb_dstr;
211 register char *s = cx->sb_s;
212 register char *m = cx->sb_m;
213 char *orig = cx->sb_orig;
214 register REGEXP * const rx = cx->sb_rx;
216 REGEXP *old = PM_GETRE(pm);
220 PM_SETRE(pm,ReREFCNT_inc(rx));
223 rxres_restore(&cx->sb_rxres, rx);
224 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
226 if (cx->sb_iters++) {
227 const I32 saviters = cx->sb_iters;
228 if (cx->sb_iters > cx->sb_maxiters)
229 DIE(aTHX_ "Substitution loop");
231 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
232 cx->sb_rxtainted |= 2;
233 sv_catsv(dstr, POPs);
234 FREETMPS; /* Prevent excess tmp stack */
237 if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
238 s == m, cx->sb_targ, NULL,
239 ((cx->sb_rflags & REXEC_COPY_STR)
240 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
241 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
243 SV * const targ = cx->sb_targ;
245 assert(cx->sb_strend >= s);
246 if(cx->sb_strend > s) {
247 if (DO_UTF8(dstr) && !SvUTF8(targ))
248 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
250 sv_catpvn(dstr, s, cx->sb_strend - s);
252 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
254 #ifdef PERL_OLD_COPY_ON_WRITE
256 sv_force_normal_flags(targ, SV_COW_DROP_PV);
262 SvPV_set(targ, SvPVX(dstr));
263 SvCUR_set(targ, SvCUR(dstr));
264 SvLEN_set(targ, SvLEN(dstr));
267 SvPV_set(dstr, NULL);
269 TAINT_IF(cx->sb_rxtainted & 1);
270 mPUSHi(saviters - 1);
272 (void)SvPOK_only_UTF8(targ);
273 TAINT_IF(cx->sb_rxtainted);
277 LEAVE_SCOPE(cx->sb_oldsave);
279 RETURNOP(pm->op_next);
281 cx->sb_iters = saviters;
283 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
286 cx->sb_orig = orig = RX_SUBBEG(rx);
288 cx->sb_strend = s + (cx->sb_strend - m);
290 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
292 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
293 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
295 sv_catpvn(dstr, s, m-s);
297 cx->sb_s = RX_OFFS(rx)[0].end + orig;
298 { /* Update the pos() information. */
299 SV * const sv = cx->sb_targ;
302 SvUPGRADE(sv, SVt_PVMG);
303 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
304 #ifdef PERL_OLD_COPY_ON_WRITE
306 sv_force_normal_flags(sv, 0);
308 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
317 (void)ReREFCNT_inc(rx);
318 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
319 rxres_save(&cx->sb_rxres, rx);
320 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
324 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
330 if (!p || p[1] < RX_NPARENS(rx)) {
331 #ifdef PERL_OLD_COPY_ON_WRITE
332 i = 7 + RX_NPARENS(rx) * 2;
334 i = 6 + RX_NPARENS(rx) * 2;
343 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
344 RX_MATCH_COPIED_off(rx);
346 #ifdef PERL_OLD_COPY_ON_WRITE
347 *p++ = PTR2UV(RX_SAVED_COPY(rx));
348 RX_SAVED_COPY(rx) = NULL;
351 *p++ = RX_NPARENS(rx);
353 *p++ = PTR2UV(RX_SUBBEG(rx));
354 *p++ = (UV)RX_SUBLEN(rx);
355 for (i = 0; i <= RX_NPARENS(rx); ++i) {
356 *p++ = (UV)RX_OFFS(rx)[i].start;
357 *p++ = (UV)RX_OFFS(rx)[i].end;
362 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
368 RX_MATCH_COPY_FREE(rx);
369 RX_MATCH_COPIED_set(rx, *p);
372 #ifdef PERL_OLD_COPY_ON_WRITE
373 if (RX_SAVED_COPY(rx))
374 SvREFCNT_dec (RX_SAVED_COPY(rx));
375 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
379 RX_NPARENS(rx) = *p++;
381 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
382 RX_SUBLEN(rx) = (I32)(*p++);
383 for (i = 0; i <= RX_NPARENS(rx); ++i) {
384 RX_OFFS(rx)[i].start = (I32)(*p++);
385 RX_OFFS(rx)[i].end = (I32)(*p++);
390 Perl_rxres_free(pTHX_ void **rsp)
392 UV * const p = (UV*)*rsp;
397 void *tmp = INT2PTR(char*,*p);
400 PoisonFree(*p, 1, sizeof(*p));
402 Safefree(INT2PTR(char*,*p));
404 #ifdef PERL_OLD_COPY_ON_WRITE
406 SvREFCNT_dec (INT2PTR(SV*,p[1]));
416 dVAR; dSP; dMARK; dORIGMARK;
417 register SV * const tmpForm = *++MARK;
422 register SV *sv = NULL;
423 const char *item = NULL;
427 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
428 const char *chophere = NULL;
429 char *linemark = NULL;
431 bool gotsome = FALSE;
433 const STRLEN fudge = SvPOK(tmpForm)
434 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
435 bool item_is_utf8 = FALSE;
436 bool targ_is_utf8 = FALSE;
438 OP * parseres = NULL;
442 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
443 if (SvREADONLY(tmpForm)) {
444 SvREADONLY_off(tmpForm);
445 parseres = doparseform(tmpForm);
446 SvREADONLY_on(tmpForm);
449 parseres = doparseform(tmpForm);
453 SvPV_force(PL_formtarget, len);
454 if (DO_UTF8(PL_formtarget))
456 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
458 f = SvPV_const(tmpForm, len);
459 /* need to jump to the next word */
460 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
464 const char *name = "???";
467 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
468 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
469 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
470 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
471 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
473 case FF_CHECKNL: name = "CHECKNL"; break;
474 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
475 case FF_SPACE: name = "SPACE"; break;
476 case FF_HALFSPACE: name = "HALFSPACE"; break;
477 case FF_ITEM: name = "ITEM"; break;
478 case FF_CHOP: name = "CHOP"; break;
479 case FF_LINEGLOB: name = "LINEGLOB"; break;
480 case FF_NEWLINE: name = "NEWLINE"; break;
481 case FF_MORE: name = "MORE"; break;
482 case FF_LINEMARK: name = "LINEMARK"; break;
483 case FF_END: name = "END"; break;
484 case FF_0DECIMAL: name = "0DECIMAL"; break;
485 case FF_LINESNGL: name = "LINESNGL"; break;
488 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
490 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
501 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
502 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
504 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
505 t = SvEND(PL_formtarget);
508 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
509 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
511 sv_utf8_upgrade(PL_formtarget);
512 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
513 t = SvEND(PL_formtarget);
533 if (ckWARN(WARN_SYNTAX))
534 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
541 const char *s = item = SvPV_const(sv, len);
544 itemsize = sv_len_utf8(sv);
545 if (itemsize != (I32)len) {
547 if (itemsize > fieldsize) {
548 itemsize = fieldsize;
549 itembytes = itemsize;
550 sv_pos_u2b(sv, &itembytes, 0);
554 send = chophere = s + itembytes;
564 sv_pos_b2u(sv, &itemsize);
568 item_is_utf8 = FALSE;
569 if (itemsize > fieldsize)
570 itemsize = fieldsize;
571 send = chophere = s + itemsize;
585 const char *s = item = SvPV_const(sv, len);
588 itemsize = sv_len_utf8(sv);
589 if (itemsize != (I32)len) {
591 if (itemsize <= fieldsize) {
592 const char *send = chophere = s + itemsize;
605 itemsize = fieldsize;
606 itembytes = itemsize;
607 sv_pos_u2b(sv, &itembytes, 0);
608 send = chophere = s + itembytes;
609 while (s < send || (s == send && isSPACE(*s))) {
619 if (strchr(PL_chopset, *s))
624 itemsize = chophere - item;
625 sv_pos_b2u(sv, &itemsize);
631 item_is_utf8 = FALSE;
632 if (itemsize <= fieldsize) {
633 const char *const send = chophere = s + itemsize;
646 itemsize = fieldsize;
647 send = chophere = s + itemsize;
648 while (s < send || (s == send && isSPACE(*s))) {
658 if (strchr(PL_chopset, *s))
663 itemsize = chophere - item;
669 arg = fieldsize - itemsize;
678 arg = fieldsize - itemsize;
689 const char *s = item;
693 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
695 sv_utf8_upgrade(PL_formtarget);
696 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
697 t = SvEND(PL_formtarget);
701 if (UTF8_IS_CONTINUED(*s)) {
702 STRLEN skip = UTF8SKIP(s);
719 if ( !((*t++ = *s++) & ~31) )
725 if (targ_is_utf8 && !item_is_utf8) {
726 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
728 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
729 for (; t < SvEND(PL_formtarget); t++) {
742 const int ch = *t++ = *s++;
745 if ( !((*t++ = *s++) & ~31) )
754 const char *s = chophere;
772 const char *s = item = SvPV_const(sv, len);
774 if ((item_is_utf8 = DO_UTF8(sv)))
775 itemsize = sv_len_utf8(sv);
777 bool chopped = FALSE;
778 const char *const send = s + len;
780 chophere = s + itemsize;
796 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
798 SvUTF8_on(PL_formtarget);
800 SvCUR_set(sv, chophere - item);
801 sv_catsv(PL_formtarget, sv);
802 SvCUR_set(sv, itemsize);
804 sv_catsv(PL_formtarget, sv);
806 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
807 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
808 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
817 #if defined(USE_LONG_DOUBLE)
820 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
824 "%#0*.*f" : "%0*.*f");
829 #if defined(USE_LONG_DOUBLE)
831 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
834 ((arg & 256) ? "%#*.*f" : "%*.*f");
837 /* If the field is marked with ^ and the value is undefined,
839 if ((arg & 512) && !SvOK(sv)) {
847 /* overflow evidence */
848 if (num_overflow(value, fieldsize, arg)) {
854 /* Formats aren't yet marked for locales, so assume "yes". */
856 STORE_NUMERIC_STANDARD_SET_LOCAL();
857 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
858 RESTORE_NUMERIC_STANDARD();
865 while (t-- > linemark && *t == ' ') ;
873 if (arg) { /* repeat until fields exhausted? */
875 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
876 lines += FmLINES(PL_formtarget);
879 if (strnEQ(linemark, linemark - arg, arg))
880 DIE(aTHX_ "Runaway format");
883 SvUTF8_on(PL_formtarget);
884 FmLINES(PL_formtarget) = lines;
886 RETURNOP(cLISTOP->op_first);
897 const char *s = chophere;
898 const char *send = item + len;
900 while (isSPACE(*s) && (s < send))
905 arg = fieldsize - itemsize;
912 if (strnEQ(s1," ",3)) {
913 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
924 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
926 SvUTF8_on(PL_formtarget);
927 FmLINES(PL_formtarget) += lines;
939 if (PL_stack_base + *PL_markstack_ptr == SP) {
941 if (GIMME_V == G_SCALAR)
943 RETURNOP(PL_op->op_next->op_next);
945 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
946 pp_pushmark(); /* push dst */
947 pp_pushmark(); /* push src */
948 ENTER; /* enter outer scope */
951 if (PL_op->op_private & OPpGREP_LEX)
952 SAVESPTR(PAD_SVl(PL_op->op_targ));
955 ENTER; /* enter inner scope */
958 src = PL_stack_base[*PL_markstack_ptr];
960 if (PL_op->op_private & OPpGREP_LEX)
961 PAD_SVl(PL_op->op_targ) = src;
966 if (PL_op->op_type == OP_MAPSTART)
967 pp_pushmark(); /* push top */
968 return ((LOGOP*)PL_op->op_next)->op_other;
974 const I32 gimme = GIMME_V;
975 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
981 /* first, move source pointer to the next item in the source list */
982 ++PL_markstack_ptr[-1];
984 /* if there are new items, push them into the destination list */
985 if (items && gimme != G_VOID) {
986 /* might need to make room back there first */
987 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
988 /* XXX this implementation is very pessimal because the stack
989 * is repeatedly extended for every set of items. Is possible
990 * to do this without any stack extension or copying at all
991 * by maintaining a separate list over which the map iterates
992 * (like foreach does). --gsar */
994 /* everything in the stack after the destination list moves
995 * towards the end the stack by the amount of room needed */
996 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
998 /* items to shift up (accounting for the moved source pointer) */
999 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1001 /* This optimization is by Ben Tilly and it does
1002 * things differently from what Sarathy (gsar)
1003 * is describing. The downside of this optimization is
1004 * that leaves "holes" (uninitialized and hopefully unused areas)
1005 * to the Perl stack, but on the other hand this
1006 * shouldn't be a problem. If Sarathy's idea gets
1007 * implemented, this optimization should become
1008 * irrelevant. --jhi */
1010 shift = count; /* Avoid shifting too often --Ben Tilly */
1014 dst = (SP += shift);
1015 PL_markstack_ptr[-1] += shift;
1016 *PL_markstack_ptr += shift;
1020 /* copy the new items down to the destination list */
1021 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1022 if (gimme == G_ARRAY) {
1024 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1027 /* scalar context: we don't care about which values map returns
1028 * (we use undef here). And so we certainly don't want to do mortal
1029 * copies of meaningless values. */
1030 while (items-- > 0) {
1032 *dst-- = &PL_sv_undef;
1036 LEAVE; /* exit inner scope */
1039 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1041 (void)POPMARK; /* pop top */
1042 LEAVE; /* exit outer scope */
1043 (void)POPMARK; /* pop src */
1044 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1045 (void)POPMARK; /* pop dst */
1046 SP = PL_stack_base + POPMARK; /* pop original mark */
1047 if (gimme == G_SCALAR) {
1048 if (PL_op->op_private & OPpGREP_LEX) {
1049 SV* sv = sv_newmortal();
1050 sv_setiv(sv, items);
1058 else if (gimme == G_ARRAY)
1065 ENTER; /* enter inner scope */
1068 /* set $_ to the new source item */
1069 src = PL_stack_base[PL_markstack_ptr[-1]];
1071 if (PL_op->op_private & OPpGREP_LEX)
1072 PAD_SVl(PL_op->op_targ) = src;
1076 RETURNOP(cLOGOP->op_other);
1085 if (GIMME == G_ARRAY)
1087 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1088 return cLOGOP->op_other;
1098 if (GIMME == G_ARRAY) {
1099 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1103 SV * const targ = PAD_SV(PL_op->op_targ);
1106 if (PL_op->op_private & OPpFLIP_LINENUM) {
1107 if (GvIO(PL_last_in_gv)) {
1108 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1111 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1113 flip = SvIV(sv) == SvIV(GvSV(gv));
1119 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1120 if (PL_op->op_flags & OPf_SPECIAL) {
1128 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1131 sv_setpvn(TARG, "", 0);
1137 /* This code tries to decide if "$left .. $right" should use the
1138 magical string increment, or if the range is numeric (we make
1139 an exception for .."0" [#18165]). AMS 20021031. */
1141 #define RANGE_IS_NUMERIC(left,right) ( \
1142 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1143 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1144 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1145 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1146 && (!SvOK(right) || looks_like_number(right))))
1152 if (GIMME == G_ARRAY) {
1158 if (RANGE_IS_NUMERIC(left,right)) {
1161 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1162 (SvOK(right) && SvNV(right) > IV_MAX))
1163 DIE(aTHX_ "Range iterator outside integer range");
1174 SV * const sv = sv_2mortal(newSViv(i++));
1179 SV * const final = sv_mortalcopy(right);
1181 const char * const tmps = SvPV_const(final, len);
1183 SV *sv = sv_mortalcopy(left);
1184 SvPV_force_nolen(sv);
1185 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1187 if (strEQ(SvPVX_const(sv),tmps))
1189 sv = sv_2mortal(newSVsv(sv));
1196 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1200 if (PL_op->op_private & OPpFLIP_LINENUM) {
1201 if (GvIO(PL_last_in_gv)) {
1202 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1205 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1206 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1214 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1215 sv_catpvs(targ, "E0");
1225 static const char * const context_name[] = {
1238 S_dopoptolabel(pTHX_ const char *label)
1243 for (i = cxstack_ix; i >= 0; i--) {
1244 register const PERL_CONTEXT * const cx = &cxstack[i];
1245 switch (CxTYPE(cx)) {
1253 if (ckWARN(WARN_EXITING))
1254 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1255 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1256 if (CxTYPE(cx) == CXt_NULL)
1260 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1261 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1262 (long)i, cx->blk_loop.label));
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 (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1312 return cxstack[cxix].blk_sub.lval;
1318 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1322 for (i = startingblock; i >= 0; i--) {
1323 register const PERL_CONTEXT * const cx = &cxstk[i];
1324 switch (CxTYPE(cx)) {
1330 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1338 S_dopoptoeval(pTHX_ I32 startingblock)
1342 for (i = startingblock; i >= 0; i--) {
1343 register const PERL_CONTEXT *cx = &cxstack[i];
1344 switch (CxTYPE(cx)) {
1348 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1356 S_dopoptoloop(pTHX_ I32 startingblock)
1360 for (i = startingblock; i >= 0; i--) {
1361 register const PERL_CONTEXT * const cx = &cxstack[i];
1362 switch (CxTYPE(cx)) {
1368 if (ckWARN(WARN_EXITING))
1369 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1370 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1371 if ((CxTYPE(cx)) == CXt_NULL)
1375 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1383 S_dopoptogiven(pTHX_ I32 startingblock)
1387 for (i = startingblock; i >= 0; i--) {
1388 register const PERL_CONTEXT *cx = &cxstack[i];
1389 switch (CxTYPE(cx)) {
1393 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1396 if (CxFOREACHDEF(cx)) {
1397 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1406 S_dopoptowhen(pTHX_ I32 startingblock)
1410 for (i = startingblock; i >= 0; i--) {
1411 register const PERL_CONTEXT *cx = &cxstack[i];
1412 switch (CxTYPE(cx)) {
1416 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1424 Perl_dounwind(pTHX_ I32 cxix)
1429 while (cxstack_ix > cxix) {
1431 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1432 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1433 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1434 /* Note: we don't need to restore the base context info till the end. */
1435 switch (CxTYPE(cx)) {
1438 continue; /* not break */
1457 PERL_UNUSED_VAR(optype);
1461 Perl_qerror(pTHX_ SV *err)
1465 sv_catsv(ERRSV, err);
1467 sv_catsv(PL_errors, err);
1469 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1471 ++PL_parser->error_count;
1475 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1484 if (PL_in_eval & EVAL_KEEPERR) {
1485 static const char prefix[] = "\t(in cleanup) ";
1486 SV * const err = ERRSV;
1487 const char *e = NULL;
1489 sv_setpvn(err,"",0);
1490 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1492 e = SvPV_const(err, len);
1494 if (*e != *message || strNE(e,message))
1498 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1499 sv_catpvn(err, prefix, sizeof(prefix)-1);
1500 sv_catpvn(err, message, msglen);
1501 if (ckWARN(WARN_MISC)) {
1502 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1503 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1508 sv_setpvn(ERRSV, message, msglen);
1512 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1513 && PL_curstackinfo->si_prev)
1521 register PERL_CONTEXT *cx;
1524 if (cxix < cxstack_ix)
1527 POPBLOCK(cx,PL_curpm);
1528 if (CxTYPE(cx) != CXt_EVAL) {
1530 message = SvPVx_const(ERRSV, msglen);
1531 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1532 PerlIO_write(Perl_error_log, message, msglen);
1537 if (gimme == G_SCALAR)
1538 *++newsp = &PL_sv_undef;
1539 PL_stack_sp = newsp;
1543 /* LEAVE could clobber PL_curcop (see save_re_context())
1544 * XXX it might be better to find a way to avoid messing with
1545 * PL_curcop in save_re_context() instead, but this is a more
1546 * minimal fix --GSAR */
1547 PL_curcop = cx->blk_oldcop;
1549 if (optype == OP_REQUIRE) {
1550 const char* const msg = SvPVx_nolen_const(ERRSV);
1551 SV * const nsv = cx->blk_eval.old_namesv;
1552 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1554 DIE(aTHX_ "%sCompilation failed in require",
1555 *msg ? msg : "Unknown error\n");
1557 assert(CxTYPE(cx) == CXt_EVAL);
1558 return cx->blk_eval.retop;
1562 message = SvPVx_const(ERRSV, msglen);
1564 write_to_stderr(message, msglen);
1572 dVAR; dSP; dPOPTOPssrl;
1573 if (SvTRUE(left) != SvTRUE(right))
1583 register I32 cxix = dopoptosub(cxstack_ix);
1584 register const PERL_CONTEXT *cx;
1585 register const PERL_CONTEXT *ccstack = cxstack;
1586 const PERL_SI *top_si = PL_curstackinfo;
1588 const char *stashname;
1595 /* we may be in a higher stacklevel, so dig down deeper */
1596 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1597 top_si = top_si->si_prev;
1598 ccstack = top_si->si_cxstack;
1599 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1602 if (GIMME != G_ARRAY) {
1608 /* caller() should not report the automatic calls to &DB::sub */
1609 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1610 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1614 cxix = dopoptosub_at(ccstack, cxix - 1);
1617 cx = &ccstack[cxix];
1618 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1619 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1620 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1621 field below is defined for any cx. */
1622 /* caller() should not report the automatic calls to &DB::sub */
1623 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1624 cx = &ccstack[dbcxix];
1627 stashname = CopSTASHPV(cx->blk_oldcop);
1628 if (GIMME != G_ARRAY) {
1631 PUSHs(&PL_sv_undef);
1634 sv_setpv(TARG, stashname);
1643 PUSHs(&PL_sv_undef);
1645 mPUSHs(newSVpv(stashname, 0));
1646 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1647 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1650 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1651 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1652 /* So is ccstack[dbcxix]. */
1654 SV * const sv = newSV(0);
1655 gv_efullname3(sv, cvgv, NULL);
1657 mPUSHi((I32)cx->blk_sub.hasargs);
1660 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1661 mPUSHi((I32)cx->blk_sub.hasargs);
1665 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1668 gimme = (I32)cx->blk_gimme;
1669 if (gimme == G_VOID)
1670 PUSHs(&PL_sv_undef);
1672 mPUSHi(gimme & G_ARRAY);
1673 if (CxTYPE(cx) == CXt_EVAL) {
1675 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1676 PUSHs(cx->blk_eval.cur_text);
1680 else if (cx->blk_eval.old_namesv) {
1681 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1684 /* eval BLOCK (try blocks have old_namesv == 0) */
1686 PUSHs(&PL_sv_undef);
1687 PUSHs(&PL_sv_undef);
1691 PUSHs(&PL_sv_undef);
1692 PUSHs(&PL_sv_undef);
1694 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
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 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1877 (SvOK(right) && SvNV(right) >= IV_MAX))
1878 DIE(aTHX_ "Range iterator outside integer range");
1879 cx->blk_loop.iterix = SvIV(sv);
1880 cx->blk_loop.itermax = SvIV(right);
1882 /* for correct -Dstv display */
1883 cx->blk_oldsp = sp - PL_stack_base;
1887 cx->blk_loop.iterlval = newSVsv(sv);
1888 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1889 (void) SvPV_nolen_const(right);
1892 else if (PL_op->op_private & OPpITER_REVERSED) {
1893 cx->blk_loop.itermax = 0;
1894 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1899 cx->blk_loop.iterary = PL_curstack;
1900 AvFILLp(PL_curstack) = SP - PL_stack_base;
1901 if (PL_op->op_private & OPpITER_REVERSED) {
1902 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1903 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1906 cx->blk_loop.iterix = MARK - PL_stack_base;
1916 register PERL_CONTEXT *cx;
1917 const I32 gimme = GIMME_V;
1923 PUSHBLOCK(cx, CXt_LOOP, SP);
1924 PUSHLOOP(cx, 0, SP);
1932 register PERL_CONTEXT *cx;
1939 assert(CxTYPE(cx) == CXt_LOOP);
1941 newsp = PL_stack_base + cx->blk_loop.resetsp;
1944 if (gimme == G_VOID)
1946 else if (gimme == G_SCALAR) {
1948 *++newsp = sv_mortalcopy(*SP);
1950 *++newsp = &PL_sv_undef;
1954 *++newsp = sv_mortalcopy(*++mark);
1955 TAINT_NOT; /* Each item is independent */
1961 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1962 PL_curpm = newpm; /* ... and pop $1 et al */
1973 register PERL_CONTEXT *cx;
1974 bool popsub2 = FALSE;
1975 bool clear_errsv = FALSE;
1983 const I32 cxix = dopoptosub(cxstack_ix);
1986 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1987 * sort block, which is a CXt_NULL
1990 PL_stack_base[1] = *PL_stack_sp;
1991 PL_stack_sp = PL_stack_base + 1;
1995 DIE(aTHX_ "Can't return outside a subroutine");
1997 if (cxix < cxstack_ix)
2000 if (CxMULTICALL(&cxstack[cxix])) {
2001 gimme = cxstack[cxix].blk_gimme;
2002 if (gimme == G_VOID)
2003 PL_stack_sp = PL_stack_base;
2004 else if (gimme == G_SCALAR) {
2005 PL_stack_base[1] = *PL_stack_sp;
2006 PL_stack_sp = PL_stack_base + 1;
2012 switch (CxTYPE(cx)) {
2015 retop = cx->blk_sub.retop;
2016 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2019 if (!(PL_in_eval & EVAL_KEEPERR))
2022 retop = cx->blk_eval.retop;
2026 if (optype == OP_REQUIRE &&
2027 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2029 /* Unassume the success we assumed earlier. */
2030 SV * const nsv = cx->blk_eval.old_namesv;
2031 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2032 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2037 retop = cx->blk_sub.retop;
2040 DIE(aTHX_ "panic: return");
2044 if (gimme == G_SCALAR) {
2047 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2049 *++newsp = SvREFCNT_inc(*SP);
2054 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2056 *++newsp = sv_mortalcopy(sv);
2061 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2064 *++newsp = sv_mortalcopy(*SP);
2067 *++newsp = &PL_sv_undef;
2069 else if (gimme == G_ARRAY) {
2070 while (++MARK <= SP) {
2071 *++newsp = (popsub2 && SvTEMP(*MARK))
2072 ? *MARK : sv_mortalcopy(*MARK);
2073 TAINT_NOT; /* Each item is independent */
2076 PL_stack_sp = newsp;
2079 /* Stack values are safe: */
2082 POPSUB(cx,sv); /* release CV and @_ ... */
2086 PL_curpm = newpm; /* ... and pop $1 et al */
2090 sv_setpvn(ERRSV,"",0);
2098 register PERL_CONTEXT *cx;
2109 if (PL_op->op_flags & OPf_SPECIAL) {
2110 cxix = dopoptoloop(cxstack_ix);
2112 DIE(aTHX_ "Can't \"last\" outside a loop block");
2115 cxix = dopoptolabel(cPVOP->op_pv);
2117 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2119 if (cxix < cxstack_ix)
2123 cxstack_ix++; /* temporarily protect top context */
2125 switch (CxTYPE(cx)) {
2128 newsp = PL_stack_base + cx->blk_loop.resetsp;
2129 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2133 nextop = cx->blk_sub.retop;
2137 nextop = cx->blk_eval.retop;
2141 nextop = cx->blk_sub.retop;
2144 DIE(aTHX_ "panic: last");
2148 if (gimme == G_SCALAR) {
2150 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2151 ? *SP : sv_mortalcopy(*SP);
2153 *++newsp = &PL_sv_undef;
2155 else if (gimme == G_ARRAY) {
2156 while (++MARK <= SP) {
2157 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2158 ? *MARK : sv_mortalcopy(*MARK);
2159 TAINT_NOT; /* Each item is independent */
2167 /* Stack values are safe: */
2170 POPLOOP(cx); /* release loop vars ... */
2174 POPSUB(cx,sv); /* release CV and @_ ... */
2177 PL_curpm = newpm; /* ... and pop $1 et al */
2180 PERL_UNUSED_VAR(optype);
2181 PERL_UNUSED_VAR(gimme);
2189 register PERL_CONTEXT *cx;
2192 if (PL_op->op_flags & OPf_SPECIAL) {
2193 cxix = dopoptoloop(cxstack_ix);
2195 DIE(aTHX_ "Can't \"next\" outside a loop block");
2198 cxix = dopoptolabel(cPVOP->op_pv);
2200 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2202 if (cxix < cxstack_ix)
2205 /* clear off anything above the scope we're re-entering, but
2206 * save the rest until after a possible continue block */
2207 inner = PL_scopestack_ix;
2209 if (PL_scopestack_ix < inner)
2210 leave_scope(PL_scopestack[PL_scopestack_ix]);
2211 PL_curcop = cx->blk_oldcop;
2212 return CX_LOOP_NEXTOP_GET(cx);
2219 register PERL_CONTEXT *cx;
2223 if (PL_op->op_flags & OPf_SPECIAL) {
2224 cxix = dopoptoloop(cxstack_ix);
2226 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2229 cxix = dopoptolabel(cPVOP->op_pv);
2231 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2233 if (cxix < cxstack_ix)
2236 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2237 if (redo_op->op_type == OP_ENTER) {
2238 /* pop one less context to avoid $x being freed in while (my $x..) */
2240 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2241 redo_op = redo_op->op_next;
2245 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2246 LEAVE_SCOPE(oldsave);
2248 PL_curcop = cx->blk_oldcop;
2253 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2257 static const char too_deep[] = "Target of goto is too deeply nested";
2260 Perl_croak(aTHX_ too_deep);
2261 if (o->op_type == OP_LEAVE ||
2262 o->op_type == OP_SCOPE ||
2263 o->op_type == OP_LEAVELOOP ||
2264 o->op_type == OP_LEAVESUB ||
2265 o->op_type == OP_LEAVETRY)
2267 *ops++ = cUNOPo->op_first;
2269 Perl_croak(aTHX_ too_deep);
2272 if (o->op_flags & OPf_KIDS) {
2274 /* First try all the kids at this level, since that's likeliest. */
2275 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2276 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2277 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2280 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2281 if (kid == PL_lastgotoprobe)
2283 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2286 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2287 ops[-1]->op_type == OP_DBSTATE)
2292 if ((o = dofindlabel(kid, label, ops, oplimit)))
2305 register PERL_CONTEXT *cx;
2306 #define GOTO_DEPTH 64
2307 OP *enterops[GOTO_DEPTH];
2308 const char *label = NULL;
2309 const bool do_dump = (PL_op->op_type == OP_DUMP);
2310 static const char must_have_label[] = "goto must have label";
2312 if (PL_op->op_flags & OPf_STACKED) {
2313 SV * const sv = POPs;
2315 /* This egregious kludge implements goto &subroutine */
2316 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2318 register PERL_CONTEXT *cx;
2319 CV* cv = (CV*)SvRV(sv);
2326 if (!CvROOT(cv) && !CvXSUB(cv)) {
2327 const GV * const gv = CvGV(cv);
2331 /* autoloaded stub? */
2332 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2334 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2335 GvNAMELEN(gv), FALSE);
2336 if (autogv && (cv = GvCV(autogv)))
2338 tmpstr = sv_newmortal();
2339 gv_efullname3(tmpstr, gv, NULL);
2340 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2342 DIE(aTHX_ "Goto undefined subroutine");
2345 /* First do some returnish stuff. */
2346 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2348 cxix = dopoptosub(cxstack_ix);
2350 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2351 if (cxix < cxstack_ix)
2355 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2356 if (CxTYPE(cx) == CXt_EVAL) {
2358 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2360 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2362 else if (CxMULTICALL(cx))
2363 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2364 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2365 /* put @_ back onto stack */
2366 AV* av = cx->blk_sub.argarray;
2368 items = AvFILLp(av) + 1;
2369 EXTEND(SP, items+1); /* @_ could have been extended. */
2370 Copy(AvARRAY(av), SP + 1, items, SV*);
2371 SvREFCNT_dec(GvAV(PL_defgv));
2372 GvAV(PL_defgv) = cx->blk_sub.savearray;
2374 /* abandon @_ if it got reified */
2379 av_extend(av, items-1);
2381 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2384 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2385 AV* const av = GvAV(PL_defgv);
2386 items = AvFILLp(av) + 1;
2387 EXTEND(SP, items+1); /* @_ could have been extended. */
2388 Copy(AvARRAY(av), SP + 1, items, SV*);
2392 if (CxTYPE(cx) == CXt_SUB &&
2393 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2394 SvREFCNT_dec(cx->blk_sub.cv);
2395 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2396 LEAVE_SCOPE(oldsave);
2398 /* Now do some callish stuff. */
2400 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2402 OP* const retop = cx->blk_sub.retop;
2407 for (index=0; index<items; index++)
2408 sv_2mortal(SP[-index]);
2411 /* XS subs don't have a CxSUB, so pop it */
2412 POPBLOCK(cx, PL_curpm);
2413 /* Push a mark for the start of arglist */
2416 (void)(*CvXSUB(cv))(aTHX_ cv);
2421 AV* const padlist = CvPADLIST(cv);
2422 if (CxTYPE(cx) == CXt_EVAL) {
2423 PL_in_eval = cx->blk_eval.old_in_eval;
2424 PL_eval_root = cx->blk_eval.old_eval_root;
2425 cx->cx_type = CXt_SUB;
2426 cx->blk_sub.hasargs = 0;
2428 cx->blk_sub.cv = cv;
2429 cx->blk_sub.olddepth = CvDEPTH(cv);
2432 if (CvDEPTH(cv) < 2)
2433 SvREFCNT_inc_simple_void_NN(cv);
2435 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2436 sub_crush_depth(cv);
2437 pad_push(padlist, CvDEPTH(cv));
2440 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2441 if (cx->blk_sub.hasargs)
2443 AV* const av = (AV*)PAD_SVl(0);
2445 cx->blk_sub.savearray = GvAV(PL_defgv);
2446 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2447 CX_CURPAD_SAVE(cx->blk_sub);
2448 cx->blk_sub.argarray = av;
2450 if (items >= AvMAX(av) + 1) {
2451 SV **ary = AvALLOC(av);
2452 if (AvARRAY(av) != ary) {
2453 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2456 if (items >= AvMAX(av) + 1) {
2457 AvMAX(av) = items - 1;
2458 Renew(ary,items+1,SV*);
2464 Copy(mark,AvARRAY(av),items,SV*);
2465 AvFILLp(av) = items - 1;
2466 assert(!AvREAL(av));
2468 /* transfer 'ownership' of refcnts to new @_ */
2478 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2479 Perl_get_db_sub(aTHX_ NULL, cv);
2481 CV * const gotocv = get_cv("DB::goto", FALSE);
2483 PUSHMARK( PL_stack_sp );
2484 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2489 RETURNOP(CvSTART(cv));
2493 label = SvPV_nolen_const(sv);
2494 if (!(do_dump || *label))
2495 DIE(aTHX_ must_have_label);
2498 else if (PL_op->op_flags & OPf_SPECIAL) {
2500 DIE(aTHX_ must_have_label);
2503 label = cPVOP->op_pv;
2505 if (label && *label) {
2506 OP *gotoprobe = NULL;
2507 bool leaving_eval = FALSE;
2508 bool in_block = FALSE;
2509 PERL_CONTEXT *last_eval_cx = NULL;
2513 PL_lastgotoprobe = NULL;
2515 for (ix = cxstack_ix; ix >= 0; ix--) {
2517 switch (CxTYPE(cx)) {
2519 leaving_eval = TRUE;
2520 if (!CxTRYBLOCK(cx)) {
2521 gotoprobe = (last_eval_cx ?
2522 last_eval_cx->blk_eval.old_eval_root :
2527 /* else fall through */
2529 gotoprobe = cx->blk_oldcop->op_sibling;
2535 gotoprobe = cx->blk_oldcop->op_sibling;
2538 gotoprobe = PL_main_root;
2541 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2542 gotoprobe = CvROOT(cx->blk_sub.cv);
2548 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2551 DIE(aTHX_ "panic: goto");
2552 gotoprobe = PL_main_root;
2556 retop = dofindlabel(gotoprobe, label,
2557 enterops, enterops + GOTO_DEPTH);
2561 PL_lastgotoprobe = gotoprobe;
2564 DIE(aTHX_ "Can't find label %s", label);
2566 /* if we're leaving an eval, check before we pop any frames
2567 that we're not going to punt, otherwise the error
2570 if (leaving_eval && *enterops && enterops[1]) {
2572 for (i = 1; enterops[i]; i++)
2573 if (enterops[i]->op_type == OP_ENTERITER)
2574 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2577 /* pop unwanted frames */
2579 if (ix < cxstack_ix) {
2586 oldsave = PL_scopestack[PL_scopestack_ix];
2587 LEAVE_SCOPE(oldsave);
2590 /* push wanted frames */
2592 if (*enterops && enterops[1]) {
2593 OP * const oldop = PL_op;
2594 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2595 for (; enterops[ix]; ix++) {
2596 PL_op = enterops[ix];
2597 /* Eventually we may want to stack the needed arguments
2598 * for each op. For now, we punt on the hard ones. */
2599 if (PL_op->op_type == OP_ENTERITER)
2600 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2601 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2609 if (!retop) retop = PL_main_start;
2611 PL_restartop = retop;
2612 PL_do_undump = TRUE;
2616 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2617 PL_do_undump = FALSE;
2634 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2636 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2639 PL_exit_flags |= PERL_EXIT_EXPECTED;
2641 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2642 if (anum || !(PL_minus_c && PL_madskills))
2647 PUSHs(&PL_sv_undef);
2654 S_save_lines(pTHX_ AV *array, SV *sv)
2656 const char *s = SvPVX_const(sv);
2657 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2660 while (s && s < send) {
2662 SV * const tmpstr = newSV_type(SVt_PVMG);
2664 t = strchr(s, '\n');
2670 sv_setpvn(tmpstr, s, t - s);
2671 av_store(array, line++, tmpstr);
2677 S_docatch(pTHX_ OP *o)
2681 OP * const oldop = PL_op;
2685 assert(CATCH_GET == TRUE);
2692 assert(cxstack_ix >= 0);
2693 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2694 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2699 /* die caught by an inner eval - continue inner loop */
2701 /* NB XXX we rely on the old popped CxEVAL still being at the top
2702 * of the stack; the way die_where() currently works, this
2703 * assumption is valid. In theory The cur_top_env value should be
2704 * returned in another global, the way retop (aka PL_restartop)
2706 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2709 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2711 PL_op = PL_restartop;
2728 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2729 /* sv Text to convert to OP tree. */
2730 /* startop op_free() this to undo. */
2731 /* code Short string id of the caller. */
2733 /* FIXME - how much of this code is common with pp_entereval? */
2734 dVAR; dSP; /* Make POPBLOCK work. */
2740 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2741 char *tmpbuf = tbuf;
2744 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2748 lex_start(sv, NULL, FALSE);
2750 /* switch to eval mode */
2752 if (IN_PERL_COMPILETIME) {
2753 SAVECOPSTASH_FREE(&PL_compiling);
2754 CopSTASH_set(&PL_compiling, PL_curstash);
2756 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2757 SV * const sv = sv_newmortal();
2758 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2759 code, (unsigned long)++PL_evalseq,
2760 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2765 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2766 (unsigned long)++PL_evalseq);
2767 SAVECOPFILE_FREE(&PL_compiling);
2768 CopFILE_set(&PL_compiling, tmpbuf+2);
2769 SAVECOPLINE(&PL_compiling);
2770 CopLINE_set(&PL_compiling, 1);
2771 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2772 deleting the eval's FILEGV from the stash before gv_check() runs
2773 (i.e. before run-time proper). To work around the coredump that
2774 ensues, we always turn GvMULTI_on for any globals that were
2775 introduced within evals. See force_ident(). GSAR 96-10-12 */
2776 safestr = savepvn(tmpbuf, len);
2777 SAVEDELETE(PL_defstash, safestr, len);
2779 #ifdef OP_IN_REGISTER
2785 /* we get here either during compilation, or via pp_regcomp at runtime */
2786 runtime = IN_PERL_RUNTIME;
2788 runcv = find_runcv(NULL);
2791 PL_op->op_type = OP_ENTEREVAL;
2792 PL_op->op_flags = 0; /* Avoid uninit warning. */
2793 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2794 PUSHEVAL(cx, 0, NULL);
2797 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2799 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2800 POPBLOCK(cx,PL_curpm);
2803 (*startop)->op_type = OP_NULL;
2804 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2806 /* XXX DAPM do this properly one year */
2807 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2809 if (IN_PERL_COMPILETIME)
2810 CopHINTS_set(&PL_compiling, PL_hints);
2811 #ifdef OP_IN_REGISTER
2814 PERL_UNUSED_VAR(newsp);
2815 PERL_UNUSED_VAR(optype);
2817 return PL_eval_start;
2822 =for apidoc find_runcv
2824 Locate the CV corresponding to the currently executing sub or eval.
2825 If db_seqp is non_null, skip CVs that are in the DB package and populate
2826 *db_seqp with the cop sequence number at the point that the DB:: code was
2827 entered. (allows debuggers to eval in the scope of the breakpoint rather
2828 than in the scope of the debugger itself).
2834 Perl_find_runcv(pTHX_ U32 *db_seqp)
2840 *db_seqp = PL_curcop->cop_seq;
2841 for (si = PL_curstackinfo; si; si = si->si_prev) {
2843 for (ix = si->si_cxix; ix >= 0; ix--) {
2844 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2845 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2846 CV * const cv = cx->blk_sub.cv;
2847 /* skip DB:: code */
2848 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2849 *db_seqp = cx->blk_oldcop->cop_seq;
2854 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2862 /* Compile a require/do, an eval '', or a /(?{...})/.
2863 * In the last case, startop is non-null, and contains the address of
2864 * a pointer that should be set to the just-compiled code.
2865 * outside is the lexically enclosing CV (if any) that invoked us.
2866 * Returns a bool indicating whether the compile was successful; if so,
2867 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2868 * pushes undef (also croaks if startop != NULL).
2872 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2875 OP * const saveop = PL_op;
2877 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2878 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2883 SAVESPTR(PL_compcv);
2884 PL_compcv = (CV*)newSV_type(SVt_PVCV);
2885 CvEVAL_on(PL_compcv);
2886 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2887 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2889 CvOUTSIDE_SEQ(PL_compcv) = seq;
2890 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2892 /* set up a scratch pad */
2894 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2895 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2899 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2901 /* make sure we compile in the right package */
2903 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2904 SAVESPTR(PL_curstash);
2905 PL_curstash = CopSTASH(PL_curcop);
2907 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2908 SAVESPTR(PL_beginav);
2909 PL_beginav = newAV();
2910 SAVEFREESV(PL_beginav);
2911 SAVESPTR(PL_unitcheckav);
2912 PL_unitcheckav = newAV();
2913 SAVEFREESV(PL_unitcheckav);
2916 SAVEBOOL(PL_madskills);
2920 /* try to compile it */
2922 PL_eval_root = NULL;
2923 PL_curcop = &PL_compiling;
2924 CopARYBASE_set(PL_curcop, 0);
2925 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2926 PL_in_eval |= EVAL_KEEPERR;
2928 sv_setpvn(ERRSV,"",0);
2929 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
2930 SV **newsp; /* Used by POPBLOCK. */
2931 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2932 I32 optype = 0; /* Might be reset by POPEVAL. */
2937 op_free(PL_eval_root);
2938 PL_eval_root = NULL;
2940 SP = PL_stack_base + POPMARK; /* pop original mark */
2942 POPBLOCK(cx,PL_curpm);
2948 msg = SvPVx_nolen_const(ERRSV);
2949 if (optype == OP_REQUIRE) {
2950 const SV * const nsv = cx->blk_eval.old_namesv;
2951 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2953 Perl_croak(aTHX_ "%sCompilation failed in require",
2954 *msg ? msg : "Unknown error\n");
2957 POPBLOCK(cx,PL_curpm);
2959 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2960 (*msg ? msg : "Unknown error\n"));
2964 sv_setpvs(ERRSV, "Compilation error");
2967 PERL_UNUSED_VAR(newsp);
2968 PUSHs(&PL_sv_undef);
2972 CopLINE_set(&PL_compiling, 0);
2974 *startop = PL_eval_root;
2976 SAVEFREEOP(PL_eval_root);
2978 /* Set the context for this new optree.
2979 * If the last op is an OP_REQUIRE, force scalar context.
2980 * Otherwise, propagate the context from the eval(). */
2981 if (PL_eval_root->op_type == OP_LEAVEEVAL
2982 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2983 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2985 scalar(PL_eval_root);
2986 else if (gimme & G_VOID)
2987 scalarvoid(PL_eval_root);
2988 else if (gimme & G_ARRAY)
2991 scalar(PL_eval_root);
2993 DEBUG_x(dump_eval());
2995 /* Register with debugger: */
2996 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
2997 CV * const cv = get_cv("DB::postponed", FALSE);
3001 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3003 call_sv((SV*)cv, G_DISCARD);
3008 call_list(PL_scopestack_ix, PL_unitcheckav);
3010 /* compiled okay, so do it */
3012 CvDEPTH(PL_compcv) = 1;
3013 SP = PL_stack_base + POPMARK; /* pop original mark */
3014 PL_op = saveop; /* The caller may need it. */
3015 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3022 S_check_type_and_open(pTHX_ const char *name)
3025 const int st_rc = PerlLIO_stat(name, &st);
3027 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3031 return PerlIO_open(name, PERL_SCRIPT_MODE);
3034 #ifndef PERL_DISABLE_PMC
3036 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3040 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3041 SV *const pmcsv = newSV(namelen + 2);
3042 char *const pmc = SvPVX(pmcsv);
3045 memcpy(pmc, name, namelen);
3047 pmc[namelen + 1] = '\0';
3049 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3050 fp = check_type_and_open(name);
3053 fp = check_type_and_open(pmc);
3055 SvREFCNT_dec(pmcsv);
3058 fp = check_type_and_open(name);
3063 # define doopen_pm(name, namelen) check_type_and_open(name)
3064 #endif /* !PERL_DISABLE_PMC */
3069 register PERL_CONTEXT *cx;
3076 int vms_unixname = 0;
3078 const char *tryname = NULL;
3080 const I32 gimme = GIMME_V;
3081 int filter_has_file = 0;
3082 PerlIO *tryrsfp = NULL;
3083 SV *filter_cache = NULL;
3084 SV *filter_state = NULL;
3085 SV *filter_sub = NULL;
3091 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3092 sv = new_version(sv);
3093 if (!sv_derived_from(PL_patchlevel, "version"))
3094 upg_version(PL_patchlevel, TRUE);
3095 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3096 if ( vcmp(sv,PL_patchlevel) <= 0 )
3097 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3098 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3101 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3104 SV * const req = SvRV(sv);
3105 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3107 /* get the left hand term */
3108 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3110 first = SvIV(*av_fetch(lav,0,0));
3111 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3112 || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3113 || av_len(lav) > 1 /* FP with > 3 digits */
3114 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3116 DIE(aTHX_ "Perl %"SVf" required--this is only "
3117 "%"SVf", stopped", SVfARG(vnormal(req)),
3118 SVfARG(vnormal(PL_patchlevel)));
3120 else { /* probably 'use 5.10' or 'use 5.8' */
3121 SV * hintsv = newSV(0);
3125 second = SvIV(*av_fetch(lav,1,0));
3127 second /= second >= 600 ? 100 : 10;
3128 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3129 (int)first, (int)second,0);
3130 upg_version(hintsv, TRUE);
3132 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3133 "--this is only %"SVf", stopped",
3134 SVfARG(vnormal(req)),
3135 SVfARG(vnormal(hintsv)),
3136 SVfARG(vnormal(PL_patchlevel)));
3141 /* We do this only with use, not require. */
3143 /* If we request a version >= 5.9.5, load feature.pm with the
3144 * feature bundle that corresponds to the required version. */
3145 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3146 SV *const importsv = vnormal(sv);
3147 *SvPVX_mutable(importsv) = ':';
3149 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3155 name = SvPV_const(sv, len);
3156 if (!(name && len > 0 && *name))
3157 DIE(aTHX_ "Null filename used");
3158 TAINT_PROPER("require");
3162 /* The key in the %ENV hash is in the syntax of file passed as the argument
3163 * usually this is in UNIX format, but sometimes in VMS format, which
3164 * can result in a module being pulled in more than once.
3165 * To prevent this, the key must be stored in UNIX format if the VMS
3166 * name can be translated to UNIX.
3168 if ((unixname = tounixspec(name, NULL)) != NULL) {
3169 unixlen = strlen(unixname);
3175 /* if not VMS or VMS name can not be translated to UNIX, pass it
3178 unixname = (char *) name;
3181 if (PL_op->op_type == OP_REQUIRE) {
3182 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3183 unixname, unixlen, 0);
3185 if (*svp != &PL_sv_undef)
3188 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3189 "Compilation failed in require", unixname);
3193 /* prepare to compile file */
3195 if (path_is_absolute(name)) {
3197 tryrsfp = doopen_pm(name, len);
3199 #ifdef MACOS_TRADITIONAL
3203 MacPerl_CanonDir(name, newname, 1);
3204 if (path_is_absolute(newname)) {
3206 tryrsfp = doopen_pm(newname, strlen(newname));
3211 AV * const ar = GvAVn(PL_incgv);
3217 namesv = newSV_type(SVt_PV);
3218 for (i = 0; i <= AvFILL(ar); i++) {
3219 SV * const dirsv = *av_fetch(ar, i, TRUE);
3221 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3228 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3229 && !sv_isobject(loader))
3231 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3234 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3235 PTR2UV(SvRV(dirsv)), name);
3236 tryname = SvPVX_const(namesv);
3247 if (sv_isobject(loader))
3248 count = call_method("INC", G_ARRAY);
3250 count = call_sv(loader, G_ARRAY);
3253 /* Adjust file name if the hook has set an %INC entry */
3254 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3256 tryname = SvPVX_const(*svp);
3265 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3266 && !isGV_with_GP(SvRV(arg))) {
3267 filter_cache = SvRV(arg);
3268 SvREFCNT_inc_simple_void_NN(filter_cache);
3275 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3279 if (SvTYPE(arg) == SVt_PVGV) {
3280 IO * const io = GvIO((GV *)arg);
3285 tryrsfp = IoIFP(io);
3286 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3287 PerlIO_close(IoOFP(io));
3298 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3300 SvREFCNT_inc_simple_void_NN(filter_sub);
3303 filter_state = SP[i];
3304 SvREFCNT_inc_simple_void(filter_state);
3308 if (!tryrsfp && (filter_cache || filter_sub)) {
3309 tryrsfp = PerlIO_open(BIT_BUCKET,
3324 filter_has_file = 0;
3326 SvREFCNT_dec(filter_cache);
3327 filter_cache = NULL;
3330 SvREFCNT_dec(filter_state);
3331 filter_state = NULL;
3334 SvREFCNT_dec(filter_sub);
3339 if (!path_is_absolute(name)
3340 #ifdef MACOS_TRADITIONAL
3341 /* We consider paths of the form :a:b ambiguous and interpret them first
3342 as global then as local
3344 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3351 dir = SvPV_const(dirsv, dirlen);
3357 #ifdef MACOS_TRADITIONAL
3361 MacPerl_CanonDir(name, buf2, 1);
3362 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3366 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3368 sv_setpv(namesv, unixdir);
3369 sv_catpv(namesv, unixname);
3371 # ifdef __SYMBIAN32__
3372 if (PL_origfilename[0] &&
3373 PL_origfilename[1] == ':' &&
3374 !(dir[0] && dir[1] == ':'))
3375 Perl_sv_setpvf(aTHX_ namesv,
3380 Perl_sv_setpvf(aTHX_ namesv,
3384 /* The equivalent of
3385 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3386 but without the need to parse the format string, or
3387 call strlen on either pointer, and with the correct
3388 allocation up front. */
3390 char *tmp = SvGROW(namesv, dirlen + len + 2);
3392 memcpy(tmp, dir, dirlen);
3395 /* name came from an SV, so it will have a '\0' at the
3396 end that we can copy as part of this memcpy(). */
3397 memcpy(tmp, name, len + 1);
3399 SvCUR_set(namesv, dirlen + len + 1);
3401 /* Don't even actually have to turn SvPOK_on() as we
3402 access it directly with SvPVX() below. */
3407 TAINT_PROPER("require");
3408 tryname = SvPVX_const(namesv);
3409 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3411 if (tryname[0] == '.' && tryname[1] == '/')
3415 else if (errno == EMFILE)
3416 /* no point in trying other paths if out of handles */
3423 SAVECOPFILE_FREE(&PL_compiling);
3424 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3425 SvREFCNT_dec(namesv);
3427 if (PL_op->op_type == OP_REQUIRE) {
3428 const char *msgstr = name;
3429 if(errno == EMFILE) {
3431 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3433 msgstr = SvPV_nolen_const(msg);
3435 if (namesv) { /* did we lookup @INC? */
3436 AV * const ar = GvAVn(PL_incgv);
3438 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3439 "%s in @INC%s%s (@INC contains:",
3441 (instr(msgstr, ".h ")
3442 ? " (change .h to .ph maybe?)" : ""),
3443 (instr(msgstr, ".ph ")
3444 ? " (did you run h2ph?)" : "")
3447 for (i = 0; i <= AvFILL(ar); i++) {
3448 sv_catpvs(msg, " ");
3449 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3451 sv_catpvs(msg, ")");
3452 msgstr = SvPV_nolen_const(msg);
3455 DIE(aTHX_ "Can't locate %s", msgstr);
3461 SETERRNO(0, SS_NORMAL);
3463 /* Assume success here to prevent recursive requirement. */
3464 /* name is never assigned to again, so len is still strlen(name) */
3465 /* Check whether a hook in @INC has already filled %INC */
3467 (void)hv_store(GvHVn(PL_incgv),
3468 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3470 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3472 (void)hv_store(GvHVn(PL_incgv),
3473 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3478 lex_start(NULL, tryrsfp, TRUE);
3482 SAVECOMPILEWARNINGS();
3483 if (PL_dowarn & G_WARN_ALL_ON)
3484 PL_compiling.cop_warnings = pWARN_ALL ;
3485 else if (PL_dowarn & G_WARN_ALL_OFF)
3486 PL_compiling.cop_warnings = pWARN_NONE ;
3488 PL_compiling.cop_warnings = pWARN_STD ;
3490 if (filter_sub || filter_cache) {
3491 SV * const datasv = filter_add(S_run_user_filter, NULL);
3492 IoLINES(datasv) = filter_has_file;
3493 IoTOP_GV(datasv) = (GV *)filter_state;
3494 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3495 IoFMT_GV(datasv) = (GV *)filter_cache;
3498 /* switch to eval mode */
3499 PUSHBLOCK(cx, CXt_EVAL, SP);
3500 PUSHEVAL(cx, name, NULL);
3501 cx->blk_eval.retop = PL_op->op_next;
3503 SAVECOPLINE(&PL_compiling);
3504 CopLINE_set(&PL_compiling, 0);
3508 /* Store and reset encoding. */
3509 encoding = PL_encoding;
3512 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3513 op = DOCATCH(PL_eval_start);
3515 op = PL_op->op_next;
3517 /* Restore encoding. */
3518 PL_encoding = encoding;
3526 register PERL_CONTEXT *cx;
3528 const I32 gimme = GIMME_V;
3529 const I32 was = PL_sub_generation;
3530 char tbuf[TYPE_DIGITS(long) + 12];
3531 char *tmpbuf = tbuf;
3537 HV *saved_hh = NULL;
3538 const char * const fakestr = "_<(eval )";
3539 const int fakelen = 9 + 1;
3541 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3542 saved_hh = (HV*) SvREFCNT_inc(POPs);
3546 TAINT_IF(SvTAINTED(sv));
3547 TAINT_PROPER("eval");
3550 lex_start(sv, NULL, FALSE);
3553 /* switch to eval mode */
3555 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3556 SV * const temp_sv = sv_newmortal();
3557 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3558 (unsigned long)++PL_evalseq,
3559 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3560 tmpbuf = SvPVX(temp_sv);
3561 len = SvCUR(temp_sv);
3564 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3565 SAVECOPFILE_FREE(&PL_compiling);
3566 CopFILE_set(&PL_compiling, tmpbuf+2);
3567 SAVECOPLINE(&PL_compiling);
3568 CopLINE_set(&PL_compiling, 1);
3569 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3570 deleting the eval's FILEGV from the stash before gv_check() runs
3571 (i.e. before run-time proper). To work around the coredump that
3572 ensues, we always turn GvMULTI_on for any globals that were
3573 introduced within evals. See force_ident(). GSAR 96-10-12 */
3574 safestr = savepvn(tmpbuf, len);
3575 SAVEDELETE(PL_defstash, safestr, len);
3577 PL_hints = PL_op->op_targ;
3579 GvHV(PL_hintgv) = saved_hh;
3580 SAVECOMPILEWARNINGS();
3581 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3582 if (PL_compiling.cop_hints_hash) {
3583 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3585 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3586 if (PL_compiling.cop_hints_hash) {
3588 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3589 HINTS_REFCNT_UNLOCK;
3591 /* special case: an eval '' executed within the DB package gets lexically
3592 * placed in the first non-DB CV rather than the current CV - this
3593 * allows the debugger to execute code, find lexicals etc, in the
3594 * scope of the code being debugged. Passing &seq gets find_runcv
3595 * to do the dirty work for us */
3596 runcv = find_runcv(&seq);
3598 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3599 PUSHEVAL(cx, 0, NULL);
3600 cx->blk_eval.retop = PL_op->op_next;
3602 /* prepare to compile string */
3604 if (PERLDB_LINE && PL_curstash != PL_debstash)
3605 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3607 ok = doeval(gimme, NULL, runcv, seq);
3608 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3610 /* Copy in anything fake and short. */
3611 my_strlcpy(safestr, fakestr, fakelen);
3613 return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3623 register PERL_CONTEXT *cx;
3625 const U8 save_flags = PL_op -> op_flags;
3630 retop = cx->blk_eval.retop;
3633 if (gimme == G_VOID)
3635 else if (gimme == G_SCALAR) {
3638 if (SvFLAGS(TOPs) & SVs_TEMP)
3641 *MARK = sv_mortalcopy(TOPs);
3645 *MARK = &PL_sv_undef;
3650 /* in case LEAVE wipes old return values */
3651 for (mark = newsp + 1; mark <= SP; mark++) {
3652 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3653 *mark = sv_mortalcopy(*mark);
3654 TAINT_NOT; /* Each item is independent */
3658 PL_curpm = newpm; /* Don't pop $1 et al till now */
3661 assert(CvDEPTH(PL_compcv) == 1);
3663 CvDEPTH(PL_compcv) = 0;
3666 if (optype == OP_REQUIRE &&
3667 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3669 /* Unassume the success we assumed earlier. */
3670 SV * const nsv = cx->blk_eval.old_namesv;
3671 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3672 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3673 /* die_where() did LEAVE, or we won't be here */
3677 if (!(save_flags & OPf_SPECIAL))
3678 sv_setpvn(ERRSV,"",0);
3684 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3685 close to the related Perl_create_eval_scope. */
3687 Perl_delete_eval_scope(pTHX)
3692 register PERL_CONTEXT *cx;
3699 PERL_UNUSED_VAR(newsp);
3700 PERL_UNUSED_VAR(gimme);
3701 PERL_UNUSED_VAR(optype);
3704 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3705 also needed by Perl_fold_constants. */
3707 Perl_create_eval_scope(pTHX_ U32 flags)
3710 const I32 gimme = GIMME_V;
3715 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3718 PL_in_eval = EVAL_INEVAL;
3719 if (flags & G_KEEPERR)
3720 PL_in_eval |= EVAL_KEEPERR;
3722 sv_setpvn(ERRSV,"",0);
3723 if (flags & G_FAKINGEVAL) {
3724 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3732 PERL_CONTEXT * const cx = create_eval_scope(0);
3733 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3734 return DOCATCH(PL_op->op_next);
3743 register PERL_CONTEXT *cx;
3748 PERL_UNUSED_VAR(optype);
3751 if (gimme == G_VOID)
3753 else if (gimme == G_SCALAR) {
3757 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3760 *MARK = sv_mortalcopy(TOPs);
3764 *MARK = &PL_sv_undef;
3769 /* in case LEAVE wipes old return values */
3771 for (mark = newsp + 1; mark <= SP; mark++) {
3772 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3773 *mark = sv_mortalcopy(*mark);
3774 TAINT_NOT; /* Each item is independent */
3778 PL_curpm = newpm; /* Don't pop $1 et al till now */
3781 sv_setpvn(ERRSV,"",0);
3788 register PERL_CONTEXT *cx;
3789 const I32 gimme = GIMME_V;
3794 if (PL_op->op_targ == 0) {
3795 SV ** const defsv_p = &GvSV(PL_defgv);
3796 *defsv_p = newSVsv(POPs);
3797 SAVECLEARSV(*defsv_p);
3800 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3802 PUSHBLOCK(cx, CXt_GIVEN, SP);
3811 register PERL_CONTEXT *cx;
3815 PERL_UNUSED_CONTEXT;
3818 assert(CxTYPE(cx) == CXt_GIVEN);
3823 PL_curpm = newpm; /* pop $1 et al */
3830 /* Helper routines used by pp_smartmatch */
3832 S_make_matcher(pTHX_ REGEXP *re)
3835 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3836 PM_SETRE(matcher, ReREFCNT_inc(re));
3838 SAVEFREEOP((OP *) matcher);
3845 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3850 PL_op = (OP *) matcher;
3855 return (SvTRUEx(POPs));
3859 S_destroy_matcher(pTHX_ PMOP *matcher)
3862 PERL_UNUSED_ARG(matcher);
3867 /* Do a smart match */
3870 return do_smartmatch(NULL, NULL);
3873 /* This version of do_smartmatch() implements the
3874 * table of smart matches that is found in perlsyn.
3877 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3882 SV *e = TOPs; /* e is for 'expression' */
3883 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3884 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3885 REGEXP *this_regex, *other_regex;
3887 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3889 # define SM_REF(type) ( \
3890 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3891 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3893 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3894 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
3895 && NOT_EMPTY_PROTO(This) && (Other = e)) \
3896 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
3897 && NOT_EMPTY_PROTO(This) && (Other = d)))
3899 # define SM_REGEX ( \
3900 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \
3901 && (this_regex = (REGEXP*) This) \
3904 (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \
3905 && (this_regex = (REGEXP*) This) \
3909 # define SM_OTHER_REF(type) \
3910 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3912 # define SM_OTHER_REGEX (SvROK(Other) \
3913 && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \
3914 && (other_regex = (REGEXP*) SvRV(Other)))
3917 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3918 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3920 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3921 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3923 tryAMAGICbinSET(smart, 0);
3925 SP -= 2; /* Pop the values */
3927 /* Take care only to invoke mg_get() once for each argument.
3928 * Currently we do this by copying the SV if it's magical. */
3931 d = sv_mortalcopy(d);
3938 e = sv_mortalcopy(e);
3943 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3945 if (This == SvRV(Other))
3956 c = call_sv(This, G_SCALAR);
3960 else if (SvTEMP(TOPs))
3961 SvREFCNT_inc_void(TOPs);
3966 else if (SM_REF(PVHV)) {
3967 if (SM_OTHER_REF(PVHV)) {
3968 /* Check that the key-sets are identical */
3970 HV *other_hv = (HV *) SvRV(Other);
3972 bool other_tied = FALSE;
3973 U32 this_key_count = 0,
3974 other_key_count = 0;
3976 /* Tied hashes don't know how many keys they have. */
3977 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
3980 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3981 HV * const temp = other_hv;
3982 other_hv = (HV *) This;
3986 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3989 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
3992 /* The hashes have the same number of keys, so it suffices
3993 to check that one is a subset of the other. */
3994 (void) hv_iterinit((HV *) This);
3995 while ( (he = hv_iternext((HV *) This)) ) {
3997 char * const key = hv_iterkey(he, &key_len);
4001 if(!hv_exists(other_hv, key, key_len)) {
4002 (void) hv_iterinit((HV *) This); /* reset iterator */
4008 (void) hv_iterinit(other_hv);
4009 while ( hv_iternext(other_hv) )
4013 other_key_count = HvUSEDKEYS(other_hv);
4015 if (this_key_count != other_key_count)
4020 else if (SM_OTHER_REF(PVAV)) {
4021 AV * const other_av = (AV *) SvRV(Other);
4022 const I32 other_len = av_len(other_av) + 1;
4025 for (i = 0; i < other_len; ++i) {
4026 SV ** const svp = av_fetch(other_av, i, FALSE);
4030 if (svp) { /* ??? When can this not happen? */
4031 key = SvPV(*svp, key_len);
4032 if (hv_exists((HV *) This, key, key_len))
4038 else if (SM_OTHER_REGEX) {
4039 PMOP * const matcher = make_matcher(other_regex);
4042 (void) hv_iterinit((HV *) This);
4043 while ( (he = hv_iternext((HV *) This)) ) {
4044 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4045 (void) hv_iterinit((HV *) This);
4046 destroy_matcher(matcher);
4050 destroy_matcher(matcher);
4054 if (hv_exists_ent((HV *) This, Other, 0))
4060 else if (SM_REF(PVAV)) {
4061 if (SM_OTHER_REF(PVAV)) {
4062 AV *other_av = (AV *) SvRV(Other);
4063 if (av_len((AV *) This) != av_len(other_av))
4067 const I32 other_len = av_len(other_av);
4069 if (NULL == seen_this) {
4070 seen_this = newHV();
4071 (void) sv_2mortal((SV *) seen_this);
4073 if (NULL == seen_other) {
4074 seen_this = newHV();
4075 (void) sv_2mortal((SV *) seen_other);
4077 for(i = 0; i <= other_len; ++i) {
4078 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4079 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4081 if (!this_elem || !other_elem) {
4082 if (this_elem || other_elem)
4085 else if (SM_SEEN_THIS(*this_elem)
4086 || SM_SEEN_OTHER(*other_elem))
4088 if (*this_elem != *other_elem)
4092 (void)hv_store_ent(seen_this,
4093 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4095 (void)hv_store_ent(seen_other,
4096 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4102 (void) do_smartmatch(seen_this, seen_other);
4112 else if (SM_OTHER_REGEX) {
4113 PMOP * const matcher = make_matcher(other_regex);
4114 const I32 this_len = av_len((AV *) This);
4117 for(i = 0; i <= this_len; ++i) {
4118 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4119 if (svp && matcher_matches_sv(matcher, *svp)) {
4120 destroy_matcher(matcher);
4124 destroy_matcher(matcher);
4127 else if (SvIOK(Other) || SvNOK(Other)) {
4130 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4131 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4138 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4148 else if (SvPOK(Other)) {
4149 const I32 this_len = av_len((AV *) This);
4152 for(i = 0; i <= this_len; ++i) {
4153 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4168 else if (!SvOK(d) || !SvOK(e)) {
4169 if (!SvOK(d) && !SvOK(e))
4174 else if (SM_REGEX) {
4175 PMOP * const matcher = make_matcher(this_regex);
4178 PUSHs(matcher_matches_sv(matcher, Other)
4181 destroy_matcher(matcher);
4184 else if (SM_REF(PVCV)) {
4186 /* This must be a null-prototyped sub, because we
4187 already checked for the other kind. */
4193 c = call_sv(This, G_SCALAR);
4196 PUSHs(&PL_sv_undef);
4197 else if (SvTEMP(TOPs))
4198 SvREFCNT_inc_void(TOPs);
4200 if (SM_OTHER_REF(PVCV)) {
4201 /* This one has to be null-proto'd too.
4202 Call both of 'em, and compare the results */
4204 c = call_sv(SvRV(Other), G_SCALAR);
4207 PUSHs(&PL_sv_undef);
4208 else if (SvTEMP(TOPs))
4209 SvREFCNT_inc_void(TOPs);
4220 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4221 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4223 if (SvPOK(Other) && !looks_like_number(Other)) {
4224 /* String comparison */
4229 /* Otherwise, numeric comparison */
4232 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4243 /* As a last resort, use string comparison */
4252 register PERL_CONTEXT *cx;
4253 const I32 gimme = GIMME_V;
4255 /* This is essentially an optimization: if the match
4256 fails, we don't want to push a context and then
4257 pop it again right away, so we skip straight
4258 to the op that follows the leavewhen.
4260 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4261 return cLOGOP->op_other->op_next;
4266 PUSHBLOCK(cx, CXt_WHEN, SP);
4275 register PERL_CONTEXT *cx;
4281 assert(CxTYPE(cx) == CXt_WHEN);
4286 PL_curpm = newpm; /* pop $1 et al */
4296 register PERL_CONTEXT *cx;
4299 cxix = dopoptowhen(cxstack_ix);
4301 DIE(aTHX_ "Can't \"continue\" outside a when block");
4302 if (cxix < cxstack_ix)
4305 /* clear off anything above the scope we're re-entering */
4306 inner = PL_scopestack_ix;
4308 if (PL_scopestack_ix < inner)
4309 leave_scope(PL_scopestack[PL_scopestack_ix]);
4310 PL_curcop = cx->blk_oldcop;
4311 return cx->blk_givwhen.leave_op;
4318 register PERL_CONTEXT *cx;
4321 cxix = dopoptogiven(cxstack_ix);
4323 if (PL_op->op_flags & OPf_SPECIAL)
4324 DIE(aTHX_ "Can't use when() outside a topicalizer");
4326 DIE(aTHX_ "Can't \"break\" outside a given block");
4328 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4329 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4331 if (cxix < cxstack_ix)
4334 /* clear off anything above the scope we're re-entering */
4335 inner = PL_scopestack_ix;
4337 if (PL_scopestack_ix < inner)
4338 leave_scope(PL_scopestack[PL_scopestack_ix]);
4339 PL_curcop = cx->blk_oldcop;
4342 return CX_LOOP_NEXTOP_GET(cx);
4344 return cx->blk_givwhen.leave_op;
4348 S_doparseform(pTHX_ SV *sv)
4351 register char *s = SvPV_force(sv, len);
4352 register char * const send = s + len;
4353 register char *base = NULL;
4354 register I32 skipspaces = 0;
4355 bool noblank = FALSE;
4356 bool repeat = FALSE;
4357 bool postspace = FALSE;
4363 bool unchopnum = FALSE;
4364 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4367 Perl_croak(aTHX_ "Null picture in formline");
4369 /* estimate the buffer size needed */
4370 for (base = s; s <= send; s++) {
4371 if (*s == '\n' || *s == '@' || *s == '^')
4377 Newx(fops, maxops, U32);
4382 *fpc++ = FF_LINEMARK;
4383 noblank = repeat = FALSE;
4401 case ' ': case '\t':
4408 } /* else FALL THROUGH */
4416 *fpc++ = FF_LITERAL;
4424 *fpc++ = (U16)skipspaces;
4428 *fpc++ = FF_NEWLINE;
4432 arg = fpc - linepc + 1;
4439 *fpc++ = FF_LINEMARK;
4440 noblank = repeat = FALSE;
4449 ischop = s[-1] == '^';
4455 arg = (s - base) - 1;
4457 *fpc++ = FF_LITERAL;
4465 *fpc++ = 2; /* skip the @* or ^* */
4467 *fpc++ = FF_LINESNGL;
4470 *fpc++ = FF_LINEGLOB;
4472 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4473 arg = ischop ? 512 : 0;
4478 const char * const f = ++s;
4481 arg |= 256 + (s - f);
4483 *fpc++ = s - base; /* fieldsize for FETCH */
4484 *fpc++ = FF_DECIMAL;
4486 unchopnum |= ! ischop;
4488 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4489 arg = ischop ? 512 : 0;
4491 s++; /* skip the '0' first */
4495 const char * const f = ++s;
4498 arg |= 256 + (s - f);
4500 *fpc++ = s - base; /* fieldsize for FETCH */
4501 *fpc++ = FF_0DECIMAL;
4503 unchopnum |= ! ischop;
4507 bool ismore = FALSE;
4510 while (*++s == '>') ;
4511 prespace = FF_SPACE;
4513 else if (*s == '|') {
4514 while (*++s == '|') ;
4515 prespace = FF_HALFSPACE;
4520 while (*++s == '<') ;
4523 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4527 *fpc++ = s - base; /* fieldsize for FETCH */
4529 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4532 *fpc++ = (U16)prespace;
4546 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4548 { /* need to jump to the next word */
4550 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4551 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4552 s = SvPVX(sv) + SvCUR(sv) + z;
4554 Copy(fops, s, arg, U32);
4556 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4559 if (unchopnum && repeat)
4560 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4566 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4568 /* Can value be printed in fldsize chars, using %*.*f ? */
4572 int intsize = fldsize - (value < 0 ? 1 : 0);
4579 while (intsize--) pwr *= 10.0;
4580 while (frcsize--) eps /= 10.0;
4583 if (value + eps >= pwr)
4586 if (value - eps <= -pwr)
4593 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4596 SV * const datasv = FILTER_DATA(idx);
4597 const int filter_has_file = IoLINES(datasv);
4598 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4599 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4603 const char *got_p = NULL;
4604 const char *prune_from = NULL;
4605 bool read_from_cache = FALSE;
4608 assert(maxlen >= 0);
4611 /* I was having segfault trouble under Linux 2.2.5 after a
4612 parse error occured. (Had to hack around it with a test
4613 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4614 not sure where the trouble is yet. XXX */
4616 if (IoFMT_GV(datasv)) {
4617 SV *const cache = (SV *)IoFMT_GV(datasv);
4620 const char *cache_p = SvPV(cache, cache_len);
4624 /* Running in block mode and we have some cached data already.
4626 if (cache_len >= umaxlen) {
4627 /* In fact, so much data we don't even need to call
4632 const char *const first_nl =
4633 (const char *)memchr(cache_p, '\n', cache_len);
4635 take = first_nl + 1 - cache_p;
4639 sv_catpvn(buf_sv, cache_p, take);
4640 sv_chop(cache, cache_p + take);
4641 /* Definately not EOF */
4645 sv_catsv(buf_sv, cache);
4647 umaxlen -= cache_len;
4650 read_from_cache = TRUE;
4654 /* Filter API says that the filter appends to the contents of the buffer.
4655 Usually the buffer is "", so the details don't matter. But if it's not,
4656 then clearly what it contains is already filtered by this filter, so we
4657 don't want to pass it in a second time.
4658 I'm going to use a mortal in case the upstream filter croaks. */
4659 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4660 ? sv_newmortal() : buf_sv;
4661 SvUPGRADE(upstream, SVt_PV);
4663 if (filter_has_file) {
4664 status = FILTER_READ(idx+1, upstream, 0);
4667 if (filter_sub && status >= 0) {
4680 PUSHs(filter_state);
4683 count = call_sv(filter_sub, G_SCALAR);
4698 if(SvOK(upstream)) {
4699 got_p = SvPV(upstream, got_len);
4701 if (got_len > umaxlen) {
4702 prune_from = got_p + umaxlen;
4705 const char *const first_nl =
4706 (const char *)memchr(got_p, '\n', got_len);
4707 if (first_nl && first_nl + 1 < got_p + got_len) {
4708 /* There's a second line here... */
4709 prune_from = first_nl + 1;
4714 /* Oh. Too long. Stuff some in our cache. */
4715 STRLEN cached_len = got_p + got_len - prune_from;
4716 SV *cache = (SV *)IoFMT_GV(datasv);
4719 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4720 } else if (SvOK(cache)) {
4721 /* Cache should be empty. */
4722 assert(!SvCUR(cache));
4725 sv_setpvn(cache, prune_from, cached_len);
4726 /* If you ask for block mode, you may well split UTF-8 characters.
4727 "If it breaks, you get to keep both parts"
4728 (Your code is broken if you don't put them back together again
4729 before something notices.) */
4730 if (SvUTF8(upstream)) {
4733 SvCUR_set(upstream, got_len - cached_len);
4734 /* Can't yet be EOF */
4739 /* If they are at EOF but buf_sv has something in it, then they may never
4740 have touched the SV upstream, so it may be undefined. If we naively
4741 concatenate it then we get a warning about use of uninitialised value.
4743 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4744 sv_catsv(buf_sv, upstream);
4748 IoLINES(datasv) = 0;
4749 SvREFCNT_dec(IoFMT_GV(datasv));
4751 SvREFCNT_dec(filter_state);
4752 IoTOP_GV(datasv) = NULL;
4755 SvREFCNT_dec(filter_sub);
4756 IoBOTTOM_GV(datasv) = NULL;
4758 filter_del(S_run_user_filter);
4760 if (status == 0 && read_from_cache) {
4761 /* If we read some data from the cache (and by getting here it implies
4762 that we emptied the cache) then we aren't yet at EOF, and mustn't
4763 report that to our caller. */
4769 /* perhaps someone can come up with a better name for
4770 this? it is not really "absolute", per se ... */
4772 S_path_is_absolute(const char *name)
4774 if (PERL_FILE_IS_ABSOLUTE(name)
4775 #ifdef MACOS_TRADITIONAL
4778 || (*name == '.' && (name[1] == '/' ||
4779 (name[1] == '.' && name[2] == '/')))
4791 * c-indentation-style: bsd
4793 * indent-tabs-mode: t
4796 * ex: set ts=8 sts=4 sw=4 noet: