3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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))
41 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
50 cxix = dopoptosub(cxstack_ix);
54 switch (cxstack[cxix].blk_gimme) {
67 /* XXXX Should store the old value to allow for tie/overload - and
68 restore in regcomp, where marked with XXXX. */
78 register PMOP *pm = (PMOP*)cLOGOP->op_other;
82 /* prevent recompiling under /o and ithreads. */
83 #if defined(USE_ITHREADS)
84 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
85 if (PL_op->op_flags & OPf_STACKED) {
94 if (PL_op->op_flags & OPf_STACKED) {
95 /* multiple args; concatentate them */
97 tmpstr = PAD_SV(ARGTARG);
98 sv_setpvs(tmpstr, "");
99 while (++MARK <= SP) {
100 if (PL_amagic_generation) {
102 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
103 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
105 sv_setsv(tmpstr, sv);
109 sv_catsv(tmpstr, *MARK);
118 SV * const sv = SvRV(tmpstr);
119 if (SvTYPE(sv) == SVt_REGEXP)
123 re = reg_temp_copy(re);
124 ReREFCNT_dec(PM_GETRE(pm));
129 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
131 assert (re != (REGEXP*) &PL_sv_undef);
133 /* Check against the last compiled regexp. */
134 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
135 memNE(RX_PRECOMP(re), t, len))
137 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
138 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
142 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
144 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
146 } else if (PL_curcop->cop_hints_hash) {
147 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
149 if (ptr && SvIOK(ptr) && SvIV(ptr))
150 eng = INT2PTR(regexp_engine*,SvIV(ptr));
153 if (PL_op->op_flags & OPf_SPECIAL)
154 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
156 if (DO_UTF8(tmpstr)) {
157 assert (SvUTF8(tmpstr));
158 } else if (SvUTF8(tmpstr)) {
159 /* Not doing UTF-8, despite what the SV says. Is this only if
160 we're trapped in use 'bytes'? */
161 /* Make a copy of the octet sequence, but without the flag on,
162 as the compiler now honours the SvUTF8 flag on tmpstr. */
164 const char *const p = SvPV(tmpstr, len);
165 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
169 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
171 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
173 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
174 inside tie/overload accessors. */
180 #ifndef INCOMPLETE_TAINTS
183 RX_EXTFLAGS(re) |= RXf_TAINTED;
185 RX_EXTFLAGS(re) &= ~RXf_TAINTED;
189 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
193 #if !defined(USE_ITHREADS)
194 /* can't change the optree at runtime either */
195 /* PMf_KEEP is handled differently under threads to avoid these problems */
196 if (pm->op_pmflags & PMf_KEEP) {
197 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
198 cLOGOP->op_first->op_next = PL_op->op_next;
208 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
209 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
210 register SV * const dstr = cx->sb_dstr;
211 register char *s = cx->sb_s;
212 register char *m = cx->sb_m;
213 char *orig = cx->sb_orig;
214 register REGEXP * const rx = cx->sb_rx;
216 REGEXP *old = PM_GETRE(pm);
220 PM_SETRE(pm,ReREFCNT_inc(rx));
223 rxres_restore(&cx->sb_rxres, rx);
224 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
226 if (cx->sb_iters++) {
227 const I32 saviters = cx->sb_iters;
228 if (cx->sb_iters > cx->sb_maxiters)
229 DIE(aTHX_ "Substitution loop");
231 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
232 cx->sb_rxtainted |= 2;
233 sv_catsv(dstr, POPs);
236 if (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
237 s == m, cx->sb_targ, NULL,
238 ((cx->sb_rflags & REXEC_COPY_STR)
239 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
240 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
242 SV * const targ = cx->sb_targ;
244 assert(cx->sb_strend >= s);
245 if(cx->sb_strend > s) {
246 if (DO_UTF8(dstr) && !SvUTF8(targ))
247 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
249 sv_catpvn(dstr, s, cx->sb_strend - s);
251 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
253 #ifdef PERL_OLD_COPY_ON_WRITE
255 sv_force_normal_flags(targ, SV_COW_DROP_PV);
261 SvPV_set(targ, SvPVX(dstr));
262 SvCUR_set(targ, SvCUR(dstr));
263 SvLEN_set(targ, SvLEN(dstr));
266 SvPV_set(dstr, NULL);
268 TAINT_IF(cx->sb_rxtainted & 1);
269 mPUSHi(saviters - 1);
271 (void)SvPOK_only_UTF8(targ);
272 TAINT_IF(cx->sb_rxtainted);
276 LEAVE_SCOPE(cx->sb_oldsave);
278 RETURNOP(pm->op_next);
280 cx->sb_iters = saviters;
282 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
285 cx->sb_orig = orig = RX_SUBBEG(rx);
287 cx->sb_strend = s + (cx->sb_strend - m);
289 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
291 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
292 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
294 sv_catpvn(dstr, s, m-s);
296 cx->sb_s = RX_OFFS(rx)[0].end + orig;
297 { /* Update the pos() information. */
298 SV * const sv = cx->sb_targ;
300 SvUPGRADE(sv, SVt_PVMG);
301 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
302 #ifdef PERL_OLD_COPY_ON_WRITE
304 sv_force_normal_flags(sv, 0);
306 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
309 mg->mg_len = m - orig;
312 (void)ReREFCNT_inc(rx);
313 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
314 rxres_save(&cx->sb_rxres, rx);
315 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
319 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
324 PERL_ARGS_ASSERT_RXRES_SAVE;
327 if (!p || p[1] < RX_NPARENS(rx)) {
328 #ifdef PERL_OLD_COPY_ON_WRITE
329 i = 7 + RX_NPARENS(rx) * 2;
331 i = 6 + RX_NPARENS(rx) * 2;
340 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
341 RX_MATCH_COPIED_off(rx);
343 #ifdef PERL_OLD_COPY_ON_WRITE
344 *p++ = PTR2UV(RX_SAVED_COPY(rx));
345 RX_SAVED_COPY(rx) = NULL;
348 *p++ = RX_NPARENS(rx);
350 *p++ = PTR2UV(RX_SUBBEG(rx));
351 *p++ = (UV)RX_SUBLEN(rx);
352 for (i = 0; i <= RX_NPARENS(rx); ++i) {
353 *p++ = (UV)RX_OFFS(rx)[i].start;
354 *p++ = (UV)RX_OFFS(rx)[i].end;
359 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
364 PERL_ARGS_ASSERT_RXRES_RESTORE;
367 RX_MATCH_COPY_FREE(rx);
368 RX_MATCH_COPIED_set(rx, *p);
371 #ifdef PERL_OLD_COPY_ON_WRITE
372 if (RX_SAVED_COPY(rx))
373 SvREFCNT_dec (RX_SAVED_COPY(rx));
374 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
378 RX_NPARENS(rx) = *p++;
380 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
381 RX_SUBLEN(rx) = (I32)(*p++);
382 for (i = 0; i <= RX_NPARENS(rx); ++i) {
383 RX_OFFS(rx)[i].start = (I32)(*p++);
384 RX_OFFS(rx)[i].end = (I32)(*p++);
389 Perl_rxres_free(pTHX_ void **rsp)
391 UV * const p = (UV*)*rsp;
393 PERL_ARGS_ASSERT_RXRES_FREE;
398 void *tmp = INT2PTR(char*,*p);
401 PoisonFree(*p, 1, sizeof(*p));
403 Safefree(INT2PTR(char*,*p));
405 #ifdef PERL_OLD_COPY_ON_WRITE
407 SvREFCNT_dec (INT2PTR(SV*,p[1]));
417 dVAR; dSP; dMARK; dORIGMARK;
418 register SV * const tmpForm = *++MARK;
423 register SV *sv = NULL;
424 const char *item = NULL;
428 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
429 const char *chophere = NULL;
430 char *linemark = NULL;
432 bool gotsome = FALSE;
434 const STRLEN fudge = SvPOK(tmpForm)
435 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
436 bool item_is_utf8 = FALSE;
437 bool targ_is_utf8 = FALSE;
439 OP * parseres = NULL;
442 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
443 if (SvREADONLY(tmpForm)) {
444 SvREADONLY_off(tmpForm);
445 parseres = doparseform(tmpForm);
446 SvREADONLY_on(tmpForm);
449 parseres = doparseform(tmpForm);
453 SvPV_force(PL_formtarget, len);
454 if (DO_UTF8(PL_formtarget))
456 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
458 f = SvPV_const(tmpForm, len);
459 /* need to jump to the next word */
460 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
464 const char *name = "???";
467 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
468 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
469 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
470 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
471 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
473 case FF_CHECKNL: name = "CHECKNL"; break;
474 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
475 case FF_SPACE: name = "SPACE"; break;
476 case FF_HALFSPACE: name = "HALFSPACE"; break;
477 case FF_ITEM: name = "ITEM"; break;
478 case FF_CHOP: name = "CHOP"; break;
479 case FF_LINEGLOB: name = "LINEGLOB"; break;
480 case FF_NEWLINE: name = "NEWLINE"; break;
481 case FF_MORE: name = "MORE"; break;
482 case FF_LINEMARK: name = "LINEMARK"; break;
483 case FF_END: name = "END"; break;
484 case FF_0DECIMAL: name = "0DECIMAL"; break;
485 case FF_LINESNGL: name = "LINESNGL"; break;
488 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
490 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
501 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
502 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
504 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
505 t = SvEND(PL_formtarget);
509 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
510 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
512 sv_utf8_upgrade(PL_formtarget);
513 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
514 t = SvEND(PL_formtarget);
534 if (ckWARN(WARN_SYNTAX))
535 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
542 const char *s = item = SvPV_const(sv, len);
545 itemsize = sv_len_utf8(sv);
546 if (itemsize != (I32)len) {
548 if (itemsize > fieldsize) {
549 itemsize = fieldsize;
550 itembytes = itemsize;
551 sv_pos_u2b(sv, &itembytes, 0);
555 send = chophere = s + itembytes;
565 sv_pos_b2u(sv, &itemsize);
569 item_is_utf8 = FALSE;
570 if (itemsize > fieldsize)
571 itemsize = fieldsize;
572 send = chophere = s + itemsize;
586 const char *s = item = SvPV_const(sv, len);
589 itemsize = sv_len_utf8(sv);
590 if (itemsize != (I32)len) {
592 if (itemsize <= fieldsize) {
593 const char *send = chophere = s + itemsize;
606 itemsize = fieldsize;
607 itembytes = itemsize;
608 sv_pos_u2b(sv, &itembytes, 0);
609 send = chophere = s + itembytes;
610 while (s < send || (s == send && isSPACE(*s))) {
620 if (strchr(PL_chopset, *s))
625 itemsize = chophere - item;
626 sv_pos_b2u(sv, &itemsize);
632 item_is_utf8 = FALSE;
633 if (itemsize <= fieldsize) {
634 const char *const send = chophere = s + itemsize;
647 itemsize = fieldsize;
648 send = chophere = s + itemsize;
649 while (s < send || (s == send && isSPACE(*s))) {
659 if (strchr(PL_chopset, *s))
664 itemsize = chophere - item;
670 arg = fieldsize - itemsize;
679 arg = fieldsize - itemsize;
690 const char *s = item;
694 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
696 sv_utf8_upgrade(PL_formtarget);
697 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
698 t = SvEND(PL_formtarget);
702 if (UTF8_IS_CONTINUED(*s)) {
703 STRLEN skip = UTF8SKIP(s);
720 if ( !((*t++ = *s++) & ~31) )
726 if (targ_is_utf8 && !item_is_utf8) {
727 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
729 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
730 for (; t < SvEND(PL_formtarget); t++) {
743 const int ch = *t++ = *s++;
746 if ( !((*t++ = *s++) & ~31) )
755 const char *s = chophere;
769 const bool oneline = fpc[-1] == FF_LINESNGL;
770 const char *s = item = SvPV_const(sv, len);
771 item_is_utf8 = DO_UTF8(sv);
774 STRLEN to_copy = itemsize;
775 const char *const send = s + len;
776 const U8 *source = (const U8 *) s;
780 chophere = s + itemsize;
784 to_copy = s - SvPVX_const(sv) - 1;
796 if (targ_is_utf8 && !item_is_utf8) {
797 source = tmp = bytes_to_utf8(source, &to_copy);
798 SvCUR_set(PL_formtarget,
799 t - SvPVX_const(PL_formtarget));
801 if (item_is_utf8 && !targ_is_utf8) {
802 /* Upgrade targ to UTF8, and then we reduce it to
803 a problem we have a simple solution for. */
804 SvCUR_set(PL_formtarget,
805 t - SvPVX_const(PL_formtarget));
807 /* Don't need get magic. */
808 sv_utf8_upgrade_flags(PL_formtarget, 0);
810 SvCUR_set(PL_formtarget,
811 t - SvPVX_const(PL_formtarget));
814 /* Easy. They agree. */
815 assert (item_is_utf8 == targ_is_utf8);
817 SvGROW(PL_formtarget,
818 SvCUR(PL_formtarget) + to_copy + fudge + 1);
819 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
821 Copy(source, t, to_copy, char);
823 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
825 if (SvGMAGICAL(sv)) {
826 /* Mustn't call sv_pos_b2u() as it does a second
827 mg_get(). Is this a bug? Do we need a _flags()
829 itemsize = utf8_length(source, source + itemsize);
831 sv_pos_b2u(sv, &itemsize);
843 #if defined(USE_LONG_DOUBLE)
846 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
850 "%#0*.*f" : "%0*.*f");
855 #if defined(USE_LONG_DOUBLE)
857 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
860 ((arg & 256) ? "%#*.*f" : "%*.*f");
863 /* If the field is marked with ^ and the value is undefined,
865 if ((arg & 512) && !SvOK(sv)) {
873 /* overflow evidence */
874 if (num_overflow(value, fieldsize, arg)) {
880 /* Formats aren't yet marked for locales, so assume "yes". */
882 STORE_NUMERIC_STANDARD_SET_LOCAL();
883 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
884 RESTORE_NUMERIC_STANDARD();
891 while (t-- > linemark && *t == ' ') ;
899 if (arg) { /* repeat until fields exhausted? */
901 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
902 lines += FmLINES(PL_formtarget);
905 if (strnEQ(linemark, linemark - arg, arg))
906 DIE(aTHX_ "Runaway format");
909 SvUTF8_on(PL_formtarget);
910 FmLINES(PL_formtarget) = lines;
912 RETURNOP(cLISTOP->op_first);
923 const char *s = chophere;
924 const char *send = item + len;
926 while (isSPACE(*s) && (s < send))
931 arg = fieldsize - itemsize;
938 if (strnEQ(s1," ",3)) {
939 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
950 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
952 SvUTF8_on(PL_formtarget);
953 FmLINES(PL_formtarget) += lines;
965 if (PL_stack_base + *PL_markstack_ptr == SP) {
967 if (GIMME_V == G_SCALAR)
969 RETURNOP(PL_op->op_next->op_next);
971 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
972 pp_pushmark(); /* push dst */
973 pp_pushmark(); /* push src */
974 ENTER; /* enter outer scope */
977 if (PL_op->op_private & OPpGREP_LEX)
978 SAVESPTR(PAD_SVl(PL_op->op_targ));
981 ENTER; /* enter inner scope */
984 src = PL_stack_base[*PL_markstack_ptr];
986 if (PL_op->op_private & OPpGREP_LEX)
987 PAD_SVl(PL_op->op_targ) = src;
992 if (PL_op->op_type == OP_MAPSTART)
993 pp_pushmark(); /* push top */
994 return ((LOGOP*)PL_op->op_next)->op_other;
1000 const I32 gimme = GIMME_V;
1001 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1007 /* first, move source pointer to the next item in the source list */
1008 ++PL_markstack_ptr[-1];
1010 /* if there are new items, push them into the destination list */
1011 if (items && gimme != G_VOID) {
1012 /* might need to make room back there first */
1013 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1014 /* XXX this implementation is very pessimal because the stack
1015 * is repeatedly extended for every set of items. Is possible
1016 * to do this without any stack extension or copying at all
1017 * by maintaining a separate list over which the map iterates
1018 * (like foreach does). --gsar */
1020 /* everything in the stack after the destination list moves
1021 * towards the end the stack by the amount of room needed */
1022 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1024 /* items to shift up (accounting for the moved source pointer) */
1025 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1027 /* This optimization is by Ben Tilly and it does
1028 * things differently from what Sarathy (gsar)
1029 * is describing. The downside of this optimization is
1030 * that leaves "holes" (uninitialized and hopefully unused areas)
1031 * to the Perl stack, but on the other hand this
1032 * shouldn't be a problem. If Sarathy's idea gets
1033 * implemented, this optimization should become
1034 * irrelevant. --jhi */
1036 shift = count; /* Avoid shifting too often --Ben Tilly */
1040 dst = (SP += shift);
1041 PL_markstack_ptr[-1] += shift;
1042 *PL_markstack_ptr += shift;
1046 /* copy the new items down to the destination list */
1047 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1048 if (gimme == G_ARRAY) {
1050 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1053 /* scalar context: we don't care about which values map returns
1054 * (we use undef here). And so we certainly don't want to do mortal
1055 * copies of meaningless values. */
1056 while (items-- > 0) {
1058 *dst-- = &PL_sv_undef;
1062 LEAVE; /* exit inner scope */
1065 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1067 (void)POPMARK; /* pop top */
1068 LEAVE; /* exit outer scope */
1069 (void)POPMARK; /* pop src */
1070 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1071 (void)POPMARK; /* pop dst */
1072 SP = PL_stack_base + POPMARK; /* pop original mark */
1073 if (gimme == G_SCALAR) {
1074 if (PL_op->op_private & OPpGREP_LEX) {
1075 SV* sv = sv_newmortal();
1076 sv_setiv(sv, items);
1084 else if (gimme == G_ARRAY)
1091 ENTER; /* enter inner scope */
1094 /* set $_ to the new source item */
1095 src = PL_stack_base[PL_markstack_ptr[-1]];
1097 if (PL_op->op_private & OPpGREP_LEX)
1098 PAD_SVl(PL_op->op_targ) = src;
1102 RETURNOP(cLOGOP->op_other);
1111 if (GIMME == G_ARRAY)
1113 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1114 return cLOGOP->op_other;
1124 if (GIMME == G_ARRAY) {
1125 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1129 SV * const targ = PAD_SV(PL_op->op_targ);
1132 if (PL_op->op_private & OPpFLIP_LINENUM) {
1133 if (GvIO(PL_last_in_gv)) {
1134 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1137 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1139 flip = SvIV(sv) == SvIV(GvSV(gv));
1145 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1146 if (PL_op->op_flags & OPf_SPECIAL) {
1154 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1157 sv_setpvs(TARG, "");
1163 /* This code tries to decide if "$left .. $right" should use the
1164 magical string increment, or if the range is numeric (we make
1165 an exception for .."0" [#18165]). AMS 20021031. */
1167 #define RANGE_IS_NUMERIC(left,right) ( \
1168 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1169 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1170 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1171 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1172 && (!SvOK(right) || looks_like_number(right))))
1178 if (GIMME == G_ARRAY) {
1184 if (RANGE_IS_NUMERIC(left,right)) {
1187 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1188 (SvOK(right) && SvNV(right) > IV_MAX))
1189 DIE(aTHX_ "Range iterator outside integer range");
1200 SV * const sv = sv_2mortal(newSViv(i++));
1205 SV * const final = sv_mortalcopy(right);
1207 const char * const tmps = SvPV_const(final, len);
1209 SV *sv = sv_mortalcopy(left);
1210 SvPV_force_nolen(sv);
1211 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1213 if (strEQ(SvPVX_const(sv),tmps))
1215 sv = sv_2mortal(newSVsv(sv));
1222 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1226 if (PL_op->op_private & OPpFLIP_LINENUM) {
1227 if (GvIO(PL_last_in_gv)) {
1228 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1231 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1232 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1240 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1241 sv_catpvs(targ, "E0");
1251 static const char * const context_name[] = {
1254 NULL, /* CXt_BLOCK never actually needs "block" */
1256 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1257 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1258 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1259 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1267 S_dopoptolabel(pTHX_ const char *label)
1272 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1274 for (i = cxstack_ix; i >= 0; i--) {
1275 register const PERL_CONTEXT * const cx = &cxstack[i];
1276 switch (CxTYPE(cx)) {
1284 if (ckWARN(WARN_EXITING))
1285 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1286 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1287 if (CxTYPE(cx) == CXt_NULL)
1290 case CXt_LOOP_LAZYIV:
1291 case CXt_LOOP_LAZYSV:
1293 case CXt_LOOP_PLAIN:
1294 if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
1295 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1296 (long)i, CxLABEL(cx)));
1299 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1309 Perl_dowantarray(pTHX)
1312 const I32 gimme = block_gimme();
1313 return (gimme == G_VOID) ? G_SCALAR : gimme;
1317 Perl_block_gimme(pTHX)
1320 const I32 cxix = dopoptosub(cxstack_ix);
1324 switch (cxstack[cxix].blk_gimme) {
1332 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1339 Perl_is_lvalue_sub(pTHX)
1342 const I32 cxix = dopoptosub(cxstack_ix);
1343 assert(cxix >= 0); /* We should only be called from inside subs */
1345 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1346 return CxLVAL(cxstack + cxix);
1352 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1357 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1359 for (i = startingblock; i >= 0; i--) {
1360 register const PERL_CONTEXT * const cx = &cxstk[i];
1361 switch (CxTYPE(cx)) {
1367 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1375 S_dopoptoeval(pTHX_ I32 startingblock)
1379 for (i = startingblock; i >= 0; i--) {
1380 register const PERL_CONTEXT *cx = &cxstack[i];
1381 switch (CxTYPE(cx)) {
1385 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1393 S_dopoptoloop(pTHX_ I32 startingblock)
1397 for (i = startingblock; i >= 0; i--) {
1398 register const PERL_CONTEXT * const cx = &cxstack[i];
1399 switch (CxTYPE(cx)) {
1405 if (ckWARN(WARN_EXITING))
1406 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1407 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1408 if ((CxTYPE(cx)) == CXt_NULL)
1411 case CXt_LOOP_LAZYIV:
1412 case CXt_LOOP_LAZYSV:
1414 case CXt_LOOP_PLAIN:
1415 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1423 S_dopoptogiven(pTHX_ I32 startingblock)
1427 for (i = startingblock; i >= 0; i--) {
1428 register const PERL_CONTEXT *cx = &cxstack[i];
1429 switch (CxTYPE(cx)) {
1433 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1435 case CXt_LOOP_PLAIN:
1436 assert(!CxFOREACHDEF(cx));
1438 case CXt_LOOP_LAZYIV:
1439 case CXt_LOOP_LAZYSV:
1441 if (CxFOREACHDEF(cx)) {
1442 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1451 S_dopoptowhen(pTHX_ I32 startingblock)
1455 for (i = startingblock; i >= 0; i--) {
1456 register const PERL_CONTEXT *cx = &cxstack[i];
1457 switch (CxTYPE(cx)) {
1461 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1469 Perl_dounwind(pTHX_ I32 cxix)
1474 while (cxstack_ix > cxix) {
1476 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1477 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1478 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1479 /* Note: we don't need to restore the base context info till the end. */
1480 switch (CxTYPE(cx)) {
1483 continue; /* not break */
1491 case CXt_LOOP_LAZYIV:
1492 case CXt_LOOP_LAZYSV:
1494 case CXt_LOOP_PLAIN:
1505 PERL_UNUSED_VAR(optype);
1509 Perl_qerror(pTHX_ SV *err)
1513 PERL_ARGS_ASSERT_QERROR;
1516 sv_catsv(ERRSV, err);
1518 sv_catsv(PL_errors, err);
1520 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1522 ++PL_parser->error_count;
1526 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1535 if (PL_in_eval & EVAL_KEEPERR) {
1536 static const char prefix[] = "\t(in cleanup) ";
1537 SV * const err = ERRSV;
1538 const char *e = NULL;
1541 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1543 e = SvPV_const(err, len);
1545 if (*e != *message || strNE(e,message))
1549 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1550 sv_catpvn(err, prefix, sizeof(prefix)-1);
1551 sv_catpvn(err, message, msglen);
1552 if (ckWARN(WARN_MISC)) {
1553 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1554 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1559 sv_setpvn(ERRSV, message, msglen);
1563 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1564 && PL_curstackinfo->si_prev)
1572 register PERL_CONTEXT *cx;
1575 if (cxix < cxstack_ix)
1578 POPBLOCK(cx,PL_curpm);
1579 if (CxTYPE(cx) != CXt_EVAL) {
1581 message = SvPVx_const(ERRSV, msglen);
1582 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1583 PerlIO_write(Perl_error_log, message, msglen);
1588 if (gimme == G_SCALAR)
1589 *++newsp = &PL_sv_undef;
1590 PL_stack_sp = newsp;
1594 /* LEAVE could clobber PL_curcop (see save_re_context())
1595 * XXX it might be better to find a way to avoid messing with
1596 * PL_curcop in save_re_context() instead, but this is a more
1597 * minimal fix --GSAR */
1598 PL_curcop = cx->blk_oldcop;
1600 if (optype == OP_REQUIRE) {
1601 const char* const msg = SvPVx_nolen_const(ERRSV);
1602 SV * const nsv = cx->blk_eval.old_namesv;
1603 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1605 DIE(aTHX_ "%sCompilation failed in require",
1606 *msg ? msg : "Unknown error\n");
1608 assert(CxTYPE(cx) == CXt_EVAL);
1609 return cx->blk_eval.retop;
1613 message = SvPVx_const(ERRSV, msglen);
1615 write_to_stderr(message, msglen);
1623 dVAR; dSP; dPOPTOPssrl;
1624 if (SvTRUE(left) != SvTRUE(right))
1634 register I32 cxix = dopoptosub(cxstack_ix);
1635 register const PERL_CONTEXT *cx;
1636 register const PERL_CONTEXT *ccstack = cxstack;
1637 const PERL_SI *top_si = PL_curstackinfo;
1639 const char *stashname;
1646 /* we may be in a higher stacklevel, so dig down deeper */
1647 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1648 top_si = top_si->si_prev;
1649 ccstack = top_si->si_cxstack;
1650 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1653 if (GIMME != G_ARRAY) {
1659 /* caller() should not report the automatic calls to &DB::sub */
1660 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1661 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1665 cxix = dopoptosub_at(ccstack, cxix - 1);
1668 cx = &ccstack[cxix];
1669 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1670 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1671 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1672 field below is defined for any cx. */
1673 /* caller() should not report the automatic calls to &DB::sub */
1674 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1675 cx = &ccstack[dbcxix];
1678 stashname = CopSTASHPV(cx->blk_oldcop);
1679 if (GIMME != G_ARRAY) {
1682 PUSHs(&PL_sv_undef);
1685 sv_setpv(TARG, stashname);
1694 PUSHs(&PL_sv_undef);
1696 mPUSHs(newSVpv(stashname, 0));
1697 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1698 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1701 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1702 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1703 /* So is ccstack[dbcxix]. */
1705 SV * const sv = newSV(0);
1706 gv_efullname3(sv, cvgv, NULL);
1708 PUSHs(boolSV(CxHASARGS(cx)));
1711 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1712 PUSHs(boolSV(CxHASARGS(cx)));
1716 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1719 gimme = (I32)cx->blk_gimme;
1720 if (gimme == G_VOID)
1721 PUSHs(&PL_sv_undef);
1723 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1724 if (CxTYPE(cx) == CXt_EVAL) {
1726 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1727 PUSHs(cx->blk_eval.cur_text);
1731 else if (cx->blk_eval.old_namesv) {
1732 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1735 /* eval BLOCK (try blocks have old_namesv == 0) */
1737 PUSHs(&PL_sv_undef);
1738 PUSHs(&PL_sv_undef);
1742 PUSHs(&PL_sv_undef);
1743 PUSHs(&PL_sv_undef);
1745 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1746 && CopSTASH_eq(PL_curcop, PL_debstash))
1748 AV * const ary = cx->blk_sub.argarray;
1749 const int off = AvARRAY(ary) - AvALLOC(ary);
1752 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1753 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1755 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1758 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1759 av_extend(PL_dbargs, AvFILLp(ary) + off);
1760 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1761 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1763 /* XXX only hints propagated via op_private are currently
1764 * visible (others are not easily accessible, since they
1765 * use the global PL_hints) */
1766 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1769 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1771 if (old_warnings == pWARN_NONE ||
1772 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1773 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1774 else if (old_warnings == pWARN_ALL ||
1775 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1776 /* Get the bit mask for $warnings::Bits{all}, because
1777 * it could have been extended by warnings::register */
1779 HV * const bits = get_hv("warnings::Bits", FALSE);
1780 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1781 mask = newSVsv(*bits_all);
1784 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1788 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1792 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1793 sv_2mortal(newRV_noinc(
1794 MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1795 cx->blk_oldcop->cop_hints_hash))))
1804 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1805 sv_reset(tmps, CopSTASH(PL_curcop));
1810 /* like pp_nextstate, but used instead when the debugger is active */
1815 PL_curcop = (COP*)PL_op;
1816 TAINT_NOT; /* Each statement is presumed innocent */
1817 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1820 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1821 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1824 register PERL_CONTEXT *cx;
1825 const I32 gimme = G_ARRAY;
1827 GV * const gv = PL_DBgv;
1828 register CV * const cv = GvCV(gv);
1831 DIE(aTHX_ "No DB::DB routine defined");
1833 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1834 /* don't do recursive DB::DB call */
1849 (void)(*CvXSUB(cv))(aTHX_ cv);
1856 PUSHBLOCK(cx, CXt_SUB, SP);
1858 cx->blk_sub.retop = PL_op->op_next;
1861 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1862 RETURNOP(CvSTART(cv));
1872 register PERL_CONTEXT *cx;
1873 const I32 gimme = GIMME_V;
1875 U8 cxtype = CXt_LOOP_FOR;
1883 if (PL_op->op_targ) {
1884 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1885 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1886 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1887 SVs_PADSTALE, SVs_PADSTALE);
1889 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1890 #ifndef USE_ITHREADS
1891 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1897 GV * const gv = (GV*)POPs;
1898 svp = &GvSV(gv); /* symbol table variable */
1899 SAVEGENERICSV(*svp);
1902 iterdata = (PAD*)gv;
1906 if (PL_op->op_private & OPpITER_DEF)
1907 cxtype |= CXp_FOR_DEF;
1911 PUSHBLOCK(cx, cxtype, SP);
1913 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1915 PUSHLOOP_FOR(cx, svp, MARK, 0);
1917 if (PL_op->op_flags & OPf_STACKED) {
1918 SV *maybe_ary = POPs;
1919 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1921 SV * const right = maybe_ary;
1924 if (RANGE_IS_NUMERIC(sv,right)) {
1925 cx->cx_type &= ~CXTYPEMASK;
1926 cx->cx_type |= CXt_LOOP_LAZYIV;
1927 /* Make sure that no-one re-orders cop.h and breaks our
1929 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1930 #ifdef NV_PRESERVES_UV
1931 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1932 (SvNV(sv) > (NV)IV_MAX)))
1934 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1935 (SvNV(right) < (NV)IV_MIN))))
1937 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1940 ((SvUV(sv) > (UV)IV_MAX) ||
1941 (SvNV(sv) > (NV)UV_MAX)))))
1943 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1945 ((SvNV(right) > 0) &&
1946 ((SvUV(right) > (UV)IV_MAX) ||
1947 (SvNV(right) > (NV)UV_MAX))))))
1949 DIE(aTHX_ "Range iterator outside integer range");
1950 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1951 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1953 /* for correct -Dstv display */
1954 cx->blk_oldsp = sp - PL_stack_base;
1958 cx->cx_type &= ~CXTYPEMASK;
1959 cx->cx_type |= CXt_LOOP_LAZYSV;
1960 /* Make sure that no-one re-orders cop.h and breaks our
1962 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
1963 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
1964 cx->blk_loop.state_u.lazysv.end = right;
1965 SvREFCNT_inc(right);
1966 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
1967 /* This will do the upgrade to SVt_PV, and warn if the value
1968 is uninitialised. */
1969 (void) SvPV_nolen_const(right);
1970 /* Doing this avoids a check every time in pp_iter in pp_hot.c
1971 to replace !SvOK() with a pointer to "". */
1973 SvREFCNT_dec(right);
1974 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
1978 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
1979 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
1980 SvREFCNT_inc(maybe_ary);
1981 cx->blk_loop.state_u.ary.ix =
1982 (PL_op->op_private & OPpITER_REVERSED) ?
1983 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
1987 else { /* iterating over items on the stack */
1988 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
1989 if (PL_op->op_private & OPpITER_REVERSED) {
1990 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
1993 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2003 register PERL_CONTEXT *cx;
2004 const I32 gimme = GIMME_V;
2010 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2011 PUSHLOOP_PLAIN(cx, SP);
2019 register PERL_CONTEXT *cx;
2026 assert(CxTYPE_is_LOOP(cx));
2028 newsp = PL_stack_base + cx->blk_loop.resetsp;
2031 if (gimme == G_VOID)
2033 else if (gimme == G_SCALAR) {
2035 *++newsp = sv_mortalcopy(*SP);
2037 *++newsp = &PL_sv_undef;
2041 *++newsp = sv_mortalcopy(*++mark);
2042 TAINT_NOT; /* Each item is independent */
2048 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2049 PL_curpm = newpm; /* ... and pop $1 et al */
2060 register PERL_CONTEXT *cx;
2061 bool popsub2 = FALSE;
2062 bool clear_errsv = FALSE;
2070 const I32 cxix = dopoptosub(cxstack_ix);
2073 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2074 * sort block, which is a CXt_NULL
2077 PL_stack_base[1] = *PL_stack_sp;
2078 PL_stack_sp = PL_stack_base + 1;
2082 DIE(aTHX_ "Can't return outside a subroutine");
2084 if (cxix < cxstack_ix)
2087 if (CxMULTICALL(&cxstack[cxix])) {
2088 gimme = cxstack[cxix].blk_gimme;
2089 if (gimme == G_VOID)
2090 PL_stack_sp = PL_stack_base;
2091 else if (gimme == G_SCALAR) {
2092 PL_stack_base[1] = *PL_stack_sp;
2093 PL_stack_sp = PL_stack_base + 1;
2099 switch (CxTYPE(cx)) {
2102 retop = cx->blk_sub.retop;
2103 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2106 if (!(PL_in_eval & EVAL_KEEPERR))
2109 retop = cx->blk_eval.retop;
2113 if (optype == OP_REQUIRE &&
2114 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2116 /* Unassume the success we assumed earlier. */
2117 SV * const nsv = cx->blk_eval.old_namesv;
2118 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2119 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2124 retop = cx->blk_sub.retop;
2127 DIE(aTHX_ "panic: return");
2131 if (gimme == G_SCALAR) {
2134 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2136 *++newsp = SvREFCNT_inc(*SP);
2141 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2143 *++newsp = sv_mortalcopy(sv);
2148 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2151 *++newsp = sv_mortalcopy(*SP);
2154 *++newsp = &PL_sv_undef;
2156 else if (gimme == G_ARRAY) {
2157 while (++MARK <= SP) {
2158 *++newsp = (popsub2 && SvTEMP(*MARK))
2159 ? *MARK : sv_mortalcopy(*MARK);
2160 TAINT_NOT; /* Each item is independent */
2163 PL_stack_sp = newsp;
2166 /* Stack values are safe: */
2169 POPSUB(cx,sv); /* release CV and @_ ... */
2173 PL_curpm = newpm; /* ... and pop $1 et al */
2186 register PERL_CONTEXT *cx;
2197 if (PL_op->op_flags & OPf_SPECIAL) {
2198 cxix = dopoptoloop(cxstack_ix);
2200 DIE(aTHX_ "Can't \"last\" outside a loop block");
2203 cxix = dopoptolabel(cPVOP->op_pv);
2205 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2207 if (cxix < cxstack_ix)
2211 cxstack_ix++; /* temporarily protect top context */
2213 switch (CxTYPE(cx)) {
2214 case CXt_LOOP_LAZYIV:
2215 case CXt_LOOP_LAZYSV:
2217 case CXt_LOOP_PLAIN:
2219 newsp = PL_stack_base + cx->blk_loop.resetsp;
2220 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2224 nextop = cx->blk_sub.retop;
2228 nextop = cx->blk_eval.retop;
2232 nextop = cx->blk_sub.retop;
2235 DIE(aTHX_ "panic: last");
2239 if (gimme == G_SCALAR) {
2241 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2242 ? *SP : sv_mortalcopy(*SP);
2244 *++newsp = &PL_sv_undef;
2246 else if (gimme == G_ARRAY) {
2247 while (++MARK <= SP) {
2248 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2249 ? *MARK : sv_mortalcopy(*MARK);
2250 TAINT_NOT; /* Each item is independent */
2258 /* Stack values are safe: */
2260 case CXt_LOOP_LAZYIV:
2261 case CXt_LOOP_PLAIN:
2262 case CXt_LOOP_LAZYSV:
2264 POPLOOP(cx); /* release loop vars ... */
2268 POPSUB(cx,sv); /* release CV and @_ ... */
2271 PL_curpm = newpm; /* ... and pop $1 et al */
2274 PERL_UNUSED_VAR(optype);
2275 PERL_UNUSED_VAR(gimme);
2283 register PERL_CONTEXT *cx;
2286 if (PL_op->op_flags & OPf_SPECIAL) {
2287 cxix = dopoptoloop(cxstack_ix);
2289 DIE(aTHX_ "Can't \"next\" outside a loop block");
2292 cxix = dopoptolabel(cPVOP->op_pv);
2294 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2296 if (cxix < cxstack_ix)
2299 /* clear off anything above the scope we're re-entering, but
2300 * save the rest until after a possible continue block */
2301 inner = PL_scopestack_ix;
2303 if (PL_scopestack_ix < inner)
2304 leave_scope(PL_scopestack[PL_scopestack_ix]);
2305 PL_curcop = cx->blk_oldcop;
2306 return CX_LOOP_NEXTOP_GET(cx);
2313 register PERL_CONTEXT *cx;
2317 if (PL_op->op_flags & OPf_SPECIAL) {
2318 cxix = dopoptoloop(cxstack_ix);
2320 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2323 cxix = dopoptolabel(cPVOP->op_pv);
2325 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2327 if (cxix < cxstack_ix)
2330 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2331 if (redo_op->op_type == OP_ENTER) {
2332 /* pop one less context to avoid $x being freed in while (my $x..) */
2334 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2335 redo_op = redo_op->op_next;
2339 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2340 LEAVE_SCOPE(oldsave);
2342 PL_curcop = cx->blk_oldcop;
2347 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2351 static const char too_deep[] = "Target of goto is too deeply nested";
2353 PERL_ARGS_ASSERT_DOFINDLABEL;
2356 Perl_croak(aTHX_ too_deep);
2357 if (o->op_type == OP_LEAVE ||
2358 o->op_type == OP_SCOPE ||
2359 o->op_type == OP_LEAVELOOP ||
2360 o->op_type == OP_LEAVESUB ||
2361 o->op_type == OP_LEAVETRY)
2363 *ops++ = cUNOPo->op_first;
2365 Perl_croak(aTHX_ too_deep);
2368 if (o->op_flags & OPf_KIDS) {
2370 /* First try all the kids at this level, since that's likeliest. */
2371 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2372 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2373 CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label))
2376 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2377 if (kid == PL_lastgotoprobe)
2379 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2382 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2383 ops[-1]->op_type == OP_DBSTATE)
2388 if ((o = dofindlabel(kid, label, ops, oplimit)))
2401 register PERL_CONTEXT *cx;
2402 #define GOTO_DEPTH 64
2403 OP *enterops[GOTO_DEPTH];
2404 const char *label = NULL;
2405 const bool do_dump = (PL_op->op_type == OP_DUMP);
2406 static const char must_have_label[] = "goto must have label";
2408 if (PL_op->op_flags & OPf_STACKED) {
2409 SV * const sv = POPs;
2411 /* This egregious kludge implements goto &subroutine */
2412 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2414 register PERL_CONTEXT *cx;
2415 CV *cv = MUTABLE_CV(SvRV(sv));
2422 if (!CvROOT(cv) && !CvXSUB(cv)) {
2423 const GV * const gv = CvGV(cv);
2427 /* autoloaded stub? */
2428 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2430 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2431 GvNAMELEN(gv), FALSE);
2432 if (autogv && (cv = GvCV(autogv)))
2434 tmpstr = sv_newmortal();
2435 gv_efullname3(tmpstr, gv, NULL);
2436 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2438 DIE(aTHX_ "Goto undefined subroutine");
2441 /* First do some returnish stuff. */
2442 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2444 cxix = dopoptosub(cxstack_ix);
2446 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2447 if (cxix < cxstack_ix)
2451 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2452 if (CxTYPE(cx) == CXt_EVAL) {
2454 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2456 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2458 else if (CxMULTICALL(cx))
2459 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2460 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2461 /* put @_ back onto stack */
2462 AV* av = cx->blk_sub.argarray;
2464 items = AvFILLp(av) + 1;
2465 EXTEND(SP, items+1); /* @_ could have been extended. */
2466 Copy(AvARRAY(av), SP + 1, items, SV*);
2467 SvREFCNT_dec(GvAV(PL_defgv));
2468 GvAV(PL_defgv) = cx->blk_sub.savearray;
2470 /* abandon @_ if it got reified */
2475 av_extend(av, items-1);
2477 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2480 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2481 AV* const av = GvAV(PL_defgv);
2482 items = AvFILLp(av) + 1;
2483 EXTEND(SP, items+1); /* @_ could have been extended. */
2484 Copy(AvARRAY(av), SP + 1, items, SV*);
2488 if (CxTYPE(cx) == CXt_SUB &&
2489 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2490 SvREFCNT_dec(cx->blk_sub.cv);
2491 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2492 LEAVE_SCOPE(oldsave);
2494 /* Now do some callish stuff. */
2496 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2498 OP* const retop = cx->blk_sub.retop;
2503 for (index=0; index<items; index++)
2504 sv_2mortal(SP[-index]);
2507 /* XS subs don't have a CxSUB, so pop it */
2508 POPBLOCK(cx, PL_curpm);
2509 /* Push a mark for the start of arglist */
2512 (void)(*CvXSUB(cv))(aTHX_ cv);
2517 AV* const padlist = CvPADLIST(cv);
2518 if (CxTYPE(cx) == CXt_EVAL) {
2519 PL_in_eval = CxOLD_IN_EVAL(cx);
2520 PL_eval_root = cx->blk_eval.old_eval_root;
2521 cx->cx_type = CXt_SUB;
2523 cx->blk_sub.cv = cv;
2524 cx->blk_sub.olddepth = CvDEPTH(cv);
2527 if (CvDEPTH(cv) < 2)
2528 SvREFCNT_inc_simple_void_NN(cv);
2530 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2531 sub_crush_depth(cv);
2532 pad_push(padlist, CvDEPTH(cv));
2535 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2538 AV *const av = MUTABLE_AV(PAD_SVl(0));
2540 cx->blk_sub.savearray = GvAV(PL_defgv);
2541 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2542 CX_CURPAD_SAVE(cx->blk_sub);
2543 cx->blk_sub.argarray = av;
2545 if (items >= AvMAX(av) + 1) {
2546 SV **ary = AvALLOC(av);
2547 if (AvARRAY(av) != ary) {
2548 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2551 if (items >= AvMAX(av) + 1) {
2552 AvMAX(av) = items - 1;
2553 Renew(ary,items+1,SV*);
2559 Copy(mark,AvARRAY(av),items,SV*);
2560 AvFILLp(av) = items - 1;
2561 assert(!AvREAL(av));
2563 /* transfer 'ownership' of refcnts to new @_ */
2573 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2574 Perl_get_db_sub(aTHX_ NULL, cv);
2576 CV * const gotocv = get_cv("DB::goto", FALSE);
2578 PUSHMARK( PL_stack_sp );
2579 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2584 RETURNOP(CvSTART(cv));
2588 label = SvPV_nolen_const(sv);
2589 if (!(do_dump || *label))
2590 DIE(aTHX_ must_have_label);
2593 else if (PL_op->op_flags & OPf_SPECIAL) {
2595 DIE(aTHX_ must_have_label);
2598 label = cPVOP->op_pv;
2600 if (label && *label) {
2601 OP *gotoprobe = NULL;
2602 bool leaving_eval = FALSE;
2603 bool in_block = FALSE;
2604 PERL_CONTEXT *last_eval_cx = NULL;
2608 PL_lastgotoprobe = NULL;
2610 for (ix = cxstack_ix; ix >= 0; ix--) {
2612 switch (CxTYPE(cx)) {
2614 leaving_eval = TRUE;
2615 if (!CxTRYBLOCK(cx)) {
2616 gotoprobe = (last_eval_cx ?
2617 last_eval_cx->blk_eval.old_eval_root :
2622 /* else fall through */
2623 case CXt_LOOP_LAZYIV:
2624 case CXt_LOOP_LAZYSV:
2626 case CXt_LOOP_PLAIN:
2627 gotoprobe = cx->blk_oldcop->op_sibling;
2633 gotoprobe = cx->blk_oldcop->op_sibling;
2636 gotoprobe = PL_main_root;
2639 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2640 gotoprobe = CvROOT(cx->blk_sub.cv);
2646 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2649 DIE(aTHX_ "panic: goto");
2650 gotoprobe = PL_main_root;
2654 retop = dofindlabel(gotoprobe, label,
2655 enterops, enterops + GOTO_DEPTH);
2659 PL_lastgotoprobe = gotoprobe;
2662 DIE(aTHX_ "Can't find label %s", label);
2664 /* if we're leaving an eval, check before we pop any frames
2665 that we're not going to punt, otherwise the error
2668 if (leaving_eval && *enterops && enterops[1]) {
2670 for (i = 1; enterops[i]; i++)
2671 if (enterops[i]->op_type == OP_ENTERITER)
2672 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2675 /* pop unwanted frames */
2677 if (ix < cxstack_ix) {
2684 oldsave = PL_scopestack[PL_scopestack_ix];
2685 LEAVE_SCOPE(oldsave);
2688 /* push wanted frames */
2690 if (*enterops && enterops[1]) {
2691 OP * const oldop = PL_op;
2692 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2693 for (; enterops[ix]; ix++) {
2694 PL_op = enterops[ix];
2695 /* Eventually we may want to stack the needed arguments
2696 * for each op. For now, we punt on the hard ones. */
2697 if (PL_op->op_type == OP_ENTERITER)
2698 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2699 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2707 if (!retop) retop = PL_main_start;
2709 PL_restartop = retop;
2710 PL_do_undump = TRUE;
2714 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2715 PL_do_undump = FALSE;
2732 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2734 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2737 PL_exit_flags |= PERL_EXIT_EXPECTED;
2739 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2740 if (anum || !(PL_minus_c && PL_madskills))
2745 PUSHs(&PL_sv_undef);
2752 S_save_lines(pTHX_ AV *array, SV *sv)
2754 const char *s = SvPVX_const(sv);
2755 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2758 PERL_ARGS_ASSERT_SAVE_LINES;
2760 while (s && s < send) {
2762 SV * const tmpstr = newSV_type(SVt_PVMG);
2764 t = strchr(s, '\n');
2770 sv_setpvn(tmpstr, s, t - s);
2771 av_store(array, line++, tmpstr);
2777 S_docatch(pTHX_ OP *o)
2781 OP * const oldop = PL_op;
2785 assert(CATCH_GET == TRUE);
2792 assert(cxstack_ix >= 0);
2793 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2794 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2799 /* die caught by an inner eval - continue inner loop */
2801 /* NB XXX we rely on the old popped CxEVAL still being at the top
2802 * of the stack; the way die_where() currently works, this
2803 * assumption is valid. In theory The cur_top_env value should be
2804 * returned in another global, the way retop (aka PL_restartop)
2806 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2809 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2811 PL_op = PL_restartop;
2828 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2829 /* sv Text to convert to OP tree. */
2830 /* startop op_free() this to undo. */
2831 /* code Short string id of the caller. */
2833 /* FIXME - how much of this code is common with pp_entereval? */
2834 dVAR; dSP; /* Make POPBLOCK work. */
2840 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2841 char *tmpbuf = tbuf;
2844 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2847 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2850 lex_start(sv, NULL, FALSE);
2852 /* switch to eval mode */
2854 if (IN_PERL_COMPILETIME) {
2855 SAVECOPSTASH_FREE(&PL_compiling);
2856 CopSTASH_set(&PL_compiling, PL_curstash);
2858 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2859 SV * const sv = sv_newmortal();
2860 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2861 code, (unsigned long)++PL_evalseq,
2862 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2867 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2868 (unsigned long)++PL_evalseq);
2869 SAVECOPFILE_FREE(&PL_compiling);
2870 CopFILE_set(&PL_compiling, tmpbuf+2);
2871 SAVECOPLINE(&PL_compiling);
2872 CopLINE_set(&PL_compiling, 1);
2873 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2874 deleting the eval's FILEGV from the stash before gv_check() runs
2875 (i.e. before run-time proper). To work around the coredump that
2876 ensues, we always turn GvMULTI_on for any globals that were
2877 introduced within evals. See force_ident(). GSAR 96-10-12 */
2878 safestr = savepvn(tmpbuf, len);
2879 SAVEDELETE(PL_defstash, safestr, len);
2881 #ifdef OP_IN_REGISTER
2887 /* we get here either during compilation, or via pp_regcomp at runtime */
2888 runtime = IN_PERL_RUNTIME;
2890 runcv = find_runcv(NULL);
2893 PL_op->op_type = OP_ENTEREVAL;
2894 PL_op->op_flags = 0; /* Avoid uninit warning. */
2895 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2899 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2901 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2902 POPBLOCK(cx,PL_curpm);
2905 (*startop)->op_type = OP_NULL;
2906 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2908 /* XXX DAPM do this properly one year */
2909 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2911 if (IN_PERL_COMPILETIME)
2912 CopHINTS_set(&PL_compiling, PL_hints);
2913 #ifdef OP_IN_REGISTER
2916 PERL_UNUSED_VAR(newsp);
2917 PERL_UNUSED_VAR(optype);
2919 return PL_eval_start;
2924 =for apidoc find_runcv
2926 Locate the CV corresponding to the currently executing sub or eval.
2927 If db_seqp is non_null, skip CVs that are in the DB package and populate
2928 *db_seqp with the cop sequence number at the point that the DB:: code was
2929 entered. (allows debuggers to eval in the scope of the breakpoint rather
2930 than in the scope of the debugger itself).
2936 Perl_find_runcv(pTHX_ U32 *db_seqp)
2942 *db_seqp = PL_curcop->cop_seq;
2943 for (si = PL_curstackinfo; si; si = si->si_prev) {
2945 for (ix = si->si_cxix; ix >= 0; ix--) {
2946 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2947 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2948 CV * const cv = cx->blk_sub.cv;
2949 /* skip DB:: code */
2950 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2951 *db_seqp = cx->blk_oldcop->cop_seq;
2956 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2964 /* Compile a require/do, an eval '', or a /(?{...})/.
2965 * In the last case, startop is non-null, and contains the address of
2966 * a pointer that should be set to the just-compiled code.
2967 * outside is the lexically enclosing CV (if any) that invoked us.
2968 * Returns a bool indicating whether the compile was successful; if so,
2969 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2970 * pushes undef (also croaks if startop != NULL).
2974 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2977 OP * const saveop = PL_op;
2979 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2980 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2985 SAVESPTR(PL_compcv);
2986 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2987 CvEVAL_on(PL_compcv);
2988 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2989 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2991 CvOUTSIDE_SEQ(PL_compcv) = seq;
2992 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2994 /* set up a scratch pad */
2996 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2997 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3001 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3003 /* make sure we compile in the right package */
3005 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3006 SAVESPTR(PL_curstash);
3007 PL_curstash = CopSTASH(PL_curcop);
3009 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3010 SAVESPTR(PL_beginav);
3011 PL_beginav = newAV();
3012 SAVEFREESV(PL_beginav);
3013 SAVESPTR(PL_unitcheckav);
3014 PL_unitcheckav = newAV();
3015 SAVEFREESV(PL_unitcheckav);
3018 SAVEBOOL(PL_madskills);
3022 /* try to compile it */
3024 PL_eval_root = NULL;
3025 PL_curcop = &PL_compiling;
3026 CopARYBASE_set(PL_curcop, 0);
3027 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3028 PL_in_eval |= EVAL_KEEPERR;
3031 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
3032 SV **newsp; /* Used by POPBLOCK. */
3033 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
3034 I32 optype = 0; /* Might be reset by POPEVAL. */
3039 op_free(PL_eval_root);
3040 PL_eval_root = NULL;
3042 SP = PL_stack_base + POPMARK; /* pop original mark */
3044 POPBLOCK(cx,PL_curpm);
3050 msg = SvPVx_nolen_const(ERRSV);
3051 if (optype == OP_REQUIRE) {
3052 const SV * const nsv = cx->blk_eval.old_namesv;
3053 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3055 Perl_croak(aTHX_ "%sCompilation failed in require",
3056 *msg ? msg : "Unknown error\n");
3059 POPBLOCK(cx,PL_curpm);
3061 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3062 (*msg ? msg : "Unknown error\n"));
3066 sv_setpvs(ERRSV, "Compilation error");
3069 PERL_UNUSED_VAR(newsp);
3070 PUSHs(&PL_sv_undef);
3074 CopLINE_set(&PL_compiling, 0);
3076 *startop = PL_eval_root;
3078 SAVEFREEOP(PL_eval_root);
3080 /* Set the context for this new optree.
3081 * If the last op is an OP_REQUIRE, force scalar context.
3082 * Otherwise, propagate the context from the eval(). */
3083 if (PL_eval_root->op_type == OP_LEAVEEVAL
3084 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3085 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3087 scalar(PL_eval_root);
3088 else if ((gimme & G_WANT) == G_VOID)
3089 scalarvoid(PL_eval_root);
3090 else if ((gimme & G_WANT) == G_ARRAY)
3093 scalar(PL_eval_root);
3095 DEBUG_x(dump_eval());
3097 /* Register with debugger: */
3098 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3099 CV * const cv = get_cv("DB::postponed", FALSE);
3103 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3105 call_sv(MUTABLE_SV(cv), G_DISCARD);
3110 call_list(PL_scopestack_ix, PL_unitcheckav);
3112 /* compiled okay, so do it */
3114 CvDEPTH(PL_compcv) = 1;
3115 SP = PL_stack_base + POPMARK; /* pop original mark */
3116 PL_op = saveop; /* The caller may need it. */
3117 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3124 S_check_type_and_open(pTHX_ const char *name)
3127 const int st_rc = PerlLIO_stat(name, &st);
3129 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3131 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3135 return PerlIO_open(name, PERL_SCRIPT_MODE);
3138 #ifndef PERL_DISABLE_PMC
3140 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3144 PERL_ARGS_ASSERT_DOOPEN_PM;
3146 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3147 SV *const pmcsv = newSV(namelen + 2);
3148 char *const pmc = SvPVX(pmcsv);
3151 memcpy(pmc, name, namelen);
3153 pmc[namelen + 1] = '\0';
3155 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3156 fp = check_type_and_open(name);
3159 fp = check_type_and_open(pmc);
3161 SvREFCNT_dec(pmcsv);
3164 fp = check_type_and_open(name);
3169 # define doopen_pm(name, namelen) check_type_and_open(name)
3170 #endif /* !PERL_DISABLE_PMC */
3175 register PERL_CONTEXT *cx;
3182 int vms_unixname = 0;
3184 const char *tryname = NULL;
3186 const I32 gimme = GIMME_V;
3187 int filter_has_file = 0;
3188 PerlIO *tryrsfp = NULL;
3189 SV *filter_cache = NULL;
3190 SV *filter_state = NULL;
3191 SV *filter_sub = NULL;
3197 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3198 sv = new_version(sv);
3199 if (!sv_derived_from(PL_patchlevel, "version"))
3200 upg_version(PL_patchlevel, TRUE);
3201 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3202 if ( vcmp(sv,PL_patchlevel) <= 0 )
3203 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3204 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3207 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3210 SV * const req = SvRV(sv);
3211 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3213 /* get the left hand term */
3214 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3216 first = SvIV(*av_fetch(lav,0,0));
3217 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3218 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3219 || av_len(lav) > 1 /* FP with > 3 digits */
3220 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3222 DIE(aTHX_ "Perl %"SVf" required--this is only "
3223 "%"SVf", stopped", SVfARG(vnormal(req)),
3224 SVfARG(vnormal(PL_patchlevel)));
3226 else { /* probably 'use 5.10' or 'use 5.8' */
3227 SV * hintsv = newSV(0);
3231 second = SvIV(*av_fetch(lav,1,0));
3233 second /= second >= 600 ? 100 : 10;
3234 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3235 (int)first, (int)second,0);
3236 upg_version(hintsv, TRUE);
3238 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3239 "--this is only %"SVf", stopped",
3240 SVfARG(vnormal(req)),
3241 SVfARG(vnormal(hintsv)),
3242 SVfARG(vnormal(PL_patchlevel)));
3247 /* We do this only with use, not require. */
3249 /* If we request a version >= 5.9.5, load feature.pm with the
3250 * feature bundle that corresponds to the required version. */
3251 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3252 SV *const importsv = vnormal(sv);
3253 *SvPVX_mutable(importsv) = ':';
3255 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3261 name = SvPV_const(sv, len);
3262 if (!(name && len > 0 && *name))
3263 DIE(aTHX_ "Null filename used");
3264 TAINT_PROPER("require");
3268 /* The key in the %ENV hash is in the syntax of file passed as the argument
3269 * usually this is in UNIX format, but sometimes in VMS format, which
3270 * can result in a module being pulled in more than once.
3271 * To prevent this, the key must be stored in UNIX format if the VMS
3272 * name can be translated to UNIX.
3274 if ((unixname = tounixspec(name, NULL)) != NULL) {
3275 unixlen = strlen(unixname);
3281 /* if not VMS or VMS name can not be translated to UNIX, pass it
3284 unixname = (char *) name;
3287 if (PL_op->op_type == OP_REQUIRE) {
3288 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3289 unixname, unixlen, 0);
3291 if (*svp != &PL_sv_undef)
3294 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3295 "Compilation failed in require", unixname);
3299 /* prepare to compile file */
3301 if (path_is_absolute(name)) {
3303 tryrsfp = doopen_pm(name, len);
3305 #ifdef MACOS_TRADITIONAL
3309 MacPerl_CanonDir(name, newname, 1);
3310 if (path_is_absolute(newname)) {
3312 tryrsfp = doopen_pm(newname, strlen(newname));
3317 AV * const ar = GvAVn(PL_incgv);
3323 namesv = newSV_type(SVt_PV);
3324 for (i = 0; i <= AvFILL(ar); i++) {
3325 SV * const dirsv = *av_fetch(ar, i, TRUE);
3327 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3334 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3335 && !sv_isobject(loader))
3337 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3340 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3341 PTR2UV(SvRV(dirsv)), name);
3342 tryname = SvPVX_const(namesv);
3353 if (sv_isobject(loader))
3354 count = call_method("INC", G_ARRAY);
3356 count = call_sv(loader, G_ARRAY);
3359 /* Adjust file name if the hook has set an %INC entry */
3360 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3362 tryname = SvPVX_const(*svp);
3371 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3372 && !isGV_with_GP(SvRV(arg))) {
3373 filter_cache = SvRV(arg);
3374 SvREFCNT_inc_simple_void_NN(filter_cache);
3381 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3385 if (isGV_with_GP(arg)) {
3386 IO * const io = GvIO((GV *)arg);
3391 tryrsfp = IoIFP(io);
3392 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3393 PerlIO_close(IoOFP(io));
3404 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3406 SvREFCNT_inc_simple_void_NN(filter_sub);
3409 filter_state = SP[i];
3410 SvREFCNT_inc_simple_void(filter_state);
3414 if (!tryrsfp && (filter_cache || filter_sub)) {
3415 tryrsfp = PerlIO_open(BIT_BUCKET,
3430 filter_has_file = 0;
3432 SvREFCNT_dec(filter_cache);
3433 filter_cache = NULL;
3436 SvREFCNT_dec(filter_state);
3437 filter_state = NULL;
3440 SvREFCNT_dec(filter_sub);
3445 if (!path_is_absolute(name)
3446 #ifdef MACOS_TRADITIONAL
3447 /* We consider paths of the form :a:b ambiguous and interpret them first
3448 as global then as local
3450 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3457 dir = SvPV_const(dirsv, dirlen);
3463 #ifdef MACOS_TRADITIONAL
3467 MacPerl_CanonDir(name, buf2, 1);
3468 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3472 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3474 sv_setpv(namesv, unixdir);
3475 sv_catpv(namesv, unixname);
3477 # ifdef __SYMBIAN32__
3478 if (PL_origfilename[0] &&
3479 PL_origfilename[1] == ':' &&
3480 !(dir[0] && dir[1] == ':'))
3481 Perl_sv_setpvf(aTHX_ namesv,
3486 Perl_sv_setpvf(aTHX_ namesv,
3490 /* The equivalent of
3491 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3492 but without the need to parse the format string, or
3493 call strlen on either pointer, and with the correct
3494 allocation up front. */
3496 char *tmp = SvGROW(namesv, dirlen + len + 2);
3498 memcpy(tmp, dir, dirlen);
3501 /* name came from an SV, so it will have a '\0' at the
3502 end that we can copy as part of this memcpy(). */
3503 memcpy(tmp, name, len + 1);
3505 SvCUR_set(namesv, dirlen + len + 1);
3507 /* Don't even actually have to turn SvPOK_on() as we
3508 access it directly with SvPVX() below. */
3513 TAINT_PROPER("require");
3514 tryname = SvPVX_const(namesv);
3515 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3517 if (tryname[0] == '.' && tryname[1] == '/')
3521 else if (errno == EMFILE)
3522 /* no point in trying other paths if out of handles */
3529 SAVECOPFILE_FREE(&PL_compiling);
3530 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3531 SvREFCNT_dec(namesv);
3533 if (PL_op->op_type == OP_REQUIRE) {
3534 const char *msgstr = name;
3535 if(errno == EMFILE) {
3537 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3539 msgstr = SvPV_nolen_const(msg);
3541 if (namesv) { /* did we lookup @INC? */
3542 AV * const ar = GvAVn(PL_incgv);
3544 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3545 "%s in @INC%s%s (@INC contains:",
3547 (instr(msgstr, ".h ")
3548 ? " (change .h to .ph maybe?)" : ""),
3549 (instr(msgstr, ".ph ")
3550 ? " (did you run h2ph?)" : "")
3553 for (i = 0; i <= AvFILL(ar); i++) {
3554 sv_catpvs(msg, " ");
3555 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3557 sv_catpvs(msg, ")");
3558 msgstr = SvPV_nolen_const(msg);
3561 DIE(aTHX_ "Can't locate %s", msgstr);
3567 SETERRNO(0, SS_NORMAL);
3569 /* Assume success here to prevent recursive requirement. */
3570 /* name is never assigned to again, so len is still strlen(name) */
3571 /* Check whether a hook in @INC has already filled %INC */
3573 (void)hv_store(GvHVn(PL_incgv),
3574 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3576 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3578 (void)hv_store(GvHVn(PL_incgv),
3579 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3584 lex_start(NULL, tryrsfp, TRUE);
3588 if (PL_compiling.cop_hints_hash) {
3589 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3590 PL_compiling.cop_hints_hash = NULL;
3593 SAVECOMPILEWARNINGS();
3594 if (PL_dowarn & G_WARN_ALL_ON)
3595 PL_compiling.cop_warnings = pWARN_ALL ;
3596 else if (PL_dowarn & G_WARN_ALL_OFF)
3597 PL_compiling.cop_warnings = pWARN_NONE ;
3599 PL_compiling.cop_warnings = pWARN_STD ;
3601 if (filter_sub || filter_cache) {
3602 SV * const datasv = filter_add(S_run_user_filter, NULL);
3603 IoLINES(datasv) = filter_has_file;
3604 IoTOP_GV(datasv) = (GV *)filter_state;
3605 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3606 IoFMT_GV(datasv) = (GV *)filter_cache;
3609 /* switch to eval mode */
3610 PUSHBLOCK(cx, CXt_EVAL, SP);
3612 cx->blk_eval.retop = PL_op->op_next;
3614 SAVECOPLINE(&PL_compiling);
3615 CopLINE_set(&PL_compiling, 0);
3619 /* Store and reset encoding. */
3620 encoding = PL_encoding;
3623 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3624 op = DOCATCH(PL_eval_start);
3626 op = PL_op->op_next;
3628 /* Restore encoding. */
3629 PL_encoding = encoding;
3634 /* This is a op added to hold the hints hash for
3635 pp_entereval. The hash can be modified by the code
3636 being eval'ed, so we return a copy instead. */
3642 mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3650 register PERL_CONTEXT *cx;
3652 const I32 gimme = GIMME_V;
3653 const I32 was = PL_sub_generation;
3654 char tbuf[TYPE_DIGITS(long) + 12];
3655 char *tmpbuf = tbuf;
3661 HV *saved_hh = NULL;
3662 const char * const fakestr = "_<(eval )";
3663 const int fakelen = 9 + 1;
3665 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3666 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3670 TAINT_IF(SvTAINTED(sv));
3671 TAINT_PROPER("eval");
3674 lex_start(sv, NULL, FALSE);
3677 /* switch to eval mode */
3679 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3680 SV * const temp_sv = sv_newmortal();
3681 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3682 (unsigned long)++PL_evalseq,
3683 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3684 tmpbuf = SvPVX(temp_sv);
3685 len = SvCUR(temp_sv);
3688 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3689 SAVECOPFILE_FREE(&PL_compiling);
3690 CopFILE_set(&PL_compiling, tmpbuf+2);
3691 SAVECOPLINE(&PL_compiling);
3692 CopLINE_set(&PL_compiling, 1);
3693 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3694 deleting the eval's FILEGV from the stash before gv_check() runs
3695 (i.e. before run-time proper). To work around the coredump that
3696 ensues, we always turn GvMULTI_on for any globals that were
3697 introduced within evals. See force_ident(). GSAR 96-10-12 */
3698 safestr = savepvn(tmpbuf, len);
3699 SAVEDELETE(PL_defstash, safestr, len);
3701 PL_hints = PL_op->op_targ;
3703 GvHV(PL_hintgv) = saved_hh;
3704 SAVECOMPILEWARNINGS();
3705 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3706 if (PL_compiling.cop_hints_hash) {
3707 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3709 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3710 if (PL_compiling.cop_hints_hash) {
3712 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3713 HINTS_REFCNT_UNLOCK;
3715 /* special case: an eval '' executed within the DB package gets lexically
3716 * placed in the first non-DB CV rather than the current CV - this
3717 * allows the debugger to execute code, find lexicals etc, in the
3718 * scope of the code being debugged. Passing &seq gets find_runcv
3719 * to do the dirty work for us */
3720 runcv = find_runcv(&seq);
3722 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3724 cx->blk_eval.retop = PL_op->op_next;
3726 /* prepare to compile string */
3728 if (PERLDB_LINE && PL_curstash != PL_debstash)
3729 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3731 ok = doeval(gimme, NULL, runcv, seq);
3732 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3734 /* Copy in anything fake and short. */
3735 my_strlcpy(safestr, fakestr, fakelen);
3737 return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3747 register PERL_CONTEXT *cx;
3749 const U8 save_flags = PL_op -> op_flags;
3754 retop = cx->blk_eval.retop;
3757 if (gimme == G_VOID)
3759 else if (gimme == G_SCALAR) {
3762 if (SvFLAGS(TOPs) & SVs_TEMP)
3765 *MARK = sv_mortalcopy(TOPs);
3769 *MARK = &PL_sv_undef;
3774 /* in case LEAVE wipes old return values */
3775 for (mark = newsp + 1; mark <= SP; mark++) {
3776 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3777 *mark = sv_mortalcopy(*mark);
3778 TAINT_NOT; /* Each item is independent */
3782 PL_curpm = newpm; /* Don't pop $1 et al till now */
3785 assert(CvDEPTH(PL_compcv) == 1);
3787 CvDEPTH(PL_compcv) = 0;
3790 if (optype == OP_REQUIRE &&
3791 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3793 /* Unassume the success we assumed earlier. */
3794 SV * const nsv = cx->blk_eval.old_namesv;
3795 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3796 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3797 /* die_where() did LEAVE, or we won't be here */
3801 if (!(save_flags & OPf_SPECIAL)) {
3809 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3810 close to the related Perl_create_eval_scope. */
3812 Perl_delete_eval_scope(pTHX)
3817 register PERL_CONTEXT *cx;
3824 PERL_UNUSED_VAR(newsp);
3825 PERL_UNUSED_VAR(gimme);
3826 PERL_UNUSED_VAR(optype);
3829 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3830 also needed by Perl_fold_constants. */
3832 Perl_create_eval_scope(pTHX_ U32 flags)
3835 const I32 gimme = GIMME_V;
3840 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3843 PL_in_eval = EVAL_INEVAL;
3844 if (flags & G_KEEPERR)
3845 PL_in_eval |= EVAL_KEEPERR;
3848 if (flags & G_FAKINGEVAL) {
3849 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3857 PERL_CONTEXT * const cx = create_eval_scope(0);
3858 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3859 return DOCATCH(PL_op->op_next);
3868 register PERL_CONTEXT *cx;
3873 PERL_UNUSED_VAR(optype);
3876 if (gimme == G_VOID)
3878 else if (gimme == G_SCALAR) {
3882 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3885 *MARK = sv_mortalcopy(TOPs);
3889 *MARK = &PL_sv_undef;
3894 /* in case LEAVE wipes old return values */
3896 for (mark = newsp + 1; mark <= SP; mark++) {
3897 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3898 *mark = sv_mortalcopy(*mark);
3899 TAINT_NOT; /* Each item is independent */
3903 PL_curpm = newpm; /* Don't pop $1 et al till now */
3913 register PERL_CONTEXT *cx;
3914 const I32 gimme = GIMME_V;
3919 if (PL_op->op_targ == 0) {
3920 SV ** const defsv_p = &GvSV(PL_defgv);
3921 *defsv_p = newSVsv(POPs);
3922 SAVECLEARSV(*defsv_p);
3925 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3927 PUSHBLOCK(cx, CXt_GIVEN, SP);
3936 register PERL_CONTEXT *cx;
3940 PERL_UNUSED_CONTEXT;
3943 assert(CxTYPE(cx) == CXt_GIVEN);
3948 PL_curpm = newpm; /* pop $1 et al */
3955 /* Helper routines used by pp_smartmatch */
3957 S_make_matcher(pTHX_ REGEXP *re)
3960 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3962 PERL_ARGS_ASSERT_MAKE_MATCHER;
3964 PM_SETRE(matcher, ReREFCNT_inc(re));
3966 SAVEFREEOP((OP *) matcher);
3973 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3978 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
3980 PL_op = (OP *) matcher;
3985 return (SvTRUEx(POPs));
3989 S_destroy_matcher(pTHX_ PMOP *matcher)
3993 PERL_ARGS_ASSERT_DESTROY_MATCHER;
3994 PERL_UNUSED_ARG(matcher);
4000 /* Do a smart match */
4003 return do_smartmatch(NULL, NULL);
4006 /* This version of do_smartmatch() implements the
4007 * table of smart matches that is found in perlsyn.
4010 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4015 SV *e = TOPs; /* e is for 'expression' */
4016 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4017 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
4018 REGEXP *this_regex, *other_regex;
4020 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
4022 # define SM_REF(type) ( \
4023 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
4024 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
4026 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
4027 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
4028 && NOT_EMPTY_PROTO(This) && (Other = e)) \
4029 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
4030 && NOT_EMPTY_PROTO(This) && (Other = d)))
4032 # define SM_REGEX ( \
4033 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \
4034 && (this_regex = (REGEXP*) This) \
4037 (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \
4038 && (this_regex = (REGEXP*) This) \
4042 # define SM_OBJECT ( \
4043 (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) \
4045 (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) ) \
4047 # define SM_OTHER_REF(type) \
4048 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
4050 # define SM_OTHER_REGEX (SvROK(Other) \
4051 && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \
4052 && (other_regex = (REGEXP*) SvRV(Other)))
4055 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
4056 sv_2mortal(newSViv(PTR2IV(sv))), 0)
4058 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
4059 sv_2mortal(newSViv(PTR2IV(sv))), 0)
4061 tryAMAGICbinSET(smart, 0);
4063 SP -= 2; /* Pop the values */
4065 /* Take care only to invoke mg_get() once for each argument.
4066 * Currently we do this by copying the SV if it's magical. */
4069 d = sv_mortalcopy(d);
4076 e = sv_mortalcopy(e);
4079 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4084 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
4086 if (This == SvRV(Other))
4097 c = call_sv(This, G_SCALAR);
4101 else if (SvTEMP(TOPs))
4102 SvREFCNT_inc_void(TOPs);
4107 else if (SM_REF(PVHV)) {
4108 if (SM_OTHER_REF(PVHV)) {
4109 /* Check that the key-sets are identical */
4111 HV *other_hv = MUTABLE_HV(SvRV(Other));
4113 bool other_tied = FALSE;
4114 U32 this_key_count = 0,
4115 other_key_count = 0;
4117 /* Tied hashes don't know how many keys they have. */
4118 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
4121 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4122 HV * const temp = other_hv;
4123 other_hv = MUTABLE_HV(This);
4124 This = MUTABLE_SV(temp);
4127 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4130 if (!tied && HvUSEDKEYS((const HV *) This) != HvUSEDKEYS(other_hv))
4133 /* The hashes have the same number of keys, so it suffices
4134 to check that one is a subset of the other. */
4135 (void) hv_iterinit(MUTABLE_HV(This));
4136 while ( (he = hv_iternext(MUTABLE_HV(This))) ) {
4138 char * const key = hv_iterkey(he, &key_len);
4142 if(!hv_exists(other_hv, key, key_len)) {
4143 (void) hv_iterinit(MUTABLE_HV(This)); /* reset iterator */
4149 (void) hv_iterinit(other_hv);
4150 while ( hv_iternext(other_hv) )
4154 other_key_count = HvUSEDKEYS(other_hv);
4156 if (this_key_count != other_key_count)
4161 else if (SM_OTHER_REF(PVAV)) {
4162 AV * const other_av = MUTABLE_AV(SvRV(Other));
4163 const I32 other_len = av_len(other_av) + 1;
4166 for (i = 0; i < other_len; ++i) {
4167 SV ** const svp = av_fetch(other_av, i, FALSE);
4171 if (svp) { /* ??? When can this not happen? */
4172 key = SvPV(*svp, key_len);
4173 if (hv_exists(MUTABLE_HV(This), key, key_len))
4179 else if (SM_OTHER_REGEX) {
4180 PMOP * const matcher = make_matcher(other_regex);
4183 (void) hv_iterinit(MUTABLE_HV(This));
4184 while ( (he = hv_iternext(MUTABLE_HV(This))) ) {
4185 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4186 (void) hv_iterinit(MUTABLE_HV(This));
4187 destroy_matcher(matcher);
4191 destroy_matcher(matcher);
4195 if (hv_exists_ent(MUTABLE_HV(This), Other, 0))
4201 else if (SM_REF(PVAV)) {
4202 if (SM_OTHER_REF(PVAV)) {
4203 AV *other_av = MUTABLE_AV(SvRV(Other));
4204 if (av_len(MUTABLE_AV(This)) != av_len(other_av))
4208 const I32 other_len = av_len(other_av);
4210 if (NULL == seen_this) {
4211 seen_this = newHV();
4212 (void) sv_2mortal(MUTABLE_SV(seen_this));
4214 if (NULL == seen_other) {
4215 seen_this = newHV();
4216 (void) sv_2mortal(MUTABLE_SV(seen_other));
4218 for(i = 0; i <= other_len; ++i) {
4219 SV * const * const this_elem = av_fetch(MUTABLE_AV(This), i, FALSE);
4220 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4222 if (!this_elem || !other_elem) {
4223 if (this_elem || other_elem)
4226 else if (SM_SEEN_THIS(*this_elem)
4227 || SM_SEEN_OTHER(*other_elem))
4229 if (*this_elem != *other_elem)
4233 (void)hv_store_ent(seen_this,
4234 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4236 (void)hv_store_ent(seen_other,
4237 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4243 (void) do_smartmatch(seen_this, seen_other);
4253 else if (SM_OTHER_REGEX) {
4254 PMOP * const matcher = make_matcher(other_regex);
4255 const I32 this_len = av_len(MUTABLE_AV(This));
4258 for(i = 0; i <= this_len; ++i) {
4259 SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
4260 if (svp && matcher_matches_sv(matcher, *svp)) {
4261 destroy_matcher(matcher);
4265 destroy_matcher(matcher);
4268 else if (SvIOK(Other) || SvNOK(Other)) {
4271 for(i = 0; i <= AvFILL(MUTABLE_AV(This)); ++i) {
4272 SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
4279 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4289 else if (SvPOK(Other)) {
4290 const I32 this_len = av_len(MUTABLE_AV(This));
4293 for(i = 0; i <= this_len; ++i) {
4294 SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
4309 else if (!SvOK(d) || !SvOK(e)) {
4310 if (!SvOK(d) && !SvOK(e))
4315 else if (SM_REGEX) {
4316 PMOP * const matcher = make_matcher(this_regex);
4319 PUSHs(matcher_matches_sv(matcher, Other)
4322 destroy_matcher(matcher);
4325 else if (SM_REF(PVCV)) {
4327 /* This must be a null-prototyped sub, because we
4328 already checked for the other kind. */
4334 c = call_sv(This, G_SCALAR);
4337 PUSHs(&PL_sv_undef);
4338 else if (SvTEMP(TOPs))
4339 SvREFCNT_inc_void(TOPs);
4341 if (SM_OTHER_REF(PVCV)) {
4342 /* This one has to be null-proto'd too.
4343 Call both of 'em, and compare the results */
4345 c = call_sv(SvRV(Other), G_SCALAR);
4348 PUSHs(&PL_sv_undef);
4349 else if (SvTEMP(TOPs))
4350 SvREFCNT_inc_void(TOPs);
4361 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4362 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4364 if (SvPOK(Other) && !looks_like_number(Other)) {
4365 /* String comparison */
4370 /* Otherwise, numeric comparison */
4373 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4384 /* As a last resort, use string comparison */
4393 register PERL_CONTEXT *cx;
4394 const I32 gimme = GIMME_V;
4396 /* This is essentially an optimization: if the match
4397 fails, we don't want to push a context and then
4398 pop it again right away, so we skip straight
4399 to the op that follows the leavewhen.
4401 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4402 return cLOGOP->op_other->op_next;
4407 PUSHBLOCK(cx, CXt_WHEN, SP);
4416 register PERL_CONTEXT *cx;
4422 assert(CxTYPE(cx) == CXt_WHEN);
4427 PL_curpm = newpm; /* pop $1 et al */
4437 register PERL_CONTEXT *cx;
4440 cxix = dopoptowhen(cxstack_ix);
4442 DIE(aTHX_ "Can't \"continue\" outside a when block");
4443 if (cxix < cxstack_ix)
4446 /* clear off anything above the scope we're re-entering */
4447 inner = PL_scopestack_ix;
4449 if (PL_scopestack_ix < inner)
4450 leave_scope(PL_scopestack[PL_scopestack_ix]);
4451 PL_curcop = cx->blk_oldcop;
4452 return cx->blk_givwhen.leave_op;
4459 register PERL_CONTEXT *cx;
4462 cxix = dopoptogiven(cxstack_ix);
4464 if (PL_op->op_flags & OPf_SPECIAL)
4465 DIE(aTHX_ "Can't use when() outside a topicalizer");
4467 DIE(aTHX_ "Can't \"break\" outside a given block");
4469 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4470 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4472 if (cxix < cxstack_ix)
4475 /* clear off anything above the scope we're re-entering */
4476 inner = PL_scopestack_ix;
4478 if (PL_scopestack_ix < inner)
4479 leave_scope(PL_scopestack[PL_scopestack_ix]);
4480 PL_curcop = cx->blk_oldcop;
4483 return CX_LOOP_NEXTOP_GET(cx);
4485 return cx->blk_givwhen.leave_op;
4489 S_doparseform(pTHX_ SV *sv)
4492 register char *s = SvPV_force(sv, len);
4493 register char * const send = s + len;
4494 register char *base = NULL;
4495 register I32 skipspaces = 0;
4496 bool noblank = FALSE;
4497 bool repeat = FALSE;
4498 bool postspace = FALSE;
4504 bool unchopnum = FALSE;
4505 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4507 PERL_ARGS_ASSERT_DOPARSEFORM;
4510 Perl_croak(aTHX_ "Null picture in formline");
4512 /* estimate the buffer size needed */
4513 for (base = s; s <= send; s++) {
4514 if (*s == '\n' || *s == '@' || *s == '^')
4520 Newx(fops, maxops, U32);
4525 *fpc++ = FF_LINEMARK;
4526 noblank = repeat = FALSE;
4544 case ' ': case '\t':
4551 } /* else FALL THROUGH */
4559 *fpc++ = FF_LITERAL;
4567 *fpc++ = (U16)skipspaces;
4571 *fpc++ = FF_NEWLINE;
4575 arg = fpc - linepc + 1;
4582 *fpc++ = FF_LINEMARK;
4583 noblank = repeat = FALSE;
4592 ischop = s[-1] == '^';
4598 arg = (s - base) - 1;
4600 *fpc++ = FF_LITERAL;
4608 *fpc++ = 2; /* skip the @* or ^* */
4610 *fpc++ = FF_LINESNGL;
4613 *fpc++ = FF_LINEGLOB;
4615 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4616 arg = ischop ? 512 : 0;
4621 const char * const f = ++s;
4624 arg |= 256 + (s - f);
4626 *fpc++ = s - base; /* fieldsize for FETCH */
4627 *fpc++ = FF_DECIMAL;
4629 unchopnum |= ! ischop;
4631 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4632 arg = ischop ? 512 : 0;
4634 s++; /* skip the '0' first */
4638 const char * const f = ++s;
4641 arg |= 256 + (s - f);
4643 *fpc++ = s - base; /* fieldsize for FETCH */
4644 *fpc++ = FF_0DECIMAL;
4646 unchopnum |= ! ischop;
4650 bool ismore = FALSE;
4653 while (*++s == '>') ;
4654 prespace = FF_SPACE;
4656 else if (*s == '|') {
4657 while (*++s == '|') ;
4658 prespace = FF_HALFSPACE;
4663 while (*++s == '<') ;
4666 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4670 *fpc++ = s - base; /* fieldsize for FETCH */
4672 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4675 *fpc++ = (U16)prespace;
4689 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4691 { /* need to jump to the next word */
4693 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4694 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4695 s = SvPVX(sv) + SvCUR(sv) + z;
4697 Copy(fops, s, arg, U32);
4699 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4702 if (unchopnum && repeat)
4703 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4709 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4711 /* Can value be printed in fldsize chars, using %*.*f ? */
4715 int intsize = fldsize - (value < 0 ? 1 : 0);
4722 while (intsize--) pwr *= 10.0;
4723 while (frcsize--) eps /= 10.0;
4726 if (value + eps >= pwr)
4729 if (value - eps <= -pwr)
4736 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4739 SV * const datasv = FILTER_DATA(idx);
4740 const int filter_has_file = IoLINES(datasv);
4741 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4742 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4746 const char *got_p = NULL;
4747 const char *prune_from = NULL;
4748 bool read_from_cache = FALSE;
4751 PERL_ARGS_ASSERT_RUN_USER_FILTER;
4753 assert(maxlen >= 0);
4756 /* I was having segfault trouble under Linux 2.2.5 after a
4757 parse error occured. (Had to hack around it with a test
4758 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4759 not sure where the trouble is yet. XXX */
4761 if (IoFMT_GV(datasv)) {
4762 SV *const cache = MUTABLE_SV(IoFMT_GV(datasv));
4765 const char *cache_p = SvPV(cache, cache_len);
4769 /* Running in block mode and we have some cached data already.
4771 if (cache_len >= umaxlen) {
4772 /* In fact, so much data we don't even need to call
4777 const char *const first_nl =
4778 (const char *)memchr(cache_p, '\n', cache_len);
4780 take = first_nl + 1 - cache_p;
4784 sv_catpvn(buf_sv, cache_p, take);
4785 sv_chop(cache, cache_p + take);
4786 /* Definately not EOF */
4790 sv_catsv(buf_sv, cache);
4792 umaxlen -= cache_len;
4795 read_from_cache = TRUE;
4799 /* Filter API says that the filter appends to the contents of the buffer.
4800 Usually the buffer is "", so the details don't matter. But if it's not,
4801 then clearly what it contains is already filtered by this filter, so we
4802 don't want to pass it in a second time.
4803 I'm going to use a mortal in case the upstream filter croaks. */
4804 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4805 ? sv_newmortal() : buf_sv;
4806 SvUPGRADE(upstream, SVt_PV);
4808 if (filter_has_file) {
4809 status = FILTER_READ(idx+1, upstream, 0);
4812 if (filter_sub && status >= 0) {
4825 PUSHs(filter_state);
4828 count = call_sv(filter_sub, G_SCALAR);
4843 if(SvOK(upstream)) {
4844 got_p = SvPV(upstream, got_len);
4846 if (got_len > umaxlen) {
4847 prune_from = got_p + umaxlen;
4850 const char *const first_nl =
4851 (const char *)memchr(got_p, '\n', got_len);
4852 if (first_nl && first_nl + 1 < got_p + got_len) {
4853 /* There's a second line here... */
4854 prune_from = first_nl + 1;
4859 /* Oh. Too long. Stuff some in our cache. */
4860 STRLEN cached_len = got_p + got_len - prune_from;
4861 SV *cache = MUTABLE_SV(IoFMT_GV(datasv));
4864 IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4865 } else if (SvOK(cache)) {
4866 /* Cache should be empty. */
4867 assert(!SvCUR(cache));
4870 sv_setpvn(cache, prune_from, cached_len);
4871 /* If you ask for block mode, you may well split UTF-8 characters.
4872 "If it breaks, you get to keep both parts"
4873 (Your code is broken if you don't put them back together again
4874 before something notices.) */
4875 if (SvUTF8(upstream)) {
4878 SvCUR_set(upstream, got_len - cached_len);
4879 /* Can't yet be EOF */
4884 /* If they are at EOF but buf_sv has something in it, then they may never
4885 have touched the SV upstream, so it may be undefined. If we naively
4886 concatenate it then we get a warning about use of uninitialised value.
4888 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4889 sv_catsv(buf_sv, upstream);
4893 IoLINES(datasv) = 0;
4894 SvREFCNT_dec(IoFMT_GV(datasv));
4896 SvREFCNT_dec(filter_state);
4897 IoTOP_GV(datasv) = NULL;
4900 SvREFCNT_dec(filter_sub);
4901 IoBOTTOM_GV(datasv) = NULL;
4903 filter_del(S_run_user_filter);
4905 if (status == 0 && read_from_cache) {
4906 /* If we read some data from the cache (and by getting here it implies
4907 that we emptied the cache) then we aren't yet at EOF, and mustn't
4908 report that to our caller. */
4914 /* perhaps someone can come up with a better name for
4915 this? it is not really "absolute", per se ... */
4917 S_path_is_absolute(const char *name)
4919 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
4921 if (PERL_FILE_IS_ABSOLUTE(name)
4922 #ifdef MACOS_TRADITIONAL
4925 || (*name == '.' && (name[1] == '/' ||
4926 (name[1] == '.' && name[2] == '/')))
4938 * c-indentation-style: bsd
4940 * indent-tabs-mode: t
4943 * ex: set ts=8 sts=4 sw=4 noet: