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