3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
20 /* This file contains control-oriented pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
26 * Control-oriented means things like pp_enteriter() and pp_next(), which
27 * alter the flow of control of the program.
32 #define PERL_IN_PP_CTL_C
36 #define WORD_ALIGN sizeof(U32)
39 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
48 cxix = dopoptosub(cxstack_ix);
52 switch (cxstack[cxix].blk_gimme) {
65 /* XXXX Should store the old value to allow for tie/overload - and
66 restore in regcomp, where marked with XXXX. */
76 register PMOP *pm = (PMOP*)cLOGOP->op_other;
80 /* prevent recompiling under /o and ithreads. */
81 #if defined(USE_ITHREADS)
82 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
83 if (PL_op->op_flags & OPf_STACKED) {
92 if (PL_op->op_flags & OPf_STACKED) {
93 /* multiple args; concatentate them */
95 tmpstr = PAD_SV(ARGTARG);
96 sv_setpvn(tmpstr, "", 0);
97 while (++MARK <= SP) {
98 if (PL_amagic_generation) {
100 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
101 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
103 sv_setsv(tmpstr, sv);
107 sv_catsv(tmpstr, *MARK);
116 SV * const sv = SvRV(tmpstr);
118 mg = mg_find(sv, PERL_MAGIC_qr);
121 regexp * const re = (regexp *)mg->mg_obj;
122 ReREFCNT_dec(PM_GETRE(pm));
123 PM_SETRE(pm, ReREFCNT_inc(re));
127 const char *t = SvPV_const(tmpstr, len);
128 regexp * const re = PM_GETRE(pm);
130 /* Check against the last compiled regexp. */
131 if (!re || !re->precomp || re->prelen != (I32)len ||
132 memNE(re->precomp, t, len))
136 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
138 if (PL_op->op_flags & OPf_SPECIAL)
139 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
141 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
143 pm->op_pmdynflags |= PMdf_DYN_UTF8;
145 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
146 if (pm->op_pmdynflags & PMdf_UTF8)
147 t = (char*)bytes_to_utf8((U8*)t, &len);
149 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm));
150 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
152 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
153 inside tie/overload accessors. */
157 #ifndef INCOMPLETE_TAINTS
160 pm->op_pmdynflags |= PMdf_TAINTED;
162 pm->op_pmdynflags &= ~PMdf_TAINTED;
166 if (!PM_GETRE(pm)->prelen && PL_curpm)
168 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
169 pm->op_pmflags |= PMf_WHITE;
171 pm->op_pmflags &= ~PMf_WHITE;
173 /* XXX runtime compiled output needs to move to the pad */
174 if (pm->op_pmflags & PMf_KEEP) {
175 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
176 #if !defined(USE_ITHREADS)
177 /* XXX can't change the optree at runtime either */
178 cLOGOP->op_first->op_next = PL_op->op_next;
188 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
189 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
190 register SV * const dstr = cx->sb_dstr;
191 register char *s = cx->sb_s;
192 register char *m = cx->sb_m;
193 char *orig = cx->sb_orig;
194 register REGEXP * const rx = cx->sb_rx;
196 REGEXP *old = PM_GETRE(pm);
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 #ifdef PERL_OLD_COPY_ON_WRITE
289 sv_force_normal_flags(sv, 0);
291 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
300 (void)ReREFCNT_inc(rx);
301 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
302 rxres_save(&cx->sb_rxres, rx);
303 RETURNOP(pm->op_pmreplstart);
307 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
313 if (!p || p[1] < rx->nparens) {
314 #ifdef PERL_OLD_COPY_ON_WRITE
315 i = 7 + rx->nparens * 2;
317 i = 6 + rx->nparens * 2;
326 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : NULL);
327 RX_MATCH_COPIED_off(rx);
329 #ifdef PERL_OLD_COPY_ON_WRITE
330 *p++ = PTR2UV(rx->saved_copy);
331 rx->saved_copy = NULL;
336 *p++ = PTR2UV(rx->subbeg);
337 *p++ = (UV)rx->sublen;
338 for (i = 0; i <= rx->nparens; ++i) {
339 *p++ = (UV)rx->startp[i];
340 *p++ = (UV)rx->endp[i];
345 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
351 RX_MATCH_COPY_FREE(rx);
352 RX_MATCH_COPIED_set(rx, *p);
355 #ifdef PERL_OLD_COPY_ON_WRITE
357 SvREFCNT_dec (rx->saved_copy);
358 rx->saved_copy = INT2PTR(SV*,*p);
364 rx->subbeg = INT2PTR(char*,*p++);
365 rx->sublen = (I32)(*p++);
366 for (i = 0; i <= rx->nparens; ++i) {
367 rx->startp[i] = (I32)(*p++);
368 rx->endp[i] = (I32)(*p++);
373 Perl_rxres_free(pTHX_ void **rsp)
375 UV * const p = (UV*)*rsp;
380 void *tmp = INT2PTR(char*,*p);
383 PoisonFree(*p, 1, sizeof(*p));
385 Safefree(INT2PTR(char*,*p));
387 #ifdef PERL_OLD_COPY_ON_WRITE
389 SvREFCNT_dec (INT2PTR(SV*,p[1]));
399 dVAR; dSP; dMARK; dORIGMARK;
400 register SV * const tmpForm = *++MARK;
405 register SV *sv = NULL;
406 const char *item = NULL;
410 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
411 const char *chophere = NULL;
412 char *linemark = NULL;
414 bool gotsome = FALSE;
416 const STRLEN fudge = SvPOK(tmpForm)
417 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
418 bool item_is_utf8 = FALSE;
419 bool targ_is_utf8 = FALSE;
421 OP * parseres = NULL;
425 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
426 if (SvREADONLY(tmpForm)) {
427 SvREADONLY_off(tmpForm);
428 parseres = doparseform(tmpForm);
429 SvREADONLY_on(tmpForm);
432 parseres = doparseform(tmpForm);
436 SvPV_force(PL_formtarget, len);
437 if (DO_UTF8(PL_formtarget))
439 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
441 f = SvPV_const(tmpForm, len);
442 /* need to jump to the next word */
443 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
447 const char *name = "???";
450 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
451 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
452 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
453 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
454 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
456 case FF_CHECKNL: name = "CHECKNL"; break;
457 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
458 case FF_SPACE: name = "SPACE"; break;
459 case FF_HALFSPACE: name = "HALFSPACE"; break;
460 case FF_ITEM: name = "ITEM"; break;
461 case FF_CHOP: name = "CHOP"; break;
462 case FF_LINEGLOB: name = "LINEGLOB"; break;
463 case FF_NEWLINE: name = "NEWLINE"; break;
464 case FF_MORE: name = "MORE"; break;
465 case FF_LINEMARK: name = "LINEMARK"; break;
466 case FF_END: name = "END"; break;
467 case FF_0DECIMAL: name = "0DECIMAL"; break;
468 case FF_LINESNGL: name = "LINESNGL"; break;
471 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
473 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
484 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
485 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
487 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
488 t = SvEND(PL_formtarget);
491 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
492 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
494 sv_utf8_upgrade(PL_formtarget);
495 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
496 t = SvEND(PL_formtarget);
516 if (ckWARN(WARN_SYNTAX))
517 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
524 const char *s = item = SvPV_const(sv, len);
527 itemsize = sv_len_utf8(sv);
528 if (itemsize != (I32)len) {
530 if (itemsize > fieldsize) {
531 itemsize = fieldsize;
532 itembytes = itemsize;
533 sv_pos_u2b(sv, &itembytes, 0);
537 send = chophere = s + itembytes;
547 sv_pos_b2u(sv, &itemsize);
551 item_is_utf8 = FALSE;
552 if (itemsize > fieldsize)
553 itemsize = fieldsize;
554 send = chophere = s + itemsize;
568 const char *s = item = SvPV_const(sv, len);
571 itemsize = sv_len_utf8(sv);
572 if (itemsize != (I32)len) {
574 if (itemsize <= fieldsize) {
575 const char *send = chophere = s + itemsize;
588 itemsize = fieldsize;
589 itembytes = itemsize;
590 sv_pos_u2b(sv, &itembytes, 0);
591 send = chophere = s + itembytes;
592 while (s < send || (s == send && isSPACE(*s))) {
602 if (strchr(PL_chopset, *s))
607 itemsize = chophere - item;
608 sv_pos_b2u(sv, &itemsize);
614 item_is_utf8 = FALSE;
615 if (itemsize <= fieldsize) {
616 const char *const send = chophere = s + itemsize;
629 itemsize = fieldsize;
630 send = chophere = s + itemsize;
631 while (s < send || (s == send && isSPACE(*s))) {
641 if (strchr(PL_chopset, *s))
646 itemsize = chophere - item;
652 arg = fieldsize - itemsize;
661 arg = fieldsize - itemsize;
672 const char *s = item;
676 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
678 sv_utf8_upgrade(PL_formtarget);
679 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
680 t = SvEND(PL_formtarget);
684 if (UTF8_IS_CONTINUED(*s)) {
685 STRLEN skip = UTF8SKIP(s);
702 if ( !((*t++ = *s++) & ~31) )
708 if (targ_is_utf8 && !item_is_utf8) {
709 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
711 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
712 for (; t < SvEND(PL_formtarget); t++) {
725 const int ch = *t++ = *s++;
728 if ( !((*t++ = *s++) & ~31) )
737 const char *s = chophere;
755 const char *s = item = SvPV_const(sv, len);
757 if ((item_is_utf8 = DO_UTF8(sv)))
758 itemsize = sv_len_utf8(sv);
760 bool chopped = FALSE;
761 const char *const send = s + len;
763 chophere = s + itemsize;
779 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
781 SvUTF8_on(PL_formtarget);
783 SvCUR_set(sv, chophere - item);
784 sv_catsv(PL_formtarget, sv);
785 SvCUR_set(sv, itemsize);
787 sv_catsv(PL_formtarget, sv);
789 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
790 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
791 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
800 #if defined(USE_LONG_DOUBLE)
801 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
803 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
808 #if defined(USE_LONG_DOUBLE)
809 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
811 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
814 /* If the field is marked with ^ and the value is undefined,
816 if ((arg & 512) && !SvOK(sv)) {
824 /* overflow evidence */
825 if (num_overflow(value, fieldsize, arg)) {
831 /* Formats aren't yet marked for locales, so assume "yes". */
833 STORE_NUMERIC_STANDARD_SET_LOCAL();
835 snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
837 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
838 #endif /* ifdef USE_SNPRINTF */
839 RESTORE_NUMERIC_STANDARD();
846 while (t-- > linemark && *t == ' ') ;
854 if (arg) { /* repeat until fields exhausted? */
856 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
857 lines += FmLINES(PL_formtarget);
860 if (strnEQ(linemark, linemark - arg, arg))
861 DIE(aTHX_ "Runaway format");
864 SvUTF8_on(PL_formtarget);
865 FmLINES(PL_formtarget) = lines;
867 RETURNOP(cLISTOP->op_first);
878 const char *s = chophere;
879 const char *send = item + len;
881 while (isSPACE(*s) && (s < send))
886 arg = fieldsize - itemsize;
893 if (strnEQ(s1," ",3)) {
894 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
905 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
907 SvUTF8_on(PL_formtarget);
908 FmLINES(PL_formtarget) += lines;
920 if (PL_stack_base + *PL_markstack_ptr == SP) {
922 if (GIMME_V == G_SCALAR)
923 XPUSHs(sv_2mortal(newSViv(0)));
924 RETURNOP(PL_op->op_next->op_next);
926 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
927 pp_pushmark(); /* push dst */
928 pp_pushmark(); /* push src */
929 ENTER; /* enter outer scope */
932 if (PL_op->op_private & OPpGREP_LEX)
933 SAVESPTR(PAD_SVl(PL_op->op_targ));
936 ENTER; /* enter inner scope */
939 src = PL_stack_base[*PL_markstack_ptr];
941 if (PL_op->op_private & OPpGREP_LEX)
942 PAD_SVl(PL_op->op_targ) = src;
947 if (PL_op->op_type == OP_MAPSTART)
948 pp_pushmark(); /* push top */
949 return ((LOGOP*)PL_op->op_next)->op_other;
955 const I32 gimme = GIMME_V;
956 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
962 /* first, move source pointer to the next item in the source list */
963 ++PL_markstack_ptr[-1];
965 /* if there are new items, push them into the destination list */
966 if (items && gimme != G_VOID) {
967 /* might need to make room back there first */
968 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
969 /* XXX this implementation is very pessimal because the stack
970 * is repeatedly extended for every set of items. Is possible
971 * to do this without any stack extension or copying at all
972 * by maintaining a separate list over which the map iterates
973 * (like foreach does). --gsar */
975 /* everything in the stack after the destination list moves
976 * towards the end the stack by the amount of room needed */
977 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
979 /* items to shift up (accounting for the moved source pointer) */
980 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
982 /* This optimization is by Ben Tilly and it does
983 * things differently from what Sarathy (gsar)
984 * is describing. The downside of this optimization is
985 * that leaves "holes" (uninitialized and hopefully unused areas)
986 * to the Perl stack, but on the other hand this
987 * shouldn't be a problem. If Sarathy's idea gets
988 * implemented, this optimization should become
989 * irrelevant. --jhi */
991 shift = count; /* Avoid shifting too often --Ben Tilly */
996 PL_markstack_ptr[-1] += shift;
997 *PL_markstack_ptr += shift;
1001 /* copy the new items down to the destination list */
1002 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1003 if (gimme == G_ARRAY) {
1005 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1008 /* scalar context: we don't care about which values map returns
1009 * (we use undef here). And so we certainly don't want to do mortal
1010 * copies of meaningless values. */
1011 while (items-- > 0) {
1013 *dst-- = &PL_sv_undef;
1017 LEAVE; /* exit inner scope */
1020 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1022 (void)POPMARK; /* pop top */
1023 LEAVE; /* exit outer scope */
1024 (void)POPMARK; /* pop src */
1025 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1026 (void)POPMARK; /* pop dst */
1027 SP = PL_stack_base + POPMARK; /* pop original mark */
1028 if (gimme == G_SCALAR) {
1029 if (PL_op->op_private & OPpGREP_LEX) {
1030 SV* sv = sv_newmortal();
1031 sv_setiv(sv, items);
1039 else if (gimme == G_ARRAY)
1046 ENTER; /* enter inner scope */
1049 /* set $_ to the new source item */
1050 src = PL_stack_base[PL_markstack_ptr[-1]];
1052 if (PL_op->op_private & OPpGREP_LEX)
1053 PAD_SVl(PL_op->op_targ) = src;
1057 RETURNOP(cLOGOP->op_other);
1066 if (GIMME == G_ARRAY)
1068 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1069 return cLOGOP->op_other;
1079 if (GIMME == G_ARRAY) {
1080 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1084 SV * const targ = PAD_SV(PL_op->op_targ);
1087 if (PL_op->op_private & OPpFLIP_LINENUM) {
1088 if (GvIO(PL_last_in_gv)) {
1089 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1092 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1094 flip = SvIV(sv) == SvIV(GvSV(gv));
1100 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1101 if (PL_op->op_flags & OPf_SPECIAL) {
1109 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1112 sv_setpvn(TARG, "", 0);
1118 /* This code tries to decide if "$left .. $right" should use the
1119 magical string increment, or if the range is numeric (we make
1120 an exception for .."0" [#18165]). AMS 20021031. */
1122 #define RANGE_IS_NUMERIC(left,right) ( \
1123 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1124 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1125 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1126 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1127 && (!SvOK(right) || looks_like_number(right))))
1133 if (GIMME == G_ARRAY) {
1139 if (RANGE_IS_NUMERIC(left,right)) {
1142 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1143 (SvOK(right) && SvNV(right) > IV_MAX))
1144 DIE(aTHX_ "Range iterator outside integer range");
1155 SV * const sv = sv_2mortal(newSViv(i++));
1160 SV * const final = sv_mortalcopy(right);
1162 const char * const tmps = SvPV_const(final, len);
1164 SV *sv = sv_mortalcopy(left);
1165 SvPV_force_nolen(sv);
1166 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1168 if (strEQ(SvPVX_const(sv),tmps))
1170 sv = sv_2mortal(newSVsv(sv));
1177 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1181 if (PL_op->op_private & OPpFLIP_LINENUM) {
1182 if (GvIO(PL_last_in_gv)) {
1183 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1186 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1187 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1195 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1196 sv_catpvs(targ, "E0");
1206 static const char * const context_name[] = {
1219 S_dopoptolabel(pTHX_ const char *label)
1224 for (i = cxstack_ix; i >= 0; i--) {
1225 register const PERL_CONTEXT * const cx = &cxstack[i];
1226 switch (CxTYPE(cx)) {
1234 if (ckWARN(WARN_EXITING))
1235 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1236 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1237 if (CxTYPE(cx) == CXt_NULL)
1241 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1242 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1243 (long)i, cx->blk_loop.label));
1246 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1256 Perl_dowantarray(pTHX)
1259 const I32 gimme = block_gimme();
1260 return (gimme == G_VOID) ? G_SCALAR : gimme;
1264 Perl_block_gimme(pTHX)
1267 const I32 cxix = dopoptosub(cxstack_ix);
1271 switch (cxstack[cxix].blk_gimme) {
1279 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1286 Perl_is_lvalue_sub(pTHX)
1289 const I32 cxix = dopoptosub(cxstack_ix);
1290 assert(cxix >= 0); /* We should only be called from inside subs */
1292 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1293 return cxstack[cxix].blk_sub.lval;
1299 S_dopoptosub(pTHX_ I32 startingblock)
1302 return dopoptosub_at(cxstack, startingblock);
1306 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1310 for (i = startingblock; i >= 0; i--) {
1311 register const PERL_CONTEXT * const cx = &cxstk[i];
1312 switch (CxTYPE(cx)) {
1318 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1326 S_dopoptoeval(pTHX_ I32 startingblock)
1330 for (i = startingblock; i >= 0; i--) {
1331 register const PERL_CONTEXT *cx = &cxstack[i];
1332 switch (CxTYPE(cx)) {
1336 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1344 S_dopoptoloop(pTHX_ I32 startingblock)
1348 for (i = startingblock; i >= 0; i--) {
1349 register const PERL_CONTEXT * const cx = &cxstack[i];
1350 switch (CxTYPE(cx)) {
1356 if (ckWARN(WARN_EXITING))
1357 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1358 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1359 if ((CxTYPE(cx)) == CXt_NULL)
1363 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1371 S_dopoptogiven(pTHX_ I32 startingblock)
1375 for (i = startingblock; i >= 0; i--) {
1376 register const PERL_CONTEXT *cx = &cxstack[i];
1377 switch (CxTYPE(cx)) {
1381 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1384 if (CxFOREACHDEF(cx)) {
1385 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1394 S_dopoptowhen(pTHX_ I32 startingblock)
1398 for (i = startingblock; i >= 0; i--) {
1399 register const PERL_CONTEXT *cx = &cxstack[i];
1400 switch (CxTYPE(cx)) {
1404 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1412 Perl_dounwind(pTHX_ I32 cxix)
1417 while (cxstack_ix > cxix) {
1419 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1420 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1421 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1422 /* Note: we don't need to restore the base context info till the end. */
1423 switch (CxTYPE(cx)) {
1426 continue; /* not break */
1445 PERL_UNUSED_VAR(optype);
1449 Perl_qerror(pTHX_ SV *err)
1453 sv_catsv(ERRSV, err);
1455 sv_catsv(PL_errors, err);
1457 Perl_warn(aTHX_ "%"SVf, (void*)err);
1462 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1471 if (PL_in_eval & EVAL_KEEPERR) {
1472 static const char prefix[] = "\t(in cleanup) ";
1473 SV * const err = ERRSV;
1474 const char *e = NULL;
1476 sv_setpvn(err,"",0);
1477 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1479 e = SvPV_const(err, len);
1481 if (*e != *message || strNE(e,message))
1485 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1486 sv_catpvn(err, prefix, sizeof(prefix)-1);
1487 sv_catpvn(err, message, msglen);
1488 if (ckWARN(WARN_MISC)) {
1489 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1490 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1495 sv_setpvn(ERRSV, message, msglen);
1499 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1500 && PL_curstackinfo->si_prev)
1508 register PERL_CONTEXT *cx;
1511 if (cxix < cxstack_ix)
1514 POPBLOCK(cx,PL_curpm);
1515 if (CxTYPE(cx) != CXt_EVAL) {
1517 message = SvPVx_const(ERRSV, msglen);
1518 PerlIO_write(Perl_error_log, "panic: die ", 11);
1519 PerlIO_write(Perl_error_log, message, msglen);
1524 if (gimme == G_SCALAR)
1525 *++newsp = &PL_sv_undef;
1526 PL_stack_sp = newsp;
1530 /* LEAVE could clobber PL_curcop (see save_re_context())
1531 * XXX it might be better to find a way to avoid messing with
1532 * PL_curcop in save_re_context() instead, but this is a more
1533 * minimal fix --GSAR */
1534 PL_curcop = cx->blk_oldcop;
1536 if (optype == OP_REQUIRE) {
1537 const char* const msg = SvPVx_nolen_const(ERRSV);
1538 SV * const nsv = cx->blk_eval.old_namesv;
1539 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1541 DIE(aTHX_ "%sCompilation failed in require",
1542 *msg ? msg : "Unknown error\n");
1544 assert(CxTYPE(cx) == CXt_EVAL);
1545 return cx->blk_eval.retop;
1549 message = SvPVx_const(ERRSV, msglen);
1551 write_to_stderr(message, msglen);
1559 dVAR; dSP; dPOPTOPssrl;
1560 if (SvTRUE(left) != SvTRUE(right))
1570 register I32 cxix = dopoptosub(cxstack_ix);
1571 register const PERL_CONTEXT *cx;
1572 register const PERL_CONTEXT *ccstack = cxstack;
1573 const PERL_SI *top_si = PL_curstackinfo;
1575 const char *stashname;
1582 /* we may be in a higher stacklevel, so dig down deeper */
1583 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1584 top_si = top_si->si_prev;
1585 ccstack = top_si->si_cxstack;
1586 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1589 if (GIMME != G_ARRAY) {
1595 /* caller() should not report the automatic calls to &DB::sub */
1596 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1597 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1601 cxix = dopoptosub_at(ccstack, cxix - 1);
1604 cx = &ccstack[cxix];
1605 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1606 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1607 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1608 field below is defined for any cx. */
1609 /* caller() should not report the automatic calls to &DB::sub */
1610 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1611 cx = &ccstack[dbcxix];
1614 stashname = CopSTASHPV(cx->blk_oldcop);
1615 if (GIMME != G_ARRAY) {
1618 PUSHs(&PL_sv_undef);
1621 sv_setpv(TARG, stashname);
1630 PUSHs(&PL_sv_undef);
1632 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1633 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1634 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1637 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1638 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1639 /* So is ccstack[dbcxix]. */
1641 SV * const sv = newSV(0);
1642 gv_efullname3(sv, cvgv, NULL);
1643 PUSHs(sv_2mortal(sv));
1644 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1647 PUSHs(sv_2mortal(newSVpvs("(unknown)")));
1648 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1652 PUSHs(sv_2mortal(newSVpvs("(eval)")));
1653 PUSHs(sv_2mortal(newSViv(0)));
1655 gimme = (I32)cx->blk_gimme;
1656 if (gimme == G_VOID)
1657 PUSHs(&PL_sv_undef);
1659 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1660 if (CxTYPE(cx) == CXt_EVAL) {
1662 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1663 PUSHs(cx->blk_eval.cur_text);
1667 else if (cx->blk_eval.old_namesv) {
1668 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1671 /* eval BLOCK (try blocks have old_namesv == 0) */
1673 PUSHs(&PL_sv_undef);
1674 PUSHs(&PL_sv_undef);
1678 PUSHs(&PL_sv_undef);
1679 PUSHs(&PL_sv_undef);
1681 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1682 && CopSTASH_eq(PL_curcop, PL_debstash))
1684 AV * const ary = cx->blk_sub.argarray;
1685 const int off = AvARRAY(ary) - AvALLOC(ary);
1688 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1689 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1691 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1694 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1695 av_extend(PL_dbargs, AvFILLp(ary) + off);
1696 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1697 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1699 /* XXX only hints propagated via op_private are currently
1700 * visible (others are not easily accessible, since they
1701 * use the global PL_hints) */
1702 PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
1705 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1707 if (old_warnings == pWARN_NONE ||
1708 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1709 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1710 else if (old_warnings == pWARN_ALL ||
1711 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1712 /* Get the bit mask for $warnings::Bits{all}, because
1713 * it could have been extended by warnings::register */
1715 HV * const bits = get_hv("warnings::Bits", FALSE);
1716 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1717 mask = newSVsv(*bits_all);
1720 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1724 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1725 PUSHs(sv_2mortal(mask));
1728 PUSHs(cx->blk_oldcop->cop_hints ?
1729 sv_2mortal(newRV_noinc(
1730 (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1731 cx->blk_oldcop->cop_hints)))
1740 const char * const tmps = (MAXARG < 1) ? "" : POPpconstx;
1741 sv_reset(tmps, CopSTASH(PL_curcop));
1746 /* like pp_nextstate, but used instead when the debugger is active */
1751 PL_curcop = (COP*)PL_op;
1752 TAINT_NOT; /* Each statement is presumed innocent */
1753 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1756 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1757 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1760 register PERL_CONTEXT *cx;
1761 const I32 gimme = G_ARRAY;
1763 GV * const gv = PL_DBgv;
1764 register CV * const cv = GvCV(gv);
1767 DIE(aTHX_ "No DB::DB routine defined");
1769 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1770 /* don't do recursive DB::DB call */
1785 (void)(*CvXSUB(cv))(aTHX_ cv);
1792 PUSHBLOCK(cx, CXt_SUB, SP);
1794 cx->blk_sub.retop = PL_op->op_next;
1797 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1798 RETURNOP(CvSTART(cv));
1808 register PERL_CONTEXT *cx;
1809 const I32 gimme = GIMME_V;
1811 U32 cxtype = CXt_LOOP | CXp_FOREACH;
1819 if (PL_op->op_targ) {
1820 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1821 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1822 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1823 SVs_PADSTALE, SVs_PADSTALE);
1825 #ifndef USE_ITHREADS
1826 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1829 SAVEPADSV(PL_op->op_targ);
1830 iterdata = INT2PTR(void*, PL_op->op_targ);
1831 cxtype |= CXp_PADVAR;
1835 GV * const gv = (GV*)POPs;
1836 svp = &GvSV(gv); /* symbol table variable */
1837 SAVEGENERICSV(*svp);
1840 iterdata = (void*)gv;
1844 if (PL_op->op_private & OPpITER_DEF)
1845 cxtype |= CXp_FOR_DEF;
1849 PUSHBLOCK(cx, cxtype, SP);
1851 PUSHLOOP(cx, iterdata, MARK);
1853 PUSHLOOP(cx, svp, MARK);
1855 if (PL_op->op_flags & OPf_STACKED) {
1856 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1857 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1859 SV * const right = (SV*)cx->blk_loop.iterary;
1862 if (RANGE_IS_NUMERIC(sv,right)) {
1863 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1864 (SvOK(right) && SvNV(right) >= IV_MAX))
1865 DIE(aTHX_ "Range iterator outside integer range");
1866 cx->blk_loop.iterix = SvIV(sv);
1867 cx->blk_loop.itermax = SvIV(right);
1869 /* for correct -Dstv display */
1870 cx->blk_oldsp = sp - PL_stack_base;
1874 cx->blk_loop.iterlval = newSVsv(sv);
1875 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1876 (void) SvPV_nolen_const(right);
1879 else if (PL_op->op_private & OPpITER_REVERSED) {
1880 cx->blk_loop.itermax = 0;
1881 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1886 cx->blk_loop.iterary = PL_curstack;
1887 AvFILLp(PL_curstack) = SP - PL_stack_base;
1888 if (PL_op->op_private & OPpITER_REVERSED) {
1889 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1890 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1893 cx->blk_loop.iterix = MARK - PL_stack_base;
1903 register PERL_CONTEXT *cx;
1904 const I32 gimme = GIMME_V;
1910 PUSHBLOCK(cx, CXt_LOOP, SP);
1911 PUSHLOOP(cx, 0, SP);
1919 register PERL_CONTEXT *cx;
1926 assert(CxTYPE(cx) == CXt_LOOP);
1928 newsp = PL_stack_base + cx->blk_loop.resetsp;
1931 if (gimme == G_VOID)
1933 else if (gimme == G_SCALAR) {
1935 *++newsp = sv_mortalcopy(*SP);
1937 *++newsp = &PL_sv_undef;
1941 *++newsp = sv_mortalcopy(*++mark);
1942 TAINT_NOT; /* Each item is independent */
1948 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1949 PL_curpm = newpm; /* ... and pop $1 et al */
1960 register PERL_CONTEXT *cx;
1961 bool popsub2 = FALSE;
1962 bool clear_errsv = FALSE;
1970 const I32 cxix = dopoptosub(cxstack_ix);
1973 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1974 * sort block, which is a CXt_NULL
1977 PL_stack_base[1] = *PL_stack_sp;
1978 PL_stack_sp = PL_stack_base + 1;
1982 DIE(aTHX_ "Can't return outside a subroutine");
1984 if (cxix < cxstack_ix)
1987 if (CxMULTICALL(&cxstack[cxix])) {
1988 gimme = cxstack[cxix].blk_gimme;
1989 if (gimme == G_VOID)
1990 PL_stack_sp = PL_stack_base;
1991 else if (gimme == G_SCALAR) {
1992 PL_stack_base[1] = *PL_stack_sp;
1993 PL_stack_sp = PL_stack_base + 1;
1999 switch (CxTYPE(cx)) {
2002 retop = cx->blk_sub.retop;
2003 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2006 if (!(PL_in_eval & EVAL_KEEPERR))
2009 retop = cx->blk_eval.retop;
2013 if (optype == OP_REQUIRE &&
2014 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2016 /* Unassume the success we assumed earlier. */
2017 SV * const nsv = cx->blk_eval.old_namesv;
2018 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2019 DIE(aTHX_ "%"SVf" did not return a true value", (void*)nsv);
2024 retop = cx->blk_sub.retop;
2027 DIE(aTHX_ "panic: return");
2031 if (gimme == G_SCALAR) {
2034 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2036 *++newsp = SvREFCNT_inc(*SP);
2041 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2043 *++newsp = sv_mortalcopy(sv);
2048 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2051 *++newsp = sv_mortalcopy(*SP);
2054 *++newsp = &PL_sv_undef;
2056 else if (gimme == G_ARRAY) {
2057 while (++MARK <= SP) {
2058 *++newsp = (popsub2 && SvTEMP(*MARK))
2059 ? *MARK : sv_mortalcopy(*MARK);
2060 TAINT_NOT; /* Each item is independent */
2063 PL_stack_sp = newsp;
2066 /* Stack values are safe: */
2069 POPSUB(cx,sv); /* release CV and @_ ... */
2073 PL_curpm = newpm; /* ... and pop $1 et al */
2077 sv_setpvn(ERRSV,"",0);
2085 register PERL_CONTEXT *cx;
2096 if (PL_op->op_flags & OPf_SPECIAL) {
2097 cxix = dopoptoloop(cxstack_ix);
2099 DIE(aTHX_ "Can't \"last\" outside a loop block");
2102 cxix = dopoptolabel(cPVOP->op_pv);
2104 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2106 if (cxix < cxstack_ix)
2110 cxstack_ix++; /* temporarily protect top context */
2112 switch (CxTYPE(cx)) {
2115 newsp = PL_stack_base + cx->blk_loop.resetsp;
2116 nextop = cx->blk_loop.last_op->op_next;
2120 nextop = cx->blk_sub.retop;
2124 nextop = cx->blk_eval.retop;
2128 nextop = cx->blk_sub.retop;
2131 DIE(aTHX_ "panic: last");
2135 if (gimme == G_SCALAR) {
2137 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2138 ? *SP : sv_mortalcopy(*SP);
2140 *++newsp = &PL_sv_undef;
2142 else if (gimme == G_ARRAY) {
2143 while (++MARK <= SP) {
2144 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2145 ? *MARK : sv_mortalcopy(*MARK);
2146 TAINT_NOT; /* Each item is independent */
2154 /* Stack values are safe: */
2157 POPLOOP(cx); /* release loop vars ... */
2161 POPSUB(cx,sv); /* release CV and @_ ... */
2164 PL_curpm = newpm; /* ... and pop $1 et al */
2167 PERL_UNUSED_VAR(optype);
2168 PERL_UNUSED_VAR(gimme);
2176 register PERL_CONTEXT *cx;
2179 if (PL_op->op_flags & OPf_SPECIAL) {
2180 cxix = dopoptoloop(cxstack_ix);
2182 DIE(aTHX_ "Can't \"next\" outside a loop block");
2185 cxix = dopoptolabel(cPVOP->op_pv);
2187 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2189 if (cxix < cxstack_ix)
2192 /* clear off anything above the scope we're re-entering, but
2193 * save the rest until after a possible continue block */
2194 inner = PL_scopestack_ix;
2196 if (PL_scopestack_ix < inner)
2197 leave_scope(PL_scopestack[PL_scopestack_ix]);
2198 PL_curcop = cx->blk_oldcop;
2199 return cx->blk_loop.next_op;
2206 register PERL_CONTEXT *cx;
2210 if (PL_op->op_flags & OPf_SPECIAL) {
2211 cxix = dopoptoloop(cxstack_ix);
2213 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2216 cxix = dopoptolabel(cPVOP->op_pv);
2218 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2220 if (cxix < cxstack_ix)
2223 redo_op = cxstack[cxix].blk_loop.redo_op;
2224 if (redo_op->op_type == OP_ENTER) {
2225 /* pop one less context to avoid $x being freed in while (my $x..) */
2227 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2228 redo_op = redo_op->op_next;
2232 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2233 LEAVE_SCOPE(oldsave);
2235 PL_curcop = cx->blk_oldcop;
2240 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2244 static const char too_deep[] = "Target of goto is too deeply nested";
2247 Perl_croak(aTHX_ too_deep);
2248 if (o->op_type == OP_LEAVE ||
2249 o->op_type == OP_SCOPE ||
2250 o->op_type == OP_LEAVELOOP ||
2251 o->op_type == OP_LEAVESUB ||
2252 o->op_type == OP_LEAVETRY)
2254 *ops++ = cUNOPo->op_first;
2256 Perl_croak(aTHX_ too_deep);
2259 if (o->op_flags & OPf_KIDS) {
2261 /* First try all the kids at this level, since that's likeliest. */
2262 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2263 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2264 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2267 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2268 if (kid == PL_lastgotoprobe)
2270 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2273 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2274 ops[-1]->op_type == OP_DBSTATE)
2279 if ((o = dofindlabel(kid, label, ops, oplimit)))
2292 register PERL_CONTEXT *cx;
2293 #define GOTO_DEPTH 64
2294 OP *enterops[GOTO_DEPTH];
2295 const char *label = NULL;
2296 const bool do_dump = (PL_op->op_type == OP_DUMP);
2297 static const char must_have_label[] = "goto must have label";
2299 if (PL_op->op_flags & OPf_STACKED) {
2300 SV * const sv = POPs;
2302 /* This egregious kludge implements goto &subroutine */
2303 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2305 register PERL_CONTEXT *cx;
2306 CV* cv = (CV*)SvRV(sv);
2313 if (!CvROOT(cv) && !CvXSUB(cv)) {
2314 const GV * const gv = CvGV(cv);
2318 /* autoloaded stub? */
2319 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2321 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2322 GvNAMELEN(gv), FALSE);
2323 if (autogv && (cv = GvCV(autogv)))
2325 tmpstr = sv_newmortal();
2326 gv_efullname3(tmpstr, gv, NULL);
2327 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",(void*)tmpstr);
2329 DIE(aTHX_ "Goto undefined subroutine");
2332 /* First do some returnish stuff. */
2333 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2335 cxix = dopoptosub(cxstack_ix);
2337 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2338 if (cxix < cxstack_ix)
2342 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2343 if (CxTYPE(cx) == CXt_EVAL) {
2345 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2347 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2349 else if (CxMULTICALL(cx))
2350 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2351 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2352 /* put @_ back onto stack */
2353 AV* av = cx->blk_sub.argarray;
2355 items = AvFILLp(av) + 1;
2356 EXTEND(SP, items+1); /* @_ could have been extended. */
2357 Copy(AvARRAY(av), SP + 1, items, SV*);
2358 SvREFCNT_dec(GvAV(PL_defgv));
2359 GvAV(PL_defgv) = cx->blk_sub.savearray;
2361 /* abandon @_ if it got reified */
2366 av_extend(av, items-1);
2368 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2371 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2372 AV* const av = GvAV(PL_defgv);
2373 items = AvFILLp(av) + 1;
2374 EXTEND(SP, items+1); /* @_ could have been extended. */
2375 Copy(AvARRAY(av), SP + 1, items, SV*);
2379 if (CxTYPE(cx) == CXt_SUB &&
2380 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2381 SvREFCNT_dec(cx->blk_sub.cv);
2382 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2383 LEAVE_SCOPE(oldsave);
2385 /* Now do some callish stuff. */
2387 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2389 OP* const retop = cx->blk_sub.retop;
2394 for (index=0; index<items; index++)
2395 sv_2mortal(SP[-index]);
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);
2408 AV* const padlist = CvPADLIST(cv);
2409 if (CxTYPE(cx) == CXt_EVAL) {
2410 PL_in_eval = cx->blk_eval.old_in_eval;
2411 PL_eval_root = cx->blk_eval.old_eval_root;
2412 cx->cx_type = CXt_SUB;
2413 cx->blk_sub.hasargs = 0;
2415 cx->blk_sub.cv = cv;
2416 cx->blk_sub.olddepth = CvDEPTH(cv);
2419 if (CvDEPTH(cv) < 2)
2420 SvREFCNT_inc_simple_void_NN(cv);
2422 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2423 sub_crush_depth(cv);
2424 pad_push(padlist, CvDEPTH(cv));
2427 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2428 if (cx->blk_sub.hasargs)
2430 AV* const av = (AV*)PAD_SVl(0);
2432 cx->blk_sub.savearray = GvAV(PL_defgv);
2433 GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2434 CX_CURPAD_SAVE(cx->blk_sub);
2435 cx->blk_sub.argarray = av;
2437 if (items >= AvMAX(av) + 1) {
2438 SV **ary = AvALLOC(av);
2439 if (AvARRAY(av) != ary) {
2440 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2441 SvPV_set(av, (char*)ary);
2443 if (items >= AvMAX(av) + 1) {
2444 AvMAX(av) = items - 1;
2445 Renew(ary,items+1,SV*);
2447 SvPV_set(av, (char*)ary);
2451 Copy(mark,AvARRAY(av),items,SV*);
2452 AvFILLp(av) = items - 1;
2453 assert(!AvREAL(av));
2455 /* transfer 'ownership' of refcnts to new @_ */
2465 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2467 * We do not care about using sv to call CV;
2468 * it's for informational purposes only.
2470 SV * const sv = GvSV(PL_DBsub);
2472 if (PERLDB_SUB_NN) {
2473 const int type = SvTYPE(sv);
2474 if (type < SVt_PVIV && type != SVt_IV)
2475 sv_upgrade(sv, SVt_PVIV);
2477 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2479 gv_efullname3(sv, CvGV(cv), NULL);
2482 CV * const gotocv = get_cv("DB::goto", FALSE);
2484 PUSHMARK( PL_stack_sp );
2485 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2490 RETURNOP(CvSTART(cv));
2494 label = SvPV_nolen_const(sv);
2495 if (!(do_dump || *label))
2496 DIE(aTHX_ must_have_label);
2499 else if (PL_op->op_flags & OPf_SPECIAL) {
2501 DIE(aTHX_ must_have_label);
2504 label = cPVOP->op_pv;
2506 if (label && *label) {
2507 OP *gotoprobe = NULL;
2508 bool leaving_eval = FALSE;
2509 bool in_block = FALSE;
2510 PERL_CONTEXT *last_eval_cx = NULL;
2514 PL_lastgotoprobe = NULL;
2516 for (ix = cxstack_ix; ix >= 0; ix--) {
2518 switch (CxTYPE(cx)) {
2520 leaving_eval = TRUE;
2521 if (!CxTRYBLOCK(cx)) {
2522 gotoprobe = (last_eval_cx ?
2523 last_eval_cx->blk_eval.old_eval_root :
2528 /* else fall through */
2530 gotoprobe = cx->blk_oldcop->op_sibling;
2536 gotoprobe = cx->blk_oldcop->op_sibling;
2539 gotoprobe = PL_main_root;
2542 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2543 gotoprobe = CvROOT(cx->blk_sub.cv);
2549 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2552 DIE(aTHX_ "panic: goto");
2553 gotoprobe = PL_main_root;
2557 retop = dofindlabel(gotoprobe, label,
2558 enterops, enterops + GOTO_DEPTH);
2562 PL_lastgotoprobe = gotoprobe;
2565 DIE(aTHX_ "Can't find label %s", label);
2567 /* if we're leaving an eval, check before we pop any frames
2568 that we're not going to punt, otherwise the error
2571 if (leaving_eval && *enterops && enterops[1]) {
2573 for (i = 1; enterops[i]; i++)
2574 if (enterops[i]->op_type == OP_ENTERITER)
2575 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2578 /* pop unwanted frames */
2580 if (ix < cxstack_ix) {
2587 oldsave = PL_scopestack[PL_scopestack_ix];
2588 LEAVE_SCOPE(oldsave);
2591 /* push wanted frames */
2593 if (*enterops && enterops[1]) {
2594 OP * const oldop = PL_op;
2595 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2596 for (; enterops[ix]; ix++) {
2597 PL_op = enterops[ix];
2598 /* Eventually we may want to stack the needed arguments
2599 * for each op. For now, we punt on the hard ones. */
2600 if (PL_op->op_type == OP_ENTERITER)
2601 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2602 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2610 if (!retop) retop = PL_main_start;
2612 PL_restartop = retop;
2613 PL_do_undump = TRUE;
2617 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2618 PL_do_undump = FALSE;
2635 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2637 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2640 PL_exit_flags |= PERL_EXIT_EXPECTED;
2642 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2643 if (anum || !(PL_minus_c && PL_madskills))
2648 PUSHs(&PL_sv_undef);
2655 S_save_lines(pTHX_ AV *array, SV *sv)
2657 const char *s = SvPVX_const(sv);
2658 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2661 while (s && s < send) {
2663 SV * const tmpstr = newSV(0);
2665 sv_upgrade(tmpstr, SVt_PVMG);
2666 t = strchr(s, '\n');
2672 sv_setpvn(tmpstr, s, t - s);
2673 av_store(array, line++, tmpstr);
2679 S_docatch_body(pTHX)
2687 S_docatch(pTHX_ OP *o)
2691 OP * const oldop = PL_op;
2695 assert(CATCH_GET == TRUE);
2702 assert(cxstack_ix >= 0);
2703 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2704 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2709 /* die caught by an inner eval - continue inner loop */
2711 /* NB XXX we rely on the old popped CxEVAL still being at the top
2712 * of the stack; the way die_where() currently works, this
2713 * assumption is valid. In theory The cur_top_env value should be
2714 * returned in another global, the way retop (aka PL_restartop)
2716 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2719 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2721 PL_op = PL_restartop;
2738 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2739 /* sv Text to convert to OP tree. */
2740 /* startop op_free() this to undo. */
2741 /* code Short string id of the caller. */
2743 /* FIXME - how much of this code is common with pp_entereval? */
2744 dVAR; dSP; /* Make POPBLOCK work. */
2751 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2752 char *tmpbuf = tbuf;
2755 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2761 /* switch to eval mode */
2763 if (IN_PERL_COMPILETIME) {
2764 SAVECOPSTASH_FREE(&PL_compiling);
2765 CopSTASH_set(&PL_compiling, PL_curstash);
2767 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2768 SV * const sv = sv_newmortal();
2769 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2770 code, (unsigned long)++PL_evalseq,
2771 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2777 len = snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2778 (unsigned long)++PL_evalseq);
2780 len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
2781 (unsigned long)++PL_evalseq);
2782 #endif /* ifdef USE_SNPRINTF */
2783 SAVECOPFILE_FREE(&PL_compiling);
2784 CopFILE_set(&PL_compiling, tmpbuf+2);
2785 SAVECOPLINE(&PL_compiling);
2786 CopLINE_set(&PL_compiling, 1);
2787 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2788 deleting the eval's FILEGV from the stash before gv_check() runs
2789 (i.e. before run-time proper). To work around the coredump that
2790 ensues, we always turn GvMULTI_on for any globals that were
2791 introduced within evals. See force_ident(). GSAR 96-10-12 */
2792 safestr = savepvn(tmpbuf, len);
2793 SAVEDELETE(PL_defstash, safestr, len);
2795 #ifdef OP_IN_REGISTER
2801 /* we get here either during compilation, or via pp_regcomp at runtime */
2802 runtime = IN_PERL_RUNTIME;
2804 runcv = find_runcv(NULL);
2807 PL_op->op_type = OP_ENTEREVAL;
2808 PL_op->op_flags = 0; /* Avoid uninit warning. */
2809 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2810 PUSHEVAL(cx, 0, NULL);
2813 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2815 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2816 POPBLOCK(cx,PL_curpm);
2819 (*startop)->op_type = OP_NULL;
2820 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2822 /* XXX DAPM do this properly one year */
2823 *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2825 if (IN_PERL_COMPILETIME)
2826 CopHINTS_set(&PL_compiling, PL_hints);
2827 #ifdef OP_IN_REGISTER
2830 PERL_UNUSED_VAR(newsp);
2831 PERL_UNUSED_VAR(optype);
2838 =for apidoc find_runcv
2840 Locate the CV corresponding to the currently executing sub or eval.
2841 If db_seqp is non_null, skip CVs that are in the DB package and populate
2842 *db_seqp with the cop sequence number at the point that the DB:: code was
2843 entered. (allows debuggers to eval in the scope of the breakpoint rather
2844 than in the scope of the debugger itself).
2850 Perl_find_runcv(pTHX_ U32 *db_seqp)
2856 *db_seqp = PL_curcop->cop_seq;
2857 for (si = PL_curstackinfo; si; si = si->si_prev) {
2859 for (ix = si->si_cxix; ix >= 0; ix--) {
2860 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2861 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2862 CV * const cv = cx->blk_sub.cv;
2863 /* skip DB:: code */
2864 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2865 *db_seqp = cx->blk_oldcop->cop_seq;
2870 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2878 /* Compile a require/do, an eval '', or a /(?{...})/.
2879 * In the last case, startop is non-null, and contains the address of
2880 * a pointer that should be set to the just-compiled code.
2881 * outside is the lexically enclosing CV (if any) that invoked us.
2884 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2886 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2889 OP * const saveop = PL_op;
2891 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2892 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2897 SAVESPTR(PL_compcv);
2898 PL_compcv = (CV*)newSV(0);
2899 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2900 CvEVAL_on(PL_compcv);
2901 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2902 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2904 CvOUTSIDE_SEQ(PL_compcv) = seq;
2905 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2907 /* set up a scratch pad */
2909 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2910 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2914 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2916 /* make sure we compile in the right package */
2918 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2919 SAVESPTR(PL_curstash);
2920 PL_curstash = CopSTASH(PL_curcop);
2922 SAVESPTR(PL_beginav);
2923 PL_beginav = newAV();
2924 SAVEFREESV(PL_beginav);
2925 SAVEI32(PL_error_count);
2928 SAVEI32(PL_madskills);
2932 /* try to compile it */
2934 PL_eval_root = NULL;
2936 PL_curcop = &PL_compiling;
2937 CopARYBASE_set(PL_curcop, 0);
2938 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2939 PL_in_eval |= EVAL_KEEPERR;
2941 sv_setpvn(ERRSV,"",0);
2942 if (yyparse() || PL_error_count || !PL_eval_root) {
2943 SV **newsp; /* Used by POPBLOCK. */
2944 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2945 I32 optype = 0; /* Might be reset by POPEVAL. */
2950 op_free(PL_eval_root);
2951 PL_eval_root = NULL;
2953 SP = PL_stack_base + POPMARK; /* pop original mark */
2955 POPBLOCK(cx,PL_curpm);
2961 msg = SvPVx_nolen_const(ERRSV);
2962 if (optype == OP_REQUIRE) {
2963 const SV * const nsv = cx->blk_eval.old_namesv;
2964 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2966 DIE(aTHX_ "%sCompilation failed in require",
2967 *msg ? msg : "Unknown error\n");
2970 POPBLOCK(cx,PL_curpm);
2972 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2973 (*msg ? msg : "Unknown error\n"));
2977 sv_setpv(ERRSV, "Compilation error");
2980 PERL_UNUSED_VAR(newsp);
2983 CopLINE_set(&PL_compiling, 0);
2985 *startop = PL_eval_root;
2987 SAVEFREEOP(PL_eval_root);
2989 /* Set the context for this new optree.
2990 * If the last op is an OP_REQUIRE, force scalar context.
2991 * Otherwise, propagate the context from the eval(). */
2992 if (PL_eval_root->op_type == OP_LEAVEEVAL
2993 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2994 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2996 scalar(PL_eval_root);
2997 else if (gimme & G_VOID)
2998 scalarvoid(PL_eval_root);
2999 else if (gimme & G_ARRAY)
3002 scalar(PL_eval_root);
3004 DEBUG_x(dump_eval());
3006 /* Register with debugger: */
3007 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3008 CV * const cv = get_cv("DB::postponed", FALSE);
3012 XPUSHs((SV*)CopFILEGV(&PL_compiling));
3014 call_sv((SV*)cv, G_DISCARD);
3018 /* compiled okay, so do it */
3020 CvDEPTH(PL_compcv) = 1;
3021 SP = PL_stack_base + POPMARK; /* pop original mark */
3022 PL_op = saveop; /* The caller may need it. */
3023 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
3025 RETURNOP(PL_eval_start);
3029 S_check_type_and_open(pTHX_ const char *name, const char *mode)
3032 const int st_rc = PerlLIO_stat(name, &st);
3034 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3038 return PerlIO_open(name, mode);
3042 S_doopen_pm(pTHX_ const char *name, const char *mode)
3044 #ifndef PERL_DISABLE_PMC
3045 const STRLEN namelen = strlen(name);
3048 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3049 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3050 const char * const pmc = SvPV_nolen_const(pmcsv);
3052 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3053 fp = check_type_and_open(name, mode);
3056 fp = check_type_and_open(pmc, mode);
3058 SvREFCNT_dec(pmcsv);
3061 fp = check_type_and_open(name, mode);
3065 return check_type_and_open(name, mode);
3066 #endif /* !PERL_DISABLE_PMC */
3072 register PERL_CONTEXT *cx;
3076 const char *tryname = NULL;
3078 const I32 gimme = GIMME_V;
3079 int filter_has_file = 0;
3080 PerlIO *tryrsfp = NULL;
3081 SV *filter_cache = NULL;
3082 SV *filter_state = NULL;
3083 SV *filter_sub = NULL;
3089 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3090 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3091 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3092 "v-string in use/require non-portable");
3094 sv = new_version(sv);
3095 if (!sv_derived_from(PL_patchlevel, "version"))
3096 upg_version(PL_patchlevel);
3097 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3098 if ( vcmp(sv,PL_patchlevel) <= 0 )
3099 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3100 (void*)vnormal(sv), (void*)vnormal(PL_patchlevel));
3103 if ( vcmp(sv,PL_patchlevel) > 0 )
3104 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3105 (void*)vnormal(sv), (void*)vnormal(PL_patchlevel));
3110 name = SvPV_const(sv, len);
3111 if (!(name && len > 0 && *name))
3112 DIE(aTHX_ "Null filename used");
3113 TAINT_PROPER("require");
3114 if (PL_op->op_type == OP_REQUIRE) {
3115 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3117 if (*svp != &PL_sv_undef)
3120 DIE(aTHX_ "Compilation failed in require");
3124 /* prepare to compile file */
3126 if (path_is_absolute(name)) {
3128 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3130 #ifdef MACOS_TRADITIONAL
3134 MacPerl_CanonDir(name, newname, 1);
3135 if (path_is_absolute(newname)) {
3137 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3142 AV * const ar = GvAVn(PL_incgv);
3146 if ((unixname = tounixspec(name, NULL)) != NULL)
3150 for (i = 0; i <= AvFILL(ar); i++) {
3151 SV * const dirsv = *av_fetch(ar, i, TRUE);
3157 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3158 && !sv_isobject(loader))
3160 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3163 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3164 PTR2UV(SvRV(dirsv)), name);
3165 tryname = SvPVX_const(namesv);
3176 if (sv_isobject(loader))
3177 count = call_method("INC", G_ARRAY);
3179 count = call_sv(loader, G_ARRAY);
3189 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3190 && !isGV_with_GP(SvRV(arg))) {
3191 filter_cache = SvRV(arg);
3192 SvREFCNT_inc_simple_void_NN(filter_cache);
3199 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3203 if (SvTYPE(arg) == SVt_PVGV) {
3204 IO * const io = GvIO((GV *)arg);
3209 tryrsfp = IoIFP(io);
3210 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3211 PerlIO_close(IoOFP(io));
3222 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3224 SvREFCNT_inc_simple_void_NN(filter_sub);
3227 filter_state = SP[i];
3228 SvREFCNT_inc_simple_void(filter_state);
3232 if (!tryrsfp && (filter_cache || filter_sub)) {
3233 tryrsfp = PerlIO_open(BIT_BUCKET,
3248 filter_has_file = 0;
3250 SvREFCNT_dec(filter_cache);
3251 filter_cache = NULL;
3254 SvREFCNT_dec(filter_state);
3255 filter_state = NULL;
3258 SvREFCNT_dec(filter_sub);
3263 if (!path_is_absolute(name)
3264 #ifdef MACOS_TRADITIONAL
3265 /* We consider paths of the form :a:b ambiguous and interpret them first
3266 as global then as local
3268 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3271 const char *dir = SvPVx_nolen_const(dirsv);
3272 #ifdef MACOS_TRADITIONAL
3276 MacPerl_CanonDir(name, buf2, 1);
3277 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3281 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3283 sv_setpv(namesv, unixdir);
3284 sv_catpv(namesv, unixname);
3286 # ifdef __SYMBIAN32__
3287 if (PL_origfilename[0] &&
3288 PL_origfilename[1] == ':' &&
3289 !(dir[0] && dir[1] == ':'))
3290 Perl_sv_setpvf(aTHX_ namesv,
3295 Perl_sv_setpvf(aTHX_ namesv,
3299 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3303 TAINT_PROPER("require");
3304 tryname = SvPVX_const(namesv);
3305 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3307 if (tryname[0] == '.' && tryname[1] == '/')
3316 SAVECOPFILE_FREE(&PL_compiling);
3317 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3318 SvREFCNT_dec(namesv);
3320 if (PL_op->op_type == OP_REQUIRE) {
3321 const char *msgstr = name;
3322 if(errno == EMFILE) {
3324 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3326 msgstr = SvPV_nolen_const(msg);
3328 if (namesv) { /* did we lookup @INC? */
3329 AV * const ar = GvAVn(PL_incgv);
3331 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3332 "%s in @INC%s%s (@INC contains:",
3334 (instr(msgstr, ".h ")
3335 ? " (change .h to .ph maybe?)" : ""),
3336 (instr(msgstr, ".ph ")
3337 ? " (did you run h2ph?)" : "")
3340 for (i = 0; i <= AvFILL(ar); i++) {
3341 sv_catpvs(msg, " ");
3342 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3344 sv_catpvs(msg, ")");
3345 msgstr = SvPV_nolen_const(msg);
3348 DIE(aTHX_ "Can't locate %s", msgstr);
3354 SETERRNO(0, SS_NORMAL);
3356 /* Assume success here to prevent recursive requirement. */
3357 /* name is never assigned to again, so len is still strlen(name) */
3358 /* Check whether a hook in @INC has already filled %INC */
3360 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3362 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3364 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc_simple(hook_sv), 0 );
3369 lex_start(sv_2mortal(newSVpvs("")));
3370 SAVEGENERICSV(PL_rsfp_filters);
3371 PL_rsfp_filters = NULL;
3376 SAVECOMPILEWARNINGS();
3377 if (PL_dowarn & G_WARN_ALL_ON)
3378 PL_compiling.cop_warnings = pWARN_ALL ;
3379 else if (PL_dowarn & G_WARN_ALL_OFF)
3380 PL_compiling.cop_warnings = pWARN_NONE ;
3381 else if (PL_taint_warn) {
3382 PL_compiling.cop_warnings
3383 = Perl_new_warnings_bitfield(aTHX_ NULL, WARN_TAINTstring, WARNsize);
3386 PL_compiling.cop_warnings = pWARN_STD ;
3387 SAVESPTR(PL_compiling.cop_io);
3388 PL_compiling.cop_io = NULL;
3390 if (filter_sub || filter_cache) {
3391 SV * const datasv = filter_add(S_run_user_filter, NULL);
3392 IoLINES(datasv) = filter_has_file;
3393 IoTOP_GV(datasv) = (GV *)filter_state;
3394 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3395 IoFMT_GV(datasv) = (GV *)filter_cache;
3398 /* switch to eval mode */
3399 PUSHBLOCK(cx, CXt_EVAL, SP);
3400 PUSHEVAL(cx, name, NULL);
3401 cx->blk_eval.retop = PL_op->op_next;
3403 SAVECOPLINE(&PL_compiling);
3404 CopLINE_set(&PL_compiling, 0);
3408 /* Store and reset encoding. */
3409 encoding = PL_encoding;
3412 op = DOCATCH(doeval(gimme, NULL, NULL, PL_curcop->cop_seq));
3414 /* Restore encoding. */
3415 PL_encoding = encoding;
3423 register PERL_CONTEXT *cx;
3425 const I32 gimme = GIMME_V;
3426 const I32 was = PL_sub_generation;
3427 char tbuf[TYPE_DIGITS(long) + 12];
3428 char *tmpbuf = tbuf;
3434 HV *saved_hh = NULL;
3435 const char * const fakestr = "_<(eval )";
3437 const int fakelen = 9 + 1;
3440 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3441 saved_hh = (HV*) SvREFCNT_inc(POPs);
3445 if (!SvPV_nolen_const(sv))
3447 TAINT_PROPER("eval");
3453 /* switch to eval mode */
3455 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3456 SV * const temp_sv = sv_newmortal();
3457 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3458 (unsigned long)++PL_evalseq,
3459 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3460 tmpbuf = SvPVX(temp_sv);
3461 len = SvCUR(temp_sv);
3465 len = snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3467 len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3468 #endif /* ifdef USE_SNPRINTF */
3469 SAVECOPFILE_FREE(&PL_compiling);
3470 CopFILE_set(&PL_compiling, tmpbuf+2);
3471 SAVECOPLINE(&PL_compiling);
3472 CopLINE_set(&PL_compiling, 1);
3473 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3474 deleting the eval's FILEGV from the stash before gv_check() runs
3475 (i.e. before run-time proper). To work around the coredump that
3476 ensues, we always turn GvMULTI_on for any globals that were
3477 introduced within evals. See force_ident(). GSAR 96-10-12 */
3478 safestr = savepvn(tmpbuf, len);
3479 SAVEDELETE(PL_defstash, safestr, len);
3481 PL_hints = PL_op->op_targ;
3483 GvHV(PL_hintgv) = saved_hh;
3484 SAVECOMPILEWARNINGS();
3485 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3486 SAVESPTR(PL_compiling.cop_io);
3487 if (specialCopIO(PL_curcop->cop_io))
3488 PL_compiling.cop_io = PL_curcop->cop_io;
3490 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3491 SAVEFREESV(PL_compiling.cop_io);
3493 if (PL_compiling.cop_hints) {
3494 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints);
3496 PL_compiling.cop_hints = PL_curcop->cop_hints;
3497 if (PL_compiling.cop_hints) {
3499 PL_compiling.cop_hints->refcounted_he_refcnt++;
3500 HINTS_REFCNT_UNLOCK;
3502 /* special case: an eval '' executed within the DB package gets lexically
3503 * placed in the first non-DB CV rather than the current CV - this
3504 * allows the debugger to execute code, find lexicals etc, in the
3505 * scope of the code being debugged. Passing &seq gets find_runcv
3506 * to do the dirty work for us */
3507 runcv = find_runcv(&seq);
3509 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3510 PUSHEVAL(cx, 0, NULL);
3511 cx->blk_eval.retop = PL_op->op_next;
3513 /* prepare to compile string */
3515 if (PERLDB_LINE && PL_curstash != PL_debstash)
3516 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3518 ret = doeval(gimme, NULL, runcv, seq);
3519 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3520 && ret != PL_op->op_next) { /* Successive compilation. */
3521 /* Copy in anything fake and short. */
3523 strlcpy(safestr, fakestr, fakelen);
3525 strcpy(safestr, fakestr);
3526 #endif /* #ifdef HAS_STRLCPY */
3528 return DOCATCH(ret);
3538 register PERL_CONTEXT *cx;
3540 const U8 save_flags = PL_op -> op_flags;
3545 retop = cx->blk_eval.retop;
3548 if (gimme == G_VOID)
3550 else if (gimme == G_SCALAR) {
3553 if (SvFLAGS(TOPs) & SVs_TEMP)
3556 *MARK = sv_mortalcopy(TOPs);
3560 *MARK = &PL_sv_undef;
3565 /* in case LEAVE wipes old return values */
3566 for (mark = newsp + 1; mark <= SP; mark++) {
3567 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3568 *mark = sv_mortalcopy(*mark);
3569 TAINT_NOT; /* Each item is independent */
3573 PL_curpm = newpm; /* Don't pop $1 et al till now */
3576 assert(CvDEPTH(PL_compcv) == 1);
3578 CvDEPTH(PL_compcv) = 0;
3581 if (optype == OP_REQUIRE &&
3582 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3584 /* Unassume the success we assumed earlier. */
3585 SV * const nsv = cx->blk_eval.old_namesv;
3586 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3587 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", (void*)nsv);
3588 /* die_where() did LEAVE, or we won't be here */
3592 if (!(save_flags & OPf_SPECIAL))
3593 sv_setpvn(ERRSV,"",0);
3599 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3600 close to the related Perl_create_eval_scope. */
3602 Perl_delete_eval_scope(pTHX)
3607 register PERL_CONTEXT *cx;
3614 PERL_UNUSED_VAR(newsp);
3615 PERL_UNUSED_VAR(gimme);
3616 PERL_UNUSED_VAR(optype);
3619 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3620 also needed by Perl_fold_constants. */
3622 Perl_create_eval_scope(pTHX_ U32 flags)
3625 const I32 gimme = GIMME_V;
3630 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3632 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3634 PL_in_eval = EVAL_INEVAL;
3635 if (flags & G_KEEPERR)
3636 PL_in_eval |= EVAL_KEEPERR;
3638 sv_setpvn(ERRSV,"",0);
3639 if (flags & G_FAKINGEVAL) {
3640 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3648 PERL_CONTEXT * const cx = create_eval_scope(0);
3649 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3650 return DOCATCH(PL_op->op_next);
3659 register PERL_CONTEXT *cx;
3664 PERL_UNUSED_VAR(optype);
3667 if (gimme == G_VOID)
3669 else if (gimme == G_SCALAR) {
3673 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3676 *MARK = sv_mortalcopy(TOPs);
3680 *MARK = &PL_sv_undef;
3685 /* in case LEAVE wipes old return values */
3687 for (mark = newsp + 1; mark <= SP; mark++) {
3688 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3689 *mark = sv_mortalcopy(*mark);
3690 TAINT_NOT; /* Each item is independent */
3694 PL_curpm = newpm; /* Don't pop $1 et al till now */
3697 sv_setpvn(ERRSV,"",0);
3704 register PERL_CONTEXT *cx;
3705 const I32 gimme = GIMME_V;
3710 if (PL_op->op_targ == 0) {
3711 SV ** const defsv_p = &GvSV(PL_defgv);
3712 *defsv_p = newSVsv(POPs);
3713 SAVECLEARSV(*defsv_p);
3716 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3718 PUSHBLOCK(cx, CXt_GIVEN, SP);
3727 register PERL_CONTEXT *cx;
3731 PERL_UNUSED_CONTEXT;
3734 assert(CxTYPE(cx) == CXt_GIVEN);
3739 PL_curpm = newpm; /* pop $1 et al */
3746 /* Helper routines used by pp_smartmatch */
3749 S_make_matcher(pTHX_ regexp *re)
3752 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3753 PM_SETRE(matcher, ReREFCNT_inc(re));
3755 SAVEFREEOP((OP *) matcher);
3763 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3768 PL_op = (OP *) matcher;
3773 return (SvTRUEx(POPs));
3778 S_destroy_matcher(pTHX_ PMOP *matcher)
3781 PERL_UNUSED_ARG(matcher);
3786 /* Do a smart match */
3789 return do_smartmatch(NULL, NULL);
3792 /* This version of do_smartmatch() implements the following
3793 table of smart matches:
3795 $a $b Type of Match Implied Matching Code
3796 ====== ===== ===================== =============
3797 (overloading trumps everything)
3799 Code[+] Code[+] referential equality match if refaddr($a) == refaddr($b)
3800 Any Code[+] scalar sub truth match if $b->($a)
3802 Hash Hash hash keys identical match if sort(keys(%$a)) ÈeqÇ sort(keys(%$b))
3803 Hash Array hash value slice truth match if $a->{any(@$b)}
3804 Hash Regex hash key grep match if any(keys(%$a)) =~ /$b/
3805 Hash Any hash entry existence match if exists $a->{$b}
3807 Array Array arrays are identical[*] match if $a È~~Ç $b
3808 Array Regex array grep match if any(@$a) =~ /$b/
3809 Array Num array contains number match if any($a) == $b
3810 Array Any array contains string match if any($a) eq $b
3812 Any undef undefined match if !defined $a
3813 Any Regex pattern match match if $a =~ /$b/
3814 Code() Code() results are equal match if $a->() eq $b->()
3815 Any Code() simple closure truth match if $b->() (ignoring $a)
3816 Num numish[!] numeric equality match if $a == $b
3817 Any Str string equality match if $a eq $b
3818 Any Num numeric equality match if $a == $b
3820 Any Any string equality match if $a eq $b
3823 + - this must be a code reference whose prototype (if present) is not ""
3824 (subs with a "" prototype are dealt with by the 'Code()' entry lower down)
3825 * - if a circular reference is found, we fall back to referential equality
3826 ! - either a real number, or a string that looks_like_number()
3831 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3836 SV *e = TOPs; /* e is for 'expression' */
3837 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3840 regexp *this_regex, *other_regex;
3842 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3844 # define SM_REF(type) ( \
3845 (SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_##type) && (other = e)) \
3846 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_##type) && (other = d)))
3848 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3849 ((SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_PVCV) \
3850 && NOT_EMPTY_PROTO(this) && (other = e)) \
3851 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_PVCV) \
3852 && NOT_EMPTY_PROTO(this) && (other = d)))
3854 # define SM_REGEX ( \
3855 (SvROK(d) && SvMAGICAL(this = SvRV(d)) \
3856 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3857 && (this_regex = (regexp *)mg->mg_obj) \
3860 (SvROK(e) && SvMAGICAL(this = SvRV(e)) \
3861 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3862 && (this_regex = (regexp *)mg->mg_obj) \
3866 # define SM_OTHER_REF(type) \
3867 (SvROK(other) && SvTYPE(SvRV(other)) == SVt_##type)
3869 # define SM_OTHER_REGEX (SvROK(other) && SvMAGICAL(SvRV(other)) \
3870 && (mg = mg_find(SvRV(other), PERL_MAGIC_qr)) \
3871 && (other_regex = (regexp *)mg->mg_obj))
3874 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3875 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3877 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3878 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3880 tryAMAGICbinSET(smart, 0);
3882 SP -= 2; /* Pop the values */
3884 /* Take care only to invoke mg_get() once for each argument.
3885 * Currently we do this by copying the SV if it's magical. */
3888 d = sv_mortalcopy(d);
3895 e = sv_mortalcopy(e);
3900 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(other)) )
3902 if (this == SvRV(other))
3913 c = call_sv(this, G_SCALAR);
3917 else if (SvTEMP(TOPs))
3918 SvREFCNT_inc_void(TOPs);
3923 else if (SM_REF(PVHV)) {
3924 if (SM_OTHER_REF(PVHV)) {
3925 /* Check that the key-sets are identical */
3927 HV *other_hv = (HV *) SvRV(other);
3929 bool other_tied = FALSE;
3930 U32 this_key_count = 0,
3931 other_key_count = 0;
3933 /* Tied hashes don't know how many keys they have. */
3934 if (SvTIED_mg(this, PERL_MAGIC_tied)) {
3937 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3938 HV * const temp = other_hv;
3939 other_hv = (HV *) this;
3943 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3946 if (!tied && HvUSEDKEYS((HV *) this) != HvUSEDKEYS(other_hv))
3949 /* The hashes have the same number of keys, so it suffices
3950 to check that one is a subset of the other. */
3951 (void) hv_iterinit((HV *) this);
3952 while ( (he = hv_iternext((HV *) this)) ) {
3954 char * const key = hv_iterkey(he, &key_len);
3958 if(!hv_exists(other_hv, key, key_len)) {
3959 (void) hv_iterinit((HV *) this); /* reset iterator */
3965 (void) hv_iterinit(other_hv);
3966 while ( hv_iternext(other_hv) )
3970 other_key_count = HvUSEDKEYS(other_hv);
3972 if (this_key_count != other_key_count)
3977 else if (SM_OTHER_REF(PVAV)) {
3978 AV * const other_av = (AV *) SvRV(other);
3979 const I32 other_len = av_len(other_av) + 1;
3982 if (HvUSEDKEYS((HV *) this) != other_len)
3985 for(i = 0; i < other_len; ++i) {
3986 SV ** const svp = av_fetch(other_av, i, FALSE);
3990 if (!svp) /* ??? When can this happen? */
3993 key = SvPV(*svp, key_len);
3994 if(!hv_exists((HV *) this, key, key_len))
3999 else if (SM_OTHER_REGEX) {
4000 PMOP * const matcher = make_matcher(other_regex);
4003 (void) hv_iterinit((HV *) this);
4004 while ( (he = hv_iternext((HV *) this)) ) {
4005 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4006 (void) hv_iterinit((HV *) this);
4007 destroy_matcher(matcher);
4011 destroy_matcher(matcher);
4015 if (hv_exists_ent((HV *) this, other, 0))
4021 else if (SM_REF(PVAV)) {
4022 if (SM_OTHER_REF(PVAV)) {
4023 AV *other_av = (AV *) SvRV(other);
4024 if (av_len((AV *) this) != av_len(other_av))
4028 const I32 other_len = av_len(other_av);
4030 if (NULL == seen_this) {
4031 seen_this = newHV();
4032 (void) sv_2mortal((SV *) seen_this);
4034 if (NULL == seen_other) {
4035 seen_this = newHV();
4036 (void) sv_2mortal((SV *) seen_other);
4038 for(i = 0; i <= other_len; ++i) {
4039 SV * const * const this_elem = av_fetch((AV *)this, i, FALSE);
4040 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4042 if (!this_elem || !other_elem) {
4043 if (this_elem || other_elem)
4046 else if (SM_SEEN_THIS(*this_elem)
4047 || SM_SEEN_OTHER(*other_elem))
4049 if (*this_elem != *other_elem)
4053 hv_store_ent(seen_this,
4054 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4056 hv_store_ent(seen_other,
4057 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4063 (void) do_smartmatch(seen_this, seen_other);
4073 else if (SM_OTHER_REGEX) {
4074 PMOP * const matcher = make_matcher(other_regex);
4075 const I32 this_len = av_len((AV *) this);
4078 for(i = 0; i <= this_len; ++i) {
4079 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4080 if (svp && matcher_matches_sv(matcher, *svp)) {
4081 destroy_matcher(matcher);
4085 destroy_matcher(matcher);
4088 else if (SvIOK(other) || SvNOK(other)) {
4091 for(i = 0; i <= AvFILL((AV *) this); ++i) {
4092 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4099 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4109 else if (SvPOK(other)) {
4110 const I32 this_len = av_len((AV *) this);
4113 for(i = 0; i <= this_len; ++i) {
4114 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4129 else if (!SvOK(d) || !SvOK(e)) {
4130 if (!SvOK(d) && !SvOK(e))
4135 else if (SM_REGEX) {
4136 PMOP * const matcher = make_matcher(this_regex);
4139 PUSHs(matcher_matches_sv(matcher, other)
4142 destroy_matcher(matcher);
4145 else if (SM_REF(PVCV)) {
4147 /* This must be a null-prototyped sub, because we
4148 already checked for the other kind. */
4154 c = call_sv(this, G_SCALAR);
4157 PUSHs(&PL_sv_undef);
4158 else if (SvTEMP(TOPs))
4159 SvREFCNT_inc_void(TOPs);
4161 if (SM_OTHER_REF(PVCV)) {
4162 /* This one has to be null-proto'd too.
4163 Call both of 'em, and compare the results */
4165 c = call_sv(SvRV(other), G_SCALAR);
4168 PUSHs(&PL_sv_undef);
4169 else if (SvTEMP(TOPs))
4170 SvREFCNT_inc_void(TOPs);
4181 else if ( ((SvIOK(d) || SvNOK(d)) && (this = d) && (other = e))
4182 || ((SvIOK(e) || SvNOK(e)) && (this = e) && (other = d)) )
4184 if (SvPOK(other) && !looks_like_number(other)) {
4185 /* String comparison */
4190 /* Otherwise, numeric comparison */
4193 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4204 /* As a last resort, use string comparison */
4213 register PERL_CONTEXT *cx;
4214 const I32 gimme = GIMME_V;
4216 /* This is essentially an optimization: if the match
4217 fails, we don't want to push a context and then
4218 pop it again right away, so we skip straight
4219 to the op that follows the leavewhen.
4221 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4222 return cLOGOP->op_other->op_next;
4227 PUSHBLOCK(cx, CXt_WHEN, SP);
4236 register PERL_CONTEXT *cx;
4242 assert(CxTYPE(cx) == CXt_WHEN);
4247 PL_curpm = newpm; /* pop $1 et al */
4257 register PERL_CONTEXT *cx;
4260 cxix = dopoptowhen(cxstack_ix);
4262 DIE(aTHX_ "Can't \"continue\" outside a when block");
4263 if (cxix < cxstack_ix)
4266 /* clear off anything above the scope we're re-entering */
4267 inner = PL_scopestack_ix;
4269 if (PL_scopestack_ix < inner)
4270 leave_scope(PL_scopestack[PL_scopestack_ix]);
4271 PL_curcop = cx->blk_oldcop;
4272 return cx->blk_givwhen.leave_op;
4279 register PERL_CONTEXT *cx;
4282 cxix = dopoptogiven(cxstack_ix);
4284 if (PL_op->op_flags & OPf_SPECIAL)
4285 DIE(aTHX_ "Can't use when() outside a topicalizer");
4287 DIE(aTHX_ "Can't \"break\" outside a given block");
4289 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4290 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4292 if (cxix < cxstack_ix)
4295 /* clear off anything above the scope we're re-entering */
4296 inner = PL_scopestack_ix;
4298 if (PL_scopestack_ix < inner)
4299 leave_scope(PL_scopestack[PL_scopestack_ix]);
4300 PL_curcop = cx->blk_oldcop;
4303 return cx->blk_loop.next_op;
4305 return cx->blk_givwhen.leave_op;
4309 S_doparseform(pTHX_ SV *sv)
4312 register char *s = SvPV_force(sv, len);
4313 register char * const send = s + len;
4314 register char *base = NULL;
4315 register I32 skipspaces = 0;
4316 bool noblank = FALSE;
4317 bool repeat = FALSE;
4318 bool postspace = FALSE;
4324 bool unchopnum = FALSE;
4325 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4328 Perl_croak(aTHX_ "Null picture in formline");
4330 /* estimate the buffer size needed */
4331 for (base = s; s <= send; s++) {
4332 if (*s == '\n' || *s == '@' || *s == '^')
4338 Newx(fops, maxops, U32);
4343 *fpc++ = FF_LINEMARK;
4344 noblank = repeat = FALSE;
4362 case ' ': case '\t':
4369 } /* else FALL THROUGH */
4377 *fpc++ = FF_LITERAL;
4385 *fpc++ = (U16)skipspaces;
4389 *fpc++ = FF_NEWLINE;
4393 arg = fpc - linepc + 1;
4400 *fpc++ = FF_LINEMARK;
4401 noblank = repeat = FALSE;
4410 ischop = s[-1] == '^';
4416 arg = (s - base) - 1;
4418 *fpc++ = FF_LITERAL;
4426 *fpc++ = 2; /* skip the @* or ^* */
4428 *fpc++ = FF_LINESNGL;
4431 *fpc++ = FF_LINEGLOB;
4433 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4434 arg = ischop ? 512 : 0;
4439 const char * const f = ++s;
4442 arg |= 256 + (s - f);
4444 *fpc++ = s - base; /* fieldsize for FETCH */
4445 *fpc++ = FF_DECIMAL;
4447 unchopnum |= ! ischop;
4449 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4450 arg = ischop ? 512 : 0;
4452 s++; /* skip the '0' first */
4456 const char * const f = ++s;
4459 arg |= 256 + (s - f);
4461 *fpc++ = s - base; /* fieldsize for FETCH */
4462 *fpc++ = FF_0DECIMAL;
4464 unchopnum |= ! ischop;
4468 bool ismore = FALSE;
4471 while (*++s == '>') ;
4472 prespace = FF_SPACE;
4474 else if (*s == '|') {
4475 while (*++s == '|') ;
4476 prespace = FF_HALFSPACE;
4481 while (*++s == '<') ;
4484 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4488 *fpc++ = s - base; /* fieldsize for FETCH */
4490 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4493 *fpc++ = (U16)prespace;
4507 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4509 { /* need to jump to the next word */
4511 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4512 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4513 s = SvPVX(sv) + SvCUR(sv) + z;
4515 Copy(fops, s, arg, U32);
4517 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4520 if (unchopnum && repeat)
4521 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4527 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4529 /* Can value be printed in fldsize chars, using %*.*f ? */
4533 int intsize = fldsize - (value < 0 ? 1 : 0);
4540 while (intsize--) pwr *= 10.0;
4541 while (frcsize--) eps /= 10.0;
4544 if (value + eps >= pwr)
4547 if (value - eps <= -pwr)
4554 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4557 SV * const datasv = FILTER_DATA(idx);
4558 const int filter_has_file = IoLINES(datasv);
4559 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4560 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4564 const char *got_p = NULL;
4565 const char *prune_from = NULL;
4566 bool read_from_cache = FALSE;
4569 assert(maxlen >= 0);
4572 /* I was having segfault trouble under Linux 2.2.5 after a
4573 parse error occured. (Had to hack around it with a test
4574 for PL_error_count == 0.) Solaris doesn't segfault --
4575 not sure where the trouble is yet. XXX */
4577 if (IoFMT_GV(datasv)) {
4578 SV *const cache = (SV *)IoFMT_GV(datasv);
4581 const char *cache_p = SvPV(cache, cache_len);
4585 /* Running in block mode and we have some cached data already.
4587 if (cache_len >= umaxlen) {
4588 /* In fact, so much data we don't even need to call
4593 const char *const first_nl = memchr(cache_p, '\n', cache_len);
4595 take = first_nl + 1 - cache_p;
4599 sv_catpvn(buf_sv, cache_p, take);
4600 sv_chop(cache, cache_p + take);
4601 /* Definately not EOF */
4605 sv_catsv(buf_sv, cache);
4607 umaxlen -= cache_len;
4610 read_from_cache = TRUE;
4614 /* Filter API says that the filter appends to the contents of the buffer.
4615 Usually the buffer is "", so the details don't matter. But if it's not,
4616 then clearly what it contains is already filtered by this filter, so we
4617 don't want to pass it in a second time.
4618 I'm going to use a mortal in case the upstream filter croaks. */
4619 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4620 ? sv_newmortal() : buf_sv;
4621 SvUPGRADE(upstream, SVt_PV);
4623 if (filter_has_file) {
4624 status = FILTER_READ(idx+1, upstream, 0);
4627 if (filter_sub && status >= 0) {
4638 PUSHs(sv_2mortal(newSViv(0)));
4640 PUSHs(filter_state);
4643 count = call_sv(filter_sub, G_SCALAR);
4658 if(SvOK(upstream)) {
4659 got_p = SvPV(upstream, got_len);
4661 if (got_len > umaxlen) {
4662 prune_from = got_p + umaxlen;
4665 const char *const first_nl = memchr(got_p, '\n', got_len);
4666 if (first_nl && first_nl + 1 < got_p + got_len) {
4667 /* There's a second line here... */
4668 prune_from = first_nl + 1;
4673 /* Oh. Too long. Stuff some in our cache. */
4674 STRLEN cached_len = got_p + got_len - prune_from;
4675 SV *cache = (SV *)IoFMT_GV(datasv);
4678 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4679 } else if (SvOK(cache)) {
4680 /* Cache should be empty. */
4681 assert(!SvCUR(cache));
4684 sv_setpvn(cache, prune_from, cached_len);
4685 /* If you ask for block mode, you may well split UTF-8 characters.
4686 "If it breaks, you get to keep both parts"
4687 (Your code is broken if you don't put them back together again
4688 before something notices.) */
4689 if (SvUTF8(upstream)) {
4692 SvCUR_set(upstream, got_len - cached_len);
4693 /* Can't yet be EOF */
4698 /* If they are at EOF but buf_sv has something in it, then they may never
4699 have touched the SV upstream, so it may be undefined. If we naively
4700 concatenate it then we get a warning about use of uninitialised value.
4702 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4703 sv_catsv(buf_sv, upstream);
4707 IoLINES(datasv) = 0;
4708 SvREFCNT_dec(IoFMT_GV(datasv));
4710 SvREFCNT_dec(filter_state);
4711 IoTOP_GV(datasv) = NULL;
4714 SvREFCNT_dec(filter_sub);
4715 IoBOTTOM_GV(datasv) = NULL;
4717 filter_del(S_run_user_filter);
4719 if (status == 0 && read_from_cache) {
4720 /* If we read some data from the cache (and by getting here it implies
4721 that we emptied the cache) then we aren't yet at EOF, and mustn't
4722 report that to our caller. */
4728 /* perhaps someone can come up with a better name for
4729 this? it is not really "absolute", per se ... */
4731 S_path_is_absolute(const char *name)
4733 if (PERL_FILE_IS_ABSOLUTE(name)
4734 #ifdef MACOS_TRADITIONAL
4737 || (*name == '.' && (name[1] == '/' ||
4738 (name[1] == '.' && name[2] == '/')))
4750 * c-indentation-style: bsd
4752 * indent-tabs-mode: t
4755 * ex: set ts=8 sts=4 sw=4 noet: