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 {
4047 463598         sv_catpvn(msg, c, 1);
4048           }
4049           }
4050 41765         sv_catpv(msg, " module)");
4051           }
4052 30 100       else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
    100        
4053 4         sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4054           }
4055 26 100       else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
    100        
4056 10         sv_catpv(msg, " (did you run h2ph?)");
4057           }
4058            
4059           /* diag_listed_as: Can't locate %s */
4060 41795         DIE(aTHX_
4061           "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4062           name, msg, inc);
4063           }
4064           }
4065 0         DIE(aTHX_ "Can't locate %s", name);
4066           }
4067            
4068 22 50       CLEAR_ERRSV();
    50        
    50        
4069 22         RETPUSHUNDEF;
4070           }
4071           else
4072 591111         SETERRNO(0, SS_NORMAL);
4073            
4074           /* Assume success here to prevent recursive requirement. */
4075           /* name is never assigned to again, so len is still strlen(name) */
4076           /* Check whether a hook in @INC has already filled %INC */
4077 591111 100       if (!hook_sv) {
4078 590939 50       (void)hv_store(GvHVn(PL_incgv),
4079           unixname, unixlen, newSVpv(tryname,0),0);
4080           } else {
4081 172 50       SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4082 172 100       if (!svp)
4083 148 50       (void)hv_store(GvHVn(PL_incgv),
4084           unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4085           }
4086            
4087 591111         ENTER_with_name("eval");
4088 591111         SAVETMPS;
4089 591111         SAVECOPFILE_FREE(&PL_compiling);
4090 875869         CopFILE_set(&PL_compiling, tryname);
4091 591111         lex_start(NULL, tryrsfp, 0);
4092            
4093 591111 100       if (filter_sub || filter_cache) {
4094           /* We can use the SvPV of the filter PVIO itself as our cache, rather
4095           than hanging another SV from it. In turn, filter_add() optionally
4096           takes the SV to use as the filter (or creates a new SV if passed
4097           NULL), so simply pass in whatever value filter_cache has. */
4098 88 100       SV * const fc = filter_cache ? newSV(0) : NULL;
4099           SV *datasv;
4100 88 100       if (fc) sv_copypv(fc, filter_cache);
4101 88         datasv = filter_add(S_run_user_filter, fc);
4102 88         IoLINES(datasv) = filter_has_file;
4103 88         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4104 88         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4105           }
4106            
4107           /* switch to eval mode */
4108 591111 50       PUSHBLOCK(cx, CXt_EVAL, SP);
4109 591111 50       PUSHEVAL(cx, name);
    50        
4110 591111         cx->blk_eval.retop = PL_op->op_next;
4111            
4112 591111         SAVECOPLINE(&PL_compiling);
4113 591111         CopLINE_set(&PL_compiling, 0);
4114            
4115 591111         PUTBACK;
4116            
4117           /* Store and reset encoding. */
4118 591111         encoding = PL_encoding;
4119 591111         PL_encoding = NULL;
4120            
4121 591111 50       if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4122 590215 100       op = DOCATCH(PL_eval_start);
4123           else
4124 0         op = PL_op->op_next;
4125            
4126           /* Restore encoding. */
4127 590213         PL_encoding = encoding;
4128            
4129           LOADED_FILE_PROBE(unixname);
4130            
4131 3687224         return op;
4132           }
4133            
4134           /* This is a op added to hold the hints hash for
4135           pp_entereval. The hash can be modified by the code
4136           being eval'ed, so we return a copy instead. */
4137            
4138 284240         PP(pp_hintseval)
4139           {
4140           dVAR;
4141 284240         dSP;
4142 284240 50       mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4143 284240         RETURN;
4144           }
4145            
4146            
4147 3760134         PP(pp_entereval)
4148           {
4149 3760134         dVAR; dSP;
4150           PERL_CONTEXT *cx;
4151           SV *sv;
4152 3760134 100       const I32 gimme = GIMME_V;
4153 3760134         const U32 was = PL_breakable_sub_gen;
4154           char tbuf[TYPE_DIGITS(long) + 12];
4155           bool saved_delete = FALSE;
4156           char *tmpbuf = tbuf;
4157           STRLEN len;
4158           CV* runcv;
4159           U32 seq, lex_flags = 0;
4160           HV *saved_hh = NULL;
4161 3760134         const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4162            
4163 3760134 100       if (PL_op->op_private & OPpEVAL_HAS_HH) {
4164 284240         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4165           }
4166 5192424 100       else if (PL_hints & HINT_LOCALIZE_HH || (
    100        
4167 3455378         PL_op->op_private & OPpEVAL_COPHH
4168 82 100       && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4169           )) {
4170 20560         saved_hh = cop_hints_2hv(PL_curcop, 0);
4171 20560         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4172           }
4173 3760134         sv = POPs;
4174 3760134 100       if (!SvPOK(sv)) {
4175           /* make sure we've got a plain PV (no overload etc) before testing
4176           * for taint. Making a copy here is probably overkill, but better
4177           * safe than sorry */
4178           STRLEN len;
4179 308 50       const char * const p = SvPV_const(sv, len);
4180            
4181 308         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4182           lex_flags |= LEX_START_COPIED;
4183            
4184 308 50       if (bytes && SvUTF8(sv))
    0        
4185 0 0       SvPVbyte_force(sv, len);
4186           }
4187 3759826 100       else if (bytes && SvUTF8(sv)) {
    100        
4188           /* Don't modify someone else's scalar */
4189           STRLEN len;
4190 8         sv = newSVsv(sv);
4191 8         (void)sv_2mortal(sv);
4192 8 50       SvPVbyte_force(sv,len);
4193           lex_flags |= LEX_START_COPIED;
4194           }
4195            
4196 3760132 100       TAINT_IF(SvTAINTED(sv));
    100        
4197 3760132 100       TAINT_PROPER("eval");
4198            
4199 3759872         ENTER_with_name("eval");
4200 3759872 100       lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
    100        
4201           ? LEX_IGNORE_UTF8_HINTS
4202           : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4203           )
4204           );
4205 3759872         SAVETMPS;
4206            
4207           /* switch to eval mode */
4208            
4209 7052178 100       if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
    100        
    50        
4210 3292306         SV * const temp_sv = sv_newmortal();
4211 9876918 50       Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4212 6584612         (unsigned long)++PL_evalseq,
4213 9876918         CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4214 3292306         tmpbuf = SvPVX(temp_sv);
4215 3292306         len = SvCUR(temp_sv);
4216           }
4217           else
4218 690190 50       len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4219 3759872         SAVECOPFILE_FREE(&PL_compiling);
4220 5628649         CopFILE_set(&PL_compiling, tmpbuf+2);
4221 3759872         SAVECOPLINE(&PL_compiling);
4222 3759872         CopLINE_set(&PL_compiling, 1);
4223           /* special case: an eval '' executed within the DB package gets lexically
4224           * placed in the first non-DB CV rather than the current CV - this
4225           * allows the debugger to execute code, find lexicals etc, in the
4226           * scope of the code being debugged. Passing &seq gets find_runcv
4227           * to do the dirty work for us */
4228 3759872         runcv = find_runcv(&seq);
4229            
4230 3759872 50       PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4231 3759872 50       PUSHEVAL(cx, 0);
4232 3759872         cx->blk_eval.retop = PL_op->op_next;
4233            
4234           /* prepare to compile string */
4235            
4236 3759872 100       if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
    100        
    100        
4237 940 50       save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4238           else {
4239           /* XXX For Cs within BEGIN {} blocks, this ends up
4240           deleting the eval's FILEGV from the stash before gv_check() runs
4241           (i.e. before run-time proper). To work around the coredump that
4242           ensues, we always turn GvMULTI_on for any globals that were
4243           introduced within evals. See force_ident(). GSAR 96-10-12 */
4244 3758932         char *const safestr = savepvn(tmpbuf, len);
4245 3758932         SAVEDELETE(PL_defstash, safestr, len);
4246           saved_delete = TRUE;
4247           }
4248          
4249 3759872         PUTBACK;
4250            
4251 3759872 100       if (doeval(gimme, runcv, seq, saved_hh)) {
4252 9232661 100       if (was != PL_breakable_sub_gen /* Some subs defined here. */
    100        
    100        
    100        
4253 3641286 100       ? (PERLDB_LINE || PERLDB_SAVESRC)
4254 1680869 100       : PERLDB_SAVESRC_NOSUBS) {
4255           /* Retain the filegv we created. */
4256 3696318 100       } else if (!saved_delete) {
4257 256         char *const safestr = savepvn(tmpbuf, len);
4258 256         SAVEDELETE(PL_defstash, safestr, len);
4259           }
4260 3697384 100       return DOCATCH(PL_eval_start);
4261           } else {
4262           /* We have already left the scope set up earlier thanks to the LEAVE
4263           in doeval(). */
4264 3100 100       if (was != PL_breakable_sub_gen /* Some subs defined here. */
    100        
    100        
    100        
4265 387 100       ? (PERLDB_LINE || PERLDB_SAVESRC)
4266 1448 100       : PERLDB_SAVESRC_INVALID) {
4267           /* Retain the filegv we created. */
4268 1234 100       } else if (!saved_delete) {
4269 4         (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4270           }
4271 1860729         return PL_op->op_next;
4272           }
4273           }
4274            
4275 4270843         PP(pp_leaveeval)
4276           {
4277 4270843         dVAR; dSP;
4278           SV **newsp;
4279           PMOP *newpm;
4280           I32 gimme;
4281           PERL_CONTEXT *cx;
4282           OP *retop;
4283 4270843         const U8 save_flags = PL_op -> op_flags;
4284           I32 optype;
4285           SV *namesv;
4286           CV *evalcv;
4287            
4288 4270843 100       PERL_ASYNC_CHECK();
4289 4270841         POPBLOCK(cx,newpm);
4290 4270841 50       POPEVAL(cx);
    100        
    100        
4291 4270841         namesv = cx->blk_eval.old_namesv;
4292 4270841         retop = cx->blk_eval.retop;
4293 4270841         evalcv = cx->blk_eval.cv;
4294            
4295 4270841         TAINT_NOT;
4296 4270841 100       SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4297           gimme, SVs_TEMP);
4298 4270841         PL_curpm = newpm; /* Don't pop $1 et al till now */
4299            
4300           #ifdef DEBUGGING
4301           assert(CvDEPTH(evalcv) == 1);
4302           #endif
4303 4270841         CvDEPTH(evalcv) = 0;
4304            
4305 6194021 100       if (optype == OP_REQUIRE &&
    50        
    50        
    50        
    50        
    100        
    100        
    100        
    0        
4306 1104114 0       !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
    0        
    0        
    50        
    100        
    50        
    50        
    50        
    100        
    100        
    100        
    50        
    100        
    50        
4307           {
4308           /* Unassume the success we assumed earlier. */
4309 4 50       (void)hv_delete(GvHVn(PL_incgv),
    50        
4310           SvPVX_const(namesv),
4311           SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4312           G_DISCARD);
4313 4         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4314           SVfARG(namesv));
4315           /* die_unwind() did LEAVE, or we won't be here */
4316           }
4317           else {
4318 4270837         LEAVE_with_name("eval");
4319 4270837 100       if (!(save_flags & OPf_SPECIAL)) {
4320 4270835 50       CLEAR_ERRSV();
    50        
    50        
4321           }
4322           }
4323            
4324 4270837         RETURNOP(retop);
4325           }
4326            
4327           /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4328           close to the related Perl_create_eval_scope. */
4329           void
4330 12705627         Perl_delete_eval_scope(pTHX)
4331           {
4332           SV **newsp;
4333           PMOP *newpm;
4334           I32 gimme;
4335           PERL_CONTEXT *cx;
4336           I32 optype;
4337          
4338 12705627         POPBLOCK(cx,newpm);
4339 12705627 100       POPEVAL(cx);
    50        
    50        
4340 12705627         PL_curpm = newpm;
4341 12705627         LEAVE_with_name("eval_scope");
4342           PERL_UNUSED_VAR(newsp);
4343           PERL_UNUSED_VAR(gimme);
4344           PERL_UNUSED_VAR(optype);
4345 12705627         }
4346            
4347           /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4348           also needed by Perl_fold_constants. */
4349           PERL_CONTEXT *
4350 28139254         Perl_create_eval_scope(pTHX_ U32 flags)
4351           {
4352           PERL_CONTEXT *cx;
4353 28139254 100       const I32 gimme = GIMME_V;
4354          
4355 28139254         ENTER_with_name("eval_scope");
4356 28139254         SAVETMPS;
4357            
4358 28139254 100       PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4359 28139254 100       PUSHEVAL(cx, 0);
4360            
4361 28139254         PL_in_eval = EVAL_INEVAL;
4362 28139254 100       if (flags & G_KEEPERR)
4363 1699167         PL_in_eval |= EVAL_KEEPERR;
4364           else
4365 26440087 100       CLEAR_ERRSV();
    100        
    100        
4366 28139254 100       if (flags & G_FAKINGEVAL) {
4367 12732689         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4368           }
4369 28139254         return cx;
4370           }
4371          
4372 15406565         PP(pp_entertry)
4373           {
4374           dVAR;
4375 15406565         PERL_CONTEXT * const cx = create_eval_scope(0);
4376 15406565         cx->blk_eval.retop = cLOGOP->op_other->op_next;
4377 15406565 100       return DOCATCH(PL_op->op_next);
4378           }
4379            
4380 15183112         PP(pp_leavetry)
4381           {
4382 15183112         dVAR; dSP;
4383           SV **newsp;
4384           PMOP *newpm;
4385           I32 gimme;
4386           PERL_CONTEXT *cx;
4387           I32 optype;
4388            
4389 15183112 100       PERL_ASYNC_CHECK();
4390 15183110         POPBLOCK(cx,newpm);
4391 15183110 100       POPEVAL(cx);
    50        
    50        
4392           PERL_UNUSED_VAR(optype);
4393            
4394 15183110         TAINT_NOT;
4395 15183110         SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4396 15183110         PL_curpm = newpm; /* Don't pop $1 et al till now */
4397            
4398 15183110         LEAVE_with_name("eval_scope");
4399 15183110 100       CLEAR_ERRSV();
    100        
    100        
4400 15183110         RETURN;
4401           }
4402            
4403 386         PP(pp_entergiven)
4404           {
4405 386         dVAR; dSP;
4406           PERL_CONTEXT *cx;
4407 386 100       const I32 gimme = GIMME_V;
4408          
4409 386         ENTER_with_name("given");
4410 386         SAVETMPS;
4411            
4412 386 100       if (PL_op->op_targ) {
4413 8         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4414 8         SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4415 12         PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4416           }
4417           else {
4418 378         SAVE_DEFSV;
4419 756         DEFSV_set(POPs);
4420           }
4421            
4422 386 50       PUSHBLOCK(cx, CXt_GIVEN, SP);
4423 386         PUSHGIVEN(cx);
4424            
4425 386         RETURN;
4426           }
4427            
4428 366         PP(pp_leavegiven)
4429           {
4430 366         dVAR; dSP;
4431           PERL_CONTEXT *cx;
4432           I32 gimme;
4433           SV **newsp;
4434           PMOP *newpm;
4435           PERL_UNUSED_CONTEXT;
4436            
4437 366         POPBLOCK(cx,newpm);
4438           assert(CxTYPE(cx) == CXt_GIVEN);
4439            
4440 366         TAINT_NOT;
4441 366         SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4442 366         PL_curpm = newpm; /* Don't pop $1 et al till now */
4443            
4444 366         LEAVE_with_name("given");
4445 366         RETURN;
4446           }
4447            
4448           /* Helper routines used by pp_smartmatch */
4449           STATIC PMOP *
4450 94         S_make_matcher(pTHX_ REGEXP *re)
4451           {
4452           dVAR;
4453 94         PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4454            
4455           PERL_ARGS_ASSERT_MAKE_MATCHER;
4456            
4457 94         PM_SETRE(matcher, ReREFCNT_inc(re));
4458            
4459 94         SAVEFREEOP((OP *) matcher);
4460 94         ENTER_with_name("matcher"); SAVETMPS;
4461 94         SAVEOP();
4462 94         return matcher;
4463           }
4464            
4465           STATIC bool
4466 348         S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4467           {
4468           dVAR;
4469 348         dSP;
4470            
4471           PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4472          
4473 348         PL_op = (OP *) matcher;
4474 348 50       XPUSHs(sv);
4475 348         PUTBACK;
4476 348         (void) Perl_pp_match(aTHX);
4477 348         SPAGAIN;
4478 348 50       return (SvTRUEx(POPs));
    50        
    0        
    50        
    0        
    0        
    50        
    50        
    50        
    100        
    50        
    100        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
4479           }
4480            
4481           STATIC void
4482 94         S_destroy_matcher(pTHX_ PMOP *matcher)
4483           {
4484           dVAR;
4485            
4486           PERL_ARGS_ASSERT_DESTROY_MATCHER;
4487           PERL_UNUSED_ARG(matcher);
4488            
4489 94 100       FREETMPS;
4490 94         LEAVE_with_name("matcher");
4491 94         }
4492            
4493           /* Do a smart match */
4494 1350         PP(pp_smartmatch)
4495           {
4496           DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4497 1350         return do_smartmatch(NULL, NULL, 0);
4498           }
4499            
4500           /* This version of do_smartmatch() implements the
4501           * table of smart matches that is found in perlsyn.
4502           */
4503           STATIC OP *
4504 1866         S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4505           {
4506           dVAR;
4507 1866         dSP;
4508          
4509           bool object_on_left = FALSE;
4510 1866         SV *e = TOPs; /* e is for 'expression' */
4511 1866         SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */
4512            
4513           /* Take care only to invoke mg_get() once for each argument.
4514           * Currently we do this by copying the SV if it's magical. */
4515 1866 50       if (d) {
4516 1866 100       if (!copied && SvGMAGICAL(d))
    100        
4517 88         d = sv_mortalcopy(d);
4518           }
4519           else
4520           d = &PL_sv_undef;
4521            
4522           assert(e);
4523 1866 100       if (SvGMAGICAL(e))
4524 86         e = sv_mortalcopy(e);
4525            
4526           /* First of all, handle overload magic of the rightmost argument */
4527 1866 100       if (SvAMAGIC(e)) {
    100        
    100        
4528           SV * tmpsv;
4529           DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4530           DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4531            
4532 52         tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4533 52 100       if (tmpsv) {
4534 24         SPAGAIN;
4535 24         (void)POPs;
4536 24         SETs(tmpsv);
4537 24         RETURN;
4538           }
4539           DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
4540           }
4541            
4542 1842         SP -= 2; /* Pop the values */
4543            
4544            
4545           /* ~~ undef */
4546 1842 100       if (!SvOK(e)) {
    50        
    50        
4547           DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
4548 134 100       if (SvOK(d))
    50        
    50        
4549 92         RETPUSHNO;
4550           else
4551 42         RETPUSHYES;
4552           }
4553            
4554 1708 100       if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
    100        
4555           DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
4556 58         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4557           }
4558 1650 100       if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
    100        
4559           object_on_left = TRUE;
4560            
4561           /* ~~ sub */
4562 1650 100       if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
    100        
4563           I32 c;
4564 118 100       if (object_on_left) {
4565           goto sm_any_sub; /* Treat objects like scalars */
4566           }
4567 108 100       else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
    100        
4568           /* Test sub truth for each key */
4569           HE *he;
4570           bool andedresults = TRUE;
4571 28         HV *hv = (HV*) SvRV(d);
4572 28         I32 numkeys = hv_iterinit(hv);
4573           DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
4574 28 100       if (numkeys == 0)
4575 8         RETPUSHYES;
4576 66 100       while ( (he = hv_iternext(hv)) ) {
4577           DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
4578 48         ENTER_with_name("smartmatch_hash_key_test");
4579 48         SAVETMPS;
4580 48 50       PUSHMARK(SP);
4581 48         PUSHs(hv_iterkeysv(he));
4582 48         PUTBACK;
4583 48         c = call_sv(e, G_SCALAR);
4584 46         SPAGAIN;
4585 46 50       if (c == 0)
4586           andedresults = FALSE;
4587           else
4588 46 50       andedresults = SvTRUEx(POPs) && andedresults;
    50        
    0        
    100        
    50        
    50        
    100        
    50        
    50        
    100        
    50        
    100        
    50        
    50        
    50        
    0        
    0        
    50        
    0        
    100        
    100        
4589 46 50       FREETMPS;
4590 46         LEAVE_with_name("smartmatch_hash_key_test");
4591           }
4592 18 100       if (andedresults)
4593 10         RETPUSHYES;
4594           else
4595 8         RETPUSHNO;
4596           }
4597 80 100       else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
    100        
4598           /* Test sub truth for each element */
4599           SSize_t i;
4600           bool andedresults = TRUE;
4601 28         AV *av = (AV*) SvRV(d);
4602 28         const I32 len = av_len(av);
4603           DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
4604 28 100       if (len == -1)
4605 8         RETPUSHYES;
4606 56 100       for (i = 0; i <= len; ++i) {
4607 48         SV * const * const svp = av_fetch(av, i, FALSE);
4608           DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
4609 48         ENTER_with_name("smartmatch_array_elem_test");
4610 48         SAVETMPS;
4611 48 50       PUSHMARK(SP);
4612 48 50       if (svp)
4613 48         PUSHs(*svp);
4614 48         PUTBACK;
4615 48         c = call_sv(e, G_SCALAR);
4616 46         SPAGAIN;
4617 46 50       if (c == 0)
4618           andedresults = FALSE;
4619           else
4620 46 50       andedresults = SvTRUEx(POPs) && andedresults;
    50        
    0        
    100        
    50        
    50        
    100        
    50        
    50        
    100        
    50        
    100        
    50        
    50        
    50        
    0        
    0        
    50        
    0        
    100        
    50        
4621 46 100       FREETMPS;
4622 46         LEAVE_with_name("smartmatch_array_elem_test");
4623           }
4624 18 100       if (andedresults)
4625 10         RETPUSHYES;
4626           else
4627 8         RETPUSHNO;
4628           }
4629           else {
4630           sm_any_sub:
4631           DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
4632 62         ENTER_with_name("smartmatch_coderef");
4633 62         SAVETMPS;
4634 62 50       PUSHMARK(SP);
4635 62         PUSHs(d);
4636 62         PUTBACK;
4637 62         c = call_sv(e, G_SCALAR);
4638 50         SPAGAIN;
4639 50 50       if (c == 0)
4640 0         PUSHs(&PL_sv_no);
4641 50 100       else if (SvTEMP(TOPs))
4642 44         SvREFCNT_inc_void(TOPs);
4643 50 100       FREETMPS;
4644 50         LEAVE_with_name("smartmatch_coderef");
4645 50         RETURN;
4646           }
4647           }
4648           /* ~~ %hash */
4649 1532 100       else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
    100        
4650 170 100       if (object_on_left) {
4651           goto sm_any_hash; /* Treat objects like scalars */
4652           }
4653 168 100       else if (!SvOK(d)) {
    50        
    50        
4654           DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
4655 8         RETPUSHNO;
4656           }
4657 160 100       else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
    100        
4658           /* Check that the key-sets are identical */
4659           HE *he;
4660 52         HV *other_hv = MUTABLE_HV(SvRV(d));
4661           bool tied = FALSE;
4662           bool other_tied = FALSE;
4663           U32 this_key_count = 0,
4664           other_key_count = 0;
4665 52         HV *hv = MUTABLE_HV(SvRV(e));
4666            
4667           DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
4668           /* Tied hashes don't know how many keys they have. */
4669 52 100       if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
    50        
4670           tied = TRUE;
4671           }
4672 34 100       else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
    50        
4673           HV * const temp = other_hv;
4674           other_hv = hv;
4675           hv = temp;
4676           tied = TRUE;
4677           }
4678 52 100       if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
    50        
4679           other_tied = TRUE;
4680          
4681 52 100       if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
    50        
    50        
    100        
4682 6         RETPUSHNO;
4683            
4684           /* The hashes have the same number of keys, so it suffices
4685           to check that one is a subset of the other. */
4686 46         (void) hv_iterinit(hv);
4687 359 100       while ( (he = hv_iternext(hv)) ) {
4688 638         SV *key = hv_iterkeysv(he);
4689            
4690           DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
4691 638         ++ this_key_count;
4692          
4693 638 100       if(!hv_exists_ent(other_hv, key, 0)) {
4694 12         (void) hv_iterinit(hv); /* reset iterator */
4695 12         RETPUSHNO;
4696           }
4697           }
4698          
4699 34 100       if (other_tied) {
4700 8         (void) hv_iterinit(other_hv);
4701 26 100       while ( hv_iternext(other_hv) )
4702 14         ++other_key_count;
4703           }
4704           else
4705 26 50       other_key_count = HvUSEDKEYS(other_hv);
4706          
4707 34 50       if (this_key_count != other_key_count)
4708 0         RETPUSHNO;
4709           else
4710 34         RETPUSHYES;
4711           }
4712 108 100       else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
    100        
4713 50         AV * const other_av = MUTABLE_AV(SvRV(d));
4714 50         const SSize_t other_len = av_len(other_av) + 1;
4715           SSize_t i;
4716 50         HV *hv = MUTABLE_HV(SvRV(e));
4717            
4718           DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
4719 82 100       for (i = 0; i < other_len; ++i) {
4720 66         SV ** const svp = av_fetch(other_av, i, FALSE);
4721           DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
4722 66 50       if (svp) { /* ??? When can this not happen? */
4723 66 100       if (hv_exists_ent(hv, *svp, 0))
4724 34         RETPUSHYES;
4725           }
4726           }
4727 16         RETPUSHNO;
4728           }
4729 58 100       else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
    50        
4730           DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
4731           sm_regex_hash:
4732           {
4733 38         PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4734           HE *he;
4735 38         HV *hv = MUTABLE_HV(SvRV(e));
4736            
4737 38         (void) hv_iterinit(hv);
4738 143 100       while ( (he = hv_iternext(hv)) ) {
4739           DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
4740 236 100       if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4741 26         (void) hv_iterinit(hv);
4742 26         destroy_matcher(matcher);
4743 26         RETPUSHYES;
4744           }
4745           }
4746 12         destroy_matcher(matcher);
4747 12         RETPUSHNO;
4748           }
4749           }
4750           else {
4751           sm_any_hash:
4752           DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
4753 40 100       if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4754 22         RETPUSHYES;
4755           else
4756 18         RETPUSHNO;
4757           }
4758           }
4759           /* ~~ @array */
4760 1362 100       else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
    100        
4761 264 100       if (object_on_left) {
4762           goto sm_any_array; /* Treat objects like scalars */
4763           }
4764 260 100       else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
    100        
4765 36         AV * const other_av = MUTABLE_AV(SvRV(e));
4766 36         const SSize_t other_len = av_len(other_av) + 1;
4767           SSize_t i;
4768            
4769           DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
4770 40 100       for (i = 0; i < other_len; ++i) {
4771 30         SV ** const svp = av_fetch(other_av, i, FALSE);
4772            
4773           DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
4774 30 50       if (svp) { /* ??? When can this not happen? */
4775 30 100       if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4776 26         RETPUSHYES;
4777           }
4778           }
4779 10         RETPUSHNO;
4780           }
4781 224 100       if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
    100        
4782 84         AV *other_av = MUTABLE_AV(SvRV(d));
4783           DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
4784 84 100       if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4785 6         RETPUSHNO;
4786           else {
4787           SSize_t i;
4788 78         const SSize_t other_len = av_len(other_av);
4789            
4790 78 100       if (NULL == seen_this) {
4791 72         seen_this = newHV();
4792 72         (void) sv_2mortal(MUTABLE_SV(seen_this));
4793           }
4794 78 100       if (NULL == seen_other) {
4795 72         seen_other = newHV();
4796 72         (void) sv_2mortal(MUTABLE_SV(seen_other));
4797           }
4798 356 100       for(i = 0; i <= other_len; ++i) {
4799 294         SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4800 294         SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4801            
4802 294 50       if (!this_elem || !other_elem) {
4803 0 0       if ((this_elem && SvOK(*this_elem))
    0        
    0        
    0        
4804 0 0       || (other_elem && SvOK(*other_elem)))
    0        
    0        
    0        
4805 0         RETPUSHNO;
4806           }
4807 294 100       else if (hv_exists_ent(seen_this,
4808 288 50       sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4809 288         hv_exists_ent(seen_other,
4810           sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4811           {
4812 6 100       if (*this_elem != *other_elem)
4813 2         RETPUSHNO;
4814           }
4815           else {
4816 288         (void)hv_store_ent(seen_this,
4817           sv_2mortal(newSViv(PTR2IV(*this_elem))),
4818           &PL_sv_undef, 0);
4819 288         (void)hv_store_ent(seen_other,
4820           sv_2mortal(newSViv(PTR2IV(*other_elem))),
4821           &PL_sv_undef, 0);
4822 288         PUSHs(*other_elem);
4823 288         PUSHs(*this_elem);
4824          
4825 288         PUTBACK;
4826           DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
4827 288         (void) do_smartmatch(seen_this, seen_other, 0);
4828 288         SPAGAIN;
4829           DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4830          
4831 288 50       if (!SvTRUEx(POPs))
    50        
    0        
    50        
    0        
    0        
    50        
    50        
    50        
    100        
    50        
    100        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    100        
4832 14         RETPUSHNO;
4833           }
4834           }
4835 62         RETPUSHYES;
4836           }
4837           }
4838 140 100       else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
    50        
4839           DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
4840           sm_regex_array:
4841           {
4842 30         PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4843 30         const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e)));
4844           SSize_t i;
4845            
4846 100 100       for(i = 0; i <= this_len; ++i) {
4847 86         SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4848           DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
4849 86 50       if (svp && matcher_matches_sv(matcher, *svp)) {
    100        
4850 16         destroy_matcher(matcher);
4851 16         RETPUSHYES;
4852           }
4853           }
4854 14         destroy_matcher(matcher);
4855 14         RETPUSHNO;
4856           }
4857           }
4858 128 100       else if (!SvOK(d)) {
    50        
    50        
4859           /* undef ~~ array */
4860 18         const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e)));
4861           SSize_t i;
4862            
4863           DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
4864 40 100       for (i = 0; i <= this_len; ++i) {
4865 30         SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4866           DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
4867 30 100       if (!svp || !SvOK(*svp))
    100        
    50        
    50        
4868 8         RETPUSHYES;
4869           }
4870 10         RETPUSHNO;
4871           }
4872           else {
4873           sm_any_array:
4874           {
4875           SSize_t i;
4876 114         const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e)));
4877            
4878           DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
4879 276 100       for (i = 0; i <= this_len; ++i) {
4880 228         SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4881 228 50       if (!svp)
4882 0         continue;
4883            
4884 228         PUSHs(d);
4885 228         PUSHs(*svp);
4886 228         PUTBACK;
4887           /* infinite recursion isn't supposed to happen here */
4888           DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
4889 228         (void) do_smartmatch(NULL, NULL, 1);
4890 228         SPAGAIN;
4891           DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
4892 228 50       if (SvTRUEx(POPs))
    50        
    0        
    50        
    0        
    0        
    50        
    50        
    100        
    100        
    50        
    100        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    100        
4893 66         RETPUSHYES;
4894           }
4895 48         RETPUSHNO;
4896           }
4897           }
4898           }
4899           /* ~~ qr// */
4900 1098 100       else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
    100        
4901 62 100       if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
    100        
    100        
4902           SV *t = d; d = e; e = t;
4903           DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
4904           goto sm_regex_hash;
4905           }
4906 44 100       else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
    100        
    100        
4907           SV *t = d; d = e; e = t;
4908           DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
4909           goto sm_regex_array;
4910           }
4911           else {
4912 26         PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4913            
4914           DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
4915 26         PUTBACK;
4916 26 100       PUSHs(matcher_matches_sv(matcher, d)
4917           ? &PL_sv_yes
4918           : &PL_sv_no);
4919 26         destroy_matcher(matcher);
4920 26         RETURN;
4921           }
4922           }
4923           /* ~~ scalar */
4924           /* See if there is overload magic on left */
4925 1036 100       else if (object_on_left && SvAMAGIC(d)) {
    50        
    50        
    100        
4926           SV *tmpsv;
4927           DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
4928           DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
4929 28         PUSHs(d); PUSHs(e);
4930 28         PUTBACK;
4931 28         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4932 28 100       if (tmpsv) {
4933 26         SPAGAIN;
4934 26         (void)POPs;
4935 26         SETs(tmpsv);
4936 26         RETURN;
4937           }
4938 2         SP -= 2;
4939           DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
4940 2         goto sm_any_scalar;
4941           }
4942 1008 100       else if (!SvOK(d)) {
    50        
    50        
4943           /* undef ~~ scalar ; we already know that the scalar is SvOK */
4944           DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
4945 22         RETPUSHNO;
4946           }
4947           else
4948           sm_any_scalar:
4949 988 100       if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
    100        
    100        
    100        
4950           DEBUG_M(if (SvNIOK(e))
4951           Perl_deb(aTHX_ " applying rule Any-Num\n");
4952           else
4953           Perl_deb(aTHX_ " applying rule Num-numish\n");
4954           );
4955           /* numeric comparison */
4956 790         PUSHs(d); PUSHs(e);
4957 790         PUTBACK;
4958 790 100       if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4959 4         (void) Perl_pp_i_eq(aTHX);
4960           else
4961 786         (void) Perl_pp_eq(aTHX);
4962 790         SPAGAIN;
4963 790 50       if (SvTRUEx(POPs))
    50        
    0        
    50        
    0        
    0        
    50        
    50        
    50        
    100        
    50        
    100        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    100        
4964 420         RETPUSHYES;
4965           else
4966 370         RETPUSHNO;
4967           }
4968          
4969           /* As a last resort, use string comparison */
4970           DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
4971 198         PUSHs(d); PUSHs(e);
4972 198         PUTBACK;
4973 995         return Perl_pp_seq(aTHX);
4974           }
4975            
4976 848         PP(pp_enterwhen)
4977           {
4978 848         dVAR; dSP;
4979           PERL_CONTEXT *cx;
4980 848 100       const I32 gimme = GIMME_V;
4981            
4982           /* This is essentially an optimization: if the match
4983           fails, we don't want to push a context and then
4984           pop it again right away, so we skip straight
4985           to the op that follows the leavewhen.
4986           RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4987           */
4988 848 100       if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
    50        
    50        
    0        
    50        
    0        
    0        
    100        
    50        
    100        
    100        
    50        
    100        
    50        
    50        
    100        
    50        
    0        
    100        
    0        
    100        
4989 466         RETURNOP(cLOGOP->op_other->op_next);
4990            
4991 382         ENTER_with_name("when");
4992 382         SAVETMPS;
4993            
4994 382 50       PUSHBLOCK(cx, CXt_WHEN, SP);
4995 382         PUSHWHEN(cx);
4996            
4997 615         RETURN;
4998           }
4999            
5000 284         PP(pp_leavewhen)
5001           {
5002 284         dVAR; dSP;
5003           I32 cxix;
5004           PERL_CONTEXT *cx;
5005           I32 gimme;
5006           SV **newsp;
5007           PMOP *newpm;
5008            
5009 284         cxix = dopoptogiven(cxstack_ix);
5010 284 100       if (cxix < 0)
5011           /* diag_listed_as: Can't "when" outside a topicalizer */
5012 4 100       DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5013 4         PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5014            
5015 280         POPBLOCK(cx,newpm);
5016           assert(CxTYPE(cx) == CXt_WHEN);
5017            
5018 280         TAINT_NOT;
5019 280         SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
5020 280         PL_curpm = newpm; /* pop $1 et al */
5021            
5022 280         LEAVE_with_name("when");
5023            
5024 280 100       if (cxix < cxstack_ix)
5025 246         dounwind(cxix);
5026            
5027 280         cx = &cxstack[cxix];
5028            
5029 280 100       if (CxFOREACH(cx)) {
    50        
5030           /* clear off anything above the scope we're re-entering */
5031 20         I32 inner = PL_scopestack_ix;
5032            
5033 20         TOPBLOCK(cx);
5034 20 50       if (PL_scopestack_ix < inner)
5035 0         leave_scope(PL_scopestack[PL_scopestack_ix]);
5036 20         PL_curcop = cx->blk_oldcop;
5037            
5038 20 50       PERL_ASYNC_CHECK();
5039 20         return cx->blk_loop.my_op->op_nextop;
5040           }
5041           else {
5042 260 50       PERL_ASYNC_CHECK();
5043 270         RETURNOP(cx->blk_givwhen.leave_op);
5044           }
5045           }
5046            
5047 70         PP(pp_continue)
5048           {
5049           dVAR; dSP;
5050           I32 cxix;
5051           PERL_CONTEXT *cx;
5052           I32 gimme;
5053           SV **newsp;
5054           PMOP *newpm;
5055            
5056           PERL_UNUSED_VAR(gimme);
5057          
5058 70         cxix = dopoptowhen(cxstack_ix);
5059 70 100       if (cxix < 0)
5060 4         DIE(aTHX_ "Can't \"continue\" outside a when block");
5061            
5062 66 50       if (cxix < cxstack_ix)
5063 66         dounwind(cxix);
5064          
5065 66         POPBLOCK(cx,newpm);
5066           assert(CxTYPE(cx) == CXt_WHEN);
5067            
5068           SP = newsp;
5069 66         PL_curpm = newpm; /* pop $1 et al */
5070            
5071 66         LEAVE_with_name("when");
5072 66         RETURNOP(cx->blk_givwhen.leave_op->op_next);
5073           }
5074            
5075 28         PP(pp_break)
5076           {
5077           dVAR;
5078           I32 cxix;
5079           PERL_CONTEXT *cx;
5080            
5081 28         cxix = dopoptogiven(cxstack_ix);
5082 28 100       if (cxix < 0)
5083 4         DIE(aTHX_ "Can't \"break\" outside a given block");
5084            
5085 24         cx = &cxstack[cxix];
5086 24 100       if (CxFOREACH(cx))
    50        
5087 10         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5088            
5089 14 100       if (cxix < cxstack_ix)
5090 12         dounwind(cxix);
5091            
5092           /* Restore the sp at the time we entered the given block */
5093 14         TOPBLOCK(cx);
5094            
5095 14         return cx->blk_givwhen.leave_op;
5096           }
5097            
5098           static MAGIC *
5099 3336         S_doparseform(pTHX_ SV *sv)
5100           {
5101           STRLEN len;
5102 3336 100       char *s = SvPV(sv, len);
5103           char *send;
5104           char *base = NULL; /* start of current field */
5105           I32 skipspaces = 0; /* number of contiguous spaces seen */
5106           bool noblank = FALSE; /* ~ or ~~ seen on this line */
5107           bool repeat = FALSE; /* ~~ seen on this line */
5108           bool postspace = FALSE; /* a text field may need right padding */
5109           U32 *fops;
5110           U32 *fpc;
5111           U32 *linepc = NULL; /* position of last FF_LINEMARK */
5112           I32 arg;
5113           bool ischop; /* it's a ^ rather than a @ */
5114           bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5115           int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5116           MAGIC *mg = NULL;
5117           SV *sv_copy;
5118            
5119           PERL_ARGS_ASSERT_DOPARSEFORM;
5120            
5121 3336 100       if (len == 0)
5122 2         Perl_croak(aTHX_ "Null picture in formline");
5123            
5124 3334 100       if (SvTYPE(sv) >= SVt_PVMG) {
5125           /* This might, of course, still return NULL. */
5126 2956         mg = mg_find(sv, PERL_MAGIC_fm);
5127           } else {
5128 378         sv_upgrade(sv, SVt_PVMG);
5129           }
5130            
5131 3334 100       if (mg) {
5132           /* still the same as previously-compiled string? */
5133 1580         SV *old = mg->mg_obj;
5134 1580 50       if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5135 1580 50       && len == SvCUR(old)
5136 1580 100       && strnEQ(SvPVX(old), SvPVX(sv), len)
5137           ) {
5138           DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5139           return mg;
5140           }
5141            
5142           DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5143 12         Safefree(mg->mg_ptr);
5144 12         mg->mg_ptr = NULL;
5145 12         SvREFCNT_dec(old);
5146 12         mg->mg_obj = NULL;
5147           }
5148           else {
5149           DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5150 1754         mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5151           }
5152            
5153 1766         sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5154 1766 50       s = SvPV(sv_copy, len); /* work on the copy, not the original */
5155 1766         send = s + len;
5156            
5157            
5158           /* estimate the buffer size needed */
5159 283294 100       for (base = s; s <= send; s++) {
5160 281528 100       if (*s == '\n' || *s == '@' || *s == '^')
    100        
5161 3894         maxops += 10;
5162           }
5163           s = base;
5164           base = NULL;
5165            
5166 1766 50       Newx(fops, maxops, U32);
5167           fpc = fops;
5168            
5169 1766 50       if (s < send) {
5170           linepc = fpc;
5171 1766         *fpc++ = FF_LINEMARK;
5172           noblank = repeat = FALSE;
5173           base = s;
5174           }
5175            
5176 275508 100       while (s <= send) {
5177 273742         switch (*s++) {
5178           default:
5179           skipspaces = 0;
5180 266972         continue;
5181            
5182           case '~':
5183 288 100       if (*s == '~') {
5184           repeat = TRUE;
5185 160         skipspaces++;
5186 160         s++;
5187           }
5188           noblank = TRUE;
5189           /* FALL THROUGH */
5190           case ' ': case '\t':
5191 1908         skipspaces++;
5192 1908         continue;
5193           case 0:
5194 968 100       if (s < send) {
5195           skipspaces = 0;
5196 8         continue;
5197           } /* else FALL THROUGH */
5198           case '\n':
5199 1800         arg = s - base;
5200 1800         skipspaces++;
5201 1800         arg -= skipspaces;
5202 1800 100       if (arg) {
5203 1002 100       if (postspace)
5204 154         *fpc++ = FF_SPACE;
5205 1002         *fpc++ = FF_LITERAL;
5206 1002         *fpc++ = (U32)arg;
5207           }
5208           postspace = FALSE;
5209 1800 100       if (s <= send)
5210           skipspaces--;
5211 1800 100       if (skipspaces) {
5212 1168         *fpc++ = FF_SKIP;
5213 1168         *fpc++ = (U32)skipspaces;
5214           }
5215           skipspaces = 0;
5216 1800 100       if (s <= send)
5217 840         *fpc++ = FF_NEWLINE;
5218 1800 100       if (noblank) {
5219 288         *fpc++ = FF_BLANK;
5220 288 100       if (repeat)
5221 160         arg = fpc - linepc + 1;
5222           else
5223           arg = 0;
5224 288         *fpc++ = (U32)arg;
5225           }
5226 1800 100       if (s < send) {
5227           linepc = fpc;
5228 34         *fpc++ = FF_LINEMARK;
5229           noblank = repeat = FALSE;
5230           base = s;
5231           }
5232           else
5233 1766         s++;
5234 1800         continue;
5235            
5236           case '@':
5237           case '^':
5238 3054         ischop = s[-1] == '^';
5239            
5240 3054 100       if (postspace) {
5241 542         *fpc++ = FF_SPACE;
5242           postspace = FALSE;
5243           }
5244 3054         arg = (s - base) - 1;
5245 3054 100       if (arg) {
5246 2154         *fpc++ = FF_LITERAL;
5247 2154         *fpc++ = (U32)arg;
5248           }
5249            
5250           base = s - 1;
5251 3054         *fpc++ = FF_FETCH;
5252 3054 100       if (*s == '*') { /* @* or ^* */
5253 1480         s++;
5254 1480         *fpc++ = 2; /* skip the @* or ^* */
5255 1480 100       if (ischop) {
5256 1086         *fpc++ = FF_LINESNGL;
5257 1086         *fpc++ = FF_CHOP;
5258           } else
5259 394         *fpc++ = FF_LINEGLOB;
5260           }
5261 1574 100       else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
    50        
    0        
5262 84 100       arg = ischop ? FORM_NUM_BLANK : 0;
5263           base = s - 1;
5264 386 100       while (*s == '#')
5265 260         s++;
5266 84 100       if (*s == '.') {
5267 44         const char * const f = ++s;
5268 114 100       while (*s == '#')
5269 48         s++;
5270 44         arg |= FORM_NUM_POINT + (s - f);
5271           }
5272 84         *fpc++ = s - base; /* fieldsize for FETCH */
5273 84         *fpc++ = FF_DECIMAL;
5274 84         *fpc++ = (U32)arg;
5275 84         unchopnum |= ! ischop;
5276           }
5277 1490 100       else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
    100        
5278 56 100       arg = ischop ? FORM_NUM_BLANK : 0;
5279           base = s - 1;
5280 56         s++; /* skip the '0' first */
5281 188 100       while (*s == '#')
5282 104         s++;
5283 56 100       if (*s == '.') {
5284 24         const char * const f = ++s;
5285 84 100       while (*s == '#')
5286 48         s++;
5287 24         arg |= FORM_NUM_POINT + (s - f);
5288           }
5289 56         *fpc++ = s - base; /* fieldsize for FETCH */
5290 56         *fpc++ = FF_0DECIMAL;
5291 56         *fpc++ = (U32)arg;
5292 56         unchopnum |= ! ischop;
5293           }
5294           else { /* text field */
5295           I32 prespace = 0;
5296           bool ismore = FALSE;
5297            
5298 1434 100       if (*s == '>') {
5299 1086 100       while (*++s == '>') ;
5300           prespace = FF_SPACE;
5301           }
5302 1136 100       else if (*s == '|') {
5303 592 100       while (*++s == '|') ;
5304           prespace = FF_HALFSPACE;
5305           postspace = TRUE;
5306           }
5307           else {
5308 944 100       if (*s == '<')
5309 3054 100       while (*++s == '<') ;
5310           postspace = TRUE;
5311           }
5312 1434 100       if (*s == '.' && s[1] == '.' && s[2] == '.') {
    50        
    50        
5313 8         s += 3;
5314           ismore = TRUE;
5315           }
5316 1434         *fpc++ = s - base; /* fieldsize for FETCH */
5317            
5318 1434 100       *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5319            
5320 1434 100       if (prespace)
5321 490         *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5322 1434         *fpc++ = FF_ITEM;
5323 1434 100       if (ismore)
5324 8         *fpc++ = FF_MORE;
5325 1434 100       if (ischop)
5326 1084         *fpc++ = FF_CHOP;
5327           }
5328           base = s;
5329           skipspaces = 0;
5330 138398         continue;
5331           }
5332           }
5333 1766         *fpc++ = FF_END;
5334            
5335           assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5336 1766         arg = fpc - fops;
5337            
5338 1766         mg->mg_ptr = (char *) fops;
5339 1766         mg->mg_len = arg * sizeof(U32);
5340 1766         mg->mg_obj = sv_copy;
5341 1766         mg->mg_flags |= MGf_REFCOUNTED;
5342            
5343 1766 100       if (unchopnum && repeat)
    100        
5344 1669         Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5345            
5346           return mg;
5347           }
5348            
5349            
5350           STATIC bool
5351           S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5352           {
5353           /* Can value be printed in fldsize chars, using %*.*f ? */
5354           NV pwr = 1;
5355           NV eps = 0.5;
5356           bool res = FALSE;
5357 128         int intsize = fldsize - (value < 0 ? 1 : 0);
5358            
5359 128 100       if (frcsize & FORM_NUM_POINT)
5360 68         intsize--;
5361 128         frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5362 128         intsize -= frcsize;
5363            
5364 532 100       while (intsize--) pwr *= 10.0;
5365 160 100       while (frcsize--) eps /= 10.0;
5366            
5367 128 100       if( value >= 0 ){
5368 104 100       if (value + eps >= pwr)
5369           res = TRUE;
5370           } else {
5371 24 100       if (value - eps <= -pwr)
5372           res = TRUE;
5373           }
5374           return res;
5375           }
5376            
5377           static I32
5378 444         S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5379 250 100       {
5380           dVAR;
5381 444 50       SV * const datasv = FILTER_DATA(idx);
5382 444         const int filter_has_file = IoLINES(datasv);
5383 444         SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5384 444         SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5385           int status = 0;
5386           SV *upstream;
5387           STRLEN got_len;
5388           char *got_p = NULL;
5389           char *prune_from = NULL;
5390           bool read_from_cache = FALSE;
5391           STRLEN umaxlen;
5392           SV *err = NULL;
5393            
5394           PERL_ARGS_ASSERT_RUN_USER_FILTER;
5395            
5396           assert(maxlen >= 0);
5397 444         umaxlen = maxlen;
5398            
5399           /* I was having segfault trouble under Linux 2.2.5 after a
5400           parse error occured. (Had to hack around it with a test
5401           for PL_parser->error_count == 0.) Solaris doesn't segfault --
5402           not sure where the trouble is yet. XXX */
5403            
5404           {
5405           SV *const cache = datasv;
5406 444 100       if (SvOK(cache)) {
    50        
    50        
5407           STRLEN cache_len;
5408 230 50       const char *cache_p = SvPV(cache, cache_len);
5409           STRLEN take = 0;
5410            
5411 230 100       if (umaxlen) {
5412           /* Running in block mode and we have some cached data already.
5413           */
5414 174 100       if (cache_len >= umaxlen) {
5415           /* In fact, so much data we don't even need to call
5416           filter_read. */
5417           take = umaxlen;
5418           }
5419           } else {
5420 56         const char *const first_nl =
5421 56         (const char *)memchr(cache_p, '\n', cache_len);
5422 56 100       if (first_nl) {
5423 28         take = first_nl + 1 - cache_p;
5424           }
5425           }
5426 230 100       if (take) {
5427 194         sv_catpvn(buf_sv, cache_p, take);
5428 194         sv_chop(cache, cache_p + take);
5429           /* Definitely not EOF */
5430 194         return 1;
5431           }
5432            
5433 36         sv_catsv(buf_sv, cache);
5434 36 100       if (umaxlen) {
5435 8         umaxlen -= cache_len;
5436           }
5437 36 100       SvOK_off(cache);
5438           read_from_cache = TRUE;
5439           }
5440           }
5441            
5442           /* Filter API says that the filter appends to the contents of the buffer.
5443           Usually the buffer is "", so the details don't matter. But if it's not,
5444           then clearly what it contains is already filtered by this filter, so we
5445           don't want to pass it in a second time.
5446           I'm going to use a mortal in case the upstream filter croaks. */
5447 250 0       upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
    0        
    100        
    50        
5448 286 50       ? sv_newmortal() : buf_sv;
5449 161         SvUPGRADE(upstream, SVt_PV);
5450          
5451 250 100       if (filter_has_file) {
5452 148         status = FILTER_READ(idx+1, upstream, 0);
5453           }
5454            
5455 486         if (filter_sub && status >= 0) {
5456 236         dSP;
5457           int count;
5458            
5459 236         ENTER_with_name("call_filter_sub");
5460 236         SAVE_DEFSV;
5461 236         SAVETMPS;
5462 118         EXTEND(SP, 2);
5463            
5464 354         DEFSV_set(upstream);
5465 236 50       PUSHMARK(SP);
5466 236         mPUSHi(0);
5467 236 100       if (filter_state) {
5468 124         PUSHs(filter_state);
5469           }
5470 236         PUTBACK;
5471 236         count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5472 236         SPAGAIN;
5473            
5474 354 50       if (count > 0) {
    100        
5475 236         SV *out = POPs;
5476 122         SvGETMAGIC(out);
5477 236 100       if (SvOK(out)) {
    50        
    50        
5478 84 100       status = SvIV(out);
5479           }
5480           else {
5481 152 50       SV * const errsv = ERRSV;
5482 152 50       if (SvTRUE_NN(errsv))
    50        
    0        
    0        
    50        
    50        
    100        
    50        
    0        
    0        
    0        
    0        
    0        
    0        
    100        
5483 8         err = newSVsv(errsv);
5484           }
5485           }
5486            
5487 236         PUTBACK;
5488 236 50       FREETMPS;
5489 236         LEAVE_with_name("call_filter_sub");
5490           }
5491            
5492 250 100       if (SvGMAGICAL(upstream)) {
5493 2         mg_get(upstream);
5494 2 50       if (upstream == buf_sv) mg_free(buf_sv);
5495           }
5496 250 100       if (SvIsCOW(upstream)) sv_force_normal(upstream);
5497 250 100       if(!err && SvOK(upstream)) {
    100        
    50        
    50        
5498 214 100       got_p = SvPV_nomg(upstream, got_len);
5499 214 100       if (umaxlen) {
5500 10 100       if (got_len > umaxlen) {
5501 6         prune_from = got_p + umaxlen;
5502           }
5503           } else {
5504 204         char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5505 204 100       if (first_nl && first_nl + 1 < got_p + got_len) {
    100        
5506           /* There's a second line here... */
5507 10         prune_from = first_nl + 1;
5508           }
5509           }
5510           }
5511 250 100       if (!err && prune_from) {
5512           /* Oh. Too long. Stuff some in our cache. */
5513 16         STRLEN cached_len = got_p + got_len - prune_from;
5514           SV *const cache = datasv;
5515            
5516           if (SvOK(cache)) {
5517           /* Cache should be empty. */
5518           assert(!SvCUR(cache));
5519           }
5520            
5521 16         sv_setpvn(cache, prune_from, cached_len);
5522           /* If you ask for block mode, you may well split UTF-8 characters.
5523           "If it breaks, you get to keep both parts"
5524           (Your code is broken if you don't put them back together again
5525           before something notices.) */
5526 16 50       if (SvUTF8(upstream)) {
5527 0         SvUTF8_on(cache);
5528           }
5529 16 100       if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5530           else
5531           /* Cannot just use sv_setpvn, as that could free the buffer
5532           before we have a chance to assign it. */
5533 2         sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5534           got_len - cached_len);
5535 16         *prune_from = 0;
5536           /* Can't yet be EOF */
5537 16 50       if (status == 0)
5538           status = 1;
5539           }
5540            
5541           /* If they are at EOF but buf_sv has something in it, then they may never
5542           have touched the SV upstream, so it may be undefined. If we naively
5543           concatenate it then we get a warning about use of uninitialised value.
5544           */
5545 268 100       if (!err && upstream != buf_sv &&
    100        
5546 30 50       SvOK(upstream)) {
    50        
5547 24         sv_catsv_nomg(buf_sv, upstream);
5548           }
5549 226 100       else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
    50        
    50        
    100        
5550            
5551 250 100       if (status <= 0) {
5552 88         IoLINES(datasv) = 0;
5553 88 100       if (filter_state) {
5554 42         SvREFCNT_dec(filter_state);
5555 42         IoTOP_GV(datasv) = NULL;
5556           }
5557 88 100       if (filter_sub) {
5558 76         SvREFCNT_dec(filter_sub);
5559 76         IoBOTTOM_GV(datasv) = NULL;
5560           }
5561 88         filter_del(S_run_user_filter);
5562           }
5563            
5564 250 100       if (err)
5565 8         croak_sv(err);
5566            
5567 242 100       if (status == 0 && read_from_cache) {
    100        
5568           /* If we read some data from the cache (and by getting here it implies
5569           that we emptied the cache) then we aren't yet at EOF, and mustn't
5570           report that to our caller. */
5571           return 1;
5572           }
5573 330         return status;
5574 989132277         }
5575            
5576           /*
5577           * Local variables:
5578           * c-indentation-style: bsd
5579           * c-basic-offset: 4
5580           * indent-tabs-mode: nil
5581           * End:
5582           *
5583           * ex: set ts=8 sts=4 sw=4 et:
5584           */