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);
3018 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3019 Perl_die(aTHX_ "%s %s not allowed in require",
3020 S_ISDIR(st.st_mode) ? "Directory" : "Block device", name);
3022 return PerlIO_open(name, mode);
3026 S_doopen_pm(pTHX_ const char *name, const char *mode)
3028 #ifndef PERL_DISABLE_PMC
3029 const STRLEN namelen = strlen(name);
3032 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3033 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3034 const char * const pmc = SvPV_nolen_const(pmcsv);
3036 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3037 fp = check_type_and_open(name, mode);
3041 if (PerlLIO_stat(name, &pmstat) < 0 ||
3042 pmstat.st_mtime < pmcstat.st_mtime)
3044 fp = check_type_and_open(pmc, mode);
3047 fp = check_type_and_open(name, mode);
3050 SvREFCNT_dec(pmcsv);
3053 fp = check_type_and_open(name, mode);
3057 return check_type_and_open(name, mode);
3058 #endif /* !PERL_DISABLE_PMC */
3064 register PERL_CONTEXT *cx;
3068 const char *tryname = NULL;
3070 const I32 gimme = GIMME_V;
3071 int filter_has_file = 0;
3072 PerlIO *tryrsfp = NULL;
3073 GV *filter_child_proc = NULL;
3074 SV *filter_state = NULL;
3075 SV *filter_sub = NULL;
3081 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3082 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3083 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3084 "v-string in use/require non-portable");
3086 sv = new_version(sv);
3087 if (!sv_derived_from(PL_patchlevel, "version"))
3088 upg_version(PL_patchlevel);
3089 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3090 if ( vcmp(sv,PL_patchlevel) < 0 )
3091 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3092 vnormal(sv), vnormal(PL_patchlevel));
3095 if ( vcmp(sv,PL_patchlevel) > 0 )
3096 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3097 vnormal(sv), vnormal(PL_patchlevel));
3102 name = SvPV_const(sv, len);
3103 if (!(name && len > 0 && *name))
3104 DIE(aTHX_ "Null filename used");
3105 TAINT_PROPER("require");
3106 if (PL_op->op_type == OP_REQUIRE) {
3107 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3109 if (*svp != &PL_sv_undef)
3112 DIE(aTHX_ "Compilation failed in require");
3116 /* prepare to compile file */
3118 if (path_is_absolute(name)) {
3120 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3122 #ifdef MACOS_TRADITIONAL
3126 MacPerl_CanonDir(name, newname, 1);
3127 if (path_is_absolute(newname)) {
3129 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3134 AV * const ar = GvAVn(PL_incgv);
3138 if ((unixname = tounixspec(name, NULL)) != NULL)
3142 for (i = 0; i <= AvFILL(ar); i++) {
3143 SV *dirsv = *av_fetch(ar, i, TRUE);
3149 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3150 && !sv_isobject(loader))
3152 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3155 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3156 PTR2UV(SvRV(dirsv)), name);
3157 tryname = SvPVX_const(namesv);
3168 if (sv_isobject(loader))
3169 count = call_method("INC", G_ARRAY);
3171 count = call_sv(loader, G_ARRAY);
3181 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3185 if (SvTYPE(arg) == SVt_PVGV) {
3186 IO *io = GvIO((GV *)arg);
3191 tryrsfp = IoIFP(io);
3192 if (IoTYPE(io) == IoTYPE_PIPE) {
3193 /* reading from a child process doesn't
3194 nest -- when returning from reading
3195 the inner module, the outer one is
3196 unreadable (closed?) I've tried to
3197 save the gv to manage the lifespan of
3198 the pipe, but this didn't help. XXX */
3199 filter_child_proc = (GV *)arg;
3200 SvREFCNT_inc_simple_void(filter_child_proc);
3203 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3204 PerlIO_close(IoOFP(io));
3216 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3218 SvREFCNT_inc_void_NN(filter_sub);
3221 filter_state = SP[i];
3222 SvREFCNT_inc_simple_void(filter_state);
3226 tryrsfp = PerlIO_open("/dev/null", PERL_SCRIPT_MODE);
3241 filter_has_file = 0;
3242 if (filter_child_proc) {
3243 SvREFCNT_dec(filter_child_proc);
3244 filter_child_proc = NULL;
3247 SvREFCNT_dec(filter_state);
3248 filter_state = NULL;
3251 SvREFCNT_dec(filter_sub);
3256 if (!path_is_absolute(name)
3257 #ifdef MACOS_TRADITIONAL
3258 /* We consider paths of the form :a:b ambiguous and interpret them first
3259 as global then as local
3261 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3264 const char *dir = SvPVx_nolen_const(dirsv);
3265 #ifdef MACOS_TRADITIONAL
3269 MacPerl_CanonDir(name, buf2, 1);
3270 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3274 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3276 sv_setpv(namesv, unixdir);
3277 sv_catpv(namesv, unixname);
3279 # ifdef __SYMBIAN32__
3280 if (PL_origfilename[0] &&
3281 PL_origfilename[1] == ':' &&
3282 !(dir[0] && dir[1] == ':'))
3283 Perl_sv_setpvf(aTHX_ namesv,
3288 Perl_sv_setpvf(aTHX_ namesv,
3292 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3296 TAINT_PROPER("require");
3297 tryname = SvPVX_const(namesv);
3298 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3300 if (tryname[0] == '.' && tryname[1] == '/')
3309 SAVECOPFILE_FREE(&PL_compiling);
3310 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3311 SvREFCNT_dec(namesv);
3313 if (PL_op->op_type == OP_REQUIRE) {
3314 const char *msgstr = name;
3315 if(errno == EMFILE) {
3317 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3319 msgstr = SvPV_nolen_const(msg);
3321 if (namesv) { /* did we lookup @INC? */
3322 AV * const ar = GvAVn(PL_incgv);
3324 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3325 "%s in @INC%s%s (@INC contains:",
3327 (instr(msgstr, ".h ")
3328 ? " (change .h to .ph maybe?)" : ""),
3329 (instr(msgstr, ".ph ")
3330 ? " (did you run h2ph?)" : "")
3333 for (i = 0; i <= AvFILL(ar); i++) {
3334 sv_catpvs(msg, " ");
3335 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3337 sv_catpvs(msg, ")");
3338 msgstr = SvPV_nolen_const(msg);
3341 DIE(aTHX_ "Can't locate %s", msgstr);
3347 SETERRNO(0, SS_NORMAL);
3349 /* Assume success here to prevent recursive requirement. */
3350 /* name is never assigned to again, so len is still strlen(name) */
3351 /* Check whether a hook in @INC has already filled %INC */
3353 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3355 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3357 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc_simple(hook_sv), 0 );
3362 lex_start(sv_2mortal(newSVpvs("")));
3363 SAVEGENERICSV(PL_rsfp_filters);
3364 PL_rsfp_filters = NULL;
3369 SAVESPTR(PL_compiling.cop_warnings);
3370 if (PL_dowarn & G_WARN_ALL_ON)
3371 PL_compiling.cop_warnings = pWARN_ALL ;
3372 else if (PL_dowarn & G_WARN_ALL_OFF)
3373 PL_compiling.cop_warnings = pWARN_NONE ;
3374 else if (PL_taint_warn)
3375 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3377 PL_compiling.cop_warnings = pWARN_STD ;
3378 SAVESPTR(PL_compiling.cop_io);
3379 PL_compiling.cop_io = NULL;
3381 if (filter_sub || filter_child_proc) {
3382 SV * const datasv = filter_add(S_run_user_filter, NULL);
3383 IoLINES(datasv) = filter_has_file;
3384 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3385 IoTOP_GV(datasv) = (GV *)filter_state;
3386 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3389 /* switch to eval mode */
3390 PUSHBLOCK(cx, CXt_EVAL, SP);
3391 PUSHEVAL(cx, name, NULL);
3392 cx->blk_eval.retop = PL_op->op_next;
3394 SAVECOPLINE(&PL_compiling);
3395 CopLINE_set(&PL_compiling, 0);
3399 /* Store and reset encoding. */
3400 encoding = PL_encoding;
3403 op = DOCATCH(doeval(gimme, NULL, NULL, PL_curcop->cop_seq));
3405 /* Restore encoding. */
3406 PL_encoding = encoding;
3414 register PERL_CONTEXT *cx;
3416 const I32 gimme = GIMME_V;
3417 const I32 was = PL_sub_generation;
3418 char tbuf[TYPE_DIGITS(long) + 12];
3419 char *tmpbuf = tbuf;
3425 HV *saved_hh = NULL;
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_sprintf(tmpbuf, "_<(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 SAVESPTR(PL_compiling.cop_warnings);
3468 if (specialWARN(PL_curcop->cop_warnings))
3469 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3471 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3472 SAVEFREESV(PL_compiling.cop_warnings);
3474 SAVESPTR(PL_compiling.cop_io);
3475 if (specialCopIO(PL_curcop->cop_io))
3476 PL_compiling.cop_io = PL_curcop->cop_io;
3478 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3479 SAVEFREESV(PL_compiling.cop_io);
3481 /* special case: an eval '' executed within the DB package gets lexically
3482 * placed in the first non-DB CV rather than the current CV - this
3483 * allows the debugger to execute code, find lexicals etc, in the
3484 * scope of the code being debugged. Passing &seq gets find_runcv
3485 * to do the dirty work for us */
3486 runcv = find_runcv(&seq);
3488 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3489 PUSHEVAL(cx, 0, NULL);
3490 cx->blk_eval.retop = PL_op->op_next;
3492 /* prepare to compile string */
3494 if (PERLDB_LINE && PL_curstash != PL_debstash)
3495 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3497 ret = doeval(gimme, NULL, runcv, seq);
3498 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3499 && ret != PL_op->op_next) { /* Successive compilation. */
3500 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3502 return DOCATCH(ret);
3512 register PERL_CONTEXT *cx;
3514 const U8 save_flags = PL_op -> op_flags;
3519 retop = cx->blk_eval.retop;
3522 if (gimme == G_VOID)
3524 else if (gimme == G_SCALAR) {
3527 if (SvFLAGS(TOPs) & SVs_TEMP)
3530 *MARK = sv_mortalcopy(TOPs);
3534 *MARK = &PL_sv_undef;
3539 /* in case LEAVE wipes old return values */
3540 for (mark = newsp + 1; mark <= SP; mark++) {
3541 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3542 *mark = sv_mortalcopy(*mark);
3543 TAINT_NOT; /* Each item is independent */
3547 PL_curpm = newpm; /* Don't pop $1 et al till now */
3550 assert(CvDEPTH(PL_compcv) == 1);
3552 CvDEPTH(PL_compcv) = 0;
3555 if (optype == OP_REQUIRE &&
3556 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3558 /* Unassume the success we assumed earlier. */
3559 SV * const nsv = cx->blk_eval.old_namesv;
3560 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3561 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3562 /* die_where() did LEAVE, or we won't be here */
3566 if (!(save_flags & OPf_SPECIAL))
3567 sv_setpvn(ERRSV,"",0);
3576 register PERL_CONTEXT *cx;
3577 const I32 gimme = GIMME_V;
3582 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3584 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3586 PL_in_eval = EVAL_INEVAL;
3587 sv_setpvn(ERRSV,"",0);
3589 return DOCATCH(PL_op->op_next);
3598 register PERL_CONTEXT *cx;
3603 PERL_UNUSED_VAR(optype);
3606 if (gimme == G_VOID)
3608 else if (gimme == G_SCALAR) {
3612 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3615 *MARK = sv_mortalcopy(TOPs);
3619 *MARK = &PL_sv_undef;
3624 /* in case LEAVE wipes old return values */
3626 for (mark = newsp + 1; mark <= SP; mark++) {
3627 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3628 *mark = sv_mortalcopy(*mark);
3629 TAINT_NOT; /* Each item is independent */
3633 PL_curpm = newpm; /* Don't pop $1 et al till now */
3636 sv_setpvn(ERRSV,"",0);
3643 register PERL_CONTEXT *cx;
3644 const I32 gimme = GIMME_V;
3649 if (PL_op->op_targ == 0) {
3650 SV ** const defsv_p = &GvSV(PL_defgv);
3651 *defsv_p = newSVsv(POPs);
3652 SAVECLEARSV(*defsv_p);
3655 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3657 PUSHBLOCK(cx, CXt_GIVEN, SP);
3666 register PERL_CONTEXT *cx;
3670 PERL_UNUSED_CONTEXT;
3673 assert(CxTYPE(cx) == CXt_GIVEN);
3678 PL_curpm = newpm; /* pop $1 et al */
3685 /* Helper routines used by pp_smartmatch */
3688 S_make_matcher(pTHX_ regexp *re)
3691 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3692 PM_SETRE(matcher, ReREFCNT_inc(re));
3694 SAVEFREEOP((OP *) matcher);
3702 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3707 PL_op = (OP *) matcher;
3712 return (SvTRUEx(POPs));
3717 S_destroy_matcher(pTHX_ PMOP *matcher)
3720 PERL_UNUSED_ARG(matcher);
3725 /* Do a smart match */
3728 return do_smartmatch(NULL, NULL);
3731 /* This version of do_smartmatch() implements the following
3732 table of smart matches:
3734 $a $b Type of Match Implied Matching Code
3735 ====== ===== ===================== =============
3736 (overloading trumps everything)
3738 Code[+] Code[+] referential equality match if refaddr($a) == refaddr($b)
3739 Any Code[+] scalar sub truth match if $b->($a)
3741 Hash Hash hash keys identical match if sort(keys(%$a)) ÈeqÇ sort(keys(%$b))
3742 Hash Array hash value slice truth match if $a->{any(@$b)}
3743 Hash Regex hash key grep match if any(keys(%$a)) =~ /$b/
3744 Hash Any hash entry existence match if exists $a->{$b}
3746 Array Array arrays are identical[*] match if $a È~~Ç $b
3747 Array Regex array grep match if any(@$a) =~ /$b/
3748 Array Num array contains number match if any($a) == $b
3749 Array Any array contains string match if any($a) eq $b
3751 Any undef undefined match if !defined $a
3752 Any Regex pattern match match if $a =~ /$b/
3753 Code() Code() results are equal match if $a->() eq $b->()
3754 Any Code() simple closure truth match if $b->() (ignoring $a)
3755 Num numish[!] numeric equality match if $a == $b
3756 Any Str string equality match if $a eq $b
3757 Any Num numeric equality match if $a == $b
3759 Any Any string equality match if $a eq $b
3762 + - this must be a code reference whose prototype (if present) is not ""
3763 (subs with a "" prototype are dealt with by the 'Code()' entry lower down)
3764 * - if a circular reference is found, we fall back to referential equality
3765 ! - either a real number, or a string that looks_like_number()
3770 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3775 SV *e = TOPs; /* e is for 'expression' */
3776 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3779 regexp *this_regex, *other_regex;
3781 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3783 # define SM_REF(type) ( \
3784 (SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_##type) && (other = e)) \
3785 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_##type) && (other = d)))
3787 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3788 ((SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_PVCV) \
3789 && NOT_EMPTY_PROTO(this) && (other = e)) \
3790 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_PVCV) \
3791 && NOT_EMPTY_PROTO(this) && (other = d)))
3793 # define SM_REGEX ( \
3794 (SvROK(d) && SvMAGICAL(this = SvRV(d)) \
3795 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3796 && (this_regex = (regexp *)mg->mg_obj) \
3799 (SvROK(e) && SvMAGICAL(this = SvRV(e)) \
3800 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3801 && (this_regex = (regexp *)mg->mg_obj) \
3805 # define SM_OTHER_REF(type) \
3806 (SvROK(other) && SvTYPE(SvRV(other)) == SVt_##type)
3808 # define SM_OTHER_REGEX (SvROK(other) && SvMAGICAL(SvRV(other)) \
3809 && (mg = mg_find(SvRV(other), PERL_MAGIC_qr)) \
3810 && (other_regex = (regexp *)mg->mg_obj))
3813 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3814 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3816 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3817 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3819 tryAMAGICbinSET(smart, 0);
3821 SP -= 2; /* Pop the values */
3823 /* Take care only to invoke mg_get() once for each argument.
3824 * Currently we do this by copying the SV if it's magical. */
3827 d = sv_mortalcopy(d);
3834 e = sv_mortalcopy(e);
3839 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(other)) )
3841 if (this == SvRV(other))
3852 c = call_sv(this, G_SCALAR);
3856 else if (SvTEMP(TOPs))
3862 else if (SM_REF(PVHV)) {
3863 if (SM_OTHER_REF(PVHV)) {
3864 /* Check that the key-sets are identical */
3866 HV *other_hv = (HV *) SvRV(other);
3868 bool other_tied = FALSE;
3869 U32 this_key_count = 0,
3870 other_key_count = 0;
3872 /* Tied hashes don't know how many keys they have. */
3873 if (SvTIED_mg(this, PERL_MAGIC_tied)) {
3876 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3877 HV * const temp = other_hv;
3878 other_hv = (HV *) this;
3882 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3885 if (!tied && HvUSEDKEYS((HV *) this) != HvUSEDKEYS(other_hv))
3888 /* The hashes have the same number of keys, so it suffices
3889 to check that one is a subset of the other. */
3890 (void) hv_iterinit((HV *) this);
3891 while ( (he = hv_iternext((HV *) this)) ) {
3893 char * const key = hv_iterkey(he, &key_len);
3897 if(!hv_exists(other_hv, key, key_len)) {
3898 (void) hv_iterinit((HV *) this); /* reset iterator */
3904 (void) hv_iterinit(other_hv);
3905 while ( hv_iternext(other_hv) )
3909 other_key_count = HvUSEDKEYS(other_hv);
3911 if (this_key_count != other_key_count)
3916 else if (SM_OTHER_REF(PVAV)) {
3917 AV * const other_av = (AV *) SvRV(other);
3918 const I32 other_len = av_len(other_av) + 1;
3921 if (HvUSEDKEYS((HV *) this) != other_len)
3924 for(i = 0; i < other_len; ++i) {
3925 SV ** const svp = av_fetch(other_av, i, FALSE);
3929 if (!svp) /* ??? When can this happen? */
3932 key = SvPV(*svp, key_len);
3933 if(!hv_exists((HV *) this, key, key_len))
3938 else if (SM_OTHER_REGEX) {
3939 PMOP * const matcher = make_matcher(other_regex);
3942 (void) hv_iterinit((HV *) this);
3943 while ( (he = hv_iternext((HV *) this)) ) {
3944 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
3945 (void) hv_iterinit((HV *) this);
3946 destroy_matcher(matcher);
3950 destroy_matcher(matcher);
3954 if (hv_exists_ent((HV *) this, other, 0))
3960 else if (SM_REF(PVAV)) {
3961 if (SM_OTHER_REF(PVAV)) {
3962 AV *other_av = (AV *) SvRV(other);
3963 if (av_len((AV *) this) != av_len(other_av))
3967 const I32 other_len = av_len(other_av);
3969 if (NULL == seen_this) {
3970 seen_this = newHV();
3971 (void) sv_2mortal((SV *) seen_this);
3973 if (NULL == seen_other) {
3974 seen_this = newHV();
3975 (void) sv_2mortal((SV *) seen_other);
3977 for(i = 0; i <= other_len; ++i) {
3978 SV * const * const this_elem = av_fetch((AV *)this, i, FALSE);
3979 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
3981 if (!this_elem || !other_elem) {
3982 if (this_elem || other_elem)
3985 else if (SM_SEEN_THIS(*this_elem)
3986 || SM_SEEN_OTHER(*other_elem))
3988 if (*this_elem != *other_elem)
3992 hv_store_ent(seen_this,
3993 sv_2mortal(newSViv(PTR2IV(*this_elem))),
3995 hv_store_ent(seen_other,
3996 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4002 (void) do_smartmatch(seen_this, seen_other);
4012 else if (SM_OTHER_REGEX) {
4013 PMOP * const matcher = make_matcher(other_regex);
4014 const I32 this_len = av_len((AV *) this);
4017 for(i = 0; i <= this_len; ++i) {
4018 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4019 if (svp && matcher_matches_sv(matcher, *svp)) {
4020 destroy_matcher(matcher);
4024 destroy_matcher(matcher);
4027 else if (SvIOK(other) || SvNOK(other)) {
4030 for(i = 0; i <= AvFILL((AV *) this); ++i) {
4031 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4038 if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
4048 else if (SvPOK(other)) {
4049 const I32 this_len = av_len((AV *) this);
4052 for(i = 0; i <= this_len; ++i) {
4053 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4068 else if (!SvOK(d) || !SvOK(e)) {
4069 if (!SvOK(d) && !SvOK(e))
4074 else if (SM_REGEX) {
4075 PMOP * const matcher = make_matcher(this_regex);
4078 PUSHs(matcher_matches_sv(matcher, other)
4081 destroy_matcher(matcher);
4084 else if (SM_REF(PVCV)) {
4086 /* This must be a null-prototyped sub, because we
4087 already checked for the other kind. */
4093 c = call_sv(this, G_SCALAR);
4096 PUSHs(&PL_sv_undef);
4097 else if (SvTEMP(TOPs))
4100 if (SM_OTHER_REF(PVCV)) {
4101 /* This one has to be null-proto'd too.
4102 Call both of 'em, and compare the results */
4104 c = call_sv(SvRV(other), G_SCALAR);
4107 PUSHs(&PL_sv_undef);
4108 else if (SvTEMP(TOPs))
4120 else if ( ((SvIOK(d) || SvNOK(d)) && (this = d) && (other = e))
4121 || ((SvIOK(e) || SvNOK(e)) && (this = e) && (other = d)) )
4123 if (SvPOK(other) && !looks_like_number(other)) {
4124 /* String comparison */
4129 /* Otherwise, numeric comparison */
4132 if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
4143 /* As a last resort, use string comparison */
4152 register PERL_CONTEXT *cx;
4153 const I32 gimme = GIMME_V;
4155 /* This is essentially an optimization: if the match
4156 fails, we don't want to push a context and then
4157 pop it again right away, so we skip straight
4158 to the op that follows the leavewhen.
4160 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4161 return cLOGOP->op_other->op_next;
4166 PUSHBLOCK(cx, CXt_WHEN, SP);
4175 register PERL_CONTEXT *cx;
4181 assert(CxTYPE(cx) == CXt_WHEN);
4186 PL_curpm = newpm; /* pop $1 et al */
4196 register PERL_CONTEXT *cx;
4199 cxix = dopoptowhen(cxstack_ix);
4201 DIE(aTHX_ "Can't \"continue\" outside a when block");
4202 if (cxix < cxstack_ix)
4205 /* clear off anything above the scope we're re-entering */
4206 inner = PL_scopestack_ix;
4208 if (PL_scopestack_ix < inner)
4209 leave_scope(PL_scopestack[PL_scopestack_ix]);
4210 PL_curcop = cx->blk_oldcop;
4211 return cx->blk_givwhen.leave_op;
4218 register PERL_CONTEXT *cx;
4221 cxix = dopoptogiven(cxstack_ix);
4223 if (PL_op->op_flags & OPf_SPECIAL)
4224 DIE(aTHX_ "Can't use when() outside a topicalizer");
4226 DIE(aTHX_ "Can't \"break\" outside a given block");
4228 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4229 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4231 if (cxix < cxstack_ix)
4234 /* clear off anything above the scope we're re-entering */
4235 inner = PL_scopestack_ix;
4237 if (PL_scopestack_ix < inner)
4238 leave_scope(PL_scopestack[PL_scopestack_ix]);
4239 PL_curcop = cx->blk_oldcop;
4242 return cx->blk_loop.next_op;
4244 return cx->blk_givwhen.leave_op;
4248 S_doparseform(pTHX_ SV *sv)
4251 register char *s = SvPV_force(sv, len);
4252 register char * const send = s + len;
4253 register char *base = NULL;
4254 register I32 skipspaces = 0;
4255 bool noblank = FALSE;
4256 bool repeat = FALSE;
4257 bool postspace = FALSE;
4263 bool unchopnum = FALSE;
4264 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4267 Perl_croak(aTHX_ "Null picture in formline");
4269 /* estimate the buffer size needed */
4270 for (base = s; s <= send; s++) {
4271 if (*s == '\n' || *s == '@' || *s == '^')
4277 Newx(fops, maxops, U32);
4282 *fpc++ = FF_LINEMARK;
4283 noblank = repeat = FALSE;
4301 case ' ': case '\t':
4308 } /* else FALL THROUGH */
4316 *fpc++ = FF_LITERAL;
4324 *fpc++ = (U16)skipspaces;
4328 *fpc++ = FF_NEWLINE;
4332 arg = fpc - linepc + 1;
4339 *fpc++ = FF_LINEMARK;
4340 noblank = repeat = FALSE;
4349 ischop = s[-1] == '^';
4355 arg = (s - base) - 1;
4357 *fpc++ = FF_LITERAL;
4365 *fpc++ = 2; /* skip the @* or ^* */
4367 *fpc++ = FF_LINESNGL;
4370 *fpc++ = FF_LINEGLOB;
4372 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4373 arg = ischop ? 512 : 0;
4378 const char * const f = ++s;
4381 arg |= 256 + (s - f);
4383 *fpc++ = s - base; /* fieldsize for FETCH */
4384 *fpc++ = FF_DECIMAL;
4386 unchopnum |= ! ischop;
4388 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4389 arg = ischop ? 512 : 0;
4391 s++; /* skip the '0' first */
4395 const char * const f = ++s;
4398 arg |= 256 + (s - f);
4400 *fpc++ = s - base; /* fieldsize for FETCH */
4401 *fpc++ = FF_0DECIMAL;
4403 unchopnum |= ! ischop;
4407 bool ismore = FALSE;
4410 while (*++s == '>') ;
4411 prespace = FF_SPACE;
4413 else if (*s == '|') {
4414 while (*++s == '|') ;
4415 prespace = FF_HALFSPACE;
4420 while (*++s == '<') ;
4423 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4427 *fpc++ = s - base; /* fieldsize for FETCH */
4429 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4432 *fpc++ = (U16)prespace;
4446 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4448 { /* need to jump to the next word */
4450 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4451 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4452 s = SvPVX(sv) + SvCUR(sv) + z;
4454 Copy(fops, s, arg, U32);
4456 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4459 if (unchopnum && repeat)
4460 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4466 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4468 /* Can value be printed in fldsize chars, using %*.*f ? */
4472 int intsize = fldsize - (value < 0 ? 1 : 0);
4479 while (intsize--) pwr *= 10.0;
4480 while (frcsize--) eps /= 10.0;
4483 if (value + eps >= pwr)
4486 if (value - eps <= -pwr)
4493 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4496 SV * const datasv = FILTER_DATA(idx);
4497 const int filter_has_file = IoLINES(datasv);
4498 GV * const filter_child_proc = (GV *)IoFMT_GV(datasv);
4499 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4500 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4503 /* I was having segfault trouble under Linux 2.2.5 after a
4504 parse error occured. (Had to hack around it with a test
4505 for PL_error_count == 0.) Solaris doesn't segfault --
4506 not sure where the trouble is yet. XXX */
4508 if (filter_has_file) {
4509 len = FILTER_READ(idx+1, buf_sv, maxlen);
4512 if (filter_sub && len >= 0) {
4523 PUSHs(sv_2mortal(newSViv(maxlen)));
4525 PUSHs(filter_state);
4528 count = call_sv(filter_sub, G_SCALAR);
4544 IoLINES(datasv) = 0;
4545 if (filter_child_proc) {
4546 SvREFCNT_dec(filter_child_proc);
4547 IoFMT_GV(datasv) = NULL;
4550 SvREFCNT_dec(filter_state);
4551 IoTOP_GV(datasv) = NULL;
4554 SvREFCNT_dec(filter_sub);
4555 IoBOTTOM_GV(datasv) = NULL;
4557 filter_del(S_run_user_filter);
4563 /* perhaps someone can come up with a better name for
4564 this? it is not really "absolute", per se ... */
4566 S_path_is_absolute(const char *name)
4568 if (PERL_FILE_IS_ABSOLUTE(name)
4569 #ifdef MACOS_TRADITIONAL
4572 || (*name == '.' && (name[1] == '/' ||
4573 (name[1] == '.' && name[2] == '/')))
4585 * c-indentation-style: bsd
4587 * indent-tabs-mode: t
4590 * ex: set ts=8 sts=4 sw=4 noet: