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.
19 * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains control-oriented pp ("push/pop") functions that
23 * execute the opcodes that make up a perl program. A typical pp function
24 * expects to find its arguments on the stack, and usually pushes its
25 * results onto the stack, hence the 'pp' terminology. Each OP structure
26 * contains a pointer to the relevant pp_foo() function.
28 * Control-oriented means things like pp_enteriter() and pp_next(), which
29 * alter the flow of control of the program.
34 #define PERL_IN_PP_CTL_C
38 #define WORD_ALIGN sizeof(U32)
41 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
43 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
52 cxix = dopoptosub(cxstack_ix);
56 switch (cxstack[cxix].blk_gimme) {
69 /* XXXX Should store the old value to allow for tie/overload - and
70 restore in regcomp, where marked with XXXX. */
80 register PMOP *pm = (PMOP*)cLOGOP->op_other;
84 /* prevent recompiling under /o and ithreads. */
85 #if defined(USE_ITHREADS)
86 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
87 if (PL_op->op_flags & OPf_STACKED) {
96 if (PL_op->op_flags & OPf_STACKED) {
97 /* multiple args; concatentate them */
99 tmpstr = PAD_SV(ARGTARG);
100 sv_setpvs(tmpstr, "");
101 while (++MARK <= SP) {
102 if (PL_amagic_generation) {
104 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
105 (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
107 sv_setsv(tmpstr, sv);
111 sv_catsv(tmpstr, *MARK);
120 SV * const sv = SvRV(tmpstr);
121 if (SvTYPE(sv) == SVt_REGEXP)
125 re = reg_temp_copy(re);
126 ReREFCNT_dec(PM_GETRE(pm));
131 const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
133 assert (re != (REGEXP*) &PL_sv_undef);
135 /* Check against the last compiled regexp. */
136 if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
137 memNE(RX_PRECOMP(re), t, len))
139 const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
140 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
144 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
146 PM_SETRE(pm, NULL); /* crucial if regcomp aborts */
148 } else if (PL_curcop->cop_hints_hash) {
149 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
151 if (ptr && SvIOK(ptr) && SvIV(ptr))
152 eng = INT2PTR(regexp_engine*,SvIV(ptr));
155 if (PL_op->op_flags & OPf_SPECIAL)
156 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
158 if (DO_UTF8(tmpstr)) {
159 assert (SvUTF8(tmpstr));
160 } else if (SvUTF8(tmpstr)) {
161 /* Not doing UTF-8, despite what the SV says. Is this only if
162 we're trapped in use 'bytes'? */
163 /* Make a copy of the octet sequence, but without the flag on,
164 as the compiler now honours the SvUTF8 flag on tmpstr. */
166 const char *const p = SvPV(tmpstr, len);
167 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
171 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
173 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
175 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
176 inside tie/overload accessors. */
182 #ifndef INCOMPLETE_TAINTS
185 RX_EXTFLAGS(re) |= RXf_TAINTED;
187 RX_EXTFLAGS(re) &= ~RXf_TAINTED;
191 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
195 #if !defined(USE_ITHREADS)
196 /* can't change the optree at runtime either */
197 /* PMf_KEEP is handled differently under threads to avoid these problems */
198 if (pm->op_pmflags & PMf_KEEP) {
199 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
200 cLOGOP->op_first->op_next = PL_op->op_next;
210 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
211 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
212 register SV * const dstr = cx->sb_dstr;
213 register char *s = cx->sb_s;
214 register char *m = cx->sb_m;
215 char *orig = cx->sb_orig;
216 register REGEXP * const rx = cx->sb_rx;
218 REGEXP *old = PM_GETRE(pm);
222 PM_SETRE(pm,ReREFCNT_inc(rx));
225 rxres_restore(&cx->sb_rxres, rx);
226 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
228 if (cx->sb_iters++) {
229 const I32 saviters = cx->sb_iters;
230 if (cx->sb_iters > cx->sb_maxiters)
231 DIE(aTHX_ "Substitution loop");
233 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
234 cx->sb_rxtainted |= 2;
235 sv_catsv(dstr, POPs);
238 if (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
239 s == m, cx->sb_targ, NULL,
240 ((cx->sb_rflags & REXEC_COPY_STR)
241 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
242 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
244 SV * const targ = cx->sb_targ;
246 assert(cx->sb_strend >= s);
247 if(cx->sb_strend > s) {
248 if (DO_UTF8(dstr) && !SvUTF8(targ))
249 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
251 sv_catpvn(dstr, s, cx->sb_strend - s);
253 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
255 #ifdef PERL_OLD_COPY_ON_WRITE
257 sv_force_normal_flags(targ, SV_COW_DROP_PV);
263 SvPV_set(targ, SvPVX(dstr));
264 SvCUR_set(targ, SvCUR(dstr));
265 SvLEN_set(targ, SvLEN(dstr));
268 SvPV_set(dstr, NULL);
270 TAINT_IF(cx->sb_rxtainted & 1);
271 mPUSHi(saviters - 1);
273 (void)SvPOK_only_UTF8(targ);
274 TAINT_IF(cx->sb_rxtainted);
278 LEAVE_SCOPE(cx->sb_oldsave);
280 RETURNOP(pm->op_next);
282 cx->sb_iters = saviters;
284 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
287 cx->sb_orig = orig = RX_SUBBEG(rx);
289 cx->sb_strend = s + (cx->sb_strend - m);
291 cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
293 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
294 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
296 sv_catpvn(dstr, s, m-s);
298 cx->sb_s = RX_OFFS(rx)[0].end + orig;
299 { /* Update the pos() information. */
300 SV * const sv = cx->sb_targ;
302 SvUPGRADE(sv, SVt_PVMG);
303 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
304 #ifdef PERL_OLD_COPY_ON_WRITE
306 sv_force_normal_flags(sv, 0);
308 mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
311 mg->mg_len = m - orig;
314 (void)ReREFCNT_inc(rx);
315 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
316 rxres_save(&cx->sb_rxres, rx);
317 RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
321 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
326 PERL_ARGS_ASSERT_RXRES_SAVE;
329 if (!p || p[1] < RX_NPARENS(rx)) {
330 #ifdef PERL_OLD_COPY_ON_WRITE
331 i = 7 + RX_NPARENS(rx) * 2;
333 i = 6 + RX_NPARENS(rx) * 2;
342 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
343 RX_MATCH_COPIED_off(rx);
345 #ifdef PERL_OLD_COPY_ON_WRITE
346 *p++ = PTR2UV(RX_SAVED_COPY(rx));
347 RX_SAVED_COPY(rx) = NULL;
350 *p++ = RX_NPARENS(rx);
352 *p++ = PTR2UV(RX_SUBBEG(rx));
353 *p++ = (UV)RX_SUBLEN(rx);
354 for (i = 0; i <= RX_NPARENS(rx); ++i) {
355 *p++ = (UV)RX_OFFS(rx)[i].start;
356 *p++ = (UV)RX_OFFS(rx)[i].end;
361 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
366 PERL_ARGS_ASSERT_RXRES_RESTORE;
369 RX_MATCH_COPY_FREE(rx);
370 RX_MATCH_COPIED_set(rx, *p);
373 #ifdef PERL_OLD_COPY_ON_WRITE
374 if (RX_SAVED_COPY(rx))
375 SvREFCNT_dec (RX_SAVED_COPY(rx));
376 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
380 RX_NPARENS(rx) = *p++;
382 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
383 RX_SUBLEN(rx) = (I32)(*p++);
384 for (i = 0; i <= RX_NPARENS(rx); ++i) {
385 RX_OFFS(rx)[i].start = (I32)(*p++);
386 RX_OFFS(rx)[i].end = (I32)(*p++);
391 S_rxres_free(pTHX_ void **rsp)
393 UV * const p = (UV*)*rsp;
395 PERL_ARGS_ASSERT_RXRES_FREE;
400 void *tmp = INT2PTR(char*,*p);
403 PoisonFree(*p, 1, sizeof(*p));
405 Safefree(INT2PTR(char*,*p));
407 #ifdef PERL_OLD_COPY_ON_WRITE
409 SvREFCNT_dec (INT2PTR(SV*,p[1]));
419 dVAR; dSP; dMARK; dORIGMARK;
420 register SV * const tmpForm = *++MARK;
425 register SV *sv = NULL;
426 const char *item = NULL;
430 bool chopspace = (strchr(PL_chopset, ' ') != NULL);
431 const char *chophere = NULL;
432 char *linemark = NULL;
434 bool gotsome = FALSE;
436 const STRLEN fudge = SvPOK(tmpForm)
437 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
438 bool item_is_utf8 = FALSE;
439 bool targ_is_utf8 = FALSE;
441 OP * parseres = NULL;
444 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
445 if (SvREADONLY(tmpForm)) {
446 SvREADONLY_off(tmpForm);
447 parseres = doparseform(tmpForm);
448 SvREADONLY_on(tmpForm);
451 parseres = doparseform(tmpForm);
455 SvPV_force(PL_formtarget, len);
456 if (DO_UTF8(PL_formtarget))
458 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
460 f = SvPV_const(tmpForm, len);
461 /* need to jump to the next word */
462 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
466 const char *name = "???";
469 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
470 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
471 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
472 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
473 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
475 case FF_CHECKNL: name = "CHECKNL"; break;
476 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
477 case FF_SPACE: name = "SPACE"; break;
478 case FF_HALFSPACE: name = "HALFSPACE"; break;
479 case FF_ITEM: name = "ITEM"; break;
480 case FF_CHOP: name = "CHOP"; break;
481 case FF_LINEGLOB: name = "LINEGLOB"; break;
482 case FF_NEWLINE: name = "NEWLINE"; break;
483 case FF_MORE: name = "MORE"; break;
484 case FF_LINEMARK: name = "LINEMARK"; break;
485 case FF_END: name = "END"; break;
486 case FF_0DECIMAL: name = "0DECIMAL"; break;
487 case FF_LINESNGL: name = "LINESNGL"; break;
490 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
492 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
503 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
504 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
506 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
507 t = SvEND(PL_formtarget);
511 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
512 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
514 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
515 t = SvEND(PL_formtarget);
535 if (ckWARN(WARN_SYNTAX))
536 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
543 const char *s = item = SvPV_const(sv, len);
546 itemsize = sv_len_utf8(sv);
547 if (itemsize != (I32)len) {
549 if (itemsize > fieldsize) {
550 itemsize = fieldsize;
551 itembytes = itemsize;
552 sv_pos_u2b(sv, &itembytes, 0);
556 send = chophere = s + itembytes;
566 sv_pos_b2u(sv, &itemsize);
570 item_is_utf8 = FALSE;
571 if (itemsize > fieldsize)
572 itemsize = fieldsize;
573 send = chophere = s + itemsize;
587 const char *s = item = SvPV_const(sv, len);
590 itemsize = sv_len_utf8(sv);
591 if (itemsize != (I32)len) {
593 if (itemsize <= fieldsize) {
594 const char *send = chophere = s + itemsize;
607 itemsize = fieldsize;
608 itembytes = itemsize;
609 sv_pos_u2b(sv, &itembytes, 0);
610 send = chophere = s + itembytes;
611 while (s < send || (s == send && isSPACE(*s))) {
621 if (strchr(PL_chopset, *s))
626 itemsize = chophere - item;
627 sv_pos_b2u(sv, &itemsize);
633 item_is_utf8 = FALSE;
634 if (itemsize <= fieldsize) {
635 const char *const send = chophere = s + itemsize;
648 itemsize = fieldsize;
649 send = chophere = s + itemsize;
650 while (s < send || (s == send && isSPACE(*s))) {
660 if (strchr(PL_chopset, *s))
665 itemsize = chophere - item;
671 arg = fieldsize - itemsize;
680 arg = fieldsize - itemsize;
691 const char *s = item;
695 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
697 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
699 t = SvEND(PL_formtarget);
703 if (UTF8_IS_CONTINUED(*s)) {
704 STRLEN skip = UTF8SKIP(s);
721 if ( !((*t++ = *s++) & ~31) )
727 if (targ_is_utf8 && !item_is_utf8) {
728 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
730 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
731 for (; t < SvEND(PL_formtarget); t++) {
744 const int ch = *t++ = *s++;
747 if ( !((*t++ = *s++) & ~31) )
756 const char *s = chophere;
770 const bool oneline = fpc[-1] == FF_LINESNGL;
771 const char *s = item = SvPV_const(sv, len);
772 item_is_utf8 = DO_UTF8(sv);
775 STRLEN to_copy = itemsize;
776 const char *const send = s + len;
777 const U8 *source = (const U8 *) s;
781 chophere = s + itemsize;
785 to_copy = s - SvPVX_const(sv) - 1;
797 if (targ_is_utf8 && !item_is_utf8) {
798 source = tmp = bytes_to_utf8(source, &to_copy);
799 SvCUR_set(PL_formtarget,
800 t - SvPVX_const(PL_formtarget));
802 if (item_is_utf8 && !targ_is_utf8) {
803 /* Upgrade targ to UTF8, and then we reduce it to
804 a problem we have a simple solution for. */
805 SvCUR_set(PL_formtarget,
806 t - SvPVX_const(PL_formtarget));
808 /* Don't need get magic. */
809 sv_utf8_upgrade_nomg(PL_formtarget);
811 SvCUR_set(PL_formtarget,
812 t - SvPVX_const(PL_formtarget));
815 /* Easy. They agree. */
816 assert (item_is_utf8 == targ_is_utf8);
818 SvGROW(PL_formtarget,
819 SvCUR(PL_formtarget) + to_copy + fudge + 1);
820 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
822 Copy(source, t, to_copy, char);
824 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
826 if (SvGMAGICAL(sv)) {
827 /* Mustn't call sv_pos_b2u() as it does a second
828 mg_get(). Is this a bug? Do we need a _flags()
830 itemsize = utf8_length(source, source + itemsize);
832 sv_pos_b2u(sv, &itemsize);
844 #if defined(USE_LONG_DOUBLE)
847 "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
851 "%#0*.*f" : "%0*.*f");
856 #if defined(USE_LONG_DOUBLE)
858 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
861 ((arg & 256) ? "%#*.*f" : "%*.*f");
864 /* If the field is marked with ^ and the value is undefined,
866 if ((arg & 512) && !SvOK(sv)) {
874 /* overflow evidence */
875 if (num_overflow(value, fieldsize, arg)) {
881 /* Formats aren't yet marked for locales, so assume "yes". */
883 STORE_NUMERIC_STANDARD_SET_LOCAL();
884 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
885 RESTORE_NUMERIC_STANDARD();
892 while (t-- > linemark && *t == ' ') ;
900 if (arg) { /* repeat until fields exhausted? */
902 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
903 lines += FmLINES(PL_formtarget);
906 if (strnEQ(linemark, linemark - arg, arg))
907 DIE(aTHX_ "Runaway format");
910 SvUTF8_on(PL_formtarget);
911 FmLINES(PL_formtarget) = lines;
913 RETURNOP(cLISTOP->op_first);
924 const char *s = chophere;
925 const char *send = item + len;
927 while (isSPACE(*s) && (s < send))
932 arg = fieldsize - itemsize;
939 if (strnEQ(s1," ",3)) {
940 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
951 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
953 SvUTF8_on(PL_formtarget);
954 FmLINES(PL_formtarget) += lines;
966 if (PL_stack_base + *PL_markstack_ptr == SP) {
968 if (GIMME_V == G_SCALAR)
970 RETURNOP(PL_op->op_next->op_next);
972 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
973 pp_pushmark(); /* push dst */
974 pp_pushmark(); /* push src */
975 ENTER; /* enter outer scope */
978 if (PL_op->op_private & OPpGREP_LEX)
979 SAVESPTR(PAD_SVl(PL_op->op_targ));
982 ENTER; /* enter inner scope */
985 src = PL_stack_base[*PL_markstack_ptr];
987 if (PL_op->op_private & OPpGREP_LEX)
988 PAD_SVl(PL_op->op_targ) = src;
993 if (PL_op->op_type == OP_MAPSTART)
994 pp_pushmark(); /* push top */
995 return ((LOGOP*)PL_op->op_next)->op_other;
1001 const I32 gimme = GIMME_V;
1002 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1008 /* first, move source pointer to the next item in the source list */
1009 ++PL_markstack_ptr[-1];
1011 /* if there are new items, push them into the destination list */
1012 if (items && gimme != G_VOID) {
1013 /* might need to make room back there first */
1014 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1015 /* XXX this implementation is very pessimal because the stack
1016 * is repeatedly extended for every set of items. Is possible
1017 * to do this without any stack extension or copying at all
1018 * by maintaining a separate list over which the map iterates
1019 * (like foreach does). --gsar */
1021 /* everything in the stack after the destination list moves
1022 * towards the end the stack by the amount of room needed */
1023 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1025 /* items to shift up (accounting for the moved source pointer) */
1026 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1028 /* This optimization is by Ben Tilly and it does
1029 * things differently from what Sarathy (gsar)
1030 * is describing. The downside of this optimization is
1031 * that leaves "holes" (uninitialized and hopefully unused areas)
1032 * to the Perl stack, but on the other hand this
1033 * shouldn't be a problem. If Sarathy's idea gets
1034 * implemented, this optimization should become
1035 * irrelevant. --jhi */
1037 shift = count; /* Avoid shifting too often --Ben Tilly */
1041 dst = (SP += shift);
1042 PL_markstack_ptr[-1] += shift;
1043 *PL_markstack_ptr += shift;
1047 /* copy the new items down to the destination list */
1048 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1049 if (gimme == G_ARRAY) {
1051 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1054 /* scalar context: we don't care about which values map returns
1055 * (we use undef here). And so we certainly don't want to do mortal
1056 * copies of meaningless values. */
1057 while (items-- > 0) {
1059 *dst-- = &PL_sv_undef;
1063 LEAVE; /* exit inner scope */
1066 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1068 (void)POPMARK; /* pop top */
1069 LEAVE; /* exit outer scope */
1070 (void)POPMARK; /* pop src */
1071 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1072 (void)POPMARK; /* pop dst */
1073 SP = PL_stack_base + POPMARK; /* pop original mark */
1074 if (gimme == G_SCALAR) {
1075 if (PL_op->op_private & OPpGREP_LEX) {
1076 SV* sv = sv_newmortal();
1077 sv_setiv(sv, items);
1085 else if (gimme == G_ARRAY)
1092 ENTER; /* enter inner scope */
1095 /* set $_ to the new source item */
1096 src = PL_stack_base[PL_markstack_ptr[-1]];
1098 if (PL_op->op_private & OPpGREP_LEX)
1099 PAD_SVl(PL_op->op_targ) = src;
1103 RETURNOP(cLOGOP->op_other);
1112 if (GIMME == G_ARRAY)
1114 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1115 return cLOGOP->op_other;
1125 if (GIMME == G_ARRAY) {
1126 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1130 SV * const targ = PAD_SV(PL_op->op_targ);
1133 if (PL_op->op_private & OPpFLIP_LINENUM) {
1134 if (GvIO(PL_last_in_gv)) {
1135 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1138 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1140 flip = SvIV(sv) == SvIV(GvSV(gv));
1146 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1147 if (PL_op->op_flags & OPf_SPECIAL) {
1155 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1158 sv_setpvs(TARG, "");
1164 /* This code tries to decide if "$left .. $right" should use the
1165 magical string increment, or if the range is numeric (we make
1166 an exception for .."0" [#18165]). AMS 20021031. */
1168 #define RANGE_IS_NUMERIC(left,right) ( \
1169 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1170 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1171 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1172 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1173 && (!SvOK(right) || looks_like_number(right))))
1179 if (GIMME == G_ARRAY) {
1185 if (RANGE_IS_NUMERIC(left,right)) {
1188 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1189 (SvOK(right) && SvNV(right) > IV_MAX))
1190 DIE(aTHX_ "Range iterator outside integer range");
1201 SV * const sv = sv_2mortal(newSViv(i++));
1206 SV * const final = sv_mortalcopy(right);
1208 const char * const tmps = SvPV_const(final, len);
1210 SV *sv = sv_mortalcopy(left);
1211 SvPV_force_nolen(sv);
1212 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1214 if (strEQ(SvPVX_const(sv),tmps))
1216 sv = sv_2mortal(newSVsv(sv));
1223 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1227 if (PL_op->op_private & OPpFLIP_LINENUM) {
1228 if (GvIO(PL_last_in_gv)) {
1229 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1232 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1233 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1241 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1242 sv_catpvs(targ, "E0");
1252 static const char * const context_name[] = {
1255 NULL, /* CXt_BLOCK never actually needs "block" */
1257 NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1258 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1259 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1260 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1268 S_dopoptolabel(pTHX_ const char *label)
1273 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1275 for (i = cxstack_ix; i >= 0; i--) {
1276 register const PERL_CONTEXT * const cx = &cxstack[i];
1277 switch (CxTYPE(cx)) {
1285 if (ckWARN(WARN_EXITING))
1286 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1287 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1288 if (CxTYPE(cx) == CXt_NULL)
1291 case CXt_LOOP_LAZYIV:
1292 case CXt_LOOP_LAZYSV:
1294 case CXt_LOOP_PLAIN:
1295 if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
1296 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1297 (long)i, CxLABEL(cx)));
1300 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1310 Perl_dowantarray(pTHX)
1313 const I32 gimme = block_gimme();
1314 return (gimme == G_VOID) ? G_SCALAR : gimme;
1318 Perl_block_gimme(pTHX)
1321 const I32 cxix = dopoptosub(cxstack_ix);
1325 switch (cxstack[cxix].blk_gimme) {
1333 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1340 Perl_is_lvalue_sub(pTHX)
1343 const I32 cxix = dopoptosub(cxstack_ix);
1344 assert(cxix >= 0); /* We should only be called from inside subs */
1346 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1347 return CxLVAL(cxstack + cxix);
1353 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1358 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1360 for (i = startingblock; i >= 0; i--) {
1361 register const PERL_CONTEXT * const cx = &cxstk[i];
1362 switch (CxTYPE(cx)) {
1368 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1376 S_dopoptoeval(pTHX_ I32 startingblock)
1380 for (i = startingblock; i >= 0; i--) {
1381 register const PERL_CONTEXT *cx = &cxstack[i];
1382 switch (CxTYPE(cx)) {
1386 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1394 S_dopoptoloop(pTHX_ I32 startingblock)
1398 for (i = startingblock; i >= 0; i--) {
1399 register const PERL_CONTEXT * const cx = &cxstack[i];
1400 switch (CxTYPE(cx)) {
1406 if (ckWARN(WARN_EXITING))
1407 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1408 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1409 if ((CxTYPE(cx)) == CXt_NULL)
1412 case CXt_LOOP_LAZYIV:
1413 case CXt_LOOP_LAZYSV:
1415 case CXt_LOOP_PLAIN:
1416 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1424 S_dopoptogiven(pTHX_ I32 startingblock)
1428 for (i = startingblock; i >= 0; i--) {
1429 register const PERL_CONTEXT *cx = &cxstack[i];
1430 switch (CxTYPE(cx)) {
1434 DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1436 case CXt_LOOP_PLAIN:
1437 assert(!CxFOREACHDEF(cx));
1439 case CXt_LOOP_LAZYIV:
1440 case CXt_LOOP_LAZYSV:
1442 if (CxFOREACHDEF(cx)) {
1443 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1452 S_dopoptowhen(pTHX_ I32 startingblock)
1456 for (i = startingblock; i >= 0; i--) {
1457 register const PERL_CONTEXT *cx = &cxstack[i];
1458 switch (CxTYPE(cx)) {
1462 DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1470 Perl_dounwind(pTHX_ I32 cxix)
1475 while (cxstack_ix > cxix) {
1477 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1478 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1479 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1480 /* Note: we don't need to restore the base context info till the end. */
1481 switch (CxTYPE(cx)) {
1484 continue; /* not break */
1492 case CXt_LOOP_LAZYIV:
1493 case CXt_LOOP_LAZYSV:
1495 case CXt_LOOP_PLAIN:
1506 PERL_UNUSED_VAR(optype);
1510 Perl_qerror(pTHX_ SV *err)
1514 PERL_ARGS_ASSERT_QERROR;
1517 sv_catsv(ERRSV, err);
1519 sv_catsv(PL_errors, err);
1521 Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1523 ++PL_parser->error_count;
1527 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1536 if (PL_in_eval & EVAL_KEEPERR) {
1537 static const char prefix[] = "\t(in cleanup) ";
1538 SV * const err = ERRSV;
1539 const char *e = NULL;
1542 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1544 e = SvPV_const(err, len);
1546 if (*e != *message || strNE(e,message))
1550 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1551 sv_catpvn(err, prefix, sizeof(prefix)-1);
1552 sv_catpvn(err, message, msglen);
1553 if (ckWARN(WARN_MISC)) {
1554 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1555 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s",
1556 SvPVX_const(err)+start);
1561 sv_setpvn(ERRSV, message, msglen);
1565 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1566 && PL_curstackinfo->si_prev)
1574 register PERL_CONTEXT *cx;
1577 if (cxix < cxstack_ix)
1580 POPBLOCK(cx,PL_curpm);
1581 if (CxTYPE(cx) != CXt_EVAL) {
1583 message = SvPVx_const(ERRSV, msglen);
1584 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1585 PerlIO_write(Perl_error_log, message, msglen);
1590 if (gimme == G_SCALAR)
1591 *++newsp = &PL_sv_undef;
1592 PL_stack_sp = newsp;
1596 /* LEAVE could clobber PL_curcop (see save_re_context())
1597 * XXX it might be better to find a way to avoid messing with
1598 * PL_curcop in save_re_context() instead, but this is a more
1599 * minimal fix --GSAR */
1600 PL_curcop = cx->blk_oldcop;
1602 if (optype == OP_REQUIRE) {
1603 const char* const msg = SvPVx_nolen_const(ERRSV);
1604 SV * const nsv = cx->blk_eval.old_namesv;
1605 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1607 DIE(aTHX_ "%sCompilation failed in require",
1608 *msg ? msg : "Unknown error\n");
1610 assert(CxTYPE(cx) == CXt_EVAL);
1611 return cx->blk_eval.retop;
1615 message = SvPVx_const(ERRSV, msglen);
1617 write_to_stderr(message, msglen);
1625 dVAR; dSP; dPOPTOPssrl;
1626 if (SvTRUE(left) != SvTRUE(right))
1636 register I32 cxix = dopoptosub(cxstack_ix);
1637 register const PERL_CONTEXT *cx;
1638 register const PERL_CONTEXT *ccstack = cxstack;
1639 const PERL_SI *top_si = PL_curstackinfo;
1641 const char *stashname;
1648 /* we may be in a higher stacklevel, so dig down deeper */
1649 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1650 top_si = top_si->si_prev;
1651 ccstack = top_si->si_cxstack;
1652 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1655 if (GIMME != G_ARRAY) {
1661 /* caller() should not report the automatic calls to &DB::sub */
1662 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1663 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1667 cxix = dopoptosub_at(ccstack, cxix - 1);
1670 cx = &ccstack[cxix];
1671 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1672 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1673 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1674 field below is defined for any cx. */
1675 /* caller() should not report the automatic calls to &DB::sub */
1676 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1677 cx = &ccstack[dbcxix];
1680 stashname = CopSTASHPV(cx->blk_oldcop);
1681 if (GIMME != G_ARRAY) {
1684 PUSHs(&PL_sv_undef);
1687 sv_setpv(TARG, stashname);
1696 PUSHs(&PL_sv_undef);
1698 mPUSHs(newSVpv(stashname, 0));
1699 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1700 mPUSHi((I32)CopLINE(cx->blk_oldcop));
1703 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1704 GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1705 /* So is ccstack[dbcxix]. */
1707 SV * const sv = newSV(0);
1708 gv_efullname3(sv, cvgv, NULL);
1710 PUSHs(boolSV(CxHASARGS(cx)));
1713 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1714 PUSHs(boolSV(CxHASARGS(cx)));
1718 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1721 gimme = (I32)cx->blk_gimme;
1722 if (gimme == G_VOID)
1723 PUSHs(&PL_sv_undef);
1725 PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1726 if (CxTYPE(cx) == CXt_EVAL) {
1728 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1729 PUSHs(cx->blk_eval.cur_text);
1733 else if (cx->blk_eval.old_namesv) {
1734 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1737 /* eval BLOCK (try blocks have old_namesv == 0) */
1739 PUSHs(&PL_sv_undef);
1740 PUSHs(&PL_sv_undef);
1744 PUSHs(&PL_sv_undef);
1745 PUSHs(&PL_sv_undef);
1747 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1748 && CopSTASH_eq(PL_curcop, PL_debstash))
1750 AV * const ary = cx->blk_sub.argarray;
1751 const int off = AvARRAY(ary) - AvALLOC(ary);
1754 GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1755 PL_dbargs = GvAV(gv_AVadd(tmpgv));
1757 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1760 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1761 av_extend(PL_dbargs, AvFILLp(ary) + off);
1762 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1763 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1765 /* XXX only hints propagated via op_private are currently
1766 * visible (others are not easily accessible, since they
1767 * use the global PL_hints) */
1768 mPUSHi(CopHINTS_get(cx->blk_oldcop));
1771 STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1773 if (old_warnings == pWARN_NONE ||
1774 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1775 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1776 else if (old_warnings == pWARN_ALL ||
1777 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1778 /* Get the bit mask for $warnings::Bits{all}, because
1779 * it could have been extended by warnings::register */
1781 HV * const bits = get_hv("warnings::Bits", 0);
1782 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1783 mask = newSVsv(*bits_all);
1786 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1790 mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1794 PUSHs(cx->blk_oldcop->cop_hints_hash ?
1795 sv_2mortal(newRV_noinc(
1796 MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1797 cx->blk_oldcop->cop_hints_hash))))
1806 const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1807 sv_reset(tmps, CopSTASH(PL_curcop));
1812 /* like pp_nextstate, but used instead when the debugger is active */
1817 PL_curcop = (COP*)PL_op;
1818 TAINT_NOT; /* Each statement is presumed innocent */
1819 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1822 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1823 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1826 register PERL_CONTEXT *cx;
1827 const I32 gimme = G_ARRAY;
1829 GV * const gv = PL_DBgv;
1830 register CV * const cv = GvCV(gv);
1833 DIE(aTHX_ "No DB::DB routine defined");
1835 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1836 /* don't do recursive DB::DB call */
1851 (void)(*CvXSUB(cv))(aTHX_ cv);
1858 PUSHBLOCK(cx, CXt_SUB, SP);
1860 cx->blk_sub.retop = PL_op->op_next;
1863 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1864 RETURNOP(CvSTART(cv));
1874 register PERL_CONTEXT *cx;
1875 const I32 gimme = GIMME_V;
1877 U8 cxtype = CXt_LOOP_FOR;
1885 if (PL_op->op_targ) {
1886 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1887 SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1888 SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1889 SVs_PADSTALE, SVs_PADSTALE);
1891 SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1892 #ifndef USE_ITHREADS
1893 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1899 GV * const gv = MUTABLE_GV(POPs);
1900 svp = &GvSV(gv); /* symbol table variable */
1901 SAVEGENERICSV(*svp);
1904 iterdata = (PAD*)gv;
1908 if (PL_op->op_private & OPpITER_DEF)
1909 cxtype |= CXp_FOR_DEF;
1913 PUSHBLOCK(cx, cxtype, SP);
1915 PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1917 PUSHLOOP_FOR(cx, svp, MARK, 0);
1919 if (PL_op->op_flags & OPf_STACKED) {
1920 SV *maybe_ary = POPs;
1921 if (SvTYPE(maybe_ary) != SVt_PVAV) {
1923 SV * const right = maybe_ary;
1926 if (RANGE_IS_NUMERIC(sv,right)) {
1927 cx->cx_type &= ~CXTYPEMASK;
1928 cx->cx_type |= CXt_LOOP_LAZYIV;
1929 /* Make sure that no-one re-orders cop.h and breaks our
1931 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1932 #ifdef NV_PRESERVES_UV
1933 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1934 (SvNV(sv) > (NV)IV_MAX)))
1936 (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1937 (SvNV(right) < (NV)IV_MIN))))
1939 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1942 ((SvUV(sv) > (UV)IV_MAX) ||
1943 (SvNV(sv) > (NV)UV_MAX)))))
1945 (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1947 ((SvNV(right) > 0) &&
1948 ((SvUV(right) > (UV)IV_MAX) ||
1949 (SvNV(right) > (NV)UV_MAX))))))
1951 DIE(aTHX_ "Range iterator outside integer range");
1952 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1953 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1955 /* for correct -Dstv display */
1956 cx->blk_oldsp = sp - PL_stack_base;
1960 cx->cx_type &= ~CXTYPEMASK;
1961 cx->cx_type |= CXt_LOOP_LAZYSV;
1962 /* Make sure that no-one re-orders cop.h and breaks our
1964 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
1965 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
1966 cx->blk_loop.state_u.lazysv.end = right;
1967 SvREFCNT_inc(right);
1968 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
1969 /* This will do the upgrade to SVt_PV, and warn if the value
1970 is uninitialised. */
1971 (void) SvPV_nolen_const(right);
1972 /* Doing this avoids a check every time in pp_iter in pp_hot.c
1973 to replace !SvOK() with a pointer to "". */
1975 SvREFCNT_dec(right);
1976 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
1980 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
1981 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
1982 SvREFCNT_inc(maybe_ary);
1983 cx->blk_loop.state_u.ary.ix =
1984 (PL_op->op_private & OPpITER_REVERSED) ?
1985 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
1989 else { /* iterating over items on the stack */
1990 cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
1991 if (PL_op->op_private & OPpITER_REVERSED) {
1992 cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
1995 cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2005 register PERL_CONTEXT *cx;
2006 const I32 gimme = GIMME_V;
2012 PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2013 PUSHLOOP_PLAIN(cx, SP);
2021 register PERL_CONTEXT *cx;
2028 assert(CxTYPE_is_LOOP(cx));
2030 newsp = PL_stack_base + cx->blk_loop.resetsp;
2033 if (gimme == G_VOID)
2035 else if (gimme == G_SCALAR) {
2037 *++newsp = sv_mortalcopy(*SP);
2039 *++newsp = &PL_sv_undef;
2043 *++newsp = sv_mortalcopy(*++mark);
2044 TAINT_NOT; /* Each item is independent */
2050 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
2051 PL_curpm = newpm; /* ... and pop $1 et al */
2062 register PERL_CONTEXT *cx;
2063 bool popsub2 = FALSE;
2064 bool clear_errsv = FALSE;
2072 const I32 cxix = dopoptosub(cxstack_ix);
2075 if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2076 * sort block, which is a CXt_NULL
2079 PL_stack_base[1] = *PL_stack_sp;
2080 PL_stack_sp = PL_stack_base + 1;
2084 DIE(aTHX_ "Can't return outside a subroutine");
2086 if (cxix < cxstack_ix)
2089 if (CxMULTICALL(&cxstack[cxix])) {
2090 gimme = cxstack[cxix].blk_gimme;
2091 if (gimme == G_VOID)
2092 PL_stack_sp = PL_stack_base;
2093 else if (gimme == G_SCALAR) {
2094 PL_stack_base[1] = *PL_stack_sp;
2095 PL_stack_sp = PL_stack_base + 1;
2101 switch (CxTYPE(cx)) {
2104 retop = cx->blk_sub.retop;
2105 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2108 if (!(PL_in_eval & EVAL_KEEPERR))
2111 retop = cx->blk_eval.retop;
2115 if (optype == OP_REQUIRE &&
2116 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2118 /* Unassume the success we assumed earlier. */
2119 SV * const nsv = cx->blk_eval.old_namesv;
2120 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2121 DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2126 retop = cx->blk_sub.retop;
2129 DIE(aTHX_ "panic: return");
2133 if (gimme == G_SCALAR) {
2136 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2138 *++newsp = SvREFCNT_inc(*SP);
2143 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2145 *++newsp = sv_mortalcopy(sv);
2150 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2153 *++newsp = sv_mortalcopy(*SP);
2156 *++newsp = &PL_sv_undef;
2158 else if (gimme == G_ARRAY) {
2159 while (++MARK <= SP) {
2160 *++newsp = (popsub2 && SvTEMP(*MARK))
2161 ? *MARK : sv_mortalcopy(*MARK);
2162 TAINT_NOT; /* Each item is independent */
2165 PL_stack_sp = newsp;
2168 /* Stack values are safe: */
2171 POPSUB(cx,sv); /* release CV and @_ ... */
2175 PL_curpm = newpm; /* ... and pop $1 et al */
2188 register PERL_CONTEXT *cx;
2199 if (PL_op->op_flags & OPf_SPECIAL) {
2200 cxix = dopoptoloop(cxstack_ix);
2202 DIE(aTHX_ "Can't \"last\" outside a loop block");
2205 cxix = dopoptolabel(cPVOP->op_pv);
2207 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2209 if (cxix < cxstack_ix)
2213 cxstack_ix++; /* temporarily protect top context */
2215 switch (CxTYPE(cx)) {
2216 case CXt_LOOP_LAZYIV:
2217 case CXt_LOOP_LAZYSV:
2219 case CXt_LOOP_PLAIN:
2221 newsp = PL_stack_base + cx->blk_loop.resetsp;
2222 nextop = cx->blk_loop.my_op->op_lastop->op_next;
2226 nextop = cx->blk_sub.retop;
2230 nextop = cx->blk_eval.retop;
2234 nextop = cx->blk_sub.retop;
2237 DIE(aTHX_ "panic: last");
2241 if (gimme == G_SCALAR) {
2243 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2244 ? *SP : sv_mortalcopy(*SP);
2246 *++newsp = &PL_sv_undef;
2248 else if (gimme == G_ARRAY) {
2249 while (++MARK <= SP) {
2250 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2251 ? *MARK : sv_mortalcopy(*MARK);
2252 TAINT_NOT; /* Each item is independent */
2260 /* Stack values are safe: */
2262 case CXt_LOOP_LAZYIV:
2263 case CXt_LOOP_PLAIN:
2264 case CXt_LOOP_LAZYSV:
2266 POPLOOP(cx); /* release loop vars ... */
2270 POPSUB(cx,sv); /* release CV and @_ ... */
2273 PL_curpm = newpm; /* ... and pop $1 et al */
2276 PERL_UNUSED_VAR(optype);
2277 PERL_UNUSED_VAR(gimme);
2285 register PERL_CONTEXT *cx;
2288 if (PL_op->op_flags & OPf_SPECIAL) {
2289 cxix = dopoptoloop(cxstack_ix);
2291 DIE(aTHX_ "Can't \"next\" outside a loop block");
2294 cxix = dopoptolabel(cPVOP->op_pv);
2296 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2298 if (cxix < cxstack_ix)
2301 /* clear off anything above the scope we're re-entering, but
2302 * save the rest until after a possible continue block */
2303 inner = PL_scopestack_ix;
2305 if (PL_scopestack_ix < inner)
2306 leave_scope(PL_scopestack[PL_scopestack_ix]);
2307 PL_curcop = cx->blk_oldcop;
2308 return CX_LOOP_NEXTOP_GET(cx);
2315 register PERL_CONTEXT *cx;
2319 if (PL_op->op_flags & OPf_SPECIAL) {
2320 cxix = dopoptoloop(cxstack_ix);
2322 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2325 cxix = dopoptolabel(cPVOP->op_pv);
2327 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2329 if (cxix < cxstack_ix)
2332 redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2333 if (redo_op->op_type == OP_ENTER) {
2334 /* pop one less context to avoid $x being freed in while (my $x..) */
2336 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2337 redo_op = redo_op->op_next;
2341 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2342 LEAVE_SCOPE(oldsave);
2344 PL_curcop = cx->blk_oldcop;
2349 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2353 static const char too_deep[] = "Target of goto is too deeply nested";
2355 PERL_ARGS_ASSERT_DOFINDLABEL;
2358 Perl_croak(aTHX_ too_deep);
2359 if (o->op_type == OP_LEAVE ||
2360 o->op_type == OP_SCOPE ||
2361 o->op_type == OP_LEAVELOOP ||
2362 o->op_type == OP_LEAVESUB ||
2363 o->op_type == OP_LEAVETRY)
2365 *ops++ = cUNOPo->op_first;
2367 Perl_croak(aTHX_ too_deep);
2370 if (o->op_flags & OPf_KIDS) {
2372 /* First try all the kids at this level, since that's likeliest. */
2373 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2374 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2375 CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label))
2378 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2379 if (kid == PL_lastgotoprobe)
2381 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2384 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2385 ops[-1]->op_type == OP_DBSTATE)
2390 if ((o = dofindlabel(kid, label, ops, oplimit)))
2403 register PERL_CONTEXT *cx;
2404 #define GOTO_DEPTH 64
2405 OP *enterops[GOTO_DEPTH];
2406 const char *label = NULL;
2407 const bool do_dump = (PL_op->op_type == OP_DUMP);
2408 static const char must_have_label[] = "goto must have label";
2410 if (PL_op->op_flags & OPf_STACKED) {
2411 SV * const sv = POPs;
2413 /* This egregious kludge implements goto &subroutine */
2414 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2416 register PERL_CONTEXT *cx;
2417 CV *cv = MUTABLE_CV(SvRV(sv));
2424 if (!CvROOT(cv) && !CvXSUB(cv)) {
2425 const GV * const gv = CvGV(cv);
2429 /* autoloaded stub? */
2430 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2432 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2433 GvNAMELEN(gv), FALSE);
2434 if (autogv && (cv = GvCV(autogv)))
2436 tmpstr = sv_newmortal();
2437 gv_efullname3(tmpstr, gv, NULL);
2438 DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2440 DIE(aTHX_ "Goto undefined subroutine");
2443 /* First do some returnish stuff. */
2444 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2446 cxix = dopoptosub(cxstack_ix);
2448 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2449 if (cxix < cxstack_ix)
2453 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2454 if (CxTYPE(cx) == CXt_EVAL) {
2456 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2458 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2460 else if (CxMULTICALL(cx))
2461 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2462 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2463 /* put @_ back onto stack */
2464 AV* av = cx->blk_sub.argarray;
2466 items = AvFILLp(av) + 1;
2467 EXTEND(SP, items+1); /* @_ could have been extended. */
2468 Copy(AvARRAY(av), SP + 1, items, SV*);
2469 SvREFCNT_dec(GvAV(PL_defgv));
2470 GvAV(PL_defgv) = cx->blk_sub.savearray;
2472 /* abandon @_ if it got reified */
2477 av_extend(av, items-1);
2479 PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2482 else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2483 AV* const av = GvAV(PL_defgv);
2484 items = AvFILLp(av) + 1;
2485 EXTEND(SP, items+1); /* @_ could have been extended. */
2486 Copy(AvARRAY(av), SP + 1, items, SV*);
2490 if (CxTYPE(cx) == CXt_SUB &&
2491 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2492 SvREFCNT_dec(cx->blk_sub.cv);
2493 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2494 LEAVE_SCOPE(oldsave);
2496 /* Now do some callish stuff. */
2498 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2500 OP* const retop = cx->blk_sub.retop;
2505 for (index=0; index<items; index++)
2506 sv_2mortal(SP[-index]);
2509 /* XS subs don't have a CxSUB, so pop it */
2510 POPBLOCK(cx, PL_curpm);
2511 /* Push a mark for the start of arglist */
2514 (void)(*CvXSUB(cv))(aTHX_ cv);
2519 AV* const padlist = CvPADLIST(cv);
2520 if (CxTYPE(cx) == CXt_EVAL) {
2521 PL_in_eval = CxOLD_IN_EVAL(cx);
2522 PL_eval_root = cx->blk_eval.old_eval_root;
2523 cx->cx_type = CXt_SUB;
2525 cx->blk_sub.cv = cv;
2526 cx->blk_sub.olddepth = CvDEPTH(cv);
2529 if (CvDEPTH(cv) < 2)
2530 SvREFCNT_inc_simple_void_NN(cv);
2532 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2533 sub_crush_depth(cv);
2534 pad_push(padlist, CvDEPTH(cv));
2537 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2540 AV *const av = MUTABLE_AV(PAD_SVl(0));
2542 cx->blk_sub.savearray = GvAV(PL_defgv);
2543 GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2544 CX_CURPAD_SAVE(cx->blk_sub);
2545 cx->blk_sub.argarray = av;
2547 if (items >= AvMAX(av) + 1) {
2548 SV **ary = AvALLOC(av);
2549 if (AvARRAY(av) != ary) {
2550 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2553 if (items >= AvMAX(av) + 1) {
2554 AvMAX(av) = items - 1;
2555 Renew(ary,items+1,SV*);
2561 Copy(mark,AvARRAY(av),items,SV*);
2562 AvFILLp(av) = items - 1;
2563 assert(!AvREAL(av));
2565 /* transfer 'ownership' of refcnts to new @_ */
2575 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2576 Perl_get_db_sub(aTHX_ NULL, cv);
2578 CV * const gotocv = get_cvs("DB::goto", 0);
2580 PUSHMARK( PL_stack_sp );
2581 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2586 RETURNOP(CvSTART(cv));
2590 label = SvPV_nolen_const(sv);
2591 if (!(do_dump || *label))
2592 DIE(aTHX_ must_have_label);
2595 else if (PL_op->op_flags & OPf_SPECIAL) {
2597 DIE(aTHX_ must_have_label);
2600 label = cPVOP->op_pv;
2602 if (label && *label) {
2603 OP *gotoprobe = NULL;
2604 bool leaving_eval = FALSE;
2605 bool in_block = FALSE;
2606 PERL_CONTEXT *last_eval_cx = NULL;
2610 PL_lastgotoprobe = NULL;
2612 for (ix = cxstack_ix; ix >= 0; ix--) {
2614 switch (CxTYPE(cx)) {
2616 leaving_eval = TRUE;
2617 if (!CxTRYBLOCK(cx)) {
2618 gotoprobe = (last_eval_cx ?
2619 last_eval_cx->blk_eval.old_eval_root :
2624 /* else fall through */
2625 case CXt_LOOP_LAZYIV:
2626 case CXt_LOOP_LAZYSV:
2628 case CXt_LOOP_PLAIN:
2629 gotoprobe = cx->blk_oldcop->op_sibling;
2635 gotoprobe = cx->blk_oldcop->op_sibling;
2638 gotoprobe = PL_main_root;
2641 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2642 gotoprobe = CvROOT(cx->blk_sub.cv);
2648 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2651 DIE(aTHX_ "panic: goto");
2652 gotoprobe = PL_main_root;
2656 retop = dofindlabel(gotoprobe, label,
2657 enterops, enterops + GOTO_DEPTH);
2661 PL_lastgotoprobe = gotoprobe;
2664 DIE(aTHX_ "Can't find label %s", label);
2666 /* if we're leaving an eval, check before we pop any frames
2667 that we're not going to punt, otherwise the error
2670 if (leaving_eval && *enterops && enterops[1]) {
2672 for (i = 1; enterops[i]; i++)
2673 if (enterops[i]->op_type == OP_ENTERITER)
2674 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2677 /* pop unwanted frames */
2679 if (ix < cxstack_ix) {
2686 oldsave = PL_scopestack[PL_scopestack_ix];
2687 LEAVE_SCOPE(oldsave);
2690 /* push wanted frames */
2692 if (*enterops && enterops[1]) {
2693 OP * const oldop = PL_op;
2694 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2695 for (; enterops[ix]; ix++) {
2696 PL_op = enterops[ix];
2697 /* Eventually we may want to stack the needed arguments
2698 * for each op. For now, we punt on the hard ones. */
2699 if (PL_op->op_type == OP_ENTERITER)
2700 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2701 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2709 if (!retop) retop = PL_main_start;
2711 PL_restartop = retop;
2712 PL_do_undump = TRUE;
2716 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2717 PL_do_undump = FALSE;
2734 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2736 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2739 PL_exit_flags |= PERL_EXIT_EXPECTED;
2741 /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2742 if (anum || !(PL_minus_c && PL_madskills))
2747 PUSHs(&PL_sv_undef);
2754 S_save_lines(pTHX_ AV *array, SV *sv)
2756 const char *s = SvPVX_const(sv);
2757 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2760 PERL_ARGS_ASSERT_SAVE_LINES;
2762 while (s && s < send) {
2764 SV * const tmpstr = newSV_type(SVt_PVMG);
2766 t = (const char *)memchr(s, '\n', send - s);
2772 sv_setpvn(tmpstr, s, t - s);
2773 av_store(array, line++, tmpstr);
2779 S_docatch(pTHX_ OP *o)
2783 OP * const oldop = PL_op;
2787 assert(CATCH_GET == TRUE);
2794 assert(cxstack_ix >= 0);
2795 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2796 cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2801 /* die caught by an inner eval - continue inner loop */
2803 /* NB XXX we rely on the old popped CxEVAL still being at the top
2804 * of the stack; the way die_where() currently works, this
2805 * assumption is valid. In theory The cur_top_env value should be
2806 * returned in another global, the way retop (aka PL_restartop)
2808 assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2811 && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2813 PL_op = PL_restartop;
2830 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2831 /* sv Text to convert to OP tree. */
2832 /* startop op_free() this to undo. */
2833 /* code Short string id of the caller. */
2835 /* FIXME - how much of this code is common with pp_entereval? */
2836 dVAR; dSP; /* Make POPBLOCK work. */
2842 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2843 char *tmpbuf = tbuf;
2846 CV* runcv = NULL; /* initialise to avoid compiler warnings */
2849 PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2852 lex_start(sv, NULL, FALSE);
2854 /* switch to eval mode */
2856 if (IN_PERL_COMPILETIME) {
2857 SAVECOPSTASH_FREE(&PL_compiling);
2858 CopSTASH_set(&PL_compiling, PL_curstash);
2860 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2861 SV * const sv = sv_newmortal();
2862 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2863 code, (unsigned long)++PL_evalseq,
2864 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2869 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2870 (unsigned long)++PL_evalseq);
2871 SAVECOPFILE_FREE(&PL_compiling);
2872 CopFILE_set(&PL_compiling, tmpbuf+2);
2873 SAVECOPLINE(&PL_compiling);
2874 CopLINE_set(&PL_compiling, 1);
2875 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2876 deleting the eval's FILEGV from the stash before gv_check() runs
2877 (i.e. before run-time proper). To work around the coredump that
2878 ensues, we always turn GvMULTI_on for any globals that were
2879 introduced within evals. See force_ident(). GSAR 96-10-12 */
2880 safestr = savepvn(tmpbuf, len);
2881 SAVEDELETE(PL_defstash, safestr, len);
2883 #ifdef OP_IN_REGISTER
2889 /* we get here either during compilation, or via pp_regcomp at runtime */
2890 runtime = IN_PERL_RUNTIME;
2892 runcv = find_runcv(NULL);
2895 PL_op->op_type = OP_ENTEREVAL;
2896 PL_op->op_flags = 0; /* Avoid uninit warning. */
2897 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2901 (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2903 (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2904 POPBLOCK(cx,PL_curpm);
2907 (*startop)->op_type = OP_NULL;
2908 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2910 /* XXX DAPM do this properly one year */
2911 *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2913 if (IN_PERL_COMPILETIME)
2914 CopHINTS_set(&PL_compiling, PL_hints);
2915 #ifdef OP_IN_REGISTER
2918 PERL_UNUSED_VAR(newsp);
2919 PERL_UNUSED_VAR(optype);
2921 return PL_eval_start;
2926 =for apidoc find_runcv
2928 Locate the CV corresponding to the currently executing sub or eval.
2929 If db_seqp is non_null, skip CVs that are in the DB package and populate
2930 *db_seqp with the cop sequence number at the point that the DB:: code was
2931 entered. (allows debuggers to eval in the scope of the breakpoint rather
2932 than in the scope of the debugger itself).
2938 Perl_find_runcv(pTHX_ U32 *db_seqp)
2944 *db_seqp = PL_curcop->cop_seq;
2945 for (si = PL_curstackinfo; si; si = si->si_prev) {
2947 for (ix = si->si_cxix; ix >= 0; ix--) {
2948 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2949 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2950 CV * const cv = cx->blk_sub.cv;
2951 /* skip DB:: code */
2952 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2953 *db_seqp = cx->blk_oldcop->cop_seq;
2958 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2966 /* Compile a require/do, an eval '', or a /(?{...})/.
2967 * In the last case, startop is non-null, and contains the address of
2968 * a pointer that should be set to the just-compiled code.
2969 * outside is the lexically enclosing CV (if any) that invoked us.
2970 * Returns a bool indicating whether the compile was successful; if so,
2971 * PL_eval_start contains the first op of the compiled ocde; otherwise,
2972 * pushes undef (also croaks if startop != NULL).
2976 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2979 OP * const saveop = PL_op;
2981 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2982 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2987 SAVESPTR(PL_compcv);
2988 PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2989 CvEVAL_on(PL_compcv);
2990 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2991 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2993 CvOUTSIDE_SEQ(PL_compcv) = seq;
2994 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2996 /* set up a scratch pad */
2998 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2999 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3003 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
3005 /* make sure we compile in the right package */
3007 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3008 SAVESPTR(PL_curstash);
3009 PL_curstash = CopSTASH(PL_curcop);
3011 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3012 SAVESPTR(PL_beginav);
3013 PL_beginav = newAV();
3014 SAVEFREESV(PL_beginav);
3015 SAVESPTR(PL_unitcheckav);
3016 PL_unitcheckav = newAV();
3017 SAVEFREESV(PL_unitcheckav);
3020 SAVEBOOL(PL_madskills);
3024 /* try to compile it */
3026 PL_eval_root = NULL;
3027 PL_curcop = &PL_compiling;
3028 CopARYBASE_set(PL_curcop, 0);
3029 if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3030 PL_in_eval |= EVAL_KEEPERR;
3033 if (yyparse() || PL_parser->error_count || !PL_eval_root) {
3034 SV **newsp; /* Used by POPBLOCK. */
3035 PERL_CONTEXT *cx = &cxstack[cxstack_ix];
3036 I32 optype = 0; /* Might be reset by POPEVAL. */
3041 op_free(PL_eval_root);
3042 PL_eval_root = NULL;
3044 SP = PL_stack_base + POPMARK; /* pop original mark */
3046 POPBLOCK(cx,PL_curpm);
3050 LEAVE; /* pp_entereval knows about this LEAVE. */
3052 msg = SvPVx_nolen_const(ERRSV);
3053 if (optype == OP_REQUIRE) {
3054 const SV * const nsv = cx->blk_eval.old_namesv;
3055 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3057 Perl_croak(aTHX_ "%sCompilation failed in require",
3058 *msg ? msg : "Unknown error\n");
3061 POPBLOCK(cx,PL_curpm);
3063 Perl_croak(aTHX_ "%sCompilation failed in regexp",
3064 (*msg ? msg : "Unknown error\n"));
3068 sv_setpvs(ERRSV, "Compilation error");
3071 PERL_UNUSED_VAR(newsp);
3072 PUSHs(&PL_sv_undef);
3076 CopLINE_set(&PL_compiling, 0);
3078 *startop = PL_eval_root;
3080 SAVEFREEOP(PL_eval_root);
3082 /* Set the context for this new optree.
3083 * If the last op is an OP_REQUIRE, force scalar context.
3084 * Otherwise, propagate the context from the eval(). */
3085 if (PL_eval_root->op_type == OP_LEAVEEVAL
3086 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3087 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3089 scalar(PL_eval_root);
3090 else if ((gimme & G_WANT) == G_VOID)
3091 scalarvoid(PL_eval_root);
3092 else if ((gimme & G_WANT) == G_ARRAY)
3095 scalar(PL_eval_root);
3097 DEBUG_x(dump_eval());
3099 /* Register with debugger: */
3100 if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3101 CV * const cv = get_cvs("DB::postponed", 0);
3105 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3107 call_sv(MUTABLE_SV(cv), G_DISCARD);
3112 call_list(PL_scopestack_ix, PL_unitcheckav);
3114 /* compiled okay, so do it */
3116 CvDEPTH(PL_compcv) = 1;
3117 SP = PL_stack_base + POPMARK; /* pop original mark */
3118 PL_op = saveop; /* The caller may need it. */
3119 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3126 S_check_type_and_open(pTHX_ const char *name)
3129 const int st_rc = PerlLIO_stat(name, &st);
3131 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3133 if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3137 return PerlIO_open(name, PERL_SCRIPT_MODE);
3140 #ifndef PERL_DISABLE_PMC
3142 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3146 PERL_ARGS_ASSERT_DOOPEN_PM;
3148 if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3149 SV *const pmcsv = newSV(namelen + 2);
3150 char *const pmc = SvPVX(pmcsv);
3153 memcpy(pmc, name, namelen);
3155 pmc[namelen + 1] = '\0';
3157 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3158 fp = check_type_and_open(name);
3161 fp = check_type_and_open(pmc);
3163 SvREFCNT_dec(pmcsv);
3166 fp = check_type_and_open(name);
3171 # define doopen_pm(name, namelen) check_type_and_open(name)
3172 #endif /* !PERL_DISABLE_PMC */
3177 register PERL_CONTEXT *cx;
3184 int vms_unixname = 0;
3186 const char *tryname = NULL;
3188 const I32 gimme = GIMME_V;
3189 int filter_has_file = 0;
3190 PerlIO *tryrsfp = NULL;
3191 SV *filter_cache = NULL;
3192 SV *filter_state = NULL;
3193 SV *filter_sub = NULL;
3199 if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3200 sv = new_version(sv);
3201 if (!sv_derived_from(PL_patchlevel, "version"))
3202 upg_version(PL_patchlevel, TRUE);
3203 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3204 if ( vcmp(sv,PL_patchlevel) <= 0 )
3205 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3206 SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3209 if ( vcmp(sv,PL_patchlevel) > 0 ) {
3212 SV * const req = SvRV(sv);
3213 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3215 /* get the left hand term */
3216 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3218 first = SvIV(*av_fetch(lav,0,0));
3219 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3220 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3221 || av_len(lav) > 1 /* FP with > 3 digits */
3222 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3224 DIE(aTHX_ "Perl %"SVf" required--this is only "
3225 "%"SVf", stopped", SVfARG(vnormal(req)),
3226 SVfARG(vnormal(PL_patchlevel)));
3228 else { /* probably 'use 5.10' or 'use 5.8' */
3229 SV * hintsv = newSV(0);
3233 second = SvIV(*av_fetch(lav,1,0));
3235 second /= second >= 600 ? 100 : 10;
3236 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3237 (int)first, (int)second,0);
3238 upg_version(hintsv, TRUE);
3240 DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3241 "--this is only %"SVf", stopped",
3242 SVfARG(vnormal(req)),
3243 SVfARG(vnormal(hintsv)),
3244 SVfARG(vnormal(PL_patchlevel)));
3249 /* We do this only with use, not require. */
3251 /* If we request a version >= 5.9.5, load feature.pm with the
3252 * feature bundle that corresponds to the required version. */
3253 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3254 SV *const importsv = vnormal(sv);
3255 *SvPVX_mutable(importsv) = ':';
3257 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3263 name = SvPV_const(sv, len);
3264 if (!(name && len > 0 && *name))
3265 DIE(aTHX_ "Null filename used");
3266 TAINT_PROPER("require");
3270 /* The key in the %ENV hash is in the syntax of file passed as the argument
3271 * usually this is in UNIX format, but sometimes in VMS format, which
3272 * can result in a module being pulled in more than once.
3273 * To prevent this, the key must be stored in UNIX format if the VMS
3274 * name can be translated to UNIX.
3276 if ((unixname = tounixspec(name, NULL)) != NULL) {
3277 unixlen = strlen(unixname);
3283 /* if not VMS or VMS name can not be translated to UNIX, pass it
3286 unixname = (char *) name;
3289 if (PL_op->op_type == OP_REQUIRE) {
3290 SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3291 unixname, unixlen, 0);
3293 if (*svp != &PL_sv_undef)
3296 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3297 "Compilation failed in require", unixname);
3301 /* prepare to compile file */
3303 if (path_is_absolute(name)) {
3305 tryrsfp = doopen_pm(name, len);
3308 AV * const ar = GvAVn(PL_incgv);
3314 namesv = newSV_type(SVt_PV);
3315 for (i = 0; i <= AvFILL(ar); i++) {
3316 SV * const dirsv = *av_fetch(ar, i, TRUE);
3318 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3325 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3326 && !sv_isobject(loader))
3328 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3331 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3332 PTR2UV(SvRV(dirsv)), name);
3333 tryname = SvPVX_const(namesv);
3344 if (sv_isobject(loader))
3345 count = call_method("INC", G_ARRAY);
3347 count = call_sv(loader, G_ARRAY);
3350 /* Adjust file name if the hook has set an %INC entry */
3351 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3353 tryname = SvPVX_const(*svp);
3362 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3363 && !isGV_with_GP(SvRV(arg))) {
3364 filter_cache = SvRV(arg);
3365 SvREFCNT_inc_simple_void_NN(filter_cache);
3372 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3376 if (isGV_with_GP(arg)) {
3377 IO * const io = GvIO((const GV *)arg);
3382 tryrsfp = IoIFP(io);
3383 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3384 PerlIO_close(IoOFP(io));
3395 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3397 SvREFCNT_inc_simple_void_NN(filter_sub);
3400 filter_state = SP[i];
3401 SvREFCNT_inc_simple_void(filter_state);
3405 if (!tryrsfp && (filter_cache || filter_sub)) {
3406 tryrsfp = PerlIO_open(BIT_BUCKET,
3421 filter_has_file = 0;
3423 SvREFCNT_dec(filter_cache);
3424 filter_cache = NULL;
3427 SvREFCNT_dec(filter_state);
3428 filter_state = NULL;
3431 SvREFCNT_dec(filter_sub);
3436 if (!path_is_absolute(name)
3442 dir = SvPV_const(dirsv, dirlen);
3450 if ((unixdir = tounixpath(dir, NULL)) == NULL)
3452 sv_setpv(namesv, unixdir);
3453 sv_catpv(namesv, unixname);
3455 # ifdef __SYMBIAN32__
3456 if (PL_origfilename[0] &&
3457 PL_origfilename[1] == ':' &&
3458 !(dir[0] && dir[1] == ':'))
3459 Perl_sv_setpvf(aTHX_ namesv,
3464 Perl_sv_setpvf(aTHX_ namesv,
3468 /* The equivalent of
3469 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3470 but without the need to parse the format string, or
3471 call strlen on either pointer, and with the correct
3472 allocation up front. */
3474 char *tmp = SvGROW(namesv, dirlen + len + 2);
3476 memcpy(tmp, dir, dirlen);
3479 /* name came from an SV, so it will have a '\0' at the
3480 end that we can copy as part of this memcpy(). */
3481 memcpy(tmp, name, len + 1);
3483 SvCUR_set(namesv, dirlen + len + 1);
3485 /* Don't even actually have to turn SvPOK_on() as we
3486 access it directly with SvPVX() below. */
3490 TAINT_PROPER("require");
3491 tryname = SvPVX_const(namesv);
3492 tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3494 if (tryname[0] == '.' && tryname[1] == '/')
3498 else if (errno == EMFILE)
3499 /* no point in trying other paths if out of handles */
3506 SAVECOPFILE_FREE(&PL_compiling);
3507 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3508 SvREFCNT_dec(namesv);
3510 if (PL_op->op_type == OP_REQUIRE) {
3511 const char *msgstr = name;
3512 if(errno == EMFILE) {
3514 = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr,
3516 msgstr = SvPV_nolen_const(msg);
3518 if (namesv) { /* did we lookup @INC? */
3519 AV * const ar = GvAVn(PL_incgv);
3521 SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3522 "%s in @INC%s%s (@INC contains:",
3524 (instr(msgstr, ".h ")
3525 ? " (change .h to .ph maybe?)" : ""),
3526 (instr(msgstr, ".ph ")
3527 ? " (did you run h2ph?)" : "")
3530 for (i = 0; i <= AvFILL(ar); i++) {
3531 sv_catpvs(msg, " ");
3532 sv_catsv(msg, *av_fetch(ar, i, TRUE));
3534 sv_catpvs(msg, ")");
3535 msgstr = SvPV_nolen_const(msg);
3538 DIE(aTHX_ "Can't locate %s", msgstr);
3544 SETERRNO(0, SS_NORMAL);
3546 /* Assume success here to prevent recursive requirement. */
3547 /* name is never assigned to again, so len is still strlen(name) */
3548 /* Check whether a hook in @INC has already filled %INC */
3550 (void)hv_store(GvHVn(PL_incgv),
3551 unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3553 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3555 (void)hv_store(GvHVn(PL_incgv),
3556 unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3561 lex_start(NULL, tryrsfp, TRUE);
3565 if (PL_compiling.cop_hints_hash) {
3566 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3567 PL_compiling.cop_hints_hash = NULL;
3570 SAVECOMPILEWARNINGS();
3571 if (PL_dowarn & G_WARN_ALL_ON)
3572 PL_compiling.cop_warnings = pWARN_ALL ;
3573 else if (PL_dowarn & G_WARN_ALL_OFF)
3574 PL_compiling.cop_warnings = pWARN_NONE ;
3576 PL_compiling.cop_warnings = pWARN_STD ;
3578 if (filter_sub || filter_cache) {
3579 SV * const datasv = filter_add(S_run_user_filter, NULL);
3580 IoLINES(datasv) = filter_has_file;
3581 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3582 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3583 IoFMT_GV(datasv) = MUTABLE_GV(filter_cache);
3586 /* switch to eval mode */
3587 PUSHBLOCK(cx, CXt_EVAL, SP);
3589 cx->blk_eval.retop = PL_op->op_next;
3591 SAVECOPLINE(&PL_compiling);
3592 CopLINE_set(&PL_compiling, 0);
3596 /* Store and reset encoding. */
3597 encoding = PL_encoding;
3600 if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3601 op = DOCATCH(PL_eval_start);
3603 op = PL_op->op_next;
3605 /* Restore encoding. */
3606 PL_encoding = encoding;
3611 /* This is a op added to hold the hints hash for
3612 pp_entereval. The hash can be modified by the code
3613 being eval'ed, so we return a copy instead. */
3619 mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3627 register PERL_CONTEXT *cx;
3629 const I32 gimme = GIMME_V;
3630 const U32 was = PL_breakable_sub_gen;
3631 char tbuf[TYPE_DIGITS(long) + 12];
3632 char *tmpbuf = tbuf;
3636 HV *saved_hh = NULL;
3638 if (PL_op->op_private & OPpEVAL_HAS_HH) {
3639 saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3643 TAINT_IF(SvTAINTED(sv));
3644 TAINT_PROPER("eval");
3647 lex_start(sv, NULL, FALSE);
3650 /* switch to eval mode */
3652 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3653 SV * const temp_sv = sv_newmortal();
3654 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3655 (unsigned long)++PL_evalseq,
3656 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3657 tmpbuf = SvPVX(temp_sv);
3658 len = SvCUR(temp_sv);
3661 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3662 SAVECOPFILE_FREE(&PL_compiling);
3663 CopFILE_set(&PL_compiling, tmpbuf+2);
3664 SAVECOPLINE(&PL_compiling);
3665 CopLINE_set(&PL_compiling, 1);
3666 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3667 deleting the eval's FILEGV from the stash before gv_check() runs
3668 (i.e. before run-time proper). To work around the coredump that
3669 ensues, we always turn GvMULTI_on for any globals that were
3670 introduced within evals. See force_ident(). GSAR 96-10-12 */
3672 PL_hints = PL_op->op_targ;
3674 GvHV(PL_hintgv) = saved_hh;
3675 SAVECOMPILEWARNINGS();
3676 PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3677 if (PL_compiling.cop_hints_hash) {
3678 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3680 PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3681 if (PL_compiling.cop_hints_hash) {
3683 PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3684 HINTS_REFCNT_UNLOCK;
3686 /* special case: an eval '' executed within the DB package gets lexically
3687 * placed in the first non-DB CV rather than the current CV - this
3688 * allows the debugger to execute code, find lexicals etc, in the
3689 * scope of the code being debugged. Passing &seq gets find_runcv
3690 * to do the dirty work for us */
3691 runcv = find_runcv(&seq);
3693 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3695 cx->blk_eval.retop = PL_op->op_next;
3697 /* prepare to compile string */
3699 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3700 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3703 if (doeval(gimme, NULL, runcv, seq)) {
3704 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3705 ? (PERLDB_LINE || PERLDB_SAVESRC)
3706 : PERLDB_SAVESRC_NOSUBS) {
3707 /* Retain the filegv we created. */
3709 char *const safestr = savepvn(tmpbuf, len);
3710 SAVEDELETE(PL_defstash, safestr, len);
3712 return DOCATCH(PL_eval_start);
3714 /* We have already left the scope set up earler thanks to the LEAVE
3716 if (was != PL_breakable_sub_gen /* Some subs defined here. */
3717 ? (PERLDB_LINE || PERLDB_SAVESRC)
3718 : PERLDB_SAVESRC_INVALID) {
3719 /* Retain the filegv we created. */
3721 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3723 return PL_op->op_next;
3734 register PERL_CONTEXT *cx;
3736 const U8 save_flags = PL_op -> op_flags;
3741 retop = cx->blk_eval.retop;
3744 if (gimme == G_VOID)
3746 else if (gimme == G_SCALAR) {
3749 if (SvFLAGS(TOPs) & SVs_TEMP)
3752 *MARK = sv_mortalcopy(TOPs);
3756 *MARK = &PL_sv_undef;
3761 /* in case LEAVE wipes old return values */
3762 for (mark = newsp + 1; mark <= SP; mark++) {
3763 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3764 *mark = sv_mortalcopy(*mark);
3765 TAINT_NOT; /* Each item is independent */
3769 PL_curpm = newpm; /* Don't pop $1 et al till now */
3772 assert(CvDEPTH(PL_compcv) == 1);
3774 CvDEPTH(PL_compcv) = 0;
3777 if (optype == OP_REQUIRE &&
3778 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3780 /* Unassume the success we assumed earlier. */
3781 SV * const nsv = cx->blk_eval.old_namesv;
3782 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3783 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3784 /* die_where() did LEAVE, or we won't be here */
3788 if (!(save_flags & OPf_SPECIAL)) {
3796 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3797 close to the related Perl_create_eval_scope. */
3799 Perl_delete_eval_scope(pTHX)
3804 register PERL_CONTEXT *cx;
3811 PERL_UNUSED_VAR(newsp);
3812 PERL_UNUSED_VAR(gimme);
3813 PERL_UNUSED_VAR(optype);
3816 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3817 also needed by Perl_fold_constants. */
3819 Perl_create_eval_scope(pTHX_ U32 flags)
3822 const I32 gimme = GIMME_V;
3827 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3830 PL_in_eval = EVAL_INEVAL;
3831 if (flags & G_KEEPERR)
3832 PL_in_eval |= EVAL_KEEPERR;
3835 if (flags & G_FAKINGEVAL) {
3836 PL_eval_root = PL_op; /* Only needed so that goto works right. */
3844 PERL_CONTEXT * const cx = create_eval_scope(0);
3845 cx->blk_eval.retop = cLOGOP->op_other->op_next;
3846 return DOCATCH(PL_op->op_next);
3855 register PERL_CONTEXT *cx;
3860 PERL_UNUSED_VAR(optype);
3863 if (gimme == G_VOID)
3865 else if (gimme == G_SCALAR) {
3869 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3872 *MARK = sv_mortalcopy(TOPs);
3876 *MARK = &PL_sv_undef;
3881 /* in case LEAVE wipes old return values */
3883 for (mark = newsp + 1; mark <= SP; mark++) {
3884 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3885 *mark = sv_mortalcopy(*mark);
3886 TAINT_NOT; /* Each item is independent */
3890 PL_curpm = newpm; /* Don't pop $1 et al till now */
3900 register PERL_CONTEXT *cx;
3901 const I32 gimme = GIMME_V;
3906 if (PL_op->op_targ == 0) {
3907 SV ** const defsv_p = &GvSV(PL_defgv);
3908 *defsv_p = newSVsv(POPs);
3909 SAVECLEARSV(*defsv_p);
3912 sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3914 PUSHBLOCK(cx, CXt_GIVEN, SP);
3923 register PERL_CONTEXT *cx;
3927 PERL_UNUSED_CONTEXT;
3930 assert(CxTYPE(cx) == CXt_GIVEN);
3935 PL_curpm = newpm; /* pop $1 et al */
3942 /* Helper routines used by pp_smartmatch */
3944 S_make_matcher(pTHX_ REGEXP *re)
3947 PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3949 PERL_ARGS_ASSERT_MAKE_MATCHER;
3951 PM_SETRE(matcher, ReREFCNT_inc(re));
3953 SAVEFREEOP((OP *) matcher);
3960 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3965 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
3967 PL_op = (OP *) matcher;
3972 return (SvTRUEx(POPs));
3976 S_destroy_matcher(pTHX_ PMOP *matcher)
3980 PERL_ARGS_ASSERT_DESTROY_MATCHER;
3981 PERL_UNUSED_ARG(matcher);
3987 /* Do a smart match */
3990 return do_smartmatch(NULL, NULL);
3993 /* This version of do_smartmatch() implements the
3994 * table of smart matches that is found in perlsyn.
3997 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4002 SV *e = TOPs; /* e is for 'expression' */
4003 SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4004 SV *This, *Other; /* 'This' (and Other to match) to play with C++ */
4005 REGEXP *this_regex, *other_regex;
4007 # define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
4009 # define SM_REF(type) ( \
4010 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
4011 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
4013 # define SM_CV_NEP /* Find a code ref without an empty prototype */ \
4014 ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV) \
4015 && NOT_EMPTY_PROTO(This) && (Other = e)) \
4016 || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV) \
4017 && NOT_EMPTY_PROTO(This) && (Other = d)))
4019 # define SM_REGEX ( \
4020 (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \
4021 && (this_regex = (REGEXP*) This) \
4024 (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \
4025 && (this_regex = (REGEXP*) This) \
4029 # define SM_OBJECT ( \
4030 (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) \
4032 (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) ) \
4034 # define SM_OTHER_REF(type) \
4035 (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
4037 # define SM_OTHER_REGEX (SvROK(Other) \
4038 && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \
4039 && (other_regex = (REGEXP*) SvRV(Other)))
4042 # define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
4043 sv_2mortal(newSViv(PTR2IV(sv))), 0)
4045 # define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
4046 sv_2mortal(newSViv(PTR2IV(sv))), 0)
4048 tryAMAGICbinSET(smart, 0);
4050 SP -= 2; /* Pop the values */
4052 /* Take care only to invoke mg_get() once for each argument.
4053 * Currently we do this by copying the SV if it's magical. */
4056 d = sv_mortalcopy(d);
4063 e = sv_mortalcopy(e);
4066 if (!SvOK(d) || !SvOK(e))
4069 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4075 if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
4077 if (This == SvRV(Other))
4088 c = call_sv(This, G_SCALAR);
4092 else if (SvTEMP(TOPs))
4093 SvREFCNT_inc_void(TOPs);
4098 else if (SM_REF(PVHV)) {
4099 if (SM_OTHER_REF(PVHV)) {
4100 /* Check that the key-sets are identical */
4102 HV *other_hv = MUTABLE_HV(SvRV(Other));
4104 bool other_tied = FALSE;
4105 U32 this_key_count = 0,
4106 other_key_count = 0;
4108 /* Tied hashes don't know how many keys they have. */
4109 if (SvTIED_mg(This, PERL_MAGIC_tied)) {
4112 else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4113 HV * const temp = other_hv;
4114 other_hv = MUTABLE_HV(This);
4115 This = MUTABLE_SV(temp);
4118 if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4121 if (!tied && HvUSEDKEYS((const HV *) This) != HvUSEDKEYS(other_hv))
4124 /* The hashes have the same number of keys, so it suffices
4125 to check that one is a subset of the other. */
4126 (void) hv_iterinit(MUTABLE_HV(This));
4127 while ( (he = hv_iternext(MUTABLE_HV(This))) ) {
4129 char * const key = hv_iterkey(he, &key_len);
4133 if(!hv_exists(other_hv, key, key_len)) {
4134 (void) hv_iterinit(MUTABLE_HV(This)); /* reset iterator */
4140 (void) hv_iterinit(other_hv);
4141 while ( hv_iternext(other_hv) )
4145 other_key_count = HvUSEDKEYS(other_hv);
4147 if (this_key_count != other_key_count)
4152 else if (SM_OTHER_REF(PVAV)) {
4153 AV * const other_av = MUTABLE_AV(SvRV(Other));
4154 const I32 other_len = av_len(other_av) + 1;
4157 for (i = 0; i < other_len; ++i) {
4158 SV ** const svp = av_fetch(other_av, i, FALSE);
4162 if (svp) { /* ??? When can this not happen? */
4163 key = SvPV(*svp, key_len);
4164 if (hv_exists(MUTABLE_HV(This), key, key_len))
4170 else if (SM_OTHER_REGEX) {
4171 PMOP * const matcher = make_matcher(other_regex);
4174 (void) hv_iterinit(MUTABLE_HV(This));
4175 while ( (he = hv_iternext(MUTABLE_HV(This))) ) {
4176 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4177 (void) hv_iterinit(MUTABLE_HV(This));
4178 destroy_matcher(matcher);
4182 destroy_matcher(matcher);
4186 if (hv_exists_ent(MUTABLE_HV(This), Other, 0))
4192 else if (SM_REF(PVAV)) {
4193 if (SM_OTHER_REF(PVAV)) {
4194 AV *other_av = MUTABLE_AV(SvRV(Other));
4195 if (av_len(MUTABLE_AV(This)) != av_len(other_av))
4199 const I32 other_len = av_len(other_av);
4201 if (NULL == seen_this) {
4202 seen_this = newHV();
4203 (void) sv_2mortal(MUTABLE_SV(seen_this));
4205 if (NULL == seen_other) {
4206 seen_this = newHV();
4207 (void) sv_2mortal(MUTABLE_SV(seen_other));
4209 for(i = 0; i <= other_len; ++i) {
4210 SV * const * const this_elem = av_fetch(MUTABLE_AV(This), i, FALSE);
4211 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4213 if (!this_elem || !other_elem) {
4214 if (this_elem || other_elem)
4217 else if (SM_SEEN_THIS(*this_elem)
4218 || SM_SEEN_OTHER(*other_elem))
4220 if (*this_elem != *other_elem)
4224 (void)hv_store_ent(seen_this,
4225 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4227 (void)hv_store_ent(seen_other,
4228 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4234 (void) do_smartmatch(seen_this, seen_other);
4244 else if (SM_OTHER_REGEX) {
4245 PMOP * const matcher = make_matcher(other_regex);
4246 const I32 this_len = av_len(MUTABLE_AV(This));
4249 for(i = 0; i <= this_len; ++i) {
4250 SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
4251 if (svp && matcher_matches_sv(matcher, *svp)) {
4252 destroy_matcher(matcher);
4256 destroy_matcher(matcher);
4259 else if (SvIOK(Other) || SvNOK(Other)) {
4262 for(i = 0; i <= AvFILL(MUTABLE_AV(This)); ++i) {
4263 SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
4270 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4280 else if (SvPOK(Other)) {
4281 const I32 this_len = av_len(MUTABLE_AV(This));
4284 for(i = 0; i <= this_len; ++i) {
4285 SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
4300 else if (!SvOK(d) || !SvOK(e)) {
4301 if (!SvOK(d) && !SvOK(e))
4306 else if (SM_REGEX) {
4307 PMOP * const matcher = make_matcher(this_regex);
4310 PUSHs(matcher_matches_sv(matcher, Other)
4313 destroy_matcher(matcher);
4316 else if (SM_REF(PVCV)) {
4318 /* This must be a null-prototyped sub, because we
4319 already checked for the other kind. */
4325 c = call_sv(This, G_SCALAR);
4328 PUSHs(&PL_sv_undef);
4329 else if (SvTEMP(TOPs))
4330 SvREFCNT_inc_void(TOPs);
4332 if (SM_OTHER_REF(PVCV)) {
4333 /* This one has to be null-proto'd too.
4334 Call both of 'em, and compare the results */
4336 c = call_sv(SvRV(Other), G_SCALAR);
4339 PUSHs(&PL_sv_undef);
4340 else if (SvTEMP(TOPs))
4341 SvREFCNT_inc_void(TOPs);
4352 else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4353 || ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4355 if (SvPOK(Other) && !looks_like_number(Other)) {
4356 /* String comparison */
4361 /* Otherwise, numeric comparison */
4364 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4375 /* As a last resort, use string comparison */
4384 register PERL_CONTEXT *cx;
4385 const I32 gimme = GIMME_V;
4387 /* This is essentially an optimization: if the match
4388 fails, we don't want to push a context and then
4389 pop it again right away, so we skip straight
4390 to the op that follows the leavewhen.
4392 if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4393 return cLOGOP->op_other->op_next;
4398 PUSHBLOCK(cx, CXt_WHEN, SP);
4407 register PERL_CONTEXT *cx;
4413 assert(CxTYPE(cx) == CXt_WHEN);
4418 PL_curpm = newpm; /* pop $1 et al */
4428 register PERL_CONTEXT *cx;
4431 cxix = dopoptowhen(cxstack_ix);
4433 DIE(aTHX_ "Can't \"continue\" outside a when block");
4434 if (cxix < cxstack_ix)
4437 /* clear off anything above the scope we're re-entering */
4438 inner = PL_scopestack_ix;
4440 if (PL_scopestack_ix < inner)
4441 leave_scope(PL_scopestack[PL_scopestack_ix]);
4442 PL_curcop = cx->blk_oldcop;
4443 return cx->blk_givwhen.leave_op;
4450 register PERL_CONTEXT *cx;
4453 cxix = dopoptogiven(cxstack_ix);
4455 if (PL_op->op_flags & OPf_SPECIAL)
4456 DIE(aTHX_ "Can't use when() outside a topicalizer");
4458 DIE(aTHX_ "Can't \"break\" outside a given block");
4460 if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4461 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4463 if (cxix < cxstack_ix)
4466 /* clear off anything above the scope we're re-entering */
4467 inner = PL_scopestack_ix;
4469 if (PL_scopestack_ix < inner)
4470 leave_scope(PL_scopestack[PL_scopestack_ix]);
4471 PL_curcop = cx->blk_oldcop;
4474 return CX_LOOP_NEXTOP_GET(cx);
4476 return cx->blk_givwhen.leave_op;
4480 S_doparseform(pTHX_ SV *sv)
4483 register char *s = SvPV_force(sv, len);
4484 register char * const send = s + len;
4485 register char *base = NULL;
4486 register I32 skipspaces = 0;
4487 bool noblank = FALSE;
4488 bool repeat = FALSE;
4489 bool postspace = FALSE;
4495 bool unchopnum = FALSE;
4496 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4498 PERL_ARGS_ASSERT_DOPARSEFORM;
4501 Perl_croak(aTHX_ "Null picture in formline");
4503 /* estimate the buffer size needed */
4504 for (base = s; s <= send; s++) {
4505 if (*s == '\n' || *s == '@' || *s == '^')
4511 Newx(fops, maxops, U32);
4516 *fpc++ = FF_LINEMARK;
4517 noblank = repeat = FALSE;
4535 case ' ': case '\t':
4542 } /* else FALL THROUGH */
4550 *fpc++ = FF_LITERAL;
4558 *fpc++ = (U16)skipspaces;
4562 *fpc++ = FF_NEWLINE;
4566 arg = fpc - linepc + 1;
4573 *fpc++ = FF_LINEMARK;
4574 noblank = repeat = FALSE;
4583 ischop = s[-1] == '^';
4589 arg = (s - base) - 1;
4591 *fpc++ = FF_LITERAL;
4599 *fpc++ = 2; /* skip the @* or ^* */
4601 *fpc++ = FF_LINESNGL;
4604 *fpc++ = FF_LINEGLOB;
4606 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4607 arg = ischop ? 512 : 0;
4612 const char * const f = ++s;
4615 arg |= 256 + (s - f);
4617 *fpc++ = s - base; /* fieldsize for FETCH */
4618 *fpc++ = FF_DECIMAL;
4620 unchopnum |= ! ischop;
4622 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
4623 arg = ischop ? 512 : 0;
4625 s++; /* skip the '0' first */
4629 const char * const f = ++s;
4632 arg |= 256 + (s - f);
4634 *fpc++ = s - base; /* fieldsize for FETCH */
4635 *fpc++ = FF_0DECIMAL;
4637 unchopnum |= ! ischop;
4641 bool ismore = FALSE;
4644 while (*++s == '>') ;
4645 prespace = FF_SPACE;
4647 else if (*s == '|') {
4648 while (*++s == '|') ;
4649 prespace = FF_HALFSPACE;
4654 while (*++s == '<') ;
4657 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4661 *fpc++ = s - base; /* fieldsize for FETCH */
4663 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4666 *fpc++ = (U16)prespace;
4680 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4682 { /* need to jump to the next word */
4684 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4685 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4686 s = SvPVX(sv) + SvCUR(sv) + z;
4688 Copy(fops, s, arg, U32);
4690 sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4693 if (unchopnum && repeat)
4694 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4700 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4702 /* Can value be printed in fldsize chars, using %*.*f ? */
4706 int intsize = fldsize - (value < 0 ? 1 : 0);
4713 while (intsize--) pwr *= 10.0;
4714 while (frcsize--) eps /= 10.0;
4717 if (value + eps >= pwr)
4720 if (value - eps <= -pwr)
4727 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4730 SV * const datasv = FILTER_DATA(idx);
4731 const int filter_has_file = IoLINES(datasv);
4732 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4733 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4737 const char *got_p = NULL;
4738 const char *prune_from = NULL;
4739 bool read_from_cache = FALSE;
4742 PERL_ARGS_ASSERT_RUN_USER_FILTER;
4744 assert(maxlen >= 0);
4747 /* I was having segfault trouble under Linux 2.2.5 after a
4748 parse error occured. (Had to hack around it with a test
4749 for PL_parser->error_count == 0.) Solaris doesn't segfault --
4750 not sure where the trouble is yet. XXX */
4752 if (IoFMT_GV(datasv)) {
4753 SV *const cache = MUTABLE_SV(IoFMT_GV(datasv));
4756 const char *cache_p = SvPV(cache, cache_len);
4760 /* Running in block mode and we have some cached data already.
4762 if (cache_len >= umaxlen) {
4763 /* In fact, so much data we don't even need to call
4768 const char *const first_nl =
4769 (const char *)memchr(cache_p, '\n', cache_len);
4771 take = first_nl + 1 - cache_p;
4775 sv_catpvn(buf_sv, cache_p, take);
4776 sv_chop(cache, cache_p + take);
4777 /* Definately not EOF */
4781 sv_catsv(buf_sv, cache);
4783 umaxlen -= cache_len;
4786 read_from_cache = TRUE;
4790 /* Filter API says that the filter appends to the contents of the buffer.
4791 Usually the buffer is "", so the details don't matter. But if it's not,
4792 then clearly what it contains is already filtered by this filter, so we
4793 don't want to pass it in a second time.
4794 I'm going to use a mortal in case the upstream filter croaks. */
4795 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4796 ? sv_newmortal() : buf_sv;
4797 SvUPGRADE(upstream, SVt_PV);
4799 if (filter_has_file) {
4800 status = FILTER_READ(idx+1, upstream, 0);
4803 if (filter_sub && status >= 0) {
4812 DEFSV_set(upstream);
4816 PUSHs(filter_state);
4819 count = call_sv(filter_sub, G_SCALAR);
4834 if(SvOK(upstream)) {
4835 got_p = SvPV(upstream, got_len);
4837 if (got_len > umaxlen) {
4838 prune_from = got_p + umaxlen;
4841 const char *const first_nl =
4842 (const char *)memchr(got_p, '\n', got_len);
4843 if (first_nl && first_nl + 1 < got_p + got_len) {
4844 /* There's a second line here... */
4845 prune_from = first_nl + 1;
4850 /* Oh. Too long. Stuff some in our cache. */
4851 STRLEN cached_len = got_p + got_len - prune_from;
4852 SV *cache = MUTABLE_SV(IoFMT_GV(datasv));
4855 IoFMT_GV(datasv) = MUTABLE_GV((cache = newSV(got_len - umaxlen)));
4856 } else if (SvOK(cache)) {
4857 /* Cache should be empty. */
4858 assert(!SvCUR(cache));
4861 sv_setpvn(cache, prune_from, cached_len);
4862 /* If you ask for block mode, you may well split UTF-8 characters.
4863 "If it breaks, you get to keep both parts"
4864 (Your code is broken if you don't put them back together again
4865 before something notices.) */
4866 if (SvUTF8(upstream)) {
4869 SvCUR_set(upstream, got_len - cached_len);
4870 /* Can't yet be EOF */
4875 /* If they are at EOF but buf_sv has something in it, then they may never
4876 have touched the SV upstream, so it may be undefined. If we naively
4877 concatenate it then we get a warning about use of uninitialised value.
4879 if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4880 sv_catsv(buf_sv, upstream);
4884 IoLINES(datasv) = 0;
4885 SvREFCNT_dec(IoFMT_GV(datasv));
4887 SvREFCNT_dec(filter_state);
4888 IoTOP_GV(datasv) = NULL;
4891 SvREFCNT_dec(filter_sub);
4892 IoBOTTOM_GV(datasv) = NULL;
4894 filter_del(S_run_user_filter);
4896 if (status == 0 && read_from_cache) {
4897 /* If we read some data from the cache (and by getting here it implies
4898 that we emptied the cache) then we aren't yet at EOF, and mustn't
4899 report that to our caller. */
4905 /* perhaps someone can come up with a better name for
4906 this? it is not really "absolute", per se ... */
4908 S_path_is_absolute(const char *name)
4910 PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
4912 if (PERL_FILE_IS_ABSOLUTE(name)
4913 || (*name == '.' && (name[1] == '/' ||
4914 (name[1] == '.' && name[2] == '/')))
4925 * c-indentation-style: bsd
4927 * indent-tabs-mode: t
4930 * ex: set ts=8 sts=4 sw=4 noet: