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 * 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))
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);
200 PM_SETRE(pm,ReREFCNT_inc(rx));
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);
249 TAINT_IF(cx->sb_rxtainted & 1);
250 PUSHs(sv_2mortal(newSViv(saviters - 1)));
252 (void)SvPOK_only_UTF8(targ);
253 TAINT_IF(cx->sb_rxtainted);
257 LEAVE_SCOPE(cx->sb_oldsave);
259 RETURNOP(pm->op_next);
261 cx->sb_iters = saviters;
263 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
266 cx->sb_orig = orig = rx->subbeg;
268 cx->sb_strend = s + (cx->sb_strend - m);
270 cx->sb_m = m = rx->startp[0] + orig;
272 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
273 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
275 sv_catpvn(dstr, s, m-s);
277 cx->sb_s = rx->endp[0] + orig;
278 { /* Update the pos() information. */
279 SV * const sv = cx->sb_targ;
282 if (SvTYPE(sv) < SVt_PVMG)
283 SvUPGRADE(sv, SVt_PVMG);
284 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
285 #ifdef PERL_OLD_COPY_ON_WRITE
287 sv_force_normal_flags(sv, 0);
289 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
298 (void)ReREFCNT_inc(rx);
299 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
300 rxres_save(&cx->sb_rxres, rx);
301 RETURNOP(pm->op_pmreplstart);
305 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
311 if (!p || p[1] < rx->nparens) {
312 #ifdef PERL_OLD_COPY_ON_WRITE
313 i = 7 + rx->nparens * 2;
315 i = 6 + rx->nparens * 2;
324 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : NULL);
325 RX_MATCH_COPIED_off(rx);
327 #ifdef PERL_OLD_COPY_ON_WRITE
328 *p++ = PTR2UV(rx->saved_copy);
329 rx->saved_copy = NULL;
334 *p++ = PTR2UV(rx->subbeg);
335 *p++ = (UV)rx->sublen;
336 for (i = 0; i <= rx->nparens; ++i) {
337 *p++ = (UV)rx->startp[i];
338 *p++ = (UV)rx->endp[i];
343 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
349 RX_MATCH_COPY_FREE(rx);
350 RX_MATCH_COPIED_set(rx, *p);
353 #ifdef PERL_OLD_COPY_ON_WRITE
355 SvREFCNT_dec (rx->saved_copy);
356 rx->saved_copy = INT2PTR(SV*,*p);
362 rx->subbeg = INT2PTR(char*,*p++);
363 rx->sublen = (I32)(*p++);
364 for (i = 0; i <= rx->nparens; ++i) {
365 rx->startp[i] = (I32)(*p++);
366 rx->endp[i] = (I32)(*p++);
371 Perl_rxres_free(pTHX_ void **rsp)
373 UV * const p = (UV*)*rsp;
378 void *tmp = INT2PTR(char*,*p);
381 PoisonFree(*p, 1, sizeof(*p));
383 Safefree(INT2PTR(char*,*p));
385 #ifdef PERL_OLD_COPY_ON_WRITE
387 SvREFCNT_dec (INT2PTR(SV*,p[1]));
397 dVAR; dSP; dMARK; dORIGMARK;
398 register SV * const tmpForm = *++MARK;
403 register SV *sv = NULL;
404 const char *item = NULL;
408 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
409 const char *chophere = NULL;
410 char *linemark = NULL;
412 bool gotsome = FALSE;
414 const STRLEN fudge = SvPOK(tmpForm)
415 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
416 bool item_is_utf8 = FALSE;
417 bool targ_is_utf8 = FALSE;
419 OP * parseres = NULL;
423 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
424 if (SvREADONLY(tmpForm)) {
425 SvREADONLY_off(tmpForm);
426 parseres = doparseform(tmpForm);
427 SvREADONLY_on(tmpForm);
430 parseres = doparseform(tmpForm);
434 SvPV_force(PL_formtarget, len);
435 if (DO_UTF8(PL_formtarget))
437 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
439 f = SvPV_const(tmpForm, len);
440 /* need to jump to the next word */
441 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
445 const char *name = "???";
448 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
449 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
450 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
451 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
452 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
454 case FF_CHECKNL: name = "CHECKNL"; break;
455 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
456 case FF_SPACE: name = "SPACE"; break;
457 case FF_HALFSPACE: name = "HALFSPACE"; break;
458 case FF_ITEM: name = "ITEM"; break;
459 case FF_CHOP: name = "CHOP"; break;
460 case FF_LINEGLOB: name = "LINEGLOB"; break;
461 case FF_NEWLINE: name = "NEWLINE"; break;
462 case FF_MORE: name = "MORE"; break;
463 case FF_LINEMARK: name = "LINEMARK"; break;
464 case FF_END: name = "END"; break;
465 case FF_0DECIMAL: name = "0DECIMAL"; break;
466 case FF_LINESNGL: name = "LINESNGL"; break;
469 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
471 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
482 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
483 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
485 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
486 t = SvEND(PL_formtarget);
489 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
490 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
492 sv_utf8_upgrade(PL_formtarget);
493 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
494 t = SvEND(PL_formtarget);
514 if (ckWARN(WARN_SYNTAX))
515 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
522 const char *s = item = SvPV_const(sv, len);
525 itemsize = sv_len_utf8(sv);
526 if (itemsize != (I32)len) {
528 if (itemsize > fieldsize) {
529 itemsize = fieldsize;
530 itembytes = itemsize;
531 sv_pos_u2b(sv, &itembytes, 0);
535 send = chophere = s + itembytes;
545 sv_pos_b2u(sv, &itemsize);
549 item_is_utf8 = FALSE;
550 if (itemsize > fieldsize)
551 itemsize = fieldsize;
552 send = chophere = s + itemsize;
566 const char *s = item = SvPV_const(sv, len);
569 itemsize = sv_len_utf8(sv);
570 if (itemsize != (I32)len) {
572 if (itemsize <= fieldsize) {
573 const char *send = chophere = s + itemsize;
586 itemsize = fieldsize;
587 itembytes = itemsize;
588 sv_pos_u2b(sv, &itembytes, 0);
589 send = chophere = s + itembytes;
590 while (s < send || (s == send && isSPACE(*s))) {
600 if (strchr(PL_chopset, *s))
605 itemsize = chophere - item;
606 sv_pos_b2u(sv, &itemsize);
612 item_is_utf8 = FALSE;
613 if (itemsize <= fieldsize) {
614 const char *const send = chophere = s + itemsize;
627 itemsize = fieldsize;
628 send = chophere = s + itemsize;
629 while (s < send || (s == send && isSPACE(*s))) {
639 if (strchr(PL_chopset, *s))
644 itemsize = chophere - item;
650 arg = fieldsize - itemsize;
659 arg = fieldsize - itemsize;
670 const char *s = item;
674 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
676 sv_utf8_upgrade(PL_formtarget);
677 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
678 t = SvEND(PL_formtarget);
682 if (UTF8_IS_CONTINUED(*s)) {
683 STRLEN skip = UTF8SKIP(s);
700 if ( !((*t++ = *s++) & ~31) )
706 if (targ_is_utf8 && !item_is_utf8) {
707 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
709 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
710 for (; t < SvEND(PL_formtarget); t++) {
723 const int ch = *t++ = *s++;
726 if ( !((*t++ = *s++) & ~31) )
735 const char *s = chophere;
753 const char *s = item = SvPV_const(sv, len);
755 if ((item_is_utf8 = DO_UTF8(sv)))
756 itemsize = sv_len_utf8(sv);
758 bool chopped = FALSE;
759 const char *const send = s + len;
761 chophere = s + itemsize;
777 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
779 SvUTF8_on(PL_formtarget);
781 SvCUR_set(sv, chophere - item);
782 sv_catsv(PL_formtarget, sv);
783 SvCUR_set(sv, itemsize);
785 sv_catsv(PL_formtarget, sv);
787 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
788 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
789 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
798 #if defined(USE_LONG_DOUBLE)
799 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
801 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
806 #if defined(USE_LONG_DOUBLE)
807 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
809 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
812 /* If the field is marked with ^ and the value is undefined,
814 if ((arg & 512) && !SvOK(sv)) {
822 /* overflow evidence */
823 if (num_overflow(value, fieldsize, arg)) {
829 /* Formats aren't yet marked for locales, so assume "yes". */
831 STORE_NUMERIC_STANDARD_SET_LOCAL();
832 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
833 RESTORE_NUMERIC_STANDARD();
840 while (t-- > linemark && *t == ' ') ;
848 if (arg) { /* repeat until fields exhausted? */
850 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
851 lines += FmLINES(PL_formtarget);
854 if (strnEQ(linemark, linemark - arg, arg))
855 DIE(aTHX_ "Runaway format");
858 SvUTF8_on(PL_formtarget);
859 FmLINES(PL_formtarget) = lines;
861 RETURNOP(cLISTOP->op_first);
872 const char *s = chophere;
873 const char *send = item + len;
875 while (isSPACE(*s) && (s < send))
880 arg = fieldsize - itemsize;
887 if (strnEQ(s1," ",3)) {
888 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
899 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
901 SvUTF8_on(PL_formtarget);
902 FmLINES(PL_formtarget) += lines;
914 if (PL_stack_base + *PL_markstack_ptr == SP) {
916 if (GIMME_V == G_SCALAR)
917 XPUSHs(sv_2mortal(newSViv(0)));
918 RETURNOP(PL_op->op_next->op_next);
920 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
921 pp_pushmark(); /* push dst */
922 pp_pushmark(); /* push src */
923 ENTER; /* enter outer scope */
926 if (PL_op->op_private & OPpGREP_LEX)
927 SAVESPTR(PAD_SVl(PL_op->op_targ));
930 ENTER; /* enter inner scope */
933 src = PL_stack_base[*PL_markstack_ptr];
935 if (PL_op->op_private & OPpGREP_LEX)
936 PAD_SVl(PL_op->op_targ) = src;
941 if (PL_op->op_type == OP_MAPSTART)
942 pp_pushmark(); /* push top */
943 return ((LOGOP*)PL_op->op_next)->op_other;
949 const I32 gimme = GIMME_V;
950 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
956 /* first, move source pointer to the next item in the source list */
957 ++PL_markstack_ptr[-1];
959 /* if there are new items, push them into the destination list */
960 if (items && gimme != G_VOID) {
961 /* might need to make room back there first */
962 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
963 /* XXX this implementation is very pessimal because the stack
964 * is repeatedly extended for every set of items. Is possible
965 * to do this without any stack extension or copying at all
966 * by maintaining a separate list over which the map iterates
967 * (like foreach does). --gsar */
969 /* everything in the stack after the destination list moves
970 * towards the end the stack by the amount of room needed */
971 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
973 /* items to shift up (accounting for the moved source pointer) */
974 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
976 /* This optimization is by Ben Tilly and it does
977 * things differently from what Sarathy (gsar)
978 * is describing. The downside of this optimization is
979 * that leaves "holes" (uninitialized and hopefully unused areas)
980 * to the Perl stack, but on the other hand this
981 * shouldn't be a problem. If Sarathy's idea gets
982 * implemented, this optimization should become
983 * irrelevant. --jhi */
985 shift = count; /* Avoid shifting too often --Ben Tilly */
990 PL_markstack_ptr[-1] += shift;
991 *PL_markstack_ptr += shift;
995 /* copy the new items down to the destination list */
996 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
997 if (gimme == G_ARRAY) {
999 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1002 /* scalar context: we don't care about which values map returns
1003 * (we use undef here). And so we certainly don't want to do mortal
1004 * copies of meaningless values. */
1005 while (items-- > 0) {
1007 *dst-- = &PL_sv_undef;
1011 LEAVE; /* exit inner scope */
1014 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1016 (void)POPMARK; /* pop top */
1017 LEAVE; /* exit outer scope */
1018 (void)POPMARK; /* pop src */
1019 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1020 (void)POPMARK; /* pop dst */
1021 SP = PL_stack_base + POPMARK; /* pop original mark */
1022 if (gimme == G_SCALAR) {
1023 if (PL_op->op_private & OPpGREP_LEX) {
1024 SV* sv = sv_newmortal();
1025 sv_setiv(sv, items);
1033 else if (gimme == G_ARRAY)
1040 ENTER; /* enter inner scope */
1043 /* set $_ to the new source item */
1044 src = PL_stack_base[PL_markstack_ptr[-1]];
1046 if (PL_op->op_private & OPpGREP_LEX)
1047 PAD_SVl(PL_op->op_targ) = src;
1051 RETURNOP(cLOGOP->op_other);
1060 if (GIMME == G_ARRAY)
1062 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1063 return cLOGOP->op_other;
1073 if (GIMME == G_ARRAY) {
1074 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1078 SV * const targ = PAD_SV(PL_op->op_targ);
1081 if (PL_op->op_private & OPpFLIP_LINENUM) {
1082 if (GvIO(PL_last_in_gv)) {
1083 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1086 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1088 flip = SvIV(sv) == SvIV(GvSV(gv));
1094 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1095 if (PL_op->op_flags & OPf_SPECIAL) {
1103 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1106 sv_setpvn(TARG, "", 0);
1112 /* This code tries to decide if "$left .. $right" should use the
1113 magical string increment, or if the range is numeric (we make
1114 an exception for .."0" [#18165]). AMS 20021031. */
1116 #define RANGE_IS_NUMERIC(left,right) ( \
1117 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1118 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1119 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1120 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1121 && (!SvOK(right) || looks_like_number(right))))
1127 if (GIMME == G_ARRAY) {
1133 if (RANGE_IS_NUMERIC(left,right)) {
1136 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1137 (SvOK(right) && SvNV(right) > IV_MAX))
1138 DIE(aTHX_ "Range iterator outside integer range");
1149 SV * const sv = sv_2mortal(newSViv(i++));
1154 SV * const final = sv_mortalcopy(right);
1156 const char * const tmps = SvPV_const(final, len);
1158 SV *sv = sv_mortalcopy(left);
1159 SvPV_force_nolen(sv);
1160 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1162 if (strEQ(SvPVX_const(sv),tmps))
1164 sv = sv_2mortal(newSVsv(sv));
1171 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1175 if (PL_op->op_private & OPpFLIP_LINENUM) {
1176 if (GvIO(PL_last_in_gv)) {
1177 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1180 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1181 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1189 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1190 sv_catpvs(targ, "E0");
1200 static const char * const context_name[] = {
1213 S_dopoptolabel(pTHX_ const char *label)
1218 for (i = cxstack_ix; i >= 0; i--) {
1219 register const PERL_CONTEXT * const cx = &cxstack[i];
1220 switch (CxTYPE(cx)) {
1228 if (ckWARN(WARN_EXITING))
1229 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1230 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1231 if (CxTYPE(cx) == CXt_NULL)
1235 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1236 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1237 (long)i, cx->blk_loop.label));
1240 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1250 Perl_dowantarray(pTHX)
1253 const I32 gimme = block_gimme();
1254 return (gimme == G_VOID) ? G_SCALAR : gimme;
1258 Perl_block_gimme(pTHX)
1261 const I32 cxix = dopoptosub(cxstack_ix);
1265 switch (cxstack[cxix].blk_gimme) {
1273 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1280 Perl_is_lvalue_sub(pTHX)
1283 const I32 cxix = dopoptosub(cxstack_ix);
1284 assert(cxix >= 0); /* We should only be called from inside subs */
1286 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1287 return cxstack[cxix].blk_sub.lval;
1293 S_dopoptosub(pTHX_ I32 startingblock)
1296 return dopoptosub_at(cxstack, startingblock);
1300 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1304 for (i = startingblock; i >= 0; i--) {
1305 register const PERL_CONTEXT * const cx = &cxstk[i];
1306 switch (CxTYPE(cx)) {
1312 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1320 S_dopoptoeval(pTHX_ I32 startingblock)
1324 for (i = startingblock; i >= 0; i--) {
1325 register const PERL_CONTEXT *cx = &cxstack[i];
1326 switch (CxTYPE(cx)) {
1330 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1338 S_dopoptoloop(pTHX_ I32 startingblock)
1342 for (i = startingblock; i >= 0; i--) {
1343 register const PERL_CONTEXT * const cx = &cxstack[i];
1344 switch (CxTYPE(cx)) {
1350 if (ckWARN(WARN_EXITING))
1351 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1352 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1353 if ((CxTYPE(cx)) == CXt_NULL)
1357 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1365 S_dopoptogiven(pTHX_ I32 startingblock)
1369 for (i = startingblock; i >= 0; i--) {
1370 register const PERL_CONTEXT *cx = &cxstack[i];
1371 switch (CxTYPE(cx)) {
1375 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1378 if (CxFOREACHDEF(cx)) {
1379 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1388 S_dopoptowhen(pTHX_ I32 startingblock)
1392 for (i = startingblock; i >= 0; i--) {
1393 register const PERL_CONTEXT *cx = &cxstack[i];
1394 switch (CxTYPE(cx)) {
1398 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1406 Perl_dounwind(pTHX_ I32 cxix)
1411 while (cxstack_ix > cxix) {
1413 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1414 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1415 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1416 /* Note: we don't need to restore the base context info till the end. */
1417 switch (CxTYPE(cx)) {
1420 continue; /* not break */
1439 PERL_UNUSED_VAR(optype);
1443 Perl_qerror(pTHX_ SV *err)
1447 sv_catsv(ERRSV, err);
1449 sv_catsv(PL_errors, err);
1451 Perl_warn(aTHX_ "%"SVf, (void*)err);
1456 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1465 if (PL_in_eval & EVAL_KEEPERR) {
1466 static const char prefix[] = "\t(in cleanup) ";
1467 SV * const err = ERRSV;
1468 const char *e = NULL;
1470 sv_setpvn(err,"",0);
1471 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1473 e = SvPV_const(err, len);
1475 if (*e != *message || strNE(e,message))
1479 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1480 sv_catpvn(err, prefix, sizeof(prefix)-1);
1481 sv_catpvn(err, message, msglen);
1482 if (ckWARN(WARN_MISC)) {
1483 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1484 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1489 sv_setpvn(ERRSV, message, msglen);
1493 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1494 && PL_curstackinfo->si_prev)
1502 register PERL_CONTEXT *cx;
1505 if (cxix < cxstack_ix)
1508 POPBLOCK(cx,PL_curpm);
1509 if (CxTYPE(cx) != CXt_EVAL) {
1511 message = SvPVx_const(ERRSV, msglen);
1512 PerlIO_write(Perl_error_log, "panic: die ", 11);
1513 PerlIO_write(Perl_error_log, message, msglen);
1518 if (gimme == G_SCALAR)
1519 *++newsp = &PL_sv_undef;
1520 PL_stack_sp = newsp;
1524 /* LEAVE could clobber PL_curcop (see save_re_context())
1525 * XXX it might be better to find a way to avoid messing with
1526 * PL_curcop in save_re_context() instead, but this is a more
1527 * minimal fix --GSAR */
1528 PL_curcop = cx->blk_oldcop;
1530 if (optype == OP_REQUIRE) {
1531 const char* const msg = SvPVx_nolen_const(ERRSV);
1532 SV * const nsv = cx->blk_eval.old_namesv;
1533 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1535 DIE(aTHX_ "%sCompilation failed in require",
1536 *msg ? msg : "Unknown error\n");
1538 assert(CxTYPE(cx) == CXt_EVAL);
1539 return cx->blk_eval.retop;
1543 message = SvPVx_const(ERRSV, msglen);
1545 write_to_stderr(message, msglen);
1553 dVAR; dSP; dPOPTOPssrl;
1554 if (SvTRUE(left) != SvTRUE(right))
1564 register I32 cxix = dopoptosub(cxstack_ix);
1565 register const PERL_CONTEXT *cx;
1566 register const PERL_CONTEXT *ccstack = cxstack;
1567 const PERL_SI *top_si = PL_curstackinfo;
1569 const char *stashname;
1576 /* we may be in a higher stacklevel, so dig down deeper */
1577 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1578 top_si = top_si->si_prev;
1579 ccstack = top_si->si_cxstack;
1580 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1583 if (GIMME != G_ARRAY) {
1589 /* caller() should not report the automatic calls to &DB::sub */
1590 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1591 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1595 cxix = dopoptosub_at(ccstack, cxix - 1);
1598 cx = &ccstack[cxix];
1599 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1600 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1601 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1602 field below is defined for any cx. */
1603 /* caller() should not report the automatic calls to &DB::sub */
1604 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1605 cx = &ccstack[dbcxix];
1608 stashname = CopSTASHPV(cx->blk_oldcop);
1609 if (GIMME != G_ARRAY) {
1612 PUSHs(&PL_sv_undef);
1615 sv_setpv(TARG, stashname);
1624 PUSHs(&PL_sv_undef);
1626 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1627 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1628 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1631 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1632 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1633 /* So is ccstack[dbcxix]. */
1635 SV * const sv = newSV(0);
1636 gv_efullname3(sv, cvgv, NULL);
1637 PUSHs(sv_2mortal(sv));
1638 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1641 PUSHs(sv_2mortal(newSVpvs("(unknown)")));
1642 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1646 PUSHs(sv_2mortal(newSVpvs("(eval)")));
1647 PUSHs(sv_2mortal(newSViv(0)));
1649 gimme = (I32)cx->blk_gimme;
1650 if (gimme == G_VOID)
1651 PUSHs(&PL_sv_undef);
1653 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1654 if (CxTYPE(cx) == CXt_EVAL) {
1656 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1657 PUSHs(cx->blk_eval.cur_text);
1661 else if (cx->blk_eval.old_namesv) {
1662 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1665 /* eval BLOCK (try blocks have old_namesv == 0) */
1667 PUSHs(&PL_sv_undef);
1668 PUSHs(&PL_sv_undef);
1672 PUSHs(&PL_sv_undef);
1673 PUSHs(&PL_sv_undef);
1675 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1676 && CopSTASH_eq(PL_curcop, PL_debstash))
1678 AV * const ary = cx->blk_sub.argarray;
1679 const int off = AvARRAY(ary) - AvALLOC(ary);
1682 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1683 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1685 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1688 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1689 av_extend(PL_dbargs, AvFILLp(ary) + off);
1690 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1691 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1693 /* XXX only hints propagated via op_private are currently
1694 * visible (others are not easily accessible, since they
1695 * use the global PL_hints) */
1696 PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
1699 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1701 if (old_warnings == pWARN_NONE ||
1702 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1703 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1704 else if (old_warnings == pWARN_ALL ||
1705 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1706 /* Get the bit mask for $warnings::Bits{all}, because
1707 * it could have been extended by warnings::register */
1709 HV * const bits = get_hv("warnings::Bits", FALSE);
1710 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1711 mask = newSVsv(*bits_all);
1714 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1718 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1719 PUSHs(sv_2mortal(mask));
1722 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1723 sv_2mortal(newRV_noinc(
1724 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1725 cx->blk_oldcop->cop_hints_hash)))
1734 const char * const tmps = (MAXARG < 1) ? "" : POPpconstx;
1735 sv_reset(tmps, CopSTASH(PL_curcop));
1740 /* like pp_nextstate, but used instead when the debugger is active */
1745 PL_curcop = (COP*)PL_op;
1746 TAINT_NOT; /* Each statement is presumed innocent */
1747 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1750 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1751 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1754 register PERL_CONTEXT *cx;
1755 const I32 gimme = G_ARRAY;
1757 GV * const gv = PL_DBgv;
1758 register CV * const cv = GvCV(gv);
1761 DIE(aTHX_ "No DB::DB routine defined");
1763 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1764 /* don't do recursive DB::DB call */
1779 (void)(*CvXSUB(cv))(aTHX_ cv);
1786 PUSHBLOCK(cx, CXt_SUB, SP);
1788 cx->blk_sub.retop = PL_op->op_next;
1791 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1792 RETURNOP(CvSTART(cv));
1802 register PERL_CONTEXT *cx;
1803 const I32 gimme = GIMME_V;
1805 U32 cxtype = CXt_LOOP | CXp_FOREACH;
1813 if (PL_op->op_targ) {
1814 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1815 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1816 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1817 SVs_PADSTALE, SVs_PADSTALE);
1819 #ifndef USE_ITHREADS
1820 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1823 SAVEPADSV(PL_op->op_targ);
1824 iterdata = INT2PTR(void*, PL_op->op_targ);
1825 cxtype |= CXp_PADVAR;
1829 GV * const gv = (GV*)POPs;
1830 svp = &GvSV(gv); /* symbol table variable */
1831 SAVEGENERICSV(*svp);
1834 iterdata = (void*)gv;
1838 if (PL_op->op_private & OPpITER_DEF)
1839 cxtype |= CXp_FOR_DEF;
1843 PUSHBLOCK(cx, cxtype, SP);
1845 PUSHLOOP(cx, iterdata, MARK);
1847 PUSHLOOP(cx, svp, MARK);
1849 if (PL_op->op_flags & OPf_STACKED) {
1850 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1851 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1853 SV * const right = (SV*)cx->blk_loop.iterary;
1856 if (RANGE_IS_NUMERIC(sv,right)) {
1857 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1858 (SvOK(right) && SvNV(right) >= IV_MAX))
1859 DIE(aTHX_ "Range iterator outside integer range");
1860 cx->blk_loop.iterix = SvIV(sv);
1861 cx->blk_loop.itermax = SvIV(right);
1863 /* for correct -Dstv display */
1864 cx->blk_oldsp = sp - PL_stack_base;
1868 cx->blk_loop.iterlval = newSVsv(sv);
1869 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1870 (void) SvPV_nolen_const(right);
1873 else if (PL_op->op_private & OPpITER_REVERSED) {
1874 cx->blk_loop.itermax = 0;
1875 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1880 cx->blk_loop.iterary = PL_curstack;
1881 AvFILLp(PL_curstack) = SP - PL_stack_base;
1882 if (PL_op->op_private & OPpITER_REVERSED) {
1883 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1884 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1887 cx->blk_loop.iterix = MARK - PL_stack_base;
1897 register PERL_CONTEXT *cx;
1898 const I32 gimme = GIMME_V;
1904 PUSHBLOCK(cx, CXt_LOOP, SP);
1905 PUSHLOOP(cx, 0, SP);
1913 register PERL_CONTEXT *cx;
1920 assert(CxTYPE(cx) == CXt_LOOP);
1922 newsp = PL_stack_base + cx->blk_loop.resetsp;
1925 if (gimme == G_VOID)
1927 else if (gimme == G_SCALAR) {
1929 *++newsp = sv_mortalcopy(*SP);
1931 *++newsp = &PL_sv_undef;
1935 *++newsp = sv_mortalcopy(*++mark);
1936 TAINT_NOT; /* Each item is independent */
1942 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1943 PL_curpm = newpm; /* ... and pop $1 et al */
1954 register PERL_CONTEXT *cx;
1955 bool popsub2 = FALSE;
1956 bool clear_errsv = FALSE;
1964 const I32 cxix = dopoptosub(cxstack_ix);
1967 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1968 * sort block, which is a CXt_NULL
1971 PL_stack_base[1] = *PL_stack_sp;
1972 PL_stack_sp = PL_stack_base + 1;
1976 DIE(aTHX_ "Can't return outside a subroutine");
1978 if (cxix < cxstack_ix)
1981 if (CxMULTICALL(&cxstack[cxix])) {
1982 gimme = cxstack[cxix].blk_gimme;
1983 if (gimme == G_VOID)
1984 PL_stack_sp = PL_stack_base;
1985 else if (gimme == G_SCALAR) {
1986 PL_stack_base[1] = *PL_stack_sp;
1987 PL_stack_sp = PL_stack_base + 1;
1993 switch (CxTYPE(cx)) {
1996 retop = cx->blk_sub.retop;
1997 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2000 if (!(PL_in_eval & EVAL_KEEPERR))
2003 retop = cx->blk_eval.retop;
2007 if (optype == OP_REQUIRE &&
2008 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2010 /* Unassume the success we assumed earlier. */
2011 SV * const nsv = cx->blk_eval.old_namesv;
2012 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2013 DIE(aTHX_ "%"SVf" did not return a true value", (void*)nsv);
2018 retop = cx->blk_sub.retop;
2021 DIE(aTHX_ "panic: return");
2025 if (gimme == G_SCALAR) {
2028 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2030 *++newsp = SvREFCNT_inc(*SP);
2035 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2037 *++newsp = sv_mortalcopy(sv);
2042 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2045 *++newsp = sv_mortalcopy(*SP);
2048 *++newsp = &PL_sv_undef;
2050 else if (gimme == G_ARRAY) {
2051 while (++MARK <= SP) {
2052 *++newsp = (popsub2 && SvTEMP(*MARK))
2053 ? *MARK : sv_mortalcopy(*MARK);
2054 TAINT_NOT; /* Each item is independent */
2057 PL_stack_sp = newsp;
2060 /* Stack values are safe: */
2063 POPSUB(cx,sv); /* release CV and @_ ... */
2067 PL_curpm = newpm; /* ... and pop $1 et al */
2071 sv_setpvn(ERRSV,"",0);
2079 register PERL_CONTEXT *cx;
2090 if (PL_op->op_flags & OPf_SPECIAL) {
2091 cxix = dopoptoloop(cxstack_ix);
2093 DIE(aTHX_ "Can't \"last\" outside a loop block");
2096 cxix = dopoptolabel(cPVOP->op_pv);
2098 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2100 if (cxix < cxstack_ix)
2104 cxstack_ix++; /* temporarily protect top context */
2106 switch (CxTYPE(cx)) {
2109 newsp = PL_stack_base + cx->blk_loop.resetsp;
2110 nextop = cx->blk_loop.last_op->op_next;
2114 nextop = cx->blk_sub.retop;
2118 nextop = cx->blk_eval.retop;
2122 nextop = cx->blk_sub.retop;
2125 DIE(aTHX_ "panic: last");
2129 if (gimme == G_SCALAR) {
2131 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2132 ? *SP : sv_mortalcopy(*SP);
2134 *++newsp = &PL_sv_undef;
2136 else if (gimme == G_ARRAY) {
2137 while (++MARK <= SP) {
2138 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2139 ? *MARK : sv_mortalcopy(*MARK);
2140 TAINT_NOT; /* Each item is independent */
2148 /* Stack values are safe: */
2151 POPLOOP(cx); /* release loop vars ... */
2155 POPSUB(cx,sv); /* release CV and @_ ... */
2158 PL_curpm = newpm; /* ... and pop $1 et al */
2161 PERL_UNUSED_VAR(optype);
2162 PERL_UNUSED_VAR(gimme);
2170 register PERL_CONTEXT *cx;
2173 if (PL_op->op_flags & OPf_SPECIAL) {
2174 cxix = dopoptoloop(cxstack_ix);
2176 DIE(aTHX_ "Can't \"next\" outside a loop block");
2179 cxix = dopoptolabel(cPVOP->op_pv);
2181 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2183 if (cxix < cxstack_ix)
2186 /* clear off anything above the scope we're re-entering, but
2187 * save the rest until after a possible continue block */
2188 inner = PL_scopestack_ix;
2190 if (PL_scopestack_ix < inner)
2191 leave_scope(PL_scopestack[PL_scopestack_ix]);
2192 PL_curcop = cx->blk_oldcop;
2193 return cx->blk_loop.next_op;
2200 register PERL_CONTEXT *cx;
2204 if (PL_op->op_flags & OPf_SPECIAL) {
2205 cxix = dopoptoloop(cxstack_ix);
2207 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2210 cxix = dopoptolabel(cPVOP->op_pv);
2212 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2214 if (cxix < cxstack_ix)
2217 redo_op = cxstack[cxix].blk_loop.redo_op;
2218 if (redo_op->op_type == OP_ENTER) {
2219 /* pop one less context to avoid $x being freed in while (my $x..) */
2221 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2222 redo_op = redo_op->op_next;
2226 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2227 LEAVE_SCOPE(oldsave);
2229 PL_curcop = cx->blk_oldcop;
2234 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2238 static const char too_deep[] = "Target of goto is too deeply nested";
2241 Perl_croak(aTHX_ too_deep);
2242 if (o->op_type == OP_LEAVE ||
2243 o->op_type == OP_SCOPE ||
2244 o->op_type == OP_LEAVELOOP ||
2245 o->op_type == OP_LEAVESUB ||
2246 o->op_type == OP_LEAVETRY)
2248 *ops++ = cUNOPo->op_first;
2250 Perl_croak(aTHX_ too_deep);
2253 if (o->op_flags & OPf_KIDS) {
2255 /* First try all the kids at this level, since that's likeliest. */
2256 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2257 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2258 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2261 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2262 if (kid == PL_lastgotoprobe)
2264 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2267 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2268 ops[-1]->op_type == OP_DBSTATE)
2273 if ((o = dofindlabel(kid, label, ops, oplimit)))
2286 register PERL_CONTEXT *cx;
2287 #define GOTO_DEPTH 64
2288 OP *enterops[GOTO_DEPTH];
2289 const char *label = NULL;
2290 const bool do_dump = (PL_op->op_type == OP_DUMP);
2291 static const char must_have_label[] = "goto must have label";
2293 if (PL_op->op_flags & OPf_STACKED) {
2294 SV * const sv = POPs;
2296 /* This egregious kludge implements goto &subroutine */
2297 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2299 register PERL_CONTEXT *cx;
2300 CV* cv = (CV*)SvRV(sv);
2307 if (!CvROOT(cv) && !CvXSUB(cv)) {
2308 const GV * const gv = CvGV(cv);
2312 /* autoloaded stub? */
2313 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2315 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2316 GvNAMELEN(gv), FALSE);
2317 if (autogv && (cv = GvCV(autogv)))
2319 tmpstr = sv_newmortal();
2320 gv_efullname3(tmpstr, gv, NULL);
2321 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",(void*)tmpstr);
2323 DIE(aTHX_ "Goto undefined subroutine");
2326 /* First do some returnish stuff. */
2327 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2329 cxix = dopoptosub(cxstack_ix);
2331 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2332 if (cxix < cxstack_ix)
2336 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2337 if (CxTYPE(cx) == CXt_EVAL) {
2339 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2341 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2343 else if (CxMULTICALL(cx))
2344 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2345 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2346 /* put @_ back onto stack */
2347 AV* av = cx->blk_sub.argarray;
2349 items = AvFILLp(av) + 1;
2350 EXTEND(SP, items+1); /* @_ could have been extended. */
2351 Copy(AvARRAY(av), SP + 1, items, SV*);
2352 SvREFCNT_dec(GvAV(PL_defgv));
2353 GvAV(PL_defgv) = cx->blk_sub.savearray;
2355 /* abandon @_ if it got reified */
2360 av_extend(av, items-1);
2362 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2365 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2366 AV* const av = GvAV(PL_defgv);
2367 items = AvFILLp(av) + 1;
2368 EXTEND(SP, items+1); /* @_ could have been extended. */
2369 Copy(AvARRAY(av), SP + 1, items, SV*);
2373 if (CxTYPE(cx) == CXt_SUB &&
2374 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2375 SvREFCNT_dec(cx->blk_sub.cv);
2376 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2377 LEAVE_SCOPE(oldsave);
2379 /* Now do some callish stuff. */
2381 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2383 OP* const retop = cx->blk_sub.retop;
2388 for (index=0; index<items; index++)
2389 sv_2mortal(SP[-index]);
2392 /* XS subs don't have a CxSUB, so pop it */
2393 POPBLOCK(cx, PL_curpm);
2394 /* Push a mark for the start of arglist */
2397 (void)(*CvXSUB(cv))(aTHX_ cv);
2402 AV* const padlist = CvPADLIST(cv);
2403 if (CxTYPE(cx) == CXt_EVAL) {
2404 PL_in_eval = cx->blk_eval.old_in_eval;
2405 PL_eval_root = cx->blk_eval.old_eval_root;
2406 cx->cx_type = CXt_SUB;
2407 cx->blk_sub.hasargs = 0;
2409 cx->blk_sub.cv = cv;
2410 cx->blk_sub.olddepth = CvDEPTH(cv);
2413 if (CvDEPTH(cv) < 2)
2414 SvREFCNT_inc_simple_void_NN(cv);
2416 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2417 sub_crush_depth(cv);
2418 pad_push(padlist, CvDEPTH(cv));
2421 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2422 if (cx->blk_sub.hasargs)
2424 AV* const av = (AV*)PAD_SVl(0);
2426 cx->blk_sub.savearray = GvAV(PL_defgv);
2427 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2428 CX_CURPAD_SAVE(cx->blk_sub);
2429 cx->blk_sub.argarray = av;
2431 if (items >= AvMAX(av) + 1) {
2432 SV **ary = AvALLOC(av);
2433 if (AvARRAY(av) != ary) {
2434 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2435 SvPV_set(av, (char*)ary);
2437 if (items >= AvMAX(av) + 1) {
2438 AvMAX(av) = items - 1;
2439 Renew(ary,items+1,SV*);
2441 SvPV_set(av, (char*)ary);
2445 Copy(mark,AvARRAY(av),items,SV*);
2446 AvFILLp(av) = items - 1;
2447 assert(!AvREAL(av));
2449 /* transfer 'ownership' of refcnts to new @_ */
2459 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2461 * We do not care about using sv to call CV;
2462 * it's for informational purposes only.
2464 SV * const sv = GvSV(PL_DBsub);
2466 if (PERLDB_SUB_NN) {
2467 const int type = SvTYPE(sv);
2468 if (type < SVt_PVIV && type != SVt_IV)
2469 sv_upgrade(sv, SVt_PVIV);
2471 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2473 gv_efullname3(sv, CvGV(cv), NULL);
2476 CV * const gotocv = get_cv("DB::goto", FALSE);
2478 PUSHMARK( PL_stack_sp );
2479 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2484 RETURNOP(CvSTART(cv));
2488 label = SvPV_nolen_const(sv);
2489 if (!(do_dump || *label))
2490 DIE(aTHX_ must_have_label);
2493 else if (PL_op->op_flags & OPf_SPECIAL) {
2495 DIE(aTHX_ must_have_label);
2498 label = cPVOP->op_pv;
2500 if (label && *label) {
2501 OP *gotoprobe = NULL;
2502 bool leaving_eval = FALSE;
2503 bool in_block = FALSE;
2504 PERL_CONTEXT *last_eval_cx = NULL;
2508 PL_lastgotoprobe = NULL;
2510 for (ix = cxstack_ix; ix >= 0; ix--) {
2512 switch (CxTYPE(cx)) {
2514 leaving_eval = TRUE;
2515 if (!CxTRYBLOCK(cx)) {
2516 gotoprobe = (last_eval_cx ?
2517 last_eval_cx->blk_eval.old_eval_root :
2522 /* else fall through */
2524 gotoprobe = cx->blk_oldcop->op_sibling;
2530 gotoprobe = cx->blk_oldcop->op_sibling;
2533 gotoprobe = PL_main_root;
2536 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2537 gotoprobe = CvROOT(cx->blk_sub.cv);
2543 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2546 DIE(aTHX_ "panic: goto");
2547 gotoprobe = PL_main_root;
2551 retop = dofindlabel(gotoprobe, label,
2552 enterops, enterops + GOTO_DEPTH);
2556 PL_lastgotoprobe = gotoprobe;
2559 DIE(aTHX_ "Can't find label %s", label);
2561 /* if we're leaving an eval, check before we pop any frames
2562 that we're not going to punt, otherwise the error
2565 if (leaving_eval && *enterops && enterops[1]) {
2567 for (i = 1; enterops[i]; i++)
2568 if (enterops[i]->op_type == OP_ENTERITER)
2569 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2572 /* pop unwanted frames */
2574 if (ix < cxstack_ix) {
2581 oldsave = PL_scopestack[PL_scopestack_ix];
2582 LEAVE_SCOPE(oldsave);
2585 /* push wanted frames */
2587 if (*enterops && enterops[1]) {
2588 OP * const oldop = PL_op;
2589 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2590 for (; enterops[ix]; ix++) {
2591 PL_op = enterops[ix];
2592 /* Eventually we may want to stack the needed arguments
2593 * for each op. For now, we punt on the hard ones. */
2594 if (PL_op->op_type == OP_ENTERITER)
2595 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2596 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2604 if (!retop) retop = PL_main_start;
2606 PL_restartop = retop;
2607 PL_do_undump = TRUE;
2611 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2612 PL_do_undump = FALSE;
2629 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2631 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2634 PL_exit_flags |= PERL_EXIT_EXPECTED;
2636 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2637 if (anum || !(PL_minus_c && PL_madskills))
2642 PUSHs(&PL_sv_undef);
2649 S_save_lines(pTHX_ AV *array, SV *sv)
2651 const char *s = SvPVX_const(sv);
2652 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2655 while (s && s < send) {
2657 SV * const tmpstr = newSV(0);
2659 sv_upgrade(tmpstr, SVt_PVMG);
2660 t = strchr(s, '\n');
2666 sv_setpvn(tmpstr, s, t - s);
2667 av_store(array, line++, tmpstr);
2673 S_docatch_body(pTHX)
2681 S_docatch(pTHX_ OP *o)
2685 OP * const oldop = PL_op;
2689 assert(CATCH_GET == TRUE);
2696 assert(cxstack_ix >= 0);
2697 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2698 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2703 /* die caught by an inner eval - continue inner loop */
2705 /* NB XXX we rely on the old popped CxEVAL still being at the top
2706 * of the stack; the way die_where() currently works, this
2707 * assumption is valid. In theory The cur_top_env value should be
2708 * returned in another global, the way retop (aka PL_restartop)
2710 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2713 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2715 PL_op = PL_restartop;
2732 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2733 /* sv Text to convert to OP tree. */
2734 /* startop op_free() this to undo. */
2735 /* code Short string id of the caller. */
2737 /* FIXME - how much of this code is common with pp_entereval? */
2738 dVAR; dSP; /* Make POPBLOCK work. */
2745 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2746 char *tmpbuf = tbuf;
2749 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2755 /* switch to eval mode */
2757 if (IN_PERL_COMPILETIME) {
2758 SAVECOPSTASH_FREE(&PL_compiling);
2759 CopSTASH_set(&PL_compiling, PL_curstash);
2761 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2762 SV * const sv = sv_newmortal();
2763 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2764 code, (unsigned long)++PL_evalseq,
2765 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2770 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2771 (unsigned long)++PL_evalseq);
2772 SAVECOPFILE_FREE(&PL_compiling);
2773 CopFILE_set(&PL_compiling, tmpbuf+2);
2774 SAVECOPLINE(&PL_compiling);
2775 CopLINE_set(&PL_compiling, 1);
2776 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2777 deleting the eval's FILEGV from the stash before gv_check() runs
2778 (i.e. before run-time proper). To work around the coredump that
2779 ensues, we always turn GvMULTI_on for any globals that were
2780 introduced within evals. See force_ident(). GSAR 96-10-12 */
2781 safestr = savepvn(tmpbuf, len);
2782 SAVEDELETE(PL_defstash, safestr, len);
2784 #ifdef OP_IN_REGISTER
2790 /* we get here either during compilation, or via pp_regcomp at runtime */
2791 runtime = IN_PERL_RUNTIME;
2793 runcv = find_runcv(NULL);
2796 PL_op->op_type = OP_ENTEREVAL;
2797 PL_op->op_flags = 0; /* Avoid uninit warning. */
2798 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2799 PUSHEVAL(cx, 0, NULL);
2802 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2804 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2805 POPBLOCK(cx,PL_curpm);
2808 (*startop)->op_type = OP_NULL;
2809 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2811 /* XXX DAPM do this properly one year */
2812 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2814 if (IN_PERL_COMPILETIME)
2815 CopHINTS_set(&PL_compiling, PL_hints);
2816 #ifdef OP_IN_REGISTER
2819 PERL_UNUSED_VAR(newsp);
2820 PERL_UNUSED_VAR(optype);
2827 =for apidoc find_runcv
2829 Locate the CV corresponding to the currently executing sub or eval.
2830 If db_seqp is non_null, skip CVs that are in the DB package and populate
2831 *db_seqp with the cop sequence number at the point that the DB:: code was
2832 entered. (allows debuggers to eval in the scope of the breakpoint rather
2833 than in the scope of the debugger itself).
2839 Perl_find_runcv(pTHX_ U32 *db_seqp)
2845 *db_seqp = PL_curcop->cop_seq;
2846 for (si = PL_curstackinfo; si; si = si->si_prev) {
2848 for (ix = si->si_cxix; ix >= 0; ix--) {
2849 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2850 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2851 CV * const cv = cx->blk_sub.cv;
2852 /* skip DB:: code */
2853 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2854 *db_seqp = cx->blk_oldcop->cop_seq;
2859 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2867 /* Compile a require/do, an eval '', or a /(?{...})/.
2868 * In the last case, startop is non-null, and contains the address of
2869 * a pointer that should be set to the just-compiled code.
2870 * outside is the lexically enclosing CV (if any) that invoked us.
2873 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2875 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2878 OP * const saveop = PL_op;
2880 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2881 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2886 SAVESPTR(PL_compcv);
2887 PL_compcv = (CV*)newSV(0);
2888 sv_upgrade((SV *)PL_compcv, 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 SAVESPTR(PL_beginav);
2912 PL_beginav = newAV();
2913 SAVEFREESV(PL_beginav);
2914 SAVEI32(PL_error_count);
2917 SAVEI32(PL_madskills);
2921 /* try to compile it */
2923 PL_eval_root = NULL;
2925 PL_curcop = &PL_compiling;
2926 CopARYBASE_set(PL_curcop, 0);
2927 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2928 PL_in_eval |= EVAL_KEEPERR;
2930 sv_setpvn(ERRSV,"",0);
2931 if (yyparse() || PL_error_count || !PL_eval_root) {
2932 SV **newsp; /* Used by POPBLOCK. */
2933 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2934 I32 optype = 0; /* Might be reset by POPEVAL. */
2939 op_free(PL_eval_root);
2940 PL_eval_root = NULL;
2942 SP = PL_stack_base + POPMARK; /* pop original mark */
2944 POPBLOCK(cx,PL_curpm);
2950 msg = SvPVx_nolen_const(ERRSV);
2951 if (optype == OP_REQUIRE) {
2952 const SV * const nsv = cx->blk_eval.old_namesv;
2953 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2955 DIE(aTHX_ "%sCompilation failed in require",
2956 *msg ? msg : "Unknown error\n");
2959 POPBLOCK(cx,PL_curpm);
2961 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2962 (*msg ? msg : "Unknown error\n"));
2966 sv_setpv(ERRSV, "Compilation error");
2969 PERL_UNUSED_VAR(newsp);
2972 CopLINE_set(&PL_compiling, 0);
2974 *startop = PL_eval_root;
2976 SAVEFREEOP(PL_eval_root);
2978 /* Set the context for this new optree.
2979 * If the last op is an OP_REQUIRE, force scalar context.
2980 * Otherwise, propagate the context from the eval(). */
2981 if (PL_eval_root->op_type == OP_LEAVEEVAL
2982 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2983 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2985 scalar(PL_eval_root);
2986 else if (gimme & G_VOID)
2987 scalarvoid(PL_eval_root);
2988 else if (gimme & G_ARRAY)
2991 scalar(PL_eval_root);
2993 DEBUG_x(dump_eval());
2995 /* Register with debugger: */
2996 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
2997 CV * const cv = get_cv("DB::postponed", FALSE);
3001 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3003 call_sv((SV*)cv, G_DISCARD);
3007 /* compiled okay, so do it */
3009 CvDEPTH(PL_compcv) = 1;
3010 SP = PL_stack_base + POPMARK; /* pop original mark */
3011 PL_op = saveop; /* The caller may need it. */
3012 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3014 RETURNOP(PL_eval_start);
3018 S_check_type_and_open(pTHX_ const char *name, const char *mode)
3021 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_cache = NULL;
3071 SV *filter_state = NULL;
3072 SV *filter_sub = NULL;
3078 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3079 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3080 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3081 "v-string in use/require non-portable");
3083 sv = new_version(sv);
3084 if (!sv_derived_from(PL_patchlevel, "version"))
3085 upg_version(PL_patchlevel);
3086 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3087 if ( vcmp(sv,PL_patchlevel) <= 0 )
3088 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3089 (void*)vnormal(sv), (void*)vnormal(PL_patchlevel));
3092 if ( vcmp(sv,PL_patchlevel) > 0 )
3093 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3094 (void*)vnormal(sv), (void*)vnormal(PL_patchlevel));
3099 name = SvPV_const(sv, len);
3100 if (!(name && len > 0 && *name))
3101 DIE(aTHX_ "Null filename used");
3102 TAINT_PROPER("require");
3103 if (PL_op->op_type == OP_REQUIRE) {
3104 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3106 if (*svp != &PL_sv_undef)
3109 DIE(aTHX_ "Compilation failed in require");
3113 /* prepare to compile file */
3115 if (path_is_absolute(name)) {
3117 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3119 #ifdef MACOS_TRADITIONAL
3123 MacPerl_CanonDir(name, newname, 1);
3124 if (path_is_absolute(newname)) {
3126 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3131 AV * const ar = GvAVn(PL_incgv);
3135 if ((unixname = tounixspec(name, NULL)) != NULL)
3139 for (i = 0; i <= AvFILL(ar); i++) {
3140 SV * const dirsv = *av_fetch(ar, i, TRUE);
3146 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3147 && !sv_isobject(loader))
3149 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3152 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3153 PTR2UV(SvRV(dirsv)), name);
3154 tryname = SvPVX_const(namesv);
3165 if (sv_isobject(loader))
3166 count = call_method("INC", G_ARRAY);
3168 count = call_sv(loader, G_ARRAY);
3178 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3179 && !isGV_with_GP(SvRV(arg))) {
3180 filter_cache = SvRV(arg);
3181 SvREFCNT_inc_simple_void_NN(filter_cache);
3188 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3192 if (SvTYPE(arg) == SVt_PVGV) {
3193 IO * const io = GvIO((GV *)arg);
3198 tryrsfp = IoIFP(io);
3199 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3200 PerlIO_close(IoOFP(io));
3211 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3213 SvREFCNT_inc_simple_void_NN(filter_sub);
3216 filter_state = SP[i];
3217 SvREFCNT_inc_simple_void(filter_state);
3221 if (!tryrsfp && (filter_cache || filter_sub)) {
3222 tryrsfp = PerlIO_open(BIT_BUCKET,
3237 filter_has_file = 0;
3239 SvREFCNT_dec(filter_cache);
3240 filter_cache = NULL;
3243 SvREFCNT_dec(filter_state);
3244 filter_state = NULL;
3247 SvREFCNT_dec(filter_sub);
3252 if (!path_is_absolute(name)
3253 #ifdef MACOS_TRADITIONAL
3254 /* We consider paths of the form :a:b ambiguous and interpret them first
3255 as global then as local
3257 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3260 const char *dir = SvPVx_nolen_const(dirsv);
3261 #ifdef MACOS_TRADITIONAL
3265 MacPerl_CanonDir(name, buf2, 1);
3266 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3270 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3272 sv_setpv(namesv, unixdir);
3273 sv_catpv(namesv, unixname);
3275 # ifdef __SYMBIAN32__
3276 if (PL_origfilename[0] &&
3277 PL_origfilename[1] == ':' &&
3278 !(dir[0] && dir[1] == ':'))
3279 Perl_sv_setpvf(aTHX_ namesv,
3284 Perl_sv_setpvf(aTHX_ namesv,
3288 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3292 TAINT_PROPER("require");
3293 tryname = SvPVX_const(namesv);
3294 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3296 if (tryname[0] == '.' && tryname[1] == '/')
3305 SAVECOPFILE_FREE(&PL_compiling);
3306 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3307 SvREFCNT_dec(namesv);
3309 if (PL_op->op_type == OP_REQUIRE) {
3310 const char *msgstr = name;
3311 if(errno == EMFILE) {
3313 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3315 msgstr = SvPV_nolen_const(msg);
3317 if (namesv) { /* did we lookup @INC? */
3318 AV * const ar = GvAVn(PL_incgv);
3320 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3321 "%s in @INC%s%s (@INC contains:",
3323 (instr(msgstr, ".h ")
3324 ? " (change .h to .ph maybe?)" : ""),
3325 (instr(msgstr, ".ph ")
3326 ? " (did you run h2ph?)" : "")
3329 for (i = 0; i <= AvFILL(ar); i++) {
3330 sv_catpvs(msg, " ");
3331 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3333 sv_catpvs(msg, ")");
3334 msgstr = SvPV_nolen_const(msg);
3337 DIE(aTHX_ "Can't locate %s", msgstr);
3343 SETERRNO(0, SS_NORMAL);
3345 /* Assume success here to prevent recursive requirement. */
3346 /* name is never assigned to again, so len is still strlen(name) */
3347 /* Check whether a hook in @INC has already filled %INC */
3349 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3351 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3353 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc_simple(hook_sv), 0 );
3358 lex_start(sv_2mortal(newSVpvs("")));
3359 SAVEGENERICSV(PL_rsfp_filters);
3360 PL_rsfp_filters = NULL;
3365 SAVECOMPILEWARNINGS();
3366 if (PL_dowarn & G_WARN_ALL_ON)
3367 PL_compiling.cop_warnings = pWARN_ALL ;
3368 else if (PL_dowarn & G_WARN_ALL_OFF)
3369 PL_compiling.cop_warnings = pWARN_NONE ;
3370 else if (PL_taint_warn) {
3371 PL_compiling.cop_warnings
3372 = Perl_new_warnings_bitfield(aTHX_ NULL, WARN_TAINTstring, WARNsize);
3375 PL_compiling.cop_warnings = pWARN_STD ;
3377 if (filter_sub || filter_cache) {
3378 SV * const datasv = filter_add(S_run_user_filter, NULL);
3379 IoLINES(datasv) = filter_has_file;
3380 IoTOP_GV(datasv) = (GV *)filter_state;
3381 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3382 IoFMT_GV(datasv) = (GV *)filter_cache;
3385 /* switch to eval mode */
3386 PUSHBLOCK(cx, CXt_EVAL, SP);
3387 PUSHEVAL(cx, name, NULL);
3388 cx->blk_eval.retop = PL_op->op_next;
3390 SAVECOPLINE(&PL_compiling);
3391 CopLINE_set(&PL_compiling, 0);
3395 /* Store and reset encoding. */
3396 encoding = PL_encoding;
3399 op = DOCATCH(doeval(gimme, NULL, NULL, PL_curcop->cop_seq));
3401 /* Restore encoding. */
3402 PL_encoding = encoding;
3410 register PERL_CONTEXT *cx;
3412 const I32 gimme = GIMME_V;
3413 const I32 was = PL_sub_generation;
3414 char tbuf[TYPE_DIGITS(long) + 12];
3415 char *tmpbuf = tbuf;
3421 HV *saved_hh = NULL;
3422 const char * const fakestr = "_<(eval )";
3424 const int fakelen = 9 + 1;
3427 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3428 saved_hh = (HV*) SvREFCNT_inc(POPs);
3432 if (!SvPV_nolen_const(sv))
3434 TAINT_PROPER("eval");
3440 /* switch to eval mode */
3442 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3443 SV * const temp_sv = sv_newmortal();
3444 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3445 (unsigned long)++PL_evalseq,
3446 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3447 tmpbuf = SvPVX(temp_sv);
3448 len = SvCUR(temp_sv);
3451 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3452 SAVECOPFILE_FREE(&PL_compiling);
3453 CopFILE_set(&PL_compiling, tmpbuf+2);
3454 SAVECOPLINE(&PL_compiling);
3455 CopLINE_set(&PL_compiling, 1);
3456 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3457 deleting the eval's FILEGV from the stash before gv_check() runs
3458 (i.e. before run-time proper). To work around the coredump that
3459 ensues, we always turn GvMULTI_on for any globals that were
3460 introduced within evals. See force_ident(). GSAR 96-10-12 */
3461 safestr = savepvn(tmpbuf, len);
3462 SAVEDELETE(PL_defstash, safestr, len);
3464 PL_hints = PL_op->op_targ;
3466 GvHV(PL_hintgv) = saved_hh;
3467 SAVECOMPILEWARNINGS();
3468 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3469 if (PL_compiling.cop_hints_hash) {
3470 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3472 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3473 if (PL_compiling.cop_hints_hash) {
3475 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3476 HINTS_REFCNT_UNLOCK;
3478 /* special case: an eval '' executed within the DB package gets lexically
3479 * placed in the first non-DB CV rather than the current CV - this
3480 * allows the debugger to execute code, find lexicals etc, in the
3481 * scope of the code being debugged. Passing &seq gets find_runcv
3482 * to do the dirty work for us */
3483 runcv = find_runcv(&seq);
3485 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3486 PUSHEVAL(cx, 0, NULL);
3487 cx->blk_eval.retop = PL_op->op_next;
3489 /* prepare to compile string */
3491 if (PERLDB_LINE && PL_curstash != PL_debstash)
3492 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3494 ret = doeval(gimme, NULL, runcv, seq);
3495 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3496 && ret != PL_op->op_next) { /* Successive compilation. */
3497 /* Copy in anything fake and short. */
3499 strlcpy(safestr, fakestr, fakelen);
3501 strcpy(safestr, fakestr);
3502 #endif /* #ifdef HAS_STRLCPY */
3504 return DOCATCH(ret);
3514 register PERL_CONTEXT *cx;
3516 const U8 save_flags = PL_op -> op_flags;
3521 retop = cx->blk_eval.retop;
3524 if (gimme == G_VOID)
3526 else if (gimme == G_SCALAR) {
3529 if (SvFLAGS(TOPs) & SVs_TEMP)
3532 *MARK = sv_mortalcopy(TOPs);
3536 *MARK = &PL_sv_undef;
3541 /* in case LEAVE wipes old return values */
3542 for (mark = newsp + 1; mark <= SP; mark++) {
3543 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3544 *mark = sv_mortalcopy(*mark);
3545 TAINT_NOT; /* Each item is independent */
3549 PL_curpm = newpm; /* Don't pop $1 et al till now */
3552 assert(CvDEPTH(PL_compcv) == 1);
3554 CvDEPTH(PL_compcv) = 0;
3557 if (optype == OP_REQUIRE &&
3558 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3560 /* Unassume the success we assumed earlier. */
3561 SV * const nsv = cx->blk_eval.old_namesv;
3562 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3563 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", (void*)nsv);
3564 /* die_where() did LEAVE, or we won't be here */
3568 if (!(save_flags & OPf_SPECIAL))
3569 sv_setpvn(ERRSV,"",0);
3575 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3576 close to the related Perl_create_eval_scope. */
3578 Perl_delete_eval_scope(pTHX)
3583 register PERL_CONTEXT *cx;
3590 PERL_UNUSED_VAR(newsp);
3591 PERL_UNUSED_VAR(gimme);
3592 PERL_UNUSED_VAR(optype);
3595 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3596 also needed by Perl_fold_constants. */
3598 Perl_create_eval_scope(pTHX_ U32 flags)
3601 const I32 gimme = GIMME_V;
3606 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3608 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3610 PL_in_eval = EVAL_INEVAL;
3611 if (flags & G_KEEPERR)
3612 PL_in_eval |= EVAL_KEEPERR;
3614 sv_setpvn(ERRSV,"",0);
3615 if (flags & G_FAKINGEVAL) {
3616 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3624 PERL_CONTEXT * const cx = create_eval_scope(0);
3625 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3626 return DOCATCH(PL_op->op_next);
3635 register PERL_CONTEXT *cx;
3640 PERL_UNUSED_VAR(optype);
3643 if (gimme == G_VOID)
3645 else if (gimme == G_SCALAR) {
3649 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3652 *MARK = sv_mortalcopy(TOPs);
3656 *MARK = &PL_sv_undef;
3661 /* in case LEAVE wipes old return values */
3663 for (mark = newsp + 1; mark <= SP; mark++) {
3664 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3665 *mark = sv_mortalcopy(*mark);
3666 TAINT_NOT; /* Each item is independent */
3670 PL_curpm = newpm; /* Don't pop $1 et al till now */
3673 sv_setpvn(ERRSV,"",0);
3680 register PERL_CONTEXT *cx;
3681 const I32 gimme = GIMME_V;
3686 if (PL_op->op_targ == 0) {
3687 SV ** const defsv_p = &GvSV(PL_defgv);
3688 *defsv_p = newSVsv(POPs);
3689 SAVECLEARSV(*defsv_p);
3692 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3694 PUSHBLOCK(cx, CXt_GIVEN, SP);
3703 register PERL_CONTEXT *cx;
3707 PERL_UNUSED_CONTEXT;
3710 assert(CxTYPE(cx) == CXt_GIVEN);
3715 PL_curpm = newpm; /* pop $1 et al */
3722 /* Helper routines used by pp_smartmatch */
3725 S_make_matcher(pTHX_ regexp *re)
3728 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3729 PM_SETRE(matcher, ReREFCNT_inc(re));
3731 SAVEFREEOP((OP *) matcher);
3739 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3744 PL_op = (OP *) matcher;
3749 return (SvTRUEx(POPs));
3754 S_destroy_matcher(pTHX_ PMOP *matcher)
3757 PERL_UNUSED_ARG(matcher);
3762 /* Do a smart match */
3765 return do_smartmatch(NULL, NULL);
3768 /* This version of do_smartmatch() implements the following
3769 table of smart matches:
3771 $a $b Type of Match Implied Matching Code
3772 ====== ===== ===================== =============
3773 (overloading trumps everything)
3775 Code[+] Code[+] referential equality match if refaddr($a) == refaddr($b)
3776 Any Code[+] scalar sub truth match if $b->($a)
3778 Hash Hash hash keys identical match if sort(keys(%$a)) ÈeqÇ sort(keys(%$b))
3779 Hash Array hash value slice truth match if $a->{any(@$b)}
3780 Hash Regex hash key grep match if any(keys(%$a)) =~ /$b/
3781 Hash Any hash entry existence match if exists $a->{$b}
3783 Array Array arrays are identical[*] match if $a È~~Ç $b
3784 Array Regex array grep match if any(@$a) =~ /$b/
3785 Array Num array contains number match if any($a) == $b
3786 Array Any array contains string match if any($a) eq $b
3788 Any undef undefined match if !defined $a
3789 Any Regex pattern match match if $a =~ /$b/
3790 Code() Code() results are equal match if $a->() eq $b->()
3791 Any Code() simple closure truth match if $b->() (ignoring $a)
3792 Num numish[!] numeric equality match if $a == $b
3793 Any Str string equality match if $a eq $b
3794 Any Num numeric equality match if $a == $b
3796 Any Any string equality match if $a eq $b
3799 + - this must be a code reference whose prototype (if present) is not ""
3800 (subs with a "" prototype are dealt with by the 'Code()' entry lower down)
3801 * - if a circular reference is found, we fall back to referential equality
3802 ! - either a real number, or a string that looks_like_number()
3807 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3812 SV *e = TOPs; /* e is for 'expression' */
3813 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3816 regexp *this_regex, *other_regex;
3818 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3820 # define SM_REF(type) ( \
3821 (SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_##type) && (other = e)) \
3822 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_##type) && (other = d)))
3824 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3825 ((SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_PVCV) \
3826 && NOT_EMPTY_PROTO(this) && (other = e)) \
3827 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_PVCV) \
3828 && NOT_EMPTY_PROTO(this) && (other = d)))
3830 # define SM_REGEX ( \
3831 (SvROK(d) && SvMAGICAL(this = SvRV(d)) \
3832 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3833 && (this_regex = (regexp *)mg->mg_obj) \
3836 (SvROK(e) && SvMAGICAL(this = SvRV(e)) \
3837 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3838 && (this_regex = (regexp *)mg->mg_obj) \
3842 # define SM_OTHER_REF(type) \
3843 (SvROK(other) && SvTYPE(SvRV(other)) == SVt_##type)
3845 # define SM_OTHER_REGEX (SvROK(other) && SvMAGICAL(SvRV(other)) \
3846 && (mg = mg_find(SvRV(other), PERL_MAGIC_qr)) \
3847 && (other_regex = (regexp *)mg->mg_obj))
3850 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3851 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3853 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3854 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3856 tryAMAGICbinSET(smart, 0);
3858 SP -= 2; /* Pop the values */
3860 /* Take care only to invoke mg_get() once for each argument.
3861 * Currently we do this by copying the SV if it's magical. */
3864 d = sv_mortalcopy(d);
3871 e = sv_mortalcopy(e);
3876 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(other)) )
3878 if (this == SvRV(other))
3889 c = call_sv(this, G_SCALAR);
3893 else if (SvTEMP(TOPs))
3894 SvREFCNT_inc_void(TOPs);
3899 else if (SM_REF(PVHV)) {
3900 if (SM_OTHER_REF(PVHV)) {
3901 /* Check that the key-sets are identical */
3903 HV *other_hv = (HV *) SvRV(other);
3905 bool other_tied = FALSE;
3906 U32 this_key_count = 0,
3907 other_key_count = 0;
3909 /* Tied hashes don't know how many keys they have. */
3910 if (SvTIED_mg(this, PERL_MAGIC_tied)) {
3913 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3914 HV * const temp = other_hv;
3915 other_hv = (HV *) this;
3919 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3922 if (!tied && HvUSEDKEYS((HV *) this) != HvUSEDKEYS(other_hv))
3925 /* The hashes have the same number of keys, so it suffices
3926 to check that one is a subset of the other. */
3927 (void) hv_iterinit((HV *) this);
3928 while ( (he = hv_iternext((HV *) this)) ) {
3930 char * const key = hv_iterkey(he, &key_len);
3934 if(!hv_exists(other_hv, key, key_len)) {
3935 (void) hv_iterinit((HV *) this); /* reset iterator */
3941 (void) hv_iterinit(other_hv);
3942 while ( hv_iternext(other_hv) )
3946 other_key_count = HvUSEDKEYS(other_hv);
3948 if (this_key_count != other_key_count)
3953 else if (SM_OTHER_REF(PVAV)) {
3954 AV * const other_av = (AV *) SvRV(other);
3955 const I32 other_len = av_len(other_av) + 1;
3958 if (HvUSEDKEYS((HV *) this) != other_len)
3961 for(i = 0; i < other_len; ++i) {
3962 SV ** const svp = av_fetch(other_av, i, FALSE);
3966 if (!svp) /* ??? When can this happen? */
3969 key = SvPV(*svp, key_len);
3970 if(!hv_exists((HV *) this, key, key_len))
3975 else if (SM_OTHER_REGEX) {
3976 PMOP * const matcher = make_matcher(other_regex);
3979 (void) hv_iterinit((HV *) this);
3980 while ( (he = hv_iternext((HV *) this)) ) {
3981 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
3982 (void) hv_iterinit((HV *) this);
3983 destroy_matcher(matcher);
3987 destroy_matcher(matcher);
3991 if (hv_exists_ent((HV *) this, other, 0))
3997 else if (SM_REF(PVAV)) {
3998 if (SM_OTHER_REF(PVAV)) {
3999 AV *other_av = (AV *) SvRV(other);
4000 if (av_len((AV *) this) != av_len(other_av))
4004 const I32 other_len = av_len(other_av);
4006 if (NULL == seen_this) {
4007 seen_this = newHV();
4008 (void) sv_2mortal((SV *) seen_this);
4010 if (NULL == seen_other) {
4011 seen_this = newHV();
4012 (void) sv_2mortal((SV *) seen_other);
4014 for(i = 0; i <= other_len; ++i) {
4015 SV * const * const this_elem = av_fetch((AV *)this, i, FALSE);
4016 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4018 if (!this_elem || !other_elem) {
4019 if (this_elem || other_elem)
4022 else if (SM_SEEN_THIS(*this_elem)
4023 || SM_SEEN_OTHER(*other_elem))
4025 if (*this_elem != *other_elem)
4029 hv_store_ent(seen_this,
4030 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4032 hv_store_ent(seen_other,
4033 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4039 (void) do_smartmatch(seen_this, seen_other);
4049 else if (SM_OTHER_REGEX) {
4050 PMOP * const matcher = make_matcher(other_regex);
4051 const I32 this_len = av_len((AV *) this);
4054 for(i = 0; i <= this_len; ++i) {
4055 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4056 if (svp && matcher_matches_sv(matcher, *svp)) {
4057 destroy_matcher(matcher);
4061 destroy_matcher(matcher);
4064 else if (SvIOK(other) || SvNOK(other)) {
4067 for(i = 0; i <= AvFILL((AV *) this); ++i) {
4068 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4075 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4085 else if (SvPOK(other)) {
4086 const I32 this_len = av_len((AV *) this);
4089 for(i = 0; i <= this_len; ++i) {
4090 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4105 else if (!SvOK(d) || !SvOK(e)) {
4106 if (!SvOK(d) && !SvOK(e))
4111 else if (SM_REGEX) {
4112 PMOP * const matcher = make_matcher(this_regex);
4115 PUSHs(matcher_matches_sv(matcher, other)
4118 destroy_matcher(matcher);
4121 else if (SM_REF(PVCV)) {
4123 /* This must be a null-prototyped sub, because we
4124 already checked for the other kind. */
4130 c = call_sv(this, G_SCALAR);
4133 PUSHs(&PL_sv_undef);
4134 else if (SvTEMP(TOPs))
4135 SvREFCNT_inc_void(TOPs);
4137 if (SM_OTHER_REF(PVCV)) {
4138 /* This one has to be null-proto'd too.
4139 Call both of 'em, and compare the results */
4141 c = call_sv(SvRV(other), G_SCALAR);
4144 PUSHs(&PL_sv_undef);
4145 else if (SvTEMP(TOPs))
4146 SvREFCNT_inc_void(TOPs);
4157 else if ( ((SvIOK(d) || SvNOK(d)) && (this = d) && (other = e))
4158 || ((SvIOK(e) || SvNOK(e)) && (this = e) && (other = d)) )
4160 if (SvPOK(other) && !looks_like_number(other)) {
4161 /* String comparison */
4166 /* Otherwise, numeric comparison */
4169 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4180 /* As a last resort, use string comparison */
4189 register PERL_CONTEXT *cx;
4190 const I32 gimme = GIMME_V;
4192 /* This is essentially an optimization: if the match
4193 fails, we don't want to push a context and then
4194 pop it again right away, so we skip straight
4195 to the op that follows the leavewhen.
4197 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4198 return cLOGOP->op_other->op_next;
4203 PUSHBLOCK(cx, CXt_WHEN, SP);
4212 register PERL_CONTEXT *cx;
4218 assert(CxTYPE(cx) == CXt_WHEN);
4223 PL_curpm = newpm; /* pop $1 et al */
4233 register PERL_CONTEXT *cx;
4236 cxix = dopoptowhen(cxstack_ix);
4238 DIE(aTHX_ "Can't \"continue\" outside a when block");
4239 if (cxix < cxstack_ix)
4242 /* clear off anything above the scope we're re-entering */
4243 inner = PL_scopestack_ix;
4245 if (PL_scopestack_ix < inner)
4246 leave_scope(PL_scopestack[PL_scopestack_ix]);
4247 PL_curcop = cx->blk_oldcop;
4248 return cx->blk_givwhen.leave_op;
4255 register PERL_CONTEXT *cx;
4258 cxix = dopoptogiven(cxstack_ix);
4260 if (PL_op->op_flags & OPf_SPECIAL)
4261 DIE(aTHX_ "Can't use when() outside a topicalizer");
4263 DIE(aTHX_ "Can't \"break\" outside a given block");
4265 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4266 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4268 if (cxix < cxstack_ix)
4271 /* clear off anything above the scope we're re-entering */
4272 inner = PL_scopestack_ix;
4274 if (PL_scopestack_ix < inner)
4275 leave_scope(PL_scopestack[PL_scopestack_ix]);
4276 PL_curcop = cx->blk_oldcop;
4279 return cx->blk_loop.next_op;
4281 return cx->blk_givwhen.leave_op;
4285 S_doparseform(pTHX_ SV *sv)
4288 register char *s = SvPV_force(sv, len);
4289 register char * const send = s + len;
4290 register char *base = NULL;
4291 register I32 skipspaces = 0;
4292 bool noblank = FALSE;
4293 bool repeat = FALSE;
4294 bool postspace = FALSE;
4300 bool unchopnum = FALSE;
4301 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4304 Perl_croak(aTHX_ "Null picture in formline");
4306 /* estimate the buffer size needed */
4307 for (base = s; s <= send; s++) {
4308 if (*s == '\n' || *s == '@' || *s == '^')
4314 Newx(fops, maxops, U32);
4319 *fpc++ = FF_LINEMARK;
4320 noblank = repeat = FALSE;
4338 case ' ': case '\t':
4345 } /* else FALL THROUGH */
4353 *fpc++ = FF_LITERAL;
4361 *fpc++ = (U16)skipspaces;
4365 *fpc++ = FF_NEWLINE;
4369 arg = fpc - linepc + 1;
4376 *fpc++ = FF_LINEMARK;
4377 noblank = repeat = FALSE;
4386 ischop = s[-1] == '^';
4392 arg = (s - base) - 1;
4394 *fpc++ = FF_LITERAL;
4402 *fpc++ = 2; /* skip the @* or ^* */
4404 *fpc++ = FF_LINESNGL;
4407 *fpc++ = FF_LINEGLOB;
4409 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4410 arg = ischop ? 512 : 0;
4415 const char * const f = ++s;
4418 arg |= 256 + (s - f);
4420 *fpc++ = s - base; /* fieldsize for FETCH */
4421 *fpc++ = FF_DECIMAL;
4423 unchopnum |= ! ischop;
4425 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4426 arg = ischop ? 512 : 0;
4428 s++; /* skip the '0' first */
4432 const char * const f = ++s;
4435 arg |= 256 + (s - f);
4437 *fpc++ = s - base; /* fieldsize for FETCH */
4438 *fpc++ = FF_0DECIMAL;
4440 unchopnum |= ! ischop;
4444 bool ismore = FALSE;
4447 while (*++s == '>') ;
4448 prespace = FF_SPACE;
4450 else if (*s == '|') {
4451 while (*++s == '|') ;
4452 prespace = FF_HALFSPACE;
4457 while (*++s == '<') ;
4460 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4464 *fpc++ = s - base; /* fieldsize for FETCH */
4466 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4469 *fpc++ = (U16)prespace;
4483 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4485 { /* need to jump to the next word */
4487 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4488 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4489 s = SvPVX(sv) + SvCUR(sv) + z;
4491 Copy(fops, s, arg, U32);
4493 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4496 if (unchopnum && repeat)
4497 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4503 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4505 /* Can value be printed in fldsize chars, using %*.*f ? */
4509 int intsize = fldsize - (value < 0 ? 1 : 0);
4516 while (intsize--) pwr *= 10.0;
4517 while (frcsize--) eps /= 10.0;
4520 if (value + eps >= pwr)
4523 if (value - eps <= -pwr)
4530 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4533 SV * const datasv = FILTER_DATA(idx);
4534 const int filter_has_file = IoLINES(datasv);
4535 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4536 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4540 const char *got_p = NULL;
4541 const char *prune_from = NULL;
4542 bool read_from_cache = FALSE;
4545 assert(maxlen >= 0);
4548 /* I was having segfault trouble under Linux 2.2.5 after a
4549 parse error occured. (Had to hack around it with a test
4550 for PL_error_count == 0.) Solaris doesn't segfault --
4551 not sure where the trouble is yet. XXX */
4553 if (IoFMT_GV(datasv)) {
4554 SV *const cache = (SV *)IoFMT_GV(datasv);
4557 const char *cache_p = SvPV(cache, cache_len);
4561 /* Running in block mode and we have some cached data already.
4563 if (cache_len >= umaxlen) {
4564 /* In fact, so much data we don't even need to call
4569 const char *const first_nl = memchr(cache_p, '\n', cache_len);
4571 take = first_nl + 1 - cache_p;
4575 sv_catpvn(buf_sv, cache_p, take);
4576 sv_chop(cache, cache_p + take);
4577 /* Definately not EOF */
4581 sv_catsv(buf_sv, cache);
4583 umaxlen -= cache_len;
4586 read_from_cache = TRUE;
4590 /* Filter API says that the filter appends to the contents of the buffer.
4591 Usually the buffer is "", so the details don't matter. But if it's not,
4592 then clearly what it contains is already filtered by this filter, so we
4593 don't want to pass it in a second time.
4594 I'm going to use a mortal in case the upstream filter croaks. */
4595 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4596 ? sv_newmortal() : buf_sv;
4597 SvUPGRADE(upstream, SVt_PV);
4599 if (filter_has_file) {
4600 status = FILTER_READ(idx+1, upstream, 0);
4603 if (filter_sub && status >= 0) {
4614 PUSHs(sv_2mortal(newSViv(0)));
4616 PUSHs(filter_state);
4619 count = call_sv(filter_sub, G_SCALAR);
4634 if(SvOK(upstream)) {
4635 got_p = SvPV(upstream, got_len);
4637 if (got_len > umaxlen) {
4638 prune_from = got_p + umaxlen;
4641 const char *const first_nl = memchr(got_p, '\n', got_len);
4642 if (first_nl && first_nl + 1 < got_p + got_len) {
4643 /* There's a second line here... */
4644 prune_from = first_nl + 1;
4649 /* Oh. Too long. Stuff some in our cache. */
4650 STRLEN cached_len = got_p + got_len - prune_from;
4651 SV *cache = (SV *)IoFMT_GV(datasv);
4654 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4655 } else if (SvOK(cache)) {
4656 /* Cache should be empty. */
4657 assert(!SvCUR(cache));
4660 sv_setpvn(cache, prune_from, cached_len);
4661 /* If you ask for block mode, you may well split UTF-8 characters.
4662 "If it breaks, you get to keep both parts"
4663 (Your code is broken if you don't put them back together again
4664 before something notices.) */
4665 if (SvUTF8(upstream)) {
4668 SvCUR_set(upstream, got_len - cached_len);
4669 /* Can't yet be EOF */
4674 /* If they are at EOF but buf_sv has something in it, then they may never
4675 have touched the SV upstream, so it may be undefined. If we naively
4676 concatenate it then we get a warning about use of uninitialised value.
4678 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4679 sv_catsv(buf_sv, upstream);
4683 IoLINES(datasv) = 0;
4684 SvREFCNT_dec(IoFMT_GV(datasv));
4686 SvREFCNT_dec(filter_state);
4687 IoTOP_GV(datasv) = NULL;
4690 SvREFCNT_dec(filter_sub);
4691 IoBOTTOM_GV(datasv) = NULL;
4693 filter_del(S_run_user_filter);
4695 if (status == 0 && read_from_cache) {
4696 /* If we read some data from the cache (and by getting here it implies
4697 that we emptied the cache) then we aren't yet at EOF, and mustn't
4698 report that to our caller. */
4704 /* perhaps someone can come up with a better name for
4705 this? it is not really "absolute", per se ... */
4707 S_path_is_absolute(const char *name)
4709 if (PERL_FILE_IS_ABSOLUTE(name)
4710 #ifdef MACOS_TRADITIONAL
4713 || (*name == '.' && (name[1] == '/' ||
4714 (name[1] == '.' && name[2] == '/')))
4726 * c-indentation-style: bsd
4728 * indent-tabs-mode: t
4731 * ex: set ts=8 sts=4 sw=4 noet: