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(CopHINTS_get(cx->blk_oldcop))));
1701 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1703 if (old_warnings == pWARN_NONE ||
1704 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1705 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1706 else if (old_warnings == pWARN_ALL ||
1707 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1708 /* Get the bit mask for $warnings::Bits{all}, because
1709 * it could have been extended by warnings::register */
1711 HV * const bits = get_hv("warnings::Bits", FALSE);
1712 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1713 mask = newSVsv(*bits_all);
1716 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1720 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1721 PUSHs(sv_2mortal(mask));
1724 PUSHs(cx->blk_oldcop->cop_hints ?
1725 sv_2mortal(newRV_noinc(
1726 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1727 cx->blk_oldcop->cop_hints)))
1736 const char * const tmps = (MAXARG < 1) ? "" : POPpconstx;
1737 sv_reset(tmps, CopSTASH(PL_curcop));
1742 /* like pp_nextstate, but used instead when the debugger is active */
1747 PL_curcop = (COP*)PL_op;
1748 TAINT_NOT; /* Each statement is presumed innocent */
1749 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1752 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1753 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1756 register PERL_CONTEXT *cx;
1757 const I32 gimme = G_ARRAY;
1759 GV * const gv = PL_DBgv;
1760 register CV * const cv = GvCV(gv);
1763 DIE(aTHX_ "No DB::DB routine defined");
1765 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1766 /* don't do recursive DB::DB call */
1781 (void)(*CvXSUB(cv))(aTHX_ cv);
1788 PUSHBLOCK(cx, CXt_SUB, SP);
1790 cx->blk_sub.retop = PL_op->op_next;
1793 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1794 RETURNOP(CvSTART(cv));
1804 register PERL_CONTEXT *cx;
1805 const I32 gimme = GIMME_V;
1807 U32 cxtype = CXt_LOOP | CXp_FOREACH;
1815 if (PL_op->op_targ) {
1816 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1817 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1818 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1819 SVs_PADSTALE, SVs_PADSTALE);
1821 #ifndef USE_ITHREADS
1822 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1825 SAVEPADSV(PL_op->op_targ);
1826 iterdata = INT2PTR(void*, PL_op->op_targ);
1827 cxtype |= CXp_PADVAR;
1831 GV * const gv = (GV*)POPs;
1832 svp = &GvSV(gv); /* symbol table variable */
1833 SAVEGENERICSV(*svp);
1836 iterdata = (void*)gv;
1840 if (PL_op->op_private & OPpITER_DEF)
1841 cxtype |= CXp_FOR_DEF;
1845 PUSHBLOCK(cx, cxtype, SP);
1847 PUSHLOOP(cx, iterdata, MARK);
1849 PUSHLOOP(cx, svp, MARK);
1851 if (PL_op->op_flags & OPf_STACKED) {
1852 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1853 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1855 SV * const right = (SV*)cx->blk_loop.iterary;
1858 if (RANGE_IS_NUMERIC(sv,right)) {
1859 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1860 (SvOK(right) && SvNV(right) >= IV_MAX))
1861 DIE(aTHX_ "Range iterator outside integer range");
1862 cx->blk_loop.iterix = SvIV(sv);
1863 cx->blk_loop.itermax = SvIV(right);
1865 /* for correct -Dstv display */
1866 cx->blk_oldsp = sp - PL_stack_base;
1870 cx->blk_loop.iterlval = newSVsv(sv);
1871 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1872 (void) SvPV_nolen_const(right);
1875 else if (PL_op->op_private & OPpITER_REVERSED) {
1876 cx->blk_loop.itermax = 0;
1877 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1882 cx->blk_loop.iterary = PL_curstack;
1883 AvFILLp(PL_curstack) = SP - PL_stack_base;
1884 if (PL_op->op_private & OPpITER_REVERSED) {
1885 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1886 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1889 cx->blk_loop.iterix = MARK - PL_stack_base;
1899 register PERL_CONTEXT *cx;
1900 const I32 gimme = GIMME_V;
1906 PUSHBLOCK(cx, CXt_LOOP, SP);
1907 PUSHLOOP(cx, 0, SP);
1915 register PERL_CONTEXT *cx;
1922 assert(CxTYPE(cx) == CXt_LOOP);
1924 newsp = PL_stack_base + cx->blk_loop.resetsp;
1927 if (gimme == G_VOID)
1928 /*EMPTY*/; /* do nothing */
1929 else if (gimme == G_SCALAR) {
1931 *++newsp = sv_mortalcopy(*SP);
1933 *++newsp = &PL_sv_undef;
1937 *++newsp = sv_mortalcopy(*++mark);
1938 TAINT_NOT; /* Each item is independent */
1944 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1945 PL_curpm = newpm; /* ... and pop $1 et al */
1956 register PERL_CONTEXT *cx;
1957 bool popsub2 = FALSE;
1958 bool clear_errsv = FALSE;
1966 const I32 cxix = dopoptosub(cxstack_ix);
1969 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1970 * sort block, which is a CXt_NULL
1973 PL_stack_base[1] = *PL_stack_sp;
1974 PL_stack_sp = PL_stack_base + 1;
1978 DIE(aTHX_ "Can't return outside a subroutine");
1980 if (cxix < cxstack_ix)
1983 if (CxMULTICALL(&cxstack[cxix])) {
1984 gimme = cxstack[cxix].blk_gimme;
1985 if (gimme == G_VOID)
1986 PL_stack_sp = PL_stack_base;
1987 else if (gimme == G_SCALAR) {
1988 PL_stack_base[1] = *PL_stack_sp;
1989 PL_stack_sp = PL_stack_base + 1;
1995 switch (CxTYPE(cx)) {
1998 retop = cx->blk_sub.retop;
1999 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2002 if (!(PL_in_eval & EVAL_KEEPERR))
2005 retop = cx->blk_eval.retop;
2009 if (optype == OP_REQUIRE &&
2010 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2012 /* Unassume the success we assumed earlier. */
2013 SV * const nsv = cx->blk_eval.old_namesv;
2014 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2015 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
2020 retop = cx->blk_sub.retop;
2023 DIE(aTHX_ "panic: return");
2027 if (gimme == G_SCALAR) {
2030 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2032 *++newsp = SvREFCNT_inc(*SP);
2037 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2039 *++newsp = sv_mortalcopy(sv);
2044 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2047 *++newsp = sv_mortalcopy(*SP);
2050 *++newsp = &PL_sv_undef;
2052 else if (gimme == G_ARRAY) {
2053 while (++MARK <= SP) {
2054 *++newsp = (popsub2 && SvTEMP(*MARK))
2055 ? *MARK : sv_mortalcopy(*MARK);
2056 TAINT_NOT; /* Each item is independent */
2059 PL_stack_sp = newsp;
2062 /* Stack values are safe: */
2065 POPSUB(cx,sv); /* release CV and @_ ... */
2069 PL_curpm = newpm; /* ... and pop $1 et al */
2073 sv_setpvn(ERRSV,"",0);
2081 register PERL_CONTEXT *cx;
2092 if (PL_op->op_flags & OPf_SPECIAL) {
2093 cxix = dopoptoloop(cxstack_ix);
2095 DIE(aTHX_ "Can't \"last\" outside a loop block");
2098 cxix = dopoptolabel(cPVOP->op_pv);
2100 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2102 if (cxix < cxstack_ix)
2106 cxstack_ix++; /* temporarily protect top context */
2108 switch (CxTYPE(cx)) {
2111 newsp = PL_stack_base + cx->blk_loop.resetsp;
2112 nextop = cx->blk_loop.last_op->op_next;
2116 nextop = cx->blk_sub.retop;
2120 nextop = cx->blk_eval.retop;
2124 nextop = cx->blk_sub.retop;
2127 DIE(aTHX_ "panic: last");
2131 if (gimme == G_SCALAR) {
2133 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2134 ? *SP : sv_mortalcopy(*SP);
2136 *++newsp = &PL_sv_undef;
2138 else if (gimme == G_ARRAY) {
2139 while (++MARK <= SP) {
2140 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2141 ? *MARK : sv_mortalcopy(*MARK);
2142 TAINT_NOT; /* Each item is independent */
2150 /* Stack values are safe: */
2153 POPLOOP(cx); /* release loop vars ... */
2157 POPSUB(cx,sv); /* release CV and @_ ... */
2160 PL_curpm = newpm; /* ... and pop $1 et al */
2163 PERL_UNUSED_VAR(optype);
2164 PERL_UNUSED_VAR(gimme);
2172 register PERL_CONTEXT *cx;
2175 if (PL_op->op_flags & OPf_SPECIAL) {
2176 cxix = dopoptoloop(cxstack_ix);
2178 DIE(aTHX_ "Can't \"next\" outside a loop block");
2181 cxix = dopoptolabel(cPVOP->op_pv);
2183 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2185 if (cxix < cxstack_ix)
2188 /* clear off anything above the scope we're re-entering, but
2189 * save the rest until after a possible continue block */
2190 inner = PL_scopestack_ix;
2192 if (PL_scopestack_ix < inner)
2193 leave_scope(PL_scopestack[PL_scopestack_ix]);
2194 PL_curcop = cx->blk_oldcop;
2195 return cx->blk_loop.next_op;
2202 register PERL_CONTEXT *cx;
2206 if (PL_op->op_flags & OPf_SPECIAL) {
2207 cxix = dopoptoloop(cxstack_ix);
2209 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2212 cxix = dopoptolabel(cPVOP->op_pv);
2214 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2216 if (cxix < cxstack_ix)
2219 redo_op = cxstack[cxix].blk_loop.redo_op;
2220 if (redo_op->op_type == OP_ENTER) {
2221 /* pop one less context to avoid $x being freed in while (my $x..) */
2223 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2224 redo_op = redo_op->op_next;
2228 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2229 LEAVE_SCOPE(oldsave);
2231 PL_curcop = cx->blk_oldcop;
2236 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2240 static const char too_deep[] = "Target of goto is too deeply nested";
2243 Perl_croak(aTHX_ too_deep);
2244 if (o->op_type == OP_LEAVE ||
2245 o->op_type == OP_SCOPE ||
2246 o->op_type == OP_LEAVELOOP ||
2247 o->op_type == OP_LEAVESUB ||
2248 o->op_type == OP_LEAVETRY)
2250 *ops++ = cUNOPo->op_first;
2252 Perl_croak(aTHX_ too_deep);
2255 if (o->op_flags & OPf_KIDS) {
2257 /* First try all the kids at this level, since that's likeliest. */
2258 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2259 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2260 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2263 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2264 if (kid == PL_lastgotoprobe)
2266 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2269 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2270 ops[-1]->op_type == OP_DBSTATE)
2275 if ((o = dofindlabel(kid, label, ops, oplimit)))
2288 register PERL_CONTEXT *cx;
2289 #define GOTO_DEPTH 64
2290 OP *enterops[GOTO_DEPTH];
2291 const char *label = NULL;
2292 const bool do_dump = (PL_op->op_type == OP_DUMP);
2293 static const char must_have_label[] = "goto must have label";
2295 if (PL_op->op_flags & OPf_STACKED) {
2296 SV * const sv = POPs;
2298 /* This egregious kludge implements goto &subroutine */
2299 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2301 register PERL_CONTEXT *cx;
2302 CV* cv = (CV*)SvRV(sv);
2309 if (!CvROOT(cv) && !CvXSUB(cv)) {
2310 const GV * const gv = CvGV(cv);
2314 /* autoloaded stub? */
2315 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2317 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2318 GvNAMELEN(gv), FALSE);
2319 if (autogv && (cv = GvCV(autogv)))
2321 tmpstr = sv_newmortal();
2322 gv_efullname3(tmpstr, gv, NULL);
2323 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2325 DIE(aTHX_ "Goto undefined subroutine");
2328 /* First do some returnish stuff. */
2329 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2331 cxix = dopoptosub(cxstack_ix);
2333 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2334 if (cxix < cxstack_ix)
2338 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2339 if (CxTYPE(cx) == CXt_EVAL) {
2341 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2343 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2345 else if (CxMULTICALL(cx))
2346 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2347 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2348 /* put @_ back onto stack */
2349 AV* av = cx->blk_sub.argarray;
2351 items = AvFILLp(av) + 1;
2352 EXTEND(SP, items+1); /* @_ could have been extended. */
2353 Copy(AvARRAY(av), SP + 1, items, SV*);
2354 SvREFCNT_dec(GvAV(PL_defgv));
2355 GvAV(PL_defgv) = cx->blk_sub.savearray;
2357 /* abandon @_ if it got reified */
2362 av_extend(av, items-1);
2364 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2367 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2368 AV* const av = GvAV(PL_defgv);
2369 items = AvFILLp(av) + 1;
2370 EXTEND(SP, items+1); /* @_ could have been extended. */
2371 Copy(AvARRAY(av), SP + 1, items, SV*);
2375 if (CxTYPE(cx) == CXt_SUB &&
2376 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2377 SvREFCNT_dec(cx->blk_sub.cv);
2378 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2379 LEAVE_SCOPE(oldsave);
2381 /* Now do some callish stuff. */
2383 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2385 OP* const retop = cx->blk_sub.retop;
2390 for (index=0; index<items; index++)
2391 sv_2mortal(SP[-index]);
2394 /* XS subs don't have a CxSUB, so pop it */
2395 POPBLOCK(cx, PL_curpm);
2396 /* Push a mark for the start of arglist */
2399 (void)(*CvXSUB(cv))(aTHX_ cv);
2404 AV* const padlist = CvPADLIST(cv);
2405 if (CxTYPE(cx) == CXt_EVAL) {
2406 PL_in_eval = cx->blk_eval.old_in_eval;
2407 PL_eval_root = cx->blk_eval.old_eval_root;
2408 cx->cx_type = CXt_SUB;
2409 cx->blk_sub.hasargs = 0;
2411 cx->blk_sub.cv = cv;
2412 cx->blk_sub.olddepth = CvDEPTH(cv);
2415 if (CvDEPTH(cv) < 2)
2416 SvREFCNT_inc_void_NN(cv);
2418 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2419 sub_crush_depth(cv);
2420 pad_push(padlist, CvDEPTH(cv));
2423 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2424 if (cx->blk_sub.hasargs)
2426 AV* const av = (AV*)PAD_SVl(0);
2428 cx->blk_sub.savearray = GvAV(PL_defgv);
2429 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2430 CX_CURPAD_SAVE(cx->blk_sub);
2431 cx->blk_sub.argarray = av;
2433 if (items >= AvMAX(av) + 1) {
2434 SV **ary = AvALLOC(av);
2435 if (AvARRAY(av) != ary) {
2436 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2437 SvPV_set(av, (char*)ary);
2439 if (items >= AvMAX(av) + 1) {
2440 AvMAX(av) = items - 1;
2441 Renew(ary,items+1,SV*);
2443 SvPV_set(av, (char*)ary);
2447 Copy(mark,AvARRAY(av),items,SV*);
2448 AvFILLp(av) = items - 1;
2449 assert(!AvREAL(av));
2451 /* transfer 'ownership' of refcnts to new @_ */
2461 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2463 * We do not care about using sv to call CV;
2464 * it's for informational purposes only.
2466 SV * const sv = GvSV(PL_DBsub);
2468 if (PERLDB_SUB_NN) {
2469 const int type = SvTYPE(sv);
2470 if (type < SVt_PVIV && type != SVt_IV)
2471 sv_upgrade(sv, SVt_PVIV);
2473 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2475 gv_efullname3(sv, CvGV(cv), NULL);
2478 CV * const gotocv = get_cv("DB::goto", FALSE);
2480 PUSHMARK( PL_stack_sp );
2481 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2486 RETURNOP(CvSTART(cv));
2490 label = SvPV_nolen_const(sv);
2491 if (!(do_dump || *label))
2492 DIE(aTHX_ must_have_label);
2495 else if (PL_op->op_flags & OPf_SPECIAL) {
2497 DIE(aTHX_ must_have_label);
2500 label = cPVOP->op_pv;
2502 if (label && *label) {
2503 OP *gotoprobe = NULL;
2504 bool leaving_eval = FALSE;
2505 bool in_block = FALSE;
2506 PERL_CONTEXT *last_eval_cx = NULL;
2510 PL_lastgotoprobe = NULL;
2512 for (ix = cxstack_ix; ix >= 0; ix--) {
2514 switch (CxTYPE(cx)) {
2516 leaving_eval = TRUE;
2517 if (!CxTRYBLOCK(cx)) {
2518 gotoprobe = (last_eval_cx ?
2519 last_eval_cx->blk_eval.old_eval_root :
2524 /* else fall through */
2526 gotoprobe = cx->blk_oldcop->op_sibling;
2532 gotoprobe = cx->blk_oldcop->op_sibling;
2535 gotoprobe = PL_main_root;
2538 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2539 gotoprobe = CvROOT(cx->blk_sub.cv);
2545 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2548 DIE(aTHX_ "panic: goto");
2549 gotoprobe = PL_main_root;
2553 retop = dofindlabel(gotoprobe, label,
2554 enterops, enterops + GOTO_DEPTH);
2558 PL_lastgotoprobe = gotoprobe;
2561 DIE(aTHX_ "Can't find label %s", label);
2563 /* if we're leaving an eval, check before we pop any frames
2564 that we're not going to punt, otherwise the error
2567 if (leaving_eval && *enterops && enterops[1]) {
2569 for (i = 1; enterops[i]; i++)
2570 if (enterops[i]->op_type == OP_ENTERITER)
2571 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2574 /* pop unwanted frames */
2576 if (ix < cxstack_ix) {
2583 oldsave = PL_scopestack[PL_scopestack_ix];
2584 LEAVE_SCOPE(oldsave);
2587 /* push wanted frames */
2589 if (*enterops && enterops[1]) {
2590 OP * const oldop = PL_op;
2591 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2592 for (; enterops[ix]; ix++) {
2593 PL_op = enterops[ix];
2594 /* Eventually we may want to stack the needed arguments
2595 * for each op. For now, we punt on the hard ones. */
2596 if (PL_op->op_type == OP_ENTERITER)
2597 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2598 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2606 if (!retop) retop = PL_main_start;
2608 PL_restartop = retop;
2609 PL_do_undump = TRUE;
2613 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2614 PL_do_undump = FALSE;
2631 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2633 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2636 PL_exit_flags |= PERL_EXIT_EXPECTED;
2638 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2639 if (anum || !(PL_minus_c && PL_madskills))
2644 PUSHs(&PL_sv_undef);
2651 S_save_lines(pTHX_ AV *array, SV *sv)
2653 const char *s = SvPVX_const(sv);
2654 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2657 while (s && s < send) {
2659 SV * const tmpstr = newSV(0);
2661 sv_upgrade(tmpstr, SVt_PVMG);
2662 t = strchr(s, '\n');
2668 sv_setpvn(tmpstr, s, t - s);
2669 av_store(array, line++, tmpstr);
2675 S_docatch_body(pTHX)
2683 S_docatch(pTHX_ OP *o)
2687 OP * const oldop = PL_op;
2691 assert(CATCH_GET == TRUE);
2698 assert(cxstack_ix >= 0);
2699 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2700 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2705 /* die caught by an inner eval - continue inner loop */
2707 /* NB XXX we rely on the old popped CxEVAL still being at the top
2708 * of the stack; the way die_where() currently works, this
2709 * assumption is valid. In theory The cur_top_env value should be
2710 * returned in another global, the way retop (aka PL_restartop)
2712 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2715 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2717 PL_op = PL_restartop;
2734 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2735 /* sv Text to convert to OP tree. */
2736 /* startop op_free() this to undo. */
2737 /* code Short string id of the caller. */
2739 /* FIXME - how much of this code is common with pp_entereval? */
2740 dVAR; dSP; /* Make POPBLOCK work. */
2747 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2748 char *tmpbuf = tbuf;
2751 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2757 /* switch to eval mode */
2759 if (IN_PERL_COMPILETIME) {
2760 SAVECOPSTASH_FREE(&PL_compiling);
2761 CopSTASH_set(&PL_compiling, PL_curstash);
2763 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2764 SV * const sv = sv_newmortal();
2765 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2766 code, (unsigned long)++PL_evalseq,
2767 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2772 len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
2773 (unsigned long)++PL_evalseq);
2774 SAVECOPFILE_FREE(&PL_compiling);
2775 CopFILE_set(&PL_compiling, tmpbuf+2);
2776 SAVECOPLINE(&PL_compiling);
2777 CopLINE_set(&PL_compiling, 1);
2778 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2779 deleting the eval's FILEGV from the stash before gv_check() runs
2780 (i.e. before run-time proper). To work around the coredump that
2781 ensues, we always turn GvMULTI_on for any globals that were
2782 introduced within evals. See force_ident(). GSAR 96-10-12 */
2783 safestr = savepvn(tmpbuf, len);
2784 SAVEDELETE(PL_defstash, safestr, len);
2786 #ifdef OP_IN_REGISTER
2792 /* we get here either during compilation, or via pp_regcomp at runtime */
2793 runtime = IN_PERL_RUNTIME;
2795 runcv = find_runcv(NULL);
2798 PL_op->op_type = OP_ENTEREVAL;
2799 PL_op->op_flags = 0; /* Avoid uninit warning. */
2800 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2801 PUSHEVAL(cx, 0, NULL);
2804 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2806 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2807 POPBLOCK(cx,PL_curpm);
2810 (*startop)->op_type = OP_NULL;
2811 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2813 /* XXX DAPM do this properly one year */
2814 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2816 if (IN_PERL_COMPILETIME)
2817 CopHINTS_set(&PL_compiling, PL_hints);
2818 #ifdef OP_IN_REGISTER
2821 PERL_UNUSED_VAR(newsp);
2822 PERL_UNUSED_VAR(optype);
2829 =for apidoc find_runcv
2831 Locate the CV corresponding to the currently executing sub or eval.
2832 If db_seqp is non_null, skip CVs that are in the DB package and populate
2833 *db_seqp with the cop sequence number at the point that the DB:: code was
2834 entered. (allows debuggers to eval in the scope of the breakpoint rather
2835 than in the scope of the debugger itself).
2841 Perl_find_runcv(pTHX_ U32 *db_seqp)
2847 *db_seqp = PL_curcop->cop_seq;
2848 for (si = PL_curstackinfo; si; si = si->si_prev) {
2850 for (ix = si->si_cxix; ix >= 0; ix--) {
2851 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2852 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2853 CV * const cv = cx->blk_sub.cv;
2854 /* skip DB:: code */
2855 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2856 *db_seqp = cx->blk_oldcop->cop_seq;
2861 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2869 /* Compile a require/do, an eval '', or a /(?{...})/.
2870 * In the last case, startop is non-null, and contains the address of
2871 * a pointer that should be set to the just-compiled code.
2872 * outside is the lexically enclosing CV (if any) that invoked us.
2875 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2877 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2880 OP * const saveop = PL_op;
2882 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2883 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2888 SAVESPTR(PL_compcv);
2889 PL_compcv = (CV*)newSV(0);
2890 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2891 CvEVAL_on(PL_compcv);
2892 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2893 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2895 CvOUTSIDE_SEQ(PL_compcv) = seq;
2896 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2898 /* set up a scratch pad */
2900 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2904 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2906 /* make sure we compile in the right package */
2908 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2909 SAVESPTR(PL_curstash);
2910 PL_curstash = CopSTASH(PL_curcop);
2912 SAVESPTR(PL_beginav);
2913 PL_beginav = newAV();
2914 SAVEFREESV(PL_beginav);
2915 SAVEI32(PL_error_count);
2918 SAVEI32(PL_madskills);
2922 /* try to compile it */
2924 PL_eval_root = NULL;
2926 PL_curcop = &PL_compiling;
2927 CopARYBASE_set(PL_curcop, 0);
2928 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2929 PL_in_eval |= EVAL_KEEPERR;
2931 sv_setpvn(ERRSV,"",0);
2932 if (yyparse() || PL_error_count || !PL_eval_root) {
2933 SV **newsp; /* Used by POPBLOCK. */
2934 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2935 I32 optype = 0; /* Might be reset by POPEVAL. */
2940 op_free(PL_eval_root);
2941 PL_eval_root = NULL;
2943 SP = PL_stack_base + POPMARK; /* pop original mark */
2945 POPBLOCK(cx,PL_curpm);
2951 msg = SvPVx_nolen_const(ERRSV);
2952 if (optype == OP_REQUIRE) {
2953 const SV * const nsv = cx->blk_eval.old_namesv;
2954 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2956 DIE(aTHX_ "%sCompilation failed in require",
2957 *msg ? msg : "Unknown error\n");
2960 POPBLOCK(cx,PL_curpm);
2962 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2963 (*msg ? msg : "Unknown error\n"));
2967 sv_setpv(ERRSV, "Compilation error");
2970 PERL_UNUSED_VAR(newsp);
2973 CopLINE_set(&PL_compiling, 0);
2975 *startop = PL_eval_root;
2977 SAVEFREEOP(PL_eval_root);
2979 /* Set the context for this new optree.
2980 * If the last op is an OP_REQUIRE, force scalar context.
2981 * Otherwise, propagate the context from the eval(). */
2982 if (PL_eval_root->op_type == OP_LEAVEEVAL
2983 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2984 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2986 scalar(PL_eval_root);
2987 else if (gimme & G_VOID)
2988 scalarvoid(PL_eval_root);
2989 else if (gimme & G_ARRAY)
2992 scalar(PL_eval_root);
2994 DEBUG_x(dump_eval());
2996 /* Register with debugger: */
2997 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2998 CV * const cv = get_cv("DB::postponed", FALSE);
3002 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3004 call_sv((SV*)cv, G_DISCARD);
3008 /* compiled okay, so do it */
3010 CvDEPTH(PL_compcv) = 1;
3011 SP = PL_stack_base + POPMARK; /* pop original mark */
3012 PL_op = saveop; /* The caller may need it. */
3013 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3015 RETURNOP(PL_eval_start);
3019 S_check_type_and_open(pTHX_ const char *name, const char *mode)
3022 const int st_rc = PerlLIO_stat(name, &st);
3023 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3027 return PerlIO_open(name, mode);
3031 S_doopen_pm(pTHX_ const char *name, const char *mode)
3033 #ifndef PERL_DISABLE_PMC
3034 const STRLEN namelen = strlen(name);
3037 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3038 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3039 const char * const pmc = SvPV_nolen_const(pmcsv);
3041 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3042 fp = check_type_and_open(name, mode);
3045 fp = check_type_and_open(pmc, mode);
3047 SvREFCNT_dec(pmcsv);
3050 fp = check_type_and_open(name, mode);
3054 return check_type_and_open(name, mode);
3055 #endif /* !PERL_DISABLE_PMC */
3061 register PERL_CONTEXT *cx;
3065 const char *tryname = NULL;
3067 const I32 gimme = GIMME_V;
3068 int filter_has_file = 0;
3069 PerlIO *tryrsfp = NULL;
3070 SV *filter_state = NULL;
3071 SV *filter_sub = NULL;
3077 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3078 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3079 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3080 "v-string in use/require non-portable");
3082 sv = new_version(sv);
3083 if (!sv_derived_from(PL_patchlevel, "version"))
3084 upg_version(PL_patchlevel);
3085 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3086 if ( vcmp(sv,PL_patchlevel) < 0 )
3087 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3088 vnormal(sv), vnormal(PL_patchlevel));
3091 if ( vcmp(sv,PL_patchlevel) > 0 )
3092 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3093 vnormal(sv), vnormal(PL_patchlevel));
3098 name = SvPV_const(sv, len);
3099 if (!(name && len > 0 && *name))
3100 DIE(aTHX_ "Null filename used");
3101 TAINT_PROPER("require");
3102 if (PL_op->op_type == OP_REQUIRE) {
3103 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3105 if (*svp != &PL_sv_undef)
3108 DIE(aTHX_ "Compilation failed in require");
3112 /* prepare to compile file */
3114 if (path_is_absolute(name)) {
3116 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3118 #ifdef MACOS_TRADITIONAL
3122 MacPerl_CanonDir(name, newname, 1);
3123 if (path_is_absolute(newname)) {
3125 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3130 AV * const ar = GvAVn(PL_incgv);
3134 if ((unixname = tounixspec(name, NULL)) != NULL)
3138 for (i = 0; i <= AvFILL(ar); i++) {
3139 SV *dirsv = *av_fetch(ar, i, TRUE);
3145 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3146 && !sv_isobject(loader))
3148 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3151 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3152 PTR2UV(SvRV(dirsv)), name);
3153 tryname = SvPVX_const(namesv);
3164 if (sv_isobject(loader))
3165 count = call_method("INC", G_ARRAY);
3167 count = call_sv(loader, G_ARRAY);
3177 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3181 if (SvTYPE(arg) == SVt_PVGV) {
3182 IO *io = GvIO((GV *)arg);
3187 tryrsfp = IoIFP(io);
3188 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3189 PerlIO_close(IoOFP(io));
3200 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3202 SvREFCNT_inc_void_NN(filter_sub);
3205 filter_state = SP[i];
3206 SvREFCNT_inc_simple_void(filter_state);
3210 tryrsfp = PerlIO_open(BIT_BUCKET,
3226 filter_has_file = 0;
3228 SvREFCNT_dec(filter_state);
3229 filter_state = NULL;
3232 SvREFCNT_dec(filter_sub);
3237 if (!path_is_absolute(name)
3238 #ifdef MACOS_TRADITIONAL
3239 /* We consider paths of the form :a:b ambiguous and interpret them first
3240 as global then as local
3242 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3245 const char *dir = SvPVx_nolen_const(dirsv);
3246 #ifdef MACOS_TRADITIONAL
3250 MacPerl_CanonDir(name, buf2, 1);
3251 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3255 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3257 sv_setpv(namesv, unixdir);
3258 sv_catpv(namesv, unixname);
3260 # ifdef __SYMBIAN32__
3261 if (PL_origfilename[0] &&
3262 PL_origfilename[1] == ':' &&
3263 !(dir[0] && dir[1] == ':'))
3264 Perl_sv_setpvf(aTHX_ namesv,
3269 Perl_sv_setpvf(aTHX_ namesv,
3273 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3277 TAINT_PROPER("require");
3278 tryname = SvPVX_const(namesv);
3279 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3281 if (tryname[0] == '.' && tryname[1] == '/')
3290 SAVECOPFILE_FREE(&PL_compiling);
3291 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3292 SvREFCNT_dec(namesv);
3294 if (PL_op->op_type == OP_REQUIRE) {
3295 const char *msgstr = name;
3296 if(errno == EMFILE) {
3298 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3300 msgstr = SvPV_nolen_const(msg);
3302 if (namesv) { /* did we lookup @INC? */
3303 AV * const ar = GvAVn(PL_incgv);
3305 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3306 "%s in @INC%s%s (@INC contains:",
3308 (instr(msgstr, ".h ")
3309 ? " (change .h to .ph maybe?)" : ""),
3310 (instr(msgstr, ".ph ")
3311 ? " (did you run h2ph?)" : "")
3314 for (i = 0; i <= AvFILL(ar); i++) {
3315 sv_catpvs(msg, " ");
3316 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3318 sv_catpvs(msg, ")");
3319 msgstr = SvPV_nolen_const(msg);
3322 DIE(aTHX_ "Can't locate %s", msgstr);
3328 SETERRNO(0, SS_NORMAL);
3330 /* Assume success here to prevent recursive requirement. */
3331 /* name is never assigned to again, so len is still strlen(name) */
3332 /* Check whether a hook in @INC has already filled %INC */
3334 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3336 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3338 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc_simple(hook_sv), 0 );
3343 lex_start(sv_2mortal(newSVpvs("")));
3344 SAVEGENERICSV(PL_rsfp_filters);
3345 PL_rsfp_filters = NULL;
3350 SAVECOMPILEWARNINGS();
3351 if (PL_dowarn & G_WARN_ALL_ON)
3352 PL_compiling.cop_warnings = pWARN_ALL ;
3353 else if (PL_dowarn & G_WARN_ALL_OFF)
3354 PL_compiling.cop_warnings = pWARN_NONE ;
3355 else if (PL_taint_warn) {
3356 PL_compiling.cop_warnings
3357 = Perl_new_warnings_bitfield(aTHX_ NULL, WARN_TAINTstring, WARNsize);
3360 PL_compiling.cop_warnings = pWARN_STD ;
3361 SAVESPTR(PL_compiling.cop_io);
3362 PL_compiling.cop_io = NULL;
3365 SV * const datasv = filter_add(S_run_user_filter, NULL);
3366 IoLINES(datasv) = filter_has_file;
3367 IoTOP_GV(datasv) = (GV *)filter_state;
3368 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3371 /* switch to eval mode */
3372 PUSHBLOCK(cx, CXt_EVAL, SP);
3373 PUSHEVAL(cx, name, NULL);
3374 cx->blk_eval.retop = PL_op->op_next;
3376 SAVECOPLINE(&PL_compiling);
3377 CopLINE_set(&PL_compiling, 0);
3381 /* Store and reset encoding. */
3382 encoding = PL_encoding;
3385 op = DOCATCH(doeval(gimme, NULL, NULL, PL_curcop->cop_seq));
3387 /* Restore encoding. */
3388 PL_encoding = encoding;
3396 register PERL_CONTEXT *cx;
3398 const I32 gimme = GIMME_V;
3399 const I32 was = PL_sub_generation;
3400 char tbuf[TYPE_DIGITS(long) + 12];
3401 char *tmpbuf = tbuf;
3407 HV *saved_hh = NULL;
3409 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3410 saved_hh = (HV*) SvREFCNT_inc(POPs);
3414 if (!SvPV_nolen_const(sv))
3416 TAINT_PROPER("eval");
3422 /* switch to eval mode */
3424 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3425 SV * const temp_sv = sv_newmortal();
3426 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3427 (unsigned long)++PL_evalseq,
3428 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3429 tmpbuf = SvPVX(temp_sv);
3430 len = SvCUR(temp_sv);
3433 len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3434 SAVECOPFILE_FREE(&PL_compiling);
3435 CopFILE_set(&PL_compiling, tmpbuf+2);
3436 SAVECOPLINE(&PL_compiling);
3437 CopLINE_set(&PL_compiling, 1);
3438 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3439 deleting the eval's FILEGV from the stash before gv_check() runs
3440 (i.e. before run-time proper). To work around the coredump that
3441 ensues, we always turn GvMULTI_on for any globals that were
3442 introduced within evals. See force_ident(). GSAR 96-10-12 */
3443 safestr = savepvn(tmpbuf, len);
3444 SAVEDELETE(PL_defstash, safestr, len);
3446 PL_hints = PL_op->op_targ;
3448 GvHV(PL_hintgv) = saved_hh;
3449 SAVECOMPILEWARNINGS();
3450 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3451 SAVESPTR(PL_compiling.cop_io);
3452 if (specialCopIO(PL_curcop->cop_io))
3453 PL_compiling.cop_io = PL_curcop->cop_io;
3455 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3456 SAVEFREESV(PL_compiling.cop_io);
3458 if (PL_compiling.cop_hints) {
3459 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints);
3461 PL_compiling.cop_hints = PL_curcop->cop_hints;
3462 if (PL_compiling.cop_hints) {
3464 PL_compiling.cop_hints->refcounted_he_refcnt++;
3465 HINTS_REFCNT_UNLOCK;
3467 /* special case: an eval '' executed within the DB package gets lexically
3468 * placed in the first non-DB CV rather than the current CV - this
3469 * allows the debugger to execute code, find lexicals etc, in the
3470 * scope of the code being debugged. Passing &seq gets find_runcv
3471 * to do the dirty work for us */
3472 runcv = find_runcv(&seq);
3474 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3475 PUSHEVAL(cx, 0, NULL);
3476 cx->blk_eval.retop = PL_op->op_next;
3478 /* prepare to compile string */
3480 if (PERLDB_LINE && PL_curstash != PL_debstash)
3481 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3483 ret = doeval(gimme, NULL, runcv, seq);
3484 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3485 && ret != PL_op->op_next) { /* Successive compilation. */
3486 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3488 return DOCATCH(ret);
3498 register PERL_CONTEXT *cx;
3500 const U8 save_flags = PL_op -> op_flags;
3505 retop = cx->blk_eval.retop;
3508 if (gimme == G_VOID)
3510 else if (gimme == G_SCALAR) {
3513 if (SvFLAGS(TOPs) & SVs_TEMP)
3516 *MARK = sv_mortalcopy(TOPs);
3520 *MARK = &PL_sv_undef;
3525 /* in case LEAVE wipes old return values */
3526 for (mark = newsp + 1; mark <= SP; mark++) {
3527 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3528 *mark = sv_mortalcopy(*mark);
3529 TAINT_NOT; /* Each item is independent */
3533 PL_curpm = newpm; /* Don't pop $1 et al till now */
3536 assert(CvDEPTH(PL_compcv) == 1);
3538 CvDEPTH(PL_compcv) = 0;
3541 if (optype == OP_REQUIRE &&
3542 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3544 /* Unassume the success we assumed earlier. */
3545 SV * const nsv = cx->blk_eval.old_namesv;
3546 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3547 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3548 /* die_where() did LEAVE, or we won't be here */
3552 if (!(save_flags & OPf_SPECIAL))
3553 sv_setpvn(ERRSV,"",0);
3559 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3560 close to the related Perl_create_eval_scope. */
3562 Perl_delete_eval_scope(pTHX)
3567 register PERL_CONTEXT *cx;
3574 PERL_UNUSED_VAR(newsp);
3575 PERL_UNUSED_VAR(gimme);
3576 PERL_UNUSED_VAR(optype);
3579 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3580 also needed by Perl_fold_constants. */
3582 Perl_create_eval_scope(pTHX_ U32 flags)
3585 const I32 gimme = GIMME_V;
3590 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3592 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3594 PL_in_eval = EVAL_INEVAL;
3595 if (flags & G_KEEPERR)
3596 PL_in_eval |= EVAL_KEEPERR;
3598 sv_setpvn(ERRSV,"",0);
3599 if (flags & G_FAKINGEVAL) {
3600 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3608 PERL_CONTEXT *cx = create_eval_scope(0);
3609 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3610 return DOCATCH(PL_op->op_next);
3619 register PERL_CONTEXT *cx;
3624 PERL_UNUSED_VAR(optype);
3627 if (gimme == G_VOID)
3629 else if (gimme == G_SCALAR) {
3633 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3636 *MARK = sv_mortalcopy(TOPs);
3640 *MARK = &PL_sv_undef;
3645 /* in case LEAVE wipes old return values */
3647 for (mark = newsp + 1; mark <= SP; mark++) {
3648 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3649 *mark = sv_mortalcopy(*mark);
3650 TAINT_NOT; /* Each item is independent */
3654 PL_curpm = newpm; /* Don't pop $1 et al till now */
3657 sv_setpvn(ERRSV,"",0);
3664 register PERL_CONTEXT *cx;
3665 const I32 gimme = GIMME_V;
3670 if (PL_op->op_targ == 0) {
3671 SV ** const defsv_p = &GvSV(PL_defgv);
3672 *defsv_p = newSVsv(POPs);
3673 SAVECLEARSV(*defsv_p);
3676 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3678 PUSHBLOCK(cx, CXt_GIVEN, SP);
3687 register PERL_CONTEXT *cx;
3691 PERL_UNUSED_CONTEXT;
3694 assert(CxTYPE(cx) == CXt_GIVEN);
3699 PL_curpm = newpm; /* pop $1 et al */
3706 /* Helper routines used by pp_smartmatch */
3709 S_make_matcher(pTHX_ regexp *re)
3712 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3713 PM_SETRE(matcher, ReREFCNT_inc(re));
3715 SAVEFREEOP((OP *) matcher);
3723 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3728 PL_op = (OP *) matcher;
3733 return (SvTRUEx(POPs));
3738 S_destroy_matcher(pTHX_ PMOP *matcher)
3741 PERL_UNUSED_ARG(matcher);
3746 /* Do a smart match */
3749 return do_smartmatch(NULL, NULL);
3752 /* This version of do_smartmatch() implements the following
3753 table of smart matches:
3755 $a $b Type of Match Implied Matching Code
3756 ====== ===== ===================== =============
3757 (overloading trumps everything)
3759 Code[+] Code[+] referential equality match if refaddr($a) == refaddr($b)
3760 Any Code[+] scalar sub truth match if $b->($a)
3762 Hash Hash hash keys identical match if sort(keys(%$a)) ÈeqÇ sort(keys(%$b))
3763 Hash Array hash value slice truth match if $a->{any(@$b)}
3764 Hash Regex hash key grep match if any(keys(%$a)) =~ /$b/
3765 Hash Any hash entry existence match if exists $a->{$b}
3767 Array Array arrays are identical[*] match if $a È~~Ç $b
3768 Array Regex array grep match if any(@$a) =~ /$b/
3769 Array Num array contains number match if any($a) == $b
3770 Array Any array contains string match if any($a) eq $b
3772 Any undef undefined match if !defined $a
3773 Any Regex pattern match match if $a =~ /$b/
3774 Code() Code() results are equal match if $a->() eq $b->()
3775 Any Code() simple closure truth match if $b->() (ignoring $a)
3776 Num numish[!] numeric equality match if $a == $b
3777 Any Str string equality match if $a eq $b
3778 Any Num numeric equality match if $a == $b
3780 Any Any string equality match if $a eq $b
3783 + - this must be a code reference whose prototype (if present) is not ""
3784 (subs with a "" prototype are dealt with by the 'Code()' entry lower down)
3785 * - if a circular reference is found, we fall back to referential equality
3786 ! - either a real number, or a string that looks_like_number()
3791 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3796 SV *e = TOPs; /* e is for 'expression' */
3797 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3800 regexp *this_regex, *other_regex;
3802 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3804 # define SM_REF(type) ( \
3805 (SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_##type) && (other = e)) \
3806 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_##type) && (other = d)))
3808 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3809 ((SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_PVCV) \
3810 && NOT_EMPTY_PROTO(this) && (other = e)) \
3811 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_PVCV) \
3812 && NOT_EMPTY_PROTO(this) && (other = d)))
3814 # define SM_REGEX ( \
3815 (SvROK(d) && SvMAGICAL(this = SvRV(d)) \
3816 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3817 && (this_regex = (regexp *)mg->mg_obj) \
3820 (SvROK(e) && SvMAGICAL(this = SvRV(e)) \
3821 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3822 && (this_regex = (regexp *)mg->mg_obj) \
3826 # define SM_OTHER_REF(type) \
3827 (SvROK(other) && SvTYPE(SvRV(other)) == SVt_##type)
3829 # define SM_OTHER_REGEX (SvROK(other) && SvMAGICAL(SvRV(other)) \
3830 && (mg = mg_find(SvRV(other), PERL_MAGIC_qr)) \
3831 && (other_regex = (regexp *)mg->mg_obj))
3834 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3835 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3837 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3838 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3840 tryAMAGICbinSET(smart, 0);
3842 SP -= 2; /* Pop the values */
3844 /* Take care only to invoke mg_get() once for each argument.
3845 * Currently we do this by copying the SV if it's magical. */
3848 d = sv_mortalcopy(d);
3855 e = sv_mortalcopy(e);
3860 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(other)) )
3862 if (this == SvRV(other))
3873 c = call_sv(this, G_SCALAR);
3877 else if (SvTEMP(TOPs))
3883 else if (SM_REF(PVHV)) {
3884 if (SM_OTHER_REF(PVHV)) {
3885 /* Check that the key-sets are identical */
3887 HV *other_hv = (HV *) SvRV(other);
3889 bool other_tied = FALSE;
3890 U32 this_key_count = 0,
3891 other_key_count = 0;
3893 /* Tied hashes don't know how many keys they have. */
3894 if (SvTIED_mg(this, PERL_MAGIC_tied)) {
3897 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3898 HV * const temp = other_hv;
3899 other_hv = (HV *) this;
3903 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3906 if (!tied && HvUSEDKEYS((HV *) this) != HvUSEDKEYS(other_hv))
3909 /* The hashes have the same number of keys, so it suffices
3910 to check that one is a subset of the other. */
3911 (void) hv_iterinit((HV *) this);
3912 while ( (he = hv_iternext((HV *) this)) ) {
3914 char * const key = hv_iterkey(he, &key_len);
3918 if(!hv_exists(other_hv, key, key_len)) {
3919 (void) hv_iterinit((HV *) this); /* reset iterator */
3925 (void) hv_iterinit(other_hv);
3926 while ( hv_iternext(other_hv) )
3930 other_key_count = HvUSEDKEYS(other_hv);
3932 if (this_key_count != other_key_count)
3937 else if (SM_OTHER_REF(PVAV)) {
3938 AV * const other_av = (AV *) SvRV(other);
3939 const I32 other_len = av_len(other_av) + 1;
3942 if (HvUSEDKEYS((HV *) this) != other_len)
3945 for(i = 0; i < other_len; ++i) {
3946 SV ** const svp = av_fetch(other_av, i, FALSE);
3950 if (!svp) /* ??? When can this happen? */
3953 key = SvPV(*svp, key_len);
3954 if(!hv_exists((HV *) this, key, key_len))
3959 else if (SM_OTHER_REGEX) {
3960 PMOP * const matcher = make_matcher(other_regex);
3963 (void) hv_iterinit((HV *) this);
3964 while ( (he = hv_iternext((HV *) this)) ) {
3965 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
3966 (void) hv_iterinit((HV *) this);
3967 destroy_matcher(matcher);
3971 destroy_matcher(matcher);
3975 if (hv_exists_ent((HV *) this, other, 0))
3981 else if (SM_REF(PVAV)) {
3982 if (SM_OTHER_REF(PVAV)) {
3983 AV *other_av = (AV *) SvRV(other);
3984 if (av_len((AV *) this) != av_len(other_av))
3988 const I32 other_len = av_len(other_av);
3990 if (NULL == seen_this) {
3991 seen_this = newHV();
3992 (void) sv_2mortal((SV *) seen_this);
3994 if (NULL == seen_other) {
3995 seen_this = newHV();
3996 (void) sv_2mortal((SV *) seen_other);
3998 for(i = 0; i <= other_len; ++i) {
3999 SV * const * const this_elem = av_fetch((AV *)this, i, FALSE);
4000 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4002 if (!this_elem || !other_elem) {
4003 if (this_elem || other_elem)
4006 else if (SM_SEEN_THIS(*this_elem)
4007 || SM_SEEN_OTHER(*other_elem))
4009 if (*this_elem != *other_elem)
4013 hv_store_ent(seen_this,
4014 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4016 hv_store_ent(seen_other,
4017 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4023 (void) do_smartmatch(seen_this, seen_other);
4033 else if (SM_OTHER_REGEX) {
4034 PMOP * const matcher = make_matcher(other_regex);
4035 const I32 this_len = av_len((AV *) this);
4038 for(i = 0; i <= this_len; ++i) {
4039 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4040 if (svp && matcher_matches_sv(matcher, *svp)) {
4041 destroy_matcher(matcher);
4045 destroy_matcher(matcher);
4048 else if (SvIOK(other) || SvNOK(other)) {
4051 for(i = 0; i <= AvFILL((AV *) this); ++i) {
4052 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4059 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4069 else if (SvPOK(other)) {
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);
4089 else if (!SvOK(d) || !SvOK(e)) {
4090 if (!SvOK(d) && !SvOK(e))
4095 else if (SM_REGEX) {
4096 PMOP * const matcher = make_matcher(this_regex);
4099 PUSHs(matcher_matches_sv(matcher, other)
4102 destroy_matcher(matcher);
4105 else if (SM_REF(PVCV)) {
4107 /* This must be a null-prototyped sub, because we
4108 already checked for the other kind. */
4114 c = call_sv(this, G_SCALAR);
4117 PUSHs(&PL_sv_undef);
4118 else if (SvTEMP(TOPs))
4121 if (SM_OTHER_REF(PVCV)) {
4122 /* This one has to be null-proto'd too.
4123 Call both of 'em, and compare the results */
4125 c = call_sv(SvRV(other), G_SCALAR);
4128 PUSHs(&PL_sv_undef);
4129 else if (SvTEMP(TOPs))
4141 else if ( ((SvIOK(d) || SvNOK(d)) && (this = d) && (other = e))
4142 || ((SvIOK(e) || SvNOK(e)) && (this = e) && (other = d)) )
4144 if (SvPOK(other) && !looks_like_number(other)) {
4145 /* String comparison */
4150 /* Otherwise, numeric comparison */
4153 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4164 /* As a last resort, use string comparison */
4173 register PERL_CONTEXT *cx;
4174 const I32 gimme = GIMME_V;
4176 /* This is essentially an optimization: if the match
4177 fails, we don't want to push a context and then
4178 pop it again right away, so we skip straight
4179 to the op that follows the leavewhen.
4181 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4182 return cLOGOP->op_other->op_next;
4187 PUSHBLOCK(cx, CXt_WHEN, SP);
4196 register PERL_CONTEXT *cx;
4202 assert(CxTYPE(cx) == CXt_WHEN);
4207 PL_curpm = newpm; /* pop $1 et al */
4217 register PERL_CONTEXT *cx;
4220 cxix = dopoptowhen(cxstack_ix);
4222 DIE(aTHX_ "Can't \"continue\" outside a when block");
4223 if (cxix < cxstack_ix)
4226 /* clear off anything above the scope we're re-entering */
4227 inner = PL_scopestack_ix;
4229 if (PL_scopestack_ix < inner)
4230 leave_scope(PL_scopestack[PL_scopestack_ix]);
4231 PL_curcop = cx->blk_oldcop;
4232 return cx->blk_givwhen.leave_op;
4239 register PERL_CONTEXT *cx;
4242 cxix = dopoptogiven(cxstack_ix);
4244 if (PL_op->op_flags & OPf_SPECIAL)
4245 DIE(aTHX_ "Can't use when() outside a topicalizer");
4247 DIE(aTHX_ "Can't \"break\" outside a given block");
4249 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4250 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4252 if (cxix < cxstack_ix)
4255 /* clear off anything above the scope we're re-entering */
4256 inner = PL_scopestack_ix;
4258 if (PL_scopestack_ix < inner)
4259 leave_scope(PL_scopestack[PL_scopestack_ix]);
4260 PL_curcop = cx->blk_oldcop;
4263 return cx->blk_loop.next_op;
4265 return cx->blk_givwhen.leave_op;
4269 S_doparseform(pTHX_ SV *sv)
4272 register char *s = SvPV_force(sv, len);
4273 register char * const send = s + len;
4274 register char *base = NULL;
4275 register I32 skipspaces = 0;
4276 bool noblank = FALSE;
4277 bool repeat = FALSE;
4278 bool postspace = FALSE;
4284 bool unchopnum = FALSE;
4285 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4288 Perl_croak(aTHX_ "Null picture in formline");
4290 /* estimate the buffer size needed */
4291 for (base = s; s <= send; s++) {
4292 if (*s == '\n' || *s == '@' || *s == '^')
4298 Newx(fops, maxops, U32);
4303 *fpc++ = FF_LINEMARK;
4304 noblank = repeat = FALSE;
4322 case ' ': case '\t':
4329 } /* else FALL THROUGH */
4337 *fpc++ = FF_LITERAL;
4345 *fpc++ = (U16)skipspaces;
4349 *fpc++ = FF_NEWLINE;
4353 arg = fpc - linepc + 1;
4360 *fpc++ = FF_LINEMARK;
4361 noblank = repeat = FALSE;
4370 ischop = s[-1] == '^';
4376 arg = (s - base) - 1;
4378 *fpc++ = FF_LITERAL;
4386 *fpc++ = 2; /* skip the @* or ^* */
4388 *fpc++ = FF_LINESNGL;
4391 *fpc++ = FF_LINEGLOB;
4393 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4394 arg = ischop ? 512 : 0;
4399 const char * const f = ++s;
4402 arg |= 256 + (s - f);
4404 *fpc++ = s - base; /* fieldsize for FETCH */
4405 *fpc++ = FF_DECIMAL;
4407 unchopnum |= ! ischop;
4409 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4410 arg = ischop ? 512 : 0;
4412 s++; /* skip the '0' first */
4416 const char * const f = ++s;
4419 arg |= 256 + (s - f);
4421 *fpc++ = s - base; /* fieldsize for FETCH */
4422 *fpc++ = FF_0DECIMAL;
4424 unchopnum |= ! ischop;
4428 bool ismore = FALSE;
4431 while (*++s == '>') ;
4432 prespace = FF_SPACE;
4434 else if (*s == '|') {
4435 while (*++s == '|') ;
4436 prespace = FF_HALFSPACE;
4441 while (*++s == '<') ;
4444 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4448 *fpc++ = s - base; /* fieldsize for FETCH */
4450 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4453 *fpc++ = (U16)prespace;
4467 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4469 { /* need to jump to the next word */
4471 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4472 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4473 s = SvPVX(sv) + SvCUR(sv) + z;
4475 Copy(fops, s, arg, U32);
4477 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4480 if (unchopnum && repeat)
4481 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4487 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4489 /* Can value be printed in fldsize chars, using %*.*f ? */
4493 int intsize = fldsize - (value < 0 ? 1 : 0);
4500 while (intsize--) pwr *= 10.0;
4501 while (frcsize--) eps /= 10.0;
4504 if (value + eps >= pwr)
4507 if (value - eps <= -pwr)
4514 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4517 SV * const datasv = FILTER_DATA(idx);
4518 const int filter_has_file = IoLINES(datasv);
4519 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4520 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4522 /* Filter API says that the filter appends to the contents of the buffer.
4523 Usually the buffer is "", so the details don't matter. But if it's not,
4524 then clearly what it contains is already filtered by this filter, so we
4525 don't want to pass it in a second time.
4526 I'm going to use a mortal in case the upstream filter croaks. */
4528 = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4529 ? sv_newmortal() : buf_sv;
4531 SvUPGRADE(upstream, SVt_PV);
4532 /* I was having segfault trouble under Linux 2.2.5 after a
4533 parse error occured. (Had to hack around it with a test
4534 for PL_error_count == 0.) Solaris doesn't segfault --
4535 not sure where the trouble is yet. XXX */
4537 if (maxlen && IoFMT_GV(datasv)) {
4538 SV *const cache = (SV *)IoFMT_GV(datasv);
4541 const char *cache_p = SvPV(cache, cache_len);
4542 /* Running in block mode and we have some cached data already. */
4543 if (cache_len >= maxlen) {
4544 /* In fact, so much data we don't even need to call
4546 sv_catpvn(buf_sv, cache_p, maxlen);
4547 sv_chop(cache, cache_p + maxlen);
4548 /* Definately not EOF */
4551 sv_catsv(buf_sv, cache);
4552 maxlen -= cache_len;
4557 if (filter_has_file) {
4558 len = FILTER_READ(idx+1, upstream, maxlen);
4561 if (filter_sub && len >= 0) {
4572 PUSHs(sv_2mortal(newSViv(maxlen)));
4574 PUSHs(filter_state);
4577 count = call_sv(filter_sub, G_SCALAR);
4593 /* Running in block mode. */
4595 const char *got_p = SvPV(upstream, got_len);
4597 if (got_len > maxlen) {
4598 /* Oh. Too long. Stuff some in our cache. */
4599 SV *cache = (SV *)IoFMT_GV(datasv);
4602 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - maxlen));
4603 } else if (SvOK(cache)) {
4604 /* Cache should be empty. */
4605 assert(!SvCUR(cache));
4608 sv_setpvn(cache, got_p + maxlen, got_len - maxlen);
4609 /* If you ask for block mode, you may well split UTF-8 characters.
4610 "If it breaks, you get to keep both parts"
4611 (Your code is broken if you don't put them back together again
4612 before something notices.) */
4613 if (SvUTF8(upstream)) {
4616 SvCUR_set(upstream, maxlen);
4620 if (upstream != buf_sv) {
4621 sv_catsv(buf_sv, upstream);
4625 IoLINES(datasv) = 0;
4626 SvREFCNT_dec(IoFMT_GV(datasv));
4628 SvREFCNT_dec(filter_state);
4629 IoTOP_GV(datasv) = NULL;
4632 SvREFCNT_dec(filter_sub);
4633 IoBOTTOM_GV(datasv) = NULL;
4635 filter_del(S_run_user_filter);
4640 /* perhaps someone can come up with a better name for
4641 this? it is not really "absolute", per se ... */
4643 S_path_is_absolute(const char *name)
4645 if (PERL_FILE_IS_ABSOLUTE(name)
4646 #ifdef MACOS_TRADITIONAL
4649 || (*name == '.' && (name[1] == '/' ||
4650 (name[1] == '.' && name[2] == '/')))
4662 * c-indentation-style: bsd
4664 * indent-tabs-mode: t
4667 * ex: set ts=8 sts=4 sw=4 noet: