3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 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, Nullsv, PERL_MAGIC_regex_global, Nullch, 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 : Nullch);
318 RX_MATCH_COPIED_off(rx);
320 #ifdef PERL_OLD_COPY_ON_WRITE
321 *p++ = PTR2UV(rx->saved_copy);
322 rx->saved_copy = Nullsv;
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 = Nullsv;
395 const char *item = Nullch;
399 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
400 const char *chophere = Nullch;
401 char *linemark = Nullch;
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;
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 = Nullch;
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, Nullch);
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 = 0;
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, Nullch);
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), Nullch);
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) {
2492 bool leaving_eval = FALSE;
2493 bool in_block = FALSE;
2494 PERL_CONTEXT *last_eval_cx = 0;
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);
2633 const NV value = SvNVx(GvSV(cCOP->cop_gv));
2634 register I32 match = I_32(value);
2637 if (((NV)match) > value)
2638 --match; /* was fractional--truncate other way */
2640 match -= cCOP->uop.scop.scop_offset;
2643 else if (match > cCOP->uop.scop.scop_max)
2644 match = cCOP->uop.scop.scop_max;
2645 PL_op = cCOP->uop.scop.scop_next[match];
2655 PL_op = PL_op->op_next; /* can't assume anything */
2657 match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255;
2658 match -= cCOP->uop.scop.scop_offset;
2661 else if (match > cCOP->uop.scop.scop_max)
2662 match = cCOP->uop.scop.scop_max;
2663 PL_op = cCOP->uop.scop.scop_next[match];
2672 S_save_lines(pTHX_ AV *array, SV *sv)
2674 const char *s = SvPVX_const(sv);
2675 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2678 while (s && s < send) {
2680 SV * const tmpstr = NEWSV(85,0);
2682 sv_upgrade(tmpstr, SVt_PVMG);
2683 t = strchr(s, '\n');
2689 sv_setpvn(tmpstr, s, t - s);
2690 av_store(array, line++, tmpstr);
2696 S_docatch_body(pTHX)
2703 S_docatch(pTHX_ OP *o)
2706 OP * const oldop = PL_op;
2710 assert(CATCH_GET == TRUE);
2717 assert(cxstack_ix >= 0);
2718 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2719 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2724 /* die caught by an inner eval - continue inner loop */
2726 /* NB XXX we rely on the old popped CxEVAL still being at the top
2727 * of the stack; the way die_where() currently works, this
2728 * assumption is valid. In theory The cur_top_env value should be
2729 * returned in another global, the way retop (aka PL_restartop)
2731 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2734 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2736 PL_op = PL_restartop;
2753 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2754 /* sv Text to convert to OP tree. */
2755 /* startop op_free() this to undo. */
2756 /* code Short string id of the caller. */
2758 /* FIXME - how much of this code is common with pp_entereval? */
2759 dVAR; dSP; /* Make POPBLOCK work. */
2766 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2767 char *tmpbuf = tbuf;
2770 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2776 /* switch to eval mode */
2778 if (IN_PERL_COMPILETIME) {
2779 SAVECOPSTASH_FREE(&PL_compiling);
2780 CopSTASH_set(&PL_compiling, PL_curstash);
2782 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2783 SV * const sv = sv_newmortal();
2784 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2785 code, (unsigned long)++PL_evalseq,
2786 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2791 len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
2792 (unsigned long)++PL_evalseq);
2793 SAVECOPFILE_FREE(&PL_compiling);
2794 CopFILE_set(&PL_compiling, tmpbuf+2);
2795 SAVECOPLINE(&PL_compiling);
2796 CopLINE_set(&PL_compiling, 1);
2797 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2798 deleting the eval's FILEGV from the stash before gv_check() runs
2799 (i.e. before run-time proper). To work around the coredump that
2800 ensues, we always turn GvMULTI_on for any globals that were
2801 introduced within evals. See force_ident(). GSAR 96-10-12 */
2802 safestr = savepvn(tmpbuf, len);
2803 SAVEDELETE(PL_defstash, safestr, len);
2805 #ifdef OP_IN_REGISTER
2811 /* we get here either during compilation, or via pp_regcomp at runtime */
2812 runtime = IN_PERL_RUNTIME;
2814 runcv = find_runcv(NULL);
2817 PL_op->op_type = OP_ENTEREVAL;
2818 PL_op->op_flags = 0; /* Avoid uninit warning. */
2819 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2820 PUSHEVAL(cx, 0, Nullgv);
2823 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2825 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2826 POPBLOCK(cx,PL_curpm);
2829 (*startop)->op_type = OP_NULL;
2830 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2832 /* XXX DAPM do this properly one year */
2833 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2835 if (IN_PERL_COMPILETIME)
2836 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2837 #ifdef OP_IN_REGISTER
2840 PERL_UNUSED_VAR(newsp);
2841 PERL_UNUSED_VAR(optype);
2848 =for apidoc find_runcv
2850 Locate the CV corresponding to the currently executing sub or eval.
2851 If db_seqp is non_null, skip CVs that are in the DB package and populate
2852 *db_seqp with the cop sequence number at the point that the DB:: code was
2853 entered. (allows debuggers to eval in the scope of the breakpoint rather
2854 than in the scope of the debugger itself).
2860 Perl_find_runcv(pTHX_ U32 *db_seqp)
2865 *db_seqp = PL_curcop->cop_seq;
2866 for (si = PL_curstackinfo; si; si = si->si_prev) {
2868 for (ix = si->si_cxix; ix >= 0; ix--) {
2869 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2870 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2871 CV * const cv = cx->blk_sub.cv;
2872 /* skip DB:: code */
2873 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2874 *db_seqp = cx->blk_oldcop->cop_seq;
2879 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2887 /* Compile a require/do, an eval '', or a /(?{...})/.
2888 * In the last case, startop is non-null, and contains the address of
2889 * a pointer that should be set to the just-compiled code.
2890 * outside is the lexically enclosing CV (if any) that invoked us.
2893 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2895 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2898 OP * const saveop = PL_op;
2900 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2901 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2906 SAVESPTR(PL_compcv);
2907 PL_compcv = (CV*)NEWSV(1104,0);
2908 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2909 CvEVAL_on(PL_compcv);
2910 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2911 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2913 CvOUTSIDE_SEQ(PL_compcv) = seq;
2914 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2916 /* set up a scratch pad */
2918 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2921 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2923 /* make sure we compile in the right package */
2925 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2926 SAVESPTR(PL_curstash);
2927 PL_curstash = CopSTASH(PL_curcop);
2929 SAVESPTR(PL_beginav);
2930 PL_beginav = newAV();
2931 SAVEFREESV(PL_beginav);
2932 SAVEI32(PL_error_count);
2934 /* try to compile it */
2936 PL_eval_root = Nullop;
2938 PL_curcop = &PL_compiling;
2939 PL_curcop->cop_arybase = 0;
2940 if (saveop && saveop->op_flags & OPf_SPECIAL)
2941 PL_in_eval |= EVAL_KEEPERR;
2943 sv_setpvn(ERRSV,"",0);
2944 if (yyparse() || PL_error_count || !PL_eval_root) {
2945 SV **newsp; /* Used by POPBLOCK. */
2946 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2947 I32 optype = 0; /* Might be reset by POPEVAL. */
2952 op_free(PL_eval_root);
2953 PL_eval_root = Nullop;
2955 SP = PL_stack_base + POPMARK; /* pop original mark */
2957 POPBLOCK(cx,PL_curpm);
2963 msg = SvPVx_nolen_const(ERRSV);
2964 if (optype == OP_REQUIRE) {
2965 const SV * const nsv = cx->blk_eval.old_namesv;
2966 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2968 DIE(aTHX_ "%sCompilation failed in require",
2969 *msg ? msg : "Unknown error\n");
2972 POPBLOCK(cx,PL_curpm);
2974 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2975 (*msg ? msg : "Unknown error\n"));
2979 sv_setpv(ERRSV, "Compilation error");
2982 PERL_UNUSED_VAR(newsp);
2985 CopLINE_set(&PL_compiling, 0);
2987 *startop = PL_eval_root;
2989 SAVEFREEOP(PL_eval_root);
2991 /* Set the context for this new optree.
2992 * If the last op is an OP_REQUIRE, force scalar context.
2993 * Otherwise, propagate the context from the eval(). */
2994 if (PL_eval_root->op_type == OP_LEAVEEVAL
2995 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2996 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2998 scalar(PL_eval_root);
2999 else if (gimme & G_VOID)
3000 scalarvoid(PL_eval_root);
3001 else if (gimme & G_ARRAY)
3004 scalar(PL_eval_root);
3006 DEBUG_x(dump_eval());
3008 /* Register with debugger: */
3009 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3010 CV * const cv = get_cv("DB::postponed", FALSE);
3014 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3016 call_sv((SV*)cv, G_DISCARD);
3020 /* compiled okay, so do it */
3022 CvDEPTH(PL_compcv) = 1;
3023 SP = PL_stack_base + POPMARK; /* pop original mark */
3024 PL_op = saveop; /* The caller may need it. */
3025 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3027 RETURNOP(PL_eval_start);
3031 S_check_type_and_open(pTHX_ const char *name, const char *mode)
3035 st_rc = PerlLIO_stat(name, &st);
3040 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3041 Perl_die(aTHX_ "%s %s not allowed in require",
3042 S_ISDIR(st.st_mode) ? "Directory" : "Block device", name);
3044 return PerlIO_open(name, mode);
3048 S_doopen_pm(pTHX_ const char *name, const char *mode)
3050 #ifndef PERL_DISABLE_PMC
3051 const STRLEN namelen = strlen(name);
3054 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3055 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3056 const char * const pmc = SvPV_nolen_const(pmcsv);
3058 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3059 fp = check_type_and_open(name, mode);
3063 if (PerlLIO_stat(name, &pmstat) < 0 ||
3064 pmstat.st_mtime < pmcstat.st_mtime)
3066 fp = check_type_and_open(pmc, mode);
3069 fp = check_type_and_open(name, mode);
3072 SvREFCNT_dec(pmcsv);
3075 fp = check_type_and_open(name, mode);
3079 return check_type_and_open(name, mode);
3080 #endif /* !PERL_DISABLE_PMC */
3086 register PERL_CONTEXT *cx;
3090 const char *tryname = Nullch;
3091 SV *namesv = Nullsv;
3092 const I32 gimme = GIMME_V;
3093 PerlIO *tryrsfp = 0;
3094 int filter_has_file = 0;
3095 GV *filter_child_proc = 0;
3096 SV *filter_state = 0;
3103 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3104 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3105 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3106 "v-string in use/require non-portable");
3108 sv = new_version(sv);
3109 if (!sv_derived_from(PL_patchlevel, "version"))
3110 (void *)upg_version(PL_patchlevel);
3111 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3112 if ( vcmp(sv,PL_patchlevel) < 0 )
3113 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3114 vnormal(sv), vnormal(PL_patchlevel));
3117 if ( vcmp(sv,PL_patchlevel) > 0 )
3118 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3119 vnormal(sv), vnormal(PL_patchlevel));
3124 name = SvPV_const(sv, len);
3125 if (!(name && len > 0 && *name))
3126 DIE(aTHX_ "Null filename used");
3127 TAINT_PROPER("require");
3128 if (PL_op->op_type == OP_REQUIRE) {
3129 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3131 if (*svp != &PL_sv_undef)
3134 DIE(aTHX_ "Compilation failed in require");
3138 /* prepare to compile file */
3140 if (path_is_absolute(name)) {
3142 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3144 #ifdef MACOS_TRADITIONAL
3148 MacPerl_CanonDir(name, newname, 1);
3149 if (path_is_absolute(newname)) {
3151 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3156 AV * const ar = GvAVn(PL_incgv);
3160 if ((unixname = tounixspec(name, Nullch)) != Nullch)
3163 namesv = NEWSV(806, 0);
3164 for (i = 0; i <= AvFILL(ar); i++) {
3165 SV *dirsv = *av_fetch(ar, i, TRUE);
3171 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3172 && !sv_isobject(loader))
3174 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3177 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3178 PTR2UV(SvRV(dirsv)), name);
3179 tryname = SvPVX_const(namesv);
3190 if (sv_isobject(loader))
3191 count = call_method("INC", G_ARRAY);
3193 count = call_sv(loader, G_ARRAY);
3203 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3207 if (SvTYPE(arg) == SVt_PVGV) {
3208 IO *io = GvIO((GV *)arg);
3213 tryrsfp = IoIFP(io);
3214 if (IoTYPE(io) == IoTYPE_PIPE) {
3215 /* reading from a child process doesn't
3216 nest -- when returning from reading
3217 the inner module, the outer one is
3218 unreadable (closed?) I've tried to
3219 save the gv to manage the lifespan of
3220 the pipe, but this didn't help. XXX */
3221 filter_child_proc = (GV *)arg;
3222 (void)SvREFCNT_inc(filter_child_proc);
3225 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3226 PerlIO_close(IoOFP(io));
3238 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3240 (void)SvREFCNT_inc(filter_sub);
3243 filter_state = SP[i];
3244 (void)SvREFCNT_inc(filter_state);
3248 tryrsfp = PerlIO_open("/dev/null",
3264 filter_has_file = 0;
3265 if (filter_child_proc) {
3266 SvREFCNT_dec(filter_child_proc);
3267 filter_child_proc = 0;
3270 SvREFCNT_dec(filter_state);
3274 SvREFCNT_dec(filter_sub);
3279 if (!path_is_absolute(name)
3280 #ifdef MACOS_TRADITIONAL
3281 /* We consider paths of the form :a:b ambiguous and interpret them first
3282 as global then as local
3284 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3287 const char *dir = SvPVx_nolen_const(dirsv);
3288 #ifdef MACOS_TRADITIONAL
3292 MacPerl_CanonDir(name, buf2, 1);
3293 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3297 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3299 sv_setpv(namesv, unixdir);
3300 sv_catpv(namesv, unixname);
3302 # ifdef __SYMBIAN32__
3303 if (PL_origfilename[0] &&
3304 PL_origfilename[1] == ':' &&
3305 !(dir[0] && dir[1] == ':'))
3306 Perl_sv_setpvf(aTHX_ namesv,
3311 Perl_sv_setpvf(aTHX_ namesv,
3315 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3319 TAINT_PROPER("require");
3320 tryname = SvPVX_const(namesv);
3321 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3323 if (tryname[0] == '.' && tryname[1] == '/')
3332 SAVECOPFILE_FREE(&PL_compiling);
3333 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3334 SvREFCNT_dec(namesv);
3336 if (PL_op->op_type == OP_REQUIRE) {
3337 const char *msgstr = name;
3338 if(errno == EMFILE) {
3339 SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3340 sv_catpv(msg, ": ");
3341 sv_catpv(msg, Strerror(errno));
3342 msgstr = SvPV_nolen_const(msg);
3344 if (namesv) { /* did we lookup @INC? */
3345 SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3346 SV * const dirmsgsv = NEWSV(0, 0);
3347 AV * const ar = GvAVn(PL_incgv);
3349 sv_catpvn(msg, " in @INC", 8);
3350 if (instr(SvPVX_const(msg), ".h "))
3351 sv_catpv(msg, " (change .h to .ph maybe?)");
3352 if (instr(SvPVX_const(msg), ".ph "))
3353 sv_catpv(msg, " (did you run h2ph?)");
3354 sv_catpv(msg, " (@INC contains:");
3355 for (i = 0; i <= AvFILL(ar); i++) {
3356 const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
3357 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3358 sv_catsv(msg, dirmsgsv);
3360 sv_catpvn(msg, ")", 1);
3361 SvREFCNT_dec(dirmsgsv);
3362 msgstr = SvPV_nolen_const(msg);
3365 DIE(aTHX_ "Can't locate %s", msgstr);
3371 SETERRNO(0, SS_NORMAL);
3373 /* Assume success here to prevent recursive requirement. */
3374 /* name is never assigned to again, so len is still strlen(name) */
3375 /* Check whether a hook in @INC has already filled %INC */
3377 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3379 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3381 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 );
3386 lex_start(sv_2mortal(newSVpvn("",0)));
3387 SAVEGENERICSV(PL_rsfp_filters);
3388 PL_rsfp_filters = NULL;
3393 SAVESPTR(PL_compiling.cop_warnings);
3394 if (PL_dowarn & G_WARN_ALL_ON)
3395 PL_compiling.cop_warnings = pWARN_ALL ;
3396 else if (PL_dowarn & G_WARN_ALL_OFF)
3397 PL_compiling.cop_warnings = pWARN_NONE ;
3398 else if (PL_taint_warn)
3399 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3401 PL_compiling.cop_warnings = pWARN_STD ;
3402 SAVESPTR(PL_compiling.cop_io);
3403 PL_compiling.cop_io = Nullsv;
3405 if (filter_sub || filter_child_proc) {
3406 SV * const datasv = filter_add(S_run_user_filter, Nullsv);
3407 IoLINES(datasv) = filter_has_file;
3408 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3409 IoTOP_GV(datasv) = (GV *)filter_state;
3410 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3413 /* switch to eval mode */
3414 PUSHBLOCK(cx, CXt_EVAL, SP);
3415 PUSHEVAL(cx, name, Nullgv);
3416 cx->blk_eval.retop = PL_op->op_next;
3418 SAVECOPLINE(&PL_compiling);
3419 CopLINE_set(&PL_compiling, 0);
3423 /* Store and reset encoding. */
3424 encoding = PL_encoding;
3425 PL_encoding = Nullsv;
3427 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3429 /* Restore encoding. */
3430 PL_encoding = encoding;
3438 register PERL_CONTEXT *cx;
3440 const I32 gimme = GIMME_V;
3441 const I32 was = PL_sub_generation;
3442 char tbuf[TYPE_DIGITS(long) + 12];
3443 char *tmpbuf = tbuf;
3451 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3452 saved_hh = (HV*) SvREFCNT_inc(POPs);
3456 if (!SvPV_nolen_const(sv))
3458 TAINT_PROPER("eval");
3464 /* switch to eval mode */
3466 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3467 SV * const sv = sv_newmortal();
3468 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3469 (unsigned long)++PL_evalseq,
3470 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3475 len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3476 SAVECOPFILE_FREE(&PL_compiling);
3477 CopFILE_set(&PL_compiling, tmpbuf+2);
3478 SAVECOPLINE(&PL_compiling);
3479 CopLINE_set(&PL_compiling, 1);
3480 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3481 deleting the eval's FILEGV from the stash before gv_check() runs
3482 (i.e. before run-time proper). To work around the coredump that
3483 ensues, we always turn GvMULTI_on for any globals that were
3484 introduced within evals. See force_ident(). GSAR 96-10-12 */
3485 safestr = savepvn(tmpbuf, len);
3486 SAVEDELETE(PL_defstash, safestr, len);
3488 PL_hints = PL_op->op_targ;
3490 GvHV(PL_hintgv) = saved_hh;
3491 SAVESPTR(PL_compiling.cop_warnings);
3492 if (specialWARN(PL_curcop->cop_warnings))
3493 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3495 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3496 SAVEFREESV(PL_compiling.cop_warnings);
3498 SAVESPTR(PL_compiling.cop_io);
3499 if (specialCopIO(PL_curcop->cop_io))
3500 PL_compiling.cop_io = PL_curcop->cop_io;
3502 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3503 SAVEFREESV(PL_compiling.cop_io);
3505 /* special case: an eval '' executed within the DB package gets lexically
3506 * placed in the first non-DB CV rather than the current CV - this
3507 * allows the debugger to execute code, find lexicals etc, in the
3508 * scope of the code being debugged. Passing &seq gets find_runcv
3509 * to do the dirty work for us */
3510 runcv = find_runcv(&seq);
3512 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3513 PUSHEVAL(cx, 0, Nullgv);
3514 cx->blk_eval.retop = PL_op->op_next;
3516 /* prepare to compile string */
3518 if (PERLDB_LINE && PL_curstash != PL_debstash)
3519 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3521 ret = doeval(gimme, NULL, runcv, seq);
3522 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3523 && ret != PL_op->op_next) { /* Successive compilation. */
3524 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3526 return DOCATCH(ret);
3536 register PERL_CONTEXT *cx;
3538 const U8 save_flags = PL_op -> op_flags;
3543 retop = cx->blk_eval.retop;
3546 if (gimme == G_VOID)
3548 else if (gimme == G_SCALAR) {
3551 if (SvFLAGS(TOPs) & SVs_TEMP)
3554 *MARK = sv_mortalcopy(TOPs);
3558 *MARK = &PL_sv_undef;
3563 /* in case LEAVE wipes old return values */
3564 for (mark = newsp + 1; mark <= SP; mark++) {
3565 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3566 *mark = sv_mortalcopy(*mark);
3567 TAINT_NOT; /* Each item is independent */
3571 PL_curpm = newpm; /* Don't pop $1 et al till now */
3574 assert(CvDEPTH(PL_compcv) == 1);
3576 CvDEPTH(PL_compcv) = 0;
3579 if (optype == OP_REQUIRE &&
3580 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3582 /* Unassume the success we assumed earlier. */
3583 SV * const nsv = cx->blk_eval.old_namesv;
3584 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3585 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3586 /* die_where() did LEAVE, or we won't be here */
3590 if (!(save_flags & OPf_SPECIAL))
3591 sv_setpvn(ERRSV,"",0);
3600 register PERL_CONTEXT *cx;
3601 const I32 gimme = GIMME_V;
3606 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3608 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3610 PL_in_eval = EVAL_INEVAL;
3611 sv_setpvn(ERRSV,"",0);
3613 return DOCATCH(PL_op->op_next);
3623 register PERL_CONTEXT *cx;
3628 PERL_UNUSED_VAR(optype);
3631 if (gimme == G_VOID)
3633 else if (gimme == G_SCALAR) {
3636 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3639 *MARK = sv_mortalcopy(TOPs);
3643 *MARK = &PL_sv_undef;
3648 /* in case LEAVE wipes old return values */
3649 for (mark = newsp + 1; mark <= SP; mark++) {
3650 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3651 *mark = sv_mortalcopy(*mark);
3652 TAINT_NOT; /* Each item is independent */
3656 PL_curpm = newpm; /* Don't pop $1 et al till now */
3659 sv_setpvn(ERRSV,"",0);
3666 register PERL_CONTEXT *cx;
3667 const I32 gimme = GIMME_V;
3672 if (PL_op->op_targ == 0) {
3673 SV **defsv_p = &GvSV(PL_defgv);
3674 *defsv_p = newSVsv(POPs);
3675 SAVECLEARSV(*defsv_p);
3678 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3680 PUSHBLOCK(cx, CXt_GIVEN, SP);
3689 register PERL_CONTEXT *cx;
3696 assert(CxTYPE(cx) == CXt_GIVEN);
3702 PL_curpm = newpm; /* pop $1 et al */
3709 /* Helper routines used by pp_smartmatch */
3712 S_make_matcher(pTHX_ regexp *re)
3714 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3715 PM_SETRE(matcher, ReREFCNT_inc(re));
3717 SAVEFREEOP((OP *) matcher);
3725 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3729 PL_op = (OP *) matcher;
3734 return (SvTRUEx(POPs));
3739 S_destroy_matcher(pTHX_ PMOP *matcher)
3741 PERL_UNUSED_ARG(matcher);
3746 /* Do a smart match */
3749 return do_smartmatch(Nullhv, Nullhv);
3752 /* This version of do_smartmatch() implements the following
3753 table of smart matches:
3755 $a $b Type of Match Implied Matching Code
3756 ====== ===== ===================== =============
3757 (overloading trumps everything)
3759 Code[+] Code[+] referential equality match if refaddr($a) == refaddr($b)
3760 Any Code[+] scalar sub truth match if $b->($a)
3762 Hash Hash hash keys identical match if sort(keys(%$a)) ÈeqÇ sort(keys(%$b))
3763 Hash Array hash value slice truth match if $a->{any(@$b)}
3764 Hash Regex hash key grep match if any(keys(%$a)) =~ /$b/
3765 Hash Any hash entry existence match if exists $a->{$b}
3767 Array Array arrays are identical[*] match if $a È~~Ç $b
3768 Array Regex array grep match if any(@$a) =~ /$b/
3769 Array Num array contains number match if any($a) == $b
3770 Array Any array contains string match if any($a) eq $b
3772 Any undef undefined match if !defined $a
3773 Any Regex pattern match match if $a =~ /$b/
3774 Code() Code() results are equal match if $a->() eq $b->()
3775 Any Code() simple closure truth match if $b->() (ignoring $a)
3776 Num numish[!] numeric equality match if $a == $b
3777 Any Str string equality match if $a eq $b
3778 Any Num numeric equality match if $a == $b
3780 Any Any string equality match if $a eq $b
3783 + - this must be a code reference whose prototype (if present) is not ""
3784 (subs with a "" prototype are dealt with by the 'Code()' entry lower down)
3785 * - if a circular reference is found, we fall back to referential equality
3786 ! - either a real number, or a string that looks_like_number()
3791 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3795 SV *e = TOPs; /* e is for 'expression' */
3796 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3799 regexp *this_regex, *other_regex;
3801 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3803 # define SM_REF(type) ( \
3804 (SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_##type) && (other = e)) \
3805 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_##type) && (other = d)))
3807 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3808 ((SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_PVCV) \
3809 && NOT_EMPTY_PROTO(this) && (other = e)) \
3810 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_PVCV) \
3811 && NOT_EMPTY_PROTO(this) && (other = d)))
3813 # define SM_REGEX ( \
3814 (SvROK(d) && SvMAGICAL(this = SvRV(d)) \
3815 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3816 && (this_regex = (regexp *)mg->mg_obj) \
3819 (SvROK(e) && SvMAGICAL(this = SvRV(e)) \
3820 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3821 && (this_regex = (regexp *)mg->mg_obj) \
3825 # define SM_OTHER_REF(type) \
3826 (SvROK(other) && SvTYPE(SvRV(other)) == SVt_##type)
3828 # define SM_OTHER_REGEX (SvROK(other) && SvMAGICAL(SvRV(other)) \
3829 && (mg = mg_find(SvRV(other), PERL_MAGIC_qr)) \
3830 && (other_regex = (regexp *)mg->mg_obj))
3833 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3834 sv_2mortal(newSViv((IV) sv)), 0)
3836 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3837 sv_2mortal(newSViv((IV) sv)), 0)
3839 tryAMAGICbinSET(smart, 0);
3841 SP -= 2; /* Pop the values */
3843 /* Take care only to invoke mg_get() once for each argument.
3844 * Currently we do this by copying the SV if it's magical. */
3847 d = sv_mortalcopy(d);
3854 e = sv_mortalcopy(e);
3859 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(other)) )
3861 if (this == SvRV(other))
3872 c = call_sv(this, G_SCALAR);
3876 else if (SvTEMP(TOPs))
3882 else if (SM_REF(PVHV)) {
3883 if (SM_OTHER_REF(PVHV)) {
3884 /* Check that the key-sets are identical */
3886 HV *other_hv = (HV *) SvRV(other);
3888 bool other_tied = FALSE;
3889 U32 this_key_count = 0,
3890 other_key_count = 0;
3892 /* Tied hashes don't know how many keys they have. */
3893 if (SvTIED_mg(this, PERL_MAGIC_tied)) {
3896 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3897 HV * temp = other_hv;
3898 other_hv = (HV *) this;
3902 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3905 if (!tied && HvUSEDKEYS((HV *) this) != HvUSEDKEYS(other_hv))
3908 /* The hashes have the same number of keys, so it suffices
3909 to check that one is a subset of the other. */
3910 (void) hv_iterinit((HV *) this);
3911 while ( (he = hv_iternext((HV *) this)) ) {
3913 char *key = hv_iterkey(he, &key_len);
3917 if(!hv_exists(other_hv, key, key_len)) {
3918 (void) hv_iterinit((HV *) this); /* reset iterator */
3924 (void) hv_iterinit(other_hv);
3925 while ( hv_iternext(other_hv) )
3929 other_key_count = HvUSEDKEYS(other_hv);
3931 if (this_key_count != other_key_count)
3936 else if (SM_OTHER_REF(PVAV)) {
3937 AV *other_av = (AV *) SvRV(other);
3938 I32 other_len = av_len(other_av) + 1;
3941 if (HvUSEDKEYS((HV *) this) != other_len)
3944 for(i = 0; i < other_len; ++i) {
3945 SV **svp = av_fetch(other_av, i, FALSE);
3949 if (!svp) /* ??? When can this happen? */
3952 key = SvPV(*svp, key_len);
3953 if(!hv_exists((HV *) this, key, key_len))
3958 else if (SM_OTHER_REGEX) {
3959 PMOP *matcher = make_matcher(other_regex);
3962 (void) hv_iterinit((HV *) this);
3963 while ( (he = hv_iternext((HV *) this)) ) {
3964 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
3965 (void) hv_iterinit((HV *) this);
3966 destroy_matcher(matcher);
3970 destroy_matcher(matcher);
3974 if (hv_exists_ent((HV *) this, other, 0))
3980 else if (SM_REF(PVAV)) {
3981 if (SM_OTHER_REF(PVAV)) {
3982 AV *other_av = (AV *) SvRV(other);
3983 if (av_len((AV *) this) != av_len(other_av))
3987 I32 other_len = av_len(other_av);
3989 if (Nullhv == seen_this) {
3990 seen_this = newHV();
3991 (void) sv_2mortal((SV *) seen_this);
3993 if (Nullhv == seen_other) {
3994 seen_this = newHV();
3995 (void) sv_2mortal((SV *) seen_other);
3997 for(i = 0; i <= other_len; ++i) {
3998 SV **this_elem = av_fetch((AV *)this, i, FALSE);
3999 SV **other_elem = av_fetch(other_av, i, FALSE);
4001 if (!this_elem || !other_elem) {
4002 if (this_elem || other_elem)
4005 else if (SM_SEEN_THIS(*this_elem)
4006 || SM_SEEN_OTHER(*other_elem))
4008 if (*this_elem != *other_elem)
4012 hv_store_ent(seen_this,
4013 sv_2mortal(newSViv((IV) *this_elem)),
4015 hv_store_ent(seen_other,
4016 sv_2mortal(newSViv((IV) *other_elem)),
4022 (void) do_smartmatch(seen_this, seen_other);
4032 else if (SM_OTHER_REGEX) {
4033 PMOP *matcher = make_matcher(other_regex);
4035 I32 this_len = av_len((AV *) this);
4037 for(i = 0; i <= this_len; ++i) {
4038 SV ** svp = av_fetch((AV *)this, i, FALSE);
4039 if (svp && matcher_matches_sv(matcher, *svp)) {
4040 destroy_matcher(matcher);
4044 destroy_matcher(matcher);
4047 else if (SvIOK(other) || SvNOK(other)) {
4050 for(i = 0; i <= AvFILL((AV *) this); ++i) {
4051 SV ** svp = av_fetch((AV *)this, i, FALSE);
4058 if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
4068 else if (SvPOK(other)) {
4070 I32 this_len = av_len((AV *) this);
4072 for(i = 0; i <= this_len; ++i) {
4073 SV ** svp = av_fetch((AV *)this, i, FALSE);
4088 else if (!SvOK(d) || !SvOK(e)) {
4089 if (!SvOK(d) && !SvOK(e))
4094 else if (SM_REGEX) {
4095 PMOP *matcher = make_matcher(this_regex);
4098 PUSHs(matcher_matches_sv(matcher, other)
4101 destroy_matcher(matcher);
4104 else if (SM_REF(PVCV)) {
4106 /* This must be a null-prototyped sub, because we
4107 already checked for the other kind. */
4113 c = call_sv(this, G_SCALAR);
4116 PUSHs(&PL_sv_undef);
4117 else if (SvTEMP(TOPs))
4120 if (SM_OTHER_REF(PVCV)) {
4121 /* This one has to be null-proto'd too.
4122 Call both of 'em, and compare the results */
4124 c = call_sv(SvRV(other), G_SCALAR);
4127 PUSHs(&PL_sv_undef);
4128 else if (SvTEMP(TOPs))
4140 else if ( ((SvIOK(d) || SvNOK(d)) && (this = d) && (other = e))
4141 || ((SvIOK(e) || SvNOK(e)) && (this = e) && (other = d)) )
4143 if (SvPOK(other) && !looks_like_number(other)) {
4144 /* String comparison */
4149 /* Otherwise, numeric comparison */
4152 if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
4163 /* As a last resort, use string comparison */
4172 register PERL_CONTEXT *cx;
4173 const I32 gimme = GIMME_V;
4175 /* This is essentially an optimization: if the match
4176 fails, we don't want to push a context and then
4177 pop it again right away, so we skip straight
4178 to the op that follows the leavewhen.
4180 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4181 return cLOGOP->op_other->op_next;
4186 PUSHBLOCK(cx, CXt_WHEN, SP);
4195 register PERL_CONTEXT *cx;
4201 assert(CxTYPE(cx) == CXt_WHEN);
4206 PL_curpm = newpm; /* pop $1 et al */
4216 register PERL_CONTEXT *cx;
4219 cxix = dopoptowhen(cxstack_ix);
4221 DIE(aTHX_ "Can't \"continue\" outside a when block");
4222 if (cxix < cxstack_ix)
4225 /* clear off anything above the scope we're re-entering */
4226 inner = PL_scopestack_ix;
4228 if (PL_scopestack_ix < inner)
4229 leave_scope(PL_scopestack[PL_scopestack_ix]);
4230 PL_curcop = cx->blk_oldcop;
4231 return cx->blk_givwhen.leave_op;
4238 register PERL_CONTEXT *cx;
4241 cxix = dopoptogiven(cxstack_ix);
4243 if (PL_op->op_flags & OPf_SPECIAL)
4244 DIE(aTHX_ "Can't use when() outside a topicalizer");
4246 DIE(aTHX_ "Can't \"break\" outside a given block");
4248 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4249 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4251 if (cxix < cxstack_ix)
4254 /* clear off anything above the scope we're re-entering */
4255 inner = PL_scopestack_ix;
4257 if (PL_scopestack_ix < inner)
4258 leave_scope(PL_scopestack[PL_scopestack_ix]);
4259 PL_curcop = cx->blk_oldcop;
4262 return cx->blk_loop.next_op;
4264 return cx->blk_givwhen.leave_op;
4268 S_doparseform(pTHX_ SV *sv)
4271 register char *s = SvPV_force(sv, len);
4272 register char *send = s + len;
4273 register char *base = Nullch;
4274 register I32 skipspaces = 0;
4275 bool noblank = FALSE;
4276 bool repeat = FALSE;
4277 bool postspace = FALSE;
4283 bool unchopnum = FALSE;
4284 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4287 Perl_croak(aTHX_ "Null picture in formline");
4289 /* estimate the buffer size needed */
4290 for (base = s; s <= send; s++) {
4291 if (*s == '\n' || *s == '@' || *s == '^')
4297 Newx(fops, maxops, U32);
4302 *fpc++ = FF_LINEMARK;
4303 noblank = repeat = FALSE;
4321 case ' ': case '\t':
4328 } /* else FALL THROUGH */
4336 *fpc++ = FF_LITERAL;
4344 *fpc++ = (U16)skipspaces;
4348 *fpc++ = FF_NEWLINE;
4352 arg = fpc - linepc + 1;
4359 *fpc++ = FF_LINEMARK;
4360 noblank = repeat = FALSE;
4369 ischop = s[-1] == '^';
4375 arg = (s - base) - 1;
4377 *fpc++ = FF_LITERAL;
4385 *fpc++ = 2; /* skip the @* or ^* */
4387 *fpc++ = FF_LINESNGL;
4390 *fpc++ = FF_LINEGLOB;
4392 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4393 arg = ischop ? 512 : 0;
4398 const char * const f = ++s;
4401 arg |= 256 + (s - f);
4403 *fpc++ = s - base; /* fieldsize for FETCH */
4404 *fpc++ = FF_DECIMAL;
4406 unchopnum |= ! ischop;
4408 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4409 arg = ischop ? 512 : 0;
4411 s++; /* skip the '0' first */
4415 const char * const f = ++s;
4418 arg |= 256 + (s - f);
4420 *fpc++ = s - base; /* fieldsize for FETCH */
4421 *fpc++ = FF_0DECIMAL;
4423 unchopnum |= ! ischop;
4427 bool ismore = FALSE;
4430 while (*++s == '>') ;
4431 prespace = FF_SPACE;
4433 else if (*s == '|') {
4434 while (*++s == '|') ;
4435 prespace = FF_HALFSPACE;
4440 while (*++s == '<') ;
4443 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4447 *fpc++ = s - base; /* fieldsize for FETCH */
4449 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4452 *fpc++ = (U16)prespace;
4466 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4468 { /* need to jump to the next word */
4470 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4471 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4472 s = SvPVX(sv) + SvCUR(sv) + z;
4474 Copy(fops, s, arg, U32);
4476 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
4479 if (unchopnum && repeat)
4480 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4486 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4488 /* Can value be printed in fldsize chars, using %*.*f ? */
4492 int intsize = fldsize - (value < 0 ? 1 : 0);
4499 while (intsize--) pwr *= 10.0;
4500 while (frcsize--) eps /= 10.0;
4503 if (value + eps >= pwr)
4506 if (value - eps <= -pwr)
4513 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4516 SV * const datasv = FILTER_DATA(idx);
4517 const int filter_has_file = IoLINES(datasv);
4518 GV * const filter_child_proc = (GV *)IoFMT_GV(datasv);
4519 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4520 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4523 /* I was having segfault trouble under Linux 2.2.5 after a
4524 parse error occured. (Had to hack around it with a test
4525 for PL_error_count == 0.) Solaris doesn't segfault --
4526 not sure where the trouble is yet. XXX */
4528 if (filter_has_file) {
4529 len = FILTER_READ(idx+1, buf_sv, maxlen);
4532 if (filter_sub && len >= 0) {
4543 PUSHs(sv_2mortal(newSViv(maxlen)));
4545 PUSHs(filter_state);
4548 count = call_sv(filter_sub, G_SCALAR);
4564 IoLINES(datasv) = 0;
4565 if (filter_child_proc) {
4566 SvREFCNT_dec(filter_child_proc);
4567 IoFMT_GV(datasv) = Nullgv;
4570 SvREFCNT_dec(filter_state);
4571 IoTOP_GV(datasv) = Nullgv;
4574 SvREFCNT_dec(filter_sub);
4575 IoBOTTOM_GV(datasv) = Nullgv;
4577 filter_del(S_run_user_filter);
4583 /* perhaps someone can come up with a better name for
4584 this? it is not really "absolute", per se ... */
4586 S_path_is_absolute(pTHX_ const char *name)
4588 if (PERL_FILE_IS_ABSOLUTE(name)
4589 #ifdef MACOS_TRADITIONAL
4592 || (*name == '.' && (name[1] == '/' ||
4593 (name[1] == '.' && name[2] == '/')))
4605 * c-indentation-style: bsd
4607 * indent-tabs-mode: t
4610 * ex: set ts=8 sts=4 sw=4 noet: