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