3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
20 /* This file contains control-oriented pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
26 * Control-oriented means things like pp_enteriter() and pp_next(), which
27 * alter the flow of control of the program.
32 #define PERL_IN_PP_CTL_C
36 #define WORD_ALIGN sizeof(U32)
39 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
48 cxix = dopoptosub(cxstack_ix);
52 switch (cxstack[cxix].blk_gimme) {
65 /* XXXX Should store the old value to allow for tie/overload - and
66 restore in regcomp, where marked with XXXX. */
76 register PMOP *pm = (PMOP*)cLOGOP->op_other;
80 /* prevent recompiling under /o and ithreads. */
81 #if defined(USE_ITHREADS)
82 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
83 if (PL_op->op_flags & OPf_STACKED) {
92 if (PL_op->op_flags & OPf_STACKED) {
93 /* multiple args; concatentate them */
95 tmpstr = PAD_SV(ARGTARG);
96 sv_setpvn(tmpstr, "", 0);
97 while (++MARK <= SP) {
98 if (PL_amagic_generation) {
100 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
101 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
103 sv_setsv(tmpstr, sv);
107 sv_catsv(tmpstr, *MARK);
116 SV *sv = SvRV(tmpstr);
118 mg = mg_find(sv, PERL_MAGIC_qr);
121 regexp * const re = (regexp *)mg->mg_obj;
122 ReREFCNT_dec(PM_GETRE(pm));
123 PM_SETRE(pm, ReREFCNT_inc(re));
127 const char *t = SvPV_const(tmpstr, len);
129 /* Check against the last compiled regexp. */
130 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
131 PM_GETRE(pm)->prelen != (I32)len ||
132 memNE(PM_GETRE(pm)->precomp, t, len))
135 ReREFCNT_dec(PM_GETRE(pm));
136 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
138 if (PL_op->op_flags & OPf_SPECIAL)
139 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
141 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
143 pm->op_pmdynflags |= PMdf_DYN_UTF8;
145 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
146 if (pm->op_pmdynflags & PMdf_UTF8)
147 t = (char*)bytes_to_utf8((U8*)t, &len);
149 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm));
150 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
152 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
153 inside tie/overload accessors. */
157 #ifndef INCOMPLETE_TAINTS
160 pm->op_pmdynflags |= PMdf_TAINTED;
162 pm->op_pmdynflags &= ~PMdf_TAINTED;
166 if (!PM_GETRE(pm)->prelen && PL_curpm)
168 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
169 pm->op_pmflags |= PMf_WHITE;
171 pm->op_pmflags &= ~PMf_WHITE;
173 /* XXX runtime compiled output needs to move to the pad */
174 if (pm->op_pmflags & PMf_KEEP) {
175 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
176 #if !defined(USE_ITHREADS)
177 /* XXX can't change the optree at runtime either */
178 cLOGOP->op_first->op_next = PL_op->op_next;
188 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
189 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
190 register SV * const dstr = cx->sb_dstr;
191 register char *s = cx->sb_s;
192 register char *m = cx->sb_m;
193 char *orig = cx->sb_orig;
194 register REGEXP * const rx = cx->sb_rx;
196 REGEXP *old = PM_GETRE(pm);
203 rxres_restore(&cx->sb_rxres, rx);
204 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
206 if (cx->sb_iters++) {
207 const I32 saviters = cx->sb_iters;
208 if (cx->sb_iters > cx->sb_maxiters)
209 DIE(aTHX_ "Substitution loop");
211 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
212 cx->sb_rxtainted |= 2;
213 sv_catsv(dstr, POPs);
214 FREETMPS; /* Prevent excess tmp stack */
217 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
218 s == m, cx->sb_targ, NULL,
219 ((cx->sb_rflags & REXEC_COPY_STR)
220 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
221 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
223 SV * const targ = cx->sb_targ;
225 assert(cx->sb_strend >= s);
226 if(cx->sb_strend > s) {
227 if (DO_UTF8(dstr) && !SvUTF8(targ))
228 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
230 sv_catpvn(dstr, s, cx->sb_strend - s);
232 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
234 #ifdef PERL_OLD_COPY_ON_WRITE
236 sv_force_normal_flags(targ, SV_COW_DROP_PV);
242 SvPV_set(targ, SvPVX(dstr));
243 SvCUR_set(targ, SvCUR(dstr));
244 SvLEN_set(targ, SvLEN(dstr));
247 SvPV_set(dstr, NULL);
250 TAINT_IF(cx->sb_rxtainted & 1);
251 PUSHs(sv_2mortal(newSViv(saviters - 1)));
253 (void)SvPOK_only_UTF8(targ);
254 TAINT_IF(cx->sb_rxtainted);
258 LEAVE_SCOPE(cx->sb_oldsave);
261 RETURNOP(pm->op_next);
263 cx->sb_iters = saviters;
265 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
268 cx->sb_orig = orig = rx->subbeg;
270 cx->sb_strend = s + (cx->sb_strend - m);
272 cx->sb_m = m = rx->startp[0] + orig;
274 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
275 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
277 sv_catpvn(dstr, s, m-s);
279 cx->sb_s = rx->endp[0] + orig;
280 { /* Update the pos() information. */
281 SV * const sv = cx->sb_targ;
284 if (SvTYPE(sv) < SVt_PVMG)
285 SvUPGRADE(sv, SVt_PVMG);
286 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
287 sv_magic(sv, NULL, PERL_MAGIC_regex_global, NULL, 0);
288 mg = mg_find(sv, PERL_MAGIC_regex_global);
296 (void)ReREFCNT_inc(rx);
297 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
298 rxres_save(&cx->sb_rxres, rx);
299 RETURNOP(pm->op_pmreplstart);
303 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
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_fetchpvs(".", GV_ADD|GV_NOTQUAL, 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_fetchpvs(".", GV_ADD|GV_NOTQUAL, 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_fetchpvs("DB::args", GV_ADD, 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)
1916 /*EMPTY*/; /* do nothing */
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 (CvISXSUB(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;
2378 for (index=0; index<items; index++)
2379 sv_2mortal(SP[-index]);
2382 /* XS subs don't have a CxSUB, so pop it */
2383 POPBLOCK(cx, PL_curpm);
2384 /* Push a mark for the start of arglist */
2387 (void)(*CvXSUB(cv))(aTHX_ cv);
2388 /* Put these at the bottom since the vars are set but not used */
2389 PERL_UNUSED_VAR(newsp);
2390 PERL_UNUSED_VAR(gimme);
2395 AV* padlist = CvPADLIST(cv);
2396 if (CxTYPE(cx) == CXt_EVAL) {
2397 PL_in_eval = cx->blk_eval.old_in_eval;
2398 PL_eval_root = cx->blk_eval.old_eval_root;
2399 cx->cx_type = CXt_SUB;
2400 cx->blk_sub.hasargs = 0;
2402 cx->blk_sub.cv = cv;
2403 cx->blk_sub.olddepth = CvDEPTH(cv);
2406 if (CvDEPTH(cv) < 2)
2407 (void)SvREFCNT_inc(cv);
2409 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2410 sub_crush_depth(cv);
2411 pad_push(padlist, CvDEPTH(cv));
2414 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2415 if (cx->blk_sub.hasargs)
2417 AV* av = (AV*)PAD_SVl(0);
2420 cx->blk_sub.savearray = GvAV(PL_defgv);
2421 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2422 CX_CURPAD_SAVE(cx->blk_sub);
2423 cx->blk_sub.argarray = av;
2425 if (items >= AvMAX(av) + 1) {
2427 if (AvARRAY(av) != ary) {
2428 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2429 SvPV_set(av, (char*)ary);
2431 if (items >= AvMAX(av) + 1) {
2432 AvMAX(av) = items - 1;
2433 Renew(ary,items+1,SV*);
2435 SvPV_set(av, (char*)ary);
2439 Copy(mark,AvARRAY(av),items,SV*);
2440 AvFILLp(av) = items - 1;
2441 assert(!AvREAL(av));
2443 /* transfer 'ownership' of refcnts to new @_ */
2453 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2455 * We do not care about using sv to call CV;
2456 * it's for informational purposes only.
2458 SV * const sv = GvSV(PL_DBsub);
2462 if (PERLDB_SUB_NN) {
2463 const int type = SvTYPE(sv);
2464 if (type < SVt_PVIV && type != SVt_IV)
2465 sv_upgrade(sv, SVt_PVIV);
2467 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2469 gv_efullname3(sv, CvGV(cv), NULL);
2472 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2473 PUSHMARK( PL_stack_sp );
2474 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2478 RETURNOP(CvSTART(cv));
2482 label = SvPV_nolen_const(sv);
2483 if (!(do_dump || *label))
2484 DIE(aTHX_ must_have_label);
2487 else if (PL_op->op_flags & OPf_SPECIAL) {
2489 DIE(aTHX_ must_have_label);
2492 label = cPVOP->op_pv;
2494 if (label && *label) {
2495 OP *gotoprobe = NULL;
2496 bool leaving_eval = FALSE;
2497 bool in_block = FALSE;
2498 PERL_CONTEXT *last_eval_cx = NULL;
2502 PL_lastgotoprobe = 0;
2504 for (ix = cxstack_ix; ix >= 0; ix--) {
2506 switch (CxTYPE(cx)) {
2508 leaving_eval = TRUE;
2509 if (!CxTRYBLOCK(cx)) {
2510 gotoprobe = (last_eval_cx ?
2511 last_eval_cx->blk_eval.old_eval_root :
2516 /* else fall through */
2518 gotoprobe = cx->blk_oldcop->op_sibling;
2524 gotoprobe = cx->blk_oldcop->op_sibling;
2527 gotoprobe = PL_main_root;
2530 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2531 gotoprobe = CvROOT(cx->blk_sub.cv);
2537 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2540 DIE(aTHX_ "panic: goto");
2541 gotoprobe = PL_main_root;
2545 retop = dofindlabel(gotoprobe, label,
2546 enterops, enterops + GOTO_DEPTH);
2550 PL_lastgotoprobe = gotoprobe;
2553 DIE(aTHX_ "Can't find label %s", label);
2555 /* if we're leaving an eval, check before we pop any frames
2556 that we're not going to punt, otherwise the error
2559 if (leaving_eval && *enterops && enterops[1]) {
2561 for (i = 1; enterops[i]; i++)
2562 if (enterops[i]->op_type == OP_ENTERITER)
2563 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2566 /* pop unwanted frames */
2568 if (ix < cxstack_ix) {
2575 oldsave = PL_scopestack[PL_scopestack_ix];
2576 LEAVE_SCOPE(oldsave);
2579 /* push wanted frames */
2581 if (*enterops && enterops[1]) {
2582 OP * const oldop = PL_op;
2583 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2584 for (; enterops[ix]; ix++) {
2585 PL_op = enterops[ix];
2586 /* Eventually we may want to stack the needed arguments
2587 * for each op. For now, we punt on the hard ones. */
2588 if (PL_op->op_type == OP_ENTERITER)
2589 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2590 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2598 if (!retop) retop = PL_main_start;
2600 PL_restartop = retop;
2601 PL_do_undump = TRUE;
2605 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2606 PL_do_undump = FALSE;
2623 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2625 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2628 PL_exit_flags |= PERL_EXIT_EXPECTED;
2630 PUSHs(&PL_sv_undef);
2637 S_save_lines(pTHX_ AV *array, SV *sv)
2639 const char *s = SvPVX_const(sv);
2640 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2643 while (s && s < send) {
2645 SV * const tmpstr = newSV(0);
2647 sv_upgrade(tmpstr, SVt_PVMG);
2648 t = strchr(s, '\n');
2654 sv_setpvn(tmpstr, s, t - s);
2655 av_store(array, line++, tmpstr);
2661 S_docatch_body(pTHX)
2669 S_docatch(pTHX_ OP *o)
2673 OP * const oldop = PL_op;
2677 assert(CATCH_GET == TRUE);
2684 assert(cxstack_ix >= 0);
2685 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2686 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2691 /* die caught by an inner eval - continue inner loop */
2693 /* NB XXX we rely on the old popped CxEVAL still being at the top
2694 * of the stack; the way die_where() currently works, this
2695 * assumption is valid. In theory The cur_top_env value should be
2696 * returned in another global, the way retop (aka PL_restartop)
2698 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2701 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2703 PL_op = PL_restartop;
2720 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2721 /* sv Text to convert to OP tree. */
2722 /* startop op_free() this to undo. */
2723 /* code Short string id of the caller. */
2725 /* FIXME - how much of this code is common with pp_entereval? */
2726 dVAR; dSP; /* Make POPBLOCK work. */
2733 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2734 char *tmpbuf = tbuf;
2737 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2743 /* switch to eval mode */
2745 if (IN_PERL_COMPILETIME) {
2746 SAVECOPSTASH_FREE(&PL_compiling);
2747 CopSTASH_set(&PL_compiling, PL_curstash);
2749 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2750 SV * const sv = sv_newmortal();
2751 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2752 code, (unsigned long)++PL_evalseq,
2753 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2758 len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
2759 (unsigned long)++PL_evalseq);
2760 SAVECOPFILE_FREE(&PL_compiling);
2761 CopFILE_set(&PL_compiling, tmpbuf+2);
2762 SAVECOPLINE(&PL_compiling);
2763 CopLINE_set(&PL_compiling, 1);
2764 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2765 deleting the eval's FILEGV from the stash before gv_check() runs
2766 (i.e. before run-time proper). To work around the coredump that
2767 ensues, we always turn GvMULTI_on for any globals that were
2768 introduced within evals. See force_ident(). GSAR 96-10-12 */
2769 safestr = savepvn(tmpbuf, len);
2770 SAVEDELETE(PL_defstash, safestr, len);
2772 #ifdef OP_IN_REGISTER
2778 /* we get here either during compilation, or via pp_regcomp at runtime */
2779 runtime = IN_PERL_RUNTIME;
2781 runcv = find_runcv(NULL);
2784 PL_op->op_type = OP_ENTEREVAL;
2785 PL_op->op_flags = 0; /* Avoid uninit warning. */
2786 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2787 PUSHEVAL(cx, 0, NULL);
2790 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2792 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2793 POPBLOCK(cx,PL_curpm);
2796 (*startop)->op_type = OP_NULL;
2797 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2799 /* XXX DAPM do this properly one year */
2800 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2802 if (IN_PERL_COMPILETIME)
2803 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2804 #ifdef OP_IN_REGISTER
2807 PERL_UNUSED_VAR(newsp);
2808 PERL_UNUSED_VAR(optype);
2815 =for apidoc find_runcv
2817 Locate the CV corresponding to the currently executing sub or eval.
2818 If db_seqp is non_null, skip CVs that are in the DB package and populate
2819 *db_seqp with the cop sequence number at the point that the DB:: code was
2820 entered. (allows debuggers to eval in the scope of the breakpoint rather
2821 than in the scope of the debugger itself).
2827 Perl_find_runcv(pTHX_ U32 *db_seqp)
2833 *db_seqp = PL_curcop->cop_seq;
2834 for (si = PL_curstackinfo; si; si = si->si_prev) {
2836 for (ix = si->si_cxix; ix >= 0; ix--) {
2837 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2838 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2839 CV * const cv = cx->blk_sub.cv;
2840 /* skip DB:: code */
2841 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2842 *db_seqp = cx->blk_oldcop->cop_seq;
2847 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2855 /* Compile a require/do, an eval '', or a /(?{...})/.
2856 * In the last case, startop is non-null, and contains the address of
2857 * a pointer that should be set to the just-compiled code.
2858 * outside is the lexically enclosing CV (if any) that invoked us.
2861 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2863 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2866 OP * const saveop = PL_op;
2868 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2869 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2874 SAVESPTR(PL_compcv);
2875 PL_compcv = (CV*)newSV(0);
2876 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2877 CvEVAL_on(PL_compcv);
2878 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2879 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2881 CvOUTSIDE_SEQ(PL_compcv) = seq;
2882 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2884 /* set up a scratch pad */
2886 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2889 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2891 /* make sure we compile in the right package */
2893 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2894 SAVESPTR(PL_curstash);
2895 PL_curstash = CopSTASH(PL_curcop);
2897 SAVESPTR(PL_beginav);
2898 PL_beginav = newAV();
2899 SAVEFREESV(PL_beginav);
2900 SAVEI32(PL_error_count);
2902 /* try to compile it */
2904 PL_eval_root = NULL;
2906 PL_curcop = &PL_compiling;
2907 PL_curcop->cop_arybase = 0;
2908 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2909 PL_in_eval |= EVAL_KEEPERR;
2911 sv_setpvn(ERRSV,"",0);
2912 if (yyparse() || PL_error_count || !PL_eval_root) {
2913 SV **newsp; /* Used by POPBLOCK. */
2914 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2915 I32 optype = 0; /* Might be reset by POPEVAL. */
2920 op_free(PL_eval_root);
2921 PL_eval_root = NULL;
2923 SP = PL_stack_base + POPMARK; /* pop original mark */
2925 POPBLOCK(cx,PL_curpm);
2931 msg = SvPVx_nolen_const(ERRSV);
2932 if (optype == OP_REQUIRE) {
2933 const SV * const nsv = cx->blk_eval.old_namesv;
2934 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2936 DIE(aTHX_ "%sCompilation failed in require",
2937 *msg ? msg : "Unknown error\n");
2940 POPBLOCK(cx,PL_curpm);
2942 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2943 (*msg ? msg : "Unknown error\n"));
2947 sv_setpv(ERRSV, "Compilation error");
2950 PERL_UNUSED_VAR(newsp);
2953 CopLINE_set(&PL_compiling, 0);
2955 *startop = PL_eval_root;
2957 SAVEFREEOP(PL_eval_root);
2959 /* Set the context for this new optree.
2960 * If the last op is an OP_REQUIRE, force scalar context.
2961 * Otherwise, propagate the context from the eval(). */
2962 if (PL_eval_root->op_type == OP_LEAVEEVAL
2963 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2964 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2966 scalar(PL_eval_root);
2967 else if (gimme & G_VOID)
2968 scalarvoid(PL_eval_root);
2969 else if (gimme & G_ARRAY)
2972 scalar(PL_eval_root);
2974 DEBUG_x(dump_eval());
2976 /* Register with debugger: */
2977 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2978 CV * const cv = get_cv("DB::postponed", FALSE);
2982 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2984 call_sv((SV*)cv, G_DISCARD);
2988 /* compiled okay, so do it */
2990 CvDEPTH(PL_compcv) = 1;
2991 SP = PL_stack_base + POPMARK; /* pop original mark */
2992 PL_op = saveop; /* The caller may need it. */
2993 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2995 RETURNOP(PL_eval_start);
2999 S_check_type_and_open(pTHX_ const char *name, const char *mode)
3002 const int st_rc = PerlLIO_stat(name, &st);
3007 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3008 Perl_die(aTHX_ "%s %s not allowed in require",
3009 S_ISDIR(st.st_mode) ? "Directory" : "Block device", name);
3011 return PerlIO_open(name, mode);
3015 S_doopen_pm(pTHX_ const char *name, const char *mode)
3017 #ifndef PERL_DISABLE_PMC
3018 const STRLEN namelen = strlen(name);
3021 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3022 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3023 const char * const pmc = SvPV_nolen_const(pmcsv);
3025 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3026 fp = check_type_and_open(name, mode);
3030 if (PerlLIO_stat(name, &pmstat) < 0 ||
3031 pmstat.st_mtime < pmcstat.st_mtime)
3033 fp = check_type_and_open(pmc, mode);
3036 fp = check_type_and_open(name, mode);
3039 SvREFCNT_dec(pmcsv);
3042 fp = check_type_and_open(name, mode);
3046 return check_type_and_open(name, mode);
3047 #endif /* !PERL_DISABLE_PMC */
3053 register PERL_CONTEXT *cx;
3057 const char *tryname = NULL;
3059 const I32 gimme = GIMME_V;
3060 int filter_has_file = 0;
3061 PerlIO *tryrsfp = NULL;
3062 GV *filter_child_proc = NULL;
3063 SV *filter_state = NULL;
3064 SV *filter_sub = NULL;
3070 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3071 if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
3072 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3073 "v-string in use/require non-portable");
3075 sv = new_version(sv);
3076 if (!sv_derived_from(PL_patchlevel, "version"))
3077 upg_version(PL_patchlevel);
3078 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3079 if ( vcmp(sv,PL_patchlevel) < 0 )
3080 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3081 vnormal(sv), vnormal(PL_patchlevel));
3084 if ( vcmp(sv,PL_patchlevel) > 0 )
3085 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3086 vnormal(sv), vnormal(PL_patchlevel));
3091 name = SvPV_const(sv, len);
3092 if (!(name && len > 0 && *name))
3093 DIE(aTHX_ "Null filename used");
3094 TAINT_PROPER("require");
3095 if (PL_op->op_type == OP_REQUIRE) {
3096 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3098 if (*svp != &PL_sv_undef)
3101 DIE(aTHX_ "Compilation failed in require");
3105 /* prepare to compile file */
3107 if (path_is_absolute(name)) {
3109 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3111 #ifdef MACOS_TRADITIONAL
3115 MacPerl_CanonDir(name, newname, 1);
3116 if (path_is_absolute(newname)) {
3118 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3123 AV * const ar = GvAVn(PL_incgv);
3127 if ((unixname = tounixspec(name, NULL)) != NULL)
3131 for (i = 0; i <= AvFILL(ar); i++) {
3132 SV *dirsv = *av_fetch(ar, i, TRUE);
3138 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3139 && !sv_isobject(loader))
3141 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3144 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3145 PTR2UV(SvRV(dirsv)), name);
3146 tryname = SvPVX_const(namesv);
3157 if (sv_isobject(loader))
3158 count = call_method("INC", G_ARRAY);
3160 count = call_sv(loader, G_ARRAY);
3170 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3174 if (SvTYPE(arg) == SVt_PVGV) {
3175 IO *io = GvIO((GV *)arg);
3180 tryrsfp = IoIFP(io);
3181 if (IoTYPE(io) == IoTYPE_PIPE) {
3182 /* reading from a child process doesn't
3183 nest -- when returning from reading
3184 the inner module, the outer one is
3185 unreadable (closed?) I've tried to
3186 save the gv to manage the lifespan of
3187 the pipe, but this didn't help. XXX */
3188 filter_child_proc = (GV *)arg;
3189 (void)SvREFCNT_inc(filter_child_proc);
3192 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3193 PerlIO_close(IoOFP(io));
3205 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3207 (void)SvREFCNT_inc(filter_sub);
3210 filter_state = SP[i];
3211 (void)SvREFCNT_inc(filter_state);
3215 tryrsfp = PerlIO_open("/dev/null", PERL_SCRIPT_MODE);
3230 filter_has_file = 0;
3231 if (filter_child_proc) {
3232 SvREFCNT_dec(filter_child_proc);
3233 filter_child_proc = NULL;
3236 SvREFCNT_dec(filter_state);
3237 filter_state = NULL;
3240 SvREFCNT_dec(filter_sub);
3245 if (!path_is_absolute(name)
3246 #ifdef MACOS_TRADITIONAL
3247 /* We consider paths of the form :a:b ambiguous and interpret them first
3248 as global then as local
3250 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3253 const char *dir = SvPVx_nolen_const(dirsv);
3254 #ifdef MACOS_TRADITIONAL
3258 MacPerl_CanonDir(name, buf2, 1);
3259 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3263 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3265 sv_setpv(namesv, unixdir);
3266 sv_catpv(namesv, unixname);
3268 # ifdef __SYMBIAN32__
3269 if (PL_origfilename[0] &&
3270 PL_origfilename[1] == ':' &&
3271 !(dir[0] && dir[1] == ':'))
3272 Perl_sv_setpvf(aTHX_ namesv,
3277 Perl_sv_setpvf(aTHX_ namesv,
3281 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3285 TAINT_PROPER("require");
3286 tryname = SvPVX_const(namesv);
3287 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3289 if (tryname[0] == '.' && tryname[1] == '/')
3298 SAVECOPFILE_FREE(&PL_compiling);
3299 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3300 SvREFCNT_dec(namesv);
3302 if (PL_op->op_type == OP_REQUIRE) {
3303 const char *msgstr = name;
3304 if(errno == EMFILE) {
3306 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3308 msgstr = SvPV_nolen_const(msg);
3310 if (namesv) { /* did we lookup @INC? */
3311 AV * const ar = GvAVn(PL_incgv);
3313 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3314 "%s in @INC%s%s (@INC contains:",
3316 (instr(msgstr, ".h ")
3317 ? " (change .h to .ph maybe?)" : ""),
3318 (instr(msgstr, ".ph ")
3319 ? " (did you run h2ph?)" : "")
3322 for (i = 0; i <= AvFILL(ar); i++) {
3323 sv_catpvs(msg, " ");
3324 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3326 sv_catpvs(msg, ")");
3327 msgstr = SvPV_nolen_const(msg);
3330 DIE(aTHX_ "Can't locate %s", msgstr);
3336 SETERRNO(0, SS_NORMAL);
3338 /* Assume success here to prevent recursive requirement. */
3339 /* name is never assigned to again, so len is still strlen(name) */
3340 /* Check whether a hook in @INC has already filled %INC */
3342 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3344 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3346 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 );
3351 lex_start(sv_2mortal(newSVpvs("")));
3352 SAVEGENERICSV(PL_rsfp_filters);
3353 PL_rsfp_filters = NULL;
3358 SAVESPTR(PL_compiling.cop_warnings);
3359 if (PL_dowarn & G_WARN_ALL_ON)
3360 PL_compiling.cop_warnings = pWARN_ALL ;
3361 else if (PL_dowarn & G_WARN_ALL_OFF)
3362 PL_compiling.cop_warnings = pWARN_NONE ;
3363 else if (PL_taint_warn)
3364 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3366 PL_compiling.cop_warnings = pWARN_STD ;
3367 SAVESPTR(PL_compiling.cop_io);
3368 PL_compiling.cop_io = NULL;
3370 if (filter_sub || filter_child_proc) {
3371 SV * const datasv = filter_add(S_run_user_filter, NULL);
3372 IoLINES(datasv) = filter_has_file;
3373 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3374 IoTOP_GV(datasv) = (GV *)filter_state;
3375 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3378 /* switch to eval mode */
3379 PUSHBLOCK(cx, CXt_EVAL, SP);
3380 PUSHEVAL(cx, name, NULL);
3381 cx->blk_eval.retop = PL_op->op_next;
3383 SAVECOPLINE(&PL_compiling);
3384 CopLINE_set(&PL_compiling, 0);
3388 /* Store and reset encoding. */
3389 encoding = PL_encoding;
3392 op = DOCATCH(doeval(gimme, NULL, NULL, PL_curcop->cop_seq));
3394 /* Restore encoding. */
3395 PL_encoding = encoding;
3403 register PERL_CONTEXT *cx;
3405 const I32 gimme = GIMME_V;
3406 const I32 was = PL_sub_generation;
3407 char tbuf[TYPE_DIGITS(long) + 12];
3408 char *tmpbuf = tbuf;
3414 HV *saved_hh = NULL;
3416 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3417 saved_hh = (HV*) SvREFCNT_inc(POPs);
3421 if (!SvPV_nolen_const(sv))
3423 TAINT_PROPER("eval");
3429 /* switch to eval mode */
3431 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3432 SV * const temp_sv = sv_newmortal();
3433 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3434 (unsigned long)++PL_evalseq,
3435 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3436 tmpbuf = SvPVX(temp_sv);
3437 len = SvCUR(temp_sv);
3440 len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3441 SAVECOPFILE_FREE(&PL_compiling);
3442 CopFILE_set(&PL_compiling, tmpbuf+2);
3443 SAVECOPLINE(&PL_compiling);
3444 CopLINE_set(&PL_compiling, 1);
3445 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3446 deleting the eval's FILEGV from the stash before gv_check() runs
3447 (i.e. before run-time proper). To work around the coredump that
3448 ensues, we always turn GvMULTI_on for any globals that were
3449 introduced within evals. See force_ident(). GSAR 96-10-12 */
3450 safestr = savepvn(tmpbuf, len);
3451 SAVEDELETE(PL_defstash, safestr, len);
3453 PL_hints = PL_op->op_targ;
3455 GvHV(PL_hintgv) = saved_hh;
3456 SAVESPTR(PL_compiling.cop_warnings);
3457 if (specialWARN(PL_curcop->cop_warnings))
3458 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3460 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3461 SAVEFREESV(PL_compiling.cop_warnings);
3463 SAVESPTR(PL_compiling.cop_io);
3464 if (specialCopIO(PL_curcop->cop_io))
3465 PL_compiling.cop_io = PL_curcop->cop_io;
3467 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3468 SAVEFREESV(PL_compiling.cop_io);
3470 /* special case: an eval '' executed within the DB package gets lexically
3471 * placed in the first non-DB CV rather than the current CV - this
3472 * allows the debugger to execute code, find lexicals etc, in the
3473 * scope of the code being debugged. Passing &seq gets find_runcv
3474 * to do the dirty work for us */
3475 runcv = find_runcv(&seq);
3477 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3478 PUSHEVAL(cx, 0, NULL);
3479 cx->blk_eval.retop = PL_op->op_next;
3481 /* prepare to compile string */
3483 if (PERLDB_LINE && PL_curstash != PL_debstash)
3484 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3486 ret = doeval(gimme, NULL, runcv, seq);
3487 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3488 && ret != PL_op->op_next) { /* Successive compilation. */
3489 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3491 return DOCATCH(ret);
3501 register PERL_CONTEXT *cx;
3503 const U8 save_flags = PL_op -> op_flags;
3508 retop = cx->blk_eval.retop;
3511 if (gimme == G_VOID)
3513 else if (gimme == G_SCALAR) {
3516 if (SvFLAGS(TOPs) & SVs_TEMP)
3519 *MARK = sv_mortalcopy(TOPs);
3523 *MARK = &PL_sv_undef;
3528 /* in case LEAVE wipes old return values */
3529 for (mark = newsp + 1; mark <= SP; mark++) {
3530 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3531 *mark = sv_mortalcopy(*mark);
3532 TAINT_NOT; /* Each item is independent */
3536 PL_curpm = newpm; /* Don't pop $1 et al till now */
3539 assert(CvDEPTH(PL_compcv) == 1);
3541 CvDEPTH(PL_compcv) = 0;
3544 if (optype == OP_REQUIRE &&
3545 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3547 /* Unassume the success we assumed earlier. */
3548 SV * const nsv = cx->blk_eval.old_namesv;
3549 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3550 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3551 /* die_where() did LEAVE, or we won't be here */
3555 if (!(save_flags & OPf_SPECIAL))
3556 sv_setpvn(ERRSV,"",0);
3565 register PERL_CONTEXT *cx;
3566 const I32 gimme = GIMME_V;
3571 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3573 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3575 PL_in_eval = EVAL_INEVAL;
3576 sv_setpvn(ERRSV,"",0);
3578 return DOCATCH(PL_op->op_next);
3587 register PERL_CONTEXT *cx;
3592 PERL_UNUSED_VAR(optype);
3595 if (gimme == G_VOID)
3597 else if (gimme == G_SCALAR) {
3601 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3604 *MARK = sv_mortalcopy(TOPs);
3608 *MARK = &PL_sv_undef;
3613 /* in case LEAVE wipes old return values */
3615 for (mark = newsp + 1; mark <= SP; mark++) {
3616 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3617 *mark = sv_mortalcopy(*mark);
3618 TAINT_NOT; /* Each item is independent */
3622 PL_curpm = newpm; /* Don't pop $1 et al till now */
3625 sv_setpvn(ERRSV,"",0);
3632 register PERL_CONTEXT *cx;
3633 const I32 gimme = GIMME_V;
3638 if (PL_op->op_targ == 0) {
3639 SV ** const defsv_p = &GvSV(PL_defgv);
3640 *defsv_p = newSVsv(POPs);
3641 SAVECLEARSV(*defsv_p);
3644 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3646 PUSHBLOCK(cx, CXt_GIVEN, SP);
3655 register PERL_CONTEXT *cx;
3662 assert(CxTYPE(cx) == CXt_GIVEN);
3668 PL_curpm = newpm; /* pop $1 et al */
3675 /* Helper routines used by pp_smartmatch */
3678 S_make_matcher(pTHX_ regexp *re)
3681 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3682 PM_SETRE(matcher, ReREFCNT_inc(re));
3684 SAVEFREEOP((OP *) matcher);
3692 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3697 PL_op = (OP *) matcher;
3702 return (SvTRUEx(POPs));
3707 S_destroy_matcher(pTHX_ PMOP *matcher)
3710 PERL_UNUSED_ARG(matcher);
3715 /* Do a smart match */
3718 return do_smartmatch(NULL, NULL);
3721 /* This version of do_smartmatch() implements the following
3722 table of smart matches:
3724 $a $b Type of Match Implied Matching Code
3725 ====== ===== ===================== =============
3726 (overloading trumps everything)
3728 Code[+] Code[+] referential equality match if refaddr($a) == refaddr($b)
3729 Any Code[+] scalar sub truth match if $b->($a)
3731 Hash Hash hash keys identical match if sort(keys(%$a)) ÈeqÇ sort(keys(%$b))
3732 Hash Array hash value slice truth match if $a->{any(@$b)}
3733 Hash Regex hash key grep match if any(keys(%$a)) =~ /$b/
3734 Hash Any hash entry existence match if exists $a->{$b}
3736 Array Array arrays are identical[*] match if $a È~~Ç $b
3737 Array Regex array grep match if any(@$a) =~ /$b/
3738 Array Num array contains number match if any($a) == $b
3739 Array Any array contains string match if any($a) eq $b
3741 Any undef undefined match if !defined $a
3742 Any Regex pattern match match if $a =~ /$b/
3743 Code() Code() results are equal match if $a->() eq $b->()
3744 Any Code() simple closure truth match if $b->() (ignoring $a)
3745 Num numish[!] numeric equality match if $a == $b
3746 Any Str string equality match if $a eq $b
3747 Any Num numeric equality match if $a == $b
3749 Any Any string equality match if $a eq $b
3752 + - this must be a code reference whose prototype (if present) is not ""
3753 (subs with a "" prototype are dealt with by the 'Code()' entry lower down)
3754 * - if a circular reference is found, we fall back to referential equality
3755 ! - either a real number, or a string that looks_like_number()
3760 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3765 SV *e = TOPs; /* e is for 'expression' */
3766 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
3769 regexp *this_regex, *other_regex;
3771 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3773 # define SM_REF(type) ( \
3774 (SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_##type) && (other = e)) \
3775 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_##type) && (other = d)))
3777 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
3778 ((SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_PVCV) \
3779 && NOT_EMPTY_PROTO(this) && (other = e)) \
3780 || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_PVCV) \
3781 && NOT_EMPTY_PROTO(this) && (other = d)))
3783 # define SM_REGEX ( \
3784 (SvROK(d) && SvMAGICAL(this = SvRV(d)) \
3785 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3786 && (this_regex = (regexp *)mg->mg_obj) \
3789 (SvROK(e) && SvMAGICAL(this = SvRV(e)) \
3790 && (mg = mg_find(this, PERL_MAGIC_qr)) \
3791 && (this_regex = (regexp *)mg->mg_obj) \
3795 # define SM_OTHER_REF(type) \
3796 (SvROK(other) && SvTYPE(SvRV(other)) == SVt_##type)
3798 # define SM_OTHER_REGEX (SvROK(other) && SvMAGICAL(SvRV(other)) \
3799 && (mg = mg_find(SvRV(other), PERL_MAGIC_qr)) \
3800 && (other_regex = (regexp *)mg->mg_obj))
3803 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3804 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3806 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3807 sv_2mortal(newSViv(PTR2IV(sv))), 0)
3809 tryAMAGICbinSET(smart, 0);
3811 SP -= 2; /* Pop the values */
3813 /* Take care only to invoke mg_get() once for each argument.
3814 * Currently we do this by copying the SV if it's magical. */
3817 d = sv_mortalcopy(d);
3824 e = sv_mortalcopy(e);
3829 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(other)) )
3831 if (this == SvRV(other))
3842 c = call_sv(this, G_SCALAR);
3846 else if (SvTEMP(TOPs))
3852 else if (SM_REF(PVHV)) {
3853 if (SM_OTHER_REF(PVHV)) {
3854 /* Check that the key-sets are identical */
3856 HV *other_hv = (HV *) SvRV(other);
3858 bool other_tied = FALSE;
3859 U32 this_key_count = 0,
3860 other_key_count = 0;
3862 /* Tied hashes don't know how many keys they have. */
3863 if (SvTIED_mg(this, PERL_MAGIC_tied)) {
3866 else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3867 HV * const temp = other_hv;
3868 other_hv = (HV *) this;
3872 if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3875 if (!tied && HvUSEDKEYS((HV *) this) != HvUSEDKEYS(other_hv))
3878 /* The hashes have the same number of keys, so it suffices
3879 to check that one is a subset of the other. */
3880 (void) hv_iterinit((HV *) this);
3881 while ( (he = hv_iternext((HV *) this)) ) {
3883 char * const key = hv_iterkey(he, &key_len);
3887 if(!hv_exists(other_hv, key, key_len)) {
3888 (void) hv_iterinit((HV *) this); /* reset iterator */
3894 (void) hv_iterinit(other_hv);
3895 while ( hv_iternext(other_hv) )
3899 other_key_count = HvUSEDKEYS(other_hv);
3901 if (this_key_count != other_key_count)
3906 else if (SM_OTHER_REF(PVAV)) {
3907 AV * const other_av = (AV *) SvRV(other);
3908 const I32 other_len = av_len(other_av) + 1;
3911 if (HvUSEDKEYS((HV *) this) != other_len)
3914 for(i = 0; i < other_len; ++i) {
3915 SV ** const svp = av_fetch(other_av, i, FALSE);
3919 if (!svp) /* ??? When can this happen? */
3922 key = SvPV(*svp, key_len);
3923 if(!hv_exists((HV *) this, key, key_len))
3928 else if (SM_OTHER_REGEX) {
3929 PMOP * const matcher = make_matcher(other_regex);
3932 (void) hv_iterinit((HV *) this);
3933 while ( (he = hv_iternext((HV *) this)) ) {
3934 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
3935 (void) hv_iterinit((HV *) this);
3936 destroy_matcher(matcher);
3940 destroy_matcher(matcher);
3944 if (hv_exists_ent((HV *) this, other, 0))
3950 else if (SM_REF(PVAV)) {
3951 if (SM_OTHER_REF(PVAV)) {
3952 AV *other_av = (AV *) SvRV(other);
3953 if (av_len((AV *) this) != av_len(other_av))
3957 const I32 other_len = av_len(other_av);
3959 if (NULL == seen_this) {
3960 seen_this = newHV();
3961 (void) sv_2mortal((SV *) seen_this);
3963 if (NULL == seen_other) {
3964 seen_this = newHV();
3965 (void) sv_2mortal((SV *) seen_other);
3967 for(i = 0; i <= other_len; ++i) {
3968 SV * const * const this_elem = av_fetch((AV *)this, i, FALSE);
3969 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
3971 if (!this_elem || !other_elem) {
3972 if (this_elem || other_elem)
3975 else if (SM_SEEN_THIS(*this_elem)
3976 || SM_SEEN_OTHER(*other_elem))
3978 if (*this_elem != *other_elem)
3982 hv_store_ent(seen_this,
3983 sv_2mortal(newSViv(PTR2IV(*this_elem))),
3985 hv_store_ent(seen_other,
3986 sv_2mortal(newSViv(PTR2IV(*other_elem))),
3992 (void) do_smartmatch(seen_this, seen_other);
4002 else if (SM_OTHER_REGEX) {
4003 PMOP * const matcher = make_matcher(other_regex);
4004 const I32 this_len = av_len((AV *) this);
4007 for(i = 0; i <= this_len; ++i) {
4008 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4009 if (svp && matcher_matches_sv(matcher, *svp)) {
4010 destroy_matcher(matcher);
4014 destroy_matcher(matcher);
4017 else if (SvIOK(other) || SvNOK(other)) {
4020 for(i = 0; i <= AvFILL((AV *) this); ++i) {
4021 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4028 if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
4038 else if (SvPOK(other)) {
4039 const I32 this_len = av_len((AV *) this);
4042 for(i = 0; i <= this_len; ++i) {
4043 SV * const * const svp = av_fetch((AV *)this, i, FALSE);
4058 else if (!SvOK(d) || !SvOK(e)) {
4059 if (!SvOK(d) && !SvOK(e))
4064 else if (SM_REGEX) {
4065 PMOP * const matcher = make_matcher(this_regex);
4068 PUSHs(matcher_matches_sv(matcher, other)
4071 destroy_matcher(matcher);
4074 else if (SM_REF(PVCV)) {
4076 /* This must be a null-prototyped sub, because we
4077 already checked for the other kind. */
4083 c = call_sv(this, G_SCALAR);
4086 PUSHs(&PL_sv_undef);
4087 else if (SvTEMP(TOPs))
4090 if (SM_OTHER_REF(PVCV)) {
4091 /* This one has to be null-proto'd too.
4092 Call both of 'em, and compare the results */
4094 c = call_sv(SvRV(other), G_SCALAR);
4097 PUSHs(&PL_sv_undef);
4098 else if (SvTEMP(TOPs))
4110 else if ( ((SvIOK(d) || SvNOK(d)) && (this = d) && (other = e))
4111 || ((SvIOK(e) || SvNOK(e)) && (this = e) && (other = d)) )
4113 if (SvPOK(other) && !looks_like_number(other)) {
4114 /* String comparison */
4119 /* Otherwise, numeric comparison */
4122 if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
4133 /* As a last resort, use string comparison */
4142 register PERL_CONTEXT *cx;
4143 const I32 gimme = GIMME_V;
4145 /* This is essentially an optimization: if the match
4146 fails, we don't want to push a context and then
4147 pop it again right away, so we skip straight
4148 to the op that follows the leavewhen.
4150 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4151 return cLOGOP->op_other->op_next;
4156 PUSHBLOCK(cx, CXt_WHEN, SP);
4165 register PERL_CONTEXT *cx;
4171 assert(CxTYPE(cx) == CXt_WHEN);
4176 PL_curpm = newpm; /* pop $1 et al */
4186 register PERL_CONTEXT *cx;
4189 cxix = dopoptowhen(cxstack_ix);
4191 DIE(aTHX_ "Can't \"continue\" outside a when block");
4192 if (cxix < cxstack_ix)
4195 /* clear off anything above the scope we're re-entering */
4196 inner = PL_scopestack_ix;
4198 if (PL_scopestack_ix < inner)
4199 leave_scope(PL_scopestack[PL_scopestack_ix]);
4200 PL_curcop = cx->blk_oldcop;
4201 return cx->blk_givwhen.leave_op;
4208 register PERL_CONTEXT *cx;
4211 cxix = dopoptogiven(cxstack_ix);
4213 if (PL_op->op_flags & OPf_SPECIAL)
4214 DIE(aTHX_ "Can't use when() outside a topicalizer");
4216 DIE(aTHX_ "Can't \"break\" outside a given block");
4218 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4219 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4221 if (cxix < cxstack_ix)
4224 /* clear off anything above the scope we're re-entering */
4225 inner = PL_scopestack_ix;
4227 if (PL_scopestack_ix < inner)
4228 leave_scope(PL_scopestack[PL_scopestack_ix]);
4229 PL_curcop = cx->blk_oldcop;
4232 return cx->blk_loop.next_op;
4234 return cx->blk_givwhen.leave_op;
4238 S_doparseform(pTHX_ SV *sv)
4241 register char *s = SvPV_force(sv, len);
4242 register char * const send = s + len;
4243 register char *base = NULL;
4244 register I32 skipspaces = 0;
4245 bool noblank = FALSE;
4246 bool repeat = FALSE;
4247 bool postspace = FALSE;
4253 bool unchopnum = FALSE;
4254 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4257 Perl_croak(aTHX_ "Null picture in formline");
4259 /* estimate the buffer size needed */
4260 for (base = s; s <= send; s++) {
4261 if (*s == '\n' || *s == '@' || *s == '^')
4267 Newx(fops, maxops, U32);
4272 *fpc++ = FF_LINEMARK;
4273 noblank = repeat = FALSE;
4291 case ' ': case '\t':
4298 } /* else FALL THROUGH */
4306 *fpc++ = FF_LITERAL;
4314 *fpc++ = (U16)skipspaces;
4318 *fpc++ = FF_NEWLINE;
4322 arg = fpc - linepc + 1;
4329 *fpc++ = FF_LINEMARK;
4330 noblank = repeat = FALSE;
4339 ischop = s[-1] == '^';
4345 arg = (s - base) - 1;
4347 *fpc++ = FF_LITERAL;
4355 *fpc++ = 2; /* skip the @* or ^* */
4357 *fpc++ = FF_LINESNGL;
4360 *fpc++ = FF_LINEGLOB;
4362 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4363 arg = ischop ? 512 : 0;
4368 const char * const f = ++s;
4371 arg |= 256 + (s - f);
4373 *fpc++ = s - base; /* fieldsize for FETCH */
4374 *fpc++ = FF_DECIMAL;
4376 unchopnum |= ! ischop;
4378 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4379 arg = ischop ? 512 : 0;
4381 s++; /* skip the '0' first */
4385 const char * const f = ++s;
4388 arg |= 256 + (s - f);
4390 *fpc++ = s - base; /* fieldsize for FETCH */
4391 *fpc++ = FF_0DECIMAL;
4393 unchopnum |= ! ischop;
4397 bool ismore = FALSE;
4400 while (*++s == '>') ;
4401 prespace = FF_SPACE;
4403 else if (*s == '|') {
4404 while (*++s == '|') ;
4405 prespace = FF_HALFSPACE;
4410 while (*++s == '<') ;
4413 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4417 *fpc++ = s - base; /* fieldsize for FETCH */
4419 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4422 *fpc++ = (U16)prespace;
4436 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4438 { /* need to jump to the next word */
4440 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4441 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4442 s = SvPVX(sv) + SvCUR(sv) + z;
4444 Copy(fops, s, arg, U32);
4446 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4449 if (unchopnum && repeat)
4450 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4456 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4458 /* Can value be printed in fldsize chars, using %*.*f ? */
4462 int intsize = fldsize - (value < 0 ? 1 : 0);
4469 while (intsize--) pwr *= 10.0;
4470 while (frcsize--) eps /= 10.0;
4473 if (value + eps >= pwr)
4476 if (value - eps <= -pwr)
4483 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4486 SV * const datasv = FILTER_DATA(idx);
4487 const int filter_has_file = IoLINES(datasv);
4488 GV * const filter_child_proc = (GV *)IoFMT_GV(datasv);
4489 SV * const filter_state = (SV *)IoTOP_GV(datasv);
4490 SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4493 /* I was having segfault trouble under Linux 2.2.5 after a
4494 parse error occured. (Had to hack around it with a test
4495 for PL_error_count == 0.) Solaris doesn't segfault --
4496 not sure where the trouble is yet. XXX */
4498 if (filter_has_file) {
4499 len = FILTER_READ(idx+1, buf_sv, maxlen);
4502 if (filter_sub && len >= 0) {
4513 PUSHs(sv_2mortal(newSViv(maxlen)));
4515 PUSHs(filter_state);
4518 count = call_sv(filter_sub, G_SCALAR);
4534 IoLINES(datasv) = 0;
4535 if (filter_child_proc) {
4536 SvREFCNT_dec(filter_child_proc);
4537 IoFMT_GV(datasv) = NULL;
4540 SvREFCNT_dec(filter_state);
4541 IoTOP_GV(datasv) = NULL;
4544 SvREFCNT_dec(filter_sub);
4545 IoBOTTOM_GV(datasv) = NULL;
4547 filter_del(S_run_user_filter);
4553 /* perhaps someone can come up with a better name for
4554 this? it is not really "absolute", per se ... */
4556 S_path_is_absolute(const char *name)
4558 if (PERL_FILE_IS_ABSOLUTE(name)
4559 #ifdef MACOS_TRADITIONAL
4562 || (*name == '.' && (name[1] == '/' ||
4563 (name[1] == '.' && name[2] == '/')))
4575 * c-indentation-style: bsd
4577 * indent-tabs-mode: t
4580 * ex: set ts=8 sts=4 sw=4 noet: