3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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))
47 cxix = dopoptosub(cxstack_ix);
51 switch (cxstack[cxix].blk_gimme) {
63 /* XXXX Should store the old value to allow for tie/overload - and
64 restore in regcomp, where marked with XXXX. */
73 register PMOP *pm = (PMOP*)cLOGOP->op_other;
75 MAGIC *mg = Null(MAGIC*);
77 /* prevent recompiling under /o and ithreads. */
78 #if defined(USE_ITHREADS)
79 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
80 if (PL_op->op_flags & OPf_STACKED) {
89 if (PL_op->op_flags & OPf_STACKED) {
90 /* multiple args; concatentate them */
92 tmpstr = PAD_SV(ARGTARG);
93 sv_setpvn(tmpstr, "", 0);
94 while (++MARK <= SP) {
95 if (PL_amagic_generation) {
97 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
98 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
100 sv_setsv(tmpstr, sv);
104 sv_catsv(tmpstr, *MARK);
113 SV *sv = SvRV(tmpstr);
115 mg = mg_find(sv, PERL_MAGIC_qr);
118 regexp * const re = (regexp *)mg->mg_obj;
119 ReREFCNT_dec(PM_GETRE(pm));
120 PM_SETRE(pm, ReREFCNT_inc(re));
124 const char *t = SvPV_const(tmpstr, len);
126 /* Check against the last compiled regexp. */
127 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
128 PM_GETRE(pm)->prelen != (I32)len ||
129 memNE(PM_GETRE(pm)->precomp, t, len))
132 ReREFCNT_dec(PM_GETRE(pm));
133 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
135 if (PL_op->op_flags & OPf_SPECIAL)
136 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
138 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
140 pm->op_pmdynflags |= PMdf_DYN_UTF8;
142 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
143 if (pm->op_pmdynflags & PMdf_UTF8)
144 t = (char*)bytes_to_utf8((U8*)t, &len);
146 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm));
147 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
149 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
150 inside tie/overload accessors. */
154 #ifndef INCOMPLETE_TAINTS
157 pm->op_pmdynflags |= PMdf_TAINTED;
159 pm->op_pmdynflags &= ~PMdf_TAINTED;
163 if (!PM_GETRE(pm)->prelen && PL_curpm)
165 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
166 pm->op_pmflags |= PMf_WHITE;
168 pm->op_pmflags &= ~PMf_WHITE;
170 /* XXX runtime compiled output needs to move to the pad */
171 if (pm->op_pmflags & PMf_KEEP) {
172 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
173 #if !defined(USE_ITHREADS)
174 /* XXX can't change the optree at runtime either */
175 cLOGOP->op_first->op_next = PL_op->op_next;
184 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
185 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
186 register SV * const dstr = cx->sb_dstr;
187 register char *s = cx->sb_s;
188 register char *m = cx->sb_m;
189 char *orig = cx->sb_orig;
190 register REGEXP * const rx = cx->sb_rx;
192 REGEXP *old = PM_GETRE(pm);
199 rxres_restore(&cx->sb_rxres, rx);
200 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
202 if (cx->sb_iters++) {
203 const I32 saviters = cx->sb_iters;
204 if (cx->sb_iters > cx->sb_maxiters)
205 DIE(aTHX_ "Substitution loop");
207 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
208 cx->sb_rxtainted |= 2;
209 sv_catsv(dstr, POPs);
210 FREETMPS; /* Prevent excess tmp stack */
213 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
214 s == m, cx->sb_targ, NULL,
215 ((cx->sb_rflags & REXEC_COPY_STR)
216 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
217 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
219 SV * const targ = cx->sb_targ;
221 assert(cx->sb_strend >= s);
222 if(cx->sb_strend > s) {
223 if (DO_UTF8(dstr) && !SvUTF8(targ))
224 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
226 sv_catpvn(dstr, s, cx->sb_strend - s);
228 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
230 #ifdef PERL_OLD_COPY_ON_WRITE
232 sv_force_normal_flags(targ, SV_COW_DROP_PV);
238 SvPV_set(targ, SvPVX(dstr));
239 SvCUR_set(targ, SvCUR(dstr));
240 SvLEN_set(targ, SvLEN(dstr));
243 SvPV_set(dstr, (char*)0);
246 TAINT_IF(cx->sb_rxtainted & 1);
247 PUSHs(sv_2mortal(newSViv(saviters - 1)));
249 (void)SvPOK_only_UTF8(targ);
250 TAINT_IF(cx->sb_rxtainted);
254 LEAVE_SCOPE(cx->sb_oldsave);
257 RETURNOP(pm->op_next);
259 cx->sb_iters = saviters;
261 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
264 cx->sb_orig = orig = rx->subbeg;
266 cx->sb_strend = s + (cx->sb_strend - m);
268 cx->sb_m = m = rx->startp[0] + orig;
270 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
271 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
273 sv_catpvn(dstr, s, m-s);
275 cx->sb_s = rx->endp[0] + orig;
276 { /* Update the pos() information. */
277 SV * const sv = cx->sb_targ;
280 if (SvTYPE(sv) < SVt_PVMG)
281 SvUPGRADE(sv, SVt_PVMG);
282 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
283 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
284 mg = mg_find(sv, PERL_MAGIC_regex_global);
292 (void)ReREFCNT_inc(rx);
293 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
294 rxres_save(&cx->sb_rxres, rx);
295 RETURNOP(pm->op_pmreplstart);
299 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
304 if (!p || p[1] < rx->nparens) {
305 #ifdef PERL_OLD_COPY_ON_WRITE
306 i = 7 + rx->nparens * 2;
308 i = 6 + rx->nparens * 2;
317 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : NULL);
318 RX_MATCH_COPIED_off(rx);
320 #ifdef PERL_OLD_COPY_ON_WRITE
321 *p++ = PTR2UV(rx->saved_copy);
322 rx->saved_copy = NULL;
327 *p++ = PTR2UV(rx->subbeg);
328 *p++ = (UV)rx->sublen;
329 for (i = 0; i <= rx->nparens; ++i) {
330 *p++ = (UV)rx->startp[i];
331 *p++ = (UV)rx->endp[i];
336 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
341 RX_MATCH_COPY_FREE(rx);
342 RX_MATCH_COPIED_set(rx, *p);
345 #ifdef PERL_OLD_COPY_ON_WRITE
347 SvREFCNT_dec (rx->saved_copy);
348 rx->saved_copy = INT2PTR(SV*,*p);
354 rx->subbeg = INT2PTR(char*,*p++);
355 rx->sublen = (I32)(*p++);
356 for (i = 0; i <= rx->nparens; ++i) {
357 rx->startp[i] = (I32)(*p++);
358 rx->endp[i] = (I32)(*p++);
363 Perl_rxres_free(pTHX_ void **rsp)
365 UV * const p = (UV*)*rsp;
369 void *tmp = INT2PTR(char*,*p);
372 Poison(*p, 1, sizeof(*p));
374 Safefree(INT2PTR(char*,*p));
376 #ifdef PERL_OLD_COPY_ON_WRITE
378 SvREFCNT_dec (INT2PTR(SV*,p[1]));
388 dSP; dMARK; dORIGMARK;
389 register SV * const tmpForm = *++MARK;
394 register SV *sv = NULL;
395 const char *item = NULL;
399 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
400 const char *chophere = NULL;
401 char *linemark = NULL;
403 bool gotsome = FALSE;
405 const STRLEN fudge = SvPOK(tmpForm)
406 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
407 bool item_is_utf8 = FALSE;
408 bool targ_is_utf8 = FALSE;
410 OP * parseres = NULL;
414 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
415 if (SvREADONLY(tmpForm)) {
416 SvREADONLY_off(tmpForm);
417 parseres = doparseform(tmpForm);
418 SvREADONLY_on(tmpForm);
421 parseres = doparseform(tmpForm);
425 SvPV_force(PL_formtarget, len);
426 if (DO_UTF8(PL_formtarget))
428 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
430 f = SvPV_const(tmpForm, len);
431 /* need to jump to the next word */
432 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
436 const char *name = "???";
439 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
440 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
441 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
442 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
443 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
445 case FF_CHECKNL: name = "CHECKNL"; break;
446 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
447 case FF_SPACE: name = "SPACE"; break;
448 case FF_HALFSPACE: name = "HALFSPACE"; break;
449 case FF_ITEM: name = "ITEM"; break;
450 case FF_CHOP: name = "CHOP"; break;
451 case FF_LINEGLOB: name = "LINEGLOB"; break;
452 case FF_NEWLINE: name = "NEWLINE"; break;
453 case FF_MORE: name = "MORE"; break;
454 case FF_LINEMARK: name = "LINEMARK"; break;
455 case FF_END: name = "END"; break;
456 case FF_0DECIMAL: name = "0DECIMAL"; break;
457 case FF_LINESNGL: name = "LINESNGL"; break;
460 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
462 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
473 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
474 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
476 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
477 t = SvEND(PL_formtarget);
480 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
481 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
483 sv_utf8_upgrade(PL_formtarget);
484 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
485 t = SvEND(PL_formtarget);
505 if (ckWARN(WARN_SYNTAX))
506 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
513 const char *s = item = SvPV_const(sv, len);
516 itemsize = sv_len_utf8(sv);
517 if (itemsize != (I32)len) {
519 if (itemsize > fieldsize) {
520 itemsize = fieldsize;
521 itembytes = itemsize;
522 sv_pos_u2b(sv, &itembytes, 0);
526 send = chophere = s + itembytes;
536 sv_pos_b2u(sv, &itemsize);
540 item_is_utf8 = FALSE;
541 if (itemsize > fieldsize)
542 itemsize = fieldsize;
543 send = chophere = s + itemsize;
557 const char *s = item = SvPV_const(sv, len);
560 itemsize = sv_len_utf8(sv);
561 if (itemsize != (I32)len) {
563 if (itemsize <= fieldsize) {
564 const char *send = chophere = s + itemsize;
577 itemsize = fieldsize;
578 itembytes = itemsize;
579 sv_pos_u2b(sv, &itembytes, 0);
580 send = chophere = s + itembytes;
581 while (s < send || (s == send && isSPACE(*s))) {
591 if (strchr(PL_chopset, *s))
596 itemsize = chophere - item;
597 sv_pos_b2u(sv, &itemsize);
603 item_is_utf8 = FALSE;
604 if (itemsize <= fieldsize) {
605 const char *const send = chophere = s + itemsize;
618 itemsize = fieldsize;
619 send = chophere = s + itemsize;
620 while (s < send || (s == send && isSPACE(*s))) {
630 if (strchr(PL_chopset, *s))
635 itemsize = chophere - item;
641 arg = fieldsize - itemsize;
650 arg = fieldsize - itemsize;
661 const char *s = item;
665 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
667 sv_utf8_upgrade(PL_formtarget);
668 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
669 t = SvEND(PL_formtarget);
673 if (UTF8_IS_CONTINUED(*s)) {
674 STRLEN skip = UTF8SKIP(s);
691 if ( !((*t++ = *s++) & ~31) )
697 if (targ_is_utf8 && !item_is_utf8) {
698 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
700 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
701 for (; t < SvEND(PL_formtarget); t++) {
714 const int ch = *t++ = *s++;
717 if ( !((*t++ = *s++) & ~31) )
726 const char *s = chophere;
744 const char *s = item = SvPV_const(sv, len);
746 if ((item_is_utf8 = DO_UTF8(sv)))
747 itemsize = sv_len_utf8(sv);
749 bool chopped = FALSE;
750 const char *const send = s + len;
752 chophere = s + itemsize;
768 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
770 SvUTF8_on(PL_formtarget);
772 SvCUR_set(sv, chophere - item);
773 sv_catsv(PL_formtarget, sv);
774 SvCUR_set(sv, itemsize);
776 sv_catsv(PL_formtarget, sv);
778 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
779 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
780 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
789 #if defined(USE_LONG_DOUBLE)
790 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
792 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
797 #if defined(USE_LONG_DOUBLE)
798 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
800 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
803 /* If the field is marked with ^ and the value is undefined,
805 if ((arg & 512) && !SvOK(sv)) {
813 /* overflow evidence */
814 if (num_overflow(value, fieldsize, arg)) {
820 /* Formats aren't yet marked for locales, so assume "yes". */
822 STORE_NUMERIC_STANDARD_SET_LOCAL();
823 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
824 RESTORE_NUMERIC_STANDARD();
831 while (t-- > linemark && *t == ' ') ;
839 if (arg) { /* repeat until fields exhausted? */
841 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
842 lines += FmLINES(PL_formtarget);
845 if (strnEQ(linemark, linemark - arg, arg))
846 DIE(aTHX_ "Runaway format");
849 SvUTF8_on(PL_formtarget);
850 FmLINES(PL_formtarget) = lines;
852 RETURNOP(cLISTOP->op_first);
863 const char *s = chophere;
864 const char *send = item + len;
866 while (isSPACE(*s) && (s < send))
871 arg = fieldsize - itemsize;
878 if (strnEQ(s1," ",3)) {
879 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
890 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
892 SvUTF8_on(PL_formtarget);
893 FmLINES(PL_formtarget) += lines;
905 if (PL_stack_base + *PL_markstack_ptr == SP) {
907 if (GIMME_V == G_SCALAR)
908 XPUSHs(sv_2mortal(newSViv(0)));
909 RETURNOP(PL_op->op_next->op_next);
911 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
912 pp_pushmark(); /* push dst */
913 pp_pushmark(); /* push src */
914 ENTER; /* enter outer scope */
917 if (PL_op->op_private & OPpGREP_LEX)
918 SAVESPTR(PAD_SVl(PL_op->op_targ));
921 ENTER; /* enter inner scope */
924 src = PL_stack_base[*PL_markstack_ptr];
926 if (PL_op->op_private & OPpGREP_LEX)
927 PAD_SVl(PL_op->op_targ) = src;
932 if (PL_op->op_type == OP_MAPSTART)
933 pp_pushmark(); /* push top */
934 return ((LOGOP*)PL_op->op_next)->op_other;
940 const I32 gimme = GIMME_V;
941 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
947 /* first, move source pointer to the next item in the source list */
948 ++PL_markstack_ptr[-1];
950 /* if there are new items, push them into the destination list */
951 if (items && gimme != G_VOID) {
952 /* might need to make room back there first */
953 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
954 /* XXX this implementation is very pessimal because the stack
955 * is repeatedly extended for every set of items. Is possible
956 * to do this without any stack extension or copying at all
957 * by maintaining a separate list over which the map iterates
958 * (like foreach does). --gsar */
960 /* everything in the stack after the destination list moves
961 * towards the end the stack by the amount of room needed */
962 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
964 /* items to shift up (accounting for the moved source pointer) */
965 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
967 /* This optimization is by Ben Tilly and it does
968 * things differently from what Sarathy (gsar)
969 * is describing. The downside of this optimization is
970 * that leaves "holes" (uninitialized and hopefully unused areas)
971 * to the Perl stack, but on the other hand this
972 * shouldn't be a problem. If Sarathy's idea gets
973 * implemented, this optimization should become
974 * irrelevant. --jhi */
976 shift = count; /* Avoid shifting too often --Ben Tilly */
981 PL_markstack_ptr[-1] += shift;
982 *PL_markstack_ptr += shift;
986 /* copy the new items down to the destination list */
987 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
988 if (gimme == G_ARRAY) {
990 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
993 /* scalar context: we don't care about which values map returns
994 * (we use undef here). And so we certainly don't want to do mortal
995 * copies of meaningless values. */
996 while (items-- > 0) {
998 *dst-- = &PL_sv_undef;
1002 LEAVE; /* exit inner scope */
1005 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1007 (void)POPMARK; /* pop top */
1008 LEAVE; /* exit outer scope */
1009 (void)POPMARK; /* pop src */
1010 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1011 (void)POPMARK; /* pop dst */
1012 SP = PL_stack_base + POPMARK; /* pop original mark */
1013 if (gimme == G_SCALAR) {
1014 if (PL_op->op_private & OPpGREP_LEX) {
1015 SV* sv = sv_newmortal();
1016 sv_setiv(sv, items);
1024 else if (gimme == G_ARRAY)
1031 ENTER; /* enter inner scope */
1034 /* set $_ to the new source item */
1035 src = PL_stack_base[PL_markstack_ptr[-1]];
1037 if (PL_op->op_private & OPpGREP_LEX)
1038 PAD_SVl(PL_op->op_targ) = src;
1042 RETURNOP(cLOGOP->op_other);
1050 if (GIMME == G_ARRAY)
1052 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1053 return cLOGOP->op_other;
1062 if (GIMME == G_ARRAY) {
1063 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1067 SV * const targ = PAD_SV(PL_op->op_targ);
1070 if (PL_op->op_private & OPpFLIP_LINENUM) {
1071 if (GvIO(PL_last_in_gv)) {
1072 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1075 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1077 flip = SvIV(sv) == SvIV(GvSV(gv));
1083 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1084 if (PL_op->op_flags & OPf_SPECIAL) {
1092 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1095 sv_setpvn(TARG, "", 0);
1101 /* This code tries to decide if "$left .. $right" should use the
1102 magical string increment, or if the range is numeric (we make
1103 an exception for .."0" [#18165]). AMS 20021031. */
1105 #define RANGE_IS_NUMERIC(left,right) ( \
1106 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1107 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1108 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1109 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1110 && (!SvOK(right) || looks_like_number(right))))
1116 if (GIMME == G_ARRAY) {
1122 if (RANGE_IS_NUMERIC(left,right)) {
1125 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1126 (SvOK(right) && SvNV(right) > IV_MAX))
1127 DIE(aTHX_ "Range iterator outside integer range");
1138 SV * const sv = sv_2mortal(newSViv(i++));
1143 SV * const final = sv_mortalcopy(right);
1145 const char * const tmps = SvPV_const(final, len);
1147 SV *sv = sv_mortalcopy(left);
1148 SvPV_force_nolen(sv);
1149 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1151 if (strEQ(SvPVX_const(sv),tmps))
1153 sv = sv_2mortal(newSVsv(sv));
1160 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1164 if (PL_op->op_private & OPpFLIP_LINENUM) {
1165 if (GvIO(PL_last_in_gv)) {
1166 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1169 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1170 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1178 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1179 sv_catpvn(targ, "E0", 2);
1189 static const char * const context_name[] = {
1202 S_dopoptolabel(pTHX_ const char *label)
1206 for (i = cxstack_ix; i >= 0; i--) {
1207 register const PERL_CONTEXT * const cx = &cxstack[i];
1208 switch (CxTYPE(cx)) {
1216 if (ckWARN(WARN_EXITING))
1217 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1218 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1219 if (CxTYPE(cx) == CXt_NULL)
1223 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1224 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1225 (long)i, cx->blk_loop.label));
1228 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1238 Perl_dowantarray(pTHX)
1240 const I32 gimme = block_gimme();
1241 return (gimme == G_VOID) ? G_SCALAR : gimme;
1245 Perl_block_gimme(pTHX)
1247 const I32 cxix = dopoptosub(cxstack_ix);
1251 switch (cxstack[cxix].blk_gimme) {
1259 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1266 Perl_is_lvalue_sub(pTHX)
1268 const I32 cxix = dopoptosub(cxstack_ix);
1269 assert(cxix >= 0); /* We should only be called from inside subs */
1271 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1272 return cxstack[cxix].blk_sub.lval;
1278 S_dopoptosub(pTHX_ I32 startingblock)
1280 return dopoptosub_at(cxstack, startingblock);
1284 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1287 for (i = startingblock; i >= 0; i--) {
1288 register const PERL_CONTEXT * const cx = &cxstk[i];
1289 switch (CxTYPE(cx)) {
1295 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1303 S_dopoptoeval(pTHX_ I32 startingblock)
1306 for (i = startingblock; i >= 0; i--) {
1307 register const PERL_CONTEXT *cx = &cxstack[i];
1308 switch (CxTYPE(cx)) {
1312 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1320 S_dopoptoloop(pTHX_ I32 startingblock)
1323 for (i = startingblock; i >= 0; i--) {
1324 register const PERL_CONTEXT * const cx = &cxstack[i];
1325 switch (CxTYPE(cx)) {
1331 if (ckWARN(WARN_EXITING))
1332 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1333 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1334 if ((CxTYPE(cx)) == CXt_NULL)
1338 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1346 S_dopoptogiven(pTHX_ I32 startingblock)
1349 for (i = startingblock; i >= 0; i--) {
1350 register const PERL_CONTEXT *cx = &cxstack[i];
1351 switch (CxTYPE(cx)) {
1355 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1358 if (CxFOREACHDEF(cx)) {
1359 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1368 S_dopoptowhen(pTHX_ I32 startingblock)
1371 for (i = startingblock; i >= 0; i--) {
1372 register const PERL_CONTEXT *cx = &cxstack[i];
1373 switch (CxTYPE(cx)) {
1377 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1385 Perl_dounwind(pTHX_ I32 cxix)
1389 while (cxstack_ix > cxix) {
1391 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1392 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1393 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1394 /* Note: we don't need to restore the base context info till the end. */
1395 switch (CxTYPE(cx)) {
1398 continue; /* not break */
1417 PERL_UNUSED_VAR(optype);
1421 Perl_qerror(pTHX_ SV *err)
1424 sv_catsv(ERRSV, err);
1426 sv_catsv(PL_errors, err);
1428 Perl_warn(aTHX_ "%"SVf, err);
1433 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1442 if (PL_in_eval & EVAL_KEEPERR) {
1443 static const char prefix[] = "\t(in cleanup) ";
1444 SV * const err = ERRSV;
1445 const char *e = NULL;
1447 sv_setpvn(err,"",0);
1448 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1450 e = SvPV_const(err, len);
1452 if (*e != *message || strNE(e,message))
1456 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1457 sv_catpvn(err, prefix, sizeof(prefix)-1);
1458 sv_catpvn(err, message, msglen);
1459 if (ckWARN(WARN_MISC)) {
1460 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1461 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1466 sv_setpvn(ERRSV, message, msglen);
1470 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1471 && PL_curstackinfo->si_prev)
1479 register PERL_CONTEXT *cx;
1482 if (cxix < cxstack_ix)
1485 POPBLOCK(cx,PL_curpm);
1486 if (CxTYPE(cx) != CXt_EVAL) {
1488 message = SvPVx_const(ERRSV, msglen);
1489 PerlIO_write(Perl_error_log, "panic: die ", 11);
1490 PerlIO_write(Perl_error_log, message, msglen);
1495 if (gimme == G_SCALAR)
1496 *++newsp = &PL_sv_undef;
1497 PL_stack_sp = newsp;
1501 /* LEAVE could clobber PL_curcop (see save_re_context())
1502 * XXX it might be better to find a way to avoid messing with
1503 * PL_curcop in save_re_context() instead, but this is a more
1504 * minimal fix --GSAR */
1505 PL_curcop = cx->blk_oldcop;
1507 if (optype == OP_REQUIRE) {
1508 const char* const msg = SvPVx_nolen_const(ERRSV);
1509 SV * const nsv = cx->blk_eval.old_namesv;
1510 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1512 DIE(aTHX_ "%sCompilation failed in require",
1513 *msg ? msg : "Unknown error\n");
1515 assert(CxTYPE(cx) == CXt_EVAL);
1516 return cx->blk_eval.retop;
1520 message = SvPVx_const(ERRSV, msglen);
1522 write_to_stderr(message, msglen);
1531 if (SvTRUE(left) != SvTRUE(right))
1540 register I32 cxix = dopoptosub(cxstack_ix);
1541 register const PERL_CONTEXT *cx;
1542 register const PERL_CONTEXT *ccstack = cxstack;
1543 const PERL_SI *top_si = PL_curstackinfo;
1545 const char *stashname;
1552 /* we may be in a higher stacklevel, so dig down deeper */
1553 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1554 top_si = top_si->si_prev;
1555 ccstack = top_si->si_cxstack;
1556 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1559 if (GIMME != G_ARRAY) {
1565 /* caller() should not report the automatic calls to &DB::sub */
1566 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1567 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1571 cxix = dopoptosub_at(ccstack, cxix - 1);
1574 cx = &ccstack[cxix];
1575 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1576 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1577 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1578 field below is defined for any cx. */
1579 /* caller() should not report the automatic calls to &DB::sub */
1580 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1581 cx = &ccstack[dbcxix];
1584 stashname = CopSTASHPV(cx->blk_oldcop);
1585 if (GIMME != G_ARRAY) {
1588 PUSHs(&PL_sv_undef);
1591 sv_setpv(TARG, stashname);
1600 PUSHs(&PL_sv_undef);
1602 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1603 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1604 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1607 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1608 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1609 /* So is ccstack[dbcxix]. */
1611 SV * const sv = NEWSV(49, 0);
1612 gv_efullname3(sv, cvgv, NULL);
1613 PUSHs(sv_2mortal(sv));
1614 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1617 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1618 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1622 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1623 PUSHs(sv_2mortal(newSViv(0)));
1625 gimme = (I32)cx->blk_gimme;
1626 if (gimme == G_VOID)
1627 PUSHs(&PL_sv_undef);
1629 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1630 if (CxTYPE(cx) == CXt_EVAL) {
1632 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1633 PUSHs(cx->blk_eval.cur_text);
1637 else if (cx->blk_eval.old_namesv) {
1638 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1641 /* eval BLOCK (try blocks have old_namesv == 0) */
1643 PUSHs(&PL_sv_undef);
1644 PUSHs(&PL_sv_undef);
1648 PUSHs(&PL_sv_undef);
1649 PUSHs(&PL_sv_undef);
1651 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1652 && CopSTASH_eq(PL_curcop, PL_debstash))
1654 AV * const ary = cx->blk_sub.argarray;
1655 const int off = AvARRAY(ary) - AvALLOC(ary);
1658 GV* const tmpgv = gv_fetchpv("DB::args", TRUE, SVt_PVAV);
1659 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1661 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1664 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1665 av_extend(PL_dbargs, AvFILLp(ary) + off);
1666 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1667 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1669 /* XXX only hints propagated via op_private are currently
1670 * visible (others are not easily accessible, since they
1671 * use the global PL_hints) */
1672 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1673 HINT_PRIVATE_MASK)));
1676 SV * const old_warnings = cx->blk_oldcop->cop_warnings ;
1678 if (old_warnings == pWARN_NONE ||
1679 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1680 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1681 else if (old_warnings == pWARN_ALL ||
1682 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1683 /* Get the bit mask for $warnings::Bits{all}, because
1684 * it could have been extended by warnings::register */
1686 HV * const bits = get_hv("warnings::Bits", FALSE);
1687 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1688 mask = newSVsv(*bits_all);
1691 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1695 mask = newSVsv(old_warnings);
1696 PUSHs(sv_2mortal(mask));
1704 const char * const tmps = (MAXARG < 1) ? "" : POPpconstx;
1705 sv_reset(tmps, CopSTASH(PL_curcop));
1710 /* like pp_nextstate, but used instead when the debugger is active */
1715 PL_curcop = (COP*)PL_op;
1716 TAINT_NOT; /* Each statement is presumed innocent */
1717 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1720 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1721 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1724 register PERL_CONTEXT *cx;
1725 const I32 gimme = G_ARRAY;
1727 GV * const gv = PL_DBgv;
1728 register CV * const cv = GvCV(gv);
1731 DIE(aTHX_ "No DB::DB routine defined");
1733 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1734 /* don't do recursive DB::DB call */
1749 (void)(*CvXSUB(cv))(aTHX_ cv);
1756 PUSHBLOCK(cx, CXt_SUB, SP);
1758 cx->blk_sub.retop = PL_op->op_next;
1761 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1762 RETURNOP(CvSTART(cv));
1772 register PERL_CONTEXT *cx;
1773 const I32 gimme = GIMME_V;
1775 U32 cxtype = CXt_LOOP | CXp_FOREACH;
1783 if (PL_op->op_targ) {
1784 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1785 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1786 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1787 SVs_PADSTALE, SVs_PADSTALE);
1789 #ifndef USE_ITHREADS
1790 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1793 SAVEPADSV(PL_op->op_targ);
1794 iterdata = INT2PTR(void*, PL_op->op_targ);
1795 cxtype |= CXp_PADVAR;
1799 GV * const gv = (GV*)POPs;
1800 svp = &GvSV(gv); /* symbol table variable */
1801 SAVEGENERICSV(*svp);
1804 iterdata = (void*)gv;
1808 if (PL_op->op_private & OPpITER_DEF)
1809 cxtype |= CXp_FOR_DEF;
1813 PUSHBLOCK(cx, cxtype, SP);
1815 PUSHLOOP(cx, iterdata, MARK);
1817 PUSHLOOP(cx, svp, MARK);
1819 if (PL_op->op_flags & OPf_STACKED) {
1820 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1821 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1823 SV * const right = (SV*)cx->blk_loop.iterary;
1826 if (RANGE_IS_NUMERIC(sv,right)) {
1827 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1828 (SvOK(right) && SvNV(right) >= IV_MAX))
1829 DIE(aTHX_ "Range iterator outside integer range");
1830 cx->blk_loop.iterix = SvIV(sv);
1831 cx->blk_loop.itermax = SvIV(right);
1833 /* for correct -Dstv display */
1834 cx->blk_oldsp = sp - PL_stack_base;
1838 cx->blk_loop.iterlval = newSVsv(sv);
1839 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1840 (void) SvPV_nolen_const(right);
1843 else if (PL_op->op_private & OPpITER_REVERSED) {
1844 cx->blk_loop.itermax = 0;
1845 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1850 cx->blk_loop.iterary = PL_curstack;
1851 AvFILLp(PL_curstack) = SP - PL_stack_base;
1852 if (PL_op->op_private & OPpITER_REVERSED) {
1853 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1854 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1857 cx->blk_loop.iterix = MARK - PL_stack_base;
1867 register PERL_CONTEXT *cx;
1868 const I32 gimme = GIMME_V;
1874 PUSHBLOCK(cx, CXt_LOOP, SP);
1875 PUSHLOOP(cx, 0, SP);
1883 register PERL_CONTEXT *cx;
1890 assert(CxTYPE(cx) == CXt_LOOP);
1892 newsp = PL_stack_base + cx->blk_loop.resetsp;
1895 if (gimme == G_VOID)
1897 else if (gimme == G_SCALAR) {
1899 *++newsp = sv_mortalcopy(*SP);
1901 *++newsp = &PL_sv_undef;
1905 *++newsp = sv_mortalcopy(*++mark);
1906 TAINT_NOT; /* Each item is independent */
1912 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1913 PL_curpm = newpm; /* ... and pop $1 et al */
1924 register PERL_CONTEXT *cx;
1925 bool popsub2 = FALSE;
1926 bool clear_errsv = FALSE;
1934 const I32 cxix = dopoptosub(cxstack_ix);
1937 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1938 * sort block, which is a CXt_NULL
1941 PL_stack_base[1] = *PL_stack_sp;
1942 PL_stack_sp = PL_stack_base + 1;
1946 DIE(aTHX_ "Can't return outside a subroutine");
1948 if (cxix < cxstack_ix)
1951 if (CxMULTICALL(&cxstack[cxix])) {
1952 gimme = cxstack[cxix].blk_gimme;
1953 if (gimme == G_VOID)
1954 PL_stack_sp = PL_stack_base;
1955 else if (gimme == G_SCALAR) {
1956 PL_stack_base[1] = *PL_stack_sp;
1957 PL_stack_sp = PL_stack_base + 1;
1963 switch (CxTYPE(cx)) {
1966 retop = cx->blk_sub.retop;
1967 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1970 if (!(PL_in_eval & EVAL_KEEPERR))
1973 retop = cx->blk_eval.retop;
1977 if (optype == OP_REQUIRE &&
1978 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1980 /* Unassume the success we assumed earlier. */
1981 SV * const nsv = cx->blk_eval.old_namesv;
1982 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
1983 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1988 retop = cx->blk_sub.retop;
1991 DIE(aTHX_ "panic: return");
1995 if (gimme == G_SCALAR) {
1998 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2000 *++newsp = SvREFCNT_inc(*SP);
2005 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2007 *++newsp = sv_mortalcopy(sv);
2012 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2015 *++newsp = sv_mortalcopy(*SP);
2018 *++newsp = &PL_sv_undef;
2020 else if (gimme == G_ARRAY) {
2021 while (++MARK <= SP) {
2022 *++newsp = (popsub2 && SvTEMP(*MARK))
2023 ? *MARK : sv_mortalcopy(*MARK);
2024 TAINT_NOT; /* Each item is independent */
2027 PL_stack_sp = newsp;
2030 /* Stack values are safe: */
2033 POPSUB(cx,sv); /* release CV and @_ ... */
2037 PL_curpm = newpm; /* ... and pop $1 et al */
2041 sv_setpvn(ERRSV,"",0);
2049 register PERL_CONTEXT *cx;
2060 if (PL_op->op_flags & OPf_SPECIAL) {
2061 cxix = dopoptoloop(cxstack_ix);
2063 DIE(aTHX_ "Can't \"last\" outside a loop block");
2066 cxix = dopoptolabel(cPVOP->op_pv);
2068 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2070 if (cxix < cxstack_ix)
2074 cxstack_ix++; /* temporarily protect top context */
2076 switch (CxTYPE(cx)) {
2079 newsp = PL_stack_base + cx->blk_loop.resetsp;
2080 nextop = cx->blk_loop.last_op->op_next;
2084 nextop = cx->blk_sub.retop;
2088 nextop = cx->blk_eval.retop;
2092 nextop = cx->blk_sub.retop;
2095 DIE(aTHX_ "panic: last");
2099 if (gimme == G_SCALAR) {
2101 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2102 ? *SP : sv_mortalcopy(*SP);
2104 *++newsp = &PL_sv_undef;
2106 else if (gimme == G_ARRAY) {
2107 while (++MARK <= SP) {
2108 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2109 ? *MARK : sv_mortalcopy(*MARK);
2110 TAINT_NOT; /* Each item is independent */
2118 /* Stack values are safe: */
2121 POPLOOP(cx); /* release loop vars ... */
2125 POPSUB(cx,sv); /* release CV and @_ ... */
2128 PL_curpm = newpm; /* ... and pop $1 et al */
2131 PERL_UNUSED_VAR(optype);
2132 PERL_UNUSED_VAR(gimme);
2140 register PERL_CONTEXT *cx;
2143 if (PL_op->op_flags & OPf_SPECIAL) {
2144 cxix = dopoptoloop(cxstack_ix);
2146 DIE(aTHX_ "Can't \"next\" outside a loop block");
2149 cxix = dopoptolabel(cPVOP->op_pv);
2151 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2153 if (cxix < cxstack_ix)
2156 /* clear off anything above the scope we're re-entering, but
2157 * save the rest until after a possible continue block */
2158 inner = PL_scopestack_ix;
2160 if (PL_scopestack_ix < inner)
2161 leave_scope(PL_scopestack[PL_scopestack_ix]);
2162 PL_curcop = cx->blk_oldcop;
2163 return cx->blk_loop.next_op;
2170 register PERL_CONTEXT *cx;
2174 if (PL_op->op_flags & OPf_SPECIAL) {
2175 cxix = dopoptoloop(cxstack_ix);
2177 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2180 cxix = dopoptolabel(cPVOP->op_pv);
2182 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2184 if (cxix < cxstack_ix)
2187 redo_op = cxstack[cxix].blk_loop.redo_op;
2188 if (redo_op->op_type == OP_ENTER) {
2189 /* pop one less context to avoid $x being freed in while (my $x..) */
2191 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2192 redo_op = redo_op->op_next;
2196 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2197 LEAVE_SCOPE(oldsave);
2199 PL_curcop = cx->blk_oldcop;
2204 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2207 static const char too_deep[] = "Target of goto is too deeply nested";
2210 Perl_croak(aTHX_ too_deep);
2211 if (o->op_type == OP_LEAVE ||
2212 o->op_type == OP_SCOPE ||
2213 o->op_type == OP_LEAVELOOP ||
2214 o->op_type == OP_LEAVESUB ||
2215 o->op_type == OP_LEAVETRY)
2217 *ops++ = cUNOPo->op_first;
2219 Perl_croak(aTHX_ too_deep);
2222 if (o->op_flags & OPf_KIDS) {
2224 /* First try all the kids at this level, since that's likeliest. */
2225 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2226 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2227 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2230 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2231 if (kid == PL_lastgotoprobe)
2233 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2236 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2237 ops[-1]->op_type == OP_DBSTATE)
2242 if ((o = dofindlabel(kid, label, ops, oplimit)))
2255 register PERL_CONTEXT *cx;
2256 #define GOTO_DEPTH 64
2257 OP *enterops[GOTO_DEPTH];
2258 const char *label = NULL;
2259 const bool do_dump = (PL_op->op_type == OP_DUMP);
2260 static const char must_have_label[] = "goto must have label";
2262 if (PL_op->op_flags & OPf_STACKED) {
2263 SV * const sv = POPs;
2265 /* This egregious kludge implements goto &subroutine */
2266 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2268 register PERL_CONTEXT *cx;
2269 CV* cv = (CV*)SvRV(sv);
2276 if (!CvROOT(cv) && !CvXSUB(cv)) {
2277 const GV * const gv = CvGV(cv);
2281 /* autoloaded stub? */
2282 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2284 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2285 GvNAMELEN(gv), FALSE);
2286 if (autogv && (cv = GvCV(autogv)))
2288 tmpstr = sv_newmortal();
2289 gv_efullname3(tmpstr, gv, NULL);
2290 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2292 DIE(aTHX_ "Goto undefined subroutine");
2295 /* First do some returnish stuff. */
2296 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2298 cxix = dopoptosub(cxstack_ix);
2300 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2301 if (cxix < cxstack_ix)
2305 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2306 if (CxTYPE(cx) == CXt_EVAL) {
2308 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2310 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2312 else if (CxMULTICALL(cx))
2313 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2314 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2315 /* put @_ back onto stack */
2316 AV* av = cx->blk_sub.argarray;
2318 items = AvFILLp(av) + 1;
2319 EXTEND(SP, items+1); /* @_ could have been extended. */
2320 Copy(AvARRAY(av), SP + 1, items, SV*);
2321 SvREFCNT_dec(GvAV(PL_defgv));
2322 GvAV(PL_defgv) = cx->blk_sub.savearray;
2324 /* abandon @_ if it got reified */
2329 av_extend(av, items-1);
2331 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2334 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2335 AV* const av = GvAV(PL_defgv);
2336 items = AvFILLp(av) + 1;
2337 EXTEND(SP, items+1); /* @_ could have been extended. */
2338 Copy(AvARRAY(av), SP + 1, items, SV*);
2342 if (CxTYPE(cx) == CXt_SUB &&
2343 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2344 SvREFCNT_dec(cx->blk_sub.cv);
2345 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2346 LEAVE_SCOPE(oldsave);
2348 /* Now do some callish stuff. */
2350 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2352 OP* retop = cx->blk_sub.retop;
2355 for (index=0; index<items; index++)
2356 sv_2mortal(SP[-index]);
2358 #ifdef PERL_XSUB_OLDSTYLE
2359 if (CvOLDSTYLE(cv)) {
2360 I32 (*fp3)(int,int,int);
2365 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2366 items = (*fp3)(CvXSUBANY(cv).any_i32,
2367 mark - PL_stack_base + 1,
2369 SP = PL_stack_base + items;
2372 #endif /* PERL_XSUB_OLDSTYLE */
2377 /* XS subs don't have a CxSUB, so pop it */
2378 POPBLOCK(cx, PL_curpm);
2379 /* Push a mark for the start of arglist */
2382 (void)(*CvXSUB(cv))(aTHX_ cv);
2383 /* Put these at the bottom since the vars are set but not used */
2384 PERL_UNUSED_VAR(newsp);
2385 PERL_UNUSED_VAR(gimme);
2391 AV* padlist = CvPADLIST(cv);
2392 if (CxTYPE(cx) == CXt_EVAL) {
2393 PL_in_eval = cx->blk_eval.old_in_eval;
2394 PL_eval_root = cx->blk_eval.old_eval_root;
2395 cx->cx_type = CXt_SUB;
2396 cx->blk_sub.hasargs = 0;
2398 cx->blk_sub.cv = cv;
2399 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2402 if (CvDEPTH(cv) < 2)
2403 (void)SvREFCNT_inc(cv);
2405 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2406 sub_crush_depth(cv);
2407 pad_push(padlist, CvDEPTH(cv));
2410 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2411 if (cx->blk_sub.hasargs)
2413 AV* av = (AV*)PAD_SVl(0);
2416 cx->blk_sub.savearray = GvAV(PL_defgv);
2417 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2418 CX_CURPAD_SAVE(cx->blk_sub);
2419 cx->blk_sub.argarray = av;
2421 if (items >= AvMAX(av) + 1) {
2423 if (AvARRAY(av) != ary) {
2424 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2425 SvPV_set(av, (char*)ary);
2427 if (items >= AvMAX(av) + 1) {
2428 AvMAX(av) = items - 1;
2429 Renew(ary,items+1,SV*);
2431 SvPV_set(av, (char*)ary);
2435 Copy(mark,AvARRAY(av),items,SV*);
2436 AvFILLp(av) = items - 1;
2437 assert(!AvREAL(av));
2439 /* transfer 'ownership' of refcnts to new @_ */
2449 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2451 * We do not care about using sv to call CV;
2452 * it's for informational purposes only.
2454 SV * const sv = GvSV(PL_DBsub);
2458 if (PERLDB_SUB_NN) {
2459 const int type = SvTYPE(sv);
2460 if (type < SVt_PVIV && type != SVt_IV)
2461 sv_upgrade(sv, SVt_PVIV);
2463 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2465 gv_efullname3(sv, CvGV(cv), NULL);
2468 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2469 PUSHMARK( PL_stack_sp );
2470 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2474 RETURNOP(CvSTART(cv));
2478 label = SvPV_nolen_const(sv);
2479 if (!(do_dump || *label))
2480 DIE(aTHX_ must_have_label);
2483 else if (PL_op->op_flags & OPf_SPECIAL) {
2485 DIE(aTHX_ must_have_label);
2488 label = cPVOP->op_pv;
2490 if (label && *label) {
2491 OP *gotoprobe = NULL;
2492 bool leaving_eval = FALSE;
2493 bool in_block = FALSE;
2494 PERL_CONTEXT *last_eval_cx = NULL;
2498 PL_lastgotoprobe = 0;
2500 for (ix = cxstack_ix; ix >= 0; ix--) {
2502 switch (CxTYPE(cx)) {
2504 leaving_eval = TRUE;
2505 if (!CxTRYBLOCK(cx)) {
2506 gotoprobe = (last_eval_cx ?
2507 last_eval_cx->blk_eval.old_eval_root :
2512 /* else fall through */
2514 gotoprobe = cx->blk_oldcop->op_sibling;
2520 gotoprobe = cx->blk_oldcop->op_sibling;
2523 gotoprobe = PL_main_root;
2526 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2527 gotoprobe = CvROOT(cx->blk_sub.cv);
2533 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2536 DIE(aTHX_ "panic: goto");
2537 gotoprobe = PL_main_root;
2541 retop = dofindlabel(gotoprobe, label,
2542 enterops, enterops + GOTO_DEPTH);
2546 PL_lastgotoprobe = gotoprobe;
2549 DIE(aTHX_ "Can't find label %s", label);
2551 /* if we're leaving an eval, check before we pop any frames
2552 that we're not going to punt, otherwise the error
2555 if (leaving_eval && *enterops && enterops[1]) {
2557 for (i = 1; enterops[i]; i++)
2558 if (enterops[i]->op_type == OP_ENTERITER)
2559 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2562 /* pop unwanted frames */
2564 if (ix < cxstack_ix) {
2571 oldsave = PL_scopestack[PL_scopestack_ix];
2572 LEAVE_SCOPE(oldsave);
2575 /* push wanted frames */
2577 if (*enterops && enterops[1]) {
2578 OP * const oldop = PL_op;
2579 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2580 for (; enterops[ix]; ix++) {
2581 PL_op = enterops[ix];
2582 /* Eventually we may want to stack the needed arguments
2583 * for each op. For now, we punt on the hard ones. */
2584 if (PL_op->op_type == OP_ENTERITER)
2585 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2586 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2594 if (!retop) retop = PL_main_start;
2596 PL_restartop = retop;
2597 PL_do_undump = TRUE;
2601 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2602 PL_do_undump = FALSE;
2618 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2620 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2623 PL_exit_flags |= PERL_EXIT_EXPECTED;
2625 PUSHs(&PL_sv_undef);
2632 S_save_lines(pTHX_ AV *array, SV *sv)
2634 const char *s = SvPVX_const(sv);
2635 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2638 while (s && s < send) {
2640 SV * const tmpstr = NEWSV(85,0);
2642 sv_upgrade(tmpstr, SVt_PVMG);
2643 t = strchr(s, '\n');
2649 sv_setpvn(tmpstr, s, t - s);
2650 av_store(array, line++, tmpstr);
2656 S_docatch_body(pTHX)
2663 S_docatch(pTHX_ OP *o)
2666 OP * const oldop = PL_op;
2670 assert(CATCH_GET == TRUE);
2677 assert(cxstack_ix >= 0);
2678 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2679 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2684 /* die caught by an inner eval - continue inner loop */
2686 /* NB XXX we rely on the old popped CxEVAL still being at the top
2687 * of the stack; the way die_where() currently works, this
2688 * assumption is valid. In theory The cur_top_env value should be
2689 * returned in another global, the way retop (aka PL_restartop)
2691 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2694 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2696 PL_op = PL_restartop;
2713 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2714 /* sv Text to convert to OP tree. */
2715 /* startop op_free() this to undo. */
2716 /* code Short string id of the caller. */
2718 /* FIXME - how much of this code is common with pp_entereval? */
2719 dVAR; dSP; /* Make POPBLOCK work. */
2726 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2727 char *tmpbuf = tbuf;
2730 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2736 /* switch to eval mode */
2738 if (IN_PERL_COMPILETIME) {
2739 SAVECOPSTASH_FREE(&PL_compiling);
2740 CopSTASH_set(&PL_compiling, PL_curstash);
2742 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2743 SV * const sv = sv_newmortal();
2744 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2745 code, (unsigned long)++PL_evalseq,
2746 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2751 len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
2752 (unsigned long)++PL_evalseq);
2753 SAVECOPFILE_FREE(&PL_compiling);
2754 CopFILE_set(&PL_compiling, tmpbuf+2);
2755 SAVECOPLINE(&PL_compiling);
2756 CopLINE_set(&PL_compiling, 1);
2757 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2758 deleting the eval's FILEGV from the stash before gv_check() runs
2759 (i.e. before run-time proper). To work around the coredump that
2760 ensues, we always turn GvMULTI_on for any globals that were
2761 introduced within evals. See force_ident(). GSAR 96-10-12 */
2762 safestr = savepvn(tmpbuf, len);
2763 SAVEDELETE(PL_defstash, safestr, len);
2765 #ifdef OP_IN_REGISTER
2771 /* we get here either during compilation, or via pp_regcomp at runtime */
2772 runtime = IN_PERL_RUNTIME;
2774 runcv = find_runcv(NULL);
2777 PL_op->op_type = OP_ENTEREVAL;
2778 PL_op->op_flags = 0; /* Avoid uninit warning. */
2779 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2780 PUSHEVAL(cx, 0, Nullgv);
2783 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2785 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2786 POPBLOCK(cx,PL_curpm);
2789 (*startop)->op_type = OP_NULL;
2790 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2792 /* XXX DAPM do this properly one year */
2793 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2795 if (IN_PERL_COMPILETIME)
2796 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2797 #ifdef OP_IN_REGISTER
2800 PERL_UNUSED_VAR(newsp);
2801 PERL_UNUSED_VAR(optype);
2808 =for apidoc find_runcv
2810 Locate the CV corresponding to the currently executing sub or eval.
2811 If db_seqp is non_null, skip CVs that are in the DB package and populate
2812 *db_seqp with the cop sequence number at the point that the DB:: code was
2813 entered. (allows debuggers to eval in the scope of the breakpoint rather
2814 than in the scope of the debugger itself).
2820 Perl_find_runcv(pTHX_ U32 *db_seqp)
2825 *db_seqp = PL_curcop->cop_seq;
2826 for (si = PL_curstackinfo; si; si = si->si_prev) {
2828 for (ix = si->si_cxix; ix >= 0; ix--) {
2829 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2830 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2831 CV * const cv = cx->blk_sub.cv;
2832 /* skip DB:: code */
2833 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2834 *db_seqp = cx->blk_oldcop->cop_seq;
2839 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2847 /* Compile a require/do, an eval '', or a /(?{...})/.
2848 * In the last case, startop is non-null, and contains the address of
2849 * a pointer that should be set to the just-compiled code.
2850 * outside is the lexically enclosing CV (if any) that invoked us.
2853 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2855 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2858 OP * const saveop = PL_op;
2860 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2861 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2866 SAVESPTR(PL_compcv);
2867 PL_compcv = (CV*)NEWSV(1104,0);
2868 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2869 CvEVAL_on(PL_compcv);
2870 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2871 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2873 CvOUTSIDE_SEQ(PL_compcv) = seq;
2874 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2876 /* set up a scratch pad */
2878 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2881 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2883 /* make sure we compile in the right package */
2885 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2886 SAVESPTR(PL_curstash);
2887 PL_curstash = CopSTASH(PL_curcop);
2889 SAVESPTR(PL_beginav);
2890 PL_beginav = newAV();
2891 SAVEFREESV(PL_beginav);
2892 SAVEI32(PL_error_count);
2894 /* try to compile it */
2896 PL_eval_root = Nullop;
2898 PL_curcop = &PL_compiling;
2899 PL_curcop->cop_arybase = 0;
2900 if (saveop && saveop->op_flags & OPf_SPECIAL)
2901 PL_in_eval |= EVAL_KEEPERR;
2903 sv_setpvn(ERRSV,"",0);
2904 if (yyparse() || PL_error_count || !PL_eval_root) {
2905 SV **newsp; /* Used by POPBLOCK. */
2906 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2907 I32 optype = 0; /* Might be reset by POPEVAL. */
2912 op_free(PL_eval_root);
2913 PL_eval_root = Nullop;
2915 SP = PL_stack_base + POPMARK; /* pop original mark */
2917 POPBLOCK(cx,PL_curpm);
2923 msg = SvPVx_nolen_const(ERRSV);
2924 if (optype == OP_REQUIRE) {
2925 const SV * const nsv = cx->blk_eval.old_namesv;
2926 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2928 DIE(aTHX_ "%sCompilation failed in require",
2929 *msg ? msg : "Unknown error\n");
2932 POPBLOCK(cx,PL_curpm);
2934 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2935 (*msg ? msg : "Unknown error\n"));
2939 sv_setpv(ERRSV, "Compilation error");
2942 PERL_UNUSED_VAR(newsp);
2945 CopLINE_set(&PL_compiling, 0);
2947 *startop = PL_eval_root;
2949 SAVEFREEOP(PL_eval_root);
2951 /* Set the context for this new optree.
2952 * If the last op is an OP_REQUIRE, force scalar context.
2953 * Otherwise, propagate the context from the eval(). */
2954 if (PL_eval_root->op_type == OP_LEAVEEVAL
2955 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2956 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2958 scalar(PL_eval_root);
2959 else if (gimme & G_VOID)
2960 scalarvoid(PL_eval_root);
2961 else if (gimme & G_ARRAY)
2964 scalar(PL_eval_root);
2966 DEBUG_x(dump_eval());
2968 /* Register with debugger: */
2969 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2970 CV * const cv = get_cv("DB::postponed", FALSE);
2974 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2976 call_sv((SV*)cv, G_DISCARD);
2980 /* compiled okay, so do it */
2982 CvDEPTH(PL_compcv) = 1;
2983 SP = PL_stack_base + POPMARK; /* pop original mark */
2984 PL_op = saveop; /* The caller may need it. */
2985 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2987 RETURNOP(PL_eval_start);
2991 S_check_type_and_open(pTHX_ const char *name, const char *mode)
2994 const int st_rc = PerlLIO_stat(name, &st);
2999 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3000 Perl_die(aTHX_ "%s %s not allowed in require",
3001 S_ISDIR(st.st_mode) ? "Directory" : "Block device", name);
3003 return PerlIO_open(name, mode);
3007 S_doopen_pm(pTHX_ const char *name, const char *mode)
3009 #ifndef PERL_DISABLE_PMC
3010 const STRLEN namelen = strlen(name);
3013 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3014 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3015 const char * const pmc = SvPV_nolen_const(pmcsv);
3017 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3018 fp = check_type_and_open(name, mode);
3022 if (PerlLIO_stat(name, &pmstat) < 0 ||
3023 pmstat.st_mtime < pmcstat.st_mtime)
3025 fp = check_type_and_open(pmc, mode);
3028 fp = check_type_and_open(name, mode);
3031 SvREFCNT_dec(pmcsv);
3034 fp = check_type_and_open(name, mode);
3038 return check_type_and_open(name, mode);
3039 #endif /* !PERL_DISABLE_PMC */
3045 register PERL_CONTEXT *cx;
3049 const char *tryname = NULL;
3051 const I32 gimme = GIMME_V;
3052 int filter_has_file = 0;
3053 PerlIO *tryrsfp = NULL;
3054 GV *filter_child_proc = NULL;
3055 SV *filter_state = NULL;
3056 SV *filter_sub = NULL;
3062 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3063 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3064 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3065 "v-string in use/require non-portable");
3067 sv = new_version(sv);
3068 if (!sv_derived_from(PL_patchlevel, "version"))
3069 (void *)upg_version(PL_patchlevel);
3070 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3071 if ( vcmp(sv,PL_patchlevel) < 0 )
3072 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3073 vnormal(sv), vnormal(PL_patchlevel));
3076 if ( vcmp(sv,PL_patchlevel) > 0 )
3077 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3078 vnormal(sv), vnormal(PL_patchlevel));
3083 name = SvPV_const(sv, len);
3084 if (!(name && len > 0 && *name))
3085 DIE(aTHX_ "Null filename used");
3086 TAINT_PROPER("require");
3087 if (PL_op->op_type == OP_REQUIRE) {
3088 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3090 if (*svp != &PL_sv_undef)
3093 DIE(aTHX_ "Compilation failed in require");
3097 /* prepare to compile file */
3099 if (path_is_absolute(name)) {
3101 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3103 #ifdef MACOS_TRADITIONAL
3107 MacPerl_CanonDir(name, newname, 1);
3108 if (path_is_absolute(newname)) {
3110 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3115 AV * const ar = GvAVn(PL_incgv);
3119 if ((unixname = tounixspec(name, NULL)) != NULL)
3122 namesv = NEWSV(806, 0);
3123 for (i = 0; i <= AvFILL(ar); i++) {
3124 SV *dirsv = *av_fetch(ar, i, TRUE);
3130 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3131 && !sv_isobject(loader))
3133 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3136 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3137 PTR2UV(SvRV(dirsv)), name);
3138 tryname = SvPVX_const(namesv);
3149 if (sv_isobject(loader))
3150 count = call_method("INC", G_ARRAY);
3152 count = call_sv(loader, G_ARRAY);
3162 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3166 if (SvTYPE(arg) == SVt_PVGV) {
3167 IO *io = GvIO((GV *)arg);
3172 tryrsfp = IoIFP(io);
3173 if (IoTYPE(io) == IoTYPE_PIPE) {
3174 /* reading from a child process doesn't
3175 nest -- when returning from reading
3176 the inner module, the outer one is
3177 unreadable (closed?) I've tried to
3178 save the gv to manage the lifespan of
3179 the pipe, but this didn't help. XXX */
3180 filter_child_proc = (GV *)arg;
3181 (void)SvREFCNT_inc(filter_child_proc);
3184 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3185 PerlIO_close(IoOFP(io));
3197 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3199 (void)SvREFCNT_inc(filter_sub);
3202 filter_state = SP[i];
3203 (void)SvREFCNT_inc(filter_state);
3207 tryrsfp = PerlIO_open("/dev/null", PERL_SCRIPT_MODE);
3222 filter_has_file = 0;
3223 if (filter_child_proc) {
3224 SvREFCNT_dec(filter_child_proc);
3225 filter_child_proc = NULL;
3228 SvREFCNT_dec(filter_state);
3229 filter_state = NULL;
3232 SvREFCNT_dec(filter_sub);
3237 if (!path_is_absolute(name)
3238 #ifdef MACOS_TRADITIONAL
3239 /* We consider paths of the form :a:b ambiguous and interpret them first
3240 as global then as local
3242 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3245 const char *dir = SvPVx_nolen_const(dirsv);
3246 #ifdef MACOS_TRADITIONAL
3250 MacPerl_CanonDir(name, buf2, 1);
3251 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3255 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3257 sv_setpv(namesv, unixdir);
3258 sv_catpv(namesv, unixname);
3260 # ifdef __SYMBIAN32__
3261 if (PL_origfilename[0] &&
3262 PL_origfilename[1] == ':' &&
3263 !(dir[0] && dir[1] == ':'))
3264 Perl_sv_setpvf(aTHX_ namesv,
3269 Perl_sv_setpvf(aTHX_ namesv,
3273 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3277 TAINT_PROPER("require");
3278 tryname = SvPVX_const(namesv);
3279 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3281 if (tryname[0] == '.' && tryname[1] == '/')
3290 SAVECOPFILE_FREE(&PL_compiling);
3291 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3292 SvREFCNT_dec(namesv);
3294 if (PL_op->op_type == OP_REQUIRE) {
3295 const char *msgstr = name;
3296 if(errno == EMFILE) {
3298 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3300 msgstr = SvPV_nolen_const(msg);
3302 if (namesv) { /* did we lookup @INC? */
3303 AV * const ar = GvAVn(PL_incgv);
3305 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3306 "%s in @INC%s%s (@INC contains:",
3308 (instr(msgstr, ".h ")
3309 ? " (change .h to .ph maybe?)" : ""),
3310 (instr(msgstr, ".ph ")
3311 ? " (did you run h2ph?)" : "")
3314 for (i = 0; i <= AvFILL(ar); i++) {
3315 sv_catpvn(msg, " ", 1);
3316 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3318 sv_catpvn(msg, ")", 1);
3319 msgstr = SvPV_nolen_const(msg);
3322 DIE(aTHX_ "Can't locate %s", msgstr);
3328 SETERRNO(0, SS_NORMAL);
3330 /* Assume success here to prevent recursive requirement. */
3331 /* name is never assigned to again, so len is still strlen(name) */
3332 /* Check whether a hook in @INC has already filled %INC */
3334 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3336 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3338 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 );
3343 lex_start(sv_2mortal(newSVpvn("",0)));
3344 SAVEGENERICSV(PL_rsfp_filters);
3345 PL_rsfp_filters = NULL;
3350 SAVESPTR(PL_compiling.cop_warnings);
3351 if (PL_dowarn & G_WARN_ALL_ON)
3352 PL_compiling.cop_warnings = pWARN_ALL ;
3353 else if (PL_dowarn & G_WARN_ALL_OFF)
3354 PL_compiling.cop_warnings = pWARN_NONE ;
3355 else if (PL_taint_warn)
3356 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3358 PL_compiling.cop_warnings = pWARN_STD ;
3359 SAVESPTR(PL_compiling.cop_io);
3360 PL_compiling.cop_io = NULL;
3362 if (filter_sub || filter_child_proc) {
3363 SV * const datasv = filter_add(S_run_user_filter, NULL);
3364 IoLINES(datasv) = filter_has_file;
3365 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3366 IoTOP_GV(datasv) = (GV *)filter_state;
3367 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3370 /* switch to eval mode */
3371 PUSHBLOCK(cx, CXt_EVAL, SP);
3372 PUSHEVAL(cx, name, Nullgv);
3373 cx->blk_eval.retop = PL_op->op_next;
3375 SAVECOPLINE(&PL_compiling);
3376 CopLINE_set(&PL_compiling, 0);
3380 /* Store and reset encoding. */
3381 encoding = PL_encoding;
3384 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3386 /* Restore encoding. */
3387 PL_encoding = encoding;
3395 register PERL_CONTEXT *cx;
3397 const I32 gimme = GIMME_V;
3398 const I32 was = PL_sub_generation;
3399 char tbuf[TYPE_DIGITS(long) + 12];
3400 char *tmpbuf = tbuf;
3406 HV *saved_hh = NULL;
3408 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3409 saved_hh = (HV*) SvREFCNT_inc(POPs);
3413 if (!SvPV_nolen_const(sv))
3415 TAINT_PROPER("eval");
3421 /* switch to eval mode */
3423 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3424 SV * const sv = sv_newmortal();
3425 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3426 (unsigned long)++PL_evalseq,
3427 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3432 len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3433 SAVECOPFILE_FREE(&PL_compiling);
3434 CopFILE_set(&PL_compiling, tmpbuf+2);
3435 SAVECOPLINE(&PL_compiling);
3436 CopLINE_set(&PL_compiling, 1);
3437 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3438 deleting the eval's FILEGV from the stash before gv_check() runs
3439 (i.e. before run-time proper). To work around the coredump that
3440 ensues, we always turn GvMULTI_on for any globals that were
3441 introduced within evals. See force_ident(). GSAR 96-10-12 */
3442 safestr = savepvn(tmpbuf, len);
3443 SAVEDELETE(PL_defstash, safestr, len);
3445 PL_hints = PL_op->op_targ;
3447 GvHV(PL_hintgv) = saved_hh;
3448 SAVESPTR(PL_compiling.cop_warnings);
3449 if (specialWARN(PL_curcop->cop_warnings))
3450 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3452 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3453 SAVEFREESV(PL_compiling.cop_warnings);
3455 SAVESPTR(PL_compiling.cop_io);
3456 if (specialCopIO(PL_curcop->cop_io))
3457 PL_compiling.cop_io = PL_curcop->cop_io;
3459 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3460 SAVEFREESV(PL_compiling.cop_io);
3462 /* special case: an eval '' executed within the DB package gets lexically
3463 * placed in the first non-DB CV rather than the current CV - this
3464 * allows the debugger to execute code, find lexicals etc, in the
3465 * scope of the code being debugged. Passing &seq gets find_runcv
3466 * to do the dirty work for us */
3467 runcv = find_runcv(&seq);
3469 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3470 PUSHEVAL(cx, 0, Nullgv);
3471 cx->blk_eval.retop = PL_op->op_next;
3473 /* prepare to compile string */
3475 if (PERLDB_LINE && PL_curstash != PL_debstash)
3476 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3478 ret = doeval(gimme, NULL, runcv, seq);
3479 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3480 && ret != PL_op->op_next) { /* Successive compilation. */
3481 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3483 return DOCATCH(ret);
3493 register PERL_CONTEXT *cx;
3495 const U8 save_flags = PL_op -> op_flags;
3500 retop = cx->blk_eval.retop;
3503 if (gimme == G_VOID)
3505 else if (gimme == G_SCALAR) {
3508 if (SvFLAGS(TOPs) & SVs_TEMP)
3511 *MARK = sv_mortalcopy(TOPs);
3515 *MARK = &PL_sv_undef;
3520 /* in case LEAVE wipes old return values */
3521 for (mark = newsp + 1; mark <= SP; mark++) {
3522 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3523 *mark = sv_mortalcopy(*mark);
3524 TAINT_NOT; /* Each item is independent */
3528 PL_curpm = newpm; /* Don't pop $1 et al till now */
3531 assert(CvDEPTH(PL_compcv) == 1);
3533 CvDEPTH(PL_compcv) = 0;
3536 if (optype == OP_REQUIRE &&
3537 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3539 /* Unassume the success we assumed earlier. */
3540 SV * const nsv = cx->blk_eval.old_namesv;
3541 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3542 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3543 /* die_where() did LEAVE, or we won't be here */
3547 if (!(save_flags & OPf_SPECIAL))
3548 sv_setpvn(ERRSV,"",0);
3557 register PERL_CONTEXT *cx;
3558 const I32 gimme = GIMME_V;
3563 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3565 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3567 PL_in_eval = EVAL_INEVAL;
3568 sv_setpvn(ERRSV,"",0);
3570 return DOCATCH(PL_op->op_next);
3579 register PERL_CONTEXT *cx;
3584 PERL_UNUSED_VAR(optype);
3587 if (gimme == G_VOID)
3589 else if (gimme == G_SCALAR) {
3593 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3596 *MARK = sv_mortalcopy(TOPs);
3600 *MARK = &PL_sv_undef;
3605 /* in case LEAVE wipes old return values */
3607 for (mark = newsp + 1; mark <= SP; mark++) {
3608 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3609 *mark = sv_mortalcopy(*mark);
3610 TAINT_NOT; /* Each item is independent */
3614 PL_curpm = newpm; /* Don't pop $1 et al till now */
3617 sv_setpvn(ERRSV,"",0);
3624 register PERL_CONTEXT *cx;
3625 const I32 gimme = GIMME_V;
3630 if (PL_op->op_targ == 0) {
3631 SV ** const defsv_p = &GvSV(PL_defgv);
3632 *defsv_p = newSVsv(POPs);
3633 SAVECLEARSV(*defsv_p);
3636 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3638 PUSHBLOCK(cx, CXt_GIVEN, SP);
3647 register PERL_CONTEXT *cx;
3654 assert(CxTYPE(cx) == CXt_GIVEN);
3660 PL_curpm = newpm; /* pop $1 et al */
3667 /* Helper routines used by pp_smartmatch */
3670 S_make_matcher(pTHX_ regexp *re)
3672 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3673 PM_SETRE(matcher, ReREFCNT_inc(re));
3675 SAVEFREEOP((OP *) matcher);
3683 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3687 PL_op = (OP *) matcher;
3692 return (SvTRUEx(POPs));
3697 S_destroy_matcher(pTHX_ PMOP *matcher)
3699 PERL_UNUSED_ARG(matcher);
3704 /* Do a smart match */
3707 return do_smartmatch(Nullhv, Nullhv);
3710 /* This version of do_smartmatch() implements the following
3711 table of smart matches:
3713 $a $b Type of Match Implied Matching Code
3714 ====== ===== ===================== =============
3715 (overloading trumps everything)
3717 Code[+] Code[+] referential equality match if refaddr($a) == refaddr($b)
3718 Any Code[+] scalar sub truth match if $b->($a)
3720 Hash Hash hash keys identical match if sort(keys(%$a)) ÈeqÇ sort(keys(%$b))
3721 Hash Array hash value slice truth match if $a->{any(@$b)}
3722 Hash Regex hash key grep match if any(keys(%$a)) =~ /$b/
3723 Hash Any hash entry existence match if exists $a->{$b}
3725 Array Array arrays are identical[*] match if $a È~~Ç $b
3726 Array Regex array grep match if any(@$a) =~ /$b/
3727 Array Num array contains number match if any($a) == $b
3728 Array Any array contains string match if any($a) eq $b
3730 Any undef undefined match if !defined $a
3731 Any Regex pattern match match if $a =~ /$b/
3732 Code() Code() results are equal match if $a->() eq $b->()
3733 Any Code() simple closure truth match if $b->() (ignoring $a)
3734 Num numish[!] numeric equality match if $a == $b
3735 Any Str string equality match if $a eq $b
3736 Any Num numeric equality match if $a == $b
3738 Any Any string equality match if $a eq $b
3741 + - this must be a code reference whose prototype (if present) is not ""
3742 (subs with a "" prototype are dealt with by the 'Code()' entry lower down)
3743 * - if a circular reference is found, we fall back to referential equality
3744 ! - either a real number, or a string that looks_like_number()
3749 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3753 SV *e = TOPs; /* e is for 'expression' */
3754 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3757 regexp *this_regex, *other_regex;
3759 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3761 # define SM_REF(type) ( \
3762 (SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_##type) && (other = e)) \
3763 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_##type) && (other = d)))
3765 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3766 ((SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_PVCV) \
3767 && NOT_EMPTY_PROTO(this) && (other = e)) \
3768 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_PVCV) \
3769 && NOT_EMPTY_PROTO(this) && (other = d)))
3771 # define SM_REGEX ( \
3772 (SvROK(d) && SvMAGICAL(this = SvRV(d)) \
3773 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3774 && (this_regex = (regexp *)mg->mg_obj) \
3777 (SvROK(e) && SvMAGICAL(this = SvRV(e)) \
3778 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3779 && (this_regex = (regexp *)mg->mg_obj) \
3783 # define SM_OTHER_REF(type) \
3784 (SvROK(other) && SvTYPE(SvRV(other)) == SVt_##type)
3786 # define SM_OTHER_REGEX (SvROK(other) && SvMAGICAL(SvRV(other)) \
3787 && (mg = mg_find(SvRV(other), PERL_MAGIC_qr)) \
3788 && (other_regex = (regexp *)mg->mg_obj))
3791 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3792 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3794 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3795 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3797 tryAMAGICbinSET(smart, 0);
3799 SP -= 2; /* Pop the values */
3801 /* Take care only to invoke mg_get() once for each argument.
3802 * Currently we do this by copying the SV if it's magical. */
3805 d = sv_mortalcopy(d);
3812 e = sv_mortalcopy(e);
3817 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(other)) )
3819 if (this == SvRV(other))
3830 c = call_sv(this, G_SCALAR);
3834 else if (SvTEMP(TOPs))
3840 else if (SM_REF(PVHV)) {
3841 if (SM_OTHER_REF(PVHV)) {
3842 /* Check that the key-sets are identical */
3844 HV *other_hv = (HV *) SvRV(other);
3846 bool other_tied = FALSE;
3847 U32 this_key_count = 0,
3848 other_key_count = 0;
3850 /* Tied hashes don't know how many keys they have. */
3851 if (SvTIED_mg(this, PERL_MAGIC_tied)) {
3854 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3855 HV * const temp = other_hv;
3856 other_hv = (HV *) this;
3860 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3863 if (!tied && HvUSEDKEYS((HV *) this) != HvUSEDKEYS(other_hv))
3866 /* The hashes have the same number of keys, so it suffices
3867 to check that one is a subset of the other. */
3868 (void) hv_iterinit((HV *) this);
3869 while ( (he = hv_iternext((HV *) this)) ) {
3871 char * const key = hv_iterkey(he, &key_len);
3875 if(!hv_exists(other_hv, key, key_len)) {
3876 (void) hv_iterinit((HV *) this); /* reset iterator */
3882 (void) hv_iterinit(other_hv);
3883 while ( hv_iternext(other_hv) )
3887 other_key_count = HvUSEDKEYS(other_hv);
3889 if (this_key_count != other_key_count)
3894 else if (SM_OTHER_REF(PVAV)) {
3895 AV * const other_av = (AV *) SvRV(other);
3896 const I32 other_len = av_len(other_av) + 1;
3899 if (HvUSEDKEYS((HV *) this) != other_len)
3902 for(i = 0; i < other_len; ++i) {
3903 SV ** const svp = av_fetch(other_av, i, FALSE);
3907 if (!svp) /* ??? When can this happen? */
3910 key = SvPV(*svp, key_len);
3911 if(!hv_exists((HV *) this, key, key_len))
3916 else if (SM_OTHER_REGEX) {
3917 PMOP * const matcher = make_matcher(other_regex);
3920 (void) hv_iterinit((HV *) this);
3921 while ( (he = hv_iternext((HV *) this)) ) {
3922 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
3923 (void) hv_iterinit((HV *) this);
3924 destroy_matcher(matcher);
3928 destroy_matcher(matcher);
3932 if (hv_exists_ent((HV *) this, other, 0))
3938 else if (SM_REF(PVAV)) {
3939 if (SM_OTHER_REF(PVAV)) {
3940 AV *other_av = (AV *) SvRV(other);
3941 if (av_len((AV *) this) != av_len(other_av))
3945 const I32 other_len = av_len(other_av);
3947 if (Nullhv == seen_this) {
3948 seen_this = newHV();
3949 (void) sv_2mortal((SV *) seen_this);
3951 if (Nullhv == seen_other) {
3952 seen_this = newHV();
3953 (void) sv_2mortal((SV *) seen_other);
3955 for(i = 0; i <= other_len; ++i) {
3956 SV * const * const this_elem = av_fetch((AV *)this, i, FALSE);
3957 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
3959 if (!this_elem || !other_elem) {
3960 if (this_elem || other_elem)
3963 else if (SM_SEEN_THIS(*this_elem)
3964 || SM_SEEN_OTHER(*other_elem))
3966 if (*this_elem != *other_elem)
3970 hv_store_ent(seen_this,
3971 sv_2mortal(newSViv(PTR2IV(*this_elem))),
3973 hv_store_ent(seen_other,
3974 sv_2mortal(newSViv(PTR2IV(*other_elem))),
3980 (void) do_smartmatch(seen_this, seen_other);
3990 else if (SM_OTHER_REGEX) {
3991 PMOP * const matcher = make_matcher(other_regex);
3992 const I32 this_len = av_len((AV *) this);
3995 for(i = 0; i <= this_len; ++i) {
3996 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
3997 if (svp && matcher_matches_sv(matcher, *svp)) {
3998 destroy_matcher(matcher);
4002 destroy_matcher(matcher);
4005 else if (SvIOK(other) || SvNOK(other)) {
4008 for(i = 0; i <= AvFILL((AV *) this); ++i) {
4009 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4016 if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
4026 else if (SvPOK(other)) {
4027 const I32 this_len = av_len((AV *) this);
4030 for(i = 0; i <= this_len; ++i) {
4031 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4046 else if (!SvOK(d) || !SvOK(e)) {
4047 if (!SvOK(d) && !SvOK(e))
4052 else if (SM_REGEX) {
4053 PMOP * const matcher = make_matcher(this_regex);
4056 PUSHs(matcher_matches_sv(matcher, other)
4059 destroy_matcher(matcher);
4062 else if (SM_REF(PVCV)) {
4064 /* This must be a null-prototyped sub, because we
4065 already checked for the other kind. */
4071 c = call_sv(this, G_SCALAR);
4074 PUSHs(&PL_sv_undef);
4075 else if (SvTEMP(TOPs))
4078 if (SM_OTHER_REF(PVCV)) {
4079 /* This one has to be null-proto'd too.
4080 Call both of 'em, and compare the results */
4082 c = call_sv(SvRV(other), G_SCALAR);
4085 PUSHs(&PL_sv_undef);
4086 else if (SvTEMP(TOPs))
4098 else if ( ((SvIOK(d) || SvNOK(d)) && (this = d) && (other = e))
4099 || ((SvIOK(e) || SvNOK(e)) && (this = e) && (other = d)) )
4101 if (SvPOK(other) && !looks_like_number(other)) {
4102 /* String comparison */
4107 /* Otherwise, numeric comparison */
4110 if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
4121 /* As a last resort, use string comparison */
4130 register PERL_CONTEXT *cx;
4131 const I32 gimme = GIMME_V;
4133 /* This is essentially an optimization: if the match
4134 fails, we don't want to push a context and then
4135 pop it again right away, so we skip straight
4136 to the op that follows the leavewhen.
4138 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4139 return cLOGOP->op_other->op_next;
4144 PUSHBLOCK(cx, CXt_WHEN, SP);
4153 register PERL_CONTEXT *cx;
4159 assert(CxTYPE(cx) == CXt_WHEN);
4164 PL_curpm = newpm; /* pop $1 et al */
4174 register PERL_CONTEXT *cx;
4177 cxix = dopoptowhen(cxstack_ix);
4179 DIE(aTHX_ "Can't \"continue\" outside a when block");
4180 if (cxix < cxstack_ix)
4183 /* clear off anything above the scope we're re-entering */
4184 inner = PL_scopestack_ix;
4186 if (PL_scopestack_ix < inner)
4187 leave_scope(PL_scopestack[PL_scopestack_ix]);
4188 PL_curcop = cx->blk_oldcop;
4189 return cx->blk_givwhen.leave_op;
4196 register PERL_CONTEXT *cx;
4199 cxix = dopoptogiven(cxstack_ix);
4201 if (PL_op->op_flags & OPf_SPECIAL)
4202 DIE(aTHX_ "Can't use when() outside a topicalizer");
4204 DIE(aTHX_ "Can't \"break\" outside a given block");
4206 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4207 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4209 if (cxix < cxstack_ix)
4212 /* clear off anything above the scope we're re-entering */
4213 inner = PL_scopestack_ix;
4215 if (PL_scopestack_ix < inner)
4216 leave_scope(PL_scopestack[PL_scopestack_ix]);
4217 PL_curcop = cx->blk_oldcop;
4220 return cx->blk_loop.next_op;
4222 return cx->blk_givwhen.leave_op;
4226 S_doparseform(pTHX_ SV *sv)
4229 register char *s = SvPV_force(sv, len);
4230 register char * const send = s + len;
4231 register char *base = NULL;
4232 register I32 skipspaces = 0;
4233 bool noblank = FALSE;
4234 bool repeat = FALSE;
4235 bool postspace = FALSE;
4241 bool unchopnum = FALSE;
4242 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4245 Perl_croak(aTHX_ "Null picture in formline");
4247 /* estimate the buffer size needed */
4248 for (base = s; s <= send; s++) {
4249 if (*s == '\n' || *s == '@' || *s == '^')
4255 Newx(fops, maxops, U32);
4260 *fpc++ = FF_LINEMARK;
4261 noblank = repeat = FALSE;
4279 case ' ': case '\t':
4286 } /* else FALL THROUGH */
4294 *fpc++ = FF_LITERAL;
4302 *fpc++ = (U16)skipspaces;
4306 *fpc++ = FF_NEWLINE;
4310 arg = fpc - linepc + 1;
4317 *fpc++ = FF_LINEMARK;
4318 noblank = repeat = FALSE;
4327 ischop = s[-1] == '^';
4333 arg = (s - base) - 1;
4335 *fpc++ = FF_LITERAL;
4343 *fpc++ = 2; /* skip the @* or ^* */
4345 *fpc++ = FF_LINESNGL;
4348 *fpc++ = FF_LINEGLOB;
4350 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4351 arg = ischop ? 512 : 0;
4356 const char * const f = ++s;
4359 arg |= 256 + (s - f);
4361 *fpc++ = s - base; /* fieldsize for FETCH */
4362 *fpc++ = FF_DECIMAL;
4364 unchopnum |= ! ischop;
4366 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4367 arg = ischop ? 512 : 0;
4369 s++; /* skip the '0' first */
4373 const char * const f = ++s;
4376 arg |= 256 + (s - f);
4378 *fpc++ = s - base; /* fieldsize for FETCH */
4379 *fpc++ = FF_0DECIMAL;
4381 unchopnum |= ! ischop;
4385 bool ismore = FALSE;
4388 while (*++s == '>') ;
4389 prespace = FF_SPACE;
4391 else if (*s == '|') {
4392 while (*++s == '|') ;
4393 prespace = FF_HALFSPACE;
4398 while (*++s == '<') ;
4401 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4405 *fpc++ = s - base; /* fieldsize for FETCH */
4407 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4410 *fpc++ = (U16)prespace;
4424 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4426 { /* need to jump to the next word */
4428 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4429 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4430 s = SvPVX(sv) + SvCUR(sv) + z;
4432 Copy(fops, s, arg, U32);
4434 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4437 if (unchopnum && repeat)
4438 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4444 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4446 /* Can value be printed in fldsize chars, using %*.*f ? */
4450 int intsize = fldsize - (value < 0 ? 1 : 0);
4457 while (intsize--) pwr *= 10.0;
4458 while (frcsize--) eps /= 10.0;
4461 if (value + eps >= pwr)
4464 if (value - eps <= -pwr)
4471 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4474 SV * const datasv = FILTER_DATA(idx);
4475 const int filter_has_file = IoLINES(datasv);
4476 GV * const filter_child_proc = (GV *)IoFMT_GV(datasv);
4477 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4478 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4481 /* I was having segfault trouble under Linux 2.2.5 after a
4482 parse error occured. (Had to hack around it with a test
4483 for PL_error_count == 0.) Solaris doesn't segfault --
4484 not sure where the trouble is yet. XXX */
4486 if (filter_has_file) {
4487 len = FILTER_READ(idx+1, buf_sv, maxlen);
4490 if (filter_sub && len >= 0) {
4501 PUSHs(sv_2mortal(newSViv(maxlen)));
4503 PUSHs(filter_state);
4506 count = call_sv(filter_sub, G_SCALAR);
4522 IoLINES(datasv) = 0;
4523 if (filter_child_proc) {
4524 SvREFCNT_dec(filter_child_proc);
4525 IoFMT_GV(datasv) = Nullgv;
4528 SvREFCNT_dec(filter_state);
4529 IoTOP_GV(datasv) = Nullgv;
4532 SvREFCNT_dec(filter_sub);
4533 IoBOTTOM_GV(datasv) = Nullgv;
4535 filter_del(S_run_user_filter);
4541 /* perhaps someone can come up with a better name for
4542 this? it is not really "absolute", per se ... */
4544 S_path_is_absolute(pTHX_ const char *name)
4546 if (PERL_FILE_IS_ABSOLUTE(name)
4547 #ifdef MACOS_TRADITIONAL
4550 || (*name == '.' && (name[1] == '/' ||
4551 (name[1] == '.' && name[2] == '/')))
4563 * c-indentation-style: bsd
4565 * indent-tabs-mode: t
4568 * ex: set ts=8 sts=4 sw=4 noet: