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))
48 cxix = dopoptosub(cxstack_ix);
52 switch (cxstack[cxix].blk_gimme) {
65 /* XXXX Should store the old value to allow for tie/overload - and
66 restore in regcomp, where marked with XXXX. */
76 register PMOP *pm = (PMOP*)cLOGOP->op_other;
80 /* prevent recompiling under /o and ithreads. */
81 #if defined(USE_ITHREADS)
82 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
83 if (PL_op->op_flags & OPf_STACKED) {
92 if (PL_op->op_flags & OPf_STACKED) {
93 /* multiple args; concatentate them */
95 tmpstr = PAD_SV(ARGTARG);
96 sv_setpvn(tmpstr, "", 0);
97 while (++MARK <= SP) {
98 if (PL_amagic_generation) {
100 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
101 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
103 sv_setsv(tmpstr, sv);
107 sv_catsv(tmpstr, *MARK);
116 SV *sv = SvRV(tmpstr);
118 mg = mg_find(sv, PERL_MAGIC_qr);
121 regexp * const re = (regexp *)mg->mg_obj;
122 ReREFCNT_dec(PM_GETRE(pm));
123 PM_SETRE(pm, ReREFCNT_inc(re));
127 const char *t = SvPV_const(tmpstr, len);
129 /* Check against the last compiled regexp. */
130 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
131 PM_GETRE(pm)->prelen != (I32)len ||
132 memNE(PM_GETRE(pm)->precomp, t, len))
135 ReREFCNT_dec(PM_GETRE(pm));
136 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
138 if (PL_op->op_flags & OPf_SPECIAL)
139 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
141 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
143 pm->op_pmdynflags |= PMdf_DYN_UTF8;
145 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
146 if (pm->op_pmdynflags & PMdf_UTF8)
147 t = (char*)bytes_to_utf8((U8*)t, &len);
149 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm));
150 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
152 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
153 inside tie/overload accessors. */
157 #ifndef INCOMPLETE_TAINTS
160 pm->op_pmdynflags |= PMdf_TAINTED;
162 pm->op_pmdynflags &= ~PMdf_TAINTED;
166 if (!PM_GETRE(pm)->prelen && PL_curpm)
168 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
169 pm->op_pmflags |= PMf_WHITE;
171 pm->op_pmflags &= ~PMf_WHITE;
173 /* XXX runtime compiled output needs to move to the pad */
174 if (pm->op_pmflags & PMf_KEEP) {
175 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
176 #if !defined(USE_ITHREADS)
177 /* XXX can't change the optree at runtime either */
178 cLOGOP->op_first->op_next = PL_op->op_next;
188 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
189 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
190 register SV * const dstr = cx->sb_dstr;
191 register char *s = cx->sb_s;
192 register char *m = cx->sb_m;
193 char *orig = cx->sb_orig;
194 register REGEXP * const rx = cx->sb_rx;
196 REGEXP *old = PM_GETRE(pm);
203 rxres_restore(&cx->sb_rxres, rx);
204 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
206 if (cx->sb_iters++) {
207 const I32 saviters = cx->sb_iters;
208 if (cx->sb_iters > cx->sb_maxiters)
209 DIE(aTHX_ "Substitution loop");
211 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
212 cx->sb_rxtainted |= 2;
213 sv_catsv(dstr, POPs);
214 FREETMPS; /* Prevent excess tmp stack */
217 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
218 s == m, cx->sb_targ, NULL,
219 ((cx->sb_rflags & REXEC_COPY_STR)
220 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
221 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
223 SV * const targ = cx->sb_targ;
225 assert(cx->sb_strend >= s);
226 if(cx->sb_strend > s) {
227 if (DO_UTF8(dstr) && !SvUTF8(targ))
228 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
230 sv_catpvn(dstr, s, cx->sb_strend - s);
232 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
234 #ifdef PERL_OLD_COPY_ON_WRITE
236 sv_force_normal_flags(targ, SV_COW_DROP_PV);
242 SvPV_set(targ, SvPVX(dstr));
243 SvCUR_set(targ, SvCUR(dstr));
244 SvLEN_set(targ, SvLEN(dstr));
247 SvPV_set(dstr, NULL);
250 TAINT_IF(cx->sb_rxtainted & 1);
251 PUSHs(sv_2mortal(newSViv(saviters - 1)));
253 (void)SvPOK_only_UTF8(targ);
254 TAINT_IF(cx->sb_rxtainted);
258 LEAVE_SCOPE(cx->sb_oldsave);
261 RETURNOP(pm->op_next);
263 cx->sb_iters = saviters;
265 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
268 cx->sb_orig = orig = rx->subbeg;
270 cx->sb_strend = s + (cx->sb_strend - m);
272 cx->sb_m = m = rx->startp[0] + orig;
274 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
275 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
277 sv_catpvn(dstr, s, m-s);
279 cx->sb_s = rx->endp[0] + orig;
280 { /* Update the pos() information. */
281 SV * const sv = cx->sb_targ;
284 if (SvTYPE(sv) < SVt_PVMG)
285 SvUPGRADE(sv, SVt_PVMG);
286 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
287 #ifdef PERL_OLD_COPY_ON_WRITE
289 sv_force_normal_flags(sv, 0);
291 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
300 (void)ReREFCNT_inc(rx);
301 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
302 rxres_save(&cx->sb_rxres, rx);
303 RETURNOP(pm->op_pmreplstart);
307 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
313 if (!p || p[1] < rx->nparens) {
314 #ifdef PERL_OLD_COPY_ON_WRITE
315 i = 7 + rx->nparens * 2;
317 i = 6 + rx->nparens * 2;
326 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : NULL);
327 RX_MATCH_COPIED_off(rx);
329 #ifdef PERL_OLD_COPY_ON_WRITE
330 *p++ = PTR2UV(rx->saved_copy);
331 rx->saved_copy = NULL;
336 *p++ = PTR2UV(rx->subbeg);
337 *p++ = (UV)rx->sublen;
338 for (i = 0; i <= rx->nparens; ++i) {
339 *p++ = (UV)rx->startp[i];
340 *p++ = (UV)rx->endp[i];
345 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
351 RX_MATCH_COPY_FREE(rx);
352 RX_MATCH_COPIED_set(rx, *p);
355 #ifdef PERL_OLD_COPY_ON_WRITE
357 SvREFCNT_dec (rx->saved_copy);
358 rx->saved_copy = INT2PTR(SV*,*p);
364 rx->subbeg = INT2PTR(char*,*p++);
365 rx->sublen = (I32)(*p++);
366 for (i = 0; i <= rx->nparens; ++i) {
367 rx->startp[i] = (I32)(*p++);
368 rx->endp[i] = (I32)(*p++);
373 Perl_rxres_free(pTHX_ void **rsp)
375 UV * const p = (UV*)*rsp;
380 void *tmp = INT2PTR(char*,*p);
383 PoisonFree(*p, 1, sizeof(*p));
385 Safefree(INT2PTR(char*,*p));
387 #ifdef PERL_OLD_COPY_ON_WRITE
389 SvREFCNT_dec (INT2PTR(SV*,p[1]));
399 dVAR; dSP; dMARK; dORIGMARK;
400 register SV * const tmpForm = *++MARK;
405 register SV *sv = NULL;
406 const char *item = NULL;
410 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
411 const char *chophere = NULL;
412 char *linemark = NULL;
414 bool gotsome = FALSE;
416 const STRLEN fudge = SvPOK(tmpForm)
417 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
418 bool item_is_utf8 = FALSE;
419 bool targ_is_utf8 = FALSE;
421 OP * parseres = NULL;
425 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
426 if (SvREADONLY(tmpForm)) {
427 SvREADONLY_off(tmpForm);
428 parseres = doparseform(tmpForm);
429 SvREADONLY_on(tmpForm);
432 parseres = doparseform(tmpForm);
436 SvPV_force(PL_formtarget, len);
437 if (DO_UTF8(PL_formtarget))
439 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
441 f = SvPV_const(tmpForm, len);
442 /* need to jump to the next word */
443 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
447 const char *name = "???";
450 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
451 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
452 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
453 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
454 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
456 case FF_CHECKNL: name = "CHECKNL"; break;
457 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
458 case FF_SPACE: name = "SPACE"; break;
459 case FF_HALFSPACE: name = "HALFSPACE"; break;
460 case FF_ITEM: name = "ITEM"; break;
461 case FF_CHOP: name = "CHOP"; break;
462 case FF_LINEGLOB: name = "LINEGLOB"; break;
463 case FF_NEWLINE: name = "NEWLINE"; break;
464 case FF_MORE: name = "MORE"; break;
465 case FF_LINEMARK: name = "LINEMARK"; break;
466 case FF_END: name = "END"; break;
467 case FF_0DECIMAL: name = "0DECIMAL"; break;
468 case FF_LINESNGL: name = "LINESNGL"; break;
471 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
473 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
484 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
485 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
487 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
488 t = SvEND(PL_formtarget);
491 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
492 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
494 sv_utf8_upgrade(PL_formtarget);
495 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
496 t = SvEND(PL_formtarget);
516 if (ckWARN(WARN_SYNTAX))
517 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
524 const char *s = item = SvPV_const(sv, len);
527 itemsize = sv_len_utf8(sv);
528 if (itemsize != (I32)len) {
530 if (itemsize > fieldsize) {
531 itemsize = fieldsize;
532 itembytes = itemsize;
533 sv_pos_u2b(sv, &itembytes, 0);
537 send = chophere = s + itembytes;
547 sv_pos_b2u(sv, &itemsize);
551 item_is_utf8 = FALSE;
552 if (itemsize > fieldsize)
553 itemsize = fieldsize;
554 send = chophere = s + itemsize;
568 const char *s = item = SvPV_const(sv, len);
571 itemsize = sv_len_utf8(sv);
572 if (itemsize != (I32)len) {
574 if (itemsize <= fieldsize) {
575 const char *send = chophere = s + itemsize;
588 itemsize = fieldsize;
589 itembytes = itemsize;
590 sv_pos_u2b(sv, &itembytes, 0);
591 send = chophere = s + itembytes;
592 while (s < send || (s == send && isSPACE(*s))) {
602 if (strchr(PL_chopset, *s))
607 itemsize = chophere - item;
608 sv_pos_b2u(sv, &itemsize);
614 item_is_utf8 = FALSE;
615 if (itemsize <= fieldsize) {
616 const char *const send = chophere = s + itemsize;
629 itemsize = fieldsize;
630 send = chophere = s + itemsize;
631 while (s < send || (s == send && isSPACE(*s))) {
641 if (strchr(PL_chopset, *s))
646 itemsize = chophere - item;
652 arg = fieldsize - itemsize;
661 arg = fieldsize - itemsize;
672 const char *s = item;
676 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
678 sv_utf8_upgrade(PL_formtarget);
679 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
680 t = SvEND(PL_formtarget);
684 if (UTF8_IS_CONTINUED(*s)) {
685 STRLEN skip = UTF8SKIP(s);
702 if ( !((*t++ = *s++) & ~31) )
708 if (targ_is_utf8 && !item_is_utf8) {
709 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
711 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
712 for (; t < SvEND(PL_formtarget); t++) {
725 const int ch = *t++ = *s++;
728 if ( !((*t++ = *s++) & ~31) )
737 const char *s = chophere;
755 const char *s = item = SvPV_const(sv, len);
757 if ((item_is_utf8 = DO_UTF8(sv)))
758 itemsize = sv_len_utf8(sv);
760 bool chopped = FALSE;
761 const char *const send = s + len;
763 chophere = s + itemsize;
779 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
781 SvUTF8_on(PL_formtarget);
783 SvCUR_set(sv, chophere - item);
784 sv_catsv(PL_formtarget, sv);
785 SvCUR_set(sv, itemsize);
787 sv_catsv(PL_formtarget, sv);
789 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
790 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
791 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
800 #if defined(USE_LONG_DOUBLE)
801 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
803 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
808 #if defined(USE_LONG_DOUBLE)
809 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
811 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
814 /* If the field is marked with ^ and the value is undefined,
816 if ((arg & 512) && !SvOK(sv)) {
824 /* overflow evidence */
825 if (num_overflow(value, fieldsize, arg)) {
831 /* Formats aren't yet marked for locales, so assume "yes". */
833 STORE_NUMERIC_STANDARD_SET_LOCAL();
834 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
835 RESTORE_NUMERIC_STANDARD();
842 while (t-- > linemark && *t == ' ') ;
850 if (arg) { /* repeat until fields exhausted? */
852 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
853 lines += FmLINES(PL_formtarget);
856 if (strnEQ(linemark, linemark - arg, arg))
857 DIE(aTHX_ "Runaway format");
860 SvUTF8_on(PL_formtarget);
861 FmLINES(PL_formtarget) = lines;
863 RETURNOP(cLISTOP->op_first);
874 const char *s = chophere;
875 const char *send = item + len;
877 while (isSPACE(*s) && (s < send))
882 arg = fieldsize - itemsize;
889 if (strnEQ(s1," ",3)) {
890 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
901 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
903 SvUTF8_on(PL_formtarget);
904 FmLINES(PL_formtarget) += lines;
916 if (PL_stack_base + *PL_markstack_ptr == SP) {
918 if (GIMME_V == G_SCALAR)
919 XPUSHs(sv_2mortal(newSViv(0)));
920 RETURNOP(PL_op->op_next->op_next);
922 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
923 pp_pushmark(); /* push dst */
924 pp_pushmark(); /* push src */
925 ENTER; /* enter outer scope */
928 if (PL_op->op_private & OPpGREP_LEX)
929 SAVESPTR(PAD_SVl(PL_op->op_targ));
932 ENTER; /* enter inner scope */
935 src = PL_stack_base[*PL_markstack_ptr];
937 if (PL_op->op_private & OPpGREP_LEX)
938 PAD_SVl(PL_op->op_targ) = src;
943 if (PL_op->op_type == OP_MAPSTART)
944 pp_pushmark(); /* push top */
945 return ((LOGOP*)PL_op->op_next)->op_other;
951 const I32 gimme = GIMME_V;
952 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
958 /* first, move source pointer to the next item in the source list */
959 ++PL_markstack_ptr[-1];
961 /* if there are new items, push them into the destination list */
962 if (items && gimme != G_VOID) {
963 /* might need to make room back there first */
964 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
965 /* XXX this implementation is very pessimal because the stack
966 * is repeatedly extended for every set of items. Is possible
967 * to do this without any stack extension or copying at all
968 * by maintaining a separate list over which the map iterates
969 * (like foreach does). --gsar */
971 /* everything in the stack after the destination list moves
972 * towards the end the stack by the amount of room needed */
973 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
975 /* items to shift up (accounting for the moved source pointer) */
976 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
978 /* This optimization is by Ben Tilly and it does
979 * things differently from what Sarathy (gsar)
980 * is describing. The downside of this optimization is
981 * that leaves "holes" (uninitialized and hopefully unused areas)
982 * to the Perl stack, but on the other hand this
983 * shouldn't be a problem. If Sarathy's idea gets
984 * implemented, this optimization should become
985 * irrelevant. --jhi */
987 shift = count; /* Avoid shifting too often --Ben Tilly */
992 PL_markstack_ptr[-1] += shift;
993 *PL_markstack_ptr += shift;
997 /* copy the new items down to the destination list */
998 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
999 if (gimme == G_ARRAY) {
1001 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1004 /* scalar context: we don't care about which values map returns
1005 * (we use undef here). And so we certainly don't want to do mortal
1006 * copies of meaningless values. */
1007 while (items-- > 0) {
1009 *dst-- = &PL_sv_undef;
1013 LEAVE; /* exit inner scope */
1016 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1018 (void)POPMARK; /* pop top */
1019 LEAVE; /* exit outer scope */
1020 (void)POPMARK; /* pop src */
1021 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1022 (void)POPMARK; /* pop dst */
1023 SP = PL_stack_base + POPMARK; /* pop original mark */
1024 if (gimme == G_SCALAR) {
1025 if (PL_op->op_private & OPpGREP_LEX) {
1026 SV* sv = sv_newmortal();
1027 sv_setiv(sv, items);
1035 else if (gimme == G_ARRAY)
1042 ENTER; /* enter inner scope */
1045 /* set $_ to the new source item */
1046 src = PL_stack_base[PL_markstack_ptr[-1]];
1048 if (PL_op->op_private & OPpGREP_LEX)
1049 PAD_SVl(PL_op->op_targ) = src;
1053 RETURNOP(cLOGOP->op_other);
1062 if (GIMME == G_ARRAY)
1064 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1065 return cLOGOP->op_other;
1075 if (GIMME == G_ARRAY) {
1076 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1080 SV * const targ = PAD_SV(PL_op->op_targ);
1083 if (PL_op->op_private & OPpFLIP_LINENUM) {
1084 if (GvIO(PL_last_in_gv)) {
1085 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1088 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1090 flip = SvIV(sv) == SvIV(GvSV(gv));
1096 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1097 if (PL_op->op_flags & OPf_SPECIAL) {
1105 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1108 sv_setpvn(TARG, "", 0);
1114 /* This code tries to decide if "$left .. $right" should use the
1115 magical string increment, or if the range is numeric (we make
1116 an exception for .."0" [#18165]). AMS 20021031. */
1118 #define RANGE_IS_NUMERIC(left,right) ( \
1119 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1120 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1121 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1122 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1123 && (!SvOK(right) || looks_like_number(right))))
1129 if (GIMME == G_ARRAY) {
1135 if (RANGE_IS_NUMERIC(left,right)) {
1138 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1139 (SvOK(right) && SvNV(right) > IV_MAX))
1140 DIE(aTHX_ "Range iterator outside integer range");
1151 SV * const sv = sv_2mortal(newSViv(i++));
1156 SV * const final = sv_mortalcopy(right);
1158 const char * const tmps = SvPV_const(final, len);
1160 SV *sv = sv_mortalcopy(left);
1161 SvPV_force_nolen(sv);
1162 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1164 if (strEQ(SvPVX_const(sv),tmps))
1166 sv = sv_2mortal(newSVsv(sv));
1173 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1177 if (PL_op->op_private & OPpFLIP_LINENUM) {
1178 if (GvIO(PL_last_in_gv)) {
1179 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1182 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1183 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1191 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1192 sv_catpvs(targ, "E0");
1202 static const char * const context_name[] = {
1215 S_dopoptolabel(pTHX_ const char *label)
1220 for (i = cxstack_ix; i >= 0; i--) {
1221 register const PERL_CONTEXT * const cx = &cxstack[i];
1222 switch (CxTYPE(cx)) {
1230 if (ckWARN(WARN_EXITING))
1231 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1232 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1233 if (CxTYPE(cx) == CXt_NULL)
1237 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1238 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1239 (long)i, cx->blk_loop.label));
1242 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1252 Perl_dowantarray(pTHX)
1255 const I32 gimme = block_gimme();
1256 return (gimme == G_VOID) ? G_SCALAR : gimme;
1260 Perl_block_gimme(pTHX)
1263 const I32 cxix = dopoptosub(cxstack_ix);
1267 switch (cxstack[cxix].blk_gimme) {
1275 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1282 Perl_is_lvalue_sub(pTHX)
1285 const I32 cxix = dopoptosub(cxstack_ix);
1286 assert(cxix >= 0); /* We should only be called from inside subs */
1288 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1289 return cxstack[cxix].blk_sub.lval;
1295 S_dopoptosub(pTHX_ I32 startingblock)
1298 return dopoptosub_at(cxstack, startingblock);
1302 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1306 for (i = startingblock; i >= 0; i--) {
1307 register const PERL_CONTEXT * const cx = &cxstk[i];
1308 switch (CxTYPE(cx)) {
1314 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1322 S_dopoptoeval(pTHX_ I32 startingblock)
1326 for (i = startingblock; i >= 0; i--) {
1327 register const PERL_CONTEXT *cx = &cxstack[i];
1328 switch (CxTYPE(cx)) {
1332 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1340 S_dopoptoloop(pTHX_ I32 startingblock)
1344 for (i = startingblock; i >= 0; i--) {
1345 register const PERL_CONTEXT * const cx = &cxstack[i];
1346 switch (CxTYPE(cx)) {
1352 if (ckWARN(WARN_EXITING))
1353 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1354 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1355 if ((CxTYPE(cx)) == CXt_NULL)
1359 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1367 S_dopoptogiven(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 given #%ld)\n", (long)i));
1380 if (CxFOREACHDEF(cx)) {
1381 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1390 S_dopoptowhen(pTHX_ I32 startingblock)
1394 for (i = startingblock; i >= 0; i--) {
1395 register const PERL_CONTEXT *cx = &cxstack[i];
1396 switch (CxTYPE(cx)) {
1400 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1408 Perl_dounwind(pTHX_ I32 cxix)
1413 while (cxstack_ix > cxix) {
1415 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1416 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1417 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1418 /* Note: we don't need to restore the base context info till the end. */
1419 switch (CxTYPE(cx)) {
1422 continue; /* not break */
1441 PERL_UNUSED_VAR(optype);
1445 Perl_qerror(pTHX_ SV *err)
1449 sv_catsv(ERRSV, err);
1451 sv_catsv(PL_errors, err);
1453 Perl_warn(aTHX_ "%"SVf, err);
1458 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1467 if (PL_in_eval & EVAL_KEEPERR) {
1468 static const char prefix[] = "\t(in cleanup) ";
1469 SV * const err = ERRSV;
1470 const char *e = NULL;
1472 sv_setpvn(err,"",0);
1473 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1475 e = SvPV_const(err, len);
1477 if (*e != *message || strNE(e,message))
1481 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1482 sv_catpvn(err, prefix, sizeof(prefix)-1);
1483 sv_catpvn(err, message, msglen);
1484 if (ckWARN(WARN_MISC)) {
1485 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1486 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1491 sv_setpvn(ERRSV, message, msglen);
1495 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1496 && PL_curstackinfo->si_prev)
1504 register PERL_CONTEXT *cx;
1507 if (cxix < cxstack_ix)
1510 POPBLOCK(cx,PL_curpm);
1511 if (CxTYPE(cx) != CXt_EVAL) {
1513 message = SvPVx_const(ERRSV, msglen);
1514 PerlIO_write(Perl_error_log, "panic: die ", 11);
1515 PerlIO_write(Perl_error_log, message, msglen);
1520 if (gimme == G_SCALAR)
1521 *++newsp = &PL_sv_undef;
1522 PL_stack_sp = newsp;
1526 /* LEAVE could clobber PL_curcop (see save_re_context())
1527 * XXX it might be better to find a way to avoid messing with
1528 * PL_curcop in save_re_context() instead, but this is a more
1529 * minimal fix --GSAR */
1530 PL_curcop = cx->blk_oldcop;
1532 if (optype == OP_REQUIRE) {
1533 const char* const msg = SvPVx_nolen_const(ERRSV);
1534 SV * const nsv = cx->blk_eval.old_namesv;
1535 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1537 DIE(aTHX_ "%sCompilation failed in require",
1538 *msg ? msg : "Unknown error\n");
1540 assert(CxTYPE(cx) == CXt_EVAL);
1541 return cx->blk_eval.retop;
1545 message = SvPVx_const(ERRSV, msglen);
1547 write_to_stderr(message, msglen);
1555 dVAR; dSP; dPOPTOPssrl;
1556 if (SvTRUE(left) != SvTRUE(right))
1566 register I32 cxix = dopoptosub(cxstack_ix);
1567 register const PERL_CONTEXT *cx;
1568 register const PERL_CONTEXT *ccstack = cxstack;
1569 const PERL_SI *top_si = PL_curstackinfo;
1571 const char *stashname;
1578 /* we may be in a higher stacklevel, so dig down deeper */
1579 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1580 top_si = top_si->si_prev;
1581 ccstack = top_si->si_cxstack;
1582 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1585 if (GIMME != G_ARRAY) {
1591 /* caller() should not report the automatic calls to &DB::sub */
1592 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1593 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1597 cxix = dopoptosub_at(ccstack, cxix - 1);
1600 cx = &ccstack[cxix];
1601 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1602 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1603 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1604 field below is defined for any cx. */
1605 /* caller() should not report the automatic calls to &DB::sub */
1606 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1607 cx = &ccstack[dbcxix];
1610 stashname = CopSTASHPV(cx->blk_oldcop);
1611 if (GIMME != G_ARRAY) {
1614 PUSHs(&PL_sv_undef);
1617 sv_setpv(TARG, stashname);
1626 PUSHs(&PL_sv_undef);
1628 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1629 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1630 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1633 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1634 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1635 /* So is ccstack[dbcxix]. */
1637 SV * const sv = newSV(0);
1638 gv_efullname3(sv, cvgv, NULL);
1639 PUSHs(sv_2mortal(sv));
1640 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1643 PUSHs(sv_2mortal(newSVpvs("(unknown)")));
1644 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1648 PUSHs(sv_2mortal(newSVpvs("(eval)")));
1649 PUSHs(sv_2mortal(newSViv(0)));
1651 gimme = (I32)cx->blk_gimme;
1652 if (gimme == G_VOID)
1653 PUSHs(&PL_sv_undef);
1655 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1656 if (CxTYPE(cx) == CXt_EVAL) {
1658 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1659 PUSHs(cx->blk_eval.cur_text);
1663 else if (cx->blk_eval.old_namesv) {
1664 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1667 /* eval BLOCK (try blocks have old_namesv == 0) */
1669 PUSHs(&PL_sv_undef);
1670 PUSHs(&PL_sv_undef);
1674 PUSHs(&PL_sv_undef);
1675 PUSHs(&PL_sv_undef);
1677 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1678 && CopSTASH_eq(PL_curcop, PL_debstash))
1680 AV * const ary = cx->blk_sub.argarray;
1681 const int off = AvARRAY(ary) - AvALLOC(ary);
1684 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1685 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1687 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1690 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1691 av_extend(PL_dbargs, AvFILLp(ary) + off);
1692 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1693 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1695 /* XXX only hints propagated via op_private are currently
1696 * visible (others are not easily accessible, since they
1697 * use the global PL_hints) */
1698 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1699 HINT_PRIVATE_MASK)));
1702 SV * const old_warnings = cx->blk_oldcop->cop_warnings ;
1704 if (old_warnings == pWARN_NONE ||
1705 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1706 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1707 else if (old_warnings == pWARN_ALL ||
1708 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1709 /* Get the bit mask for $warnings::Bits{all}, because
1710 * it could have been extended by warnings::register */
1712 HV * const bits = get_hv("warnings::Bits", FALSE);
1713 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1714 mask = newSVsv(*bits_all);
1717 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1721 mask = newSVsv(old_warnings);
1722 PUSHs(sv_2mortal(mask));
1725 PUSHs(cx->blk_oldcop->cop_hints ?
1726 sv_2mortal(newRV_noinc(
1727 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1728 cx->blk_oldcop->cop_hints)))
1737 const char * const tmps = (MAXARG < 1) ? "" : POPpconstx;
1738 sv_reset(tmps, CopSTASH(PL_curcop));
1743 /* like pp_nextstate, but used instead when the debugger is active */
1748 PL_curcop = (COP*)PL_op;
1749 TAINT_NOT; /* Each statement is presumed innocent */
1750 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1753 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1754 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1757 register PERL_CONTEXT *cx;
1758 const I32 gimme = G_ARRAY;
1760 GV * const gv = PL_DBgv;
1761 register CV * const cv = GvCV(gv);
1764 DIE(aTHX_ "No DB::DB routine defined");
1766 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1767 /* don't do recursive DB::DB call */
1782 (void)(*CvXSUB(cv))(aTHX_ cv);
1789 PUSHBLOCK(cx, CXt_SUB, SP);
1791 cx->blk_sub.retop = PL_op->op_next;
1794 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1795 RETURNOP(CvSTART(cv));
1805 register PERL_CONTEXT *cx;
1806 const I32 gimme = GIMME_V;
1808 U32 cxtype = CXt_LOOP | CXp_FOREACH;
1816 if (PL_op->op_targ) {
1817 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1818 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1819 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1820 SVs_PADSTALE, SVs_PADSTALE);
1822 #ifndef USE_ITHREADS
1823 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1826 SAVEPADSV(PL_op->op_targ);
1827 iterdata = INT2PTR(void*, PL_op->op_targ);
1828 cxtype |= CXp_PADVAR;
1832 GV * const gv = (GV*)POPs;
1833 svp = &GvSV(gv); /* symbol table variable */
1834 SAVEGENERICSV(*svp);
1837 iterdata = (void*)gv;
1841 if (PL_op->op_private & OPpITER_DEF)
1842 cxtype |= CXp_FOR_DEF;
1846 PUSHBLOCK(cx, cxtype, SP);
1848 PUSHLOOP(cx, iterdata, MARK);
1850 PUSHLOOP(cx, svp, MARK);
1852 if (PL_op->op_flags & OPf_STACKED) {
1853 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1854 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1856 SV * const right = (SV*)cx->blk_loop.iterary;
1859 if (RANGE_IS_NUMERIC(sv,right)) {
1860 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1861 (SvOK(right) && SvNV(right) >= IV_MAX))
1862 DIE(aTHX_ "Range iterator outside integer range");
1863 cx->blk_loop.iterix = SvIV(sv);
1864 cx->blk_loop.itermax = SvIV(right);
1866 /* for correct -Dstv display */
1867 cx->blk_oldsp = sp - PL_stack_base;
1871 cx->blk_loop.iterlval = newSVsv(sv);
1872 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1873 (void) SvPV_nolen_const(right);
1876 else if (PL_op->op_private & OPpITER_REVERSED) {
1877 cx->blk_loop.itermax = 0;
1878 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1883 cx->blk_loop.iterary = PL_curstack;
1884 AvFILLp(PL_curstack) = SP - PL_stack_base;
1885 if (PL_op->op_private & OPpITER_REVERSED) {
1886 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1887 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1890 cx->blk_loop.iterix = MARK - PL_stack_base;
1900 register PERL_CONTEXT *cx;
1901 const I32 gimme = GIMME_V;
1907 PUSHBLOCK(cx, CXt_LOOP, SP);
1908 PUSHLOOP(cx, 0, SP);
1916 register PERL_CONTEXT *cx;
1923 assert(CxTYPE(cx) == CXt_LOOP);
1925 newsp = PL_stack_base + cx->blk_loop.resetsp;
1928 if (gimme == G_VOID)
1929 /*EMPTY*/; /* do nothing */
1930 else if (gimme == G_SCALAR) {
1932 *++newsp = sv_mortalcopy(*SP);
1934 *++newsp = &PL_sv_undef;
1938 *++newsp = sv_mortalcopy(*++mark);
1939 TAINT_NOT; /* Each item is independent */
1945 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1946 PL_curpm = newpm; /* ... and pop $1 et al */
1957 register PERL_CONTEXT *cx;
1958 bool popsub2 = FALSE;
1959 bool clear_errsv = FALSE;
1967 const I32 cxix = dopoptosub(cxstack_ix);
1970 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1971 * sort block, which is a CXt_NULL
1974 PL_stack_base[1] = *PL_stack_sp;
1975 PL_stack_sp = PL_stack_base + 1;
1979 DIE(aTHX_ "Can't return outside a subroutine");
1981 if (cxix < cxstack_ix)
1984 if (CxMULTICALL(&cxstack[cxix])) {
1985 gimme = cxstack[cxix].blk_gimme;
1986 if (gimme == G_VOID)
1987 PL_stack_sp = PL_stack_base;
1988 else if (gimme == G_SCALAR) {
1989 PL_stack_base[1] = *PL_stack_sp;
1990 PL_stack_sp = PL_stack_base + 1;
1996 switch (CxTYPE(cx)) {
1999 retop = cx->blk_sub.retop;
2000 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2003 if (!(PL_in_eval & EVAL_KEEPERR))
2006 retop = cx->blk_eval.retop;
2010 if (optype == OP_REQUIRE &&
2011 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2013 /* Unassume the success we assumed earlier. */
2014 SV * const nsv = cx->blk_eval.old_namesv;
2015 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2016 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
2021 retop = cx->blk_sub.retop;
2024 DIE(aTHX_ "panic: return");
2028 if (gimme == G_SCALAR) {
2031 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2033 *++newsp = SvREFCNT_inc(*SP);
2038 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2040 *++newsp = sv_mortalcopy(sv);
2045 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2048 *++newsp = sv_mortalcopy(*SP);
2051 *++newsp = &PL_sv_undef;
2053 else if (gimme == G_ARRAY) {
2054 while (++MARK <= SP) {
2055 *++newsp = (popsub2 && SvTEMP(*MARK))
2056 ? *MARK : sv_mortalcopy(*MARK);
2057 TAINT_NOT; /* Each item is independent */
2060 PL_stack_sp = newsp;
2063 /* Stack values are safe: */
2066 POPSUB(cx,sv); /* release CV and @_ ... */
2070 PL_curpm = newpm; /* ... and pop $1 et al */
2074 sv_setpvn(ERRSV,"",0);
2082 register PERL_CONTEXT *cx;
2093 if (PL_op->op_flags & OPf_SPECIAL) {
2094 cxix = dopoptoloop(cxstack_ix);
2096 DIE(aTHX_ "Can't \"last\" outside a loop block");
2099 cxix = dopoptolabel(cPVOP->op_pv);
2101 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2103 if (cxix < cxstack_ix)
2107 cxstack_ix++; /* temporarily protect top context */
2109 switch (CxTYPE(cx)) {
2112 newsp = PL_stack_base + cx->blk_loop.resetsp;
2113 nextop = cx->blk_loop.last_op->op_next;
2117 nextop = cx->blk_sub.retop;
2121 nextop = cx->blk_eval.retop;
2125 nextop = cx->blk_sub.retop;
2128 DIE(aTHX_ "panic: last");
2132 if (gimme == G_SCALAR) {
2134 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2135 ? *SP : sv_mortalcopy(*SP);
2137 *++newsp = &PL_sv_undef;
2139 else if (gimme == G_ARRAY) {
2140 while (++MARK <= SP) {
2141 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2142 ? *MARK : sv_mortalcopy(*MARK);
2143 TAINT_NOT; /* Each item is independent */
2151 /* Stack values are safe: */
2154 POPLOOP(cx); /* release loop vars ... */
2158 POPSUB(cx,sv); /* release CV and @_ ... */
2161 PL_curpm = newpm; /* ... and pop $1 et al */
2164 PERL_UNUSED_VAR(optype);
2165 PERL_UNUSED_VAR(gimme);
2173 register PERL_CONTEXT *cx;
2176 if (PL_op->op_flags & OPf_SPECIAL) {
2177 cxix = dopoptoloop(cxstack_ix);
2179 DIE(aTHX_ "Can't \"next\" outside a loop block");
2182 cxix = dopoptolabel(cPVOP->op_pv);
2184 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2186 if (cxix < cxstack_ix)
2189 /* clear off anything above the scope we're re-entering, but
2190 * save the rest until after a possible continue block */
2191 inner = PL_scopestack_ix;
2193 if (PL_scopestack_ix < inner)
2194 leave_scope(PL_scopestack[PL_scopestack_ix]);
2195 PL_curcop = cx->blk_oldcop;
2196 return cx->blk_loop.next_op;
2203 register PERL_CONTEXT *cx;
2207 if (PL_op->op_flags & OPf_SPECIAL) {
2208 cxix = dopoptoloop(cxstack_ix);
2210 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2213 cxix = dopoptolabel(cPVOP->op_pv);
2215 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2217 if (cxix < cxstack_ix)
2220 redo_op = cxstack[cxix].blk_loop.redo_op;
2221 if (redo_op->op_type == OP_ENTER) {
2222 /* pop one less context to avoid $x being freed in while (my $x..) */
2224 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2225 redo_op = redo_op->op_next;
2229 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2230 LEAVE_SCOPE(oldsave);
2232 PL_curcop = cx->blk_oldcop;
2237 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2241 static const char too_deep[] = "Target of goto is too deeply nested";
2244 Perl_croak(aTHX_ too_deep);
2245 if (o->op_type == OP_LEAVE ||
2246 o->op_type == OP_SCOPE ||
2247 o->op_type == OP_LEAVELOOP ||
2248 o->op_type == OP_LEAVESUB ||
2249 o->op_type == OP_LEAVETRY)
2251 *ops++ = cUNOPo->op_first;
2253 Perl_croak(aTHX_ too_deep);
2256 if (o->op_flags & OPf_KIDS) {
2258 /* First try all the kids at this level, since that's likeliest. */
2259 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2260 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2261 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2264 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2265 if (kid == PL_lastgotoprobe)
2267 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2270 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2271 ops[-1]->op_type == OP_DBSTATE)
2276 if ((o = dofindlabel(kid, label, ops, oplimit)))
2289 register PERL_CONTEXT *cx;
2290 #define GOTO_DEPTH 64
2291 OP *enterops[GOTO_DEPTH];
2292 const char *label = NULL;
2293 const bool do_dump = (PL_op->op_type == OP_DUMP);
2294 static const char must_have_label[] = "goto must have label";
2296 if (PL_op->op_flags & OPf_STACKED) {
2297 SV * const sv = POPs;
2299 /* This egregious kludge implements goto &subroutine */
2300 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2302 register PERL_CONTEXT *cx;
2303 CV* cv = (CV*)SvRV(sv);
2310 if (!CvROOT(cv) && !CvXSUB(cv)) {
2311 const GV * const gv = CvGV(cv);
2315 /* autoloaded stub? */
2316 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2318 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2319 GvNAMELEN(gv), FALSE);
2320 if (autogv && (cv = GvCV(autogv)))
2322 tmpstr = sv_newmortal();
2323 gv_efullname3(tmpstr, gv, NULL);
2324 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2326 DIE(aTHX_ "Goto undefined subroutine");
2329 /* First do some returnish stuff. */
2330 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2332 cxix = dopoptosub(cxstack_ix);
2334 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2335 if (cxix < cxstack_ix)
2339 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2340 if (CxTYPE(cx) == CXt_EVAL) {
2342 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2344 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2346 else if (CxMULTICALL(cx))
2347 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2348 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2349 /* put @_ back onto stack */
2350 AV* av = cx->blk_sub.argarray;
2352 items = AvFILLp(av) + 1;
2353 EXTEND(SP, items+1); /* @_ could have been extended. */
2354 Copy(AvARRAY(av), SP + 1, items, SV*);
2355 SvREFCNT_dec(GvAV(PL_defgv));
2356 GvAV(PL_defgv) = cx->blk_sub.savearray;
2358 /* abandon @_ if it got reified */
2363 av_extend(av, items-1);
2365 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2368 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2369 AV* const av = GvAV(PL_defgv);
2370 items = AvFILLp(av) + 1;
2371 EXTEND(SP, items+1); /* @_ could have been extended. */
2372 Copy(AvARRAY(av), SP + 1, items, SV*);
2376 if (CxTYPE(cx) == CXt_SUB &&
2377 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2378 SvREFCNT_dec(cx->blk_sub.cv);
2379 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2380 LEAVE_SCOPE(oldsave);
2382 /* Now do some callish stuff. */
2384 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2386 OP* const retop = cx->blk_sub.retop;
2391 for (index=0; index<items; index++)
2392 sv_2mortal(SP[-index]);
2395 /* XS subs don't have a CxSUB, so pop it */
2396 POPBLOCK(cx, PL_curpm);
2397 /* Push a mark for the start of arglist */
2400 (void)(*CvXSUB(cv))(aTHX_ cv);
2405 AV* const padlist = CvPADLIST(cv);
2406 if (CxTYPE(cx) == CXt_EVAL) {
2407 PL_in_eval = cx->blk_eval.old_in_eval;
2408 PL_eval_root = cx->blk_eval.old_eval_root;
2409 cx->cx_type = CXt_SUB;
2410 cx->blk_sub.hasargs = 0;
2412 cx->blk_sub.cv = cv;
2413 cx->blk_sub.olddepth = CvDEPTH(cv);
2416 if (CvDEPTH(cv) < 2)
2417 SvREFCNT_inc_void_NN(cv);
2419 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2420 sub_crush_depth(cv);
2421 pad_push(padlist, CvDEPTH(cv));
2424 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2425 if (cx->blk_sub.hasargs)
2427 AV* const av = (AV*)PAD_SVl(0);
2429 cx->blk_sub.savearray = GvAV(PL_defgv);
2430 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2431 CX_CURPAD_SAVE(cx->blk_sub);
2432 cx->blk_sub.argarray = av;
2434 if (items >= AvMAX(av) + 1) {
2435 SV **ary = AvALLOC(av);
2436 if (AvARRAY(av) != ary) {
2437 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2438 SvPV_set(av, (char*)ary);
2440 if (items >= AvMAX(av) + 1) {
2441 AvMAX(av) = items - 1;
2442 Renew(ary,items+1,SV*);
2444 SvPV_set(av, (char*)ary);
2448 Copy(mark,AvARRAY(av),items,SV*);
2449 AvFILLp(av) = items - 1;
2450 assert(!AvREAL(av));
2452 /* transfer 'ownership' of refcnts to new @_ */
2462 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2464 * We do not care about using sv to call CV;
2465 * it's for informational purposes only.
2467 SV * const sv = GvSV(PL_DBsub);
2469 if (PERLDB_SUB_NN) {
2470 const int type = SvTYPE(sv);
2471 if (type < SVt_PVIV && type != SVt_IV)
2472 sv_upgrade(sv, SVt_PVIV);
2474 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2476 gv_efullname3(sv, CvGV(cv), NULL);
2479 CV * const gotocv = get_cv("DB::goto", FALSE);
2481 PUSHMARK( PL_stack_sp );
2482 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2487 RETURNOP(CvSTART(cv));
2491 label = SvPV_nolen_const(sv);
2492 if (!(do_dump || *label))
2493 DIE(aTHX_ must_have_label);
2496 else if (PL_op->op_flags & OPf_SPECIAL) {
2498 DIE(aTHX_ must_have_label);
2501 label = cPVOP->op_pv;
2503 if (label && *label) {
2504 OP *gotoprobe = NULL;
2505 bool leaving_eval = FALSE;
2506 bool in_block = FALSE;
2507 PERL_CONTEXT *last_eval_cx = NULL;
2511 PL_lastgotoprobe = NULL;
2513 for (ix = cxstack_ix; ix >= 0; ix--) {
2515 switch (CxTYPE(cx)) {
2517 leaving_eval = TRUE;
2518 if (!CxTRYBLOCK(cx)) {
2519 gotoprobe = (last_eval_cx ?
2520 last_eval_cx->blk_eval.old_eval_root :
2525 /* else fall through */
2527 gotoprobe = cx->blk_oldcop->op_sibling;
2533 gotoprobe = cx->blk_oldcop->op_sibling;
2536 gotoprobe = PL_main_root;
2539 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2540 gotoprobe = CvROOT(cx->blk_sub.cv);
2546 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2549 DIE(aTHX_ "panic: goto");
2550 gotoprobe = PL_main_root;
2554 retop = dofindlabel(gotoprobe, label,
2555 enterops, enterops + GOTO_DEPTH);
2559 PL_lastgotoprobe = gotoprobe;
2562 DIE(aTHX_ "Can't find label %s", label);
2564 /* if we're leaving an eval, check before we pop any frames
2565 that we're not going to punt, otherwise the error
2568 if (leaving_eval && *enterops && enterops[1]) {
2570 for (i = 1; enterops[i]; i++)
2571 if (enterops[i]->op_type == OP_ENTERITER)
2572 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2575 /* pop unwanted frames */
2577 if (ix < cxstack_ix) {
2584 oldsave = PL_scopestack[PL_scopestack_ix];
2585 LEAVE_SCOPE(oldsave);
2588 /* push wanted frames */
2590 if (*enterops && enterops[1]) {
2591 OP * const oldop = PL_op;
2592 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2593 for (; enterops[ix]; ix++) {
2594 PL_op = enterops[ix];
2595 /* Eventually we may want to stack the needed arguments
2596 * for each op. For now, we punt on the hard ones. */
2597 if (PL_op->op_type == OP_ENTERITER)
2598 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2599 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2607 if (!retop) retop = PL_main_start;
2609 PL_restartop = retop;
2610 PL_do_undump = TRUE;
2614 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2615 PL_do_undump = FALSE;
2632 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2634 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2637 PL_exit_flags |= PERL_EXIT_EXPECTED;
2639 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2640 if (anum || !(PL_minus_c && PL_madskills))
2645 PUSHs(&PL_sv_undef);
2652 S_save_lines(pTHX_ AV *array, SV *sv)
2654 const char *s = SvPVX_const(sv);
2655 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2658 while (s && s < send) {
2660 SV * const tmpstr = newSV(0);
2662 sv_upgrade(tmpstr, SVt_PVMG);
2663 t = strchr(s, '\n');
2669 sv_setpvn(tmpstr, s, t - s);
2670 av_store(array, line++, tmpstr);
2676 S_docatch_body(pTHX)
2684 S_docatch(pTHX_ OP *o)
2688 OP * const oldop = PL_op;
2692 assert(CATCH_GET == TRUE);
2699 assert(cxstack_ix >= 0);
2700 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2701 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2706 /* die caught by an inner eval - continue inner loop */
2708 /* NB XXX we rely on the old popped CxEVAL still being at the top
2709 * of the stack; the way die_where() currently works, this
2710 * assumption is valid. In theory The cur_top_env value should be
2711 * returned in another global, the way retop (aka PL_restartop)
2713 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2716 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2718 PL_op = PL_restartop;
2735 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2736 /* sv Text to convert to OP tree. */
2737 /* startop op_free() this to undo. */
2738 /* code Short string id of the caller. */
2740 /* FIXME - how much of this code is common with pp_entereval? */
2741 dVAR; dSP; /* Make POPBLOCK work. */
2748 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2749 char *tmpbuf = tbuf;
2752 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2758 /* switch to eval mode */
2760 if (IN_PERL_COMPILETIME) {
2761 SAVECOPSTASH_FREE(&PL_compiling);
2762 CopSTASH_set(&PL_compiling, PL_curstash);
2764 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2765 SV * const sv = sv_newmortal();
2766 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2767 code, (unsigned long)++PL_evalseq,
2768 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2773 len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
2774 (unsigned long)++PL_evalseq);
2775 SAVECOPFILE_FREE(&PL_compiling);
2776 CopFILE_set(&PL_compiling, tmpbuf+2);
2777 SAVECOPLINE(&PL_compiling);
2778 CopLINE_set(&PL_compiling, 1);
2779 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2780 deleting the eval's FILEGV from the stash before gv_check() runs
2781 (i.e. before run-time proper). To work around the coredump that
2782 ensues, we always turn GvMULTI_on for any globals that were
2783 introduced within evals. See force_ident(). GSAR 96-10-12 */
2784 safestr = savepvn(tmpbuf, len);
2785 SAVEDELETE(PL_defstash, safestr, len);
2787 #ifdef OP_IN_REGISTER
2793 /* we get here either during compilation, or via pp_regcomp at runtime */
2794 runtime = IN_PERL_RUNTIME;
2796 runcv = find_runcv(NULL);
2799 PL_op->op_type = OP_ENTEREVAL;
2800 PL_op->op_flags = 0; /* Avoid uninit warning. */
2801 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2802 PUSHEVAL(cx, 0, NULL);
2805 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2807 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2808 POPBLOCK(cx,PL_curpm);
2811 (*startop)->op_type = OP_NULL;
2812 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2814 /* XXX DAPM do this properly one year */
2815 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2817 if (IN_PERL_COMPILETIME)
2818 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2819 #ifdef OP_IN_REGISTER
2822 PERL_UNUSED_VAR(newsp);
2823 PERL_UNUSED_VAR(optype);
2830 =for apidoc find_runcv
2832 Locate the CV corresponding to the currently executing sub or eval.
2833 If db_seqp is non_null, skip CVs that are in the DB package and populate
2834 *db_seqp with the cop sequence number at the point that the DB:: code was
2835 entered. (allows debuggers to eval in the scope of the breakpoint rather
2836 than in the scope of the debugger itself).
2842 Perl_find_runcv(pTHX_ U32 *db_seqp)
2848 *db_seqp = PL_curcop->cop_seq;
2849 for (si = PL_curstackinfo; si; si = si->si_prev) {
2851 for (ix = si->si_cxix; ix >= 0; ix--) {
2852 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2853 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2854 CV * const cv = cx->blk_sub.cv;
2855 /* skip DB:: code */
2856 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2857 *db_seqp = cx->blk_oldcop->cop_seq;
2862 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2870 /* Compile a require/do, an eval '', or a /(?{...})/.
2871 * In the last case, startop is non-null, and contains the address of
2872 * a pointer that should be set to the just-compiled code.
2873 * outside is the lexically enclosing CV (if any) that invoked us.
2876 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2878 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2881 OP * const saveop = PL_op;
2883 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2884 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2889 SAVESPTR(PL_compcv);
2890 PL_compcv = (CV*)newSV(0);
2891 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2892 CvEVAL_on(PL_compcv);
2893 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2894 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2896 CvOUTSIDE_SEQ(PL_compcv) = seq;
2897 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2899 /* set up a scratch pad */
2901 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2905 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2907 /* make sure we compile in the right package */
2909 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2910 SAVESPTR(PL_curstash);
2911 PL_curstash = CopSTASH(PL_curcop);
2913 SAVESPTR(PL_beginav);
2914 PL_beginav = newAV();
2915 SAVEFREESV(PL_beginav);
2916 SAVEI32(PL_error_count);
2919 SAVEI32(PL_madskills);
2923 /* try to compile it */
2925 PL_eval_root = NULL;
2927 PL_curcop = &PL_compiling;
2928 CopARYBASE_set(PL_curcop, 0);
2929 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2930 PL_in_eval |= EVAL_KEEPERR;
2932 sv_setpvn(ERRSV,"",0);
2933 if (yyparse() || PL_error_count || !PL_eval_root) {
2934 SV **newsp; /* Used by POPBLOCK. */
2935 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2936 I32 optype = 0; /* Might be reset by POPEVAL. */
2941 op_free(PL_eval_root);
2942 PL_eval_root = NULL;
2944 SP = PL_stack_base + POPMARK; /* pop original mark */
2946 POPBLOCK(cx,PL_curpm);
2952 msg = SvPVx_nolen_const(ERRSV);
2953 if (optype == OP_REQUIRE) {
2954 const SV * const nsv = cx->blk_eval.old_namesv;
2955 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2957 DIE(aTHX_ "%sCompilation failed in require",
2958 *msg ? msg : "Unknown error\n");
2961 POPBLOCK(cx,PL_curpm);
2963 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2964 (*msg ? msg : "Unknown error\n"));
2968 sv_setpv(ERRSV, "Compilation error");
2971 PERL_UNUSED_VAR(newsp);
2974 CopLINE_set(&PL_compiling, 0);
2976 *startop = PL_eval_root;
2978 SAVEFREEOP(PL_eval_root);
2980 /* Set the context for this new optree.
2981 * If the last op is an OP_REQUIRE, force scalar context.
2982 * Otherwise, propagate the context from the eval(). */
2983 if (PL_eval_root->op_type == OP_LEAVEEVAL
2984 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2985 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2987 scalar(PL_eval_root);
2988 else if (gimme & G_VOID)
2989 scalarvoid(PL_eval_root);
2990 else if (gimme & G_ARRAY)
2993 scalar(PL_eval_root);
2995 DEBUG_x(dump_eval());
2997 /* Register with debugger: */
2998 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2999 CV * const cv = get_cv("DB::postponed", FALSE);
3003 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3005 call_sv((SV*)cv, G_DISCARD);
3009 /* compiled okay, so do it */
3011 CvDEPTH(PL_compcv) = 1;
3012 SP = PL_stack_base + POPMARK; /* pop original mark */
3013 PL_op = saveop; /* The caller may need it. */
3014 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3016 RETURNOP(PL_eval_start);
3020 S_check_type_and_open(pTHX_ const char *name, const char *mode)
3023 const int st_rc = PerlLIO_stat(name, &st);
3024 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3028 return PerlIO_open(name, mode);
3032 S_doopen_pm(pTHX_ const char *name, const char *mode)
3034 #ifndef PERL_DISABLE_PMC
3035 const STRLEN namelen = strlen(name);
3038 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3039 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3040 const char * const pmc = SvPV_nolen_const(pmcsv);
3042 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3043 fp = check_type_and_open(name, mode);
3046 fp = check_type_and_open(pmc, mode);
3048 SvREFCNT_dec(pmcsv);
3051 fp = check_type_and_open(name, mode);
3055 return check_type_and_open(name, mode);
3056 #endif /* !PERL_DISABLE_PMC */
3062 register PERL_CONTEXT *cx;
3066 const char *tryname = NULL;
3068 const I32 gimme = GIMME_V;
3069 int filter_has_file = 0;
3070 PerlIO *tryrsfp = NULL;
3071 GV *filter_child_proc = NULL;
3072 SV *filter_state = NULL;
3073 SV *filter_sub = NULL;
3079 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3080 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3081 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3082 "v-string in use/require non-portable");
3084 sv = new_version(sv);
3085 if (!sv_derived_from(PL_patchlevel, "version"))
3086 upg_version(PL_patchlevel);
3087 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3088 if ( vcmp(sv,PL_patchlevel) < 0 )
3089 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3090 vnormal(sv), vnormal(PL_patchlevel));
3093 if ( vcmp(sv,PL_patchlevel) > 0 )
3094 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3095 vnormal(sv), vnormal(PL_patchlevel));
3100 name = SvPV_const(sv, len);
3101 if (!(name && len > 0 && *name))
3102 DIE(aTHX_ "Null filename used");
3103 TAINT_PROPER("require");
3104 if (PL_op->op_type == OP_REQUIRE) {
3105 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3107 if (*svp != &PL_sv_undef)
3110 DIE(aTHX_ "Compilation failed in require");
3114 /* prepare to compile file */
3116 if (path_is_absolute(name)) {
3118 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3120 #ifdef MACOS_TRADITIONAL
3124 MacPerl_CanonDir(name, newname, 1);
3125 if (path_is_absolute(newname)) {
3127 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3132 AV * const ar = GvAVn(PL_incgv);
3136 if ((unixname = tounixspec(name, NULL)) != NULL)
3140 for (i = 0; i <= AvFILL(ar); i++) {
3141 SV *dirsv = *av_fetch(ar, i, TRUE);
3147 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3148 && !sv_isobject(loader))
3150 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3153 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3154 PTR2UV(SvRV(dirsv)), name);
3155 tryname = SvPVX_const(namesv);
3166 if (sv_isobject(loader))
3167 count = call_method("INC", G_ARRAY);
3169 count = call_sv(loader, G_ARRAY);
3179 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3183 if (SvTYPE(arg) == SVt_PVGV) {
3184 IO *io = GvIO((GV *)arg);
3189 tryrsfp = IoIFP(io);
3190 if (IoTYPE(io) == IoTYPE_PIPE) {
3191 /* reading from a child process doesn't
3192 nest -- when returning from reading
3193 the inner module, the outer one is
3194 unreadable (closed?) I've tried to
3195 save the gv to manage the lifespan of
3196 the pipe, but this didn't help. XXX */
3197 filter_child_proc = (GV *)arg;
3198 SvREFCNT_inc_simple_void(filter_child_proc);
3201 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3202 PerlIO_close(IoOFP(io));
3214 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3216 SvREFCNT_inc_void_NN(filter_sub);
3219 filter_state = SP[i];
3220 SvREFCNT_inc_simple_void(filter_state);
3224 tryrsfp = PerlIO_open("/dev/null", PERL_SCRIPT_MODE);
3239 filter_has_file = 0;
3240 if (filter_child_proc) {
3241 SvREFCNT_dec(filter_child_proc);
3242 filter_child_proc = NULL;
3245 SvREFCNT_dec(filter_state);
3246 filter_state = NULL;
3249 SvREFCNT_dec(filter_sub);
3254 if (!path_is_absolute(name)
3255 #ifdef MACOS_TRADITIONAL
3256 /* We consider paths of the form :a:b ambiguous and interpret them first
3257 as global then as local
3259 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3262 const char *dir = SvPVx_nolen_const(dirsv);
3263 #ifdef MACOS_TRADITIONAL
3267 MacPerl_CanonDir(name, buf2, 1);
3268 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3272 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3274 sv_setpv(namesv, unixdir);
3275 sv_catpv(namesv, unixname);
3277 # ifdef __SYMBIAN32__
3278 if (PL_origfilename[0] &&
3279 PL_origfilename[1] == ':' &&
3280 !(dir[0] && dir[1] == ':'))
3281 Perl_sv_setpvf(aTHX_ namesv,
3286 Perl_sv_setpvf(aTHX_ namesv,
3290 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3294 TAINT_PROPER("require");
3295 tryname = SvPVX_const(namesv);
3296 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3298 if (tryname[0] == '.' && tryname[1] == '/')
3307 SAVECOPFILE_FREE(&PL_compiling);
3308 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3309 SvREFCNT_dec(namesv);
3311 if (PL_op->op_type == OP_REQUIRE) {
3312 const char *msgstr = name;
3313 if(errno == EMFILE) {
3315 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3317 msgstr = SvPV_nolen_const(msg);
3319 if (namesv) { /* did we lookup @INC? */
3320 AV * const ar = GvAVn(PL_incgv);
3322 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3323 "%s in @INC%s%s (@INC contains:",
3325 (instr(msgstr, ".h ")
3326 ? " (change .h to .ph maybe?)" : ""),
3327 (instr(msgstr, ".ph ")
3328 ? " (did you run h2ph?)" : "")
3331 for (i = 0; i <= AvFILL(ar); i++) {
3332 sv_catpvs(msg, " ");
3333 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3335 sv_catpvs(msg, ")");
3336 msgstr = SvPV_nolen_const(msg);
3339 DIE(aTHX_ "Can't locate %s", msgstr);
3345 SETERRNO(0, SS_NORMAL);
3347 /* Assume success here to prevent recursive requirement. */
3348 /* name is never assigned to again, so len is still strlen(name) */
3349 /* Check whether a hook in @INC has already filled %INC */
3351 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3353 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3355 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc_simple(hook_sv), 0 );
3360 lex_start(sv_2mortal(newSVpvs("")));
3361 SAVEGENERICSV(PL_rsfp_filters);
3362 PL_rsfp_filters = NULL;
3367 SAVESPTR(PL_compiling.cop_warnings);
3368 if (PL_dowarn & G_WARN_ALL_ON)
3369 PL_compiling.cop_warnings = pWARN_ALL ;
3370 else if (PL_dowarn & G_WARN_ALL_OFF)
3371 PL_compiling.cop_warnings = pWARN_NONE ;
3372 else if (PL_taint_warn)
3373 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3375 PL_compiling.cop_warnings = pWARN_STD ;
3376 SAVESPTR(PL_compiling.cop_io);
3377 PL_compiling.cop_io = NULL;
3379 if (filter_sub || filter_child_proc) {
3380 SV * const datasv = filter_add(S_run_user_filter, NULL);
3381 IoLINES(datasv) = filter_has_file;
3382 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3383 IoTOP_GV(datasv) = (GV *)filter_state;
3384 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3387 /* switch to eval mode */
3388 PUSHBLOCK(cx, CXt_EVAL, SP);
3389 PUSHEVAL(cx, name, NULL);
3390 cx->blk_eval.retop = PL_op->op_next;
3392 SAVECOPLINE(&PL_compiling);
3393 CopLINE_set(&PL_compiling, 0);
3397 /* Store and reset encoding. */
3398 encoding = PL_encoding;
3401 op = DOCATCH(doeval(gimme, NULL, NULL, PL_curcop->cop_seq));
3403 /* Restore encoding. */
3404 PL_encoding = encoding;
3412 register PERL_CONTEXT *cx;
3414 const I32 gimme = GIMME_V;
3415 const I32 was = PL_sub_generation;
3416 char tbuf[TYPE_DIGITS(long) + 12];
3417 char *tmpbuf = tbuf;
3423 HV *saved_hh = NULL;
3425 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3426 saved_hh = (HV*) SvREFCNT_inc(POPs);
3430 if (!SvPV_nolen_const(sv))
3432 TAINT_PROPER("eval");
3438 /* switch to eval mode */
3440 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3441 SV * const temp_sv = sv_newmortal();
3442 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3443 (unsigned long)++PL_evalseq,
3444 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3445 tmpbuf = SvPVX(temp_sv);
3446 len = SvCUR(temp_sv);
3449 len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3450 SAVECOPFILE_FREE(&PL_compiling);
3451 CopFILE_set(&PL_compiling, tmpbuf+2);
3452 SAVECOPLINE(&PL_compiling);
3453 CopLINE_set(&PL_compiling, 1);
3454 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3455 deleting the eval's FILEGV from the stash before gv_check() runs
3456 (i.e. before run-time proper). To work around the coredump that
3457 ensues, we always turn GvMULTI_on for any globals that were
3458 introduced within evals. See force_ident(). GSAR 96-10-12 */
3459 safestr = savepvn(tmpbuf, len);
3460 SAVEDELETE(PL_defstash, safestr, len);
3462 PL_hints = PL_op->op_targ;
3464 GvHV(PL_hintgv) = saved_hh;
3465 SAVESPTR(PL_compiling.cop_warnings);
3466 if (specialWARN(PL_curcop->cop_warnings))
3467 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3469 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3470 SAVEFREESV(PL_compiling.cop_warnings);
3472 SAVESPTR(PL_compiling.cop_io);
3473 if (specialCopIO(PL_curcop->cop_io))
3474 PL_compiling.cop_io = PL_curcop->cop_io;
3476 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3477 SAVEFREESV(PL_compiling.cop_io);
3479 if (PL_compiling.cop_hints) {
3480 PL_compiling.cop_hints->refcounted_he_refcnt--;
3482 PL_compiling.cop_hints = PL_curcop->cop_hints;
3483 if (PL_compiling.cop_hints) {
3485 /* PL_curcop could be pointing to an optree owned by another /.*parent/
3486 thread. We can't manipulate the reference count of the refcounted he
3487 there (race condition) so we have to do something less than
3488 pleasant to keep it read only. The simplest solution seems to be to
3489 copy their chain. We might want to cache this.
3490 Alternatively we could add a flag to the refcounted he *we* point to
3491 here saying "I don't own a reference count on the thing I point to",
3492 and arrange for Perl_refcounted_he_free() to spot that. If so, we'd
3493 still need to copy the topmost refcounted he so that we could change
3494 its flag. So still not trivial. (Flag bits could be hung from the
3496 PL_compiling.cop_hints
3497 = Perl_refcounted_he_copy(aTHX_ PL_compiling.cop_hints);
3499 PL_compiling.cop_hints->refcounted_he_refcnt++;
3502 /* special case: an eval '' executed within the DB package gets lexically
3503 * placed in the first non-DB CV rather than the current CV - this
3504 * allows the debugger to execute code, find lexicals etc, in the
3505 * scope of the code being debugged. Passing &seq gets find_runcv
3506 * to do the dirty work for us */
3507 runcv = find_runcv(&seq);
3509 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3510 PUSHEVAL(cx, 0, NULL);
3511 cx->blk_eval.retop = PL_op->op_next;
3513 /* prepare to compile string */
3515 if (PERLDB_LINE && PL_curstash != PL_debstash)
3516 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3518 ret = doeval(gimme, NULL, runcv, seq);
3519 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3520 && ret != PL_op->op_next) { /* Successive compilation. */
3521 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3523 return DOCATCH(ret);
3533 register PERL_CONTEXT *cx;
3535 const U8 save_flags = PL_op -> op_flags;
3540 retop = cx->blk_eval.retop;
3543 if (gimme == G_VOID)
3545 else if (gimme == G_SCALAR) {
3548 if (SvFLAGS(TOPs) & SVs_TEMP)
3551 *MARK = sv_mortalcopy(TOPs);
3555 *MARK = &PL_sv_undef;
3560 /* in case LEAVE wipes old return values */
3561 for (mark = newsp + 1; mark <= SP; mark++) {
3562 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3563 *mark = sv_mortalcopy(*mark);
3564 TAINT_NOT; /* Each item is independent */
3568 PL_curpm = newpm; /* Don't pop $1 et al till now */
3571 assert(CvDEPTH(PL_compcv) == 1);
3573 CvDEPTH(PL_compcv) = 0;
3576 if (optype == OP_REQUIRE &&
3577 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3579 /* Unassume the success we assumed earlier. */
3580 SV * const nsv = cx->blk_eval.old_namesv;
3581 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3582 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3583 /* die_where() did LEAVE, or we won't be here */
3587 if (!(save_flags & OPf_SPECIAL))
3588 sv_setpvn(ERRSV,"",0);
3594 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3595 close to the related Perl_create_eval_scope. */
3597 Perl_delete_eval_scope(pTHX)
3602 register PERL_CONTEXT *cx;
3609 PERL_UNUSED_VAR(newsp);
3610 PERL_UNUSED_VAR(gimme);
3611 PERL_UNUSED_VAR(optype);
3614 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3615 also needed by Perl_fold_constants. */
3617 Perl_create_eval_scope(pTHX_ U32 flags)
3620 const I32 gimme = GIMME_V;
3625 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3627 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3629 PL_in_eval = EVAL_INEVAL;
3630 if (flags & G_KEEPERR)
3631 PL_in_eval |= EVAL_KEEPERR;
3633 sv_setpvn(ERRSV,"",0);
3634 if (flags & G_FAKINGEVAL) {
3635 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3643 PERL_CONTEXT *cx = create_eval_scope(0);
3644 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3645 return DOCATCH(PL_op->op_next);
3654 register PERL_CONTEXT *cx;
3659 PERL_UNUSED_VAR(optype);
3662 if (gimme == G_VOID)
3664 else if (gimme == G_SCALAR) {
3668 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3671 *MARK = sv_mortalcopy(TOPs);
3675 *MARK = &PL_sv_undef;
3680 /* in case LEAVE wipes old return values */
3682 for (mark = newsp + 1; mark <= SP; mark++) {
3683 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3684 *mark = sv_mortalcopy(*mark);
3685 TAINT_NOT; /* Each item is independent */
3689 PL_curpm = newpm; /* Don't pop $1 et al till now */
3692 sv_setpvn(ERRSV,"",0);
3699 register PERL_CONTEXT *cx;
3700 const I32 gimme = GIMME_V;
3705 if (PL_op->op_targ == 0) {
3706 SV ** const defsv_p = &GvSV(PL_defgv);
3707 *defsv_p = newSVsv(POPs);
3708 SAVECLEARSV(*defsv_p);
3711 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3713 PUSHBLOCK(cx, CXt_GIVEN, SP);
3722 register PERL_CONTEXT *cx;
3726 PERL_UNUSED_CONTEXT;
3729 assert(CxTYPE(cx) == CXt_GIVEN);
3734 PL_curpm = newpm; /* pop $1 et al */
3741 /* Helper routines used by pp_smartmatch */
3744 S_make_matcher(pTHX_ regexp *re)
3747 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3748 PM_SETRE(matcher, ReREFCNT_inc(re));
3750 SAVEFREEOP((OP *) matcher);
3758 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3763 PL_op = (OP *) matcher;
3768 return (SvTRUEx(POPs));
3773 S_destroy_matcher(pTHX_ PMOP *matcher)
3776 PERL_UNUSED_ARG(matcher);
3781 /* Do a smart match */
3784 return do_smartmatch(NULL, NULL);
3787 /* This version of do_smartmatch() implements the following
3788 table of smart matches:
3790 $a $b Type of Match Implied Matching Code
3791 ====== ===== ===================== =============
3792 (overloading trumps everything)
3794 Code[+] Code[+] referential equality match if refaddr($a) == refaddr($b)
3795 Any Code[+] scalar sub truth match if $b->($a)
3797 Hash Hash hash keys identical match if sort(keys(%$a)) ÈeqÇ sort(keys(%$b))
3798 Hash Array hash value slice truth match if $a->{any(@$b)}
3799 Hash Regex hash key grep match if any(keys(%$a)) =~ /$b/
3800 Hash Any hash entry existence match if exists $a->{$b}
3802 Array Array arrays are identical[*] match if $a È~~Ç $b
3803 Array Regex array grep match if any(@$a) =~ /$b/
3804 Array Num array contains number match if any($a) == $b
3805 Array Any array contains string match if any($a) eq $b
3807 Any undef undefined match if !defined $a
3808 Any Regex pattern match match if $a =~ /$b/
3809 Code() Code() results are equal match if $a->() eq $b->()
3810 Any Code() simple closure truth match if $b->() (ignoring $a)
3811 Num numish[!] numeric equality match if $a == $b
3812 Any Str string equality match if $a eq $b
3813 Any Num numeric equality match if $a == $b
3815 Any Any string equality match if $a eq $b
3818 + - this must be a code reference whose prototype (if present) is not ""
3819 (subs with a "" prototype are dealt with by the 'Code()' entry lower down)
3820 * - if a circular reference is found, we fall back to referential equality
3821 ! - either a real number, or a string that looks_like_number()
3826 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3831 SV *e = TOPs; /* e is for 'expression' */
3832 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3835 regexp *this_regex, *other_regex;
3837 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3839 # define SM_REF(type) ( \
3840 (SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_##type) && (other = e)) \
3841 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_##type) && (other = d)))
3843 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3844 ((SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_PVCV) \
3845 && NOT_EMPTY_PROTO(this) && (other = e)) \
3846 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_PVCV) \
3847 && NOT_EMPTY_PROTO(this) && (other = d)))
3849 # define SM_REGEX ( \
3850 (SvROK(d) && SvMAGICAL(this = SvRV(d)) \
3851 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3852 && (this_regex = (regexp *)mg->mg_obj) \
3855 (SvROK(e) && SvMAGICAL(this = SvRV(e)) \
3856 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3857 && (this_regex = (regexp *)mg->mg_obj) \
3861 # define SM_OTHER_REF(type) \
3862 (SvROK(other) && SvTYPE(SvRV(other)) == SVt_##type)
3864 # define SM_OTHER_REGEX (SvROK(other) && SvMAGICAL(SvRV(other)) \
3865 && (mg = mg_find(SvRV(other), PERL_MAGIC_qr)) \
3866 && (other_regex = (regexp *)mg->mg_obj))
3869 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3870 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3872 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3873 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3875 tryAMAGICbinSET(smart, 0);
3877 SP -= 2; /* Pop the values */
3879 /* Take care only to invoke mg_get() once for each argument.
3880 * Currently we do this by copying the SV if it's magical. */
3883 d = sv_mortalcopy(d);
3890 e = sv_mortalcopy(e);
3895 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(other)) )
3897 if (this == SvRV(other))
3908 c = call_sv(this, G_SCALAR);
3912 else if (SvTEMP(TOPs))
3918 else if (SM_REF(PVHV)) {
3919 if (SM_OTHER_REF(PVHV)) {
3920 /* Check that the key-sets are identical */
3922 HV *other_hv = (HV *) SvRV(other);
3924 bool other_tied = FALSE;
3925 U32 this_key_count = 0,
3926 other_key_count = 0;
3928 /* Tied hashes don't know how many keys they have. */
3929 if (SvTIED_mg(this, PERL_MAGIC_tied)) {
3932 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3933 HV * const temp = other_hv;
3934 other_hv = (HV *) this;
3938 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3941 if (!tied && HvUSEDKEYS((HV *) this) != HvUSEDKEYS(other_hv))
3944 /* The hashes have the same number of keys, so it suffices
3945 to check that one is a subset of the other. */
3946 (void) hv_iterinit((HV *) this);
3947 while ( (he = hv_iternext((HV *) this)) ) {
3949 char * const key = hv_iterkey(he, &key_len);
3953 if(!hv_exists(other_hv, key, key_len)) {
3954 (void) hv_iterinit((HV *) this); /* reset iterator */
3960 (void) hv_iterinit(other_hv);
3961 while ( hv_iternext(other_hv) )
3965 other_key_count = HvUSEDKEYS(other_hv);
3967 if (this_key_count != other_key_count)
3972 else if (SM_OTHER_REF(PVAV)) {
3973 AV * const other_av = (AV *) SvRV(other);
3974 const I32 other_len = av_len(other_av) + 1;
3977 if (HvUSEDKEYS((HV *) this) != other_len)
3980 for(i = 0; i < other_len; ++i) {
3981 SV ** const svp = av_fetch(other_av, i, FALSE);
3985 if (!svp) /* ??? When can this happen? */
3988 key = SvPV(*svp, key_len);
3989 if(!hv_exists((HV *) this, key, key_len))
3994 else if (SM_OTHER_REGEX) {
3995 PMOP * const matcher = make_matcher(other_regex);
3998 (void) hv_iterinit((HV *) this);
3999 while ( (he = hv_iternext((HV *) this)) ) {
4000 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4001 (void) hv_iterinit((HV *) this);
4002 destroy_matcher(matcher);
4006 destroy_matcher(matcher);
4010 if (hv_exists_ent((HV *) this, other, 0))
4016 else if (SM_REF(PVAV)) {
4017 if (SM_OTHER_REF(PVAV)) {
4018 AV *other_av = (AV *) SvRV(other);
4019 if (av_len((AV *) this) != av_len(other_av))
4023 const I32 other_len = av_len(other_av);
4025 if (NULL == seen_this) {
4026 seen_this = newHV();
4027 (void) sv_2mortal((SV *) seen_this);
4029 if (NULL == seen_other) {
4030 seen_this = newHV();
4031 (void) sv_2mortal((SV *) seen_other);
4033 for(i = 0; i <= other_len; ++i) {
4034 SV * const * const this_elem = av_fetch((AV *)this, i, FALSE);
4035 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4037 if (!this_elem || !other_elem) {
4038 if (this_elem || other_elem)
4041 else if (SM_SEEN_THIS(*this_elem)
4042 || SM_SEEN_OTHER(*other_elem))
4044 if (*this_elem != *other_elem)
4048 hv_store_ent(seen_this,
4049 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4051 hv_store_ent(seen_other,
4052 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4058 (void) do_smartmatch(seen_this, seen_other);
4068 else if (SM_OTHER_REGEX) {
4069 PMOP * const matcher = make_matcher(other_regex);
4070 const I32 this_len = av_len((AV *) this);
4073 for(i = 0; i <= this_len; ++i) {
4074 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4075 if (svp && matcher_matches_sv(matcher, *svp)) {
4076 destroy_matcher(matcher);
4080 destroy_matcher(matcher);
4083 else if (SvIOK(other) || SvNOK(other)) {
4086 for(i = 0; i <= AvFILL((AV *) this); ++i) {
4087 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4094 if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
4104 else if (SvPOK(other)) {
4105 const I32 this_len = av_len((AV *) this);
4108 for(i = 0; i <= this_len; ++i) {
4109 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4124 else if (!SvOK(d) || !SvOK(e)) {
4125 if (!SvOK(d) && !SvOK(e))
4130 else if (SM_REGEX) {
4131 PMOP * const matcher = make_matcher(this_regex);
4134 PUSHs(matcher_matches_sv(matcher, other)
4137 destroy_matcher(matcher);
4140 else if (SM_REF(PVCV)) {
4142 /* This must be a null-prototyped sub, because we
4143 already checked for the other kind. */
4149 c = call_sv(this, G_SCALAR);
4152 PUSHs(&PL_sv_undef);
4153 else if (SvTEMP(TOPs))
4156 if (SM_OTHER_REF(PVCV)) {
4157 /* This one has to be null-proto'd too.
4158 Call both of 'em, and compare the results */
4160 c = call_sv(SvRV(other), G_SCALAR);
4163 PUSHs(&PL_sv_undef);
4164 else if (SvTEMP(TOPs))
4176 else if ( ((SvIOK(d) || SvNOK(d)) && (this = d) && (other = e))
4177 || ((SvIOK(e) || SvNOK(e)) && (this = e) && (other = d)) )
4179 if (SvPOK(other) && !looks_like_number(other)) {
4180 /* String comparison */
4185 /* Otherwise, numeric comparison */
4188 if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
4199 /* As a last resort, use string comparison */
4208 register PERL_CONTEXT *cx;
4209 const I32 gimme = GIMME_V;
4211 /* This is essentially an optimization: if the match
4212 fails, we don't want to push a context and then
4213 pop it again right away, so we skip straight
4214 to the op that follows the leavewhen.
4216 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4217 return cLOGOP->op_other->op_next;
4222 PUSHBLOCK(cx, CXt_WHEN, SP);
4231 register PERL_CONTEXT *cx;
4237 assert(CxTYPE(cx) == CXt_WHEN);
4242 PL_curpm = newpm; /* pop $1 et al */
4252 register PERL_CONTEXT *cx;
4255 cxix = dopoptowhen(cxstack_ix);
4257 DIE(aTHX_ "Can't \"continue\" outside a when block");
4258 if (cxix < cxstack_ix)
4261 /* clear off anything above the scope we're re-entering */
4262 inner = PL_scopestack_ix;
4264 if (PL_scopestack_ix < inner)
4265 leave_scope(PL_scopestack[PL_scopestack_ix]);
4266 PL_curcop = cx->blk_oldcop;
4267 return cx->blk_givwhen.leave_op;
4274 register PERL_CONTEXT *cx;
4277 cxix = dopoptogiven(cxstack_ix);
4279 if (PL_op->op_flags & OPf_SPECIAL)
4280 DIE(aTHX_ "Can't use when() outside a topicalizer");
4282 DIE(aTHX_ "Can't \"break\" outside a given block");
4284 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4285 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4287 if (cxix < cxstack_ix)
4290 /* clear off anything above the scope we're re-entering */
4291 inner = PL_scopestack_ix;
4293 if (PL_scopestack_ix < inner)
4294 leave_scope(PL_scopestack[PL_scopestack_ix]);
4295 PL_curcop = cx->blk_oldcop;
4298 return cx->blk_loop.next_op;
4300 return cx->blk_givwhen.leave_op;
4304 S_doparseform(pTHX_ SV *sv)
4307 register char *s = SvPV_force(sv, len);
4308 register char * const send = s + len;
4309 register char *base = NULL;
4310 register I32 skipspaces = 0;
4311 bool noblank = FALSE;
4312 bool repeat = FALSE;
4313 bool postspace = FALSE;
4319 bool unchopnum = FALSE;
4320 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4323 Perl_croak(aTHX_ "Null picture in formline");
4325 /* estimate the buffer size needed */
4326 for (base = s; s <= send; s++) {
4327 if (*s == '\n' || *s == '@' || *s == '^')
4333 Newx(fops, maxops, U32);
4338 *fpc++ = FF_LINEMARK;
4339 noblank = repeat = FALSE;
4357 case ' ': case '\t':
4364 } /* else FALL THROUGH */
4372 *fpc++ = FF_LITERAL;
4380 *fpc++ = (U16)skipspaces;
4384 *fpc++ = FF_NEWLINE;
4388 arg = fpc - linepc + 1;
4395 *fpc++ = FF_LINEMARK;
4396 noblank = repeat = FALSE;
4405 ischop = s[-1] == '^';
4411 arg = (s - base) - 1;
4413 *fpc++ = FF_LITERAL;
4421 *fpc++ = 2; /* skip the @* or ^* */
4423 *fpc++ = FF_LINESNGL;
4426 *fpc++ = FF_LINEGLOB;
4428 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4429 arg = ischop ? 512 : 0;
4434 const char * const f = ++s;
4437 arg |= 256 + (s - f);
4439 *fpc++ = s - base; /* fieldsize for FETCH */
4440 *fpc++ = FF_DECIMAL;
4442 unchopnum |= ! ischop;
4444 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4445 arg = ischop ? 512 : 0;
4447 s++; /* skip the '0' first */
4451 const char * const f = ++s;
4454 arg |= 256 + (s - f);
4456 *fpc++ = s - base; /* fieldsize for FETCH */
4457 *fpc++ = FF_0DECIMAL;
4459 unchopnum |= ! ischop;
4463 bool ismore = FALSE;
4466 while (*++s == '>') ;
4467 prespace = FF_SPACE;
4469 else if (*s == '|') {
4470 while (*++s == '|') ;
4471 prespace = FF_HALFSPACE;
4476 while (*++s == '<') ;
4479 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4483 *fpc++ = s - base; /* fieldsize for FETCH */
4485 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4488 *fpc++ = (U16)prespace;
4502 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4504 { /* need to jump to the next word */
4506 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4507 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4508 s = SvPVX(sv) + SvCUR(sv) + z;
4510 Copy(fops, s, arg, U32);
4512 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4515 if (unchopnum && repeat)
4516 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4522 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4524 /* Can value be printed in fldsize chars, using %*.*f ? */
4528 int intsize = fldsize - (value < 0 ? 1 : 0);
4535 while (intsize--) pwr *= 10.0;
4536 while (frcsize--) eps /= 10.0;
4539 if (value + eps >= pwr)
4542 if (value - eps <= -pwr)
4549 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4552 SV * const datasv = FILTER_DATA(idx);
4553 const int filter_has_file = IoLINES(datasv);
4554 GV * const filter_child_proc = (GV *)IoFMT_GV(datasv);
4555 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4556 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4559 /* I was having segfault trouble under Linux 2.2.5 after a
4560 parse error occured. (Had to hack around it with a test
4561 for PL_error_count == 0.) Solaris doesn't segfault --
4562 not sure where the trouble is yet. XXX */
4564 if (filter_has_file) {
4565 len = FILTER_READ(idx+1, buf_sv, maxlen);
4568 if (filter_sub && len >= 0) {
4579 PUSHs(sv_2mortal(newSViv(maxlen)));
4581 PUSHs(filter_state);
4584 count = call_sv(filter_sub, G_SCALAR);
4600 IoLINES(datasv) = 0;
4601 if (filter_child_proc) {
4602 SvREFCNT_dec(filter_child_proc);
4603 IoFMT_GV(datasv) = NULL;
4606 SvREFCNT_dec(filter_state);
4607 IoTOP_GV(datasv) = NULL;
4610 SvREFCNT_dec(filter_sub);
4611 IoBOTTOM_GV(datasv) = NULL;
4613 filter_del(S_run_user_filter);
4619 /* perhaps someone can come up with a better name for
4620 this? it is not really "absolute", per se ... */
4622 S_path_is_absolute(const char *name)
4624 if (PERL_FILE_IS_ABSOLUTE(name)
4625 #ifdef MACOS_TRADITIONAL
4628 || (*name == '.' && (name[1] == '/' ||
4629 (name[1] == '.' && name[2] == '/')))
4641 * c-indentation-style: bsd
4643 * indent-tabs-mode: t
4646 * ex: set ts=8 sts=4 sw=4 noet: