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