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;
78 MAGIC *mg = Null(MAGIC*);
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(REGEXP*)); /* 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)
308 if (!p || p[1] < rx->nparens) {
309 #ifdef PERL_OLD_COPY_ON_WRITE
310 i = 7 + rx->nparens * 2;
312 i = 6 + rx->nparens * 2;
321 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : NULL);
322 RX_MATCH_COPIED_off(rx);
324 #ifdef PERL_OLD_COPY_ON_WRITE
325 *p++ = PTR2UV(rx->saved_copy);
326 rx->saved_copy = NULL;
331 *p++ = PTR2UV(rx->subbeg);
332 *p++ = (UV)rx->sublen;
333 for (i = 0; i <= rx->nparens; ++i) {
334 *p++ = (UV)rx->startp[i];
335 *p++ = (UV)rx->endp[i];
340 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
345 RX_MATCH_COPY_FREE(rx);
346 RX_MATCH_COPIED_set(rx, *p);
349 #ifdef PERL_OLD_COPY_ON_WRITE
351 SvREFCNT_dec (rx->saved_copy);
352 rx->saved_copy = INT2PTR(SV*,*p);
358 rx->subbeg = INT2PTR(char*,*p++);
359 rx->sublen = (I32)(*p++);
360 for (i = 0; i <= rx->nparens; ++i) {
361 rx->startp[i] = (I32)(*p++);
362 rx->endp[i] = (I32)(*p++);
367 Perl_rxres_free(pTHX_ void **rsp)
369 UV * const p = (UV*)*rsp;
373 void *tmp = INT2PTR(char*,*p);
376 Poison(*p, 1, sizeof(*p));
378 Safefree(INT2PTR(char*,*p));
380 #ifdef PERL_OLD_COPY_ON_WRITE
382 SvREFCNT_dec (INT2PTR(SV*,p[1]));
392 dVAR; dSP; dMARK; dORIGMARK;
393 register SV * const tmpForm = *++MARK;
398 register SV *sv = NULL;
399 const char *item = NULL;
403 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
404 const char *chophere = NULL;
405 char *linemark = NULL;
407 bool gotsome = FALSE;
409 const STRLEN fudge = SvPOK(tmpForm)
410 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
411 bool item_is_utf8 = FALSE;
412 bool targ_is_utf8 = FALSE;
414 OP * parseres = NULL;
418 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
419 if (SvREADONLY(tmpForm)) {
420 SvREADONLY_off(tmpForm);
421 parseres = doparseform(tmpForm);
422 SvREADONLY_on(tmpForm);
425 parseres = doparseform(tmpForm);
429 SvPV_force(PL_formtarget, len);
430 if (DO_UTF8(PL_formtarget))
432 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
434 f = SvPV_const(tmpForm, len);
435 /* need to jump to the next word */
436 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
440 const char *name = "???";
443 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
444 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
445 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
446 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
447 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
449 case FF_CHECKNL: name = "CHECKNL"; break;
450 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
451 case FF_SPACE: name = "SPACE"; break;
452 case FF_HALFSPACE: name = "HALFSPACE"; break;
453 case FF_ITEM: name = "ITEM"; break;
454 case FF_CHOP: name = "CHOP"; break;
455 case FF_LINEGLOB: name = "LINEGLOB"; break;
456 case FF_NEWLINE: name = "NEWLINE"; break;
457 case FF_MORE: name = "MORE"; break;
458 case FF_LINEMARK: name = "LINEMARK"; break;
459 case FF_END: name = "END"; break;
460 case FF_0DECIMAL: name = "0DECIMAL"; break;
461 case FF_LINESNGL: name = "LINESNGL"; break;
464 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
466 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
477 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
478 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
480 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
481 t = SvEND(PL_formtarget);
484 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
485 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
487 sv_utf8_upgrade(PL_formtarget);
488 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
489 t = SvEND(PL_formtarget);
509 if (ckWARN(WARN_SYNTAX))
510 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
517 const char *s = item = SvPV_const(sv, len);
520 itemsize = sv_len_utf8(sv);
521 if (itemsize != (I32)len) {
523 if (itemsize > fieldsize) {
524 itemsize = fieldsize;
525 itembytes = itemsize;
526 sv_pos_u2b(sv, &itembytes, 0);
530 send = chophere = s + itembytes;
540 sv_pos_b2u(sv, &itemsize);
544 item_is_utf8 = FALSE;
545 if (itemsize > fieldsize)
546 itemsize = fieldsize;
547 send = chophere = s + itemsize;
561 const char *s = item = SvPV_const(sv, len);
564 itemsize = sv_len_utf8(sv);
565 if (itemsize != (I32)len) {
567 if (itemsize <= fieldsize) {
568 const char *send = chophere = s + itemsize;
581 itemsize = fieldsize;
582 itembytes = itemsize;
583 sv_pos_u2b(sv, &itembytes, 0);
584 send = chophere = s + itembytes;
585 while (s < send || (s == send && isSPACE(*s))) {
595 if (strchr(PL_chopset, *s))
600 itemsize = chophere - item;
601 sv_pos_b2u(sv, &itemsize);
607 item_is_utf8 = FALSE;
608 if (itemsize <= fieldsize) {
609 const char *const send = chophere = s + itemsize;
622 itemsize = fieldsize;
623 send = chophere = s + itemsize;
624 while (s < send || (s == send && isSPACE(*s))) {
634 if (strchr(PL_chopset, *s))
639 itemsize = chophere - item;
645 arg = fieldsize - itemsize;
654 arg = fieldsize - itemsize;
665 const char *s = item;
669 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
671 sv_utf8_upgrade(PL_formtarget);
672 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
673 t = SvEND(PL_formtarget);
677 if (UTF8_IS_CONTINUED(*s)) {
678 STRLEN skip = UTF8SKIP(s);
695 if ( !((*t++ = *s++) & ~31) )
701 if (targ_is_utf8 && !item_is_utf8) {
702 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
704 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
705 for (; t < SvEND(PL_formtarget); t++) {
718 const int ch = *t++ = *s++;
721 if ( !((*t++ = *s++) & ~31) )
730 const char *s = chophere;
748 const char *s = item = SvPV_const(sv, len);
750 if ((item_is_utf8 = DO_UTF8(sv)))
751 itemsize = sv_len_utf8(sv);
753 bool chopped = FALSE;
754 const char *const send = s + len;
756 chophere = s + itemsize;
772 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
774 SvUTF8_on(PL_formtarget);
776 SvCUR_set(sv, chophere - item);
777 sv_catsv(PL_formtarget, sv);
778 SvCUR_set(sv, itemsize);
780 sv_catsv(PL_formtarget, sv);
782 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
783 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
784 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
793 #if defined(USE_LONG_DOUBLE)
794 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
796 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
801 #if defined(USE_LONG_DOUBLE)
802 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
804 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
807 /* If the field is marked with ^ and the value is undefined,
809 if ((arg & 512) && !SvOK(sv)) {
817 /* overflow evidence */
818 if (num_overflow(value, fieldsize, arg)) {
824 /* Formats aren't yet marked for locales, so assume "yes". */
826 STORE_NUMERIC_STANDARD_SET_LOCAL();
827 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
828 RESTORE_NUMERIC_STANDARD();
835 while (t-- > linemark && *t == ' ') ;
843 if (arg) { /* repeat until fields exhausted? */
845 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
846 lines += FmLINES(PL_formtarget);
849 if (strnEQ(linemark, linemark - arg, arg))
850 DIE(aTHX_ "Runaway format");
853 SvUTF8_on(PL_formtarget);
854 FmLINES(PL_formtarget) = lines;
856 RETURNOP(cLISTOP->op_first);
867 const char *s = chophere;
868 const char *send = item + len;
870 while (isSPACE(*s) && (s < send))
875 arg = fieldsize - itemsize;
882 if (strnEQ(s1," ",3)) {
883 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
894 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
896 SvUTF8_on(PL_formtarget);
897 FmLINES(PL_formtarget) += lines;
909 if (PL_stack_base + *PL_markstack_ptr == SP) {
911 if (GIMME_V == G_SCALAR)
912 XPUSHs(sv_2mortal(newSViv(0)));
913 RETURNOP(PL_op->op_next->op_next);
915 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
916 pp_pushmark(); /* push dst */
917 pp_pushmark(); /* push src */
918 ENTER; /* enter outer scope */
921 if (PL_op->op_private & OPpGREP_LEX)
922 SAVESPTR(PAD_SVl(PL_op->op_targ));
925 ENTER; /* enter inner scope */
928 src = PL_stack_base[*PL_markstack_ptr];
930 if (PL_op->op_private & OPpGREP_LEX)
931 PAD_SVl(PL_op->op_targ) = src;
936 if (PL_op->op_type == OP_MAPSTART)
937 pp_pushmark(); /* push top */
938 return ((LOGOP*)PL_op->op_next)->op_other;
944 const I32 gimme = GIMME_V;
945 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
951 /* first, move source pointer to the next item in the source list */
952 ++PL_markstack_ptr[-1];
954 /* if there are new items, push them into the destination list */
955 if (items && gimme != G_VOID) {
956 /* might need to make room back there first */
957 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
958 /* XXX this implementation is very pessimal because the stack
959 * is repeatedly extended for every set of items. Is possible
960 * to do this without any stack extension or copying at all
961 * by maintaining a separate list over which the map iterates
962 * (like foreach does). --gsar */
964 /* everything in the stack after the destination list moves
965 * towards the end the stack by the amount of room needed */
966 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
968 /* items to shift up (accounting for the moved source pointer) */
969 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
971 /* This optimization is by Ben Tilly and it does
972 * things differently from what Sarathy (gsar)
973 * is describing. The downside of this optimization is
974 * that leaves "holes" (uninitialized and hopefully unused areas)
975 * to the Perl stack, but on the other hand this
976 * shouldn't be a problem. If Sarathy's idea gets
977 * implemented, this optimization should become
978 * irrelevant. --jhi */
980 shift = count; /* Avoid shifting too often --Ben Tilly */
985 PL_markstack_ptr[-1] += shift;
986 *PL_markstack_ptr += shift;
990 /* copy the new items down to the destination list */
991 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
992 if (gimme == G_ARRAY) {
994 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
997 /* scalar context: we don't care about which values map returns
998 * (we use undef here). And so we certainly don't want to do mortal
999 * copies of meaningless values. */
1000 while (items-- > 0) {
1002 *dst-- = &PL_sv_undef;
1006 LEAVE; /* exit inner scope */
1009 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1011 (void)POPMARK; /* pop top */
1012 LEAVE; /* exit outer scope */
1013 (void)POPMARK; /* pop src */
1014 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1015 (void)POPMARK; /* pop dst */
1016 SP = PL_stack_base + POPMARK; /* pop original mark */
1017 if (gimme == G_SCALAR) {
1018 if (PL_op->op_private & OPpGREP_LEX) {
1019 SV* sv = sv_newmortal();
1020 sv_setiv(sv, items);
1028 else if (gimme == G_ARRAY)
1035 ENTER; /* enter inner scope */
1038 /* set $_ to the new source item */
1039 src = PL_stack_base[PL_markstack_ptr[-1]];
1041 if (PL_op->op_private & OPpGREP_LEX)
1042 PAD_SVl(PL_op->op_targ) = src;
1046 RETURNOP(cLOGOP->op_other);
1055 if (GIMME == G_ARRAY)
1057 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1058 return cLOGOP->op_other;
1068 if (GIMME == G_ARRAY) {
1069 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1073 SV * const targ = PAD_SV(PL_op->op_targ);
1076 if (PL_op->op_private & OPpFLIP_LINENUM) {
1077 if (GvIO(PL_last_in_gv)) {
1078 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1081 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1083 flip = SvIV(sv) == SvIV(GvSV(gv));
1089 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1090 if (PL_op->op_flags & OPf_SPECIAL) {
1098 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1101 sv_setpvn(TARG, "", 0);
1107 /* This code tries to decide if "$left .. $right" should use the
1108 magical string increment, or if the range is numeric (we make
1109 an exception for .."0" [#18165]). AMS 20021031. */
1111 #define RANGE_IS_NUMERIC(left,right) ( \
1112 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1113 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1114 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1115 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1116 && (!SvOK(right) || looks_like_number(right))))
1122 if (GIMME == G_ARRAY) {
1128 if (RANGE_IS_NUMERIC(left,right)) {
1131 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1132 (SvOK(right) && SvNV(right) > IV_MAX))
1133 DIE(aTHX_ "Range iterator outside integer range");
1144 SV * const sv = sv_2mortal(newSViv(i++));
1149 SV * const final = sv_mortalcopy(right);
1151 const char * const tmps = SvPV_const(final, len);
1153 SV *sv = sv_mortalcopy(left);
1154 SvPV_force_nolen(sv);
1155 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1157 if (strEQ(SvPVX_const(sv),tmps))
1159 sv = sv_2mortal(newSVsv(sv));
1166 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1170 if (PL_op->op_private & OPpFLIP_LINENUM) {
1171 if (GvIO(PL_last_in_gv)) {
1172 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1175 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1176 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1184 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1185 sv_catpvs(targ, "E0");
1195 static const char * const context_name[] = {
1208 S_dopoptolabel(pTHX_ const char *label)
1213 for (i = cxstack_ix; i >= 0; i--) {
1214 register const PERL_CONTEXT * const cx = &cxstack[i];
1215 switch (CxTYPE(cx)) {
1223 if (ckWARN(WARN_EXITING))
1224 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1225 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1226 if (CxTYPE(cx) == CXt_NULL)
1230 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1231 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1232 (long)i, cx->blk_loop.label));
1235 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1245 Perl_dowantarray(pTHX)
1248 const I32 gimme = block_gimme();
1249 return (gimme == G_VOID) ? G_SCALAR : gimme;
1253 Perl_block_gimme(pTHX)
1256 const I32 cxix = dopoptosub(cxstack_ix);
1260 switch (cxstack[cxix].blk_gimme) {
1268 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1275 Perl_is_lvalue_sub(pTHX)
1278 const I32 cxix = dopoptosub(cxstack_ix);
1279 assert(cxix >= 0); /* We should only be called from inside subs */
1281 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1282 return cxstack[cxix].blk_sub.lval;
1288 S_dopoptosub(pTHX_ I32 startingblock)
1291 return dopoptosub_at(cxstack, startingblock);
1295 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1299 for (i = startingblock; i >= 0; i--) {
1300 register const PERL_CONTEXT * const cx = &cxstk[i];
1301 switch (CxTYPE(cx)) {
1307 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1315 S_dopoptoeval(pTHX_ I32 startingblock)
1319 for (i = startingblock; i >= 0; i--) {
1320 register const PERL_CONTEXT *cx = &cxstack[i];
1321 switch (CxTYPE(cx)) {
1325 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1333 S_dopoptoloop(pTHX_ I32 startingblock)
1337 for (i = startingblock; i >= 0; i--) {
1338 register const PERL_CONTEXT * const cx = &cxstack[i];
1339 switch (CxTYPE(cx)) {
1345 if (ckWARN(WARN_EXITING))
1346 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1347 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1348 if ((CxTYPE(cx)) == CXt_NULL)
1352 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1360 S_dopoptogiven(pTHX_ I32 startingblock)
1364 for (i = startingblock; i >= 0; i--) {
1365 register const PERL_CONTEXT *cx = &cxstack[i];
1366 switch (CxTYPE(cx)) {
1370 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1373 if (CxFOREACHDEF(cx)) {
1374 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1383 S_dopoptowhen(pTHX_ I32 startingblock)
1387 for (i = startingblock; i >= 0; i--) {
1388 register const PERL_CONTEXT *cx = &cxstack[i];
1389 switch (CxTYPE(cx)) {
1393 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1401 Perl_dounwind(pTHX_ I32 cxix)
1406 while (cxstack_ix > cxix) {
1408 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1409 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1410 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1411 /* Note: we don't need to restore the base context info till the end. */
1412 switch (CxTYPE(cx)) {
1415 continue; /* not break */
1434 PERL_UNUSED_VAR(optype);
1438 Perl_qerror(pTHX_ SV *err)
1442 sv_catsv(ERRSV, err);
1444 sv_catsv(PL_errors, err);
1446 Perl_warn(aTHX_ "%"SVf, err);
1451 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1460 if (PL_in_eval & EVAL_KEEPERR) {
1461 static const char prefix[] = "\t(in cleanup) ";
1462 SV * const err = ERRSV;
1463 const char *e = NULL;
1465 sv_setpvn(err,"",0);
1466 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1468 e = SvPV_const(err, len);
1470 if (*e != *message || strNE(e,message))
1474 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1475 sv_catpvn(err, prefix, sizeof(prefix)-1);
1476 sv_catpvn(err, message, msglen);
1477 if (ckWARN(WARN_MISC)) {
1478 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1479 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1484 sv_setpvn(ERRSV, message, msglen);
1488 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1489 && PL_curstackinfo->si_prev)
1497 register PERL_CONTEXT *cx;
1500 if (cxix < cxstack_ix)
1503 POPBLOCK(cx,PL_curpm);
1504 if (CxTYPE(cx) != CXt_EVAL) {
1506 message = SvPVx_const(ERRSV, msglen);
1507 PerlIO_write(Perl_error_log, "panic: die ", 11);
1508 PerlIO_write(Perl_error_log, message, msglen);
1513 if (gimme == G_SCALAR)
1514 *++newsp = &PL_sv_undef;
1515 PL_stack_sp = newsp;
1519 /* LEAVE could clobber PL_curcop (see save_re_context())
1520 * XXX it might be better to find a way to avoid messing with
1521 * PL_curcop in save_re_context() instead, but this is a more
1522 * minimal fix --GSAR */
1523 PL_curcop = cx->blk_oldcop;
1525 if (optype == OP_REQUIRE) {
1526 const char* const msg = SvPVx_nolen_const(ERRSV);
1527 SV * const nsv = cx->blk_eval.old_namesv;
1528 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1530 DIE(aTHX_ "%sCompilation failed in require",
1531 *msg ? msg : "Unknown error\n");
1533 assert(CxTYPE(cx) == CXt_EVAL);
1534 return cx->blk_eval.retop;
1538 message = SvPVx_const(ERRSV, msglen);
1540 write_to_stderr(message, msglen);
1548 dVAR; dSP; dPOPTOPssrl;
1549 if (SvTRUE(left) != SvTRUE(right))
1559 register I32 cxix = dopoptosub(cxstack_ix);
1560 register const PERL_CONTEXT *cx;
1561 register const PERL_CONTEXT *ccstack = cxstack;
1562 const PERL_SI *top_si = PL_curstackinfo;
1564 const char *stashname;
1571 /* we may be in a higher stacklevel, so dig down deeper */
1572 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1573 top_si = top_si->si_prev;
1574 ccstack = top_si->si_cxstack;
1575 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1578 if (GIMME != G_ARRAY) {
1584 /* caller() should not report the automatic calls to &DB::sub */
1585 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1586 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1590 cxix = dopoptosub_at(ccstack, cxix - 1);
1593 cx = &ccstack[cxix];
1594 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1595 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1596 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1597 field below is defined for any cx. */
1598 /* caller() should not report the automatic calls to &DB::sub */
1599 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1600 cx = &ccstack[dbcxix];
1603 stashname = CopSTASHPV(cx->blk_oldcop);
1604 if (GIMME != G_ARRAY) {
1607 PUSHs(&PL_sv_undef);
1610 sv_setpv(TARG, stashname);
1619 PUSHs(&PL_sv_undef);
1621 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1622 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1623 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1626 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1627 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1628 /* So is ccstack[dbcxix]. */
1630 SV * const sv = newSV(0);
1631 gv_efullname3(sv, cvgv, NULL);
1632 PUSHs(sv_2mortal(sv));
1633 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1636 PUSHs(sv_2mortal(newSVpvs("(unknown)")));
1637 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1641 PUSHs(sv_2mortal(newSVpvs("(eval)")));
1642 PUSHs(sv_2mortal(newSViv(0)));
1644 gimme = (I32)cx->blk_gimme;
1645 if (gimme == G_VOID)
1646 PUSHs(&PL_sv_undef);
1648 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1649 if (CxTYPE(cx) == CXt_EVAL) {
1651 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1652 PUSHs(cx->blk_eval.cur_text);
1656 else if (cx->blk_eval.old_namesv) {
1657 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1660 /* eval BLOCK (try blocks have old_namesv == 0) */
1662 PUSHs(&PL_sv_undef);
1663 PUSHs(&PL_sv_undef);
1667 PUSHs(&PL_sv_undef);
1668 PUSHs(&PL_sv_undef);
1670 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1671 && CopSTASH_eq(PL_curcop, PL_debstash))
1673 AV * const ary = cx->blk_sub.argarray;
1674 const int off = AvARRAY(ary) - AvALLOC(ary);
1677 GV* const tmpgv = gv_fetchpv("DB::args", TRUE, SVt_PVAV);
1678 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1680 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1683 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1684 av_extend(PL_dbargs, AvFILLp(ary) + off);
1685 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1686 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1688 /* XXX only hints propagated via op_private are currently
1689 * visible (others are not easily accessible, since they
1690 * use the global PL_hints) */
1691 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1692 HINT_PRIVATE_MASK)));
1695 SV * const old_warnings = cx->blk_oldcop->cop_warnings ;
1697 if (old_warnings == pWARN_NONE ||
1698 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1699 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1700 else if (old_warnings == pWARN_ALL ||
1701 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1702 /* Get the bit mask for $warnings::Bits{all}, because
1703 * it could have been extended by warnings::register */
1705 HV * const bits = get_hv("warnings::Bits", FALSE);
1706 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1707 mask = newSVsv(*bits_all);
1710 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1714 mask = newSVsv(old_warnings);
1715 PUSHs(sv_2mortal(mask));
1724 const char * const tmps = (MAXARG < 1) ? "" : POPpconstx;
1725 sv_reset(tmps, CopSTASH(PL_curcop));
1730 /* like pp_nextstate, but used instead when the debugger is active */
1735 PL_curcop = (COP*)PL_op;
1736 TAINT_NOT; /* Each statement is presumed innocent */
1737 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1740 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1741 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1744 register PERL_CONTEXT *cx;
1745 const I32 gimme = G_ARRAY;
1747 GV * const gv = PL_DBgv;
1748 register CV * const cv = GvCV(gv);
1751 DIE(aTHX_ "No DB::DB routine defined");
1753 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1754 /* don't do recursive DB::DB call */
1769 (void)(*CvXSUB(cv))(aTHX_ cv);
1776 PUSHBLOCK(cx, CXt_SUB, SP);
1778 cx->blk_sub.retop = PL_op->op_next;
1781 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1782 RETURNOP(CvSTART(cv));
1792 register PERL_CONTEXT *cx;
1793 const I32 gimme = GIMME_V;
1795 U32 cxtype = CXt_LOOP | CXp_FOREACH;
1803 if (PL_op->op_targ) {
1804 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1805 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1806 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1807 SVs_PADSTALE, SVs_PADSTALE);
1809 #ifndef USE_ITHREADS
1810 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1813 SAVEPADSV(PL_op->op_targ);
1814 iterdata = INT2PTR(void*, PL_op->op_targ);
1815 cxtype |= CXp_PADVAR;
1819 GV * const gv = (GV*)POPs;
1820 svp = &GvSV(gv); /* symbol table variable */
1821 SAVEGENERICSV(*svp);
1824 iterdata = (void*)gv;
1828 if (PL_op->op_private & OPpITER_DEF)
1829 cxtype |= CXp_FOR_DEF;
1833 PUSHBLOCK(cx, cxtype, SP);
1835 PUSHLOOP(cx, iterdata, MARK);
1837 PUSHLOOP(cx, svp, MARK);
1839 if (PL_op->op_flags & OPf_STACKED) {
1840 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1841 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1843 SV * const right = (SV*)cx->blk_loop.iterary;
1846 if (RANGE_IS_NUMERIC(sv,right)) {
1847 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1848 (SvOK(right) && SvNV(right) >= IV_MAX))
1849 DIE(aTHX_ "Range iterator outside integer range");
1850 cx->blk_loop.iterix = SvIV(sv);
1851 cx->blk_loop.itermax = SvIV(right);
1853 /* for correct -Dstv display */
1854 cx->blk_oldsp = sp - PL_stack_base;
1858 cx->blk_loop.iterlval = newSVsv(sv);
1859 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1860 (void) SvPV_nolen_const(right);
1863 else if (PL_op->op_private & OPpITER_REVERSED) {
1864 cx->blk_loop.itermax = 0;
1865 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1870 cx->blk_loop.iterary = PL_curstack;
1871 AvFILLp(PL_curstack) = SP - PL_stack_base;
1872 if (PL_op->op_private & OPpITER_REVERSED) {
1873 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1874 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1877 cx->blk_loop.iterix = MARK - PL_stack_base;
1887 register PERL_CONTEXT *cx;
1888 const I32 gimme = GIMME_V;
1894 PUSHBLOCK(cx, CXt_LOOP, SP);
1895 PUSHLOOP(cx, 0, SP);
1903 register PERL_CONTEXT *cx;
1910 assert(CxTYPE(cx) == CXt_LOOP);
1912 newsp = PL_stack_base + cx->blk_loop.resetsp;
1915 if (gimme == G_VOID)
1917 else if (gimme == G_SCALAR) {
1919 *++newsp = sv_mortalcopy(*SP);
1921 *++newsp = &PL_sv_undef;
1925 *++newsp = sv_mortalcopy(*++mark);
1926 TAINT_NOT; /* Each item is independent */
1932 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1933 PL_curpm = newpm; /* ... and pop $1 et al */
1944 register PERL_CONTEXT *cx;
1945 bool popsub2 = FALSE;
1946 bool clear_errsv = FALSE;
1954 const I32 cxix = dopoptosub(cxstack_ix);
1957 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1958 * sort block, which is a CXt_NULL
1961 PL_stack_base[1] = *PL_stack_sp;
1962 PL_stack_sp = PL_stack_base + 1;
1966 DIE(aTHX_ "Can't return outside a subroutine");
1968 if (cxix < cxstack_ix)
1971 if (CxMULTICALL(&cxstack[cxix])) {
1972 gimme = cxstack[cxix].blk_gimme;
1973 if (gimme == G_VOID)
1974 PL_stack_sp = PL_stack_base;
1975 else if (gimme == G_SCALAR) {
1976 PL_stack_base[1] = *PL_stack_sp;
1977 PL_stack_sp = PL_stack_base + 1;
1983 switch (CxTYPE(cx)) {
1986 retop = cx->blk_sub.retop;
1987 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1990 if (!(PL_in_eval & EVAL_KEEPERR))
1993 retop = cx->blk_eval.retop;
1997 if (optype == OP_REQUIRE &&
1998 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2000 /* Unassume the success we assumed earlier. */
2001 SV * const nsv = cx->blk_eval.old_namesv;
2002 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2003 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
2008 retop = cx->blk_sub.retop;
2011 DIE(aTHX_ "panic: return");
2015 if (gimme == G_SCALAR) {
2018 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2020 *++newsp = SvREFCNT_inc(*SP);
2025 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2027 *++newsp = sv_mortalcopy(sv);
2032 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2035 *++newsp = sv_mortalcopy(*SP);
2038 *++newsp = &PL_sv_undef;
2040 else if (gimme == G_ARRAY) {
2041 while (++MARK <= SP) {
2042 *++newsp = (popsub2 && SvTEMP(*MARK))
2043 ? *MARK : sv_mortalcopy(*MARK);
2044 TAINT_NOT; /* Each item is independent */
2047 PL_stack_sp = newsp;
2050 /* Stack values are safe: */
2053 POPSUB(cx,sv); /* release CV and @_ ... */
2057 PL_curpm = newpm; /* ... and pop $1 et al */
2061 sv_setpvn(ERRSV,"",0);
2069 register PERL_CONTEXT *cx;
2080 if (PL_op->op_flags & OPf_SPECIAL) {
2081 cxix = dopoptoloop(cxstack_ix);
2083 DIE(aTHX_ "Can't \"last\" outside a loop block");
2086 cxix = dopoptolabel(cPVOP->op_pv);
2088 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2090 if (cxix < cxstack_ix)
2094 cxstack_ix++; /* temporarily protect top context */
2096 switch (CxTYPE(cx)) {
2099 newsp = PL_stack_base + cx->blk_loop.resetsp;
2100 nextop = cx->blk_loop.last_op->op_next;
2104 nextop = cx->blk_sub.retop;
2108 nextop = cx->blk_eval.retop;
2112 nextop = cx->blk_sub.retop;
2115 DIE(aTHX_ "panic: last");
2119 if (gimme == G_SCALAR) {
2121 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2122 ? *SP : sv_mortalcopy(*SP);
2124 *++newsp = &PL_sv_undef;
2126 else if (gimme == G_ARRAY) {
2127 while (++MARK <= SP) {
2128 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2129 ? *MARK : sv_mortalcopy(*MARK);
2130 TAINT_NOT; /* Each item is independent */
2138 /* Stack values are safe: */
2141 POPLOOP(cx); /* release loop vars ... */
2145 POPSUB(cx,sv); /* release CV and @_ ... */
2148 PL_curpm = newpm; /* ... and pop $1 et al */
2151 PERL_UNUSED_VAR(optype);
2152 PERL_UNUSED_VAR(gimme);
2160 register PERL_CONTEXT *cx;
2163 if (PL_op->op_flags & OPf_SPECIAL) {
2164 cxix = dopoptoloop(cxstack_ix);
2166 DIE(aTHX_ "Can't \"next\" outside a loop block");
2169 cxix = dopoptolabel(cPVOP->op_pv);
2171 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2173 if (cxix < cxstack_ix)
2176 /* clear off anything above the scope we're re-entering, but
2177 * save the rest until after a possible continue block */
2178 inner = PL_scopestack_ix;
2180 if (PL_scopestack_ix < inner)
2181 leave_scope(PL_scopestack[PL_scopestack_ix]);
2182 PL_curcop = cx->blk_oldcop;
2183 return cx->blk_loop.next_op;
2190 register PERL_CONTEXT *cx;
2194 if (PL_op->op_flags & OPf_SPECIAL) {
2195 cxix = dopoptoloop(cxstack_ix);
2197 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2200 cxix = dopoptolabel(cPVOP->op_pv);
2202 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2204 if (cxix < cxstack_ix)
2207 redo_op = cxstack[cxix].blk_loop.redo_op;
2208 if (redo_op->op_type == OP_ENTER) {
2209 /* pop one less context to avoid $x being freed in while (my $x..) */
2211 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2212 redo_op = redo_op->op_next;
2216 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2217 LEAVE_SCOPE(oldsave);
2219 PL_curcop = cx->blk_oldcop;
2224 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2228 static const char too_deep[] = "Target of goto is too deeply nested";
2231 Perl_croak(aTHX_ too_deep);
2232 if (o->op_type == OP_LEAVE ||
2233 o->op_type == OP_SCOPE ||
2234 o->op_type == OP_LEAVELOOP ||
2235 o->op_type == OP_LEAVESUB ||
2236 o->op_type == OP_LEAVETRY)
2238 *ops++ = cUNOPo->op_first;
2240 Perl_croak(aTHX_ too_deep);
2243 if (o->op_flags & OPf_KIDS) {
2245 /* First try all the kids at this level, since that's likeliest. */
2246 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2247 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2248 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2251 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2252 if (kid == PL_lastgotoprobe)
2254 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2257 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2258 ops[-1]->op_type == OP_DBSTATE)
2263 if ((o = dofindlabel(kid, label, ops, oplimit)))
2276 register PERL_CONTEXT *cx;
2277 #define GOTO_DEPTH 64
2278 OP *enterops[GOTO_DEPTH];
2279 const char *label = NULL;
2280 const bool do_dump = (PL_op->op_type == OP_DUMP);
2281 static const char must_have_label[] = "goto must have label";
2283 if (PL_op->op_flags & OPf_STACKED) {
2284 SV * const sv = POPs;
2286 /* This egregious kludge implements goto &subroutine */
2287 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2289 register PERL_CONTEXT *cx;
2290 CV* cv = (CV*)SvRV(sv);
2297 if (!CvROOT(cv) && !CvXSUB(cv)) {
2298 const GV * const gv = CvGV(cv);
2302 /* autoloaded stub? */
2303 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2305 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2306 GvNAMELEN(gv), FALSE);
2307 if (autogv && (cv = GvCV(autogv)))
2309 tmpstr = sv_newmortal();
2310 gv_efullname3(tmpstr, gv, NULL);
2311 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2313 DIE(aTHX_ "Goto undefined subroutine");
2316 /* First do some returnish stuff. */
2317 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2319 cxix = dopoptosub(cxstack_ix);
2321 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2322 if (cxix < cxstack_ix)
2326 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2327 if (CxTYPE(cx) == CXt_EVAL) {
2329 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2331 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2333 else if (CxMULTICALL(cx))
2334 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2335 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2336 /* put @_ back onto stack */
2337 AV* av = cx->blk_sub.argarray;
2339 items = AvFILLp(av) + 1;
2340 EXTEND(SP, items+1); /* @_ could have been extended. */
2341 Copy(AvARRAY(av), SP + 1, items, SV*);
2342 SvREFCNT_dec(GvAV(PL_defgv));
2343 GvAV(PL_defgv) = cx->blk_sub.savearray;
2345 /* abandon @_ if it got reified */
2350 av_extend(av, items-1);
2352 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2355 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2356 AV* const av = GvAV(PL_defgv);
2357 items = AvFILLp(av) + 1;
2358 EXTEND(SP, items+1); /* @_ could have been extended. */
2359 Copy(AvARRAY(av), SP + 1, items, SV*);
2363 if (CxTYPE(cx) == CXt_SUB &&
2364 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2365 SvREFCNT_dec(cx->blk_sub.cv);
2366 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2367 LEAVE_SCOPE(oldsave);
2369 /* Now do some callish stuff. */
2371 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2373 OP* retop = cx->blk_sub.retop;
2376 for (index=0; index<items; index++)
2377 sv_2mortal(SP[-index]);
2379 #ifdef PERL_XSUB_OLDSTYLE
2380 if (CvOLDSTYLE(cv)) {
2381 I32 (*fp3)(int,int,int);
2386 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2387 items = (*fp3)(CvXSUBANY(cv).any_i32,
2388 mark - PL_stack_base + 1,
2390 SP = PL_stack_base + items;
2393 #endif /* PERL_XSUB_OLDSTYLE */
2398 /* XS subs don't have a CxSUB, so pop it */
2399 POPBLOCK(cx, PL_curpm);
2400 /* Push a mark for the start of arglist */
2403 (void)(*CvXSUB(cv))(aTHX_ cv);
2404 /* Put these at the bottom since the vars are set but not used */
2405 PERL_UNUSED_VAR(newsp);
2406 PERL_UNUSED_VAR(gimme);
2412 AV* padlist = CvPADLIST(cv);
2413 if (CxTYPE(cx) == CXt_EVAL) {
2414 PL_in_eval = cx->blk_eval.old_in_eval;
2415 PL_eval_root = cx->blk_eval.old_eval_root;
2416 cx->cx_type = CXt_SUB;
2417 cx->blk_sub.hasargs = 0;
2419 cx->blk_sub.cv = cv;
2420 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2423 if (CvDEPTH(cv) < 2)
2424 (void)SvREFCNT_inc(cv);
2426 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2427 sub_crush_depth(cv);
2428 pad_push(padlist, CvDEPTH(cv));
2431 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2432 if (cx->blk_sub.hasargs)
2434 AV* av = (AV*)PAD_SVl(0);
2437 cx->blk_sub.savearray = GvAV(PL_defgv);
2438 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2439 CX_CURPAD_SAVE(cx->blk_sub);
2440 cx->blk_sub.argarray = av;
2442 if (items >= AvMAX(av) + 1) {
2444 if (AvARRAY(av) != ary) {
2445 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2446 SvPV_set(av, (char*)ary);
2448 if (items >= AvMAX(av) + 1) {
2449 AvMAX(av) = items - 1;
2450 Renew(ary,items+1,SV*);
2452 SvPV_set(av, (char*)ary);
2456 Copy(mark,AvARRAY(av),items,SV*);
2457 AvFILLp(av) = items - 1;
2458 assert(!AvREAL(av));
2460 /* transfer 'ownership' of refcnts to new @_ */
2470 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2472 * We do not care about using sv to call CV;
2473 * it's for informational purposes only.
2475 SV * const sv = GvSV(PL_DBsub);
2479 if (PERLDB_SUB_NN) {
2480 const int type = SvTYPE(sv);
2481 if (type < SVt_PVIV && type != SVt_IV)
2482 sv_upgrade(sv, SVt_PVIV);
2484 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2486 gv_efullname3(sv, CvGV(cv), NULL);
2489 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2490 PUSHMARK( PL_stack_sp );
2491 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2495 RETURNOP(CvSTART(cv));
2499 label = SvPV_nolen_const(sv);
2500 if (!(do_dump || *label))
2501 DIE(aTHX_ must_have_label);
2504 else if (PL_op->op_flags & OPf_SPECIAL) {
2506 DIE(aTHX_ must_have_label);
2509 label = cPVOP->op_pv;
2511 if (label && *label) {
2512 OP *gotoprobe = NULL;
2513 bool leaving_eval = FALSE;
2514 bool in_block = FALSE;
2515 PERL_CONTEXT *last_eval_cx = NULL;
2519 PL_lastgotoprobe = 0;
2521 for (ix = cxstack_ix; ix >= 0; ix--) {
2523 switch (CxTYPE(cx)) {
2525 leaving_eval = TRUE;
2526 if (!CxTRYBLOCK(cx)) {
2527 gotoprobe = (last_eval_cx ?
2528 last_eval_cx->blk_eval.old_eval_root :
2533 /* else fall through */
2535 gotoprobe = cx->blk_oldcop->op_sibling;
2541 gotoprobe = cx->blk_oldcop->op_sibling;
2544 gotoprobe = PL_main_root;
2547 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2548 gotoprobe = CvROOT(cx->blk_sub.cv);
2554 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2557 DIE(aTHX_ "panic: goto");
2558 gotoprobe = PL_main_root;
2562 retop = dofindlabel(gotoprobe, label,
2563 enterops, enterops + GOTO_DEPTH);
2567 PL_lastgotoprobe = gotoprobe;
2570 DIE(aTHX_ "Can't find label %s", label);
2572 /* if we're leaving an eval, check before we pop any frames
2573 that we're not going to punt, otherwise the error
2576 if (leaving_eval && *enterops && enterops[1]) {
2578 for (i = 1; enterops[i]; i++)
2579 if (enterops[i]->op_type == OP_ENTERITER)
2580 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2583 /* pop unwanted frames */
2585 if (ix < cxstack_ix) {
2592 oldsave = PL_scopestack[PL_scopestack_ix];
2593 LEAVE_SCOPE(oldsave);
2596 /* push wanted frames */
2598 if (*enterops && enterops[1]) {
2599 OP * const oldop = PL_op;
2600 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2601 for (; enterops[ix]; ix++) {
2602 PL_op = enterops[ix];
2603 /* Eventually we may want to stack the needed arguments
2604 * for each op. For now, we punt on the hard ones. */
2605 if (PL_op->op_type == OP_ENTERITER)
2606 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2607 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2615 if (!retop) retop = PL_main_start;
2617 PL_restartop = retop;
2618 PL_do_undump = TRUE;
2622 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2623 PL_do_undump = FALSE;
2640 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2642 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2645 PL_exit_flags |= PERL_EXIT_EXPECTED;
2647 PUSHs(&PL_sv_undef);
2654 S_save_lines(pTHX_ AV *array, SV *sv)
2656 const char *s = SvPVX_const(sv);
2657 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2660 while (s && s < send) {
2662 SV * const tmpstr = newSV(0);
2664 sv_upgrade(tmpstr, SVt_PVMG);
2665 t = strchr(s, '\n');
2671 sv_setpvn(tmpstr, s, t - s);
2672 av_store(array, line++, tmpstr);
2678 S_docatch_body(pTHX)
2686 S_docatch(pTHX_ OP *o)
2690 OP * const oldop = PL_op;
2694 assert(CATCH_GET == TRUE);
2701 assert(cxstack_ix >= 0);
2702 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2703 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2708 /* die caught by an inner eval - continue inner loop */
2710 /* NB XXX we rely on the old popped CxEVAL still being at the top
2711 * of the stack; the way die_where() currently works, this
2712 * assumption is valid. In theory The cur_top_env value should be
2713 * returned in another global, the way retop (aka PL_restartop)
2715 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2718 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2720 PL_op = PL_restartop;
2737 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2738 /* sv Text to convert to OP tree. */
2739 /* startop op_free() this to undo. */
2740 /* code Short string id of the caller. */
2742 /* FIXME - how much of this code is common with pp_entereval? */
2743 dVAR; dSP; /* Make POPBLOCK work. */
2750 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2751 char *tmpbuf = tbuf;
2754 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2760 /* switch to eval mode */
2762 if (IN_PERL_COMPILETIME) {
2763 SAVECOPSTASH_FREE(&PL_compiling);
2764 CopSTASH_set(&PL_compiling, PL_curstash);
2766 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2767 SV * const sv = sv_newmortal();
2768 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2769 code, (unsigned long)++PL_evalseq,
2770 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2775 len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
2776 (unsigned long)++PL_evalseq);
2777 SAVECOPFILE_FREE(&PL_compiling);
2778 CopFILE_set(&PL_compiling, tmpbuf+2);
2779 SAVECOPLINE(&PL_compiling);
2780 CopLINE_set(&PL_compiling, 1);
2781 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2782 deleting the eval's FILEGV from the stash before gv_check() runs
2783 (i.e. before run-time proper). To work around the coredump that
2784 ensues, we always turn GvMULTI_on for any globals that were
2785 introduced within evals. See force_ident(). GSAR 96-10-12 */
2786 safestr = savepvn(tmpbuf, len);
2787 SAVEDELETE(PL_defstash, safestr, len);
2789 #ifdef OP_IN_REGISTER
2795 /* we get here either during compilation, or via pp_regcomp at runtime */
2796 runtime = IN_PERL_RUNTIME;
2798 runcv = find_runcv(NULL);
2801 PL_op->op_type = OP_ENTEREVAL;
2802 PL_op->op_flags = 0; /* Avoid uninit warning. */
2803 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2804 PUSHEVAL(cx, 0, Nullgv);
2807 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2809 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2810 POPBLOCK(cx,PL_curpm);
2813 (*startop)->op_type = OP_NULL;
2814 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2816 /* XXX DAPM do this properly one year */
2817 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2819 if (IN_PERL_COMPILETIME)
2820 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2821 #ifdef OP_IN_REGISTER
2824 PERL_UNUSED_VAR(newsp);
2825 PERL_UNUSED_VAR(optype);
2832 =for apidoc find_runcv
2834 Locate the CV corresponding to the currently executing sub or eval.
2835 If db_seqp is non_null, skip CVs that are in the DB package and populate
2836 *db_seqp with the cop sequence number at the point that the DB:: code was
2837 entered. (allows debuggers to eval in the scope of the breakpoint rather
2838 than in the scope of the debugger itself).
2844 Perl_find_runcv(pTHX_ U32 *db_seqp)
2850 *db_seqp = PL_curcop->cop_seq;
2851 for (si = PL_curstackinfo; si; si = si->si_prev) {
2853 for (ix = si->si_cxix; ix >= 0; ix--) {
2854 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2855 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2856 CV * const cv = cx->blk_sub.cv;
2857 /* skip DB:: code */
2858 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2859 *db_seqp = cx->blk_oldcop->cop_seq;
2864 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2872 /* Compile a require/do, an eval '', or a /(?{...})/.
2873 * In the last case, startop is non-null, and contains the address of
2874 * a pointer that should be set to the just-compiled code.
2875 * outside is the lexically enclosing CV (if any) that invoked us.
2878 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2880 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2883 OP * const saveop = PL_op;
2885 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2886 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2891 SAVESPTR(PL_compcv);
2892 PL_compcv = (CV*)newSV(0);
2893 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2894 CvEVAL_on(PL_compcv);
2895 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2896 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2898 CvOUTSIDE_SEQ(PL_compcv) = seq;
2899 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2901 /* set up a scratch pad */
2903 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2906 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2908 /* make sure we compile in the right package */
2910 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2911 SAVESPTR(PL_curstash);
2912 PL_curstash = CopSTASH(PL_curcop);
2914 SAVESPTR(PL_beginav);
2915 PL_beginav = newAV();
2916 SAVEFREESV(PL_beginav);
2917 SAVEI32(PL_error_count);
2919 /* try to compile it */
2921 PL_eval_root = Nullop;
2923 PL_curcop = &PL_compiling;
2924 PL_curcop->cop_arybase = 0;
2925 if (saveop && saveop->op_type != OP_REQUIRE && saveop->op_flags & OPf_SPECIAL)
2926 PL_in_eval |= EVAL_KEEPERR;
2928 sv_setpvn(ERRSV,"",0);
2929 if (yyparse() || PL_error_count || !PL_eval_root) {
2930 SV **newsp; /* Used by POPBLOCK. */
2931 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2932 I32 optype = 0; /* Might be reset by POPEVAL. */
2937 op_free(PL_eval_root);
2938 PL_eval_root = Nullop;
2940 SP = PL_stack_base + POPMARK; /* pop original mark */
2942 POPBLOCK(cx,PL_curpm);
2948 msg = SvPVx_nolen_const(ERRSV);
2949 if (optype == OP_REQUIRE) {
2950 const SV * const nsv = cx->blk_eval.old_namesv;
2951 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2953 DIE(aTHX_ "%sCompilation failed in require",
2954 *msg ? msg : "Unknown error\n");
2957 POPBLOCK(cx,PL_curpm);
2959 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2960 (*msg ? msg : "Unknown error\n"));
2964 sv_setpv(ERRSV, "Compilation error");
2967 PERL_UNUSED_VAR(newsp);
2970 CopLINE_set(&PL_compiling, 0);
2972 *startop = PL_eval_root;
2974 SAVEFREEOP(PL_eval_root);
2976 /* Set the context for this new optree.
2977 * If the last op is an OP_REQUIRE, force scalar context.
2978 * Otherwise, propagate the context from the eval(). */
2979 if (PL_eval_root->op_type == OP_LEAVEEVAL
2980 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2981 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2983 scalar(PL_eval_root);
2984 else if (gimme & G_VOID)
2985 scalarvoid(PL_eval_root);
2986 else if (gimme & G_ARRAY)
2989 scalar(PL_eval_root);
2991 DEBUG_x(dump_eval());
2993 /* Register with debugger: */
2994 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2995 CV * const cv = get_cv("DB::postponed", FALSE);
2999 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3001 call_sv((SV*)cv, G_DISCARD);
3005 /* compiled okay, so do it */
3007 CvDEPTH(PL_compcv) = 1;
3008 SP = PL_stack_base + POPMARK; /* pop original mark */
3009 PL_op = saveop; /* The caller may need it. */
3010 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3012 RETURNOP(PL_eval_start);
3016 S_check_type_and_open(pTHX_ const char *name, const char *mode)
3019 const int st_rc = PerlLIO_stat(name, &st);
3024 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3025 Perl_die(aTHX_ "%s %s not allowed in require",
3026 S_ISDIR(st.st_mode) ? "Directory" : "Block device", name);
3028 return PerlIO_open(name, mode);
3032 S_doopen_pm(pTHX_ const char *name, const char *mode)
3034 #ifndef PERL_DISABLE_PMC
3035 const STRLEN namelen = strlen(name);
3038 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3039 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3040 const char * const pmc = SvPV_nolen_const(pmcsv);
3042 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3043 fp = check_type_and_open(name, mode);
3047 if (PerlLIO_stat(name, &pmstat) < 0 ||
3048 pmstat.st_mtime < pmcstat.st_mtime)
3050 fp = check_type_and_open(pmc, mode);
3053 fp = check_type_and_open(name, mode);
3056 SvREFCNT_dec(pmcsv);
3059 fp = check_type_and_open(name, mode);
3063 return check_type_and_open(name, mode);
3064 #endif /* !PERL_DISABLE_PMC */
3070 register PERL_CONTEXT *cx;
3074 const char *tryname = NULL;
3076 const I32 gimme = GIMME_V;
3077 int filter_has_file = 0;
3078 PerlIO *tryrsfp = NULL;
3079 GV *filter_child_proc = NULL;
3080 SV *filter_state = NULL;
3081 SV *filter_sub = NULL;
3087 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3088 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3089 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3090 "v-string in use/require non-portable");
3092 sv = new_version(sv);
3093 if (!sv_derived_from(PL_patchlevel, "version"))
3094 (void *)upg_version(PL_patchlevel);
3095 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3096 if ( vcmp(sv,PL_patchlevel) < 0 )
3097 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3098 vnormal(sv), vnormal(PL_patchlevel));
3101 if ( vcmp(sv,PL_patchlevel) > 0 )
3102 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3103 vnormal(sv), vnormal(PL_patchlevel));
3108 name = SvPV_const(sv, len);
3109 if (!(name && len > 0 && *name))
3110 DIE(aTHX_ "Null filename used");
3111 TAINT_PROPER("require");
3112 if (PL_op->op_type == OP_REQUIRE) {
3113 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3115 if (*svp != &PL_sv_undef)
3118 DIE(aTHX_ "Compilation failed in require");
3122 /* prepare to compile file */
3124 if (path_is_absolute(name)) {
3126 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3128 #ifdef MACOS_TRADITIONAL
3132 MacPerl_CanonDir(name, newname, 1);
3133 if (path_is_absolute(newname)) {
3135 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3140 AV * const ar = GvAVn(PL_incgv);
3144 if ((unixname = tounixspec(name, NULL)) != NULL)
3148 for (i = 0; i <= AvFILL(ar); i++) {
3149 SV *dirsv = *av_fetch(ar, i, TRUE);
3155 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3156 && !sv_isobject(loader))
3158 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3161 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3162 PTR2UV(SvRV(dirsv)), name);
3163 tryname = SvPVX_const(namesv);
3174 if (sv_isobject(loader))
3175 count = call_method("INC", G_ARRAY);
3177 count = call_sv(loader, G_ARRAY);
3187 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3191 if (SvTYPE(arg) == SVt_PVGV) {
3192 IO *io = GvIO((GV *)arg);
3197 tryrsfp = IoIFP(io);
3198 if (IoTYPE(io) == IoTYPE_PIPE) {
3199 /* reading from a child process doesn't
3200 nest -- when returning from reading
3201 the inner module, the outer one is
3202 unreadable (closed?) I've tried to
3203 save the gv to manage the lifespan of
3204 the pipe, but this didn't help. XXX */
3205 filter_child_proc = (GV *)arg;
3206 (void)SvREFCNT_inc(filter_child_proc);
3209 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3210 PerlIO_close(IoOFP(io));
3222 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3224 (void)SvREFCNT_inc(filter_sub);
3227 filter_state = SP[i];
3228 (void)SvREFCNT_inc(filter_state);
3232 tryrsfp = PerlIO_open("/dev/null", PERL_SCRIPT_MODE);
3247 filter_has_file = 0;
3248 if (filter_child_proc) {
3249 SvREFCNT_dec(filter_child_proc);
3250 filter_child_proc = NULL;
3253 SvREFCNT_dec(filter_state);
3254 filter_state = NULL;
3257 SvREFCNT_dec(filter_sub);
3262 if (!path_is_absolute(name)
3263 #ifdef MACOS_TRADITIONAL
3264 /* We consider paths of the form :a:b ambiguous and interpret them first
3265 as global then as local
3267 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3270 const char *dir = SvPVx_nolen_const(dirsv);
3271 #ifdef MACOS_TRADITIONAL
3275 MacPerl_CanonDir(name, buf2, 1);
3276 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3280 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3282 sv_setpv(namesv, unixdir);
3283 sv_catpv(namesv, unixname);
3285 # ifdef __SYMBIAN32__
3286 if (PL_origfilename[0] &&
3287 PL_origfilename[1] == ':' &&
3288 !(dir[0] && dir[1] == ':'))
3289 Perl_sv_setpvf(aTHX_ namesv,
3294 Perl_sv_setpvf(aTHX_ namesv,
3298 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3302 TAINT_PROPER("require");
3303 tryname = SvPVX_const(namesv);
3304 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3306 if (tryname[0] == '.' && tryname[1] == '/')
3315 SAVECOPFILE_FREE(&PL_compiling);
3316 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3317 SvREFCNT_dec(namesv);
3319 if (PL_op->op_type == OP_REQUIRE) {
3320 const char *msgstr = name;
3321 if(errno == EMFILE) {
3323 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3325 msgstr = SvPV_nolen_const(msg);
3327 if (namesv) { /* did we lookup @INC? */
3328 AV * const ar = GvAVn(PL_incgv);
3330 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3331 "%s in @INC%s%s (@INC contains:",
3333 (instr(msgstr, ".h ")
3334 ? " (change .h to .ph maybe?)" : ""),
3335 (instr(msgstr, ".ph ")
3336 ? " (did you run h2ph?)" : "")
3339 for (i = 0; i <= AvFILL(ar); i++) {
3340 sv_catpvs(msg, " ");
3341 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3343 sv_catpvs(msg, ")");
3344 msgstr = SvPV_nolen_const(msg);
3347 DIE(aTHX_ "Can't locate %s", msgstr);
3353 SETERRNO(0, SS_NORMAL);
3355 /* Assume success here to prevent recursive requirement. */
3356 /* name is never assigned to again, so len is still strlen(name) */
3357 /* Check whether a hook in @INC has already filled %INC */
3359 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3361 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3363 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 );
3368 lex_start(sv_2mortal(newSVpvs("")));
3369 SAVEGENERICSV(PL_rsfp_filters);
3370 PL_rsfp_filters = NULL;
3375 SAVESPTR(PL_compiling.cop_warnings);
3376 if (PL_dowarn & G_WARN_ALL_ON)
3377 PL_compiling.cop_warnings = pWARN_ALL ;
3378 else if (PL_dowarn & G_WARN_ALL_OFF)
3379 PL_compiling.cop_warnings = pWARN_NONE ;
3380 else if (PL_taint_warn)
3381 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3383 PL_compiling.cop_warnings = pWARN_STD ;
3384 SAVESPTR(PL_compiling.cop_io);
3385 PL_compiling.cop_io = NULL;
3387 if (filter_sub || filter_child_proc) {
3388 SV * const datasv = filter_add(S_run_user_filter, NULL);
3389 IoLINES(datasv) = filter_has_file;
3390 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3391 IoTOP_GV(datasv) = (GV *)filter_state;
3392 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3395 /* switch to eval mode */
3396 PUSHBLOCK(cx, CXt_EVAL, SP);
3397 PUSHEVAL(cx, name, Nullgv);
3398 cx->blk_eval.retop = PL_op->op_next;
3400 SAVECOPLINE(&PL_compiling);
3401 CopLINE_set(&PL_compiling, 0);
3405 /* Store and reset encoding. */
3406 encoding = PL_encoding;
3409 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3411 /* Restore encoding. */
3412 PL_encoding = encoding;
3420 register PERL_CONTEXT *cx;
3422 const I32 gimme = GIMME_V;
3423 const I32 was = PL_sub_generation;
3424 char tbuf[TYPE_DIGITS(long) + 12];
3425 char *tmpbuf = tbuf;
3431 HV *saved_hh = NULL;
3433 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3434 saved_hh = (HV*) SvREFCNT_inc(POPs);
3438 if (!SvPV_nolen_const(sv))
3440 TAINT_PROPER("eval");
3446 /* switch to eval mode */
3448 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3449 SV * const sv = sv_newmortal();
3450 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3451 (unsigned long)++PL_evalseq,
3452 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3457 len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3458 SAVECOPFILE_FREE(&PL_compiling);
3459 CopFILE_set(&PL_compiling, tmpbuf+2);
3460 SAVECOPLINE(&PL_compiling);
3461 CopLINE_set(&PL_compiling, 1);
3462 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3463 deleting the eval's FILEGV from the stash before gv_check() runs
3464 (i.e. before run-time proper). To work around the coredump that
3465 ensues, we always turn GvMULTI_on for any globals that were
3466 introduced within evals. See force_ident(). GSAR 96-10-12 */
3467 safestr = savepvn(tmpbuf, len);
3468 SAVEDELETE(PL_defstash, safestr, len);
3470 PL_hints = PL_op->op_targ;
3472 GvHV(PL_hintgv) = saved_hh;
3473 SAVESPTR(PL_compiling.cop_warnings);
3474 if (specialWARN(PL_curcop->cop_warnings))
3475 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3477 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3478 SAVEFREESV(PL_compiling.cop_warnings);
3480 SAVESPTR(PL_compiling.cop_io);
3481 if (specialCopIO(PL_curcop->cop_io))
3482 PL_compiling.cop_io = PL_curcop->cop_io;
3484 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3485 SAVEFREESV(PL_compiling.cop_io);
3487 /* special case: an eval '' executed within the DB package gets lexically
3488 * placed in the first non-DB CV rather than the current CV - this
3489 * allows the debugger to execute code, find lexicals etc, in the
3490 * scope of the code being debugged. Passing &seq gets find_runcv
3491 * to do the dirty work for us */
3492 runcv = find_runcv(&seq);
3494 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3495 PUSHEVAL(cx, 0, Nullgv);
3496 cx->blk_eval.retop = PL_op->op_next;
3498 /* prepare to compile string */
3500 if (PERLDB_LINE && PL_curstash != PL_debstash)
3501 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3503 ret = doeval(gimme, NULL, runcv, seq);
3504 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3505 && ret != PL_op->op_next) { /* Successive compilation. */
3506 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3508 return DOCATCH(ret);
3518 register PERL_CONTEXT *cx;
3520 const U8 save_flags = PL_op -> op_flags;
3525 retop = cx->blk_eval.retop;
3528 if (gimme == G_VOID)
3530 else if (gimme == G_SCALAR) {
3533 if (SvFLAGS(TOPs) & SVs_TEMP)
3536 *MARK = sv_mortalcopy(TOPs);
3540 *MARK = &PL_sv_undef;
3545 /* in case LEAVE wipes old return values */
3546 for (mark = newsp + 1; mark <= SP; mark++) {
3547 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3548 *mark = sv_mortalcopy(*mark);
3549 TAINT_NOT; /* Each item is independent */
3553 PL_curpm = newpm; /* Don't pop $1 et al till now */
3556 assert(CvDEPTH(PL_compcv) == 1);
3558 CvDEPTH(PL_compcv) = 0;
3561 if (optype == OP_REQUIRE &&
3562 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3564 /* Unassume the success we assumed earlier. */
3565 SV * const nsv = cx->blk_eval.old_namesv;
3566 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3567 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3568 /* die_where() did LEAVE, or we won't be here */
3572 if (!(save_flags & OPf_SPECIAL))
3573 sv_setpvn(ERRSV,"",0);
3582 register PERL_CONTEXT *cx;
3583 const I32 gimme = GIMME_V;
3588 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3590 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3592 PL_in_eval = EVAL_INEVAL;
3593 sv_setpvn(ERRSV,"",0);
3595 return DOCATCH(PL_op->op_next);
3604 register PERL_CONTEXT *cx;
3609 PERL_UNUSED_VAR(optype);
3612 if (gimme == G_VOID)
3614 else if (gimme == G_SCALAR) {
3618 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3621 *MARK = sv_mortalcopy(TOPs);
3625 *MARK = &PL_sv_undef;
3630 /* in case LEAVE wipes old return values */
3632 for (mark = newsp + 1; mark <= SP; mark++) {
3633 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3634 *mark = sv_mortalcopy(*mark);
3635 TAINT_NOT; /* Each item is independent */
3639 PL_curpm = newpm; /* Don't pop $1 et al till now */
3642 sv_setpvn(ERRSV,"",0);
3649 register PERL_CONTEXT *cx;
3650 const I32 gimme = GIMME_V;
3655 if (PL_op->op_targ == 0) {
3656 SV ** const defsv_p = &GvSV(PL_defgv);
3657 *defsv_p = newSVsv(POPs);
3658 SAVECLEARSV(*defsv_p);
3661 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3663 PUSHBLOCK(cx, CXt_GIVEN, SP);
3672 register PERL_CONTEXT *cx;
3679 assert(CxTYPE(cx) == CXt_GIVEN);
3685 PL_curpm = newpm; /* pop $1 et al */
3692 /* Helper routines used by pp_smartmatch */
3695 S_make_matcher(pTHX_ regexp *re)
3698 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3699 PM_SETRE(matcher, ReREFCNT_inc(re));
3701 SAVEFREEOP((OP *) matcher);
3709 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3714 PL_op = (OP *) matcher;
3719 return (SvTRUEx(POPs));
3724 S_destroy_matcher(pTHX_ PMOP *matcher)
3727 PERL_UNUSED_ARG(matcher);
3732 /* Do a smart match */
3735 return do_smartmatch(Nullhv, Nullhv);
3738 /* This version of do_smartmatch() implements the following
3739 table of smart matches:
3741 $a $b Type of Match Implied Matching Code
3742 ====== ===== ===================== =============
3743 (overloading trumps everything)
3745 Code[+] Code[+] referential equality match if refaddr($a) == refaddr($b)
3746 Any Code[+] scalar sub truth match if $b->($a)
3748 Hash Hash hash keys identical match if sort(keys(%$a)) ÈeqÇ sort(keys(%$b))
3749 Hash Array hash value slice truth match if $a->{any(@$b)}
3750 Hash Regex hash key grep match if any(keys(%$a)) =~ /$b/
3751 Hash Any hash entry existence match if exists $a->{$b}
3753 Array Array arrays are identical[*] match if $a È~~Ç $b
3754 Array Regex array grep match if any(@$a) =~ /$b/
3755 Array Num array contains number match if any($a) == $b
3756 Array Any array contains string match if any($a) eq $b
3758 Any undef undefined match if !defined $a
3759 Any Regex pattern match match if $a =~ /$b/
3760 Code() Code() results are equal match if $a->() eq $b->()
3761 Any Code() simple closure truth match if $b->() (ignoring $a)
3762 Num numish[!] numeric equality match if $a == $b
3763 Any Str string equality match if $a eq $b
3764 Any Num numeric equality match if $a == $b
3766 Any Any string equality match if $a eq $b
3769 + - this must be a code reference whose prototype (if present) is not ""
3770 (subs with a "" prototype are dealt with by the 'Code()' entry lower down)
3771 * - if a circular reference is found, we fall back to referential equality
3772 ! - either a real number, or a string that looks_like_number()
3777 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3782 SV *e = TOPs; /* e is for 'expression' */
3783 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3786 regexp *this_regex, *other_regex;
3788 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3790 # define SM_REF(type) ( \
3791 (SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_##type) && (other = e)) \
3792 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_##type) && (other = d)))
3794 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3795 ((SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_PVCV) \
3796 && NOT_EMPTY_PROTO(this) && (other = e)) \
3797 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_PVCV) \
3798 && NOT_EMPTY_PROTO(this) && (other = d)))
3800 # define SM_REGEX ( \
3801 (SvROK(d) && SvMAGICAL(this = SvRV(d)) \
3802 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3803 && (this_regex = (regexp *)mg->mg_obj) \
3806 (SvROK(e) && SvMAGICAL(this = SvRV(e)) \
3807 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3808 && (this_regex = (regexp *)mg->mg_obj) \
3812 # define SM_OTHER_REF(type) \
3813 (SvROK(other) && SvTYPE(SvRV(other)) == SVt_##type)
3815 # define SM_OTHER_REGEX (SvROK(other) && SvMAGICAL(SvRV(other)) \
3816 && (mg = mg_find(SvRV(other), PERL_MAGIC_qr)) \
3817 && (other_regex = (regexp *)mg->mg_obj))
3820 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3821 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3823 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3824 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3826 tryAMAGICbinSET(smart, 0);
3828 SP -= 2; /* Pop the values */
3830 /* Take care only to invoke mg_get() once for each argument.
3831 * Currently we do this by copying the SV if it's magical. */
3834 d = sv_mortalcopy(d);
3841 e = sv_mortalcopy(e);
3846 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(other)) )
3848 if (this == SvRV(other))
3859 c = call_sv(this, G_SCALAR);
3863 else if (SvTEMP(TOPs))
3869 else if (SM_REF(PVHV)) {
3870 if (SM_OTHER_REF(PVHV)) {
3871 /* Check that the key-sets are identical */
3873 HV *other_hv = (HV *) SvRV(other);
3875 bool other_tied = FALSE;
3876 U32 this_key_count = 0,
3877 other_key_count = 0;
3879 /* Tied hashes don't know how many keys they have. */
3880 if (SvTIED_mg(this, PERL_MAGIC_tied)) {
3883 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3884 HV * const temp = other_hv;
3885 other_hv = (HV *) this;
3889 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3892 if (!tied && HvUSEDKEYS((HV *) this) != HvUSEDKEYS(other_hv))
3895 /* The hashes have the same number of keys, so it suffices
3896 to check that one is a subset of the other. */
3897 (void) hv_iterinit((HV *) this);
3898 while ( (he = hv_iternext((HV *) this)) ) {
3900 char * const key = hv_iterkey(he, &key_len);
3904 if(!hv_exists(other_hv, key, key_len)) {
3905 (void) hv_iterinit((HV *) this); /* reset iterator */
3911 (void) hv_iterinit(other_hv);
3912 while ( hv_iternext(other_hv) )
3916 other_key_count = HvUSEDKEYS(other_hv);
3918 if (this_key_count != other_key_count)
3923 else if (SM_OTHER_REF(PVAV)) {
3924 AV * const other_av = (AV *) SvRV(other);
3925 const I32 other_len = av_len(other_av) + 1;
3928 if (HvUSEDKEYS((HV *) this) != other_len)
3931 for(i = 0; i < other_len; ++i) {
3932 SV ** const svp = av_fetch(other_av, i, FALSE);
3936 if (!svp) /* ??? When can this happen? */
3939 key = SvPV(*svp, key_len);
3940 if(!hv_exists((HV *) this, key, key_len))
3945 else if (SM_OTHER_REGEX) {
3946 PMOP * const matcher = make_matcher(other_regex);
3949 (void) hv_iterinit((HV *) this);
3950 while ( (he = hv_iternext((HV *) this)) ) {
3951 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
3952 (void) hv_iterinit((HV *) this);
3953 destroy_matcher(matcher);
3957 destroy_matcher(matcher);
3961 if (hv_exists_ent((HV *) this, other, 0))
3967 else if (SM_REF(PVAV)) {
3968 if (SM_OTHER_REF(PVAV)) {
3969 AV *other_av = (AV *) SvRV(other);
3970 if (av_len((AV *) this) != av_len(other_av))
3974 const I32 other_len = av_len(other_av);
3976 if (Nullhv == seen_this) {
3977 seen_this = newHV();
3978 (void) sv_2mortal((SV *) seen_this);
3980 if (Nullhv == seen_other) {
3981 seen_this = newHV();
3982 (void) sv_2mortal((SV *) seen_other);
3984 for(i = 0; i <= other_len; ++i) {
3985 SV * const * const this_elem = av_fetch((AV *)this, i, FALSE);
3986 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
3988 if (!this_elem || !other_elem) {
3989 if (this_elem || other_elem)
3992 else if (SM_SEEN_THIS(*this_elem)
3993 || SM_SEEN_OTHER(*other_elem))
3995 if (*this_elem != *other_elem)
3999 hv_store_ent(seen_this,
4000 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4002 hv_store_ent(seen_other,
4003 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4009 (void) do_smartmatch(seen_this, seen_other);
4019 else if (SM_OTHER_REGEX) {
4020 PMOP * const matcher = make_matcher(other_regex);
4021 const I32 this_len = av_len((AV *) this);
4024 for(i = 0; i <= this_len; ++i) {
4025 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4026 if (svp && matcher_matches_sv(matcher, *svp)) {
4027 destroy_matcher(matcher);
4031 destroy_matcher(matcher);
4034 else if (SvIOK(other) || SvNOK(other)) {
4037 for(i = 0; i <= AvFILL((AV *) this); ++i) {
4038 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4045 if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
4055 else if (SvPOK(other)) {
4056 const I32 this_len = av_len((AV *) this);
4059 for(i = 0; i <= this_len; ++i) {
4060 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4075 else if (!SvOK(d) || !SvOK(e)) {
4076 if (!SvOK(d) && !SvOK(e))
4081 else if (SM_REGEX) {
4082 PMOP * const matcher = make_matcher(this_regex);
4085 PUSHs(matcher_matches_sv(matcher, other)
4088 destroy_matcher(matcher);
4091 else if (SM_REF(PVCV)) {
4093 /* This must be a null-prototyped sub, because we
4094 already checked for the other kind. */
4100 c = call_sv(this, G_SCALAR);
4103 PUSHs(&PL_sv_undef);
4104 else if (SvTEMP(TOPs))
4107 if (SM_OTHER_REF(PVCV)) {
4108 /* This one has to be null-proto'd too.
4109 Call both of 'em, and compare the results */
4111 c = call_sv(SvRV(other), G_SCALAR);
4114 PUSHs(&PL_sv_undef);
4115 else if (SvTEMP(TOPs))
4127 else if ( ((SvIOK(d) || SvNOK(d)) && (this = d) && (other = e))
4128 || ((SvIOK(e) || SvNOK(e)) && (this = e) && (other = d)) )
4130 if (SvPOK(other) && !looks_like_number(other)) {
4131 /* String comparison */
4136 /* Otherwise, numeric comparison */
4139 if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
4150 /* As a last resort, use string comparison */
4159 register PERL_CONTEXT *cx;
4160 const I32 gimme = GIMME_V;
4162 /* This is essentially an optimization: if the match
4163 fails, we don't want to push a context and then
4164 pop it again right away, so we skip straight
4165 to the op that follows the leavewhen.
4167 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4168 return cLOGOP->op_other->op_next;
4173 PUSHBLOCK(cx, CXt_WHEN, SP);
4182 register PERL_CONTEXT *cx;
4188 assert(CxTYPE(cx) == CXt_WHEN);
4193 PL_curpm = newpm; /* pop $1 et al */
4203 register PERL_CONTEXT *cx;
4206 cxix = dopoptowhen(cxstack_ix);
4208 DIE(aTHX_ "Can't \"continue\" outside a when block");
4209 if (cxix < cxstack_ix)
4212 /* clear off anything above the scope we're re-entering */
4213 inner = PL_scopestack_ix;
4215 if (PL_scopestack_ix < inner)
4216 leave_scope(PL_scopestack[PL_scopestack_ix]);
4217 PL_curcop = cx->blk_oldcop;
4218 return cx->blk_givwhen.leave_op;
4225 register PERL_CONTEXT *cx;
4228 cxix = dopoptogiven(cxstack_ix);
4230 if (PL_op->op_flags & OPf_SPECIAL)
4231 DIE(aTHX_ "Can't use when() outside a topicalizer");
4233 DIE(aTHX_ "Can't \"break\" outside a given block");
4235 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4236 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4238 if (cxix < cxstack_ix)
4241 /* clear off anything above the scope we're re-entering */
4242 inner = PL_scopestack_ix;
4244 if (PL_scopestack_ix < inner)
4245 leave_scope(PL_scopestack[PL_scopestack_ix]);
4246 PL_curcop = cx->blk_oldcop;
4249 return cx->blk_loop.next_op;
4251 return cx->blk_givwhen.leave_op;
4255 S_doparseform(pTHX_ SV *sv)
4258 register char *s = SvPV_force(sv, len);
4259 register char * const send = s + len;
4260 register char *base = NULL;
4261 register I32 skipspaces = 0;
4262 bool noblank = FALSE;
4263 bool repeat = FALSE;
4264 bool postspace = FALSE;
4270 bool unchopnum = FALSE;
4271 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4274 Perl_croak(aTHX_ "Null picture in formline");
4276 /* estimate the buffer size needed */
4277 for (base = s; s <= send; s++) {
4278 if (*s == '\n' || *s == '@' || *s == '^')
4284 Newx(fops, maxops, U32);
4289 *fpc++ = FF_LINEMARK;
4290 noblank = repeat = FALSE;
4308 case ' ': case '\t':
4315 } /* else FALL THROUGH */
4323 *fpc++ = FF_LITERAL;
4331 *fpc++ = (U16)skipspaces;
4335 *fpc++ = FF_NEWLINE;
4339 arg = fpc - linepc + 1;
4346 *fpc++ = FF_LINEMARK;
4347 noblank = repeat = FALSE;
4356 ischop = s[-1] == '^';
4362 arg = (s - base) - 1;
4364 *fpc++ = FF_LITERAL;
4372 *fpc++ = 2; /* skip the @* or ^* */
4374 *fpc++ = FF_LINESNGL;
4377 *fpc++ = FF_LINEGLOB;
4379 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4380 arg = ischop ? 512 : 0;
4385 const char * const f = ++s;
4388 arg |= 256 + (s - f);
4390 *fpc++ = s - base; /* fieldsize for FETCH */
4391 *fpc++ = FF_DECIMAL;
4393 unchopnum |= ! ischop;
4395 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4396 arg = ischop ? 512 : 0;
4398 s++; /* skip the '0' first */
4402 const char * const f = ++s;
4405 arg |= 256 + (s - f);
4407 *fpc++ = s - base; /* fieldsize for FETCH */
4408 *fpc++ = FF_0DECIMAL;
4410 unchopnum |= ! ischop;
4414 bool ismore = FALSE;
4417 while (*++s == '>') ;
4418 prespace = FF_SPACE;
4420 else if (*s == '|') {
4421 while (*++s == '|') ;
4422 prespace = FF_HALFSPACE;
4427 while (*++s == '<') ;
4430 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4434 *fpc++ = s - base; /* fieldsize for FETCH */
4436 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4439 *fpc++ = (U16)prespace;
4453 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4455 { /* need to jump to the next word */
4457 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4458 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4459 s = SvPVX(sv) + SvCUR(sv) + z;
4461 Copy(fops, s, arg, U32);
4463 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4466 if (unchopnum && repeat)
4467 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4473 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4475 /* Can value be printed in fldsize chars, using %*.*f ? */
4479 int intsize = fldsize - (value < 0 ? 1 : 0);
4486 while (intsize--) pwr *= 10.0;
4487 while (frcsize--) eps /= 10.0;
4490 if (value + eps >= pwr)
4493 if (value - eps <= -pwr)
4500 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4503 SV * const datasv = FILTER_DATA(idx);
4504 const int filter_has_file = IoLINES(datasv);
4505 GV * const filter_child_proc = (GV *)IoFMT_GV(datasv);
4506 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4507 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4510 /* I was having segfault trouble under Linux 2.2.5 after a
4511 parse error occured. (Had to hack around it with a test
4512 for PL_error_count == 0.) Solaris doesn't segfault --
4513 not sure where the trouble is yet. XXX */
4515 if (filter_has_file) {
4516 len = FILTER_READ(idx+1, buf_sv, maxlen);
4519 if (filter_sub && len >= 0) {
4530 PUSHs(sv_2mortal(newSViv(maxlen)));
4532 PUSHs(filter_state);
4535 count = call_sv(filter_sub, G_SCALAR);
4551 IoLINES(datasv) = 0;
4552 if (filter_child_proc) {
4553 SvREFCNT_dec(filter_child_proc);
4554 IoFMT_GV(datasv) = Nullgv;
4557 SvREFCNT_dec(filter_state);
4558 IoTOP_GV(datasv) = Nullgv;
4561 SvREFCNT_dec(filter_sub);
4562 IoBOTTOM_GV(datasv) = Nullgv;
4564 filter_del(S_run_user_filter);
4570 /* perhaps someone can come up with a better name for
4571 this? it is not really "absolute", per se ... */
4573 S_path_is_absolute(pTHX_ const char *name)
4575 if (PERL_FILE_IS_ABSOLUTE(name)
4576 #ifdef MACOS_TRADITIONAL
4579 || (*name == '.' && (name[1] == '/' ||
4580 (name[1] == '.' && name[2] == '/')))
4592 * c-indentation-style: bsd
4594 * indent-tabs-mode: t
4597 * ex: set ts=8 sts=4 sw=4 noet: