source: vendor/perl/5.8.8/pp_ctl.c

Last change on this file was 3181, checked in by bird, 18 years ago

perl 5.8.8
File size: 92.5 KB
Line 
1/* pp_ctl.c
2 *
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
11/*
12 * Now far ahead the Road has gone,
13 * And I must follow, if I can,
14 * Pursuing it with eager feet,
15 * Until it joins some larger way
16 * Where many paths and errands meet.
17 * And whither then? I cannot say.
18 */
19
20/* This file contains control-oriented pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
25 *
26 * Control-oriented means things like pp_enteriter() and pp_next(), which
27 * alter the flow of control of the program.
28 */
29
30
31#include "EXTERN.h"
32#define PERL_IN_PP_CTL_C
33#include "perl.h"
34
35#ifndef WORD_ALIGN
36#define WORD_ALIGN sizeof(U32)
37#endif
38
39#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
40
41static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
42
43PP(pp_wantarray)
44{
45 dSP;
46 I32 cxix;
47 EXTEND(SP, 1);
48
49 cxix = dopoptosub(cxstack_ix);
50 if (cxix < 0)
51 RETPUSHUNDEF;
52
53 switch (cxstack[cxix].blk_gimme) {
54 case G_ARRAY:
55 RETPUSHYES;
56 case G_SCALAR:
57 RETPUSHNO;
58 default:
59 RETPUSHUNDEF;
60 }
61}
62
63PP(pp_regcmaybe)
64{
65 return NORMAL;
66}
67
68PP(pp_regcreset)
69{
70 /* XXXX Should store the old value to allow for tie/overload - and
71 restore in regcomp, where marked with XXXX. */
72 PL_reginterp_cnt = 0;
73 TAINT_NOT;
74 return NORMAL;
75}
76
77PP(pp_regcomp)
78{
79 dSP;
80 register PMOP *pm = (PMOP*)cLOGOP->op_other;
81 SV *tmpstr;
82 MAGIC *mg = Null(MAGIC*);
83
84 tmpstr = POPs;
85
86 /* prevent recompiling under /o and ithreads. */
87#if defined(USE_ITHREADS) || defined(USE_5005THREADS)
88 if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
89 RETURN;
90#endif
91
92 if (SvROK(tmpstr)) {
93 SV *sv = SvRV(tmpstr);
94 if(SvMAGICAL(sv))
95 mg = mg_find(sv, PERL_MAGIC_qr);
96 }
97 if (mg) {
98 regexp * const re = (regexp *)mg->mg_obj;
99 ReREFCNT_dec(PM_GETRE(pm));
100 PM_SETRE(pm, ReREFCNT_inc(re));
101 }
102 else {
103 STRLEN len;
104 const char *t = SvPV_const(tmpstr, len);
105
106 /* Check against the last compiled regexp. */
107 if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
108 PM_GETRE(pm)->prelen != (I32)len ||
109 memNE(PM_GETRE(pm)->precomp, t, len))
110 {
111 if (PM_GETRE(pm)) {
112 ReREFCNT_dec(PM_GETRE(pm));
113 PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
114 }
115 if (PL_op->op_flags & OPf_SPECIAL)
116 PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
117
118 pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
119 if (DO_UTF8(tmpstr))
120 pm->op_pmdynflags |= PMdf_DYN_UTF8;
121 else {
122 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
123 if (pm->op_pmdynflags & PMdf_UTF8)
124 t = (char*)bytes_to_utf8((U8*)t, &len);
125 }
126 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm));
127 if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
128 Safefree(t);
129 PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
130 inside tie/overload accessors. */
131 }
132 }
133
134#ifndef INCOMPLETE_TAINTS
135 if (PL_tainting) {
136 if (PL_tainted)
137 pm->op_pmdynflags |= PMdf_TAINTED;
138 else
139 pm->op_pmdynflags &= ~PMdf_TAINTED;
140 }
141#endif
142
143 if (!PM_GETRE(pm)->prelen && PL_curpm)
144 pm = PL_curpm;
145 else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
146 pm->op_pmflags |= PMf_WHITE;
147 else
148 pm->op_pmflags &= ~PMf_WHITE;
149
150 /* XXX runtime compiled output needs to move to the pad */
151 if (pm->op_pmflags & PMf_KEEP) {
152 pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
153#if !defined(USE_ITHREADS) && !defined(USE_5005THREADS)
154 /* XXX can't change the optree at runtime either */
155 cLOGOP->op_first->op_next = PL_op->op_next;
156#endif
157 }
158 RETURN;
159}
160
161PP(pp_substcont)
162{
163 dSP;
164 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
165 register PMOP * const pm = (PMOP*) cLOGOP->op_other;
166 register SV * const dstr = cx->sb_dstr;
167 register char *s = cx->sb_s;
168 register char *m = cx->sb_m;
169 char *orig = cx->sb_orig;
170 register REGEXP * const rx = cx->sb_rx;
171 SV *nsv = Nullsv;
172 REGEXP *old = PM_GETRE(pm);
173 if(old != rx) {
174 if(old)
175 ReREFCNT_dec(old);
176 PM_SETRE(pm,rx);
177 }
178
179 rxres_restore(&cx->sb_rxres, rx);
180 RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
181
182 if (cx->sb_iters++) {
183 const I32 saviters = cx->sb_iters;
184 if (cx->sb_iters > cx->sb_maxiters)
185 DIE(aTHX_ "Substitution loop");
186
187 if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
188 cx->sb_rxtainted |= 2;
189 sv_catsv(dstr, POPs);
190
191 /* Are we done */
192 if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
193 s == m, cx->sb_targ, NULL,
194 ((cx->sb_rflags & REXEC_COPY_STR)
195 ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
196 : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
197 {
198 SV * const targ = cx->sb_targ;
199
200 assert(cx->sb_strend >= s);
201 if(cx->sb_strend > s) {
202 if (DO_UTF8(dstr) && !SvUTF8(targ))
203 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
204 else
205 sv_catpvn(dstr, s, cx->sb_strend - s);
206 }
207 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
208
209 SvPV_free(targ);
210 SvPV_set(targ, SvPVX(dstr));
211 SvCUR_set(targ, SvCUR(dstr));
212 SvLEN_set(targ, SvLEN(dstr));
213 if (DO_UTF8(dstr))
214 SvUTF8_on(targ);
215 SvPV_set(dstr, (char*)0);
216 sv_free(dstr);
217
218 TAINT_IF(cx->sb_rxtainted & 1);
219 PUSHs(sv_2mortal(newSViv(saviters - 1)));
220
221 (void)SvPOK_only_UTF8(targ);
222 TAINT_IF(cx->sb_rxtainted);
223 SvSETMAGIC(targ);
224 SvTAINT(targ);
225
226 LEAVE_SCOPE(cx->sb_oldsave);
227 ReREFCNT_dec(rx);
228 POPSUBST(cx);
229 RETURNOP(pm->op_next);
230 }
231 cx->sb_iters = saviters;
232 }
233 if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
234 m = s;
235 s = orig;
236 cx->sb_orig = orig = rx->subbeg;
237 s = orig + (m - s);
238 cx->sb_strend = s + (cx->sb_strend - m);
239 }
240 cx->sb_m = m = rx->startp[0] + orig;
241 if (m > s) {
242 if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
243 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
244 else
245 sv_catpvn(dstr, s, m-s);
246 }
247 cx->sb_s = rx->endp[0] + orig;
248 { /* Update the pos() information. */
249 SV * const sv = cx->sb_targ;
250 MAGIC *mg;
251 I32 i;
252 if (SvTYPE(sv) < SVt_PVMG)
253 (void)SvUPGRADE(sv, SVt_PVMG);
254 if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
255 sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
256 mg = mg_find(sv, PERL_MAGIC_regex_global);
257 }
258 i = m - orig;
259 if (DO_UTF8(sv))
260 sv_pos_b2u(sv, &i);
261 mg->mg_len = i;
262 }
263 if (old != rx)
264 (void)ReREFCNT_inc(rx);
265 cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
266 rxres_save(&cx->sb_rxres, rx);
267 RETURNOP(pm->op_pmreplstart);
268}
269
270void
271Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
272{
273 UV *p = (UV*)*rsp;
274 U32 i;
275
276 if (!p || p[1] < rx->nparens) {
277 i = 6 + rx->nparens * 2;
278 if (!p)
279 Newx(p, i, UV);
280 else
281 Renew(p, i, UV);
282 *rsp = (void*)p;
283 }
284
285 *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
286 RX_MATCH_COPIED_off(rx);
287
288 *p++ = rx->nparens;
289
290 *p++ = PTR2UV(rx->subbeg);
291 *p++ = (UV)rx->sublen;
292 for (i = 0; i <= rx->nparens; ++i) {
293 *p++ = (UV)rx->startp[i];
294 *p++ = (UV)rx->endp[i];
295 }
296}
297
298void
299Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
300{
301 UV *p = (UV*)*rsp;
302 U32 i;
303
304 if (RX_MATCH_COPIED(rx))
305 Safefree(rx->subbeg);
306 RX_MATCH_COPIED_set(rx, *p);
307 *p++ = 0;
308
309 rx->nparens = *p++;
310
311 rx->subbeg = INT2PTR(char*,*p++);
312 rx->sublen = (I32)(*p++);
313 for (i = 0; i <= rx->nparens; ++i) {
314 rx->startp[i] = (I32)(*p++);
315 rx->endp[i] = (I32)(*p++);
316 }
317}
318
319void
320Perl_rxres_free(pTHX_ void **rsp)
321{
322 UV * const p = (UV*)*rsp;
323
324 if (p) {
325#ifdef PERL_POISON
326 void *tmp = INT2PTR(char*,*p);
327 Safefree(tmp);
328 if (*p)
329 Poison(*p, 1, sizeof(*p));
330#else
331 Safefree(INT2PTR(char*,*p));
332#endif
333 Safefree(p);
334 *rsp = Null(void*);
335 }
336}
337
338PP(pp_formline)
339{
340 dSP; dMARK; dORIGMARK;
341 register SV * const tmpForm = *++MARK;
342 register U32 *fpc;
343 register char *t;
344 const char *f;
345 register I32 arg;
346 register SV *sv = Nullsv;
347 const char *item = Nullch;
348 I32 itemsize = 0;
349 I32 fieldsize = 0;
350 I32 lines = 0;
351 bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
352 const char *chophere = Nullch;
353 char *linemark = Nullch;
354 NV value;
355 bool gotsome = FALSE;
356 STRLEN len;
357 const STRLEN fudge = SvPOK(tmpForm)
358 ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
359 bool item_is_utf8 = FALSE;
360 bool targ_is_utf8 = FALSE;
361 SV * nsv = Nullsv;
362 OP * parseres = 0;
363 const char *fmt;
364 bool oneline;
365
366 if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
367 if (SvREADONLY(tmpForm)) {
368 SvREADONLY_off(tmpForm);
369 parseres = doparseform(tmpForm);
370 SvREADONLY_on(tmpForm);
371 }
372 else
373 parseres = doparseform(tmpForm);
374 if (parseres)
375 return parseres;
376 }
377 SvPV_force(PL_formtarget, len);
378 if (DO_UTF8(PL_formtarget))
379 targ_is_utf8 = TRUE;
380 t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */
381 t += len;
382 f = SvPV_const(tmpForm, len);
383 /* need to jump to the next word */
384 fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
385
386 for (;;) {
387 DEBUG_f( {
388 const char *name = "???";
389 arg = -1;
390 switch (*fpc) {
391 case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
392 case FF_BLANK: arg = fpc[1]; name = "BLANK"; break;
393 case FF_SKIP: arg = fpc[1]; name = "SKIP"; break;
394 case FF_FETCH: arg = fpc[1]; name = "FETCH"; break;
395 case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break;
396
397 case FF_CHECKNL: name = "CHECKNL"; break;
398 case FF_CHECKCHOP: name = "CHECKCHOP"; break;
399 case FF_SPACE: name = "SPACE"; break;
400 case FF_HALFSPACE: name = "HALFSPACE"; break;
401 case FF_ITEM: name = "ITEM"; break;
402 case FF_CHOP: name = "CHOP"; break;
403 case FF_LINEGLOB: name = "LINEGLOB"; break;
404 case FF_NEWLINE: name = "NEWLINE"; break;
405 case FF_MORE: name = "MORE"; break;
406 case FF_LINEMARK: name = "LINEMARK"; break;
407 case FF_END: name = "END"; break;
408 case FF_0DECIMAL: name = "0DECIMAL"; break;
409 case FF_LINESNGL: name = "LINESNGL"; break;
410 }
411 if (arg >= 0)
412 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
413 else
414 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
415 } );
416 switch (*fpc++) {
417 case FF_LINEMARK:
418 linemark = t;
419 lines++;
420 gotsome = FALSE;
421 break;
422
423 case FF_LITERAL:
424 arg = *fpc++;
425 if (targ_is_utf8 && !SvUTF8(tmpForm)) {
426 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
427 *t = '\0';
428 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
429 t = SvEND(PL_formtarget);
430 break;
431 }
432 if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
433 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
434 *t = '\0';
435 sv_utf8_upgrade(PL_formtarget);
436 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
437 t = SvEND(PL_formtarget);
438 targ_is_utf8 = TRUE;
439 }
440 while (arg--)
441 *t++ = *f++;
442 break;
443
444 case FF_SKIP:
445 f += *fpc++;
446 break;
447
448 case FF_FETCH:
449 arg = *fpc++;
450 f += arg;
451 fieldsize = arg;
452
453 if (MARK < SP)
454 sv = *++MARK;
455 else {
456 sv = &PL_sv_no;
457 if (ckWARN(WARN_SYNTAX))
458 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
459 }
460 break;
461
462 case FF_CHECKNL:
463 {
464 const char *send;
465 const char *s = item = SvPV_const(sv, len);
466 itemsize = len;
467 if (DO_UTF8(sv)) {
468 itemsize = sv_len_utf8(sv);
469 if (itemsize != (I32)len) {
470 I32 itembytes;
471 if (itemsize > fieldsize) {
472 itemsize = fieldsize;
473 itembytes = itemsize;
474 sv_pos_u2b(sv, &itembytes, 0);
475 }
476 else
477 itembytes = len;
478 send = chophere = s + itembytes;
479 while (s < send) {
480 if (*s & ~31)
481 gotsome = TRUE;
482 else if (*s == '\n')
483 break;
484 s++;
485 }
486 item_is_utf8 = TRUE;
487 itemsize = s - item;
488 sv_pos_b2u(sv, &itemsize);
489 break;
490 }
491 }
492 item_is_utf8 = FALSE;
493 if (itemsize > fieldsize)
494 itemsize = fieldsize;
495 send = chophere = s + itemsize;
496 while (s < send) {
497 if (*s & ~31)
498 gotsome = TRUE;
499 else if (*s == '\n')
500 break;
501 s++;
502 }
503 itemsize = s - item;
504 break;
505 }
506
507 case FF_CHECKCHOP:
508 {
509 const char *s = item = SvPV_const(sv, len);
510 itemsize = len;
511 if (DO_UTF8(sv)) {
512 itemsize = sv_len_utf8(sv);
513 if (itemsize != (I32)len) {
514 I32 itembytes;
515 if (itemsize <= fieldsize) {
516 const char *send = chophere = s + itemsize;
517 while (s < send) {
518 if (*s == '\r') {
519 itemsize = s - item;
520 chophere = s;
521 break;
522 }
523 if (*s++ & ~31)
524 gotsome = TRUE;
525 }
526 }
527 else {
528 const char *send;
529 itemsize = fieldsize;
530 itembytes = itemsize;
531 sv_pos_u2b(sv, &itembytes, 0);
532 send = chophere = s + itembytes;
533 while (s < send || (s == send && isSPACE(*s))) {
534 if (isSPACE(*s)) {
535 if (chopspace)
536 chophere = s;
537 if (*s == '\r')
538 break;
539 }
540 else {
541 if (*s & ~31)
542 gotsome = TRUE;
543 if (strchr(PL_chopset, *s))
544 chophere = s + 1;
545 }
546 s++;
547 }
548 itemsize = chophere - item;
549 sv_pos_b2u(sv, &itemsize);
550 }
551 item_is_utf8 = TRUE;
552 break;
553 }
554 }
555 item_is_utf8 = FALSE;
556 if (itemsize <= fieldsize) {
557 const char *const send = chophere = s + itemsize;
558 while (s < send) {
559 if (*s == '\r') {
560 itemsize = s - item;
561 chophere = s;
562 break;
563 }
564 if (*s++ & ~31)
565 gotsome = TRUE;
566 }
567 }
568 else {
569 const char *send;
570 itemsize = fieldsize;
571 send = chophere = s + itemsize;
572 while (s < send || (s == send && isSPACE(*s))) {
573 if (isSPACE(*s)) {
574 if (chopspace)
575 chophere = s;
576 if (*s == '\r')
577 break;
578 }
579 else {
580 if (*s & ~31)
581 gotsome = TRUE;
582 if (strchr(PL_chopset, *s))
583 chophere = s + 1;
584 }
585 s++;
586 }
587 itemsize = chophere - item;
588 }
589 break;
590 }
591
592 case FF_SPACE:
593 arg = fieldsize - itemsize;
594 if (arg) {
595 fieldsize -= arg;
596 while (arg-- > 0)
597 *t++ = ' ';
598 }
599 break;
600
601 case FF_HALFSPACE:
602 arg = fieldsize - itemsize;
603 if (arg) {
604 arg /= 2;
605 fieldsize -= arg;
606 while (arg-- > 0)
607 *t++ = ' ';
608 }
609 break;
610
611 case FF_ITEM:
612 {
613 const char *s = item;
614 arg = itemsize;
615 if (item_is_utf8) {
616 if (!targ_is_utf8) {
617 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
618 *t = '\0';
619 sv_utf8_upgrade(PL_formtarget);
620 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
621 t = SvEND(PL_formtarget);
622 targ_is_utf8 = TRUE;
623 }
624 while (arg--) {
625 if (UTF8_IS_CONTINUED(*s)) {
626 STRLEN skip = UTF8SKIP(s);
627 switch (skip) {
628 default:
629 Move(s,t,skip,char);
630 s += skip;
631 t += skip;
632 break;
633 case 7: *t++ = *s++;
634 case 6: *t++ = *s++;
635 case 5: *t++ = *s++;
636 case 4: *t++ = *s++;
637 case 3: *t++ = *s++;
638 case 2: *t++ = *s++;
639 case 1: *t++ = *s++;
640 }
641 }
642 else {
643 if ( !((*t++ = *s++) & ~31) )
644 t[-1] = ' ';
645 }
646 }
647 break;
648 }
649 if (targ_is_utf8 && !item_is_utf8) {
650 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
651 *t = '\0';
652 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
653 for (; t < SvEND(PL_formtarget); t++) {
654#ifdef EBCDIC
655 const int ch = *t;
656 if (iscntrl(ch))
657#else
658 if (!(*t & ~31))
659#endif
660 *t = ' ';
661 }
662 break;
663 }
664 while (arg--) {
665#ifdef EBCDIC
666 const int ch = *t++ = *s++;
667 if (iscntrl(ch))
668#else
669 if ( !((*t++ = *s++) & ~31) )
670#endif
671 t[-1] = ' ';
672 }
673 break;
674 }
675
676 case FF_CHOP:
677 {
678 const char *s = chophere;
679 if (chopspace) {
680 while (*s && isSPACE(*s))
681 s++;
682 }
683 sv_chop(sv,(char *)s);
684 SvSETMAGIC(sv);
685 break;
686 }
687
688 case FF_LINESNGL:
689 chopspace = 0;
690 oneline = TRUE;
691 goto ff_line;
692 case FF_LINEGLOB:
693 oneline = FALSE;
694 ff_line:
695 {
696 const char *s = item = SvPV_const(sv, len);
697 itemsize = len;
698 if ((item_is_utf8 = DO_UTF8(sv)))
699 itemsize = sv_len_utf8(sv);
700 if (itemsize) {
701 bool chopped = FALSE;
702 const char *const send = s + len;
703 gotsome = TRUE;
704 chophere = s + itemsize;
705 while (s < send) {
706 if (*s++ == '\n') {
707 if (oneline) {
708 chopped = TRUE;
709 chophere = s;
710 break;
711 } else {
712 if (s == send) {
713 itemsize--;
714 chopped = TRUE;
715 } else
716 lines++;
717 }
718 }
719 }
720 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
721 if (targ_is_utf8)
722 SvUTF8_on(PL_formtarget);
723 if (oneline) {
724 SvCUR_set(sv, chophere - item);
725 sv_catsv(PL_formtarget, sv);
726 SvCUR_set(sv, itemsize);
727 } else
728 sv_catsv(PL_formtarget, sv);
729 if (chopped)
730 SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
731 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
732 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
733 if (item_is_utf8)
734 targ_is_utf8 = TRUE;
735 }
736 break;
737 }
738
739 case FF_0DECIMAL:
740 arg = *fpc++;
741#if defined(USE_LONG_DOUBLE)
742 fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
743#else
744 fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
745#endif
746 goto ff_dec;
747 case FF_DECIMAL:
748 arg = *fpc++;
749#if defined(USE_LONG_DOUBLE)
750 fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
751#else
752 fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
753#endif
754 ff_dec:
755 /* If the field is marked with ^ and the value is undefined,
756 blank it out. */
757 if ((arg & 512) && !SvOK(sv)) {
758 arg = fieldsize;
759 while (arg--)
760 *t++ = ' ';
761 break;
762 }
763 gotsome = TRUE;
764 value = SvNV(sv);
765 /* overflow evidence */
766 if (num_overflow(value, fieldsize, arg)) {
767 arg = fieldsize;
768 while (arg--)
769 *t++ = '#';
770 break;
771 }
772 /* Formats aren't yet marked for locales, so assume "yes". */
773 {
774 STORE_NUMERIC_STANDARD_SET_LOCAL();
775 sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
776 RESTORE_NUMERIC_STANDARD();
777 }
778 t += fieldsize;
779 break;
780
781 case FF_NEWLINE:
782 f++;
783 while (t-- > linemark && *t == ' ') ;
784 t++;
785 *t++ = '\n';
786 break;
787
788 case FF_BLANK:
789 arg = *fpc++;
790 if (gotsome) {
791 if (arg) { /* repeat until fields exhausted? */
792 *t = '\0';
793 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
794 lines += FmLINES(PL_formtarget);
795 if (lines == 200) {
796 arg = t - linemark;
797 if (strnEQ(linemark, linemark - arg, arg))
798 DIE(aTHX_ "Runaway format");
799 }
800 if (targ_is_utf8)
801 SvUTF8_on(PL_formtarget);
802 FmLINES(PL_formtarget) = lines;
803 SP = ORIGMARK;
804 RETURNOP(cLISTOP->op_first);
805 }
806 }
807 else {
808 t = linemark;
809 lines--;
810 }
811 break;
812
813 case FF_MORE:
814 {
815 const char *s = chophere;
816 const char *send = item + len;
817 if (chopspace) {
818 while (*s && isSPACE(*s) && s < send)
819 s++;
820 }
821 if (s < send) {
822 char *s1;
823 arg = fieldsize - itemsize;
824 if (arg) {
825 fieldsize -= arg;
826 while (arg-- > 0)
827 *t++ = ' ';
828 }
829 s1 = t - 3;
830 if (strnEQ(s1," ",3)) {
831 while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
832 s1--;
833 }
834 *s1++ = '.';
835 *s1++ = '.';
836 *s1++ = '.';
837 }
838 break;
839 }
840 case FF_END:
841 *t = '\0';
842 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
843 if (targ_is_utf8)
844 SvUTF8_on(PL_formtarget);
845 FmLINES(PL_formtarget) += lines;
846 SP = ORIGMARK;
847 RETPUSHYES;
848 }
849 }
850}
851
852PP(pp_grepstart)
853{
854 dSP;
855 SV *src;
856
857 if (PL_stack_base + *PL_markstack_ptr == SP) {
858 (void)POPMARK;
859 if (GIMME_V == G_SCALAR)
860 XPUSHs(sv_2mortal(newSViv(0)));
861 RETURNOP(PL_op->op_next->op_next);
862 }
863 PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
864 pp_pushmark(); /* push dst */
865 pp_pushmark(); /* push src */
866 ENTER; /* enter outer scope */
867
868 SAVETMPS;
869 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
870 SAVESPTR(DEFSV);
871 ENTER; /* enter inner scope */
872 SAVEVPTR(PL_curpm);
873
874 src = PL_stack_base[*PL_markstack_ptr];
875 SvTEMP_off(src);
876 DEFSV = src;
877
878 PUTBACK;
879 if (PL_op->op_type == OP_MAPSTART)
880 pp_pushmark(); /* push top */
881 return ((LOGOP*)PL_op->op_next)->op_other;
882}
883
884PP(pp_mapstart)
885{
886 DIE(aTHX_ "panic: mapstart"); /* uses grepstart */
887}
888
889PP(pp_mapwhile)
890{
891 dSP;
892 const I32 gimme = GIMME_V;
893 I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
894 I32 count;
895 I32 shift;
896 SV** src;
897 SV** dst;
898
899 /* first, move source pointer to the next item in the source list */
900 ++PL_markstack_ptr[-1];
901
902 /* if there are new items, push them into the destination list */
903 if (items && gimme != G_VOID) {
904 /* might need to make room back there first */
905 if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
906 /* XXX this implementation is very pessimal because the stack
907 * is repeatedly extended for every set of items. Is possible
908 * to do this without any stack extension or copying at all
909 * by maintaining a separate list over which the map iterates
910 * (like foreach does). --gsar */
911
912 /* everything in the stack after the destination list moves
913 * towards the end the stack by the amount of room needed */
914 shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
915
916 /* items to shift up (accounting for the moved source pointer) */
917 count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
918
919 /* This optimization is by Ben Tilly and it does
920 * things differently from what Sarathy (gsar)
921 * is describing. The downside of this optimization is
922 * that leaves "holes" (uninitialized and hopefully unused areas)
923 * to the Perl stack, but on the other hand this
924 * shouldn't be a problem. If Sarathy's idea gets
925 * implemented, this optimization should become
926 * irrelevant. --jhi */
927 if (shift < count)
928 shift = count; /* Avoid shifting too often --Ben Tilly */
929
930 EXTEND(SP,shift);
931 src = SP;
932 dst = (SP += shift);
933 PL_markstack_ptr[-1] += shift;
934 *PL_markstack_ptr += shift;
935 while (count--)
936 *dst-- = *src--;
937 }
938 /* copy the new items down to the destination list */
939 dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
940 if (gimme == G_ARRAY) {
941 while (items-- > 0)
942 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
943 }
944 else {
945 /* scalar context: we don't care about which values map returns
946 * (we use undef here). And so we certainly don't want to do mortal
947 * copies of meaningless values. */
948 while (items-- > 0) {
949 (void)POPs;
950 *dst-- = &PL_sv_undef;
951 }
952 }
953 }
954 LEAVE; /* exit inner scope */
955
956 /* All done yet? */
957 if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
958
959 (void)POPMARK; /* pop top */
960 LEAVE; /* exit outer scope */
961 (void)POPMARK; /* pop src */
962 items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
963 (void)POPMARK; /* pop dst */
964 SP = PL_stack_base + POPMARK; /* pop original mark */
965 if (gimme == G_SCALAR) {
966 dTARGET;
967 XPUSHi(items);
968 }
969 else if (gimme == G_ARRAY)
970 SP += items;
971 RETURN;
972 }
973 else {
974 SV *src;
975
976 ENTER; /* enter inner scope */
977 SAVEVPTR(PL_curpm);
978
979 /* set $_ to the new source item */
980 src = PL_stack_base[PL_markstack_ptr[-1]];
981 SvTEMP_off(src);
982 DEFSV = src;
983
984 RETURNOP(cLOGOP->op_other);
985 }
986}
987
988/* Range stuff. */
989
990PP(pp_range)
991{
992 if (GIMME == G_ARRAY)
993 return NORMAL;
994 if (SvTRUEx(PAD_SV(PL_op->op_targ)))
995 return cLOGOP->op_other;
996 else
997 return NORMAL;
998}
999
1000PP(pp_flip)
1001{
1002 dSP;
1003
1004 if (GIMME == G_ARRAY) {
1005 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1006 }
1007 else {
1008 dTOPss;
1009 SV * const targ = PAD_SV(PL_op->op_targ);
1010 int flip = 0;
1011
1012 if (PL_op->op_private & OPpFLIP_LINENUM) {
1013 if (GvIO(PL_last_in_gv)) {
1014 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1015 }
1016 else {
1017 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1018 if (gv && GvSV(gv))
1019 flip = SvIV(sv) == SvIV(GvSV(gv));
1020 }
1021 } else {
1022 flip = SvTRUE(sv);
1023 }
1024 if (flip) {
1025 sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1026 if (PL_op->op_flags & OPf_SPECIAL) {
1027 sv_setiv(targ, 1);
1028 SETs(targ);
1029 RETURN;
1030 }
1031 else {
1032 sv_setiv(targ, 0);
1033 SP--;
1034 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1035 }
1036 }
1037 sv_setpvn(TARG, "", 0);
1038 SETs(targ);
1039 RETURN;
1040 }
1041}
1042
1043/* This code tries to decide if "$left .. $right" should use the
1044 magical string increment, or if the range is numeric (we make
1045 an exception for .."0" [#18165]). AMS 20021031. */
1046
1047#define RANGE_IS_NUMERIC(left,right) ( \
1048 SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
1049 SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1050 (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1051 looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1052 && (!SvOK(right) || looks_like_number(right))))
1053
1054PP(pp_flop)
1055{
1056 dSP;
1057
1058 if (GIMME == G_ARRAY) {
1059 dPOPPOPssrl;
1060
1061 if (SvGMAGICAL(left))
1062 mg_get(left);
1063 if (SvGMAGICAL(right))
1064 mg_get(right);
1065
1066 if (RANGE_IS_NUMERIC(left,right)) {
1067 register IV i, j;
1068 IV max;
1069 if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1070 (SvOK(right) && SvNV(right) > IV_MAX))
1071 DIE(aTHX_ "Range iterator outside integer range");
1072 i = SvIV(left);
1073 max = SvIV(right);
1074 if (max >= i) {
1075 j = max - i + 1;
1076 EXTEND_MORTAL(j);
1077 EXTEND(SP, j);
1078 }
1079 else
1080 j = 0;
1081 while (j--) {
1082 SV * const sv = sv_2mortal(newSViv(i++));
1083 PUSHs(sv);
1084 }
1085 }
1086 else {
1087 SV * const final = sv_mortalcopy(right);
1088 STRLEN len;
1089 const char * const tmps = SvPV_const(final, len);
1090
1091 SV *sv = sv_mortalcopy(left);
1092 SvPV_force_nolen(sv);
1093 while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1094 XPUSHs(sv);
1095 if (strEQ(SvPVX_const(sv),tmps))
1096 break;
1097 sv = sv_2mortal(newSVsv(sv));
1098 sv_inc(sv);
1099 }
1100 }
1101 }
1102 else {
1103 dTOPss;
1104 SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1105 int flop = 0;
1106 sv_inc(targ);
1107
1108 if (PL_op->op_private & OPpFLIP_LINENUM) {
1109 if (GvIO(PL_last_in_gv)) {
1110 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1111 }
1112 else {
1113 GV * const gv = gv_fetchpv(".", TRUE, SVt_PV);
1114 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1115 }
1116 }
1117 else {
1118 flop = SvTRUE(sv);
1119 }
1120
1121 if (flop) {
1122 sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1123 sv_catpvn(targ, "E0", 2);
1124 }
1125 SETs(targ);
1126 }
1127
1128 RETURN;
1129}
1130
1131/* Control. */
1132
1133static const char * const context_name[] = {
1134 "pseudo-block",
1135 "subroutine",
1136 "eval",
1137 "loop",
1138 "substitution",
1139 "block",
1140 "format"
1141};
1142
1143STATIC I32
1144S_dopoptolabel(pTHX_ const char *label)
1145{
1146 register I32 i;
1147
1148 for (i = cxstack_ix; i >= 0; i--) {
1149 register const PERL_CONTEXT * const cx = &cxstack[i];
1150 switch (CxTYPE(cx)) {
1151 case CXt_SUBST:
1152 case CXt_SUB:
1153 case CXt_FORMAT:
1154 case CXt_EVAL:
1155 case CXt_NULL:
1156 if (ckWARN(WARN_EXITING))
1157 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1158 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1159 if (CxTYPE(cx) == CXt_NULL)
1160 return -1;
1161 break;
1162 case CXt_LOOP:
1163 if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1164 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1165 (long)i, cx->blk_loop.label));
1166 continue;
1167 }
1168 DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1169 return i;
1170 }
1171 }
1172 return i;
1173}
1174
1175I32
1176Perl_dowantarray(pTHX)
1177{
1178 const I32 gimme = block_gimme();
1179 return (gimme == G_VOID) ? G_SCALAR : gimme;
1180}
1181
1182I32
1183Perl_block_gimme(pTHX)
1184{
1185 const I32 cxix = dopoptosub(cxstack_ix);
1186 if (cxix < 0)
1187 return G_VOID;
1188
1189 switch (cxstack[cxix].blk_gimme) {
1190 case G_VOID:
1191 return G_VOID;
1192 case G_SCALAR:
1193 return G_SCALAR;
1194 case G_ARRAY:
1195 return G_ARRAY;
1196 default:
1197 Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1198 /* NOTREACHED */
1199 return 0;
1200 }
1201}
1202
1203I32
1204Perl_is_lvalue_sub(pTHX)
1205{
1206 const I32 cxix = dopoptosub(cxstack_ix);
1207 assert(cxix >= 0); /* We should only be called from inside subs */
1208
1209 if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1210 return cxstack[cxix].blk_sub.lval;
1211 else
1212 return 0;
1213}
1214
1215STATIC I32
1216S_dopoptosub(pTHX_ I32 startingblock)
1217{
1218 return dopoptosub_at(cxstack, startingblock);
1219}
1220
1221STATIC I32
1222S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1223{
1224 I32 i;
1225 for (i = startingblock; i >= 0; i--) {
1226 register const PERL_CONTEXT * const cx = &cxstk[i];
1227 switch (CxTYPE(cx)) {
1228 default:
1229 continue;
1230 case CXt_EVAL:
1231 case CXt_SUB:
1232 case CXt_FORMAT:
1233 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1234 return i;
1235 }
1236 }
1237 return i;
1238}
1239
1240STATIC I32
1241S_dopoptoeval(pTHX_ I32 startingblock)
1242{
1243 I32 i;
1244 for (i = startingblock; i >= 0; i--) {
1245 register const PERL_CONTEXT *cx = &cxstack[i];
1246 switch (CxTYPE(cx)) {
1247 default:
1248 continue;
1249 case CXt_EVAL:
1250 DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1251 return i;
1252 }
1253 }
1254 return i;
1255}
1256
1257STATIC I32
1258S_dopoptoloop(pTHX_ I32 startingblock)
1259{
1260 I32 i;
1261 for (i = startingblock; i >= 0; i--) {
1262 register const PERL_CONTEXT * const cx = &cxstack[i];
1263 switch (CxTYPE(cx)) {
1264 case CXt_SUBST:
1265 case CXt_SUB:
1266 case CXt_FORMAT:
1267 case CXt_EVAL:
1268 case CXt_NULL:
1269 if (ckWARN(WARN_EXITING))
1270 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1271 context_name[CxTYPE(cx)], OP_NAME(PL_op));
1272 if ((CxTYPE(cx)) == CXt_NULL)
1273 return -1;
1274 break;
1275 case CXt_LOOP:
1276 DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1277 return i;
1278 }
1279 }
1280 return i;
1281}
1282
1283void
1284Perl_dounwind(pTHX_ I32 cxix)
1285{
1286 I32 optype;
1287
1288 while (cxstack_ix > cxix) {
1289 SV *sv;
1290 register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1291 DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1292 (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1293 /* Note: we don't need to restore the base context info till the end. */
1294 switch (CxTYPE(cx)) {
1295 case CXt_SUBST:
1296 POPSUBST(cx);
1297 continue; /* not break */
1298 case CXt_SUB:
1299 POPSUB(cx,sv);
1300 LEAVESUB(sv);
1301 break;
1302 case CXt_EVAL:
1303 POPEVAL(cx);
1304 break;
1305 case CXt_LOOP:
1306 POPLOOP(cx);
1307 break;
1308 case CXt_NULL:
1309 break;
1310 case CXt_FORMAT:
1311 POPFORMAT(cx);
1312 break;
1313 }
1314 cxstack_ix--;
1315 }
1316 PERL_UNUSED_VAR(optype);
1317}
1318
1319void
1320Perl_qerror(pTHX_ SV *err)
1321{
1322 if (PL_in_eval)
1323 sv_catsv(ERRSV, err);
1324 else if (PL_errors)
1325 sv_catsv(PL_errors, err);
1326 else
1327 Perl_warn(aTHX_ "%"SVf, err);
1328 ++PL_error_count;
1329}
1330
1331OP *
1332Perl_die_where(pTHX_ char *message, STRLEN msglen)
1333{
1334 if (PL_in_eval) {
1335 I32 cxix;
1336 I32 gimme;
1337
1338 if (message) {
1339 if (PL_in_eval & EVAL_KEEPERR) {
1340 static const char prefix[] = "\t(in cleanup) ";
1341 SV * const err = ERRSV;
1342 const char *e = Nullch;
1343 if (!SvPOK(err))
1344 sv_setpvn(err,"",0);
1345 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1346 STRLEN len;
1347 e = SvPV_const(err, len);
1348 e += len - msglen;
1349 if (*e != *message || strNE(e,message))
1350 e = Nullch;
1351 }
1352 if (!e) {
1353 SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1354 sv_catpvn(err, prefix, sizeof(prefix)-1);
1355 sv_catpvn(err, message, msglen);
1356 if (ckWARN(WARN_MISC)) {
1357 const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1358 Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1359 }
1360 }
1361 }
1362 else {
1363 sv_setpvn(ERRSV, message, msglen);
1364 }
1365 }
1366
1367 while ((cxix = dopoptoeval(cxstack_ix)) < 0
1368 && PL_curstackinfo->si_prev)
1369 {
1370 dounwind(-1);
1371 POPSTACK;
1372 }
1373
1374 if (cxix >= 0) {
1375 I32 optype;
1376 register PERL_CONTEXT *cx;
1377 SV **newsp;
1378
1379 if (cxix < cxstack_ix)
1380 dounwind(cxix);
1381
1382 POPBLOCK(cx,PL_curpm);
1383 if (CxTYPE(cx) != CXt_EVAL) {
1384 if (!message)
1385 message = (char *)SvPVx_const(ERRSV, msglen);
1386 PerlIO_write(Perl_error_log, "panic: die ", 11);
1387 PerlIO_write(Perl_error_log, message, msglen);
1388 my_exit(1);
1389 }
1390 POPEVAL(cx);
1391
1392 if (gimme == G_SCALAR)
1393 *++newsp = &PL_sv_undef;
1394 PL_stack_sp = newsp;
1395
1396 LEAVE;
1397
1398 /* LEAVE could clobber PL_curcop (see save_re_context())
1399 * XXX it might be better to find a way to avoid messing with
1400 * PL_curcop in save_re_context() instead, but this is a more
1401 * minimal fix --GSAR */
1402 PL_curcop = cx->blk_oldcop;
1403
1404 if (optype == OP_REQUIRE) {
1405 const char* msg = SvPVx_nolen_const(ERRSV);
1406 DIE(aTHX_ "%sCompilation failed in require",
1407 *msg ? msg : "Unknown error\n");
1408 }
1409 return pop_return();
1410 }
1411 }
1412 if (!message)
1413 message = (char *)SvPVx_const(ERRSV, msglen);
1414
1415 write_to_stderr(message, msglen);
1416 my_failure_exit();
1417 /* NOTREACHED */
1418 return 0;
1419}
1420
1421PP(pp_xor)
1422{
1423 dSP; dPOPTOPssrl;
1424 if (SvTRUE(left) != SvTRUE(right))
1425 RETSETYES;
1426 else
1427 RETSETNO;
1428}
1429
1430PP(pp_andassign)
1431{
1432 dSP;
1433 if (!SvTRUE(TOPs))
1434 RETURN;
1435 else
1436 RETURNOP(cLOGOP->op_other);
1437}
1438
1439PP(pp_orassign)
1440{
1441 dSP;
1442 if (SvTRUE(TOPs))
1443 RETURN;
1444 else
1445 RETURNOP(cLOGOP->op_other);
1446}
1447
1448PP(pp_caller)
1449{
1450 dSP;
1451 register I32 cxix = dopoptosub(cxstack_ix);
1452 register const PERL_CONTEXT *cx;
1453 register const PERL_CONTEXT *ccstack = cxstack;
1454 const PERL_SI *top_si = PL_curstackinfo;
1455 I32 gimme;
1456 const char *stashname;
1457 I32 count = 0;
1458
1459 if (MAXARG)
1460 count = POPi;
1461
1462 for (;;) {
1463 /* we may be in a higher stacklevel, so dig down deeper */
1464 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1465 top_si = top_si->si_prev;
1466 ccstack = top_si->si_cxstack;
1467 cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1468 }
1469 if (cxix < 0) {
1470 if (GIMME != G_ARRAY) {
1471 EXTEND(SP, 1);
1472 RETPUSHUNDEF;
1473 }
1474 RETURN;
1475 }
1476 /* caller() should not report the automatic calls to &DB::sub */
1477 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1478 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1479 count++;
1480 if (!count--)
1481 break;
1482 cxix = dopoptosub_at(ccstack, cxix - 1);
1483 }
1484
1485 cx = &ccstack[cxix];
1486 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1487 const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1488 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1489 field below is defined for any cx. */
1490 /* caller() should not report the automatic calls to &DB::sub */
1491 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1492 cx = &ccstack[dbcxix];
1493 }
1494
1495 stashname = CopSTASHPV(cx->blk_oldcop);
1496 if (GIMME != G_ARRAY) {
1497 EXTEND(SP, 1);
1498 if (!stashname)
1499 PUSHs(&PL_sv_undef);
1500 else {
1501 dTARGET;
1502 sv_setpv(TARG, stashname);
1503 PUSHs(TARG);
1504 }
1505 RETURN;
1506 }
1507
1508 EXTEND(SP, 10);
1509
1510 if (!stashname)
1511 PUSHs(&PL_sv_undef);
1512 else
1513 PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1514 PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1515 PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1516 if (!MAXARG)
1517 RETURN;
1518 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1519 GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1520 /* So is ccstack[dbcxix]. */
1521 if (isGV(cvgv)) {
1522 SV * const sv = NEWSV(49, 0);
1523 gv_efullname3(sv, cvgv, Nullch);
1524 PUSHs(sv_2mortal(sv));
1525 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1526 }
1527 else {
1528 PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1529 PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1530 }
1531 }
1532 else {
1533 PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1534 PUSHs(sv_2mortal(newSViv(0)));
1535 }
1536 gimme = (I32)cx->blk_gimme;
1537 if (gimme == G_VOID)
1538 PUSHs(&PL_sv_undef);
1539 else
1540 PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1541 if (CxTYPE(cx) == CXt_EVAL) {
1542 /* eval STRING */
1543 if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1544 PUSHs(cx->blk_eval.cur_text);
1545 PUSHs(&PL_sv_no);
1546 }
1547 /* require */
1548 else if (cx->blk_eval.old_namesv) {
1549 PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1550 PUSHs(&PL_sv_yes);
1551 }
1552 /* eval BLOCK (try blocks have old_namesv == 0) */
1553 else {
1554 PUSHs(&PL_sv_undef);
1555 PUSHs(&PL_sv_undef);
1556 }
1557 }
1558 else {
1559 PUSHs(&PL_sv_undef);
1560 PUSHs(&PL_sv_undef);
1561 }
1562 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1563 && CopSTASH_eq(PL_curcop, PL_debstash))
1564 {
1565 AV * const ary = cx->blk_sub.argarray;
1566 const int off = AvARRAY(ary) - AvALLOC(ary);
1567
1568 if (!PL_dbargs) {
1569 GV* tmpgv;
1570 PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1571 SVt_PVAV)));
1572 GvMULTI_on(tmpgv);
1573 AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
1574 }
1575
1576 if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1577 av_extend(PL_dbargs, AvFILLp(ary) + off);
1578 Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1579 AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1580 }
1581 /* XXX only hints propagated via op_private are currently
1582 * visible (others are not easily accessible, since they
1583 * use the global PL_hints) */
1584 PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1585 HINT_PRIVATE_MASK)));
1586 {
1587 SV * mask ;
1588 SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1589
1590 if (old_warnings == pWARN_NONE ||
1591 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1592 mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1593 else if (old_warnings == pWARN_ALL ||
1594 (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1595 /* Get the bit mask for $warnings::Bits{all}, because
1596 * it could have been extended by warnings::register */
1597 SV **bits_all;
1598 HV *bits = get_hv("warnings::Bits", FALSE);
1599 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1600 mask = newSVsv(*bits_all);
1601 }
1602 else {
1603 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1604 }
1605 }
1606 else
1607 mask = newSVsv(old_warnings);
1608 PUSHs(sv_2mortal(mask));
1609 }
1610 RETURN;
1611}
1612
1613PP(pp_reset)
1614{
1615 dSP;
1616 const char *tmps;
1617
1618 if (MAXARG < 1)
1619 tmps = "";
1620 else
1621 tmps = POPpconstx;
1622 sv_reset((char *)tmps, CopSTASH(PL_curcop));
1623 PUSHs(&PL_sv_yes);
1624 RETURN;
1625}
1626
1627PP(pp_lineseq)
1628{
1629 return NORMAL;
1630}
1631
1632/* like pp_nextstate, but used instead when the debugger is active */
1633
1634PP(pp_dbstate)
1635{
1636 PL_curcop = (COP*)PL_op;
1637 TAINT_NOT; /* Each statement is presumed innocent */
1638 PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1639 FREETMPS;
1640
1641 if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1642 || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1643 {
1644 dSP;
1645 register CV *cv;
1646 register PERL_CONTEXT *cx;
1647 const I32 gimme = G_ARRAY;
1648 U8 hasargs;
1649 GV *gv;
1650
1651 gv = PL_DBgv;
1652 cv = GvCV(gv);
1653 if (!cv)
1654 DIE(aTHX_ "No DB::DB routine defined");
1655
1656 if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1657 /* don't do recursive DB::DB call */
1658 return NORMAL;
1659
1660 ENTER;
1661 SAVETMPS;
1662
1663 SAVEI32(PL_debug);
1664 SAVESTACK_POS();
1665 PL_debug = 0;
1666 hasargs = 0;
1667 SPAGAIN;
1668
1669 if (CvXSUB(cv)) {
1670 CvDEPTH(cv)++;
1671 PUSHMARK(SP);
1672 (void)(*CvXSUB(cv))(aTHX_ cv);
1673
1674 CvDEPTH(cv)--;
1675 FREETMPS;
1676 LEAVE;
1677 return NORMAL;
1678 } else {
1679 push_return(PL_op->op_next);
1680 PUSHBLOCK(cx, CXt_SUB, SP);
1681 PUSHSUB_DB(cx);
1682 CvDEPTH(cv)++;
1683 SAVECOMPPAD();
1684 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1685 RETURNOP(CvSTART(cv));
1686 }
1687 }
1688 else
1689 return NORMAL;
1690}
1691
1692PP(pp_scope)
1693{
1694 return NORMAL;
1695}
1696
1697PP(pp_enteriter)
1698{
1699 dSP; dMARK;
1700 register PERL_CONTEXT *cx;
1701 const I32 gimme = GIMME_V;
1702 SV **svp;
1703 U32 cxtype = CXt_LOOP;
1704#ifdef USE_ITHREADS
1705 void *iterdata;
1706#endif
1707
1708 ENTER;
1709 SAVETMPS;
1710
1711#ifdef USE_5005THREADS
1712 if (PL_op->op_flags & OPf_SPECIAL) {
1713 svp = &THREADSV(PL_op->op_targ); /* per-thread variable */
1714 SAVEGENERICSV(*svp);
1715 *svp = NEWSV(0,0);
1716 }
1717 else
1718#endif /* USE_5005THREADS */
1719 if (PL_op->op_targ) {
1720#ifndef USE_ITHREADS
1721 svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
1722 SAVESPTR(*svp);
1723#else
1724 SAVEPADSV(PL_op->op_targ);
1725 iterdata = INT2PTR(void*, PL_op->op_targ);
1726 cxtype |= CXp_PADVAR;
1727#endif
1728 }
1729 else {
1730 GV *gv = (GV*)POPs;
1731 svp = &GvSV(gv); /* symbol table variable */
1732 SAVEGENERICSV(*svp);
1733 *svp = NEWSV(0,0);
1734#ifdef USE_ITHREADS
1735 iterdata = (void*)gv;
1736#endif
1737 }
1738
1739 ENTER;
1740
1741 PUSHBLOCK(cx, cxtype, SP);
1742#ifdef USE_ITHREADS
1743 PUSHLOOP(cx, iterdata, MARK);
1744#else
1745 PUSHLOOP(cx, svp, MARK);
1746#endif
1747 if (PL_op->op_flags & OPf_STACKED) {
1748 cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1749 if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1750 dPOPss;
1751 SV *right = (SV*)cx->blk_loop.iterary;
1752 SvGETMAGIC(sv);
1753 SvGETMAGIC(right);
1754 if (RANGE_IS_NUMERIC(sv,right)) {
1755 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1756 (SvOK(right) && SvNV(right) >= IV_MAX))
1757 DIE(aTHX_ "Range iterator outside integer range");
1758 cx->blk_loop.iterix = SvIV(sv);
1759 cx->blk_loop.itermax = SvIV(right);
1760#ifdef DEBUGGING
1761 /* for correct -Dstv display */
1762 cx->blk_oldsp = sp - PL_stack_base;
1763#endif
1764 }
1765 else {
1766 cx->blk_loop.iterlval = newSVsv(sv);
1767 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1768 (void) SvPV_nolen_const(right);
1769 }
1770 }
1771 else if (PL_op->op_private & OPpITER_REVERSED) {
1772 cx->blk_loop.itermax = 0;
1773 cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1774
1775 }
1776 }
1777 else {
1778 cx->blk_loop.iterary = PL_curstack;
1779 AvFILLp(PL_curstack) = SP - PL_stack_base;
1780 if (PL_op->op_private & OPpITER_REVERSED) {
1781 cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1782 cx->blk_loop.iterix = cx->blk_oldsp + 1;
1783 }
1784 else {
1785 cx->blk_loop.iterix = MARK - PL_stack_base;
1786 }
1787 }
1788
1789 RETURN;
1790}
1791
1792PP(pp_enterloop)
1793{
1794 dSP;
1795 register PERL_CONTEXT *cx;
1796 const I32 gimme = GIMME_V;
1797
1798 ENTER;
1799 SAVETMPS;
1800 ENTER;
1801
1802 PUSHBLOCK(cx, CXt_LOOP, SP);
1803 PUSHLOOP(cx, 0, SP);
1804
1805 RETURN;
1806}
1807
1808PP(pp_leaveloop)
1809{
1810 dSP;
1811 register PERL_CONTEXT *cx;
1812 I32 gimme;
1813 SV **newsp;
1814 PMOP *newpm;
1815 SV **mark;
1816
1817 POPBLOCK(cx,newpm);
1818 assert(CxTYPE(cx) == CXt_LOOP);
1819 mark = newsp;
1820 newsp = PL_stack_base + cx->blk_loop.resetsp;
1821
1822 TAINT_NOT;
1823 if (gimme == G_VOID)
1824 ; /* do nothing */
1825 else if (gimme == G_SCALAR) {
1826 if (mark < SP)
1827 *++newsp = sv_mortalcopy(*SP);
1828 else
1829 *++newsp = &PL_sv_undef;
1830 }
1831 else {
1832 while (mark < SP) {
1833 *++newsp = sv_mortalcopy(*++mark);
1834 TAINT_NOT; /* Each item is independent */
1835 }
1836 }
1837 SP = newsp;
1838 PUTBACK;
1839
1840 POPLOOP(cx); /* Stack values are safe: release loop vars ... */
1841 PL_curpm = newpm; /* ... and pop $1 et al */
1842
1843 LEAVE;
1844 LEAVE;
1845
1846 return NORMAL;
1847}
1848
1849PP(pp_return)
1850{
1851 dSP; dMARK;
1852 I32 cxix;
1853 register PERL_CONTEXT *cx;
1854 bool popsub2 = FALSE;
1855 bool clear_errsv = FALSE;
1856 I32 gimme;
1857 SV **newsp;
1858 PMOP *newpm;
1859 I32 optype = 0;
1860 SV *sv;
1861
1862 if (PL_curstackinfo->si_type == PERLSI_SORT) {
1863 if (cxstack_ix == PL_sortcxix
1864 || dopoptosub(cxstack_ix) <= PL_sortcxix)
1865 {
1866 if (cxstack_ix > PL_sortcxix)
1867 dounwind(PL_sortcxix);
1868 AvARRAY(PL_curstack)[1] = *SP;
1869 PL_stack_sp = PL_stack_base + 1;
1870 return 0;
1871 }
1872 }
1873
1874 cxix = dopoptosub(cxstack_ix);
1875 if (cxix < 0)
1876 DIE(aTHX_ "Can't return outside a subroutine");
1877 if (cxix < cxstack_ix)
1878 dounwind(cxix);
1879
1880 POPBLOCK(cx,newpm);
1881 switch (CxTYPE(cx)) {
1882 case CXt_SUB:
1883 popsub2 = TRUE;
1884 cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1885 break;
1886 case CXt_EVAL:
1887 if (!(PL_in_eval & EVAL_KEEPERR))
1888 clear_errsv = TRUE;
1889 POPEVAL(cx);
1890 if (CxTRYBLOCK(cx))
1891 break;
1892 lex_end();
1893 if (optype == OP_REQUIRE &&
1894 (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1895 {
1896 /* Unassume the success we assumed earlier. */
1897 SV * const nsv = cx->blk_eval.old_namesv;
1898 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
1899 DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1900 }
1901 break;
1902 case CXt_FORMAT:
1903 POPFORMAT(cx);
1904 break;
1905 default:
1906 DIE(aTHX_ "panic: return");
1907 }
1908
1909 TAINT_NOT;
1910 if (gimme == G_SCALAR) {
1911 if (MARK < SP) {
1912 if (popsub2) {
1913 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1914 if (SvTEMP(TOPs)) {
1915 *++newsp = SvREFCNT_inc(*SP);
1916 FREETMPS;
1917 sv_2mortal(*newsp);
1918 }
1919 else {
1920 sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1921 FREETMPS;
1922 *++newsp = sv_mortalcopy(sv);
1923 SvREFCNT_dec(sv);
1924 }
1925 }
1926 else
1927 *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1928 }
1929 else
1930 *++newsp = sv_mortalcopy(*SP);
1931 }
1932 else
1933 *++newsp = &PL_sv_undef;
1934 }
1935 else if (gimme == G_ARRAY) {
1936 while (++MARK <= SP) {
1937 *++newsp = (popsub2 && SvTEMP(*MARK))
1938 ? *MARK : sv_mortalcopy(*MARK);
1939 TAINT_NOT; /* Each item is independent */
1940 }
1941 }
1942 PL_stack_sp = newsp;
1943
1944 LEAVE;
1945 /* Stack values are safe: */
1946 if (popsub2) {
1947 cxstack_ix--;
1948 POPSUB(cx,sv); /* release CV and @_ ... */
1949 }
1950 else
1951 sv = Nullsv;
1952 PL_curpm = newpm; /* ... and pop $1 et al */
1953
1954 LEAVESUB(sv);
1955 if (clear_errsv)
1956 sv_setpvn(ERRSV,"",0);
1957 return pop_return();
1958}
1959
1960PP(pp_last)
1961{
1962 dSP;
1963 I32 cxix;
1964 register PERL_CONTEXT *cx;
1965 I32 pop2 = 0;
1966 I32 gimme;
1967 I32 optype;
1968 OP *nextop;
1969 SV **newsp;
1970 PMOP *newpm;
1971 SV **mark;
1972 SV *sv = Nullsv;
1973
1974
1975 if (PL_op->op_flags & OPf_SPECIAL) {
1976 cxix = dopoptoloop(cxstack_ix);
1977 if (cxix < 0)
1978 DIE(aTHX_ "Can't \"last\" outside a loop block");
1979 }
1980 else {
1981 cxix = dopoptolabel(cPVOP->op_pv);
1982 if (cxix < 0)
1983 DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1984 }
1985 if (cxix < cxstack_ix)
1986 dounwind(cxix);
1987
1988 POPBLOCK(cx,newpm);
1989 cxstack_ix++; /* temporarily protect top context */
1990 mark = newsp;
1991 switch (CxTYPE(cx)) {
1992 case CXt_LOOP:
1993 pop2 = CXt_LOOP;
1994 newsp = PL_stack_base + cx->blk_loop.resetsp;
1995 nextop = cx->blk_loop.last_op->op_next;
1996 break;
1997 case CXt_SUB:
1998 pop2 = CXt_SUB;
1999 nextop = pop_return();
2000 break;
2001 case CXt_EVAL:
2002 POPEVAL(cx);
2003 nextop = pop_return();
2004 break;
2005 case CXt_FORMAT:
2006 POPFORMAT(cx);
2007 nextop = pop_return();
2008 break;
2009 default:
2010 DIE(aTHX_ "panic: last");
2011 }
2012
2013 TAINT_NOT;
2014 if (gimme == G_SCALAR) {
2015 if (MARK < SP)
2016 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2017 ? *SP : sv_mortalcopy(*SP);
2018 else
2019 *++newsp = &PL_sv_undef;
2020 }
2021 else if (gimme == G_ARRAY) {
2022 while (++MARK <= SP) {
2023 *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2024 ? *MARK : sv_mortalcopy(*MARK);
2025 TAINT_NOT; /* Each item is independent */
2026 }
2027 }
2028 SP = newsp;
2029 PUTBACK;
2030
2031 LEAVE;
2032 cxstack_ix--;
2033 /* Stack values are safe: */
2034 switch (pop2) {
2035 case CXt_LOOP:
2036 POPLOOP(cx); /* release loop vars ... */
2037 LEAVE;
2038 break;
2039 case CXt_SUB:
2040 POPSUB(cx,sv); /* release CV and @_ ... */
2041 break;
2042 }
2043 PL_curpm = newpm; /* ... and pop $1 et al */
2044
2045 LEAVESUB(sv);
2046 PERL_UNUSED_VAR(optype);
2047 PERL_UNUSED_VAR(gimme);
2048 return nextop;
2049}
2050
2051PP(pp_next)
2052{
2053 I32 cxix;
2054 register PERL_CONTEXT *cx;
2055 I32 inner;
2056
2057 if (PL_op->op_flags & OPf_SPECIAL) {
2058 cxix = dopoptoloop(cxstack_ix);
2059 if (cxix < 0)
2060 DIE(aTHX_ "Can't \"next\" outside a loop block");
2061 }
2062 else {
2063 cxix = dopoptolabel(cPVOP->op_pv);
2064 if (cxix < 0)
2065 DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2066 }
2067 if (cxix < cxstack_ix)
2068 dounwind(cxix);
2069
2070 /* clear off anything above the scope we're re-entering, but
2071 * save the rest until after a possible continue block */
2072 inner = PL_scopestack_ix;
2073 TOPBLOCK(cx);
2074 if (PL_scopestack_ix < inner)
2075 leave_scope(PL_scopestack[PL_scopestack_ix]);
2076 PL_curcop = cx->blk_oldcop;
2077 return cx->blk_loop.next_op;
2078}
2079
2080PP(pp_redo)
2081{
2082 I32 cxix;
2083 register PERL_CONTEXT *cx;
2084 I32 oldsave;
2085
2086 if (PL_op->op_flags & OPf_SPECIAL) {
2087 cxix = dopoptoloop(cxstack_ix);
2088 if (cxix < 0)
2089 DIE(aTHX_ "Can't \"redo\" outside a loop block");
2090 }
2091 else {
2092 cxix = dopoptolabel(cPVOP->op_pv);
2093 if (cxix < 0)
2094 DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2095 }
2096 if (cxix < cxstack_ix)
2097 dounwind(cxix);
2098
2099 TOPBLOCK(cx);
2100 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2101 LEAVE_SCOPE(oldsave);
2102 FREETMPS;
2103 PL_curcop = cx->blk_oldcop;
2104 return cx->blk_loop.redo_op;
2105}
2106
2107STATIC OP *
2108S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2109{
2110 OP **ops = opstack;
2111 static const char too_deep[] = "Target of goto is too deeply nested";
2112
2113 if (ops >= oplimit)
2114 Perl_croak(aTHX_ too_deep);
2115 if (o->op_type == OP_LEAVE ||
2116 o->op_type == OP_SCOPE ||
2117 o->op_type == OP_LEAVELOOP ||
2118 o->op_type == OP_LEAVESUB ||
2119 o->op_type == OP_LEAVETRY)
2120 {
2121 *ops++ = cUNOPo->op_first;
2122 if (ops >= oplimit)
2123 Perl_croak(aTHX_ too_deep);
2124 }
2125 *ops = 0;
2126 if (o->op_flags & OPf_KIDS) {
2127 OP *kid;
2128 /* First try all the kids at this level, since that's likeliest. */
2129 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2130 if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2131 kCOP->cop_label && strEQ(kCOP->cop_label, label))
2132 return kid;
2133 }
2134 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2135 if (kid == PL_lastgotoprobe)
2136 continue;
2137 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2138 if (ops == opstack)
2139 *ops++ = kid;
2140 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2141 ops[-1]->op_type == OP_DBSTATE)
2142 ops[-1] = kid;
2143 else
2144 *ops++ = kid;
2145 }
2146 if ((o = dofindlabel(kid, label, ops, oplimit)))
2147 return o;
2148 }
2149 }
2150 *ops = 0;
2151 return 0;
2152}
2153
2154PP(pp_dump)
2155{
2156 return pp_goto();
2157 /*NOTREACHED*/
2158}
2159
2160PP(pp_goto)
2161{
2162 dSP;
2163 OP *retop = 0;
2164 I32 ix;
2165 register PERL_CONTEXT *cx;
2166#define GOTO_DEPTH 64
2167 OP *enterops[GOTO_DEPTH];
2168 const char *label = 0;
2169 const bool do_dump = (PL_op->op_type == OP_DUMP);
2170 static const char must_have_label[] = "goto must have label";
2171
2172 if (PL_op->op_flags & OPf_STACKED) {
2173 SV * const sv = POPs;
2174
2175 /* This egregious kludge implements goto &subroutine */
2176 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2177 I32 cxix;
2178 register PERL_CONTEXT *cx;
2179 CV* cv = (CV*)SvRV(sv);
2180 SV** mark;
2181 I32 items = 0;
2182 I32 oldsave;
2183 bool reified = 0;
2184
2185 retry:
2186 if (!CvROOT(cv) && !CvXSUB(cv)) {
2187 const GV * const gv = CvGV(cv);
2188 if (gv) {
2189 GV *autogv;
2190 SV *tmpstr;
2191 /* autoloaded stub? */
2192 if (cv != GvCV(gv) && (cv = GvCV(gv)))
2193 goto retry;
2194 autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2195 GvNAMELEN(gv), FALSE);
2196 if (autogv && (cv = GvCV(autogv)))
2197 goto retry;
2198 tmpstr = sv_newmortal();
2199 gv_efullname3(tmpstr, (GV *) gv, Nullch);
2200 DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2201 }
2202 DIE(aTHX_ "Goto undefined subroutine");
2203 }
2204
2205 /* First do some returnish stuff. */
2206 (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2207 FREETMPS;
2208 cxix = dopoptosub(cxstack_ix);
2209 if (cxix < 0)
2210 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2211 if (cxix < cxstack_ix)
2212 dounwind(cxix);
2213 TOPBLOCK(cx);
2214 SPAGAIN;
2215 if (CxTYPE(cx) == CXt_EVAL) {
2216 if (CxREALEVAL(cx))
2217 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2218 else
2219 DIE(aTHX_ "Can't goto subroutine from an eval-block");
2220 }
2221 if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2222 /* put @_ back onto stack */
2223 AV* av = cx->blk_sub.argarray;
2224
2225 items = AvFILLp(av) + 1;
2226 EXTEND(SP, items+1); /* @_ could have been extended. */
2227 Copy(AvARRAY(av), SP + 1, items, SV*);
2228#ifndef USE_5005THREADS
2229 SvREFCNT_dec(GvAV(PL_defgv));
2230 GvAV(PL_defgv) = cx->blk_sub.savearray;
2231#endif /* USE_5005THREADS */
2232 CLEAR_ARGARRAY(av);
2233 /* abandon @_ if it got reified */
2234 if (AvREAL(av)) {
2235 reified = 1;
2236 SvREFCNT_dec(av);
2237 av = newAV();
2238 av_extend(av, items-1);
2239 AvFLAGS(av) = AVf_REIFY;
2240 PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2241 }
2242 }
2243 else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
2244#ifdef USE_5005THREADS
2245 AV* const av = (AV*)PAD_SVl(0);
2246#else
2247 AV* const av = GvAV(PL_defgv);
2248#endif
2249 items = AvFILLp(av) + 1;
2250 EXTEND(SP, items+1); /* @_ could have been extended. */
2251 Copy(AvARRAY(av), SP + 1, items, SV*);
2252 }
2253 mark = SP;
2254 SP += items;
2255 if (CxTYPE(cx) == CXt_SUB &&
2256 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2257 SvREFCNT_dec(cx->blk_sub.cv);
2258 oldsave = PL_scopestack[PL_scopestack_ix - 1];
2259 LEAVE_SCOPE(oldsave);
2260
2261 /* Now do some callish stuff. */
2262 SAVETMPS;
2263 SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2264 if (CvXSUB(cv)) {
2265 if (reified) {
2266 I32 index;
2267 for (index=0; index<items; index++)
2268 sv_2mortal(SP[-index]);
2269 }
2270#ifdef PERL_XSUB_OLDSTYLE
2271 if (CvOLDSTYLE(cv)) {
2272 I32 (*fp3)(int,int,int);
2273 while (SP > mark) {
2274 SP[1] = SP[0];
2275 SP--;
2276 }
2277 fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2278 items = (*fp3)(CvXSUBANY(cv).any_i32,
2279 mark - PL_stack_base + 1,
2280 items);
2281 SP = PL_stack_base + items;
2282 }
2283 else
2284#endif /* PERL_XSUB_OLDSTYLE */
2285 {
2286 SV **newsp;
2287 I32 gimme;
2288
2289 /* Push a mark for the start of arglist */
2290 PUSHMARK(mark);
2291 PUTBACK;
2292 (void)(*CvXSUB(cv))(aTHX_ cv);
2293
2294 /* Pop the current context like a decent sub should */
2295 POPBLOCK(cx, PL_curpm);
2296 /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2297
2298 /* Put these at the bottom since the vars are set but not used */
2299 PERL_UNUSED_VAR(newsp);
2300 PERL_UNUSED_VAR(gimme);
2301 }
2302 LEAVE;
2303 return pop_return();
2304 }
2305 else {
2306 AV* padlist = CvPADLIST(cv);
2307 if (CxTYPE(cx) == CXt_EVAL) {
2308 PL_in_eval = cx->blk_eval.old_in_eval;
2309 PL_eval_root = cx->blk_eval.old_eval_root;
2310 cx->cx_type = CXt_SUB;
2311 cx->blk_sub.hasargs = 0;
2312 }
2313 cx->blk_sub.cv = cv;
2314 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2315
2316 CvDEPTH(cv)++;
2317 if (CvDEPTH(cv) < 2)
2318 (void)SvREFCNT_inc(cv);
2319 else {
2320 if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2321 sub_crush_depth(cv);
2322 pad_push(padlist, CvDEPTH(cv), 1);
2323 }
2324#ifdef USE_5005THREADS
2325 if (!cx->blk_sub.hasargs) {
2326 AV* av = (AV*)PAD_SVl(0);
2327
2328 items = AvFILLp(av) + 1;
2329 if (items) {
2330 /* Mark is at the end of the stack. */
2331 EXTEND(SP, items);
2332 Copy(AvARRAY(av), SP + 1, items, SV*);
2333 SP += items;
2334 PUTBACK ;
2335 }
2336 }
2337#endif /* USE_5005THREADS */
2338 SAVECOMPPAD();
2339 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2340#ifndef USE_5005THREADS
2341 if (cx->blk_sub.hasargs)
2342#endif /* USE_5005THREADS */
2343 {
2344 AV* av = (AV*)PAD_SVl(0);
2345 SV** ary;
2346
2347#ifndef USE_5005THREADS
2348 cx->blk_sub.savearray = GvAV(PL_defgv);
2349 GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2350#endif /* USE_5005THREADS */
2351 CX_CURPAD_SAVE(cx->blk_sub);
2352 cx->blk_sub.argarray = av;
2353
2354 if (items >= AvMAX(av) + 1) {
2355 ary = AvALLOC(av);
2356 if (AvARRAY(av) != ary) {
2357 AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2358 SvPV_set(av, (char*)ary);
2359 }
2360 if (items >= AvMAX(av) + 1) {
2361 AvMAX(av) = items - 1;
2362 Renew(ary,items+1,SV*);
2363 AvALLOC(av) = ary;
2364 SvPV_set(av, (char*)ary);
2365 }
2366 }
2367 ++mark;
2368 Copy(mark,AvARRAY(av),items,SV*);
2369 AvFILLp(av) = items - 1;
2370 assert(!AvREAL(av));
2371 if (reified) {
2372 /* transfer 'ownership' of refcnts to new @_ */
2373 AvREAL_on(av);
2374 AvREIFY_off(av);
2375 }
2376 while (items--) {
2377 if (*mark)
2378 SvTEMP_off(*mark);
2379 mark++;
2380 }
2381 }
2382 if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
2383 /*
2384 * We do not care about using sv to call CV;
2385 * it's for informational purposes only.
2386 */
2387 SV * const sv = GvSV(PL_DBsub);
2388 CV *gotocv;
2389
2390 save_item(sv);
2391 if (PERLDB_SUB_NN) {
2392 const int type = SvTYPE(sv);
2393 if (type < SVt_PVIV && type != SVt_IV)
2394 sv_upgrade(sv, SVt_PVIV);
2395 (void)SvIOK_on(sv);
2396 SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2397 } else {
2398 gv_efullname3(sv, CvGV(cv), Nullch);
2399 }
2400 if ( PERLDB_GOTO
2401 && (gotocv = get_cv("DB::goto", FALSE)) ) {
2402 PUSHMARK( PL_stack_sp );
2403 call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2404 PL_stack_sp--;
2405 }
2406 }
2407 RETURNOP(CvSTART(cv));
2408 }
2409 }
2410 else {
2411 label = SvPV_nolen_const(sv);
2412 if (!(do_dump || *label))
2413 DIE(aTHX_ must_have_label);
2414 }
2415 }
2416 else if (PL_op->op_flags & OPf_SPECIAL) {
2417 if (! do_dump)
2418 DIE(aTHX_ must_have_label);
2419 }
2420 else
2421 label = cPVOP->op_pv;
2422
2423 if (label && *label) {
2424 OP *gotoprobe = 0;
2425 bool leaving_eval = FALSE;
2426 bool in_block = FALSE;
2427 PERL_CONTEXT *last_eval_cx = 0;
2428
2429 /* find label */
2430
2431 PL_lastgotoprobe = 0;
2432 *enterops = 0;
2433 for (ix = cxstack_ix; ix >= 0; ix--) {
2434 cx = &cxstack[ix];
2435 switch (CxTYPE(cx)) {
2436 case CXt_EVAL:
2437 leaving_eval = TRUE;
2438 if (!CxTRYBLOCK(cx)) {
2439 gotoprobe = (last_eval_cx ?
2440 last_eval_cx->blk_eval.old_eval_root :
2441 PL_eval_root);
2442 last_eval_cx = cx;
2443 break;
2444 }
2445 /* else fall through */
2446 case CXt_LOOP:
2447 gotoprobe = cx->blk_oldcop->op_sibling;
2448 break;
2449 case CXt_SUBST:
2450 continue;
2451 case CXt_BLOCK:
2452 if (ix) {
2453 gotoprobe = cx->blk_oldcop->op_sibling;
2454 in_block = TRUE;
2455 } else
2456 gotoprobe = PL_main_root;
2457 break;
2458 case CXt_SUB:
2459 if (CvDEPTH(cx->blk_sub.cv)) {
2460 gotoprobe = CvROOT(cx->blk_sub.cv);
2461 break;
2462 }
2463 /* FALL THROUGH */
2464 case CXt_FORMAT:
2465 case CXt_NULL:
2466 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2467 default:
2468 if (ix)
2469 DIE(aTHX_ "panic: goto");
2470 gotoprobe = PL_main_root;
2471 break;
2472 }
2473 if (gotoprobe) {
2474 retop = dofindlabel(gotoprobe, label,
2475 enterops, enterops + GOTO_DEPTH);
2476 if (retop)
2477 break;
2478 }
2479 PL_lastgotoprobe = gotoprobe;
2480 }
2481 if (!retop)
2482 DIE(aTHX_ "Can't find label %s", label);
2483
2484 /* if we're leaving an eval, check before we pop any frames
2485 that we're not going to punt, otherwise the error
2486 won't be caught */
2487
2488 if (leaving_eval && *enterops && enterops[1]) {
2489 I32 i;
2490 for (i = 1; enterops[i]; i++)
2491 if (enterops[i]->op_type == OP_ENTERITER)
2492 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2493 }
2494
2495 /* pop unwanted frames */
2496
2497 if (ix < cxstack_ix) {
2498 I32 oldsave;
2499
2500 if (ix < 0)
2501 ix = 0;
2502 dounwind(ix);
2503 TOPBLOCK(cx);
2504 oldsave = PL_scopestack[PL_scopestack_ix];
2505 LEAVE_SCOPE(oldsave);
2506 }
2507
2508 /* push wanted frames */
2509
2510 if (*enterops && enterops[1]) {
2511 OP *oldop = PL_op;
2512 ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2513 for (; enterops[ix]; ix++) {
2514 PL_op = enterops[ix];
2515 /* Eventually we may want to stack the needed arguments
2516 * for each op. For now, we punt on the hard ones. */
2517 if (PL_op->op_type == OP_ENTERITER)
2518 DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2519 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2520 }
2521 PL_op = oldop;
2522 }
2523 }
2524
2525 if (do_dump) {
2526#ifdef VMS
2527 if (!retop) retop = PL_main_start;
2528#endif
2529 PL_restartop = retop;
2530 PL_do_undump = TRUE;
2531
2532 my_unexec();
2533
2534 PL_restartop = 0; /* hmm, must be GNU unexec().. */
2535 PL_do_undump = FALSE;
2536 }
2537
2538 RETURNOP(retop);
2539}
2540
2541PP(pp_exit)
2542{
2543 dSP;
2544 I32 anum;
2545
2546 if (MAXARG < 1)
2547 anum = 0;
2548 else {
2549 anum = SvIVx(POPs);
2550#ifdef VMS
2551 if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2552 anum = 0;
2553 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2554#endif
2555 }
2556 PL_exit_flags |= PERL_EXIT_EXPECTED;
2557 my_exit(anum);
2558 PUSHs(&PL_sv_undef);
2559 RETURN;
2560}
2561
2562#ifdef NOTYET
2563PP(pp_nswitch)
2564{
2565 dSP;
2566 const NV value = SvNVx(GvSV(cCOP->cop_gv));
2567 register I32 match = I_32(value);
2568
2569 if (value < 0.0) {
2570 if (((NV)match) > value)
2571 --match; /* was fractional--truncate other way */
2572 }
2573 match -= cCOP->uop.scop.scop_offset;
2574 if (match < 0)
2575 match = 0;
2576 else if (match > cCOP->uop.scop.scop_max)
2577 match = cCOP->uop.scop.scop_max;
2578 PL_op = cCOP->uop.scop.scop_next[match];
2579 RETURNOP(PL_op);
2580}
2581
2582PP(pp_cswitch)
2583{
2584 dSP;
2585 register I32 match;
2586
2587 if (PL_multiline)
2588 PL_op = PL_op->op_next; /* can't assume anything */
2589 else {
2590 match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255;
2591 match -= cCOP->uop.scop.scop_offset;
2592 if (match < 0)
2593 match = 0;
2594 else if (match > cCOP->uop.scop.scop_max)
2595 match = cCOP->uop.scop.scop_max;
2596 PL_op = cCOP->uop.scop.scop_next[match];
2597 }
2598 RETURNOP(PL_op);
2599}
2600#endif
2601
2602/* Eval. */
2603
2604STATIC void
2605S_save_lines(pTHX_ AV *array, SV *sv)
2606{
2607 const char *s = SvPVX_const(sv);
2608 const char * const send = SvPVX_const(sv) + SvCUR(sv);
2609 I32 line = 1;
2610
2611 while (s && s < send) {
2612 const char *t;
2613 SV * const tmpstr = NEWSV(85,0);
2614
2615 sv_upgrade(tmpstr, SVt_PVMG);
2616 t = strchr(s, '\n');
2617 if (t)
2618 t++;
2619 else
2620 t = send;
2621
2622 sv_setpvn(tmpstr, s, t - s);
2623 av_store(array, line++, tmpstr);
2624 s = t;
2625 }
2626}
2627
2628#ifdef PERL_FLEXIBLE_EXCEPTIONS
2629STATIC void *
2630S_docatch_body(pTHX_ va_list args)
2631{
2632 return docatch_body();
2633}
2634#endif
2635
2636STATIC void
2637S_docatch_body(pTHX)
2638{
2639 CALLRUNOPS(aTHX);
2640 return;
2641}
2642
2643STATIC OP *
2644S_docatch(pTHX_ OP *o)
2645{
2646 int ret;
2647 OP * const oldop = PL_op;
2648 OP *retop;
2649 volatile PERL_SI *cursi = PL_curstackinfo;
2650 dJMPENV;
2651
2652#ifdef DEBUGGING
2653 assert(CATCH_GET == TRUE);
2654#endif
2655 PL_op = o;
2656
2657 /* Normally, the leavetry at the end of this block of ops will
2658 * pop an op off the return stack and continue there. By setting
2659 * the op to Nullop, we force an exit from the inner runops()
2660 * loop. DAPM.
2661 */
2662 retop = pop_return();
2663 push_return(Nullop);
2664
2665#ifdef PERL_FLEXIBLE_EXCEPTIONS
2666 redo_body:
2667 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2668#else
2669 JMPENV_PUSH(ret);
2670#endif
2671 switch (ret) {
2672 case 0:
2673#ifndef PERL_FLEXIBLE_EXCEPTIONS
2674 redo_body:
2675 docatch_body();
2676#endif
2677 break;
2678 case 3:
2679 /* die caught by an inner eval - continue inner loop */
2680 if (PL_restartop && cursi == PL_curstackinfo) {
2681 PL_op = PL_restartop;
2682 PL_restartop = 0;
2683 goto redo_body;
2684 }
2685 /* a die in this eval - continue in outer loop */
2686 if (!PL_restartop)
2687 break;
2688 /* FALL THROUGH */
2689 default:
2690 JMPENV_POP;
2691 PL_op = oldop;
2692 JMPENV_JUMP(ret);
2693 /* NOTREACHED */
2694 }
2695 JMPENV_POP;
2696 PL_op = oldop;
2697 return retop;
2698}
2699
2700OP *
2701Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2702/* sv Text to convert to OP tree. */
2703/* startop op_free() this to undo. */
2704/* code Short string id of the caller. */
2705{
2706 dSP; /* Make POPBLOCK work. */
2707 PERL_CONTEXT *cx;
2708 SV **newsp;
2709 I32 gimme = G_VOID;
2710 I32 optype;
2711 OP dummy;
2712 OP *rop;
2713 char tbuf[TYPE_DIGITS(long) + 12 + 10];
2714 char *tmpbuf = tbuf;
2715 char *safestr;
2716 int runtime;
2717 CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2718
2719 ENTER;
2720 lex_start(sv);
2721 SAVETMPS;
2722 /* switch to eval mode */
2723
2724 if (IN_PERL_COMPILETIME) {
2725 SAVECOPSTASH_FREE(&PL_compiling);
2726 CopSTASH_set(&PL_compiling, PL_curstash);
2727 }
2728 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2729 SV * const sv = sv_newmortal();
2730 Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2731 code, (unsigned long)++PL_evalseq,
2732 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2733 tmpbuf = SvPVX(sv);
2734 }
2735 else
2736 sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2737 SAVECOPFILE_FREE(&PL_compiling);
2738 CopFILE_set(&PL_compiling, tmpbuf+2);
2739 SAVECOPLINE(&PL_compiling);
2740 CopLINE_set(&PL_compiling, 1);
2741 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2742 deleting the eval's FILEGV from the stash before gv_check() runs
2743 (i.e. before run-time proper). To work around the coredump that
2744 ensues, we always turn GvMULTI_on for any globals that were
2745 introduced within evals. See force_ident(). GSAR 96-10-12 */
2746 safestr = savepv(tmpbuf);
2747 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2748 SAVEHINTS();
2749#ifdef OP_IN_REGISTER
2750 PL_opsave = op;
2751#else
2752 SAVEVPTR(PL_op);
2753#endif
2754
2755 /* we get here either during compilation, or via pp_regcomp at runtime */
2756 runtime = IN_PERL_RUNTIME;
2757 if (runtime)
2758 runcv = find_runcv(NULL);
2759
2760 PL_op = &dummy;
2761 PL_op->op_type = OP_ENTEREVAL;
2762 PL_op->op_flags = 0; /* Avoid uninit warning. */
2763 PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2764 PUSHEVAL(cx, 0, Nullgv);
2765
2766 if (runtime)
2767 rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2768 else
2769 rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2770 POPBLOCK(cx,PL_curpm);
2771 POPEVAL(cx);
2772
2773 (*startop)->op_type = OP_NULL;
2774 (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2775 lex_end();
2776 /* XXX DAPM do this properly one year */
2777 *padp = (AV*)SvREFCNT_inc(PL_comppad);
2778 LEAVE;
2779 if (IN_PERL_COMPILETIME)
2780 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2781#ifdef OP_IN_REGISTER
2782 op = PL_opsave;
2783#endif
2784 PERL_UNUSED_VAR(newsp);
2785 PERL_UNUSED_VAR(optype);
2786
2787 return rop;
2788}
2789
2790
2791/*
2792=for apidoc find_runcv
2793
2794Locate the CV corresponding to the currently executing sub or eval.
2795If db_seqp is non_null, skip CVs that are in the DB package and populate
2796*db_seqp with the cop sequence number at the point that the DB:: code was
2797entered. (allows debuggers to eval in the scope of the breakpoint rather
2798than in the scope of the debugger itself).
2799
2800=cut
2801*/
2802
2803CV*
2804Perl_find_runcv(pTHX_ U32 *db_seqp)
2805{
2806 PERL_SI *si;
2807
2808 if (db_seqp)
2809 *db_seqp = PL_curcop->cop_seq;
2810 for (si = PL_curstackinfo; si; si = si->si_prev) {
2811 I32 ix;
2812 for (ix = si->si_cxix; ix >= 0; ix--) {
2813 const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2814 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2815 CV * const cv = cx->blk_sub.cv;
2816 /* skip DB:: code */
2817 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2818 *db_seqp = cx->blk_oldcop->cop_seq;
2819 continue;
2820 }
2821 return cv;
2822 }
2823 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2824 return PL_compcv;
2825 }
2826 }
2827 return PL_main_cv;
2828}
2829
2830
2831/* Compile a require/do, an eval '', or a /(?{...})/.
2832 * In the last case, startop is non-null, and contains the address of
2833 * a pointer that should be set to the just-compiled code.
2834 * outside is the lexically enclosing CV (if any) that invoked us.
2835 */
2836
2837/* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2838STATIC OP *
2839S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2840{
2841 dSP;
2842 OP * const saveop = PL_op;
2843
2844 PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2845 ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2846 : EVAL_INEVAL);
2847
2848 PUSHMARK(SP);
2849
2850 SAVESPTR(PL_compcv);
2851 PL_compcv = (CV*)NEWSV(1104,0);
2852 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2853 CvEVAL_on(PL_compcv);
2854 assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2855 cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2856
2857#ifdef USE_5005THREADS
2858 CvOWNER(PL_compcv) = 0;
2859 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2860 MUTEX_INIT(CvMUTEXP(PL_compcv));
2861#endif /* USE_5005THREADS */
2862
2863 CvOUTSIDE_SEQ(PL_compcv) = seq;
2864 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2865
2866 /* set up a scratch pad */
2867
2868 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2869
2870
2871 SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2872
2873 /* make sure we compile in the right package */
2874
2875 if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2876 SAVESPTR(PL_curstash);
2877 PL_curstash = CopSTASH(PL_curcop);
2878 }
2879 SAVESPTR(PL_beginav);
2880 PL_beginav = newAV();
2881 SAVEFREESV(PL_beginav);
2882 SAVEI32(PL_error_count);
2883
2884 /* try to compile it */
2885
2886 PL_eval_root = Nullop;
2887 PL_error_count = 0;
2888 PL_curcop = &PL_compiling;
2889 PL_curcop->cop_arybase = 0;
2890 if (saveop && saveop->op_flags & OPf_SPECIAL)
2891 PL_in_eval |= EVAL_KEEPERR;
2892 else
2893 sv_setpvn(ERRSV,"",0);
2894 if (yyparse() || PL_error_count || !PL_eval_root) {
2895 SV **newsp; /* Used by POPBLOCK. */
2896 PERL_CONTEXT *cx;
2897 I32 optype = 0; /* Might be reset by POPEVAL. */
2898 const char *msg;
2899
2900 PL_op = saveop;
2901 if (PL_eval_root) {
2902 op_free(PL_eval_root);
2903 PL_eval_root = Nullop;
2904 }
2905 SP = PL_stack_base + POPMARK; /* pop original mark */
2906 if (!startop) {
2907 POPBLOCK(cx,PL_curpm);
2908 POPEVAL(cx);
2909 pop_return();
2910 }
2911 lex_end();
2912 LEAVE;
2913
2914 msg = SvPVx_nolen_const(ERRSV);
2915 if (optype == OP_REQUIRE) {
2916 const char* const msg = SvPVx_nolen_const(ERRSV);
2917 DIE(aTHX_ "%sCompilation failed in require",
2918 *msg ? msg : "Unknown error\n");
2919 }
2920 else if (startop) {
2921 POPBLOCK(cx,PL_curpm);
2922 POPEVAL(cx);
2923 Perl_croak(aTHX_ "%sCompilation failed in regexp",
2924 (*msg ? msg : "Unknown error\n"));
2925 }
2926 else {
2927 if (!*msg) {
2928 sv_setpv(ERRSV, "Compilation error");
2929 }
2930 }
2931#ifdef USE_5005THREADS
2932 MUTEX_LOCK(&PL_eval_mutex);
2933 PL_eval_owner = 0;
2934 COND_SIGNAL(&PL_eval_cond);
2935 MUTEX_UNLOCK(&PL_eval_mutex);
2936#endif /* USE_5005THREADS */
2937 PERL_UNUSED_VAR(newsp);
2938 RETPUSHUNDEF;
2939 }
2940 CopLINE_set(&PL_compiling, 0);
2941 if (startop) {
2942 *startop = PL_eval_root;
2943 } else
2944 SAVEFREEOP(PL_eval_root);
2945
2946 /* Set the context for this new optree.
2947 * If the last op is an OP_REQUIRE, force scalar context.
2948 * Otherwise, propagate the context from the eval(). */
2949 if (PL_eval_root->op_type == OP_LEAVEEVAL
2950 && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2951 && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2952 == OP_REQUIRE)
2953 scalar(PL_eval_root);
2954 else if (gimme & G_VOID)
2955 scalarvoid(PL_eval_root);
2956 else if (gimme & G_ARRAY)
2957 list(PL_eval_root);
2958 else
2959 scalar(PL_eval_root);
2960
2961 DEBUG_x(dump_eval());
2962
2963 /* Register with debugger: */
2964 if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2965 CV * const cv = get_cv("DB::postponed", FALSE);
2966 if (cv) {
2967 dSP;
2968 PUSHMARK(SP);
2969 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2970 PUTBACK;
2971 call_sv((SV*)cv, G_DISCARD);
2972 }
2973 }
2974
2975 /* compiled okay, so do it */
2976
2977 CvDEPTH(PL_compcv) = 1;
2978 SP = PL_stack_base + POPMARK; /* pop original mark */
2979 PL_op = saveop; /* The caller may need it. */
2980 PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
2981#ifdef USE_5005THREADS
2982 MUTEX_LOCK(&PL_eval_mutex);
2983 PL_eval_owner = 0;
2984 COND_SIGNAL(&PL_eval_cond);
2985 MUTEX_UNLOCK(&PL_eval_mutex);
2986#endif /* USE_5005THREADS */
2987
2988 RETURNOP(PL_eval_start);
2989}
2990
2991STATIC PerlIO *
2992S_check_type_and_open(pTHX_ const char *name, const char *mode)
2993{
2994 Stat_t st;
2995 int st_rc;
2996 st_rc = PerlLIO_stat(name, &st);
2997 if (st_rc < 0) {
2998 return Nullfp;
2999 }
3000
3001 if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3002 Perl_die(aTHX_ "%s %s not allowed in require",
3003 S_ISDIR(st.st_mode) ? "Directory" : "Block device", name);
3004 }
3005 return PerlIO_open(name, mode);
3006}
3007
3008STATIC PerlIO *
3009S_doopen_pm(pTHX_ const char *name, const char *mode)
3010{
3011#ifndef PERL_DISABLE_PMC
3012 const STRLEN namelen = strlen(name);
3013 PerlIO *fp;
3014
3015 if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3016 SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3017 const char * const pmc = SvPV_nolen_const(pmcsv);
3018 Stat_t pmcstat;
3019 if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3020 fp = check_type_and_open(name, mode);
3021 }
3022 else {
3023 Stat_t pmstat;
3024 if (PerlLIO_stat(name, &pmstat) < 0 ||
3025 pmstat.st_mtime < pmcstat.st_mtime)
3026 {
3027 fp = check_type_and_open(pmc, mode);
3028 }
3029 else {
3030 fp = check_type_and_open(name, mode);
3031 }
3032 }
3033 SvREFCNT_dec(pmcsv);
3034 }
3035 else {
3036 fp = check_type_and_open(name, mode);
3037 }
3038 return fp;
3039#else
3040 return check_type_and_open(name, mode);
3041#endif /* !PERL_DISABLE_PMC */
3042}
3043
3044PP(pp_require)
3045{
3046 dSP;
3047 register PERL_CONTEXT *cx;
3048 SV *sv;
3049 const char *name;
3050 STRLEN len;
3051 const char *tryname = Nullch;
3052 SV *namesv = Nullsv;
3053 SV** svp;
3054 const I32 gimme = GIMME_V;
3055 PerlIO *tryrsfp = 0;
3056 int filter_has_file = 0;
3057 GV *filter_child_proc = 0;
3058 SV *filter_state = 0;
3059 SV *filter_sub = 0;
3060 SV *hook_sv = 0;
3061 SV *encoding;
3062 OP *op;
3063
3064 sv = POPs;
3065 if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
3066 if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
3067 UV rev = 0, ver = 0, sver = 0;
3068 STRLEN len;
3069 U8 *s = (U8*)SvPVX(sv);
3070 U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
3071 if (s < end) {
3072 rev = utf8n_to_uvchr(s, end - s, &len, 0);
3073 s += len;
3074 if (s < end) {
3075 ver = utf8n_to_uvchr(s, end - s, &len, 0);
3076 s += len;
3077 if (s < end)
3078 sver = utf8n_to_uvchr(s, end - s, &len, 0);
3079 }
3080 }
3081 if (PERL_REVISION < rev
3082 || (PERL_REVISION == rev
3083 && (PERL_VERSION < ver
3084 || (PERL_VERSION == ver
3085 && PERL_SUBVERSION < sver))))
3086 {
3087 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3088 "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3089 PERL_VERSION, PERL_SUBVERSION);
3090 }
3091 RETPUSHYES;
3092 }
3093 else if (!SvPOKp(sv)) { /* require 5.005_03 */
3094 if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3095 + ((NV)PERL_SUBVERSION/(NV)1000000)
3096 + 0.00000099 < SvNV(sv))
3097 {
3098 NV nrev = SvNV(sv);
3099 UV rev = (UV)nrev;
3100 NV nver = (nrev - rev) * 1000;
3101 UV ver = (UV)(nver + 0.0009);
3102 NV nsver = (nver - ver) * 1000;
3103 UV sver = (UV)(nsver + 0.0009);
3104
3105 /* help out with the "use 5.6" confusion */
3106 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3107 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3108 " (did you mean v%"UVuf".%03"UVuf"?)--"
3109 "this is only v%d.%d.%d, stopped",
3110 rev, ver, sver, rev, ver/100,
3111 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3112 }
3113 else {
3114 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3115 "this is only v%d.%d.%d, stopped",
3116 rev, ver, sver, PERL_REVISION, PERL_VERSION,
3117 PERL_SUBVERSION);
3118 }
3119 }
3120 RETPUSHYES;
3121 }
3122 }
3123 name = SvPV_const(sv, len);
3124 if (!(name && len > 0 && *name))
3125 DIE(aTHX_ "Null filename used");
3126 TAINT_PROPER("require");
3127 if (PL_op->op_type == OP_REQUIRE &&
3128 (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3129 *svp != &PL_sv_undef)
3130 RETPUSHYES;
3131
3132 /* prepare to compile file */
3133
3134 if (path_is_absolute(name)) {
3135 tryname = name;
3136 tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3137 }
3138#ifdef MACOS_TRADITIONAL
3139 if (!tryrsfp) {
3140 char newname[256];
3141
3142 MacPerl_CanonDir(name, newname, 1);
3143 if (path_is_absolute(newname)) {
3144 tryname = newname;
3145 tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3146 }
3147 }
3148#endif
3149 if (!tryrsfp) {
3150 AV * const ar = GvAVn(PL_incgv);
3151 I32 i;
3152#ifdef VMS
3153 char *unixname;
3154 if ((unixname = tounixspec((char *)name, Nullch)) != Nullch)
3155#endif
3156 {
3157 namesv = NEWSV(806, 0);
3158 for (i = 0; i <= AvFILL(ar); i++) {
3159 SV *dirsv = *av_fetch(ar, i, TRUE);
3160
3161 if (SvROK(dirsv)) {
3162 int count;
3163 SV *loader = dirsv;
3164
3165 if (SvTYPE(SvRV(loader)) == SVt_PVAV
3166 && !sv_isobject(loader))
3167 {
3168 loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3169 }
3170
3171 Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3172 PTR2UV(SvRV(dirsv)), name);
3173 tryname = SvPVX_const(namesv);
3174 tryrsfp = 0;
3175
3176 ENTER;
3177 SAVETMPS;
3178 EXTEND(SP, 2);
3179
3180 PUSHMARK(SP);
3181 PUSHs(dirsv);
3182 PUSHs(sv);
3183 PUTBACK;
3184 if (sv_isobject(loader))
3185 count = call_method("INC", G_ARRAY);
3186 else
3187 count = call_sv(loader, G_ARRAY);
3188 SPAGAIN;
3189
3190 if (count > 0) {
3191 int i = 0;
3192 SV *arg;
3193
3194 SP -= count - 1;
3195 arg = SP[i++];
3196
3197 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3198 arg = SvRV(arg);
3199 }
3200
3201 if (SvTYPE(arg) == SVt_PVGV) {
3202 IO *io = GvIO((GV *)arg);
3203
3204 ++filter_has_file;
3205
3206 if (io) {
3207 tryrsfp = IoIFP(io);
3208 if (IoTYPE(io) == IoTYPE_PIPE) {
3209 /* reading from a child process doesn't
3210 nest -- when returning from reading
3211 the inner module, the outer one is
3212 unreadable (closed?) I've tried to
3213 save the gv to manage the lifespan of
3214 the pipe, but this didn't help. XXX */
3215 filter_child_proc = (GV *)arg;
3216 (void)SvREFCNT_inc(filter_child_proc);
3217 }
3218 else {
3219 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3220 PerlIO_close(IoOFP(io));
3221 }
3222 IoIFP(io) = Nullfp;
3223 IoOFP(io) = Nullfp;
3224 }
3225 }
3226
3227 if (i < count) {
3228 arg = SP[i++];
3229 }
3230 }
3231
3232 if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3233 filter_sub = arg;
3234 (void)SvREFCNT_inc(filter_sub);
3235
3236 if (i < count) {
3237 filter_state = SP[i];
3238 (void)SvREFCNT_inc(filter_state);
3239 }
3240
3241 if (tryrsfp == 0) {
3242 tryrsfp = PerlIO_open("/dev/null",
3243 PERL_SCRIPT_MODE);
3244 }
3245 }
3246 SP--;
3247 }
3248
3249 PUTBACK;
3250 FREETMPS;
3251 LEAVE;
3252
3253 if (tryrsfp) {
3254 hook_sv = dirsv;
3255 break;
3256 }
3257
3258 filter_has_file = 0;
3259 if (filter_child_proc) {
3260 SvREFCNT_dec(filter_child_proc);
3261 filter_child_proc = 0;
3262 }
3263 if (filter_state) {
3264 SvREFCNT_dec(filter_state);
3265 filter_state = 0;
3266 }
3267 if (filter_sub) {
3268 SvREFCNT_dec(filter_sub);
3269 filter_sub = 0;
3270 }
3271 }
3272 else {
3273 if (!path_is_absolute(name)
3274#ifdef MACOS_TRADITIONAL
3275 /* We consider paths of the form :a:b ambiguous and interpret them first
3276 as global then as local
3277 */
3278 || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3279#endif
3280 ) {
3281 const char *dir = SvPVx_nolen_const(dirsv);
3282#ifdef MACOS_TRADITIONAL
3283 char buf1[256];
3284 char buf2[256];
3285
3286 MacPerl_CanonDir(name, buf2, 1);
3287 Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3288#else
3289# ifdef VMS
3290 char *unixdir;
3291 if ((unixdir = tounixpath((char *)dir, Nullch)) == Nullch)
3292 continue;
3293 sv_setpv(namesv, unixdir);
3294 sv_catpv(namesv, unixname);
3295# else
3296# ifdef SYMBIAN
3297 if (PL_origfilename[0] &&
3298 PL_origfilename[1] == ':' &&
3299 !(dir[0] && dir[1] == ':'))
3300 Perl_sv_setpvf(aTHX_ namesv,
3301 "%c:%s\\%s",
3302 PL_origfilename[0],
3303 dir, name);
3304 else
3305 Perl_sv_setpvf(aTHX_ namesv,
3306 "%s\\%s",
3307 dir, name);
3308# else
3309 Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3310# endif
3311# endif
3312#endif
3313 TAINT_PROPER("require");
3314 tryname = SvPVX_const(namesv);
3315 tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3316 if (tryrsfp) {
3317 if (tryname[0] == '.' && tryname[1] == '/')
3318 tryname += 2;
3319 break;
3320 }
3321 }
3322 }
3323 }
3324 }
3325 }
3326 SAVECOPFILE_FREE(&PL_compiling);
3327 CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3328 SvREFCNT_dec(namesv);
3329 if (!tryrsfp) {
3330 if (PL_op->op_type == OP_REQUIRE) {
3331 const char *msgstr = name;
3332 if(errno == EMFILE) {
3333 SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3334 sv_catpv(msg, ": ");
3335 sv_catpv(msg, Strerror(errno));
3336 msgstr = SvPV_nolen_const(msg);
3337 } else {
3338 if (namesv) { /* did we lookup @INC? */
3339 SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3340 SV * const dirmsgsv = NEWSV(0, 0);
3341 AV * const ar = GvAVn(PL_incgv);
3342 I32 i;
3343 sv_catpvn(msg, " in @INC", 8);
3344 if (instr(SvPVX_const(msg), ".h "))
3345 sv_catpv(msg, " (change .h to .ph maybe?)");
3346 if (instr(SvPVX_const(msg), ".ph "))
3347 sv_catpv(msg, " (did you run h2ph?)");
3348 sv_catpv(msg, " (@INC contains:");
3349 for (i = 0; i <= AvFILL(ar); i++) {
3350 const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
3351 Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3352 sv_catsv(msg, dirmsgsv);
3353 }
3354 sv_catpvn(msg, ")", 1);
3355 SvREFCNT_dec(dirmsgsv);
3356 msgstr = SvPV_nolen_const(msg);
3357 }
3358 }
3359 DIE(aTHX_ "Can't locate %s", msgstr);
3360 }
3361
3362 RETPUSHUNDEF;
3363 }
3364 else
3365 SETERRNO(0, SS_NORMAL);
3366
3367 /* Assume success here to prevent recursive requirement. */
3368 len = strlen(name);
3369 /* Check whether a hook in @INC has already filled %INC */
3370 if (!hook_sv) {
3371 (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3372 } else {
3373 SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3374 if (!svp)
3375 (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 );
3376 }
3377
3378 ENTER;
3379 SAVETMPS;
3380 lex_start(sv_2mortal(newSVpvn("",0)));
3381 SAVEGENERICSV(PL_rsfp_filters);
3382 PL_rsfp_filters = Nullav;
3383
3384 PL_rsfp = tryrsfp;
3385 SAVEHINTS();
3386 PL_hints = 0;
3387 SAVESPTR(PL_compiling.cop_warnings);
3388 if (PL_dowarn & G_WARN_ALL_ON)
3389 PL_compiling.cop_warnings = pWARN_ALL ;
3390 else if (PL_dowarn & G_WARN_ALL_OFF)
3391 PL_compiling.cop_warnings = pWARN_NONE ;
3392 else if (PL_taint_warn)
3393 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3394 else
3395 PL_compiling.cop_warnings = pWARN_STD ;
3396 SAVESPTR(PL_compiling.cop_io);
3397 PL_compiling.cop_io = Nullsv;
3398
3399 if (filter_sub || filter_child_proc) {
3400 SV * const datasv = filter_add(run_user_filter, Nullsv);
3401 IoLINES(datasv) = filter_has_file;
3402 IoFMT_GV(datasv) = (GV *)filter_child_proc;
3403 IoTOP_GV(datasv) = (GV *)filter_state;
3404 IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3405 }
3406
3407 /* switch to eval mode */
3408 push_return(PL_op->op_next);
3409 PUSHBLOCK(cx, CXt_EVAL, SP);
3410 PUSHEVAL(cx, name, Nullgv);
3411
3412 SAVECOPLINE(&PL_compiling);
3413 CopLINE_set(&PL_compiling, 0);
3414
3415 PUTBACK;
3416#ifdef USE_5005THREADS
3417 MUTEX_LOCK(&PL_eval_mutex);
3418 if (PL_eval_owner && PL_eval_owner != thr)
3419 while (PL_eval_owner)
3420 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3421 PL_eval_owner = thr;
3422 MUTEX_UNLOCK(&PL_eval_mutex);
3423#endif /* USE_5005THREADS */
3424
3425 /* Store and reset encoding. */
3426 encoding = PL_encoding;
3427 PL_encoding = Nullsv;
3428
3429 op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3430
3431 /* Restore encoding. */
3432 PL_encoding = encoding;
3433
3434 return op;
3435}
3436
3437PP(pp_dofile)
3438{
3439 return pp_require();
3440}
3441
3442PP(pp_entereval)
3443{
3444 dSP;
3445 register PERL_CONTEXT *cx;
3446 dPOPss;
3447 const I32 gimme = GIMME_V;
3448 const I32 was = PL_sub_generation;
3449 char tbuf[TYPE_DIGITS(long) + 12];
3450 char *tmpbuf = tbuf;
3451 char *safestr;
3452 STRLEN len;
3453 OP *ret;
3454 CV* runcv;
3455 U32 seq;
3456
3457 if (!SvPV_const(sv,len))
3458 RETPUSHUNDEF;
3459 TAINT_PROPER("eval");
3460
3461 ENTER;
3462 lex_start(sv);
3463 SAVETMPS;
3464
3465 /* switch to eval mode */
3466
3467 if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3468 SV * const sv = sv_newmortal();
3469 Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3470 (unsigned long)++PL_evalseq,
3471 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3472 tmpbuf = SvPVX(sv);
3473 }
3474 else
3475 sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3476 SAVECOPFILE_FREE(&PL_compiling);
3477 CopFILE_set(&PL_compiling, tmpbuf+2);
3478 SAVECOPLINE(&PL_compiling);
3479 CopLINE_set(&PL_compiling, 1);
3480 /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3481 deleting the eval's FILEGV from the stash before gv_check() runs
3482 (i.e. before run-time proper). To work around the coredump that
3483 ensues, we always turn GvMULTI_on for any globals that were
3484 introduced within evals. See force_ident(). GSAR 96-10-12 */
3485 safestr = savepv(tmpbuf);
3486 SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3487 SAVEHINTS();
3488 PL_hints = PL_op->op_targ;
3489 SAVESPTR(PL_compiling.cop_warnings);
3490 if (specialWARN(PL_curcop->cop_warnings))
3491 PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3492 else {
3493 PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3494 SAVEFREESV(PL_compiling.cop_warnings);
3495 }
3496 SAVESPTR(PL_compiling.cop_io);
3497 if (specialCopIO(PL_curcop->cop_io))
3498 PL_compiling.cop_io = PL_curcop->cop_io;
3499 else {
3500 PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3501 SAVEFREESV(PL_compiling.cop_io);
3502 }
3503 /* special case: an eval '' executed within the DB package gets lexically
3504 * placed in the first non-DB CV rather than the current CV - this
3505 * allows the debugger to execute code, find lexicals etc, in the
3506 * scope of the code being debugged. Passing &seq gets find_runcv
3507 * to do the dirty work for us */
3508 runcv = find_runcv(&seq);
3509
3510 push_return(PL_op->op_next);
3511 PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3512 PUSHEVAL(cx, 0, Nullgv);
3513
3514 /* prepare to compile string */
3515
3516 if (PERLDB_LINE && PL_curstash != PL_debstash)
3517 save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3518 PUTBACK;
3519#ifdef USE_5005THREADS
3520 MUTEX_LOCK(&PL_eval_mutex);
3521 if (PL_eval_owner && PL_eval_owner != thr)
3522 while (PL_eval_owner)
3523 COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3524 PL_eval_owner = thr;
3525 MUTEX_UNLOCK(&PL_eval_mutex);
3526#endif /* USE_5005THREADS */
3527 ret = doeval(gimme, NULL, runcv, seq);
3528 if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3529 && ret != PL_op->op_next) { /* Successive compilation. */
3530 strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
3531 }
3532 return DOCATCH(ret);
3533}
3534
3535PP(pp_leaveeval)
3536{
3537 dSP;
3538 register SV **mark;
3539 SV **newsp;
3540 PMOP *newpm;
3541 I32 gimme;
3542 register PERL_CONTEXT *cx;
3543 OP *retop;
3544 const U8 save_flags = PL_op -> op_flags;
3545 I32 optype;
3546
3547 POPBLOCK(cx,newpm);
3548 POPEVAL(cx);
3549 retop = pop_return();
3550
3551 TAINT_NOT;
3552 if (gimme == G_VOID)
3553 MARK = newsp;
3554 else if (gimme == G_SCALAR) {
3555 MARK = newsp + 1;
3556 if (MARK <= SP) {
3557 if (SvFLAGS(TOPs) & SVs_TEMP)
3558 *MARK = TOPs;
3559 else
3560 *MARK = sv_mortalcopy(TOPs);
3561 }
3562 else {
3563 MEXTEND(mark,0);
3564 *MARK = &PL_sv_undef;
3565 }
3566 SP = MARK;
3567 }
3568 else {
3569 /* in case LEAVE wipes old return values */
3570 for (mark = newsp + 1; mark <= SP; mark++) {
3571 if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3572 *mark = sv_mortalcopy(*mark);
3573 TAINT_NOT; /* Each item is independent */
3574 }
3575 }
3576 }
3577 PL_curpm = newpm; /* Don't pop $1 et al till now */
3578
3579#ifdef DEBUGGING
3580 assert(CvDEPTH(PL_compcv) == 1);
3581#endif
3582 CvDEPTH(PL_compcv) = 0;
3583 lex_end();
3584
3585 if (optype == OP_REQUIRE &&
3586 !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3587 {
3588 /* Unassume the success we assumed earlier. */
3589 SV * const nsv = cx->blk_eval.old_namesv;
3590 (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3591 retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3592 /* die_where() did LEAVE, or we won't be here */
3593 }
3594 else {
3595 LEAVE;
3596 if (!(save_flags & OPf_SPECIAL))
3597 sv_setpvn(ERRSV,"",0);
3598 }
3599
3600 RETURNOP(retop);
3601}
3602
3603PP(pp_entertry)
3604{
3605 dSP;
3606 register PERL_CONTEXT *cx;
3607 const I32 gimme = GIMME_V;
3608
3609 ENTER;
3610 SAVETMPS;
3611
3612 push_return(cLOGOP->op_other->op_next);
3613 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3614 PUSHEVAL(cx, 0, 0);
3615
3616 PL_in_eval = EVAL_INEVAL;
3617 sv_setpvn(ERRSV,"",0);
3618 PUTBACK;
3619 return DOCATCH(PL_op->op_next);
3620}
3621
3622PP(pp_leavetry)
3623{
3624 dSP;
3625 register SV **mark;
3626 SV **newsp;
3627 PMOP *newpm;
3628 OP* retop;
3629 I32 gimme;
3630 register PERL_CONTEXT *cx;
3631 I32 optype;
3632
3633 POPBLOCK(cx,newpm);
3634 POPEVAL(cx);
3635 retop = pop_return();
3636 PERL_UNUSED_VAR(optype);
3637
3638 TAINT_NOT;
3639 if (gimme == G_VOID)
3640 SP = newsp;
3641 else if (gimme == G_SCALAR) {
3642 MARK = newsp + 1;
3643 if (MARK <= SP) {
3644 if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3645 *MARK = TOPs;
3646 else
3647 *MARK = sv_mortalcopy(TOPs);
3648 }
3649 else {
3650 MEXTEND(mark,0);
3651 *MARK = &PL_sv_undef;
3652 }
3653 SP = MARK;
3654 }
3655 else {
3656 /* in case LEAVE wipes old return values */
3657 for (mark = newsp + 1; mark <= SP; mark++) {
3658 if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3659 *mark = sv_mortalcopy(*mark);
3660 TAINT_NOT; /* Each item is independent */
3661 }
3662 }
3663 }
3664 PL_curpm = newpm; /* Don't pop $1 et al till now */
3665
3666 LEAVE;
3667 sv_setpvn(ERRSV,"",0);
3668 RETURNOP(retop);
3669}
3670
3671STATIC OP *
3672S_doparseform(pTHX_ SV *sv)
3673{
3674 STRLEN len;
3675 register char *s = SvPV_force(sv, len);
3676 register char *send = s + len;
3677 register char *base = Nullch;
3678 register I32 skipspaces = 0;
3679 bool noblank = FALSE;
3680 bool repeat = FALSE;
3681 bool postspace = FALSE;
3682 U32 *fops;
3683 register U32 *fpc;
3684 U32 *linepc = 0;
3685 register I32 arg;
3686 bool ischop;
3687 bool unchopnum = FALSE;
3688 int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3689
3690 if (len == 0)
3691 Perl_croak(aTHX_ "Null picture in formline");
3692
3693 /* estimate the buffer size needed */
3694 for (base = s; s <= send; s++) {
3695 if (*s == '\n' || *s == '@' || *s == '^')
3696 maxops += 10;
3697 }
3698 s = base;
3699 base = Nullch;
3700
3701 Newx(fops, maxops, U32);
3702 fpc = fops;
3703
3704 if (s < send) {
3705 linepc = fpc;
3706 *fpc++ = FF_LINEMARK;
3707 noblank = repeat = FALSE;
3708 base = s;
3709 }
3710
3711 while (s <= send) {
3712 switch (*s++) {
3713 default:
3714 skipspaces = 0;
3715 continue;
3716
3717 case '~':
3718 if (*s == '~') {
3719 repeat = TRUE;
3720 *s = ' ';
3721 }
3722 noblank = TRUE;
3723 s[-1] = ' ';
3724 /* FALL THROUGH */
3725 case ' ': case '\t':
3726 skipspaces++;
3727 continue;
3728 case 0:
3729 if (s < send) {
3730 skipspaces = 0;
3731 continue;
3732 } /* else FALL THROUGH */
3733 case '\n':
3734 arg = s - base;
3735 skipspaces++;
3736 arg -= skipspaces;
3737 if (arg) {
3738 if (postspace)
3739 *fpc++ = FF_SPACE;
3740 *fpc++ = FF_LITERAL;
3741 *fpc++ = (U16)arg;
3742 }
3743 postspace = FALSE;
3744 if (s <= send)
3745 skipspaces--;
3746 if (skipspaces) {
3747 *fpc++ = FF_SKIP;
3748 *fpc++ = (U16)skipspaces;
3749 }
3750 skipspaces = 0;
3751 if (s <= send)
3752 *fpc++ = FF_NEWLINE;
3753 if (noblank) {
3754 *fpc++ = FF_BLANK;
3755 if (repeat)
3756 arg = fpc - linepc + 1;
3757 else
3758 arg = 0;
3759 *fpc++ = (U16)arg;
3760 }
3761 if (s < send) {
3762 linepc = fpc;
3763 *fpc++ = FF_LINEMARK;
3764 noblank = repeat = FALSE;
3765 base = s;
3766 }
3767 else
3768 s++;
3769 continue;
3770
3771 case '@':
3772 case '^':
3773 ischop = s[-1] == '^';
3774
3775 if (postspace) {
3776 *fpc++ = FF_SPACE;
3777 postspace = FALSE;
3778 }
3779 arg = (s - base) - 1;
3780 if (arg) {
3781 *fpc++ = FF_LITERAL;
3782 *fpc++ = (U16)arg;
3783 }
3784
3785 base = s - 1;
3786 *fpc++ = FF_FETCH;
3787 if (*s == '*') {
3788 s++;
3789 *fpc++ = 2; /* skip the @* or ^* */
3790 if (ischop) {
3791 *fpc++ = FF_LINESNGL;
3792 *fpc++ = FF_CHOP;
3793 } else
3794 *fpc++ = FF_LINEGLOB;
3795 }
3796 else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3797 arg = ischop ? 512 : 0;
3798 base = s - 1;
3799 while (*s == '#')
3800 s++;
3801 if (*s == '.') {
3802 const char * const f = ++s;
3803 while (*s == '#')
3804 s++;
3805 arg |= 256 + (s - f);
3806 }
3807 *fpc++ = s - base; /* fieldsize for FETCH */
3808 *fpc++ = FF_DECIMAL;
3809 *fpc++ = (U16)arg;
3810 unchopnum |= ! ischop;
3811 }
3812 else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
3813 arg = ischop ? 512 : 0;
3814 base = s - 1;
3815 s++; /* skip the '0' first */
3816 while (*s == '#')
3817 s++;
3818 if (*s == '.') {
3819 const char * const f = ++s;
3820 while (*s == '#')
3821 s++;
3822 arg |= 256 + (s - f);
3823 }
3824 *fpc++ = s - base; /* fieldsize for FETCH */
3825 *fpc++ = FF_0DECIMAL;
3826 *fpc++ = (U16)arg;
3827 unchopnum |= ! ischop;
3828 }
3829 else {
3830 I32 prespace = 0;
3831 bool ismore = FALSE;
3832
3833 if (*s == '>') {
3834 while (*++s == '>') ;
3835 prespace = FF_SPACE;
3836 }
3837 else if (*s == '|') {
3838 while (*++s == '|') ;
3839 prespace = FF_HALFSPACE;
3840 postspace = TRUE;
3841 }
3842 else {
3843 if (*s == '<')
3844 while (*++s == '<') ;
3845 postspace = TRUE;
3846 }
3847 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3848 s += 3;
3849 ismore = TRUE;
3850 }
3851 *fpc++ = s - base; /* fieldsize for FETCH */
3852
3853 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3854
3855 if (prespace)
3856 *fpc++ = (U16)prespace;
3857 *fpc++ = FF_ITEM;
3858 if (ismore)
3859 *fpc++ = FF_MORE;
3860 if (ischop)
3861 *fpc++ = FF_CHOP;
3862 }
3863 base = s;
3864 skipspaces = 0;
3865 continue;
3866 }
3867 }
3868 *fpc++ = FF_END;
3869
3870 assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3871 arg = fpc - fops;
3872 { /* need to jump to the next word */
3873 int z;
3874 z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3875 SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3876 s = SvPVX(sv) + SvCUR(sv) + z;
3877 }
3878 Copy(fops, s, arg, U32);
3879 Safefree(fops);
3880 sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3881 SvCOMPILED_on(sv);
3882
3883 if (unchopnum && repeat)
3884 DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3885 return 0;
3886}
3887
3888
3889STATIC bool
3890S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3891{
3892 /* Can value be printed in fldsize chars, using %*.*f ? */
3893 NV pwr = 1;
3894 NV eps = 0.5;
3895 bool res = FALSE;
3896 int intsize = fldsize - (value < 0 ? 1 : 0);
3897
3898 if (frcsize & 256)
3899 intsize--;
3900 frcsize &= 255;
3901 intsize -= frcsize;
3902
3903 while (intsize--) pwr *= 10.0;
3904 while (frcsize--) eps /= 10.0;
3905
3906 if( value >= 0 ){
3907 if (value + eps >= pwr)
3908 res = TRUE;
3909 } else {
3910 if (value - eps <= -pwr)
3911 res = TRUE;
3912 }
3913 return res;
3914}
3915
3916static I32
3917run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3918{
3919 SV *datasv = FILTER_DATA(idx);
3920 const int filter_has_file = IoLINES(datasv);
3921 GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3922 SV *filter_state = (SV *)IoTOP_GV(datasv);
3923 SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3924 int len = 0;
3925
3926 /* I was having segfault trouble under Linux 2.2.5 after a
3927 parse error occured. (Had to hack around it with a test
3928 for PL_error_count == 0.) Solaris doesn't segfault --
3929 not sure where the trouble is yet. XXX */
3930
3931 if (filter_has_file) {
3932 len = FILTER_READ(idx+1, buf_sv, maxlen);
3933 }
3934
3935 if (filter_sub && len >= 0) {
3936 dSP;
3937 int count;
3938
3939 ENTER;
3940 SAVE_DEFSV;
3941 SAVETMPS;
3942 EXTEND(SP, 2);
3943
3944 DEFSV = buf_sv;
3945 PUSHMARK(SP);
3946 PUSHs(sv_2mortal(newSViv(maxlen)));
3947 if (filter_state) {
3948 PUSHs(filter_state);
3949 }
3950 PUTBACK;
3951 count = call_sv(filter_sub, G_SCALAR);
3952 SPAGAIN;
3953
3954 if (count > 0) {
3955 SV *out = POPs;
3956 if (SvOK(out)) {
3957 len = SvIV(out);
3958 }
3959 }
3960
3961 PUTBACK;
3962 FREETMPS;
3963 LEAVE;
3964 }
3965
3966 if (len <= 0) {
3967 IoLINES(datasv) = 0;
3968 if (filter_child_proc) {
3969 SvREFCNT_dec(filter_child_proc);
3970 IoFMT_GV(datasv) = Nullgv;
3971 }
3972 if (filter_state) {
3973 SvREFCNT_dec(filter_state);
3974 IoTOP_GV(datasv) = Nullgv;
3975 }
3976 if (filter_sub) {
3977 SvREFCNT_dec(filter_sub);
3978 IoBOTTOM_GV(datasv) = Nullgv;
3979 }
3980 filter_del(run_user_filter);
3981 }
3982
3983 return len;
3984}
3985
3986/* perhaps someone can come up with a better name for
3987 this? it is not really "absolute", per se ... */
3988static bool
3989S_path_is_absolute(pTHX_ const char *name)
3990{
3991 if (PERL_FILE_IS_ABSOLUTE(name)
3992#ifdef MACOS_TRADITIONAL
3993 || (*name == ':'))
3994#else
3995 || (*name == '.' && (name[1] == '/' ||
3996 (name[1] == '.' && name[2] == '/'))))
3997#endif
3998 {
3999 return TRUE;
4000 }
4001 else
4002 return FALSE;
4003}
4004
4005/*
4006 * Local variables:
4007 * c-indentation-style: bsd
4008 * c-basic-offset: 4
4009 * indent-tabs-mode: t
4010 * End:
4011 *
4012 * ex: set ts=8 sts=4 sw=4 noet:
4013 */
Note: See TracBrowser for help on using the repository browser.