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