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