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