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