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