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 Poison(*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));
1731 const char * const tmps = (MAXARG < 1) ? "" : POPpconstx;
1732 sv_reset(tmps, CopSTASH(PL_curcop));
1737 /* like pp_nextstate, but used instead when the debugger is active */
1742 PL_curcop = (COP*)PL_op;
1743 TAINT_NOT; /* Each statement is presumed innocent */
1744 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1747 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1748 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1751 register PERL_CONTEXT *cx;
1752 const I32 gimme = G_ARRAY;
1754 GV * const gv = PL_DBgv;
1755 register CV * const cv = GvCV(gv);
1758 DIE(aTHX_ "No DB::DB routine defined");
1760 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1761 /* don't do recursive DB::DB call */
1776 (void)(*CvXSUB(cv))(aTHX_ cv);
1783 PUSHBLOCK(cx, CXt_SUB, SP);
1785 cx->blk_sub.retop = PL_op->op_next;
1788 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1789 RETURNOP(CvSTART(cv));
1799 register PERL_CONTEXT *cx;
1800 const I32 gimme = GIMME_V;
1802 U32 cxtype = CXt_LOOP | CXp_FOREACH;
1810 if (PL_op->op_targ) {
1811 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1812 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1813 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1814 SVs_PADSTALE, SVs_PADSTALE);
1816 #ifndef USE_ITHREADS
1817 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1820 SAVEPADSV(PL_op->op_targ);
1821 iterdata = INT2PTR(void*, PL_op->op_targ);
1822 cxtype |= CXp_PADVAR;
1826 GV * const gv = (GV*)POPs;
1827 svp = &GvSV(gv); /* symbol table variable */
1828 SAVEGENERICSV(*svp);
1831 iterdata = (void*)gv;
1835 if (PL_op->op_private & OPpITER_DEF)
1836 cxtype |= CXp_FOR_DEF;
1840 PUSHBLOCK(cx, cxtype, SP);
1842 PUSHLOOP(cx, iterdata, MARK);
1844 PUSHLOOP(cx, svp, MARK);
1846 if (PL_op->op_flags & OPf_STACKED) {
1847 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1848 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1850 SV * const right = (SV*)cx->blk_loop.iterary;
1853 if (RANGE_IS_NUMERIC(sv,right)) {
1854 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1855 (SvOK(right) && SvNV(right) >= IV_MAX))
1856 DIE(aTHX_ "Range iterator outside integer range");
1857 cx->blk_loop.iterix = SvIV(sv);
1858 cx->blk_loop.itermax = SvIV(right);
1860 /* for correct -Dstv display */
1861 cx->blk_oldsp = sp - PL_stack_base;
1865 cx->blk_loop.iterlval = newSVsv(sv);
1866 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1867 (void) SvPV_nolen_const(right);
1870 else if (PL_op->op_private & OPpITER_REVERSED) {
1871 cx->blk_loop.itermax = 0;
1872 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1877 cx->blk_loop.iterary = PL_curstack;
1878 AvFILLp(PL_curstack) = SP - PL_stack_base;
1879 if (PL_op->op_private & OPpITER_REVERSED) {
1880 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1881 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1884 cx->blk_loop.iterix = MARK - PL_stack_base;
1894 register PERL_CONTEXT *cx;
1895 const I32 gimme = GIMME_V;
1901 PUSHBLOCK(cx, CXt_LOOP, SP);
1902 PUSHLOOP(cx, 0, SP);
1910 register PERL_CONTEXT *cx;
1917 assert(CxTYPE(cx) == CXt_LOOP);
1919 newsp = PL_stack_base + cx->blk_loop.resetsp;
1922 if (gimme == G_VOID)
1923 /*EMPTY*/; /* do nothing */
1924 else if (gimme == G_SCALAR) {
1926 *++newsp = sv_mortalcopy(*SP);
1928 *++newsp = &PL_sv_undef;
1932 *++newsp = sv_mortalcopy(*++mark);
1933 TAINT_NOT; /* Each item is independent */
1939 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1940 PL_curpm = newpm; /* ... and pop $1 et al */
1951 register PERL_CONTEXT *cx;
1952 bool popsub2 = FALSE;
1953 bool clear_errsv = FALSE;
1961 const I32 cxix = dopoptosub(cxstack_ix);
1964 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1965 * sort block, which is a CXt_NULL
1968 PL_stack_base[1] = *PL_stack_sp;
1969 PL_stack_sp = PL_stack_base + 1;
1973 DIE(aTHX_ "Can't return outside a subroutine");
1975 if (cxix < cxstack_ix)
1978 if (CxMULTICALL(&cxstack[cxix])) {
1979 gimme = cxstack[cxix].blk_gimme;
1980 if (gimme == G_VOID)
1981 PL_stack_sp = PL_stack_base;
1982 else if (gimme == G_SCALAR) {
1983 PL_stack_base[1] = *PL_stack_sp;
1984 PL_stack_sp = PL_stack_base + 1;
1990 switch (CxTYPE(cx)) {
1993 retop = cx->blk_sub.retop;
1994 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1997 if (!(PL_in_eval & EVAL_KEEPERR))
2000 retop = cx->blk_eval.retop;
2004 if (optype == OP_REQUIRE &&
2005 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2007 /* Unassume the success we assumed earlier. */
2008 SV * const nsv = cx->blk_eval.old_namesv;
2009 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2010 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
2015 retop = cx->blk_sub.retop;
2018 DIE(aTHX_ "panic: return");
2022 if (gimme == G_SCALAR) {
2025 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2027 *++newsp = SvREFCNT_inc(*SP);
2032 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2034 *++newsp = sv_mortalcopy(sv);
2039 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2042 *++newsp = sv_mortalcopy(*SP);
2045 *++newsp = &PL_sv_undef;
2047 else if (gimme == G_ARRAY) {
2048 while (++MARK <= SP) {
2049 *++newsp = (popsub2 && SvTEMP(*MARK))
2050 ? *MARK : sv_mortalcopy(*MARK);
2051 TAINT_NOT; /* Each item is independent */
2054 PL_stack_sp = newsp;
2057 /* Stack values are safe: */
2060 POPSUB(cx,sv); /* release CV and @_ ... */
2064 PL_curpm = newpm; /* ... and pop $1 et al */
2068 sv_setpvn(ERRSV,"",0);
2076 register PERL_CONTEXT *cx;
2087 if (PL_op->op_flags & OPf_SPECIAL) {
2088 cxix = dopoptoloop(cxstack_ix);
2090 DIE(aTHX_ "Can't \"last\" outside a loop block");
2093 cxix = dopoptolabel(cPVOP->op_pv);
2095 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2097 if (cxix < cxstack_ix)
2101 cxstack_ix++; /* temporarily protect top context */
2103 switch (CxTYPE(cx)) {
2106 newsp = PL_stack_base + cx->blk_loop.resetsp;
2107 nextop = cx->blk_loop.last_op->op_next;
2111 nextop = cx->blk_sub.retop;
2115 nextop = cx->blk_eval.retop;
2119 nextop = cx->blk_sub.retop;
2122 DIE(aTHX_ "panic: last");
2126 if (gimme == G_SCALAR) {
2128 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2129 ? *SP : sv_mortalcopy(*SP);
2131 *++newsp = &PL_sv_undef;
2133 else if (gimme == G_ARRAY) {
2134 while (++MARK <= SP) {
2135 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2136 ? *MARK : sv_mortalcopy(*MARK);
2137 TAINT_NOT; /* Each item is independent */
2145 /* Stack values are safe: */
2148 POPLOOP(cx); /* release loop vars ... */
2152 POPSUB(cx,sv); /* release CV and @_ ... */
2155 PL_curpm = newpm; /* ... and pop $1 et al */
2158 PERL_UNUSED_VAR(optype);
2159 PERL_UNUSED_VAR(gimme);
2167 register PERL_CONTEXT *cx;
2170 if (PL_op->op_flags & OPf_SPECIAL) {
2171 cxix = dopoptoloop(cxstack_ix);
2173 DIE(aTHX_ "Can't \"next\" outside a loop block");
2176 cxix = dopoptolabel(cPVOP->op_pv);
2178 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2180 if (cxix < cxstack_ix)
2183 /* clear off anything above the scope we're re-entering, but
2184 * save the rest until after a possible continue block */
2185 inner = PL_scopestack_ix;
2187 if (PL_scopestack_ix < inner)
2188 leave_scope(PL_scopestack[PL_scopestack_ix]);
2189 PL_curcop = cx->blk_oldcop;
2190 return cx->blk_loop.next_op;
2197 register PERL_CONTEXT *cx;
2201 if (PL_op->op_flags & OPf_SPECIAL) {
2202 cxix = dopoptoloop(cxstack_ix);
2204 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2207 cxix = dopoptolabel(cPVOP->op_pv);
2209 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2211 if (cxix < cxstack_ix)
2214 redo_op = cxstack[cxix].blk_loop.redo_op;
2215 if (redo_op->op_type == OP_ENTER) {
2216 /* pop one less context to avoid $x being freed in while (my $x..) */
2218 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2219 redo_op = redo_op->op_next;
2223 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2224 LEAVE_SCOPE(oldsave);
2226 PL_curcop = cx->blk_oldcop;
2231 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2235 static const char too_deep[] = "Target of goto is too deeply nested";
2238 Perl_croak(aTHX_ too_deep);
2239 if (o->op_type == OP_LEAVE ||
2240 o->op_type == OP_SCOPE ||
2241 o->op_type == OP_LEAVELOOP ||
2242 o->op_type == OP_LEAVESUB ||
2243 o->op_type == OP_LEAVETRY)
2245 *ops++ = cUNOPo->op_first;
2247 Perl_croak(aTHX_ too_deep);
2250 if (o->op_flags & OPf_KIDS) {
2252 /* First try all the kids at this level, since that's likeliest. */
2253 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2254 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2255 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2258 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2259 if (kid == PL_lastgotoprobe)
2261 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2264 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2265 ops[-1]->op_type == OP_DBSTATE)
2270 if ((o = dofindlabel(kid, label, ops, oplimit)))
2283 register PERL_CONTEXT *cx;
2284 #define GOTO_DEPTH 64
2285 OP *enterops[GOTO_DEPTH];
2286 const char *label = NULL;
2287 const bool do_dump = (PL_op->op_type == OP_DUMP);
2288 static const char must_have_label[] = "goto must have label";
2290 if (PL_op->op_flags & OPf_STACKED) {
2291 SV * const sv = POPs;
2293 /* This egregious kludge implements goto &subroutine */
2294 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2296 register PERL_CONTEXT *cx;
2297 CV* cv = (CV*)SvRV(sv);
2304 if (!CvROOT(cv) && !CvXSUB(cv)) {
2305 const GV * const gv = CvGV(cv);
2309 /* autoloaded stub? */
2310 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2312 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2313 GvNAMELEN(gv), FALSE);
2314 if (autogv && (cv = GvCV(autogv)))
2316 tmpstr = sv_newmortal();
2317 gv_efullname3(tmpstr, gv, NULL);
2318 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2320 DIE(aTHX_ "Goto undefined subroutine");
2323 /* First do some returnish stuff. */
2324 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2326 cxix = dopoptosub(cxstack_ix);
2328 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2329 if (cxix < cxstack_ix)
2333 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2334 if (CxTYPE(cx) == CXt_EVAL) {
2336 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2338 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2340 else if (CxMULTICALL(cx))
2341 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2342 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2343 /* put @_ back onto stack */
2344 AV* av = cx->blk_sub.argarray;
2346 items = AvFILLp(av) + 1;
2347 EXTEND(SP, items+1); /* @_ could have been extended. */
2348 Copy(AvARRAY(av), SP + 1, items, SV*);
2349 SvREFCNT_dec(GvAV(PL_defgv));
2350 GvAV(PL_defgv) = cx->blk_sub.savearray;
2352 /* abandon @_ if it got reified */
2357 av_extend(av, items-1);
2359 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2362 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2363 AV* const av = GvAV(PL_defgv);
2364 items = AvFILLp(av) + 1;
2365 EXTEND(SP, items+1); /* @_ could have been extended. */
2366 Copy(AvARRAY(av), SP + 1, items, SV*);
2370 if (CxTYPE(cx) == CXt_SUB &&
2371 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2372 SvREFCNT_dec(cx->blk_sub.cv);
2373 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2374 LEAVE_SCOPE(oldsave);
2376 /* Now do some callish stuff. */
2378 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2380 OP* const retop = cx->blk_sub.retop;
2385 for (index=0; index<items; index++)
2386 sv_2mortal(SP[-index]);
2389 /* XS subs don't have a CxSUB, so pop it */
2390 POPBLOCK(cx, PL_curpm);
2391 /* Push a mark for the start of arglist */
2394 (void)(*CvXSUB(cv))(aTHX_ cv);
2399 AV* const padlist = CvPADLIST(cv);
2400 if (CxTYPE(cx) == CXt_EVAL) {
2401 PL_in_eval = cx->blk_eval.old_in_eval;
2402 PL_eval_root = cx->blk_eval.old_eval_root;
2403 cx->cx_type = CXt_SUB;
2404 cx->blk_sub.hasargs = 0;
2406 cx->blk_sub.cv = cv;
2407 cx->blk_sub.olddepth = CvDEPTH(cv);
2410 if (CvDEPTH(cv) < 2)
2411 SvREFCNT_inc_void_NN(cv);
2413 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2414 sub_crush_depth(cv);
2415 pad_push(padlist, CvDEPTH(cv));
2418 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2419 if (cx->blk_sub.hasargs)
2421 AV* const av = (AV*)PAD_SVl(0);
2423 cx->blk_sub.savearray = GvAV(PL_defgv);
2424 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2425 CX_CURPAD_SAVE(cx->blk_sub);
2426 cx->blk_sub.argarray = av;
2428 if (items >= AvMAX(av) + 1) {
2429 SV **ary = AvALLOC(av);
2430 if (AvARRAY(av) != ary) {
2431 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2432 SvPV_set(av, (char*)ary);
2434 if (items >= AvMAX(av) + 1) {
2435 AvMAX(av) = items - 1;
2436 Renew(ary,items+1,SV*);
2438 SvPV_set(av, (char*)ary);
2442 Copy(mark,AvARRAY(av),items,SV*);
2443 AvFILLp(av) = items - 1;
2444 assert(!AvREAL(av));
2446 /* transfer 'ownership' of refcnts to new @_ */
2456 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2458 * We do not care about using sv to call CV;
2459 * it's for informational purposes only.
2461 SV * const sv = GvSV(PL_DBsub);
2463 if (PERLDB_SUB_NN) {
2464 const int type = SvTYPE(sv);
2465 if (type < SVt_PVIV && type != SVt_IV)
2466 sv_upgrade(sv, SVt_PVIV);
2468 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2470 gv_efullname3(sv, CvGV(cv), NULL);
2473 CV * const gotocv = get_cv("DB::goto", FALSE);
2475 PUSHMARK( PL_stack_sp );
2476 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2481 RETURNOP(CvSTART(cv));
2485 label = SvPV_nolen_const(sv);
2486 if (!(do_dump || *label))
2487 DIE(aTHX_ must_have_label);
2490 else if (PL_op->op_flags & OPf_SPECIAL) {
2492 DIE(aTHX_ must_have_label);
2495 label = cPVOP->op_pv;
2497 if (label && *label) {
2498 OP *gotoprobe = NULL;
2499 bool leaving_eval = FALSE;
2500 bool in_block = FALSE;
2501 PERL_CONTEXT *last_eval_cx = NULL;
2505 PL_lastgotoprobe = 0;
2507 for (ix = cxstack_ix; ix >= 0; ix--) {
2509 switch (CxTYPE(cx)) {
2511 leaving_eval = TRUE;
2512 if (!CxTRYBLOCK(cx)) {
2513 gotoprobe = (last_eval_cx ?
2514 last_eval_cx->blk_eval.old_eval_root :
2519 /* else fall through */
2521 gotoprobe = cx->blk_oldcop->op_sibling;
2527 gotoprobe = cx->blk_oldcop->op_sibling;
2530 gotoprobe = PL_main_root;
2533 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2534 gotoprobe = CvROOT(cx->blk_sub.cv);
2540 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2543 DIE(aTHX_ "panic: goto");
2544 gotoprobe = PL_main_root;
2548 retop = dofindlabel(gotoprobe, label,
2549 enterops, enterops + GOTO_DEPTH);
2553 PL_lastgotoprobe = gotoprobe;
2556 DIE(aTHX_ "Can't find label %s", label);
2558 /* if we're leaving an eval, check before we pop any frames
2559 that we're not going to punt, otherwise the error
2562 if (leaving_eval && *enterops && enterops[1]) {
2564 for (i = 1; enterops[i]; i++)
2565 if (enterops[i]->op_type == OP_ENTERITER)
2566 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2569 /* pop unwanted frames */
2571 if (ix < cxstack_ix) {
2578 oldsave = PL_scopestack[PL_scopestack_ix];
2579 LEAVE_SCOPE(oldsave);
2582 /* push wanted frames */
2584 if (*enterops && enterops[1]) {
2585 OP * const oldop = PL_op;
2586 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2587 for (; enterops[ix]; ix++) {
2588 PL_op = enterops[ix];
2589 /* Eventually we may want to stack the needed arguments
2590 * for each op. For now, we punt on the hard ones. */
2591 if (PL_op->op_type == OP_ENTERITER)
2592 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2593 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2601 if (!retop) retop = PL_main_start;
2603 PL_restartop = retop;
2604 PL_do_undump = TRUE;
2608 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2609 PL_do_undump = FALSE;
2626 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2628 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2631 PL_exit_flags |= PERL_EXIT_EXPECTED;
2633 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2634 if (anum || !(PL_minus_c && PL_madskills))
2639 PUSHs(&PL_sv_undef);
2646 S_save_lines(pTHX_ AV *array, SV *sv)
2648 const char *s = SvPVX_const(sv);
2649 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2652 while (s && s < send) {
2654 SV * const tmpstr = newSV(0);
2656 sv_upgrade(tmpstr, SVt_PVMG);
2657 t = strchr(s, '\n');
2663 sv_setpvn(tmpstr, s, t - s);
2664 av_store(array, line++, tmpstr);
2670 S_docatch_body(pTHX)
2678 S_docatch(pTHX_ OP *o)
2682 OP * const oldop = PL_op;
2686 assert(CATCH_GET == TRUE);
2693 assert(cxstack_ix >= 0);
2694 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2695 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2700 /* die caught by an inner eval - continue inner loop */
2702 /* NB XXX we rely on the old popped CxEVAL still being at the top
2703 * of the stack; the way die_where() currently works, this
2704 * assumption is valid. In theory The cur_top_env value should be
2705 * returned in another global, the way retop (aka PL_restartop)
2707 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2710 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2712 PL_op = PL_restartop;
2729 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2730 /* sv Text to convert to OP tree. */
2731 /* startop op_free() this to undo. */
2732 /* code Short string id of the caller. */
2734 /* FIXME - how much of this code is common with pp_entereval? */
2735 dVAR; dSP; /* Make POPBLOCK work. */
2742 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2743 char *tmpbuf = tbuf;
2746 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2752 /* switch to eval mode */
2754 if (IN_PERL_COMPILETIME) {
2755 SAVECOPSTASH_FREE(&PL_compiling);
2756 CopSTASH_set(&PL_compiling, PL_curstash);
2758 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2759 SV * const sv = sv_newmortal();
2760 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2761 code, (unsigned long)++PL_evalseq,
2762 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2767 len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
2768 (unsigned long)++PL_evalseq);
2769 SAVECOPFILE_FREE(&PL_compiling);
2770 CopFILE_set(&PL_compiling, tmpbuf+2);
2771 SAVECOPLINE(&PL_compiling);
2772 CopLINE_set(&PL_compiling, 1);
2773 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2774 deleting the eval's FILEGV from the stash before gv_check() runs
2775 (i.e. before run-time proper). To work around the coredump that
2776 ensues, we always turn GvMULTI_on for any globals that were
2777 introduced within evals. See force_ident(). GSAR 96-10-12 */
2778 safestr = savepvn(tmpbuf, len);
2779 SAVEDELETE(PL_defstash, safestr, len);
2781 #ifdef OP_IN_REGISTER
2787 /* we get here either during compilation, or via pp_regcomp at runtime */
2788 runtime = IN_PERL_RUNTIME;
2790 runcv = find_runcv(NULL);
2793 PL_op->op_type = OP_ENTEREVAL;
2794 PL_op->op_flags = 0; /* Avoid uninit warning. */
2795 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2796 PUSHEVAL(cx, 0, NULL);
2799 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2801 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2802 POPBLOCK(cx,PL_curpm);
2805 (*startop)->op_type = OP_NULL;
2806 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2808 /* XXX DAPM do this properly one year */
2809 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2811 if (IN_PERL_COMPILETIME)
2812 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2813 #ifdef OP_IN_REGISTER
2816 PERL_UNUSED_VAR(newsp);
2817 PERL_UNUSED_VAR(optype);
2824 =for apidoc find_runcv
2826 Locate the CV corresponding to the currently executing sub or eval.
2827 If db_seqp is non_null, skip CVs that are in the DB package and populate
2828 *db_seqp with the cop sequence number at the point that the DB:: code was
2829 entered. (allows debuggers to eval in the scope of the breakpoint rather
2830 than in the scope of the debugger itself).
2836 Perl_find_runcv(pTHX_ U32 *db_seqp)
2842 *db_seqp = PL_curcop->cop_seq;
2843 for (si = PL_curstackinfo; si; si = si->si_prev) {
2845 for (ix = si->si_cxix; ix >= 0; ix--) {
2846 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2847 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2848 CV * const cv = cx->blk_sub.cv;
2849 /* skip DB:: code */
2850 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2851 *db_seqp = cx->blk_oldcop->cop_seq;
2856 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2864 /* Compile a require/do, an eval '', or a /(?{...})/.
2865 * In the last case, startop is non-null, and contains the address of
2866 * a pointer that should be set to the just-compiled code.
2867 * outside is the lexically enclosing CV (if any) that invoked us.
2870 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2872 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2875 OP * const saveop = PL_op;
2877 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2878 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2883 SAVESPTR(PL_compcv);
2884 PL_compcv = (CV*)newSV(0);
2885 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2886 CvEVAL_on(PL_compcv);
2887 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2888 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2890 CvOUTSIDE_SEQ(PL_compcv) = seq;
2891 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2893 /* set up a scratch pad */
2895 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2899 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2901 /* make sure we compile in the right package */
2903 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2904 SAVESPTR(PL_curstash);
2905 PL_curstash = CopSTASH(PL_curcop);
2907 SAVESPTR(PL_beginav);
2908 PL_beginav = newAV();
2909 SAVEFREESV(PL_beginav);
2910 SAVEI32(PL_error_count);
2913 SAVEI32(PL_madskills);
2917 /* try to compile it */
2919 PL_eval_root = NULL;
2921 PL_curcop = &PL_compiling;
2922 PL_curcop->cop_arybase = 0;
2923 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2924 PL_in_eval |= EVAL_KEEPERR;
2926 sv_setpvn(ERRSV,"",0);
2927 if (yyparse() || PL_error_count || !PL_eval_root) {
2928 SV **newsp; /* Used by POPBLOCK. */
2929 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2930 I32 optype = 0; /* Might be reset by POPEVAL. */
2935 op_free(PL_eval_root);
2936 PL_eval_root = NULL;
2938 SP = PL_stack_base + POPMARK; /* pop original mark */
2940 POPBLOCK(cx,PL_curpm);
2946 msg = SvPVx_nolen_const(ERRSV);
2947 if (optype == OP_REQUIRE) {
2948 const SV * const nsv = cx->blk_eval.old_namesv;
2949 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2951 DIE(aTHX_ "%sCompilation failed in require",
2952 *msg ? msg : "Unknown error\n");
2955 POPBLOCK(cx,PL_curpm);
2957 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2958 (*msg ? msg : "Unknown error\n"));
2962 sv_setpv(ERRSV, "Compilation error");
2965 PERL_UNUSED_VAR(newsp);
2968 CopLINE_set(&PL_compiling, 0);
2970 *startop = PL_eval_root;
2972 SAVEFREEOP(PL_eval_root);
2974 /* Set the context for this new optree.
2975 * If the last op is an OP_REQUIRE, force scalar context.
2976 * Otherwise, propagate the context from the eval(). */
2977 if (PL_eval_root->op_type == OP_LEAVEEVAL
2978 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2979 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2981 scalar(PL_eval_root);
2982 else if (gimme & G_VOID)
2983 scalarvoid(PL_eval_root);
2984 else if (gimme & G_ARRAY)
2987 scalar(PL_eval_root);
2989 DEBUG_x(dump_eval());
2991 /* Register with debugger: */
2992 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2993 CV * const cv = get_cv("DB::postponed", FALSE);
2997 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2999 call_sv((SV*)cv, G_DISCARD);
3003 /* compiled okay, so do it */
3005 CvDEPTH(PL_compcv) = 1;
3006 SP = PL_stack_base + POPMARK; /* pop original mark */
3007 PL_op = saveop; /* The caller may need it. */
3008 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3010 RETURNOP(PL_eval_start);
3014 S_check_type_and_open(pTHX_ const char *name, const char *mode)
3017 const int st_rc = PerlLIO_stat(name, &st);
3018 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3022 return PerlIO_open(name, mode);
3026 S_doopen_pm(pTHX_ const char *name, const char *mode)
3028 #ifndef PERL_DISABLE_PMC
3029 const STRLEN namelen = strlen(name);
3032 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3033 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3034 const char * const pmc = SvPV_nolen_const(pmcsv);
3036 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3037 fp = check_type_and_open(name, mode);
3040 fp = check_type_and_open(pmc, mode);
3042 SvREFCNT_dec(pmcsv);
3045 fp = check_type_and_open(name, mode);
3049 return check_type_and_open(name, mode);
3050 #endif /* !PERL_DISABLE_PMC */
3056 register PERL_CONTEXT *cx;
3060 const char *tryname = NULL;
3062 const I32 gimme = GIMME_V;
3063 int filter_has_file = 0;
3064 PerlIO *tryrsfp = NULL;
3065 GV *filter_child_proc = NULL;
3066 SV *filter_state = NULL;
3067 SV *filter_sub = NULL;
3073 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3074 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3075 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3076 "v-string in use/require non-portable");
3078 sv = new_version(sv);
3079 if (!sv_derived_from(PL_patchlevel, "version"))
3080 upg_version(PL_patchlevel);
3081 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3082 if ( vcmp(sv,PL_patchlevel) < 0 )
3083 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3084 vnormal(sv), vnormal(PL_patchlevel));
3087 if ( vcmp(sv,PL_patchlevel) > 0 )
3088 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3089 vnormal(sv), vnormal(PL_patchlevel));
3094 name = SvPV_const(sv, len);
3095 if (!(name && len > 0 && *name))
3096 DIE(aTHX_ "Null filename used");
3097 TAINT_PROPER("require");
3098 if (PL_op->op_type == OP_REQUIRE) {
3099 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3101 if (*svp != &PL_sv_undef)
3104 DIE(aTHX_ "Compilation failed in require");
3108 /* prepare to compile file */
3110 if (path_is_absolute(name)) {
3112 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3114 #ifdef MACOS_TRADITIONAL
3118 MacPerl_CanonDir(name, newname, 1);
3119 if (path_is_absolute(newname)) {
3121 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3126 AV * const ar = GvAVn(PL_incgv);
3130 if ((unixname = tounixspec(name, NULL)) != NULL)
3134 for (i = 0; i <= AvFILL(ar); i++) {
3135 SV *dirsv = *av_fetch(ar, i, TRUE);
3141 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3142 && !sv_isobject(loader))
3144 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3147 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3148 PTR2UV(SvRV(dirsv)), name);
3149 tryname = SvPVX_const(namesv);
3160 if (sv_isobject(loader))
3161 count = call_method("INC", G_ARRAY);
3163 count = call_sv(loader, G_ARRAY);
3173 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3177 if (SvTYPE(arg) == SVt_PVGV) {
3178 IO *io = GvIO((GV *)arg);
3183 tryrsfp = IoIFP(io);
3184 if (IoTYPE(io) == IoTYPE_PIPE) {
3185 /* reading from a child process doesn't
3186 nest -- when returning from reading
3187 the inner module, the outer one is
3188 unreadable (closed?) I've tried to
3189 save the gv to manage the lifespan of
3190 the pipe, but this didn't help. XXX */
3191 filter_child_proc = (GV *)arg;
3192 SvREFCNT_inc_simple_void(filter_child_proc);
3195 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3196 PerlIO_close(IoOFP(io));
3208 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3210 SvREFCNT_inc_void_NN(filter_sub);
3213 filter_state = SP[i];
3214 SvREFCNT_inc_simple_void(filter_state);
3218 tryrsfp = PerlIO_open("/dev/null", PERL_SCRIPT_MODE);
3233 filter_has_file = 0;
3234 if (filter_child_proc) {
3235 SvREFCNT_dec(filter_child_proc);
3236 filter_child_proc = NULL;
3239 SvREFCNT_dec(filter_state);
3240 filter_state = NULL;
3243 SvREFCNT_dec(filter_sub);
3248 if (!path_is_absolute(name)
3249 #ifdef MACOS_TRADITIONAL
3250 /* We consider paths of the form :a:b ambiguous and interpret them first
3251 as global then as local
3253 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3256 const char *dir = SvPVx_nolen_const(dirsv);
3257 #ifdef MACOS_TRADITIONAL
3261 MacPerl_CanonDir(name, buf2, 1);
3262 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3266 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3268 sv_setpv(namesv, unixdir);
3269 sv_catpv(namesv, unixname);
3271 # ifdef __SYMBIAN32__
3272 if (PL_origfilename[0] &&
3273 PL_origfilename[1] == ':' &&
3274 !(dir[0] && dir[1] == ':'))
3275 Perl_sv_setpvf(aTHX_ namesv,
3280 Perl_sv_setpvf(aTHX_ namesv,
3284 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3288 TAINT_PROPER("require");
3289 tryname = SvPVX_const(namesv);
3290 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3292 if (tryname[0] == '.' && tryname[1] == '/')
3301 SAVECOPFILE_FREE(&PL_compiling);
3302 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3303 SvREFCNT_dec(namesv);
3305 if (PL_op->op_type == OP_REQUIRE) {
3306 const char *msgstr = name;
3307 if(errno == EMFILE) {
3309 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3311 msgstr = SvPV_nolen_const(msg);
3313 if (namesv) { /* did we lookup @INC? */
3314 AV * const ar = GvAVn(PL_incgv);
3316 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3317 "%s in @INC%s%s (@INC contains:",
3319 (instr(msgstr, ".h ")
3320 ? " (change .h to .ph maybe?)" : ""),
3321 (instr(msgstr, ".ph ")
3322 ? " (did you run h2ph?)" : "")
3325 for (i = 0; i <= AvFILL(ar); i++) {
3326 sv_catpvs(msg, " ");
3327 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3329 sv_catpvs(msg, ")");
3330 msgstr = SvPV_nolen_const(msg);
3333 DIE(aTHX_ "Can't locate %s", msgstr);
3339 SETERRNO(0, SS_NORMAL);
3341 /* Assume success here to prevent recursive requirement. */
3342 /* name is never assigned to again, so len is still strlen(name) */
3343 /* Check whether a hook in @INC has already filled %INC */
3345 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3347 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3349 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc_simple(hook_sv), 0 );
3354 lex_start(sv_2mortal(newSVpvs("")));
3355 SAVEGENERICSV(PL_rsfp_filters);
3356 PL_rsfp_filters = NULL;
3361 SAVESPTR(PL_compiling.cop_warnings);
3362 if (PL_dowarn & G_WARN_ALL_ON)
3363 PL_compiling.cop_warnings = pWARN_ALL ;
3364 else if (PL_dowarn & G_WARN_ALL_OFF)
3365 PL_compiling.cop_warnings = pWARN_NONE ;
3366 else if (PL_taint_warn)
3367 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3369 PL_compiling.cop_warnings = pWARN_STD ;
3370 SAVESPTR(PL_compiling.cop_io);
3371 PL_compiling.cop_io = NULL;
3373 if (filter_sub || filter_child_proc) {
3374 SV * const datasv = filter_add(S_run_user_filter, NULL);
3375 IoLINES(datasv) = filter_has_file;
3376 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3377 IoTOP_GV(datasv) = (GV *)filter_state;
3378 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3381 /* switch to eval mode */
3382 PUSHBLOCK(cx, CXt_EVAL, SP);
3383 PUSHEVAL(cx, name, NULL);
3384 cx->blk_eval.retop = PL_op->op_next;
3386 SAVECOPLINE(&PL_compiling);
3387 CopLINE_set(&PL_compiling, 0);
3391 /* Store and reset encoding. */
3392 encoding = PL_encoding;
3395 op = DOCATCH(doeval(gimme, NULL, NULL, PL_curcop->cop_seq));
3397 /* Restore encoding. */
3398 PL_encoding = encoding;
3406 register PERL_CONTEXT *cx;
3408 const I32 gimme = GIMME_V;
3409 const I32 was = PL_sub_generation;
3410 char tbuf[TYPE_DIGITS(long) + 12];
3411 char *tmpbuf = tbuf;
3417 HV *saved_hh = NULL;
3419 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3420 saved_hh = (HV*) SvREFCNT_inc(POPs);
3424 if (!SvPV_nolen_const(sv))
3426 TAINT_PROPER("eval");
3432 /* switch to eval mode */
3434 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3435 SV * const temp_sv = sv_newmortal();
3436 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3437 (unsigned long)++PL_evalseq,
3438 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3439 tmpbuf = SvPVX(temp_sv);
3440 len = SvCUR(temp_sv);
3443 len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3444 SAVECOPFILE_FREE(&PL_compiling);
3445 CopFILE_set(&PL_compiling, tmpbuf+2);
3446 SAVECOPLINE(&PL_compiling);
3447 CopLINE_set(&PL_compiling, 1);
3448 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3449 deleting the eval's FILEGV from the stash before gv_check() runs
3450 (i.e. before run-time proper). To work around the coredump that
3451 ensues, we always turn GvMULTI_on for any globals that were
3452 introduced within evals. See force_ident(). GSAR 96-10-12 */
3453 safestr = savepvn(tmpbuf, len);
3454 SAVEDELETE(PL_defstash, safestr, len);
3456 PL_hints = PL_op->op_targ;
3458 GvHV(PL_hintgv) = saved_hh;
3459 SAVESPTR(PL_compiling.cop_warnings);
3460 if (specialWARN(PL_curcop->cop_warnings))
3461 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3463 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3464 SAVEFREESV(PL_compiling.cop_warnings);
3466 SAVESPTR(PL_compiling.cop_io);
3467 if (specialCopIO(PL_curcop->cop_io))
3468 PL_compiling.cop_io = PL_curcop->cop_io;
3470 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3471 SAVEFREESV(PL_compiling.cop_io);
3473 /* special case: an eval '' executed within the DB package gets lexically
3474 * placed in the first non-DB CV rather than the current CV - this
3475 * allows the debugger to execute code, find lexicals etc, in the
3476 * scope of the code being debugged. Passing &seq gets find_runcv
3477 * to do the dirty work for us */
3478 runcv = find_runcv(&seq);
3480 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3481 PUSHEVAL(cx, 0, NULL);
3482 cx->blk_eval.retop = PL_op->op_next;
3484 /* prepare to compile string */
3486 if (PERLDB_LINE && PL_curstash != PL_debstash)
3487 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3489 ret = doeval(gimme, NULL, runcv, seq);
3490 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3491 && ret != PL_op->op_next) { /* Successive compilation. */
3492 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3494 return DOCATCH(ret);
3504 register PERL_CONTEXT *cx;
3506 const U8 save_flags = PL_op -> op_flags;
3511 retop = cx->blk_eval.retop;
3514 if (gimme == G_VOID)
3516 else if (gimme == G_SCALAR) {
3519 if (SvFLAGS(TOPs) & SVs_TEMP)
3522 *MARK = sv_mortalcopy(TOPs);
3526 *MARK = &PL_sv_undef;
3531 /* in case LEAVE wipes old return values */
3532 for (mark = newsp + 1; mark <= SP; mark++) {
3533 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3534 *mark = sv_mortalcopy(*mark);
3535 TAINT_NOT; /* Each item is independent */
3539 PL_curpm = newpm; /* Don't pop $1 et al till now */
3542 assert(CvDEPTH(PL_compcv) == 1);
3544 CvDEPTH(PL_compcv) = 0;
3547 if (optype == OP_REQUIRE &&
3548 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3550 /* Unassume the success we assumed earlier. */
3551 SV * const nsv = cx->blk_eval.old_namesv;
3552 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3553 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3554 /* die_where() did LEAVE, or we won't be here */
3558 if (!(save_flags & OPf_SPECIAL))
3559 sv_setpvn(ERRSV,"",0);
3565 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3566 close to the related Perl_create_eval_scope. */
3568 Perl_delete_eval_scope(pTHX)
3573 register PERL_CONTEXT *cx;
3580 PERL_UNUSED_VAR(newsp);
3581 PERL_UNUSED_VAR(gimme);
3582 PERL_UNUSED_VAR(optype);
3585 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3586 also needed by Perl_fold_constants. */
3588 Perl_create_eval_scope(pTHX_ U32 flags)
3591 const I32 gimme = GIMME_V;
3596 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3598 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3600 PL_in_eval = EVAL_INEVAL;
3601 if (flags & G_KEEPERR)
3602 PL_in_eval |= EVAL_KEEPERR;
3604 sv_setpvn(ERRSV,"",0);
3605 if (flags & G_FAKINGEVAL) {
3606 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3614 PERL_CONTEXT *cx = create_eval_scope(0);
3615 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3616 return DOCATCH(PL_op->op_next);
3625 register PERL_CONTEXT *cx;
3630 PERL_UNUSED_VAR(optype);
3633 if (gimme == G_VOID)
3635 else if (gimme == G_SCALAR) {
3639 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3642 *MARK = sv_mortalcopy(TOPs);
3646 *MARK = &PL_sv_undef;
3651 /* in case LEAVE wipes old return values */
3653 for (mark = newsp + 1; mark <= SP; mark++) {
3654 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3655 *mark = sv_mortalcopy(*mark);
3656 TAINT_NOT; /* Each item is independent */
3660 PL_curpm = newpm; /* Don't pop $1 et al till now */
3663 sv_setpvn(ERRSV,"",0);
3670 register PERL_CONTEXT *cx;
3671 const I32 gimme = GIMME_V;
3676 if (PL_op->op_targ == 0) {
3677 SV ** const defsv_p = &GvSV(PL_defgv);
3678 *defsv_p = newSVsv(POPs);
3679 SAVECLEARSV(*defsv_p);
3682 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3684 PUSHBLOCK(cx, CXt_GIVEN, SP);
3693 register PERL_CONTEXT *cx;
3697 PERL_UNUSED_CONTEXT;
3700 assert(CxTYPE(cx) == CXt_GIVEN);
3705 PL_curpm = newpm; /* pop $1 et al */
3712 /* Helper routines used by pp_smartmatch */
3715 S_make_matcher(pTHX_ regexp *re)
3718 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3719 PM_SETRE(matcher, ReREFCNT_inc(re));
3721 SAVEFREEOP((OP *) matcher);
3729 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3734 PL_op = (OP *) matcher;
3739 return (SvTRUEx(POPs));
3744 S_destroy_matcher(pTHX_ PMOP *matcher)
3747 PERL_UNUSED_ARG(matcher);
3752 /* Do a smart match */
3755 return do_smartmatch(NULL, NULL);
3758 /* This version of do_smartmatch() implements the following
3759 table of smart matches:
3761 $a $b Type of Match Implied Matching Code
3762 ====== ===== ===================== =============
3763 (overloading trumps everything)
3765 Code[+] Code[+] referential equality match if refaddr($a) == refaddr($b)
3766 Any Code[+] scalar sub truth match if $b->($a)
3768 Hash Hash hash keys identical match if sort(keys(%$a)) ÈeqÇ sort(keys(%$b))
3769 Hash Array hash value slice truth match if $a->{any(@$b)}
3770 Hash Regex hash key grep match if any(keys(%$a)) =~ /$b/
3771 Hash Any hash entry existence match if exists $a->{$b}
3773 Array Array arrays are identical[*] match if $a È~~Ç $b
3774 Array Regex array grep match if any(@$a) =~ /$b/
3775 Array Num array contains number match if any($a) == $b
3776 Array Any array contains string match if any($a) eq $b
3778 Any undef undefined match if !defined $a
3779 Any Regex pattern match match if $a =~ /$b/
3780 Code() Code() results are equal match if $a->() eq $b->()
3781 Any Code() simple closure truth match if $b->() (ignoring $a)
3782 Num numish[!] numeric equality match if $a == $b
3783 Any Str string equality match if $a eq $b
3784 Any Num numeric equality match if $a == $b
3786 Any Any string equality match if $a eq $b
3789 + - this must be a code reference whose prototype (if present) is not ""
3790 (subs with a "" prototype are dealt with by the 'Code()' entry lower down)
3791 * - if a circular reference is found, we fall back to referential equality
3792 ! - either a real number, or a string that looks_like_number()
3797 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3802 SV *e = TOPs; /* e is for 'expression' */
3803 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3806 regexp *this_regex, *other_regex;
3808 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3810 # define SM_REF(type) ( \
3811 (SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_##type) && (other = e)) \
3812 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_##type) && (other = d)))
3814 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3815 ((SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_PVCV) \
3816 && NOT_EMPTY_PROTO(this) && (other = e)) \
3817 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_PVCV) \
3818 && NOT_EMPTY_PROTO(this) && (other = d)))
3820 # define SM_REGEX ( \
3821 (SvROK(d) && SvMAGICAL(this = SvRV(d)) \
3822 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3823 && (this_regex = (regexp *)mg->mg_obj) \
3826 (SvROK(e) && SvMAGICAL(this = SvRV(e)) \
3827 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3828 && (this_regex = (regexp *)mg->mg_obj) \
3832 # define SM_OTHER_REF(type) \
3833 (SvROK(other) && SvTYPE(SvRV(other)) == SVt_##type)
3835 # define SM_OTHER_REGEX (SvROK(other) && SvMAGICAL(SvRV(other)) \
3836 && (mg = mg_find(SvRV(other), PERL_MAGIC_qr)) \
3837 && (other_regex = (regexp *)mg->mg_obj))
3840 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3841 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3843 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3844 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3846 tryAMAGICbinSET(smart, 0);
3848 SP -= 2; /* Pop the values */
3850 /* Take care only to invoke mg_get() once for each argument.
3851 * Currently we do this by copying the SV if it's magical. */
3854 d = sv_mortalcopy(d);
3861 e = sv_mortalcopy(e);
3866 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(other)) )
3868 if (this == SvRV(other))
3879 c = call_sv(this, G_SCALAR);
3883 else if (SvTEMP(TOPs))
3889 else if (SM_REF(PVHV)) {
3890 if (SM_OTHER_REF(PVHV)) {
3891 /* Check that the key-sets are identical */
3893 HV *other_hv = (HV *) SvRV(other);
3895 bool other_tied = FALSE;
3896 U32 this_key_count = 0,
3897 other_key_count = 0;
3899 /* Tied hashes don't know how many keys they have. */
3900 if (SvTIED_mg(this, PERL_MAGIC_tied)) {
3903 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3904 HV * const temp = other_hv;
3905 other_hv = (HV *) this;
3909 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3912 if (!tied && HvUSEDKEYS((HV *) this) != HvUSEDKEYS(other_hv))
3915 /* The hashes have the same number of keys, so it suffices
3916 to check that one is a subset of the other. */
3917 (void) hv_iterinit((HV *) this);
3918 while ( (he = hv_iternext((HV *) this)) ) {
3920 char * const key = hv_iterkey(he, &key_len);
3924 if(!hv_exists(other_hv, key, key_len)) {
3925 (void) hv_iterinit((HV *) this); /* reset iterator */
3931 (void) hv_iterinit(other_hv);
3932 while ( hv_iternext(other_hv) )
3936 other_key_count = HvUSEDKEYS(other_hv);
3938 if (this_key_count != other_key_count)
3943 else if (SM_OTHER_REF(PVAV)) {
3944 AV * const other_av = (AV *) SvRV(other);
3945 const I32 other_len = av_len(other_av) + 1;
3948 if (HvUSEDKEYS((HV *) this) != other_len)
3951 for(i = 0; i < other_len; ++i) {
3952 SV ** const svp = av_fetch(other_av, i, FALSE);
3956 if (!svp) /* ??? When can this happen? */
3959 key = SvPV(*svp, key_len);
3960 if(!hv_exists((HV *) this, key, key_len))
3965 else if (SM_OTHER_REGEX) {
3966 PMOP * const matcher = make_matcher(other_regex);
3969 (void) hv_iterinit((HV *) this);
3970 while ( (he = hv_iternext((HV *) this)) ) {
3971 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
3972 (void) hv_iterinit((HV *) this);
3973 destroy_matcher(matcher);
3977 destroy_matcher(matcher);
3981 if (hv_exists_ent((HV *) this, other, 0))
3987 else if (SM_REF(PVAV)) {
3988 if (SM_OTHER_REF(PVAV)) {
3989 AV *other_av = (AV *) SvRV(other);
3990 if (av_len((AV *) this) != av_len(other_av))
3994 const I32 other_len = av_len(other_av);
3996 if (NULL == seen_this) {
3997 seen_this = newHV();
3998 (void) sv_2mortal((SV *) seen_this);
4000 if (NULL == seen_other) {
4001 seen_this = newHV();
4002 (void) sv_2mortal((SV *) seen_other);
4004 for(i = 0; i <= other_len; ++i) {
4005 SV * const * const this_elem = av_fetch((AV *)this, i, FALSE);
4006 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4008 if (!this_elem || !other_elem) {
4009 if (this_elem || other_elem)
4012 else if (SM_SEEN_THIS(*this_elem)
4013 || SM_SEEN_OTHER(*other_elem))
4015 if (*this_elem != *other_elem)
4019 hv_store_ent(seen_this,
4020 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4022 hv_store_ent(seen_other,
4023 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4029 (void) do_smartmatch(seen_this, seen_other);
4039 else if (SM_OTHER_REGEX) {
4040 PMOP * const matcher = make_matcher(other_regex);
4041 const I32 this_len = av_len((AV *) this);
4044 for(i = 0; i <= this_len; ++i) {
4045 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4046 if (svp && matcher_matches_sv(matcher, *svp)) {
4047 destroy_matcher(matcher);
4051 destroy_matcher(matcher);
4054 else if (SvIOK(other) || SvNOK(other)) {
4057 for(i = 0; i <= AvFILL((AV *) this); ++i) {
4058 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4065 if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
4075 else if (SvPOK(other)) {
4076 const I32 this_len = av_len((AV *) this);
4079 for(i = 0; i <= this_len; ++i) {
4080 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4095 else if (!SvOK(d) || !SvOK(e)) {
4096 if (!SvOK(d) && !SvOK(e))
4101 else if (SM_REGEX) {
4102 PMOP * const matcher = make_matcher(this_regex);
4105 PUSHs(matcher_matches_sv(matcher, other)
4108 destroy_matcher(matcher);
4111 else if (SM_REF(PVCV)) {
4113 /* This must be a null-prototyped sub, because we
4114 already checked for the other kind. */
4120 c = call_sv(this, G_SCALAR);
4123 PUSHs(&PL_sv_undef);
4124 else if (SvTEMP(TOPs))
4127 if (SM_OTHER_REF(PVCV)) {
4128 /* This one has to be null-proto'd too.
4129 Call both of 'em, and compare the results */
4131 c = call_sv(SvRV(other), G_SCALAR);
4134 PUSHs(&PL_sv_undef);
4135 else if (SvTEMP(TOPs))
4147 else if ( ((SvIOK(d) || SvNOK(d)) && (this = d) && (other = e))
4148 || ((SvIOK(e) || SvNOK(e)) && (this = e) && (other = d)) )
4150 if (SvPOK(other) && !looks_like_number(other)) {
4151 /* String comparison */
4156 /* Otherwise, numeric comparison */
4159 if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
4170 /* As a last resort, use string comparison */
4179 register PERL_CONTEXT *cx;
4180 const I32 gimme = GIMME_V;
4182 /* This is essentially an optimization: if the match
4183 fails, we don't want to push a context and then
4184 pop it again right away, so we skip straight
4185 to the op that follows the leavewhen.
4187 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4188 return cLOGOP->op_other->op_next;
4193 PUSHBLOCK(cx, CXt_WHEN, SP);
4202 register PERL_CONTEXT *cx;
4208 assert(CxTYPE(cx) == CXt_WHEN);
4213 PL_curpm = newpm; /* pop $1 et al */
4223 register PERL_CONTEXT *cx;
4226 cxix = dopoptowhen(cxstack_ix);
4228 DIE(aTHX_ "Can't \"continue\" outside a when block");
4229 if (cxix < cxstack_ix)
4232 /* clear off anything above the scope we're re-entering */
4233 inner = PL_scopestack_ix;
4235 if (PL_scopestack_ix < inner)
4236 leave_scope(PL_scopestack[PL_scopestack_ix]);
4237 PL_curcop = cx->blk_oldcop;
4238 return cx->blk_givwhen.leave_op;
4245 register PERL_CONTEXT *cx;
4248 cxix = dopoptogiven(cxstack_ix);
4250 if (PL_op->op_flags & OPf_SPECIAL)
4251 DIE(aTHX_ "Can't use when() outside a topicalizer");
4253 DIE(aTHX_ "Can't \"break\" outside a given block");
4255 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4256 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
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;
4269 return cx->blk_loop.next_op;
4271 return cx->blk_givwhen.leave_op;
4275 S_doparseform(pTHX_ SV *sv)
4278 register char *s = SvPV_force(sv, len);
4279 register char * const send = s + len;
4280 register char *base = NULL;
4281 register I32 skipspaces = 0;
4282 bool noblank = FALSE;
4283 bool repeat = FALSE;
4284 bool postspace = FALSE;
4290 bool unchopnum = FALSE;
4291 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4294 Perl_croak(aTHX_ "Null picture in formline");
4296 /* estimate the buffer size needed */
4297 for (base = s; s <= send; s++) {
4298 if (*s == '\n' || *s == '@' || *s == '^')
4304 Newx(fops, maxops, U32);
4309 *fpc++ = FF_LINEMARK;
4310 noblank = repeat = FALSE;
4328 case ' ': case '\t':
4335 } /* else FALL THROUGH */
4343 *fpc++ = FF_LITERAL;
4351 *fpc++ = (U16)skipspaces;
4355 *fpc++ = FF_NEWLINE;
4359 arg = fpc - linepc + 1;
4366 *fpc++ = FF_LINEMARK;
4367 noblank = repeat = FALSE;
4376 ischop = s[-1] == '^';
4382 arg = (s - base) - 1;
4384 *fpc++ = FF_LITERAL;
4392 *fpc++ = 2; /* skip the @* or ^* */
4394 *fpc++ = FF_LINESNGL;
4397 *fpc++ = FF_LINEGLOB;
4399 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4400 arg = ischop ? 512 : 0;
4405 const char * const f = ++s;
4408 arg |= 256 + (s - f);
4410 *fpc++ = s - base; /* fieldsize for FETCH */
4411 *fpc++ = FF_DECIMAL;
4413 unchopnum |= ! ischop;
4415 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4416 arg = ischop ? 512 : 0;
4418 s++; /* skip the '0' first */
4422 const char * const f = ++s;
4425 arg |= 256 + (s - f);
4427 *fpc++ = s - base; /* fieldsize for FETCH */
4428 *fpc++ = FF_0DECIMAL;
4430 unchopnum |= ! ischop;
4434 bool ismore = FALSE;
4437 while (*++s == '>') ;
4438 prespace = FF_SPACE;
4440 else if (*s == '|') {
4441 while (*++s == '|') ;
4442 prespace = FF_HALFSPACE;
4447 while (*++s == '<') ;
4450 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4454 *fpc++ = s - base; /* fieldsize for FETCH */
4456 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4459 *fpc++ = (U16)prespace;
4473 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4475 { /* need to jump to the next word */
4477 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4478 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4479 s = SvPVX(sv) + SvCUR(sv) + z;
4481 Copy(fops, s, arg, U32);
4483 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4486 if (unchopnum && repeat)
4487 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4493 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4495 /* Can value be printed in fldsize chars, using %*.*f ? */
4499 int intsize = fldsize - (value < 0 ? 1 : 0);
4506 while (intsize--) pwr *= 10.0;
4507 while (frcsize--) eps /= 10.0;
4510 if (value + eps >= pwr)
4513 if (value - eps <= -pwr)
4520 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4523 SV * const datasv = FILTER_DATA(idx);
4524 const int filter_has_file = IoLINES(datasv);
4525 GV * const filter_child_proc = (GV *)IoFMT_GV(datasv);
4526 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4527 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4530 /* I was having segfault trouble under Linux 2.2.5 after a
4531 parse error occured. (Had to hack around it with a test
4532 for PL_error_count == 0.) Solaris doesn't segfault --
4533 not sure where the trouble is yet. XXX */
4535 if (filter_has_file) {
4536 len = FILTER_READ(idx+1, buf_sv, maxlen);
4539 if (filter_sub && len >= 0) {
4550 PUSHs(sv_2mortal(newSViv(maxlen)));
4552 PUSHs(filter_state);
4555 count = call_sv(filter_sub, G_SCALAR);
4571 IoLINES(datasv) = 0;
4572 if (filter_child_proc) {
4573 SvREFCNT_dec(filter_child_proc);
4574 IoFMT_GV(datasv) = NULL;
4577 SvREFCNT_dec(filter_state);
4578 IoTOP_GV(datasv) = NULL;
4581 SvREFCNT_dec(filter_sub);
4582 IoBOTTOM_GV(datasv) = NULL;
4584 filter_del(S_run_user_filter);
4590 /* perhaps someone can come up with a better name for
4591 this? it is not really "absolute", per se ... */
4593 S_path_is_absolute(const char *name)
4595 if (PERL_FILE_IS_ABSOLUTE(name)
4596 #ifdef MACOS_TRADITIONAL
4599 || (*name == '.' && (name[1] == '/' ||
4600 (name[1] == '.' && name[2] == '/')))
4612 * c-indentation-style: bsd
4614 * indent-tabs-mode: t
4617 * ex: set ts=8 sts=4 sw=4 noet: