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 #include "feature.h"
37
38 #define dopopto_cursub() \
39 (PL_curstackinfo->si_cxsubix >= 0 \
40 ? PL_curstackinfo->si_cxsubix \
41 : dopoptosub_at(cxstack, cxstack_ix))
42
43 #define dopoptosub(plop) dopoptosub_at(cxstack, (plop))
44
PP(pp_wantarray)45 PP(pp_wantarray)
46 {
47 I32 cxix;
48 const PERL_CONTEXT *cx;
49 SV *sv;
50
51 if (PL_op->op_private & OPpOFFBYONE) {
52 if (!(cx = caller_cx(1,NULL))) {
53 sv = &PL_sv_undef;
54 goto ret;
55 }
56 }
57 else {
58 cxix = dopopto_cursub();
59 if (cxix < 0) {
60 sv = &PL_sv_undef;
61 goto ret;
62 }
63 cx = &cxstack[cxix];
64 }
65
66 switch (cx->blk_gimme) {
67 case G_LIST:
68 sv = &PL_sv_yes;
69 break;
70 case G_SCALAR:
71 sv = &PL_sv_no;
72 break;
73 default:
74 sv = &PL_sv_undef;
75 break;
76 }
77
78 ret:
79 rpp_xpush_IMM(sv);
80 return NORMAL;
81 }
82
PP(pp_regcreset)83 PP(pp_regcreset)
84 {
85 TAINT_NOT;
86 return NORMAL;
87 }
88
PP(pp_regcomp)89 PP(pp_regcomp)
90 {
91 PMOP *pm = cPMOPx(cLOGOP->op_other);
92 SV **args;
93 int nargs;
94 REGEXP *re = NULL;
95 REGEXP *new_re;
96 const regexp_engine *eng;
97 bool is_bare_re= FALSE;
98
99 if (PL_op->op_flags & OPf_STACKED) {
100 dMARK;
101 nargs = PL_stack_sp - MARK;
102 args = ++MARK;
103 }
104 else {
105 nargs = 1;
106 args = PL_stack_sp;
107 }
108
109 /* prevent recompiling under /o and ithreads. */
110 #if defined(USE_ITHREADS)
111 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
112 goto finish;
113 #endif
114
115 re = PM_GETRE(pm);
116 assert (re != (REGEXP*) &PL_sv_undef);
117 eng = re ? RX_ENGINE(re) : current_re_engine();
118
119 new_re = (eng->op_comp
120 ? eng->op_comp
121 : &Perl_re_op_compile
122 )(aTHX_ args, nargs, pm->op_code_list, eng, re,
123 &is_bare_re,
124 (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK),
125 pm->op_pmflags |
126 (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0));
127
128 if (pm->op_pmflags & PMf_HAS_CV)
129 ReANY(new_re)->qr_anoncv
130 = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ));
131
132 if (is_bare_re) {
133 REGEXP *tmp;
134 /* The match's LHS's get-magic might need to access this op's regexp
135 (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call
136 get-magic now before we replace the regexp. Hopefully this hack can
137 be replaced with the approach described at
138 https://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html
139 some day. */
140 if (pm->op_type == OP_MATCH) {
141 SV *lhs;
142 const bool was_tainted = TAINT_get;
143 if (pm->op_flags & OPf_STACKED)
144 lhs = args[-1];
145 else if (pm->op_targ)
146 lhs = PAD_SV(pm->op_targ);
147 else lhs = DEFSV;
148 SvGETMAGIC(lhs);
149 /* Restore the previous value of PL_tainted (which may have been
150 modified by get-magic), to avoid incorrectly setting the
151 RXf_TAINTED flag with RX_TAINT_on further down. */
152 TAINT_set(was_tainted);
153 #ifdef NO_TAINT_SUPPORT
154 PERL_UNUSED_VAR(was_tainted);
155 #endif
156 }
157 tmp = reg_temp_copy(NULL, new_re);
158 ReREFCNT_dec(new_re);
159 new_re = tmp;
160 }
161
162 if (re != new_re) {
163 ReREFCNT_dec(re);
164 PM_SETRE(pm, new_re);
165 }
166
167
168 assert(TAINTING_get || !TAINT_get);
169 if (TAINT_get) {
170 SvTAINTED_on((SV*)new_re);
171 RX_TAINT_on(new_re);
172 }
173
174 /* handle the empty pattern */
175 if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) {
176 if (PL_curpm == PL_reg_curpm) {
177 if (PL_curpm_under && PL_curpm_under == PL_reg_curpm) {
178 Perl_croak(aTHX_ "Infinite recursion via empty pattern");
179 }
180 }
181 }
182
183 #if !defined(USE_ITHREADS)
184 /* can't change the optree at runtime either */
185 /* PMf_KEEP is handled differently under threads to avoid these problems */
186 if (pm->op_pmflags & PMf_KEEP) {
187 cLOGOP->op_first->op_next = PL_op->op_next;
188 }
189 #endif
190
191 #if defined(USE_ITHREADS)
192 finish:
193 #endif
194 rpp_popfree_to_NN(args - 1);
195 return NORMAL;
196 }
197
198
199 /* s/.../expr/e is executed in order as if written as
200 *
201 * pp_subst();
202 * while (pp_substcont()) {
203 * expr;
204 * }
205 *
206 * Only on the second and later calls to pp_substcont() is there a scalar
207 * on the stack holding the value of expr.
208 *
209 * Note that pp_subst() leaves its original 0-2 args on the stack to
210 * avoid them being prematurely freed. It is pp_substcont()'s
211 * responsibility to pop them after the last iteration.
212 */
213
PP(pp_substcont)214 PP(pp_substcont)
215 {
216 PERL_CONTEXT *cx = CX_CUR();
217 PMOP * const pm = cPMOPx(cLOGOP->op_other);
218 SV * const dstr = cx->sb_dstr;
219 char *s = cx->sb_s;
220 char *m = cx->sb_m;
221 char *orig = cx->sb_orig;
222 REGEXP * const rx = cx->sb_rx;
223 SV *nsv = NULL;
224 REGEXP *old = PM_GETRE(pm);
225
226 PERL_ASYNC_CHECK();
227
228 if(old != rx) {
229 if(old)
230 ReREFCNT_dec(old);
231 PM_SETRE(pm,ReREFCNT_inc(rx));
232 }
233
234 rxres_restore(&cx->sb_rxres, rx);
235
236 if (cx->sb_iters++) {
237 /* second+ time round. Result is on stack */
238 const SSize_t saviters = cx->sb_iters;
239 if (cx->sb_iters > cx->sb_maxiters)
240 DIE(aTHX_ "Substitution loop");
241
242 SvGETMAGIC(*PL_stack_sp); /* possibly clear taint on $1 etc: #67962 */
243
244 /* See "how taint works": pp_subst() in pp_hot.c */
245 sv_catsv_nomg(dstr, *PL_stack_sp);
246 rpp_popfree_1_NN();
247 if (UNLIKELY(TAINT_get))
248 cx->sb_rxtainted |= SUBST_TAINT_REPL;
249 if (CxONCE(cx) || s < orig ||
250 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
251 (s == m), cx->sb_targ, NULL,
252 (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW)))
253 {
254 /* no more iterations. Push return value etc */
255 SV *targ = cx->sb_targ;
256 SV *retval;
257
258 assert(cx->sb_strend >= s);
259 if(cx->sb_strend > s) {
260 if (DO_UTF8(dstr) && !SvUTF8(targ))
261 sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
262 else
263 sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
264 }
265 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
266 cx->sb_rxtainted |= SUBST_TAINT_PAT;
267
268 if (pm->op_pmflags & PMf_NONDESTRUCT) {
269 retval = dstr;
270 /* From here on down we're using the copy, and leaving the
271 original untouched. */
272 targ = dstr;
273 }
274 else {
275 SV_CHECK_THINKFIRST_COW_DROP(targ);
276 if (isGV(targ)) Perl_croak_no_modify();
277 SvPV_free(targ);
278 SvPV_set(targ, SvPVX(dstr));
279 SvCUR_set(targ, SvCUR(dstr));
280 SvLEN_set(targ, SvLEN(dstr));
281 if (DO_UTF8(dstr))
282 SvUTF8_on(targ);
283 SvPV_set(dstr, NULL);
284
285 PL_tainted = 0;
286 retval = sv_newmortal();
287 sv_setiv(retval, saviters - 1);
288
289 (void)SvPOK_only_UTF8(targ);
290 }
291
292 /* pop the original args (if any) to pp_subst(),
293 * then push the result */
294 if (pm->op_pmflags & PMf_CONST)
295 rpp_popfree_1_NN(); /* pop replacement string */
296 if (pm->op_flags & OPf_STACKED)
297 rpp_replace_1_1_NN(retval); /* pop LHS of =~ */
298 else
299 rpp_push_1(retval);
300
301 /* update the taint state of various variables in
302 * preparation for final exit.
303 * See "how taint works": pp_subst() in pp_hot.c */
304 if (TAINTING_get) {
305 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
306 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
307 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
308 )
309 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
310
311 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
312 && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
313 )
314 SvTAINTED_on(retval); /* taint return value */
315 /* needed for mg_set below */
316 TAINT_set(
317 cBOOL(cx->sb_rxtainted &
318 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))
319 );
320
321 /* sv_magic(), when adding magic (e.g.taint magic), also
322 * recalculates any pos() magic, converting any byte offset
323 * to utf8 offset. Make sure pos() is reset before this
324 * happens rather than using the now invalid value (since
325 * we've just replaced targ's pvx buffer with the
326 * potentially shorter dstr buffer). Normally (i.e. in
327 * non-taint cases), pos() gets removed a few lines later
328 * with the SvSETMAGIC().
329 */
330 {
331 MAGIC *mg;
332 mg = mg_find_mglob(targ);
333 if (mg) {
334 MgBYTEPOS_set(mg, targ, SvPVX(targ), -1);
335 }
336 }
337
338 SvTAINT(TARG);
339 }
340 /* PL_tainted must be correctly set for this mg_set */
341 SvSETMAGIC(TARG);
342 TAINT_NOT;
343
344 CX_LEAVE_SCOPE(cx);
345 CX_POPSUBST(cx);
346 CX_POP(cx);
347
348 PERL_ASYNC_CHECK();
349 return pm->op_next;
350 NOT_REACHED; /* NOTREACHED */
351 }
352 cx->sb_iters = saviters;
353 }
354
355 /* First iteration. The substitution expression hasn;'t been executed
356 * this time */
357
358 if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
359 m = s;
360 s = orig;
361 assert(!RX_SUBOFFSET(rx));
362 cx->sb_orig = orig = RX_SUBBEG(rx);
363 s = orig + (m - s);
364 cx->sb_strend = s + (cx->sb_strend - m);
365 }
366 cx->sb_m = m = RX_OFFS_START(rx,0) + orig;
367 if (m > s) {
368 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
369 sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
370 else
371 sv_catpvn_nomg(dstr, s, m-s);
372 }
373 cx->sb_s = RX_OFFS_END(rx,0) + orig;
374 { /* Update the pos() information. */
375 SV * const sv
376 = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
377 MAGIC *mg;
378
379 /* the string being matched against may no longer be a string,
380 * e.g. $_=0; s/.../$_++/ge */
381
382 if (!SvPOK(sv))
383 SvPV_force_nomg_nolen(sv);
384
385 if (!(mg = mg_find_mglob(sv))) {
386 mg = sv_magicext_mglob(sv);
387 }
388 MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
389 }
390 if (old != rx)
391 (void)ReREFCNT_inc(rx);
392 /* update the taint state of various variables in preparation
393 * for calling the code block.
394 * See "how taint works": pp_subst() in pp_hot.c */
395 if (TAINTING_get) {
396 if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
397 cx->sb_rxtainted |= SUBST_TAINT_PAT;
398
399 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
400 ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
401 == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
402 )
403 (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
404
405 if (cx->sb_iters > 1 && (cx->sb_rxtainted &
406 (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
407 SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
408 ? cx->sb_dstr : cx->sb_targ);
409 TAINT_NOT;
410 }
411 rxres_save(&cx->sb_rxres, rx);
412 PL_curpm = pm;
413 return pm->op_pmstashstartu.op_pmreplstart;
414 }
415
416
417 void
Perl_rxres_save(pTHX_ void ** rsp,REGEXP * rx)418 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
419 {
420 UV *p = (UV*)*rsp;
421 U32 i;
422
423 PERL_ARGS_ASSERT_RXRES_SAVE;
424 PERL_UNUSED_CONTEXT;
425
426 /* deal with regexp_paren_pair items */
427 if (!p || p[1] < RX_NPARENS(rx)) {
428 #ifdef PERL_ANY_COW
429 i = 7 + (RX_NPARENS(rx)+1) * 2;
430 #else
431 i = 6 + (RX_NPARENS(rx)+1) * 2;
432 #endif
433 if (!p)
434 Newx(p, i, UV);
435 else
436 Renew(p, i, UV);
437 *rsp = (void*)p;
438 }
439
440 /* what (if anything) to free on croak */
441 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
442 RX_MATCH_COPIED_off(rx);
443 *p++ = RX_NPARENS(rx);
444
445 #ifdef PERL_ANY_COW
446 *p++ = PTR2UV(RX_SAVED_COPY(rx));
447 RX_SAVED_COPY(rx) = NULL;
448 #endif
449
450 *p++ = PTR2UV(RX_SUBBEG(rx));
451 *p++ = (UV)RX_SUBLEN(rx);
452 *p++ = (UV)RX_SUBOFFSET(rx);
453 *p++ = (UV)RX_SUBCOFFSET(rx);
454 for (i = 0; i <= RX_NPARENS(rx); ++i) {
455 *p++ = (UV)RX_OFFSp(rx)[i].start;
456 *p++ = (UV)RX_OFFSp(rx)[i].end;
457 }
458 }
459
460 static void
S_rxres_restore(pTHX_ void ** rsp,REGEXP * rx)461 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
462 {
463 UV *p = (UV*)*rsp;
464 U32 i;
465
466 PERL_ARGS_ASSERT_RXRES_RESTORE;
467 PERL_UNUSED_CONTEXT;
468
469 RX_MATCH_COPY_FREE(rx);
470 RX_MATCH_COPIED_set(rx, *p);
471 *p++ = 0;
472 RX_NPARENS(rx) = *p++;
473
474 #ifdef PERL_ANY_COW
475 if (RX_SAVED_COPY(rx))
476 SvREFCNT_dec (RX_SAVED_COPY(rx));
477 RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
478 *p++ = 0;
479 #endif
480
481 RX_SUBBEG(rx) = INT2PTR(char*,*p++);
482 RX_SUBLEN(rx) = (SSize_t)(*p++);
483 RX_SUBOFFSET(rx) = (Size_t)*p++;
484 RX_SUBCOFFSET(rx) = (SSize_t)*p++;
485 for (i = 0; i <= RX_NPARENS(rx); ++i) {
486 RX_OFFSp(rx)[i].start = (SSize_t)(*p++);
487 RX_OFFSp(rx)[i].end = (SSize_t)(*p++);
488 }
489 }
490
491 static void
S_rxres_free(pTHX_ void ** rsp)492 S_rxres_free(pTHX_ void **rsp)
493 {
494 UV * const p = (UV*)*rsp;
495
496 PERL_ARGS_ASSERT_RXRES_FREE;
497 PERL_UNUSED_CONTEXT;
498
499 if (p) {
500 void *tmp = INT2PTR(char*,*p);
501 #ifdef PERL_POISON
502 #ifdef PERL_ANY_COW
503 U32 i = 9 + p[1] * 2;
504 #else
505 U32 i = 8 + p[1] * 2;
506 #endif
507 #endif
508
509 #ifdef PERL_ANY_COW
510 SvREFCNT_dec (INT2PTR(SV*,p[2]));
511 #endif
512 #ifdef PERL_POISON
513 PoisonFree(p, i, sizeof(UV));
514 #endif
515
516 Safefree(tmp);
517 Safefree(p);
518 *rsp = NULL;
519 }
520 }
521
522 #define FORM_NUM_BLANK (1<<30)
523 #define FORM_NUM_POINT (1<<29)
524
525 PP_wrapped(pp_formline, 0, 1)
526 {
527 dSP; dMARK; dORIGMARK;
528 SV * const tmpForm = *++MARK;
529 SV *formsv; /* contains text of original format */
530 U32 *fpc; /* format ops program counter */
531 char *t; /* current append position in target string */
532 const char *f; /* current position in format string */
533 I32 arg;
534 SV *sv = NULL; /* current item */
535 const char *item = NULL;/* string value of current item */
536 I32 itemsize = 0; /* length (chars) of item, possibly truncated */
537 I32 itembytes = 0; /* as itemsize, but length in bytes */
538 I32 fieldsize = 0; /* width of current field */
539 I32 lines = 0; /* number of lines that have been output */
540 bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
541 const char *chophere = NULL; /* where to chop current item */
542 STRLEN linemark = 0; /* pos of start of line in output */
543 NV value;
544 bool gotsome = FALSE; /* seen at least one non-blank item on this line */
545 STRLEN len; /* length of current sv */
546 STRLEN linemax; /* estimate of output size in bytes */
547 bool item_is_utf8 = FALSE;
548 bool targ_is_utf8 = FALSE;
549 const char *fmt;
550 MAGIC *mg = NULL;
551 U8 *source; /* source of bytes to append */
552 STRLEN to_copy; /* how may bytes to append */
553 char trans; /* what chars to translate */
554 bool copied_form = FALSE; /* have we duplicated the form? */
555
556 mg = doparseform(tmpForm);
557
558 fpc = (U32*)mg->mg_ptr;
559 /* the actual string the format was compiled from.
560 * with overload etc, this may not match tmpForm */
561 formsv = mg->mg_obj;
562
563
564 SvPV_force(PL_formtarget, len);
565 if (SvTAINTED(tmpForm) || SvTAINTED(formsv))
566 SvTAINTED_on(PL_formtarget);
567 if (DO_UTF8(PL_formtarget))
568 targ_is_utf8 = TRUE;
569 /* this is an initial estimate of how much output buffer space
570 * to allocate. It may be exceeded later */
571 linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1);
572 t = SvGROW(PL_formtarget, len + linemax + 1);
573 /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */
574 t += len;
575 f = SvPV_const(formsv, len);
576
577 for (;;) {
578 DEBUG_f( {
579 const char *name = "???";
580 arg = -1;
581 switch (*fpc) {
582 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
583 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
584 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
585 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
586 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
587
588 case FF_CHECKNL: name = "CHECKNL"; break;
589 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
590 case FF_SPACE: name = "SPACE"; break;
591 case FF_HALFSPACE: name = "HALFSPACE"; break;
592 case FF_ITEM: name = "ITEM"; break;
593 case FF_CHOP: name = "CHOP"; break;
594 case FF_LINEGLOB: name = "LINEGLOB"; break;
595 case FF_NEWLINE: name = "NEWLINE"; break;
596 case FF_MORE: name = "MORE"; break;
597 case FF_LINEMARK: name = "LINEMARK"; break;
598 case FF_END: name = "END"; break;
599 case FF_0DECIMAL: name = "0DECIMAL"; break;
600 case FF_LINESNGL: name = "LINESNGL"; break;
601 }
602 if (arg >= 0)
603 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
604 else
605 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
606 } );
607 switch (*fpc++) {
608 case FF_LINEMARK: /* start (or end) of a line */
609 linemark = t - SvPVX(PL_formtarget);
610 lines++;
611 gotsome = FALSE;
612 break;
613
614 case FF_LITERAL: /* append <arg> literal chars */
615 to_copy = *fpc++;
616 source = (U8 *)f;
617 f += to_copy;
618 trans = '~';
619 item_is_utf8 = (targ_is_utf8)
620 ? cBOOL(DO_UTF8(formsv))
621 : cBOOL(SvUTF8(formsv));
622 goto append;
623
624 case FF_SKIP: /* skip <arg> chars in format */
625 f += *fpc++;
626 break;
627
628 case FF_FETCH: /* get next item and set field size to <arg> */
629 arg = *fpc++;
630 f += arg;
631 fieldsize = arg;
632
633 if (MARK < SP)
634 sv = *++MARK;
635 else {
636 sv = &PL_sv_no;
637 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
638 }
639 if (SvTAINTED(sv))
640 SvTAINTED_on(PL_formtarget);
641 break;
642
643 case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
644 {
645 const char *s = item = SvPV_const(sv, len);
646 const char *send = s + len;
647
648 itemsize = 0;
649 item_is_utf8 = DO_UTF8(sv);
650 while (s < send) {
651 if (!isCNTRL(*s))
652 gotsome = TRUE;
653 else if (*s == '\n')
654 break;
655
656 if (item_is_utf8)
657 s += UTF8SKIP(s);
658 else
659 s++;
660 itemsize++;
661 if (itemsize == fieldsize)
662 break;
663 }
664 itembytes = s - item;
665 chophere = s;
666 break;
667 }
668
669 case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
670 {
671 const char *s = item = SvPV_const(sv, len);
672 const char *send = s + len;
673 I32 size = 0;
674
675 chophere = NULL;
676 item_is_utf8 = DO_UTF8(sv);
677 while (s < send) {
678 /* look for a legal split position */
679 if (isSPACE(*s)) {
680 if (*s == '\r') {
681 chophere = s;
682 itemsize = size;
683 break;
684 }
685 if (chopspace) {
686 /* provisional split point */
687 chophere = s;
688 itemsize = size;
689 }
690 /* we delay testing fieldsize until after we've
691 * processed the possible split char directly
692 * following the last field char; so if fieldsize=3
693 * and item="a b cdef", we consume "a b", not "a".
694 * Ditto further down.
695 */
696 if (size == fieldsize)
697 break;
698 }
699 else {
700 if (size == fieldsize)
701 break;
702 if (strchr(PL_chopset, *s)) {
703 /* provisional split point */
704 /* for a non-space split char, we include
705 * the split char; hence the '+1' */
706 chophere = s + 1;
707 itemsize = size + 1;
708 }
709 if (!isCNTRL(*s))
710 gotsome = TRUE;
711 }
712
713 if (item_is_utf8)
714 s += UTF8SKIP(s);
715 else
716 s++;
717 size++;
718 }
719 if (!chophere || s == send) {
720 chophere = s;
721 itemsize = size;
722 }
723 itembytes = chophere - item;
724
725 break;
726 }
727
728 case FF_SPACE: /* append padding space (diff of field, item size) */
729 arg = fieldsize - itemsize;
730 if (arg) {
731 fieldsize -= arg;
732 while (arg-- > 0)
733 *t++ = ' ';
734 }
735 break;
736
737 case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
738 arg = fieldsize - itemsize;
739 if (arg) {
740 arg /= 2;
741 fieldsize -= arg;
742 while (arg-- > 0)
743 *t++ = ' ';
744 }
745 break;
746
747 case FF_ITEM: /* append a text item, while blanking ctrl chars */
748 to_copy = itembytes;
749 source = (U8 *)item;
750 trans = 1;
751 goto append;
752
753 case FF_CHOP: /* (for ^*) chop the current item */
754 if (sv != &PL_sv_no) {
755 const char *s = chophere;
756 if (!copied_form &&
757 ((sv == tmpForm || SvSMAGICAL(sv))
758 || (SvGMAGICAL(tmpForm) && !sv_only_taint_gmagic(tmpForm))) ) {
759 /* sv and tmpForm are either the same SV, or magic might allow modification
760 of tmpForm when sv is modified, so copy */
761 SV *newformsv = sv_mortalcopy(formsv);
762 U32 *new_compiled;
763
764 f = SvPV_nolen(newformsv) + (f - SvPV_nolen(formsv));
765 Newx(new_compiled, mg->mg_len / sizeof(U32), U32);
766 memcpy(new_compiled, mg->mg_ptr, mg->mg_len);
767 SAVEFREEPV(new_compiled);
768 fpc = new_compiled + (fpc - (U32*)mg->mg_ptr);
769 formsv = newformsv;
770
771 copied_form = TRUE;
772 }
773 if (chopspace) {
774 while (isSPACE(*s))
775 s++;
776 }
777 if (SvPOKp(sv))
778 sv_chop(sv,s);
779 else
780 /* tied, overloaded or similar strangeness.
781 * Do it the hard way */
782 sv_setpvn(sv, s, len - (s-item));
783 SvSETMAGIC(sv);
784 break;
785 }
786 /* FALLTHROUGH */
787
788 case FF_LINESNGL: /* process ^* */
789 chopspace = 0;
790 /* FALLTHROUGH */
791
792 case FF_LINEGLOB: /* process @* */
793 {
794 const bool oneline = fpc[-1] == FF_LINESNGL;
795 const char *s = item = SvPV_const(sv, len);
796 const char *const send = s + len;
797
798 item_is_utf8 = DO_UTF8(sv);
799 chophere = s + len;
800 if (!len)
801 break;
802 trans = 0;
803 gotsome = TRUE;
804 source = (U8 *) s;
805 to_copy = len;
806 while (s < send) {
807 if (*s++ == '\n') {
808 if (oneline) {
809 to_copy = s - item - 1;
810 chophere = s;
811 break;
812 } else {
813 if (s == send) {
814 to_copy--;
815 } else
816 lines++;
817 }
818 }
819 }
820 }
821
822 append:
823 /* append to_copy bytes from source to PL_formstring.
824 * item_is_utf8 implies source is utf8.
825 * if trans, translate certain characters during the copy */
826 {
827 U8 *tmp = NULL;
828 STRLEN grow = 0;
829
830 SvCUR_set(PL_formtarget,
831 t - SvPVX_const(PL_formtarget));
832
833 if (targ_is_utf8 && !item_is_utf8) {
834 source = tmp = bytes_to_utf8(source, &to_copy);
835 grow = to_copy;
836 } else {
837 if (item_is_utf8 && !targ_is_utf8) {
838 U8 *s;
839 /* Upgrade targ to UTF8, and then we reduce it to
840 a problem we have a simple solution for.
841 Don't need get magic. */
842 sv_utf8_upgrade_nomg(PL_formtarget);
843 targ_is_utf8 = TRUE;
844 /* re-calculate linemark */
845 s = (U8*)SvPVX(PL_formtarget);
846 /* the bytes we initially allocated to append the
847 * whole line may have been gobbled up during the
848 * upgrade, so allocate a whole new line's worth
849 * for safety */
850 grow = linemax;
851 while (linemark--)
852 s += UTF8_SAFE_SKIP(s,
853 (U8 *) SvEND(PL_formtarget));
854 linemark = s - (U8*)SvPVX(PL_formtarget);
855 }
856 /* Easy. They agree. */
857 assert (item_is_utf8 == targ_is_utf8);
858 }
859 if (!trans)
860 /* @* and ^* are the only things that can exceed
861 * the linemax, so grow by the output size, plus
862 * a whole new form's worth in case of any further
863 * output */
864 grow = linemax + to_copy;
865 if (grow)
866 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1);
867 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
868
869 Copy(source, t, to_copy, char);
870 if (trans) {
871 /* blank out ~ or control chars, depending on trans.
872 * works on bytes not chars, so relies on not
873 * matching utf8 continuation bytes */
874 U8 *s = (U8*)t;
875 U8 *send = s + to_copy;
876 while (s < send) {
877 const int ch = *s;
878 if (trans == '~' ? (ch == '~') : isCNTRL(ch))
879 *s = ' ';
880 s++;
881 }
882 }
883
884 t += to_copy;
885 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
886 if (tmp)
887 Safefree(tmp);
888 break;
889 }
890
891 case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
892 arg = *fpc++;
893 fmt = (const char *)
894 ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
895 goto ff_dec;
896
897 case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
898 arg = *fpc++;
899 fmt = (const char *)
900 ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
901 ff_dec:
902 /* If the field is marked with ^ and the value is undefined,
903 blank it out. */
904 if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) {
905 arg = fieldsize;
906 while (arg--)
907 *t++ = ' ';
908 break;
909 }
910 gotsome = TRUE;
911 value = SvNV(sv);
912 /* overflow evidence */
913 if (num_overflow(value, fieldsize, arg)) {
914 arg = fieldsize;
915 while (arg--)
916 *t++ = '#';
917 break;
918 }
919 /* Formats aren't yet marked for locales, so assume "yes". */
920 {
921 Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
922 int len;
923 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
924 #ifdef USE_QUADMATH
925 {
926 int len;
927 if (!quadmath_format_valid(fmt))
928 Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
929 WITH_LC_NUMERIC_SET_TO_NEEDED(
930 len = quadmath_snprintf(t, max, fmt, (int) fieldsize,
931 (int) arg, value);
932 );
933 if (len == -1)
934 Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", fmt);
935 }
936 #else
937 /* we generate fmt ourselves so it is safe */
938 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
939 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
940 GCC_DIAG_RESTORE_STMT;
941 #endif
942 PERL_MY_SNPRINTF_POST_GUARD(len, max);
943 }
944 t += fieldsize;
945 break;
946
947 case FF_NEWLINE: /* delete trailing spaces, then append \n */
948 f++;
949 while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
950 t++;
951 *t++ = '\n';
952 break;
953
954 case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
955 arg = *fpc++;
956 if (gotsome) {
957 if (arg) { /* repeat until fields exhausted? */
958 fpc--;
959 goto end;
960 }
961 }
962 else {
963 t = SvPVX(PL_formtarget) + linemark;
964 lines--;
965 }
966 break;
967
968 case FF_MORE: /* replace long end of string with '...' */
969 {
970 const char *s = chophere;
971 const char *send = item + len;
972 if (chopspace) {
973 while (isSPACE(*s) && (s < send))
974 s++;
975 }
976 if (s < send) {
977 char *s1;
978 arg = fieldsize - itemsize;
979 if (arg) {
980 fieldsize -= arg;
981 while (arg-- > 0)
982 *t++ = ' ';
983 }
984 s1 = t - 3;
985 if (strBEGINs(s1," ")) {
986 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
987 s1--;
988 }
989 *s1++ = '.';
990 *s1++ = '.';
991 *s1++ = '.';
992 }
993 break;
994 }
995
996 case FF_END: /* tidy up, then return */
997 end:
998 assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
999 *t = '\0';
1000 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1001 if (targ_is_utf8)
1002 SvUTF8_on(PL_formtarget);
1003 FmLINES(PL_formtarget) += lines;
1004 SP = ORIGMARK;
1005 if (fpc[-1] == FF_BLANK)
1006 RETURNOP(cLISTOP->op_first);
1007 else
1008 RETPUSHYES;
1009 }
1010 }
1011 }
1012
1013 /* also used for: pp_mapstart() */
PP(pp_grepstart)1014 PP(pp_grepstart)
1015 {
1016 /* See the code comments at the start of pp_grepwhile() and
1017 * pp_mapwhile() for an explanation of how the stack is used
1018 * during a grep or map.
1019 */
1020 SV *src;
1021 SV **svp;
1022
1023 if (PL_stack_base + TOPMARK == PL_stack_sp) {
1024 (void)POPMARK;
1025 if (GIMME_V == G_SCALAR) {
1026 rpp_extend(1);
1027 *++PL_stack_sp = &PL_sv_zero;
1028 }
1029 return PL_op->op_next->op_next;
1030 }
1031 svp = PL_stack_base + TOPMARK + 1;
1032 PUSHMARK(svp); /* push dst */
1033 PUSHMARK(svp); /* push src */
1034 ENTER_with_name("grep"); /* enter outer scope */
1035
1036 SAVETMPS;
1037 SAVE_DEFSV;
1038 ENTER_with_name("grep_item"); /* enter inner scope */
1039 SAVEVPTR(PL_curpm);
1040
1041 src = PL_stack_base[TOPMARK];
1042 if (SvPADTMP(src)) {
1043 SV *newsrc = sv_mortalcopy(src);
1044 PL_tmps_floor++;
1045 PL_stack_base[TOPMARK] = newsrc;
1046 #ifdef PERL_RC_STACK
1047 SvREFCNT_inc_simple_void_NN(newsrc);
1048 SvREFCNT_dec(src);
1049 #endif
1050 src = newsrc;
1051 }
1052 SvTEMP_off(src);
1053 DEFSV_set(src);
1054
1055 if (PL_op->op_type == OP_MAPSTART)
1056 PUSHMARK(PL_stack_sp); /* push top */
1057 return cLOGOPx(PL_op->op_next)->op_other;
1058 }
1059
1060 /* pp_grepwhile() lives in pp_hot.c */
1061
PP(pp_mapwhile)1062 PP(pp_mapwhile)
1063 {
1064 /* Understanding the stack during a map.
1065 *
1066 * 'map expr, args' is implemented in the form of
1067 *
1068 * grepstart; // which handles map too
1069 * do {
1070 * expr;
1071 * mapwhile;
1072 * } while (args);
1073 *
1074 * The stack examples below are in the form of 'perl -Ds' output,
1075 * where any stack element indexed by PL_markstack_ptr[i] has a star
1076 * just to the right of it. In addition, the corresponding i value
1077 * is displayed under the indexed stack element.
1078 *
1079 * On entry to mapwhile, the stack looks like this:
1080 *
1081 * => * A1..An X1 * X2..Xn C * R1..Rn * E1..En
1082 * [-3] [-2] [-1] [0]
1083 *
1084 * where:
1085 * A1..An Accumulated results from all previous iterations of expr
1086 * X1..Xn Random garbage
1087 * C The current (just processed) arg, still aliased to $_.
1088 * R1..Rn The args remaining to be processed.
1089 * E1..En the (list) result of the just-executed map expression.
1090 *
1091 * Note that it is easiest to think of stack marks [-1] and [-2] as both
1092 * being one too high, and so it would make more sense to have had the
1093 * marks like this:
1094 *
1095 * => * A1..An * X1..Xn * C R1..Rn * E1..En
1096 * [-3] [-2] [-1] [0]
1097 *
1098 * where the stack is divided neatly into 4 groups:
1099 * - accumulated results
1100 * - discards and/or holes proactively created for later result storage
1101 * - being, or yet to be, processed,
1102 * - results of last expr
1103 * But off-by-one is the way it is currently, and it works as long as
1104 * we keep it consistent and bear it in mind.
1105 *
1106 * pp_mapwhile() does the following:
1107 *
1108 * - If there isn't enough space in the X1..Xn zone to insert the
1109 * expression results, grow the stack and shift up everything above C.
1110 * - move E1..En to just above An
1111 * - at the same time, manipulate the tmps stack so that temporaries
1112 * from executing expr can be freed without prematurely freeing
1113 * E1..En.
1114 * - if on last iteration, pop all the marks, reset the stack pointer
1115 * and update the return args based on caller context.
1116 * - else alias $_ to the next arg.
1117 *
1118 */
1119
1120 const U8 gimme = GIMME_V;
1121 SSize_t items = (PL_stack_sp - PL_stack_base) - TOPMARK; /* how many new items */
1122 SSize_t count;
1123 SSize_t shift;
1124 SV** src;
1125 SV** dst;
1126
1127 #ifdef PERL_RC_STACK
1128 /* for ref-counted stack, we need to account for the currently-aliased
1129 * stack element, as it might (or might not) get over-written when
1130 * copying values from the expr to the end of the accumulated results
1131 * section of the list. By RC--ing and zeroing out the stack entry, we
1132 * ensure consistent handling.
1133 */
1134 dst = PL_stack_base + PL_markstack_ptr[-1];
1135 SvREFCNT_dec_NN(*dst);
1136 *dst = NULL;
1137 #endif
1138
1139 /* first, move source pointer to the next item in the source list */
1140 ++PL_markstack_ptr[-1];
1141
1142 /* if there are new items, push them into the destination list */
1143 if (items && gimme != G_VOID) {
1144 /* might need to make room back there first */
1145 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1146 /* XXX this implementation is very pessimal because the stack
1147 * is repeatedly extended for every set of items. Is possible
1148 * to do this without any stack extension or copying at all
1149 * by maintaining a separate list over which the map iterates
1150 * (like foreach does). --gsar */
1151
1152 /* everything in the stack after the destination list moves
1153 * towards the end the stack by the amount of room needed */
1154 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1155
1156 /* items to shift up (accounting for the moved source pointer) */
1157 count = (PL_stack_sp - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1158
1159 /* This optimization is by Ben Tilly and it does
1160 * things differently from what Sarathy (gsar)
1161 * is describing. The downside of this optimization is
1162 * that leaves "holes" (uninitialized and hopefully unused areas)
1163 * to the Perl stack, but on the other hand this
1164 * shouldn't be a problem. If Sarathy's idea gets
1165 * implemented, this optimization should become
1166 * irrelevant. --jhi */
1167 if (shift < count)
1168 shift = count; /* Avoid shifting too often --Ben Tilly */
1169
1170 rpp_extend(shift);
1171 src = PL_stack_sp;
1172 PL_stack_sp += shift;
1173 dst = PL_stack_sp;
1174 PL_markstack_ptr[-1] += shift;
1175 *PL_markstack_ptr += shift;
1176 while (count--)
1177 *dst-- = *src--;
1178 #ifdef PERL_RC_STACK
1179 /* zero out the hole just created, so that on a
1180 * reference-counted stack, so that the just-shifted SVs
1181 * aren't counted twice.
1182 */
1183 Zero(src+1, (dst-src), SV*);
1184 #endif
1185 }
1186 /* copy the new items down to the destination list */
1187 PL_markstack_ptr[-2] += items;
1188 dst = PL_stack_base + PL_markstack_ptr[-2] - 1;
1189 if (gimme == G_LIST) {
1190 /* add returned items to the collection (making mortal copies
1191 * if necessary), then clear the current temps stack frame
1192 * *except* for those items. We do this splicing the items
1193 * into the start of the tmps frame (so some items may be on
1194 * the tmps stack twice), then moving PL_tmps_floor above
1195 * them, then freeing the frame. That way, the only tmps that
1196 * accumulate over iterations are the return values for map.
1197 * We have to do to this way so that everything gets correctly
1198 * freed if we die during the map.
1199 */
1200 SSize_t tmpsbase;
1201 SSize_t i = items;
1202 /* make space for the slice */
1203 EXTEND_MORTAL(items);
1204 tmpsbase = PL_tmps_floor + 1;
1205 Move(PL_tmps_stack + tmpsbase,
1206 PL_tmps_stack + tmpsbase + items,
1207 PL_tmps_ix - PL_tmps_floor,
1208 SV*);
1209 PL_tmps_ix += items;
1210
1211 while (i-- > 0) {
1212 #ifdef PERL_RC_STACK
1213 SV *sv = *PL_stack_sp;
1214 assert(!*dst); /* not overwriting ptrs to refcnted SVs */
1215 if (!SvTEMP(sv)) {
1216 sv = sv_mortalcopy(sv);
1217 /* NB - don't really need the mortalising above.
1218 * A simple copy would suffice */
1219 *dst-- = sv;
1220 SvREFCNT_inc_simple_void_NN(sv);
1221 rpp_popfree_1_NN();
1222 }
1223 else {
1224 *dst-- = sv;
1225 PL_stack_sp--;
1226 }
1227
1228 #else
1229 SV *sv = *PL_stack_sp--;
1230 if (!SvTEMP(sv))
1231 sv = sv_mortalcopy(sv);
1232 *dst-- = sv;
1233 #endif
1234 PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv);
1235 }
1236 /* clear the stack frame except for the items */
1237 PL_tmps_floor += items;
1238 FREETMPS;
1239 /* FREETMPS may have cleared the TEMP flag on some of the items */
1240 i = items;
1241 while (i-- > 0)
1242 SvTEMP_on(PL_tmps_stack[--tmpsbase]);
1243 }
1244 else {
1245 /* scalar context: we don't care about which values map returns
1246 * (we use undef here). And so we certainly don't want to do mortal
1247 * copies of meaningless values. */
1248 *(dst - items + 1) = &PL_sv_undef;
1249 rpp_popfree_to(PL_stack_sp - items);
1250 FREETMPS;
1251 }
1252 }
1253 else {
1254 if (items) {
1255 assert(gimme == G_VOID);
1256 rpp_popfree_to(PL_stack_sp - items);
1257 }
1258 FREETMPS;
1259 }
1260 LEAVE_with_name("grep_item"); /* exit inner scope */
1261
1262 /* All done yet? */
1263 if (PL_markstack_ptr[-1] > TOPMARK) {
1264
1265 (void)POPMARK; /* pop top */
1266 LEAVE_with_name("grep"); /* exit outer scope */
1267 (void)POPMARK; /* pop src */
1268 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1269 (void)POPMARK; /* pop dst */
1270 SV **svp = PL_stack_base + POPMARK; /* pop original mark */
1271 if (gimme == G_LIST)
1272 svp += items;
1273 rpp_popfree_to(svp);
1274 if (gimme == G_SCALAR) {
1275 dTARGET;
1276 TARGi(items, 1);
1277 /* XXX is the extend necessary? */
1278 rpp_xpush_1(targ);
1279 }
1280 return NORMAL;
1281 }
1282 else {
1283 SV *src;
1284
1285 ENTER_with_name("grep_item"); /* enter inner scope */
1286 SAVEVPTR(PL_curpm);
1287
1288 /* set $_ to the new source item */
1289 src = PL_stack_base[PL_markstack_ptr[-1]];
1290 if (SvPADTMP(src)) {
1291 SV *newsrc = sv_mortalcopy(src);
1292 PL_stack_base[PL_markstack_ptr[-1]] = newsrc;
1293 #ifdef PERL_RC_STACK
1294 SvREFCNT_inc_simple_void_NN(newsrc);
1295 SvREFCNT_dec(src);
1296 #endif
1297 src = newsrc;
1298 }
1299 if (SvPADTMP(src)) {
1300 src = sv_mortalcopy(src);
1301 }
1302 SvTEMP_off(src);
1303 DEFSV_set(src);
1304
1305 return cLOGOP->op_other;
1306 }
1307 }
1308
1309 /* Range stuff. */
1310
PP(pp_range)1311 PP(pp_range)
1312 {
1313 dTARG;
1314 if (GIMME_V == G_LIST)
1315 return NORMAL;
1316 GETTARGET;
1317 if (SvTRUE_NN(targ))
1318 return cLOGOP->op_other;
1319 else
1320 return NORMAL;
1321 }
1322
1323
1324 PP_wrapped(pp_flip,((GIMME_V == G_LIST) ? 0 : 1), 0)
1325 {
1326 dSP;
1327
1328 if (GIMME_V == G_LIST) {
1329 RETURNOP(cLOGOPx(cUNOP->op_first)->op_other);
1330 }
1331 else {
1332 dTOPss;
1333 SV * const targ = PAD_SV(PL_op->op_targ);
1334 int flip = 0;
1335
1336 if (PL_op->op_private & OPpFLIP_LINENUM) {
1337 if (GvIO(PL_last_in_gv)) {
1338 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1339 }
1340 else {
1341 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1342 if (gv && GvSV(gv))
1343 flip = SvIV(sv) == SvIV(GvSV(gv));
1344 }
1345 } else {
1346 flip = SvTRUE_NN(sv);
1347 }
1348 if (flip) {
1349 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1350 if (PL_op->op_flags & OPf_SPECIAL) {
1351 sv_setiv(targ, 1);
1352 SETs(targ);
1353 RETURN;
1354 }
1355 else {
1356 sv_setiv(targ, 0);
1357 SP--;
1358 RETURNOP(cLOGOPx(cUNOP->op_first)->op_other);
1359 }
1360 }
1361 SvPVCLEAR(TARG);
1362 SETs(targ);
1363 RETURN;
1364 }
1365 }
1366
1367
1368 /* This code tries to decide if "$left .. $right" should use the
1369 magical string increment, or if the range is numeric. Initially,
1370 an exception was made for *any* string beginning with "0" (see
1371 [#18165], AMS 20021031), but now that is only applied when the
1372 string's length is also >1 - see the rules now documented in
1373 perlop [#133695] */
1374
1375 #define RANGE_IS_NUMERIC(left,right) ( \
1376 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1377 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1378 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1379 looks_like_number(left)) && SvPOKp(left) \
1380 && !(*SvPVX_const(left) == '0' && SvCUR(left)>1 ) )) \
1381 && (!SvOK(right) || looks_like_number(right))))
1382
1383
1384 PP_wrapped(pp_flop, (GIMME_V == G_LIST) ? 2 : 1, 0)
1385 {
1386 dSP;
1387
1388 if (GIMME_V == G_LIST) {
1389 dPOPPOPssrl;
1390
1391 SvGETMAGIC(left);
1392 SvGETMAGIC(right);
1393
1394 if (RANGE_IS_NUMERIC(left,right)) {
1395 IV i, j, n;
1396 if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
1397 (SvOK(right) && (SvIOK(right)
1398 ? SvIsUV(right) && SvUV(right) > IV_MAX
1399 : SvNV_nomg(right) > (NV) IV_MAX)))
1400 DIE(aTHX_ "Range iterator outside integer range");
1401 i = SvIV_nomg(left);
1402 j = SvIV_nomg(right);
1403 if (j >= i) {
1404 /* Dance carefully around signed max. */
1405 bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
1406 if (!overflow) {
1407 n = j - i + 1;
1408 /* The wraparound of signed integers is undefined
1409 * behavior, but here we aim for count >=1, and
1410 * negative count is just wrong. */
1411 if (n < 1
1412 #if IVSIZE > Size_t_size
1413 || n > SSize_t_MAX
1414 #endif
1415 )
1416 overflow = TRUE;
1417 }
1418 if (overflow)
1419 Perl_croak(aTHX_ "Out of memory during list extend");
1420 EXTEND_MORTAL(n);
1421 EXTEND(SP, n);
1422 }
1423 else
1424 n = 0;
1425 while (n--) {
1426 SV * const sv = sv_2mortal(newSViv(i));
1427 PUSHs(sv);
1428 if (n) /* avoid incrementing above IV_MAX */
1429 i++;
1430 }
1431 }
1432 else {
1433 STRLEN len, llen;
1434 const char * const lpv = SvPV_nomg_const(left, llen);
1435 const char * const tmps = SvPV_nomg_const(right, len);
1436
1437 SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP);
1438 if (DO_UTF8(right) && IN_UNI_8_BIT)
1439 len = sv_len_utf8_nomg(right);
1440 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1441 XPUSHs(sv);
1442 if (strEQ(SvPVX_const(sv),tmps))
1443 break;
1444 sv = sv_2mortal(newSVsv(sv));
1445 sv_inc(sv);
1446 }
1447 }
1448 }
1449 else {
1450 dTOPss;
1451 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1452 int flop = 0;
1453 sv_inc(targ);
1454
1455 if (PL_op->op_private & OPpFLIP_LINENUM) {
1456 if (GvIO(PL_last_in_gv)) {
1457 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1458 }
1459 else {
1460 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1461 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1462 }
1463 }
1464 else {
1465 flop = SvTRUE_NN(sv);
1466 }
1467
1468 if (flop) {
1469 sv_setiv(PAD_SV(cUNOPx(cUNOP->op_first)->op_first->op_targ), 0);
1470 sv_catpvs(targ, "E0");
1471 }
1472 SETs(targ);
1473 }
1474
1475 RETURN;
1476 }
1477
1478
1479 /* Control. */
1480
1481 static const char * const context_name[] = {
1482 "pseudo-block",
1483 NULL, /* CXt_WHEN never actually needs "block" */
1484 NULL, /* CXt_BLOCK never actually needs "block" */
1485 NULL, /* CXt_GIVEN never actually needs "block" */
1486 NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1487 NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1488 NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1489 NULL, /* CXt_LOOP_LIST never actually needs "loop" */
1490 NULL, /* CXt_LOOP_ARY never actually needs "loop" */
1491 "subroutine",
1492 "format",
1493 "eval",
1494 "substitution",
1495 "defer block",
1496 };
1497
1498 STATIC I32
S_dopoptolabel(pTHX_ const char * label,STRLEN len,U32 flags)1499 S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
1500 {
1501 I32 i;
1502
1503 PERL_ARGS_ASSERT_DOPOPTOLABEL;
1504
1505 for (i = cxstack_ix; i >= 0; i--) {
1506 const PERL_CONTEXT * const cx = &cxstack[i];
1507 switch (CxTYPE(cx)) {
1508 case CXt_EVAL:
1509 if(CxTRY(cx))
1510 continue;
1511 /* FALLTHROUGH */
1512 case CXt_SUBST:
1513 case CXt_SUB:
1514 case CXt_FORMAT:
1515 case CXt_NULL:
1516 /* diag_listed_as: Exiting subroutine via %s */
1517 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1518 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1519 if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */
1520 return -1;
1521 break;
1522 case CXt_LOOP_PLAIN:
1523 case CXt_LOOP_LAZYIV:
1524 case CXt_LOOP_LAZYSV:
1525 case CXt_LOOP_LIST:
1526 case CXt_LOOP_ARY:
1527 {
1528 STRLEN cx_label_len = 0;
1529 U32 cx_label_flags = 0;
1530 const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags);
1531 if (!cx_label || !(
1532 ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
1533 (flags & SVf_UTF8)
1534 ? (bytes_cmp_utf8(
1535 (const U8*)cx_label, cx_label_len,
1536 (const U8*)label, len) == 0)
1537 : (bytes_cmp_utf8(
1538 (const U8*)label, len,
1539 (const U8*)cx_label, cx_label_len) == 0)
1540 : (len == cx_label_len && ((cx_label == label)
1541 || memEQ(cx_label, label, len))) )) {
1542 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1543 (long)i, cx_label));
1544 continue;
1545 }
1546 DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1547 return i;
1548 }
1549 }
1550 }
1551 return i;
1552 }
1553
1554 /*
1555 =for apidoc_section $callback
1556 =for apidoc dowantarray
1557
1558 Implements the deprecated L<perlapi/C<GIMME>>.
1559
1560 =cut
1561 */
1562
1563 U8
Perl_dowantarray(pTHX)1564 Perl_dowantarray(pTHX)
1565 {
1566 const U8 gimme = block_gimme();
1567 return (gimme == G_VOID) ? G_SCALAR : gimme;
1568 }
1569
1570 /* note that this function has mostly been superseded by Perl_gimme_V */
1571
1572 U8
Perl_block_gimme(pTHX)1573 Perl_block_gimme(pTHX)
1574 {
1575 const I32 cxix = dopopto_cursub();
1576 U8 gimme;
1577 if (cxix < 0)
1578 return G_VOID;
1579
1580 gimme = (cxstack[cxix].blk_gimme & G_WANT);
1581 if (!gimme)
1582 Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
1583 return gimme;
1584 }
1585
1586 /*
1587 =for apidoc is_lvalue_sub
1588
1589 Returns non-zero if the sub calling this function is being called in an lvalue
1590 context. Returns 0 otherwise.
1591
1592 =cut
1593 */
1594
1595 I32
Perl_is_lvalue_sub(pTHX)1596 Perl_is_lvalue_sub(pTHX)
1597 {
1598 const I32 cxix = dopopto_cursub();
1599 assert(cxix >= 0); /* We should only be called from inside subs */
1600
1601 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1602 return CxLVAL(cxstack + cxix);
1603 else
1604 return 0;
1605 }
1606
1607 /* only used by cx_pushsub() */
1608 I32
Perl_was_lvalue_sub(pTHX)1609 Perl_was_lvalue_sub(pTHX)
1610 {
1611 const I32 cxix = dopoptosub(cxstack_ix-1);
1612 assert(cxix >= 0); /* We should only be called from inside subs */
1613
1614 if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1615 return CxLVAL(cxstack + cxix);
1616 else
1617 return 0;
1618 }
1619
1620 STATIC I32
S_dopoptosub_at(pTHX_ const PERL_CONTEXT * cxstk,I32 startingblock)1621 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1622 {
1623 I32 i;
1624
1625 PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1626 #ifndef DEBUGGING
1627 PERL_UNUSED_CONTEXT;
1628 #endif
1629
1630 for (i = startingblock; i >= 0; i--) {
1631 const PERL_CONTEXT * const cx = &cxstk[i];
1632 switch (CxTYPE(cx)) {
1633 default:
1634 continue;
1635 case CXt_SUB:
1636 /* in sub foo { /(?{...})/ }, foo ends up on the CX stack
1637 * twice; the first for the normal foo() call, and the second
1638 * for a faked up re-entry into the sub to execute the
1639 * code block. Hide this faked entry from the world. */
1640 if (cx->cx_type & CXp_SUB_RE_FAKE)
1641 continue;
1642 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1643 return i;
1644
1645 case CXt_EVAL:
1646 if (CxTRY(cx))
1647 continue;
1648 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1649 return i;
1650
1651 case CXt_FORMAT:
1652 DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1653 return i;
1654 }
1655 }
1656 return i;
1657 }
1658
1659 STATIC I32
S_dopoptoeval(pTHX_ I32 startingblock)1660 S_dopoptoeval(pTHX_ I32 startingblock)
1661 {
1662 I32 i;
1663 for (i = startingblock; i >= 0; i--) {
1664 const PERL_CONTEXT *cx = &cxstack[i];
1665 switch (CxTYPE(cx)) {
1666 default:
1667 continue;
1668 case CXt_EVAL:
1669 DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1670 return i;
1671 }
1672 }
1673 return i;
1674 }
1675
1676 STATIC I32
S_dopoptoloop(pTHX_ I32 startingblock)1677 S_dopoptoloop(pTHX_ I32 startingblock)
1678 {
1679 I32 i;
1680 for (i = startingblock; i >= 0; i--) {
1681 const PERL_CONTEXT * const cx = &cxstack[i];
1682 switch (CxTYPE(cx)) {
1683 case CXt_EVAL:
1684 if(CxTRY(cx))
1685 continue;
1686 /* FALLTHROUGH */
1687 case CXt_SUBST:
1688 case CXt_SUB:
1689 case CXt_FORMAT:
1690 case CXt_NULL:
1691 /* diag_listed_as: Exiting subroutine via %s */
1692 Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1693 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1694 if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */
1695 return -1;
1696 break;
1697 case CXt_LOOP_PLAIN:
1698 case CXt_LOOP_LAZYIV:
1699 case CXt_LOOP_LAZYSV:
1700 case CXt_LOOP_LIST:
1701 case CXt_LOOP_ARY:
1702 DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1703 return i;
1704 }
1705 }
1706 return i;
1707 }
1708
1709 /* find the next GIVEN or FOR (with implicit $_) loop context block */
1710
1711 STATIC I32
S_dopoptogivenfor(pTHX_ I32 startingblock)1712 S_dopoptogivenfor(pTHX_ I32 startingblock)
1713 {
1714 I32 i;
1715 for (i = startingblock; i >= 0; i--) {
1716 const PERL_CONTEXT *cx = &cxstack[i];
1717 switch (CxTYPE(cx)) {
1718 default:
1719 continue;
1720 case CXt_GIVEN:
1721 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
1722 return i;
1723 case CXt_LOOP_PLAIN:
1724 assert(!(cx->cx_type & CXp_FOR_DEF));
1725 break;
1726 case CXt_LOOP_LAZYIV:
1727 case CXt_LOOP_LAZYSV:
1728 case CXt_LOOP_LIST:
1729 case CXt_LOOP_ARY:
1730 if (cx->cx_type & CXp_FOR_DEF) {
1731 DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
1732 return i;
1733 }
1734 }
1735 }
1736 return i;
1737 }
1738
1739 STATIC I32
S_dopoptowhen(pTHX_ I32 startingblock)1740 S_dopoptowhen(pTHX_ I32 startingblock)
1741 {
1742 I32 i;
1743 for (i = startingblock; i >= 0; i--) {
1744 const PERL_CONTEXT *cx = &cxstack[i];
1745 switch (CxTYPE(cx)) {
1746 default:
1747 continue;
1748 case CXt_WHEN:
1749 DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1750 return i;
1751 }
1752 }
1753 return i;
1754 }
1755
1756 /* dounwind(): pop all contexts above (but not including) cxix.
1757 * Note that it clears the savestack frame associated with each popped
1758 * context entry, but doesn't free any temps.
1759 * It does a cx_popblock() of the last frame that it pops, and leaves
1760 * cxstack_ix equal to cxix.
1761 */
1762
1763 void
Perl_dounwind(pTHX_ I32 cxix)1764 Perl_dounwind(pTHX_ I32 cxix)
1765 {
1766 if (!PL_curstackinfo) /* can happen if die during thread cloning */
1767 return;
1768
1769 while (cxstack_ix > cxix) {
1770 PERL_CONTEXT *cx = CX_CUR();
1771
1772 CX_DEBUG(cx, "UNWIND");
1773 /* Note: we don't need to restore the base context info till the end. */
1774
1775 CX_LEAVE_SCOPE(cx);
1776
1777 switch (CxTYPE(cx)) {
1778 case CXt_SUBST:
1779 CX_POPSUBST(cx);
1780 /* CXt_SUBST is not a block context type, so skip the
1781 * cx_popblock(cx) below */
1782 if (cxstack_ix == cxix + 1) {
1783 cxstack_ix--;
1784 return;
1785 }
1786 break;
1787 case CXt_SUB:
1788 cx_popsub(cx);
1789 break;
1790 case CXt_EVAL:
1791 cx_popeval(cx);
1792 break;
1793 case CXt_LOOP_PLAIN:
1794 case CXt_LOOP_LAZYIV:
1795 case CXt_LOOP_LAZYSV:
1796 case CXt_LOOP_LIST:
1797 case CXt_LOOP_ARY:
1798 cx_poploop(cx);
1799 break;
1800 case CXt_WHEN:
1801 cx_popwhen(cx);
1802 break;
1803 case CXt_GIVEN:
1804 cx_popgiven(cx);
1805 break;
1806 case CXt_BLOCK:
1807 case CXt_NULL:
1808 case CXt_DEFER:
1809 /* these two don't have a POPFOO() */
1810 break;
1811 case CXt_FORMAT:
1812 cx_popformat(cx);
1813 break;
1814 }
1815 if (cxstack_ix == cxix + 1) {
1816 cx_popblock(cx);
1817 }
1818 cxstack_ix--;
1819 }
1820
1821 }
1822
1823
1824 /* Like rpp_popfree_to(), but takes an offset rather than a pointer,
1825 * and frees everything above ix appropriately, *regardless* of the
1826 * refcountedness of the stack. If necessary it removes any split stack.
1827 * Intended for use during exit() and die() and similar.
1828 */
1829 void
Perl_rpp_obliterate_stack_to(pTHX_ I32 ix)1830 Perl_rpp_obliterate_stack_to(pTHX_ I32 ix)
1831 {
1832 #ifdef PERL_RC_STACK
1833 I32 nonrc_base = PL_curstackinfo->si_stack_nonrc_base;
1834 assert(ix >= 0);
1835 assert(ix <= PL_stack_sp - PL_stack_base);
1836 assert(nonrc_base <= PL_stack_sp - PL_stack_base + 1);
1837
1838 if (nonrc_base && nonrc_base > ix) {
1839 /* abandon any non-refcounted stuff */
1840 PL_stack_sp = PL_stack_base + nonrc_base - 1;
1841 /* and mark the stack as fully refcounted again */
1842 PL_curstackinfo->si_stack_nonrc_base = 0;
1843 }
1844
1845 if (rpp_stack_is_rc())
1846 rpp_popfree_to(PL_stack_base + ix);
1847 else
1848 PL_stack_sp = PL_stack_base + ix;
1849 #else
1850 PL_stack_sp = PL_stack_base + ix;
1851 #endif
1852
1853 }
1854
1855
1856 void
Perl_qerror(pTHX_ SV * err)1857 Perl_qerror(pTHX_ SV *err)
1858 {
1859 PERL_ARGS_ASSERT_QERROR;
1860 if (err!=NULL) {
1861 if (PL_in_eval) {
1862 if (PL_in_eval & EVAL_KEEPERR) {
1863 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
1864 SVfARG(err));
1865 }
1866 else {
1867 sv_catsv(ERRSV, err);
1868 }
1869 }
1870 else if (PL_errors)
1871 sv_catsv(PL_errors, err);
1872 else
1873 Perl_warn(aTHX_ "%" SVf, SVfARG(err));
1874
1875 if (PL_parser) {
1876 ++PL_parser->error_count;
1877 }
1878 }
1879
1880 if ( PL_parser && (err == NULL ||
1881 PL_parser->error_count >= PERL_STOP_PARSING_AFTER_N_ERRORS)
1882 ) {
1883 const char * const name = OutCopFILE(PL_curcop);
1884 SV * errsv = NULL;
1885 U8 raw_error_count = PERL_PARSE_ERROR_COUNT(PL_parser->error_count);
1886
1887 if (PL_in_eval) {
1888 errsv = ERRSV;
1889 }
1890
1891 if (err == NULL) {
1892 abort_execution(errsv, name);
1893 }
1894 else
1895 if (raw_error_count >= PERL_STOP_PARSING_AFTER_N_ERRORS) {
1896 if (errsv) {
1897 Perl_croak(aTHX_ "%" SVf "%s has too many errors.\n",
1898 SVfARG(errsv), name);
1899 } else {
1900 Perl_croak(aTHX_ "%s has too many errors.\n", name);
1901 }
1902 }
1903 }
1904 }
1905
1906
1907 /* pop a CXt_EVAL context and in addition, if it was a require then
1908 * based on action:
1909 * 0: do nothing extra;
1910 * 1: undef $INC{$name}; croak "$name did not return a true value";
1911 * 2: delete $INC{$name}; croak "$errsv: Compilation failed in require"
1912 */
1913
1914 static void
S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT * cx,SV * errsv,int action)1915 S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
1916 {
1917 SV *namesv = NULL; /* init to avoid dumb compiler warning */
1918 bool do_croak;
1919
1920 CX_LEAVE_SCOPE(cx);
1921 do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE);
1922 if (do_croak) {
1923 /* keep namesv alive after cx_popeval() */
1924 namesv = cx->blk_eval.old_namesv;
1925 cx->blk_eval.old_namesv = NULL;
1926 sv_2mortal(namesv);
1927 }
1928 cx_popeval(cx);
1929 cx_popblock(cx);
1930 CX_POP(cx);
1931
1932 if (do_croak) {
1933 const char *fmt;
1934 HV *inc_hv = GvHVn(PL_incgv);
1935
1936 if (action == 1) {
1937 (void)hv_delete_ent(inc_hv, namesv, G_DISCARD, 0);
1938 fmt = "%" SVf " did not return a true value";
1939 errsv = namesv;
1940 }
1941 else {
1942 (void)hv_store_ent(inc_hv, namesv, &PL_sv_undef, 0);
1943 fmt = "%" SVf "Compilation failed in require";
1944 if (!errsv)
1945 errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
1946 }
1947
1948 Perl_croak(aTHX_ fmt, SVfARG(errsv));
1949 }
1950 }
1951
1952
1953 /* die_unwind(): this is the final destination for the various croak()
1954 * functions. If we're in an eval, unwind the context and other stacks
1955 * back to the top-most CXt_EVAL and set $@ to msv; otherwise print msv
1956 * to STDERR and initiate an exit. Note that if the CXt_EVAL popped back
1957 * to is a require the exception will be rethrown, as requires don't
1958 * actually trap exceptions.
1959 */
1960
1961 void
Perl_die_unwind(pTHX_ SV * msv)1962 Perl_die_unwind(pTHX_ SV *msv)
1963 {
1964 SV *exceptsv = msv;
1965 U8 in_eval = PL_in_eval;
1966 PERL_ARGS_ASSERT_DIE_UNWIND;
1967
1968 if (in_eval) {
1969 I32 cxix;
1970
1971 /* We need to keep this SV alive through all the stack unwinding
1972 * and FREETMPSing below, while ensuing that it doesn't leak
1973 * if we call out to something which then dies (e.g. sub STORE{die}
1974 * when unlocalising a tied var). So we do a dance with
1975 * mortalising and SAVEFREEing.
1976 */
1977 if (PL_phase == PERL_PHASE_DESTRUCT) {
1978 exceptsv = sv_mortalcopy(exceptsv);
1979 } else {
1980 exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
1981 }
1982
1983 /*
1984 * Historically, perl used to set ERRSV ($@) early in the die
1985 * process and rely on it not getting clobbered during unwinding.
1986 * That sucked, because it was liable to get clobbered, so the
1987 * setting of ERRSV used to emit the exception from eval{} has
1988 * been moved to much later, after unwinding (see just before
1989 * JMPENV_JUMP below). However, some modules were relying on the
1990 * early setting, by examining $@ during unwinding to use it as
1991 * a flag indicating whether the current unwinding was caused by
1992 * an exception. It was never a reliable flag for that purpose,
1993 * being totally open to false positives even without actual
1994 * clobberage, but was useful enough for production code to
1995 * semantically rely on it.
1996 *
1997 * We'd like to have a proper introspective interface that
1998 * explicitly describes the reason for whatever unwinding
1999 * operations are currently in progress, so that those modules
2000 * work reliably and $@ isn't further overloaded. But we don't
2001 * have one yet. In its absence, as a stopgap measure, ERRSV is
2002 * now *additionally* set here, before unwinding, to serve as the
2003 * (unreliable) flag that it used to.
2004 *
2005 * This behaviour is temporary, and should be removed when a
2006 * proper way to detect exceptional unwinding has been developed.
2007 * As of 2010-12, the authors of modules relying on the hack
2008 * are aware of the issue, because the modules failed on
2009 * perls 5.13.{1..7} which had late setting of $@ without this
2010 * early-setting hack.
2011 */
2012 if (!(in_eval & EVAL_KEEPERR)) {
2013 /* remove any read-only/magic from the SV, so we don't
2014 get infinite recursion when setting ERRSV */
2015 SANE_ERRSV();
2016 sv_setsv_flags(ERRSV, exceptsv,
2017 (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
2018 }
2019
2020 if (in_eval & EVAL_KEEPERR) {
2021 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf,
2022 SVfARG(exceptsv));
2023 }
2024
2025 while ((cxix = dopoptoeval(cxstack_ix)) < 0
2026 && PL_curstackinfo->si_prev)
2027 {
2028 dounwind(-1);
2029 rpp_obliterate_stack_to(0);
2030 POPSTACK;
2031 }
2032
2033 if (cxix >= 0) {
2034 PERL_CONTEXT *cx;
2035 U8 gimme;
2036 JMPENV *restartjmpenv;
2037 OP *restartop;
2038
2039 if (cxix < cxstack_ix)
2040 dounwind(cxix);
2041
2042 cx = CX_CUR();
2043 assert(CxTYPE(cx) == CXt_EVAL);
2044
2045 rpp_obliterate_stack_to(cx->blk_oldsp);
2046
2047 /* return false to the caller of eval */
2048 gimme = cx->blk_gimme;
2049 if (gimme == G_SCALAR)
2050 rpp_xpush_IMM(&PL_sv_undef);
2051
2052 restartjmpenv = cx->blk_eval.cur_top_env;
2053 restartop = cx->blk_eval.retop;
2054
2055 /* We need a FREETMPS here to avoid late-called destructors
2056 * clobbering $@ *after* we set it below, e.g.
2057 * sub DESTROY { eval { die "X" } }
2058 * eval { my $x = bless []; die $x = 0, "Y" };
2059 * is($@, "Y")
2060 * Here the clearing of the $x ref mortalises the anon array,
2061 * which needs to be freed *before* $& is set to "Y",
2062 * otherwise it gets overwritten with "X".
2063 *
2064 * However, the FREETMPS will clobber exceptsv, so preserve it
2065 * on the savestack for now.
2066 */
2067 SAVEFREESV(SvREFCNT_inc_simple_NN(exceptsv));
2068 FREETMPS;
2069 /* now we're about to pop the savestack, so re-mortalise it */
2070 sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
2071
2072 /* Note that unlike pp_entereval, pp_require isn't supposed to
2073 * trap errors. So if we're a require, after we pop the
2074 * CXt_EVAL that pp_require pushed, rethrow the error with
2075 * croak(exceptsv). This is all handled by the call below when
2076 * action == 2.
2077 */
2078 S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
2079
2080 if (!(in_eval & EVAL_KEEPERR)) {
2081 SANE_ERRSV();
2082 sv_setsv(ERRSV, exceptsv);
2083 }
2084 PL_restartjmpenv = restartjmpenv;
2085 PL_restartop = restartop;
2086 JMPENV_JUMP(3);
2087 NOT_REACHED; /* NOTREACHED */
2088 }
2089 }
2090
2091 write_to_stderr(exceptsv);
2092 my_failure_exit();
2093 NOT_REACHED; /* NOTREACHED */
2094 }
2095
2096
PP(pp_xor)2097 PP(pp_xor)
2098 {
2099 SV *left = PL_stack_sp[0];
2100 SV *right = PL_stack_sp[-1];
2101 rpp_replace_2_IMM_NN(SvTRUE_NN(left) != SvTRUE_NN(right)
2102 ? &PL_sv_yes
2103 : &PL_sv_no);
2104 return NORMAL;
2105 }
2106
2107
2108 /*
2109
2110 =for apidoc_section $CV
2111
2112 =for apidoc caller_cx
2113
2114 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
2115 returned C<PERL_CONTEXT> structure can be interrogated to find all the
2116 information returned to Perl by C<caller>. Note that XSUBs don't get a
2117 stack frame, so C<caller_cx(0, NULL)> will return information for the
2118 immediately-surrounding Perl code.
2119
2120 This function skips over the automatic calls to C<&DB::sub> made on the
2121 behalf of the debugger. If the stack frame requested was a sub called by
2122 C<DB::sub>, the return value will be the frame for the call to
2123 C<DB::sub>, since that has the correct line number/etc. for the call
2124 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
2125 frame for the sub call itself.
2126
2127 =cut
2128 */
2129
2130 const PERL_CONTEXT *
Perl_caller_cx(pTHX_ I32 count,const PERL_CONTEXT ** dbcxp)2131 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
2132 {
2133 I32 cxix = dopopto_cursub();
2134 const PERL_CONTEXT *cx;
2135 const PERL_CONTEXT *ccstack = cxstack;
2136 const PERL_SI *top_si = PL_curstackinfo;
2137
2138 for (;;) {
2139 /* we may be in a higher stacklevel, so dig down deeper */
2140 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
2141 top_si = top_si->si_prev;
2142 ccstack = top_si->si_cxstack;
2143 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
2144 }
2145 if (cxix < 0)
2146 return NULL;
2147 /* caller() should not report the automatic calls to &DB::sub */
2148 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
2149 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
2150 count++;
2151 if (!count--)
2152 break;
2153 cxix = dopoptosub_at(ccstack, cxix - 1);
2154 }
2155
2156 cx = &ccstack[cxix];
2157 if (dbcxp) *dbcxp = cx;
2158
2159 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2160 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
2161 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
2162 field below is defined for any cx. */
2163 /* caller() should not report the automatic calls to &DB::sub */
2164 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2165 cx = &ccstack[dbcxix];
2166 }
2167
2168 return cx;
2169 }
2170
2171 PP_wrapped(pp_caller, MAXARG, 0)
2172 {
2173 dSP;
2174 const PERL_CONTEXT *cx;
2175 const PERL_CONTEXT *dbcx;
2176 U8 gimme = GIMME_V;
2177 const HEK *stash_hek;
2178 I32 count = 0;
2179 bool has_arg = MAXARG && TOPs;
2180 const COP *lcop;
2181
2182 if (MAXARG) {
2183 if (has_arg)
2184 count = POPi;
2185 else (void)POPs;
2186 }
2187
2188 cx = caller_cx(count + cBOOL(PL_op->op_private & OPpOFFBYONE), &dbcx);
2189 if (!cx) {
2190 if (gimme != G_LIST) {
2191 EXTEND(SP, 1);
2192 RETPUSHUNDEF;
2193 }
2194 RETURN;
2195 }
2196
2197 /* populate @DB::args ? */
2198 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
2199 && CopSTASH_eq(PL_curcop, PL_debstash))
2200 {
2201 /* slot 0 of the pad contains the original @_ */
2202 AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
2203 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2204 cx->blk_sub.olddepth+1]))[0]);
2205 const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
2206
2207 Perl_init_dbargs(aTHX);
2208
2209 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
2210 av_extend(PL_dbargs, AvFILLp(ary) + off);
2211
2212 /* Alias elements of @_ to @DB::args */
2213 for (SSize_t i = AvFILLp(ary) + off; i >= 0; i--) {
2214 SV* sv = AvALLOC(ary)[i];
2215 /* for a shifted @_, the elements between AvALLOC and AvARRAY
2216 * point to old SVs which may have been freed or even
2217 * reallocated in the meantime. In the interests of
2218 * reconstructing the original @_ before any shifting, use
2219 * those old values, even at the risk of them being wrong.
2220 * But if the ref count is 0, then don't use it because
2221 * further assigning that value anywhere will panic.
2222 * Of course there's nothing to stop a RC != 0 SV being
2223 * subsequently freed, but hopefully people quickly copy the
2224 * contents of @DB::args before doing anything else.
2225 */
2226 if (sv && (SvREFCNT(sv) == 0 || SvIS_FREED(sv)))
2227 sv = NULL;
2228 AvARRAY(PL_dbargs)[i] = sv;
2229 }
2230 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
2231 }
2232
2233 CX_DEBUG(cx, "CALLER");
2234 assert(CopSTASH(cx->blk_oldcop));
2235 stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
2236 ? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
2237 : NULL;
2238 if (gimme != G_LIST) {
2239 EXTEND(SP, 1);
2240 if (!stash_hek)
2241 PUSHs(&PL_sv_undef);
2242 else {
2243 dTARGET;
2244 sv_sethek(TARG, stash_hek);
2245 PUSHs(TARG);
2246 }
2247 RETURN;
2248 }
2249
2250 EXTEND(SP, 11);
2251
2252 if (!stash_hek)
2253 PUSHs(&PL_sv_undef);
2254 else {
2255 dTARGET;
2256 sv_sethek(TARG, stash_hek);
2257 PUSHTARG;
2258 }
2259 mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
2260 lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
2261 cx->blk_sub.retop, TRUE);
2262 if (!lcop)
2263 lcop = cx->blk_oldcop;
2264 mPUSHu(CopLINE(lcop));
2265 if (!has_arg)
2266 RETURN;
2267 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2268 /* So is ccstack[dbcxix]. */
2269 if (CvHASGV(dbcx->blk_sub.cv)) {
2270 PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
2271 PUSHs(boolSV(CxHASARGS(cx)));
2272 }
2273 else {
2274 PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
2275 PUSHs(boolSV(CxHASARGS(cx)));
2276 }
2277 }
2278 else {
2279 PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
2280 PUSHs(&PL_sv_zero);
2281 }
2282 gimme = cx->blk_gimme;
2283 if (gimme == G_VOID)
2284 PUSHs(&PL_sv_undef);
2285 else
2286 PUSHs(boolSV((gimme & G_WANT) == G_LIST));
2287 if (CxTYPE(cx) == CXt_EVAL) {
2288 /* eval STRING */
2289 if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
2290 SV *cur_text = cx->blk_eval.cur_text;
2291 if (SvCUR(cur_text) >= 2) {
2292 PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
2293 SvUTF8(cur_text)|SVs_TEMP));
2294 }
2295 else {
2296 /* I think this is will always be "", but be sure */
2297 PUSHs(sv_2mortal(newSVsv(cur_text)));
2298 }
2299
2300 PUSHs(&PL_sv_no);
2301 }
2302 /* require */
2303 else if (cx->blk_eval.old_namesv) {
2304 mPUSHs(newSVsv(cx->blk_eval.old_namesv));
2305 PUSHs(&PL_sv_yes);
2306 }
2307 /* eval BLOCK (try blocks have old_namesv == 0) */
2308 else {
2309 PUSHs(&PL_sv_undef);
2310 PUSHs(&PL_sv_undef);
2311 }
2312 }
2313 else {
2314 PUSHs(&PL_sv_undef);
2315 PUSHs(&PL_sv_undef);
2316 }
2317
2318 mPUSHi(CopHINTS_get(cx->blk_oldcop));
2319 {
2320 SV * mask ;
2321 char *old_warnings = cx->blk_oldcop->cop_warnings;
2322
2323 if (old_warnings == pWARN_NONE)
2324 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
2325 else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)
2326 mask = &PL_sv_undef ;
2327 else if (old_warnings == pWARN_ALL ||
2328 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
2329 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
2330 }
2331 else
2332 mask = newSVpvn(old_warnings, RCPV_LEN(old_warnings));
2333 mPUSHs(mask);
2334 }
2335
2336 PUSHs(cx->blk_oldcop->cop_hints_hash ?
2337 sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
2338 : &PL_sv_undef);
2339 RETURN;
2340 }
2341
2342
2343 PP_wrapped(pp_reset, MAXARG, 0)
2344 {
2345 dSP;
2346 const char * tmps;
2347 STRLEN len = 0;
2348 if (MAXARG < 1 || (!TOPs && !POPs)) {
2349 EXTEND(SP, 1);
2350 tmps = NULL, len = 0;
2351 }
2352 else
2353 tmps = SvPVx_const(POPs, len);
2354 sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
2355 PUSHs(&PL_sv_yes);
2356 RETURN;
2357 }
2358
2359 /* like pp_nextstate, but used instead when the debugger is active */
2360
PP(pp_dbstate)2361 PP(pp_dbstate)
2362 {
2363 PL_curcop = (COP*)PL_op;
2364 TAINT_NOT; /* Each statement is presumed innocent */
2365 rpp_popfree_to_NN(PL_stack_base + CX_CUR()->blk_oldsp);
2366 FREETMPS;
2367
2368 PERL_ASYNC_CHECK();
2369
2370 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
2371 || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
2372 {
2373 PERL_CONTEXT *cx;
2374 const U8 gimme = G_LIST;
2375 GV * const gv = PL_DBgv;
2376 CV * cv = NULL;
2377
2378 if (gv && isGV_with_GP(gv))
2379 cv = GvCV(gv);
2380
2381 if (!cv || (!CvROOT(cv) && !CvXSUB(cv)))
2382 DIE(aTHX_ "No DB::DB routine defined");
2383
2384 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
2385 /* don't do recursive DB::DB call */
2386 return NORMAL;
2387
2388 if (CvISXSUB(cv)) {
2389 ENTER;
2390 SAVEI32(PL_debug);
2391 PL_debug = 0;
2392 /* I suspect that saving the stack position is no longer
2393 * required. It was added in 5.001 by:
2394 *
2395 * NETaa13155: &DB::DB left trash on the stack.
2396 * From: Thomas Koenig
2397 * Files patched: lib/perl5db.pl pp_ctl.c
2398 * The call by pp_dbstate() to &DB::DB left trash on the
2399 * stack. It now calls DB in list context, and DB returns
2400 * ().
2401 *
2402 * but the details of what bug it fixed are long lost to
2403 * history. SAVESTACK_POS() doesn't work well with stacks
2404 * which may be split into partly reference-counted and partly
2405 * not halves, so skip it and hope it doesn't cause any
2406 * problems.
2407 */
2408 #ifndef PERL_RC_STACK
2409 SAVESTACK_POS();
2410 #endif
2411 SAVETMPS;
2412 PUSHMARK(PL_stack_sp);
2413 rpp_invoke_xs(cv);
2414 FREETMPS;
2415 LEAVE;
2416 return NORMAL;
2417 }
2418 else {
2419 #ifdef PERL_RC_STACK
2420 assert(!PL_curstackinfo->si_stack_nonrc_base);
2421 #endif
2422 cx = cx_pushblock(CXt_SUB, gimme, PL_stack_sp, PL_savestack_ix);
2423 cx_pushsub(cx, cv, PL_op->op_next, 0);
2424 /* OP_DBSTATE's op_private holds hint bits rather than
2425 * the lvalue-ish flags seen in OP_ENTERSUB. So cancel
2426 * any CxLVAL() flags that have now been mis-calculated */
2427 cx->blk_u16 = 0;
2428
2429 SAVEI32(PL_debug);
2430 PL_debug = 0;
2431 /* see comment above about SAVESTACK_POS */
2432 #ifndef PERL_RC_STACK
2433 SAVESTACK_POS();
2434 #endif
2435 CvDEPTH(cv)++;
2436 if (CvDEPTH(cv) >= 2)
2437 pad_push(CvPADLIST(cv), CvDEPTH(cv));
2438 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
2439 return CvSTART(cv);
2440 }
2441 }
2442 else
2443 return NORMAL;
2444 }
2445
2446
PP(pp_enter)2447 PP(pp_enter)
2448 {
2449 U8 gimme = GIMME_V;
2450
2451 (void)cx_pushblock(CXt_BLOCK, gimme, PL_stack_sp, PL_savestack_ix);
2452 return NORMAL;
2453 }
2454
2455
PP(pp_leave)2456 PP(pp_leave)
2457 {
2458 PERL_CONTEXT *cx;
2459 SV **oldsp;
2460 U8 gimme;
2461
2462 cx = CX_CUR();
2463 assert(CxTYPE(cx) == CXt_BLOCK);
2464
2465 if (PL_op->op_flags & OPf_SPECIAL)
2466 /* fake block should preserve $1 et al; e.g. /(...)/ while ...; */
2467 cx->blk_oldpm = PL_curpm;
2468
2469 oldsp = PL_stack_base + cx->blk_oldsp;
2470 gimme = cx->blk_gimme;
2471
2472 if (gimme == G_VOID)
2473 rpp_popfree_to_NN(oldsp);
2474 else
2475 leave_adjust_stacks(oldsp, oldsp, gimme,
2476 PL_op->op_private & OPpLVALUE ? 3 : 1);
2477
2478 CX_LEAVE_SCOPE(cx);
2479 cx_popblock(cx);
2480 CX_POP(cx);
2481
2482 return NORMAL;
2483 }
2484
2485 static bool
S_outside_integer(pTHX_ SV * sv)2486 S_outside_integer(pTHX_ SV *sv)
2487 {
2488 if (SvOK(sv)) {
2489 const NV nv = SvNV_nomg(sv);
2490 if (Perl_isinfnan(nv))
2491 return TRUE;
2492 #ifdef NV_PRESERVES_UV
2493 if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
2494 return TRUE;
2495 #else
2496 if (nv <= (NV)IV_MIN)
2497 return TRUE;
2498 if ((nv > 0) &&
2499 ((nv > (NV)UV_MAX ||
2500 SvUV_nomg(sv) > (UV)IV_MAX)))
2501 return TRUE;
2502 #endif
2503 }
2504 return FALSE;
2505 }
2506
PP(pp_enteriter)2507 PP(pp_enteriter)
2508 {
2509 dMARK;
2510 PERL_CONTEXT *cx;
2511 const U8 gimme = GIMME_V;
2512 void *itervarp; /* GV or pad slot of the iteration variable */
2513 SV *itersave; /* the old var in the iterator var slot */
2514 U8 cxflags = 0;
2515
2516 if (PL_op->op_targ) { /* "my" variable */
2517 itervarp = &PAD_SVl(PL_op->op_targ);
2518 itersave = *(SV**)itervarp;
2519 assert(itersave);
2520 if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
2521 /* the SV currently in the pad slot is never live during
2522 * iteration (the slot is always aliased to one of the items)
2523 * so it's always stale */
2524 SvPADSTALE_on(itersave);
2525 }
2526 SvREFCNT_inc_simple_void_NN(itersave);
2527 cxflags = CXp_FOR_PAD;
2528 }
2529 else {
2530 SV * const sv = *PL_stack_sp;
2531 itervarp = (void *)sv;
2532 if (LIKELY(isGV(sv))) { /* symbol table variable */
2533 itersave = GvSV(sv);
2534 SvREFCNT_inc_simple_void(itersave);
2535 cxflags = CXp_FOR_GV;
2536 if (PL_op->op_private & OPpITER_DEF)
2537 cxflags |= CXp_FOR_DEF;
2538 }
2539 else { /* LV ref: for \$foo (...) */
2540 assert(SvTYPE(sv) == SVt_PVMG);
2541 assert(SvMAGIC(sv));
2542 assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
2543 itersave = NULL;
2544 cxflags = CXp_FOR_LVREF;
2545 }
2546 /* we transfer ownership of 1 ref count of itervarp from the stack
2547 * to the CX entry, so no SvREFCNT_dec() needed */
2548 (void)rpp_pop_1_norc();
2549 }
2550 /* OPpITER_DEF (implicit $_) should only occur with a GV iter var */
2551 assert((cxflags & CXp_FOR_GV) || !(PL_op->op_private & OPpITER_DEF));
2552
2553 /* Note that this context is initially set as CXt_NULL. Further on
2554 * down it's changed to one of the CXt_LOOP_*. Before it's changed,
2555 * there mustn't be anything in the blk_loop substruct that requires
2556 * freeing or undoing, in case we die in the meantime. And vice-versa.
2557 */
2558 cx = cx_pushblock(cxflags, gimme, MARK, PL_savestack_ix);
2559 cx_pushloop_for(cx, itervarp, itersave);
2560
2561 if (PL_op->op_flags & OPf_STACKED) {
2562 /* OPf_STACKED implies either a single array: for(@), with a
2563 * single AV on the stack, or a range: for (1..5), with 1 and 5 on
2564 * the stack */
2565 SV *maybe_ary = *PL_stack_sp;
2566 if (SvTYPE(maybe_ary) != SVt_PVAV) {
2567 /* range */
2568 SV* sv = PL_stack_sp[-1];
2569 SV * const right = maybe_ary;
2570 if (UNLIKELY(cxflags & CXp_FOR_LVREF))
2571 DIE(aTHX_ "Assigned value is not a reference");
2572 SvGETMAGIC(sv);
2573 SvGETMAGIC(right);
2574 if (RANGE_IS_NUMERIC(sv,right)) {
2575 cx->cx_type |= CXt_LOOP_LAZYIV;
2576 if (S_outside_integer(aTHX_ sv) ||
2577 S_outside_integer(aTHX_ right))
2578 DIE(aTHX_ "Range iterator outside integer range");
2579 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2580 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2581 rpp_popfree_2_NN();
2582 }
2583 else {
2584 cx->cx_type |= CXt_LOOP_LAZYSV;
2585 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2586 cx->blk_loop.state_u.lazysv.end = right;
2587
2588 /* we transfer ownership of 1 ref count of right from the
2589 * stack to the CX .end entry, so no SvREFCNT_dec() needed */
2590 (void)rpp_pop_1_norc();
2591
2592 rpp_popfree_1_NN(); /* free the (now copied) start SV */
2593 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2594 /* This will do the upgrade to SVt_PV, and warn if the value
2595 is uninitialised. */
2596 (void) SvPV_nolen_const(right);
2597 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2598 to replace !SvOK() with a pointer to "". */
2599 if (!SvOK(right)) {
2600 SvREFCNT_dec(right);
2601 cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2602 }
2603 }
2604 }
2605 else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2606 /* for (@array) {} */
2607 cx->cx_type |= CXt_LOOP_ARY;
2608 cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2609 /* we transfer ownership of 1 ref count of the av from the
2610 * stack to the CX .ary entry, so no SvREFCNT_dec() needed */
2611 (void)rpp_pop_1_norc();
2612 cx->blk_loop.state_u.ary.ix =
2613 (PL_op->op_private & OPpITER_REVERSED) ?
2614 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2615 -1;
2616 }
2617 /* rpp_extend(1) not needed in this branch
2618 * because we just popped 1 item */
2619 }
2620 else { /* iterating over items on the stack */
2621 cx->cx_type |= CXt_LOOP_LIST;
2622 cx->blk_oldsp = PL_stack_sp - PL_stack_base;
2623 cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base;
2624 cx->blk_loop.state_u.stack.ix =
2625 (PL_op->op_private & OPpITER_REVERSED)
2626 ? cx->blk_oldsp + 1
2627 : cx->blk_loop.state_u.stack.basesp;
2628 /* pre-extend stack so pp_iter doesn't have to check every time
2629 * it pushes yes/no */
2630 rpp_extend(1);
2631 }
2632
2633 return NORMAL;
2634 }
2635
PP(pp_enterloop)2636 PP(pp_enterloop)
2637 {
2638 PERL_CONTEXT *cx;
2639 const U8 gimme = GIMME_V;
2640
2641 cx = cx_pushblock(CXt_LOOP_PLAIN, gimme, PL_stack_sp, PL_savestack_ix);
2642 cx_pushloop_plain(cx);
2643 return NORMAL;
2644 }
2645
2646
PP(pp_leaveloop)2647 PP(pp_leaveloop)
2648 {
2649 PERL_CONTEXT *cx;
2650 U8 gimme;
2651 SV **base;
2652 SV **oldsp;
2653
2654 cx = CX_CUR();
2655 assert(CxTYPE_is_LOOP(cx));
2656 oldsp = PL_stack_base + cx->blk_oldsp;
2657 base = CxTYPE(cx) == CXt_LOOP_LIST
2658 ? PL_stack_base + cx->blk_loop.state_u.stack.basesp
2659 : oldsp;
2660 gimme = cx->blk_gimme;
2661
2662 if (gimme == G_VOID)
2663 rpp_popfree_to_NN(base);
2664 else
2665 leave_adjust_stacks(oldsp, base, gimme,
2666 PL_op->op_private & OPpLVALUE ? 3 : 1);
2667
2668 CX_LEAVE_SCOPE(cx);
2669 cx_poploop(cx); /* Stack values are safe: release loop vars ... */
2670 cx_popblock(cx);
2671 CX_POP(cx);
2672
2673 return NORMAL;
2674 }
2675
2676
2677 /* This duplicates most of pp_leavesub, but with additional code to handle
2678 * return args in lvalue context. It was forked from pp_leavesub to
2679 * avoid slowing down that function any further.
2680 *
2681 * Any changes made to this function may need to be copied to pp_leavesub
2682 * and vice-versa.
2683 *
2684 * also tail-called by pp_return
2685 */
2686
PP(pp_leavesublv)2687 PP(pp_leavesublv)
2688 {
2689 U8 gimme;
2690 PERL_CONTEXT *cx;
2691 SV **oldsp;
2692 OP *retop;
2693
2694 cx = CX_CUR();
2695 assert(CxTYPE(cx) == CXt_SUB);
2696
2697 if (CxMULTICALL(cx)) {
2698 /* entry zero of a stack is always PL_sv_undef, which
2699 * simplifies converting a '()' return into undef in scalar context */
2700 assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
2701 return 0;
2702 }
2703
2704 gimme = cx->blk_gimme;
2705 oldsp = PL_stack_base + cx->blk_oldsp; /* last arg of previous frame */
2706
2707 if (gimme == G_VOID)
2708 rpp_popfree_to_NN(oldsp);
2709 else {
2710 U8 lval = CxLVAL(cx);
2711 bool is_lval = (lval && !(lval & OPpENTERSUB_INARGS));
2712 const char *what = NULL;
2713
2714 if (gimme == G_SCALAR) {
2715 if (is_lval) {
2716 /* check for bad return arg */
2717 if (oldsp < PL_stack_sp) {
2718 SV *sv = *PL_stack_sp;
2719 if ((SvPADTMP(sv) || SvREADONLY(sv))) {
2720 what =
2721 SvREADONLY(sv) ? (sv == &PL_sv_undef) ? "undef"
2722 : "a readonly value" : "a temporary";
2723 }
2724 else goto ok;
2725 }
2726 else {
2727 /* sub:lvalue{} will take us here. */
2728 what = "undef";
2729 }
2730 croak:
2731 Perl_croak(aTHX_
2732 "Can't return %s from lvalue subroutine", what);
2733 }
2734
2735 ok:
2736 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2737
2738 if (lval & OPpDEREF) {
2739 /* lval_sub()->{...} and similar */
2740 SvGETMAGIC(*PL_stack_sp);
2741 if (!SvOK(*PL_stack_sp)) {
2742 SV *sv = vivify_ref(*PL_stack_sp, CxLVAL(cx) & OPpDEREF);
2743 rpp_replace_1_1_NN(sv);
2744 }
2745 }
2746 }
2747 else {
2748 assert(gimme == G_LIST);
2749 assert (!(lval & OPpDEREF));
2750
2751 if (is_lval) {
2752 /* scan for bad return args */
2753 SV **p;
2754 for (p = PL_stack_sp; p > oldsp; p--) {
2755 SV *sv = *p;
2756 /* the PL_sv_undef exception is to allow things like
2757 * this to work, where PL_sv_undef acts as 'skip'
2758 * placeholder on the LHS of list assigns:
2759 * sub foo :lvalue { undef }
2760 * ($a, undef, foo(), $b) = 1..4;
2761 */
2762 if (sv != &PL_sv_undef && (SvPADTMP(sv) || SvREADONLY(sv)))
2763 {
2764 /* Might be flattened array after $#array = */
2765 what = SvREADONLY(sv)
2766 ? "a readonly value" : "a temporary";
2767 goto croak;
2768 }
2769 }
2770 }
2771
2772 leave_adjust_stacks(oldsp, oldsp, gimme, is_lval ? 3 : 2);
2773 }
2774 }
2775
2776 CX_LEAVE_SCOPE(cx);
2777 cx_popsub(cx); /* Stack values are safe: release CV and @_ ... */
2778 cx_popblock(cx);
2779 retop = cx->blk_sub.retop;
2780 CX_POP(cx);
2781
2782 return retop;
2783 }
2784
S_defer_blockname(PERL_CONTEXT * cx)2785 static const char *S_defer_blockname(PERL_CONTEXT *cx)
2786 {
2787 return (cx->cx_type & CXp_FINALLY) ? "finally" : "defer";
2788 }
2789
2790
PP(pp_return)2791 PP(pp_return)
2792 {
2793 dMARK;
2794 PERL_CONTEXT *cx;
2795 I32 cxix = dopopto_cursub();
2796
2797 assert(cxstack_ix >= 0);
2798 if (cxix < cxstack_ix) {
2799 I32 i;
2800 /* Check for defer { return; } */
2801 for(i = cxstack_ix; i > cxix; i--) {
2802 if(CxTYPE(&cxstack[i]) == CXt_DEFER)
2803 /* diag_listed_as: Can't "%s" out of a "defer" block */
2804 /* diag_listed_as: Can't "%s" out of a "finally" block */
2805 Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block",
2806 "return", S_defer_blockname(&cxstack[i]));
2807 }
2808 if (cxix < 0) {
2809 if (!( PL_curstackinfo->si_type == PERLSI_SORT
2810 || ( PL_curstackinfo->si_type == PERLSI_MULTICALL
2811 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE))
2812 )
2813 )
2814 DIE(aTHX_ "Can't return outside a subroutine");
2815 /* We must be in:
2816 * a sort block, which is a CXt_NULL not a CXt_SUB;
2817 * or a /(?{...})/ block.
2818 * Handle specially. */
2819 assert(CxTYPE(&cxstack[0]) == CXt_NULL
2820 || ( CxTYPE(&cxstack[0]) == CXt_SUB
2821 && (cxstack[0].cx_type & CXp_SUB_RE_FAKE)));
2822 if (cxstack_ix > 0) {
2823 /* See comment below about context popping. Since we know
2824 * we're scalar and not lvalue, we can preserve the return
2825 * value in a simpler fashion than there. */
2826 SV *sv = *PL_stack_sp;
2827 assert(cxstack[0].blk_gimme == G_SCALAR);
2828 if ( (PL_stack_sp != PL_stack_base)
2829 && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
2830 )
2831 #ifdef PERL_RC_STACK
2832 rpp_replace_at_norc(PL_stack_sp, newSVsv(sv));
2833 #else
2834 *PL_stack_sp = sv_mortalcopy(sv);
2835 #endif
2836 dounwind(0);
2837 }
2838 /* caller responsible for popping cxstack[0] */
2839 return 0;
2840 }
2841
2842 /* There are contexts that need popping. Doing this may free the
2843 * return value(s), so preserve them first: e.g. popping the plain
2844 * loop here would free $x:
2845 * sub f { { my $x = 1; return $x } }
2846 * We may also need to shift the args down; for example,
2847 * for (1,2) { return 3,4 }
2848 * leaves 1,2,3,4 on the stack. Both these actions will be done by
2849 * leave_adjust_stacks(), along with freeing any temps. Note that
2850 * whoever we tail-call (e.g. pp_leaveeval) will also call
2851 * leave_adjust_stacks(); however, the second call is likely to
2852 * just see a bunch of SvTEMPs with a ref count of 1, and so just
2853 * pass them through, rather than copying them again. So this
2854 * isn't as inefficient as it sounds.
2855 */
2856 cx = &cxstack[cxix];
2857 if (cx->blk_gimme != G_VOID)
2858 leave_adjust_stacks(MARK, PL_stack_base + cx->blk_oldsp,
2859 cx->blk_gimme,
2860 CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv)
2861 ? 3 : 0);
2862 dounwind(cxix);
2863 cx = &cxstack[cxix]; /* CX stack may have been realloced */
2864 }
2865 else {
2866 /* Like in the branch above, we need to handle any extra junk on
2867 * the stack. But because we're not also popping extra contexts, we
2868 * don't have to worry about prematurely freeing args. So we just
2869 * need to do the bare minimum to handle junk, and leave the main
2870 * arg processing in the function we tail call, e.g. pp_leavesub.
2871 * In list context we have to splice out the junk; in scalar
2872 * context we can leave as-is (pp_leavesub will later return the
2873 * top stack element). But for an empty arg list, e.g.
2874 * for (1,2) { return }
2875 * we need to set PL_stack_sp = oldsp so that pp_leavesub knows to
2876 * push &PL_sv_undef onto the stack.
2877 */
2878 SV **oldsp;
2879 cx = &cxstack[cxix];
2880 oldsp = PL_stack_base + cx->blk_oldsp;
2881 if (oldsp != MARK) {
2882 SSize_t nargs = PL_stack_sp - MARK;
2883 if (nargs) {
2884 if (cx->blk_gimme == G_LIST) {
2885 /* shift return args to base of call stack frame */
2886 #ifdef PERL_RC_STACK
2887 /* free the items on the stack that will get
2888 * overwritten */
2889 SV **p;
2890 for (p = MARK; p > oldsp; p--) {
2891 SV *sv = *p;
2892 *p = NULL;
2893 SvREFCNT_dec(sv);
2894 }
2895 #endif
2896 Move(MARK + 1, oldsp + 1, nargs, SV*);
2897 PL_stack_sp = oldsp + nargs;
2898 }
2899 }
2900 else
2901 rpp_popfree_to_NN(oldsp);
2902 }
2903 }
2904
2905 /* fall through to a normal exit */
2906 switch (CxTYPE(cx)) {
2907 case CXt_EVAL:
2908 return CxEVALBLOCK(cx)
2909 ? Perl_pp_leavetry(aTHX)
2910 : Perl_pp_leaveeval(aTHX);
2911 case CXt_SUB:
2912 return CvLVALUE(cx->blk_sub.cv)
2913 ? Perl_pp_leavesublv(aTHX)
2914 : Perl_pp_leavesub(aTHX);
2915 case CXt_FORMAT:
2916 return Perl_pp_leavewrite(aTHX);
2917 default:
2918 DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2919 }
2920 }
2921
2922 /* find the enclosing loop or labelled loop and dounwind() back to it. */
2923
2924 static PERL_CONTEXT *
S_unwind_loop(pTHX)2925 S_unwind_loop(pTHX)
2926 {
2927 I32 cxix;
2928 if (PL_op->op_flags & OPf_SPECIAL) {
2929 cxix = dopoptoloop(cxstack_ix);
2930 if (cxix < 0)
2931 /* diag_listed_as: Can't "last" outside a loop block */
2932 Perl_croak(aTHX_ "Can't \"%s\" outside a loop block",
2933 OP_NAME(PL_op));
2934 }
2935 else {
2936 STRLEN label_len;
2937 const char * label;
2938 U32 label_flags;
2939 SV *sv;
2940
2941 if (PL_op->op_flags & OPf_STACKED) {
2942 sv = *PL_stack_sp;
2943 label = SvPV(sv, label_len);
2944 label_flags = SvUTF8(sv);
2945 }
2946 else {
2947 sv = NULL; /* not needed, but shuts up compiler warn */
2948 label = cPVOP->op_pv;
2949 label_len = strlen(label);
2950 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2951 }
2952
2953 cxix = dopoptolabel(label, label_len, label_flags);
2954 if (cxix < 0)
2955 /* diag_listed_as: Label not found for "last %s" */
2956 Perl_croak(aTHX_ "Label not found for \"%s %" SVf "\"",
2957 OP_NAME(PL_op),
2958 SVfARG(PL_op->op_flags & OPf_STACKED
2959 && !SvGMAGICAL(sv)
2960 ? sv
2961 : newSVpvn_flags(label,
2962 label_len,
2963 label_flags | SVs_TEMP)));
2964 if (PL_op->op_flags & OPf_STACKED)
2965 rpp_popfree_1_NN();
2966 }
2967
2968 if (cxix < cxstack_ix) {
2969 I32 i;
2970 /* Check for defer { last ... } etc */
2971 for(i = cxstack_ix; i > cxix; i--) {
2972 if(CxTYPE(&cxstack[i]) == CXt_DEFER)
2973 /* diag_listed_as: Can't "%s" out of a "defer" block */
2974 /* diag_listed_as: Can't "%s" out of a "finally" block */
2975 Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block",
2976 OP_NAME(PL_op), S_defer_blockname(&cxstack[i]));
2977 }
2978 dounwind(cxix);
2979 }
2980 return &cxstack[cxix];
2981 }
2982
2983
PP(pp_last)2984 PP(pp_last)
2985 {
2986 PERL_CONTEXT *cx;
2987 OP* nextop;
2988
2989 cx = S_unwind_loop(aTHX);
2990
2991 assert(CxTYPE_is_LOOP(cx));
2992 rpp_popfree_to_NN(PL_stack_base
2993 + (CxTYPE(cx) == CXt_LOOP_LIST
2994 ? cx->blk_loop.state_u.stack.basesp
2995 : cx->blk_oldsp
2996 ));
2997
2998 TAINT_NOT;
2999
3000 /* Stack values are safe: */
3001 CX_LEAVE_SCOPE(cx);
3002 cx_poploop(cx); /* release loop vars ... */
3003 cx_popblock(cx);
3004 nextop = cx->blk_loop.my_op->op_lastop->op_next;
3005 CX_POP(cx);
3006
3007 return nextop;
3008 }
3009
PP(pp_next)3010 PP(pp_next)
3011 {
3012 PERL_CONTEXT *cx;
3013
3014 /* if not a bare 'next' in the main scope, search for it */
3015 cx = CX_CUR();
3016 if (!((PL_op->op_flags & OPf_SPECIAL) && CxTYPE_is_LOOP(cx)))
3017 cx = S_unwind_loop(aTHX);
3018
3019 cx_topblock(cx);
3020 PL_curcop = cx->blk_oldcop;
3021 PERL_ASYNC_CHECK();
3022 return (cx)->blk_loop.my_op->op_nextop;
3023 }
3024
PP(pp_redo)3025 PP(pp_redo)
3026 {
3027 PERL_CONTEXT *cx = S_unwind_loop(aTHX);
3028 OP* redo_op = cx->blk_loop.my_op->op_redoop;
3029
3030 if (redo_op->op_type == OP_ENTER) {
3031 /* pop one less context to avoid $x being freed in while (my $x..) */
3032 cxstack_ix++;
3033 cx = CX_CUR();
3034 assert(CxTYPE(cx) == CXt_BLOCK);
3035 redo_op = redo_op->op_next;
3036 }
3037
3038 FREETMPS;
3039 CX_LEAVE_SCOPE(cx);
3040 cx_topblock(cx);
3041 PL_curcop = cx->blk_oldcop;
3042 PERL_ASYNC_CHECK();
3043 return redo_op;
3044 }
3045
3046 #define UNENTERABLE (OP *)1
3047 #define GOTO_DEPTH 64
3048
3049 STATIC OP *
S_dofindlabel(pTHX_ OP * o,const char * label,STRLEN len,U32 flags,OP ** opstack,OP ** oplimit)3050 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
3051 {
3052 OP **ops = opstack;
3053 static const char* const too_deep = "Target of goto is too deeply nested";
3054
3055 PERL_ARGS_ASSERT_DOFINDLABEL;
3056
3057 if (ops >= oplimit)
3058 Perl_croak(aTHX_ "%s", too_deep);
3059 if (o->op_type == OP_LEAVE ||
3060 o->op_type == OP_SCOPE ||
3061 o->op_type == OP_LEAVELOOP ||
3062 o->op_type == OP_LEAVESUB ||
3063 o->op_type == OP_LEAVETRY ||
3064 o->op_type == OP_LEAVEGIVEN)
3065 {
3066 *ops++ = cUNOPo->op_first;
3067 }
3068 else if (oplimit - opstack < GOTO_DEPTH) {
3069 if (o->op_flags & OPf_KIDS
3070 && cUNOPo->op_first->op_type == OP_PUSHMARK) {
3071 *ops++ = UNENTERABLE;
3072 }
3073 else if (o->op_flags & OPf_KIDS && PL_opargs[o->op_type]
3074 && OP_CLASS(o) != OA_LOGOP
3075 && o->op_type != OP_LINESEQ
3076 && o->op_type != OP_SREFGEN
3077 && o->op_type != OP_ENTEREVAL
3078 && o->op_type != OP_GLOB
3079 && o->op_type != OP_RV2CV) {
3080 OP * const kid = cUNOPo->op_first;
3081 if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid))
3082 *ops++ = UNENTERABLE;
3083 }
3084 }
3085 if (ops >= oplimit)
3086 Perl_croak(aTHX_ "%s", too_deep);
3087 *ops = 0;
3088 if (o->op_flags & OPf_KIDS) {
3089 OP *kid;
3090 OP * const kid1 = cUNOPo->op_first;
3091 /* First try all the kids at this level, since that's likeliest. */
3092 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3093 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3094 STRLEN kid_label_len;
3095 U32 kid_label_flags;
3096 const char *kid_label = CopLABEL_len_flags(kCOP,
3097 &kid_label_len, &kid_label_flags);
3098 if (kid_label && (
3099 ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
3100 (flags & SVf_UTF8)
3101 ? (bytes_cmp_utf8(
3102 (const U8*)kid_label, kid_label_len,
3103 (const U8*)label, len) == 0)
3104 : (bytes_cmp_utf8(
3105 (const U8*)label, len,
3106 (const U8*)kid_label, kid_label_len) == 0)
3107 : ( len == kid_label_len && ((kid_label == label)
3108 || memEQ(kid_label, label, len)))))
3109 return kid;
3110 }
3111 }
3112 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
3113 bool first_kid_of_binary = FALSE;
3114 if (kid == PL_lastgotoprobe)
3115 continue;
3116 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3117 if (ops == opstack)
3118 *ops++ = kid;
3119 else if (ops[-1] != UNENTERABLE
3120 && (ops[-1]->op_type == OP_NEXTSTATE ||
3121 ops[-1]->op_type == OP_DBSTATE))
3122 ops[-1] = kid;
3123 else
3124 *ops++ = kid;
3125 }
3126 if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) {
3127 first_kid_of_binary = TRUE;
3128 ops--;
3129 }
3130 if ((o = dofindlabel(kid, label, len, flags, ops, oplimit))) {
3131 if (kid->op_type == OP_PUSHDEFER)
3132 Perl_croak(aTHX_ "Can't \"goto\" into a \"defer\" block");
3133 return o;
3134 }
3135 if (first_kid_of_binary)
3136 *ops++ = UNENTERABLE;
3137 }
3138 }
3139 *ops = 0;
3140 return 0;
3141 }
3142
3143
3144 static void
S_check_op_type(pTHX_ OP * const o)3145 S_check_op_type(pTHX_ OP * const o)
3146 {
3147 /* Eventually we may want to stack the needed arguments
3148 * for each op. For now, we punt on the hard ones. */
3149 /* XXX This comment seems to me like wishful thinking. --sprout */
3150 if (o == UNENTERABLE)
3151 Perl_croak(aTHX_
3152 "Can't \"goto\" into a binary or list expression");
3153 if (o->op_type == OP_ENTERITER)
3154 Perl_croak(aTHX_
3155 "Can't \"goto\" into the middle of a foreach loop");
3156 if (o->op_type == OP_ENTERGIVEN)
3157 Perl_croak(aTHX_
3158 "Can't \"goto\" into a \"given\" block");
3159 }
3160
3161 /* also used for: pp_dump() */
3162
PP(pp_goto)3163 PP(pp_goto)
3164 {
3165 OP *retop = NULL;
3166 I32 ix;
3167 PERL_CONTEXT *cx;
3168 OP *enterops[GOTO_DEPTH];
3169 const char *label = NULL;
3170 STRLEN label_len = 0;
3171 U32 label_flags = 0;
3172 const bool do_dump = (PL_op->op_type == OP_DUMP);
3173 static const char* const must_have_label = "goto must have label";
3174
3175 if (PL_op->op_flags & OPf_STACKED) {
3176 /* goto EXPR or goto &foo */
3177
3178 SV * const sv = *PL_stack_sp;
3179 SvGETMAGIC(sv);
3180
3181 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
3182 /* This egregious kludge implements goto &subroutine */
3183 I32 cxix;
3184 PERL_CONTEXT *cx;
3185 CV *cv = MUTABLE_CV(SvRV(sv));
3186 AV *arg = GvAV(PL_defgv);
3187 CV *old_cv = NULL;
3188
3189 while (!CvROOT(cv) && !CvXSUB(cv)) {
3190 const GV * const gv = CvGV(cv);
3191 if (gv) {
3192 GV *autogv;
3193 SV *tmpstr;
3194 /* autoloaded stub? */
3195 if (cv != GvCV(gv) && (cv = GvCV(gv)))
3196 continue;
3197 autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
3198 GvNAMELEN(gv),
3199 GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
3200 if (autogv && (cv = GvCV(autogv)))
3201 continue;
3202 tmpstr = sv_newmortal();
3203 gv_efullname3(tmpstr, gv, NULL);
3204 DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr));
3205 }
3206 DIE(aTHX_ "Goto undefined subroutine");
3207 }
3208
3209 cxix = dopopto_cursub();
3210 if (cxix < 0) {
3211 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
3212 }
3213 cx = &cxstack[cxix];
3214 /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
3215 if (CxTYPE(cx) == CXt_EVAL) {
3216 if (CxREALEVAL(cx))
3217 /* diag_listed_as: Can't goto subroutine from an eval-%s */
3218 DIE(aTHX_ "Can't goto subroutine from an eval-string");
3219 else
3220 /* diag_listed_as: Can't goto subroutine from an eval-%s */
3221 DIE(aTHX_ "Can't goto subroutine from an eval-block");
3222 }
3223 else if (CxMULTICALL(cx))
3224 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
3225
3226 /* Check for defer { goto &...; } */
3227 for(ix = cxstack_ix; ix > cxix; ix--) {
3228 if(CxTYPE(&cxstack[ix]) == CXt_DEFER)
3229 /* diag_listed_as: Can't "%s" out of a "defer" block */
3230 Perl_croak(aTHX_ "Can't \"%s\" out of a \"%s\" block",
3231 "goto", S_defer_blockname(&cxstack[ix]));
3232 }
3233
3234 /* First do some returnish stuff. */
3235
3236 SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
3237 rpp_popfree_1_NN(); /* safe to free original sv now */
3238
3239 FREETMPS;
3240 if (cxix < cxstack_ix) {
3241 dounwind(cxix);
3242 }
3243 cx = CX_CUR();
3244 cx_topblock(cx);
3245
3246 /* protect @_ during save stack unwind. */
3247 if (arg)
3248 SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
3249
3250 assert(PL_scopestack_ix == cx->blk_oldscopesp);
3251 CX_LEAVE_SCOPE(cx);
3252
3253 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
3254 /* this is part of cx_popsub_args() */
3255 AV* av = MUTABLE_AV(PAD_SVl(0));
3256 assert(AvARRAY(MUTABLE_AV(
3257 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
3258 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
3259
3260 /* we are going to donate the current @_ from the old sub
3261 * to the new sub. This first part of the donation puts a
3262 * new empty AV in the pad[0] slot of the old sub,
3263 * unless pad[0] and @_ differ (e.g. if the old sub did
3264 * local *_ = []); in which case clear the old pad[0]
3265 * array in the usual way */
3266
3267 if (av != arg && !SvMAGICAL(av) && SvREFCNT(av) == 1
3268 #ifndef PERL_RC_STACK
3269 && !AvREAL(av)
3270 #endif
3271 )
3272 clear_defarray_simple(av);
3273 else
3274 clear_defarray(av, av == arg);
3275 }
3276
3277 /* don't restore PL_comppad here. It won't be needed if the
3278 * sub we're going to is non-XS, but restoring it early then
3279 * croaking (e.g. the "Goto undefined subroutine" below)
3280 * means the CX block gets processed again in dounwind,
3281 * but this time with the wrong PL_comppad */
3282
3283 /* A destructor called during LEAVE_SCOPE could have undefined
3284 * our precious cv. See bug #99850. */
3285 if (!CvROOT(cv) && !CvXSUB(cv)) {
3286 const GV * const gv = CvGV(cv);
3287 if (gv) {
3288 SV * const tmpstr = sv_newmortal();
3289 gv_efullname3(tmpstr, gv, NULL);
3290 DIE(aTHX_ "Goto undefined subroutine &%" SVf,
3291 SVfARG(tmpstr));
3292 }
3293 DIE(aTHX_ "Goto undefined subroutine");
3294 }
3295
3296 if (CxTYPE(cx) == CXt_SUB) {
3297 CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
3298 /*on XS calls defer freeing the old CV as it could
3299 * prematurely set PL_op to NULL, which could cause
3300 * e..g XS subs using GIMME_V to SEGV */
3301 if (CvISXSUB(cv))
3302 old_cv = cx->blk_sub.cv;
3303 else
3304 SvREFCNT_dec_NN(cx->blk_sub.cv);
3305 }
3306
3307 /* Now do some callish stuff. */
3308 if (CvISXSUB(cv)) {
3309 const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
3310 const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
3311 SV** mark;
3312 UNOP fake_goto_op;
3313
3314 ENTER;
3315 SAVETMPS;
3316 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
3317 if (old_cv)
3318 SAVEFREESV(old_cv); /* ditto, deferred freeing of old CV */
3319
3320 /* put GvAV(defgv) back onto stack */
3321 if (items)
3322 rpp_extend(items + 1); /* @_ could have been extended. */
3323 mark = PL_stack_sp;
3324 if (items) {
3325 SSize_t index;
3326 #ifdef PERL_RC_STACK
3327 assert(AvREAL(arg));
3328 #else
3329 bool r = cBOOL(AvREAL(arg));
3330 #endif
3331 for (index=0; index<items; index++)
3332 {
3333 SV *sv;
3334 if (m) {
3335 SV ** const svp = av_fetch(arg, index, 0);
3336 sv = svp ? *svp : NULL;
3337 }
3338 else sv = AvARRAY(arg)[index];
3339
3340 #ifdef PERL_RC_STACK
3341 rpp_push_1(
3342 sv
3343 ? sv
3344 : newSVavdefelem(arg, index, 1)
3345 );
3346 #else
3347 rpp_push_1(
3348 sv
3349 ? (r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv)
3350 : sv_2mortal(newSVavdefelem(arg, index, 1))
3351 );
3352 #endif
3353 }
3354 }
3355
3356 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
3357 /* Restore old @_ */
3358 CX_POP_SAVEARRAY(cx);
3359 }
3360
3361 retop = cx->blk_sub.retop;
3362 PL_comppad = cx->blk_sub.prevcomppad;
3363 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
3364
3365 /* Make a temporary a copy of the current GOTO op on the C
3366 * stack, but with a modified gimme (we can't modify the
3367 * real GOTO op as that's not thread-safe). This allows XS
3368 * users of GIMME_V to get the correct calling context,
3369 * even though there is no longer a CXt_SUB frame to
3370 * provide that information.
3371 */
3372 Copy(PL_op, &fake_goto_op, 1, UNOP);
3373 fake_goto_op.op_flags =
3374 (fake_goto_op.op_flags & ~OPf_WANT)
3375 | (cx->blk_gimme & G_WANT);
3376 PL_op = (OP*)&fake_goto_op;
3377
3378 /* XS subs don't have a CXt_SUB, so pop it;
3379 * this is a cx_popblock(), less all the stuff we already did
3380 * for cx_topblock() earlier */
3381 PL_curcop = cx->blk_oldcop;
3382 /* this is cx_popsub, less all the stuff we already did */
3383 PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix;
3384
3385 CX_POP(cx);
3386
3387 /* Push a mark for the start of arglist */
3388 PUSHMARK(mark);
3389 rpp_invoke_xs(cv);
3390 LEAVE;
3391 goto finish;
3392 }
3393 else {
3394 PADLIST * const padlist = CvPADLIST(cv);
3395
3396 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
3397
3398 /* partial unrolled cx_pushsub(): */
3399
3400 cx->blk_sub.cv = cv;
3401 cx->blk_sub.olddepth = CvDEPTH(cv);
3402
3403 CvDEPTH(cv)++;
3404 SvREFCNT_inc_simple_void_NN(cv);
3405 if (CvDEPTH(cv) > 1) {
3406 if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
3407 sub_crush_depth(cv);
3408 pad_push(padlist, CvDEPTH(cv));
3409 }
3410 PL_curcop = cx->blk_oldcop;
3411 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
3412
3413 if (CxHASARGS(cx))
3414 {
3415 /* second half of donating @_ from the old sub to the
3416 * new sub: abandon the original pad[0] AV in the
3417 * new sub, and replace it with the donated @_.
3418 * pad[0] takes ownership of the extra refcount
3419 * we gave arg earlier */
3420 if (arg) {
3421 SvREFCNT_dec(PAD_SVl(0));
3422 PAD_SVl(0) = (SV *)arg;
3423 SvREFCNT_inc_simple_void_NN(arg);
3424 }
3425
3426 /* GvAV(PL_defgv) might have been modified on scope
3427 exit, so point it at arg again. */
3428 if (arg != GvAV(PL_defgv)) {
3429 AV * const av = GvAV(PL_defgv);
3430 GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
3431 SvREFCNT_dec(av);
3432 }
3433 }
3434
3435 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
3436 Perl_get_db_sub(aTHX_ NULL, cv);
3437 if (PERLDB_GOTO) {
3438 CV * const gotocv = get_cvs("DB::goto", 0);
3439 if (gotocv) {
3440 PUSHMARK( PL_stack_sp );
3441 call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
3442 PL_stack_sp--;
3443 }
3444 }
3445 }
3446 retop = CvSTART(cv);
3447 goto finish;
3448 }
3449 }
3450 else {
3451 /* goto EXPR */
3452 /* avoid premature free of label before popping it off stack */
3453 SvREFCNT_inc_NN(sv);
3454 sv_2mortal(sv);
3455 rpp_popfree_1_NN();
3456 label = SvPV_nomg_const(sv, label_len);
3457 label_flags = SvUTF8(sv);
3458 }
3459 }
3460 else if (!(PL_op->op_flags & OPf_SPECIAL)) {
3461 /* goto LABEL or dump LABEL */
3462 label = cPVOP->op_pv;
3463 label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
3464 label_len = strlen(label);
3465 }
3466 if (!(do_dump || label_len)) DIE(aTHX_ "%s", must_have_label);
3467
3468 PERL_ASYNC_CHECK();
3469
3470 if (label_len) {
3471 OP *gotoprobe = NULL;
3472 bool leaving_eval = FALSE;
3473 bool in_block = FALSE;
3474 bool pseudo_block = FALSE;
3475 PERL_CONTEXT *last_eval_cx = NULL;
3476
3477 /* find label */
3478
3479 PL_lastgotoprobe = NULL;
3480 *enterops = 0;
3481 for (ix = cxstack_ix; ix >= 0; ix--) {
3482 cx = &cxstack[ix];
3483 switch (CxTYPE(cx)) {
3484 case CXt_EVAL:
3485 leaving_eval = TRUE;
3486 if (!CxEVALBLOCK(cx)) {
3487 gotoprobe = (last_eval_cx ?
3488 last_eval_cx->blk_eval.old_eval_root :
3489 PL_eval_root);
3490 last_eval_cx = cx;
3491 break;
3492 }
3493 /* else fall through */
3494 case CXt_LOOP_PLAIN:
3495 case CXt_LOOP_LAZYIV:
3496 case CXt_LOOP_LAZYSV:
3497 case CXt_LOOP_LIST:
3498 case CXt_LOOP_ARY:
3499 case CXt_GIVEN:
3500 case CXt_WHEN:
3501 gotoprobe = OpSIBLING(cx->blk_oldcop);
3502 break;
3503 case CXt_SUBST:
3504 continue;
3505 case CXt_BLOCK:
3506 if (ix) {
3507 gotoprobe = OpSIBLING(cx->blk_oldcop);
3508 in_block = TRUE;
3509 } else
3510 gotoprobe = PL_main_root;
3511 break;
3512 case CXt_SUB:
3513 gotoprobe = CvROOT(cx->blk_sub.cv);
3514 pseudo_block = cBOOL(CxMULTICALL(cx));
3515 break;
3516 case CXt_FORMAT:
3517 case CXt_NULL:
3518 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3519 case CXt_DEFER:
3520 /* diag_listed_as: Can't "%s" out of a "defer" block */
3521 DIE(aTHX_ "Can't \"%s\" out of a \"%s\" block", "goto", S_defer_blockname(cx));
3522 default:
3523 if (ix)
3524 DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3525 CxTYPE(cx), (long) ix);
3526 gotoprobe = PL_main_root;
3527 break;
3528 }
3529 if (gotoprobe) {
3530 OP *sibl1, *sibl2;
3531
3532 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3533 enterops, enterops + GOTO_DEPTH);
3534 if (retop)
3535 break;
3536 if ( (sibl1 = OpSIBLING(gotoprobe)) &&
3537 sibl1->op_type == OP_UNSTACK &&
3538 (sibl2 = OpSIBLING(sibl1)))
3539 {
3540 retop = dofindlabel(sibl2,
3541 label, label_len, label_flags, enterops,
3542 enterops + GOTO_DEPTH);
3543 if (retop)
3544 break;
3545 }
3546 }
3547 if (pseudo_block)
3548 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3549 PL_lastgotoprobe = gotoprobe;
3550 }
3551 if (!retop)
3552 DIE(aTHX_ "Can't find label %" UTF8f,
3553 UTF8fARG(label_flags, label_len, label));
3554
3555 /* if we're leaving an eval, check before we pop any frames
3556 that we're not going to punt, otherwise the error
3557 won't be caught */
3558
3559 if (leaving_eval && *enterops && enterops[1]) {
3560 I32 i;
3561 for (i = 1; enterops[i]; i++)
3562 S_check_op_type(aTHX_ enterops[i]);
3563 }
3564
3565 if (*enterops && enterops[1]) {
3566 I32 i = enterops[1] != UNENTERABLE
3567 && enterops[1]->op_type == OP_ENTER && in_block
3568 ? 2
3569 : 1;
3570 if (enterops[i])
3571 deprecate_fatal_in(WARN_DEPRECATED__GOTO_CONSTRUCT,
3572 "5.42",
3573 "Use of \"goto\" to jump into a construct");
3574 }
3575
3576 /* pop unwanted frames */
3577
3578 if (ix < cxstack_ix) {
3579 if (ix < 0)
3580 DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
3581 dounwind(ix);
3582 cx = CX_CUR();
3583 cx_topblock(cx);
3584 }
3585
3586 /* push wanted frames */
3587
3588 if (*enterops && enterops[1]) {
3589 OP * const oldop = PL_op;
3590 ix = enterops[1] != UNENTERABLE
3591 && enterops[1]->op_type == OP_ENTER && in_block
3592 ? 2
3593 : 1;
3594 for (; enterops[ix]; ix++) {
3595 PL_op = enterops[ix];
3596 S_check_op_type(aTHX_ PL_op);
3597 DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n",
3598 OP_NAME(PL_op)));
3599 PL_op->op_ppaddr(aTHX);
3600 }
3601 PL_op = oldop;
3602 }
3603 }
3604
3605 if (do_dump) {
3606 #ifdef VMS
3607 if (!retop) retop = PL_main_start;
3608 #endif
3609 PL_restartop = retop;
3610 PL_do_undump = TRUE;
3611
3612 my_unexec();
3613
3614 PL_restartop = 0; /* hmm, must be GNU unexec().. */
3615 PL_do_undump = FALSE;
3616 }
3617
3618 finish:
3619 PERL_ASYNC_CHECK();
3620 return retop;
3621 }
3622
3623 PP_wrapped(pp_exit, 1, 0)
3624 {
3625 dSP;
3626 I32 anum;
3627
3628 if (MAXARG < 1)
3629 anum = 0;
3630 else if (!TOPs) {
3631 anum = 0; (void)POPs;
3632 }
3633 else {
3634 anum = SvIVx(POPs);
3635 #ifdef VMS
3636 if (anum == 1
3637 && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3638 anum = 0;
3639 VMSISH_HUSHED =
3640 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3641 #endif
3642 }
3643 PL_exit_flags |= PERL_EXIT_EXPECTED;
3644 my_exit(anum);
3645 PUSHs(&PL_sv_undef);
3646 RETURN;
3647 }
3648
3649 /* Eval. */
3650
3651 STATIC void
S_save_lines(pTHX_ AV * array,SV * sv)3652 S_save_lines(pTHX_ AV *array, SV *sv)
3653 {
3654 const char *s = SvPVX_const(sv);
3655 const char * const send = SvPVX_const(sv) + SvCUR(sv);
3656 I32 line = 1;
3657
3658 PERL_ARGS_ASSERT_SAVE_LINES;
3659
3660 while (s && s < send) {
3661 const char *t;
3662 SV * const tmpstr = newSV_type(SVt_PVMG);
3663
3664 t = (const char *)memchr(s, '\n', send - s);
3665 if (t)
3666 t++;
3667 else
3668 t = send;
3669
3670 sv_setpvn_fresh(tmpstr, s, t - s);
3671 av_store(array, line++, tmpstr);
3672 s = t;
3673 }
3674 }
3675
3676 /*
3677 =for apidoc docatch
3678
3679 Interpose, for the current op and RUNOPS loop,
3680
3681 - a new JMPENV stack catch frame, and
3682 - an inner RUNOPS loop to run all the remaining ops following the
3683 current PL_op.
3684
3685 Then handle any exceptions raised while in that loop.
3686 For a caught eval at this level, re-enter the loop with the specified
3687 restart op (i.e. the op following the OP_LEAVETRY etc); otherwise re-throw
3688 the exception.
3689
3690 docatch() is intended to be used like this:
3691
3692 PP(pp_entertry)
3693 {
3694 if (CATCH_GET)
3695 return docatch(Perl_pp_entertry);
3696
3697 ... rest of function ...
3698 return PL_op->op_next;
3699 }
3700
3701 If a new catch frame isn't needed, the op behaves normally. Otherwise it
3702 calls docatch(), which recursively calls pp_entertry(), this time with
3703 CATCH_GET() false, so the rest of the body of the entertry is run. Then
3704 docatch() calls CALLRUNOPS() which executes all the ops following the
3705 entertry. When the loop finally finishes, control returns to docatch(),
3706 which pops the JMPENV and returns to the parent pp_entertry(), which
3707 itself immediately returns. Note that *all* subsequent ops are run within
3708 the inner RUNOPS loop, not just the body of the eval. For example, in
3709
3710 sub TIEARRAY { eval {1}; my $x }
3711 tie @a, "main";
3712
3713 at the point the 'my' is executed, the C stack will look something like:
3714
3715 #10 main()
3716 #9 perl_run() # JMPENV_PUSH level 1 here
3717 #8 S_run_body()
3718 #7 Perl_runops_standard() # main RUNOPS loop
3719 #6 Perl_pp_tie()
3720 #5 Perl_call_sv()
3721 #4 Perl_runops_standard() # unguarded RUNOPS loop: no new JMPENV
3722 #3 Perl_pp_entertry()
3723 #2 S_docatch() # JMPENV_PUSH level 2 here
3724 #1 Perl_runops_standard() # docatch()'s RUNOPs loop
3725 #0 Perl_pp_padsv()
3726
3727 Basically, any section of the perl core which starts a RUNOPS loop may
3728 make a promise that it will catch any exceptions and restart the loop if
3729 necessary. If it's not prepared to do that (like call_sv() isn't), then
3730 it sets CATCH_GET() to true, so that any later eval-like code knows to
3731 set up a new handler and loop (via docatch()).
3732
3733 See L<perlinterp/"Exception handing"> for further details.
3734
3735 =cut
3736 */
3737
3738 STATIC OP *
S_docatch(pTHX_ Perl_ppaddr_t firstpp)3739 S_docatch(pTHX_ Perl_ppaddr_t firstpp)
3740 {
3741 int ret;
3742 OP * const oldop = PL_op;
3743 dJMPENV;
3744
3745 assert(CATCH_GET);
3746 JMPENV_PUSH(ret);
3747 assert(!CATCH_GET);
3748
3749 switch (ret) {
3750 case 0: /* normal flow-of-control return from JMPENV_PUSH */
3751
3752 /* re-run the current op, this time executing the full body of the
3753 * pp function */
3754 PL_op = firstpp(aTHX);
3755 redo_body:
3756 if (PL_op) {
3757 CALLRUNOPS(aTHX);
3758 }
3759 break;
3760
3761 case 3: /* an exception raised within an eval */
3762 if (PL_restartjmpenv == PL_top_env) {
3763 /* die caught by an inner eval - continue inner loop */
3764
3765 if (!PL_restartop)
3766 break;
3767 PL_restartjmpenv = NULL;
3768 PL_op = PL_restartop;
3769 PL_restartop = 0;
3770 goto redo_body;
3771 }
3772 /* FALLTHROUGH */
3773
3774 default:
3775 JMPENV_POP;
3776 PL_op = oldop;
3777 JMPENV_JUMP(ret); /* re-throw the exception */
3778 NOT_REACHED; /* NOTREACHED */
3779 }
3780 JMPENV_POP;
3781 PL_op = oldop;
3782 return NULL;
3783 }
3784
3785
3786 /*
3787 =for apidoc find_runcv
3788
3789 Locate the CV corresponding to the currently executing sub or eval.
3790 If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
3791 C<*db_seqp> with the cop sequence number at the point that the DB:: code was
3792 entered. (This allows debuggers to eval in the scope of the breakpoint
3793 rather than in the scope of the debugger itself.)
3794
3795 =cut
3796 */
3797
3798 CV*
Perl_find_runcv(pTHX_ U32 * db_seqp)3799 Perl_find_runcv(pTHX_ U32 *db_seqp)
3800 {
3801 return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3802 }
3803
3804 /* If this becomes part of the API, it might need a better name. */
3805 CV *
Perl_find_runcv_where(pTHX_ U8 cond,IV arg,U32 * db_seqp)3806 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3807 {
3808 PERL_SI *si;
3809 int level = 0;
3810
3811 if (db_seqp)
3812 *db_seqp =
3813 PL_curcop == &PL_compiling
3814 ? PL_cop_seqmax
3815 : PL_curcop->cop_seq;
3816
3817 for (si = PL_curstackinfo; si; si = si->si_prev) {
3818 I32 ix;
3819 for (ix = si->si_cxix; ix >= 0; ix--) {
3820 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3821 CV *cv = NULL;
3822 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3823 cv = cx->blk_sub.cv;
3824 /* skip DB:: code */
3825 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3826 *db_seqp = cx->blk_oldcop->cop_seq;
3827 continue;
3828 }
3829 if (cx->cx_type & CXp_SUB_RE)
3830 continue;
3831 }
3832 else if (CxTYPE(cx) == CXt_EVAL && !CxEVALBLOCK(cx))
3833 cv = cx->blk_eval.cv;
3834 if (cv) {
3835 switch (cond) {
3836 case FIND_RUNCV_padid_eq:
3837 if (!CvPADLIST(cv)
3838 || CvPADLIST(cv)->xpadl_id != (U32)arg)
3839 continue;
3840 return cv;
3841 case FIND_RUNCV_level_eq:
3842 if (level++ != arg) continue;
3843 /* FALLTHROUGH */
3844 default:
3845 return cv;
3846 }
3847 }
3848 }
3849 }
3850 return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3851 }
3852
3853
3854 /* S_try_yyparse():
3855 *
3856 * Run yyparse() in a setjmp wrapper. Returns:
3857 * 0: yyparse() successful
3858 * 1: yyparse() failed
3859 * 3: yyparse() died
3860 *
3861 * This is used to trap Perl_croak() calls that are executed
3862 * during the compilation process and before the code has been
3863 * completely compiled. It is expected to be called from
3864 * doeval_compile() only. The parameter 'caller_op' is
3865 * only used in DEBUGGING to validate the logic is working
3866 * correctly.
3867 *
3868 * See also try_run_unitcheck().
3869 *
3870 */
3871 STATIC int
S_try_yyparse(pTHX_ int gramtype,OP * caller_op)3872 S_try_yyparse(pTHX_ int gramtype, OP *caller_op)
3873 {
3874 /* if we die during compilation PL_restartop and PL_restartjmpenv
3875 * will be set by Perl_die_unwind(). We need to restore their values
3876 * if that happens as they are intended for the case where the code
3877 * compiles and dies during execution, not where it dies during
3878 * compilation. PL_restartop and caller_op->op_next should be the
3879 * same anyway, and when compilation fails then caller_op->op_next is
3880 * used as the next op after the compile.
3881 */
3882 JMPENV *restartjmpenv = PL_restartjmpenv;
3883 OP *restartop = PL_restartop;
3884 dJMPENV;
3885 int ret;
3886 PERL_UNUSED_ARG(caller_op); /* only used in debugging builds */
3887
3888 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3889 JMPENV_PUSH(ret);
3890 switch (ret) {
3891 case 0:
3892 ret = yyparse(gramtype) ? 1 : 0;
3893 break;
3894 case 3:
3895 /* yyparse() died and we trapped the error. We need to restore
3896 * the old PL_restartjmpenv and PL_restartop values. */
3897 assert(PL_restartop == caller_op->op_next); /* we expect these to match */
3898 PL_restartjmpenv = restartjmpenv;
3899 PL_restartop = restartop;
3900 break;
3901 default:
3902 JMPENV_POP;
3903 JMPENV_JUMP(ret);
3904 NOT_REACHED; /* NOTREACHED */
3905 }
3906 JMPENV_POP;
3907 return ret;
3908 }
3909
3910 /* S_try_run_unitcheck()
3911 *
3912 * Run PL_unitcheckav in a setjmp wrapper via call_list.
3913 * Returns:
3914 * 0: unitcheck blocks ran without error
3915 * 3: a unitcheck block died
3916 *
3917 * This is used to trap Perl_croak() calls that are executed
3918 * during UNITCHECK blocks executed after the compilation
3919 * process has completed but before the code itself has been
3920 * executed via the normal run loops. It is expected to be called
3921 * from doeval_compile() only. The parameter 'caller_op' is
3922 * only used in DEBUGGING to validate the logic is working
3923 * correctly.
3924 *
3925 * See also try_yyparse().
3926 */
3927 STATIC int
S_try_run_unitcheck(pTHX_ OP * caller_op)3928 S_try_run_unitcheck(pTHX_ OP* caller_op)
3929 {
3930 /* if we die during compilation PL_restartop and PL_restartjmpenv
3931 * will be set by Perl_die_unwind(). We need to restore their values
3932 * if that happens as they are intended for the case where the code
3933 * compiles and dies during execution, not where it dies during
3934 * compilation. UNITCHECK runs after compilation completes, and
3935 * if it dies we will execute the PL_restartop anyway via the
3936 * failed compilation code path. PL_restartop and caller_op->op_next
3937 * should be the same anyway, and when compilation fails then
3938 * caller_op->op_next is used as the next op after the compile.
3939 */
3940 JMPENV *restartjmpenv = PL_restartjmpenv;
3941 OP *restartop = PL_restartop;
3942 dJMPENV;
3943 int ret;
3944 PERL_UNUSED_ARG(caller_op); /* only used in debugging builds */
3945
3946 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
3947 JMPENV_PUSH(ret);
3948 switch (ret) {
3949 case 0:
3950 call_list(PL_scopestack_ix, PL_unitcheckav);
3951 break;
3952 case 3:
3953 /* call_list died */
3954 /* call_list() died and we trapped the error. We should restore
3955 * the old PL_restartjmpenv and PL_restartop values, as they are
3956 * used only in the case where the code was actually run.
3957 * The assert validates that we will still execute the PL_restartop.
3958 */
3959 assert(PL_restartop == caller_op->op_next); /* we expect these to match */
3960 PL_restartjmpenv = restartjmpenv;
3961 PL_restartop = restartop;
3962 break;
3963 default:
3964 JMPENV_POP;
3965 JMPENV_JUMP(ret);
3966 NOT_REACHED; /* NOTREACHED */
3967 }
3968 JMPENV_POP;
3969 return ret;
3970 }
3971
3972 /* Compile a require/do or an eval ''.
3973 *
3974 * outside is the lexically enclosing CV (if any) that invoked us.
3975 * seq is the current COP scope value.
3976 * hh is the saved hints hash, if any.
3977 *
3978 * Returns a bool indicating whether the compile was successful; if so,
3979 * PL_eval_start contains the first op of the compiled code; otherwise,
3980 * pushes undef.
3981 *
3982 * This function is called from two places: pp_require and pp_entereval.
3983 * These can be distinguished by whether PL_op is entereval.
3984 */
3985
3986 STATIC bool
S_doeval_compile(pTHX_ U8 gimme,CV * outside,U32 seq,HV * hh)3987 S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
3988 {
3989 OP * const saveop = PL_op;
3990 bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3991 COP * const oldcurcop = PL_curcop;
3992 bool in_require = (saveop->op_type == OP_REQUIRE);
3993 int yystatus;
3994 CV *evalcv;
3995
3996 PL_in_eval = (in_require
3997 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3998 : (EVAL_INEVAL |
3999 ((PL_op->op_private & OPpEVAL_RE_REPARSING)
4000 ? EVAL_RE_REPARSING : 0)));
4001
4002 PUSHMARK(PL_stack_sp);
4003
4004 evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
4005 CvEVAL_on(evalcv);
4006 assert(CxTYPE(CX_CUR()) == CXt_EVAL);
4007 CX_CUR()->blk_eval.cv = evalcv;
4008 CX_CUR()->blk_gimme = gimme;
4009
4010 CvOUTSIDE_SEQ(evalcv) = seq;
4011 CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
4012
4013 /* set up a scratch pad */
4014
4015 CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
4016 PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
4017
4018
4019 SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
4020
4021 /* make sure we compile in the right package */
4022
4023 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
4024 SAVEGENERICSV(PL_curstash);
4025 PL_curstash = (HV *)CopSTASH(PL_curcop);
4026 if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
4027 else {
4028 SvREFCNT_inc_simple_void(PL_curstash);
4029 save_item(PL_curstname);
4030 sv_sethek(PL_curstname, HvNAME_HEK(PL_curstash));
4031 }
4032 }
4033 /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
4034 SAVESPTR(PL_beginav);
4035 PL_beginav = newAV();
4036 SAVEFREESV(PL_beginav);
4037 SAVESPTR(PL_unitcheckav);
4038 PL_unitcheckav = newAV();
4039 SAVEFREESV(PL_unitcheckav);
4040
4041
4042 ENTER_with_name("evalcomp");
4043 SAVESPTR(PL_compcv);
4044 PL_compcv = evalcv;
4045
4046 /* try to compile it */
4047
4048 PL_eval_root = NULL;
4049 PL_curcop = &PL_compiling;
4050 if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
4051 PL_in_eval |= EVAL_KEEPERR;
4052 else
4053 CLEAR_ERRSV();
4054
4055 SAVEHINTS();
4056 if (clear_hints) {
4057 PL_hints = HINTS_DEFAULT;
4058 PL_prevailing_version = 0;
4059 hv_clear(GvHV(PL_hintgv));
4060 CLEARFEATUREBITS();
4061 }
4062 else {
4063 PL_hints = saveop->op_private & OPpEVAL_COPHH
4064 ? oldcurcop->cop_hints : (U32)saveop->op_targ;
4065 PL_prevailing_version = 0; /* we might change this below */
4066
4067 /* making 'use re eval' not be in scope when compiling the
4068 * qr/mabye_has_runtime_code_block/ ensures that we don't get
4069 * infinite recursion when S_has_runtime_code() gives a false
4070 * positive: the second time round, HINT_RE_EVAL isn't set so we
4071 * don't bother calling S_has_runtime_code() */
4072 if (PL_in_eval & EVAL_RE_REPARSING)
4073 PL_hints &= ~HINT_RE_EVAL;
4074
4075 if (hh) {
4076 /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
4077 SvREFCNT_dec(GvHV(PL_hintgv));
4078 GvHV(PL_hintgv) = hh;
4079 FETCHFEATUREBITSHH(hh);
4080 /* temporarily turn magical flags off so we can delete without it getting in the way */
4081 const U32 wasflags = SvFLAGS(hh);
4082 SvMAGICAL_off(hh);
4083
4084 SV *versv;
4085 /* hh is a new copy for us to use; we are permitted to delete keys */
4086 if((versv = hv_deletes(hh, "CORE/prevailing_version", 0)) && SvOK(versv)) {
4087 SAVEI16(PL_prevailing_version);
4088 PL_prevailing_version = SvUV(versv);
4089 }
4090
4091 SvFLAGS(hh) = wasflags;
4092 }
4093 }
4094 SAVECOMPILEWARNINGS();
4095 if (clear_hints) {
4096 if (PL_dowarn & G_WARN_ALL_ON)
4097 PL_compiling.cop_warnings = pWARN_ALL ;
4098 else if (PL_dowarn & G_WARN_ALL_OFF)
4099 PL_compiling.cop_warnings = pWARN_NONE ;
4100 else
4101 PL_compiling.cop_warnings = pWARN_STD ;
4102 }
4103 else {
4104 PL_compiling.cop_warnings =
4105 DUP_WARNINGS(oldcurcop->cop_warnings);
4106 cophh_free(CopHINTHASH_get(&PL_compiling));
4107 if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
4108 /* The label, if present, is the first entry on the chain. So rather
4109 than writing a blank label in front of it (which involves an
4110 allocation), just use the next entry in the chain. */
4111 PL_compiling.cop_hints_hash
4112 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
4113 /* Check the assumption that this removed the label. */
4114 assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
4115 }
4116 else
4117 PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
4118 }
4119
4120 CALL_BLOCK_HOOKS(bhk_eval, saveop);
4121
4122 /* we should never be CATCH_GET true here, as our immediate callers should
4123 * always handle that case. */
4124 assert(!CATCH_GET);
4125 /* compile the code */
4126
4127
4128 yystatus = (!in_require)
4129 ? S_try_yyparse(aTHX_ GRAMPROG, saveop)
4130 : yyparse(GRAMPROG);
4131
4132 if (yystatus || PL_parser->error_count || !PL_eval_root) {
4133 PERL_CONTEXT *cx;
4134 SV *errsv;
4135
4136 PL_op = saveop;
4137 if (yystatus != 3) {
4138 /* note that if yystatus == 3, then the require/eval died during
4139 * compilation, so the EVAL CX block has already been popped, and
4140 * various vars restored. This block applies similar steps after
4141 * the other "failed to compile" cases in yyparse, eg, where
4142 * yystatus=1, "failed, but did not die". */
4143
4144 if (!in_require)
4145 invoke_exception_hook(ERRSV,FALSE);
4146
4147 op_free(PL_eval_root);
4148 PL_eval_root = NULL;
4149
4150 rpp_popfree_to(PL_stack_base + POPMARK); /* pop original mark */
4151 cx = CX_CUR();
4152 assert(CxTYPE(cx) == CXt_EVAL);
4153 /* If we are in an eval we need to make sure that $SIG{__DIE__}
4154 * handler is invoked so we simulate that part of the
4155 * Perl_die_unwind() process. In a require we will croak
4156 * so it will happen there. */
4157 /* pop the CXt_EVAL, and if was a require, croak */
4158 S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
4159
4160 }
4161
4162 /* die_unwind() re-croaks when in require, having popped the
4163 * require EVAL context. So we should never catch a require
4164 * exception here */
4165 assert(!in_require);
4166
4167 errsv = ERRSV;
4168 if (!*(SvPV_nolen_const(errsv)))
4169 sv_setpvs(errsv, "Compilation error");
4170
4171 if (gimme == G_SCALAR) {
4172 if (yystatus == 3) {
4173 /* die_unwind already pushed undef in scalar context */
4174 assert(*PL_stack_sp == &PL_sv_undef);
4175 }
4176 else {
4177 rpp_xpush_1(&PL_sv_undef);
4178 }
4179 }
4180 return FALSE;
4181 }
4182
4183 /* Compilation successful. Now clean up */
4184
4185 LEAVE_with_name("evalcomp");
4186
4187 CopLINE_set(&PL_compiling, 0);
4188 SAVEFREEOP(PL_eval_root);
4189 cv_forget_slab(evalcv);
4190
4191 DEBUG_x(dump_eval());
4192
4193 /* Register with debugger: */
4194 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
4195 CV * const cv = get_cvs("DB::postponed", 0);
4196 if (cv) {
4197 PUSHMARK(PL_stack_sp);
4198 rpp_xpush_1(MUTABLE_SV(CopFILEGV(&PL_compiling)));
4199 call_sv(MUTABLE_SV(cv), G_DISCARD);
4200 }
4201 }
4202
4203 if (PL_unitcheckav && av_count(PL_unitcheckav)>0) {
4204 OP *es = PL_eval_start;
4205 /* TODO: are we sure we shouldn't do S_try_run_unitcheck()
4206 * when `in_require` is true? */
4207 if (in_require) {
4208 call_list(PL_scopestack_ix, PL_unitcheckav);
4209 }
4210 else if (S_try_run_unitcheck(aTHX_ saveop)) {
4211 /* there was an error! */
4212
4213 /* Restore PL_OP */
4214 PL_op = saveop;
4215
4216 SV *errsv = ERRSV;
4217 if (!*(SvPV_nolen_const(errsv))) {
4218 /* This happens when using:
4219 * eval qq# UNITCHECK { die "\x00"; } #;
4220 */
4221 sv_setpvs(errsv, "Unit check error");
4222 }
4223
4224 if (gimme != G_LIST)
4225 rpp_xpush_1(&PL_sv_undef);
4226 return FALSE;
4227 }
4228 PL_eval_start = es;
4229 }
4230
4231 CvDEPTH(evalcv) = 1;
4232 rpp_popfree_to_NN(PL_stack_base + POPMARK); /* pop original mark */
4233 PL_op = saveop; /* The caller may need it. */
4234 PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */
4235
4236 return TRUE;
4237 }
4238
4239
4240 /* Return NULL if the file doesn't exist or isn't a file;
4241 * else return PerlIO_openn().
4242 */
4243
4244 STATIC PerlIO *
S_check_type_and_open(pTHX_ SV * name)4245 S_check_type_and_open(pTHX_ SV *name)
4246 {
4247 Stat_t st;
4248 STRLEN len;
4249 PerlIO * retio;
4250 const char *p = SvPV_const(name, len);
4251 int st_rc;
4252
4253 PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
4254
4255 /* checking here captures a reasonable error message when
4256 * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
4257 * user gets a confusing message about looking for the .pmc file
4258 * rather than for the .pm file so do the check in S_doopen_pm when
4259 * PMC is on instead of here. S_doopen_pm calls this func.
4260 * This check prevents a \0 in @INC causing problems.
4261 */
4262 #ifdef PERL_DISABLE_PMC
4263 if (!IS_SAFE_PATHNAME(p, len, "require"))
4264 return NULL;
4265 #endif
4266
4267 /* on Win32 stat is expensive (it does an open() and close() twice and
4268 a couple other IO calls), the open will fail with a dir on its own with
4269 errno EACCES, so only do a stat to separate a dir from a real EACCES
4270 caused by user perms */
4271 #ifndef WIN32
4272 st_rc = PerlLIO_stat(p, &st);
4273
4274 if (st_rc < 0)
4275 return NULL;
4276 else {
4277 int eno;
4278 if(S_ISBLK(st.st_mode)) {
4279 eno = EINVAL;
4280 goto not_file;
4281 }
4282 else if(S_ISDIR(st.st_mode)) {
4283 eno = EISDIR;
4284 not_file:
4285 errno = eno;
4286 return NULL;
4287 }
4288 }
4289 #endif
4290
4291 retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
4292 #ifdef WIN32
4293 /* EACCES stops the INC search early in pp_require to implement
4294 feature RT #113422 */
4295 if(!retio && errno == EACCES) { /* exists but probably a directory */
4296 int eno;
4297 st_rc = PerlLIO_stat(p, &st);
4298 if (st_rc >= 0) {
4299 if(S_ISDIR(st.st_mode))
4300 eno = EISDIR;
4301 else if(S_ISBLK(st.st_mode))
4302 eno = EINVAL;
4303 else
4304 eno = EACCES;
4305 errno = eno;
4306 }
4307 }
4308 #endif
4309 return retio;
4310 }
4311
4312 /* doopen_pm(): return the equivalent of PerlIO_openn() on the given name,
4313 * but first check for bad names (\0) and non-files.
4314 * Also if the filename ends in .pm and unless PERL_DISABLE_PMC,
4315 * try loading Foo.pmc first.
4316 */
4317 #ifndef PERL_DISABLE_PMC
4318 STATIC PerlIO *
S_doopen_pm(pTHX_ SV * name)4319 S_doopen_pm(pTHX_ SV *name)
4320 {
4321 STRLEN namelen;
4322 const char *p = SvPV_const(name, namelen);
4323
4324 PERL_ARGS_ASSERT_DOOPEN_PM;
4325
4326 /* check the name before trying for the .pmc name to avoid the
4327 * warning referring to the .pmc which the user probably doesn't
4328 * know or care about
4329 */
4330 if (!IS_SAFE_PATHNAME(p, namelen, "require"))
4331 return NULL;
4332
4333 if (memENDPs(p, namelen, ".pm")) {
4334 SV *const pmcsv = sv_newmortal();
4335 PerlIO * pmcio;
4336
4337 SvSetSV_nosteal(pmcsv,name);
4338 sv_catpvs(pmcsv, "c");
4339
4340 pmcio = check_type_and_open(pmcsv);
4341 if (pmcio)
4342 return pmcio;
4343 }
4344 return check_type_and_open(name);
4345 }
4346 #else
4347 # define doopen_pm(name) check_type_and_open(name)
4348 #endif /* !PERL_DISABLE_PMC */
4349
4350 /* require doesn't search in @INC for absolute names, or when the name is
4351 explicitly relative the current directory: i.e. ./, ../ */
4352 PERL_STATIC_INLINE bool
S_path_is_searchable(const char * name)4353 S_path_is_searchable(const char *name)
4354 {
4355 PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
4356
4357 if (PERL_FILE_IS_ABSOLUTE(name)
4358 #ifdef WIN32
4359 || (*name == '.' && ((name[1] == '/' ||
4360 (name[1] == '.' && name[2] == '/'))
4361 || (name[1] == '\\' ||
4362 ( name[1] == '.' && name[2] == '\\')))
4363 )
4364 #else
4365 || (*name == '.' && (name[1] == '/' ||
4366 (name[1] == '.' && name[2] == '/')))
4367 #endif
4368 )
4369 {
4370 return FALSE;
4371 }
4372 else
4373 return TRUE;
4374 }
4375
4376
4377 /* implement 'require 5.010001' */
4378
4379 static OP *
S_require_version(pTHX_ SV * sv)4380 S_require_version(pTHX_ SV *sv)
4381 {
4382 sv = sv_2mortal(new_version(sv));
4383 rpp_popfree_1_NN();
4384
4385 if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
4386 upg_version(PL_patchlevel, TRUE);
4387 if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
4388 if ( vcmp(sv,PL_patchlevel) <= 0 )
4389 DIE(aTHX_ "Perls since %" SVf " too modern--this is %" SVf ", stopped",
4390 SVfARG(sv_2mortal(vnormal(sv))),
4391 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
4392 );
4393 }
4394 else {
4395 if ( vcmp(sv,PL_patchlevel) > 0 ) {
4396 I32 first = 0;
4397 AV *lav;
4398 SV * const req = SvRV(sv);
4399 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
4400
4401 /* get the left hand term */
4402 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
4403
4404 first = SvIV(*av_fetch(lav,0,0));
4405 if ( first > (int)PERL_REVISION /* probably 'use 6.0' */
4406 || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
4407 || av_count(lav) > 2 /* FP with > 3 digits */
4408 || strstr(SvPVX(pv),".0") /* FP with leading 0 */
4409 ) {
4410 DIE(aTHX_ "Perl %" SVf " required--this is only "
4411 "%" SVf ", stopped",
4412 SVfARG(sv_2mortal(vnormal(req))),
4413 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
4414 );
4415 }
4416 else { /* probably 'use 5.10' or 'use 5.8' */
4417 SV *hintsv;
4418 I32 second = 0;
4419
4420 if (av_count(lav) > 1)
4421 second = SvIV(*av_fetch(lav,1,0));
4422
4423 second /= second >= 600 ? 100 : 10;
4424 hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
4425 (int)first, (int)second);
4426 upg_version(hintsv, TRUE);
4427
4428 DIE(aTHX_ "Perl %" SVf " required (did you mean %" SVf "?)"
4429 "--this is only %" SVf ", stopped",
4430 SVfARG(sv_2mortal(vnormal(req))),
4431 SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
4432 SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
4433 );
4434 }
4435 }
4436 }
4437
4438 rpp_push_IMM(&PL_sv_yes);
4439 return NORMAL;
4440 }
4441
4442
4443 /* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">.
4444 * The first form will have already been converted at compile time to
4445 * the second form.
4446 * sv is still on the stack at this point. */
4447
4448 static OP *
S_require_file(pTHX_ SV * sv)4449 S_require_file(pTHX_ SV *sv)
4450 {
4451 PERL_CONTEXT *cx;
4452 const char *name;
4453 STRLEN len;
4454 char * unixname;
4455 STRLEN unixlen;
4456 #ifdef VMS
4457 int vms_unixname = 0;
4458 char *unixdir;
4459 #endif
4460 /* tryname is the actual pathname (with @INC prefix) which was loaded.
4461 * It's stored as a value in %INC, and used for error messages */
4462 const char *tryname = NULL;
4463 SV *namesv = NULL; /* SV equivalent of tryname */
4464 const U8 gimme = GIMME_V;
4465 int filter_has_file = 0;
4466 PerlIO *tryrsfp = NULL;
4467 SV *filter_cache = NULL;
4468 SV *filter_state = NULL;
4469 SV *filter_sub = NULL;
4470 SV *hook_sv = NULL;
4471 OP *op;
4472 int saved_errno;
4473 bool path_searchable;
4474 I32 old_savestack_ix;
4475 const bool op_is_require = PL_op->op_type == OP_REQUIRE;
4476 const char *const op_name = op_is_require ? "require" : "do";
4477 SV ** svp_cached = NULL;
4478
4479 assert(op_is_require || PL_op->op_type == OP_DOFILE);
4480
4481 if (!SvOK(sv))
4482 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
4483 name = SvPV_nomg_const(sv, len);
4484 if (!(name && len > 0 && *name))
4485 DIE(aTHX_ "Missing or undefined argument to %s", op_name);
4486
4487 if (
4488 PL_hook__require__before
4489 && SvROK(PL_hook__require__before)
4490 && SvTYPE(SvRV(PL_hook__require__before)) == SVt_PVCV
4491 ) {
4492 SV* name_sv = sv_mortalcopy(sv);
4493 SV *post_hook__require__before_sv = NULL;
4494
4495 ENTER_with_name("call_PRE_REQUIRE");
4496 SAVETMPS;
4497 PUSHMARK(PL_stack_sp);
4498 rpp_xpush_1(name_sv); /* always use the object for method calls */
4499 call_sv(PL_hook__require__before, G_SCALAR);
4500 SV *rsv = *PL_stack_sp;
4501 if (SvOK(rsv) && SvROK(rsv) && SvTYPE(SvRV(rsv)) == SVt_PVCV) {
4502 /* the RC++ preserves it across the popping and/or FREETMPS
4503 * below */
4504 post_hook__require__before_sv = SvREFCNT_inc_simple_NN(rsv);
4505 rpp_popfree_1_NN();
4506 }
4507 if (!sv_streq(name_sv,sv)) {
4508 /* they modified the name argument, so do some sleight of hand */
4509 name = SvPV_nomg_const(name_sv, len);
4510 if (!(name && len > 0 && *name))
4511 DIE(aTHX_ "Missing or undefined argument to %s via %%{^HOOK}{require__before}",
4512 op_name);
4513 sv = name_sv;
4514 }
4515 FREETMPS;
4516 LEAVE_with_name("call_PRE_REQUIRE");
4517 if (post_hook__require__before_sv) {
4518 SV *nsv = newSVsv(sv);
4519 MORTALDESTRUCTOR_SV(post_hook__require__before_sv, nsv);
4520 SvREFCNT_dec_NN(nsv);
4521 SvREFCNT_dec_NN(post_hook__require__before_sv);
4522 }
4523 }
4524 if (
4525 PL_hook__require__after
4526 && SvROK(PL_hook__require__after)
4527 && SvTYPE(SvRV(PL_hook__require__after)) == SVt_PVCV
4528 ) {
4529 SV *nsv = newSVsv(sv);
4530 MORTALDESTRUCTOR_SV(PL_hook__require__after, nsv);
4531 SvREFCNT_dec_NN(nsv);
4532 }
4533
4534 #ifndef VMS
4535 /* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */
4536 if (op_is_require) {
4537 /* can optimize to only perform one single lookup */
4538 svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0);
4539 if (svp_cached &&
4540 (SvGETMAGIC(*svp_cached), SvOK(*svp_cached)))
4541 {
4542 rpp_replace_1_IMM_NN(&PL_sv_yes);
4543 return NORMAL;
4544 }
4545 }
4546 #endif
4547
4548 if (!IS_SAFE_PATHNAME(name, len, op_name)) {
4549 if (!op_is_require) {
4550 CLEAR_ERRSV();
4551 rpp_replace_1_IMM_NN(&PL_sv_undef);
4552 return NORMAL;
4553 }
4554 DIE(aTHX_ "Can't locate %s: %s",
4555 pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
4556 NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
4557 Strerror(ENOENT));
4558 }
4559 TAINT_PROPER(op_name);
4560
4561 path_searchable = path_is_searchable(name);
4562
4563 #ifdef VMS
4564 /* The key in the %ENV hash is in the syntax of file passed as the argument
4565 * usually this is in UNIX format, but sometimes in VMS format, which
4566 * can result in a module being pulled in more than once.
4567 * To prevent this, the key must be stored in UNIX format if the VMS
4568 * name can be translated to UNIX.
4569 */
4570
4571 if ((unixname =
4572 tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4573 != NULL) {
4574 unixlen = strlen(unixname);
4575 vms_unixname = 1;
4576 }
4577 else
4578 #endif
4579 {
4580 /* if not VMS or VMS name can not be translated to UNIX, pass it
4581 * through.
4582 */
4583 unixname = (char *) name;
4584 unixlen = len;
4585 }
4586 if (op_is_require) {
4587 /* reuse the previous hv_fetch result if possible */
4588 SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4589 if ( svp ) {
4590 /* we already did a get magic if this was cached */
4591 if (!svp_cached)
4592 SvGETMAGIC(*svp);
4593 if (SvOK(*svp)) {
4594 rpp_replace_1_IMM_NN(&PL_sv_yes);
4595 return NORMAL;
4596 }
4597 else
4598 DIE(aTHX_ "Attempt to reload %s aborted.\n"
4599 "Compilation failed in require", unixname);
4600 }
4601
4602 /*XXX OPf_KIDS should always be true? -dapm 4/2017 */
4603 if (PL_op->op_flags & OPf_KIDS) {
4604 SVOP * const kid = cSVOPx(cUNOP->op_first);
4605
4606 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4607 /* Make sure that a bareword module name (e.g. ::Foo::Bar)
4608 * doesn't map to a naughty pathname like /Foo/Bar.pm.
4609 * Note that the parser will normally detect such errors
4610 * at compile time before we reach here, but
4611 * Perl_load_module() can fake up an identical optree
4612 * without going near the parser, and being able to put
4613 * anything as the bareword. So we include a duplicate set
4614 * of checks here at runtime.
4615 */
4616 const STRLEN package_len = len - 3;
4617 const char slashdot[2] = {'/', '.'};
4618 #ifdef DOSISH
4619 const char backslashdot[2] = {'\\', '.'};
4620 #endif
4621
4622 /* Disallow *purported* barewords that map to absolute
4623 filenames, filenames relative to the current or parent
4624 directory, or (*nix) hidden filenames. Also sanity check
4625 that the generated filename ends .pm */
4626 if (!path_searchable || len < 3 || name[0] == '.'
4627 || !memEQs(name + package_len, len - package_len, ".pm"))
4628 DIE(aTHX_ "Bareword in require maps to disallowed filename \"%" SVf "\"", sv);
4629 if (memchr(name, 0, package_len)) {
4630 /* diag_listed_as: Bareword in require contains "%s" */
4631 DIE(aTHX_ "Bareword in require contains \"\\0\"");
4632 }
4633 if (ninstr(name, name + package_len, slashdot,
4634 slashdot + sizeof(slashdot))) {
4635 /* diag_listed_as: Bareword in require contains "%s" */
4636 DIE(aTHX_ "Bareword in require contains \"/.\"");
4637 }
4638 #ifdef DOSISH
4639 if (ninstr(name, name + package_len, backslashdot,
4640 backslashdot + sizeof(backslashdot))) {
4641 /* diag_listed_as: Bareword in require contains "%s" */
4642 DIE(aTHX_ "Bareword in require contains \"\\.\"");
4643 }
4644 #endif
4645 }
4646 }
4647 }
4648
4649 PERL_DTRACE_PROBE_FILE_LOADING(unixname);
4650
4651 /* Try to locate and open a file, possibly using @INC */
4652
4653 /* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load
4654 * the file directly rather than via @INC ... */
4655 if (!path_searchable) {
4656 /* At this point, name is SvPVX(sv) */
4657 tryname = name;
4658 tryrsfp = doopen_pm(sv);
4659 }
4660
4661 /* ... but if we fail, still search @INC for code references;
4662 * these are applied even on non-searchable paths (except
4663 * if we got EACESS).
4664 *
4665 * For searchable paths, just search @INC normally
4666 */
4667 AV *inc_checked = (AV*)sv_2mortal((SV*)newAV());
4668 if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
4669 SSize_t inc_idx;
4670 #ifdef VMS
4671 if (vms_unixname)
4672 #endif
4673 {
4674 AV *incdir_av = (AV*)sv_2mortal((SV*)newAV());
4675 SV *nsv = sv; /* non const copy we can change if necessary */
4676 namesv = newSV_type(SVt_PV);
4677 AV *inc_ar = GvAVn(PL_incgv);
4678 SSize_t incdir_continue_inc_idx = -1;
4679
4680 for (
4681 inc_idx = 0;
4682 (AvFILL(incdir_av)>=0 /* we have INCDIR items pending */
4683 || inc_idx <= AvFILL(inc_ar)); /* @INC entries remain */
4684 inc_idx++
4685 ) {
4686 SV *dirsv;
4687
4688 /* do we have any pending INCDIR items? */
4689 if (AvFILL(incdir_av)>=0) {
4690 /* yep, shift it out */
4691 dirsv = av_shift(incdir_av);
4692 if (AvFILL(incdir_av)<0) {
4693 /* incdir is now empty, continue from where
4694 * we left off after we process this entry */
4695 inc_idx = incdir_continue_inc_idx;
4696 }
4697 } else {
4698 dirsv = *av_fetch(inc_ar, inc_idx, TRUE);
4699 }
4700
4701 if (SvGMAGICAL(dirsv)) {
4702 SvGETMAGIC(dirsv);
4703 dirsv = newSVsv_nomg(dirsv);
4704 } else {
4705 /* on the other hand, since we aren't copying we do need
4706 * to increment */
4707 SvREFCNT_inc(dirsv);
4708 }
4709 if (!SvOK(dirsv))
4710 continue;
4711
4712 av_push(inc_checked, dirsv);
4713
4714 if (SvROK(dirsv)) {
4715 int count;
4716 SV **svp;
4717 SV *loader = dirsv;
4718 UV diruv = PTR2UV(SvRV(dirsv));
4719
4720 if (SvTYPE(SvRV(loader)) == SVt_PVAV
4721 && !SvOBJECT(SvRV(loader)))
4722 {
4723 loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
4724 if (SvGMAGICAL(loader)) {
4725 SvGETMAGIC(loader);
4726 SV *l = sv_newmortal();
4727 sv_setsv_nomg(l, loader);
4728 loader = l;
4729 }
4730 }
4731
4732 if (SvPADTMP(nsv)) {
4733 nsv = sv_newmortal();
4734 SvSetSV_nosteal(nsv,sv);
4735 }
4736
4737 const char *method = NULL;
4738 bool is_incdir = FALSE;
4739 SV * inc_idx_sv = save_scalar(PL_incgv);
4740 sv_setiv(inc_idx_sv,inc_idx);
4741 if (sv_isobject(loader)) {
4742 /* if it is an object and it has an INC method, then
4743 * call the method.
4744 */
4745 HV *pkg = SvSTASH(SvRV(loader));
4746 GV * gv = gv_fetchmethod_pvn_flags(pkg, "INC", 3, GV_AUTOLOAD);
4747 if (gv && isGV(gv)) {
4748 method = "INC";
4749 } else {
4750 /* no point to autoload here, it would have been found above */
4751 gv = gv_fetchmethod_pvn_flags(pkg, "INCDIR", 6, 0);
4752 if (gv && isGV(gv)) {
4753 method = "INCDIR";
4754 is_incdir = TRUE;
4755 }
4756 }
4757 /* But if we have no method, check if this is a
4758 * coderef, if it is then we treat it as an
4759 * unblessed coderef would be treated: we
4760 * execute it. If it is some other and it is in
4761 * an array ref wrapper, then really we don't
4762 * know what to do with it, (why use the
4763 * wrapper?) and we throw an exception to help
4764 * debug. If it is not in a wrapper assume it
4765 * has an overload and treat it as a string.
4766 * Maybe in the future we can detect if it does
4767 * have overloading and throw an error if not.
4768 */
4769 if (!method) {
4770 if (SvTYPE(SvRV(loader)) != SVt_PVCV) {
4771 if (amagic_applies(loader,string_amg,AMGf_unary))
4772 goto treat_as_string;
4773 else {
4774 croak("Can't locate object method \"INC\", nor"
4775 " \"INCDIR\" nor string overload via"
4776 " package %" HvNAMEf_QUOTEDPREFIX " %s"
4777 " in @INC", pkg,
4778 dirsv == loader
4779 ? "in object hook"
4780 : "in object in ARRAY hook"
4781 );
4782 }
4783 }
4784 }
4785 }
4786
4787 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s",
4788 diruv, name);
4789 tryname = SvPVX_const(namesv);
4790 tryrsfp = NULL;
4791
4792 ENTER_with_name("call_INC_hook");
4793 SAVETMPS;
4794 PUSHMARK(PL_stack_sp);
4795 /* add the args array for method calls */
4796 bool add_dirsv = (method && (loader != dirsv));
4797 rpp_extend(2 + add_dirsv);
4798 rpp_push_2(
4799 /* always use the object for method calls */
4800 method ? loader : dirsv,
4801 nsv
4802 );
4803 if (add_dirsv)
4804 rpp_push_1(dirsv);
4805 if (method) {
4806 count = call_method(method, G_LIST|G_EVAL);
4807 } else {
4808 count = call_sv(loader, G_LIST|G_EVAL);
4809 }
4810
4811 if (count > 0) {
4812 int i = 0;
4813 SV *arg;
4814 SV **base = PL_stack_sp - count + 1;
4815
4816 if (is_incdir) {
4817 /* push the stringified returned items into the
4818 * incdir_av array for processing immediately
4819 * afterwards. we deliberately stringify or copy
4820 * "special" arguments, so that overload logic for
4821 * instance applies, but so that the end result is
4822 * stable. We speficially do *not* support returning
4823 * coderefs from an INCDIR call. */
4824 while (count-->0) {
4825 arg = base[i++];
4826 SvGETMAGIC(arg);
4827 if (!SvOK(arg))
4828 continue;
4829 if (SvROK(arg)) {
4830 STRLEN l;
4831 char *pv = SvPV(arg,l);
4832 arg = newSVpvn(pv,l);
4833 }
4834 else if (SvGMAGICAL(arg)) {
4835 arg = newSVsv_nomg(arg);
4836 }
4837 else {
4838 SvREFCNT_inc(arg);
4839 }
4840 av_push(incdir_av, arg);
4841 }
4842 /* We copy $INC into incdir_continue_inc_idx
4843 * so that when we finish processing the items
4844 * we just inserted into incdir_av we can continue
4845 * as though we had just finished executing the INCDIR
4846 * hook. We honour $INC here just like we would for
4847 * an INC hook, the hook might have rewritten @INC
4848 * at the same time as returning something to us.
4849 */
4850 inc_idx_sv = GvSVn(PL_incgv);
4851 incdir_continue_inc_idx = SvOK(inc_idx_sv)
4852 ? SvIV(inc_idx_sv) : -1;
4853
4854 goto done_hook;
4855 }
4856
4857 arg = base[i++];
4858
4859 if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
4860 && !isGV_with_GP(SvRV(arg))) {
4861 filter_cache = SvRV(arg);
4862
4863 if (i < count) {
4864 arg = base[i++];
4865 }
4866 }
4867
4868 if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
4869 arg = SvRV(arg);
4870 }
4871
4872 if (isGV_with_GP(arg)) {
4873 IO * const io = GvIO((const GV *)arg);
4874
4875 ++filter_has_file;
4876
4877 if (io) {
4878 tryrsfp = IoIFP(io);
4879 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
4880 PerlIO_close(IoOFP(io));
4881 }
4882 IoIFP(io) = NULL;
4883 IoOFP(io) = NULL;
4884 }
4885
4886 if (i < count) {
4887 arg = base[i++];
4888 }
4889 }
4890
4891 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
4892 filter_sub = arg;
4893 SvREFCNT_inc_simple_void_NN(filter_sub);
4894
4895 if (i < count) {
4896 filter_state = base[i];
4897 SvREFCNT_inc_simple_void(filter_state);
4898 }
4899 }
4900
4901 if (!tryrsfp && (filter_cache || filter_sub)) {
4902 tryrsfp = PerlIO_open(BIT_BUCKET,
4903 PERL_SCRIPT_MODE);
4904 }
4905 done_hook:
4906 rpp_popfree_to_NN(base - 1);
4907 } else {
4908 SV *errsv= ERRSV;
4909 if (SvTRUE(errsv) && !SvROK(errsv)) {
4910 STRLEN l;
4911 char *pv= SvPV(errsv,l);
4912 /* Heuristic to tell if this error message
4913 * includes the standard line number info:
4914 * check if the line ends in digit dot newline.
4915 * If it does then we add some extra info so
4916 * its obvious this is coming from a hook.
4917 * If it is a user generated error we try to
4918 * leave it alone. l>12 is to ensure the
4919 * other checks are in string, but also
4920 * accounts for "at ... line 1.\n" to a
4921 * certain extent. Really we should check
4922 * further, but this is good enough for back
4923 * compat I think.
4924 */
4925 if (l>=12 && pv[l-1] == '\n' && pv[l-2] == '.' && isDIGIT(pv[l-3]))
4926 sv_catpvf(errsv, "%s %s hook died--halting @INC search",
4927 method ? method : "INC",
4928 method ? "method" : "sub");
4929 croak_sv(errsv);
4930 }
4931 }
4932
4933 /* FREETMPS may free our filter_cache */
4934 SvREFCNT_inc_simple_void(filter_cache);
4935
4936 /*
4937 Let the hook override which @INC entry we visit
4938 next by setting $INC to a different value than it
4939 was before we called the hook. If they have
4940 completely rewritten the array they might want us
4941 to start traversing from the beginning, which is
4942 represented by -1. We use undef as an equivalent of
4943 -1. This can't be used as a way to call a hook
4944 twice, as we still dedupe.
4945 We have to do this before we LEAVE, as we localized
4946 $INC before we called the hook.
4947 */
4948 inc_idx_sv = GvSVn(PL_incgv);
4949 inc_idx = SvOK(inc_idx_sv) ? SvIV(inc_idx_sv) : -1;
4950
4951 FREETMPS;
4952 LEAVE_with_name("call_INC_hook");
4953
4954 /*
4955 It is possible that @INC has been replaced and that inc_ar
4956 now points at a freed AV. So we have to refresh it from
4957 the GV to be sure.
4958 */
4959 inc_ar = GvAVn(PL_incgv);
4960
4961 /* Now re-mortalize it. */
4962 sv_2mortal(filter_cache);
4963
4964 /* Adjust file name if the hook has set an %INC entry.
4965 This needs to happen after the FREETMPS above. */
4966 svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
4967 /* we have to make sure that the value is not undef
4968 * or the empty string, if it is then we should not
4969 * set tryname to it as this will break error messages.
4970 *
4971 * This might happen if an @INC hook evals the module
4972 * which was required in the first place and which
4973 * triggered the @INC hook, and that eval dies.
4974 * See https://github.com/Perl/perl5/issues/20535
4975 */
4976 if (svp && SvOK(*svp)) {
4977 STRLEN len;
4978 const char *tmp_pv = SvPV_const(*svp,len);
4979 /* we also guard against the deliberate empty string.
4980 * We do not guard against '0', if people want to set their
4981 * file name to 0 that is up to them. */
4982 if (len)
4983 tryname = tmp_pv;
4984 }
4985
4986 if (tryrsfp) {
4987 hook_sv = dirsv;
4988 break;
4989 }
4990
4991 filter_has_file = 0;
4992 filter_cache = NULL;
4993 if (filter_state) {
4994 SvREFCNT_dec_NN(filter_state);
4995 filter_state = NULL;
4996 }
4997 if (filter_sub) {
4998 SvREFCNT_dec_NN(filter_sub);
4999 filter_sub = NULL;
5000 }
5001 }
5002 else
5003 treat_as_string:
5004 if (path_searchable) {
5005 /* match against a plain @INC element (non-searchable
5006 * paths are only matched against refs in @INC) */
5007 const char *dir;
5008 STRLEN dirlen;
5009 if (SvOK(dirsv)) {
5010 dir = SvPV_nomg_const(dirsv, dirlen);
5011 } else {
5012 dir = "";
5013 dirlen = 0;
5014 }
5015
5016 if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name))
5017 continue;
5018 #ifdef VMS
5019 if ((unixdir =
5020 tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
5021 == NULL)
5022 continue;
5023 sv_setpv(namesv, unixdir);
5024 sv_catpv(namesv, unixname);
5025 #else
5026 /* The equivalent of
5027 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
5028 but without the need to parse the format string, or
5029 call strlen on either pointer, and with the correct
5030 allocation up front. */
5031 {
5032 char *tmp = SvGROW(namesv, dirlen + len + 2);
5033
5034 memcpy(tmp, dir, dirlen);
5035 tmp +=dirlen;
5036
5037 /* Avoid '<dir>//<file>' */
5038 if (!dirlen || *(tmp-1) != '/') {
5039 *tmp++ = '/';
5040 } else {
5041 /* So SvCUR_set reports the correct length below */
5042 dirlen--;
5043 }
5044
5045 /* name came from an SV, so it will have a '\0' at the
5046 end that we can copy as part of this memcpy(). */
5047 memcpy(tmp, name, len + 1);
5048
5049 SvCUR_set(namesv, dirlen + len + 1);
5050 SvPOK_on(namesv);
5051 }
5052 #endif
5053 TAINT_PROPER(op_name);
5054 tryname = SvPVX_const(namesv);
5055 tryrsfp = doopen_pm(namesv);
5056 if (tryrsfp) {
5057 if (tryname[0] == '.' && tryname[1] == '/') {
5058 ++tryname;
5059 while (*++tryname == '/') {}
5060 }
5061 break;
5062 }
5063 else if (errno == EMFILE || errno == EACCES) {
5064 /* no point in trying other paths if out of handles;
5065 * on the other hand, if we couldn't open one of the
5066 * files, then going on with the search could lead to
5067 * unexpected results; see perl #113422
5068 */
5069 break;
5070 }
5071 }
5072 }
5073 }
5074 }
5075
5076 /* at this point we've ether opened a file (tryrsfp) or set errno */
5077
5078 saved_errno = errno; /* sv_2mortal can realloc things */
5079 sv_2mortal(namesv);
5080 if (!tryrsfp) {
5081 /* we failed; croak if require() or return undef if do() */
5082 if (op_is_require) {
5083 if(saved_errno == EMFILE || saved_errno == EACCES) {
5084 /* diag_listed_as: Can't locate %s */
5085 DIE(aTHX_ "Can't locate %s: %s: %s",
5086 name, tryname, Strerror(saved_errno));
5087 } else {
5088 if (path_searchable) { /* did we lookup @INC? */
5089 SSize_t i;
5090 SV *const msg = newSVpvs_flags("", SVs_TEMP);
5091 SV *const inc = newSVpvs_flags("", SVs_TEMP);
5092 for (i = 0; i <= AvFILL(inc_checked); i++) {
5093 SV **svp= av_fetch(inc_checked, i, TRUE);
5094 if (!svp || !*svp) continue;
5095 sv_catpvs(inc, " ");
5096 sv_catsv(inc, *svp);
5097 }
5098 if (memENDPs(name, len, ".pm")) {
5099 const char *e = name + len - (sizeof(".pm") - 1);
5100 const char *c;
5101 bool utf8 = cBOOL(SvUTF8(sv));
5102
5103 /* if the filename, when converted from "Foo/Bar.pm"
5104 * form back to Foo::Bar form, makes a valid
5105 * package name (i.e. parseable by C<require
5106 * Foo::Bar>), then emit a hint.
5107 *
5108 * this loop is modelled after the one in
5109 S_parse_ident */
5110 c = name;
5111 while (c < e) {
5112 if (utf8 && isIDFIRST_utf8_safe(c, e)) {
5113 c += UTF8SKIP(c);
5114 while (c < e && isIDCONT_utf8_safe(
5115 (const U8*) c, (const U8*) e))
5116 c += UTF8SKIP(c);
5117 }
5118 else if (isWORDCHAR_A(*c)) {
5119 while (c < e && isWORDCHAR_A(*c))
5120 c++;
5121 }
5122 else if (*c == '/')
5123 c++;
5124 else
5125 break;
5126 }
5127
5128 if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) {
5129 sv_catpvs(msg, " (you may need to install the ");
5130 for (c = name; c < e; c++) {
5131 if (*c == '/') {
5132 sv_catpvs(msg, "::");
5133 }
5134 else {
5135 sv_catpvn(msg, c, 1);
5136 }
5137 }
5138 sv_catpvs(msg, " module)");
5139 }
5140 }
5141 else if (memENDs(name, len, ".h")) {
5142 sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
5143 }
5144 else if (memENDs(name, len, ".ph")) {
5145 sv_catpvs(msg, " (did you run h2ph?)");
5146 }
5147
5148 /* diag_listed_as: Can't locate %s */
5149 DIE(aTHX_
5150 "Can't locate %s in @INC%" SVf " (@INC entries checked:%" SVf ")",
5151 name, msg, inc);
5152 }
5153 }
5154 DIE(aTHX_ "Can't locate %s", name);
5155 }
5156 else {
5157 #ifdef DEFAULT_INC_EXCLUDES_DOT
5158 Stat_t st;
5159 PerlIO *io = NULL;
5160 dSAVE_ERRNO;
5161 /* the complication is to match the logic from doopen_pm() so
5162 * we don't treat do "sda1" as a previously successful "do".
5163 */
5164 bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED__DOT_IN_INC)
5165 && PerlLIO_stat(name, &st) == 0 && !S_ISDIR(st.st_mode) && !S_ISBLK(st.st_mode)
5166 && (io = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &sv)) != NULL;
5167 if (io)
5168 PerlIO_close(io);
5169
5170 RESTORE_ERRNO;
5171 if (do_warn) {
5172 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED__DOT_IN_INC),
5173 "do \"%s\" failed, '.' is no longer in @INC; "
5174 "did you mean do \"./%s\"?",
5175 name, name);
5176 }
5177 #endif
5178 CLEAR_ERRSV();
5179 rpp_replace_1_IMM_NN(&PL_sv_undef);
5180 return NORMAL;
5181 }
5182 }
5183 else
5184 SETERRNO(0, SS_NORMAL);
5185
5186 rpp_popfree_1_NN(); /* finished with sv now */
5187
5188 /* Update %INC. Assume success here to prevent recursive requirement. */
5189 /* name is never assigned to again, so len is still strlen(name) */
5190 /* Check whether a hook in @INC has already filled %INC */
5191 if (!hook_sv) {
5192 (void)hv_store(GvHVn(PL_incgv),
5193 unixname, unixlen, newSVpv(tryname,0),0);
5194 } else {
5195 /* store the hook in the sv, note we have to *copy* hook_sv,
5196 * we don't want modifications to it to change @INC - see GH #20577
5197 */
5198 SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
5199 if (!svp)
5200 (void)hv_store(GvHVn(PL_incgv),
5201 unixname, unixlen, newSVsv(hook_sv), 0 );
5202 }
5203
5204 /* Now parse the file */
5205
5206 old_savestack_ix = PL_savestack_ix;
5207 SAVECOPFILE_FREE(&PL_compiling);
5208 CopFILE_set(&PL_compiling, tryname);
5209 lex_start(NULL, tryrsfp, 0);
5210
5211 if (filter_sub || filter_cache) {
5212 /* We can use the SvPV of the filter PVIO itself as our cache, rather
5213 than hanging another SV from it. In turn, filter_add() optionally
5214 takes the SV to use as the filter (or creates a new SV if passed
5215 NULL), so simply pass in whatever value filter_cache has. */
5216 SV * const fc = filter_cache ? newSV_type(SVt_NULL) : NULL;
5217 SV *datasv;
5218 if (fc) sv_copypv(fc, filter_cache);
5219 datasv = filter_add(S_run_user_filter, fc);
5220 IoLINES(datasv) = filter_has_file;
5221 IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
5222 IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
5223 }
5224
5225 /* switch to eval mode */
5226 assert(!CATCH_GET);
5227 cx = cx_pushblock(CXt_EVAL, gimme, PL_stack_sp, old_savestack_ix);
5228 cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0));
5229
5230 SAVECOPLINE(&PL_compiling);
5231 CopLINE_set(&PL_compiling, 0);
5232
5233 if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL))
5234 op = PL_eval_start;
5235 else
5236 op = PL_op->op_next;
5237
5238 PERL_DTRACE_PROBE_FILE_LOADED(unixname);
5239
5240 return op;
5241 }
5242
5243
5244 /* also used for: pp_dofile() */
5245
PP(pp_require)5246 PP(pp_require)
5247 {
5248 /* If a suitable JMPENV catch frame isn't present, call docatch(),
5249 * which will:
5250 * - add such a frame, and
5251 * - start a new RUNOPS loop, which will (as the first op to run),
5252 * recursively call this pp function again.
5253 * The main body of this function is then executed by the inner call.
5254 */
5255 if (CATCH_GET)
5256 return docatch(Perl_pp_require);
5257
5258 {
5259 SV *sv = *PL_stack_sp;
5260 SvGETMAGIC(sv);
5261 /* these tail-called subs are responsible for popping sv off the
5262 * stack */
5263 return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE)
5264 ? S_require_version(aTHX_ sv)
5265 : S_require_file(aTHX_ sv);
5266 }
5267 }
5268
5269
5270 /* This is a op added to hold the hints hash for
5271 pp_entereval. The hash can be modified by the code
5272 being eval'ed, so we return a copy instead. */
5273
PP(pp_hintseval)5274 PP(pp_hintseval)
5275 {
5276 rpp_extend(1);
5277 rpp_push_1_norc(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
5278 return NORMAL;
5279 }
5280
5281
PP(pp_entereval)5282 PP(pp_entereval)
5283 {
5284 PERL_CONTEXT *cx;
5285 SV *sv;
5286 U8 gimme;
5287 U32 was;
5288 char tbuf[TYPE_DIGITS(long) + 12];
5289 bool saved_delete;
5290 char *tmpbuf;
5291 STRLEN len;
5292 CV* runcv;
5293 U32 seq, lex_flags;
5294 HV *saved_hh;
5295 bool bytes;
5296 I32 old_savestack_ix;
5297
5298 /* If a suitable JMPENV catch frame isn't present, call docatch(),
5299 * which will:
5300 * - add such a frame, and
5301 * - start a new RUNOPS loop, which will (as the first op to run),
5302 * recursively call this pp function again.
5303 * The main body of this function is then executed by the inner call.
5304 */
5305 if (CATCH_GET)
5306 return docatch(Perl_pp_entereval);
5307
5308 assert(!CATCH_GET);
5309
5310 gimme = GIMME_V;
5311 was = PL_breakable_sub_gen;
5312 saved_delete = FALSE;
5313 tmpbuf = tbuf;
5314 lex_flags = 0;
5315 saved_hh = NULL;
5316 bytes = PL_op->op_private & OPpEVAL_BYTES;
5317
5318 if (PL_op->op_private & OPpEVAL_HAS_HH) {
5319 saved_hh = MUTABLE_HV(rpp_pop_1_norc());
5320 }
5321 else if (PL_hints & HINT_LOCALIZE_HH || (
5322 PL_op->op_private & OPpEVAL_COPHH
5323 && PL_curcop->cop_hints & HINT_LOCALIZE_HH
5324 )) {
5325 saved_hh = cop_hints_2hv(PL_curcop, 0);
5326 hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
5327 }
5328 sv = *PL_stack_sp;
5329 if (!SvPOK(sv)) {
5330 /* make sure we've got a plain PV (no overload etc) before testing
5331 * for taint. Making a copy here is probably overkill, but better
5332 * safe than sorry */
5333 STRLEN len;
5334 const char * const p = SvPV_const(sv, len);
5335
5336 sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
5337 lex_flags |= LEX_START_COPIED;
5338
5339 if (bytes && SvUTF8(sv))
5340 SvPVbyte_force(sv, len);
5341 }
5342 else if (bytes && SvUTF8(sv)) {
5343 /* Don't modify someone else's scalar */
5344 STRLEN len;
5345 sv = newSVsv(sv);
5346 (void)sv_2mortal(sv);
5347 SvPVbyte_force(sv,len);
5348 lex_flags |= LEX_START_COPIED;
5349 }
5350
5351 TAINT_IF(SvTAINTED(sv));
5352 TAINT_PROPER("eval");
5353
5354 old_savestack_ix = PL_savestack_ix;
5355
5356 lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
5357 ? LEX_IGNORE_UTF8_HINTS
5358 : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
5359 )
5360 );
5361
5362 rpp_popfree_1_NN(); /* can free sv now */
5363
5364 /* switch to eval mode */
5365
5366 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
5367 SV * const temp_sv = sv_newmortal();
5368 Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" LINE_Tf "]",
5369 (unsigned long)++PL_evalseq,
5370 CopFILE(PL_curcop), CopLINE(PL_curcop));
5371 tmpbuf = SvPVX(temp_sv);
5372 len = SvCUR(temp_sv);
5373 }
5374 else
5375 len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
5376 SAVECOPFILE_FREE(&PL_compiling);
5377 CopFILE_set(&PL_compiling, tmpbuf+2);
5378 SAVECOPLINE(&PL_compiling);
5379 CopLINE_set(&PL_compiling, 1);
5380 /* special case: an eval '' executed within the DB package gets lexically
5381 * placed in the first non-DB CV rather than the current CV - this
5382 * allows the debugger to execute code, find lexicals etc, in the
5383 * scope of the code being debugged. Passing &seq gets find_runcv
5384 * to do the dirty work for us */
5385 runcv = find_runcv(&seq);
5386
5387 assert(!CATCH_GET);
5388 cx = cx_pushblock((CXt_EVAL|CXp_REAL),
5389 gimme, PL_stack_sp, old_savestack_ix);
5390 cx_pusheval(cx, PL_op->op_next, NULL);
5391
5392 /* prepare to compile string */
5393
5394 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
5395 save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
5396 else {
5397 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
5398 deleting the eval's FILEGV from the stash before gv_check() runs
5399 (i.e. before run-time proper). To work around the coredump that
5400 ensues, we always turn GvMULTI_on for any globals that were
5401 introduced within evals. See force_ident(). GSAR 96-10-12 */
5402 char *const safestr = savepvn(tmpbuf, len);
5403 SAVEDELETE(PL_defstash, safestr, len);
5404 saved_delete = TRUE;
5405 }
5406
5407 if (doeval_compile(gimme, runcv, seq, saved_hh)) {
5408 if (was != PL_breakable_sub_gen /* Some subs defined here. */
5409 ? PERLDB_LINE_OR_SAVESRC
5410 : PERLDB_SAVESRC_NOSUBS) {
5411 /* Retain the filegv we created. */
5412 } else if (!saved_delete) {
5413 char *const safestr = savepvn(tmpbuf, len);
5414 SAVEDELETE(PL_defstash, safestr, len);
5415 }
5416 return PL_eval_start;
5417 } else {
5418 /* We have already left the scope set up earlier thanks to the LEAVE
5419 in doeval_compile(). */
5420 if (was != PL_breakable_sub_gen /* Some subs defined here. */
5421 ? PERLDB_LINE_OR_SAVESRC
5422 : PERLDB_SAVESRC_INVALID) {
5423 /* Retain the filegv we created. */
5424 } else if (!saved_delete) {
5425 (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
5426 }
5427 if (PL_op->op_private & OPpEVAL_EVALSV)
5428 /* signal compiletime failure to our eval_sv() caller */
5429 *++PL_stack_sp = NULL;
5430 return PL_op->op_next;
5431 }
5432 }
5433
5434
5435 /* also tail-called by pp_return */
5436
PP(pp_leaveeval)5437 PP(pp_leaveeval)
5438 {
5439 SV **oldsp;
5440 U8 gimme;
5441 PERL_CONTEXT *cx;
5442 OP *retop;
5443 int failed;
5444 bool override_return = FALSE; /* is feature 'module_true' in effect? */
5445 CV *evalcv;
5446 bool keep;
5447
5448 PERL_ASYNC_CHECK();
5449
5450 cx = CX_CUR();
5451 assert(CxTYPE(cx) == CXt_EVAL);
5452
5453 oldsp = PL_stack_base + cx->blk_oldsp;
5454 gimme = cx->blk_gimme;
5455
5456 bool is_require= CxOLD_OP_TYPE(cx) == OP_REQUIRE;
5457 if (is_require) {
5458 /* We are in an require. Check if use feature 'module_true' is enabled,
5459 * and if so later on correct any returns from the require. */
5460
5461 /* we might be called for an OP_LEAVEEVAL or OP_RETURN opcode
5462 * and the parse tree will look different for either case.
5463 * so find the right op to check later */
5464 if (OP_TYPE_IS_OR_WAS(PL_op, OP_RETURN)) {
5465 if (PL_op->op_flags & OPf_SPECIAL)
5466 override_return = true;
5467 }
5468 else if ((PL_op->op_flags & OPf_KIDS) && OP_TYPE_IS_OR_WAS(PL_op, OP_LEAVEEVAL)){
5469 COP *old_pl_curcop = PL_curcop;
5470 OP *check = cUNOPx(PL_op)->op_first;
5471
5472 /* ok, we found something to check, we need to scan through
5473 * it and find the last OP_NEXTSTATE it contains and then read the
5474 * feature state out of the COP data it contains.
5475 */
5476 if (check) {
5477 if (!OP_TYPE_IS(check,OP_STUB)) {
5478 const OP *kid = cLISTOPx(check)->op_first;
5479 const OP *last_state = NULL;
5480
5481 for (; kid; kid = OpSIBLING(kid)) {
5482 if (
5483 OP_TYPE_IS_OR_WAS(kid, OP_NEXTSTATE)
5484 || OP_TYPE_IS_OR_WAS(kid, OP_DBSTATE)
5485 ){
5486 last_state = kid;
5487 }
5488 }
5489 if (last_state) {
5490 PL_curcop = cCOPx(last_state);
5491 if (FEATURE_MODULE_TRUE_IS_ENABLED) {
5492 override_return = TRUE;
5493 }
5494 } else {
5495 NOT_REACHED; /* NOTREACHED */
5496 }
5497 }
5498 } else {
5499 NOT_REACHED; /* NOTREACHED */
5500 }
5501 PL_curcop = old_pl_curcop;
5502 }
5503 }
5504
5505 /* we might override this later if 'module_true' is enabled */
5506 failed = is_require
5507 && !(gimme == G_SCALAR
5508 ? SvTRUE_NN(*PL_stack_sp)
5509 : PL_stack_sp > oldsp);
5510
5511 if (gimme == G_VOID) {
5512 rpp_popfree_to(oldsp);
5513 /* free now to avoid late-called destructors clobbering $@ */
5514 FREETMPS;
5515 }
5516 else
5517 leave_adjust_stacks(oldsp, oldsp, gimme, 0);
5518
5519 /* the cx_popeval does a leavescope, which frees the optree associated
5520 * with eval, which if it frees the nextstate associated with
5521 * PL_curcop, sets PL_curcop to NULL. Which can mess up freeing a
5522 * regex when running under 'use re Debug' because it needs PL_curcop
5523 * to get the current hints. So restore it early.
5524 */
5525 PL_curcop = cx->blk_oldcop;
5526
5527 /* grab this value before cx_popeval restores the old PL_in_eval */
5528 keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
5529 retop = cx->blk_eval.retop;
5530 evalcv = cx->blk_eval.cv;
5531 #ifdef DEBUGGING
5532 assert(CvDEPTH(evalcv) == 1);
5533 #endif
5534 CvDEPTH(evalcv) = 0;
5535
5536 if (override_return) {
5537 /* make sure that we use a standard return when feature 'module_load'
5538 * is enabled. Returns from require are problematic (consider what happens
5539 * when it is called twice) */
5540 if (gimme == G_SCALAR)
5541 rpp_replace_1_IMM_NN(&PL_sv_yes);
5542 assert(gimme == G_VOID || gimme == G_SCALAR);
5543 failed = 0;
5544 }
5545
5546 /* pop the CXt_EVAL, and if a require failed, croak */
5547 S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
5548
5549 if (!keep)
5550 CLEAR_ERRSV();
5551
5552 return retop;
5553 }
5554
5555 /* Ops that implement try/catch syntax
5556 * Note the asymmetry here:
5557 * pp_entertrycatch does two pushblocks
5558 * pp_leavetrycatch pops only the outer one; the inner one is popped by
5559 * pp_poptry or by stack-unwind of die within the try block
5560 */
5561
PP(pp_entertrycatch)5562 PP(pp_entertrycatch)
5563 {
5564 PERL_CONTEXT *cx;
5565 const U8 gimme = GIMME_V;
5566
5567 /* If a suitable JMPENV catch frame isn't present, call docatch(),
5568 * which will:
5569 * - add such a frame, and
5570 * - start a new RUNOPS loop, which will (as the first op to run),
5571 * recursively call this pp function again.
5572 * The main body of this function is then executed by the inner call.
5573 */
5574 if (CATCH_GET)
5575 return docatch(Perl_pp_entertrycatch);
5576
5577 assert(!CATCH_GET);
5578
5579 Perl_pp_enter(aTHX); /* performs cx_pushblock(CXt_BLOCK, ...) */
5580
5581 save_scalar(PL_errgv);
5582 CLEAR_ERRSV();
5583
5584 cx = cx_pushblock((CXt_EVAL|CXp_EVALBLOCK|CXp_TRY), gimme,
5585 PL_stack_sp, PL_savestack_ix);
5586 cx_pushtry(cx, cLOGOP->op_other);
5587
5588 PL_in_eval = EVAL_INEVAL;
5589
5590 return NORMAL;
5591 }
5592
PP(pp_leavetrycatch)5593 PP(pp_leavetrycatch)
5594 {
5595 /* leavetrycatch is leave */
5596 return Perl_pp_leave(aTHX);
5597 }
5598
PP(pp_poptry)5599 PP(pp_poptry)
5600 {
5601 /* poptry is leavetry */
5602 return Perl_pp_leavetry(aTHX);
5603 }
5604
PP(pp_catch)5605 PP(pp_catch)
5606 {
5607 dTARGET;
5608
5609 save_clearsv(&(PAD_SVl(PL_op->op_targ)));
5610 sv_setsv(TARG, ERRSV);
5611 CLEAR_ERRSV();
5612
5613 return cLOGOP->op_other;
5614 }
5615
5616 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
5617 close to the related Perl_create_eval_scope. */
5618 void
Perl_delete_eval_scope(pTHX)5619 Perl_delete_eval_scope(pTHX)
5620 {
5621 PERL_CONTEXT *cx;
5622
5623 cx = CX_CUR();
5624 CX_LEAVE_SCOPE(cx);
5625 cx_popeval(cx);
5626 cx_popblock(cx);
5627 CX_POP(cx);
5628 }
5629
5630 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
5631 also needed by Perl_fold_constants. */
5632 void
Perl_create_eval_scope(pTHX_ OP * retop,SV ** sp,U32 flags)5633 Perl_create_eval_scope(pTHX_ OP *retop, SV **sp, U32 flags)
5634 {
5635 PERL_CONTEXT *cx;
5636 const U8 gimme = GIMME_V;
5637
5638 PERL_ARGS_ASSERT_CREATE_EVAL_SCOPE;
5639
5640 cx = cx_pushblock((CXt_EVAL|CXp_EVALBLOCK), gimme,
5641 sp, PL_savestack_ix);
5642 cx_pusheval(cx, retop, NULL);
5643
5644 PL_in_eval = EVAL_INEVAL;
5645 if (flags & G_KEEPERR)
5646 PL_in_eval |= EVAL_KEEPERR;
5647 else
5648 CLEAR_ERRSV();
5649 if (flags & G_FAKINGEVAL) {
5650 PL_eval_root = PL_op; /* Only needed so that goto works right. */
5651 }
5652 }
5653
PP(pp_entertry)5654 PP(pp_entertry)
5655 {
5656 OP *retop = cLOGOP->op_other->op_next;
5657
5658 /* If a suitable JMPENV catch frame isn't present, call docatch(),
5659 * which will:
5660 * - add such a frame, and
5661 * - start a new RUNOPS loop, which will (as the first op to run),
5662 * recursively call this pp function again.
5663 * The main body of this function is then executed by the inner call.
5664 */
5665 if (CATCH_GET)
5666 return docatch(Perl_pp_entertry);
5667
5668 assert(!CATCH_GET);
5669
5670 create_eval_scope(retop, PL_stack_sp, 0);
5671
5672 return PL_op->op_next;
5673 }
5674
5675
5676 /* also tail-called by pp_return */
5677
PP(pp_leavetry)5678 PP(pp_leavetry)
5679 {
5680 SV **oldsp;
5681 U8 gimme;
5682 PERL_CONTEXT *cx;
5683 OP *retop;
5684
5685 PERL_ASYNC_CHECK();
5686
5687 cx = CX_CUR();
5688 assert(CxTYPE(cx) == CXt_EVAL);
5689 oldsp = PL_stack_base + cx->blk_oldsp;
5690 gimme = cx->blk_gimme;
5691
5692 if (gimme == G_VOID) {
5693 rpp_popfree_to_NN(oldsp);
5694 /* free now to avoid late-called destructors clobbering $@ */
5695 FREETMPS;
5696 }
5697 else
5698 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5699 CX_LEAVE_SCOPE(cx);
5700 cx_popeval(cx);
5701 cx_popblock(cx);
5702 retop = CxTRY(cx) ? PL_op->op_next : cx->blk_eval.retop;
5703 CX_POP(cx);
5704
5705 CLEAR_ERRSV();
5706 return retop;
5707 }
5708
PP(pp_entergiven)5709 PP(pp_entergiven)
5710 {
5711 PERL_CONTEXT *cx;
5712 const U8 gimme = GIMME_V;
5713 SV *origsv = DEFSV;
5714
5715 assert(!PL_op->op_targ); /* used to be set for lexical $_ */
5716 GvSV(PL_defgv) = rpp_pop_1_norc();
5717
5718 cx = cx_pushblock(CXt_GIVEN, gimme, PL_stack_sp, PL_savestack_ix);
5719 cx_pushgiven(cx, origsv);
5720
5721 return NORMAL;
5722 }
5723
PP(pp_leavegiven)5724 PP(pp_leavegiven)
5725 {
5726 PERL_CONTEXT *cx;
5727 U8 gimme;
5728 SV **oldsp;
5729 PERL_UNUSED_CONTEXT;
5730
5731 cx = CX_CUR();
5732 assert(CxTYPE(cx) == CXt_GIVEN);
5733 oldsp = PL_stack_base + cx->blk_oldsp;
5734 gimme = cx->blk_gimme;
5735
5736 if (gimme == G_VOID)
5737 rpp_popfree_to_NN(oldsp);
5738 else
5739 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
5740
5741 CX_LEAVE_SCOPE(cx);
5742 cx_popgiven(cx);
5743 cx_popblock(cx);
5744 CX_POP(cx);
5745
5746 return NORMAL;
5747 }
5748
5749 /* Helper routines used by pp_smartmatch */
5750 STATIC PMOP *
S_make_matcher(pTHX_ REGEXP * re)5751 S_make_matcher(pTHX_ REGEXP *re)
5752 {
5753 PMOP *matcher = cPMOPx(newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED));
5754
5755 PERL_ARGS_ASSERT_MAKE_MATCHER;
5756
5757 PM_SETRE(matcher, ReREFCNT_inc(re));
5758
5759 SAVEFREEOP((OP *) matcher);
5760 ENTER_with_name("matcher"); SAVETMPS;
5761 SAVEOP();
5762 return matcher;
5763 }
5764
5765 STATIC bool
S_matcher_matches_sv(pTHX_ PMOP * matcher,SV * sv)5766 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
5767 {
5768 bool result;
5769
5770 PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
5771
5772 PL_op = (OP *) matcher;
5773 rpp_xpush_1(sv);
5774 (void) Perl_pp_match(aTHX);
5775 result = SvTRUEx(*PL_stack_sp);
5776 rpp_popfree_1_NN();
5777 return result;
5778 }
5779
5780 STATIC void
S_destroy_matcher(pTHX_ PMOP * matcher)5781 S_destroy_matcher(pTHX_ PMOP *matcher)
5782 {
5783 PERL_ARGS_ASSERT_DESTROY_MATCHER;
5784 PERL_UNUSED_ARG(matcher);
5785
5786 FREETMPS;
5787 LEAVE_with_name("matcher");
5788 }
5789
5790
5791 /* Do a smart match */
PP(pp_smartmatch)5792 PP(pp_smartmatch)
5793 {
5794 DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
5795 return do_smartmatch(NULL, NULL, 0);
5796 }
5797
5798
5799 /* This version of do_smartmatch() implements the
5800 * table of smart matches that is found in perlsyn.
5801 */
5802 STATIC OP *
S_do_smartmatch(pTHX_ HV * seen_this,HV * seen_other,const bool copied)5803 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
5804 {
5805 bool object_on_left = FALSE;
5806 SV *e = PL_stack_sp[0]; /* e is for 'expression' */
5807 SV *d = PL_stack_sp[-1]; /* d is for 'default', as in PL_defgv */
5808
5809 /* Take care only to invoke mg_get() once for each argument.
5810 * Currently we do this by copying the SV if it's magical. */
5811 if (d) {
5812 if (!copied && SvGMAGICAL(d))
5813 d = sv_mortalcopy(d);
5814 }
5815 else
5816 d = &PL_sv_undef;
5817
5818 assert(e);
5819 if (SvGMAGICAL(e))
5820 e = sv_mortalcopy(e);
5821
5822 /* First of all, handle overload magic of the rightmost argument */
5823 if (SvAMAGIC(e)) {
5824 SV * tmpsv;
5825 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
5826 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
5827
5828 tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
5829 if (tmpsv) {
5830 rpp_replace_2_1_NN(tmpsv);
5831 return NORMAL;
5832 }
5833 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n"));
5834 }
5835
5836 /* ~~ undef */
5837 if (!SvOK(e)) {
5838 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n"));
5839 if (SvOK(d))
5840 goto ret_no;
5841 else
5842 goto ret_yes;
5843 }
5844
5845 if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
5846 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
5847 Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
5848 }
5849 if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
5850 object_on_left = TRUE;
5851
5852 /* ~~ sub */
5853 if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
5854 if (object_on_left) {
5855 goto sm_any_sub; /* Treat objects like scalars */
5856 }
5857 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5858 /* Test sub truth for each key */
5859 HE *he;
5860 bool andedresults = TRUE;
5861 HV *hv = (HV*) SvRV(d);
5862 I32 numkeys = hv_iterinit(hv);
5863 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n"));
5864 if (numkeys == 0)
5865 goto ret_yes;
5866 while ( (he = hv_iternext(hv)) ) {
5867 DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n"));
5868 ENTER_with_name("smartmatch_hash_key_test");
5869 SAVETMPS;
5870 PUSHMARK(PL_stack_sp);
5871 rpp_xpush_1(hv_iterkeysv(he));
5872 (void)call_sv(e, G_SCALAR);
5873 andedresults = SvTRUEx(PL_stack_sp[0]) && andedresults;
5874 rpp_popfree_1_NN();
5875 FREETMPS;
5876 LEAVE_with_name("smartmatch_hash_key_test");
5877 }
5878 if (andedresults)
5879 goto ret_yes;
5880 else
5881 goto ret_no;
5882 }
5883 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5884 /* Test sub truth for each element */
5885 Size_t i;
5886 bool andedresults = TRUE;
5887 AV *av = (AV*) SvRV(d);
5888 const Size_t len = av_count(av);
5889 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
5890 if (len == 0)
5891 goto ret_yes;
5892 for (i = 0; i < len; ++i) {
5893 SV * const * const svp = av_fetch(av, i, FALSE);
5894 DEBUG_M(Perl_deb(aTHX_ " testing array element...\n"));
5895 ENTER_with_name("smartmatch_array_elem_test");
5896 SAVETMPS;
5897 PUSHMARK(PL_stack_sp);
5898 if (svp)
5899 rpp_xpush_1(*svp);
5900 (void)call_sv(e, G_SCALAR);
5901 andedresults = SvTRUEx(PL_stack_sp[0]) && andedresults;
5902 rpp_popfree_1_NN();
5903 FREETMPS;
5904 LEAVE_with_name("smartmatch_array_elem_test");
5905 }
5906 if (andedresults)
5907 goto ret_yes;
5908 else
5909 goto ret_no;
5910 }
5911 else {
5912 sm_any_sub:
5913 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n"));
5914 ENTER_with_name("smartmatch_coderef");
5915 PUSHMARK(PL_stack_sp);
5916 rpp_xpush_1(d);
5917 (void)call_sv(e, G_SCALAR);
5918 LEAVE_with_name("smartmatch_coderef");
5919 SV *retsv = *PL_stack_sp--;
5920 rpp_replace_2_1(retsv);
5921 #ifdef PERL_RC_STACK
5922 SvREFCNT_dec(retsv);
5923 #endif
5924 return NORMAL;
5925 }
5926 }
5927 /* ~~ %hash */
5928 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
5929 if (object_on_left) {
5930 goto sm_any_hash; /* Treat objects like scalars */
5931 }
5932 else if (!SvOK(d)) {
5933 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n"));
5934 goto ret_no;
5935 }
5936 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
5937 /* Check that the key-sets are identical */
5938 HE *he;
5939 HV *other_hv = MUTABLE_HV(SvRV(d));
5940 bool tied;
5941 bool other_tied;
5942 U32 this_key_count = 0,
5943 other_key_count = 0;
5944 HV *hv = MUTABLE_HV(SvRV(e));
5945
5946 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
5947 /* Tied hashes don't know how many keys they have. */
5948 tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
5949 other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
5950 if (!tied ) {
5951 if(other_tied) {
5952 /* swap HV sides */
5953 HV * const temp = other_hv;
5954 other_hv = hv;
5955 hv = temp;
5956 tied = TRUE;
5957 other_tied = FALSE;
5958 }
5959 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
5960 goto ret_no;
5961 }
5962
5963 /* The hashes have the same number of keys, so it suffices
5964 to check that one is a subset of the other. */
5965 (void) hv_iterinit(hv);
5966 while ( (he = hv_iternext(hv)) ) {
5967 SV *key = hv_iterkeysv(he);
5968
5969 DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n"));
5970 ++ this_key_count;
5971
5972 if(!hv_exists_ent(other_hv, key, 0)) {
5973 (void) hv_iterinit(hv); /* reset iterator */
5974 goto ret_no;
5975 }
5976 }
5977
5978 if (other_tied) {
5979 (void) hv_iterinit(other_hv);
5980 while ( hv_iternext(other_hv) )
5981 ++other_key_count;
5982 }
5983 else
5984 other_key_count = HvUSEDKEYS(other_hv);
5985
5986 if (this_key_count != other_key_count)
5987 goto ret_no;
5988 else
5989 goto ret_yes;
5990 }
5991 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
5992 AV * const other_av = MUTABLE_AV(SvRV(d));
5993 const Size_t other_len = av_count(other_av);
5994 Size_t i;
5995 HV *hv = MUTABLE_HV(SvRV(e));
5996
5997 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n"));
5998 for (i = 0; i < other_len; ++i) {
5999 SV ** const svp = av_fetch(other_av, i, FALSE);
6000 DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n"));
6001 if (svp) { /* ??? When can this not happen? */
6002 if (hv_exists_ent(hv, *svp, 0))
6003 goto ret_yes;
6004 }
6005 }
6006 goto ret_no;
6007 }
6008 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
6009 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n"));
6010 sm_regex_hash:
6011 {
6012 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
6013 HE *he;
6014 HV *hv = MUTABLE_HV(SvRV(e));
6015
6016 (void) hv_iterinit(hv);
6017 while ( (he = hv_iternext(hv)) ) {
6018 DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
6019 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
6020 (void) hv_iterinit(hv);
6021 destroy_matcher(matcher);
6022 goto ret_yes;
6023 }
6024 }
6025 destroy_matcher(matcher);
6026 goto ret_no;
6027 }
6028 }
6029 else {
6030 sm_any_hash:
6031 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n"));
6032 if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
6033 goto ret_yes;
6034 else
6035 goto ret_no;
6036 }
6037 }
6038 /* ~~ @array */
6039 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
6040 if (object_on_left) {
6041 goto sm_any_array; /* Treat objects like scalars */
6042 }
6043 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
6044 AV * const other_av = MUTABLE_AV(SvRV(e));
6045 const Size_t other_len = av_count(other_av);
6046 Size_t i;
6047
6048 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
6049 for (i = 0; i < other_len; ++i) {
6050 SV ** const svp = av_fetch(other_av, i, FALSE);
6051
6052 DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n"));
6053 if (svp) { /* ??? When can this not happen? */
6054 if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
6055 goto ret_yes;
6056 }
6057 }
6058 goto ret_no;
6059 }
6060 if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
6061 AV *other_av = MUTABLE_AV(SvRV(d));
6062 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
6063 if (av_count(MUTABLE_AV(SvRV(e))) != av_count(other_av))
6064 goto ret_no;
6065 else {
6066 Size_t i;
6067 const Size_t other_len = av_count(other_av);
6068
6069 if (NULL == seen_this) {
6070 seen_this = (HV*)newSV_type_mortal(SVt_PVHV);
6071 }
6072 if (NULL == seen_other) {
6073 seen_other = (HV*)newSV_type_mortal(SVt_PVHV);
6074 }
6075 for(i = 0; i < other_len; ++i) {
6076 SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
6077 SV * const * const other_elem = av_fetch(other_av, i, FALSE);
6078
6079 if (!this_elem || !other_elem) {
6080 if ((this_elem && SvOK(*this_elem))
6081 || (other_elem && SvOK(*other_elem)))
6082 goto ret_no;
6083 }
6084 else if (hv_exists_ent(seen_this,
6085 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
6086 hv_exists_ent(seen_other,
6087 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
6088 {
6089 if (*this_elem != *other_elem)
6090 goto ret_no;
6091 }
6092 else {
6093 (void)hv_store_ent(seen_this,
6094 sv_2mortal(newSViv(PTR2IV(*this_elem))),
6095 &PL_sv_undef, 0);
6096 (void)hv_store_ent(seen_other,
6097 sv_2mortal(newSViv(PTR2IV(*other_elem))),
6098 &PL_sv_undef, 0);
6099 rpp_xpush_2(*other_elem, *this_elem);
6100 DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n"));
6101 (void) do_smartmatch(seen_this, seen_other, 0);
6102 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
6103
6104 bool ok = SvTRUEx(PL_stack_sp[0]);
6105 rpp_popfree_1_NN();
6106 if (!ok)
6107 goto ret_no;
6108 }
6109 }
6110 goto ret_yes;
6111 }
6112 }
6113 else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
6114 DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n"));
6115 sm_regex_array:
6116 {
6117 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
6118 const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
6119 Size_t i;
6120
6121 for(i = 0; i < this_len; ++i) {
6122 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
6123 DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
6124 if (svp && matcher_matches_sv(matcher, *svp)) {
6125 destroy_matcher(matcher);
6126 goto ret_yes;
6127 }
6128 }
6129 destroy_matcher(matcher);
6130 goto ret_no;
6131 }
6132 }
6133 else if (!SvOK(d)) {
6134 /* undef ~~ array */
6135 const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
6136 Size_t i;
6137
6138 DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
6139 for (i = 0; i < this_len; ++i) {
6140 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
6141 DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n"));
6142 if (!svp || !SvOK(*svp))
6143 goto ret_yes;
6144 }
6145 goto ret_no;
6146 }
6147 else {
6148 sm_any_array:
6149 {
6150 Size_t i;
6151 const Size_t this_len = av_count(MUTABLE_AV(SvRV(e)));
6152
6153 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
6154 for (i = 0; i < this_len; ++i) {
6155 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
6156 if (!svp)
6157 continue;
6158
6159 rpp_xpush_2(d, *svp);
6160 /* infinite recursion isn't supposed to happen here */
6161 DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n"));
6162 (void) do_smartmatch(NULL, NULL, 1);
6163 DEBUG_M(Perl_deb(aTHX_ " recursion finished\n"));
6164 bool ok = SvTRUEx(PL_stack_sp[0]);
6165 rpp_popfree_1_NN();
6166 if (ok)
6167 goto ret_yes;
6168 }
6169 goto ret_no;
6170 }
6171 }
6172 }
6173 /* ~~ qr// */
6174 else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
6175 if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
6176 SV *t = d; d = e; e = t;
6177 DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n"));
6178 goto sm_regex_hash;
6179 }
6180 else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
6181 SV *t = d; d = e; e = t;
6182 DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n"));
6183 goto sm_regex_array;
6184 }
6185 else {
6186 PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
6187 bool result;
6188
6189 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
6190 result = matcher_matches_sv(matcher, d);
6191 destroy_matcher(matcher);
6192 if (result)
6193 goto ret_yes;
6194 else
6195 goto ret_no;
6196 }
6197 }
6198 /* ~~ scalar */
6199 /* See if there is overload magic on left */
6200 else if (object_on_left && SvAMAGIC(d)) {
6201 SV *tmpsv;
6202 DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n"));
6203 DEBUG_M(Perl_deb(aTHX_ " attempting overload\n"));
6204 tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
6205 if (tmpsv) {
6206 rpp_replace_2_1_NN(tmpsv);
6207 return NORMAL;
6208 }
6209
6210 DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n"));
6211 goto sm_any_scalar;
6212 }
6213 else if (!SvOK(d)) {
6214 /* undef ~~ scalar ; we already know that the scalar is SvOK */
6215 DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n"));
6216 goto ret_no;
6217 }
6218 else
6219 sm_any_scalar:
6220 if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
6221 DEBUG_M(if (SvNIOK(e))
6222 Perl_deb(aTHX_ " applying rule Any-Num\n");
6223 else
6224 Perl_deb(aTHX_ " applying rule Num-numish\n");
6225 );
6226 /* numeric comparison */
6227 rpp_xpush_2(d, e);
6228 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
6229 (void) Perl_pp_i_eq(aTHX);
6230 else
6231 (void) Perl_pp_eq(aTHX);
6232 bool ok = SvTRUEx(PL_stack_sp[0]);
6233 rpp_popfree_1_NN();
6234 if (ok)
6235 goto ret_yes;
6236 else
6237 goto ret_no;
6238 }
6239
6240 /* As a last resort, use string comparison */
6241 DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n"));
6242 rpp_xpush_2(d, e);
6243 Perl_pp_seq(aTHX);
6244 {
6245 bool ok = SvTRUEx(PL_stack_sp[0]);
6246 rpp_popfree_1_NN();
6247 if (ok)
6248 goto ret_yes;
6249 else
6250 goto ret_no;
6251 }
6252
6253 ret_no:
6254 rpp_replace_2_IMM_NN(&PL_sv_no);
6255 return NORMAL;
6256
6257 ret_yes:
6258 rpp_replace_2_IMM_NN(&PL_sv_yes);
6259 return NORMAL;
6260 }
6261
6262
PP(pp_enterwhen)6263 PP(pp_enterwhen)
6264 {
6265 PERL_CONTEXT *cx;
6266 const U8 gimme = GIMME_V;
6267
6268 /* This is essentially an optimization: if the match
6269 fails, we don't want to push a context and then
6270 pop it again right away, so we skip straight
6271 to the op that follows the leavewhen.
6272 */
6273 if (!(PL_op->op_flags & OPf_SPECIAL)) { /* SPECIAL implies no condition */
6274 bool tr = SvTRUEx(*PL_stack_sp);
6275 rpp_popfree_1_NN();
6276 if (!tr) {
6277 if (gimme == G_SCALAR)
6278 rpp_push_IMM(&PL_sv_undef);
6279 return cLOGOP->op_other->op_next;
6280 }
6281 }
6282
6283 cx = cx_pushblock(CXt_WHEN, gimme, PL_stack_sp, PL_savestack_ix);
6284 cx_pushwhen(cx);
6285
6286 return NORMAL;
6287 }
6288
PP(pp_leavewhen)6289 PP(pp_leavewhen)
6290 {
6291 I32 cxix;
6292 PERL_CONTEXT *cx;
6293 U8 gimme;
6294 SV **oldsp;
6295
6296 cx = CX_CUR();
6297 assert(CxTYPE(cx) == CXt_WHEN);
6298 gimme = cx->blk_gimme;
6299
6300 cxix = dopoptogivenfor(cxstack_ix);
6301 if (cxix < 0)
6302 /* diag_listed_as: Can't "when" outside a topicalizer */
6303 DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
6304 PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
6305
6306 oldsp = PL_stack_base + cx->blk_oldsp;
6307 if (gimme == G_VOID)
6308 rpp_popfree_to_NN(oldsp);
6309 else
6310 leave_adjust_stacks(oldsp, oldsp, gimme, 1);
6311
6312 /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
6313 assert(cxix < cxstack_ix);
6314 dounwind(cxix);
6315
6316 cx = &cxstack[cxix];
6317
6318 if (CxFOREACH(cx)) {
6319 /* emulate pp_next. Note that any stack(s) cleanup will be
6320 * done by the pp_unstack which op_nextop should point to */
6321 cx = CX_CUR();
6322 cx_topblock(cx);
6323 PL_curcop = cx->blk_oldcop;
6324 return cx->blk_loop.my_op->op_nextop;
6325 }
6326 else {
6327 PERL_ASYNC_CHECK();
6328 assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
6329 return cx->blk_givwhen.leave_op;
6330 }
6331 }
6332
PP(pp_continue)6333 PP(pp_continue)
6334 {
6335 I32 cxix;
6336 PERL_CONTEXT *cx;
6337 OP *nextop;
6338
6339 cxix = dopoptowhen(cxstack_ix);
6340 if (cxix < 0)
6341 DIE(aTHX_ "Can't \"continue\" outside a when block");
6342
6343 if (cxix < cxstack_ix)
6344 dounwind(cxix);
6345
6346 cx = CX_CUR();
6347 assert(CxTYPE(cx) == CXt_WHEN);
6348 rpp_popfree_to_NN(PL_stack_base + cx->blk_oldsp);
6349 CX_LEAVE_SCOPE(cx);
6350 cx_popwhen(cx);
6351 cx_popblock(cx);
6352 nextop = cx->blk_givwhen.leave_op->op_next;
6353 CX_POP(cx);
6354
6355 return nextop;
6356 }
6357
PP(pp_break)6358 PP(pp_break)
6359 {
6360 I32 cxix;
6361 PERL_CONTEXT *cx;
6362
6363 cxix = dopoptogivenfor(cxstack_ix);
6364 if (cxix < 0)
6365 DIE(aTHX_ "Can't \"break\" outside a given block");
6366
6367 cx = &cxstack[cxix];
6368 if (CxFOREACH(cx))
6369 DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
6370
6371 if (cxix < cxstack_ix)
6372 dounwind(cxix);
6373
6374 /* Restore the sp at the time we entered the given block */
6375 cx = CX_CUR();
6376 rpp_popfree_to_NN(PL_stack_base + cx->blk_oldsp);
6377
6378 return cx->blk_givwhen.leave_op;
6379 }
6380
6381 static void
_invoke_defer_block(pTHX_ U8 type,void * _arg)6382 _invoke_defer_block(pTHX_ U8 type, void *_arg)
6383 {
6384 OP *start = (OP *)_arg;
6385 #ifdef DEBUGGING
6386 I32 was_cxstack_ix = cxstack_ix;
6387 #endif
6388
6389 cx_pushblock(type, G_VOID, PL_stack_sp, PL_savestack_ix);
6390 ENTER;
6391 SAVETMPS;
6392
6393 SAVEOP();
6394 PL_op = start;
6395
6396 CALLRUNOPS(aTHX);
6397
6398 FREETMPS;
6399 LEAVE;
6400
6401 {
6402 PERL_CONTEXT *cx;
6403
6404 cx = CX_CUR();
6405 assert(CxTYPE(cx) == CXt_DEFER);
6406
6407 /* since we're called during a scope cleanup (including after
6408 * a croak), theere's no guarantee thr stack is currently
6409 * ref-counted */
6410 #ifdef PERL_RC_STACK
6411 if (rpp_stack_is_rc())
6412 rpp_popfree_to_NN(PL_stack_base + cx->blk_oldsp);
6413 else
6414 #endif
6415 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
6416
6417
6418 CX_LEAVE_SCOPE(cx);
6419 cx_popblock(cx);
6420 CX_POP(cx);
6421 }
6422
6423 assert(cxstack_ix == was_cxstack_ix);
6424 }
6425
6426 static void
invoke_defer_block(pTHX_ void * _arg)6427 invoke_defer_block(pTHX_ void *_arg)
6428 {
6429 _invoke_defer_block(aTHX_ CXt_DEFER, _arg);
6430 }
6431
6432 static void
invoke_finally_block(pTHX_ void * _arg)6433 invoke_finally_block(pTHX_ void *_arg)
6434 {
6435 _invoke_defer_block(aTHX_ CXt_DEFER|CXp_FINALLY, _arg);
6436 }
6437
PP(pp_pushdefer)6438 PP(pp_pushdefer)
6439 {
6440 if(PL_op->op_private & OPpDEFER_FINALLY)
6441 SAVEDESTRUCTOR_X(invoke_finally_block, cLOGOP->op_other);
6442 else
6443 SAVEDESTRUCTOR_X(invoke_defer_block, cLOGOP->op_other);
6444
6445 return NORMAL;
6446 }
6447
6448 static MAGIC *
S_doparseform(pTHX_ SV * sv)6449 S_doparseform(pTHX_ SV *sv)
6450 {
6451 STRLEN len;
6452 char *s = SvPV(sv, len);
6453 char *send;
6454 char *base = NULL; /* start of current field */
6455 I32 skipspaces = 0; /* number of contiguous spaces seen */
6456 bool noblank = FALSE; /* ~ or ~~ seen on this line */
6457 bool repeat = FALSE; /* ~~ seen on this line */
6458 bool postspace = FALSE; /* a text field may need right padding */
6459 U32 *fops;
6460 U32 *fpc;
6461 U32 *linepc = NULL; /* position of last FF_LINEMARK */
6462 I32 arg;
6463 bool ischop; /* it's a ^ rather than a @ */
6464 bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
6465 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
6466 MAGIC *mg = NULL;
6467 SV *sv_copy;
6468
6469 PERL_ARGS_ASSERT_DOPARSEFORM;
6470
6471 if (len == 0)
6472 Perl_croak(aTHX_ "Null picture in formline");
6473
6474 if (SvTYPE(sv) >= SVt_PVMG) {
6475 /* This might, of course, still return NULL. */
6476 mg = mg_find(sv, PERL_MAGIC_fm);
6477 } else {
6478 sv_upgrade(sv, SVt_PVMG);
6479 }
6480
6481 if (mg) {
6482 /* still the same as previously-compiled string? */
6483 SV *old = mg->mg_obj;
6484 if ( ! (cBOOL(SvUTF8(old)) ^ cBOOL(SvUTF8(sv)))
6485 && len == SvCUR(old)
6486 && strnEQ(SvPVX(old), s, len)
6487 ) {
6488 DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
6489 return mg;
6490 }
6491
6492 DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
6493 Safefree(mg->mg_ptr);
6494 mg->mg_ptr = NULL;
6495 SvREFCNT_dec(old);
6496 mg->mg_obj = NULL;
6497 }
6498 else {
6499 DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
6500 mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
6501 }
6502
6503 sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
6504 s = SvPV(sv_copy, len); /* work on the copy, not the original */
6505 send = s + len;
6506
6507
6508 /* estimate the buffer size needed */
6509 for (base = s; s <= send; s++) {
6510 if (*s == '\n' || *s == '@' || *s == '^')
6511 maxops += 10;
6512 }
6513 s = base;
6514 base = NULL;
6515
6516 Newx(fops, maxops, U32);
6517 fpc = fops;
6518
6519 if (s < send) {
6520 linepc = fpc;
6521 *fpc++ = FF_LINEMARK;
6522 noblank = repeat = FALSE;
6523 base = s;
6524 }
6525
6526 while (s <= send) {
6527 switch (*s++) {
6528 default:
6529 skipspaces = 0;
6530 continue;
6531
6532 case '~':
6533 if (*s == '~') {
6534 repeat = TRUE;
6535 skipspaces++;
6536 s++;
6537 }
6538 noblank = TRUE;
6539 /* FALLTHROUGH */
6540 case ' ': case '\t':
6541 skipspaces++;
6542 continue;
6543 case 0:
6544 if (s < send) {
6545 skipspaces = 0;
6546 continue;
6547 }
6548 /* FALLTHROUGH */
6549 case '\n':
6550 arg = s - base;
6551 skipspaces++;
6552 arg -= skipspaces;
6553 if (arg) {
6554 if (postspace)
6555 *fpc++ = FF_SPACE;
6556 *fpc++ = FF_LITERAL;
6557 *fpc++ = (U32)arg;
6558 }
6559 postspace = FALSE;
6560 if (s <= send)
6561 skipspaces--;
6562 if (skipspaces) {
6563 *fpc++ = FF_SKIP;
6564 *fpc++ = (U32)skipspaces;
6565 }
6566 skipspaces = 0;
6567 if (s <= send)
6568 *fpc++ = FF_NEWLINE;
6569 if (noblank) {
6570 *fpc++ = FF_BLANK;
6571 if (repeat)
6572 arg = fpc - linepc + 1;
6573 else
6574 arg = 0;
6575 *fpc++ = (U32)arg;
6576 }
6577 if (s < send) {
6578 linepc = fpc;
6579 *fpc++ = FF_LINEMARK;
6580 noblank = repeat = FALSE;
6581 base = s;
6582 }
6583 else
6584 s++;
6585 continue;
6586
6587 case '@':
6588 case '^':
6589 ischop = s[-1] == '^';
6590
6591 if (postspace) {
6592 *fpc++ = FF_SPACE;
6593 postspace = FALSE;
6594 }
6595 arg = (s - base) - 1;
6596 if (arg) {
6597 *fpc++ = FF_LITERAL;
6598 *fpc++ = (U32)arg;
6599 }
6600
6601 base = s - 1;
6602 *fpc++ = FF_FETCH;
6603 if (*s == '*') { /* @* or ^* */
6604 s++;
6605 *fpc++ = 2; /* skip the @* or ^* */
6606 if (ischop) {
6607 *fpc++ = FF_LINESNGL;
6608 *fpc++ = FF_CHOP;
6609 } else
6610 *fpc++ = FF_LINEGLOB;
6611 }
6612 else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
6613 arg = ischop ? FORM_NUM_BLANK : 0;
6614 base = s - 1;
6615 while (*s == '#')
6616 s++;
6617 if (*s == '.') {
6618 const char * const f = ++s;
6619 while (*s == '#')
6620 s++;
6621 arg |= FORM_NUM_POINT + (s - f);
6622 }
6623 *fpc++ = s - base; /* fieldsize for FETCH */
6624 *fpc++ = FF_DECIMAL;
6625 *fpc++ = (U32)arg;
6626 unchopnum |= ! ischop;
6627 }
6628 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
6629 arg = ischop ? FORM_NUM_BLANK : 0;
6630 base = s - 1;
6631 s++; /* skip the '0' first */
6632 while (*s == '#')
6633 s++;
6634 if (*s == '.') {
6635 const char * const f = ++s;
6636 while (*s == '#')
6637 s++;
6638 arg |= FORM_NUM_POINT + (s - f);
6639 }
6640 *fpc++ = s - base; /* fieldsize for FETCH */
6641 *fpc++ = FF_0DECIMAL;
6642 *fpc++ = (U32)arg;
6643 unchopnum |= ! ischop;
6644 }
6645 else { /* text field */
6646 I32 prespace = 0;
6647 bool ismore = FALSE;
6648
6649 if (*s == '>') {
6650 while (*++s == '>') ;
6651 prespace = FF_SPACE;
6652 }
6653 else if (*s == '|') {
6654 while (*++s == '|') ;
6655 prespace = FF_HALFSPACE;
6656 postspace = TRUE;
6657 }
6658 else {
6659 if (*s == '<')
6660 while (*++s == '<') ;
6661 postspace = TRUE;
6662 }
6663 if (*s == '.' && s[1] == '.' && s[2] == '.') {
6664 s += 3;
6665 ismore = TRUE;
6666 }
6667 *fpc++ = s - base; /* fieldsize for FETCH */
6668
6669 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
6670
6671 if (prespace)
6672 *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
6673 *fpc++ = FF_ITEM;
6674 if (ismore)
6675 *fpc++ = FF_MORE;
6676 if (ischop)
6677 *fpc++ = FF_CHOP;
6678 }
6679 base = s;
6680 skipspaces = 0;
6681 continue;
6682 }
6683 }
6684 *fpc++ = FF_END;
6685
6686 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
6687 arg = fpc - fops;
6688
6689 mg->mg_ptr = (char *) fops;
6690 mg->mg_len = arg * sizeof(U32);
6691 mg->mg_obj = sv_copy;
6692 mg->mg_flags |= MGf_REFCOUNTED;
6693
6694 if (unchopnum && repeat)
6695 Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
6696
6697 return mg;
6698 }
6699
6700
6701 STATIC bool
S_num_overflow(NV value,I32 fldsize,I32 frcsize)6702 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
6703 {
6704 /* Can value be printed in fldsize chars, using %*.*f ? */
6705 NV pwr = 1;
6706 NV eps = 0.5;
6707 bool res = FALSE;
6708 int intsize = fldsize - (value < 0 ? 1 : 0);
6709
6710 if (frcsize & FORM_NUM_POINT)
6711 intsize--;
6712 frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
6713 intsize -= frcsize;
6714
6715 while (intsize--) pwr *= 10.0;
6716 while (frcsize--) eps /= 10.0;
6717
6718 if( value >= 0 ){
6719 if (value + eps >= pwr)
6720 res = TRUE;
6721 } else {
6722 if (value - eps <= -pwr)
6723 res = TRUE;
6724 }
6725 return res;
6726 }
6727
6728 static I32
S_run_user_filter(pTHX_ int idx,SV * buf_sv,int maxlen)6729 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
6730 {
6731 SV * const datasv = FILTER_DATA(idx);
6732 const int filter_has_file = IoLINES(datasv);
6733 SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
6734 SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
6735 int status = 0;
6736 SV *upstream;
6737 STRLEN got_len;
6738 char *got_p = NULL;
6739 char *prune_from = NULL;
6740 bool read_from_cache = FALSE;
6741 STRLEN umaxlen;
6742 SV *err = NULL;
6743
6744 PERL_ARGS_ASSERT_RUN_USER_FILTER;
6745
6746 assert(maxlen >= 0);
6747 umaxlen = maxlen;
6748
6749 /* I was having segfault trouble under Linux 2.2.5 after a
6750 parse error occurred. (Had to hack around it with a test
6751 for PL_parser->error_count == 0.) Solaris doesn't segfault --
6752 not sure where the trouble is yet. XXX */
6753
6754 {
6755 SV *const cache = datasv;
6756 if (SvOK(cache)) {
6757 STRLEN cache_len;
6758 const char *cache_p = SvPV(cache, cache_len);
6759 STRLEN take = 0;
6760
6761 if (umaxlen) {
6762 /* Running in block mode and we have some cached data already.
6763 */
6764 if (cache_len >= umaxlen) {
6765 /* In fact, so much data we don't even need to call
6766 filter_read. */
6767 take = umaxlen;
6768 }
6769 } else {
6770 const char *const first_nl =
6771 (const char *)memchr(cache_p, '\n', cache_len);
6772 if (first_nl) {
6773 take = first_nl + 1 - cache_p;
6774 }
6775 }
6776 if (take) {
6777 sv_catpvn(buf_sv, cache_p, take);
6778 sv_chop(cache, cache_p + take);
6779 /* Definitely not EOF */
6780 return 1;
6781 }
6782
6783 sv_catsv(buf_sv, cache);
6784 if (umaxlen) {
6785 umaxlen -= cache_len;
6786 }
6787 SvOK_off(cache);
6788 read_from_cache = TRUE;
6789 }
6790 }
6791
6792 /* Filter API says that the filter appends to the contents of the buffer.
6793 Usually the buffer is "", so the details don't matter. But if it's not,
6794 then clearly what it contains is already filtered by this filter, so we
6795 don't want to pass it in a second time.
6796 I'm going to use a mortal in case the upstream filter croaks. */
6797 upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
6798 ? newSV_type_mortal(SVt_PV) : buf_sv;
6799 SvUPGRADE(upstream, SVt_PV);
6800
6801 if (filter_has_file) {
6802 status = FILTER_READ(idx+1, upstream, 0);
6803 }
6804
6805 if (filter_sub && status >= 0) {
6806 dSP;
6807 int count;
6808
6809 ENTER_with_name("call_filter_sub");
6810 SAVE_DEFSV;
6811 SAVETMPS;
6812 EXTEND(SP, 2);
6813
6814 DEFSV_set(upstream);
6815 PUSHMARK(SP);
6816 PUSHs(&PL_sv_zero);
6817 if (filter_state) {
6818 PUSHs(filter_state);
6819 }
6820 PUTBACK;
6821 count = call_sv(filter_sub, G_SCALAR|G_EVAL);
6822 SPAGAIN;
6823
6824 if (count > 0) {
6825 SV *out = POPs;
6826 SvGETMAGIC(out);
6827 if (SvOK(out)) {
6828 status = SvIV(out);
6829 }
6830 else {
6831 SV * const errsv = ERRSV;
6832 if (SvTRUE_NN(errsv))
6833 err = newSVsv(errsv);
6834 }
6835 }
6836
6837 PUTBACK;
6838 FREETMPS;
6839 LEAVE_with_name("call_filter_sub");
6840 }
6841
6842 if (SvGMAGICAL(upstream)) {
6843 mg_get(upstream);
6844 if (upstream == buf_sv) mg_free(buf_sv);
6845 }
6846 if (SvIsCOW(upstream)) sv_force_normal(upstream);
6847 if(!err && SvOK(upstream)) {
6848 got_p = SvPV_nomg(upstream, got_len);
6849 if (umaxlen) {
6850 if (got_len > umaxlen) {
6851 prune_from = got_p + umaxlen;
6852 }
6853 } else {
6854 char *const first_nl = (char *)memchr(got_p, '\n', got_len);
6855 if (first_nl && first_nl + 1 < got_p + got_len) {
6856 /* There's a second line here... */
6857 prune_from = first_nl + 1;
6858 }
6859 }
6860 }
6861 if (!err && prune_from) {
6862 /* Oh. Too long. Stuff some in our cache. */
6863 STRLEN cached_len = got_p + got_len - prune_from;
6864 SV *const cache = datasv;
6865
6866 if (SvOK(cache)) {
6867 /* Cache should be empty. */
6868 assert(!SvCUR(cache));
6869 }
6870
6871 sv_setpvn(cache, prune_from, cached_len);
6872 /* If you ask for block mode, you may well split UTF-8 characters.
6873 "If it breaks, you get to keep both parts"
6874 (Your code is broken if you don't put them back together again
6875 before something notices.) */
6876 if (SvUTF8(upstream)) {
6877 SvUTF8_on(cache);
6878 }
6879 if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
6880 else
6881 /* Cannot just use sv_setpvn, as that could free the buffer
6882 before we have a chance to assign it. */
6883 sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
6884 got_len - cached_len);
6885 *prune_from = 0;
6886 /* Can't yet be EOF */
6887 if (status == 0)
6888 status = 1;
6889 }
6890
6891 /* If they are at EOF but buf_sv has something in it, then they may never
6892 have touched the SV upstream, so it may be undefined. If we naively
6893 concatenate it then we get a warning about use of uninitialised value.
6894 */
6895 if (!err && upstream != buf_sv &&
6896 SvOK(upstream)) {
6897 sv_catsv_nomg(buf_sv, upstream);
6898 }
6899 else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
6900
6901 if (status <= 0) {
6902 IoLINES(datasv) = 0;
6903 if (filter_state) {
6904 SvREFCNT_dec(filter_state);
6905 IoTOP_GV(datasv) = NULL;
6906 }
6907 if (filter_sub) {
6908 SvREFCNT_dec(filter_sub);
6909 IoBOTTOM_GV(datasv) = NULL;
6910 }
6911 filter_del(S_run_user_filter);
6912 }
6913
6914 if (err)
6915 croak_sv(err);
6916
6917 if (status == 0 && read_from_cache) {
6918 /* If we read some data from the cache (and by getting here it implies
6919 that we emptied the cache) then we aren't yet at EOF, and mustn't
6920 report that to our caller. */
6921 return 1;
6922 }
6923 return status;
6924 }
6925
6926 /*
6927 * ex: set ts=8 sts=4 sw=4 et:
6928 */
6929