File Coverage

pp_ctl.c
Criterion Covered Total %
statement 2393 2520 95.0
branch 2461 3402 72.3
condition n/a
subroutine n/a
total 4854 5922 82.0


line stmt bran cond sub time code
1           /* pp_ctl.c
2           *
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
5           *
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.
8           *
9           */
10            
11           /*
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.
18           *
19           * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
20           */
21            
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.
27           *
28           * Control-oriented means things like pp_enteriter() and pp_next(), which
29           * alter the flow of control of the program.
30           */
31            
32            
33           #include "EXTERN.h"
34           #define PERL_IN_PP_CTL_C
35           #include "perl.h"
36            
37           #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
38            
39           #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
40            
41 5278598         PP(pp_wantarray)
42 5278598 50       {
43           dVAR;
44 5278598         dSP;
45           I32 cxix;
46           const PERL_CONTEXT *cx;
47 2639299         EXTEND(SP, 1);
48            
49 5278598 100       if (PL_op->op_private & OPpOFFBYONE) {
50 16 100       if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
51           }
52           else {
53 5278582         cxix = dopoptosub(cxstack_ix);
54 5278582 100       if (cxix < 0)
55 6         RETPUSHUNDEF;
56 5278576         cx = &cxstack[cxix];
57           }
58            
59 5278588         switch (cx->blk_gimme) {
60           case G_ARRAY:
61 1226564         RETPUSHYES;
62           case G_SCALAR:
63 3003162         RETPUSHNO;
64           default:
65 3163730         RETPUSHUNDEF;
66           }
67           }
68            
69 52556         PP(pp_regcreset)
70           {
71           dVAR;
72 52556         TAINT_NOT;
73 52556         return NORMAL;
74           }
75            
76 22326134         PP(pp_regcomp)
77           {
78           dVAR;
79 22326134         dSP;
80 22326134         PMOP *pm = (PMOP*)cLOGOP->op_other;
81           SV **args;
82           int nargs;
83           REGEXP *re = NULL;
84           REGEXP *new_re;
85           const regexp_engine *eng;
86 22326134         bool is_bare_re= FALSE;
87            
88 22326134 100       if (PL_op->op_flags & OPf_STACKED) {
89 7430889         dMARK;
90 7430889         nargs = SP - MARK;
91 7430889         args = ++MARK;
92           }
93           else {
94           nargs = 1;
95           args = SP;
96           }
97            
98           /* prevent recompiling under /o and ithreads. */
99           #if defined(USE_ITHREADS)
100           if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
101           SP = args-1;
102           RETURN;
103           }
104           #endif
105            
106 22326134         re = PM_GETRE(pm);
107           assert (re != (REGEXP*) &PL_sv_undef);
108 33067953 100       eng = re ? RX_ENGINE(re) : current_re_engine();
109            
110           /*
111           In the below logic: these are basically the same - check if this regcomp is part of a split.
112            
113           (PL_op->op_pmflags & PMf_split )
114           (PL_op->op_next->op_type == OP_PUSHRE)
115            
116           We could add a new mask for this and copy the PMf_split, if we did
117           some bit definition fiddling first.
118            
119           For now we leave this
120           */
121            
122 33292981         new_re = (eng->op_comp
123           ? eng->op_comp
124 22326134 50       : &Perl_re_op_compile
125 33292981 100       )(aTHX_ args, nargs, pm->op_code_list, eng, re,
126           &is_bare_re,
127 22326134         (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
128 22326134         pm->op_pmflags |
129 22326134         (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
130            
131 22323860 100       if (pm->op_pmflags & PMf_HAS_CV)
132           ReANY(new_re)->qr_anoncv
133 12         = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
134            
135 22323860 100       if (is_bare_re) {
136           REGEXP *tmp;
137           /* The match's LHS's get-magic might need to access this op's regexp
138           (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
139           get-magic now before we replace the regexp. Hopefully this hack can
140           be replaced with the approach described at
141           http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
142           some day. */
143 26359798 100       if (pm->op_type == OP_MATCH) {
    100        
144           SV *lhs;
145 12931823         const bool was_tainted = TAINT_get;
146 12931823 100       if (pm->op_flags & OPf_STACKED)
147 10808297         lhs = args[-1];
148 2123526 100       else if (pm->op_private & OPpTARGET_MY)
149 8         lhs = PAD_SV(pm->op_targ);
150 2123518 50       else lhs = DEFSV;
151 6277835         SvGETMAGIC(lhs);
152           /* Restore the previous value of PL_tainted (which may have been
153           modified by get-magic), to avoid incorrectly setting the
154           RXf_TAINTED flag with RX_TAINT_on further down. */
155 12931823         TAINT_set(was_tainted);
156           #if NO_TAINT_SUPPORT
157           PERL_UNUSED_VAR(was_tainted);
158           #endif
159           }
160 13427975         tmp = reg_temp_copy(NULL, new_re);
161 13427975         ReREFCNT_dec(new_re);
162           new_re = tmp;
163           }
164            
165 22323860 100       if (re != new_re) {
166 17407710         ReREFCNT_dec(re);
167 17407710         PM_SETRE(pm, new_re);
168           }
169            
170            
171           #ifndef INCOMPLETE_TAINTS
172 22323860 100       if (TAINTING_get && TAINT_get) {
    100        
173 17596 50       SvTAINTED_on((SV*)new_re);
174 17596         RX_TAINT_on(new_re);
175           }
176           #endif
177            
178           #if !defined(USE_ITHREADS)
179           /* can't change the optree at runtime either */
180           /* PMf_KEEP is handled differently under threads to avoid these problems */
181 33289570 100       if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
    100        
182 34         pm = PL_curpm;
183 22323860 100       if (pm->op_pmflags & PMf_KEEP) {
184 4212         pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
185 4212         cLOGOP->op_first->op_next = PL_op->op_next;
186           }
187           #endif
188            
189 22323860         SP = args-1;
190 22323860         RETURN;
191           }
192            
193            
194 12964146         PP(pp_substcont)
195           {
196           dVAR;
197 12964146         dSP;
198 12964146         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
199 12964146         PMOP * const pm = (PMOP*) cLOGOP->op_other;
200 12964146         SV * const dstr = cx->sb_dstr;
201 12964146         char *s = cx->sb_s;
202 12964146         char *m = cx->sb_m;
203 12964146         char *orig = cx->sb_orig;
204 12964146         REGEXP * const rx = cx->sb_rx;
205           SV *nsv = NULL;
206 12964146         REGEXP *old = PM_GETRE(pm);
207            
208 12964146 50       PERL_ASYNC_CHECK();
209            
210 12964146 100       if(old != rx) {
211 22 50       if(old)
212 22         ReREFCNT_dec(old);
213 22         PM_SETRE(pm,ReREFCNT_inc(rx));
214           }
215            
216 12964146         rxres_restore(&cx->sb_rxres, rx);
217            
218 24614865 100       if (cx->sb_iters++) {
    100        
219 11650719         const I32 saviters = cx->sb_iters;
220 11650719 50       if (cx->sb_iters > cx->sb_maxiters)
221 0         DIE(aTHX_ "Substitution loop");
222            
223 15087920         SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
224            
225           /* See "how taint works" above pp_subst() */
226 11650719 100       if (SvTAINTED(TOPs))
    50        
227 0         cx->sb_rxtainted |= SUBST_TAINT_REPL;
228 11650719         sv_catsv_nomg(dstr, POPs);
229 23019961         if (CxONCE(cx) || s < orig ||
230 11369242         !CALLREGEXEC(rx, s, cx->sb_strend, orig,
231           (s == m), cx->sb_targ, NULL,
232           (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
233           {
234 1313419         SV *targ = cx->sb_targ;
235            
236           assert(cx->sb_strend >= s);
237 1313419 100       if(cx->sb_strend > s) {
238 822593 100       if (DO_UTF8(dstr) && !SvUTF8(targ))
    50        
    100        
239 78         sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
240           else
241 822515         sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
242           }
243 1313419 100       if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
244 30         cx->sb_rxtainted |= SUBST_TAINT_PAT;
245            
246 1313419 100       if (pm->op_pmflags & PMf_NONDESTRUCT) {
247 1904         PUSHs(dstr);
248           /* From here on down we're using the copy, and leaving the
249           original untouched. */
250           targ = dstr;
251           }
252           else {
253 1311515 100       SV_CHECK_THINKFIRST_COW_DROP(targ);
254 1311511 100       if (isGV(targ)) Perl_croak_no_modify();
255 1311507 100       SvPV_free(targ);
    100        
    50        
    50        
256 1311507         SvPV_set(targ, SvPVX(dstr));
257 1311507         SvCUR_set(targ, SvCUR(dstr));
258 1311507         SvLEN_set(targ, SvLEN(dstr));
259 1311507 100       if (DO_UTF8(dstr))
    50        
260 9026         SvUTF8_on(targ);
261 1311507         SvPV_set(dstr, NULL);
262            
263 1311507         PL_tainted = 0;
264 1311507         mPUSHi(saviters - 1);
265            
266 1311507         (void)SvPOK_only_UTF8(targ);
267           }
268            
269           /* update the taint state of various various variables in
270           * preparation for final exit.
271           * See "how taint works" above pp_subst() */
272 1313411 50       if (TAINTING_get) {
273 0 0       if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
    0        
274 0         ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
275           == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
276           )
277 0         (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
278            
279 0 0       if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
280 0 0       && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
281           )
282 0 0       SvTAINTED_on(TOPs); /* taint return value */
283           /* needed for mg_set below */
284 0         TAINT_set(
285           cBOOL(cx->sb_rxtainted &
286           (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
287           );
288 0 0       SvTAINT(TARG);
    0        
    0        
289           }
290           /* PL_tainted must be correctly set for this mg_set */
291 1313411 50       SvSETMAGIC(TARG);
292 1313411         TAINT_NOT;
293 1313411 100       LEAVE_SCOPE(cx->sb_oldsave);
294 1313411         POPSUBST(cx);
295 1313411 50       PERL_ASYNC_CHECK();
296 1313411         RETURNOP(pm->op_next);
297           assert(0); /* NOTREACHED */
298           }
299 10337300         cx->sb_iters = saviters;
300           }
301 11667184 100       if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
    100        
302           m = s;
303           s = orig;
304           assert(!RX_SUBOFFSET(rx));
305 6670         cx->sb_orig = orig = RX_SUBBEG(rx);
306 6670         s = orig + (m - s);
307 6670         cx->sb_strend = s + (cx->sb_strend - m);
308           }
309 11650727         cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
310 11650727 100       if (m > s) {
311 726136 100       if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
    50        
    100        
312 6         sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
313           else
314 726130         sv_catpvn_nomg(dstr, s, m-s);
315           }
316 11650727         cx->sb_s = RX_OFFS(rx)[0].end + orig;
317           { /* Update the pos() information. */
318           SV * const sv
319 11650727 100       = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
320           MAGIC *mg;
321 11650727 100       if (!(mg = mg_find_mglob(sv))) {
322 729267         mg = sv_magicext_mglob(sv);
323           }
324           assert(SvPOK(dstr));
325 11650727 100       MgBYTEPOS_set(mg, sv, SvPVX(dstr), m - orig);
    50        
    0        
326           }
327 11650727 100       if (old != rx)
328           (void)ReREFCNT_inc(rx);
329           /* update the taint state of various various variables in preparation
330           * for calling the code block.
331           * See "how taint works" above pp_subst() */
332 11650727 50       if (TAINTING_get) {
333 0 0       if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
334 0         cx->sb_rxtainted |= SUBST_TAINT_PAT;
335            
336 0 0       if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
    0        
337 0         ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
338           == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
339           )
340 0         (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
341            
342 0 0       if (cx->sb_iters > 1 && (cx->sb_rxtainted &
    0        
343           (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
344 0 0       SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
    0        
345           ? cx->sb_dstr : cx->sb_targ);
346 0         TAINT_NOT;
347           }
348 11650727         rxres_save(&cx->sb_rxres, rx);
349 11650727         PL_curpm = pm;
350 12307612         RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
351           }
352            
353           void
354 12964154         Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
355           {
356 12964154         UV *p = (UV*)*rsp;
357           U32 i;
358            
359           PERL_ARGS_ASSERT_RXRES_SAVE;
360           PERL_UNUSED_CONTEXT;
361            
362 18789338 100       if (!p || p[1] < RX_NPARENS(rx)) {
    50        
363           #ifdef PERL_ANY_COW
364 1313427         i = 7 + (RX_NPARENS(rx)+1) * 2;
365           #else
366           i = 6 + (RX_NPARENS(rx)+1) * 2;
367           #endif
368 1313427 50       if (!p)
369 1313427 50       Newx(p, i, UV);
370           else
371 0 0       Renew(p, i, UV);
372 1313427         *rsp = (void*)p;
373           }
374            
375           /* what (if anything) to free on croak */
376 12983946 100       *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
377 12964154         RX_MATCH_COPIED_off(rx);
378 12964154         *p++ = RX_NPARENS(rx);
379            
380           #ifdef PERL_ANY_COW
381 12964154         *p++ = PTR2UV(RX_SAVED_COPY(rx));
382 12964154         RX_SAVED_COPY(rx) = NULL;
383           #endif
384            
385 12964154         *p++ = PTR2UV(RX_SUBBEG(rx));
386 12964154         *p++ = (UV)RX_SUBLEN(rx);
387 12964154         *p++ = (UV)RX_SUBOFFSET(rx);
388 12964154         *p++ = (UV)RX_SUBCOFFSET(rx);
389 60793705 100       for (i = 0; i <= RX_NPARENS(rx); ++i) {
390 27565940         *p++ = (UV)RX_OFFS(rx)[i].start;
391 27565940         *p++ = (UV)RX_OFFS(rx)[i].end;
392           }
393 12964154         }
394            
395           static void
396 12964146         S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
397           {
398 12964146         UV *p = (UV*)*rsp;
399           U32 i;
400            
401           PERL_ARGS_ASSERT_RXRES_RESTORE;
402           PERL_UNUSED_CONTEXT;
403            
404 19445884 100       RX_MATCH_COPY_FREE(rx);
    50        
    50        
405 19445860 100       RX_MATCH_COPIED_set(rx, *p);
406 12964146         *p++ = 0;
407 12964146         RX_NPARENS(rx) = *p++;
408            
409           #ifdef PERL_ANY_COW
410 12964146 100       if (RX_SAVED_COPY(rx))
411 24         SvREFCNT_dec (RX_SAVED_COPY(rx));
412 12964146         RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
413 12964146         *p++ = 0;
414           #endif
415            
416 12964146         RX_SUBBEG(rx) = INT2PTR(char*,*p++);
417 12964146         RX_SUBLEN(rx) = (I32)(*p++);
418 12964146         RX_SUBOFFSET(rx) = (I32)*p++;
419 12964146         RX_SUBCOFFSET(rx) = (I32)*p++;
420 60793675 100       for (i = 0; i <= RX_NPARENS(rx); ++i) {
421 27565928         RX_OFFS(rx)[i].start = (I32)(*p++);
422 27565928         RX_OFFS(rx)[i].end = (I32)(*p++);
423           }
424 12964146         }
425            
426           static void
427 1313427         S_rxres_free(pTHX_ void **rsp)
428           {
429 1313427         UV * const p = (UV*)*rsp;
430            
431           PERL_ARGS_ASSERT_RXRES_FREE;
432           PERL_UNUSED_CONTEXT;
433            
434 1313427 50       if (p) {
435 1313427         void *tmp = INT2PTR(char*,*p);
436           #ifdef PERL_POISON
437           #ifdef PERL_ANY_COW
438           U32 i = 9 + p[1] * 2;
439           #else
440           U32 i = 8 + p[1] * 2;
441           #endif
442           #endif
443            
444           #ifdef PERL_ANY_COW
445 1313427         SvREFCNT_dec (INT2PTR(SV*,p[2]));
446           #endif
447           #ifdef PERL_POISON
448           PoisonFree(p, i, sizeof(UV));
449           #endif
450            
451 1313427         Safefree(tmp);
452 1313427         Safefree(p);
453 1313427         *rsp = NULL;
454           }
455 1313427         }
456            
457           #define FORM_NUM_BLANK (1<<30)
458           #define FORM_NUM_POINT (1<<29)
459            
460 3336         PP(pp_formline)
461           {
462 3336         dVAR; dSP; dMARK; dORIGMARK;
463 3336         SV * const tmpForm = *++MARK;
464           SV *formsv; /* contains text of original format */
465           U32 *fpc; /* format ops program counter */
466           char *t; /* current append position in target string */
467           const char *f; /* current position in format string */
468           I32 arg;
469           SV *sv = NULL; /* current item */
470           const char *item = NULL;/* string value of current item */
471 3336         I32 itemsize = 0; /* length of current item, possibly truncated */
472           I32 fieldsize = 0; /* width of current field */
473           I32 lines = 0; /* number of lines that have been output */
474 3336         bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
475           const char *chophere = NULL; /* where to chop current item */
476           STRLEN linemark = 0; /* pos of start of line in output */
477           NV value;
478           bool gotsome = FALSE; /* seen at least one non-blank item on this line */
479           STRLEN len;
480           STRLEN linemax; /* estimate of output size in bytes */
481           bool item_is_utf8 = FALSE;
482           bool targ_is_utf8 = FALSE;
483           const char *fmt;
484           MAGIC *mg = NULL;
485           U8 *source; /* source of bytes to append */
486           STRLEN to_copy; /* how may bytes to append */
487           char trans; /* what chars to translate */
488            
489 3336         mg = doparseform(tmpForm);
490            
491 3330         fpc = (U32*)mg->mg_ptr;
492           /* the actual string the format was compiled from.
493           * with overload etc, this may not match tmpForm */
494 3330         formsv = mg->mg_obj;
495            
496            
497 3330 100       SvPV_force(PL_formtarget, len);
498 3330 50       if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
    50        
    50        
    0        
499 0 0       SvTAINTED_on(PL_formtarget);
500 3330 100       if (DO_UTF8(PL_formtarget))
    50        
501           targ_is_utf8 = TRUE;
502 3330 50       linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
503 3330 50       t = SvGROW(PL_formtarget, len + linemax + 1);
    100        
504           /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
505 3330         t += len;
506 3330 50       f = SvPV_const(formsv, len);
507            
508           for (;;) {
509           DEBUG_f( {
510           const char *name = "???";
511           arg = -1;
512           switch (*fpc) {
513           case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
514           case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
515           case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
516           case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
517           case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
518            
519           case FF_CHECKNL: name = "CHECKNL"; break;
520           case FF_CHECKCHOP: name = "CHECKCHOP"; break;
521           case FF_SPACE: name = "SPACE"; break;
522           case FF_HALFSPACE: name = "HALFSPACE"; break;
523           case FF_ITEM: name = "ITEM"; break;
524           case FF_CHOP: name = "CHOP"; break;
525           case FF_LINEGLOB: name = "LINEGLOB"; break;
526           case FF_NEWLINE: name = "NEWLINE"; break;
527           case FF_MORE: name = "MORE"; break;
528           case FF_LINEMARK: name = "LINEMARK"; break;
529           case FF_END: name = "END"; break;
530           case FF_0DECIMAL: name = "0DECIMAL"; break;
531           case FF_LINESNGL: name = "LINESNGL"; break;
532           }
533           if (arg >= 0)
534           PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
535           else
536           PerlIO_printf(Perl_debug_log, "%-16s\n", name);
537           } );
538 39834         switch (*fpc++) {
539           case FF_LINEMARK:
540 3404         linemark = t - SvPVX(PL_formtarget);
541 3404         lines++;
542           gotsome = FALSE;
543 3404         break;
544            
545           case FF_LITERAL:
546 5602         to_copy = *fpc++;
547           source = (U8 *)f;
548 5602         f += to_copy;
549           trans = '~';
550 5602 100       item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
    100        
    50        
551 5602         goto append;
552            
553           case FF_SKIP:
554 2198         f += *fpc++;
555 2198         break;
556            
557           case FF_FETCH:
558 5682         arg = *fpc++;
559 5682         f += arg;
560           fieldsize = arg;
561            
562 5682 100       if (MARK < SP)
563 5668         sv = *++MARK;
564           else {
565           sv = &PL_sv_no;
566 14         Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
567           }
568 5682 100       if (SvTAINTED(sv))
    50        
569 0 0       SvTAINTED_on(PL_formtarget);
570           break;
571            
572           case FF_CHECKNL:
573           {
574           const char *send;
575 592 100       const char *s = item = SvPV_const(sv, len);
576 592         itemsize = len;
577 592 100       if (DO_UTF8(sv)) {
    50        
578 4         itemsize = sv_len_utf8(sv);
579 4 50       if (itemsize != (I32)len) {
580           I32 itembytes;
581 4 50       if (itemsize > fieldsize) {
582 0         itemsize = fieldsize;
583 0         itembytes = itemsize;
584 0         sv_pos_u2b(sv, &itembytes, 0);
585           }
586           else
587 4         itembytes = len;
588 4         send = chophere = s + itembytes;
589 14 100       while (s < send) {
590 8 50       if (! isCNTRL(*s))
591           gotsome = TRUE;
592 0 0       else if (*s == '\n')
593           break;
594 8         s++;
595           }
596           item_is_utf8 = TRUE;
597 4         itemsize = s - item;
598 4         sv_pos_b2u(sv, &itemsize);
599 18254         break;
600           }
601           }
602           item_is_utf8 = FALSE;
603 588 100       if (itemsize > fieldsize)
604 72         itemsize = fieldsize;
605 588         send = chophere = s + itemsize;
606 2412 100       while (s < send) {
607 1542 100       if (! isCNTRL(*s))
608           gotsome = TRUE;
609 12 50       else if (*s == '\n')
610           break;
611 1530         s++;
612           }
613 588         itemsize = s - item;
614 588         break;
615           }
616            
617           case FF_CHECKCHOP:
618           {
619 3072 100       const char *s = item = SvPV_const(sv, len);
620 3072         itemsize = len;
621 3072 50       if (DO_UTF8(sv)) {
    0        
622 0         itemsize = sv_len_utf8(sv);
623 0 0       if (itemsize != (I32)len) {
624           I32 itembytes;
625 0 0       if (itemsize <= fieldsize) {
626 0         const char *send = chophere = s + itemsize;
627 0 0       while (s < send) {
628 0 0       if (*s == '\r') {
629 0         itemsize = s - item;
630           chophere = s;
631 0         break;
632           }
633 0 0       if (! isCNTRL(*s))
634           gotsome = TRUE;
635 0         s++;
636           }
637           }
638           else {
639           const char *send;
640 0         itemsize = fieldsize;
641 0         itembytes = itemsize;
642 0         sv_pos_u2b(sv, &itembytes, 0);
643 0         send = chophere = s + itembytes;
644 0 0       while (s < send || (s == send && isSPACE(*s))) {
    0        
    0        
645 0 0       if (isSPACE(*s)) {
646 0 0       if (chopspace)
647           chophere = s;
648 0 0       if (*s == '\r')
649           break;
650           }
651           else {
652 0 0       if (! isCNTRL(*s))
653           gotsome = TRUE;
654 0 0       if (strchr(PL_chopset, *s))
    0        
    0        
655 0         chophere = s + 1;
656           }
657 0         s++;
658           }
659 0         itemsize = chophere - item;
660 0         sv_pos_b2u(sv, &itemsize);
661           }
662           item_is_utf8 = TRUE;
663           break;
664           }
665           }
666           item_is_utf8 = FALSE;
667 3072 100       if (itemsize <= fieldsize) {
668 2858         const char *const send = chophere = s + itemsize;
669 15805 100       while (s < send) {
670 11522 100       if (*s == '\r') {
671 4         itemsize = s - item;
672           chophere = s;
673 4         break;
674           }
675 11518 50       if (! isCNTRL(*s))
676           gotsome = TRUE;
677 11518         s++;
678           }
679           }
680           else {
681           const char *send;
682 214         itemsize = fieldsize;
683 214         send = chophere = s + itemsize;
684 7987 100       while (s < send || (s == send && isSPACE(*s))) {
    100        
    100        
685 7666 100       if (isSPACE(*s)) {
686 1074 50       if (chopspace)
687           chophere = s;
688 1074 50       if (*s == '\r')
689           break;
690           }
691           else {
692 6592 50       if (! isCNTRL(*s))
693           gotsome = TRUE;
694 6592 50       if (strchr(PL_chopset, *s))
    0        
    100        
695 26         chophere = s + 1;
696           }
697 7666         s++;
698           }
699 214         itemsize = chophere - item;
700           }
701           break;
702           }
703            
704           case FF_SPACE:
705 2266         arg = fieldsize - itemsize;
706 2266 100       if (arg) {
707           fieldsize -= arg;
708 15004 100       while (arg-- > 0)
709 12816         *t++ = ' ';
710           }
711           break;
712            
713           case FF_HALFSPACE:
714 240         arg = fieldsize - itemsize;
715 240 50       if (arg) {
716 240         arg /= 2;
717 240         fieldsize -= arg;
718 636 100       while (arg-- > 0)
719 276         *t++ = ' ';
720           }
721           break;
722            
723           case FF_ITEM:
724 3664         to_copy = itemsize;
725           source = (U8 *)item;
726           trans = 1;
727 3664 100       if (item_is_utf8) {
728           /* convert to_copy from chars to bytes */
729           U8 *s = source;
730 8 100       while (to_copy--)
731 4         s += UTF8SKIP(s);
732 4         to_copy = s - source;
733           }
734           goto append;
735            
736           case FF_CHOP:
737           {
738           const char *s = chophere;
739 4544 100       if (chopspace) {
740 3296 100       while (isSPACE(*s))
741 224         s++;
742           }
743 4544         sv_chop(sv,s);
744 5280 100       SvSETMAGIC(sv);
745           break;
746           }
747            
748           case FF_LINESNGL:
749           chopspace = 0;
750           case FF_LINEGLOB:
751           {
752 1882         const bool oneline = fpc[-1] == FF_LINESNGL;
753 1882 100       const char *s = item = SvPV_const(sv, len);
754 1882         const char *const send = s + len;
755            
756 1882 100       item_is_utf8 = DO_UTF8(sv);
    50        
757 1882 100       if (!len)
758           break;
759           trans = 0;
760           gotsome = TRUE;
761 1680         chophere = s + len;
762           source = (U8 *) s;
763 1680         to_copy = len;
764 11230 100       while (s < send) {
765 9194 100       if (*s++ == '\n') {
766 990 100       if (oneline) {
767 484         to_copy = s - SvPVX_const(sv) - 1;
768           chophere = s;
769 484         break;
770           } else {
771 506 100       if (s == send) {
772 250         to_copy--;
773           } else
774 4483         lines++;
775           }
776           }
777           }
778           }
779            
780           append:
781           /* append to_copy bytes from source to PL_formstring.
782           * item_is_utf8 implies source is utf8.
783           * if trans, translate certain characters during the copy */
784           {
785           U8 *tmp = NULL;
786           STRLEN grow = 0;
787            
788 10946         SvCUR_set(PL_formtarget,
789           t - SvPVX_const(PL_formtarget));
790            
791 10946 100       if (targ_is_utf8 && !item_is_utf8) {
    100        
792 828         source = tmp = bytes_to_utf8(source, &to_copy);
793           } else {
794 10118 100       if (item_is_utf8 && !targ_is_utf8) {
    100        
795           U8 *s;
796           /* Upgrade targ to UTF8, and then we reduce it to
797           a problem we have a simple solution for.
798           Don't need get magic. */
799 406         sv_utf8_upgrade_nomg(PL_formtarget);
800           targ_is_utf8 = TRUE;
801           /* re-calculate linemark */
802 406         s = (U8*)SvPVX(PL_formtarget);
803           /* the bytes we initially allocated to append the
804           * whole line may have been gobbled up during the
805           * upgrade, so allocate a whole new line's worth
806           * for safety */
807           grow = linemax;
808 621 100       while (linemark--)
809 12         s += UTF8SKIP(s);
810 406         linemark = s - (U8*)SvPVX(PL_formtarget);
811           }
812           /* Easy. They agree. */
813           assert (item_is_utf8 == targ_is_utf8);
814           }
815 10946 100       if (!trans)
816           /* @* and ^* are the only things that can exceed
817           * the linemax, so grow by the output size, plus
818           * a whole new form's worth in case of any further
819           * output */
820 1680         grow = linemax + to_copy;
821 10946 100       if (grow)
822 1686 50       SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
    100        
823 10946         t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
824            
825 10946         Copy(source, t, to_copy, char);
826 10946 100       if (trans) {
827           /* blank out ~ or control chars, depending on trans.
828           * works on bytes not chars, so relies on not
829           * matching utf8 continuation bytes */
830           U8 *s = (U8*)t;
831 9266         U8 *send = s + to_copy;
832 306177 100       while (s < send) {
833 292278         const int ch = *s;
834 292278 100       if (trans == '~' ? (ch == '~') : isCNTRL(ch))
    50        
    50        
    100        
835 752         *s = ' ';
836 292278         s++;
837           }
838           }
839            
840 10946         t += to_copy;
841 10946         SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
842 10946 100       if (tmp)
843 828         Safefree(tmp);
844           break;
845           }
846            
847           case FF_0DECIMAL:
848 56         arg = *fpc++;
849           #if defined(USE_LONG_DOUBLE)
850           fmt = (const char *)
851           ((arg & FORM_NUM_POINT) ?
852           "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
853           #else
854 56 100       fmt = (const char *)
855 56         ((arg & FORM_NUM_POINT) ?
856           "%#0*.*f" : "%0*.*f");
857           #endif
858 56         goto ff_dec;
859           case FF_DECIMAL:
860 80         arg = *fpc++;
861           #if defined(USE_LONG_DOUBLE)
862           fmt = (const char *)
863           ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
864           #else
865 80 100       fmt = (const char *)
866 80         ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f");
867           #endif
868           ff_dec:
869           /* If the field is marked with ^ and the value is undefined,
870           blank it out. */
871 136 100       if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
    100        
    50        
    50        
872           arg = fieldsize;
873 40 100       while (arg--)
874 32         *t++ = ' ';
875           break;
876           }
877           gotsome = TRUE;
878 128 100       value = SvNV(sv);
879           /* overflow evidence */
880 128 100       if (num_overflow(value, fieldsize, arg)) {
881           arg = fieldsize;
882 224 100       while (arg--)
883 184         *t++ = '#';
884           break;
885           }
886           /* Formats aren't yet marked for locales, so assume "yes". */
887           {
888 88 50       STORE_NUMERIC_STANDARD_SET_LOCAL();
    50        
    0        
    50        
    50        
889 88         arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
890 132 50       my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value);
    50        
891 88 50       RESTORE_NUMERIC_STANDARD();
892           }
893 88         t += fieldsize;
894 88         break;
895            
896           case FF_NEWLINE:
897 2444         f++;
898 5883 100       while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
    100        
899           t++;
900 2444         *t++ = '\n';
901 2444         break;
902            
903           case FF_BLANK:
904 1566         arg = *fpc++;
905 1566 100       if (gotsome) {
906 926 100       if (arg) { /* repeat until fields exhausted? */
907 796         fpc--;
908 796         goto end;
909           }
910           }
911           else {
912 640         t = SvPVX(PL_formtarget) + linemark;
913 640         lines--;
914           }
915           break;
916            
917           case FF_MORE:
918           {
919           const char *s = chophere;
920 8         const char *send = item + len;
921 8 50       if (chopspace) {
922 24 100       while (isSPACE(*s) && (s < send))
923 16         s++;
924           }
925 8 100       if (s < send) {
926           char *s1;
927 4         arg = fieldsize - itemsize;
928 4 50       if (arg) {
929           fieldsize -= arg;
930 12 100       while (arg-- > 0)
931 8         *t++ = ' ';
932           }
933 4         s1 = t - 3;
934 4 50       if (strnEQ(s1," ",3)) {
935 0 0       while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
    0        
936 0         s1--;
937           }
938 4         *s1++ = '.';
939 4         *s1++ = '.';
940 4         *s1++ = '.';
941           }
942           break;
943           }
944           case FF_END:
945           end:
946           assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
947 3330         *t = '\0';
948 3330         SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
949 3330 100       if (targ_is_utf8)
950 430         SvUTF8_on(PL_formtarget);
951 3330         FmLINES(PL_formtarget) += lines;
952 3330         SP = ORIGMARK;
953 3330 100       if (fpc[-1] == FF_BLANK)
954 796         RETURNOP(cLISTOP->op_first);
955           else
956 2932         RETPUSHYES;
957           }
958           }
959           }
960            
961 16995643         PP(pp_grepstart)
962           {
963 16995643         dVAR; dSP;
964           SV *src;
965            
966 16995643 100       if (PL_stack_base + *PL_markstack_ptr == SP) {
967 521310         (void)POPMARK;
968 521310 100       if (GIMME_V == G_SCALAR)
    100        
969 377608 50       mXPUSHi(0);
970 521310         RETURNOP(PL_op->op_next->op_next);
971           }
972 16474333         PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
973 16474333         Perl_pp_pushmark(aTHX); /* push dst */
974 16474333         Perl_pp_pushmark(aTHX); /* push src */
975 16474333         ENTER_with_name("grep"); /* enter outer scope */
976            
977 16474333         SAVETMPS;
978 16474333 100       if (PL_op->op_private & OPpGREP_LEX)
979 18         SAVESPTR(PAD_SVl(PL_op->op_targ));
980           else
981 16474315         SAVE_DEFSV;
982 16474333         ENTER_with_name("grep_item"); /* enter inner scope */
983 16474333         SAVEVPTR(PL_curpm);
984            
985 16474333         src = PL_stack_base[*PL_markstack_ptr];
986 16474333 100       if (SvPADTMP(src) && !IS_PADGV(src)) {
987 3304         src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
988 3304         PL_tmps_floor++;
989           }
990 16474333         SvTEMP_off(src);
991 16474333 100       if (PL_op->op_private & OPpGREP_LEX)
992 18         PAD_SVl(PL_op->op_targ) = src;
993           else
994 32948630         DEFSV_set(src);
995            
996 16474333         PUTBACK;
997 16474333 100       if (PL_op->op_type == OP_MAPSTART)
998 2931075         Perl_pp_pushmark(aTHX); /* push top */
999 16734988         return ((LOGOP*)PL_op->op_next)->op_other;
1000           }
1001            
1002 9057670         PP(pp_mapwhile)
1003           {
1004 9057670         dVAR; dSP;
1005 9057670 100       const I32 gimme = GIMME_V;
1006 9057670         I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1007           I32 count;
1008           I32 shift;
1009           SV** src;
1010           SV** dst;
1011            
1012           /* first, move source pointer to the next item in the source list */
1013 9057670         ++PL_markstack_ptr[-1];
1014            
1015           /* if there are new items, push them into the destination list */
1016 9057670 100       if (items && gimme != G_VOID) {
1017           /* might need to make room back there first */
1018 8793832 100       if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
    100        
1019           /* XXX this implementation is very pessimal because the stack
1020           * is repeatedly extended for every set of items. Is possible
1021           * to do this without any stack extension or copying at all
1022           * by maintaining a separate list over which the map iterates
1023           * (like foreach does). --gsar */
1024            
1025           /* everything in the stack after the destination list moves
1026           * towards the end the stack by the amount of room needed */
1027 160124         shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1028            
1029           /* items to shift up (accounting for the moved source pointer) */
1030 160124         count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1031            
1032           /* This optimization is by Ben Tilly and it does
1033           * things differently from what Sarathy (gsar)
1034           * is describing. The downside of this optimization is
1035           * that leaves "holes" (uninitialized and hopefully unused areas)
1036           * to the Perl stack, but on the other hand this
1037           * shouldn't be a problem. If Sarathy's idea gets
1038           * implemented, this optimization should become
1039           * irrelevant. --jhi */
1040 160124 50       if (shift < count)
1041           shift = count; /* Avoid shifting too often --Ben Tilly */
1042            
1043 79340         EXTEND(SP,shift);
1044           src = SP;
1045 160124         dst = (SP += shift);
1046 160124         PL_markstack_ptr[-1] += shift;
1047 160124         *PL_markstack_ptr += shift;
1048 2343907 100       while (count--)
1049 2105275         *dst-- = *src--;
1050           }
1051           /* copy the new items down to the destination list */
1052 8633708         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1053 8633708 100       if (gimme == G_ARRAY) {
1054           /* add returned items to the collection (making mortal copies
1055           * if necessary), then clear the current temps stack frame
1056           * *except* for those items. We do this splicing the items
1057           * into the start of the tmps frame (so some items may be on
1058           * the tmps stack twice), then moving PL_tmps_floor above
1059           * them, then freeing the frame. That way, the only tmps that
1060           * accumulate over iterations are the return values for map.
1061           * We have to do to this way so that everything gets correctly
1062           * freed if we die during the map.
1063           */
1064           I32 tmpsbase;
1065           I32 i = items;
1066           /* make space for the slice */
1067 8633558 100       EXTEND_MORTAL(items);
1068 8633558         tmpsbase = PL_tmps_floor + 1;
1069 8633558 50       Move(PL_tmps_stack + tmpsbase,
1070           PL_tmps_stack + tmpsbase + items,
1071           PL_tmps_ix - PL_tmps_floor,
1072           SV*);
1073 8633558         PL_tmps_ix += items;
1074            
1075 23512600 100       while (i-- > 0) {
1076 10572579         SV *sv = POPs;
1077 10572579 100       if (!SvTEMP(sv))
1078 5990599         sv = sv_mortalcopy(sv);
1079 10572579         *dst-- = sv;
1080 15829680         PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1081           }
1082           /* clear the stack frame except for the items */
1083 8633558         PL_tmps_floor += items;
1084 8633558 50       FREETMPS;
1085           /* FREETMPS may have cleared the TEMP flag on some of the items */
1086           i = items;
1087 23512600 100       while (i-- > 0)
1088 10572579         SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1089           }
1090           else {
1091           /* scalar context: we don't care about which values map returns
1092           * (we use undef here). And so we certainly don't want to do mortal
1093           * copies of meaningless values. */
1094 328 100       while (items-- > 0) {
1095 178         (void)POPs;
1096 178         *dst-- = &PL_sv_undef;
1097           }
1098 150 100       FREETMPS;
1099           }
1100           }
1101           else {
1102 423962 100       FREETMPS;
1103           }
1104 9057670         LEAVE_with_name("grep_item"); /* exit inner scope */
1105            
1106           /* All done yet? */
1107 9057670 100       if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1108            
1109 2931055         (void)POPMARK; /* pop top */
1110 2931055         LEAVE_with_name("grep"); /* exit outer scope */
1111 2931055         (void)POPMARK; /* pop src */
1112 2931055         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1113 2931055         (void)POPMARK; /* pop dst */
1114 2931055         SP = PL_stack_base + POPMARK; /* pop original mark */
1115 2931055 100       if (gimme == G_SCALAR) {
1116 44 100       if (PL_op->op_private & OPpGREP_LEX) {
1117 2         SV* sv = sv_newmortal();
1118 2         sv_setiv(sv, items);
1119 2         PUSHs(sv);
1120           }
1121           else {
1122 42         dTARGET;
1123 42 50       XPUSHi(items);
    50        
1124           }
1125           }
1126 2931011 100       else if (gimme == G_ARRAY)
1127 2910293         SP += items;
1128 2931055         RETURN;
1129           }
1130           else {
1131           SV *src;
1132            
1133 6126615         ENTER_with_name("grep_item"); /* enter inner scope */
1134 6126615         SAVEVPTR(PL_curpm);
1135            
1136           /* set $_ to the new source item */
1137 6126615         src = PL_stack_base[PL_markstack_ptr[-1]];
1138 6126615 100       if (SvPADTMP(src) && !IS_PADGV(src)) src = sv_mortalcopy(src);
1139 6126615         SvTEMP_off(src);
1140 6126615 100       if (PL_op->op_private & OPpGREP_LEX)
1141 10         PAD_SVl(PL_op->op_targ) = src;
1142           else
1143 12253210         DEFSV_set(src);
1144            
1145 7593701         RETURNOP(cLOGOP->op_other);
1146           }
1147           }
1148            
1149           /* Range stuff. */
1150            
1151 190998         PP(pp_range)
1152           {
1153           dVAR;
1154 190998 100       if (GIMME == G_ARRAY)
    100        
1155 176090         return NORMAL;
1156 14908 50       if (SvTRUEx(PAD_SV(PL_op->op_targ)))
    50        
    0        
    100        
    50        
    50        
    50        
    0        
    0        
    0        
    0        
    0        
    50        
    50        
    100        
    50        
    0        
    100        
    0        
    100        
1157 7554         return cLOGOP->op_other;
1158           else
1159 99896         return NORMAL;
1160           }
1161            
1162 183444         PP(pp_flip)
1163           {
1164           dVAR;
1165 183444         dSP;
1166            
1167 183444 100       if (GIMME == G_ARRAY) {
    100        
1168 176090         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1169           }
1170           else {
1171 7354         dTOPss;
1172 7354         SV * const targ = PAD_SV(PL_op->op_targ);
1173           int flip = 0;
1174            
1175 7354 100       if (PL_op->op_private & OPpFLIP_LINENUM) {
1176 748 100       if (GvIO(PL_last_in_gv)) {
    100        
    50        
    50        
1177 724 50       flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1178           }
1179           else {
1180 24         GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1181 24 50       if (gv && GvSV(gv))
    50        
1182 24 100       flip = SvIV(sv) == SvIV(GvSV(gv));
    50        
1183           }
1184           } else {
1185 6606 50       flip = SvTRUE(sv);
    50        
    0        
    100        
    50        
    50        
    100        
    50        
    50        
    100        
    50        
    100        
    50        
    100        
    50        
    50        
    50        
    50        
    0        
1186           }
1187 7354 100       if (flip) {
1188 852         sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1189 852 100       if (PL_op->op_flags & OPf_SPECIAL) {
1190 544         sv_setiv(targ, 1);
1191 544         SETs(targ);
1192 544         RETURN;
1193           }
1194           else {
1195 308         sv_setiv(targ, 0);
1196 308         SP--;
1197 308         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1198           }
1199           }
1200 6502         sv_setpvs(TARG, "");
1201 6502         SETs(targ);
1202 95693         RETURN;
1203           }
1204           }
1205            
1206           /* This code tries to decide if "$left .. $right" should use the
1207           magical string increment, or if the range is numeric (we make
1208           an exception for .."0" [#18165]). AMS 20021031. */
1209            
1210           #define RANGE_IS_NUMERIC(left,right) ( \
1211           SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1212           SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1213           (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1214           looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1215           && (!SvOK(right) || looks_like_number(right))))
1216            
1217 183952         PP(pp_flop)
1218           {
1219 183952         dVAR; dSP;
1220            
1221 358609 100       if (GIMME == G_ARRAY) {
    100        
    100        
    100        
1222 176090         dPOPPOPssrl;
1223            
1224 87339         SvGETMAGIC(left);
1225 87331         SvGETMAGIC(right);
1226            
1227 176090 100       if (RANGE_IS_NUMERIC(left,right)) {
    100        
    50        
    50        
    100        
    100        
    100        
    50        
    50        
    50        
    100        
    50        
    50        
    100        
    50        
    50        
    100        
    50        
    50        
    100        
    100        
    100        
    100        
    50        
    50        
    100        
1228           IV i, j;
1229           IV max;
1230 349843 100       if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
    50        
    50        
    100        
    50        
    0        
    50        
    100        
    100        
    100        
1231 349817 50       (SvOK(right) && (SvIOK(right)
    50        
    50        
    0        
    50        
1232 87080 0       ? SvIsUV(right) && SvUV(right) > IV_MAX
    0        
1233 34         : SvNV_nomg(right) > IV_MAX)))
1234 0         DIE(aTHX_ "Range iterator outside integer range");
1235 175638 100       i = SvIV_nomg(left);
1236 175638 100       max = SvIV_nomg(right);
1237 349248 100       if (max >= i) {
    100        
1238 173610         j = max - i + 1;
1239           if (j > SSize_t_MAX)
1240           Perl_croak(aTHX_ "Out of memory during list extend");
1241 173610 100       EXTEND_MORTAL(j);
1242 174730         EXTEND(SP, j);
1243           }
1244           else
1245           j = 0;
1246 1382316 100       while (j--) {
1247 1206678         SV * const sv = sv_2mortal(newSViv(i++));
1248 1206678         PUSHs(sv);
1249           }
1250           }
1251           else {
1252           STRLEN len, llen;
1253 452 100       const char * const lpv = SvPV_nomg_const(left, llen);
1254 452 100       const char * const tmps = SvPV_nomg_const(right, len);
1255            
1256 452         SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1257 48460 100       while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
    100        
1258 48214 100       XPUSHs(sv);
1259 48214 100       if (strEQ(SvPVX_const(sv),tmps))
1260           break;
1261 47782         sv = sv_2mortal(newSVsv(sv));
1262 47782         sv_inc(sv);
1263           }
1264           }
1265           }
1266           else {
1267 7862         dTOPss;
1268 7862         SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1269           int flop = 0;
1270 7862         sv_inc(targ);
1271            
1272 7862 100       if (PL_op->op_private & OPpFLIP_LINENUM) {
1273 96 100       if (GvIO(PL_last_in_gv)) {
    100        
    50        
    50        
1274 86 50       flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1275           }
1276           else {
1277 10         GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1278 10 50       if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
    50        
    100        
    50        
1279           }
1280           }
1281           else {
1282 7766 50       flop = SvTRUE(sv);
    50        
    0        
    100        
    50        
    50        
    100        
    50        
    50        
    100        
    50        
    100        
    50        
    50        
    100        
    50        
    0        
    100        
    0        
1283           }
1284            
1285 7862 100       if (flop) {
1286 584         sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1287 584         sv_catpvs(targ, "E0");
1288           }
1289 7862         SETs(targ);
1290           }
1291            
1292 183952         RETURN;
1293           }
1294            
1295           /* Control. */
1296            
1297           static const char * const context_name[] = {
1298           "pseudo-block",
1299           NULL, /* CXt_WHEN never actually needs "block" */
1300           NULL, /* CXt_BLOCK never actually needs "block" */
1301           NULL, /* CXt_GIVEN never actually needs "block" */
1302           NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1303           NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1304           NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1305           NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1306           "subroutine",
1307           "format",
1308           "eval",
1309           "substitution",
1310           };
1311            
1312           STATIC I32
1313 328878         S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1314           {
1315           dVAR;
1316           I32 i;
1317            
1318           PERL_ARGS_ASSERT_DOPOPTOLABEL;
1319            
1320 826492 100       for (i = cxstack_ix; i >= 0; i--) {
1321 662050         const PERL_CONTEXT * const cx = &cxstack[i];
1322 662050         switch (CxTYPE(cx)) {
1323           case CXt_SUBST:
1324           case CXt_SUB:
1325           case CXt_FORMAT:
1326           case CXt_EVAL:
1327           case CXt_NULL:
1328           /* diag_listed_as: Exiting subroutine via %s */
1329 5052 50       Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1330 2526 0       context_name[CxTYPE(cx)], OP_NAME(PL_op));
1331 2526 100       if (CxTYPE(cx) == CXt_NULL)
1332           return -1;
1333           break;
1334           case CXt_LOOP_LAZYIV:
1335           case CXt_LOOP_LAZYSV:
1336           case CXt_LOOP_FOR:
1337           case CXt_LOOP_PLAIN:
1338           {
1339 398290         STRLEN cx_label_len = 0;
1340 398290         U32 cx_label_flags = 0;
1341 398290         const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1342 1056955 100       if (!cx_label || !(
    100        
    100        
    100        
1343 329478         ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1344 4         (flags & SVf_UTF8)
1345 0         ? (bytes_cmp_utf8(
1346           (const U8*)cx_label, cx_label_len,
1347           (const U8*)label, len) == 0)
1348 4         : (bytes_cmp_utf8(
1349           (const U8*)label, len,
1350           (const U8*)cx_label, cx_label_len) == 0)
1351 493629 50       : (len == cx_label_len && ((cx_label == label)
1352 328892 100       || memEQ(cx_label, label, len))) )) {
1353           DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1354           (long)i, cx_label));
1355 69422         continue;
1356           }
1357           DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1358           return i;
1359           }
1360           }
1361           }
1362           return i;
1363           }
1364            
1365            
1366            
1367           I32
1368 7890657         Perl_dowantarray(pTHX)
1369           {
1370           dVAR;
1371 7890657         const I32 gimme = block_gimme();
1372 7890657 100       return (gimme == G_VOID) ? G_SCALAR : gimme;
1373           }
1374            
1375           I32
1376 96180580         Perl_block_gimme(pTHX)
1377           {
1378           dVAR;
1379 96180580         const I32 cxix = dopoptosub(cxstack_ix);
1380 96180580 100       if (cxix < 0)
1381           return G_VOID;
1382            
1383 96155296         switch (cxstack[cxix].blk_gimme) {
1384           case G_VOID:
1385           return G_VOID;
1386           case G_SCALAR:
1387 47280558         return G_SCALAR;
1388           case G_ARRAY:
1389 16182566         return G_ARRAY;
1390           default:
1391 48163177         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1392           assert(0); /* NOTREACHED */
1393           return 0;
1394           }
1395           }
1396            
1397           I32
1398 730         Perl_is_lvalue_sub(pTHX)
1399           {
1400           dVAR;
1401 730         const I32 cxix = dopoptosub(cxstack_ix);
1402           assert(cxix >= 0); /* We should only be called from inside subs */
1403            
1404 730 100       if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
    50        
1405 614         return CxLVAL(cxstack + cxix);
1406           else
1407           return 0;
1408           }
1409            
1410           /* only used by PUSHSUB */
1411           I32
1412 32         Perl_was_lvalue_sub(pTHX)
1413           {
1414           dVAR;
1415 32         const I32 cxix = dopoptosub(cxstack_ix-1);
1416           assert(cxix >= 0); /* We should only be called from inside subs */
1417            
1418 32 100       if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
    50        
1419 27         return CxLVAL(cxstack + cxix);
1420           else
1421           return 0;
1422           }
1423            
1424           STATIC I32
1425 387704903         S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1426           {
1427           dVAR;
1428           I32 i;
1429            
1430           PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1431            
1432 646433084 100       for (i = startingblock; i >= 0; i--) {
1433 451501661         const PERL_CONTEXT * const cx = &cxstk[i];
1434 451501661         switch (CxTYPE(cx)) {
1435           default:
1436 65665706         continue;
1437           case CXt_SUB:
1438           /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1439           * twice; the first for the normal foo() call, and the second
1440           * for a faked up re-entry into the sub to execute the
1441           * code block. Hide this faked entry from the world. */
1442 385071715 100       if (cx->cx_type & CXp_SUB_RE_FAKE)
1443 106         continue;
1444           case CXt_EVAL:
1445           case CXt_FORMAT:
1446           DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1447           return i;
1448           }
1449           }
1450           return i;
1451           }
1452            
1453           STATIC I32
1454           S_dopoptoeval(pTHX_ I32 startingblock)
1455           {
1456           dVAR;
1457           I32 i;
1458 403408 100       for (i = startingblock; i >= 0; i--) {
1459 561537         const PERL_CONTEXT *cx = &cxstack[i];
1460 561537 100       switch (CxTYPE(cx)) {
1461           default:
1462 242090         continue;
1463           case CXt_EVAL:
1464           DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1465           return i;
1466           }
1467           }
1468           return i;
1469           }
1470            
1471           STATIC I32
1472 11356549         S_dopoptoloop(pTHX_ I32 startingblock)
1473           {
1474           dVAR;
1475           I32 i;
1476 25193089 100       for (i = startingblock; i >= 0; i--) {
1477 19374847         const PERL_CONTEXT * const cx = &cxstack[i];
1478 19374847         switch (CxTYPE(cx)) {
1479           case CXt_SUBST:
1480           case CXt_SUB:
1481           case CXt_FORMAT:
1482           case CXt_EVAL:
1483           case CXt_NULL:
1484           /* diag_listed_as: Exiting subroutine via %s */
1485 124 50       Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1486 62 0       context_name[CxTYPE(cx)], OP_NAME(PL_op));
1487 62 100       if ((CxTYPE(cx)) == CXt_NULL)
1488           return -1;
1489           break;
1490           case CXt_LOOP_LAZYIV:
1491           case CXt_LOOP_LAZYSV:
1492           case CXt_LOOP_FOR:
1493           case CXt_LOOP_PLAIN:
1494           DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1495           return i;
1496           }
1497           }
1498           return i;
1499           }
1500            
1501           STATIC I32
1502 312         S_dopoptogiven(pTHX_ I32 startingblock)
1503           {
1504           dVAR;
1505           I32 i;
1506 1074 100       for (i = startingblock; i >= 0; i--) {
1507 914         const PERL_CONTEXT *cx = &cxstack[i];
1508 914         switch (CxTYPE(cx)) {
1509           default:
1510 610         continue;
1511           case CXt_GIVEN:
1512           DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1513           return i;
1514           case CXt_LOOP_PLAIN:
1515           assert(!CxFOREACHDEF(cx));
1516           break;
1517           case CXt_LOOP_LAZYIV:
1518           case CXt_LOOP_LAZYSV:
1519           case CXt_LOOP_FOR:
1520 30 50       if (CxFOREACHDEF(cx)) {
    50        
    50        
1521           DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1522           return i;
1523           }
1524           }
1525           }
1526           return i;
1527           }
1528            
1529           STATIC I32
1530           S_dopoptowhen(pTHX_ I32 startingblock)
1531           {
1532           dVAR;
1533           I32 i;
1534 113 100       for (i = startingblock; i >= 0; i--) {
1535 144         const PERL_CONTEXT *cx = &cxstack[i];
1536 144 100       switch (CxTYPE(cx)) {
1537           default:
1538 78         continue;
1539           case CXt_WHEN:
1540           DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1541           return i;
1542           }
1543           }
1544           return i;
1545           }
1546            
1547           void
1548 26747967         Perl_dounwind(pTHX_ I32 cxix)
1549           {
1550           dVAR;
1551           I32 optype;
1552            
1553 26747967 50       if (!PL_curstackinfo) /* can happen if die during thread cloning */
1554 26747967         return;
1555            
1556 61339221 100       while (cxstack_ix > cxix) {
1557           SV *sv;
1558 34591254         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1559           DEBUG_CX("UNWIND"); \
1560           /* Note: we don't need to restore the base context info till the end. */
1561 34591254         switch (CxTYPE(cx)) {
1562           case CXt_SUBST:
1563 16         POPSUBST(cx);
1564 16         continue; /* not break */
1565           case CXt_SUB:
1566 302085 100       POPSUB(cx,sv);
    100        
    100        
    50        
    100        
1567 201630         LEAVESUB(sv);
1568 201630         break;
1569           case CXt_EVAL:
1570 334 100       POPEVAL(cx);
    50        
    100        
1571           break;
1572           case CXt_LOOP_LAZYIV:
1573           case CXt_LOOP_LAZYSV:
1574           case CXt_LOOP_FOR:
1575           case CXt_LOOP_PLAIN:
1576 3909043 50       POPLOOP(cx);
    100        
1577           break;
1578           case CXt_NULL:
1579           break;
1580           case CXt_FORMAT:
1581 69 50       POPFORMAT(cx);
    50        
1582 46         break;
1583           }
1584 34591246         cxstack_ix--;
1585           }
1586           PERL_UNUSED_VAR(optype);
1587           }
1588            
1589           void
1590 2384         Perl_qerror(pTHX_ SV *err)
1591           {
1592           dVAR;
1593            
1594           PERL_ARGS_ASSERT_QERROR;
1595            
1596 2384 100       if (PL_in_eval) {
1597 2120 100       if (PL_in_eval & EVAL_KEEPERR) {
1598 2         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1599           SVfARG(err));
1600           }
1601           else
1602 2118 50       sv_catsv(ERRSV, err);
1603           }
1604 264 50       else if (PL_errors)
1605 264         sv_catsv(PL_errors, err);
1606           else
1607 0         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1608 2384 50       if (PL_parser)
1609 2384         ++PL_parser->error_count;
1610 2384         }
1611            
1612           void
1613 320537         Perl_die_unwind(pTHX_ SV *msv)
1614           {
1615           dVAR;
1616 320537         SV *exceptsv = sv_mortalcopy(msv);
1617 320537         U8 in_eval = PL_in_eval;
1618           PERL_ARGS_ASSERT_DIE_UNWIND;
1619            
1620 320537 100       if (in_eval) {
1621           I32 cxix;
1622           I32 gimme;
1623            
1624           /*
1625           * Historically, perl used to set ERRSV ($@) early in the die
1626           * process and rely on it not getting clobbered during unwinding.
1627           * That sucked, because it was liable to get clobbered, so the
1628           * setting of ERRSV used to emit the exception from eval{} has
1629           * been moved to much later, after unwinding (see just before
1630           * JMPENV_JUMP below). However, some modules were relying on the
1631           * early setting, by examining $@ during unwinding to use it as
1632           * a flag indicating whether the current unwinding was caused by
1633           * an exception. It was never a reliable flag for that purpose,
1634           * being totally open to false positives even without actual
1635           * clobberage, but was useful enough for production code to
1636           * semantically rely on it.
1637           *
1638           * We'd like to have a proper introspective interface that
1639           * explicitly describes the reason for whatever unwinding
1640           * operations are currently in progress, so that those modules
1641           * work reliably and $@ isn't further overloaded. But we don't
1642           * have one yet. In its absence, as a stopgap measure, ERRSV is
1643           * now *additionally* set here, before unwinding, to serve as the
1644           * (unreliable) flag that it used to.
1645           *
1646           * This behaviour is temporary, and should be removed when a
1647           * proper way to detect exceptional unwinding has been developed.
1648           * As of 2010-12, the authors of modules relying on the hack
1649           * are aware of the issue, because the modules failed on
1650           * perls 5.13.{1..7} which had late setting of $@ without this
1651           * early-setting hack.
1652           */
1653 319447 100       if (!(in_eval & EVAL_KEEPERR)) {
1654 319253         SvTEMP_off(exceptsv);
1655 319253 50       sv_setsv(ERRSV, exceptsv);
1656           }
1657            
1658 319447 100       if (in_eval & EVAL_KEEPERR) {
1659 160900         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
1660           SVfARG(exceptsv));
1661           }
1662            
1663 640954 100       while ((cxix = dopoptoeval(cxstack_ix)) < 0
1664 1030 50       && PL_curstackinfo->si_prev)
1665           {
1666 1030         dounwind(-1);
1667 1030 50       POPSTACK;
1668           }
1669            
1670 319447 50       if (cxix >= 0) {
1671           I32 optype;
1672           SV *namesv;
1673           PERL_CONTEXT *cx;
1674           SV **newsp;
1675           COP *oldcop;
1676           JMPENV *restartjmpenv;
1677           OP *restartop;
1678            
1679 319447 100       if (cxix < cxstack_ix)
1680 140662         dounwind(cxix);
1681            
1682 319447         POPBLOCK(cx,PL_curpm);
1683 319447 50       if (CxTYPE(cx) != CXt_EVAL) {
1684           STRLEN msglen;
1685 0 0       const char* message = SvPVx_const(exceptsv, msglen);
1686 0 0       PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
    0        
    0        
    0        
1687 0 0       PerlIO_write(Perl_error_log, message, msglen);
    0        
    0        
    0        
1688 0         my_exit(1);
1689           }
1690 319447 100       POPEVAL(cx);
    50        
    100        
1691 319447         namesv = cx->blk_eval.old_namesv;
1692 319447         oldcop = cx->blk_oldcop;
1693 319447         restartjmpenv = cx->blk_eval.cur_top_env;
1694 319447         restartop = cx->blk_eval.retop;
1695            
1696 319447 100       if (gimme == G_SCALAR)
1697 201927         *++newsp = &PL_sv_undef;
1698 319447         PL_stack_sp = newsp;
1699            
1700 319447         LEAVE;
1701            
1702           /* LEAVE could clobber PL_curcop (see save_re_context())
1703           * XXX it might be better to find a way to avoid messing with
1704           * PL_curcop in save_re_context() instead, but this is a more
1705           * minimal fix --GSAR */
1706 319445         PL_curcop = oldcop;
1707            
1708 319445 100       if (optype == OP_REQUIRE) {
1709 1796 50       (void)hv_store(GvHVn(PL_incgv),
    50        
1710           SvPVX_const(namesv),
1711           SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
1712           &PL_sv_undef, 0);
1713           /* note that unlike pp_entereval, pp_require isn't
1714           * supposed to trap errors. So now that we've popped the
1715           * EVAL that pp_require pushed, and processed the error
1716           * message, rethrow the error */
1717 1796 50       Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
1718           SVfARG(exceptsv ? exceptsv : newSVpvs_flags("Unknown error\n",
1719           SVs_TEMP)));
1720           }
1721 317649 100       if (!(in_eval & EVAL_KEEPERR))
1722 317455 50       sv_setsv(ERRSV, exceptsv);
1723 317649         PL_restartjmpenv = restartjmpenv;
1724 317649         PL_restartop = restartop;
1725 317649 50       JMPENV_JUMP(3);
1726           assert(0); /* NOTREACHED */
1727           }
1728           }
1729            
1730 1090         write_to_stderr(exceptsv);
1731 1088         my_failure_exit();
1732           assert(0); /* NOTREACHED */
1733           }
1734            
1735 108566         PP(pp_xor)
1736           {
1737 108566         dVAR; dSP; dPOPTOPssrl;
1738 108566 50       if (SvTRUE(left) != SvTRUE(right))
    50        
    0        
    100        
    50        
    50        
    100        
    50        
    100        
    100        
    50        
    100        
    50        
    50        
    100        
    50        
    0        
    100        
    0        
    50        
    50        
    0        
    100        
    50        
    50        
    100        
    50        
    100        
    100        
    100        
    100        
    50        
    50        
    100        
    50        
    0        
    100        
    0        
    100        
1739 1018         RETSETYES;
1740           else
1741 108057         RETSETNO;
1742           }
1743            
1744           /*
1745           =for apidoc caller_cx
1746            
1747           The XSUB-writer's equivalent of L. The
1748           returned C structure can be interrogated to find all the
1749           information returned to Perl by C. Note that XSUBs don't get a
1750           stack frame, so C will return information for the
1751           immediately-surrounding Perl code.
1752            
1753           This function skips over the automatic calls to C<&DB::sub> made on the
1754           behalf of the debugger. If the stack frame requested was a sub called by
1755           C, the return value will be the frame for the call to
1756           C, since that has the correct line number/etc. for the call
1757           site. If I is non-C, it will be set to a pointer to the
1758           frame for the sub call itself.
1759            
1760           =cut
1761           */
1762            
1763           const PERL_CONTEXT *
1764 7740194         Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1765           {
1766 7740194         I32 cxix = dopoptosub(cxstack_ix);
1767           const PERL_CONTEXT *cx;
1768 7740194         const PERL_CONTEXT *ccstack = cxstack;
1769 7740194         const PERL_SI *top_si = PL_curstackinfo;
1770            
1771           for (;;) {
1772           /* we may be in a higher stacklevel, so dig down deeper */
1773 35786405 100       while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
    100        
1774 5508         top_si = top_si->si_prev;
1775 5508         ccstack = top_si->si_cxstack;
1776 14026579         cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1777           }
1778 35780897 100       if (cxix < 0)
1779           return NULL;
1780           /* caller() should not report the automatic calls to &DB::sub */
1781 35678439 100       if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
    100        
    100        
1782 56020         ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1783 16784         count++;
1784 35650429 100       if (!count--)
1785           break;
1786 28040703         cxix = dopoptosub_at(ccstack, cxix - 1);
1787 28040703         }
1788            
1789 7609726         cx = &ccstack[cxix];
1790 7609726 100       if (dbcxp) *dbcxp = cx;
1791            
1792 7609726 100       if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1793 7598978         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1794           /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1795           field below is defined for any cx. */
1796           /* caller() should not report the automatic calls to &DB::sub */
1797 7598978 100       if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
    100        
    100        
1798 1958         cx = &ccstack[dbcxix];
1799           }
1800            
1801 7674960         return cx;
1802           }
1803            
1804 7739904         PP(pp_caller)
1805 5368107 50       {
1806           dVAR;
1807 7739904         dSP;
1808           const PERL_CONTEXT *cx;
1809           const PERL_CONTEXT *dbcx;
1810           I32 gimme;
1811           const HEK *stash_hek;
1812           I32 count = 0;
1813 7739904 100       bool has_arg = MAXARG && TOPs;
    100        
1814           const COP *lcop;
1815            
1816 7739904 100       if (MAXARG) {
1817 6109314 100       if (has_arg)
1818 6109310 50       count = POPi;
1819 4         else (void)POPs;
1820           }
1821            
1822 7739904         cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
1823 7739904 100       if (!cx) {
1824 130628 50       if (GIMME != G_ARRAY) {
    100        
    50        
1825 164         EXTEND(SP, 1);
1826 328         RETPUSHUNDEF;
1827           }
1828 130136         RETURN;
1829           }
1830            
1831           DEBUG_CX("CALLER");
1832           assert(CopSTASH(cx->blk_oldcop));
1833 7609440         stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
1834 15163738 50       ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
1835 22773178 100       : NULL;
    100        
    100        
1836 8705809 100       if (GIMME != G_ARRAY) {
    100        
    50        
1837 1096369         EXTEND(SP, 1);
1838 2241333 100       if (!stash_hek)
1839 10         PUSHs(&PL_sv_undef);
1840           else {
1841 2241323         dTARGET;
1842 2241323         sv_sethek(TARG, stash_hek);
1843 2241323         PUSHs(TARG);
1844           }
1845 2241333         RETURN;
1846           }
1847            
1848 2680815         EXTEND(SP, 11);
1849            
1850 5368107 100       if (!stash_hek)
1851 28         PUSHs(&PL_sv_undef);
1852           else {
1853 5368079         dTARGET;
1854 5368079         sv_sethek(TARG, stash_hek);
1855 5368079 50       PUSHTARG;
1856           }
1857 5368107 50       mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1858 5368107         lcop = closest_cop(cx->blk_oldcop, cx->blk_oldcop->op_sibling,
1859           cx->blk_sub.retop, TRUE);
1860 5368107 100       if (!lcop)
1861 2016         lcop = cx->blk_oldcop;
1862 5368107         mPUSHi((I32)CopLINE(lcop));
1863 5368107 100       if (!has_arg)
1864 306960         RETURN;
1865 5061147 100       if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1866 5056415         GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1867           /* So is ccstack[dbcxix]. */
1868 10112830 50       if (cvgv && isGV(cvgv)) {
    50        
1869 5056415         SV * const sv = newSV(0);
1870 5056415         gv_efullname3(sv, cvgv, NULL);
1871 5056415         mPUSHs(sv);
1872 5056415 100       PUSHs(boolSV(CxHASARGS(cx)));
1873           }
1874           else {
1875 0         PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1876 0 0       PUSHs(boolSV(CxHASARGS(cx)));
1877           }
1878           }
1879           else {
1880 4732         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1881 4732         mPUSHi(0);
1882           }
1883 5061147         gimme = (I32)cx->blk_gimme;
1884 5061147 100       if (gimme == G_VOID)
1885 3263545         PUSHs(&PL_sv_undef);
1886           else
1887 1797602 100       PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1888 5061147 100       if (CxTYPE(cx) == CXt_EVAL) {
1889           /* eval STRING */
1890 4732 100       if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1891 396         PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text),
1892           SvCUR(cx->blk_eval.cur_text)-2,
1893           SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP));
1894 396         PUSHs(&PL_sv_no);
1895           }
1896           /* require */
1897 4336 100       else if (cx->blk_eval.old_namesv) {
1898 2728         mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1899 2728         PUSHs(&PL_sv_yes);
1900           }
1901           /* eval BLOCK (try blocks have old_namesv == 0) */
1902           else {
1903 1608         PUSHs(&PL_sv_undef);
1904 1608         PUSHs(&PL_sv_undef);
1905           }
1906           }
1907           else {
1908 5056415         PUSHs(&PL_sv_undef);
1909 5056415         PUSHs(&PL_sv_undef);
1910           }
1911 5061147 100       if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1912 5055807 100       && CopSTASH_eq(PL_curcop, PL_debstash))
1913           {
1914 87344         AV * const ary = cx->blk_sub.argarray;
1915 87344         const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
1916            
1917 87344         Perl_init_dbargs(aTHX);
1918            
1919 87342 100       if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1920 422         av_extend(PL_dbargs, AvFILLp(ary) + off);
1921 87342 50       Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1922 87342         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1923           }
1924 5061145         mPUSHi(CopHINTS_get(cx->blk_oldcop));
1925           {
1926           SV * mask ;
1927 5061145         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1928            
1929 5061145 100       if (old_warnings == pWARN_NONE)
1930 4708         mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1931 5056437 100       else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
    100        
1932           mask = &PL_sv_undef ;
1933 4709954 100       else if (old_warnings == pWARN_ALL ||
    100        
1934 704620 50       (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1935           /* Get the bit mask for $warnings::Bits{all}, because
1936           * it could have been extended by warnings::register */
1937           SV **bits_all;
1938 2733372         HV * const bits = get_hv("warnings::Bits", 0);
1939 2733372 100       if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
    50        
1940 2733072         mask = newSVsv(*bits_all);
1941           }
1942           else {
1943 300         mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1944           }
1945           }
1946           else
1947 1976582         mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1948 5061145         mPUSHs(mask);
1949           }
1950            
1951 5061145 100       PUSHs(cx->blk_oldcop->cop_hints_hash ?
1952           sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1953           : &PL_sv_undef);
1954 6426980         RETURN;
1955           }
1956            
1957 58         PP(pp_reset)
1958           {
1959           dVAR;
1960 58         dSP;
1961           const char * tmps;
1962 58         STRLEN len = 0;
1963 58 100       if (MAXARG < 1 || (!TOPs && !POPs))
    100        
    50        
1964 26         tmps = NULL, len = 0;
1965           else
1966 32 100       tmps = SvPVx_const(POPs, len);
1967 58         sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
1968 58         PUSHs(&PL_sv_yes);
1969 58         RETURN;
1970           }
1971            
1972           /* like pp_nextstate, but used instead when the debugger is active */
1973            
1974 762718         PP(pp_dbstate)
1975           {
1976           dVAR;
1977 762718         PL_curcop = (COP*)PL_op;
1978 762718         TAINT_NOT; /* Each statement is presumed innocent */
1979 762718         PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1980 762718 100       FREETMPS;
1981            
1982 762718 50       PERL_ASYNC_CHECK();
1983            
1984 2041645 100       if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
    50        
    50        
    100        
1985 2041465 100       || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
    0        
    50        
    0        
    100        
    50        
1986           {
1987           dSP;
1988           PERL_CONTEXT *cx;
1989           const I32 gimme = G_ARRAY;
1990           U8 hasargs;
1991 329550         GV * const gv = PL_DBgv;
1992           CV * cv = NULL;
1993            
1994 329550 50       if (gv && isGV_with_GP(gv))
    100        
    50        
1995 329548         cv = GvCV(gv);
1996            
1997 329550 100       if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
    100        
    50        
1998 4         DIE(aTHX_ "No DB::DB routine defined");
1999            
2000 329546 100       if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
    100        
2001           /* don't do recursive DB::DB call */
2002 327808         return NORMAL;
2003            
2004 1738         ENTER;
2005 1738         SAVETMPS;
2006            
2007 1738         SAVEI32(PL_debug);
2008 1738 50       SAVESTACK_POS();
2009 1738         PL_debug = 0;
2010           hasargs = 0;
2011 1738         SPAGAIN;
2012            
2013 1738 50       if (CvISXSUB(cv)) {
2014 0 0       PUSHMARK(SP);
2015 0         (void)(*CvXSUB(cv))(aTHX_ cv);
2016 0 0       FREETMPS;
2017 0         LEAVE;
2018 0         return NORMAL;
2019           }
2020           else {
2021 1738 50       PUSHBLOCK(cx, CXt_SUB, SP);
2022 3476 100       PUSHSUB_DB(cx);
2023 1738         cx->blk_sub.retop = PL_op->op_next;
2024 1738         CvDEPTH(cv)++;
2025 1738 100       if (CvDEPTH(cv) >= 2) {
2026           PERL_STACK_OVERFLOW_CHECK();
2027 42         pad_push(CvPADLIST(cv), CvDEPTH(cv));
2028           }
2029 1738         SAVECOMPPAD();
2030 3476         PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2031 1738         RETURNOP(CvSTART(cv));
2032           }
2033           }
2034           else
2035 597941         return NORMAL;
2036           }
2037            
2038           STATIC SV **
2039 298501413         S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
2040           {
2041           bool padtmp = 0;
2042           PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
2043            
2044 298501413 100       if (flags & SVs_PADTMP) {
2045 232049933         flags &= ~SVs_PADTMP;
2046           padtmp = 1;
2047           }
2048 298501413 100       if (gimme == G_SCALAR) {
2049 35516265 100       if (MARK < SP)
2050 75966088 100       *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
    100        
2051 56790144 100       ? *SP : sv_mortalcopy(*SP);
2052           else {
2053           /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2054           MARK = newsp;
2055 34 50       MEXTEND(MARK, 1);
2056 34         *++MARK = &PL_sv_undef;
2057 34         return MARK;
2058           }
2059           }
2060 262985148 100       else if (gimme == G_ARRAY) {
2061           /* in case LEAVE wipes old return values */
2062 64092312 100       while (++MARK <= SP) {
2063 32088378 100       if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
    100        
    100        
2064 1565334         *++newsp = *MARK;
2065           else {
2066 30523044         *++newsp = sv_mortalcopy(*MARK);
2067 31305711         TAINT_NOT; /* Each item is independent */
2068           }
2069           }
2070           /* When this function was called with MARK == newsp, we reach this
2071           * point with SP == newsp. */
2072           }
2073            
2074 298501396         return newsp;
2075           }
2076            
2077 247293224         PP(pp_enter)
2078           {
2079 247293224         dVAR; dSP;
2080           PERL_CONTEXT *cx;
2081 247293224 100       I32 gimme = GIMME_V;
2082            
2083 247293224         ENTER_with_name("block");
2084            
2085 247293224         SAVETMPS;
2086 247293224 100       PUSHBLOCK(cx, CXt_BLOCK, SP);
2087            
2088 247293224         RETURN;
2089           }
2090            
2091 216866177         PP(pp_leave)
2092           {
2093 216866177         dVAR; dSP;
2094           PERL_CONTEXT *cx;
2095           SV **newsp;
2096           PMOP *newpm;
2097           I32 gimme;
2098            
2099 216866177 100       if (PL_op->op_flags & OPf_SPECIAL) {
2100 2975396         cx = &cxstack[cxstack_ix];
2101 2975396         cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
2102           }
2103            
2104 216866177         POPBLOCK(cx,newpm);
2105            
2106 216866177 100       gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
    50        
2107            
2108 216866177         TAINT_NOT;
2109 216866177         SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
2110 216866177         PL_curpm = newpm; /* Don't pop $1 et al till now */
2111            
2112 216866177         LEAVE_with_name("block");
2113            
2114 216866177         RETURN;
2115           }
2116            
2117 30822110         PP(pp_enteriter)
2118           {
2119 30822110         dVAR; dSP; dMARK;
2120           PERL_CONTEXT *cx;
2121 30822110 50       const I32 gimme = GIMME_V;
2122           void *itervar; /* location of the iteration variable */
2123           U8 cxtype = CXt_LOOP_FOR;
2124            
2125 30822110         ENTER_with_name("loop1");
2126 30822110         SAVETMPS;
2127            
2128 30822110 100       if (PL_op->op_targ) { /* "my" variable */
2129 13745172 100       if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2130 12887603         SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2131 12887603         SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2132           SVs_PADSTALE, SVs_PADSTALE);
2133           }
2134 13745172         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2135           #ifdef USE_ITHREADS
2136           itervar = PL_comppad;
2137           #else
2138 13745172         itervar = &PAD_SVl(PL_op->op_targ);
2139           #endif
2140           }
2141           else { /* symbol table variable */
2142 17076938         GV * const gv = MUTABLE_GV(POPs);
2143 17076938         SV** svp = &GvSV(gv);
2144 25598490         save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2145 17076938         *svp = newSV(0);
2146           itervar = (void *)gv;
2147           }
2148            
2149 30822110 100       if (PL_op->op_private & OPpITER_DEF)
2150           cxtype |= CXp_FOR_DEF;
2151            
2152 30822110         ENTER_with_name("loop2");
2153            
2154 30822110 50       PUSHBLOCK(cx, cxtype, SP);
2155 30822110         PUSHLOOP_FOR(cx, itervar, MARK);
2156 30822110 100       if (PL_op->op_flags & OPf_STACKED) {
2157 8297864         SV *maybe_ary = POPs;
2158 8918253 100       if (SvTYPE(maybe_ary) != SVt_PVAV) {
    100        
    100        
2159 620746         dPOPss;
2160           SV * const right = maybe_ary;
2161 310199         SvGETMAGIC(sv);
2162 310201         SvGETMAGIC(right);
2163 620746 100       if (RANGE_IS_NUMERIC(sv,right)) {
    100        
    50        
    50        
    50        
    100        
    100        
    50        
    50        
    50        
    100        
    50        
    50        
    100        
    50        
    50        
    100        
    50        
    50        
    100        
    100        
    100        
    100        
    50        
    50        
    100        
2164 620686         cx->cx_type &= ~CXTYPEMASK;
2165 620686         cx->cx_type |= CXt_LOOP_LAZYIV;
2166           /* Make sure that no-one re-orders cop.h and breaks our
2167           assumptions */
2168           assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2169           #ifdef NV_PRESERVES_UV
2170           if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
2171           (SvNV_nomg(sv) > (NV)IV_MAX)))
2172           ||
2173           (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
2174           (SvNV_nomg(right) < (NV)IV_MIN))))
2175           #else
2176 3990555 100       if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
    50        
    50        
    100        
    100        
    100        
    100        
    50        
    100        
    100        
    100        
    100        
    100        
2177 620606 100       ||
2178 977688 100       ((SvNV_nomg(sv) > 0) &&
    100        
2179 714308 0       ((SvUV_nomg(sv) > (UV)IV_MAX) ||
    50        
2180 357001 50       (SvNV_nomg(sv) > (NV)UV_MAX)))))
2181 620668 100       ||
2182 765891 50       (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
    50        
    50        
    100        
2183 620608 100       ||
2184 1171935 100       ((SvNV_nomg(right) > 0) &&
    100        
2185 1103442 100       ((SvUV_nomg(right) > (UV)IV_MAX) ||
    50        
2186 551497 50       (SvNV_nomg(right) > (NV)UV_MAX))
2187           ))))
2188           #endif
2189 36         DIE(aTHX_ "Range iterator outside integer range");
2190 620650 100       cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2191 620650 100       cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2192           #ifdef DEBUGGING
2193           /* for correct -Dstv display */
2194           cx->blk_oldsp = sp - PL_stack_base;
2195           #endif
2196           }
2197           else {
2198 60         cx->cx_type &= ~CXTYPEMASK;
2199 60         cx->cx_type |= CXt_LOOP_LAZYSV;
2200           /* Make sure that no-one re-orders cop.h and breaks our
2201           assumptions */
2202           assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2203 60         cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2204 60         cx->blk_loop.state_u.lazysv.end = right;
2205           SvREFCNT_inc(right);
2206 60 100       (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2207           /* This will do the upgrade to SVt_PV, and warn if the value
2208           is uninitialised. */
2209 60 100       (void) SvPV_nolen_const(right);
2210           /* Doing this avoids a check every time in pp_iter in pp_hot.c
2211           to replace !SvOK() with a pointer to "". */
2212 60 100       if (!SvOK(right)) {
    50        
    50        
2213 6         SvREFCNT_dec(right);
2214 6         cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2215           }
2216           }
2217           }
2218           else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2219 7677118         cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2220           SvREFCNT_inc(maybe_ary);
2221 7677118         cx->blk_loop.state_u.ary.ix =
2222 7677118         (PL_op->op_private & OPpITER_REVERSED) ?
2223 7677118 100       AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
    50        
2224           -1;
2225           }
2226           }
2227           else { /* iterating over items on the stack */
2228 22524246         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2229 22524246 100       if (PL_op->op_private & OPpITER_REVERSED) {
2230 7262         cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2231           }
2232           else {
2233 22516984         cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2234           }
2235           }
2236            
2237 30822074         RETURN;
2238           }
2239            
2240 35267572         PP(pp_enterloop)
2241           {
2242 35267572         dVAR; dSP;
2243           PERL_CONTEXT *cx;
2244 35267572 100       const I32 gimme = GIMME_V;
2245            
2246 35267572         ENTER_with_name("loop1");
2247 35267572         SAVETMPS;
2248 35267572         ENTER_with_name("loop2");
2249            
2250 35267572 100       PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2251 35267572         PUSHLOOP_PLAIN(cx, SP);
2252            
2253 35267572         RETURN;
2254           }
2255            
2256 60118060         PP(pp_leaveloop)
2257           {
2258 60118060         dVAR; dSP;
2259           PERL_CONTEXT *cx;
2260           I32 gimme;
2261           SV **newsp;
2262           PMOP *newpm;
2263           SV **mark;
2264            
2265 60118060         POPBLOCK(cx,newpm);
2266           assert(CxTYPE_is_LOOP(cx));
2267           mark = newsp;
2268 60118060         newsp = PL_stack_base + cx->blk_loop.resetsp;
2269            
2270 60118060         TAINT_NOT;
2271 60118060         SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0);
2272 60118060         PUTBACK;
2273            
2274 60118060 100       POPLOOP(cx); /* Stack values are safe: release loop vars ... */
    100        
2275 60118060         PL_curpm = newpm; /* ... and pop $1 et al */
2276            
2277 60118060         LEAVE_with_name("loop2");
2278 60118060         LEAVE_with_name("loop1");
2279            
2280 60118060         return NORMAL;
2281           }
2282            
2283           STATIC void
2284 1600         S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2285           PERL_CONTEXT *cx, PMOP *newpm)
2286           {
2287 1600         const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2288 1600 100       if (gimme == G_SCALAR) {
2289 1158 100       if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
    100        
2290           SV *sv;
2291           const char *what = NULL;
2292 540 100       if (MARK < SP) {
2293           assert(MARK+1 == SP);
2294 801 100       if ((SvPADTMP(TOPs) ||
    100        
2295 530         (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2296           == SVf_READONLY
2297 14 50       ) &&
2298 14         !SvSMAGICAL(TOPs)) {
2299           what =
2300 24         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2301 19 100       : "a readonly value" : "a temporary";
    100        
2302           }
2303           else goto copy_sv;
2304           }
2305           else {
2306           /* sub:lvalue{} will take us here. */
2307           what = "undef";
2308           }
2309 18         LEAVE;
2310 18         cxstack_ix--;
2311 27 50       POPSUB(cx,sv);
    50        
    50        
    50        
    50        
2312 18         PL_curpm = newpm;
2313 18         LEAVESUB(sv);
2314 18         Perl_croak(aTHX_
2315           "Can't return %s from lvalue subroutine", what
2316           );
2317           }
2318 618 50       if (MARK < SP) {
    0        
2319           copy_sv:
2320 1710 50       if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
    100        
2321 14 100       if (!SvPADTMP(*SP)) {
2322 20         *++newsp = SvREFCNT_inc(*SP);
2323 10 100       FREETMPS;
2324 10         sv_2mortal(*newsp);
2325           }
2326           else {
2327           /* FREETMPS could clobber it */
2328 4         SV *sv = SvREFCNT_inc(*SP);
2329 4 50       FREETMPS;
2330 4         *++newsp = sv_mortalcopy(sv);
2331 4         SvREFCNT_dec(sv);
2332           }
2333           }
2334           else
2335 1689         *++newsp =
2336 1126         SvPADTMP(*SP)
2337 238         ? sv_mortalcopy(*SP)
2338 1245 100       : !SvTEMP(*SP)
2339 798         ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2340 1287 100       : *SP;
2341           }
2342           else {
2343 0         EXTEND(newsp,1);
2344 0         *++newsp = &PL_sv_undef;
2345           }
2346 1152 100       if (CxLVAL(cx) & OPpDEREF) {
    50        
2347 12         SvGETMAGIC(TOPs);
2348 24 50       if (!SvOK(TOPs)) {
    50        
    50        
2349 24         TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2350           }
2351           }
2352           }
2353 442 100       else if (gimme == G_ARRAY) {
2354           assert (!(CxLVAL(cx) & OPpDEREF));
2355 360 100       if (ref || !CxLVAL(cx))
    100        
2356 728 100       while (++MARK <= SP)
2357 636         *++newsp =
2358 424         SvFLAGS(*MARK) & SVs_PADTMP
2359 88         ? sv_mortalcopy(*MARK)
2360 468 100       : SvTEMP(*MARK)
2361           ? *MARK
2362 336 100       : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2363 104 100       else while (++MARK <= SP) {
2364 56 100       if (*MARK != &PL_sv_undef
2365 50 100       && (SvPADTMP(*MARK)
2366 46 100       || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2367           == SVf_READONLY
2368           )
2369           ) {
2370           SV *sv;
2371           /* Might be flattened array after $#array = */
2372 8         PUTBACK;
2373 8         LEAVE;
2374 8         cxstack_ix--;
2375 12 50       POPSUB(cx,sv);
    50        
    50        
    50        
    50        
2376 8         PL_curpm = newpm;
2377 8         LEAVESUB(sv);
2378           /* diag_listed_as: Can't return %s from lvalue subroutine */
2379 8 100       Perl_croak(aTHX_
2380           "Can't return a %s from lvalue subroutine",
2381 8         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2382           }
2383           else
2384 72         *++newsp =
2385 48         SvTEMP(*MARK)
2386           ? *MARK
2387 48 50       : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2388           }
2389           }
2390 1574         PL_stack_sp = newsp;
2391 1574         }
2392            
2393 242741932         PP(pp_return)
2394           {
2395 242741932         dVAR; dSP; dMARK;
2396           PERL_CONTEXT *cx;
2397           bool popsub2 = FALSE;
2398           bool clear_errsv = FALSE;
2399           bool lval = FALSE;
2400           I32 gimme;
2401           SV **newsp;
2402           PMOP *newpm;
2403           I32 optype = 0;
2404           SV *namesv;
2405           SV *sv;
2406           OP *retop = NULL;
2407            
2408 242741932         const I32 cxix = dopoptosub(cxstack_ix);
2409            
2410 242741932 100       if (cxix < 0) {
2411 13662 50       if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2412           * sort block, which is a CXt_NULL
2413           * not a CXt_SUB */
2414 13662         dounwind(0);
2415 13662         PL_stack_base[1] = *PL_stack_sp;
2416 13662         PL_stack_sp = PL_stack_base + 1;
2417 13662         return 0;
2418           }
2419           else
2420 0         DIE(aTHX_ "Can't return outside a subroutine");
2421           }
2422 242728270 100       if (cxix < cxstack_ix)
2423 19304455         dounwind(cxix);
2424            
2425 242728270 100       if (CxMULTICALL(&cxstack[cxix])) {
2426 34926         gimme = cxstack[cxix].blk_gimme;
2427 34926 50       if (gimme == G_VOID)
2428 0         PL_stack_sp = PL_stack_base;
2429 34926 50       else if (gimme == G_SCALAR) {
2430 34926         PL_stack_base[1] = *PL_stack_sp;
2431 34926         PL_stack_sp = PL_stack_base + 1;
2432           }
2433           return 0;
2434           }
2435            
2436 242693344         POPBLOCK(cx,newpm);
2437 242693344         switch (CxTYPE(cx)) {
2438           case CXt_SUB:
2439           popsub2 = TRUE;
2440 242683650         lval = !!CvLVALUE(cx->blk_sub.cv);
2441 242683650         retop = cx->blk_sub.retop;
2442 242683650         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2443 242683650         break;
2444           case CXt_EVAL:
2445 9630 50       if (!(PL_in_eval & EVAL_KEEPERR))
2446           clear_errsv = TRUE;
2447 9630 100       POPEVAL(cx);
    50        
    100        
2448 9630         namesv = cx->blk_eval.old_namesv;
2449 9630         retop = cx->blk_eval.retop;
2450 9630 100       if (CxTRYBLOCK(cx))
2451           break;
2452 9647 100       if (optype == OP_REQUIRE &&
    50        
    50        
    50        
    100        
    50        
2453 32 50       (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
    50        
    0        
    0        
    0        
    50        
    50        
    0        
    0        
    50        
    50        
    50        
    0        
    0        
    50        
    0        
2454           {
2455           /* Unassume the success we assumed earlier. */
2456 0 0       (void)hv_delete(GvHVn(PL_incgv),
    0        
2457           SvPVX_const(namesv),
2458           SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2459           G_DISCARD);
2460 0         DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2461           }
2462           break;
2463           case CXt_FORMAT:
2464 64         retop = cx->blk_sub.retop;
2465 96 50       POPFORMAT(cx);
    50        
2466 64         break;
2467           default:
2468 0         DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2469           }
2470            
2471 242693344         TAINT_NOT;
2472 242693344 100       if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2473           else {
2474 242693178 100       if (gimme == G_SCALAR) {
2475 202009446 100       if (MARK < SP) {
2476 189173474 100       if (popsub2) {
2477 283736623 50       if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
    100        
2478 30841704 100       if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2479 20561136         && !SvMAGICAL(TOPs)) {
2480 18878088         *++newsp = SvREFCNT_inc(*SP);
2481 9439044 50       FREETMPS;
2482 9439044         sv_2mortal(*newsp);
2483           }
2484           else {
2485 11122092         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2486 11122092 100       FREETMPS;
2487 11122092         *++newsp = sv_mortalcopy(sv);
2488 11122092         SvREFCNT_dec(sv);
2489           }
2490           }
2491 252894919 100       else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2492 168602750         && !SvMAGICAL(*SP)) {
2493 15533618         *++newsp = *SP;
2494           }
2495           else
2496 153069132         *++newsp = sv_mortalcopy(*SP);
2497           }
2498           else
2499 9588         *++newsp = sv_mortalcopy(*SP);
2500           }
2501           else
2502 12835972         *++newsp = &PL_sv_undef;
2503           }
2504 40683732 100       else if (gimme == G_ARRAY) {
2505 45802312 100       while (++MARK <= SP) {
2506 85091069         *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2507 28363691 100       && !SvGMAGICAL(*MARK)
2508 44502568 50       ? *MARK : sv_mortalcopy(*MARK);
2509 28363687         TAINT_NOT; /* Each item is independent */
2510           }
2511           }
2512 242693170         PL_stack_sp = newsp;
2513           }
2514            
2515 242693330         LEAVE;
2516           /* Stack values are safe: */
2517 242693330 100       if (popsub2) {
2518 242683636         cxstack_ix--;
2519 364010766 100       POPSUB(cx,sv); /* release CV and @_ ... */
    100        
    50        
    50        
    100        
2520           }
2521           else
2522           sv = NULL;
2523 242693330         PL_curpm = newpm; /* ... and pop $1 et al */
2524            
2525 242693330         LEAVESUB(sv);
2526 242693330 100       if (clear_errsv) {
2527 121390462 50       CLEAR_ERRSV();
    50        
    50        
2528           }
2529           return retop;
2530           }
2531            
2532           /* This duplicates parts of pp_leavesub, so that it can share code with
2533           * pp_return */
2534 1434         PP(pp_leavesublv)
2535           {
2536 1434         dVAR; dSP;
2537           SV **newsp;
2538           PMOP *newpm;
2539           I32 gimme;
2540           PERL_CONTEXT *cx;
2541           SV *sv;
2542            
2543 1434 50       if (CxMULTICALL(&cxstack[cxstack_ix]))
2544           return 0;
2545            
2546 1434         POPBLOCK(cx,newpm);
2547 1434         cxstack_ix++; /* temporarily protect top context */
2548            
2549 1434         TAINT_NOT;
2550            
2551 1434         S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2552            
2553 1414         LEAVE;
2554 2121 100       POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
    50        
    50        
    50        
    100        
2555 1414         cxstack_ix--;
2556 1414         PL_curpm = newpm; /* ... and pop $1 et al */
2557            
2558 1414         LEAVESUB(sv);
2559 1414         return cx->blk_sub.retop;
2560           }
2561            
2562           static I32
2563 11685427         S_unwind_loop(pTHX_ const char * const opname)
2564           {
2565           dVAR;
2566           I32 cxix;
2567 11685427 100       if (PL_op->op_flags & OPf_SPECIAL) {
2568 11356549         cxix = dopoptoloop(cxstack_ix);
2569 11356549 100       if (cxix < 0)
2570           /* diag_listed_as: Can't "last" outside a loop block */
2571 22         Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2572           }
2573           else {
2574 328878         dSP;
2575           STRLEN label_len;
2576           const char * const label =
2577 328878         PL_op->op_flags & OPf_STACKED
2578 12         ? SvPV(TOPs,label_len)
2579 328884 100       : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
    50        
2580           const U32 label_flags =
2581 328878         PL_op->op_flags & OPf_STACKED
2582 9         ? SvUTF8(POPs)
2583 493317 100       : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
    100        
2584 328878         PUTBACK;
2585 328878         cxix = dopoptolabel(label, label_len, label_flags);
2586 328878 100       if (cxix < 0)
2587           /* diag_listed_as: Label not found for "last %s" */
2588 15 50       Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2589           opname,
2590 10 0       SVfARG(PL_op->op_flags & OPf_STACKED
2591           && !SvGMAGICAL(TOPp1s)
2592           ? TOPp1s
2593           : newSVpvn_flags(label,
2594           label_len,
2595           label_flags | SVs_TEMP)));
2596           }
2597 11685395 100       if (cxix < cxstack_ix)
2598 7257004         dounwind(cxix);
2599 11685395         return cxix;
2600           }
2601            
2602 2062595         PP(pp_last)
2603           {
2604           dVAR;
2605           PERL_CONTEXT *cx;
2606           I32 pop2 = 0;
2607           I32 gimme;
2608           I32 optype;
2609           OP *nextop = NULL;
2610           SV **newsp;
2611           PMOP *newpm;
2612           SV **mark;
2613           SV *sv = NULL;
2614            
2615 2062595         S_unwind_loop(aTHX_ "last");
2616            
2617 2062579         POPBLOCK(cx,newpm);
2618 2062579         cxstack_ix++; /* temporarily protect top context */
2619           mark = newsp;
2620 2062579         switch (CxTYPE(cx)) {
2621           case CXt_LOOP_LAZYIV:
2622           case CXt_LOOP_LAZYSV:
2623           case CXt_LOOP_FOR:
2624           case CXt_LOOP_PLAIN:
2625 2062579         pop2 = CxTYPE(cx);
2626 2062579         newsp = PL_stack_base + cx->blk_loop.resetsp;
2627 2062579         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2628 2062579         break;
2629           case CXt_SUB:
2630           pop2 = CXt_SUB;
2631 0         nextop = cx->blk_sub.retop;
2632 0         break;
2633           case CXt_EVAL:
2634 0 0       POPEVAL(cx);
    0        
    0        
2635 0         nextop = cx->blk_eval.retop;
2636 0         break;
2637           case CXt_FORMAT:
2638 0 0       POPFORMAT(cx);
    0        
2639 0         nextop = cx->blk_sub.retop;
2640 0         break;
2641           default:
2642 0         DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2643           }
2644            
2645 2062579         TAINT_NOT;
2646 2062579 50       PL_stack_sp = adjust_stack_on_leave(newsp, PL_stack_sp, MARK, gimme,
2647           pop2 == CXt_SUB ? SVs_TEMP : 0);
2648            
2649 2062579         LEAVE;
2650 2062579         cxstack_ix--;
2651           /* Stack values are safe: */
2652 2062579         switch (pop2) {
2653           case CXt_LOOP_LAZYIV:
2654           case CXt_LOOP_PLAIN:
2655           case CXt_LOOP_LAZYSV:
2656           case CXt_LOOP_FOR:
2657 2062579 100       POPLOOP(cx); /* release loop vars ... */
    100        
2658 2062579         LEAVE;
2659 2062579         break;
2660           case CXt_SUB:
2661 0 0       POPSUB(cx,sv); /* release CV and @_ ... */
    0        
    0        
    0        
    0        
2662           break;
2663           }
2664 2062579         PL_curpm = newpm; /* ... and pop $1 et al */
2665            
2666 2062579         LEAVESUB(sv);
2667           PERL_UNUSED_VAR(optype);
2668           PERL_UNUSED_VAR(gimme);
2669 2062579         return nextop;
2670           }
2671            
2672 9356754         PP(pp_next)
2673           {
2674           dVAR;
2675           PERL_CONTEXT *cx;
2676 9356754         const I32 inner = PL_scopestack_ix;
2677            
2678 9356754         S_unwind_loop(aTHX_ "next");
2679            
2680           /* clear off anything above the scope we're re-entering, but
2681           * save the rest until after a possible continue block */
2682 9356740         TOPBLOCK(cx);
2683 9356740 100       if (PL_scopestack_ix < inner)
2684 5320604         leave_scope(PL_scopestack[PL_scopestack_ix]);
2685 9356740         PL_curcop = cx->blk_oldcop;
2686 9356740 50       PERL_ASYNC_CHECK();
2687 9356740         return (cx)->blk_loop.my_op->op_nextop;
2688           }
2689            
2690 266078         PP(pp_redo)
2691           {
2692           dVAR;
2693 266078         const I32 cxix = S_unwind_loop(aTHX_ "redo");
2694           PERL_CONTEXT *cx;
2695           I32 oldsave;
2696 266076         OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2697            
2698 266076 100       if (redo_op->op_type == OP_ENTER) {
2699           /* pop one less context to avoid $x being freed in while (my $x..) */
2700 53056         cxstack_ix++;
2701           assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2702 53056         redo_op = redo_op->op_next;
2703           }
2704            
2705 266076         TOPBLOCK(cx);
2706 266076         oldsave = PL_scopestack[PL_scopestack_ix - 1];
2707 266076 100       LEAVE_SCOPE(oldsave);
2708 266076 100       FREETMPS;
2709 266076         PL_curcop = cx->blk_oldcop;
2710 266076 50       PERL_ASYNC_CHECK();
2711 266076         return redo_op;
2712           }
2713            
2714           STATIC OP *
2715 948374         S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2716           {
2717           dVAR;
2718           OP **ops = opstack;
2719           static const char* const too_deep = "Target of goto is too deeply nested";
2720            
2721           PERL_ARGS_ASSERT_DOFINDLABEL;
2722            
2723 948374 50       if (ops >= oplimit)
2724 0         Perl_croak(aTHX_ "%s", too_deep);
2725 1422561 100       if (o->op_type == OP_LEAVE ||
2726 948374         o->op_type == OP_SCOPE ||
2727 903014 100       o->op_type == OP_LEAVELOOP ||
2728 1352521 100       o->op_type == OP_LEAVESUB ||
2729 901014         o->op_type == OP_LEAVETRY)
2730           {
2731 47442         *ops++ = cUNOPo->op_first;
2732 47442 50       if (ops >= oplimit)
2733 0         Perl_croak(aTHX_ "%s", too_deep);
2734           }
2735 948374         *ops = 0;
2736 948374 100       if (o->op_flags & OPf_KIDS) {
2737           OP *kid;
2738           /* First try all the kids at this level, since that's likeliest. */
2739 1506702 100       for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2740 1033752 100       if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2741           STRLEN kid_label_len;
2742           U32 kid_label_flags;
2743 133896         const char *kid_label = CopLABEL_len_flags(kCOP,
2744           &kid_label_len, &kid_label_flags);
2745 151016 100       if (kid_label && (
    50        
    0        
    100        
    100        
2746 8560         ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2747 0         (flags & SVf_UTF8)
2748 0         ? (bytes_cmp_utf8(
2749           (const U8*)kid_label, kid_label_len,
2750           (const U8*)label, len) == 0)
2751 0         : (bytes_cmp_utf8(
2752           (const U8*)label, len,
2753           (const U8*)kid_label, kid_label_len) == 0)
2754 11814 50       : ( len == kid_label_len && ((kid_label == label)
2755 8047 100       || memEQ(kid_label, label, len)))))
2756           return kid;
2757           }
2758           }
2759 1402478 100       for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2760 938076 100       if (kid == PL_lastgotoprobe)
2761 2858         continue;
2762 935218 100       if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2763 84656 100       if (ops == opstack)
2764 5956         *ops++ = kid;
2765 78700 100       else if (ops[-1]->op_type == OP_NEXTSTATE ||
2766           ops[-1]->op_type == OP_DBSTATE)
2767 45826         ops[-1] = kid;
2768           else
2769 32874         *ops++ = kid;
2770           }
2771 935218 100       if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2772           return o;
2773           }
2774           }
2775 934622         *ops = 0;
2776 941498         return 0;
2777           }
2778            
2779 122908         PP(pp_goto)
2780           {
2781 122908         dVAR; dSP;
2782           OP *retop = NULL;
2783           I32 ix;
2784           PERL_CONTEXT *cx;
2785           #define GOTO_DEPTH 64
2786           OP *enterops[GOTO_DEPTH];
2787           const char *label = NULL;
2788 122908         STRLEN label_len = 0;
2789           U32 label_flags = 0;
2790 122908         const bool do_dump = (PL_op->op_type == OP_DUMP);
2791           static const char* const must_have_label = "goto must have label";
2792            
2793 180495 100       if (PL_op->op_flags & OPf_STACKED) {
    100        
2794 117690         SV * const sv = POPs;
2795 57589         SvGETMAGIC(sv);
2796            
2797           /* This egregious kludge implements goto &subroutine */
2798 117690 100       if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
    50        
2799           I32 cxix;
2800           PERL_CONTEXT *cx;
2801 117668         CV *cv = MUTABLE_CV(SvRV(sv));
2802 117669         AV *arg = GvAV(PL_defgv);
2803           I32 oldsave;
2804            
2805           retry:
2806 117670 100       if (!CvROOT(cv) && !CvXSUB(cv)) {
    50        
2807           const GV * const gv = CvGV(cv);
2808 6 50       if (gv) {
2809           GV *autogv;
2810           SV *tmpstr;
2811           /* autoloaded stub? */
2812 6 50       if (cv != GvCV(gv) && (cv = GvCV(gv)))
    0        
2813           goto retry;
2814 6 100       autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2815           GvNAMELEN(gv),
2816           GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2817 6 100       if (autogv && (cv = GvCV(autogv)))
    50        
2818           goto retry;
2819 4         tmpstr = sv_newmortal();
2820 4         gv_efullname3(tmpstr, gv, NULL);
2821 4         DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2822           }
2823 0         DIE(aTHX_ "Goto undefined subroutine");
2824           }
2825            
2826           /* First do some returnish stuff. */
2827 117664 50       SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2828 117664 100       FREETMPS;
2829 117664         cxix = dopoptosub(cxstack_ix);
2830 117664 100       if (cxix < cxstack_ix) {
2831 572 100       if (cxix < 0) {
2832 10         SvREFCNT_dec(cv);
2833 10         DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2834           }
2835 562         dounwind(cxix);
2836           }
2837 117654         TOPBLOCK(cx);
2838 117654         SPAGAIN;
2839           /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2840 117654 100       if (CxTYPE(cx) == CXt_EVAL) {
2841 8         SvREFCNT_dec(cv);
2842 8 100       if (CxREALEVAL(cx))
2843           /* diag_listed_as: Can't goto subroutine from an eval-%s */
2844 6         DIE(aTHX_ "Can't goto subroutine from an eval-string");
2845           else
2846           /* diag_listed_as: Can't goto subroutine from an eval-%s */
2847 2         DIE(aTHX_ "Can't goto subroutine from an eval-block");
2848           }
2849 117646 100       else if (CxMULTICALL(cx))
2850           {
2851 6         SvREFCNT_dec(cv);
2852 6         DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2853           }
2854 117640 100       if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2855 117562         AV* av = cx->blk_sub.argarray;
2856            
2857           /* abandon the original @_ if it got reified or if it is
2858           the same as the current @_ */
2859 117562 100       if (AvREAL(av) || av == arg) {
2860 117558         SvREFCNT_dec(av);
2861 117558         av = newAV();
2862 117558         AvREIFY_only(av);
2863 117558         PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2864           }
2865 4         else CLEAR_ARGARRAY(av);
2866           }
2867           /* We donate this refcount later to the callee’s pad. */
2868 117640 50       SvREFCNT_inc_simple_void(arg);
2869 175202 50       if (CxTYPE(cx) == CXt_SUB &&
    100        
2870 235280         !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2871 117638         SvREFCNT_dec(cx->blk_sub.cv);
2872 117640         oldsave = PL_scopestack[PL_scopestack_ix - 1];
2873 117640 50       LEAVE_SCOPE(oldsave);
2874            
2875           /* A destructor called during LEAVE_SCOPE could have undefined
2876           * our precious cv. See bug #99850. */
2877 117640 100       if (!CvROOT(cv) && !CvXSUB(cv)) {
    50        
2878           const GV * const gv = CvGV(cv);
2879 2         SvREFCNT_dec(arg);
2880 2 50       if (gv) {
2881 2         SV * const tmpstr = sv_newmortal();
2882 2         gv_efullname3(tmpstr, gv, NULL);
2883 2         DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2884           SVfARG(tmpstr));
2885           }
2886 0         DIE(aTHX_ "Goto undefined subroutine");
2887           }
2888            
2889           /* Now do some callish stuff. */
2890 117638         SAVETMPS;
2891 117638         SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2892 117656 100       if (CvISXSUB(cv)) {
    50        
2893 36         OP* const retop = cx->blk_sub.retop;
2894           SV **newsp;
2895           I32 gimme;
2896 36         const SSize_t items = AvFILLp(arg) + 1;
2897           SV** mark;
2898            
2899           PERL_UNUSED_VAR(newsp);
2900           PERL_UNUSED_VAR(gimme);
2901            
2902           /* put GvAV(defgv) back onto stack */
2903 18         EXTEND(SP, items+1); /* @_ could have been extended. */
2904 36 50       Copy(AvARRAY(arg), SP + 1, items, SV*);
2905           mark = SP;
2906 36         SP += items;
2907 36 100       if (AvREAL(arg)) {
2908           I32 index;
2909 6 100       for (index=0; index
2910 4         SvREFCNT_inc_void(sv_2mortal(SP[-index]));
2911           }
2912 36         SvREFCNT_dec(arg);
2913 36 100       if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2914           /* Restore old @_ */
2915 30         arg = GvAV(PL_defgv);
2916 30         GvAV(PL_defgv) = cx->blk_sub.savearray;
2917 30         SvREFCNT_dec(arg);
2918           }
2919            
2920           /* XS subs don't have a CxSUB, so pop it */
2921 36         POPBLOCK(cx, PL_curpm);
2922           /* Push a mark for the start of arglist */
2923 36 50       PUSHMARK(mark);
2924 36         PUTBACK;
2925 36         (void)(*CvXSUB(cv))(aTHX_ cv);
2926 28         LEAVE;
2927 28 50       PERL_ASYNC_CHECK();
2928           return retop;
2929           }
2930           else {
2931 117602         PADLIST * const padlist = CvPADLIST(cv);
2932 117602         cx->blk_sub.cv = cv;
2933 117602         cx->blk_sub.olddepth = CvDEPTH(cv);
2934            
2935 117602         CvDEPTH(cv)++;
2936 117602 100       if (CvDEPTH(cv) < 2)
2937 116270         SvREFCNT_inc_simple_void_NN(cv);
2938           else {
2939 1332 100       if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
    50        
2940 0         sub_crush_depth(cv);
2941 1332         pad_push(padlist, CvDEPTH(cv));
2942           }
2943 117602         PL_curcop = cx->blk_oldcop;
2944 117602         SAVECOMPPAD();
2945 235204         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2946 117602 100       if (CxHASARGS(cx))
2947           {
2948 117530         CX_CURPAD_SAVE(cx->blk_sub);
2949            
2950           /* cx->blk_sub.argarray has no reference count, so we
2951           need something to hang on to our argument array so
2952           that cx->blk_sub.argarray does not end up pointing
2953           to freed memory as the result of undef *_. So put
2954           it in the callee’s pad, donating our refer-
2955           ence count. */
2956 117530         SvREFCNT_dec(PAD_SVl(0));
2957 117530         PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2958            
2959           /* GvAV(PL_defgv) might have been modified on scope
2960           exit, so restore it. */
2961 117530 100       if (arg != GvAV(PL_defgv)) {
2962 2         AV * const av = GvAV(PL_defgv);
2963 4         GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2964 2         SvREFCNT_dec(av);
2965           }
2966           }
2967 72         else SvREFCNT_dec(arg);
2968 117602 100       if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
    100        
2969 42         Perl_get_db_sub(aTHX_ NULL, cv);
2970 42 50       if (PERLDB_GOTO) {
    50        
2971 0         CV * const gotocv = get_cvs("DB::goto", 0);
2972 0 0       if (gotocv) {
2973 0 0       PUSHMARK( PL_stack_sp );
2974 0         call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2975 0         PL_stack_sp--;
2976           }
2977           }
2978           }
2979 117602 50       PERL_ASYNC_CHECK();
2980 117602         RETURNOP(CvSTART(cv));
2981           }
2982           }
2983           else {
2984 22 50       label = SvPV_nomg_const(sv, label_len);
2985 22         label_flags = SvUTF8(sv);
2986           }
2987           }
2988 5218 100       else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2989 5216         label = cPVOP->op_pv;
2990 5216 100       label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2991 5216         label_len = strlen(label);
2992           }
2993 5240 100       if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
    100        
2994            
2995 5234 50       PERL_ASYNC_CHECK();
2996            
2997 5234 50       if (label_len) {
2998           OP *gotoprobe = NULL;
2999           bool leaving_eval = FALSE;
3000           bool in_block = FALSE;
3001           PERL_CONTEXT *last_eval_cx = NULL;
3002            
3003           /* find label */
3004            
3005 5234         PL_lastgotoprobe = NULL;
3006 5234         *enterops = 0;
3007 13170 100       for (ix = cxstack_ix; ix >= 0; ix--) {
3008 13154         cx = &cxstack[ix];
3009 13154         switch (CxTYPE(cx)) {
3010           case CXt_EVAL:
3011           leaving_eval = TRUE;
3012 90 100       if (!CxTRYBLOCK(cx)) {
3013           gotoprobe = (last_eval_cx ?
3014 74 100       last_eval_cx->blk_eval.old_eval_root :
3015           PL_eval_root);
3016           last_eval_cx = cx;
3017 74         break;
3018           }
3019           /* else fall through */
3020           case CXt_LOOP_LAZYIV:
3021           case CXt_LOOP_LAZYSV:
3022           case CXt_LOOP_FOR:
3023           case CXt_LOOP_PLAIN:
3024           case CXt_GIVEN:
3025           case CXt_WHEN:
3026 908         gotoprobe = cx->blk_oldcop->op_sibling;
3027 908         break;
3028           case CXt_SUBST:
3029 0         continue;
3030           case CXt_BLOCK:
3031 10158 100       if (ix) {
3032 10092         gotoprobe = cx->blk_oldcop->op_sibling;
3033           in_block = TRUE;
3034           } else
3035 66         gotoprobe = PL_main_root;
3036           break;
3037           case CXt_SUB:
3038 3018 50       if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
    100        
3039 2000         gotoprobe = CvROOT(cx->blk_sub.cv);
3040 2000         break;
3041           }
3042           /* FALL THROUGH */
3043           case CXt_FORMAT:
3044           case CXt_NULL:
3045 14         DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3046           default:
3047 0 0       if (ix)
3048 0         DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3049 0         CxTYPE(cx), (long) ix);
3050 0         gotoprobe = PL_main_root;
3051 0         break;
3052           }
3053 13140 50       if (gotoprobe) {
3054 13140         retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3055           enterops, enterops + GOTO_DEPTH);
3056 13140 100       if (retop)
3057           break;
3058 10535 100       if (gotoprobe->op_sibling &&
    100        
3059 2805 100       gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3060 218         gotoprobe->op_sibling->op_sibling) {
3061 16         retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3062           label, label_len, label_flags, enterops,
3063           enterops + GOTO_DEPTH);
3064 16 100       if (retop)
3065           break;
3066           }
3067           }
3068 7936         PL_lastgotoprobe = gotoprobe;
3069           }
3070 5220 100       if (!retop)
3071 16         DIE(aTHX_ "Can't find label %"UTF8f,
3072           UTF8fARG(label_flags, label_len, label));
3073            
3074           /* if we're leaving an eval, check before we pop any frames
3075           that we're not going to punt, otherwise the error
3076           won't be caught */
3077            
3078 5204 100       if (leaving_eval && *enterops && enterops[1]) {
    100        
    100        
3079           I32 i;
3080 12 100       for (i = 1; enterops[i]; i++)
3081 12 100       if (enterops[i]->op_type == OP_ENTERITER)
3082 4         DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3083           }
3084            
3085 5200 100       if (*enterops && enterops[1]) {
    100        
3086 28 100       I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
    100        
3087 28 100       if (enterops[i])
3088 14         deprecate("\"goto\" to jump into a construct");
3089           }
3090            
3091           /* pop unwanted frames */
3092            
3093 5200 100       if (ix < cxstack_ix) {
3094           I32 oldsave;
3095            
3096 5042 50       if (ix < 0)
3097           ix = 0;
3098 5042         dounwind(ix);
3099 5042         TOPBLOCK(cx);
3100 5042         oldsave = PL_scopestack[PL_scopestack_ix];
3101 5042 100       LEAVE_SCOPE(oldsave);
3102           }
3103            
3104           /* push wanted frames */
3105            
3106 5200 100       if (*enterops && enterops[1]) {
    100        
3107 28         OP * const oldop = PL_op;
3108 28 100       ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
    100        
3109 58 100       for (; enterops[ix]; ix++) {
3110 30         PL_op = enterops[ix];
3111           /* Eventually we may want to stack the needed arguments
3112           * for each op. For now, we punt on the hard ones. */
3113 30 50       if (PL_op->op_type == OP_ENTERITER)
3114 0         DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3115 30         PL_op->op_ppaddr(aTHX);
3116           }
3117 28         PL_op = oldop;
3118           }
3119           }
3120            
3121 5200 50       if (do_dump) {
3122           #ifdef VMS
3123           if (!retop) retop = PL_main_start;
3124           #endif
3125 0         PL_restartop = retop;
3126 0         PL_do_undump = TRUE;
3127            
3128 0         my_unexec();
3129            
3130 0         PL_restartop = 0; /* hmm, must be GNU unexec().. */
3131 0         PL_do_undump = FALSE;
3132           }
3133            
3134 5200 50       PERL_ASYNC_CHECK();
3135 65273         RETURNOP(retop);
3136           }
3137            
3138 1268         PP(pp_exit)
3139           {
3140           dVAR;
3141 1268         dSP;
3142           I32 anum;
3143            
3144 1268 100       if (MAXARG < 1)
3145           anum = 0;
3146 1076 100       else if (!TOPs) {
3147           anum = 0; (void)POPs;
3148           }
3149           else {
3150 1074 100       anum = SvIVx(POPs);
3151           #ifdef VMS
3152           if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
3153           anum = 0;
3154           VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
3155           #endif
3156           }
3157 1268         PL_exit_flags |= PERL_EXIT_EXPECTED;
3158           #ifdef PERL_MAD
3159           /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3160           if (anum || !(PL_minus_c && PL_madskills))
3161           my_exit(anum);
3162           #else
3163 1268         my_exit(anum);
3164           #endif
3165           PUSHs(&PL_sv_undef);
3166           RETURN;
3167           }
3168            
3169           /* Eval. */
3170            
3171           STATIC void
3172           S_save_lines(pTHX_ AV *array, SV *sv)
3173           {
3174 940         const char *s = SvPVX_const(sv);
3175 940         const char * const send = SvPVX_const(sv) + SvCUR(sv);
3176           I32 line = 1;
3177            
3178           PERL_ARGS_ASSERT_SAVE_LINES;
3179            
3180 3326 100       while (s && s < send) {
3181           const char *t;
3182 2386         SV * const tmpstr = newSV_type(SVt_PVMG);
3183            
3184 2386         t = (const char *)memchr(s, '\n', send - s);
3185 2386 100       if (t)
3186 1446         t++;
3187           else
3188           t = send;
3189            
3190 2386         sv_setpvn(tmpstr, s, t - s);
3191 2386         av_store(array, line++, tmpstr);
3192           s = t;
3193           }
3194           }
3195            
3196           /*
3197           =for apidoc docatch
3198            
3199           Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3200            
3201           0 is used as continue inside eval,
3202            
3203           3 is used for a die caught by an inner eval - continue inner loop
3204            
3205           See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3206           establish a local jmpenv to handle exception traps.
3207            
3208           =cut
3209           */
3210           STATIC OP *
3211 26033         S_docatch(pTHX_ OP *o)
3212           {
3213           dVAR;
3214           int ret;
3215 26033         OP * const oldop = PL_op;
3216           dJMPENV;
3217            
3218           #ifdef DEBUGGING
3219           assert(CATCH_GET == TRUE);
3220           #endif
3221 26033         PL_op = o;
3222            
3223 26033         JMPENV_PUSH(ret);
3224 27447         switch (ret) {
3225           case 0:
3226           assert(cxstack_ix >= 0);
3227           assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3228 26033         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3229           redo_body:
3230 26899         CALLRUNOPS(aTHX);
3231           break;
3232           case 3:
3233           /* die caught by an inner eval - continue inner loop */
3234 1406 100       if (PL_restartop && PL_restartjmpenv == PL_top_env) {
    100        
3235 866         PL_restartjmpenv = NULL;
3236 866         PL_op = PL_restartop;
3237 866         PL_restartop = 0;
3238 866         goto redo_body;
3239           }
3240           /* FALL THROUGH */
3241           default:
3242 548         JMPENV_POP;
3243 548         PL_op = oldop;
3244 548 50       JMPENV_JUMP(ret);
    0        
3245           assert(0); /* NOTREACHED */
3246           }
3247 25485         JMPENV_POP;
3248 25485         PL_op = oldop;
3249 25485         return NULL;
3250           }
3251            
3252            
3253           /*
3254           =for apidoc find_runcv
3255            
3256           Locate the CV corresponding to the currently executing sub or eval.
3257           If db_seqp is non_null, skip CVs that are in the DB package and populate
3258           *db_seqp with the cop sequence number at the point that the DB:: code was
3259           entered. (allows debuggers to eval in the scope of the breakpoint rather
3260           than in the scope of the debugger itself).
3261            
3262           =cut
3263           */
3264            
3265           CV*
3266 6944666         Perl_find_runcv(pTHX_ U32 *db_seqp)
3267           {
3268 6944666         return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3269           }
3270            
3271           /* If this becomes part of the API, it might need a better name. */
3272           CV *
3273 6944816         Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3274           {
3275           dVAR;
3276           PERL_SI *si;
3277           int level = 0;
3278            
3279 6944816 100       if (db_seqp)
3280 3759872         *db_seqp =
3281           PL_curcop == &PL_compiling
3282           ? PL_cop_seqmax
3283 3759872 100       : PL_curcop->cop_seq;
3284            
3285 7229768 100       for (si = PL_curstackinfo; si; si = si->si_prev) {
3286           I32 ix;
3287 9579105 100       for (ix = si->si_cxix; ix >= 0; ix--) {
3288 9294153         const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3289           CV *cv = NULL;
3290 9294153 100       if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3291 6395848         cv = cx->blk_sub.cv;
3292           /* skip DB:: code */
3293 6395848 100       if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
    50        
    100        
3294 894         *db_seqp = cx->blk_oldcop->cop_seq;
3295 894         continue;
3296           }
3297 6394954 100       if (cx->cx_type & CXp_SUB_RE)
3298 8         continue;
3299           }
3300 2898305 100       else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
    100        
3301 265190         cv = cx->blk_eval.cv;
3302 9293251 100       if (cv) {
3303 6660136         switch (cond) {
3304           case FIND_RUNCV_padid_eq:
3305 20 50       if (!CvPADLIST(cv)
3306 20 100       || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg))
3307 12         continue;
3308           return cv;
3309           case FIND_RUNCV_level_eq:
3310 250 100       if (level++ != arg) continue;
3311           /* GERONIMO! */
3312           default:
3313           return cv;
3314           }
3315           }
3316           }
3317           }
3318 3631377 100       return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3319           }
3320            
3321            
3322           /* Run yyparse() in a setjmp wrapper. Returns:
3323           * 0: yyparse() successful
3324           * 1: yyparse() failed
3325           * 3: yyparse() died
3326           */
3327           STATIC int
3328 8662         S_try_yyparse(pTHX_ int gramtype)
3329           {
3330           int ret;
3331           dJMPENV;
3332            
3333           assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3334 8662         JMPENV_PUSH(ret);
3335 8676         switch (ret) {
3336           case 0:
3337 8662         ret = yyparse(gramtype) ? 1 : 0;
3338 8648         break;
3339           case 3:
3340           break;
3341           default:
3342 0         JMPENV_POP;
3343 0 0       JMPENV_JUMP(ret);
    0        
3344           assert(0); /* NOTREACHED */
3345           }
3346 8662         JMPENV_POP;
3347 8662         return ret;
3348           }
3349            
3350            
3351           /* Compile a require/do or an eval ''.
3352           *
3353           * outside is the lexically enclosing CV (if any) that invoked us.
3354           * seq is the current COP scope value.
3355           * hh is the saved hints hash, if any.
3356           *
3357           * Returns a bool indicating whether the compile was successful; if so,
3358           * PL_eval_start contains the first op of the compiled code; otherwise,
3359           * pushes undef.
3360           *
3361           * This function is called from two places: pp_require and pp_entereval.
3362           * These can be distinguished by whether PL_op is entereval.
3363           */
3364            
3365           STATIC bool
3366 4350983         S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3367           {
3368 4350983         dVAR; dSP;
3369 4350983         OP * const saveop = PL_op;
3370 4350983         bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3371 4350983         COP * const oldcurcop = PL_curcop;
3372 4350983         bool in_require = (saveop->op_type == OP_REQUIRE);
3373           int yystatus;
3374           CV *evalcv;
3375            
3376 6230788 100       PL_in_eval = (in_require
    100        
3377           ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3378           : (EVAL_INEVAL |
3379 3781928         ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3380           ? EVAL_RE_REPARSING : 0)));
3381            
3382 4350983 50       PUSHMARK(SP);
3383            
3384 4350983         evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3385 4350983         CvEVAL_on(evalcv);
3386           assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3387 4350983         cxstack[cxstack_ix].blk_eval.cv = evalcv;
3388 4350983         cxstack[cxstack_ix].blk_gimme = gimme;
3389            
3390 4350983         CvOUTSIDE_SEQ(evalcv) = seq;
3391 8701966         CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3392            
3393           /* set up a scratch pad */
3394            
3395 4350983         CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3396 4350983         PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3397            
3398            
3399           if (!PL_madskills)
3400 4350983         SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
3401            
3402           /* make sure we compile in the right package */
3403            
3404 4350983 100       if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3405 2930969         SAVEGENERICSV(PL_curstash);
3406 2930969         PL_curstash = (HV *)CopSTASH(PL_curcop);
3407 2930969 100       if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3408 2930967 50       else SvREFCNT_inc_simple_void(PL_curstash);
3409           }
3410           /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3411 4350983         SAVESPTR(PL_beginav);
3412 4350983         PL_beginav = newAV();
3413 4350983         SAVEFREESV(PL_beginav);
3414 4350983         SAVESPTR(PL_unitcheckav);
3415 4350983         PL_unitcheckav = newAV();
3416 4350983         SAVEFREESV(PL_unitcheckav);
3417            
3418           #ifdef PERL_MAD
3419           SAVEBOOL(PL_madskills);
3420           PL_madskills = 0;
3421           #endif
3422            
3423 4350983         ENTER_with_name("evalcomp");
3424 4350983         SAVESPTR(PL_compcv);
3425 4350983         PL_compcv = evalcv;
3426            
3427           /* try to compile it */
3428            
3429 4350983         PL_eval_root = NULL;
3430 4350983         PL_curcop = &PL_compiling;
3431 4350983 100       if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
    100        
3432 24         PL_in_eval |= EVAL_KEEPERR;
3433           else
3434 4350959 100       CLEAR_ERRSV();
    50        
    100        
3435            
3436 4350983         SAVEHINTS();
3437 4350983 100       if (clear_hints) {
3438 591111         PL_hints = 0;
3439 591111         hv_clear(GvHV(PL_hintgv));
3440           }
3441           else {
3442 5628602 100       PL_hints = saveop->op_private & OPpEVAL_COPHH
3443 3759778         ? oldcurcop->cop_hints : saveop->op_targ;
3444            
3445           /* making 'use re eval' not be in scope when compiling the
3446           * qr/mabye_has_runtime_code_block/ ensures that we don't get
3447           * infinite recursion when S_has_runtime_code() gives a false
3448           * positive: the second time round, HINT_RE_EVAL isn't set so we
3449           * don't bother calling S_has_runtime_code() */
3450 3759872 100       if (PL_in_eval & EVAL_RE_REPARSING)
3451 88         PL_hints &= ~HINT_RE_EVAL;
3452            
3453 3759872 100       if (hh) {
3454           /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3455 304798         SvREFCNT_dec(GvHV(PL_hintgv));
3456 304798         GvHV(PL_hintgv) = hh;
3457           }
3458           }
3459 4350983         SAVECOMPILEWARNINGS();
3460 4350983 100       if (clear_hints) {
3461 591111 100       if (PL_dowarn & G_WARN_ALL_ON)
3462 94         PL_compiling.cop_warnings = pWARN_ALL ;
3463 591017 100       else if (PL_dowarn & G_WARN_ALL_OFF)
3464 118         PL_compiling.cop_warnings = pWARN_NONE ;
3465           else
3466 590899         PL_compiling.cop_warnings = pWARN_STD ;
3467           }
3468           else {
3469 3759872         PL_compiling.cop_warnings =
3470 3759872 100       DUP_WARNINGS(oldcurcop->cop_warnings);
    100        
3471 3759872         cophh_free(CopHINTHASH_get(&PL_compiling));
3472 3759872 100       if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3473           /* The label, if present, is the first entry on the chain. So rather
3474           than writing a blank label in front of it (which involves an
3475           allocation), just use the next entry in the chain. */
3476           PL_compiling.cop_hints_hash
3477 26         = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3478           /* Check the assumption that this removed the label. */
3479           assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3480           }
3481           else
3482 3759846         PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3483           }
3484            
3485 4629661 100       CALL_BLOCK_HOOKS(bhk_eval, saveop);
    50        
    100        
    50        
    50        
    100        
3486            
3487           /* note that yyparse() may raise an exception, e.g. C,
3488           * so honour CATCH_GET and trap it here if necessary */
3489            
3490 4350983 100       yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
    100        
3491            
3492 4288861 100       if (yystatus || PL_parser->error_count || !PL_eval_root) {
    100        
    50        
3493           SV **newsp; /* Used by POPBLOCK. */
3494           PERL_CONTEXT *cx;
3495           I32 optype; /* Used by POPEVAL. */
3496           SV *namesv;
3497           SV *errsv = NULL;
3498            
3499           cx = NULL;
3500           namesv = NULL;
3501           PERL_UNUSED_VAR(newsp);
3502           PERL_UNUSED_VAR(optype);
3503            
3504           /* note that if yystatus == 3, then the EVAL CX block has already
3505           * been popped, and various vars restored */
3506 1262         PL_op = saveop;
3507 1262 100       if (yystatus != 3) {
3508 1248 100       if (PL_eval_root) {
3509 1186         op_free(PL_eval_root);
3510 1186         PL_eval_root = NULL;
3511           }
3512 1248         SP = PL_stack_base + POPMARK; /* pop original mark */
3513 1248         POPBLOCK(cx,PL_curpm);
3514 1248 50       POPEVAL(cx);
    50        
    100        
3515 1248         namesv = cx->blk_eval.old_namesv;
3516           /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3517 1248         LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
3518           }
3519            
3520 1262 50       errsv = ERRSV;
3521 1262 100       if (in_require) {
3522 22 50       if (!cx) {
3523           /* If cx is still NULL, it means that we didn't go in the
3524           * POPEVAL branch. */
3525 0         cx = &cxstack[cxstack_ix];
3526           assert(CxTYPE(cx) == CXt_EVAL);
3527 0         namesv = cx->blk_eval.old_namesv;
3528           }
3529 22 50       (void)hv_store(GvHVn(PL_incgv),
    50        
3530           SvPVX_const(namesv),
3531           SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3532           &PL_sv_undef, 0);
3533 22 50       Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3534           SVfARG(errsv
3535           ? errsv
3536           : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3537           }
3538           else {
3539 1240 50       if (!*(SvPV_nolen_const(errsv))) {
    50        
3540 0         sv_setpvs(errsv, "Compilation error");
3541           }
3542           }
3543 1240 100       if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3544 1240         PUTBACK;
3545 1240         return FALSE;
3546           }
3547           else
3548 4287599         LEAVE_with_name("evalcomp");
3549            
3550 4287599         CopLINE_set(&PL_compiling, 0);
3551 4287599         SAVEFREEOP(PL_eval_root);
3552 4287599         cv_forget_slab(evalcv);
3553            
3554           DEBUG_x(dump_eval());
3555            
3556           /* Register with debugger: */
3557 4287599 100       if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
    100        
    100        
3558 3150         CV * const cv = get_cvs("DB::postponed", 0);
3559 3150 100       if (cv) {
3560 768         dSP;
3561 768 50       PUSHMARK(SP);
3562 768 50       XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3563 768         PUTBACK;
3564 768         call_sv(MUTABLE_SV(cv), G_DISCARD);
3565           }
3566           }
3567            
3568 4287599 50       if (PL_unitcheckav) {
3569 4287599         OP *es = PL_eval_start;
3570 4287599         call_list(PL_scopestack_ix, PL_unitcheckav);
3571 4287599         PL_eval_start = es;
3572           }
3573            
3574           /* compiled okay, so do it */
3575            
3576 4287599         CvDEPTH(evalcv) = 1;
3577 4287599         SP = PL_stack_base + POPMARK; /* pop original mark */
3578 4287599         PL_op = saveop; /* The caller may need it. */
3579 4287599         PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
3580            
3581 4287599         PUTBACK;
3582 4288219         return TRUE;
3583           }
3584            
3585           STATIC PerlIO *
3586 3071434         S_check_type_and_open(pTHX_ SV *name)
3587           {
3588           Stat_t st;
3589 3071434 50       const char *p = SvPV_nolen_const(name);
3590           int st_rc;
3591            
3592           PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3593            
3594           /* checking here captures a reasonable error message when
3595           * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3596           * user gets a confusing message about looking for the .pmc file
3597           * rather than for the .pm file.
3598           * This check prevents a \0 in @INC causing problems.
3599           */
3600 3071434 50       if (!IS_SAFE_PATHNAME(name, "require"))
3601           return NULL;
3602            
3603           st_rc = PerlLIO_stat(p, &st);
3604            
3605 3071434 100       if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
    100        
    50        
3606           return NULL;
3607           }
3608            
3609           #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3610 1868256         return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3611           #else
3612           return PerlIO_open(p, PERL_SCRIPT_MODE);
3613           #endif
3614           }
3615            
3616           #ifndef PERL_DISABLE_PMC
3617           STATIC PerlIO *
3618 3071436         S_doopen_pm(pTHX_ SV *name)
3619           {
3620           STRLEN namelen;
3621 3071436 50       const char *p = SvPV_const(name, namelen);
3622            
3623           PERL_ARGS_ASSERT_DOOPEN_PM;
3624            
3625           /* check the name before trying for the .pmc name to avoid the
3626           * warning referring to the .pmc which the user probably doesn't
3627           * know or care about
3628           */
3629 3071436 100       if (!IS_SAFE_PATHNAME(name, "require"))
3630           return NULL;
3631            
3632 3071434 100       if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
    100        
3633 2923876         SV *const pmcsv = sv_newmortal();
3634           Stat_t pmcstat;
3635            
3636 2923876 50       SvSetSV_nosteal(pmcsv,name);
3637 2923876         sv_catpvn(pmcsv, "c", 1);
3638            
3639 5847752 50       if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
    100        
3640 8         return check_type_and_open(pmcsv);
3641           }
3642 3071431         return check_type_and_open(name);
3643           }
3644           #else
3645           # define doopen_pm(name) check_type_and_open(name)
3646           #endif /* !PERL_DISABLE_PMC */
3647            
3648           /* require doesn't search for absolute names, or when the name is
3649           explicity relative the current directory */
3650           PERL_STATIC_INLINE bool
3651           S_path_is_searchable(const char *name)
3652           {
3653           PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3654            
3655 6570031 100       if (PERL_FILE_IS_ABSOLUTE(name)
3656           #ifdef WIN32
3657           || (*name == '.' && ((name[1] == '/' ||
3658           (name[1] == '.' && name[2] == '/'))
3659           || (name[1] == '\\' ||
3660           ( name[1] == '.' && name[2] == '\\')))
3661           )
3662           #else
3663 6571566 100       || (*name == '.' && (name[1] == '/' ||
    100        
    100        
3664 3341844 50       (name[1] == '.' && name[2] == '/')))
3665           #endif
3666           )
3667           {
3668           return FALSE;
3669           }
3670           else
3671           return TRUE;
3672           }
3673            
3674 6728743         PP(pp_require)
3675           {
3676 6728743         dVAR; dSP;
3677           PERL_CONTEXT *cx;
3678           SV *sv;
3679           const char *name;
3680           STRLEN len;
3681           char * unixname;
3682           STRLEN unixlen;
3683           #ifdef VMS
3684           int vms_unixname = 0;
3685           char *unixnamebuf;
3686           char *unixdir;
3687           char *unixdirbuf;
3688           #endif
3689           const char *tryname = NULL;
3690           SV *namesv = NULL;
3691 6728743 100       const I32 gimme = GIMME_V;
3692           int filter_has_file = 0;
3693           PerlIO *tryrsfp = NULL;
3694           SV *filter_cache = NULL;
3695           SV *filter_state = NULL;
3696           SV *filter_sub = NULL;
3697           SV *hook_sv = NULL;
3698           SV *encoding;
3699           OP *op;
3700           int saved_errno;
3701           bool path_searchable;
3702            
3703 6728743         sv = POPs;
3704 6728743 100       if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
    100        
    50        
    100        
3705 158686         sv = sv_2mortal(new_version(sv));
3706 158686 100       if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3707 17238         upg_version(PL_patchlevel, TRUE);
3708 158686 100       if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
    100        
3709 34 100       if ( vcmp(sv,PL_patchlevel) <= 0 )
3710 18         DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3711 18         SVfARG(sv_2mortal(vnormal(sv))),
3712 18         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3713           );
3714           }
3715           else {
3716 158652 100       if ( vcmp(sv,PL_patchlevel) > 0 ) {
3717           I32 first = 0;
3718           AV *lav;
3719 36         SV * const req = SvRV(sv);
3720 36         SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3721            
3722           /* get the left hand term */
3723 36         lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3724            
3725 36 50       first = SvIV(*av_fetch(lav,0,0));
3726 36 100       if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
3727 20 100       || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3728 16 100       || av_len(lav) > 1 /* FP with > 3 digits */
3729 10 50       || strstr(SvPVX(pv),".0") /* FP with leading 0 */
3730           ) {
3731 26         DIE(aTHX_ "Perl %"SVf" required--this is only "
3732           "%"SVf", stopped",
3733 26         SVfARG(sv_2mortal(vnormal(req))),
3734 26         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3735           );
3736           }
3737           else { /* probably 'use 5.10' or 'use 5.8' */
3738           SV *hintsv;
3739           I32 second = 0;
3740            
3741 10 50       if (av_len(lav)>=1)
3742 10 50       second = SvIV(*av_fetch(lav,1,0));
3743            
3744 10 100       second /= second >= 600 ? 100 : 10;
3745 10         hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3746           (int)first, (int)second);
3747 10         upg_version(hintsv, TRUE);
3748            
3749 10         DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3750           "--this is only %"SVf", stopped",
3751 10         SVfARG(sv_2mortal(vnormal(req))),
3752 10         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3753 10         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3754           );
3755           }
3756           }
3757           }
3758            
3759 158632         RETPUSHYES;
3760           }
3761 6570057 100       name = SvPV_const(sv, len);
3762 6570057 50       if (!(name && len > 0 && *name))
    100        
    50        
3763 20         DIE(aTHX_ "Null filename used");
3764 6570037 100       if (!IS_SAFE_PATHNAME(sv, "require")) {
3765 18 50       DIE(aTHX_ "Can't locate %s: %s",
3766 24         pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3767           SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3768           Strerror(ENOENT));
3769           }
3770 6570031 100       TAINT_PROPER("require");
3771            
3772           path_searchable = path_is_searchable(name);
3773            
3774           #ifdef VMS
3775           /* The key in the %ENV hash is in the syntax of file passed as the argument
3776           * usually this is in UNIX format, but sometimes in VMS format, which
3777           * can result in a module being pulled in more than once.
3778           * To prevent this, the key must be stored in UNIX format if the VMS
3779           * name can be translated to UNIX.
3780           */
3781          
3782           if ((unixnamebuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))
3783           && (unixname = tounixspec(name, unixnamebuf)) != NULL) {
3784           unixlen = strlen(unixname);
3785           vms_unixname = 1;
3786           }
3787           else
3788           #endif
3789           {
3790           /* if not VMS or VMS name can not be translated to UNIX, pass it
3791           * through.
3792           */
3793           unixname = (char *) name;
3794 6570031         unixlen = len;
3795           }
3796 6570031 100       if (PL_op->op_type == OP_REQUIRE) {
3797 6547953 50       SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3798           unixname, unixlen, 0);
3799 6547953 100       if ( svp ) {
3800 5937091 100       if (*svp != &PL_sv_undef)
3801 5936445         RETPUSHYES;
3802           else
3803 646         DIE(aTHX_ "Attempt to reload %s aborted.\n"
3804           "Compilation failed in require", unixname);
3805           }
3806           }
3807            
3808           LOADING_FILE_PROBE(unixname);
3809            
3810           /* prepare to compile file */
3811            
3812 632940 100       if (!path_searchable) {
3813           /* At this point, name is SvPVX(sv) */
3814           tryname = name;
3815 12510         tryrsfp = doopen_pm(sv);
3816           }
3817 632940 100       if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
    100        
    50        
3818 620448 50       AV * const ar = GvAVn(PL_incgv);
3819           SSize_t i;
3820           #ifdef VMS
3821           if (vms_unixname)
3822           #endif
3823           {
3824 620448         namesv = newSV_type(SVt_PV);
3825 3101033 100       for (i = 0; i <= AvFILL(ar); i++) {
    100        
3826 3059216         SV * const dirsv = *av_fetch(ar, i, TRUE);
3827            
3828 3059216 100       if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
    50        
3829 214         mg_get(dirsv);
3830 3059452         if (SvROK(dirsv)) {
3831           int count;
3832           SV **svp;
3833           SV *loader = dirsv;
3834            
3835 236 100       if (SvTYPE(SvRV(loader)) == SVt_PVAV
3836 20 100       && !sv_isobject(loader))
3837           {
3838 16         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3839           }
3840            
3841 236         Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3842 236         PTR2UV(SvRV(dirsv)), name);
3843 236         tryname = SvPVX_const(namesv);
3844           tryrsfp = NULL;
3845            
3846 236         ENTER_with_name("call_INC");
3847 236         SAVETMPS;
3848 118         EXTEND(SP, 2);
3849            
3850 236 50       PUSHMARK(SP);
3851 236         PUSHs(dirsv);
3852 236         PUSHs(sv);
3853 236         PUTBACK;
3854 236 100       if (sv_isobject(loader))
3855 12         count = call_method("INC", G_ARRAY);
3856           else
3857 224         count = call_sv(loader, G_ARRAY);
3858 228         SPAGAIN;
3859            
3860 228 100       if (count > 0) {
3861           int i = 0;
3862           SV *arg;
3863            
3864 224         SP -= count - 1;
3865 224         arg = SP[i++];
3866            
3867 224 100       if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
    100        
3868 144 100       && !isGV_with_GP(SvRV(arg))) {
    50        
3869 20         filter_cache = SvRV(arg);
3870            
3871 20 100       if (i < count) {
3872 10         arg = SP[i++];
3873           }
3874           }
3875            
3876 224 100       if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
    100        
    50        
3877 130         arg = SvRV(arg);
3878           }
3879            
3880 224 100       if (isGV_with_GP(arg)) {
    50        
3881 130 50       IO * const io = GvIO((const GV *)arg);
    50        
    50        
3882            
3883           ++filter_has_file;
3884            
3885 130 50       if (io) {
3886 130         tryrsfp = IoIFP(io);
3887 130 50       if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
    0        
3888 0         PerlIO_close(IoOFP(io));
3889           }
3890 130         IoIFP(io) = NULL;
3891 130         IoOFP(io) = NULL;
3892           }
3893            
3894 130 100       if (i < count) {
3895 44         arg = SP[i++];
3896           }
3897           }
3898            
3899 224 100       if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
    100        
3900           filter_sub = arg;
3901 76         SvREFCNT_inc_simple_void_NN(filter_sub);
3902            
3903 76 100       if (i < count) {
3904 42         filter_state = SP[i];
3905 42 50       SvREFCNT_inc_simple_void(filter_state);
3906           }
3907           }
3908            
3909 224 100       if (!tryrsfp && (filter_cache || filter_sub)) {
    100        
3910 42         tryrsfp = PerlIO_open(BIT_BUCKET,
3911           PERL_SCRIPT_MODE);
3912           }
3913 224         SP--;
3914           }
3915            
3916 228         PUTBACK;
3917 228 100       FREETMPS;
3918 228         LEAVE_with_name("call_INC");
3919            
3920           /* Adjust file name if the hook has set an %INC entry.
3921           This needs to happen after the FREETMPS above. */
3922 228 50       svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3923 228 100       if (svp)
3924 24 100       tryname = SvPV_nolen_const(*svp);
3925            
3926 228 100       if (tryrsfp) {
3927           hook_sv = dirsv;
3928           break;
3929           }
3930            
3931           filter_has_file = 0;
3932           filter_cache = NULL;
3933 56 50       if (filter_state) {
3934 0         SvREFCNT_dec(filter_state);
3935           filter_state = NULL;
3936           }
3937 56 50       if (filter_sub) {
3938 0         SvREFCNT_dec(filter_sub);
3939           filter_sub = NULL;
3940           }
3941           }
3942           else {
3943 3058980 100       if (path_searchable) {
3944           const char *dir;
3945           STRLEN dirlen;
3946            
3947 3058926 50       if (SvOK(dirsv)) {
    0        
    0        
3948 3058926 50       dir = SvPV_const(dirsv, dirlen);
3949           } else {
3950           dir = "";
3951 0         dirlen = 0;
3952           }
3953            
3954           #ifdef VMS
3955           if (((unixdirbuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) == NULL)
3956           || ((unixdir = tounixpath(dir, unixdirbuf)) == NULL))
3957           continue;
3958           sv_setpv(namesv, unixdir);
3959           sv_catpv(namesv, unixname);
3960           #else
3961           # ifdef __SYMBIAN32__
3962           if (PL_origfilename[0] &&
3963           PL_origfilename[1] == ':' &&
3964           !(dir[0] && dir[1] == ':'))
3965           Perl_sv_setpvf(aTHX_ namesv,
3966           "%c:%s\\%s",
3967           PL_origfilename[0],
3968           dir, name);
3969           else
3970           Perl_sv_setpvf(aTHX_ namesv,
3971           "%s\\%s",
3972           dir, name);
3973           # else
3974           /* The equivalent of
3975           Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3976           but without the need to parse the format string, or
3977           call strlen on either pointer, and with the correct
3978           allocation up front. */
3979           {
3980 3058926 100       char *tmp = SvGROW(namesv, dirlen + len + 2);
    100        
3981            
3982 3058926         memcpy(tmp, dir, dirlen);
3983 3058926         tmp +=dirlen;
3984            
3985           /* Avoid '//' */
3986 3058926 50       if (!dirlen || *(tmp-1) != '/') {
    100        
3987 3058436         *tmp++ = '/';
3988           }
3989            
3990           /* name came from an SV, so it will have a '\0' at the
3991           end that we can copy as part of this memcpy(). */
3992 3058926         memcpy(tmp, name, len + 1);
3993            
3994 3058926         SvCUR_set(namesv, dirlen + len + 1);
3995 3058926         SvPOK_on(namesv);
3996           }
3997           # endif
3998           #endif
3999 3058926 100       TAINT_PROPER("require");
4000 3058926         tryname = SvPVX_const(namesv);
4001 3058926         tryrsfp = doopen_pm(namesv);
4002 3058926 100       if (tryrsfp) {
4003 578449 100       if (tryname[0] == '.' && tryname[1] == '/') {
    100        
4004 4776         ++tryname;
4005 4776 50       while (*++tryname == '/') {}
4006           }
4007           break;
4008           }
4009 2480477 100       else if (errno == EMFILE || errno == EACCES) {
4010           /* no point in trying other paths if out of handles;
4011           * on the other hand, if we couldn't open one of the
4012           * files, then going on with the search could lead to
4013           * unexpected results; see perl #113422
4014           */
4015           break;
4016           }
4017           }
4018           }
4019           }
4020           }
4021           }
4022 632932         saved_errno = errno; /* sv_2mortal can realloc things */
4023 632932         sv_2mortal(namesv);
4024 632932 100       if (!tryrsfp) {
4025 41821 100       if (PL_op->op_type == OP_REQUIRE) {
4026 41799 100       if(saved_errno == EMFILE || saved_errno == EACCES) {
4027           /* diag_listed_as: Can't locate %s */
4028 4         DIE(aTHX_ "Can't locate %s: %s", name, Strerror(saved_errno));
4029           } else {
4030 41795 50       if (namesv) { /* did we lookup @INC? */
4031 41795 50       AV * const ar = GvAVn(PL_incgv);
4032           SSize_t i;
4033 41795         SV *const msg = newSVpvs_flags("", SVs_TEMP);
4034 41795         SV *const inc = newSVpvs_flags("", SVs_TEMP);
4035 493258 100       for (i = 0; i <= AvFILL(ar); i++) {
    100        
4036 451463         sv_catpvs(inc, " ");
4037 451463         sv_catsv(inc, *av_fetch(ar, i, TRUE));
4038           }
4039 83560 100       if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
    100        
4040 41765         const char *c, *e = name + len - 3;
4041 41765         sv_catpv(msg, " (you may need to install the ");
4042 547038 100       for (c = name; c < e; c++) {
4043 505273 100       if (*c == '/') {
4044 41675         sv_catpvn(msg, "::", 2);
4045           }
4046           else {