3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 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 * const 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);
128 regexp * const re = PM_GETRE(pm);
130 /* Check against the last compiled regexp. */
131 if (!re || !re->precomp || re->prelen != (I32)len ||
132 memNE(re->precomp, t, len))
134 const regexp_engine *eng = re ? re->engine : NULL;
138 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
139 } else if (PL_curcop->cop_hints_hash) {
140 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
142 if (ptr && SvIOK(ptr) && SvIV(ptr))
143 eng = INT2PTR(regexp_engine*,SvIV(ptr));
146 if (PL_op->op_flags & OPf_SPECIAL)
147 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
149 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
151 pm->op_pmdynflags |= PMdf_DYN_UTF8;
153 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
154 if (pm->op_pmdynflags & PMdf_UTF8)
155 t = (char*)bytes_to_utf8((U8*)t, &len);
158 PM_SETRE(pm, CALLREGCOMP_ENG(eng,(char *)t, (char *)t + len, pm));
160 PM_SETRE(pm, CALLREGCOMP((char *)t, (char *)t + len, pm));
162 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
164 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
165 inside tie/overload accessors. */
169 #ifndef INCOMPLETE_TAINTS
172 pm->op_pmdynflags |= PMdf_TAINTED;
174 pm->op_pmdynflags &= ~PMdf_TAINTED;
178 if (!PM_GETRE(pm)->prelen && PL_curpm)
180 else if (PM_GETRE(pm)->extflags & RXf_WHITE)
181 pm->op_pmflags |= PMf_WHITE;
183 pm->op_pmflags &= ~PMf_WHITE;
185 /* XXX runtime compiled output needs to move to the pad */
186 if (pm->op_pmflags & PMf_KEEP) {
187 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
188 #if !defined(USE_ITHREADS)
189 /* XXX can't change the optree at runtime either */
190 cLOGOP->op_first->op_next = PL_op->op_next;
200 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
201 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
202 register SV * const dstr = cx->sb_dstr;
203 register char *s = cx->sb_s;
204 register char *m = cx->sb_m;
205 char *orig = cx->sb_orig;
206 register REGEXP * const rx = cx->sb_rx;
208 REGEXP *old = PM_GETRE(pm);
212 PM_SETRE(pm,ReREFCNT_inc(rx));
215 rxres_restore(&cx->sb_rxres, rx);
216 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
218 if (cx->sb_iters++) {
219 const I32 saviters = cx->sb_iters;
220 if (cx->sb_iters > cx->sb_maxiters)
221 DIE(aTHX_ "Substitution loop");
223 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
224 cx->sb_rxtainted |= 2;
225 sv_catsv(dstr, POPs);
226 FREETMPS; /* Prevent excess tmp stack */
229 if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
230 s == m, cx->sb_targ, NULL,
231 ((cx->sb_rflags & REXEC_COPY_STR)
232 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
233 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
235 SV * const targ = cx->sb_targ;
237 assert(cx->sb_strend >= s);
238 if(cx->sb_strend > s) {
239 if (DO_UTF8(dstr) && !SvUTF8(targ))
240 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
242 sv_catpvn(dstr, s, cx->sb_strend - s);
244 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
246 #ifdef PERL_OLD_COPY_ON_WRITE
248 sv_force_normal_flags(targ, SV_COW_DROP_PV);
254 SvPV_set(targ, SvPVX(dstr));
255 SvCUR_set(targ, SvCUR(dstr));
256 SvLEN_set(targ, SvLEN(dstr));
259 SvPV_set(dstr, NULL);
261 TAINT_IF(cx->sb_rxtainted & 1);
262 PUSHs(sv_2mortal(newSViv(saviters - 1)));
264 (void)SvPOK_only_UTF8(targ);
265 TAINT_IF(cx->sb_rxtainted);
269 LEAVE_SCOPE(cx->sb_oldsave);
271 RETURNOP(pm->op_next);
273 cx->sb_iters = saviters;
275 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
278 cx->sb_orig = orig = rx->subbeg;
280 cx->sb_strend = s + (cx->sb_strend - m);
282 cx->sb_m = m = rx->startp[0] + orig;
284 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
285 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
287 sv_catpvn(dstr, s, m-s);
289 cx->sb_s = rx->endp[0] + orig;
290 { /* Update the pos() information. */
291 SV * const sv = cx->sb_targ;
294 SvUPGRADE(sv, SVt_PVMG);
295 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
296 #ifdef PERL_OLD_COPY_ON_WRITE
298 sv_force_normal_flags(sv, 0);
300 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
309 (void)ReREFCNT_inc(rx);
310 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
311 rxres_save(&cx->sb_rxres, rx);
312 RETURNOP(pm->op_pmreplstart);
316 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
322 if (!p || p[1] < rx->nparens) {
323 #ifdef PERL_OLD_COPY_ON_WRITE
324 i = 7 + rx->nparens * 2;
326 i = 6 + rx->nparens * 2;
335 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : NULL);
336 RX_MATCH_COPIED_off(rx);
338 #ifdef PERL_OLD_COPY_ON_WRITE
339 *p++ = PTR2UV(rx->saved_copy);
340 rx->saved_copy = NULL;
345 *p++ = PTR2UV(rx->subbeg);
346 *p++ = (UV)rx->sublen;
347 for (i = 0; i <= rx->nparens; ++i) {
348 *p++ = (UV)rx->startp[i];
349 *p++ = (UV)rx->endp[i];
354 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
360 RX_MATCH_COPY_FREE(rx);
361 RX_MATCH_COPIED_set(rx, *p);
364 #ifdef PERL_OLD_COPY_ON_WRITE
366 SvREFCNT_dec (rx->saved_copy);
367 rx->saved_copy = INT2PTR(SV*,*p);
373 rx->subbeg = INT2PTR(char*,*p++);
374 rx->sublen = (I32)(*p++);
375 for (i = 0; i <= rx->nparens; ++i) {
376 rx->startp[i] = (I32)(*p++);
377 rx->endp[i] = (I32)(*p++);
382 Perl_rxres_free(pTHX_ void **rsp)
384 UV * const p = (UV*)*rsp;
389 void *tmp = INT2PTR(char*,*p);
392 PoisonFree(*p, 1, sizeof(*p));
394 Safefree(INT2PTR(char*,*p));
396 #ifdef PERL_OLD_COPY_ON_WRITE
398 SvREFCNT_dec (INT2PTR(SV*,p[1]));
408 dVAR; dSP; dMARK; dORIGMARK;
409 register SV * const tmpForm = *++MARK;
414 register SV *sv = NULL;
415 const char *item = NULL;
419 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
420 const char *chophere = NULL;
421 char *linemark = NULL;
423 bool gotsome = FALSE;
425 const STRLEN fudge = SvPOK(tmpForm)
426 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
427 bool item_is_utf8 = FALSE;
428 bool targ_is_utf8 = FALSE;
430 OP * parseres = NULL;
434 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
435 if (SvREADONLY(tmpForm)) {
436 SvREADONLY_off(tmpForm);
437 parseres = doparseform(tmpForm);
438 SvREADONLY_on(tmpForm);
441 parseres = doparseform(tmpForm);
445 SvPV_force(PL_formtarget, len);
446 if (DO_UTF8(PL_formtarget))
448 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
450 f = SvPV_const(tmpForm, len);
451 /* need to jump to the next word */
452 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
456 const char *name = "???";
459 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
460 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
461 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
462 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
463 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
465 case FF_CHECKNL: name = "CHECKNL"; break;
466 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
467 case FF_SPACE: name = "SPACE"; break;
468 case FF_HALFSPACE: name = "HALFSPACE"; break;
469 case FF_ITEM: name = "ITEM"; break;
470 case FF_CHOP: name = "CHOP"; break;
471 case FF_LINEGLOB: name = "LINEGLOB"; break;
472 case FF_NEWLINE: name = "NEWLINE"; break;
473 case FF_MORE: name = "MORE"; break;
474 case FF_LINEMARK: name = "LINEMARK"; break;
475 case FF_END: name = "END"; break;
476 case FF_0DECIMAL: name = "0DECIMAL"; break;
477 case FF_LINESNGL: name = "LINESNGL"; break;
480 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
482 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
493 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
494 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
496 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
497 t = SvEND(PL_formtarget);
500 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
501 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
503 sv_utf8_upgrade(PL_formtarget);
504 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
505 t = SvEND(PL_formtarget);
525 if (ckWARN(WARN_SYNTAX))
526 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
533 const char *s = item = SvPV_const(sv, len);
536 itemsize = sv_len_utf8(sv);
537 if (itemsize != (I32)len) {
539 if (itemsize > fieldsize) {
540 itemsize = fieldsize;
541 itembytes = itemsize;
542 sv_pos_u2b(sv, &itembytes, 0);
546 send = chophere = s + itembytes;
556 sv_pos_b2u(sv, &itemsize);
560 item_is_utf8 = FALSE;
561 if (itemsize > fieldsize)
562 itemsize = fieldsize;
563 send = chophere = s + itemsize;
577 const char *s = item = SvPV_const(sv, len);
580 itemsize = sv_len_utf8(sv);
581 if (itemsize != (I32)len) {
583 if (itemsize <= fieldsize) {
584 const char *send = chophere = s + itemsize;
597 itemsize = fieldsize;
598 itembytes = itemsize;
599 sv_pos_u2b(sv, &itembytes, 0);
600 send = chophere = s + itembytes;
601 while (s < send || (s == send && isSPACE(*s))) {
611 if (strchr(PL_chopset, *s))
616 itemsize = chophere - item;
617 sv_pos_b2u(sv, &itemsize);
623 item_is_utf8 = FALSE;
624 if (itemsize <= fieldsize) {
625 const char *const send = chophere = s + itemsize;
638 itemsize = fieldsize;
639 send = chophere = s + itemsize;
640 while (s < send || (s == send && isSPACE(*s))) {
650 if (strchr(PL_chopset, *s))
655 itemsize = chophere - item;
661 arg = fieldsize - itemsize;
670 arg = fieldsize - itemsize;
681 const char *s = item;
685 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
687 sv_utf8_upgrade(PL_formtarget);
688 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
689 t = SvEND(PL_formtarget);
693 if (UTF8_IS_CONTINUED(*s)) {
694 STRLEN skip = UTF8SKIP(s);
711 if ( !((*t++ = *s++) & ~31) )
717 if (targ_is_utf8 && !item_is_utf8) {
718 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
720 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
721 for (; t < SvEND(PL_formtarget); t++) {
734 const int ch = *t++ = *s++;
737 if ( !((*t++ = *s++) & ~31) )
746 const char *s = chophere;
764 const char *s = item = SvPV_const(sv, len);
766 if ((item_is_utf8 = DO_UTF8(sv)))
767 itemsize = sv_len_utf8(sv);
769 bool chopped = FALSE;
770 const char *const send = s + len;
772 chophere = s + itemsize;
788 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
790 SvUTF8_on(PL_formtarget);
792 SvCUR_set(sv, chophere - item);
793 sv_catsv(PL_formtarget, sv);
794 SvCUR_set(sv, itemsize);
796 sv_catsv(PL_formtarget, sv);
798 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
799 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
800 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
809 #if defined(USE_LONG_DOUBLE)
812 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
816 "%#0*.*f" : "%0*.*f");
821 #if defined(USE_LONG_DOUBLE)
823 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
826 ((arg & 256) ? "%#*.*f" : "%*.*f");
829 /* If the field is marked with ^ and the value is undefined,
831 if ((arg & 512) && !SvOK(sv)) {
839 /* overflow evidence */
840 if (num_overflow(value, fieldsize, arg)) {
846 /* Formats aren't yet marked for locales, so assume "yes". */
848 STORE_NUMERIC_STANDARD_SET_LOCAL();
849 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
850 RESTORE_NUMERIC_STANDARD();
857 while (t-- > linemark && *t == ' ') ;
865 if (arg) { /* repeat until fields exhausted? */
867 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
868 lines += FmLINES(PL_formtarget);
871 if (strnEQ(linemark, linemark - arg, arg))
872 DIE(aTHX_ "Runaway format");
875 SvUTF8_on(PL_formtarget);
876 FmLINES(PL_formtarget) = lines;
878 RETURNOP(cLISTOP->op_first);
889 const char *s = chophere;
890 const char *send = item + len;
892 while (isSPACE(*s) && (s < send))
897 arg = fieldsize - itemsize;
904 if (strnEQ(s1," ",3)) {
905 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
916 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
918 SvUTF8_on(PL_formtarget);
919 FmLINES(PL_formtarget) += lines;
931 if (PL_stack_base + *PL_markstack_ptr == SP) {
933 if (GIMME_V == G_SCALAR)
934 XPUSHs(sv_2mortal(newSViv(0)));
935 RETURNOP(PL_op->op_next->op_next);
937 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
938 pp_pushmark(); /* push dst */
939 pp_pushmark(); /* push src */
940 ENTER; /* enter outer scope */
943 if (PL_op->op_private & OPpGREP_LEX)
944 SAVESPTR(PAD_SVl(PL_op->op_targ));
947 ENTER; /* enter inner scope */
950 src = PL_stack_base[*PL_markstack_ptr];
952 if (PL_op->op_private & OPpGREP_LEX)
953 PAD_SVl(PL_op->op_targ) = src;
958 if (PL_op->op_type == OP_MAPSTART)
959 pp_pushmark(); /* push top */
960 return ((LOGOP*)PL_op->op_next)->op_other;
966 const I32 gimme = GIMME_V;
967 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
973 /* first, move source pointer to the next item in the source list */
974 ++PL_markstack_ptr[-1];
976 /* if there are new items, push them into the destination list */
977 if (items && gimme != G_VOID) {
978 /* might need to make room back there first */
979 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
980 /* XXX this implementation is very pessimal because the stack
981 * is repeatedly extended for every set of items. Is possible
982 * to do this without any stack extension or copying at all
983 * by maintaining a separate list over which the map iterates
984 * (like foreach does). --gsar */
986 /* everything in the stack after the destination list moves
987 * towards the end the stack by the amount of room needed */
988 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
990 /* items to shift up (accounting for the moved source pointer) */
991 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
993 /* This optimization is by Ben Tilly and it does
994 * things differently from what Sarathy (gsar)
995 * is describing. The downside of this optimization is
996 * that leaves "holes" (uninitialized and hopefully unused areas)
997 * to the Perl stack, but on the other hand this
998 * shouldn't be a problem. If Sarathy's idea gets
999 * implemented, this optimization should become
1000 * irrelevant. --jhi */
1002 shift = count; /* Avoid shifting too often --Ben Tilly */
1006 dst = (SP += shift);
1007 PL_markstack_ptr[-1] += shift;
1008 *PL_markstack_ptr += shift;
1012 /* copy the new items down to the destination list */
1013 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1014 if (gimme == G_ARRAY) {
1016 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1019 /* scalar context: we don't care about which values map returns
1020 * (we use undef here). And so we certainly don't want to do mortal
1021 * copies of meaningless values. */
1022 while (items-- > 0) {
1024 *dst-- = &PL_sv_undef;
1028 LEAVE; /* exit inner scope */
1031 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1033 (void)POPMARK; /* pop top */
1034 LEAVE; /* exit outer scope */
1035 (void)POPMARK; /* pop src */
1036 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1037 (void)POPMARK; /* pop dst */
1038 SP = PL_stack_base + POPMARK; /* pop original mark */
1039 if (gimme == G_SCALAR) {
1040 if (PL_op->op_private & OPpGREP_LEX) {
1041 SV* sv = sv_newmortal();
1042 sv_setiv(sv, items);
1050 else if (gimme == G_ARRAY)
1057 ENTER; /* enter inner scope */
1060 /* set $_ to the new source item */
1061 src = PL_stack_base[PL_markstack_ptr[-1]];
1063 if (PL_op->op_private & OPpGREP_LEX)
1064 PAD_SVl(PL_op->op_targ) = src;
1068 RETURNOP(cLOGOP->op_other);
1077 if (GIMME == G_ARRAY)
1079 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1080 return cLOGOP->op_other;
1090 if (GIMME == G_ARRAY) {
1091 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1095 SV * const targ = PAD_SV(PL_op->op_targ);
1098 if (PL_op->op_private & OPpFLIP_LINENUM) {
1099 if (GvIO(PL_last_in_gv)) {
1100 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1103 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1105 flip = SvIV(sv) == SvIV(GvSV(gv));
1111 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1112 if (PL_op->op_flags & OPf_SPECIAL) {
1120 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1123 sv_setpvn(TARG, "", 0);
1129 /* This code tries to decide if "$left .. $right" should use the
1130 magical string increment, or if the range is numeric (we make
1131 an exception for .."0" [#18165]). AMS 20021031. */
1133 #define RANGE_IS_NUMERIC(left,right) ( \
1134 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1135 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1136 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1137 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1138 && (!SvOK(right) || looks_like_number(right))))
1144 if (GIMME == G_ARRAY) {
1150 if (RANGE_IS_NUMERIC(left,right)) {
1153 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1154 (SvOK(right) && SvNV(right) > IV_MAX))
1155 DIE(aTHX_ "Range iterator outside integer range");
1166 SV * const sv = sv_2mortal(newSViv(i++));
1171 SV * const final = sv_mortalcopy(right);
1173 const char * const tmps = SvPV_const(final, len);
1175 SV *sv = sv_mortalcopy(left);
1176 SvPV_force_nolen(sv);
1177 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1179 if (strEQ(SvPVX_const(sv),tmps))
1181 sv = sv_2mortal(newSVsv(sv));
1188 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1192 if (PL_op->op_private & OPpFLIP_LINENUM) {
1193 if (GvIO(PL_last_in_gv)) {
1194 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1197 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1198 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1206 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1207 sv_catpvs(targ, "E0");
1217 static const char * const context_name[] = {
1230 S_dopoptolabel(pTHX_ const char *label)
1235 for (i = cxstack_ix; i >= 0; i--) {
1236 register const PERL_CONTEXT * const cx = &cxstack[i];
1237 switch (CxTYPE(cx)) {
1245 if (ckWARN(WARN_EXITING))
1246 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1247 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1248 if (CxTYPE(cx) == CXt_NULL)
1252 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1253 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1254 (long)i, cx->blk_loop.label));
1257 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1267 Perl_dowantarray(pTHX)
1270 const I32 gimme = block_gimme();
1271 return (gimme == G_VOID) ? G_SCALAR : gimme;
1275 Perl_block_gimme(pTHX)
1278 const I32 cxix = dopoptosub(cxstack_ix);
1282 switch (cxstack[cxix].blk_gimme) {
1290 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1297 Perl_is_lvalue_sub(pTHX)
1300 const I32 cxix = dopoptosub(cxstack_ix);
1301 assert(cxix >= 0); /* We should only be called from inside subs */
1303 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1304 return cxstack[cxix].blk_sub.lval;
1310 S_dopoptosub(pTHX_ I32 startingblock)
1313 return dopoptosub_at(cxstack, startingblock);
1317 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1321 for (i = startingblock; i >= 0; i--) {
1322 register const PERL_CONTEXT * const cx = &cxstk[i];
1323 switch (CxTYPE(cx)) {
1329 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1337 S_dopoptoeval(pTHX_ I32 startingblock)
1341 for (i = startingblock; i >= 0; i--) {
1342 register const PERL_CONTEXT *cx = &cxstack[i];
1343 switch (CxTYPE(cx)) {
1347 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1355 S_dopoptoloop(pTHX_ I32 startingblock)
1359 for (i = startingblock; i >= 0; i--) {
1360 register const PERL_CONTEXT * const cx = &cxstack[i];
1361 switch (CxTYPE(cx)) {
1367 if (ckWARN(WARN_EXITING))
1368 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1369 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1370 if ((CxTYPE(cx)) == CXt_NULL)
1374 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1382 S_dopoptogiven(pTHX_ I32 startingblock)
1386 for (i = startingblock; i >= 0; i--) {
1387 register const PERL_CONTEXT *cx = &cxstack[i];
1388 switch (CxTYPE(cx)) {
1392 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1395 if (CxFOREACHDEF(cx)) {
1396 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1405 S_dopoptowhen(pTHX_ I32 startingblock)
1409 for (i = startingblock; i >= 0; i--) {
1410 register const PERL_CONTEXT *cx = &cxstack[i];
1411 switch (CxTYPE(cx)) {
1415 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1423 Perl_dounwind(pTHX_ I32 cxix)
1428 while (cxstack_ix > cxix) {
1430 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1431 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1432 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1433 /* Note: we don't need to restore the base context info till the end. */
1434 switch (CxTYPE(cx)) {
1437 continue; /* not break */
1456 PERL_UNUSED_VAR(optype);
1460 Perl_qerror(pTHX_ SV *err)
1464 sv_catsv(ERRSV, err);
1466 sv_catsv(PL_errors, err);
1468 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1473 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1482 if (PL_in_eval & EVAL_KEEPERR) {
1483 static const char prefix[] = "\t(in cleanup) ";
1484 SV * const err = ERRSV;
1485 const char *e = NULL;
1487 sv_setpvn(err,"",0);
1488 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1490 e = SvPV_const(err, len);
1492 if (*e != *message || strNE(e,message))
1496 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1497 sv_catpvn(err, prefix, sizeof(prefix)-1);
1498 sv_catpvn(err, message, msglen);
1499 if (ckWARN(WARN_MISC)) {
1500 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1501 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1506 sv_setpvn(ERRSV, message, msglen);
1510 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1511 && PL_curstackinfo->si_prev)
1519 register PERL_CONTEXT *cx;
1522 if (cxix < cxstack_ix)
1525 POPBLOCK(cx,PL_curpm);
1526 if (CxTYPE(cx) != CXt_EVAL) {
1528 message = SvPVx_const(ERRSV, msglen);
1529 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1530 PerlIO_write(Perl_error_log, message, msglen);
1535 if (gimme == G_SCALAR)
1536 *++newsp = &PL_sv_undef;
1537 PL_stack_sp = newsp;
1541 /* LEAVE could clobber PL_curcop (see save_re_context())
1542 * XXX it might be better to find a way to avoid messing with
1543 * PL_curcop in save_re_context() instead, but this is a more
1544 * minimal fix --GSAR */
1545 PL_curcop = cx->blk_oldcop;
1547 if (optype == OP_REQUIRE) {
1548 const char* const msg = SvPVx_nolen_const(ERRSV);
1549 SV * const nsv = cx->blk_eval.old_namesv;
1550 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1552 DIE(aTHX_ "%sCompilation failed in require",
1553 *msg ? msg : "Unknown error\n");
1555 assert(CxTYPE(cx) == CXt_EVAL);
1556 return cx->blk_eval.retop;
1560 message = SvPVx_const(ERRSV, msglen);
1562 write_to_stderr(message, msglen);
1570 dVAR; dSP; dPOPTOPssrl;
1571 if (SvTRUE(left) != SvTRUE(right))
1581 register I32 cxix = dopoptosub(cxstack_ix);
1582 register const PERL_CONTEXT *cx;
1583 register const PERL_CONTEXT *ccstack = cxstack;
1584 const PERL_SI *top_si = PL_curstackinfo;
1586 const char *stashname;
1593 /* we may be in a higher stacklevel, so dig down deeper */
1594 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1595 top_si = top_si->si_prev;
1596 ccstack = top_si->si_cxstack;
1597 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1600 if (GIMME != G_ARRAY) {
1606 /* caller() should not report the automatic calls to &DB::sub */
1607 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1608 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1612 cxix = dopoptosub_at(ccstack, cxix - 1);
1615 cx = &ccstack[cxix];
1616 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1617 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1618 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1619 field below is defined for any cx. */
1620 /* caller() should not report the automatic calls to &DB::sub */
1621 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1622 cx = &ccstack[dbcxix];
1625 stashname = CopSTASHPV(cx->blk_oldcop);
1626 if (GIMME != G_ARRAY) {
1629 PUSHs(&PL_sv_undef);
1632 sv_setpv(TARG, stashname);
1641 PUSHs(&PL_sv_undef);
1643 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1644 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1645 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1648 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1649 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1650 /* So is ccstack[dbcxix]. */
1652 SV * const sv = newSV(0);
1653 gv_efullname3(sv, cvgv, NULL);
1654 PUSHs(sv_2mortal(sv));
1655 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1658 PUSHs(sv_2mortal(newSVpvs("(unknown)")));
1659 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1663 PUSHs(sv_2mortal(newSVpvs("(eval)")));
1664 PUSHs(sv_2mortal(newSViv(0)));
1666 gimme = (I32)cx->blk_gimme;
1667 if (gimme == G_VOID)
1668 PUSHs(&PL_sv_undef);
1670 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1671 if (CxTYPE(cx) == CXt_EVAL) {
1673 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1674 PUSHs(cx->blk_eval.cur_text);
1678 else if (cx->blk_eval.old_namesv) {
1679 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1682 /* eval BLOCK (try blocks have old_namesv == 0) */
1684 PUSHs(&PL_sv_undef);
1685 PUSHs(&PL_sv_undef);
1689 PUSHs(&PL_sv_undef);
1690 PUSHs(&PL_sv_undef);
1692 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1693 && CopSTASH_eq(PL_curcop, PL_debstash))
1695 AV * const ary = cx->blk_sub.argarray;
1696 const int off = AvARRAY(ary) - AvALLOC(ary);
1699 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1700 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1702 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1705 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1706 av_extend(PL_dbargs, AvFILLp(ary) + off);
1707 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1708 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1710 /* XXX only hints propagated via op_private are currently
1711 * visible (others are not easily accessible, since they
1712 * use the global PL_hints) */
1713 PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
1716 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1718 if (old_warnings == pWARN_NONE ||
1719 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1720 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1721 else if (old_warnings == pWARN_ALL ||
1722 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1723 /* Get the bit mask for $warnings::Bits{all}, because
1724 * it could have been extended by warnings::register */
1726 HV * const bits = get_hv("warnings::Bits", FALSE);
1727 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1728 mask = newSVsv(*bits_all);
1731 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1735 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1736 PUSHs(sv_2mortal(mask));
1739 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1740 sv_2mortal(newRV_noinc(
1741 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1742 cx->blk_oldcop->cop_hints_hash)))
1751 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1752 sv_reset(tmps, CopSTASH(PL_curcop));
1757 /* like pp_nextstate, but used instead when the debugger is active */
1762 PL_curcop = (COP*)PL_op;
1763 TAINT_NOT; /* Each statement is presumed innocent */
1764 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1767 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1768 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1771 register PERL_CONTEXT *cx;
1772 const I32 gimme = G_ARRAY;
1774 GV * const gv = PL_DBgv;
1775 register CV * const cv = GvCV(gv);
1778 DIE(aTHX_ "No DB::DB routine defined");
1780 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1781 /* don't do recursive DB::DB call */
1796 (void)(*CvXSUB(cv))(aTHX_ cv);
1803 PUSHBLOCK(cx, CXt_SUB, SP);
1805 cx->blk_sub.retop = PL_op->op_next;
1808 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1809 RETURNOP(CvSTART(cv));
1819 register PERL_CONTEXT *cx;
1820 const I32 gimme = GIMME_V;
1822 U16 cxtype = CXt_LOOP | CXp_FOREACH;
1830 if (PL_op->op_targ) {
1831 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1832 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1833 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1834 SVs_PADSTALE, SVs_PADSTALE);
1836 #ifndef USE_ITHREADS
1837 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1840 SAVEPADSV(PL_op->op_targ);
1841 iterdata = INT2PTR(void*, PL_op->op_targ);
1842 cxtype |= CXp_PADVAR;
1846 GV * const gv = (GV*)POPs;
1847 svp = &GvSV(gv); /* symbol table variable */
1848 SAVEGENERICSV(*svp);
1851 iterdata = (void*)gv;
1855 if (PL_op->op_private & OPpITER_DEF)
1856 cxtype |= CXp_FOR_DEF;
1860 PUSHBLOCK(cx, cxtype, SP);
1862 PUSHLOOP(cx, iterdata, MARK);
1864 PUSHLOOP(cx, svp, MARK);
1866 if (PL_op->op_flags & OPf_STACKED) {
1867 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1868 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1870 SV * const right = (SV*)cx->blk_loop.iterary;
1873 if (RANGE_IS_NUMERIC(sv,right)) {
1874 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1875 (SvOK(right) && SvNV(right) >= IV_MAX))
1876 DIE(aTHX_ "Range iterator outside integer range");
1877 cx->blk_loop.iterix = SvIV(sv);
1878 cx->blk_loop.itermax = SvIV(right);
1880 /* for correct -Dstv display */
1881 cx->blk_oldsp = sp - PL_stack_base;
1885 cx->blk_loop.iterlval = newSVsv(sv);
1886 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1887 (void) SvPV_nolen_const(right);
1890 else if (PL_op->op_private & OPpITER_REVERSED) {
1891 cx->blk_loop.itermax = 0;
1892 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1897 cx->blk_loop.iterary = PL_curstack;
1898 AvFILLp(PL_curstack) = SP - PL_stack_base;
1899 if (PL_op->op_private & OPpITER_REVERSED) {
1900 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1901 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1904 cx->blk_loop.iterix = MARK - PL_stack_base;
1914 register PERL_CONTEXT *cx;
1915 const I32 gimme = GIMME_V;
1921 PUSHBLOCK(cx, CXt_LOOP, SP);
1922 PUSHLOOP(cx, 0, SP);
1930 register PERL_CONTEXT *cx;
1937 assert(CxTYPE(cx) == CXt_LOOP);
1939 newsp = PL_stack_base + cx->blk_loop.resetsp;
1942 if (gimme == G_VOID)
1944 else if (gimme == G_SCALAR) {
1946 *++newsp = sv_mortalcopy(*SP);
1948 *++newsp = &PL_sv_undef;
1952 *++newsp = sv_mortalcopy(*++mark);
1953 TAINT_NOT; /* Each item is independent */
1959 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1960 PL_curpm = newpm; /* ... and pop $1 et al */
1971 register PERL_CONTEXT *cx;
1972 bool popsub2 = FALSE;
1973 bool clear_errsv = FALSE;
1981 const I32 cxix = dopoptosub(cxstack_ix);
1984 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1985 * sort block, which is a CXt_NULL
1988 PL_stack_base[1] = *PL_stack_sp;
1989 PL_stack_sp = PL_stack_base + 1;
1993 DIE(aTHX_ "Can't return outside a subroutine");
1995 if (cxix < cxstack_ix)
1998 if (CxMULTICALL(&cxstack[cxix])) {
1999 gimme = cxstack[cxix].blk_gimme;
2000 if (gimme == G_VOID)
2001 PL_stack_sp = PL_stack_base;
2002 else if (gimme == G_SCALAR) {
2003 PL_stack_base[1] = *PL_stack_sp;
2004 PL_stack_sp = PL_stack_base + 1;
2010 switch (CxTYPE(cx)) {
2013 retop = cx->blk_sub.retop;
2014 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2017 if (!(PL_in_eval & EVAL_KEEPERR))
2020 retop = cx->blk_eval.retop;
2024 if (optype == OP_REQUIRE &&
2025 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2027 /* Unassume the success we assumed earlier. */
2028 SV * const nsv = cx->blk_eval.old_namesv;
2029 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2030 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2035 retop = cx->blk_sub.retop;
2038 DIE(aTHX_ "panic: return");
2042 if (gimme == G_SCALAR) {
2045 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2047 *++newsp = SvREFCNT_inc(*SP);
2052 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2054 *++newsp = sv_mortalcopy(sv);
2059 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2062 *++newsp = sv_mortalcopy(*SP);
2065 *++newsp = &PL_sv_undef;
2067 else if (gimme == G_ARRAY) {
2068 while (++MARK <= SP) {
2069 *++newsp = (popsub2 && SvTEMP(*MARK))
2070 ? *MARK : sv_mortalcopy(*MARK);
2071 TAINT_NOT; /* Each item is independent */
2074 PL_stack_sp = newsp;
2077 /* Stack values are safe: */
2080 POPSUB(cx,sv); /* release CV and @_ ... */
2084 PL_curpm = newpm; /* ... and pop $1 et al */
2088 sv_setpvn(ERRSV,"",0);
2096 register PERL_CONTEXT *cx;
2107 if (PL_op->op_flags & OPf_SPECIAL) {
2108 cxix = dopoptoloop(cxstack_ix);
2110 DIE(aTHX_ "Can't \"last\" outside a loop block");
2113 cxix = dopoptolabel(cPVOP->op_pv);
2115 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2117 if (cxix < cxstack_ix)
2121 cxstack_ix++; /* temporarily protect top context */
2123 switch (CxTYPE(cx)) {
2126 newsp = PL_stack_base + cx->blk_loop.resetsp;
2127 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2131 nextop = cx->blk_sub.retop;
2135 nextop = cx->blk_eval.retop;
2139 nextop = cx->blk_sub.retop;
2142 DIE(aTHX_ "panic: last");
2146 if (gimme == G_SCALAR) {
2148 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2149 ? *SP : sv_mortalcopy(*SP);
2151 *++newsp = &PL_sv_undef;
2153 else if (gimme == G_ARRAY) {
2154 while (++MARK <= SP) {
2155 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2156 ? *MARK : sv_mortalcopy(*MARK);
2157 TAINT_NOT; /* Each item is independent */
2165 /* Stack values are safe: */
2168 POPLOOP(cx); /* release loop vars ... */
2172 POPSUB(cx,sv); /* release CV and @_ ... */
2175 PL_curpm = newpm; /* ... and pop $1 et al */
2178 PERL_UNUSED_VAR(optype);
2179 PERL_UNUSED_VAR(gimme);
2187 register PERL_CONTEXT *cx;
2190 if (PL_op->op_flags & OPf_SPECIAL) {
2191 cxix = dopoptoloop(cxstack_ix);
2193 DIE(aTHX_ "Can't \"next\" outside a loop block");
2196 cxix = dopoptolabel(cPVOP->op_pv);
2198 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2200 if (cxix < cxstack_ix)
2203 /* clear off anything above the scope we're re-entering, but
2204 * save the rest until after a possible continue block */
2205 inner = PL_scopestack_ix;
2207 if (PL_scopestack_ix < inner)
2208 leave_scope(PL_scopestack[PL_scopestack_ix]);
2209 PL_curcop = cx->blk_oldcop;
2210 return CX_LOOP_NEXTOP_GET(cx);
2217 register PERL_CONTEXT *cx;
2221 if (PL_op->op_flags & OPf_SPECIAL) {
2222 cxix = dopoptoloop(cxstack_ix);
2224 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2227 cxix = dopoptolabel(cPVOP->op_pv);
2229 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2231 if (cxix < cxstack_ix)
2234 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2235 if (redo_op->op_type == OP_ENTER) {
2236 /* pop one less context to avoid $x being freed in while (my $x..) */
2238 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2239 redo_op = redo_op->op_next;
2243 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2244 LEAVE_SCOPE(oldsave);
2246 PL_curcop = cx->blk_oldcop;
2251 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2255 static const char too_deep[] = "Target of goto is too deeply nested";
2258 Perl_croak(aTHX_ too_deep);
2259 if (o->op_type == OP_LEAVE ||
2260 o->op_type == OP_SCOPE ||
2261 o->op_type == OP_LEAVELOOP ||
2262 o->op_type == OP_LEAVESUB ||
2263 o->op_type == OP_LEAVETRY)
2265 *ops++ = cUNOPo->op_first;
2267 Perl_croak(aTHX_ too_deep);
2270 if (o->op_flags & OPf_KIDS) {
2272 /* First try all the kids at this level, since that's likeliest. */
2273 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2274 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2275 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2278 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2279 if (kid == PL_lastgotoprobe)
2281 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2284 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2285 ops[-1]->op_type == OP_DBSTATE)
2290 if ((o = dofindlabel(kid, label, ops, oplimit)))
2303 register PERL_CONTEXT *cx;
2304 #define GOTO_DEPTH 64
2305 OP *enterops[GOTO_DEPTH];
2306 const char *label = NULL;
2307 const bool do_dump = (PL_op->op_type == OP_DUMP);
2308 static const char must_have_label[] = "goto must have label";
2310 if (PL_op->op_flags & OPf_STACKED) {
2311 SV * const sv = POPs;
2313 /* This egregious kludge implements goto &subroutine */
2314 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2316 register PERL_CONTEXT *cx;
2317 CV* cv = (CV*)SvRV(sv);
2324 if (!CvROOT(cv) && !CvXSUB(cv)) {
2325 const GV * const gv = CvGV(cv);
2329 /* autoloaded stub? */
2330 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2332 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2333 GvNAMELEN(gv), FALSE);
2334 if (autogv && (cv = GvCV(autogv)))
2336 tmpstr = sv_newmortal();
2337 gv_efullname3(tmpstr, gv, NULL);
2338 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2340 DIE(aTHX_ "Goto undefined subroutine");
2343 /* First do some returnish stuff. */
2344 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2346 cxix = dopoptosub(cxstack_ix);
2348 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2349 if (cxix < cxstack_ix)
2353 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2354 if (CxTYPE(cx) == CXt_EVAL) {
2356 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2358 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2360 else if (CxMULTICALL(cx))
2361 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2362 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2363 /* put @_ back onto stack */
2364 AV* av = cx->blk_sub.argarray;
2366 items = AvFILLp(av) + 1;
2367 EXTEND(SP, items+1); /* @_ could have been extended. */
2368 Copy(AvARRAY(av), SP + 1, items, SV*);
2369 SvREFCNT_dec(GvAV(PL_defgv));
2370 GvAV(PL_defgv) = cx->blk_sub.savearray;
2372 /* abandon @_ if it got reified */
2377 av_extend(av, items-1);
2379 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2382 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2383 AV* const av = GvAV(PL_defgv);
2384 items = AvFILLp(av) + 1;
2385 EXTEND(SP, items+1); /* @_ could have been extended. */
2386 Copy(AvARRAY(av), SP + 1, items, SV*);
2390 if (CxTYPE(cx) == CXt_SUB &&
2391 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2392 SvREFCNT_dec(cx->blk_sub.cv);
2393 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2394 LEAVE_SCOPE(oldsave);
2396 /* Now do some callish stuff. */
2398 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2400 OP* const retop = cx->blk_sub.retop;
2405 for (index=0; index<items; index++)
2406 sv_2mortal(SP[-index]);
2409 /* XS subs don't have a CxSUB, so pop it */
2410 POPBLOCK(cx, PL_curpm);
2411 /* Push a mark for the start of arglist */
2414 (void)(*CvXSUB(cv))(aTHX_ cv);
2419 AV* const padlist = CvPADLIST(cv);
2420 if (CxTYPE(cx) == CXt_EVAL) {
2421 PL_in_eval = cx->blk_eval.old_in_eval;
2422 PL_eval_root = cx->blk_eval.old_eval_root;
2423 cx->cx_type = CXt_SUB;
2424 cx->blk_sub.hasargs = 0;
2426 cx->blk_sub.cv = cv;
2427 cx->blk_sub.olddepth = CvDEPTH(cv);
2430 if (CvDEPTH(cv) < 2)
2431 SvREFCNT_inc_simple_void_NN(cv);
2433 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2434 sub_crush_depth(cv);
2435 pad_push(padlist, CvDEPTH(cv));
2438 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2439 if (cx->blk_sub.hasargs)
2441 AV* const av = (AV*)PAD_SVl(0);
2443 cx->blk_sub.savearray = GvAV(PL_defgv);
2444 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2445 CX_CURPAD_SAVE(cx->blk_sub);
2446 cx->blk_sub.argarray = av;
2448 if (items >= AvMAX(av) + 1) {
2449 SV **ary = AvALLOC(av);
2450 if (AvARRAY(av) != ary) {
2451 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2454 if (items >= AvMAX(av) + 1) {
2455 AvMAX(av) = items - 1;
2456 Renew(ary,items+1,SV*);
2462 Copy(mark,AvARRAY(av),items,SV*);
2463 AvFILLp(av) = items - 1;
2464 assert(!AvREAL(av));
2466 /* transfer 'ownership' of refcnts to new @_ */
2476 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2477 Perl_get_db_sub(aTHX_ NULL, cv);
2479 CV * const gotocv = get_cv("DB::goto", FALSE);
2481 PUSHMARK( PL_stack_sp );
2482 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2487 RETURNOP(CvSTART(cv));
2491 label = SvPV_nolen_const(sv);
2492 if (!(do_dump || *label))
2493 DIE(aTHX_ must_have_label);
2496 else if (PL_op->op_flags & OPf_SPECIAL) {
2498 DIE(aTHX_ must_have_label);
2501 label = cPVOP->op_pv;
2503 if (label && *label) {
2504 OP *gotoprobe = NULL;
2505 bool leaving_eval = FALSE;
2506 bool in_block = FALSE;
2507 PERL_CONTEXT *last_eval_cx = NULL;
2511 PL_lastgotoprobe = NULL;
2513 for (ix = cxstack_ix; ix >= 0; ix--) {
2515 switch (CxTYPE(cx)) {
2517 leaving_eval = TRUE;
2518 if (!CxTRYBLOCK(cx)) {
2519 gotoprobe = (last_eval_cx ?
2520 last_eval_cx->blk_eval.old_eval_root :
2525 /* else fall through */
2527 gotoprobe = cx->blk_oldcop->op_sibling;
2533 gotoprobe = cx->blk_oldcop->op_sibling;
2536 gotoprobe = PL_main_root;
2539 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2540 gotoprobe = CvROOT(cx->blk_sub.cv);
2546 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2549 DIE(aTHX_ "panic: goto");
2550 gotoprobe = PL_main_root;
2554 retop = dofindlabel(gotoprobe, label,
2555 enterops, enterops + GOTO_DEPTH);
2559 PL_lastgotoprobe = gotoprobe;
2562 DIE(aTHX_ "Can't find label %s", label);
2564 /* if we're leaving an eval, check before we pop any frames
2565 that we're not going to punt, otherwise the error
2568 if (leaving_eval && *enterops && enterops[1]) {
2570 for (i = 1; enterops[i]; i++)
2571 if (enterops[i]->op_type == OP_ENTERITER)
2572 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2575 /* pop unwanted frames */
2577 if (ix < cxstack_ix) {
2584 oldsave = PL_scopestack[PL_scopestack_ix];
2585 LEAVE_SCOPE(oldsave);
2588 /* push wanted frames */
2590 if (*enterops && enterops[1]) {
2591 OP * const oldop = PL_op;
2592 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2593 for (; enterops[ix]; ix++) {
2594 PL_op = enterops[ix];
2595 /* Eventually we may want to stack the needed arguments
2596 * for each op. For now, we punt on the hard ones. */
2597 if (PL_op->op_type == OP_ENTERITER)
2598 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2599 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2607 if (!retop) retop = PL_main_start;
2609 PL_restartop = retop;
2610 PL_do_undump = TRUE;
2614 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2615 PL_do_undump = FALSE;
2632 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2634 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2637 PL_exit_flags |= PERL_EXIT_EXPECTED;
2639 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2640 if (anum || !(PL_minus_c && PL_madskills))
2645 PUSHs(&PL_sv_undef);
2652 S_save_lines(pTHX_ AV *array, SV *sv)
2654 const char *s = SvPVX_const(sv);
2655 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2658 while (s && s < send) {
2660 SV * const tmpstr = newSV_type(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_snprintf(tmpbuf, sizeof(tbuf), "_<(%.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.
2876 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2879 OP * const saveop = PL_op;
2881 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2882 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2887 SAVESPTR(PL_compcv);
2888 PL_compcv = (CV*)newSV_type(SVt_PVCV);
2889 CvEVAL_on(PL_compcv);
2890 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2891 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2893 CvOUTSIDE_SEQ(PL_compcv) = seq;
2894 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2896 /* set up a scratch pad */
2898 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2899 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2903 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2905 /* make sure we compile in the right package */
2907 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2908 SAVESPTR(PL_curstash);
2909 PL_curstash = CopSTASH(PL_curcop);
2911 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2912 SAVESPTR(PL_beginav);
2913 PL_beginav = newAV();
2914 SAVEFREESV(PL_beginav);
2915 SAVESPTR(PL_unitcheckav);
2916 PL_unitcheckav = newAV();
2917 SAVEFREESV(PL_unitcheckav);
2918 SAVEI32(PL_error_count);
2921 SAVEI32(PL_madskills);
2925 /* try to compile it */
2927 PL_eval_root = NULL;
2929 PL_curcop = &PL_compiling;
2930 CopARYBASE_set(PL_curcop, 0);
2931 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2932 PL_in_eval |= EVAL_KEEPERR;
2934 sv_setpvn(ERRSV,"",0);
2935 if (yyparse() || PL_error_count || !PL_eval_root) {
2936 SV **newsp; /* Used by POPBLOCK. */
2937 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2938 I32 optype = 0; /* Might be reset by POPEVAL. */
2943 op_free(PL_eval_root);
2944 PL_eval_root = NULL;
2946 SP = PL_stack_base + POPMARK; /* pop original mark */
2948 POPBLOCK(cx,PL_curpm);
2954 msg = SvPVx_nolen_const(ERRSV);
2955 if (optype == OP_REQUIRE) {
2956 const SV * const nsv = cx->blk_eval.old_namesv;
2957 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2959 DIE(aTHX_ "%sCompilation failed in require",
2960 *msg ? msg : "Unknown error\n");
2963 POPBLOCK(cx,PL_curpm);
2965 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2966 (*msg ? msg : "Unknown error\n"));
2970 sv_setpvs(ERRSV, "Compilation error");
2973 PERL_UNUSED_VAR(newsp);
2976 CopLINE_set(&PL_compiling, 0);
2978 *startop = PL_eval_root;
2980 SAVEFREEOP(PL_eval_root);
2982 /* Set the context for this new optree.
2983 * If the last op is an OP_REQUIRE, force scalar context.
2984 * Otherwise, propagate the context from the eval(). */
2985 if (PL_eval_root->op_type == OP_LEAVEEVAL
2986 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2987 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2989 scalar(PL_eval_root);
2990 else if (gimme & G_VOID)
2991 scalarvoid(PL_eval_root);
2992 else if (gimme & G_ARRAY)
2995 scalar(PL_eval_root);
2997 DEBUG_x(dump_eval());
2999 /* Register with debugger: */
3000 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3001 CV * const cv = get_cv("DB::postponed", FALSE);
3005 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3007 call_sv((SV*)cv, G_DISCARD);
3012 call_list(PL_scopestack_ix, PL_unitcheckav);
3014 /* compiled okay, so do it */
3016 CvDEPTH(PL_compcv) = 1;
3017 SP = PL_stack_base + POPMARK; /* pop original mark */
3018 PL_op = saveop; /* The caller may need it. */
3019 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3021 RETURNOP(PL_eval_start);
3025 S_check_type_and_open(pTHX_ const char *name, const char *mode)
3028 const int st_rc = PerlLIO_stat(name, &st);
3030 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3034 return PerlIO_open(name, mode);
3038 S_doopen_pm(pTHX_ const char *name, const char *mode)
3040 #ifndef PERL_DISABLE_PMC
3041 const STRLEN namelen = strlen(name);
3044 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3045 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3046 const char * const pmc = SvPV_nolen_const(pmcsv);
3048 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3049 fp = check_type_and_open(name, mode);
3052 fp = check_type_and_open(pmc, mode);
3054 SvREFCNT_dec(pmcsv);
3057 fp = check_type_and_open(name, mode);
3061 return check_type_and_open(name, mode);
3062 #endif /* !PERL_DISABLE_PMC */
3068 register PERL_CONTEXT *cx;
3072 const char *tryname = NULL;
3074 const I32 gimme = GIMME_V;
3075 int filter_has_file = 0;
3076 PerlIO *tryrsfp = NULL;
3077 SV *filter_cache = NULL;
3078 SV *filter_state = NULL;
3079 SV *filter_sub = NULL;
3085 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3086 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3087 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3088 "v-string in use/require non-portable");
3090 sv = new_version(sv);
3091 if (!sv_derived_from(PL_patchlevel, "version"))
3092 upg_version(PL_patchlevel, TRUE);
3093 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3094 if ( vcmp(sv,PL_patchlevel) <= 0 )
3095 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3096 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3099 if ( vcmp(sv,PL_patchlevel) > 0 )
3100 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3101 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3104 /* If we request a version >= 5.9.5, load feature.pm with the
3105 * feature bundle that corresponds to the required version.
3106 * We do this only with use, not require. */
3107 if (PL_compcv && vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3108 SV *const importsv = vnormal(sv);
3109 *SvPVX_mutable(importsv) = ':';
3111 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3117 name = SvPV_const(sv, len);
3118 if (!(name && len > 0 && *name))
3119 DIE(aTHX_ "Null filename used");
3120 TAINT_PROPER("require");
3121 if (PL_op->op_type == OP_REQUIRE) {
3122 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3124 if (*svp != &PL_sv_undef)
3127 DIE(aTHX_ "Compilation failed in require");
3131 /* prepare to compile file */
3133 if (path_is_absolute(name)) {
3135 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3137 #ifdef MACOS_TRADITIONAL
3141 MacPerl_CanonDir(name, newname, 1);
3142 if (path_is_absolute(newname)) {
3144 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3149 AV * const ar = GvAVn(PL_incgv);
3153 if ((unixname = tounixspec(name, NULL)) != NULL)
3157 for (i = 0; i <= AvFILL(ar); i++) {
3158 SV * const dirsv = *av_fetch(ar, i, TRUE);
3160 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3167 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3168 && !sv_isobject(loader))
3170 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3173 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3174 PTR2UV(SvRV(dirsv)), name);
3175 tryname = SvPVX_const(namesv);
3186 if (sv_isobject(loader))
3187 count = call_method("INC", G_ARRAY);
3189 count = call_sv(loader, G_ARRAY);
3192 /* Adjust file name if the hook has set an %INC entry */
3193 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3195 tryname = SvPVX_const(*svp);
3204 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3205 && !isGV_with_GP(SvRV(arg))) {
3206 filter_cache = SvRV(arg);
3207 SvREFCNT_inc_simple_void_NN(filter_cache);
3214 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3218 if (SvTYPE(arg) == SVt_PVGV) {
3219 IO * const io = GvIO((GV *)arg);
3224 tryrsfp = IoIFP(io);
3225 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3226 PerlIO_close(IoOFP(io));
3237 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3239 SvREFCNT_inc_simple_void_NN(filter_sub);
3242 filter_state = SP[i];
3243 SvREFCNT_inc_simple_void(filter_state);
3247 if (!tryrsfp && (filter_cache || filter_sub)) {
3248 tryrsfp = PerlIO_open(BIT_BUCKET,
3263 filter_has_file = 0;
3265 SvREFCNT_dec(filter_cache);
3266 filter_cache = NULL;
3269 SvREFCNT_dec(filter_state);
3270 filter_state = NULL;
3273 SvREFCNT_dec(filter_sub);
3278 if (!path_is_absolute(name)
3279 #ifdef MACOS_TRADITIONAL
3280 /* We consider paths of the form :a:b ambiguous and interpret them first
3281 as global then as local
3283 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3286 const char *dir = SvPVx_nolen_const(dirsv);
3287 #ifdef MACOS_TRADITIONAL
3291 MacPerl_CanonDir(name, buf2, 1);
3292 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3296 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3298 sv_setpv(namesv, unixdir);
3299 sv_catpv(namesv, unixname);
3301 # ifdef __SYMBIAN32__
3302 if (PL_origfilename[0] &&
3303 PL_origfilename[1] == ':' &&
3304 !(dir[0] && dir[1] == ':'))
3305 Perl_sv_setpvf(aTHX_ namesv,
3310 Perl_sv_setpvf(aTHX_ namesv,
3314 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3318 TAINT_PROPER("require");
3319 tryname = SvPVX_const(namesv);
3320 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3322 if (tryname[0] == '.' && tryname[1] == '/')
3326 else if (errno == EMFILE)
3327 /* no point in trying other paths if out of handles */
3334 SAVECOPFILE_FREE(&PL_compiling);
3335 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3336 SvREFCNT_dec(namesv);
3338 if (PL_op->op_type == OP_REQUIRE) {
3339 const char *msgstr = name;
3340 if(errno == EMFILE) {
3342 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3344 msgstr = SvPV_nolen_const(msg);
3346 if (namesv) { /* did we lookup @INC? */
3347 AV * const ar = GvAVn(PL_incgv);
3349 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3350 "%s in @INC%s%s (@INC contains:",
3352 (instr(msgstr, ".h ")
3353 ? " (change .h to .ph maybe?)" : ""),
3354 (instr(msgstr, ".ph ")
3355 ? " (did you run h2ph?)" : "")
3358 for (i = 0; i <= AvFILL(ar); i++) {
3359 sv_catpvs(msg, " ");
3360 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3362 sv_catpvs(msg, ")");
3363 msgstr = SvPV_nolen_const(msg);
3366 DIE(aTHX_ "Can't locate %s", msgstr);
3372 SETERRNO(0, SS_NORMAL);
3374 /* Assume success here to prevent recursive requirement. */
3375 /* name is never assigned to again, so len is still strlen(name) */
3376 /* Check whether a hook in @INC has already filled %INC */
3378 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3380 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3382 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc_simple(hook_sv), 0 );
3388 SAVEGENERICSV(PL_rsfp_filters);
3389 PL_rsfp_filters = NULL;
3394 SAVECOMPILEWARNINGS();
3395 if (PL_dowarn & G_WARN_ALL_ON)
3396 PL_compiling.cop_warnings = pWARN_ALL ;
3397 else if (PL_dowarn & G_WARN_ALL_OFF)
3398 PL_compiling.cop_warnings = pWARN_NONE ;
3400 PL_compiling.cop_warnings = pWARN_STD ;
3402 if (filter_sub || filter_cache) {
3403 SV * const datasv = filter_add(S_run_user_filter, NULL);
3404 IoLINES(datasv) = filter_has_file;
3405 IoTOP_GV(datasv) = (GV *)filter_state;
3406 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3407 IoFMT_GV(datasv) = (GV *)filter_cache;
3410 /* switch to eval mode */
3411 PUSHBLOCK(cx, CXt_EVAL, SP);
3412 PUSHEVAL(cx, name, NULL);
3413 cx->blk_eval.retop = PL_op->op_next;
3415 SAVECOPLINE(&PL_compiling);
3416 CopLINE_set(&PL_compiling, 0);
3420 /* Store and reset encoding. */
3421 encoding = PL_encoding;
3424 op = DOCATCH(doeval(gimme, NULL, NULL, PL_curcop->cop_seq));
3426 /* Restore encoding. */
3427 PL_encoding = encoding;
3435 register PERL_CONTEXT *cx;
3437 const I32 gimme = GIMME_V;
3438 const I32 was = PL_sub_generation;
3439 char tbuf[TYPE_DIGITS(long) + 12];
3440 char *tmpbuf = tbuf;
3446 HV *saved_hh = NULL;
3447 const char * const fakestr = "_<(eval )";
3448 const int fakelen = 9 + 1;
3450 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3451 saved_hh = (HV*) SvREFCNT_inc(POPs);
3455 TAINT_IF(SvTAINTED(sv));
3456 TAINT_PROPER("eval");
3462 /* switch to eval mode */
3464 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3465 SV * const temp_sv = sv_newmortal();
3466 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3467 (unsigned long)++PL_evalseq,
3468 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3469 tmpbuf = SvPVX(temp_sv);
3470 len = SvCUR(temp_sv);
3473 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3474 SAVECOPFILE_FREE(&PL_compiling);
3475 CopFILE_set(&PL_compiling, tmpbuf+2);
3476 SAVECOPLINE(&PL_compiling);
3477 CopLINE_set(&PL_compiling, 1);
3478 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3479 deleting the eval's FILEGV from the stash before gv_check() runs
3480 (i.e. before run-time proper). To work around the coredump that
3481 ensues, we always turn GvMULTI_on for any globals that were
3482 introduced within evals. See force_ident(). GSAR 96-10-12 */
3483 safestr = savepvn(tmpbuf, len);
3484 SAVEDELETE(PL_defstash, safestr, len);
3486 PL_hints = PL_op->op_targ;
3488 GvHV(PL_hintgv) = saved_hh;
3489 SAVECOMPILEWARNINGS();
3490 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3491 if (PL_compiling.cop_hints_hash) {
3492 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3494 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3495 if (PL_compiling.cop_hints_hash) {
3497 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3498 HINTS_REFCNT_UNLOCK;
3500 /* special case: an eval '' executed within the DB package gets lexically
3501 * placed in the first non-DB CV rather than the current CV - this
3502 * allows the debugger to execute code, find lexicals etc, in the
3503 * scope of the code being debugged. Passing &seq gets find_runcv
3504 * to do the dirty work for us */
3505 runcv = find_runcv(&seq);
3507 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3508 PUSHEVAL(cx, 0, NULL);
3509 cx->blk_eval.retop = PL_op->op_next;
3511 /* prepare to compile string */
3513 if (PERLDB_LINE && PL_curstash != PL_debstash)
3514 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3516 ret = doeval(gimme, NULL, runcv, seq);
3517 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3518 && ret != PL_op->op_next) { /* Successive compilation. */
3519 /* Copy in anything fake and short. */
3520 my_strlcpy(safestr, fakestr, fakelen);
3522 return DOCATCH(ret);
3532 register PERL_CONTEXT *cx;
3534 const U8 save_flags = PL_op -> op_flags;
3539 retop = cx->blk_eval.retop;
3542 if (gimme == G_VOID)
3544 else if (gimme == G_SCALAR) {
3547 if (SvFLAGS(TOPs) & SVs_TEMP)
3550 *MARK = sv_mortalcopy(TOPs);
3554 *MARK = &PL_sv_undef;
3559 /* in case LEAVE wipes old return values */
3560 for (mark = newsp + 1; mark <= SP; mark++) {
3561 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3562 *mark = sv_mortalcopy(*mark);
3563 TAINT_NOT; /* Each item is independent */
3567 PL_curpm = newpm; /* Don't pop $1 et al till now */
3570 assert(CvDEPTH(PL_compcv) == 1);
3572 CvDEPTH(PL_compcv) = 0;
3575 if (optype == OP_REQUIRE &&
3576 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3578 /* Unassume the success we assumed earlier. */
3579 SV * const nsv = cx->blk_eval.old_namesv;
3580 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3581 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3582 /* die_where() did LEAVE, or we won't be here */
3586 if (!(save_flags & OPf_SPECIAL))
3587 sv_setpvn(ERRSV,"",0);
3593 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3594 close to the related Perl_create_eval_scope. */
3596 Perl_delete_eval_scope(pTHX)
3601 register PERL_CONTEXT *cx;
3608 PERL_UNUSED_VAR(newsp);
3609 PERL_UNUSED_VAR(gimme);
3610 PERL_UNUSED_VAR(optype);
3613 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3614 also needed by Perl_fold_constants. */
3616 Perl_create_eval_scope(pTHX_ U32 flags)
3619 const I32 gimme = GIMME_V;
3624 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3627 PL_in_eval = EVAL_INEVAL;
3628 if (flags & G_KEEPERR)
3629 PL_in_eval |= EVAL_KEEPERR;
3631 sv_setpvn(ERRSV,"",0);
3632 if (flags & G_FAKINGEVAL) {
3633 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3641 PERL_CONTEXT * const cx = create_eval_scope(0);
3642 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3643 return DOCATCH(PL_op->op_next);
3652 register PERL_CONTEXT *cx;
3657 PERL_UNUSED_VAR(optype);
3660 if (gimme == G_VOID)
3662 else if (gimme == G_SCALAR) {
3666 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3669 *MARK = sv_mortalcopy(TOPs);
3673 *MARK = &PL_sv_undef;
3678 /* in case LEAVE wipes old return values */
3680 for (mark = newsp + 1; mark <= SP; mark++) {
3681 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3682 *mark = sv_mortalcopy(*mark);
3683 TAINT_NOT; /* Each item is independent */
3687 PL_curpm = newpm; /* Don't pop $1 et al till now */
3690 sv_setpvn(ERRSV,"",0);
3697 register PERL_CONTEXT *cx;
3698 const I32 gimme = GIMME_V;
3703 if (PL_op->op_targ == 0) {
3704 SV ** const defsv_p = &GvSV(PL_defgv);
3705 *defsv_p = newSVsv(POPs);
3706 SAVECLEARSV(*defsv_p);
3709 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3711 PUSHBLOCK(cx, CXt_GIVEN, SP);
3720 register PERL_CONTEXT *cx;
3724 PERL_UNUSED_CONTEXT;
3727 assert(CxTYPE(cx) == CXt_GIVEN);
3732 PL_curpm = newpm; /* pop $1 et al */
3739 /* Helper routines used by pp_smartmatch */
3742 S_make_matcher(pTHX_ regexp *re)
3745 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3746 PM_SETRE(matcher, ReREFCNT_inc(re));
3748 SAVEFREEOP((OP *) matcher);
3756 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3761 PL_op = (OP *) matcher;
3766 return (SvTRUEx(POPs));
3771 S_destroy_matcher(pTHX_ PMOP *matcher)
3774 PERL_UNUSED_ARG(matcher);
3779 /* Do a smart match */
3782 return do_smartmatch(NULL, NULL);
3785 /* This version of do_smartmatch() implements the
3786 * table of smart matches that is found in perlsyn.
3790 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3795 SV *e = TOPs; /* e is for 'expression' */
3796 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3797 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
3799 regexp *this_regex, *other_regex;
3801 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3803 # define SM_REF(type) ( \
3804 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3805 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3807 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3808 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
3809 && NOT_EMPTY_PROTO(This) && (Other = e)) \
3810 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
3811 && NOT_EMPTY_PROTO(This) && (Other = d)))
3813 # define SM_REGEX ( \
3814 (SvROK(d) && SvMAGICAL(This = SvRV(d)) \
3815 && (mg = mg_find(This, PERL_MAGIC_qr)) \
3816 && (this_regex = (regexp *)mg->mg_obj) \
3819 (SvROK(e) && SvMAGICAL(This = SvRV(e)) \
3820 && (mg = mg_find(This, PERL_MAGIC_qr)) \
3821 && (this_regex = (regexp *)mg->mg_obj) \
3825 # define SM_OTHER_REF(type) \
3826 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3828 # define SM_OTHER_REGEX (SvROK(Other) && SvMAGICAL(SvRV(Other)) \
3829 && (mg = mg_find(SvRV(Other), PERL_MAGIC_qr)) \
3830 && (other_regex = (regexp *)mg->mg_obj))
3833 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3834 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3836 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3837 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3839 tryAMAGICbinSET(smart, 0);
3841 SP -= 2; /* Pop the values */
3843 /* Take care only to invoke mg_get() once for each argument.
3844 * Currently we do this by copying the SV if it's magical. */
3847 d = sv_mortalcopy(d);
3854 e = sv_mortalcopy(e);
3859 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3861 if (This == SvRV(Other))
3872 c = call_sv(This, G_SCALAR);
3876 else if (SvTEMP(TOPs))
3877 SvREFCNT_inc_void(TOPs);
3882 else if (SM_REF(PVHV)) {
3883 if (SM_OTHER_REF(PVHV)) {
3884 /* Check that the key-sets are identical */
3886 HV *other_hv = (HV *) SvRV(Other);
3888 bool other_tied = FALSE;
3889 U32 this_key_count = 0,
3890 other_key_count = 0;
3892 /* Tied hashes don't know how many keys they have. */
3893 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
3896 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3897 HV * const temp = other_hv;
3898 other_hv = (HV *) This;
3902 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3905 if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
3908 /* The hashes have the same number of keys, so it suffices
3909 to check that one is a subset of the other. */
3910 (void) hv_iterinit((HV *) This);
3911 while ( (he = hv_iternext((HV *) This)) ) {
3913 char * const key = hv_iterkey(he, &key_len);
3917 if(!hv_exists(other_hv, key, key_len)) {
3918 (void) hv_iterinit((HV *) This); /* reset iterator */
3924 (void) hv_iterinit(other_hv);
3925 while ( hv_iternext(other_hv) )
3929 other_key_count = HvUSEDKEYS(other_hv);
3931 if (this_key_count != other_key_count)
3936 else if (SM_OTHER_REF(PVAV)) {
3937 AV * const other_av = (AV *) SvRV(Other);
3938 const I32 other_len = av_len(other_av) + 1;
3941 if (HvUSEDKEYS((HV *) This) != other_len)
3944 for(i = 0; i < other_len; ++i) {
3945 SV ** const svp = av_fetch(other_av, i, FALSE);
3949 if (!svp) /* ??? When can this happen? */
3952 key = SvPV(*svp, key_len);
3953 if(!hv_exists((HV *) This, key, key_len))
3958 else if (SM_OTHER_REGEX) {
3959 PMOP * const matcher = make_matcher(other_regex);
3962 (void) hv_iterinit((HV *) This);
3963 while ( (he = hv_iternext((HV *) This)) ) {
3964 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
3965 (void) hv_iterinit((HV *) This);
3966 destroy_matcher(matcher);
3970 destroy_matcher(matcher);
3974 if (hv_exists_ent((HV *) This, Other, 0))
3980 else if (SM_REF(PVAV)) {
3981 if (SM_OTHER_REF(PVAV)) {
3982 AV *other_av = (AV *) SvRV(Other);
3983 if (av_len((AV *) This) != av_len(other_av))
3987 const I32 other_len = av_len(other_av);
3989 if (NULL == seen_this) {
3990 seen_this = newHV();
3991 (void) sv_2mortal((SV *) seen_this);
3993 if (NULL == seen_other) {
3994 seen_this = newHV();
3995 (void) sv_2mortal((SV *) seen_other);
3997 for(i = 0; i <= other_len; ++i) {
3998 SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
3999 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4001 if (!this_elem || !other_elem) {
4002 if (this_elem || other_elem)
4005 else if (SM_SEEN_THIS(*this_elem)
4006 || SM_SEEN_OTHER(*other_elem))
4008 if (*this_elem != *other_elem)
4012 hv_store_ent(seen_this,
4013 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4015 hv_store_ent(seen_other,
4016 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4022 (void) do_smartmatch(seen_this, seen_other);
4032 else if (SM_OTHER_REGEX) {
4033 PMOP * const matcher = make_matcher(other_regex);
4034 const I32 this_len = av_len((AV *) This);
4037 for(i = 0; i <= this_len; ++i) {
4038 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4039 if (svp && matcher_matches_sv(matcher, *svp)) {
4040 destroy_matcher(matcher);
4044 destroy_matcher(matcher);
4047 else if (SvIOK(Other) || SvNOK(Other)) {
4050 for(i = 0; i <= AvFILL((AV *) This); ++i) {
4051 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4058 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4068 else if (SvPOK(Other)) {
4069 const I32 this_len = av_len((AV *) This);
4072 for(i = 0; i <= this_len; ++i) {
4073 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4088 else if (!SvOK(d) || !SvOK(e)) {
4089 if (!SvOK(d) && !SvOK(e))
4094 else if (SM_REGEX) {
4095 PMOP * const matcher = make_matcher(this_regex);
4098 PUSHs(matcher_matches_sv(matcher, Other)
4101 destroy_matcher(matcher);
4104 else if (SM_REF(PVCV)) {
4106 /* This must be a null-prototyped sub, because we
4107 already checked for the other kind. */
4113 c = call_sv(This, G_SCALAR);
4116 PUSHs(&PL_sv_undef);
4117 else if (SvTEMP(TOPs))
4118 SvREFCNT_inc_void(TOPs);
4120 if (SM_OTHER_REF(PVCV)) {
4121 /* This one has to be null-proto'd too.
4122 Call both of 'em, and compare the results */
4124 c = call_sv(SvRV(Other), G_SCALAR);
4127 PUSHs(&PL_sv_undef);
4128 else if (SvTEMP(TOPs))
4129 SvREFCNT_inc_void(TOPs);
4140 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4141 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4143 if (SvPOK(Other) && !looks_like_number(Other)) {
4144 /* String comparison */
4149 /* Otherwise, numeric comparison */
4152 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4163 /* As a last resort, use string comparison */
4172 register PERL_CONTEXT *cx;
4173 const I32 gimme = GIMME_V;
4175 /* This is essentially an optimization: if the match
4176 fails, we don't want to push a context and then
4177 pop it again right away, so we skip straight
4178 to the op that follows the leavewhen.
4180 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4181 return cLOGOP->op_other->op_next;
4186 PUSHBLOCK(cx, CXt_WHEN, SP);
4195 register PERL_CONTEXT *cx;
4201 assert(CxTYPE(cx) == CXt_WHEN);
4206 PL_curpm = newpm; /* pop $1 et al */
4216 register PERL_CONTEXT *cx;
4219 cxix = dopoptowhen(cxstack_ix);
4221 DIE(aTHX_ "Can't \"continue\" outside a when block");
4222 if (cxix < cxstack_ix)
4225 /* clear off anything above the scope we're re-entering */
4226 inner = PL_scopestack_ix;
4228 if (PL_scopestack_ix < inner)
4229 leave_scope(PL_scopestack[PL_scopestack_ix]);
4230 PL_curcop = cx->blk_oldcop;
4231 return cx->blk_givwhen.leave_op;
4238 register PERL_CONTEXT *cx;
4241 cxix = dopoptogiven(cxstack_ix);
4243 if (PL_op->op_flags & OPf_SPECIAL)
4244 DIE(aTHX_ "Can't use when() outside a topicalizer");
4246 DIE(aTHX_ "Can't \"break\" outside a given block");
4248 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4249 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4251 if (cxix < cxstack_ix)
4254 /* clear off anything above the scope we're re-entering */
4255 inner = PL_scopestack_ix;
4257 if (PL_scopestack_ix < inner)
4258 leave_scope(PL_scopestack[PL_scopestack_ix]);
4259 PL_curcop = cx->blk_oldcop;
4262 return CX_LOOP_NEXTOP_GET(cx);
4264 return cx->blk_givwhen.leave_op;
4268 S_doparseform(pTHX_ SV *sv)
4271 register char *s = SvPV_force(sv, len);
4272 register char * const send = s + len;
4273 register char *base = NULL;
4274 register I32 skipspaces = 0;
4275 bool noblank = FALSE;
4276 bool repeat = FALSE;
4277 bool postspace = FALSE;
4283 bool unchopnum = FALSE;
4284 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4287 Perl_croak(aTHX_ "Null picture in formline");
4289 /* estimate the buffer size needed */
4290 for (base = s; s <= send; s++) {
4291 if (*s == '\n' || *s == '@' || *s == '^')
4297 Newx(fops, maxops, U32);
4302 *fpc++ = FF_LINEMARK;
4303 noblank = repeat = FALSE;
4321 case ' ': case '\t':
4328 } /* else FALL THROUGH */
4336 *fpc++ = FF_LITERAL;
4344 *fpc++ = (U16)skipspaces;
4348 *fpc++ = FF_NEWLINE;
4352 arg = fpc - linepc + 1;
4359 *fpc++ = FF_LINEMARK;
4360 noblank = repeat = FALSE;
4369 ischop = s[-1] == '^';
4375 arg = (s - base) - 1;
4377 *fpc++ = FF_LITERAL;
4385 *fpc++ = 2; /* skip the @* or ^* */
4387 *fpc++ = FF_LINESNGL;
4390 *fpc++ = FF_LINEGLOB;
4392 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4393 arg = ischop ? 512 : 0;
4398 const char * const f = ++s;
4401 arg |= 256 + (s - f);
4403 *fpc++ = s - base; /* fieldsize for FETCH */
4404 *fpc++ = FF_DECIMAL;
4406 unchopnum |= ! ischop;
4408 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4409 arg = ischop ? 512 : 0;
4411 s++; /* skip the '0' first */
4415 const char * const f = ++s;
4418 arg |= 256 + (s - f);
4420 *fpc++ = s - base; /* fieldsize for FETCH */
4421 *fpc++ = FF_0DECIMAL;
4423 unchopnum |= ! ischop;
4427 bool ismore = FALSE;
4430 while (*++s == '>') ;
4431 prespace = FF_SPACE;
4433 else if (*s == '|') {
4434 while (*++s == '|') ;
4435 prespace = FF_HALFSPACE;
4440 while (*++s == '<') ;
4443 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4447 *fpc++ = s - base; /* fieldsize for FETCH */
4449 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4452 *fpc++ = (U16)prespace;
4466 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4468 { /* need to jump to the next word */
4470 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4471 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4472 s = SvPVX(sv) + SvCUR(sv) + z;
4474 Copy(fops, s, arg, U32);
4476 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4479 if (unchopnum && repeat)
4480 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4486 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4488 /* Can value be printed in fldsize chars, using %*.*f ? */
4492 int intsize = fldsize - (value < 0 ? 1 : 0);
4499 while (intsize--) pwr *= 10.0;
4500 while (frcsize--) eps /= 10.0;
4503 if (value + eps >= pwr)
4506 if (value - eps <= -pwr)
4513 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4516 SV * const datasv = FILTER_DATA(idx);
4517 const int filter_has_file = IoLINES(datasv);
4518 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4519 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4523 const char *got_p = NULL;
4524 const char *prune_from = NULL;
4525 bool read_from_cache = FALSE;
4528 assert(maxlen >= 0);
4531 /* I was having segfault trouble under Linux 2.2.5 after a
4532 parse error occured. (Had to hack around it with a test
4533 for PL_error_count == 0.) Solaris doesn't segfault --
4534 not sure where the trouble is yet. XXX */
4536 if (IoFMT_GV(datasv)) {
4537 SV *const cache = (SV *)IoFMT_GV(datasv);
4540 const char *cache_p = SvPV(cache, cache_len);
4544 /* Running in block mode and we have some cached data already.
4546 if (cache_len >= umaxlen) {
4547 /* In fact, so much data we don't even need to call
4552 const char *const first_nl =
4553 (const char *)memchr(cache_p, '\n', cache_len);
4555 take = first_nl + 1 - cache_p;
4559 sv_catpvn(buf_sv, cache_p, take);
4560 sv_chop(cache, cache_p + take);
4561 /* Definately not EOF */
4565 sv_catsv(buf_sv, cache);
4567 umaxlen -= cache_len;
4570 read_from_cache = TRUE;
4574 /* Filter API says that the filter appends to the contents of the buffer.
4575 Usually the buffer is "", so the details don't matter. But if it's not,
4576 then clearly what it contains is already filtered by this filter, so we
4577 don't want to pass it in a second time.
4578 I'm going to use a mortal in case the upstream filter croaks. */
4579 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4580 ? sv_newmortal() : buf_sv;
4581 SvUPGRADE(upstream, SVt_PV);
4583 if (filter_has_file) {
4584 status = FILTER_READ(idx+1, upstream, 0);
4587 if (filter_sub && status >= 0) {
4598 PUSHs(sv_2mortal(newSViv(0)));
4600 PUSHs(filter_state);
4603 count = call_sv(filter_sub, G_SCALAR);
4618 if(SvOK(upstream)) {
4619 got_p = SvPV(upstream, got_len);
4621 if (got_len > umaxlen) {
4622 prune_from = got_p + umaxlen;
4625 const char *const first_nl =
4626 (const char *)memchr(got_p, '\n', got_len);
4627 if (first_nl && first_nl + 1 < got_p + got_len) {
4628 /* There's a second line here... */
4629 prune_from = first_nl + 1;
4634 /* Oh. Too long. Stuff some in our cache. */
4635 STRLEN cached_len = got_p + got_len - prune_from;
4636 SV *cache = (SV *)IoFMT_GV(datasv);
4639 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4640 } else if (SvOK(cache)) {
4641 /* Cache should be empty. */
4642 assert(!SvCUR(cache));
4645 sv_setpvn(cache, prune_from, cached_len);
4646 /* If you ask for block mode, you may well split UTF-8 characters.
4647 "If it breaks, you get to keep both parts"
4648 (Your code is broken if you don't put them back together again
4649 before something notices.) */
4650 if (SvUTF8(upstream)) {
4653 SvCUR_set(upstream, got_len - cached_len);
4654 /* Can't yet be EOF */
4659 /* If they are at EOF but buf_sv has something in it, then they may never
4660 have touched the SV upstream, so it may be undefined. If we naively
4661 concatenate it then we get a warning about use of uninitialised value.
4663 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4664 sv_catsv(buf_sv, upstream);
4668 IoLINES(datasv) = 0;
4669 SvREFCNT_dec(IoFMT_GV(datasv));
4671 SvREFCNT_dec(filter_state);
4672 IoTOP_GV(datasv) = NULL;
4675 SvREFCNT_dec(filter_sub);
4676 IoBOTTOM_GV(datasv) = NULL;
4678 filter_del(S_run_user_filter);
4680 if (status == 0 && read_from_cache) {
4681 /* If we read some data from the cache (and by getting here it implies
4682 that we emptied the cache) then we aren't yet at EOF, and mustn't
4683 report that to our caller. */
4689 /* perhaps someone can come up with a better name for
4690 this? it is not really "absolute", per se ... */
4692 S_path_is_absolute(const char *name)
4694 if (PERL_FILE_IS_ABSOLUTE(name)
4695 #ifdef MACOS_TRADITIONAL
4698 || (*name == '.' && (name[1] == '/' ||
4699 (name[1] == '.' && name[2] == '/')))
4711 * c-indentation-style: bsd
4713 * indent-tabs-mode: t
4716 * ex: set ts=8 sts=4 sw=4 noet: