3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
20 /* This file contains control-oriented pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
26 * Control-oriented means things like pp_enteriter() and pp_next(), which
27 * alter the flow of control of the program.
32 #define PERL_IN_PP_CTL_C
36 #define WORD_ALIGN sizeof(U32)
39 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
48 cxix = dopoptosub(cxstack_ix);
52 switch (cxstack[cxix].blk_gimme) {
65 /* XXXX Should store the old value to allow for tie/overload - and
66 restore in regcomp, where marked with XXXX. */
76 register PMOP *pm = (PMOP*)cLOGOP->op_other;
80 /* prevent recompiling under /o and ithreads. */
81 #if defined(USE_ITHREADS)
82 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
83 if (PL_op->op_flags & OPf_STACKED) {
92 if (PL_op->op_flags & OPf_STACKED) {
93 /* multiple args; concatentate them */
95 tmpstr = PAD_SV(ARGTARG);
96 sv_setpvn(tmpstr, "", 0);
97 while (++MARK <= SP) {
98 if (PL_amagic_generation) {
100 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
101 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
103 sv_setsv(tmpstr, sv);
107 sv_catsv(tmpstr, *MARK);
116 SV *sv = SvRV(tmpstr);
118 mg = mg_find(sv, PERL_MAGIC_qr);
121 regexp * const re = (regexp *)mg->mg_obj;
122 ReREFCNT_dec(PM_GETRE(pm));
123 PM_SETRE(pm, ReREFCNT_inc(re));
127 const char *t = SvPV_const(tmpstr, len);
129 /* Check against the last compiled regexp. */
130 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
131 PM_GETRE(pm)->prelen != (I32)len ||
132 memNE(PM_GETRE(pm)->precomp, t, len))
135 ReREFCNT_dec(PM_GETRE(pm));
136 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
138 if (PL_op->op_flags & OPf_SPECIAL)
139 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
141 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
143 pm->op_pmdynflags |= PMdf_DYN_UTF8;
145 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
146 if (pm->op_pmdynflags & PMdf_UTF8)
147 t = (char*)bytes_to_utf8((U8*)t, &len);
149 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm));
150 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
152 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
153 inside tie/overload accessors. */
157 #ifndef INCOMPLETE_TAINTS
160 pm->op_pmdynflags |= PMdf_TAINTED;
162 pm->op_pmdynflags &= ~PMdf_TAINTED;
166 if (!PM_GETRE(pm)->prelen && PL_curpm)
168 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
169 pm->op_pmflags |= PMf_WHITE;
171 pm->op_pmflags &= ~PMf_WHITE;
173 /* XXX runtime compiled output needs to move to the pad */
174 if (pm->op_pmflags & PMf_KEEP) {
175 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
176 #if !defined(USE_ITHREADS)
177 /* XXX can't change the optree at runtime either */
178 cLOGOP->op_first->op_next = PL_op->op_next;
188 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
189 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
190 register SV * const dstr = cx->sb_dstr;
191 register char *s = cx->sb_s;
192 register char *m = cx->sb_m;
193 char *orig = cx->sb_orig;
194 register REGEXP * const rx = cx->sb_rx;
196 REGEXP *old = PM_GETRE(pm);
203 rxres_restore(&cx->sb_rxres, rx);
204 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
206 if (cx->sb_iters++) {
207 const I32 saviters = cx->sb_iters;
208 if (cx->sb_iters > cx->sb_maxiters)
209 DIE(aTHX_ "Substitution loop");
211 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
212 cx->sb_rxtainted |= 2;
213 sv_catsv(dstr, POPs);
214 FREETMPS; /* Prevent excess tmp stack */
217 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
218 s == m, cx->sb_targ, NULL,
219 ((cx->sb_rflags & REXEC_COPY_STR)
220 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
221 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
223 SV * const targ = cx->sb_targ;
225 assert(cx->sb_strend >= s);
226 if(cx->sb_strend > s) {
227 if (DO_UTF8(dstr) && !SvUTF8(targ))
228 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
230 sv_catpvn(dstr, s, cx->sb_strend - s);
232 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
234 #ifdef PERL_OLD_COPY_ON_WRITE
236 sv_force_normal_flags(targ, SV_COW_DROP_PV);
242 SvPV_set(targ, SvPVX(dstr));
243 SvCUR_set(targ, SvCUR(dstr));
244 SvLEN_set(targ, SvLEN(dstr));
247 SvPV_set(dstr, NULL);
250 TAINT_IF(cx->sb_rxtainted & 1);
251 PUSHs(sv_2mortal(newSViv(saviters - 1)));
253 (void)SvPOK_only_UTF8(targ);
254 TAINT_IF(cx->sb_rxtainted);
258 LEAVE_SCOPE(cx->sb_oldsave);
261 RETURNOP(pm->op_next);
263 cx->sb_iters = saviters;
265 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
268 cx->sb_orig = orig = rx->subbeg;
270 cx->sb_strend = s + (cx->sb_strend - m);
272 cx->sb_m = m = rx->startp[0] + orig;
274 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
275 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
277 sv_catpvn(dstr, s, m-s);
279 cx->sb_s = rx->endp[0] + orig;
280 { /* Update the pos() information. */
281 SV * const sv = cx->sb_targ;
284 if (SvTYPE(sv) < SVt_PVMG)
285 SvUPGRADE(sv, SVt_PVMG);
286 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
287 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
288 mg = mg_find(sv, PERL_MAGIC_regex_global);
296 (void)ReREFCNT_inc(rx);
297 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
298 rxres_save(&cx->sb_rxres, rx);
299 RETURNOP(pm->op_pmreplstart);
303 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
309 if (!p || p[1] < rx->nparens) {
310 #ifdef PERL_OLD_COPY_ON_WRITE
311 i = 7 + rx->nparens * 2;
313 i = 6 + rx->nparens * 2;
322 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : NULL);
323 RX_MATCH_COPIED_off(rx);
325 #ifdef PERL_OLD_COPY_ON_WRITE
326 *p++ = PTR2UV(rx->saved_copy);
327 rx->saved_copy = NULL;
332 *p++ = PTR2UV(rx->subbeg);
333 *p++ = (UV)rx->sublen;
334 for (i = 0; i <= rx->nparens; ++i) {
335 *p++ = (UV)rx->startp[i];
336 *p++ = (UV)rx->endp[i];
341 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
347 RX_MATCH_COPY_FREE(rx);
348 RX_MATCH_COPIED_set(rx, *p);
351 #ifdef PERL_OLD_COPY_ON_WRITE
353 SvREFCNT_dec (rx->saved_copy);
354 rx->saved_copy = INT2PTR(SV*,*p);
360 rx->subbeg = INT2PTR(char*,*p++);
361 rx->sublen = (I32)(*p++);
362 for (i = 0; i <= rx->nparens; ++i) {
363 rx->startp[i] = (I32)(*p++);
364 rx->endp[i] = (I32)(*p++);
369 Perl_rxres_free(pTHX_ void **rsp)
371 UV * const p = (UV*)*rsp;
376 void *tmp = INT2PTR(char*,*p);
379 Poison(*p, 1, sizeof(*p));
381 Safefree(INT2PTR(char*,*p));
383 #ifdef PERL_OLD_COPY_ON_WRITE
385 SvREFCNT_dec (INT2PTR(SV*,p[1]));
395 dVAR; dSP; dMARK; dORIGMARK;
396 register SV * const tmpForm = *++MARK;
401 register SV *sv = NULL;
402 const char *item = NULL;
406 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
407 const char *chophere = NULL;
408 char *linemark = NULL;
410 bool gotsome = FALSE;
412 const STRLEN fudge = SvPOK(tmpForm)
413 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
414 bool item_is_utf8 = FALSE;
415 bool targ_is_utf8 = FALSE;
417 OP * parseres = NULL;
421 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
422 if (SvREADONLY(tmpForm)) {
423 SvREADONLY_off(tmpForm);
424 parseres = doparseform(tmpForm);
425 SvREADONLY_on(tmpForm);
428 parseres = doparseform(tmpForm);
432 SvPV_force(PL_formtarget, len);
433 if (DO_UTF8(PL_formtarget))
435 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
437 f = SvPV_const(tmpForm, len);
438 /* need to jump to the next word */
439 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
443 const char *name = "???";
446 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
447 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
448 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
449 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
450 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
452 case FF_CHECKNL: name = "CHECKNL"; break;
453 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
454 case FF_SPACE: name = "SPACE"; break;
455 case FF_HALFSPACE: name = "HALFSPACE"; break;
456 case FF_ITEM: name = "ITEM"; break;
457 case FF_CHOP: name = "CHOP"; break;
458 case FF_LINEGLOB: name = "LINEGLOB"; break;
459 case FF_NEWLINE: name = "NEWLINE"; break;
460 case FF_MORE: name = "MORE"; break;
461 case FF_LINEMARK: name = "LINEMARK"; break;
462 case FF_END: name = "END"; break;
463 case FF_0DECIMAL: name = "0DECIMAL"; break;
464 case FF_LINESNGL: name = "LINESNGL"; break;
467 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
469 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
480 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
481 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
483 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
484 t = SvEND(PL_formtarget);
487 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
488 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
490 sv_utf8_upgrade(PL_formtarget);
491 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
492 t = SvEND(PL_formtarget);
512 if (ckWARN(WARN_SYNTAX))
513 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
520 const char *s = item = SvPV_const(sv, len);
523 itemsize = sv_len_utf8(sv);
524 if (itemsize != (I32)len) {
526 if (itemsize > fieldsize) {
527 itemsize = fieldsize;
528 itembytes = itemsize;
529 sv_pos_u2b(sv, &itembytes, 0);
533 send = chophere = s + itembytes;
543 sv_pos_b2u(sv, &itemsize);
547 item_is_utf8 = FALSE;
548 if (itemsize > fieldsize)
549 itemsize = fieldsize;
550 send = chophere = s + itemsize;
564 const char *s = item = SvPV_const(sv, len);
567 itemsize = sv_len_utf8(sv);
568 if (itemsize != (I32)len) {
570 if (itemsize <= fieldsize) {
571 const char *send = chophere = s + itemsize;
584 itemsize = fieldsize;
585 itembytes = itemsize;
586 sv_pos_u2b(sv, &itembytes, 0);
587 send = chophere = s + itembytes;
588 while (s < send || (s == send && isSPACE(*s))) {
598 if (strchr(PL_chopset, *s))
603 itemsize = chophere - item;
604 sv_pos_b2u(sv, &itemsize);
610 item_is_utf8 = FALSE;
611 if (itemsize <= fieldsize) {
612 const char *const send = chophere = s + itemsize;
625 itemsize = fieldsize;
626 send = chophere = s + itemsize;
627 while (s < send || (s == send && isSPACE(*s))) {
637 if (strchr(PL_chopset, *s))
642 itemsize = chophere - item;
648 arg = fieldsize - itemsize;
657 arg = fieldsize - itemsize;
668 const char *s = item;
672 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
674 sv_utf8_upgrade(PL_formtarget);
675 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
676 t = SvEND(PL_formtarget);
680 if (UTF8_IS_CONTINUED(*s)) {
681 STRLEN skip = UTF8SKIP(s);
698 if ( !((*t++ = *s++) & ~31) )
704 if (targ_is_utf8 && !item_is_utf8) {
705 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
707 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
708 for (; t < SvEND(PL_formtarget); t++) {
721 const int ch = *t++ = *s++;
724 if ( !((*t++ = *s++) & ~31) )
733 const char *s = chophere;
751 const char *s = item = SvPV_const(sv, len);
753 if ((item_is_utf8 = DO_UTF8(sv)))
754 itemsize = sv_len_utf8(sv);
756 bool chopped = FALSE;
757 const char *const send = s + len;
759 chophere = s + itemsize;
775 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
777 SvUTF8_on(PL_formtarget);
779 SvCUR_set(sv, chophere - item);
780 sv_catsv(PL_formtarget, sv);
781 SvCUR_set(sv, itemsize);
783 sv_catsv(PL_formtarget, sv);
785 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
786 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
787 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
796 #if defined(USE_LONG_DOUBLE)
797 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
799 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
804 #if defined(USE_LONG_DOUBLE)
805 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
807 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
810 /* If the field is marked with ^ and the value is undefined,
812 if ((arg & 512) && !SvOK(sv)) {
820 /* overflow evidence */
821 if (num_overflow(value, fieldsize, arg)) {
827 /* Formats aren't yet marked for locales, so assume "yes". */
829 STORE_NUMERIC_STANDARD_SET_LOCAL();
830 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
831 RESTORE_NUMERIC_STANDARD();
838 while (t-- > linemark && *t == ' ') ;
846 if (arg) { /* repeat until fields exhausted? */
848 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
849 lines += FmLINES(PL_formtarget);
852 if (strnEQ(linemark, linemark - arg, arg))
853 DIE(aTHX_ "Runaway format");
856 SvUTF8_on(PL_formtarget);
857 FmLINES(PL_formtarget) = lines;
859 RETURNOP(cLISTOP->op_first);
870 const char *s = chophere;
871 const char *send = item + len;
873 while (isSPACE(*s) && (s < send))
878 arg = fieldsize - itemsize;
885 if (strnEQ(s1," ",3)) {
886 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
897 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
899 SvUTF8_on(PL_formtarget);
900 FmLINES(PL_formtarget) += lines;
912 if (PL_stack_base + *PL_markstack_ptr == SP) {
914 if (GIMME_V == G_SCALAR)
915 XPUSHs(sv_2mortal(newSViv(0)));
916 RETURNOP(PL_op->op_next->op_next);
918 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
919 pp_pushmark(); /* push dst */
920 pp_pushmark(); /* push src */
921 ENTER; /* enter outer scope */
924 if (PL_op->op_private & OPpGREP_LEX)
925 SAVESPTR(PAD_SVl(PL_op->op_targ));
928 ENTER; /* enter inner scope */
931 src = PL_stack_base[*PL_markstack_ptr];
933 if (PL_op->op_private & OPpGREP_LEX)
934 PAD_SVl(PL_op->op_targ) = src;
939 if (PL_op->op_type == OP_MAPSTART)
940 pp_pushmark(); /* push top */
941 return ((LOGOP*)PL_op->op_next)->op_other;
947 const I32 gimme = GIMME_V;
948 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
954 /* first, move source pointer to the next item in the source list */
955 ++PL_markstack_ptr[-1];
957 /* if there are new items, push them into the destination list */
958 if (items && gimme != G_VOID) {
959 /* might need to make room back there first */
960 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
961 /* XXX this implementation is very pessimal because the stack
962 * is repeatedly extended for every set of items. Is possible
963 * to do this without any stack extension or copying at all
964 * by maintaining a separate list over which the map iterates
965 * (like foreach does). --gsar */
967 /* everything in the stack after the destination list moves
968 * towards the end the stack by the amount of room needed */
969 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
971 /* items to shift up (accounting for the moved source pointer) */
972 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
974 /* This optimization is by Ben Tilly and it does
975 * things differently from what Sarathy (gsar)
976 * is describing. The downside of this optimization is
977 * that leaves "holes" (uninitialized and hopefully unused areas)
978 * to the Perl stack, but on the other hand this
979 * shouldn't be a problem. If Sarathy's idea gets
980 * implemented, this optimization should become
981 * irrelevant. --jhi */
983 shift = count; /* Avoid shifting too often --Ben Tilly */
988 PL_markstack_ptr[-1] += shift;
989 *PL_markstack_ptr += shift;
993 /* copy the new items down to the destination list */
994 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
995 if (gimme == G_ARRAY) {
997 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1000 /* scalar context: we don't care about which values map returns
1001 * (we use undef here). And so we certainly don't want to do mortal
1002 * copies of meaningless values. */
1003 while (items-- > 0) {
1005 *dst-- = &PL_sv_undef;
1009 LEAVE; /* exit inner scope */
1012 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1014 (void)POPMARK; /* pop top */
1015 LEAVE; /* exit outer scope */
1016 (void)POPMARK; /* pop src */
1017 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1018 (void)POPMARK; /* pop dst */
1019 SP = PL_stack_base + POPMARK; /* pop original mark */
1020 if (gimme == G_SCALAR) {
1021 if (PL_op->op_private & OPpGREP_LEX) {
1022 SV* sv = sv_newmortal();
1023 sv_setiv(sv, items);
1031 else if (gimme == G_ARRAY)
1038 ENTER; /* enter inner scope */
1041 /* set $_ to the new source item */
1042 src = PL_stack_base[PL_markstack_ptr[-1]];
1044 if (PL_op->op_private & OPpGREP_LEX)
1045 PAD_SVl(PL_op->op_targ) = src;
1049 RETURNOP(cLOGOP->op_other);
1058 if (GIMME == G_ARRAY)
1060 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1061 return cLOGOP->op_other;
1071 if (GIMME == G_ARRAY) {
1072 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1076 SV * const targ = PAD_SV(PL_op->op_targ);
1079 if (PL_op->op_private & OPpFLIP_LINENUM) {
1080 if (GvIO(PL_last_in_gv)) {
1081 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1084 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1086 flip = SvIV(sv) == SvIV(GvSV(gv));
1092 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1093 if (PL_op->op_flags & OPf_SPECIAL) {
1101 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1104 sv_setpvn(TARG, "", 0);
1110 /* This code tries to decide if "$left .. $right" should use the
1111 magical string increment, or if the range is numeric (we make
1112 an exception for .."0" [#18165]). AMS 20021031. */
1114 #define RANGE_IS_NUMERIC(left,right) ( \
1115 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1116 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1117 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1118 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1119 && (!SvOK(right) || looks_like_number(right))))
1125 if (GIMME == G_ARRAY) {
1131 if (RANGE_IS_NUMERIC(left,right)) {
1134 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1135 (SvOK(right) && SvNV(right) > IV_MAX))
1136 DIE(aTHX_ "Range iterator outside integer range");
1147 SV * const sv = sv_2mortal(newSViv(i++));
1152 SV * const final = sv_mortalcopy(right);
1154 const char * const tmps = SvPV_const(final, len);
1156 SV *sv = sv_mortalcopy(left);
1157 SvPV_force_nolen(sv);
1158 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1160 if (strEQ(SvPVX_const(sv),tmps))
1162 sv = sv_2mortal(newSVsv(sv));
1169 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1173 if (PL_op->op_private & OPpFLIP_LINENUM) {
1174 if (GvIO(PL_last_in_gv)) {
1175 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1178 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1179 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1187 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1188 sv_catpvs(targ, "E0");
1198 static const char * const context_name[] = {
1211 S_dopoptolabel(pTHX_ const char *label)
1216 for (i = cxstack_ix; i >= 0; i--) {
1217 register const PERL_CONTEXT * const cx = &cxstack[i];
1218 switch (CxTYPE(cx)) {
1226 if (ckWARN(WARN_EXITING))
1227 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1228 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1229 if (CxTYPE(cx) == CXt_NULL)
1233 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1234 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1235 (long)i, cx->blk_loop.label));
1238 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1248 Perl_dowantarray(pTHX)
1251 const I32 gimme = block_gimme();
1252 return (gimme == G_VOID) ? G_SCALAR : gimme;
1256 Perl_block_gimme(pTHX)
1259 const I32 cxix = dopoptosub(cxstack_ix);
1263 switch (cxstack[cxix].blk_gimme) {
1271 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1278 Perl_is_lvalue_sub(pTHX)
1281 const I32 cxix = dopoptosub(cxstack_ix);
1282 assert(cxix >= 0); /* We should only be called from inside subs */
1284 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1285 return cxstack[cxix].blk_sub.lval;
1291 S_dopoptosub(pTHX_ I32 startingblock)
1294 return dopoptosub_at(cxstack, startingblock);
1298 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1302 for (i = startingblock; i >= 0; i--) {
1303 register const PERL_CONTEXT * const cx = &cxstk[i];
1304 switch (CxTYPE(cx)) {
1310 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1318 S_dopoptoeval(pTHX_ I32 startingblock)
1322 for (i = startingblock; i >= 0; i--) {
1323 register const PERL_CONTEXT *cx = &cxstack[i];
1324 switch (CxTYPE(cx)) {
1328 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1336 S_dopoptoloop(pTHX_ I32 startingblock)
1340 for (i = startingblock; i >= 0; i--) {
1341 register const PERL_CONTEXT * const cx = &cxstack[i];
1342 switch (CxTYPE(cx)) {
1348 if (ckWARN(WARN_EXITING))
1349 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1350 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1351 if ((CxTYPE(cx)) == CXt_NULL)
1355 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1363 S_dopoptogiven(pTHX_ I32 startingblock)
1367 for (i = startingblock; i >= 0; i--) {
1368 register const PERL_CONTEXT *cx = &cxstack[i];
1369 switch (CxTYPE(cx)) {
1373 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1376 if (CxFOREACHDEF(cx)) {
1377 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1386 S_dopoptowhen(pTHX_ I32 startingblock)
1390 for (i = startingblock; i >= 0; i--) {
1391 register const PERL_CONTEXT *cx = &cxstack[i];
1392 switch (CxTYPE(cx)) {
1396 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1404 Perl_dounwind(pTHX_ I32 cxix)
1409 while (cxstack_ix > cxix) {
1411 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1412 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1413 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1414 /* Note: we don't need to restore the base context info till the end. */
1415 switch (CxTYPE(cx)) {
1418 continue; /* not break */
1437 PERL_UNUSED_VAR(optype);
1441 Perl_qerror(pTHX_ SV *err)
1445 sv_catsv(ERRSV, err);
1447 sv_catsv(PL_errors, err);
1449 Perl_warn(aTHX_ "%"SVf, err);
1454 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1463 if (PL_in_eval & EVAL_KEEPERR) {
1464 static const char prefix[] = "\t(in cleanup) ";
1465 SV * const err = ERRSV;
1466 const char *e = NULL;
1468 sv_setpvn(err,"",0);
1469 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1471 e = SvPV_const(err, len);
1473 if (*e != *message || strNE(e,message))
1477 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1478 sv_catpvn(err, prefix, sizeof(prefix)-1);
1479 sv_catpvn(err, message, msglen);
1480 if (ckWARN(WARN_MISC)) {
1481 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1482 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1487 sv_setpvn(ERRSV, message, msglen);
1491 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1492 && PL_curstackinfo->si_prev)
1500 register PERL_CONTEXT *cx;
1503 if (cxix < cxstack_ix)
1506 POPBLOCK(cx,PL_curpm);
1507 if (CxTYPE(cx) != CXt_EVAL) {
1509 message = SvPVx_const(ERRSV, msglen);
1510 PerlIO_write(Perl_error_log, "panic: die ", 11);
1511 PerlIO_write(Perl_error_log, message, msglen);
1516 if (gimme == G_SCALAR)
1517 *++newsp = &PL_sv_undef;
1518 PL_stack_sp = newsp;
1522 /* LEAVE could clobber PL_curcop (see save_re_context())
1523 * XXX it might be better to find a way to avoid messing with
1524 * PL_curcop in save_re_context() instead, but this is a more
1525 * minimal fix --GSAR */
1526 PL_curcop = cx->blk_oldcop;
1528 if (optype == OP_REQUIRE) {
1529 const char* const msg = SvPVx_nolen_const(ERRSV);
1530 SV * const nsv = cx->blk_eval.old_namesv;
1531 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1533 DIE(aTHX_ "%sCompilation failed in require",
1534 *msg ? msg : "Unknown error\n");
1536 assert(CxTYPE(cx) == CXt_EVAL);
1537 return cx->blk_eval.retop;
1541 message = SvPVx_const(ERRSV, msglen);
1543 write_to_stderr(message, msglen);
1551 dVAR; dSP; dPOPTOPssrl;
1552 if (SvTRUE(left) != SvTRUE(right))
1562 register I32 cxix = dopoptosub(cxstack_ix);
1563 register const PERL_CONTEXT *cx;
1564 register const PERL_CONTEXT *ccstack = cxstack;
1565 const PERL_SI *top_si = PL_curstackinfo;
1567 const char *stashname;
1574 /* we may be in a higher stacklevel, so dig down deeper */
1575 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1576 top_si = top_si->si_prev;
1577 ccstack = top_si->si_cxstack;
1578 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1581 if (GIMME != G_ARRAY) {
1587 /* caller() should not report the automatic calls to &DB::sub */
1588 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1589 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1593 cxix = dopoptosub_at(ccstack, cxix - 1);
1596 cx = &ccstack[cxix];
1597 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1598 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1599 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1600 field below is defined for any cx. */
1601 /* caller() should not report the automatic calls to &DB::sub */
1602 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1603 cx = &ccstack[dbcxix];
1606 stashname = CopSTASHPV(cx->blk_oldcop);
1607 if (GIMME != G_ARRAY) {
1610 PUSHs(&PL_sv_undef);
1613 sv_setpv(TARG, stashname);
1622 PUSHs(&PL_sv_undef);
1624 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1625 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1626 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1629 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1630 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1631 /* So is ccstack[dbcxix]. */
1633 SV * const sv = newSV(0);
1634 gv_efullname3(sv, cvgv, NULL);
1635 PUSHs(sv_2mortal(sv));
1636 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1639 PUSHs(sv_2mortal(newSVpvs("(unknown)")));
1640 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1644 PUSHs(sv_2mortal(newSVpvs("(eval)")));
1645 PUSHs(sv_2mortal(newSViv(0)));
1647 gimme = (I32)cx->blk_gimme;
1648 if (gimme == G_VOID)
1649 PUSHs(&PL_sv_undef);
1651 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1652 if (CxTYPE(cx) == CXt_EVAL) {
1654 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1655 PUSHs(cx->blk_eval.cur_text);
1659 else if (cx->blk_eval.old_namesv) {
1660 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1663 /* eval BLOCK (try blocks have old_namesv == 0) */
1665 PUSHs(&PL_sv_undef);
1666 PUSHs(&PL_sv_undef);
1670 PUSHs(&PL_sv_undef);
1671 PUSHs(&PL_sv_undef);
1673 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1674 && CopSTASH_eq(PL_curcop, PL_debstash))
1676 AV * const ary = cx->blk_sub.argarray;
1677 const int off = AvARRAY(ary) - AvALLOC(ary);
1680 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1681 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1683 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1686 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1687 av_extend(PL_dbargs, AvFILLp(ary) + off);
1688 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1689 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1691 /* XXX only hints propagated via op_private are currently
1692 * visible (others are not easily accessible, since they
1693 * use the global PL_hints) */
1694 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1695 HINT_PRIVATE_MASK)));
1698 SV * const old_warnings = cx->blk_oldcop->cop_warnings ;
1700 if (old_warnings == pWARN_NONE ||
1701 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1702 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1703 else if (old_warnings == pWARN_ALL ||
1704 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1705 /* Get the bit mask for $warnings::Bits{all}, because
1706 * it could have been extended by warnings::register */
1708 HV * const bits = get_hv("warnings::Bits", FALSE);
1709 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1710 mask = newSVsv(*bits_all);
1713 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1717 mask = newSVsv(old_warnings);
1718 PUSHs(sv_2mortal(mask));
1727 const char * const tmps = (MAXARG < 1) ? "" : POPpconstx;
1728 sv_reset(tmps, CopSTASH(PL_curcop));
1733 /* like pp_nextstate, but used instead when the debugger is active */
1738 PL_curcop = (COP*)PL_op;
1739 TAINT_NOT; /* Each statement is presumed innocent */
1740 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1743 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1744 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1747 register PERL_CONTEXT *cx;
1748 const I32 gimme = G_ARRAY;
1750 GV * const gv = PL_DBgv;
1751 register CV * const cv = GvCV(gv);
1754 DIE(aTHX_ "No DB::DB routine defined");
1756 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1757 /* don't do recursive DB::DB call */
1772 (void)(*CvXSUB(cv))(aTHX_ cv);
1779 PUSHBLOCK(cx, CXt_SUB, SP);
1781 cx->blk_sub.retop = PL_op->op_next;
1784 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1785 RETURNOP(CvSTART(cv));
1795 register PERL_CONTEXT *cx;
1796 const I32 gimme = GIMME_V;
1798 U32 cxtype = CXt_LOOP | CXp_FOREACH;
1806 if (PL_op->op_targ) {
1807 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1808 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1809 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1810 SVs_PADSTALE, SVs_PADSTALE);
1812 #ifndef USE_ITHREADS
1813 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1816 SAVEPADSV(PL_op->op_targ);
1817 iterdata = INT2PTR(void*, PL_op->op_targ);
1818 cxtype |= CXp_PADVAR;
1822 GV * const gv = (GV*)POPs;
1823 svp = &GvSV(gv); /* symbol table variable */
1824 SAVEGENERICSV(*svp);
1827 iterdata = (void*)gv;
1831 if (PL_op->op_private & OPpITER_DEF)
1832 cxtype |= CXp_FOR_DEF;
1836 PUSHBLOCK(cx, cxtype, SP);
1838 PUSHLOOP(cx, iterdata, MARK);
1840 PUSHLOOP(cx, svp, MARK);
1842 if (PL_op->op_flags & OPf_STACKED) {
1843 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1844 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1846 SV * const right = (SV*)cx->blk_loop.iterary;
1849 if (RANGE_IS_NUMERIC(sv,right)) {
1850 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1851 (SvOK(right) && SvNV(right) >= IV_MAX))
1852 DIE(aTHX_ "Range iterator outside integer range");
1853 cx->blk_loop.iterix = SvIV(sv);
1854 cx->blk_loop.itermax = SvIV(right);
1856 /* for correct -Dstv display */
1857 cx->blk_oldsp = sp - PL_stack_base;
1861 cx->blk_loop.iterlval = newSVsv(sv);
1862 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1863 (void) SvPV_nolen_const(right);
1866 else if (PL_op->op_private & OPpITER_REVERSED) {
1867 cx->blk_loop.itermax = 0;
1868 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1873 cx->blk_loop.iterary = PL_curstack;
1874 AvFILLp(PL_curstack) = SP - PL_stack_base;
1875 if (PL_op->op_private & OPpITER_REVERSED) {
1876 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1877 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1880 cx->blk_loop.iterix = MARK - PL_stack_base;
1890 register PERL_CONTEXT *cx;
1891 const I32 gimme = GIMME_V;
1897 PUSHBLOCK(cx, CXt_LOOP, SP);
1898 PUSHLOOP(cx, 0, SP);
1906 register PERL_CONTEXT *cx;
1913 assert(CxTYPE(cx) == CXt_LOOP);
1915 newsp = PL_stack_base + cx->blk_loop.resetsp;
1918 if (gimme == G_VOID)
1919 /*EMPTY*/; /* do nothing */
1920 else if (gimme == G_SCALAR) {
1922 *++newsp = sv_mortalcopy(*SP);
1924 *++newsp = &PL_sv_undef;
1928 *++newsp = sv_mortalcopy(*++mark);
1929 TAINT_NOT; /* Each item is independent */
1935 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1936 PL_curpm = newpm; /* ... and pop $1 et al */
1947 register PERL_CONTEXT *cx;
1948 bool popsub2 = FALSE;
1949 bool clear_errsv = FALSE;
1957 const I32 cxix = dopoptosub(cxstack_ix);
1960 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1961 * sort block, which is a CXt_NULL
1964 PL_stack_base[1] = *PL_stack_sp;
1965 PL_stack_sp = PL_stack_base + 1;
1969 DIE(aTHX_ "Can't return outside a subroutine");
1971 if (cxix < cxstack_ix)
1974 if (CxMULTICALL(&cxstack[cxix])) {
1975 gimme = cxstack[cxix].blk_gimme;
1976 if (gimme == G_VOID)
1977 PL_stack_sp = PL_stack_base;
1978 else if (gimme == G_SCALAR) {
1979 PL_stack_base[1] = *PL_stack_sp;
1980 PL_stack_sp = PL_stack_base + 1;
1986 switch (CxTYPE(cx)) {
1989 retop = cx->blk_sub.retop;
1990 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1993 if (!(PL_in_eval & EVAL_KEEPERR))
1996 retop = cx->blk_eval.retop;
2000 if (optype == OP_REQUIRE &&
2001 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2003 /* Unassume the success we assumed earlier. */
2004 SV * const nsv = cx->blk_eval.old_namesv;
2005 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2006 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
2011 retop = cx->blk_sub.retop;
2014 DIE(aTHX_ "panic: return");
2018 if (gimme == G_SCALAR) {
2021 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2023 *++newsp = SvREFCNT_inc(*SP);
2028 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2030 *++newsp = sv_mortalcopy(sv);
2035 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2038 *++newsp = sv_mortalcopy(*SP);
2041 *++newsp = &PL_sv_undef;
2043 else if (gimme == G_ARRAY) {
2044 while (++MARK <= SP) {
2045 *++newsp = (popsub2 && SvTEMP(*MARK))
2046 ? *MARK : sv_mortalcopy(*MARK);
2047 TAINT_NOT; /* Each item is independent */
2050 PL_stack_sp = newsp;
2053 /* Stack values are safe: */
2056 POPSUB(cx,sv); /* release CV and @_ ... */
2060 PL_curpm = newpm; /* ... and pop $1 et al */
2064 sv_setpvn(ERRSV,"",0);
2072 register PERL_CONTEXT *cx;
2083 if (PL_op->op_flags & OPf_SPECIAL) {
2084 cxix = dopoptoloop(cxstack_ix);
2086 DIE(aTHX_ "Can't \"last\" outside a loop block");
2089 cxix = dopoptolabel(cPVOP->op_pv);
2091 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2093 if (cxix < cxstack_ix)
2097 cxstack_ix++; /* temporarily protect top context */
2099 switch (CxTYPE(cx)) {
2102 newsp = PL_stack_base + cx->blk_loop.resetsp;
2103 nextop = cx->blk_loop.last_op->op_next;
2107 nextop = cx->blk_sub.retop;
2111 nextop = cx->blk_eval.retop;
2115 nextop = cx->blk_sub.retop;
2118 DIE(aTHX_ "panic: last");
2122 if (gimme == G_SCALAR) {
2124 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2125 ? *SP : sv_mortalcopy(*SP);
2127 *++newsp = &PL_sv_undef;
2129 else if (gimme == G_ARRAY) {
2130 while (++MARK <= SP) {
2131 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2132 ? *MARK : sv_mortalcopy(*MARK);
2133 TAINT_NOT; /* Each item is independent */
2141 /* Stack values are safe: */
2144 POPLOOP(cx); /* release loop vars ... */
2148 POPSUB(cx,sv); /* release CV and @_ ... */
2151 PL_curpm = newpm; /* ... and pop $1 et al */
2154 PERL_UNUSED_VAR(optype);
2155 PERL_UNUSED_VAR(gimme);
2163 register PERL_CONTEXT *cx;
2166 if (PL_op->op_flags & OPf_SPECIAL) {
2167 cxix = dopoptoloop(cxstack_ix);
2169 DIE(aTHX_ "Can't \"next\" outside a loop block");
2172 cxix = dopoptolabel(cPVOP->op_pv);
2174 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2176 if (cxix < cxstack_ix)
2179 /* clear off anything above the scope we're re-entering, but
2180 * save the rest until after a possible continue block */
2181 inner = PL_scopestack_ix;
2183 if (PL_scopestack_ix < inner)
2184 leave_scope(PL_scopestack[PL_scopestack_ix]);
2185 PL_curcop = cx->blk_oldcop;
2186 return cx->blk_loop.next_op;
2193 register PERL_CONTEXT *cx;
2197 if (PL_op->op_flags & OPf_SPECIAL) {
2198 cxix = dopoptoloop(cxstack_ix);
2200 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2203 cxix = dopoptolabel(cPVOP->op_pv);
2205 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2207 if (cxix < cxstack_ix)
2210 redo_op = cxstack[cxix].blk_loop.redo_op;
2211 if (redo_op->op_type == OP_ENTER) {
2212 /* pop one less context to avoid $x being freed in while (my $x..) */
2214 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2215 redo_op = redo_op->op_next;
2219 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2220 LEAVE_SCOPE(oldsave);
2222 PL_curcop = cx->blk_oldcop;
2227 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2231 static const char too_deep[] = "Target of goto is too deeply nested";
2234 Perl_croak(aTHX_ too_deep);
2235 if (o->op_type == OP_LEAVE ||
2236 o->op_type == OP_SCOPE ||
2237 o->op_type == OP_LEAVELOOP ||
2238 o->op_type == OP_LEAVESUB ||
2239 o->op_type == OP_LEAVETRY)
2241 *ops++ = cUNOPo->op_first;
2243 Perl_croak(aTHX_ too_deep);
2246 if (o->op_flags & OPf_KIDS) {
2248 /* First try all the kids at this level, since that's likeliest. */
2249 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2250 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2251 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2254 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2255 if (kid == PL_lastgotoprobe)
2257 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2260 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2261 ops[-1]->op_type == OP_DBSTATE)
2266 if ((o = dofindlabel(kid, label, ops, oplimit)))
2279 register PERL_CONTEXT *cx;
2280 #define GOTO_DEPTH 64
2281 OP *enterops[GOTO_DEPTH];
2282 const char *label = NULL;
2283 const bool do_dump = (PL_op->op_type == OP_DUMP);
2284 static const char must_have_label[] = "goto must have label";
2286 if (PL_op->op_flags & OPf_STACKED) {
2287 SV * const sv = POPs;
2289 /* This egregious kludge implements goto &subroutine */
2290 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2292 register PERL_CONTEXT *cx;
2293 CV* cv = (CV*)SvRV(sv);
2300 if (!CvROOT(cv) && !CvXSUB(cv)) {
2301 const GV * const gv = CvGV(cv);
2305 /* autoloaded stub? */
2306 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2308 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2309 GvNAMELEN(gv), FALSE);
2310 if (autogv && (cv = GvCV(autogv)))
2312 tmpstr = sv_newmortal();
2313 gv_efullname3(tmpstr, gv, NULL);
2314 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2316 DIE(aTHX_ "Goto undefined subroutine");
2319 /* First do some returnish stuff. */
2320 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2322 cxix = dopoptosub(cxstack_ix);
2324 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2325 if (cxix < cxstack_ix)
2329 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2330 if (CxTYPE(cx) == CXt_EVAL) {
2332 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2334 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2336 else if (CxMULTICALL(cx))
2337 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2338 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2339 /* put @_ back onto stack */
2340 AV* av = cx->blk_sub.argarray;
2342 items = AvFILLp(av) + 1;
2343 EXTEND(SP, items+1); /* @_ could have been extended. */
2344 Copy(AvARRAY(av), SP + 1, items, SV*);
2345 SvREFCNT_dec(GvAV(PL_defgv));
2346 GvAV(PL_defgv) = cx->blk_sub.savearray;
2348 /* abandon @_ if it got reified */
2353 av_extend(av, items-1);
2355 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2358 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2359 AV* const av = GvAV(PL_defgv);
2360 items = AvFILLp(av) + 1;
2361 EXTEND(SP, items+1); /* @_ could have been extended. */
2362 Copy(AvARRAY(av), SP + 1, items, SV*);
2366 if (CxTYPE(cx) == CXt_SUB &&
2367 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2368 SvREFCNT_dec(cx->blk_sub.cv);
2369 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2370 LEAVE_SCOPE(oldsave);
2372 /* Now do some callish stuff. */
2374 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2376 OP* const retop = cx->blk_sub.retop;
2381 for (index=0; index<items; index++)
2382 sv_2mortal(SP[-index]);
2385 /* XS subs don't have a CxSUB, so pop it */
2386 POPBLOCK(cx, PL_curpm);
2387 /* Push a mark for the start of arglist */
2390 (void)(*CvXSUB(cv))(aTHX_ cv);
2395 AV* const padlist = CvPADLIST(cv);
2396 if (CxTYPE(cx) == CXt_EVAL) {
2397 PL_in_eval = cx->blk_eval.old_in_eval;
2398 PL_eval_root = cx->blk_eval.old_eval_root;
2399 cx->cx_type = CXt_SUB;
2400 cx->blk_sub.hasargs = 0;
2402 cx->blk_sub.cv = cv;
2403 cx->blk_sub.olddepth = CvDEPTH(cv);
2406 if (CvDEPTH(cv) < 2)
2407 SvREFCNT_inc_void_NN(cv);
2409 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2410 sub_crush_depth(cv);
2411 pad_push(padlist, CvDEPTH(cv));
2414 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2415 if (cx->blk_sub.hasargs)
2417 AV* const av = (AV*)PAD_SVl(0);
2419 cx->blk_sub.savearray = GvAV(PL_defgv);
2420 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2421 CX_CURPAD_SAVE(cx->blk_sub);
2422 cx->blk_sub.argarray = av;
2424 if (items >= AvMAX(av) + 1) {
2425 SV **ary = AvALLOC(av);
2426 if (AvARRAY(av) != ary) {
2427 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2428 SvPV_set(av, (char*)ary);
2430 if (items >= AvMAX(av) + 1) {
2431 AvMAX(av) = items - 1;
2432 Renew(ary,items+1,SV*);
2434 SvPV_set(av, (char*)ary);
2438 Copy(mark,AvARRAY(av),items,SV*);
2439 AvFILLp(av) = items - 1;
2440 assert(!AvREAL(av));
2442 /* transfer 'ownership' of refcnts to new @_ */
2452 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2454 * We do not care about using sv to call CV;
2455 * it's for informational purposes only.
2457 SV * const sv = GvSV(PL_DBsub);
2459 if (PERLDB_SUB_NN) {
2460 const int type = SvTYPE(sv);
2461 if (type < SVt_PVIV && type != SVt_IV)
2462 sv_upgrade(sv, SVt_PVIV);
2464 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2466 gv_efullname3(sv, CvGV(cv), NULL);
2469 CV * const gotocv = get_cv("DB::goto", FALSE);
2471 PUSHMARK( PL_stack_sp );
2472 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2477 RETURNOP(CvSTART(cv));
2481 label = SvPV_nolen_const(sv);
2482 if (!(do_dump || *label))
2483 DIE(aTHX_ must_have_label);
2486 else if (PL_op->op_flags & OPf_SPECIAL) {
2488 DIE(aTHX_ must_have_label);
2491 label = cPVOP->op_pv;
2493 if (label && *label) {
2494 OP *gotoprobe = NULL;
2495 bool leaving_eval = FALSE;
2496 bool in_block = FALSE;
2497 PERL_CONTEXT *last_eval_cx = NULL;
2501 PL_lastgotoprobe = 0;
2503 for (ix = cxstack_ix; ix >= 0; ix--) {
2505 switch (CxTYPE(cx)) {
2507 leaving_eval = TRUE;
2508 if (!CxTRYBLOCK(cx)) {
2509 gotoprobe = (last_eval_cx ?
2510 last_eval_cx->blk_eval.old_eval_root :
2515 /* else fall through */
2517 gotoprobe = cx->blk_oldcop->op_sibling;
2523 gotoprobe = cx->blk_oldcop->op_sibling;
2526 gotoprobe = PL_main_root;
2529 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2530 gotoprobe = CvROOT(cx->blk_sub.cv);
2536 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2539 DIE(aTHX_ "panic: goto");
2540 gotoprobe = PL_main_root;
2544 retop = dofindlabel(gotoprobe, label,
2545 enterops, enterops + GOTO_DEPTH);
2549 PL_lastgotoprobe = gotoprobe;
2552 DIE(aTHX_ "Can't find label %s", label);
2554 /* if we're leaving an eval, check before we pop any frames
2555 that we're not going to punt, otherwise the error
2558 if (leaving_eval && *enterops && enterops[1]) {
2560 for (i = 1; enterops[i]; i++)
2561 if (enterops[i]->op_type == OP_ENTERITER)
2562 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2565 /* pop unwanted frames */
2567 if (ix < cxstack_ix) {
2574 oldsave = PL_scopestack[PL_scopestack_ix];
2575 LEAVE_SCOPE(oldsave);
2578 /* push wanted frames */
2580 if (*enterops && enterops[1]) {
2581 OP * const oldop = PL_op;
2582 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2583 for (; enterops[ix]; ix++) {
2584 PL_op = enterops[ix];
2585 /* Eventually we may want to stack the needed arguments
2586 * for each op. For now, we punt on the hard ones. */
2587 if (PL_op->op_type == OP_ENTERITER)
2588 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2589 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2597 if (!retop) retop = PL_main_start;
2599 PL_restartop = retop;
2600 PL_do_undump = TRUE;
2604 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2605 PL_do_undump = FALSE;
2622 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2624 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2627 PL_exit_flags |= PERL_EXIT_EXPECTED;
2629 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2630 if (anum || !(PL_minus_c && PL_madskills))
2635 PUSHs(&PL_sv_undef);
2642 S_save_lines(pTHX_ AV *array, SV *sv)
2644 const char *s = SvPVX_const(sv);
2645 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2648 while (s && s < send) {
2650 SV * const tmpstr = newSV(0);
2652 sv_upgrade(tmpstr, SVt_PVMG);
2653 t = strchr(s, '\n');
2659 sv_setpvn(tmpstr, s, t - s);
2660 av_store(array, line++, tmpstr);
2666 S_docatch_body(pTHX)
2674 S_docatch(pTHX_ OP *o)
2678 OP * const oldop = PL_op;
2682 assert(CATCH_GET == TRUE);
2689 assert(cxstack_ix >= 0);
2690 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2691 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2696 /* die caught by an inner eval - continue inner loop */
2698 /* NB XXX we rely on the old popped CxEVAL still being at the top
2699 * of the stack; the way die_where() currently works, this
2700 * assumption is valid. In theory The cur_top_env value should be
2701 * returned in another global, the way retop (aka PL_restartop)
2703 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2706 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2708 PL_op = PL_restartop;
2725 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2726 /* sv Text to convert to OP tree. */
2727 /* startop op_free() this to undo. */
2728 /* code Short string id of the caller. */
2730 /* FIXME - how much of this code is common with pp_entereval? */
2731 dVAR; dSP; /* Make POPBLOCK work. */
2738 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2739 char *tmpbuf = tbuf;
2742 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2748 /* switch to eval mode */
2750 if (IN_PERL_COMPILETIME) {
2751 SAVECOPSTASH_FREE(&PL_compiling);
2752 CopSTASH_set(&PL_compiling, PL_curstash);
2754 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2755 SV * const sv = sv_newmortal();
2756 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2757 code, (unsigned long)++PL_evalseq,
2758 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2763 len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
2764 (unsigned long)++PL_evalseq);
2765 SAVECOPFILE_FREE(&PL_compiling);
2766 CopFILE_set(&PL_compiling, tmpbuf+2);
2767 SAVECOPLINE(&PL_compiling);
2768 CopLINE_set(&PL_compiling, 1);
2769 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2770 deleting the eval's FILEGV from the stash before gv_check() runs
2771 (i.e. before run-time proper). To work around the coredump that
2772 ensues, we always turn GvMULTI_on for any globals that were
2773 introduced within evals. See force_ident(). GSAR 96-10-12 */
2774 safestr = savepvn(tmpbuf, len);
2775 SAVEDELETE(PL_defstash, safestr, len);
2777 #ifdef OP_IN_REGISTER
2783 /* we get here either during compilation, or via pp_regcomp at runtime */
2784 runtime = IN_PERL_RUNTIME;
2786 runcv = find_runcv(NULL);
2789 PL_op->op_type = OP_ENTEREVAL;
2790 PL_op->op_flags = 0; /* Avoid uninit warning. */
2791 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2792 PUSHEVAL(cx, 0, NULL);
2795 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2797 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2798 POPBLOCK(cx,PL_curpm);
2801 (*startop)->op_type = OP_NULL;
2802 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2804 /* XXX DAPM do this properly one year */
2805 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2807 if (IN_PERL_COMPILETIME)
2808 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2809 #ifdef OP_IN_REGISTER
2812 PERL_UNUSED_VAR(newsp);
2813 PERL_UNUSED_VAR(optype);
2820 =for apidoc find_runcv
2822 Locate the CV corresponding to the currently executing sub or eval.
2823 If db_seqp is non_null, skip CVs that are in the DB package and populate
2824 *db_seqp with the cop sequence number at the point that the DB:: code was
2825 entered. (allows debuggers to eval in the scope of the breakpoint rather
2826 than in the scope of the debugger itself).
2832 Perl_find_runcv(pTHX_ U32 *db_seqp)
2838 *db_seqp = PL_curcop->cop_seq;
2839 for (si = PL_curstackinfo; si; si = si->si_prev) {
2841 for (ix = si->si_cxix; ix >= 0; ix--) {
2842 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2843 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2844 CV * const cv = cx->blk_sub.cv;
2845 /* skip DB:: code */
2846 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2847 *db_seqp = cx->blk_oldcop->cop_seq;
2852 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2860 /* Compile a require/do, an eval '', or a /(?{...})/.
2861 * In the last case, startop is non-null, and contains the address of
2862 * a pointer that should be set to the just-compiled code.
2863 * outside is the lexically enclosing CV (if any) that invoked us.
2866 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2868 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2871 OP * const saveop = PL_op;
2873 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2874 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2879 SAVESPTR(PL_compcv);
2880 PL_compcv = (CV*)newSV(0);
2881 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2882 CvEVAL_on(PL_compcv);
2883 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2884 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2886 CvOUTSIDE_SEQ(PL_compcv) = seq;
2887 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2889 /* set up a scratch pad */
2891 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2895 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2897 /* make sure we compile in the right package */
2899 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2900 SAVESPTR(PL_curstash);
2901 PL_curstash = CopSTASH(PL_curcop);
2903 SAVESPTR(PL_beginav);
2904 PL_beginav = newAV();
2905 SAVEFREESV(PL_beginav);
2906 SAVEI32(PL_error_count);
2909 SAVEI32(PL_madskills);
2913 /* try to compile it */
2915 PL_eval_root = NULL;
2917 PL_curcop = &PL_compiling;
2918 PL_curcop->cop_arybase = 0;
2919 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2920 PL_in_eval |= EVAL_KEEPERR;
2922 sv_setpvn(ERRSV,"",0);
2923 if (yyparse() || PL_error_count || !PL_eval_root) {
2924 SV **newsp; /* Used by POPBLOCK. */
2925 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2926 I32 optype = 0; /* Might be reset by POPEVAL. */
2931 op_free(PL_eval_root);
2932 PL_eval_root = NULL;
2934 SP = PL_stack_base + POPMARK; /* pop original mark */
2936 POPBLOCK(cx,PL_curpm);
2942 msg = SvPVx_nolen_const(ERRSV);
2943 if (optype == OP_REQUIRE) {
2944 const SV * const nsv = cx->blk_eval.old_namesv;
2945 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2947 DIE(aTHX_ "%sCompilation failed in require",
2948 *msg ? msg : "Unknown error\n");
2951 POPBLOCK(cx,PL_curpm);
2953 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2954 (*msg ? msg : "Unknown error\n"));
2958 sv_setpv(ERRSV, "Compilation error");
2961 PERL_UNUSED_VAR(newsp);
2964 CopLINE_set(&PL_compiling, 0);
2966 *startop = PL_eval_root;
2968 SAVEFREEOP(PL_eval_root);
2970 /* Set the context for this new optree.
2971 * If the last op is an OP_REQUIRE, force scalar context.
2972 * Otherwise, propagate the context from the eval(). */
2973 if (PL_eval_root->op_type == OP_LEAVEEVAL
2974 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2975 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2977 scalar(PL_eval_root);
2978 else if (gimme & G_VOID)
2979 scalarvoid(PL_eval_root);
2980 else if (gimme & G_ARRAY)
2983 scalar(PL_eval_root);
2985 DEBUG_x(dump_eval());
2987 /* Register with debugger: */
2988 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2989 CV * const cv = get_cv("DB::postponed", FALSE);
2993 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2995 call_sv((SV*)cv, G_DISCARD);
2999 /* compiled okay, so do it */
3001 CvDEPTH(PL_compcv) = 1;
3002 SP = PL_stack_base + POPMARK; /* pop original mark */
3003 PL_op = saveop; /* The caller may need it. */
3004 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3006 RETURNOP(PL_eval_start);
3010 S_check_type_and_open(pTHX_ const char *name, const char *mode)
3013 const int st_rc = PerlLIO_stat(name, &st);
3014 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3018 return PerlIO_open(name, mode);
3022 S_doopen_pm(pTHX_ const char *name, const char *mode)
3024 #ifndef PERL_DISABLE_PMC
3025 const STRLEN namelen = strlen(name);
3028 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3029 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3030 const char * const pmc = SvPV_nolen_const(pmcsv);
3032 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3033 fp = check_type_and_open(name, mode);
3036 fp = check_type_and_open(pmc, mode);
3038 SvREFCNT_dec(pmcsv);
3041 fp = check_type_and_open(name, mode);
3045 return check_type_and_open(name, mode);
3046 #endif /* !PERL_DISABLE_PMC */
3052 register PERL_CONTEXT *cx;
3056 const char *tryname = NULL;
3058 const I32 gimme = GIMME_V;
3059 int filter_has_file = 0;
3060 PerlIO *tryrsfp = NULL;
3061 GV *filter_child_proc = NULL;
3062 SV *filter_state = NULL;
3063 SV *filter_sub = NULL;
3069 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3070 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3071 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3072 "v-string in use/require non-portable");
3074 sv = new_version(sv);
3075 if (!sv_derived_from(PL_patchlevel, "version"))
3076 upg_version(PL_patchlevel);
3077 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3078 if ( vcmp(sv,PL_patchlevel) < 0 )
3079 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3080 vnormal(sv), vnormal(PL_patchlevel));
3083 if ( vcmp(sv,PL_patchlevel) > 0 )
3084 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3085 vnormal(sv), vnormal(PL_patchlevel));
3090 name = SvPV_const(sv, len);
3091 if (!(name && len > 0 && *name))
3092 DIE(aTHX_ "Null filename used");
3093 TAINT_PROPER("require");
3094 if (PL_op->op_type == OP_REQUIRE) {
3095 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3097 if (*svp != &PL_sv_undef)
3100 DIE(aTHX_ "Compilation failed in require");
3104 /* prepare to compile file */
3106 if (path_is_absolute(name)) {
3108 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3110 #ifdef MACOS_TRADITIONAL
3114 MacPerl_CanonDir(name, newname, 1);
3115 if (path_is_absolute(newname)) {
3117 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3122 AV * const ar = GvAVn(PL_incgv);
3126 if ((unixname = tounixspec(name, NULL)) != NULL)
3130 for (i = 0; i <= AvFILL(ar); i++) {
3131 SV *dirsv = *av_fetch(ar, i, TRUE);
3137 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3138 && !sv_isobject(loader))
3140 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3143 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3144 PTR2UV(SvRV(dirsv)), name);
3145 tryname = SvPVX_const(namesv);
3156 if (sv_isobject(loader))
3157 count = call_method("INC", G_ARRAY);
3159 count = call_sv(loader, G_ARRAY);
3169 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3173 if (SvTYPE(arg) == SVt_PVGV) {
3174 IO *io = GvIO((GV *)arg);
3179 tryrsfp = IoIFP(io);
3180 if (IoTYPE(io) == IoTYPE_PIPE) {
3181 /* reading from a child process doesn't
3182 nest -- when returning from reading
3183 the inner module, the outer one is
3184 unreadable (closed?) I've tried to
3185 save the gv to manage the lifespan of
3186 the pipe, but this didn't help. XXX */
3187 filter_child_proc = (GV *)arg;
3188 SvREFCNT_inc_simple_void(filter_child_proc);
3191 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3192 PerlIO_close(IoOFP(io));
3204 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3206 SvREFCNT_inc_void_NN(filter_sub);
3209 filter_state = SP[i];
3210 SvREFCNT_inc_simple_void(filter_state);
3214 tryrsfp = PerlIO_open("/dev/null", PERL_SCRIPT_MODE);
3229 filter_has_file = 0;
3230 if (filter_child_proc) {
3231 SvREFCNT_dec(filter_child_proc);
3232 filter_child_proc = NULL;
3235 SvREFCNT_dec(filter_state);
3236 filter_state = NULL;
3239 SvREFCNT_dec(filter_sub);
3244 if (!path_is_absolute(name)
3245 #ifdef MACOS_TRADITIONAL
3246 /* We consider paths of the form :a:b ambiguous and interpret them first
3247 as global then as local
3249 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3252 const char *dir = SvPVx_nolen_const(dirsv);
3253 #ifdef MACOS_TRADITIONAL
3257 MacPerl_CanonDir(name, buf2, 1);
3258 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3262 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3264 sv_setpv(namesv, unixdir);
3265 sv_catpv(namesv, unixname);
3267 # ifdef __SYMBIAN32__
3268 if (PL_origfilename[0] &&
3269 PL_origfilename[1] == ':' &&
3270 !(dir[0] && dir[1] == ':'))
3271 Perl_sv_setpvf(aTHX_ namesv,
3276 Perl_sv_setpvf(aTHX_ namesv,
3280 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3284 TAINT_PROPER("require");
3285 tryname = SvPVX_const(namesv);
3286 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3288 if (tryname[0] == '.' && tryname[1] == '/')
3297 SAVECOPFILE_FREE(&PL_compiling);
3298 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3299 SvREFCNT_dec(namesv);
3301 if (PL_op->op_type == OP_REQUIRE) {
3302 const char *msgstr = name;
3303 if(errno == EMFILE) {
3305 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3307 msgstr = SvPV_nolen_const(msg);
3309 if (namesv) { /* did we lookup @INC? */
3310 AV * const ar = GvAVn(PL_incgv);
3312 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3313 "%s in @INC%s%s (@INC contains:",
3315 (instr(msgstr, ".h ")
3316 ? " (change .h to .ph maybe?)" : ""),
3317 (instr(msgstr, ".ph ")
3318 ? " (did you run h2ph?)" : "")
3321 for (i = 0; i <= AvFILL(ar); i++) {
3322 sv_catpvs(msg, " ");
3323 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3325 sv_catpvs(msg, ")");
3326 msgstr = SvPV_nolen_const(msg);
3329 DIE(aTHX_ "Can't locate %s", msgstr);
3335 SETERRNO(0, SS_NORMAL);
3337 /* Assume success here to prevent recursive requirement. */
3338 /* name is never assigned to again, so len is still strlen(name) */
3339 /* Check whether a hook in @INC has already filled %INC */
3341 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3343 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3345 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc_simple(hook_sv), 0 );
3350 lex_start(sv_2mortal(newSVpvs("")));
3351 SAVEGENERICSV(PL_rsfp_filters);
3352 PL_rsfp_filters = NULL;
3357 SAVESPTR(PL_compiling.cop_warnings);
3358 if (PL_dowarn & G_WARN_ALL_ON)
3359 PL_compiling.cop_warnings = pWARN_ALL ;
3360 else if (PL_dowarn & G_WARN_ALL_OFF)
3361 PL_compiling.cop_warnings = pWARN_NONE ;
3362 else if (PL_taint_warn)
3363 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3365 PL_compiling.cop_warnings = pWARN_STD ;
3366 SAVESPTR(PL_compiling.cop_io);
3367 PL_compiling.cop_io = NULL;
3369 if (filter_sub || filter_child_proc) {
3370 SV * const datasv = filter_add(S_run_user_filter, NULL);
3371 IoLINES(datasv) = filter_has_file;
3372 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3373 IoTOP_GV(datasv) = (GV *)filter_state;
3374 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3377 /* switch to eval mode */
3378 PUSHBLOCK(cx, CXt_EVAL, SP);
3379 PUSHEVAL(cx, name, NULL);
3380 cx->blk_eval.retop = PL_op->op_next;
3382 SAVECOPLINE(&PL_compiling);
3383 CopLINE_set(&PL_compiling, 0);
3387 /* Store and reset encoding. */
3388 encoding = PL_encoding;
3391 op = DOCATCH(doeval(gimme, NULL, NULL, PL_curcop->cop_seq));
3393 /* Restore encoding. */
3394 PL_encoding = encoding;
3402 register PERL_CONTEXT *cx;
3404 const I32 gimme = GIMME_V;
3405 const I32 was = PL_sub_generation;
3406 char tbuf[TYPE_DIGITS(long) + 12];
3407 char *tmpbuf = tbuf;
3413 HV *saved_hh = NULL;
3415 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3416 saved_hh = (HV*) SvREFCNT_inc(POPs);
3420 if (!SvPV_nolen_const(sv))
3422 TAINT_PROPER("eval");
3428 /* switch to eval mode */
3430 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3431 SV * const temp_sv = sv_newmortal();
3432 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3433 (unsigned long)++PL_evalseq,
3434 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3435 tmpbuf = SvPVX(temp_sv);
3436 len = SvCUR(temp_sv);
3439 len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3440 SAVECOPFILE_FREE(&PL_compiling);
3441 CopFILE_set(&PL_compiling, tmpbuf+2);
3442 SAVECOPLINE(&PL_compiling);
3443 CopLINE_set(&PL_compiling, 1);
3444 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3445 deleting the eval's FILEGV from the stash before gv_check() runs
3446 (i.e. before run-time proper). To work around the coredump that
3447 ensues, we always turn GvMULTI_on for any globals that were
3448 introduced within evals. See force_ident(). GSAR 96-10-12 */
3449 safestr = savepvn(tmpbuf, len);
3450 SAVEDELETE(PL_defstash, safestr, len);
3452 PL_hints = PL_op->op_targ;
3454 GvHV(PL_hintgv) = saved_hh;
3455 SAVESPTR(PL_compiling.cop_warnings);
3456 if (specialWARN(PL_curcop->cop_warnings))
3457 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3459 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3460 SAVEFREESV(PL_compiling.cop_warnings);
3462 SAVESPTR(PL_compiling.cop_io);
3463 if (specialCopIO(PL_curcop->cop_io))
3464 PL_compiling.cop_io = PL_curcop->cop_io;
3466 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3467 SAVEFREESV(PL_compiling.cop_io);
3469 /* special case: an eval '' executed within the DB package gets lexically
3470 * placed in the first non-DB CV rather than the current CV - this
3471 * allows the debugger to execute code, find lexicals etc, in the
3472 * scope of the code being debugged. Passing &seq gets find_runcv
3473 * to do the dirty work for us */
3474 runcv = find_runcv(&seq);
3476 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3477 PUSHEVAL(cx, 0, NULL);
3478 cx->blk_eval.retop = PL_op->op_next;
3480 /* prepare to compile string */
3482 if (PERLDB_LINE && PL_curstash != PL_debstash)
3483 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3485 ret = doeval(gimme, NULL, runcv, seq);
3486 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3487 && ret != PL_op->op_next) { /* Successive compilation. */
3488 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3490 return DOCATCH(ret);
3500 register PERL_CONTEXT *cx;
3502 const U8 save_flags = PL_op -> op_flags;
3507 retop = cx->blk_eval.retop;
3510 if (gimme == G_VOID)
3512 else if (gimme == G_SCALAR) {
3515 if (SvFLAGS(TOPs) & SVs_TEMP)
3518 *MARK = sv_mortalcopy(TOPs);
3522 *MARK = &PL_sv_undef;
3527 /* in case LEAVE wipes old return values */
3528 for (mark = newsp + 1; mark <= SP; mark++) {
3529 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3530 *mark = sv_mortalcopy(*mark);
3531 TAINT_NOT; /* Each item is independent */
3535 PL_curpm = newpm; /* Don't pop $1 et al till now */
3538 assert(CvDEPTH(PL_compcv) == 1);
3540 CvDEPTH(PL_compcv) = 0;
3543 if (optype == OP_REQUIRE &&
3544 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3546 /* Unassume the success we assumed earlier. */
3547 SV * const nsv = cx->blk_eval.old_namesv;
3548 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3549 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3550 /* die_where() did LEAVE, or we won't be here */
3554 if (!(save_flags & OPf_SPECIAL))
3555 sv_setpvn(ERRSV,"",0);
3564 register PERL_CONTEXT *cx;
3565 const I32 gimme = GIMME_V;
3570 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3572 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3574 PL_in_eval = EVAL_INEVAL;
3575 sv_setpvn(ERRSV,"",0);
3577 return DOCATCH(PL_op->op_next);
3586 register PERL_CONTEXT *cx;
3591 PERL_UNUSED_VAR(optype);
3594 if (gimme == G_VOID)
3596 else if (gimme == G_SCALAR) {
3600 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3603 *MARK = sv_mortalcopy(TOPs);
3607 *MARK = &PL_sv_undef;
3612 /* in case LEAVE wipes old return values */
3614 for (mark = newsp + 1; mark <= SP; mark++) {
3615 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3616 *mark = sv_mortalcopy(*mark);
3617 TAINT_NOT; /* Each item is independent */
3621 PL_curpm = newpm; /* Don't pop $1 et al till now */
3624 sv_setpvn(ERRSV,"",0);
3631 register PERL_CONTEXT *cx;
3632 const I32 gimme = GIMME_V;
3637 if (PL_op->op_targ == 0) {
3638 SV ** const defsv_p = &GvSV(PL_defgv);
3639 *defsv_p = newSVsv(POPs);
3640 SAVECLEARSV(*defsv_p);
3643 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3645 PUSHBLOCK(cx, CXt_GIVEN, SP);
3654 register PERL_CONTEXT *cx;
3658 PERL_UNUSED_CONTEXT;
3661 assert(CxTYPE(cx) == CXt_GIVEN);
3666 PL_curpm = newpm; /* pop $1 et al */
3673 /* Helper routines used by pp_smartmatch */
3676 S_make_matcher(pTHX_ regexp *re)
3679 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3680 PM_SETRE(matcher, ReREFCNT_inc(re));
3682 SAVEFREEOP((OP *) matcher);
3690 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3695 PL_op = (OP *) matcher;
3700 return (SvTRUEx(POPs));
3705 S_destroy_matcher(pTHX_ PMOP *matcher)
3708 PERL_UNUSED_ARG(matcher);
3713 /* Do a smart match */
3716 return do_smartmatch(NULL, NULL);
3719 /* This version of do_smartmatch() implements the following
3720 table of smart matches:
3722 $a $b Type of Match Implied Matching Code
3723 ====== ===== ===================== =============
3724 (overloading trumps everything)
3726 Code[+] Code[+] referential equality match if refaddr($a) == refaddr($b)
3727 Any Code[+] scalar sub truth match if $b->($a)
3729 Hash Hash hash keys identical match if sort(keys(%$a)) ÈeqÇ sort(keys(%$b))
3730 Hash Array hash value slice truth match if $a->{any(@$b)}
3731 Hash Regex hash key grep match if any(keys(%$a)) =~ /$b/
3732 Hash Any hash entry existence match if exists $a->{$b}
3734 Array Array arrays are identical[*] match if $a È~~Ç $b
3735 Array Regex array grep match if any(@$a) =~ /$b/
3736 Array Num array contains number match if any($a) == $b
3737 Array Any array contains string match if any($a) eq $b
3739 Any undef undefined match if !defined $a
3740 Any Regex pattern match match if $a =~ /$b/
3741 Code() Code() results are equal match if $a->() eq $b->()
3742 Any Code() simple closure truth match if $b->() (ignoring $a)
3743 Num numish[!] numeric equality match if $a == $b
3744 Any Str string equality match if $a eq $b
3745 Any Num numeric equality match if $a == $b
3747 Any Any string equality match if $a eq $b
3750 + - this must be a code reference whose prototype (if present) is not ""
3751 (subs with a "" prototype are dealt with by the 'Code()' entry lower down)
3752 * - if a circular reference is found, we fall back to referential equality
3753 ! - either a real number, or a string that looks_like_number()
3758 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3763 SV *e = TOPs; /* e is for 'expression' */
3764 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3767 regexp *this_regex, *other_regex;
3769 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3771 # define SM_REF(type) ( \
3772 (SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_##type) && (other = e)) \
3773 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_##type) && (other = d)))
3775 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3776 ((SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_PVCV) \
3777 && NOT_EMPTY_PROTO(this) && (other = e)) \
3778 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_PVCV) \
3779 && NOT_EMPTY_PROTO(this) && (other = d)))
3781 # define SM_REGEX ( \
3782 (SvROK(d) && SvMAGICAL(this = SvRV(d)) \
3783 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3784 && (this_regex = (regexp *)mg->mg_obj) \
3787 (SvROK(e) && SvMAGICAL(this = SvRV(e)) \
3788 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3789 && (this_regex = (regexp *)mg->mg_obj) \
3793 # define SM_OTHER_REF(type) \
3794 (SvROK(other) && SvTYPE(SvRV(other)) == SVt_##type)
3796 # define SM_OTHER_REGEX (SvROK(other) && SvMAGICAL(SvRV(other)) \
3797 && (mg = mg_find(SvRV(other), PERL_MAGIC_qr)) \
3798 && (other_regex = (regexp *)mg->mg_obj))
3801 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3802 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3804 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3805 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3807 tryAMAGICbinSET(smart, 0);
3809 SP -= 2; /* Pop the values */
3811 /* Take care only to invoke mg_get() once for each argument.
3812 * Currently we do this by copying the SV if it's magical. */
3815 d = sv_mortalcopy(d);
3822 e = sv_mortalcopy(e);
3827 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(other)) )
3829 if (this == SvRV(other))
3840 c = call_sv(this, G_SCALAR);
3844 else if (SvTEMP(TOPs))
3850 else if (SM_REF(PVHV)) {
3851 if (SM_OTHER_REF(PVHV)) {
3852 /* Check that the key-sets are identical */
3854 HV *other_hv = (HV *) SvRV(other);
3856 bool other_tied = FALSE;
3857 U32 this_key_count = 0,
3858 other_key_count = 0;
3860 /* Tied hashes don't know how many keys they have. */
3861 if (SvTIED_mg(this, PERL_MAGIC_tied)) {
3864 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3865 HV * const temp = other_hv;
3866 other_hv = (HV *) this;
3870 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3873 if (!tied && HvUSEDKEYS((HV *) this) != HvUSEDKEYS(other_hv))
3876 /* The hashes have the same number of keys, so it suffices
3877 to check that one is a subset of the other. */
3878 (void) hv_iterinit((HV *) this);
3879 while ( (he = hv_iternext((HV *) this)) ) {
3881 char * const key = hv_iterkey(he, &key_len);
3885 if(!hv_exists(other_hv, key, key_len)) {
3886 (void) hv_iterinit((HV *) this); /* reset iterator */
3892 (void) hv_iterinit(other_hv);
3893 while ( hv_iternext(other_hv) )
3897 other_key_count = HvUSEDKEYS(other_hv);
3899 if (this_key_count != other_key_count)
3904 else if (SM_OTHER_REF(PVAV)) {
3905 AV * const other_av = (AV *) SvRV(other);
3906 const I32 other_len = av_len(other_av) + 1;
3909 if (HvUSEDKEYS((HV *) this) != other_len)
3912 for(i = 0; i < other_len; ++i) {
3913 SV ** const svp = av_fetch(other_av, i, FALSE);
3917 if (!svp) /* ??? When can this happen? */
3920 key = SvPV(*svp, key_len);
3921 if(!hv_exists((HV *) this, key, key_len))
3926 else if (SM_OTHER_REGEX) {
3927 PMOP * const matcher = make_matcher(other_regex);
3930 (void) hv_iterinit((HV *) this);
3931 while ( (he = hv_iternext((HV *) this)) ) {
3932 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
3933 (void) hv_iterinit((HV *) this);
3934 destroy_matcher(matcher);
3938 destroy_matcher(matcher);
3942 if (hv_exists_ent((HV *) this, other, 0))
3948 else if (SM_REF(PVAV)) {
3949 if (SM_OTHER_REF(PVAV)) {
3950 AV *other_av = (AV *) SvRV(other);
3951 if (av_len((AV *) this) != av_len(other_av))
3955 const I32 other_len = av_len(other_av);
3957 if (NULL == seen_this) {
3958 seen_this = newHV();
3959 (void) sv_2mortal((SV *) seen_this);
3961 if (NULL == seen_other) {
3962 seen_this = newHV();
3963 (void) sv_2mortal((SV *) seen_other);
3965 for(i = 0; i <= other_len; ++i) {
3966 SV * const * const this_elem = av_fetch((AV *)this, i, FALSE);
3967 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
3969 if (!this_elem || !other_elem) {
3970 if (this_elem || other_elem)
3973 else if (SM_SEEN_THIS(*this_elem)
3974 || SM_SEEN_OTHER(*other_elem))
3976 if (*this_elem != *other_elem)
3980 hv_store_ent(seen_this,
3981 sv_2mortal(newSViv(PTR2IV(*this_elem))),
3983 hv_store_ent(seen_other,
3984 sv_2mortal(newSViv(PTR2IV(*other_elem))),
3990 (void) do_smartmatch(seen_this, seen_other);
4000 else if (SM_OTHER_REGEX) {
4001 PMOP * const matcher = make_matcher(other_regex);
4002 const I32 this_len = av_len((AV *) this);
4005 for(i = 0; i <= this_len; ++i) {
4006 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4007 if (svp && matcher_matches_sv(matcher, *svp)) {
4008 destroy_matcher(matcher);
4012 destroy_matcher(matcher);
4015 else if (SvIOK(other) || SvNOK(other)) {
4018 for(i = 0; i <= AvFILL((AV *) this); ++i) {
4019 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4026 if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
4036 else if (SvPOK(other)) {
4037 const I32 this_len = av_len((AV *) this);
4040 for(i = 0; i <= this_len; ++i) {
4041 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4056 else if (!SvOK(d) || !SvOK(e)) {
4057 if (!SvOK(d) && !SvOK(e))
4062 else if (SM_REGEX) {
4063 PMOP * const matcher = make_matcher(this_regex);
4066 PUSHs(matcher_matches_sv(matcher, other)
4069 destroy_matcher(matcher);
4072 else if (SM_REF(PVCV)) {
4074 /* This must be a null-prototyped sub, because we
4075 already checked for the other kind. */
4081 c = call_sv(this, G_SCALAR);
4084 PUSHs(&PL_sv_undef);
4085 else if (SvTEMP(TOPs))
4088 if (SM_OTHER_REF(PVCV)) {
4089 /* This one has to be null-proto'd too.
4090 Call both of 'em, and compare the results */
4092 c = call_sv(SvRV(other), G_SCALAR);
4095 PUSHs(&PL_sv_undef);
4096 else if (SvTEMP(TOPs))
4108 else if ( ((SvIOK(d) || SvNOK(d)) && (this = d) && (other = e))
4109 || ((SvIOK(e) || SvNOK(e)) && (this = e) && (other = d)) )
4111 if (SvPOK(other) && !looks_like_number(other)) {
4112 /* String comparison */
4117 /* Otherwise, numeric comparison */
4120 if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
4131 /* As a last resort, use string comparison */
4140 register PERL_CONTEXT *cx;
4141 const I32 gimme = GIMME_V;
4143 /* This is essentially an optimization: if the match
4144 fails, we don't want to push a context and then
4145 pop it again right away, so we skip straight
4146 to the op that follows the leavewhen.
4148 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4149 return cLOGOP->op_other->op_next;
4154 PUSHBLOCK(cx, CXt_WHEN, SP);
4163 register PERL_CONTEXT *cx;
4169 assert(CxTYPE(cx) == CXt_WHEN);
4174 PL_curpm = newpm; /* pop $1 et al */
4184 register PERL_CONTEXT *cx;
4187 cxix = dopoptowhen(cxstack_ix);
4189 DIE(aTHX_ "Can't \"continue\" outside a when block");
4190 if (cxix < cxstack_ix)
4193 /* clear off anything above the scope we're re-entering */
4194 inner = PL_scopestack_ix;
4196 if (PL_scopestack_ix < inner)
4197 leave_scope(PL_scopestack[PL_scopestack_ix]);
4198 PL_curcop = cx->blk_oldcop;
4199 return cx->blk_givwhen.leave_op;
4206 register PERL_CONTEXT *cx;
4209 cxix = dopoptogiven(cxstack_ix);
4211 if (PL_op->op_flags & OPf_SPECIAL)
4212 DIE(aTHX_ "Can't use when() outside a topicalizer");
4214 DIE(aTHX_ "Can't \"break\" outside a given block");
4216 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4217 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4219 if (cxix < cxstack_ix)
4222 /* clear off anything above the scope we're re-entering */
4223 inner = PL_scopestack_ix;
4225 if (PL_scopestack_ix < inner)
4226 leave_scope(PL_scopestack[PL_scopestack_ix]);
4227 PL_curcop = cx->blk_oldcop;
4230 return cx->blk_loop.next_op;
4232 return cx->blk_givwhen.leave_op;
4236 S_doparseform(pTHX_ SV *sv)
4239 register char *s = SvPV_force(sv, len);
4240 register char * const send = s + len;
4241 register char *base = NULL;
4242 register I32 skipspaces = 0;
4243 bool noblank = FALSE;
4244 bool repeat = FALSE;
4245 bool postspace = FALSE;
4251 bool unchopnum = FALSE;
4252 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4255 Perl_croak(aTHX_ "Null picture in formline");
4257 /* estimate the buffer size needed */
4258 for (base = s; s <= send; s++) {
4259 if (*s == '\n' || *s == '@' || *s == '^')
4265 Newx(fops, maxops, U32);
4270 *fpc++ = FF_LINEMARK;
4271 noblank = repeat = FALSE;
4289 case ' ': case '\t':
4296 } /* else FALL THROUGH */
4304 *fpc++ = FF_LITERAL;
4312 *fpc++ = (U16)skipspaces;
4316 *fpc++ = FF_NEWLINE;
4320 arg = fpc - linepc + 1;
4327 *fpc++ = FF_LINEMARK;
4328 noblank = repeat = FALSE;
4337 ischop = s[-1] == '^';
4343 arg = (s - base) - 1;
4345 *fpc++ = FF_LITERAL;
4353 *fpc++ = 2; /* skip the @* or ^* */
4355 *fpc++ = FF_LINESNGL;
4358 *fpc++ = FF_LINEGLOB;
4360 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4361 arg = ischop ? 512 : 0;
4366 const char * const f = ++s;
4369 arg |= 256 + (s - f);
4371 *fpc++ = s - base; /* fieldsize for FETCH */
4372 *fpc++ = FF_DECIMAL;
4374 unchopnum |= ! ischop;
4376 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4377 arg = ischop ? 512 : 0;
4379 s++; /* skip the '0' first */
4383 const char * const f = ++s;
4386 arg |= 256 + (s - f);
4388 *fpc++ = s - base; /* fieldsize for FETCH */
4389 *fpc++ = FF_0DECIMAL;
4391 unchopnum |= ! ischop;
4395 bool ismore = FALSE;
4398 while (*++s == '>') ;
4399 prespace = FF_SPACE;
4401 else if (*s == '|') {
4402 while (*++s == '|') ;
4403 prespace = FF_HALFSPACE;
4408 while (*++s == '<') ;
4411 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4415 *fpc++ = s - base; /* fieldsize for FETCH */
4417 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4420 *fpc++ = (U16)prespace;
4434 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4436 { /* need to jump to the next word */
4438 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4439 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4440 s = SvPVX(sv) + SvCUR(sv) + z;
4442 Copy(fops, s, arg, U32);
4444 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4447 if (unchopnum && repeat)
4448 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4454 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4456 /* Can value be printed in fldsize chars, using %*.*f ? */
4460 int intsize = fldsize - (value < 0 ? 1 : 0);
4467 while (intsize--) pwr *= 10.0;
4468 while (frcsize--) eps /= 10.0;
4471 if (value + eps >= pwr)
4474 if (value - eps <= -pwr)
4481 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4484 SV * const datasv = FILTER_DATA(idx);
4485 const int filter_has_file = IoLINES(datasv);
4486 GV * const filter_child_proc = (GV *)IoFMT_GV(datasv);
4487 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4488 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4491 /* I was having segfault trouble under Linux 2.2.5 after a
4492 parse error occured. (Had to hack around it with a test
4493 for PL_error_count == 0.) Solaris doesn't segfault --
4494 not sure where the trouble is yet. XXX */
4496 if (filter_has_file) {
4497 len = FILTER_READ(idx+1, buf_sv, maxlen);
4500 if (filter_sub && len >= 0) {
4511 PUSHs(sv_2mortal(newSViv(maxlen)));
4513 PUSHs(filter_state);
4516 count = call_sv(filter_sub, G_SCALAR);
4532 IoLINES(datasv) = 0;
4533 if (filter_child_proc) {
4534 SvREFCNT_dec(filter_child_proc);
4535 IoFMT_GV(datasv) = NULL;
4538 SvREFCNT_dec(filter_state);
4539 IoTOP_GV(datasv) = NULL;
4542 SvREFCNT_dec(filter_sub);
4543 IoBOTTOM_GV(datasv) = NULL;
4545 filter_del(S_run_user_filter);
4551 /* perhaps someone can come up with a better name for
4552 this? it is not really "absolute", per se ... */
4554 S_path_is_absolute(const char *name)
4556 if (PERL_FILE_IS_ABSOLUTE(name)
4557 #ifdef MACOS_TRADITIONAL
4560 || (*name == '.' && (name[1] == '/' ||
4561 (name[1] == '.' && name[2] == '/')))
4573 * c-indentation-style: bsd
4575 * indent-tabs-mode: t
4578 * ex: set ts=8 sts=4 sw=4 noet: